Tested by adding macro definition of procedural form of define.
Actually works for defining higher order functions too! For free!
--- /dev/null
+;; 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))
create-symbol λ λ-symbol
create-symbol begin begin-symbol
create-symbol eof eof-symbol
create-symbol λ λ-symbol
create-symbol begin begin-symbol
create-symbol eof eof-symbol
+create-symbol no-match no-match-symbol
\ Symbol to be bound to welcome message procedure by library
create-symbol welcome welcome-symbol
\ Symbol to be bound to welcome message procedure by library
create-symbol welcome welcome-symbol
: definition? ( obj -- obj bool )
define-symbol tagged-list? ;
: definition? ( obj -- obj bool )
define-symbol tagged-list? ;
-: make-lambda ( params body -- lambda-exp )
- lambda-symbol -2rot cons cons ;
-
-( Handles iterative expansion of defines in
- terms of nested lambdas. Most Schemes only
- handle one iteration of expansion! )
-: definition-var-val ( obj -- var val )
-
- cdr 2dup cdr 2swap car ( val var )
-
- begin
- symbol-type istype? false =
- while
- 2dup cdr 2swap car ( val formals var' )
- -2rot 2swap ( var' formals val )
- make-lambda nil cons ( var' val' )
- 2swap ( val' var' )
- repeat
+: definition-var ( obj -- var )
+ cdr car ;
+: definition-val ( obj -- val )
+ cdr cdr car ;
: eval-definition ( obj env -- res )
: eval-definition ( obj env -- res )
- 2dup 2rot ( env env obj )
- definition-var-val ( env env var val )
- 2rot eval ( env var val )
+ 2swap
+ 2over 2over
+ definition-val 2swap
+ eval
+ 2swap definition-var 2swap
+
+ 2rot
extend-env eval-sequence eval
;
extend-env eval-sequence eval
;
: expand-quasiquote ;
: expand-definition ;
: expand-assignment ;
: expand-quasiquote ;
: expand-definition ;
: expand-assignment ;
: expand-begin ;
: expand-application ;
: expand-begin ;
: expand-application ;
+: expand-macro ( exp -- result )
+ pair-type istype? invert if exit then
+ 2dup car symbol-type istype? invert if 2drop exit then
+
+ lookup-macro nil? if
+ 2drop exit then
+
+ 2over cdr macro-eval
+
+ 2dup no-match-symbol objeq? if
+ 2drop exit
+ else
+ 2swap 2drop
+ then
+
+ R> drop ['] expand goto-deferred
+;
+
:noname ( exp -- result )
:noname ( exp -- result )
quasiquote? if expand-quasiquote exit then
definition? if expand-definition exit then
quasiquote? if expand-quasiquote exit then
definition? if expand-definition exit then
lambda? if expand-lambda exit then
lambda? if expand-lambda exit then
- begin? if expand-sequence exit then
+ begin? if expand-begin exit then
- application? if expand-apply exit then
+ application? if expand-application exit then
include scheme-primitives.4th
include scheme-primitives.4th
+ s" scheme-derived-forms.scm" load 2drop
+
\ s" scheme-library.scm" load 2drop
\ }}}
\ s" scheme-library.scm" load 2drop
\ }}}