;
-: cstr>charlist ( addr n -- symbol-obj )
+: cstr>charlist ( addr n -- charlist )
dup 0= if
2drop nil
else
count
cstr>charlist
- drop symbol-type
-
- 2dup
-
- symbol-table obj@
- cons
- symbol-table obj!
+ charlist>symbol
create swap , ,
does> dup @ swap 1+ @
nil nil nil extend-env
global-env obj!
+\ }}}
+
+\ ---- Primitives ---- {{{
+
+: make-primitive ( cfa -- )
+ bl word
+ count
+
+ \ 2dup ." Defining primitive " type ." ..." cr
+
+ cstr>charlist
+ charlist>symbol
+
+ rot primitive-proc-type ( var prim )
+ global-env obj@ define-var
+;
+
+: arg-count-error
+ bold fg red ." Incorrect argument count." reset-term cr
+ abort
+;
+
+: ensure-arg-count ( args n -- )
+ dup 0= if
+ drop nil objeq? false = if
+ arg-count-error
+ then
+ else
+ -rot nil? if
+ arg-count-error
+ then
+
+ cdr rot 1- recurse
+ then
+;
+
+: arg-type-error
+ bold fg red ." Incorrect argument type." reset-term cr
+ abort
+;
+
+: ensure-arg-type ( arg type -- arg )
+ istype? false = if
+ arg-type-error
+ then
+;
+
+
\ }}}
\ ---- Macros ---- {{{
2swap
;
+:noname
+ \ Dummy apply procedure
+ \ Should never actually run!
+ ." Error: Dummy apply procedure executed!" cr
+; dup make-primitive apply
+objvar dummy-apply-proc
+primitive-proc-type dummy-apply-proc obj!
+
: apply ( proc argvals -- result )
2swap dup case
primitive-proc-type of
- drop execute
+ drop execute
endof
compound-proc-type of
application? if
2over 2over ( env exp env exp )
- operator 2dup ( env exp env opname opname )
-
- lookup-macro nil? if
- \ Regular function application
-
- 2drop ( env exp env opname )
+ operator ( 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
+ 2dup lookup-macro nil? false = if
+ \ Macro function evaluation
( env exp env opname mproc )
2swap 2drop -2rot 2drop cdr ( env mproc body )
2swap
['] eval goto-deferred
then
+
+ \ Regular function application
+
+ 2drop ( env exp env opname )
+
+ 2swap eval ( env exp proc )
+
+ 2dup dummy-apply-proc obj@ objeq? if
+ 2drop ( env exp )
+ cdr 2over 2over car ( env expbody env real-opname )
+ 2swap eval ( env expbody proc )
+
+ 2swap cdr
+ nil? false = if car then ( env proc real-operand )
+
+ 2rot eval ( proc argvals )
+
+ pair-type istype? false = if
+ bold fg red ." Error: apply requires a list of operand arguments." cr
+ reset-term abort
+ then
+
+ apply
+ exit
+ then
+
+ -2rot ( proc env exp )
+ operands 2swap ( proc operands env )
+ list-of-vals ( proc argvals )
+
+ apply
exit
then
\ }}}
-\ ---- Primitives ---- {{{
-
-: make-primitive ( cfa -- )
- bl word
- count
-
- \ 2dup ." Defining primitive " type ." ..." cr
-
- cstr>charlist
- drop symbol-type
-
- 2dup
-
- symbol-table obj@
- cons
- symbol-table obj!
-
- rot primitive-proc-type ( var prim )
- global-env obj@ define-var
-;
-
-: arg-count-error
- bold fg red ." Incorrect argument count." reset-term cr
- abort
-;
-
-: ensure-arg-count ( args n -- )
- dup 0= if
- drop nil objeq? false = if
- arg-count-error
- then
- else
- -rot nil? if
- arg-count-error
- then
-
- cdr rot 1- recurse
- then
-;
-
-: arg-type-error
- bold fg red ." Incorrect argument type." reset-term cr
- abort
-;
-
-: ensure-arg-type ( arg type -- arg )
- istype? false = if
- arg-type-error
- then
-;
-
-include scheme-primitives.4th
-
-\ }}}
-
\ ---- Standard Library ---- {{{
+ include scheme-primitives.4th
+
s" scheme-library.scm" load 2drop
\ }}}