From: Tim Vaughan Date: Sun, 6 Nov 2016 00:12:59 +0000 (+1300) Subject: Implemented let as macro. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=55761030cc43072bbc8b2d1ef5a053fc64a6a3ec;p=scheme.forth.jl.git Implemented let as macro. --- diff --git a/scheme-library.scm b/scheme-library.scm index 1a68a10..5ee0b49 100644 --- a/scheme-library.scm +++ b/scheme-library.scm @@ -7,6 +7,12 @@ (define (null? args) (eq? args ())) +(define (caar l) (car (car l))) +(define (cadr l) (car (cdr l))) +(define (cdar l) (cdr (car l))) +(define (cddr l) (cdr (cdr l))) +(define (cadar l) (car (cdr (car l)))) + ; Join two lists together (define (join l1 l2) (if (null? l1) @@ -29,12 +35,32 @@ ;; LIBRARY FORMS + +; let + +(define (let-vars args) + (if (null? args) + '() + (cons (caar args) (let-vars (cdr args))))) + +(define (let-inits args) + (if (null? args) + '() + (cons (cadar args) (let-inits (cdr args))))) + +(define-macro (let args . body) + `((lambda ,(let-vars args) + ,@body) ,@(let-inits args))) + +; while + (define-macro (while condition . body) + (define loop (gensym)) `(begin - (define (loop) + (define (,loop) (if ,condition - (begin ,@body (loop)))) - (loop))) + (begin ,@body (,loop)))) + (,loop))) ;; TESTING diff --git a/scheme-primitives.4th b/scheme-primitives.4th index 86fbbd9..38fe2e0 100644 --- a/scheme-primitives.4th +++ b/scheme-primitives.4th @@ -1,4 +1,4 @@ -( ==== Type predicates ==== ) +\ ==== Type predicates ==== {{{ :noname ( args -- boolobj ) 2dup 1 ensure-arg-count @@ -48,7 +48,9 @@ car primitive-proc-type istype? -rot 2drop boolean-type ; make-primitive procedure? -( ==== Type conversions ==== ) +\ }}} + +\ ==== Type conversions ==== {{{ :noname ( args -- fixnum ) 2dup 1 ensure-arg-count @@ -153,7 +155,9 @@ charlist>symbol ; make-primitive string->symbol -( ==== Arithmetic ==== ) +\ }}} + +\ ==== Arithmetic ==== {{{ : add-prim ( args -- fixnum ) 2dup nil objeq? if @@ -284,7 +288,9 @@ variable relcfa hide relcfa -( ==== Pairs and Lists ==== ) +\ }}} + +\ ==== Pairs and Lists ==== {{{ :noname ( args -- pair ) 2dup 2 ensure-arg-count @@ -297,21 +303,21 @@ hide relcfa \ args is already a list! ; make-primitive list -:noname ( args -- pair ) +:noname ( args -- obj ) 2dup 1 ensure-arg-count car pair-type ensure-arg-type car ; make-primitive car -:noname ( args -- pair ) +:noname ( args -- obj ) 2dup 1 ensure-arg-count car pair-type ensure-arg-type cdr ; make-primitive cdr -:noname ( args -- pair ) +:noname ( args -- ok ) 2dup 2 ensure-arg-count 2dup cdr car 2swap car pair-type ensure-arg-type @@ -321,7 +327,7 @@ hide relcfa ok-symbol ; make-primitive set-car! -:noname ( args -- pair ) +:noname ( args -- ok ) 2dup 2 ensure-arg-count 2dup cdr car 2swap car pair-type ensure-arg-type @@ -331,7 +337,9 @@ hide relcfa ok-symbol ; make-primitive set-cdr! -( ==== Polymorphic equality testing ==== ) +\ }}} + +\ ==== Polymorphic equality testing ==== {{{ :noname ( args -- bool ) 2dup 2 ensure-arg-count @@ -341,7 +349,9 @@ hide relcfa objeq? boolean-type ; make-primitive eq? -( ==== Input/Output ==== ) +\ }}} + +\ ==== Input/Output ==== {{{ :noname ( args -- finalResult ) 2dup 1 ensure-arg-count @@ -434,7 +444,9 @@ defer display none ; make-primitive newline -( ==== Evaluation ==== ) +\ }}} + +\ ==== Evaluation ==== {{{ :noname ( args -- result ) 2dup car 2swap cdr @@ -444,8 +456,11 @@ defer display apply ; make-primitive apply -( ==== Error System ==== ) +\ }}} + +\ ==== Miscellaneous ==== {{{ +( Produce a recoverable exception. ) :noname ( args -- result ) bold fg red @@ -459,3 +474,15 @@ defer display recoverable-exception throw ; make-primitive error + +( Generate a temporary unique symbol. Used in the creation of hygienic macros. ) +:noname ( args -- result ) + 0 ensure-arg-count + + [char] _ character-type nil cons + drop symbol-type +; make-primitive gensym + +\ }}} + +\ vim:fdm=marker diff --git a/scheme.4th b/scheme.4th index 95c621a..f8dd089 100644 --- a/scheme.4th +++ b/scheme.4th @@ -139,11 +139,6 @@ variable nextfree cdr-cells + ! ; -: caar car car ; -: cadr cdr car ; -: cdar car cdr ; -: cddr cdr cdr ; - : nil 0 nil-type ; : nil? nil-type istype? ; @@ -1058,7 +1053,7 @@ parse-idx-stack parse-idx-sp ! quote-symbol tagged-list? ; : quote-body ( quote-obj -- quote-body-obj ) - cadr ; + cdr car ; : quasiquote? ( obj -- obj bool ) quasiquote-symbol tagged-list? ;