include debugging.4th
defer read
+defer expand
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
: 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 )
extend-env eval-sequence eval
;
-defer expand
-
-: expand-quasiquote ;
-: expand-define-macro ;
-: expand-if ;
-: expand-lambda ;
-: expand-application ;
-
: expand-macro ( exp -- result )
pair-type istype? invert if exit then
2dup car symbol-type istype? invert if 2drop exit 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
cons cons cons ;
-: expand-sequence ( exp -- res )
+: expand-list ( exp -- res )
nil? if exit then
2dup car expand
cons ;
-: expand-begin ( exp -- res )
- begin-symbol 2swap
- begin-actions expand-sequence
+: macro-definition-nameparams
+ cdr car ;
- cons ;
+: 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-sequence
+ 2swap lambda-body expand-list
cons cons ;
-:noname ( exp -- result )
+: 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-begin exit then
+ if? if expand-if exit then
application? if expand-application exit then
include scheme-primitives.4th
- s" scheme-derived-forms.scm" load 2drop
-
-\ s" scheme-library.scm" load 2drop
+ s" scheme-library.scm" load 2drop
\ }}}
enable-gc
\ Display welcome message
- \ welcome-symbol nil cons global-env obj@ eval 2drop
+ welcome-symbol nil cons global-env obj@ eval 2drop
begin
['] repl-body catch