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 77e4b7197e2fc042ce2822b0fcfd90a8b5ce5ab9
parent fc8c5c8788b4e02d076e66296c94ca45881f6fbf
Author: Alexander Burger <abu@software-lab.de>
Date:   Thu, 14 Jul 2011 08:26:20 +0200

'prop' and '::' cons default cell
Diffstat:
MCHANGES | 1+
Mdoc/refP.html | 7++++---
Mdoc/ref_.html | 7++++---
Mersatz/fun.src | 6+++---
Mersatz/picolisp.jar | 0
Mersatz/sys.src | 35++++++++++++++++++++++-------------
Mlib/db.l | 10++--------
Mlib/tags | 32++++++++++++++++----------------
Msrc/sym.c | 49+++++++++++++++++++++++++++----------------------
Msrc/vers.h | 2+-
Msrc64/sym.l | 146++++++++++++++++++++++++++++++++++++++++++++++++-------------------------------
Msrc64/version.l | 4++--
Mtest/src/sym.l | 6+++++-
13 files changed, 175 insertions(+), 130 deletions(-)

diff --git a/CHANGES b/CHANGES @@ -1,4 +1,5 @@ * XXsep11 picoLisp-3.0.8 + 'prop' and '::' cons default cell "lib/test.l" position independent 'hash' function Bug in 'dbFetchEX' for db extensions diff --git a/doc/refP.html b/doc/refP.html @@ -654,13 +654,14 @@ href="refP.html#prog1">prog1</a></code>. 123-> 2 </code></pre> -<dt><a name="prop"><code>(prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym</code></a> +<dt><a name="prop"><code>(prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var</code></a> <dd>Fetches a property for a property key <code>sym</code> from a symbol. That symbol is <code>sym1</code> (if no other arguments are given), or a symbol found by applying the <code><a href="refG.html#get">get</a></code> algorithm to <code>sym1|lst</code> and the following arguments. The property (the cell, not -just its value) is returned, suitable for direct (destructive) manipulations. -See also <code><a href="ref_.html#::">::</a></code>. +just its value) is returned, suitable for direct (destructive) manipulations +with functions expecting a <code>var</code> argument. See also <code><a +href="ref_.html#::">::</a></code>. <pre><code> : (put 'X 'cnt 0) diff --git a/doc/ref_.html b/doc/ref_.html @@ -250,14 +250,15 @@ href="ref_.html#;">;</a></code>, <code><a href="ref_.html#=:">=:</a></code> and -> 1 </code></pre> -<dt><a name="::"><code>(:: sym [sym1|cnt .. sym2]) -> lst|sym</code></a> +<dt><a name="::"><code>(:: sym [sym1|cnt .. sym2]) -> var</code></a> <dd>Fetches a property for a property key <code>sym</code> or <code>sym2</code> from a symbol. That symbol is <code>This</code> (if no other arguments are given), or a symbol found by applying the <code><a href="refG.html#get">get</a></code> algorithm to <code>This</code> and the following arguments. The property (the cell, not just its value) is returned, -suitable for direct (destructive) manipulations. Used typically in methods or -<code><a href="refW.html#with">with</a></code> bodies. See also <code><a +suitable for direct (destructive) manipulations with functions expecting a +<code>var</code> argument. Used typically in methods or <code><a +href="refW.html#with">with</a></code> bodies. See also <code><a href="ref_.html#=:">=:</a></code>, <code><a href="refP.html#prop">prop</a></code> and <code><a href="ref_.html#:">:</a></code>. diff --git a/ersatz/fun.src b/ersatz/fun.src @@ -1,4 +1,4 @@ -# 09jul11abu +# 14jul11abu # (c) Software Lab. Alexander Burger # Ersatz PicoLisp Functions @@ -1990,7 +1990,7 @@ get (x) x = x.get(ex.Car.eval()); return x; -# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym +# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var prop (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr).Cdr instanceof Cell) @@ -2021,7 +2021,7 @@ prop (x) while (ex.Cdr instanceof Cell); return x; -# (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym +# (:: sym|0 [sym1|cnt .. sym2]) -> var :: (x) x = This.Car; while ((ex = ex.Cdr).Cdr instanceof Cell) 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 @@ -// 09jul11abu +// 13jul11abu // (c) Software Lab. Alexander Burger import java.util.*; @@ -2179,7 +2179,7 @@ public class PicoLisp { System.arraycopy(Prop, 0, a, 0, p); Prop = a; } - Prop[p] = val != T? new Cell(val, key): key; + Prop[p] = val != T? new Cell(val, key) : key; } } else if (val != Nil) @@ -2208,21 +2208,30 @@ public class PicoLisp { } final Any prop(Any key) { - if (Prop == null) - return Nil; Any x; - int i = Prop.length; + + if (Prop == null) { + (Prop = new Any[3])[2] = x = new Cell(Nil, key); + return x; + } + int i = Prop.length, p = -1; do { - if ((x = Prop[--i]) != null) { - if (x instanceof Cell) { - if (key == x.Cdr) - return x; - } - else if (key == x) - return key; + if ((x = Prop[--i]) == null) + p = i; + else if (x instanceof Cell) { + if (key == x.Cdr) + return x; } + else if (key == x) + return key; } while (i != 0); - return Nil; + if (p < 0) { + Any[] a = new Any[(p = Prop.length) * 2]; + System.arraycopy(Prop, 0, a, 0, p); + Prop = a; + } + Prop[p] = x = new Cell(Nil, key); + return x; } final Any putl(Any lst) { diff --git a/lib/db.l b/lib/db.l @@ -1,4 +1,4 @@ -# 06jun11abu +# 13jul11abu # (c) Software Lab. Alexander Burger # *Dbs *Jnl *Blob upd @@ -835,9 +835,7 @@ (de inc! (Obj Var Val) (when (num? (get Obj Var)) (dbSync) - (prog2 - (touch Obj) - (inc (prop Obj Var) (or Val 1)) + (prog1 (inc (prop Obj Var) (or Val 1)) (commit 'upd) ) ) ) (de blob! (Obj Var File) @@ -916,7 +914,6 @@ (dm inc> (Var Val) (when (num? (get This Var)) - (touch This) (let Old (get This Var) (rel> (meta This Var) This Old (inc (prop This Var) (or Val 1)) ) @@ -927,7 +924,6 @@ (dm inc!> (Var Val) (when (num? (get This Var)) (dbSync) - (touch This) (let Old (get This Var) (rel> (meta This Var) This Old (inc (prop This Var) (or Val 1)) ) @@ -938,7 +934,6 @@ (dm dec> (Var Val) (when (num? (get This Var)) - (touch This) (let Old (get This Var) (rel> (meta This Var) This Old (dec (prop This Var) (or Val 1)) ) @@ -949,7 +944,6 @@ (dm dec!> (Var Val) (when (num? (get This Var)) (dbSync) - (touch This) (let Old (get This Var) (rel> (meta This Var) This Old (dec (prop This Var) (or Val 1)) ) diff --git a/lib/tags b/lib/tags @@ -8,15 +8,15 @@ $ (2953 . "@src64/flow.l") - (2209 . "@src64/big.l") -> (3913 . "@src64/subr.l") / (2511 . "@src64/big.l") -: (2896 . "@src64/sym.l") -:: (2920 . "@src64/sym.l") -; (2822 . "@src64/sym.l") +: (2916 . "@src64/sym.l") +:: (2940 . "@src64/sym.l") +; (2842 . "@src64/sym.l") < (2207 . "@src64/subr.l") <= (2237 . "@src64/subr.l") <> (2144 . "@src64/subr.l") = (2115 . "@src64/subr.l") =0 (2173 . "@src64/subr.l") -=: (2851 . "@src64/sym.l") +=: (2871 . "@src64/sym.l") == (2059 . "@src64/subr.l") ==== (965 . "@src64/sym.l") =T (2181 . "@src64/subr.l") @@ -138,7 +138,7 @@ fish (1613 . "@src64/apply.l") flg? (2445 . "@src64/subr.l") flip (1699 . "@src64/subr.l") flush (5070 . "@src64/io.l") -fold (3341 . "@src64/sym.l") +fold (3371 . "@src64/sym.l") for (2222 . "@src64/flow.l") fork (3256 . "@src64/flow.l") format (2089 . "@src64/big.l") @@ -148,9 +148,9 @@ full (1075 . "@src64/subr.l") fun? (732 . "@src64/sym.l") gc (432 . "@src64/gc.l") ge0 (2705 . "@src64/big.l") -get (2748 . "@src64/sym.l") +get (2766 . "@src64/sym.l") getd (740 . "@src64/sym.l") -getl (3030 . "@src64/sym.l") +getl (3060 . "@src64/sym.l") glue (1232 . "@src64/sym.l") gt0 (2716 . "@src64/big.l") hash (2974 . "@src64/big.l") @@ -190,8 +190,8 @@ lit (155 . "@src64/flow.l") load (4133 . "@src64/io.l") lock (1182 . "@src64/db.l") loop (2165 . "@src64/flow.l") -low? (3213 . "@src64/sym.l") -lowc (3243 . "@src64/sym.l") +low? (3243 . "@src64/sym.l") +lowc (3273 . "@src64/sym.l") lst? (2415 . "@src64/subr.l") lt0 (2680 . "@src64/big.l") lup (2224 . "@src64/sym.l") @@ -210,7 +210,7 @@ max (2327 . "@src64/subr.l") maxi (1511 . "@src64/apply.l") member (2455 . "@src64/subr.l") memq (2477 . "@src64/subr.l") -meta (3133 . "@src64/sym.l") +meta (3163 . "@src64/sym.l") meth (1084 . "@src64/flow.l") method (1048 . "@src64/flow.l") min (2356 . "@src64/subr.l") @@ -265,13 +265,13 @@ prior (2713 . "@src64/subr.l") prog (1752 . "@src64/flow.l") prog1 (1760 . "@src64/flow.l") prog2 (1777 . "@src64/flow.l") -prop (2779 . "@src64/sym.l") +prop (2797 . "@src64/sym.l") protect (517 . "@src64/main.l") prove (3527 . "@src64/subr.l") push (1686 . "@src64/sym.l") push1 (1722 . "@src64/sym.l") -put (2696 . "@src64/sym.l") -putl (2948 . "@src64/sym.l") +put (2714 . "@src64/sym.l") +putl (2978 . "@src64/sym.l") pwd (2675 . "@src64/main.l") queue (1918 . "@src64/sym.l") quit (1090 . "@src64/main.l") @@ -333,8 +333,8 @@ unify (3935 . "@src64/subr.l") unless (1893 . "@src64/flow.l") until (2077 . "@src64/flow.l") up (698 . "@src64/main.l") -upp? (3228 . "@src64/sym.l") -uppc (3292 . "@src64/sym.l") +upp? (3258 . "@src64/sym.l") +uppc (3322 . "@src64/sym.l") use (1565 . "@src64/flow.l") usec (2663 . "@src64/main.l") val (1461 . "@src64/sym.l") @@ -342,7 +342,7 @@ version (3048 . "@src64/main.l") wait (3118 . "@src64/io.l") when (1876 . "@src64/flow.l") while (2053 . "@src64/flow.l") -wipe (3088 . "@src64/sym.l") +wipe (3118 . "@src64/sym.l") with (1322 . "@src64/flow.l") wr (5195 . "@src64/io.l") xchg (1536 . "@src64/sym.l") diff --git a/src/sym.c b/src/sym.c @@ -1,4 +1,4 @@ -/* 25oct10abu +/* 14jul11abu * (c) Software Lab. Alexander Burger */ @@ -1056,28 +1056,29 @@ any get(any x, any key) { any prop(any x, any key) { any y, z; - if (!isCell(y = tail1(x))) - return Nil; - if (!isCell(car(y))) { - if (key == car(y)) - return key; - } - else if (key == cdar(y)) - return car(y); - while (isCell(z = cdr(y))) { - if (!isCell(car(z))) { - if (key == car(z)) { - cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + if (isCell(y = tail1(x))) { + if (!isCell(car(y))) { + if (key == car(y)) return key; - } } - else if (key == cdar(z)) { - cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); - return car(z); + else if (key == cdar(y)) + return car(y); + while (isCell(z = cdr(y))) { + if (!isCell(car(z))) { + if (key == car(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return key; + } + } + else if (key == cdar(z)) { + cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); + return car(z); + } + y = z; } - y = z; } - return Nil; + Tail(x, cons(y = cons(Nil,key), tail1(x))); + return y; } // (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any @@ -1131,7 +1132,7 @@ any doGet(any ex) { return Pop(c1); } -// (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym +// (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var any doProp(any ex) { any x; cell c1, c2; @@ -1149,7 +1150,8 @@ any doProp(any ex) { data(c2) = EVAL(car(x)); } NeedSym(ex,data(c1)); - Fetch(ex,data(c1)); + CheckNil(ex,data(c1)); + Touch(ex,data(c1)); return prop(Pop(c1), data(c2)); } @@ -1224,7 +1226,7 @@ any doCol(any ex) { return y; } -// (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym +// (:: sym|0 [sym1|cnt .. sym2]) -> var any doPropCol(any ex) { any x, y; @@ -1242,6 +1244,9 @@ any doPropCol(any ex) { } } } + NeedSym(ex,y); + CheckNil(ex,y); + Touch(ex,y); return prop(y, car(x)); } diff --git a/src/vers.h b/src/vers.h @@ -1 +1 @@ -static byte Version[4] = {3,0,7,2}; +static byte Version[4] = {3,0,7,3}; diff --git a/src64/sym.l b/src64/sym.l @@ -1,4 +1,4 @@ -# 28mar11abu +# 14jul11abu # (c) Software Lab. Alexander Burger ### Compare long names ### @@ -2622,73 +2622,91 @@ ret (code 'propEC_E 0) - ld A (E TAIL) # Get tail - num A # No properties? - jnz retNil # Return NIL - off A SYM # Clear 'extern' tag - atom (A) # First property atomic? - if nz # Yes - cmp C (A) # Found flag? - if eq # Yes - ld E C # Return key - ret - end - else - cmp C ((A) CDR) # Found property? - if eq # Yes - ld E (A) # Return property - ret - end - end push X - do - ld X (A CDR) # Next property - atom X # Any? - while z # Yes - atom (X) # Atomic? + ld A (E TAIL) # Get tail + num A # Properties? + if z # Yes + off A SYM # Clear 'extern' tag + atom (A) # First property atomic? if nz # Yes - cmp C (X) # Found flag? + cmp C (A) # Found flag? if eq # Yes - ld (A CDR) (X CDR) # Unlink cell - ld A (E TAIL) # Get tail - sym A # Extern? - if z # No - ld (X CDR) A # Insert cell in front - else - off A SYM # Clear 'extern' tag - ld (X CDR) A # Insert cell in front - or X SYM # Set 'extern' tag - end - ld (E TAIL) X ld E C # Return key pop X ret end else - cmp C ((X) CDR) # Found property? + cmp C ((A) CDR) # Found property? if eq # Yes - ld (A CDR) (X CDR) # Unlink cell - ld A (E TAIL) # Get tail - sym A # Extern? - if z # No - ld (X CDR) A # Insert cell in front - ld (E TAIL) X - ld E (X) # Return property - else - off A SYM # Clear 'extern' tag - ld (X CDR) A # Insert cell in front - ld A (X) # Return property - or X SYM # Set 'extern' tag - ld (E TAIL) X - ld E A - end + ld E (A) # Return property pop X ret end end - ld A X - loop - ld E Nil # Return NIL + do + ld X (A CDR) # Next property + atom X # Any? + while z # Yes + atom (X) # Atomic? + if nz # Yes + cmp C (X) # Found flag? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + or X SYM # Set 'extern' tag + end + ld (E TAIL) X + ld E C # Return key + pop X + ret + end + else + cmp C ((X) CDR) # Found property? + if eq # Yes + ld (A CDR) (X CDR) # Unlink cell + ld A (E TAIL) # Get tail + sym A # Extern? + if z # No + ld (X CDR) A # Insert cell in front + ld (E TAIL) X + ld E (X) # Return property + else + off A SYM # Clear 'extern' tag + ld (X CDR) A # Insert cell in front + ld A (X) # Return property + or X SYM # Set 'extern' tag + ld (E TAIL) X + ld E A + end + pop X + ret + end + end + ld A X + loop + end + call cons_A # New property cell + ld (A) Nil # (NIL . key) + ld (A CDR) C + call consA_C # New first property + ld (C) A + ld X (E TAIL) # Get tail + sym X # Extern? + if z # No + ld (C CDR) X + else + off X SYM # Clear 'extern' tag + ld (C CDR) X + or C SYM # Set 'extern' tag + end + ld (E TAIL) C # Set new tail + ld E A # Return first (new) cell pop X ret @@ -2775,7 +2793,7 @@ pop X ret -# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> lst|sym +# (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var (code 'doProp 2) push X push Y @@ -2807,9 +2825,11 @@ jnz symErrEX sym E jz symErrEX + cmp E Nil # Can't be NIL + jeq protErrEX sym (E TAIL) # External symbol? if nz # Yes - call dbFetchEX # Fetch it + call dbTouchEX # Touch it end ld C (L I) # Get key call propEC_E @@ -2916,7 +2936,7 @@ pop X ret -# (:: sym|0 [sym1|cnt .. sym2]) -> lst|sym +# (:: sym|0 [sym1|cnt .. sym2]) -> var (code 'doPropCol 2) push X push Y @@ -2939,6 +2959,16 @@ call getnECX_E loop end + num E # Need symbol + jnz symErrEX + sym E + jz symErrEX + cmp E Nil # Can't be NIL + jeq protErrEX + sym (E TAIL) # External symbol? + if nz # Yes + call dbTouchEX # Touch it + end call propEC_E pop Y pop X diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 08jul11abu +# 14jul11abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 7 2) +(de *Version 3 0 7 3) # vi:et:ts=3:sw=3 diff --git a/test/src/sym.l b/test/src/sym.l @@ -1,4 +1,4 @@ -# 09sep09abu +# 13jul11abu # (c) Software Lab. Alexander Burger ### name ### @@ -267,6 +267,7 @@ (put A 'x 1) (put B 'a 'y 2) (put C 0 -1 'a 'z 3) + (test '(NIL . p) (prop 'A 'p)) (test 1 (get A 'x)) (test 1 (; A x)) (test 2 (with A (: y))) @@ -281,6 +282,9 @@ (test 3 (get C 0 1 'z)) (test 3 (get C 0 -1 'a 'z)) (test 3 (; C 0 -1 a z)) + (test 1 (push (prop 'A 'p) 1)) + (test 1 (with 'A (pop (:: p)))) + (test NIL (get 'A 'p)) (test (3 . z) (prop C 0 -1 'a 'z)) (test 9 (with C (=: 0 -1 a z (* 3 3)))) (test (9 . z) (with C (:: 0 -1 a z)))