+ 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 ;
+
+: 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 ;
+
+: definition-var ( obj -- var )
+ cdr car
+ symbol-type istype? false = if car then
+;
+
+: definition-val ( obj -- val )
+ 2dup cdr car symbol-type istype? if
+ 2drop
+ cdr cdr car
+ else
+ cdr 2swap cdr cdr
+ make-lambda
+ then
+;
+
+: assignment? ( obj -- obj bool )
+ set!-symbol tagged-list? ;
+
+: assignment-var ( obj -- var )
+ cdr car ;
+
+: assignment-val ( obj -- val )
+ cdr cdr car ;
+
+: eval-definition ( obj env -- res )
+ 2swap
+ 2over 2over ( env obj env obj )
+ definition-val 2swap ( env obj valexp env )
+ eval ( env obj val )
+
+ 2swap definition-var 2swap ( env var val )
+
+ 2rot ( var val env )
+ define-var
+
+ ok-symbol
+;
+
+: 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|false )
+ cdr cdr cdr
+ nil? if
+ 2drop false
+ else
+ car
+ then ;
+
+: false? ( boolobj -- boolean )
+ boolean-type istype? if
+ false boolean-type objeq?
+ else
+ 2drop false
+ then