+: fileport>fid ( fileport -- fid )
+ drop ;
+
+: fid>fileport ( fid -- fileport )
+ fileport-type ;
+
+: open-input-file ( addr n -- fileport )
+ r/o open-file drop fid>fileport
+;
+
+: close-port ( fileport -- )
+ fileport>fid close-file drop
+;
+
+objvar console-i/o-port
+0 fileport-type console-i/o-port obj!
+
+objvar current-input-port
+console-i/o-port obj@ current-input-port obj!
+
+: read-port ( fileport -- obj )
+ current-input-port obj!
+ read ;
+
+: read-console ( -- obj )
+ console-i/o-port obj@ read-port ;
+
+\ }}}
+
+\ ---- Pre-defined symbols ---- {{{
+
+objvar symbol-table
+
+: duplicate-charlist ( charlist -- copy )
+ 2dup nil objeq? 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 -- symbol-obj )
+ 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
+ drop symbol-type
+
+ 2dup
+
+ symbol-table obj@
+ cons
+ symbol-table obj!
+
+ create swap , ,
+ does> dup @ swap 1+ @
+;
+
+create-symbol quote quote-symbol
+create-symbol define define-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
+ 2dup nil objeq? 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
+ bold fg red ." Tried to read unbound variable." reset-term cr abort
+ 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
+ bold fg red ." Tried to set unbound variable." reset-term cr abort
+ 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
+
+objvar global-env
+nil nil nil extend-env
+global-env obj!
+
+\ }}}
+
+\ ---- Read ---- {{{