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 eb37bc9703be0487641f0340492fea9402512a1b
parent 41693ab7a04bf821052b902eedc21cc829503f42
Author: Alexander Burger <abu@software-lab.de>
Date:   Tue,  1 Mar 2011 11:59:35 +0100

T Simplified equal()
Diffstat:
Mersatz/picolisp.jar | 0
Mersatz/sys.src | 13+++++++------
Mlib/tags | 42+++++++++++++++++++++---------------------
Msrc/main.c | 77+++++++++++++++++++++++++++++++++++++----------------------------------------
Msrc64/main.l | 10++--------
Msrc64/version.l | 4++--
6 files changed, 69 insertions(+), 77 deletions(-)

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 @@ -// 06feb11abu +// 01mar11abu // (c) Software Lab. Alexander Burger import java.util.*; @@ -2623,18 +2623,17 @@ public class PicoLisp { final boolean equal(Any x) { if (!(x instanceof Cell)) return false; + if (!x.Car.equal(Car)) + return false; HashSet<Any> mark = new HashSet<Any>(); Any y = this, a = x, b = y; for (;;) { - if (!x.Car.equal(y.Car)) - return false; if (!(x.Cdr instanceof Cell)) return x.Cdr.equal(y.Cdr); if (!(y.Cdr instanceof Cell)) return false; - mark.add(x); x = x.Cdr; - mark.add(y); y = y.Cdr; - if (mark.contains(x) || mark.contains(y)) { + mark.add(x); x = x.Cdr; y = y.Cdr; + if (mark.contains(x)) { for (;;) { if (a == x) return b == y; @@ -2643,6 +2642,8 @@ public class PicoLisp { a = a.Cdr; b = b.Cdr; } } + if (!x.Car.equal(y.Car)) + return false; } } diff --git a/lib/tags b/lib/tags @@ -32,9 +32,9 @@ and (1621 . "@src64/flow.l") any (3879 . "@src64/io.l") append (1338 . "@src64/subr.l") apply (713 . "@src64/apply.l") -arg (2264 . "@src64/main.l") -args (2240 . "@src64/main.l") -argv (2885 . "@src64/main.l") +arg (2258 . "@src64/main.l") +args (2234 . "@src64/main.l") +argv (2879 . "@src64/main.l") as (146 . "@src64/flow.l") asoq (3001 . "@src64/subr.l") assoc (2966 . "@src64/subr.l") @@ -65,7 +65,7 @@ call (3090 . "@src64/flow.l") car (5 . "@src64/subr.l") case (1962 . "@src64/flow.l") catch (2464 . "@src64/flow.l") -cd (2640 . "@src64/main.l") +cd (2634 . "@src64/main.l") cdaaar (464 . "@src64/subr.l") cdaadr (487 . "@src64/subr.l") cdaar (179 . "@src64/subr.l") @@ -88,7 +88,7 @@ circ (816 . "@src64/subr.l") circ? (2398 . "@src64/subr.l") clip (1795 . "@src64/subr.l") close (4267 . "@src64/io.l") -cmd (2867 . "@src64/main.l") +cmd (2861 . "@src64/main.l") cnt (1413 . "@src64/apply.l") co (2546 . "@src64/flow.l") commit (1496 . "@src64/db.l") @@ -99,9 +99,9 @@ connect (201 . "@src64/net.l") cons (747 . "@src64/subr.l") copy (1225 . "@src64/subr.l") ctl (4207 . "@src64/io.l") -ctty (2665 . "@src64/main.l") +ctty (2659 . "@src64/main.l") cut (1797 . "@src64/sym.l") -date (2379 . "@src64/main.l") +date (2373 . "@src64/main.l") dbck (2105 . "@src64/db.l") de (531 . "@src64/flow.l") dec (2323 . "@src64/big.l") @@ -111,7 +111,7 @@ del (1852 . "@src64/sym.l") delete (1401 . "@src64/subr.l") delq (1452 . "@src64/subr.l") diff (2585 . "@src64/subr.l") -dir (2798 . "@src64/main.l") +dir (2792 . "@src64/main.l") dm (543 . "@src64/flow.l") do (2138 . "@src64/flow.l") e (2920 . "@src64/flow.l") @@ -119,7 +119,7 @@ echo (4298 . "@src64/io.l") env (615 . "@src64/main.l") eof (3438 . "@src64/io.l") eol (3429 . "@src64/io.l") -errno (1375 . "@src64/main.l") +errno (1369 . "@src64/main.l") eval (182 . "@src64/flow.l") ext (5028 . "@src64/io.l") ext? (1034 . "@src64/sym.l") @@ -127,7 +127,7 @@ extern (900 . "@src64/sym.l") extra (1263 . "@src64/flow.l") extract (1218 . "@src64/apply.l") fifo (1963 . "@src64/sym.l") -file (2745 . "@src64/main.l") +file (2739 . "@src64/main.l") fill (3236 . "@src64/subr.l") filter (1161 . "@src64/apply.l") fin (2029 . "@src64/subr.l") @@ -164,7 +164,7 @@ ifn (1862 . "@src64/flow.l") in (4103 . "@src64/io.l") inc (2256 . "@src64/big.l") index (2633 . "@src64/subr.l") -info (2702 . "@src64/main.l") +info (2696 . "@src64/main.l") intern (875 . "@src64/sym.l") ipid (3209 . "@src64/flow.l") isa (959 . "@src64/flow.l") @@ -181,7 +181,7 @@ lieu (1156 . "@src64/db.l") line (3613 . "@src64/io.l") lines (3766 . "@src64/io.l") link (1172 . "@src64/subr.l") -lisp (1942 . "@src64/main.l") +lisp (1936 . "@src64/main.l") list (887 . "@src64/subr.l") listen (151 . "@src64/net.l") lit (157 . "@src64/flow.l") @@ -220,10 +220,10 @@ n== (2083 . "@src64/subr.l") nT (2194 . "@src64/subr.l") name (499 . "@src64/sym.l") nand (1656 . "@src64/flow.l") -native (1383 . "@src64/main.l") +native (1377 . "@src64/main.l") need (919 . "@src64/subr.l") new (833 . "@src64/flow.l") -next (2247 . "@src64/main.l") +next (2241 . "@src64/main.l") nil (1739 . "@src64/flow.l") nond (1939 . "@src64/flow.l") nor (1677 . "@src64/flow.l") @@ -237,7 +237,7 @@ onOff (1613 . "@src64/sym.l") one (1646 . "@src64/sym.l") open (4229 . "@src64/io.l") opid (3225 . "@src64/flow.l") -opt (2988 . "@src64/main.l") +opt (2982 . "@src64/main.l") or (1637 . "@src64/flow.l") out (4123 . "@src64/io.l") pack (1144 . "@src64/sym.l") @@ -270,9 +270,9 @@ push (1688 . "@src64/sym.l") push1 (1724 . "@src64/sym.l") put (2698 . "@src64/sym.l") putl (2950 . "@src64/sym.l") -pwd (2629 . "@src64/main.l") +pwd (2623 . "@src64/main.l") queue (1920 . "@src64/sym.l") -quit (1092 . "@src64/main.l") +quit (1086 . "@src64/main.l") quote (141 . "@src64/flow.l") rand (2973 . "@src64/big.l") range (997 . "@src64/subr.l") @@ -281,7 +281,7 @@ raw (458 . "@src64/main.l") rd (5045 . "@src64/io.l") read (2573 . "@src64/io.l") replace (1499 . "@src64/subr.l") -rest (2293 . "@src64/main.l") +rest (2287 . "@src64/main.l") reverse (1674 . "@src64/subr.l") rewind (5011 . "@src64/io.l") rollback (1890 . "@src64/db.l") @@ -322,7 +322,7 @@ text (1272 . "@src64/sym.l") throw (2490 . "@src64/flow.l") tick (3177 . "@src64/flow.l") till (3524 . "@src64/io.l") -time (2512 . "@src64/main.l") +time (2506 . "@src64/main.l") touch (1049 . "@src64/sym.l") trim (1755 . "@src64/subr.l") try (1172 . "@src64/flow.l") @@ -335,9 +335,9 @@ up (706 . "@src64/main.l") upp? (3230 . "@src64/sym.l") uppc (3294 . "@src64/sym.l") use (1570 . "@src64/flow.l") -usec (2617 . "@src64/main.l") +usec (2611 . "@src64/main.l") val (1463 . "@src64/sym.l") -version (3002 . "@src64/main.l") +version (2996 . "@src64/main.l") wait (3064 . "@src64/io.l") when (1881 . "@src64/flow.l") while (2058 . "@src64/flow.l") diff --git a/src/main.c b/src/main.c @@ -1,4 +1,4 @@ -/* 18jan11abu +/* 01mar11abu * (c) Software Lab. Alexander Burger */ @@ -370,6 +370,9 @@ any circ(any x) { /* Comparisons */ bool equal(any x, any y) { + any a, b; + bool res; + for (;;) { if (x == y) return YES; @@ -377,54 +380,48 @@ bool equal(any x, any y) { if (!isNum(y) || unDig(x) != unDig(y)) return NO; x = cdr(numCell(x)), y = cdr(numCell(y)); + continue; } - else if (isSym(x)) { + if (isSym(x)) { if (!isSym(y) || !isNum(x = name(x)) || !isNum(y = name(y))) return NO; + continue; } - else if (!isCell(y)) + if (!isCell(y)) return NO; - else { - any a = x, b = y; - bool res = NO; - - for (;;) { - if (!equal(car(x), car(y))) - break; - if (!isCell(cdr(x))) { - res = equal(cdr(x), cdr(y)); - break; - } - if (!isCell(cdr(y))) - break; - *(word*)&car(x) |= 1, x = cdr(x); - *(word*)&car(y) |= 1, y = cdr(y); - if (num(car(x)) & 1 || num(car(y)) & 1) { - for (;;) { - if (a == x) { - res = b == y; - break; - } - if (b == y) { - res = NO; - break; - } - *(word*)&car(a) &= ~1, a = cdr(a); - *(word*)&car(b) &= ~1, b = cdr(b); + a = x, b = y; + res = NO; + for (;;) { + if (!equal(car(x), car(y))) + break; + if (!isCell(cdr(x))) { + res = equal(cdr(x), cdr(y)); + break; + } + if (!isCell(cdr(y))) + break; + *(word*)&car(x) |= 1, x = cdr(x), y = cdr(y); + if (num(car(x)) & 1) { + for (;;) { + if (a == x) { + res = b == y; + break; + } + if (b == y) { + res = NO; + break; } - do { - *(word*)&car(a) &= ~1, a = cdr(a); - *(word*)&car(b) &= ~1, b = cdr(b); - } while (a != x); - return res; + *(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b); } + do + *(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b); + while (a != x); + return res; } - while (a != x) { - *(word*)&car(a) &= ~1, a = cdr(a); - *(word*)&car(b) &= ~1, b = cdr(b); - } - return res; } + while (a != x) + *(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b); + return res; } } diff --git a/src64/main.l b/src64/main.l @@ -1,4 +1,4 @@ -# 26feb11abu +# 01mar11abu # (c) Software Lab. Alexander Burger ### Global return labels ### @@ -859,13 +859,10 @@ break nz # Yes: 'ne' or (A) 1 # Mark ld A (A CDR) - or (E) 1 ld E (E CDR) test (A) 1 # Detected circularity? - jnz 10 # Yes - test (E) 1 if nz -10 do + do cmp X A # Skip non-circular parts if eq # Done? cmp Y E # Set result @@ -878,14 +875,12 @@ end off (X) 1 # Unmark ld X (X CDR) - off (Y) 1 ld Y (Y CDR) loop push F # Save result do off (X) 1 # Unmark circular part ld X (X CDR) - off (Y) 1 ld Y (Y CDR) cmp X A until eq @@ -901,7 +896,6 @@ while ne off (X) 1 # Unmark ld X (X CDR) - off (Y) 1 ld Y (Y CDR) loop pop F # Get result diff --git a/src64/version.l b/src64/version.l @@ -1,6 +1,6 @@ -# 28feb11abu +# 01mar11abu # (c) Software Lab. Alexander Burger -(de *Version 3 0 5 18) +(de *Version 3 0 5 19) # vi:et:ts=3:sw=3