+ recurse
+
+ cons
+;
+
+: readsymbol ( -- charlist )
+ delim? if nil exit then
+
+ nextchar inc-parse-idx character-type
+
+ recurse
+
+ cons
+;
+
+: readpair ( -- pairobj )
+ eatspaces
+
+ \ Empty lists
+ nextchar [char] ) = if
+ inc-parse-idx
+
+ delim? false = if
+ bold fg red
+ ." No delimiter following right paren. Aborting." cr
+ reset-term abort
+ then
+
+ dec-parse-idx
+
+ 0 nil-type exit
+ then
+
+ \ Read first pair element
+ read
+
+ \ Pairs
+ eatspaces
+ nextchar [char] . = if
+ inc-parse-idx
+
+ delim? false = if
+ bold fg red
+ ." No delimiter following '.'. Aborting." cr
+ reset-term abort
+ then
+
+ eatspaces read
+ else
+ recurse
+ then
+
+ eatspaces
+
+ cons
+;
+
+\ Parse a scheme expression
+:noname ( -- obj )
+
+ eatspaces
+
+ fixnum? if
+ readfixnum
+ exit
+ then
+
+ realnum? if
+ readrealnum
+ exit
+ then
+
+ boolean? if
+ readbool
+ exit
+ then
+
+ character? if
+ readchar
+ exit
+ then
+
+ string? if
+ inc-parse-idx
+
+ readstring
+ drop string-type
+
+ nextchar [char] " <> if
+ bold red ." Missing closing double-quote." reset-term cr
+ abort
+ then
+
+ inc-parse-idx
+
+ exit
+ then
+
+ pair? if
+ inc-parse-idx
+
+ eatspaces
+
+ readpair
+
+ eatspaces
+
+ nextchar [char] ) <> if
+ bold red ." Missing closing paren." reset-term cr
+ abort
+ then
+
+ inc-parse-idx
+
+ exit
+ then
+
+ nextchar [char] ' = if
+ inc-parse-idx
+ quote-symbol recurse nil cons cons exit
+ then
+
+ nextchar [char] ` = if
+ inc-parse-idx
+ quasiquote-symbol recurse nil cons cons exit
+ then
+
+ nextchar [char] , = if
+ inc-parse-idx
+ nextchar [char] @ = if
+ inc-parse-idx
+ unquote-splicing-symbol recurse nil cons cons exit
+ else
+ unquote-symbol recurse nil cons cons exit
+ then
+ then
+
+ eof? if
+ EOF character-type
+ inc-parse-idx
+ exit
+ then
+
+ \ Anything else is parsed as a symbol
+ readsymbol charlist>symbol
+
+ \ Replace λ with lambda
+ 2dup λ-symbol objeq? if
+ 2drop lambda-symbol
+ then
+
+
+; is read
+
+\ }}}
+
+\ ---- Eval ---- {{{
+
+: self-evaluating? ( obj -- obj bool )
+ boolean-type istype? if true exit then
+ fixnum-type istype? if true exit then
+ realnum-type istype? if true exit then
+ 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
+;
+
+: tagged-list? ( obj tag-obj -- obj bool )
+ 2over
+ pair-type istype? false = if
+ 2drop 2drop false
+ else
+ car objeq?
+ then ;
+
+: quote? ( obj -- obj bool )
+ quote-symbol tagged-list? ;
+
+: quote-body ( quote-obj -- quote-body-obj )
+ cadr ;
+
+: quasiquote? ( obj -- obj bool )
+ quasiquote-symbol tagged-list? ;
+
+: unquote? ( obj -- obj bool )
+ unquote-symbol tagged-list?
+;
+
+: eval-unquote ( env obj -- res )
+ cdr ( env args )
+
+ nil? if
+ recoverable-exception throw" no arguments to unquote."
+ then
+
+ 2dup cdr
+ nil? false = if
+ recoverable-exception throw" too many arguments to unquote."
+ then
+
+ 2drop car 2swap eval
+;
+
+defer eval-quasiquote-item
+: eval-quasiquote-list ( env obj -- res )
+ nil? if
+ 2swap 2drop exit
+ then
+
+ 2over 2over ( env obj env obj )
+
+ car eval-quasiquote-item ( env obj caritem )
+
+ -2rot cdr recurse ( caritem cdritems )
+ cons
+;
+
+:noname ( env obj )
+ unquote? if
+ eval-unquote exit
+ then
+
+ pair-type istype? if
+ eval-quasiquote-list exit
+ then
+
+ 2swap 2drop
+; is eval-quasiquote-item
+
+: eval-quasiquote ( obj env -- res )
+ 2swap cdr ( env args )
+
+ nil? if
+ recoverable-exception throw" no arguments to quasiquote."
+ then
+
+ 2dup cdr ( env args args-cdr )
+ nil? false = if
+ recoverable-exception throw" too many arguments to quasiquote."
+ then
+
+ 2drop car ( env arg )
+
+ eval-quasiquote-item
+;
+
+: variable? ( obj -- obj bool )
+ symbol-type istype? ;
+
+: 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
+
+ 2swap car
+;
+
+: eval-definition ( obj env -- res )
+ 2dup 2rot ( env env obj )
+ definition-var-val ( env env var val )
+ 2rot eval ( env var val )
+
+ 2rot ( var val env )
+ define-var
+
+ ok-symbol
+;
+
+: assignment? ( obj -- obj bool )
+ set!-symbol tagged-list? ;