include debugging.4th
defer read
+defer expand
+defer analyze
defer eval
defer print
create-symbol if if-symbol
create-symbol lambda lambda-symbol
create-symbol λ λ-symbol
-create-symbol begin begin-symbol
create-symbol eof eof-symbol
+create-symbol no-match no-match-symbol
\ Symbol to be bound to welcome message procedure by library
create-symbol welcome welcome-symbol
: definition? ( obj -- obj bool )
define-symbol tagged-list? ;
-: make-lambda ( params body -- lambda-exp )
- lambda-symbol -2rot cons cons ;
-
-( Handles iterative expansion of defines in
- terms of nested lambdas. Most Schemes only
- handle one iteration of expansion! )
-: definition-var-val ( obj -- var val )
-
- cdr 2dup cdr 2swap car ( val var )
-
- 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 ( obj -- var )
+ cdr car ;
- 2swap car
-;
+: definition-val ( obj -- val )
+ cdr cdr car ;
: eval-definition ( obj env -- res )
- 2dup 2rot ( env env obj )
- definition-var-val ( env env var val )
- 2rot eval ( env var val )
+ 2swap
+ 2over 2over
+ definition-val 2swap
+ eval
- 2rot ( var val env )
+ 2swap definition-var 2swap
+
+ 2rot
define-var
ok-symbol
: lambda-body ( obj -- body )
cdr cdr ;
-: begin? ( obj -- obj bool )
- begin-symbol tagged-list? ;
-
-: begin-actions ( obj -- actions )
- cdr ;
-
: eval-sequence ( explist env -- finalexp env )
( Evaluates all bar the final expressions in
an an expression list. The final expression
exit
then
- begin? if
- begin-actions 2swap
- eval-sequence
- ['] eval goto-deferred
- then
-
application? if
2over 2over ( env exp env exp )
\ }}}
+\ ---- Analyze ----
+
+: evaluate-eproc ( env eproc --- res )
+ begin
+ nil? invert
+ while
+ 2dup car
+ 2swap cdr
+ repeat
+
+ 2drop \ get rid of null
+
+ \ Final element of eproc list is primitive procedure
+ drop \ dump type signifier
+ R> drop >body >R \ GOTO primitive procedure (executor)
+;
+
+: self-evaluating-executor ( env exp -- exp )
+ 2swap 2drop ;
+
+: analyze-self-evaluating ( exp --- eproc )
+ ['] self-evaluating-executor primitive-proc-type
+ nil cons cons
+;
+
+: quote-executor ( env exp -- exp )
+ 2swap 2drop ;
+
+: analyze-quoted ( exp -- eproc )
+ quote-body
+
+ ['] quote-executor primitive-proc-type
+ nil cons cons
+;
+
+: variable-executor ( env var -- val )
+ 2swap lookup-var ;
+
+: analyze-variable ( exp -- eproc )
+ ['] variable-executor primitive-proc-type
+ nil cons cons
+;
+
+: assignment-executor ( env var val-eproc -- ok )
+ 2rot 2dup 2rot ( var env env val-eproc )
+ evaluate-eproc 2swap ( var val env )
+ set-var
+ ok-symbol ;
+
+: analyze-assignment ( exp -- eproc )
+ 2dup assignment-var
+ 2swap assignment-val analyze ( var val-eproc )
+
+ ['] assignment-executor primitive-proc-type
+ nil cons cons cons
+;
+
+:noname ( exp --- eproc )
+
+ self-evaluating? if
+ analyze-self-evaluating
+ exit
+ then
+
+ quote? if
+ analyze-quoted
+ exit
+ then
+
+ variable? if
+ analyze-variable
+ exit
+ then
+
+ assignment? if
+ analyze-assignment
+ exit
+ then
+
+; is analyze
+
+
\ ---- Macro Expansion ---- {{{
( Simply evaluates the given procedure with expbody as its argument. )
extend-env eval-sequence eval
;
-: expand-quasiquote ;
-: expand-definition ;
-: expand-assignment ;
-: expand-define-macro ;
-: expand-if ;
-: expand-lambda ;
-: expand-begin ;
-: expand-application ;
+: expand-macro ( exp -- result )
+ pair-type istype? invert if exit then
+ 2dup car symbol-type istype? invert if 2drop exit then
+
+ lookup-macro nil? if
+ 2drop exit then
+
+ 2over cdr macro-eval
+
+ 2dup no-match-symbol objeq? if
+ 2drop exit
+ else
+ 2swap 2drop
+ then
+
+ R> drop ['] expand goto-deferred
+;
+
+: expand-quasiquote-item ( exp -- result )
+ nil? if exit then
+
+ unquote? if
+ unquote-symbol 2swap cdr car expand nil cons cons
+ exit
+ then
+
+ unquote-splicing? if
+ unquote-splicing-symbol 2swap cdr car expand nil cons cons
+ exit
+ then
+
+ pair-type istype? if
+ 2dup car recurse
+ 2swap cdr recurse
+ cons
+ then
+;
+
+: expand-quasiquote ( exp -- result )
+ quasiquote-symbol 2swap cdr
+
+ expand-quasiquote-item
+
+ cons ;
+
+: expand-definition ( exp -- result )
+ define-symbol 2swap
+
+ 2dup definition-var
+ 2swap definition-val expand
+ nil ( define var val' nil )
+
+ cons cons cons ;
+
+: expand-assignment ( exp -- result )
+ set!-symbol 2swap
+
+ 2dup assignment-var
+ 2swap assignment-val expand
+ nil ( define var val' nil )
+
+ cons cons cons ;
+
+: expand-list ( exp -- res )
+ nil? if exit then
+
+ 2dup car expand
+ 2swap cdr recurse
+
+ cons ;
+
+: macro-definition-nameparams
+ cdr car ;
+
+: expand-define-macro ( exp -- res )
+ define-macro-symbol 2swap
+ 2dup macro-definition-nameparams
+ 2swap macro-definition-body expand-list
+
+ cons cons ;
+
+: expand-lambda ( exp -- res )
+ lambda-symbol 2swap
+ 2dup lambda-parameters
+ 2swap lambda-body expand-list
+
+ cons cons ;
+
+: expand-if ( exp -- res )
+ if-symbol 2swap
+
+ 2dup if-predicate expand
+ 2swap 2dup if-consequent expand
+ 2swap if-alternative none? if
+ 2drop nil
+ else
+ expand nil cons
+ then
+
+ cons cons cons ;
+
+: expand-application ( exp -- res )
+ 2dup operator expand
+ 2swap operands expand-list
+
+ cons ;
:noname ( exp -- result )
+ expand-macro
+
+ self-evaluating? if exit then
+
+ quote? if exit then
quasiquote? if expand-quasiquote exit then
macro-definition? if expand-define-macro exit then
- if? if expand-if exit then
-
lambda? if expand-lambda exit then
- begin? if expand-sequence exit then
+ if? if expand-if exit then
- application? if expand-apply exit then
+ application? if expand-application exit then
; is expand
include scheme-primitives.4th
-\ s" scheme-library.scm" load 2drop
+ \ s" scheme-library.scm" load 2drop
\ }}}