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 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:
Mersatz/fun.src | 7+++++--
Mersatz/picolisp.jar | 0
Mlib/tags | 110++++++++++++++++++++++++++++++++++++++++----------------------------------------
Msrc/ht.c | 4++--
Msrc/io.c | 6+++---
Msrc/pico.h | 5+++--
Msrc/sym.c | 37++++++++++++++++++++++++-------------
Msrc64/sym.l | 18++++++++++++++----
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