picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

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:
MCHANGES | 1+
Mdoc64/structures | 21+++++++++++++++++++--
Mersatz/picolisp.jar | 0
Mersatz/sys.src | 6+++++-
Mlib/tags | 40++++++++++++++++++++--------------------
Msrc/apply.c | 12+++++++++---
Msrc64/apply.l | 138+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------
Msrc64/version.l | 4++--
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