commit 59b9560bfb7bddea44005587fd7cb364f4c71f61
parent b6b302c5f3fb9f027b9eee3dbe4f7cc0fdb2f2e2
Author: Commit-Bot <unknown>
Date: Wed, 17 Nov 2010 15:06:37 +0000
Automatic commit from picoLisp.tgz, From: Wed, 17 Nov 2010 15:06:37 GMT
Diffstat:
17 files changed, 389 insertions(+), 310 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXdec10 picoLisp-3.0.5
+ 'circ?' function
Ersatz PicoLisp (Java) version
Bug in (rd 'cnt)
diff --git a/doc/ref.html b/doc/ref.html
@@ -1887,6 +1887,7 @@ abbreviations:
<dd><code>
<a href="refA.html#atom">atom</a>
<a href="refP.html#pair">pair</a>
+ <a href="refC.html#circ?">circ?</a>
<a href="refL.html#lst?">lst?</a>
<a href="refN.html#num?">num?</a>
<a href="refS.html#sym?">sym?</a>
diff --git a/doc/refC.html b/doc/refC.html
@@ -310,6 +310,7 @@ is returned. A list argument is returned unchanged.
<dd>Produces a circular list of all <code>any</code> arguments by <code><a
href="refC.html#cons">cons</a></code>ing them to a list and then connecting the
CDR of the last cell to the first cell. See also <code><a
+href="refC.html#circ?">circ?</a></code> and <code><a
href="refL.html#list">list</a></code>.
<pre><code>
@@ -317,6 +318,19 @@ href="refL.html#list">list</a></code>.
-> (a b c .)
</code></pre>
+<dt><a name="circ?"><code>(circ? 'any) -> any</code></a> <dd>Returs the circular
+(sub)list if <code>any</code> is a circular list, else <code>NIL</code>. See
+also <code><a href="refC.html#circ">circ</a></code>.
+
+<pre><code>
+: (circ? 'a)
+-> NIL
+: (circ? (1 2 3))
+-> NIL
+: (circ? (1 . (2 3 .)))
+-> (2 3 .)
+</code></pre>
+
<dt><a name="class"><code>(class sym . typ) -> obj</code></a>
<dd>Defines <code>sym</code> as a class with the superclass(es)
<code>typ</code>. As a side effect, the global variable <code><a
diff --git a/ersatz/fun.src b/ersatz/fun.src
@@ -1,4 +1,4 @@
-# 14nov10abu
+# 17nov10abu
# (c) Software Lab. Alexander Burger
# Ersatz PicoLisp Functions
@@ -1556,23 +1556,22 @@ sys ()
# (call 'any ..) -> flg
call (i j x)
- j = (int)(x = ex.Cdr).length();
- String[] cmd = new String[j];
- for (i = 0; i < j; ++i) {
- cmd[i] = x.Car.eval().name();
- x = x.Cdr;
- }
+ ArrayList<String> cmd = new ArrayList<String>();
+ for (x = ex.Cdr; x instanceof Cell; x = x.Cdr)
+ cmd.add(x.Car.eval().name());
try {
- Process p = Runtime.getRuntime().exec(cmd);
+ ProcessBuilder pb = new ProcessBuilder(cmd);
+ pb.redirectErrorStream(true);
+ Process p = pb.start();
BufferedReader in = new BufferedReader(new InputStreamReader(p.getInputStream()));
String line;
while ((line = in.readLine()) != null)
System.out.println(line);
- i = p.waitFor();
+ return p.waitFor() == 0? T : Nil;
}
- catch (IOException e) {System.err.println(cmd[0] + ": Can't exec");}
+ catch (IOException e) {System.err.println(cmd.get(0) + ": Can't exec");}
catch (InterruptedException e) {} //#! sighandler()
- return i == 0? T : Nil;
+ return Nil;
# (ipid) -> pid | NIL
ipid ()
@@ -2693,6 +2692,10 @@ atom ()
pair (x)
return (x = ex.Cdr.Car.eval()) instanceof Cell? x : Nil;
+# (circ? 'any) -> any
+circ? (x)
+ return (x = ex.Cdr.Car.eval()) instanceof Cell && (x = circ(x)) != null? x : Nil;
+
# (lst? 'any) -> flg
lst? (x)
return (x = ex.Cdr.Car.eval()) instanceof Cell || x == Nil? T : Nil;
@@ -3186,8 +3189,7 @@ char (x)
# (skip ['any]) -> sym
skip (c)
- c = firstChar(ex.Cdr.Car.eval());
- return InFile.skip(c) < 0? Nil : mkChar(c);
+ return InFile.skip(firstChar(ex.Cdr.Car.eval())) < 0? Nil : mkChar((char)InFile.Chr);
# (eol) -> flg
eol ()
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 @@
-// 14nov10abu
+// 17nov10abu
// (c) Software Lab. Alexander Burger
import java.util.*;
@@ -683,15 +683,13 @@ public class PicoLisp {
final static String evString(Any ex) {return ex.Car.eval().name();}
final static Any circ(Any x) {
- int m = 0;
- Any[] mark = new Any[12];
+ HashSet<Any> mark = new HashSet<Any>();
for (;;) {
- mark = append(mark, m++, x);
+ mark.add(x);
if (!((x = x.Cdr) instanceof Cell))
return null;
- for (int i = 0; i < m; ++i)
- if (mark[i] == x)
- return x;
+ if (mark.contains(x))
+ return x;
}
}
@@ -2570,36 +2568,26 @@ public class PicoLisp {
final boolean equal(Any x) {
if (!(x instanceof Cell))
return false;
- Any y = this;
- while (x.Car == Quote) {
- if (y.Car != Quote)
- return false;
- if (x == x.Cdr)
- return y == y.Cdr;
- if (y == y.Cdr)
- return false;
- if (!(x.Cdr instanceof Cell))
- return x.Cdr.equal(y.Cdr);
- x = x.Cdr;
- if (!(y.Cdr instanceof Cell))
- return false;
- y = y;
- }
- Any a = x;
- Any b = y;
+ 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);
- x = x.Cdr;
if (!(y.Cdr instanceof Cell))
return false;
- y = y.Cdr;
- if (x == a)
- return y == b;
- if (y == b)
- return false;
+ mark.add(x); x = x.Cdr;
+ mark.add(y); y = y.Cdr;
+ if (mark.contains(x) || mark.contains(y)) {
+ for (;;) {
+ if (a == x)
+ return b == y;
+ if (b == y)
+ return false;
+ a = a.Cdr; b = b.Cdr;
+ }
+ }
}
}
@@ -2627,43 +2615,29 @@ public class PicoLisp {
}
final long length() {
- long n = 1;
- Any x = this;
- while (x.Car == Quote) {
- if (x == x.Cdr)
- return -1;
+ long n = 0;
+ HashSet<Any> mark = new HashSet<Any>();
+ for (Any x = this;;) {
+ ++n;
+ mark.add(x);
if (!((x = x.Cdr) instanceof Cell))
return n;
- ++n;
- }
- Any y = x;
- while ((x = x.Cdr) instanceof Cell) {
- if (x == y)
+ if (mark.contains(x))
return -1;
- ++n;
}
- return n;
}
- final long size() {return size(this);}
- final long size(Any x) {
- long n;
- Any y;
-
- n = 1;
- while (x.Car == Quote) {
- if (x == x.Cdr || !((x = x.Cdr) instanceof Cell))
- return n;
+ final long size() {
+ long n = 0;
+ HashSet<Any> mark = new HashSet<Any>();
+ for (Any x = this;;) {
++n;
- }
- for (y = x;;) {
if (x.Car instanceof Cell)
- n += size(x.Car);
- if (!((x = x.Cdr) instanceof Cell) || x == y)
- break;
- ++n;
+ n += x.Car.size();
+ mark.add(x);
+ if (!((x = x.Cdr) instanceof Cell) || mark.contains(x))
+ return n;
}
- return n;
}
final InFrame rdOpen(Any ex) {
diff --git a/lib/tags b/lib/tags
@@ -6,7 +6,7 @@ $ (2943 . "@src64/flow.l")
*/ (2446 . "@src64/big.l")
+ (2171 . "@src64/big.l")
- (2209 . "@src64/big.l")
--> (3820 . "@src64/subr.l")
+-> (3842 . "@src64/subr.l")
/ (2511 . "@src64/big.l")
: (2898 . "@src64/sym.l")
:: (2922 . "@src64/sym.l")
@@ -29,15 +29,15 @@ adr (613 . "@src64/main.l")
alarm (487 . "@src64/main.l")
all (772 . "@src64/sym.l")
and (1621 . "@src64/flow.l")
-any (3869 . "@src64/io.l")
+any (3870 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (591 . "@src64/apply.l")
-arg (2243 . "@src64/main.l")
-args (2219 . "@src64/main.l")
-argv (2864 . "@src64/main.l")
+arg (2266 . "@src64/main.l")
+args (2242 . "@src64/main.l")
+argv (2887 . "@src64/main.l")
as (146 . "@src64/flow.l")
-asoq (2942 . "@src64/subr.l")
-assoc (2907 . "@src64/subr.l")
+asoq (2964 . "@src64/subr.l")
+assoc (2929 . "@src64/subr.l")
at (2106 . "@src64/flow.l")
atom (2372 . "@src64/subr.l")
bind (1359 . "@src64/flow.l")
@@ -65,7 +65,7 @@ call (3074 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1962 . "@src64/flow.l")
catch (2462 . "@src64/flow.l")
-cd (2619 . "@src64/main.l")
+cd (2642 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -82,12 +82,13 @@ cdddr (245 . "@src64/subr.l")
cddr (79 . "@src64/subr.l")
cdr (17 . "@src64/subr.l")
chain (1132 . "@src64/subr.l")
-char (3351 . "@src64/io.l")
+char (3352 . "@src64/io.l")
chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
+circ? (2389 . "@src64/subr.l")
clip (1786 . "@src64/subr.l")
-close (4257 . "@src64/io.l")
-cmd (2846 . "@src64/main.l")
+close (4258 . "@src64/io.l")
+cmd (2869 . "@src64/main.l")
cnt (1291 . "@src64/apply.l")
co (2544 . "@src64/flow.l")
commit (1496 . "@src64/db.l")
@@ -97,10 +98,10 @@ cond (1916 . "@src64/flow.l")
connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
-ctl (4197 . "@src64/io.l")
-ctty (2644 . "@src64/main.l")
+ctl (4198 . "@src64/io.l")
+ctty (2667 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2358 . "@src64/main.l")
+date (2381 . "@src64/main.l")
dbck (2105 . "@src64/db.l")
de (531 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
@@ -109,39 +110,39 @@ default (1661 . "@src64/sym.l")
del (1852 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
-diff (2563 . "@src64/subr.l")
-dir (2777 . "@src64/main.l")
+diff (2576 . "@src64/subr.l")
+dir (2800 . "@src64/main.l")
dm (543 . "@src64/flow.l")
do (2136 . "@src64/flow.l")
e (2904 . "@src64/flow.l")
-echo (4288 . "@src64/io.l")
+echo (4289 . "@src64/io.l")
env (625 . "@src64/main.l")
-eof (3428 . "@src64/io.l")
-eol (3419 . "@src64/io.l")
-errno (1358 . "@src64/main.l")
+eof (3429 . "@src64/io.l")
+eol (3420 . "@src64/io.l")
+errno (1381 . "@src64/main.l")
eval (182 . "@src64/flow.l")
-ext (5017 . "@src64/io.l")
+ext (5019 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
extra (1263 . "@src64/flow.l")
extract (1096 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
-file (2724 . "@src64/main.l")
-fill (3177 . "@src64/subr.l")
+file (2747 . "@src64/main.l")
+fill (3199 . "@src64/subr.l")
filter (1039 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
finally (2520 . "@src64/flow.l")
find (1200 . "@src64/apply.l")
fish (1491 . "@src64/apply.l")
-flg? (2419 . "@src64/subr.l")
+flg? (2432 . "@src64/subr.l")
flip (1686 . "@src64/subr.l")
-flush (4992 . "@src64/io.l")
+flush (4994 . "@src64/io.l")
fold (3343 . "@src64/sym.l")
for (2225 . "@src64/flow.l")
fork (3248 . "@src64/flow.l")
format (2089 . "@src64/big.l")
free (2047 . "@src64/db.l")
-from (3447 . "@src64/io.l")
+from (3448 . "@src64/io.l")
full (1066 . "@src64/subr.l")
fun? (734 . "@src64/sym.l")
gc (429 . "@src64/gc.l")
@@ -153,42 +154,42 @@ glue (1234 . "@src64/sym.l")
gt0 (2702 . "@src64/big.l")
head (1807 . "@src64/subr.l")
heap (542 . "@src64/main.l")
-hear (3130 . "@src64/io.l")
+hear (3131 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1027 . "@src64/db.l")
idx (2037 . "@src64/sym.l")
if (1802 . "@src64/flow.l")
if2 (1821 . "@src64/flow.l")
ifn (1862 . "@src64/flow.l")
-in (4093 . "@src64/io.l")
+in (4094 . "@src64/io.l")
inc (2256 . "@src64/big.l")
-index (2611 . "@src64/subr.l")
-info (2681 . "@src64/main.l")
+index (2624 . "@src64/subr.l")
+info (2704 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3193 . "@src64/flow.l")
isa (959 . "@src64/flow.l")
job (1426 . "@src64/flow.l")
journal (970 . "@src64/db.l")
-key (3278 . "@src64/io.l")
+key (3279 . "@src64/io.l")
kill (3225 . "@src64/flow.l")
last (2031 . "@src64/subr.l")
-length (2687 . "@src64/subr.l")
+length (2700 . "@src64/subr.l")
let (1476 . "@src64/flow.l")
let? (1537 . "@src64/flow.l")
lieu (1156 . "@src64/db.l")
-line (3603 . "@src64/io.l")
-lines (3756 . "@src64/io.l")
+line (3604 . "@src64/io.l")
+lines (3757 . "@src64/io.l")
link (1163 . "@src64/subr.l")
-lisp (1921 . "@src64/main.l")
+lisp (1944 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (157 . "@src64/flow.l")
-load (4070 . "@src64/io.l")
+load (4071 . "@src64/io.l")
lock (1184 . "@src64/db.l")
loop (2168 . "@src64/flow.l")
low? (3215 . "@src64/sym.l")
lowc (3245 . "@src64/sym.l")
-lst? (2389 . "@src64/subr.l")
+lst? (2402 . "@src64/subr.l")
lt0 (2680 . "@src64/big.l")
lup (2226 . "@src64/sym.l")
made (1098 . "@src64/subr.l")
@@ -201,91 +202,91 @@ mapcon (919 . "@src64/apply.l")
maplist (811 . "@src64/apply.l")
maps (668 . "@src64/apply.l")
mark (1965 . "@src64/db.l")
-match (3062 . "@src64/subr.l")
+match (3084 . "@src64/subr.l")
max (2314 . "@src64/subr.l")
maxi (1389 . "@src64/apply.l")
-member (2429 . "@src64/subr.l")
-memq (2451 . "@src64/subr.l")
+member (2442 . "@src64/subr.l")
+memq (2464 . "@src64/subr.l")
meta (3135 . "@src64/sym.l")
meth (1087 . "@src64/flow.l")
method (1051 . "@src64/flow.l")
min (2343 . "@src64/subr.l")
mini (1440 . "@src64/apply.l")
mix (1251 . "@src64/subr.l")
-mmeq (2479 . "@src64/subr.l")
+mmeq (2492 . "@src64/subr.l")
n0 (2176 . "@src64/subr.l")
n== (2074 . "@src64/subr.l")
nT (2185 . "@src64/subr.l")
name (499 . "@src64/sym.l")
nand (1656 . "@src64/flow.l")
-native (1366 . "@src64/main.l")
+native (1389 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (833 . "@src64/flow.l")
-next (2226 . "@src64/main.l")
+next (2249 . "@src64/main.l")
nil (1739 . "@src64/flow.l")
nond (1939 . "@src64/flow.l")
nor (1677 . "@src64/flow.l")
not (1729 . "@src64/flow.l")
nth (685 . "@src64/subr.l")
-num? (2400 . "@src64/subr.l")
+num? (2413 . "@src64/subr.l")
off (1598 . "@src64/sym.l")
-offset (2651 . "@src64/subr.l")
+offset (2664 . "@src64/subr.l")
on (1583 . "@src64/sym.l")
onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
-open (4219 . "@src64/io.l")
+open (4220 . "@src64/io.l")
opid (3209 . "@src64/flow.l")
-opt (2967 . "@src64/main.l")
+opt (2990 . "@src64/main.l")
or (1637 . "@src64/flow.l")
-out (4113 . "@src64/io.l")
+out (4114 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
pair (2381 . "@src64/subr.l")
pass (632 . "@src64/apply.l")
pat? (720 . "@src64/sym.l")
-path (1229 . "@src64/io.l")
-peek (3335 . "@src64/io.l")
+path (1230 . "@src64/io.l")
+peek (3336 . "@src64/io.l")
pick (1247 . "@src64/apply.l")
-pipe (4134 . "@src64/io.l")
-poll (3222 . "@src64/io.l")
+pipe (4135 . "@src64/io.l")
+poll (3223 . "@src64/io.l")
pool (648 . "@src64/db.l")
pop (1773 . "@src64/sym.l")
port (5 . "@src64/net.l")
-pr (5100 . "@src64/io.l")
+pr (5102 . "@src64/io.l")
pre? (1411 . "@src64/sym.l")
-prin (4916 . "@src64/io.l")
-prinl (4930 . "@src64/io.l")
-print (4956 . "@src64/io.l")
-println (4987 . "@src64/io.l")
-printsp (4972 . "@src64/io.l")
+prin (4918 . "@src64/io.l")
+prinl (4932 . "@src64/io.l")
+print (4958 . "@src64/io.l")
+println (4989 . "@src64/io.l")
+printsp (4974 . "@src64/io.l")
prog (1757 . "@src64/flow.l")
prog1 (1765 . "@src64/flow.l")
prog2 (1782 . "@src64/flow.l")
prop (2781 . "@src64/sym.l")
protect (532 . "@src64/main.l")
-prove (3434 . "@src64/subr.l")
+prove (3456 . "@src64/subr.l")
push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2608 . "@src64/main.l")
+pwd (2631 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
-quit (1075 . "@src64/main.l")
+quit (1098 . "@src64/main.l")
quote (141 . "@src64/flow.l")
rand (2959 . "@src64/big.l")
range (988 . "@src64/subr.l")
-rank (2970 . "@src64/subr.l")
+rank (2992 . "@src64/subr.l")
raw (465 . "@src64/main.l")
-rd (5034 . "@src64/io.l")
-read (2561 . "@src64/io.l")
+rd (5036 . "@src64/io.l")
+read (2562 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2272 . "@src64/main.l")
+rest (2295 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
-rewind (5000 . "@src64/io.l")
+rewind (5002 . "@src64/io.l")
rollback (1890 . "@src64/db.l")
rot (848 . "@src64/subr.l")
-rpc (5133 . "@src64/io.l")
+rpc (5135 . "@src64/io.l")
run (313 . "@src64/flow.l")
-sect (2515 . "@src64/subr.l")
+sect (2528 . "@src64/subr.l")
seed (2944 . "@src64/big.l")
seek (1153 . "@src64/apply.l")
send (1131 . "@src64/flow.l")
@@ -293,54 +294,54 @@ seq (1083 . "@src64/db.l")
set (1482 . "@src64/sym.l")
setq (1515 . "@src64/sym.l")
sigio (503 . "@src64/main.l")
-size (2752 . "@src64/subr.l")
-skip (3405 . "@src64/io.l")
-sort (3869 . "@src64/subr.l")
+size (2765 . "@src64/subr.l")
+skip (3406 . "@src64/io.l")
+sort (3891 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
-space (4934 . "@src64/io.l")
+space (4936 . "@src64/io.l")
split (1579 . "@src64/subr.l")
stack (571 . "@src64/main.l")
state (2006 . "@src64/flow.l")
stem (1976 . "@src64/subr.l")
-str (3923 . "@src64/io.l")
+str (3924 . "@src64/io.l")
str? (1013 . "@src64/sym.l")
strip (1563 . "@src64/subr.l")
sub? (1444 . "@src64/sym.l")
sum (1338 . "@src64/apply.l")
super (1218 . "@src64/flow.l")
-sym (3909 . "@src64/io.l")
-sym? (2408 . "@src64/subr.l")
-sync (3090 . "@src64/io.l")
+sym (3910 . "@src64/io.l")
+sym? (2421 . "@src64/subr.l")
+sync (3091 . "@src64/io.l")
sys (3045 . "@src64/flow.l")
t (1748 . "@src64/flow.l")
tail (1898 . "@src64/subr.l")
-tell (3162 . "@src64/io.l")
+tell (3163 . "@src64/io.l")
text (1272 . "@src64/sym.l")
throw (2488 . "@src64/flow.l")
tick (3161 . "@src64/flow.l")
-till (3514 . "@src64/io.l")
-time (2491 . "@src64/main.l")
+till (3515 . "@src64/io.l")
+time (2514 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1172 . "@src64/flow.l")
type (912 . "@src64/flow.l")
udp (268 . "@src64/net.l")
-unify (3842 . "@src64/subr.l")
+unify (3864 . "@src64/subr.l")
unless (1898 . "@src64/flow.l")
until (2082 . "@src64/flow.l")
up (712 . "@src64/main.l")
upp? (3230 . "@src64/sym.l")
uppc (3294 . "@src64/sym.l")
use (1570 . "@src64/flow.l")
-usec (2596 . "@src64/main.l")
+usec (2619 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2981 . "@src64/main.l")
-wait (3052 . "@src64/io.l")
+version (3004 . "@src64/main.l")
+wait (3053 . "@src64/io.l")
when (1881 . "@src64/flow.l")
while (2058 . "@src64/flow.l")
wipe (3090 . "@src64/sym.l")
with (1327 . "@src64/flow.l")
-wr (5117 . "@src64/io.l")
+wr (5119 . "@src64/io.l")
xchg (1538 . "@src64/sym.l")
xor (1698 . "@src64/flow.l")
x| (2871 . "@src64/big.l")
diff --git a/src/main.c b/src/main.c
@@ -1,4 +1,4 @@
-/* 12oct10abu
+/* 16nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -380,36 +380,48 @@ bool equal(any x, any y) {
if (!isSym(y) || !isNum(x = name(x)) || !isNum(y = name(y)))
return NO;
}
+ else if (!isCell(y))
+ return NO;
else {
- any a, b;
+ any a = x, b = y;
+ bool res = NO;
- if (!isCell(y))
- return NO;
- while (car(x) == Quote) {
- if (car(y) != Quote)
- return NO;
- if (x == cdr(x))
- return y == cdr(y);
- if (y == cdr(y))
- return NO;
- if (!isCell(x = cdr(x)))
- return equal(x, cdr(y));
- if (!isCell(y = cdr(y)))
- return NO;
- }
- a = x, b = y;
for (;;) {
if (!equal(car(x), car(y)))
- return NO;
- if (!isCell(x = cdr(x)))
- return equal(x, cdr(y));
- if (!isCell(y = cdr(y)))
- return NO;
- if (x == a)
- return y == b;
- if (y == b)
- return NO;
+ 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);
+ }
+ do {
+ *(word*)&car(a) &= ~1, a = cdr(a);
+ *(word*)&car(b) &= ~1, 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;
}
}
}
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 15oct10abu
+/* 16nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -461,6 +461,7 @@ any doChain(any);
any doChar(any);
any doChop(any);
any doCirc(any);
+any doCircQ(any);
any doClip(any);
any doClose(any);
any doCmd(any);
diff --git a/src/subr.c b/src/subr.c
@@ -1,4 +1,4 @@
-/* 22oct10abu
+/* 16nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -1048,6 +1048,12 @@ any doPair(any x) {
return isCell(x = EVAL(car(x)))? x : Nil;
}
+// (circ? 'any) -> any
+any doCircQ(any x) {
+ x = cdr(x);
+ return isCell(x = EVAL(car(x))) && (x = circ(x))? x : Nil;
+}
+
// (lst? 'any) -> flg
any doLstQ(any x) {
x = cdr(x);
@@ -1176,41 +1182,50 @@ any doLength(any x) {
for (n = 0, c = symChar(name(x)); c; ++n, c = symChar(NULL));
return boxCnt(n);
}
- n = 1;
- while (car(x) == Quote) {
- if (x == cdr(x))
- return T;
- if (!isCell(x = cdr(x)))
- return boxCnt(n);
+ for (n = 0, y = x;;) {
++n;
- }
- y = x;
- while (isCell(x = cdr(x))) {
- if (x == y)
+ *(word*)&car(y) |= 1;
+ if (!isCell(y = cdr(y))) {
+ do
+ *(word*)&car(x) &= ~1;
+ while (isCell(x = cdr(x)));
+ return boxCnt(n);
+ }
+ if (num(car(y)) & 1) {
+ while (x != y)
+ *(word*)&car(x) &= ~1, x = cdr(x);
+ do
+ *(word*)&car(x) &= ~1;
+ while (y != (x = cdr(x)));
return T;
- ++n;
+ }
}
- return boxCnt(n);
}
static int size(any x) {
int n;
any y;
- n = 1;
- while (car(x) == Quote) {
- if (x == cdr(x) || !isCell(x = cdr(x)))
- return n;
- ++n;
- }
- for (y = x;;) {
- if (isCell(car(x)))
- n += size(car(x));
- if (!isCell(x = cdr(x)) || x == y)
- break;
+ for (n = 0, y = x;;) {
++n;
+ if (isCell(car(y)))
+ n += size(car(y));
+ *(word*)&car(y) |= 1;
+ if (!isCell(y = cdr(y))) {
+ do
+ *(word*)&car(x) &= ~1;
+ while (isCell(x = cdr(x)));
+ return n;
+ }
+ if (num(car(y)) & 1) {
+ while (x != y)
+ *(word*)&car(x) &= ~1, x = cdr(x);
+ do
+ *(word*)&car(x) &= ~1;
+ while (y != (x = cdr(x)));
+ return n;
+ }
}
- return n;
}
// (size 'any) -> cnt
diff --git a/src/tab.c b/src/tab.c
@@ -1,4 +1,4 @@
-/* 30sep10abu
+/* 16nov10abu
* (c) Software Lab. Alexander Burger
*/
@@ -75,6 +75,7 @@ static symInit Symbols[] = {
{doChain, "chain"},
{doChop, "chop"},
{doCirc, "circ"},
+ {doCircQ, "circ?"},
{doClip, "clip"},
{doClose, "close"},
{doCmd, "cmd"},
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 12oct10abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -433,6 +433,7 @@
initSym NIL "min" doMin
initSym NIL "atom" doAtom
initSym NIL "pair" doPair
+ initSym NIL "circ?" doCircQ
initSym NIL "lst?" doLstQ
initSym NIL "num?" doNumQ
initSym NIL "sym?" doSymQ
diff --git a/src64/io.l b/src64/io.l
@@ -1,4 +1,4 @@
-# 07oct10abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
# Close file descriptor
@@ -919,7 +919,8 @@
push Y
ld B BEG # Begin list
call (PutBinBZ)
- call circE_XYF # Circular list?
+ ld X E # Keep list in X
+ call circE_YF # Circular?
if nz # No
do
ld E (X) # Next item
@@ -4787,7 +4788,8 @@
push Y
ld B (char "(") # Open paren
call (PutB)
- call circE_XYF # Circular list?
+ ld X E # Keep list in X
+ call circE_YF # Circular?
if nz # No
do
ld E (X) # Print CAR
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 07oct10abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -756,8 +756,7 @@
pop X
ret
-(code 'circE_XYF)
- ld X E # Return list in X
+(code 'circE_YF)
ld Y E # Keep list in Y
do
or (E) 1 # Mark
@@ -836,60 +835,84 @@
end
atom E # E atomic?
jnz ret # Yes: 'ne'
+ push X
+ push Y
+ ld X A # Keep list heads
+ ld Y E
do
- cmp (A) Quote # A quoted?
- while eq # Yes
- cmp (E) Quote # E also quoted?
- jnz ret # No: 'ne'
- cmp A (A CDR) # A circular?
- if eq # Yes
- cmp E (E CDR) # Check if E also circular
- ret
- end
- cmp E (E CDR) # E circular?
- jz retnz # Yes: 'ne'
- ld A (A CDR) # Next cells
- ld E (E CDR)
- atom A # Any?
- jnz equalAE_F # No: Compare with E's CDR
- atom E
- jnz ret # No: 'ne'
- loop
- push A # Save list heads
- push E
- do
- push (A CDR) # Save CDRs
- push (E CDR)
- ld A (A) # Recurse on CARs
- ld E (E)
+ push A # Save lists
+ push E
cmp S (StkLimit) # Stack check
jlt stkErr
+ ld A (A) # Recurse on CARs
+ ld E (E)
call equalAE_F # Equal?
- pop E # Retrieve CDRs
+ pop E # Retrieve lists
pop A
break ne # No: 'ne'
- atom A # A's CDR atomic?
+ atom (A CDR) # A's CDR atomic?
if nz # Yes
- cmp S (StkLimit) # Stack check
- jlt stkErr
+ push A # Save lists
+ push E
+ ld A (A CDR) # Recurse on CDRs
+ ld E (E CDR)
call equalAE_F # Compare with E's CDR
+ pop E # Retrieve lists
+ pop A
break T
end
- atom E # E's CDR atomic?
+ atom (E CDR) # E's CDR atomic?
break nz # Yes: 'ne'
- cmp A (S I) # A circular?
- if eq # Yes
- cmp E (S) # Return whether E is also circular
- break T
- end
- cmp E (S) # E circular?
- if eq # Yes
- clrz
- break T # 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
+ cmp X A # Skip non-circular parts
+ if eq # Done?
+ cmp Y E # Set result
+ break T
+ end
+ cmp Y E
+ if eq
+ clrz # Result "No"
+ break T
+ 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
+ pop F # Get result
+ pop Y
+ pop X
+ ret
end
loop
- pop A # Drop list heads
- pop A
+ push F # Save result
+ do
+ cmp X A # Skip non-circular part
+ while ne
+ off (X) 1 # Unmark
+ ld X (X CDR)
+ off (Y) 1
+ ld Y (Y CDR)
+ loop
+ pop F # Get result
+ pop Y
+ pop X
ret
(code 'compareAE_F 0) # C
diff --git a/src64/subr.l b/src64/subr.l
@@ -1,4 +1,4 @@
-# 10jun10abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
# (car 'var) -> any
@@ -2385,6 +2385,19 @@
jnz retNil # Yes
ret
+# (circ? 'any) -> any
+(code 'doCircQ 2)
+ ld E ((E CDR)) # Get arg
+ eval # Eval it
+ atom E # Atom?
+ jnz retNil # Yes
+ push Y
+ call circE_YF # Circular?
+ ldz E Y # Yes
+ ldnz E Nil
+ pop Y
+ ret
+
# (lst? 'any) -> flg
(code 'doLstQ 2)
ld E ((E CDR)) # Get arg
@@ -2695,33 +2708,39 @@
end
sym E # Symbol?
if z # No (list)
- push X
- push Y
- ld X E # List in X
- ld E ONE # Counter
+ ld C E # Keep list in C
+ ld A ONE # Init counter
do
- cmp X Quote
- while eq
- ld Y (X CDR) # Next cell
- cmp Y X # Circular?
- jz lengthT # Yes
- ld X Y
- atom X # Done?
- jnz 10 # Yes
- add E (hex "10") # Increment counter
- loop
- ld Y X # Keep list head
- do
- ld X (X CDR) # Next cell
- atom X # Any?
- while z # Yes
- cmp X Y # Hit head?
- jz lengthT # Yes
- add E (hex "10") # Increment counter
+ or (E) 1 # Mark
+ ld E (E CDR) # Normal list?
+ atom E
+ if nz # Yes
+ do
+ off (C) 1 # Unmark
+ ld C (C CDR)
+ atom C # Done?
+ until nz # Yes
+ ld E A # Get count
+ ret # Return length
+ end
+ test (E) 1 # Detected circularity?
+ if nz # Yes
+ do
+ cmp C E # Skip non-circular part
+ while ne
+ off (C) 1 # Unmark
+ ld C (C CDR)
+ loop
+ do
+ off (C) 1 # Unmark circular part
+ ld C (C CDR)
+ cmp C E # Done?
+ until eq # Yes
+ ld E TSym
+ ret # Return T
+ end
+ add A (hex "10") # Increment counter
loop
-10 pop Y
- pop X
- ret
end
# Symbol
cmp E Nil # NIL?
@@ -2742,12 +2761,6 @@
pop X
ret
-: lengthT
- ld E TSym # Return T
- pop Y
- pop X
- ret
-
# (size 'any) -> cnt
(code 'doSize 2)
push X
@@ -2870,20 +2883,9 @@
ret
(code 'sizeCE_C 0)
- add C (hex "10") # Increment count
+ push E # Save list
do
- cmp (E) Quote # CAR is 'quote'?
- while eq # Yes
- cmp E (E CDR) # Circular?
- jeq ret # Yes
- ld E (E CDR) # More cells?
- atom E
- jnz ret # No
add C (hex "10") # Increment count
- loop
- push X
- ld X E # Keep head in X
- do
atom (E) # Is CAR a cell?
if z # Yes
push E
@@ -2893,15 +2895,35 @@
call sizeCE_C
pop E
end
- ld E (E CDR) # More cells?
+ or (E) 1 # Mark
+ ld E (E CDR) # Normal list?
atom E
- while z # Yes
- cmp E X # Circular?
- while ne # No
- add C (hex "10") # Increment count
+ if nz # Yes
+ pop E # Get original list
+ do
+ off (E) 1 # Unmark
+ ld E (E CDR)
+ atom E # Done?
+ until nz # Yes
+ ret
+ end
+ test (E) 1 # Detected circularity?
+ if nz # Yes
+ pop A # Get original list
+ do
+ cmp A E # Skip non-circular part
+ while ne
+ off (A) 1 # Unmark
+ ld A (A CDR)
+ loop
+ do
+ off (A) 1 # Unmark circular part
+ ld A (A CDR)
+ cmp A E # Done?
+ until eq # Yes
+ ret
+ end
loop
- pop X
- ret
# (assoc 'any 'lst) -> lst
(code 'doAssoc 2)
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 15nov10abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 4 8)
+(de *Version 3 0 4 9)
# vi:et:ts=3:sw=3
diff --git a/test/src/subr.l b/test/src/subr.l
@@ -1,4 +1,4 @@
-# 07nov09abu
+# 16nov10abu
# (c) Software Lab. Alexander Burger
### c[ad]*r ###
@@ -228,6 +228,7 @@
(test T (= "a" "a"))
(test T (== "a" "a"))
(test T (= (1 (2) 3) (1 (2) 3)))
+(test T (= (1 . (2 3 .)) (1 . (2 3 .))))
### <> ###
@@ -305,6 +306,12 @@
(test (1 2 3) (pair (1 2 3)))
+### circ? ###
+(test NIL (circ? 'a))
+(test NIL (circ? (1 2 3)))
+(test (2 3 . @) (circ? (1 . (2 3 .))))
+
+
### lst? ###
(test T (lst? NIL))
(test NIL (lst? T))
@@ -383,6 +390,7 @@
(test 3 (length 123))
(test 3 (length (1 (2) 3)))
(test T (length (1 2 3 .)))
+(test T (length (1 . (2 3 .))))
### size ###
@@ -394,6 +402,7 @@
(test 3 (size (1 2 3 .)))
(test 8 (size '((1 2 3) (4 5 6))))
(test 6 (size '((1 2 .) (4 5 .))))
+(test 3 (size (1 . (2 3 .))))
### assoc ###
