+: duplicate-charlist ( charlist -- copy )
+ nil? false = if
+ 2dup car 2swap cdr recurse cons
+ then ;
+
+: charlist-equiv ( charlist charlist -- bool )
+
+ 2over 2over
+
+ \ One or both nil
+ nil? -rot 2drop
+ if
+ nil? -rot 2drop
+ if
+ 2drop 2drop true exit
+ else
+ 2drop 2drop false exit
+ then
+ else
+ nil? -rot 2drop
+ if
+ 2drop 2drop false exit
+ then
+ then
+
+ 2over 2over
+
+ \ Neither nil
+ car drop -rot car drop = if
+ cdr 2swap cdr recurse
+ else
+ 2drop 2drop false
+ then
+;
+
+: charlist>symbol ( charlist -- symbol-obj )
+
+ symbol-table obj@
+
+ begin
+ nil? false =
+ while
+ 2over 2over
+ car drop pair-type
+ charlist-equiv if
+ 2swap 2drop
+ car
+ exit
+ else
+ cdr
+ then
+ repeat
+
+ 2drop
+ drop symbol-type 2dup
+ symbol-table obj@ cons
+ symbol-table obj!
+;
+
+
+: cstr>charlist ( addr n -- charlist )
+ dup 0= if
+ 2drop nil
+ else
+ 2dup drop @ character-type 2swap
+ swap 1+ swap 1-
+ recurse
+
+ cons
+ then
+;
+
+: create-symbol ( -- )
+ bl word
+ count
+
+ cstr>charlist
+ charlist>symbol
+
+ create swap , ,
+ does> dup @ swap 1+ @
+;
+
+create-symbol quote quote-symbol
+create-symbol quasiquote quasiquote-symbol
+create-symbol unquote unquote-symbol
+create-symbol unquote-splicing unquote-splicing-symbol
+create-symbol define define-symbol
+create-symbol define-macro define-macro-symbol
+create-symbol set! set!-symbol
+create-symbol ok ok-symbol
+create-symbol if if-symbol
+create-symbol lambda lambda-symbol
+create-symbol λ λ-symbol
+create-symbol begin begin-symbol
+
+\ }}}
+
+\ ---- Environments ---- {{{
+
+: enclosing-env ( env -- env )
+ cdr ;
+
+: first-frame ( env -- frame )
+ car ;
+
+: make-frame ( vars vals -- frame )
+ cons ;
+
+: frame-vars ( frame -- vars )
+ car ;
+
+: frame-vals ( frame -- vals )
+ cdr ;
+
+: add-binding ( var val frame -- )
+ 2swap 2over frame-vals cons
+ 2over set-cdr!
+ 2swap 2over frame-vars cons
+ 2swap set-car!
+;
+
+: extend-env ( vars vals env -- env )
+ >R >R
+ make-frame
+ R> R>
+ cons
+;
+
+objvar vars
+objvar vals
+
+: get-vars-vals-frame ( var frame -- bool )
+ 2dup frame-vars vars obj!
+ frame-vals vals obj!
+
+ begin
+ vars obj@ nil objeq? false =
+ while
+ 2dup vars obj@ car objeq? if
+ 2drop true
+ exit
+ then
+
+ vars obj@ cdr vars obj!
+ vals obj@ cdr vals obj!
+ repeat
+
+ 2drop false
+;
+
+: get-vars-vals ( var env -- vars? vals? bool )
+
+ begin
+ nil? false =
+ while
+ 2over 2over first-frame
+ get-vars-vals-frame if
+ 2drop 2drop
+ vars obj@ vals obj@ true
+ exit
+ then
+
+ enclosing-env
+ repeat
+
+ 2drop 2drop
+ false
+;
+
+hide vars
+hide vals
+
+: lookup-var ( var env -- val )
+ get-vars-vals if
+ 2swap 2drop car
+ else
+ recoverable-exception throw" Tried to read unbound variable."
+ then
+;
+
+: set-var ( var val env -- )
+ >R >R 2swap R> R> ( val var env )
+ get-vars-vals if
+ 2swap 2drop ( val vals )
+ set-car!
+ else
+ recoverable-exception throw" Tried to set unbound variable."
+ then
+;
+
+objvar env
+
+: define-var ( var val env -- )
+ env obj!
+
+ 2over env obj@ ( var val var env )
+ get-vars-vals if
+ 2swap 2drop ( var val vals )
+ set-car!
+ 2drop
+ else
+ env obj@
+ first-frame ( var val frame )
+ add-binding
+ then
+;
+
+hide env
+
+: make-procedure ( params body env -- proc )
+ nil
+ cons cons cons
+ drop compound-proc-type
+;
+
+objvar global-env
+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
+;
+
+: ensure-arg-count ( args n -- )
+ dup 0= if
+ drop nil objeq? false = if
+ recoverable-exception throw" Too many arguments for primitive procedure."
+ then
+ else
+ -rot nil? if
+ recoverable-exception throw" Too few arguments for primitive procedure."
+ 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
+ recoverable-exception throw" Incorrect argument type for primitive procedure."
+ then
+;
+
+
+\ }}}
+
+\ ---- Macros ---- {{{
+
+objvar macro-table
+
+( Look up macro in macro table. Returns nil if
+ no macro is found. )
+: lookup-macro ( name_symbol -- proc )
+ macro-table obj@
+
+ begin
+ nil? false =
+ while
+ 2over 2over
+ car car objeq? if
+ 2swap 2drop
+ car cdr
+ exit
+ then
+
+ cdr
+ repeat
+
+ 2swap 2drop
+;
+
+: make-macro ( name_symbol params body env -- )
+ make-procedure
+
+ 2swap ( proc name_symbol )
+
+ macro-table obj@
+
+ begin
+ nil? false =
+ while
+ 2over 2over ( proc name table name table )
+ car car objeq? if
+ 2swap 2drop ( proc table )
+ car ( proc entry )
+ set-cdr!
+ exit
+ then
+
+ cdr
+ repeat
+
+ 2drop
+
+ 2swap cons
+ macro-table obj@ cons
+ macro-table obj!
+;
+
+\ }}}
+
+\ ---- Read ---- {{{