+: character? ( -- bool )
+ nextchar [char] # <> if false exit then
+
+ push-parse-idx
+ inc-parse-idx
+
+ nextchar [char] \ <> if pop-parse-idx false exit then
+
+ inc-parse-idx
+
+ S" newline" str-equiv? if pop-parse-idx true exit then
+ S" space" str-equiv? if pop-parse-idx true exit then
+ S" tab" str-equiv? if pop-parse-idx true exit then
+
+ charavailable? false = if pop-parse-idx false exit then
+
+ pop-parse-idx true
+;
+
+: pair? ( -- bool )
+ nextchar [char] ( = ;
+
+: string? ( -- bool )
+ nextchar [char] " = ;
+
+: readfixnum ( -- num-atom )
+ plus? minus? or if
+ minus?
+ inc-parse-idx
+ else
+ false
+ then
+
+ 0
+
+ begin digit? while
+ 10 * nextchar [char] 0 - +
+ inc-parse-idx
+ repeat
+
+ swap if negate then
+
+ fixnum-type
+;
+
+: readrealnum ( -- realnum )
+
+ \ Remember that at this point we're guaranteed to
+ \ have a parsable real on this line.
+
+ parse-str parse-idx @ +
+
+ begin delim? false = while
+ inc-parse-idx
+ repeat
+
+ parse-str parse-idx @ + over -
+
+ float-parse
+
+ realnum-type
+;
+
+: readbool ( -- bool-obj )
+ inc-parse-idx
+
+ nextchar [char] f = if
+ false
+ else
+ true
+ then
+
+ inc-parse-idx
+
+ boolean-type
+;
+
+: readchar ( -- char-obj )
+ inc-parse-idx
+ inc-parse-idx
+
+ S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
+ S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
+ S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
+
+ nextchar character-type
+
+ inc-parse-idx
+;
+
+: readstring ( -- charlist )
+ nextchar [char] " = if
+ inc-parse-idx
+
+ delim? false = if
+ bold fg red
+ ." No delimiter following right double quote. Aborting." cr
+ reset-term abort
+ then
+
+ dec-parse-idx
+
+ 0 nil-type exit
+ then
+
+ nextchar [char] \ = if
+ inc-parse-idx
+ nextchar case
+ [char] n of '\n' endof
+ [char] " of [char] " endof
+ [char] \
+ endcase
+ else
+ nextchar
+ then
+ inc-parse-idx character-type
+
+ 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? ;
+
+: unquote-splicing? ( obj -- obj bool )
+ unquote-splicing-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
+;
+
+( Create a new list from elements of l1 consed on to l2 )
+: join-lists ( l2 l1 -- l3 )
+ nil? if 2drop exit then
+
+ 2dup car
+ -2rot cdr
+ recurse cons
+;
+
+defer eval-quasiquote-item
+: eval-quasiquote-list ( env obj -- res )
+ nil? if
+ 2swap 2drop exit
+ then
+
+ 2over 2over ( env obj env obj )
+
+ cdr recurse
+ -2rot car ( cdritems env objcar )
+
+ unquote-splicing? if
+ eval-unquote ( cdritems caritem )
+
+ 2swap nil? if
+ 2drop
+ else
+ 2swap join-lists
+ then
+ else
+ eval-quasiquote-item ( cdritems caritem )
+ 2swap cons
+ then
+
+;
+
+: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? ;
+
+: assignment-var ( obj -- var )
+ cdr car ;
+
+: assignment-val ( obj -- val )
+ cdr cdr car ;
+
+: eval-assignment ( obj env -- res )
+ 2swap
+ 2over 2over ( env obj env obj )
+ assignment-val 2swap ( env obj valexp env )
+ eval ( env obj val )
+
+ 2swap assignment-var 2swap ( env var val )
+
+ 2rot ( var val env )
+ set-var
+
+ ok-symbol
+;
+
+: macro-definition? ( obj -- obj bool )
+ define-macro-symbol tagged-list? ;
+
+: macro-definition-name ( exp -- mname )
+ cdr car car ;
+
+: macro-definition-params ( exp -- params )
+ cdr car cdr ;
+
+: macro-definition-body ( exp -- body )
+ cdr cdr ;
+
+objvar env
+: eval-define-macro ( obj env -- res )
+ env obj!
+
+ 2dup macro-definition-name 2swap ( name obj )
+ 2dup macro-definition-params 2swap ( name params obj )
+ macro-definition-body ( name params body )
+
+ env obj@ ( name params body env )
+
+ make-macro
+
+ ok-symbol
+;
+hide env
+
+: if? ( obj -- obj bool )
+ if-symbol tagged-list? ;
+
+: if-predicate ( ifobj -- pred )
+ cdr car ;
+
+: if-consequent ( ifobj -- conseq )
+ cdr cdr car ;
+
+: if-alternative ( ifobj -- alt|none )
+ cdr cdr cdr
+ nil? if
+ 2drop none
+ else
+ car
+ then ;
+
+: false? ( boolobj -- boolean )
+ boolean-type istype? if
+ false boolean-type objeq?
+ else
+ 2drop false
+ then
+;
+
+: true? ( boolobj -- bool )
+ false? invert ;
+
+: lambda? ( obj -- obj bool )
+ lambda-symbol tagged-list? ;
+
+: lambda-parameters ( obj -- params )
+ cdr car ;
+
+: 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
+ is returned to allow for tail optimization. )
+
+ 2swap ( env explist )
+
+ \ Abort on empty list
+ nil? if
+ 2drop none
+ 2swap exit
+ then
+
+ begin
+ 2dup cdr ( env explist nextexplist )
+ nil? false =
+ while
+ -2rot car 2over ( nextexplist env exp env )
+ eval
+ 2drop \ discard result
+ 2swap ( env nextexplist )
+ repeat
+
+ 2drop car 2swap ( finalexp env )
+;
+
+: application? ( obj -- obj bool )
+ pair-type istype? ;
+
+: operator ( obj -- operator )
+ car ;
+
+: operands ( obj -- operands )
+ cdr ;
+
+: nooperands? ( operands -- bool )
+ nil objeq? ;
+
+: first-operand ( operands -- operand )
+ car ;
+
+: rest-operands ( operands -- other-operands )
+ cdr ;
+
+: list-of-vals ( args env -- vals )
+ 2swap
+
+ 2dup nooperands? if
+ 2swap 2drop
+ else
+ 2over 2over first-operand 2swap eval
+ -2rot rest-operands 2swap recurse
+ cons
+ then
+;
+
+: procedure-params ( proc -- params )
+ drop pair-type car ;
+
+: procedure-body ( proc -- body )
+ drop pair-type cdr car ;
+
+: procedure-env ( proc -- body )
+ drop pair-type cdr cdr car ;
+
+( Ensure terminating symbol arg name is handled
+ specially to allow for variadic procedures. )
+: flatten-proc-args ( argvals argnames -- argvals' argnames' )
+ nil? if
+ 2over nil? false = if
+ recoverable-exception throw" Too many arguments for compound procedure."
+ else
+ 2drop
+ then
+ exit
+ then
+
+ symbol-type istype? if
+ nil cons
+ 2swap
+ nil cons
+ 2swap
+ exit
+ then
+
+ 2over
+ nil? if
+ recoverable-exception throw" Too few arguments for compound procedure."
+ else
+ cdr
+ then
+
+ 2over cdr
+
+ recurse ( argvals argnames argvals'' argnames'' )
+ 2rot car 2swap cons ( argvals argvals'' argnames' )
+ 2rot car 2rot cons ( argnames' argvals' )
+ 2swap
+;
+
+: apply ( proc argvals -- result )
+ 2swap dup case
+ primitive-proc-type of
+ drop execute
+ endof
+
+ compound-proc-type of
+ 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 )
+
+ eval-sequence
+
+ R> drop ['] eval goto-deferred \ Tail call optimization
+ endof
+
+ recoverable-exception throw" Object not applicable."
+ endcase
+;
+
+: macro-expand ( proc expbody -- result )
+ 2swap
+ 2dup procedure-body ( expbody proc procbody )
+ -2rot 2dup procedure-params ( procbody expbody proc argnames )
+ -2rot procedure-env ( procbody argnames expbody procenv )
+
+ -2rot 2swap
+ flatten-proc-args
+ 2swap 2rot
+
+ extend-env eval-sequence eval
+;
+
+:noname ( obj env -- result )
+ 2swap
+
+ self-evaluating? if
+ 2swap 2drop
+ exit
+ then
+
+ quote? if
+ quote-body
+ 2swap 2drop
+ exit
+ then
+
+ quasiquote? if
+ 2swap eval-quasiquote
+ exit
+ then
+
+ variable? if
+ 2swap lookup-var
+ exit
+ then
+
+ definition? if
+ 2swap eval-definition
+ exit
+ then
+
+ assignment? if
+ 2swap eval-assignment
+ exit
+ then
+
+ macro-definition? if
+ 2swap eval-define-macro
+ exit
+ then
+
+ if? if
+ 2over 2over
+ if-predicate
+ 2swap eval
+
+ true? if
+ if-consequent
+ else
+ if-alternative
+ then
+
+ 2swap
+ ['] eval goto-deferred
+ then
+
+ lambda? if
+ 2dup lambda-parameters
+ 2swap lambda-body
+ 2rot make-procedure
+ exit
+ then
+
+ begin? if
+ begin-actions 2swap
+ eval-sequence
+ ['] eval goto-deferred
+ then
+
+ application? if
+
+ 2over 2over ( env exp env exp )
+ operator ( env exp env opname )
+
+ 2dup lookup-macro nil? false = if
+ \ Macro function evaluation
+
+ ( env exp env opname mproc )
+ 2swap 2drop -2rot 2drop cdr ( env mproc body )
+
+ macro-expand
+
+ 2swap
+ ['] eval goto-deferred
+ else
+ \ Regular function application
+
+ 2drop ( env exp env opname )
+
+ 2swap eval ( env exp proc )
+
+ -2rot ( proc env exp )
+ operands 2swap ( proc operands env )
+ list-of-vals ( proc argvals )
+
+ apply