The Lambda Lab
/
projects
/
scheme.forth.jl.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
2e9cddd
)
Implemented quote.
author
Tim Vaughan
<tgvaughan@gmail.com>
Wed, 13 Jul 2016 11:13:45 +0000
(23:13 +1200)
committer
Tim Vaughan
<tgvaughan@gmail.com>
Wed, 13 Jul 2016 11:13:45 +0000
(23:13 +1200)
scheme.4th
patch
|
blob
|
history
diff --git
a/scheme.4th
b/scheme.4th
index
120edd2
..
4df51d0
100644
(file)
--- a/
scheme.4th
+++ b/
scheme.4th
@@
-50,6
+50,11
@@
variable nextfree
cdr-type-cells + @
;
cdr-type-cells + @
;
+: caar car car ;
+: cadr cdr car ;
+: cdar car cdr ;
+: cddr cdr cdr ;
+
: nil 0 nil-type ;
: nil? nil-type istype? ;
: nil 0 nil-type ;
: nil? nil-type istype? ;
@@
-65,6
+70,9
@@
variable nextfree
objvar symbol-table
nil symbol-table setobj
objvar symbol-table
nil symbol-table setobj
+: objeq? ( obj obj -- bool )
+ rot = -rot = and ;
+
\ ---- Pre-defined symbols ----
: (create-symbol) ( addr n -- symbol-obj )
\ ---- Pre-defined symbols ----
: (create-symbol) ( addr n -- symbol-obj )
@@
-82,15
+90,21
@@
nil symbol-table setobj
: create-symbol ( -- )
bl word
count
: create-symbol ( -- )
bl word
count
+
(create-symbol)
drop symbol-type
(create-symbol)
drop symbol-type
+ 2dup
+
symbol-table fetchobj
cons
symbol-table setobj
symbol-table fetchobj
cons
symbol-table setobj
+
+ create swap , ,
+ does> dup @ swap 1+ @
;
;
-create-symbol quote
+create-symbol quote
quote
\ ---- Read ----
\ ---- Read ----
@@
-527,6
+541,11
@@
defer read
exit
then
exit
then
+ nextchar [char] ' = if
+ inc-parse-idx
+ quote recurse nil cons cons exit
+ then
+
eof? if
bold fg blue ." Moriturus te saluto." reset-term ." ok" cr
quit
eof? if
bold fg blue ." Moriturus te saluto." reset-term ." ok" cr
quit
@@
-542,14
+561,39
@@
defer read
\ ---- Eval ----
: self-evaluating? ( obj -- obj bool )
\ ---- Eval ----
: self-evaluating? ( obj -- obj bool )
- true \ everything self-evaluating for now
+ boolean-type istype? if true exit then
+ number-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
+
+ 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 tagged-list? ;
+
+: quote-body ( quote-obj -- quote-body-obj )
+ cadr ;
+
: eval
self-evaluating? if
exit
then
: eval
self-evaluating? if
exit
then
+ quote? if
+ quote-body
+ exit
+ then
+
bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
abort
;
bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
abort
;