commit d8c9b211f62ef0cbe88c896511f483e6faf908f7
parent 53af6e7e5107497018e37ff5a10948c2c10d2d62
Author: Commit-Bot <unknown>
Date: Wed, 21 Jul 2010 13:34:37 +0000
Automatic commit from picoLisp.tgz, From: Wed, 21 Jul 2010 13:34:37 GMT
Diffstat:
| M | lib/math64.l | | | 4 | ++-- |
| M | lib/tags | | | 122 | ++++++++++++++++++++++++++++++++++++++++---------------------------------------- |
| M | src/io.c | | | 72 | ++++++++++++++++++++++++++++++++++++++++++++++++++---------------------- |
| M | src/main.c | | | 24 | +++++++++++++++++++++++- |
| M | src/pico.h | | | 3 | ++- |
| M | src64/io.l | | | 173 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------- |
| M | src64/main.l | | | 34 | +++++++++++++++++++++++++++++++++- |
| M | src64/version.l | | | 4 | ++-- |
8 files changed, 291 insertions(+), 145 deletions(-)
diff --git a/lib/math64.l b/lib/math64.l
@@ -1,7 +1,7 @@
-# 19jun10abu
+# 21jul10abu
# (c) Software Lab. Alexander Burger
-(load "lib/native.l")
+(load "@lib/native.l")
(de log (X)
(and (gt0 X) ("log" X 1.0)) )
diff --git a/lib/tags b/lib/tags
@@ -29,12 +29,12 @@ adr (609 . "@src64/main.l")
alarm (483 . "@src64/main.l")
all (772 . "@src64/sym.l")
and (1643 . "@src64/flow.l")
-any (3764 . "@src64/io.l")
+any (3792 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (597 . "@src64/apply.l")
-arg (1999 . "@src64/main.l")
-args (1975 . "@src64/main.l")
-argv (2620 . "@src64/main.l")
+arg (2031 . "@src64/main.l")
+args (2007 . "@src64/main.l")
+argv (2652 . "@src64/main.l")
as (146 . "@src64/flow.l")
asoq (2942 . "@src64/subr.l")
assoc (2907 . "@src64/subr.l")
@@ -65,7 +65,7 @@ call (3102 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1984 . "@src64/flow.l")
catch (2484 . "@src64/flow.l")
-cd (2375 . "@src64/main.l")
+cd (2407 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -82,12 +82,12 @@ cdddr (245 . "@src64/subr.l")
cddr (79 . "@src64/subr.l")
cdr (17 . "@src64/subr.l")
chain (1132 . "@src64/subr.l")
-char (3246 . "@src64/io.l")
+char (3274 . "@src64/io.l")
chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1786 . "@src64/subr.l")
-close (4152 . "@src64/io.l")
-cmd (2602 . "@src64/main.l")
+close (4180 . "@src64/io.l")
+cmd (2634 . "@src64/main.l")
cnt (1297 . "@src64/apply.l")
co (2566 . "@src64/flow.l")
commit (1503 . "@src64/db.l")
@@ -97,10 +97,10 @@ cond (1938 . "@src64/flow.l")
connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
-ctl (4092 . "@src64/io.l")
-ctty (2400 . "@src64/main.l")
+ctl (4120 . "@src64/io.l")
+ctty (2432 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2114 . "@src64/main.l")
+date (2146 . "@src64/main.l")
dbck (2092 . "@src64/db.l")
de (549 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
@@ -110,23 +110,23 @@ del (1852 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
diff (2563 . "@src64/subr.l")
-dir (2533 . "@src64/main.l")
+dir (2565 . "@src64/main.l")
dm (561 . "@src64/flow.l")
do (2158 . "@src64/flow.l")
e (2932 . "@src64/flow.l")
-echo (4183 . "@src64/io.l")
+echo (4211 . "@src64/io.l")
env (621 . "@src64/main.l")
-eof (3323 . "@src64/io.l")
-eol (3314 . "@src64/io.l")
-errno (1316 . "@src64/main.l")
+eof (3351 . "@src64/io.l")
+eol (3342 . "@src64/io.l")
+errno (1348 . "@src64/main.l")
eval (208 . "@src64/flow.l")
-ext (4874 . "@src64/io.l")
+ext (4936 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
extra (1284 . "@src64/flow.l")
extract (1102 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
-file (2480 . "@src64/main.l")
+file (2512 . "@src64/main.l")
fill (3177 . "@src64/subr.l")
filter (1045 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
@@ -135,13 +135,13 @@ find (1206 . "@src64/apply.l")
fish (1497 . "@src64/apply.l")
flg? (2419 . "@src64/subr.l")
flip (1686 . "@src64/subr.l")
-flush (4849 . "@src64/io.l")
+flush (4911 . "@src64/io.l")
fold (3345 . "@src64/sym.l")
for (2247 . "@src64/flow.l")
fork (3269 . "@src64/flow.l")
format (2089 . "@src64/big.l")
free (2034 . "@src64/db.l")
-from (3342 . "@src64/io.l")
+from (3370 . "@src64/io.l")
full (1066 . "@src64/subr.l")
fun? (734 . "@src64/sym.l")
gc (446 . "@src64/gc.l")
@@ -153,36 +153,36 @@ glue (1234 . "@src64/sym.l")
gt0 (2702 . "@src64/big.l")
head (1807 . "@src64/subr.l")
heap (538 . "@src64/main.l")
-hear (3064 . "@src64/io.l")
+hear (3092 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1034 . "@src64/db.l")
idx (2037 . "@src64/sym.l")
if (1824 . "@src64/flow.l")
if2 (1843 . "@src64/flow.l")
ifn (1884 . "@src64/flow.l")
-in (3988 . "@src64/io.l")
+in (4016 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2611 . "@src64/subr.l")
-info (2437 . "@src64/main.l")
+info (2469 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
job (1448 . "@src64/flow.l")
journal (977 . "@src64/db.l")
-key (3173 . "@src64/io.l")
+key (3201 . "@src64/io.l")
kill (3246 . "@src64/flow.l")
last (2031 . "@src64/subr.l")
length (2687 . "@src64/subr.l")
let (1498 . "@src64/flow.l")
let? (1559 . "@src64/flow.l")
lieu (1163 . "@src64/db.l")
-line (3498 . "@src64/io.l")
-lines (3651 . "@src64/io.l")
+line (3526 . "@src64/io.l")
+lines (3679 . "@src64/io.l")
link (1163 . "@src64/subr.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
-load (3965 . "@src64/io.l")
+load (3993 . "@src64/io.l")
lock (1191 . "@src64/db.l")
loop (2190 . "@src64/flow.l")
low? (3217 . "@src64/sym.l")
@@ -217,10 +217,10 @@ n== (2074 . "@src64/subr.l")
nT (2185 . "@src64/subr.l")
name (499 . "@src64/sym.l")
nand (1678 . "@src64/flow.l")
-native (1324 . "@src64/main.l")
+native (1356 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (1982 . "@src64/main.l")
+next (2014 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -232,31 +232,31 @@ offset (2651 . "@src64/subr.l")
on (1583 . "@src64/sym.l")
onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
-open (4114 . "@src64/io.l")
+open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2723 . "@src64/main.l")
+opt (2755 . "@src64/main.l")
or (1659 . "@src64/flow.l")
-out (4008 . "@src64/io.l")
+out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
pair (2381 . "@src64/subr.l")
pass (638 . "@src64/apply.l")
pat? (720 . "@src64/sym.l")
-path (1170 . "@src64/io.l")
-peek (3230 . "@src64/io.l")
+path (1198 . "@src64/io.l")
+peek (3258 . "@src64/io.l")
pick (1253 . "@src64/apply.l")
pid (157 . "@src64/flow.l")
-pipe (4029 . "@src64/io.l")
-poll (3126 . "@src64/io.l")
+pipe (4057 . "@src64/io.l")
+poll (3154 . "@src64/io.l")
pool (657 . "@src64/db.l")
pop (1773 . "@src64/sym.l")
port (5 . "@src64/net.l")
-pr (4965 . "@src64/io.l")
+pr (5027 . "@src64/io.l")
pre? (1411 . "@src64/sym.l")
-prin (4773 . "@src64/io.l")
-prinl (4787 . "@src64/io.l")
-print (4813 . "@src64/io.l")
-println (4844 . "@src64/io.l")
-printsp (4829 . "@src64/io.l")
+prin (4835 . "@src64/io.l")
+prinl (4849 . "@src64/io.l")
+print (4875 . "@src64/io.l")
+println (4906 . "@src64/io.l")
+printsp (4891 . "@src64/io.l")
prog (1779 . "@src64/flow.l")
prog1 (1787 . "@src64/flow.l")
prog2 (1804 . "@src64/flow.l")
@@ -267,23 +267,23 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2364 . "@src64/main.l")
+pwd (2396 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
-quit (1033 . "@src64/main.l")
+quit (1065 . "@src64/main.l")
quote (141 . "@src64/flow.l")
rand (2959 . "@src64/big.l")
range (988 . "@src64/subr.l")
rank (2970 . "@src64/subr.l")
raw (461 . "@src64/main.l")
-rd (4891 . "@src64/io.l")
-read (2502 . "@src64/io.l")
+rd (4953 . "@src64/io.l")
+read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2028 . "@src64/main.l")
+rest (2060 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
-rewind (4857 . "@src64/io.l")
+rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
rot (848 . "@src64/subr.l")
-rpc (4998 . "@src64/io.l")
+rpc (5060 . "@src64/io.l")
run (331 . "@src64/flow.l")
sect (2515 . "@src64/subr.l")
seed (2944 . "@src64/big.l")
@@ -294,32 +294,32 @@ set (1482 . "@src64/sym.l")
setq (1515 . "@src64/sym.l")
sigio (499 . "@src64/main.l")
size (2752 . "@src64/subr.l")
-skip (3300 . "@src64/io.l")
+skip (3328 . "@src64/io.l")
sort (3869 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
-space (4791 . "@src64/io.l")
+space (4853 . "@src64/io.l")
split (1579 . "@src64/subr.l")
stack (567 . "@src64/main.l")
state (2028 . "@src64/flow.l")
stem (1976 . "@src64/subr.l")
-str (3818 . "@src64/io.l")
+str (3846 . "@src64/io.l")
str? (1013 . "@src64/sym.l")
strip (1563 . "@src64/subr.l")
sub? (1444 . "@src64/sym.l")
sum (1344 . "@src64/apply.l")
super (1237 . "@src64/flow.l")
-sym (3804 . "@src64/io.l")
+sym (3832 . "@src64/io.l")
sym? (2408 . "@src64/subr.l")
-sync (3026 . "@src64/io.l")
+sync (3054 . "@src64/io.l")
sys (3073 . "@src64/flow.l")
t (1770 . "@src64/flow.l")
tail (1898 . "@src64/subr.l")
-tell (3096 . "@src64/io.l")
+tell (3124 . "@src64/io.l")
text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
-till (3409 . "@src64/io.l")
-time (2247 . "@src64/main.l")
+till (3437 . "@src64/io.l")
+time (2279 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -332,15 +332,15 @@ up (708 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2352 . "@src64/main.l")
+usec (2384 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2737 . "@src64/main.l")
-wait (2988 . "@src64/io.l")
+version (2769 . "@src64/main.l")
+wait (3016 . "@src64/io.l")
when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
wipe (3090 . "@src64/sym.l")
with (1349 . "@src64/flow.l")
-wr (4982 . "@src64/io.l")
+wr (5044 . "@src64/io.l")
xchg (1538 . "@src64/sym.l")
xor (1720 . "@src64/flow.l")
x| (2871 . "@src64/big.l")
diff --git a/src/io.c b/src/io.c
@@ -1,4 +1,4 @@
-/* 03jun10abu
+/* 21jul10abu
* (c) Software Lab. Alexander Burger
*/
@@ -392,19 +392,32 @@ void binPrint(int extn, any x) {
prNum(EXTERN, extn? extOffs(-extn, y) : y);
}
else {
- y = x;
putBin(BEG);
- while (binPrint(extn, car(x)), !isNil(x = cdr(x))) {
- if (x == y) {
- putBin(DOT);
- break;
- }
- if (!isCell(x)) {
- putBin(DOT);
- binPrint(extn, x);
- return;
+ if ((y = circ(x)) == NULL) {
+ while (binPrint(extn, car(x)), !isNil(x = cdr(x))) {
+ if (!isCell(x)) {
+ putBin(DOT);
+ binPrint(extn, x);
+ return;
+ }
}
}
+ else if (y == x) {
+ do
+ binPrint(extn, car(x));
+ while (y != (x = cdr(x)));
+ putBin(DOT);
+ }
+ else {
+ do
+ binPrint(extn, car(x));
+ while (y != (x = cdr(x)));
+ putBin(DOT), putBin(BEG);
+ do
+ binPrint(extn, car(x));
+ while (y != (x = cdr(x)));
+ putBin(DOT), putBin(END);
+ }
putBin(END);
}
}
@@ -2283,19 +2296,34 @@ void print1(any x) {
else if (car(x) == Quote && x != cdr(x))
Env.put('\''), print1(cdr(x));
else {
- any y = x;
+ any y;
+
Env.put('(');
- while (print1(car(x)), !isNil(x = cdr(x))) {
- if (x == y) {
- outString(" .");
- break;
- }
- if (!isCell(x)) {
- outString(" . ");
- print1(x);
- break;
+ if ((y = circ(x)) == NULL) {
+ while (print1(car(x)), !isNil(x = cdr(x))) {
+ if (!isCell(x)) {
+ outString(" . ");
+ print1(x);
+ break;
+ }
+ space();
}
- space();
+ }
+ else if (y == x) {
+ do
+ print1(car(x)), space();
+ while (y != (x = cdr(x)));
+ Env.put('.');
+ }
+ else {
+ do
+ print1(car(x)), space();
+ while (y != (x = cdr(x)));
+ outString(". (");
+ do
+ print1(car(x)), space();
+ while (y != (x = cdr(x)));
+ outString(".)");
}
Env.put(')');
}
diff --git a/src/main.c b/src/main.c
@@ -1,4 +1,4 @@
-/* 04jun10abu
+/* 21jul10abu
* (c) Software Lab. Alexander Burger
*/
@@ -344,6 +344,28 @@ any doUp(any x) {
}
/*** Primitives ***/
+any circ(any x) {
+ any y = x;
+
+ for (;;) {
+ *(word*)&car(y) |= 1;
+ if (!isCell(y = cdr(y))) {
+ do
+ *(word*)&car(x) &= ~1;
+ while (isCell(x = cdr(x)));
+ return NULL;
+ }
+ 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 y;
+ }
+ }
+}
+
/* Comparisons */
bool equal(any x, any y) {
for (;;) {
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 04jun10abu
+/* 21jul10abu
* (c) Software Lab. Alexander Burger
*/
@@ -280,6 +280,7 @@ void bye(int) __attribute__ ((noreturn));
void byteSym(int,int*,any*);
void cellError(any,any) __attribute__ ((noreturn));
void charSym(int,int*,any*);
+any circ(any);
void closeInFile(int);
void closeOnExec(any,int);
void closeOutFile(int);
diff --git a/src64/io.l b/src64/io.l
@@ -1,4 +1,4 @@
-# 11jun10abu
+# 21jul10abu
# (c) Software Lab. Alexander Burger
# Close file descriptor
@@ -753,7 +753,7 @@
else
sub A 63 # Adjust count
push A # <S I> Count
- ld A (* 4 63) # Output first tag byte
+ ld B (* 4 63) # Output first tag byte
call (PutBinBZ)
push 63 # <S> and first 63 data bytes
do
@@ -790,8 +790,8 @@
if nz # Yes
cmp E Nil # NIL?
if eq # Yes
- ld A NIX
- jmp (PutBinBZ) # Output NIX
+ ld B NIX # Output NIX
+ jmp (PutBinBZ)
end
sym (E TAIL) # External symbol?
if nz # Yes
@@ -826,8 +826,8 @@
call nameX_X # Get name
zero X # Any?
if eq # No
- ld A NIX
- call (PutBinBZ) # Output NIX
+ ld B NIX # Output NIX
+ call (PutBinBZ)
else
ld Y Intern
call isInternEXY_F # Internal symbol?
@@ -868,7 +868,7 @@
dec E # More?
until z # No
else
- ld A (* 4 63) # Output first tag byte
+ ld B (* 4 63) # Output first tag byte
or A C # Combine with tag
call (PutBinBZ)
sub E 63 # Adjust count
@@ -911,36 +911,64 @@
end
push X
push Y
- ld X E # Get expression
- ld Y E # in X and Y
- ld A BEG # Begin list
+ ld B BEG # Begin list
call (PutBinBZ)
- do
- ld E (X) # Next item
- call binPrintEZ
- ld X (X CDR) # More?
- cmp X Nil
- while ne # Yes
- cmp X Y # Circular?
+ call circE_XYF # Circular list?
+ if nz # No
+ do
+ ld E (X) # Next item
+ call binPrintEZ
+ ld X (X CDR) # NIL-terminated?
+ cmp X Nil
+ while ne # No
+ atom X # Atomic tail?
+ if nz # Yes
+ ld B DOT # Output dotted pair
+ call (PutBinBZ)
+ ld E X # Output atom
+ call binPrintEZ
+ pop Y # Return
+ pop X
+ ret
+ end
+ loop
+ else
+ cmp X Y # Fully circular?
if eq # Yes
- ld A DOT # Output dotted pair
+ do
+ ld E (X) # Output CAR
+ call binPrintEZ
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B DOT # Output dotted pair
call (PutBinBZ)
- break T
- end
- atom X # End of list?
- if nz # Yes
- ld A DOT # Output dotted pair
+ else
+ do # Non-circular part
+ ld E (X) # Output CAR
+ call binPrintEZ
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B DOT # Output DOT+BEG
+ call (PutBinBZ)
+ ld B BEG
+ call (PutBinBZ)
+ do # Circular part
+ ld E (X) # Output CAR
+ call binPrintEZ
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B DOT # Output DOT+END
+ call (PutBinBZ)
+ ld B END
call (PutBinBZ)
- ld E X # Output atom
- call binPrintEZ
- pop Y # Return
- pop X
- ret
end
- loop
+ end
pop Y
pop X
- ld A END # End list
+ ld B END # End list
jmp (PutBinBZ)
# Family IPC
@@ -4675,36 +4703,70 @@
ret
end
end
- ld X E # Keep list head
+ push Y
ld B (char "(") # Open paren
call (PutB)
- do
- push (E CDR) # Save rest
- ld E (E) # Print CAR
- call printE
- pop E
- cmp E Nil # NIL-terminated?
- while ne # No
- cmp E X # Circular?
+ call circE_XYF # Circular list?
+ if nz # No
+ do
+ ld E (X) # Print CAR
+ call printE
+ ld X (X CDR) # NIL-terminated?
+ cmp X Nil
+ while ne # No
+ atom X # Atomic tail?
+ if nz # Yes
+ call space # Print " . "
+ ld B (char ".")
+ call (PutB)
+ call space
+ ld E X # and the atom
+ call printE
+ break T
+ end
+ call space # Print space
+ loop
+ else
+ cmp X Y # Fully circular?
if eq # Yes
- call space # Print " ."
- ld B (char ".")
+ do
+ ld E (X) # Print CAR
+ call printE
+ call space # and space
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B (char ".") # Print "."
call (PutB)
- break T
- end
- atom E # Atomic tail?
- if nz # Yes
- call space # Print " . "
- ld B (char ".")
+ else
+ do # Non-circular part
+ ld E (X) # Print CAR
+ call printE
+ call space # and space
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B (char ".") # Print ". ("
call (PutB)
call space
- call printE # and the atom
- break T
+ ld B (char "(")
+ call (PutB)
+ do # Circular part
+ ld E (X) # Print CAR
+ call printE
+ call space # and space
+ ld X (X CDR) # Done?
+ cmp X Y
+ until eq # Yes
+ ld B (char ".") # Print ".)"
+ call (PutB)
+ ld B (char ")")
+ call (PutB)
end
- call space # Print space
- loop
+ end
ld B (char ")") # Closing paren
call (PutB)
+ pop Y
pop X
ret
@@ -4999,18 +5061,18 @@
push X
ld X (E CDR) # Args
ld A BEG # Begin list
- call putCharA
+ call putCharB
do
ld E (X) # Eval next arg
eval
- ld (PutBinBZ) putCharA # Set binary print function
+ ld (PutBinBZ) putCharB # Set binary print function
ld (Extn) (ExtN) # Set external symbol offset
call binPrintEZ
ld X (X CDR) # X on rest
atom X # Any
until nz # No
ld A END # End list
- call putCharA
+ call putCharB
cc fflush((stdout)) # Flush
nul4 # OK?
ld E Nil
@@ -5018,7 +5080,8 @@
pop X
ret
-(code 'putCharA 0)
+(code 'putCharB 0)
+ zxt # Extend into A
cc putchar_unlocked(A)
ret
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 19jun10abu
+# 21jul10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -752,6 +752,38 @@
pop X
ret
+(code 'circE_XYF)
+ ld X E # Return list in X
+ ld Y E # Keep list in Y
+ do
+ or (E) 1 # Mark
+ ld E (E CDR) # Normal list?
+ atom E
+ if nz # Yes
+ do
+ off (Y) 1 # Unmark
+ ld Y (Y CDR)
+ atom Y # Done?
+ until nz # Yes
+ ret # 'nz' - No circularity found
+ end
+ test (E) 1 # Detected circularity?
+ if nz # Yes
+ do
+ cmp Y E # Skip non-circular part
+ while ne
+ off (Y) 1 # Unmark
+ ld Y (Y CDR)
+ loop
+ do
+ off (Y) 1 # Unmark circular part
+ ld Y (Y CDR)
+ cmp Y E # Done?
+ until eq # Yes
+ ret # 'z' - Circularity in Y
+ end
+ loop
+
### Comparisons ###
(code 'equalAE_F 0)
cmp A E # Pointer-equal?
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 15jul10abu
+# 21jul10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 5)
+(de *Version 3 0 3 6)
# vi:et:ts=3:sw=3
