cdr-cells + !
;
-: caar car car ;
-: cadr cdr car ;
-: cdar car cdr ;
-: cddr cdr cdr ;
-
: nil 0 nil-type ;
: nil? nil-type istype? ;
quote-symbol tagged-list? ;
: quote-body ( quote-obj -- quote-body-obj )
- cadr ;
+ cdr car ;
+
+: quasiquote? ( obj -- obj bool )
+ quasiquote-symbol tagged-list? ;
+
+: unquote? ( obj -- obj bool )
+ unquote-symbol tagged-list? ;
+
+: unquote-splicing? ( obj -- obj bool )
+ unquote-splicing-symbol tagged-list? ;
+
+: eval-unquote ( env obj -- res )
+ cdr ( env args )
+
+ nil? if
+ recoverable-exception throw" no arguments to unquote."
+ then
+
+ 2dup cdr
+ nil? false = if
+ recoverable-exception throw" too many arguments to unquote."
+ then
+
+ 2drop car 2swap eval
+;
+
+( Create a new list from elements of l1 consed on to l2 )
+: join-lists ( l2 l1 -- l3 )
+ nil? if 2drop exit then
+
+ 2dup car
+ -2rot cdr
+ recurse cons
+;
+
+defer eval-quasiquote-item
+: eval-quasiquote-pair ( env obj -- res )
+ 2over 2over ( env obj env obj )
+
+ cdr eval-quasiquote-item
+
+ -2rot car ( cdritem env objcar )
+
+ unquote-splicing? if
+ eval-unquote ( cdritems caritem )
+
+ 2swap nil? if
+ 2drop
+ else
+ 2swap join-lists
+ then
+ else
+ eval-quasiquote-item ( cdritems caritem )
+ 2swap cons
+ then
+
+;
+
+:noname ( env obj )
+ nil? if
+ 2swap 2drop exit
+ then
+
+ unquote? if
+ eval-unquote exit
+ then
+
+ pair-type istype? if
+ eval-quasiquote-pair exit
+ then
+
+ 2swap 2drop
+; is eval-quasiquote-item
+
+: eval-quasiquote ( obj env -- res )
+ 2swap cdr ( env args )
+
+ nil? if
+ recoverable-exception throw" no arguments to quasiquote."
+ then
+
+ 2dup cdr ( env args args-cdr )
+ nil? false = if
+ recoverable-exception throw" too many arguments to quasiquote."
+ then
+
+ 2drop car ( env arg )
+
+ eval-quasiquote-item
+;
: variable? ( obj -- obj bool )
symbol-type istype? ;
: if-consequent ( ifobj -- conseq )
cdr cdr car ;
-: if-alternative ( ifobj -- alt|false )
+: if-alternative ( ifobj -- alt|none )
cdr cdr cdr
nil? if
- 2drop false
+ 2drop none
else
car
then ;
endcase
;
+( Simply evaluates the given procedure with expbody as its argument. )
: macro-expand ( proc expbody -- result )
2swap
2dup procedure-body ( expbody proc procbody )
exit
then
+ quasiquote? if
+ 2swap eval-quasiquote
+ exit
+ then
+
variable? if
2swap lookup-var
exit
: printnone ( noneobj -- )
2drop ." Unspecified return value" ;
+: printport ( port -- )
+ 2drop ." <port>" ;
+
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
realnum-type istype? if printrealnum exit then