252 lines
6.2 KiB
Scheme
252 lines
6.2 KiB
Scheme
; Copyright (c) 2024, Peter McGoron
|
|
;
|
|
; Redistribution and use in source and binary forms, with or without
|
|
; modification, are permitted provided that the following conditions
|
|
; are met:
|
|
;
|
|
; 1) Redistributions of source code must retain the above copyright
|
|
; notice, this list of conditions and the following disclaimer.
|
|
; 2) Redistributions in binary form must reproduce the above copyright
|
|
; notice, this list of conditions and the following disclaimer in the
|
|
; documentation and/or other materials provided with the distribution.
|
|
;
|
|
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
|
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
|
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
|
; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
|
; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
|
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
|
|
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
|
|
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
|
|
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
|
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
; Primitives are special syntatic forms. They differ from built-in
|
|
; functions.
|
|
;
|
|
; primitives:
|
|
; __unilambda: lambda of one argument
|
|
; __define: define in the environment
|
|
; __define-macro: Like __define but for macros
|
|
; set!
|
|
; __exec: apply an argument to a lambda and return it to the continuation.
|
|
;
|
|
; Others:
|
|
; <undefined>: A value that can only be passed to __unilambda. It cannot
|
|
; be bound to a top-level, or "set!", or added to a list.
|
|
; It can also be the parameter of a __unilambda, although
|
|
; it still cannot be used.
|
|
;
|
|
; Macros are functions that return an sexpr.
|
|
|
|
; (define (__exec function argument continuation)
|
|
; (continuation (function argument))
|
|
; )
|
|
|
|
; __continuation-if runs the first continuation if the argument is true,
|
|
; and the second if the argument is false.
|
|
(__define-macro if
|
|
(__unilambda l
|
|
`(__continue-if ,(car l)
|
|
(__unilambda <undefined> ,(car (cdr l)))
|
|
(__unilambda <undefined> ,(car (cdr (cdr l))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(__define-macro let
|
|
(__unilambda l ; car = args, cdr = body
|
|
(if (null? (car args))
|
|
(cdr args)
|
|
; (car args) = ((A a) (B b) ...)
|
|
; (car (car args)) = (A a)
|
|
; (cdr (car (car args))) = (a)
|
|
`(__exec (__unilambda <undefined> ,(car (cdr (car (car args)))))
|
|
<undefined>
|
|
(__unilambda ,(car (car (car args)))
|
|
(let ,(cdr (car args)) ,@body)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(__define-macro let* let)
|
|
|
|
; if and __unilambda only execute one statement.
|
|
(__define-macro begin body
|
|
(let ((first (car body))
|
|
(rest (cdr body))
|
|
)
|
|
(if (null? rest)
|
|
first
|
|
`(__exec (__unilambda <undefined> ,first)
|
|
<undefined>
|
|
(__unilambda <undefined> (begin ,@rest))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(__define-macro __bindlambda
|
|
(__unilambda l
|
|
(let ((larg (car l))
|
|
(args (car (cdr l)))
|
|
(body (cdr (cdr l)))
|
|
)
|
|
(if (null? args)
|
|
`(__unilambda larg
|
|
(if (not (null? larg))
|
|
(raise "incorrect number of arguments")
|
|
(begin ,@body)
|
|
)
|
|
)
|
|
(if (symbol? args)
|
|
`(__unilambda ,args ,@body)
|
|
(let* ((argval (cons args))
|
|
(rest (cdr args))
|
|
(arg (cons argval))
|
|
(val (cons (cdr argval)))
|
|
)
|
|
`(__unilambda ,larg
|
|
(let ((,arg ,val)) __bindlambda ,larg ,rest ,@body)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(__define-macro lambda
|
|
(__unilambda l
|
|
(let ((args (car l))
|
|
(body (cdr l))
|
|
)
|
|
(if (symbol? args)
|
|
`(__unilambda ,args ,@body)
|
|
(if (null? args)
|
|
`(__unilambda <undefined> (begin ,@body))
|
|
(let ((larg (gensym)))
|
|
`(__bindlambda ,larg ,@body)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(__define-macro define-macro
|
|
(lambda (name-and-args . body)
|
|
(let ((name (car name-and-args))
|
|
(args (cdr name-and-args))
|
|
(tmpname (gensym))
|
|
)
|
|
`(__define-macro ,name
|
|
(lambda ,args ,@body)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-macro (and . body)
|
|
(if (null? body)
|
|
1
|
|
(let ((first (car body))
|
|
(rest (cdr body))
|
|
)
|
|
`(if ,first (and ,@rest) 0)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-macro (or . body)
|
|
(if (null? body)
|
|
0
|
|
(let ((first (car body))
|
|
(rest (cdr body))
|
|
)
|
|
`(if ,first 1 (or ,@rest))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-macro (letrec args . body)
|
|
(if (null? args)
|
|
body
|
|
(let* ((argval (car args))
|
|
(arg (car argval))
|
|
(val (car (cdr argval)))
|
|
(rest (cdr args))
|
|
)
|
|
`(let ((,arg <undefined>))
|
|
(letrec ,rest (begin (set! ,arg ,val) ,@body))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define-macro (define name . body)
|
|
(if (symbol? name)
|
|
`(__define ,name ,@body)
|
|
(let ((fname (car name))
|
|
(args (cdr name))
|
|
(tmparg (gensym))
|
|
)
|
|
`(__define ,fname
|
|
(lambda ,tmparg
|
|
(letrec ((,fname (lambda ,args ,@body)))
|
|
(,fname . ,tmparg)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;; Standard Library ;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (call-with-current-continuation f)
|
|
(f (current-continuation))
|
|
)
|
|
(define call/cc call-with-current-continuation)
|
|
|
|
;; for a list of (v1 v2 ... vn)
|
|
;; runs (f vn (... (f v2 (f v1 start))))
|
|
(define (foldl f start l)
|
|
(letrec
|
|
((loop
|
|
(lambda (ret-list cur-list)
|
|
(if (eqv? value '())
|
|
value
|
|
(loop (f (car cur-list) value)
|
|
(cdr cur-list))
|
|
)
|
|
)
|
|
))
|
|
(loop start l)
|
|
)
|
|
)
|
|
|
|
(define (reverse l) (foldl cons '() l))
|
|
|
|
;; for a list of (v1 v2 ... vn)
|
|
;; runs (f v1 (f v2 (... (f vn start))))
|
|
(define (foldr f start l) (foldl f start (reverse l)))
|
|
|
|
(define (append . l)
|
|
(foldr (lambda (to-prepend collected)
|
|
(foldr cons collected to-prepend)
|
|
)
|
|
'()
|
|
l
|
|
)
|
|
)
|
|
|
|
(define (apply f . l) (__uniapply f (__uniapply append l)))
|
|
(define (list . l) l)
|
|
|
|
;; (define (+ . l) (foldl __bin+ 0 l))
|
|
;; (define (* . l) (foldl __bin* 1 l))
|