does> dup @ swap 1+ @
;
-create-symbol quote quote-symbol
-create-symbol define define-symbol
-create-symbol define-macro define-macro-symbol
-create-symbol set! set!-symbol
-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 quote quote-symbol
+create-symbol quasiquote quasiquote-symbol
+create-symbol unquote unquote-symbol
+create-symbol unquote-splicing unquote-splicing-symbol
+create-symbol define define-symbol
+create-symbol define-macro define-macro-symbol
+create-symbol set! set!-symbol
+create-symbol ok ok-symbol
+create-symbol if if-symbol
+create-symbol lambda lambda-symbol
+create-symbol λ λ-symbol
+create-symbol begin begin-symbol
\ }}}
quote-symbol recurse nil cons cons exit
then
+ nextchar [char] ` = if
+ inc-parse-idx
+ quasiquote-symbol recurse nil cons cons exit
+ then
+
+ nextchar [char] , = if
+ inc-parse-idx
+ nextchar [char] @ = if
+ inc-parse-idx
+ unquote-splicing-symbol recurse nil cons cons exit
+ else
+ unquote-symbol recurse nil cons cons exit
+ then
+ then
+
eof? if
EOF character-type
inc-parse-idx
: make-lambda ( params body -- lambda-exp )
lambda-symbol -2rot cons cons ;
-( Handles recursive expansion of defines in
+( Handles iterative expansion of defines in
terms of nested lambdas. Most Schemes only
- handle one level of expansion! )
-: (definition-var-val) ( val var -- val' var' )
- symbol-type istype? if 2swap car 2swap exit then
+ handle one iteration of expansion! )
+: definition-var-val ( obj -- var val )
- 2dup cdr 2swap car
- symbol-type istype? if
- 2swap ( body procname procargs )
- 2rot ( procname procargs body )
- make-lambda ( procname lambda-exp )
- 2swap
- exit
- then
+ cdr 2dup cdr 2swap car ( val var )
- ( body procargs nextval )
- -2rot 2swap ( nextval procargs body )
- make-lambda nil cons ( nextval lambda-exp )
- 2swap ( lambda-exp nextval )
- recurse
-;
+ 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-val ( obj -- var val )
- cdr 2dup cdr 2swap car
- (definition-var-val)
- 2swap
+ 2swap car
;
-: assignment? ( obj -- obj bool )
- set!-symbol tagged-list? ;
-
-: assignment-var ( obj -- var )
- cdr car ;
-
-: assignment-val ( obj -- val )
- cdr cdr car ;
-
: eval-definition ( obj env -- res )
2dup 2rot ( env env obj )
definition-var-val ( env env var val )
ok-symbol
;
+
+: assignment? ( obj -- obj bool )
+ set!-symbol tagged-list? ;
+
+: assignment-var ( obj -- var )
+ cdr car ;
+: assignment-val ( obj -- val )
+ cdr cdr car ;
+
: eval-assignment ( obj env -- res )
2swap
2over 2over ( env obj env obj )
( env exp env opname mproc )
2swap 2drop -2rot 2drop cdr ( env mproc body )
- 2dup print cr
macro-expand
- 2dup print cr
2swap
['] eval goto-deferred