+: set-car! ( obj pair-obj -- )
+ drop dup
+ rot swap car-type-cells + !
+ car-cells + !
+;
+
+: set-cdr! ( obj pair-obj -- )
+ drop dup
+ rot swap cdr-type-cells + !
+ cdr-cells + !
+;
+
+: nil 0 nil-type ;
+: nil? nil-type istype? ;
+
+: none 0 none-type ;
+: none? none-type istype? ;
+
+: objvar create nil swap , , ;
+
+: value@ ( objvar -- val ) @ ;
+: type@ ( objvar -- type ) 1+ @ ;
+: value! ( newval objvar -- ) ! ;
+: type! ( newtype objvar -- ) 1+ ! ;
+: obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
+: obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
+
+: objeq? ( obj obj -- bool )
+ rot = -rot = and ;
+
+: 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
+ >R >R ( a1 a2 b1 b2 )
+ 2swap ( b1 b2 a1 a2 )
+ R> R> ( b1 b2 a1 a2 c1 c2 )
+ 2swap
+;
+
+: -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
+ 2swap ( a1 a2 c1 c2 b1 b2 )
+ >R >R ( a1 a2 c1 c2 )
+ 2swap ( c1 c2 a1 a2 )
+ R> R>
+;
+
+\ }}}
+
+\ ---- Port I/O ---- {{{
+
+: 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 )
+ 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!
+;
+
+\ }}}