+: create-symbol ( -- )
+ bl word
+ count
+
+ (create-symbol)
+ drop symbol-type
+
+ 2dup
+
+ symbol-table fetchobj
+ cons
+ symbol-table setobj
+
+ create swap , ,
+ does> dup @ swap 1+ @
+;
+
+create-symbol quote quote-symbol
+create-symbol define define-symbol
+create-symbol set! set!-symbol
+
+\ ---- Environments ----
+
+objvar global-env
+
+: 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-car!
+ 2swap 2over frame-vars cons
+ swap set-cdr!
+;
+
+: extend-env ( vars vals env -- env )
+ >R >R
+ make-frame
+ R> R>
+ cons
+;
+
+objvar vars
+objvar vals
+
+: lookup-var-frame ( var frame -- val? bool )
+ 2dup frame-vars vars setobj
+ frame-vals vals setobj
+
+ begin
+ vars fetchobj nil objeq? false =
+ while
+ 2dup vars fetchobj car objeq? if
+ 2drop
+ vals fetchobj car true
+ exit
+ then
+
+ vars fetchobj cdr vars setobj
+ vals fetchobj cdr vals setobj
+ repeat
+
+ 2drop false
+;
+
+: lookup-var ( var env -- val )
+ begin
+ 2dup nil objeq? false =
+ while
+ 2over 2over first-frame
+ lookup-var-frame if
+ -rot 2drop -rot 2drop
+ exit
+ then
+
+ enclosing-env
+ repeat
+
+ bold fg red ." Unbound variable. Aborting." reset-term cr
+ abort
+;
+
+objvar val
+
+: set-var-frame ( var frame -- )
+ 2dup frame-vars vars setobj
+ frame-vals vals setobj
+
+ begin
+ vars fetchobj nil objeq? false =
+ while
+ 2dup vars fetchobj car objeq? if
+ 2drop
+ \ *** TODO ***
+ then
+
+ vars fetchobj cdr vars setobj
+ vals fetchobj cdr vals setobj
+ repeat
+;
+
+
+: set-var ( var val env -- )
+
+ 2swap val setobj
+
+ begin
+ 2dup nil objeq? false =
+ while
+ 2over 2over first-frame
+ set-var-frame if
+ exit
+ then
+
+ enclosing-env
+ repeat
+
+ bold fg red ." Unbound variable. Aborting." reset-term cr
+ abort
+;
+
+hide vars
+hide vals
+hide val
+
+\ ---- Read ----
+
+variable parse-idx
+variable stored-parse-idx
+create parse-str 161 allot
+variable parse-str-span
+
+create parse-idx-stack 10 allot
+variable parse-idx-sp
+parse-idx-stack parse-idx-sp !
+
+: push-parse-idx
+ parse-idx @ parse-idx-sp @ !
+ 1 parse-idx-sp +!