From 724ff46a1b082bef48b310a85d5a82037c2a914c Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Mon, 19 Jun 2017 21:32:43 +1200 Subject: [PATCH] Macro expansion working properly. begin is now a library form too. --- src/scheme-derived-forms.scm | 14 -- src/scheme-library.scm | 239 ++++++++++++++++++----------------- src/scheme.4th | 44 ++----- 3 files changed, 135 insertions(+), 162 deletions(-) delete mode 100644 src/scheme-derived-forms.scm diff --git a/src/scheme-derived-forms.scm b/src/scheme-derived-forms.scm deleted file mode 100644 index 010519d..0000000 --- a/src/scheme-derived-forms.scm +++ /dev/null @@ -1,14 +0,0 @@ -;; define (procedural syntax) - -; Due to recursive macro expansion, this definition also allows -; for curried function definitions. - -(define-macro (define args . body) - (if (pair? args) - `(define ,(car args) (lambda ,(cdr args) ,@body)) - 'no-match)) - -;; Macro expansion test code - -(define-macro (test) - '(begin (display "Hello!") (newline))) diff --git a/src/scheme-library.scm b/src/scheme-library.scm index a420c70..67ab483 100644 --- a/src/scheme-library.scm +++ b/src/scheme-library.scm @@ -1,26 +1,127 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Standard Library Procedures and Macros ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; DERIVED FORMS -;; MISC +;; define (procedural syntax) + +(define-macro (define args . body) + (if (pair? args) + `(define ,(car args) (lambda ,(cdr args) ,@body)) + 'no-match)) + +;; begin + +(define-macro (begin . sequence) + `((lambda () ,@sequence))) + +;; caddr etc. + +(define-macro (caar l) `(car (car ,l))) +(define-macro (cadr l) `(car (cdr ,l))) +(define-macro (cdar l) `(cdr (car ,l))) +(define-macro (cddr l) `(cdr (cdr ,l))) +(define-macro (caaar l) `(car (car (car ,l)))) +(define-macro (caadr l) `(car (car (cdr ,l)))) +(define-macro (cadar l) `(car (cdr (car ,l)))) +(define-macro (caddr l) `(car (cdr (cdr ,l)))) +(define-macro (cdaar l) `(cdr (car (car ,l)))) +(define-macro (cdadr l) `(cdr (car (cdr ,l)))) +(define-macro (cddar l) `(cdr (cdr (car ,l)))) +(define-macro (cdddr l) `(cdr (cdr (cdr ,l)))) +(define-macro (cadddr l) `(car (cdr (cdr (cdr ,l))))) + + +;; Methods used in remaining macro definitions: + +(define (map proc l) + (if (null? l) + '() + (cons (proc (car l)) (map proc (cdr l))))) + +;; let + +(define-macro (let args . body) + `((lambda ,(map (lambda (x) (car x)) args) + ,@body) ,@(map (lambda (x) (cadr x)) args))) + +;; let* + +(define-macro (let* args . body) + (if (null? args) + `(let () ,@body) + `(let (,(car args)) + (let* ,(cdr args) ,@body)))) + +;; while + +(define-macro (while condition . body) + (let ((loop (gensym))) + `(begin + (define (,loop) + (if ,condition + (begin ,@body (,loop)))) + (,loop)))) + +;; cond + +((lambda () + (define (cond-predicate clause) (car clause)) + (define (cond-actions clause) (cdr clause)) + (define (cond-else-clause? clause) + (eq? (cond-predicate clause) 'else)) + + (define (expand-clauses clauses) + (if (null? clauses) + (none) + (let ((first (car clauses)) + (rest (cdr clauses))) + (if (cond-else-clause? first) + (if (null? rest) + `(begin ,@(cond-actions first)) + (error "else clause isn't last in cond expression.")) + `(if ,(cond-predicate first) + (begin ,@(cond-actions first)) + ,(expand-clauses rest)))))) -(define (not x) (if x #f #t)) + (define-macro (cond . clauses) + (if (null? clauses) + (error "cond requires at least one clause.") + (expand-clauses clauses))))) + +;; and + +((lambda () + (define (expand-and-expressions expressions) + (let ((first (car expressions)) + (rest (cdr expressions))) + (if (null? rest) + first + `(if ,first + ,(expand-and-expressions rest) + #f)))) -(define (list . args) args) + (define-macro (and . expressions) + (if (null? expressions) + #t + (expand-and-expressions expressions))) + )) + +;; or + +((lambda () + (define (expand-or-expressions expressions) + (if (null? expressions) + #f + (let ((first (car expressions)) + (rest (cdr expressions)) + (val (gensym))) + `(let ((,val ,first)) + (if ,val + ,val + ,(expand-or-expressions rest)))))) + + (define-macro (or . expressions) + (expand-or-expressions expressions)) + )) -(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 (caaar l) (car (car (car l)))) -(define (caadr l) (car (car (cdr l)))) -(define (cadar l) (car (cdr (car l)))) -(define (caddr l) (car (cdr (cdr l)))) -(define (cdaar l) (cdr (car (car l)))) -(define (cdadr l) (cdr (car (cdr l)))) -(define (cddar l) (cdr (cdr (car l)))) -(define (cdddr l) (cdr (cdr (cdr l)))) -(define (cadddr l) (car (cdr (cdr (cdr l))))) ;; FUNCTIONAL PROGRAMMING @@ -36,10 +137,6 @@ (car l) (fold-left proc (proc (car l) (car (cdr l))) (cdr (cdr l)))))) -(define (map proc l) - (if (null? l) - '() - (cons (proc (car l)) (map proc (cdr l))))) ;; NUMBERS @@ -214,6 +311,7 @@ (if (flonum? x) #t (if (ratnum? x) #t #f)))) + ;; LISTS ; Return number of items in list @@ -245,101 +343,8 @@ (append (reverse (cdr l)) (list (car l))))) -;; LIBRARY SPECIAL FORMS - -; let - -(define-macro (let args . body) - `((lambda ,(map (lambda (x) (car x)) args) - ,@body) ,@(map (lambda (x) (cadr x)) args))) - -; let* - -(define-macro (let* args . body) - (if (null? args) - `(let () ,@body) - `(let (,(car args)) - (let* ,(cdr args) ,@body)))) - -; while - -(define-macro (while condition . body) - (let ((loop (gensym))) - `(begin - (define (,loop) - (if ,condition - (begin ,@body (,loop)))) - (,loop)))) - -; cond - -((lambda () - (define (cond-predicate clause) (car clause)) - (define (cond-actions clause) (cdr clause)) - (define (cond-else-clause? clause) - (eq? (cond-predicate clause) 'else)) - - (define (expand-clauses clauses) - (if (null? clauses) - (none) - (let ((first (car clauses)) - (rest (cdr clauses))) - (if (cond-else-clause? first) - (if (null? rest) - `(begin ,@(cond-actions first)) - (error "else clause isn't last in cond expression.")) - `(if ,(cond-predicate first) - (begin ,@(cond-actions first)) - ,(expand-clauses rest)))))) - - (define-macro (cond . clauses) - (if (null? clauses) - (error "cond requires at least one clause.") - (expand-clauses clauses))) - )) - -; and - -((lambda () - (define (expand-and-expressions expressions) - (let ((first (car expressions)) - (rest (cdr expressions))) - (if (null? rest) - first - `(if ,first - ,(expand-and-expressions rest) - #f)))) - - (define-macro (and . expressions) - (if (null? expressions) - #t - (expand-and-expressions expressions))) - )) - -; or - -((lambda () - (define (expand-or-expressions expressions) - (if (null? expressions) - #f - (let ((first (car expressions)) - (rest (cdr expressions)) - (val (gensym))) - `(let ((,val ,first)) - (if ,val - ,val - ,(expand-or-expressions rest)))))) - - (define-macro (or . expressions) - (expand-or-expressions expressions)) - )) - - ;; TESTING -(define-macro (backwards . body) - (cons 'begin (reverse body))) - ; Test for the while macro. (define (count) (define counter 10) @@ -365,6 +370,8 @@ 0 (fix:+ n (sum-recurse (fix:- n 1))))) + + ;; MISC (define (license) diff --git a/src/scheme.4th b/src/scheme.4th index 9b5eb27..ec97f09 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -10,6 +10,7 @@ include float.4th include debugging.4th defer read +defer expand defer eval defer print @@ -261,7 +262,6 @@ create-symbol ok ok-symbol create-symbol if if-symbol create-symbol lambda lambda-symbol create-symbol λ λ-symbol -create-symbol begin begin-symbol create-symbol eof eof-symbol create-symbol no-match no-match-symbol @@ -1512,12 +1512,6 @@ hide env : lambda-body ( obj -- body ) cdr cdr ; -: begin? ( obj -- obj bool ) - begin-symbol tagged-list? ; - -: begin-actions ( obj -- actions ) - cdr ; - : eval-sequence ( explist env -- finalexp env ) ( Evaluates all bar the final expressions in an an expression list. The final expression @@ -1712,12 +1706,6 @@ hide env exit then - begin? if - begin-actions 2swap - eval-sequence - ['] eval goto-deferred - then - application? if 2over 2over ( env exp env exp ) @@ -1754,8 +1742,6 @@ hide env extend-env eval-sequence eval ; -defer expand - : expand-macro ( exp -- result ) pair-type istype? invert if exit then 2dup car symbol-type istype? invert if 2drop exit then @@ -1778,11 +1764,16 @@ defer expand nil? if exit then unquote? if - unquote-symbol 2swap cdr expand nil cons cons + unquote-symbol 2swap cdr car expand nil cons cons + exit + then + + unquote-splicing? if + unquote-splicing-symbol 2swap cdr car expand nil cons cons exit then - pair? if + pair-type istype? if 2dup car recurse 2swap cdr recurse cons @@ -1847,25 +1838,18 @@ defer expand 2swap if-alternative none? if 2drop nil else - nil cons + expand nil cons then cons cons cons ; -: expand-begin ( exp -- res ) - begin-symbol 2swap - begin-actions expand-list - - cons ; - : expand-application ( exp -- res ) - 2dup operator + 2dup operator expand 2swap operands expand-list cons ; :noname ( exp -- result ) - expand-macro self-evaluating? if exit then @@ -1884,8 +1868,6 @@ defer expand if? if expand-if exit then - begin? if expand-begin exit then - application? if expand-application exit then ; is expand @@ -2128,9 +2110,7 @@ variable gc-stack-depth include scheme-primitives.4th - s" scheme-derived-forms.scm" load 2drop - -\ s" scheme-library.scm" load 2drop + s" scheme-library.scm" load 2drop \ }}} @@ -2163,7 +2143,7 @@ variable gc-stack-depth enable-gc \ Display welcome message - \ welcome-symbol nil cons global-env obj@ eval 2drop + welcome-symbol nil cons global-env obj@ eval 2drop begin ['] repl-body catch -- 2.20.1