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:
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)))
