make-type character-type
make-type string-type
make-type nil-type
+make-type none-type
make-type pair-type
make-type symbol-type
make-type primitive-proc-type
: nil 0 nil-type ;
: nil? nil-type istype? ;
+: none 0 none-type ;
+: none? none-type istype? ;
+
: objvar create nil swap , , ;
: value@ ( objvar -- val ) @ ;
character-type istype? if true exit then
string-type istype? if true exit then
nil-type istype? if true exit then
+ none-type istype? if true exit then
false
;
2swap ( env explist )
\ Abort on empty list
- 2dup nil objeq? if 2swap exit then
+ 2dup nil objeq? if
+ 2drop none
+ 2swap exit
+ then
begin
2dup cdr ( env explist nextexplist )
: procedure-env ( proc -- body )
drop pair-type cdr cdr car ;
-: apply ( proc args )
+( Ensure terminating symbol arg name is handled
+ specially to allow for variadic procedures. )
+: flatten-proc-args ( argvals argnames -- argvals' argnames' )
+ nil? if exit then
+
+ symbol-type istype? if
+ nil cons
+ 2swap
+ nil cons
+ 2swap
+ exit
+ then
+
+ 2over cdr 2over cdr
+ recurse ( argvals argnames argvals'' argnames'' )
+ 2rot car 2swap cons ( argvals argvals'' argnames' )
+ 2rot car 2rot cons ( argnames' argvals' )
+ 2swap
+;
+
+: apply ( proc argvals )
2swap dup case
primitive-proc-type of
drop execute
endof
compound-proc-type of
- 2dup procedure-body ( args proc body )
- -2rot 2dup procedure-params ( body args proc params )
- -2rot procedure-env ( body params args procenv )
+ 2dup procedure-body ( argvals proc body )
+ -2rot 2dup procedure-params ( body argvals proc argnames )
+ -2rot procedure-env ( body argnames argvals procenv )
+
+ -2rot 2swap
+ flatten-proc-args
+ 2swap 2rot
extend-env ( body env )
then
begin? if
- \ TODO
+ begin-actions 2swap
+ eval-sequence
+ ['] eval goto-deferred
then
application? if
: printcomp ( primobj -- )
2drop ." <compound procedure>" ;
+: printnone ( noneobj -- )
+ 2drop ." Unspecified return value" ;
+
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
realnum-type istype? if printrealnum exit then
pair-type istype? if ." (" printpair ." )" exit then
primitive-proc-type istype? if printprim exit then
compound-proc-type istype? if printcomp exit then
+ none-type istype? if printnone exit then
bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
abort
read-console
2dup EOF character-type objeq? if
+ 2drop
bold fg blue ." Moriturus te saluto." reset-term cr
exit
then