commit f97472196d52791f4ec70141c71944622be8a07a
parent 5b4a48a0d77bb624b4f8aba4a97e13bfd6f07d45
Author: Alexander Burger <abu@software-lab.de>
Date: Thu, 3 Feb 2011 09:41:50 +0100
Map/apply support for FEXPRs
Diffstat:
8 files changed, 181 insertions(+), 41 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXmar11 picoLisp-3.0.6
+ Map/apply support for FEXPRs
Bug in vararg method calls (64-bit)
'fill' handles '^'
'le0' function
diff --git a/doc64/structures b/doc64/structures
@@ -1,4 +1,4 @@
-# 12oct10abu
+# 03feb11abu
# (c) Software Lab. Alexander Burger
@@ -172,7 +172,7 @@
+---- LINK <-- L
- Apply frame:
+ Apply frame (SUBR):
^
Apply |
+---> LINK ----+
@@ -191,6 +191,23 @@
+---- LINK <-- L <-- Apply
+ Apply frame (FEXPR):
+ ^
+ Apply |
+ +---> LINK ----+
+ | ...
+ | valN <-+ (gc)
+ | zero |
+ | NIL | (gc)
+ | carN --+ <-+
+ | ... |
+ | val1 <-+ | (gc)
+ | zero | |
+ | cdr1 --|---+ (gc)
+ | car1 --+ <-- args
+ +---- LINK <-- L <-- Apply
+
+
Catch frame:
^
X |
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/ersatz/sys.src b/ersatz/sys.src
@@ -1,4 +1,4 @@
-// 25jan11abu
+// 03feb11abu
// (c) Software Lab. Alexander Burger
import java.util.*;
@@ -2268,6 +2268,8 @@ public class PicoLisp {
bnd.add(x.Car); // Save value
bnd.add(x); // and symbol
x.Car = Nil; // Set to NIL
+ while (--n >= i)
+ x.Car = new Cell(mkSymbol(cf? v[n].Car : v[n]), x.Car);
}
bnd.add(This.Car);
bnd.add(This);
@@ -2582,6 +2584,8 @@ public class PicoLisp {
bnd.add(x.Car); // Save old value
bnd.add(x); // and symbol
x.Car = Nil; // Set to NIL
+ while (--n >= i)
+ x.Car = new Cell(mkSymbol(cf? v[n].Car : v[n]), x.Car);
}
Env.Bind = bnd;
x = Cdr.prog();
diff --git a/lib/tags b/lib/tags
@@ -31,7 +31,7 @@ all (772 . "@src64/sym.l")
and (1621 . "@src64/flow.l")
any (3877 . "@src64/io.l")
append (1338 . "@src64/subr.l")
-apply (591 . "@src64/apply.l")
+apply (703 . "@src64/apply.l")
arg (2267 . "@src64/main.l")
args (2243 . "@src64/main.l")
argv (2888 . "@src64/main.l")
@@ -45,7 +45,7 @@ bit? (2746 . "@src64/big.l")
bool (1721 . "@src64/flow.l")
box (822 . "@src64/flow.l")
box? (999 . "@src64/sym.l")
-by (1547 . "@src64/apply.l")
+by (1659 . "@src64/apply.l")
bye (3422 . "@src64/flow.l")
caaaar (271 . "@src64/subr.l")
caaadr (288 . "@src64/subr.l")
@@ -89,7 +89,7 @@ circ? (2398 . "@src64/subr.l")
clip (1795 . "@src64/subr.l")
close (4265 . "@src64/io.l")
cmd (2870 . "@src64/main.l")
-cnt (1291 . "@src64/apply.l")
+cnt (1403 . "@src64/apply.l")
co (2544 . "@src64/flow.l")
commit (1496 . "@src64/db.l")
con (725 . "@src64/subr.l")
@@ -125,15 +125,15 @@ ext (5026 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
extra (1263 . "@src64/flow.l")
-extract (1096 . "@src64/apply.l")
+extract (1208 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
file (2748 . "@src64/main.l")
fill (3236 . "@src64/subr.l")
-filter (1039 . "@src64/apply.l")
+filter (1151 . "@src64/apply.l")
fin (2029 . "@src64/subr.l")
finally (2520 . "@src64/flow.l")
-find (1200 . "@src64/apply.l")
-fish (1491 . "@src64/apply.l")
+find (1312 . "@src64/apply.l")
+fish (1603 . "@src64/apply.l")
flg? (2441 . "@src64/subr.l")
flip (1695 . "@src64/subr.l")
flush (5001 . "@src64/io.l")
@@ -195,24 +195,24 @@ lt0 (2680 . "@src64/big.l")
lup (2226 . "@src64/sym.l")
made (1107 . "@src64/subr.l")
make (1088 . "@src64/subr.l")
-map (727 . "@src64/apply.l")
-mapc (769 . "@src64/apply.l")
-mapcan (979 . "@src64/apply.l")
-mapcar (865 . "@src64/apply.l")
-mapcon (919 . "@src64/apply.l")
-maplist (811 . "@src64/apply.l")
-maps (668 . "@src64/apply.l")
+map (839 . "@src64/apply.l")
+mapc (881 . "@src64/apply.l")
+mapcan (1091 . "@src64/apply.l")
+mapcar (977 . "@src64/apply.l")
+mapcon (1031 . "@src64/apply.l")
+maplist (923 . "@src64/apply.l")
+maps (780 . "@src64/apply.l")
mark (1965 . "@src64/db.l")
match (3121 . "@src64/subr.l")
max (2323 . "@src64/subr.l")
-maxi (1389 . "@src64/apply.l")
+maxi (1501 . "@src64/apply.l")
member (2451 . "@src64/subr.l")
memq (2473 . "@src64/subr.l")
meta (3135 . "@src64/sym.l")
meth (1087 . "@src64/flow.l")
method (1051 . "@src64/flow.l")
min (2352 . "@src64/subr.l")
-mini (1440 . "@src64/apply.l")
+mini (1552 . "@src64/apply.l")
mix (1260 . "@src64/subr.l")
mmeq (2501 . "@src64/subr.l")
n0 (2185 . "@src64/subr.l")
@@ -242,11 +242,11 @@ or (1637 . "@src64/flow.l")
out (4121 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
pair (2390 . "@src64/subr.l")
-pass (632 . "@src64/apply.l")
+pass (744 . "@src64/apply.l")
pat? (720 . "@src64/sym.l")
path (1238 . "@src64/io.l")
peek (3343 . "@src64/io.l")
-pick (1247 . "@src64/apply.l")
+pick (1359 . "@src64/apply.l")
pipe (4142 . "@src64/io.l")
poll (3232 . "@src64/io.l")
pool (648 . "@src64/db.l")
@@ -290,7 +290,7 @@ rpc (5142 . "@src64/io.l")
run (313 . "@src64/flow.l")
sect (2537 . "@src64/subr.l")
seed (2958 . "@src64/big.l")
-seek (1153 . "@src64/apply.l")
+seek (1265 . "@src64/apply.l")
send (1131 . "@src64/flow.l")
seq (1083 . "@src64/db.l")
set (1482 . "@src64/sym.l")
@@ -309,7 +309,7 @@ str (3931 . "@src64/io.l")
str? (1013 . "@src64/sym.l")
strip (1572 . "@src64/subr.l")
sub? (1444 . "@src64/sym.l")
-sum (1338 . "@src64/apply.l")
+sum (1450 . "@src64/apply.l")
super (1218 . "@src64/flow.l")
sym (3917 . "@src64/io.l")
sym? (2430 . "@src64/subr.l")
diff --git a/src/apply.c b/src/apply.c
@@ -1,4 +1,4 @@
-/* 12oct10abu
+/* 03feb11abu
* (c) Software Lab. Alexander Burger
*/
@@ -26,7 +26,10 @@ any apply(any ex, any foo, bool cf, int n, cell *p) {
if (isNil(x))
x = prog(cdr(foo));
else if (x != At) {
- f.bnd[f.cnt].sym = x, f.bnd[f.cnt++].val = val(x), val(x) = Nil;
+ f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil;
+ while (--n >= 0)
+ val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x));
+ ++f.cnt;
x = prog(cdr(foo));
}
else {
@@ -81,7 +84,10 @@ any apply(any ex, any foo, bool cf, int n, cell *p) {
x = prog(cdr(expr));
}
else if (x != At) {
- f.bnd[f.cnt].sym = x, f.bnd[f.cnt++].val = val(x), val(x) = Nil;
+ f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil;
+ while (--n >= 0)
+ val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x));
+ ++f.cnt;
f.bnd[f.cnt].sym = This;
f.bnd[f.cnt++].val = val(This);
val(This) = o;
diff --git a/src64/apply.l b/src64/apply.l
@@ -1,4 +1,4 @@
-# 27jan11abu
+# 03feb11abu
# (c) Software Lab. Alexander Burger
(code 'applyXYZ_E 0)
@@ -87,12 +87,40 @@
if ne # No
push (X) # Save last parameter's old value
push X # and the last parameter
- ld (X) Nil # Set new value to NIL
link
ld (EnvBind) L # Close bind frame
push 0 # Init env swap
- ld Z (C CDR) # Body in Z
- prog Z # Run body
+ cmp Y Z # More args?
+ if eq # No
+ ld (X) Nil # Set new value to NIL
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ else
+ push (EnvApply) # Build apply frame
+ link
+ sym S # Align stack to cell boundary
+ if nz
+ push ZERO
+ end
+ ld E Nil # Init 'args' list
+ do
+ push (Z) # Next arg
+ push ZERO # Dummy symbol's tail
+ push E # Dummy cell's CDR
+ lea A (S II) # Value address
+ push A # CAR
+ ld E S # Set 'args' list
+ add Z I
+ cmp Z Y # More args?
+ until eq # No
+ ld (X) E # Set new value to 'args' list
+ link
+ ld (EnvApply) L # Close apply frame
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ drop
+ pop (EnvApply)
+ end
pop A # Drop env swap
pop L # Get link
do # Unbind symbols
@@ -221,12 +249,40 @@
if ne # No
push (X) # Save last parameter's old value
push X # and the last parameter
- ld (X) Nil # Set new value to NIL
link
ld (EnvBind) L # Close bind frame
push 0 # Init env swap
- ld Z (C CDR) # Body in Z
- prog Z # Run body
+ cmp Y Z # More args?
+ if eq # No
+ ld (X) Nil # Set new value to NIL
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ else
+ push (EnvApply) # Build apply frame
+ link
+ sym S # Align stack to cell boundary
+ if nz
+ push ZERO
+ end
+ ld E Nil # Init 'args' list
+ do
+ push (Z) # Next arg
+ push ZERO # Dummy symbol's tail
+ push E # Dummy cell's CDR
+ lea A (S II) # Value address
+ push A # CAR
+ ld E S # Set 'args' list
+ add Z I
+ cmp Z Y # More args?
+ until eq # No
+ ld (X) E # Set new value to 'args' list
+ link
+ ld (EnvApply) L # Close apply frame
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ drop
+ pop (EnvApply)
+ end
pop A # Drop env swap
pop L # Get link
do # Unbind symbols
@@ -380,12 +436,40 @@
if ne # No
push (X) # Save last parameter's old value
push X # and the last parameter
- ld (X) Nil # Set new value to NIL
link
ld (EnvBind) L # Close bind frame
push 0 # Init env swap
- ld Z (C CDR) # Body in Z
- prog Z # Run body
+ cmp Y Z # More args?
+ if eq # No
+ ld (X) Nil # Set new value to NIL
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ else
+ push (EnvApply) # Build apply frame
+ link
+ sym S # Align stack to cell boundary
+ if nz
+ push ZERO
+ end
+ ld E Nil # Init 'args' list
+ do
+ push ((Z)) # Next arg
+ push ZERO # Dummy symbol's tail
+ push E # Dummy cell's CDR
+ lea A (S II) # Value address
+ push A # CAR
+ ld E S # Set 'args' list
+ add Z I
+ cmp Z Y # More args?
+ until eq # No
+ ld (X) E # Set new value to 'args' list
+ link
+ ld (EnvApply) L # Close apply frame
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ drop
+ pop (EnvApply)
+ end
pop A # Drop env swap
pop L # Get link
do # Unbind symbols
@@ -514,12 +598,40 @@
if ne # No
push (X) # Save last parameter's old value
push X # and the last parameter
- ld (X) Nil # Set new value to NIL
link
ld (EnvBind) L # Close bind frame
push 0 # Init env swap
- ld Z (C CDR) # Body in Z
- prog Z # Run body
+ cmp Y Z # More args?
+ if eq # No
+ ld (X) Nil # Set new value to NIL
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ else
+ push (EnvApply) # Build apply frame
+ link
+ sym S # Align stack to cell boundary
+ if nz
+ push ZERO
+ end
+ ld E Nil # Init 'args' list
+ do
+ push ((Z)) # Next arg
+ push ZERO # Dummy symbol's tail
+ push E # Dummy cell's CDR
+ lea A (S II) # Value address
+ push A # CAR
+ ld E S # Set 'args' list
+ add Z I
+ cmp Z Y # More args?
+ until eq # No
+ ld (X) E # Set new value to 'args' list
+ link
+ ld (EnvApply) L # Close apply frame
+ ld Z (C CDR) # Body in Z
+ prog Z # Run body
+ drop
+ pop (EnvApply)
+ end
pop A # Drop env swap
pop L # Get link
do # Unbind symbols
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 28jan11abu
+# 03feb11abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 5 11)
+(de *Version 3 0 5 12)
# vi:et:ts=3:sw=3
