The Lambda Lab
/
projects
/
scheme.forth.jl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fixed if form when no alternative.
[scheme.forth.jl.git]
/
scheme.4th
diff --git
a/scheme.4th
b/scheme.4th
index
5d3b778
..
244a33f
100644
(file)
--- a/
scheme.4th
+++ b/
scheme.4th
@@
-1064,8
+1064,10
@@
parse-idx-stack parse-idx-sp !
quasiquote-symbol tagged-list? ;
: unquote? ( obj -- obj bool )
quasiquote-symbol tagged-list? ;
: unquote? ( obj -- obj bool )
- unquote-symbol tagged-list?
-;
+ unquote-symbol tagged-list? ;
+
+: unquote-splicing? ( obj -- obj bool )
+ unquote-splicing-symbol tagged-list? ;
: eval-unquote ( env obj -- res )
cdr ( env args )
: eval-unquote ( env obj -- res )
cdr ( env args )
@@
-1082,24
+1084,53
@@
parse-idx-stack parse-idx-sp !
2drop car 2swap eval
;
2drop car 2swap eval
;
-: (eval-quasiquote) ( env obj -- res )
+( Create a new list from elements of l1 consed on to l2 )
+: join-lists ( l2 l1 -- l3 )
+ nil? if 2drop exit then
+
+ 2dup car
+ -2rot cdr
+ recurse cons
+;
+
+defer eval-quasiquote-item
+: eval-quasiquote-list ( env obj -- res )
nil? if
2swap 2drop exit
then
nil? if
2swap 2drop exit
then
- 2over 2over
car ( env obj env obj-car
)
+ 2over 2over
( env obj env obj
)
- unquote? if
- eval-unquote
+ cdr recurse
+ -2rot car ( cdritems env objcar )
+
+ unquote-splicing? if
+ eval-unquote ( cdritems caritem )
+
+ 2swap nil? if
+ 2drop
+ else
+ 2swap join-lists
+ then
else
else
- 2swap 2drop
+ eval-quasiquote-item ( cdritems caritem )
+ 2swap cons
then
then
- -2rot cdr ( caritem env cdr )
- recurse ( caritem cdritems )
- cons
;
;
+:noname ( env obj )
+ unquote? if
+ eval-unquote exit
+ then
+
+ pair-type istype? if
+ eval-quasiquote-list exit
+ then
+
+ 2swap 2drop
+; is eval-quasiquote-item
+
: eval-quasiquote ( obj env -- res )
2swap cdr ( env args )
: eval-quasiquote ( obj env -- res )
2swap cdr ( env args )
@@
-1114,15
+1145,8
@@
parse-idx-stack parse-idx-sp !
2drop car ( env arg )
2drop car ( env arg )
- unquote? if
- eval-unquote exit
- then
-
- pair-type istype? if
- (eval-quasiquote) exit
- then
-
- 2swap 2drop ;
+ eval-quasiquote-item
+;
: variable? ( obj -- obj bool )
symbol-type istype? ;
: variable? ( obj -- obj bool )
symbol-type istype? ;
@@
-1223,10
+1247,10
@@
hide env
: if-consequent ( ifobj -- conseq )
cdr cdr car ;
: if-consequent ( ifobj -- conseq )
cdr cdr car ;
-: if-alternative ( ifobj -- alt|
fals
e )
+: if-alternative ( ifobj -- alt|
non
e )
cdr cdr cdr
nil? if
cdr cdr cdr
nil? if
- 2drop
fals
e
+ 2drop
non
e
else
car
then ;
else
car
then ;
@@
-1570,6
+1594,9
@@
hide env
: printnone ( noneobj -- )
2drop ." Unspecified return value" ;
: printnone ( noneobj -- )
2drop ." Unspecified return value" ;
+: printport ( port -- )
+ 2drop ." <port>" ;
+
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
realnum-type istype? if printrealnum exit then
:noname ( obj -- )
fixnum-type istype? if printfixnum exit then
realnum-type istype? if printrealnum exit then