objvar symbol-table
: duplicate-charlist ( charlist -- copy )
- 2dup nil objeq? false = if
+ nil? false = if
2dup car 2swap cdr recurse cons
then ;
: get-vars-vals ( var env -- vars? vals? bool )
begin
- 2dup nil objeq? false =
+ nil? false =
while
2over 2over first-frame
get-vars-vals-frame if
objvar macro-table
-: lookup-macro ( name_symbol -- proc? bool )
+( Look up macro in macro table. Returns nil if
+ no macro is found. )
+: lookup-macro ( name_symbol -- proc )
macro-table obj@
begin
car car objeq? if
2swap 2drop
car cdr
- true exit
+ exit
then
+
+ cdr
repeat
- 2drop false
+ 2swap 2drop
;
: make-macro ( name_symbol params body env -- )
set-cdr!
exit
then
+
+ cdr
repeat
2drop
: macro-definition? ( obj -- obj bool )
define-macro-symbol tagged-list? ;
+: macro-definition-name ( exp -- mname )
+ cdr car car ;
+
+: macro-definition-params ( exp -- params )
+ cdr car cdr ;
+
+: macro-definition-body ( exp -- body )
+ cdr cdr ;
+
+objvar env
+: eval-define-macro ( obj env -- res )
+ env obj!
+
+ 2dup macro-definition-name 2swap ( name obj )
+ 2dup macro-definition-params 2swap ( name params obj )
+ macro-definition-body ( name params body )
+
+ env obj@ ( name params body env )
+
+ make-macro
+
+ ok-symbol
+;
+hide env
+
: if? ( obj -- obj bool )
if-symbol tagged-list? ;
: if-alternative ( ifobj -- alt|false )
cdr cdr cdr
- 2dup nil objeq? if
+ nil? if
2drop false
else
car
2swap ( env explist )
\ Abort on empty list
- 2dup nil objeq? if
+ nil? if
2drop none
2swap exit
then
begin
2dup cdr ( env explist nextexplist )
- 2dup nil objeq? false =
+ nil? false =
while
-2rot car 2over ( nextexplist env exp env )
eval
application? if
- 2over 2over
- operator
+ 2over 2over ( env exp env exp )
+ operator 2dup ( env exp env opname opname )
- find-macro-proc nil objeq? if
+ lookup-macro nil? if
\ Regular function application
- 2swap eval
- -2rot
- operands 2swap list-of-vals
+ 2drop ( env exp env opname )
+
+ 2swap eval ( env exp proc )
+ -2rot ( proc env exp )
+ operands 2swap ( proc operands env )
+ list-of-vals ( proc argvals )
apply
else
\ Macro function evaluation
- 2swap 2drop 2swap ( env mproc exp )
+ ." Macro eval"
- apply 2swap ( expanded-exp env )
+ ( env exp env opname mproc )
+ 2swap 2drop -2rot 2drop cdr ( env mproc body )
- ['] eval goto-deferred
+ \ TODO: evaluate macro procedure on expression body
+ ." ABORTED: Macros not yet fully implemented!" abort
then
exit
then
arg-count-error
then
else
- -rot 2dup nil objeq? if
+ -rot nil? if
arg-count-error
then
dup 2swap ( origaddr addr charlist )
begin
- 2dup nil objeq? false =
+ nil? false =
while
2dup cdr 2swap car
drop ( origaddr addr charlist char )