; 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: ; : 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 ,(car (cdr l))) (__unilambda ,(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 ,(car (cdr (car (car args))))) (__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 ,first) (__unilambda (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 (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 )) (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))