commit 2905ac117d70ba6ac8078c33dfb9bd79ad400fd2
parent af8ac696f621360eb8975476298d52b4eb268e15
Author: Alexander Burger <abu@software-lab.de>
Date: Sat, 23 Jul 2011 07:56:37 +0200
Clean up transient symtab during rename
Diffstat:
8 files changed, 106 insertions(+), 81 deletions(-)
diff --git a/ersatz/fun.src b/ersatz/fun.src
@@ -1,4 +1,4 @@
-# 14jul11abu
+# 22jul11abu
# (c) Software Lab. Alexander Burger
# Ersatz PicoLisp Functions
@@ -1638,6 +1638,8 @@ name (x y s)
return mkStr(y.name());
if ((s = ((Symbol)y)).Name != null && Intern.get(s.Name) == s)
err(ex, s, "Can't rename");
+ if (Transient.get(((Symbol)y).Name) == y)
+ Transient.remove(((Symbol)y).Name);
s.Name = ((Symbol)(x = x.Car.eval())).Name;
return s;
@@ -1697,7 +1699,8 @@ ext? T
# (zap 'sym) -> sym
zap (s)
s = (Symbol)ex.Cdr.Car.eval();
- Intern.remove(s.name());
+ if (Intern.get(s.Name) == s)
+ Intern.remove(s.Name);
return s;
# (chop 'any) -> lst
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib/tags b/lib/tags
@@ -8,17 +8,17 @@ $ (2953 . "@src64/flow.l")
- (2209 . "@src64/big.l")
-> (3913 . "@src64/subr.l")
/ (2511 . "@src64/big.l")
-: (2916 . "@src64/sym.l")
-:: (2940 . "@src64/sym.l")
-; (2842 . "@src64/sym.l")
+: (2926 . "@src64/sym.l")
+:: (2950 . "@src64/sym.l")
+; (2852 . "@src64/sym.l")
< (2207 . "@src64/subr.l")
<= (2237 . "@src64/subr.l")
<> (2144 . "@src64/subr.l")
= (2115 . "@src64/subr.l")
=0 (2173 . "@src64/subr.l")
-=: (2871 . "@src64/sym.l")
+=: (2881 . "@src64/sym.l")
== (2059 . "@src64/subr.l")
-==== (965 . "@src64/sym.l")
+==== (975 . "@src64/sym.l")
=T (2181 . "@src64/subr.l")
> (2267 . "@src64/subr.l")
>= (2297 . "@src64/subr.l")
@@ -27,7 +27,7 @@ abs (2729 . "@src64/big.l")
accept (139 . "@src64/net.l")
adr (595 . "@src64/main.l")
alarm (472 . "@src64/main.l")
-all (770 . "@src64/sym.l")
+all (780 . "@src64/sym.l")
and (1616 . "@src64/flow.l")
any (3933 . "@src64/io.l")
append (1338 . "@src64/subr.l")
@@ -44,7 +44,7 @@ bind (1354 . "@src64/flow.l")
bit? (2746 . "@src64/big.l")
bool (1716 . "@src64/flow.l")
box (819 . "@src64/flow.l")
-box? (997 . "@src64/sym.l")
+box? (1007 . "@src64/sym.l")
by (1669 . "@src64/apply.l")
bye (3430 . "@src64/flow.l")
caaaar (271 . "@src64/subr.l")
@@ -83,7 +83,7 @@ cddr (79 . "@src64/subr.l")
cdr (17 . "@src64/subr.l")
chain (1141 . "@src64/subr.l")
char (3415 . "@src64/io.l")
-chop (1091 . "@src64/sym.l")
+chop (1101 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
circ? (2402 . "@src64/subr.l")
clip (1799 . "@src64/subr.l")
@@ -100,14 +100,14 @@ cons (747 . "@src64/subr.l")
copy (1225 . "@src64/subr.l")
ctl (4216 . "@src64/io.l")
ctty (2711 . "@src64/main.l")
-cut (1795 . "@src64/sym.l")
+cut (1805 . "@src64/sym.l")
date (2425 . "@src64/main.l")
dbck (2104 . "@src64/db.l")
de (529 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
def (453 . "@src64/flow.l")
-default (1659 . "@src64/sym.l")
-del (1850 . "@src64/sym.l")
+default (1669 . "@src64/sym.l")
+del (1860 . "@src64/sym.l")
delete (1401 . "@src64/subr.l")
delq (1452 . "@src64/subr.l")
diff (2589 . "@src64/subr.l")
@@ -123,11 +123,11 @@ err (4196 . "@src64/io.l")
errno (1375 . "@src64/main.l")
eval (180 . "@src64/flow.l")
ext (5095 . "@src64/io.l")
-ext? (1032 . "@src64/sym.l")
-extern (898 . "@src64/sym.l")
+ext? (1042 . "@src64/sym.l")
+extern (908 . "@src64/sym.l")
extra (1259 . "@src64/flow.l")
extract (1218 . "@src64/apply.l")
-fifo (1961 . "@src64/sym.l")
+fifo (1971 . "@src64/sym.l")
file (2791 . "@src64/main.l")
fill (3240 . "@src64/subr.l")
filter (1161 . "@src64/apply.l")
@@ -138,20 +138,20 @@ fish (1613 . "@src64/apply.l")
flg? (2445 . "@src64/subr.l")
flip (1699 . "@src64/subr.l")
flush (5070 . "@src64/io.l")
-fold (3371 . "@src64/sym.l")
+fold (3381 . "@src64/sym.l")
for (2222 . "@src64/flow.l")
fork (3256 . "@src64/flow.l")
format (2089 . "@src64/big.l")
free (2046 . "@src64/db.l")
from (3511 . "@src64/io.l")
full (1075 . "@src64/subr.l")
-fun? (732 . "@src64/sym.l")
+fun? (742 . "@src64/sym.l")
gc (432 . "@src64/gc.l")
ge0 (2705 . "@src64/big.l")
-get (2766 . "@src64/sym.l")
-getd (740 . "@src64/sym.l")
-getl (3060 . "@src64/sym.l")
-glue (1232 . "@src64/sym.l")
+get (2776 . "@src64/sym.l")
+getd (750 . "@src64/sym.l")
+getl (3070 . "@src64/sym.l")
+glue (1242 . "@src64/sym.l")
gt0 (2716 . "@src64/big.l")
hash (2974 . "@src64/big.l")
head (1820 . "@src64/subr.l")
@@ -159,7 +159,7 @@ heap (527 . "@src64/main.l")
hear (3196 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1025 . "@src64/db.l")
-idx (2035 . "@src64/sym.l")
+idx (2045 . "@src64/sym.l")
if (1797 . "@src64/flow.l")
if2 (1816 . "@src64/flow.l")
ifn (1857 . "@src64/flow.l")
@@ -167,7 +167,7 @@ in (4156 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2637 . "@src64/subr.l")
info (2748 . "@src64/main.l")
-intern (873 . "@src64/sym.l")
+intern (883 . "@src64/sym.l")
ipid (3201 . "@src64/flow.l")
isa (956 . "@src64/flow.l")
job (1421 . "@src64/flow.l")
@@ -190,11 +190,11 @@ lit (155 . "@src64/flow.l")
load (4133 . "@src64/io.l")
lock (1182 . "@src64/db.l")
loop (2165 . "@src64/flow.l")
-low? (3243 . "@src64/sym.l")
-lowc (3273 . "@src64/sym.l")
+low? (3253 . "@src64/sym.l")
+lowc (3283 . "@src64/sym.l")
lst? (2415 . "@src64/subr.l")
lt0 (2680 . "@src64/big.l")
-lup (2224 . "@src64/sym.l")
+lup (2234 . "@src64/sym.l")
made (1107 . "@src64/subr.l")
make (1088 . "@src64/subr.l")
map (849 . "@src64/apply.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 (3163 . "@src64/sym.l")
+meta (3173 . "@src64/sym.l")
meth (1084 . "@src64/flow.l")
method (1048 . "@src64/flow.l")
min (2356 . "@src64/subr.l")
@@ -220,7 +220,7 @@ mmeq (2505 . "@src64/subr.l")
n0 (2189 . "@src64/subr.l")
n== (2087 . "@src64/subr.l")
nT (2198 . "@src64/subr.l")
-name (497 . "@src64/sym.l")
+name (502 . "@src64/sym.l")
nand (1651 . "@src64/flow.l")
native (1383 . "@src64/main.l")
need (919 . "@src64/subr.l")
@@ -232,30 +232,30 @@ nor (1672 . "@src64/flow.l")
not (1724 . "@src64/flow.l")
nth (685 . "@src64/subr.l")
num? (2426 . "@src64/subr.l")
-off (1596 . "@src64/sym.l")
+off (1606 . "@src64/sym.l")
offset (2677 . "@src64/subr.l")
-on (1581 . "@src64/sym.l")
-onOff (1611 . "@src64/sym.l")
-one (1644 . "@src64/sym.l")
+on (1591 . "@src64/sym.l")
+onOff (1621 . "@src64/sym.l")
+one (1654 . "@src64/sym.l")
open (4300 . "@src64/io.l")
opid (3217 . "@src64/flow.l")
opt (3034 . "@src64/main.l")
or (1632 . "@src64/flow.l")
out (4176 . "@src64/io.l")
-pack (1142 . "@src64/sym.l")
+pack (1152 . "@src64/sym.l")
pair (2394 . "@src64/subr.l")
pass (754 . "@src64/apply.l")
-pat? (718 . "@src64/sym.l")
+pat? (728 . "@src64/sym.l")
path (1237 . "@src64/io.l")
peek (3399 . "@src64/io.l")
pick (1369 . "@src64/apply.l")
pipe (4237 . "@src64/io.l")
poll (3288 . "@src64/io.l")
pool (648 . "@src64/db.l")
-pop (1771 . "@src64/sym.l")
+pop (1781 . "@src64/sym.l")
port (5 . "@src64/net.l")
pr (5178 . "@src64/io.l")
-pre? (1409 . "@src64/sym.l")
+pre? (1419 . "@src64/sym.l")
prin (4994 . "@src64/io.l")
prinl (5008 . "@src64/io.l")
print (5034 . "@src64/io.l")
@@ -265,15 +265,15 @@ prior (2713 . "@src64/subr.l")
prog (1752 . "@src64/flow.l")
prog1 (1760 . "@src64/flow.l")
prog2 (1777 . "@src64/flow.l")
-prop (2797 . "@src64/sym.l")
+prop (2807 . "@src64/sym.l")
protect (517 . "@src64/main.l")
prove (3527 . "@src64/subr.l")
-push (1686 . "@src64/sym.l")
-push1 (1722 . "@src64/sym.l")
-put (2714 . "@src64/sym.l")
-putl (2978 . "@src64/sym.l")
+push (1696 . "@src64/sym.l")
+push1 (1732 . "@src64/sym.l")
+put (2724 . "@src64/sym.l")
+putl (2988 . "@src64/sym.l")
pwd (2675 . "@src64/main.l")
-queue (1918 . "@src64/sym.l")
+queue (1928 . "@src64/sym.l")
quit (1090 . "@src64/main.l")
quote (139 . "@src64/flow.l")
rand (3001 . "@src64/big.l")
@@ -294,22 +294,22 @@ seed (2959 . "@src64/big.l")
seek (1275 . "@src64/apply.l")
send (1128 . "@src64/flow.l")
seq (1081 . "@src64/db.l")
-set (1480 . "@src64/sym.l")
-setq (1513 . "@src64/sym.l")
+set (1490 . "@src64/sym.l")
+setq (1523 . "@src64/sym.l")
sigio (488 . "@src64/main.l")
size (2806 . "@src64/subr.l")
skip (3469 . "@src64/io.l")
sort (3962 . "@src64/subr.l")
-sp? (709 . "@src64/sym.l")
+sp? (719 . "@src64/sym.l")
space (5012 . "@src64/io.l")
split (1592 . "@src64/subr.l")
stack (556 . "@src64/main.l")
state (2001 . "@src64/flow.l")
stem (1989 . "@src64/subr.l")
str (3987 . "@src64/io.l")
-str? (1011 . "@src64/sym.l")
+str? (1021 . "@src64/sym.l")
strip (1576 . "@src64/subr.l")
-sub? (1442 . "@src64/sym.l")
+sub? (1452 . "@src64/sym.l")
sum (1460 . "@src64/apply.l")
super (1215 . "@src64/flow.l")
sym (3973 . "@src64/io.l")
@@ -319,12 +319,12 @@ sys (3053 . "@src64/flow.l")
t (1743 . "@src64/flow.l")
tail (1911 . "@src64/subr.l")
tell (3228 . "@src64/io.l")
-text (1270 . "@src64/sym.l")
+text (1280 . "@src64/sym.l")
throw (2485 . "@src64/flow.l")
tick (3169 . "@src64/flow.l")
till (3578 . "@src64/io.l")
time (2558 . "@src64/main.l")
-touch (1047 . "@src64/sym.l")
+touch (1057 . "@src64/sym.l")
trim (1759 . "@src64/subr.l")
try (1169 . "@src64/flow.l")
type (909 . "@src64/flow.l")
@@ -333,23 +333,23 @@ unify (3935 . "@src64/subr.l")
unless (1893 . "@src64/flow.l")
until (2077 . "@src64/flow.l")
up (698 . "@src64/main.l")
-upp? (3258 . "@src64/sym.l")
-uppc (3322 . "@src64/sym.l")
+upp? (3268 . "@src64/sym.l")
+uppc (3332 . "@src64/sym.l")
use (1565 . "@src64/flow.l")
usec (2663 . "@src64/main.l")
-val (1461 . "@src64/sym.l")
+val (1471 . "@src64/sym.l")
version (3048 . "@src64/main.l")
wait (3118 . "@src64/io.l")
when (1876 . "@src64/flow.l")
while (2053 . "@src64/flow.l")
-wipe (3118 . "@src64/sym.l")
+wipe (3128 . "@src64/sym.l")
with (1322 . "@src64/flow.l")
wr (5195 . "@src64/io.l")
-xchg (1536 . "@src64/sym.l")
+xchg (1546 . "@src64/sym.l")
xor (1693 . "@src64/flow.l")
x| (2885 . "@src64/big.l")
yield (2709 . "@src64/flow.l")
yoke (1196 . "@src64/subr.l")
-zap (1061 . "@src64/sym.l")
-zero (1629 . "@src64/sym.l")
+zap (1071 . "@src64/sym.l")
+zero (1639 . "@src64/sym.l")
| (2845 . "@src64/big.l")
diff --git a/src/ht.c b/src/ht.c
@@ -1,4 +1,4 @@
-/* 01apr10abu
+/* 22jul11abu
* (c) Software Lab. Alexander Burger
*/
@@ -125,7 +125,7 @@ static void htFmt(any x) {
bufString(x, nm);
if (isExt(x))
Env.put('-'), htEncode(nm);
- else if (hashed(x, ihash(y), Intern))
+ else if (hashed(x, Intern[ihash(y)]))
Env.put('$'), htEncode(nm);
else if (strchr("$+-", *nm)) {
putHex(*nm);
diff --git a/src/io.c b/src/io.c
@@ -1,4 +1,4 @@
-/* 09mar11abu
+/* 22jul11abu
* (c) Software Lab. Alexander Burger
*/
@@ -403,7 +403,7 @@ void binPrint(int extn, any x) {
if (!isNum(y = name(x)))
binPrint(extn, y);
else if (!isExt(x))
- prNum(hashed(x, ihash(y), Intern)? INTERN : TRANSIENT, y);
+ prNum(hashed(x, Intern[ihash(y)])? INTERN : TRANSIENT, y);
else
prNum(EXTERN, extn? extOffs(-extn, y) : y);
}
@@ -2377,7 +2377,7 @@ void print1(any x) {
Env.put('$'), outWord(num(x)/sizeof(cell));
else if (isExt(x))
Env.put('{'), outSym(c), Env.put('}');
- else if (hashed(x, ihash(y), Intern)) {
+ else if (hashed(x, Intern[ihash(y)])) {
if (unDig(y) == '.')
Env.put('\\'), Env.put('.');
else {
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 09jul11abu
+/* 22jul11abu
* (c) Software Lab. Alexander Burger
*/
@@ -324,7 +324,7 @@ any get(any,any);
int getChar(void);
void getStdin(void);
void giveup(char*) __attribute__ ((noreturn));
-bool hashed(any,long,any*);
+bool hashed(any,any);
void heapAlloc(void);
any idx(any,any,int);
unsigned long ihash(any);
@@ -393,6 +393,7 @@ void symError(any,any) __attribute__ ((noreturn));
any symToNum(any,int,int,int);
word2 unBoxWord2(any);
void undefined(any,any);
+void unintern(any,any*);
void unwind (catchFrame*);
void varError(any,any) __attribute__ ((noreturn));
long waitFd(any,int,long);
diff --git a/src/sym.c b/src/sym.c
@@ -1,4 +1,4 @@
-/* 14jul11abu
+/* 22jul11abu
* (c) Software Lab. Alexander Burger
*/
@@ -26,12 +26,12 @@ unsigned long ehash(any x) {
return h % EHASH;
}
-bool hashed(any s, long h, any *tab) {
- any x;
-
- for (x = tab[h]; isCell(x); x = cdr(x))
+bool hashed(any s, any x) {
+ while (isCell(x)) {
if (s == car(x))
return YES;
+ x = cdr(x);
+ }
return NO;
}
@@ -61,6 +61,18 @@ any findHash(any s, any *p) {
return NULL;
}
+void unintern(any s, any *p) {
+ any x;
+
+ while (isCell(x = *p)) {
+ if (s == car(x)) {
+ *p = cdr(x);
+ return;
+ }
+ p = &x->cdr;
+ }
+}
+
/* Get symbol name */
any name(any s) {
for (s = tail1(s); isCell(s); s = cdr(s));
@@ -70,6 +82,7 @@ any name(any s) {
// (name 'sym ['sym2]) -> sym
any doName(any ex) {
any x, y, *p;
+ unsigned long n;
cell c1;
x = cdr(ex), data(c1) = EVAL(car(x));
@@ -77,11 +90,13 @@ any doName(any ex) {
y = name(data(c1));
if (!isCell(x = cdr(x)))
return isNum(y)? consStr(y) : Nil;
- if (isNil(data(c1)) || isExt(data(c1)) || hashed(data(c1), ihash(y), Intern))
+ n = ihash(y);
+ if (isNil(data(c1)) || isExt(data(c1)) || hashed(data(c1), Intern[n]))
err(ex, data(c1), "Can't rename");
Save(c1);
x = EVAL(car(x));
NeedSym(ex,x);
+ unintern(data(c1), Transient + n);
for (p = &tail(data(c1)); isCell(*p); p = &cdr(*p));
*p = name(x);
return Pop(c1);
@@ -262,7 +277,7 @@ any doBoxQ(any x) {
any doStrQ(any x) {
x = cdr(x);
return isSym(x = EVAL(car(x))) &&
- !isExt(x) && !hashed(x, ihash(name(x)), Intern)? x : Nil;
+ !isExt(x) && !hashed(x, Intern[ihash(name(x))])? x : Nil;
}
// (ext? 'any) -> sym | NIL
@@ -282,7 +297,7 @@ any doTouch(any ex) {
// (zap 'sym) -> sym
any doZap(any ex) {
- any x, y, *h;
+ any x;
x = cdr(ex), x = EVAL(car(x));
NeedSym(ex,x);
@@ -291,11 +306,7 @@ any doZap(any ex) {
else {
if (x >= Nil && x <= Bye)
protError(ex,x);
- for (h = Intern + ihash(name(x)); isCell(y = *h); h = &y->cdr)
- if (x == car(y)) {
- *h = cdr(y);
- break;
- }
+ unintern(x, Intern + ihash(name(x)));
}
return x;
}
diff --git a/src64/sym.l b/src64/sym.l
@@ -1,4 +1,4 @@
-# 14jul11abu
+# 22jul11abu
# (c) Software Lab. Alexander Burger
### Compare long names ###
@@ -350,9 +350,10 @@
loop
### Unintern a symbol ###
+# E symbol
# X name
# Y tree
-(code 'uninternXY 0)
+(code 'uninternEXY 0)
cmp X ZERO # Name?
jeq ret # No
cnt X # Short name?
@@ -365,6 +366,8 @@
call nameA_A # Get name
cmp A X # Equal?
if eq # Yes
+ cmp E (C) # Correct symbol?
+ jne Ret # No
ld A (C CDR) # Get subtrees
atom (A) # Left branch?
if nz # No
@@ -418,6 +421,8 @@
call nameA_A # Get name
call cmpLongAX_F # Equal?
if eq # Yes
+ cmp E (C) # Correct symbol?
+ jne Ret # No
ld A (C CDR) # Get subtrees
atom (A) # Left branch?
if nz # No
@@ -545,14 +550,19 @@
jz symErrEX
ld X (E TAIL)
call nameX_X # Get name
+ push X # Save new name
ld E (L I) # Get first symbol
+ ld X (E TAIL)
+ call nameX_X # Get name
+ ld Y Transient
+ call uninternEXY # Unintern
lea Y (E TAIL)
do
num (Y) # Find name
while z
lea Y ((Y) CDR)
loop
- ld (Y) X # Store name of second
+ pop (Y) # Store name of second
drop
end
pop Y
@@ -1081,7 +1091,7 @@
ld X (E TAIL)
call nameX_X # Get name
ld Y Intern
- call uninternXY # Unintern symbol
+ call uninternEXY # Unintern symbol
pop Y
end
pop X
