commit bc651b35b90895e2cbeb09380afb90b834f276f0
parent bd4b0e0aa5d742992e7fc94d67b1ddc3c67f067e
Author: Commit-Bot <unknown>
Date: Wed, 9 Jun 2010 15:12:05 +0000
Automatic commit from picoLisp.tgz, From: Wed, 09 Jun 2010 15:12:05 GMT
Diffstat:
17 files changed, 604 insertions(+), 183 deletions(-)
diff --git a/app/lib.l b/app/lib.l
@@ -1,9 +1,9 @@
-# 22jan08abu
+# 08jun10abu
# (c) Software Lab. Alexander Burger
### PDF-Print ###
(dm (ps> . +Ord) ()
- (a4)
+ (a4 (pack "Order" (: nr)))
(font (12 . "Helvetica"))
(eps "img/7fach.eps" 340 150 75)
(window 380 120 120 30
diff --git a/doc64/structures b/doc64/structures
@@ -1,4 +1,4 @@
-# 02jun10abu
+# 07jun10abu
# (c) Software Lab. Alexander Burger
@@ -193,8 +193,8 @@
Method frame:
^
- cls |
- key |
+ <II> cls |
+ <I> key |
LINK ----+ <-- Meth
@@ -218,6 +218,28 @@
LINK ----+ <-- inFrames, outFrames, ctlFrames
+ Coroutine frame:
+ ^
+ X |
+ Y |
+ Z |
+ L |
+ <III> [env] |
+ <II> seg |
+ <I> lim |
+ LINK ----+ <-- co7
+
+
+ Stack segment:
+ <-I> tag # Tag
+ <-II> stk # Stack pointer --+
+ [env] # Environment |
+ Stack ... |
+ X |
+ Y |
+ Z |
+ L <-----------------------+
+
### Memory ###
@@ -263,7 +285,6 @@
+--------------------------+ Mic
-
### Database file ###
+-------------+-+-------------+-+----+
diff --git a/img/7fach.eps b/img/7fach.eps
@@ -1,7 +1,6 @@
%!PS-Adobe-3.0 EPSF-3.0
%%For: Josef Bartl
%%CreationDate: Tue Feb 18 11:34:19 2003
-%%Title: 7fach.eps
%%Creator: Sketch 0.6.7
%%Pages: 1
%%BoundingBox: 35 63 232 148
diff --git a/lib/ps.l b/lib/ps.l
@@ -1,4 +1,4 @@
-# 12nov09abu
+# 08jun10abu
# (c) Software Lab. Alexander Burger
# "*Glyph" "*PgX" "*PgY"
@@ -47,8 +47,9 @@
(pack "-dDEVICEHEIGHTPOINTS=" "*PgY")
Ps Pdf ) ) )
-(de psHead (DX DY)
- (prinl "%!PS-Adobe-1.0")
+(de psHead (DX DY Ttl)
+ (prinl "%!PS-Adobe-2.0")
+ (and Ttl (prinl "%%Title: " @))
(prinl "%%Creator: PicoLisp")
(prinl "%%BoundingBox: 0 0 "
(setq "*DX" DX "*PgX" DX) " "
@@ -58,17 +59,17 @@
(off "*Fonts" "*Lim" "*UL")
(setq "*Size" 12) )
-(de a4 ()
- (psHead 595 842) )
+(de a4 (Ttl)
+ (psHead 595 842 Ttl) )
-(de a4L ()
- (psHead 842 595) )
+(de a4L (Ttl)
+ (psHead 842 595 Ttl) )
-(de a5 ()
- (psHead 420 595) )
+(de a5 (Ttl)
+ (psHead 420 595 Ttl) )
-(de a5L ()
- (psHead 595 420) )
+(de a5L (Ttl)
+ (psHead 595 420 Ttl) )
(de _font ()
(prinl "/" "*Font" " findfont " "*Size" " scalefont setfont") )
@@ -293,11 +294,11 @@
(psEval "Prg") ) )
(de eps (Eps X Y DX DY)
- (prinl "gsave " (or X 0) " " (- "*PgY" (or Y 0)) " translate")
+ (prinl "save " (or X 0) " " (- "*PgY" (or Y 0)) " translate")
(when DX
(prinl DX " 100. div " (or DY DX) " 100. div scale") )
(in Eps (echo))
- (prinl "grestore") )
+ (prinl "restore") )
(====)
diff --git a/lib/tags b/lib/tags
@@ -1,5 +1,5 @@
-! (2560 . "@src64/flow.l")
-$ (2662 . "@src64/flow.l")
+! (2823 . "@src64/flow.l")
+$ (2925 . "@src64/flow.l")
% (2251 . "@src64/big.l")
& (2472 . "@src64/big.l")
* (2070 . "@src64/big.l")
@@ -25,28 +25,28 @@ $ (2662 . "@src64/flow.l")
>> (2306 . "@src64/big.l")
abs (2396 . "@src64/big.l")
accept (139 . "@src64/net.l")
-adr (560 . "@src64/main.l")
-alarm (475 . "@src64/main.l")
+adr (593 . "@src64/main.l")
+alarm (483 . "@src64/main.l")
all (772 . "@src64/sym.l")
-and (1637 . "@src64/flow.l")
+and (1635 . "@src64/flow.l")
any (3758 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (581 . "@src64/apply.l")
-arg (1928 . "@src64/main.l")
-args (1904 . "@src64/main.l")
-argv (2549 . "@src64/main.l")
+arg (1963 . "@src64/main.l")
+args (1939 . "@src64/main.l")
+argv (2584 . "@src64/main.l")
as (146 . "@src64/flow.l")
asoq (2938 . "@src64/subr.l")
assoc (2903 . "@src64/subr.l")
-at (2122 . "@src64/flow.l")
+at (2120 . "@src64/flow.l")
atom (2370 . "@src64/subr.l")
-bind (1375 . "@src64/flow.l")
+bind (1373 . "@src64/flow.l")
bit? (2413 . "@src64/big.l")
-bool (1737 . "@src64/flow.l")
-box (839 . "@src64/flow.l")
+bool (1735 . "@src64/flow.l")
+box (837 . "@src64/flow.l")
box? (999 . "@src64/sym.l")
by (1535 . "@src64/apply.l")
-bye (3137 . "@src64/flow.l")
+bye (3400 . "@src64/flow.l")
caaaar (271 . "@src64/subr.l")
caaadr (288 . "@src64/subr.l")
caaar (99 . "@src64/subr.l")
@@ -61,11 +61,11 @@ caddar (409 . "@src64/subr.l")
cadddr (435 . "@src64/subr.l")
caddr (156 . "@src64/subr.l")
cadr (45 . "@src64/subr.l")
-call (2793 . "@src64/flow.l")
+call (3056 . "@src64/flow.l")
car (5 . "@src64/subr.l")
-case (1978 . "@src64/flow.l")
-catch (2478 . "@src64/flow.l")
-cd (2304 . "@src64/main.l")
+case (1976 . "@src64/flow.l")
+catch (2476 . "@src64/flow.l")
+cd (2339 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -87,63 +87,64 @@ chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1784 . "@src64/subr.l")
close (4146 . "@src64/io.l")
-cmd (2531 . "@src64/main.l")
+cmd (2566 . "@src64/main.l")
cnt (1279 . "@src64/apply.l")
+co (2558 . "@src64/flow.l")
commit (1503 . "@src64/db.l")
con (725 . "@src64/subr.l")
conc (781 . "@src64/subr.l")
-cond (1932 . "@src64/flow.l")
+cond (1930 . "@src64/flow.l")
connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
ctl (4086 . "@src64/io.l")
-ctty (2329 . "@src64/main.l")
+ctty (2364 . "@src64/main.l")
cut (1795 . "@src64/sym.l")
-date (2043 . "@src64/main.l")
+date (2078 . "@src64/main.l")
dbck (2092 . "@src64/db.l")
-de (551 . "@src64/flow.l")
+de (549 . "@src64/flow.l")
dec (2004 . "@src64/big.l")
-def (475 . "@src64/flow.l")
+def (473 . "@src64/flow.l")
default (1659 . "@src64/sym.l")
del (1850 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
diff (2561 . "@src64/subr.l")
-dir (2462 . "@src64/main.l")
-dm (563 . "@src64/flow.l")
-do (2152 . "@src64/flow.l")
-e (2623 . "@src64/flow.l")
+dir (2497 . "@src64/main.l")
+dm (561 . "@src64/flow.l")
+do (2150 . "@src64/flow.l")
+e (2886 . "@src64/flow.l")
echo (4177 . "@src64/io.l")
-env (572 . "@src64/main.l")
+env (605 . "@src64/main.l")
eof (3317 . "@src64/io.l")
eol (3308 . "@src64/io.l")
-errno (1255 . "@src64/main.l")
+errno (1290 . "@src64/main.l")
eval (208 . "@src64/flow.l")
ext (4864 . "@src64/io.l")
ext? (1034 . "@src64/sym.l")
extern (900 . "@src64/sym.l")
-extra (1280 . "@src64/flow.l")
+extra (1278 . "@src64/flow.l")
extract (1084 . "@src64/apply.l")
fifo (1961 . "@src64/sym.l")
-file (2409 . "@src64/main.l")
+file (2444 . "@src64/main.l")
fill (3165 . "@src64/subr.l")
filter (1027 . "@src64/apply.l")
fin (2018 . "@src64/subr.l")
-finally (2536 . "@src64/flow.l")
+finally (2534 . "@src64/flow.l")
find (1188 . "@src64/apply.l")
fish (1479 . "@src64/apply.l")
flg? (2417 . "@src64/subr.l")
flip (1686 . "@src64/subr.l")
flush (4839 . "@src64/io.l")
fold (3341 . "@src64/sym.l")
-for (2241 . "@src64/flow.l")
-fork (2960 . "@src64/flow.l")
+for (2239 . "@src64/flow.l")
+fork (3223 . "@src64/flow.l")
format (1770 . "@src64/big.l")
free (2034 . "@src64/db.l")
from (3336 . "@src64/io.l")
full (1066 . "@src64/subr.l")
fun? (734 . "@src64/sym.l")
-gc (380 . "@src64/gc.l")
+gc (442 . "@src64/gc.l")
ge0 (2372 . "@src64/big.l")
get (2748 . "@src64/sym.l")
getd (742 . "@src64/sym.l")
@@ -151,29 +152,29 @@ getl (3030 . "@src64/sym.l")
glue (1232 . "@src64/sym.l")
gt0 (2383 . "@src64/big.l")
head (1805 . "@src64/subr.l")
-heap (530 . "@src64/main.l")
+heap (538 . "@src64/main.l")
hear (3058 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1034 . "@src64/db.l")
idx (2035 . "@src64/sym.l")
-if (1818 . "@src64/flow.l")
-if2 (1837 . "@src64/flow.l")
-ifn (1878 . "@src64/flow.l")
+if (1816 . "@src64/flow.l")
+if2 (1835 . "@src64/flow.l")
+ifn (1876 . "@src64/flow.l")
in (3982 . "@src64/io.l")
inc (1937 . "@src64/big.l")
index (2609 . "@src64/subr.l")
-info (2366 . "@src64/main.l")
+info (2401 . "@src64/main.l")
intern (875 . "@src64/sym.l")
-ipid (2905 . "@src64/flow.l")
-isa (976 . "@src64/flow.l")
-job (1442 . "@src64/flow.l")
+ipid (3168 . "@src64/flow.l")
+isa (974 . "@src64/flow.l")
+job (1440 . "@src64/flow.l")
journal (977 . "@src64/db.l")
key (3167 . "@src64/io.l")
-kill (2937 . "@src64/flow.l")
+kill (3200 . "@src64/flow.l")
last (2029 . "@src64/subr.l")
length (2685 . "@src64/subr.l")
-let (1492 . "@src64/flow.l")
-let? (1553 . "@src64/flow.l")
+let (1490 . "@src64/flow.l")
+let? (1551 . "@src64/flow.l")
lieu (1163 . "@src64/db.l")
line (3492 . "@src64/io.l")
lines (3645 . "@src64/io.l")
@@ -183,7 +184,7 @@ listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
load (3959 . "@src64/io.l")
lock (1191 . "@src64/db.l")
-loop (2184 . "@src64/flow.l")
+loop (2182 . "@src64/flow.l")
low? (3213 . "@src64/sym.l")
lowc (3243 . "@src64/sym.l")
lst? (2387 . "@src64/subr.l")
@@ -205,8 +206,8 @@ maxi (1377 . "@src64/apply.l")
member (2427 . "@src64/subr.l")
memq (2449 . "@src64/subr.l")
meta (3135 . "@src64/sym.l")
-meth (1102 . "@src64/flow.l")
-method (1066 . "@src64/flow.l")
+meth (1100 . "@src64/flow.l")
+method (1064 . "@src64/flow.l")
min (2341 . "@src64/subr.l")
mini (1428 . "@src64/apply.l")
mix (1251 . "@src64/subr.l")
@@ -215,15 +216,15 @@ n0 (2174 . "@src64/subr.l")
n== (2072 . "@src64/subr.l")
nT (2183 . "@src64/subr.l")
name (499 . "@src64/sym.l")
-nand (1672 . "@src64/flow.l")
-native (1263 . "@src64/main.l")
+nand (1670 . "@src64/flow.l")
+native (1298 . "@src64/main.l")
need (918 . "@src64/subr.l")
-new (850 . "@src64/flow.l")
-next (1911 . "@src64/main.l")
-nil (1755 . "@src64/flow.l")
-nond (1955 . "@src64/flow.l")
-nor (1693 . "@src64/flow.l")
-not (1745 . "@src64/flow.l")
+new (848 . "@src64/flow.l")
+next (1946 . "@src64/main.l")
+nil (1753 . "@src64/flow.l")
+nond (1953 . "@src64/flow.l")
+nor (1691 . "@src64/flow.l")
+not (1743 . "@src64/flow.l")
nth (685 . "@src64/subr.l")
num? (2398 . "@src64/subr.l")
off (1596 . "@src64/sym.l")
@@ -232,9 +233,9 @@ on (1581 . "@src64/sym.l")
onOff (1611 . "@src64/sym.l")
one (1644 . "@src64/sym.l")
open (4108 . "@src64/io.l")
-opid (2921 . "@src64/flow.l")
-opt (2652 . "@src64/main.l")
-or (1653 . "@src64/flow.l")
+opid (3184 . "@src64/flow.l")
+opt (2687 . "@src64/main.l")
+or (1651 . "@src64/flow.l")
out (4002 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
pair (2379 . "@src64/subr.l")
@@ -256,92 +257,94 @@ prinl (4777 . "@src64/io.l")
print (4803 . "@src64/io.l")
println (4834 . "@src64/io.l")
printsp (4819 . "@src64/io.l")
-prog (1773 . "@src64/flow.l")
-prog1 (1781 . "@src64/flow.l")
-prog2 (1798 . "@src64/flow.l")
+prog (1771 . "@src64/flow.l")
+prog1 (1779 . "@src64/flow.l")
+prog2 (1796 . "@src64/flow.l")
prop (2779 . "@src64/sym.l")
-protect (520 . "@src64/main.l")
+protect (528 . "@src64/main.l")
prove (3412 . "@src64/subr.l")
push (1686 . "@src64/sym.l")
push1 (1722 . "@src64/sym.l")
put (2696 . "@src64/sym.l")
putl (2948 . "@src64/sym.l")
-pwd (2293 . "@src64/main.l")
+pwd (2328 . "@src64/main.l")
queue (1918 . "@src64/sym.l")
-quit (976 . "@src64/main.l")
+quit (1009 . "@src64/main.l")
quote (141 . "@src64/flow.l")
rand (2640 . "@src64/big.l")
range (988 . "@src64/subr.l")
rank (2966 . "@src64/subr.l")
-raw (453 . "@src64/main.l")
+raw (461 . "@src64/main.l")
rd (4881 . "@src64/io.l")
read (2498 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (1957 . "@src64/main.l")
+rest (1992 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4847 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
rot (848 . "@src64/subr.l")
rpc (4986 . "@src64/io.l")
-run (332 . "@src64/flow.l")
+run (331 . "@src64/flow.l")
sect (2513 . "@src64/subr.l")
seed (2625 . "@src64/big.l")
seek (1141 . "@src64/apply.l")
-send (1146 . "@src64/flow.l")
+send (1144 . "@src64/flow.l")
seq (1090 . "@src64/db.l")
set (1480 . "@src64/sym.l")
setq (1513 . "@src64/sym.l")
-sigio (491 . "@src64/main.l")
+sigio (499 . "@src64/main.l")
size (2750 . "@src64/subr.l")
skip (3294 . "@src64/io.l")
sort (3837 . "@src64/subr.l")
sp? (711 . "@src64/sym.l")
space (4781 . "@src64/io.l")
split (1579 . "@src64/subr.l")
-state (2022 . "@src64/flow.l")
+stack (567 . "@src64/main.l")
+state (2020 . "@src64/flow.l")
stem (1974 . "@src64/subr.l")
str (3812 . "@src64/io.l")
str? (1013 . "@src64/sym.l")
strip (1563 . "@src64/subr.l")
sub? (1442 . "@src64/sym.l")
sum (1326 . "@src64/apply.l")
-super (1233 . "@src64/flow.l")
+super (1231 . "@src64/flow.l")
sym (3798 . "@src64/io.l")
sym? (2406 . "@src64/subr.l")
sync (3020 . "@src64/io.l")
-sys (2764 . "@src64/flow.l")
-t (1764 . "@src64/flow.l")
+sys (3027 . "@src64/flow.l")
+t (1762 . "@src64/flow.l")
tail (1896 . "@src64/subr.l")
tell (3090 . "@src64/io.l")
text (1270 . "@src64/sym.l")
-throw (2504 . "@src64/flow.l")
-tick (2873 . "@src64/flow.l")
+throw (2502 . "@src64/flow.l")
+tick (3136 . "@src64/flow.l")
till (3403 . "@src64/io.l")
-time (2176 . "@src64/main.l")
+time (2211 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
-try (1187 . "@src64/flow.l")
-type (929 . "@src64/flow.l")
+try (1185 . "@src64/flow.l")
+type (927 . "@src64/flow.l")
udp (268 . "@src64/net.l")
unify (3810 . "@src64/subr.l")
-unless (1914 . "@src64/flow.l")
-until (2098 . "@src64/flow.l")
-up (659 . "@src64/main.l")
+unless (1912 . "@src64/flow.l")
+until (2096 . "@src64/flow.l")
+up (692 . "@src64/main.l")
upp? (3228 . "@src64/sym.l")
uppc (3292 . "@src64/sym.l")
-use (1586 . "@src64/flow.l")
-usec (2281 . "@src64/main.l")
+use (1584 . "@src64/flow.l")
+usec (2316 . "@src64/main.l")
val (1461 . "@src64/sym.l")
-version (2666 . "@src64/main.l")
+version (2701 . "@src64/main.l")
wait (2982 . "@src64/io.l")
-when (1897 . "@src64/flow.l")
-while (2074 . "@src64/flow.l")
+when (1895 . "@src64/flow.l")
+while (2072 . "@src64/flow.l")
wipe (3088 . "@src64/sym.l")
-with (1343 . "@src64/flow.l")
+with (1341 . "@src64/flow.l")
wr (4970 . "@src64/io.l")
xchg (1536 . "@src64/sym.l")
-xor (1714 . "@src64/flow.l")
+xor (1712 . "@src64/flow.l")
x| (2552 . "@src64/big.l")
+yield (2712 . "@src64/flow.l")
yoke (1187 . "@src64/subr.l")
zap (1063 . "@src64/sym.l")
zero (1629 . "@src64/sym.l")
diff --git a/src/flow.c b/src/flow.c
@@ -1,4 +1,4 @@
-/* 19may10abu
+/* 04jun10abu
* (c) Software Lab. Alexander Burger
*/
@@ -1397,8 +1397,8 @@ static struct { // bindFrame
} Brk;
any brkLoad(any x) {
- if (!Env.brk && isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) {
- Env.brk = YES;
+ if (!Break && isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) {
+ Break = YES;
Brk.cnt = 3;
Brk.bnd[0].sym = Up, Brk.bnd[0].val = val(Up), val(Up) = x;
Brk.bnd[1].sym = Run, Brk.bnd[1].val = val(Run), val(Run) = Nil;
@@ -1412,7 +1412,7 @@ any brkLoad(any x) {
val(Run) = Brk.bnd[1].val;
x = val(Up), val(Up) = Brk.bnd[0].val;
Env.bind = Brk.link;
- Env.brk = NO;
+ Break = NO;
}
return x;
}
@@ -1431,7 +1431,7 @@ any doE(any ex) {
inFrame *in;
cell c1, at, key;
- if (!Env.brk)
+ if (!Break)
err(ex, NULL, "No Break");
Push(c1,val(Dbg)), val(Dbg) = Nil;
Push(at, val(At)), val(At) = Brk.bnd[2].val;
diff --git a/src/io.c b/src/io.c
@@ -1,4 +1,4 @@
-/* 30may10abu
+/* 03jun10abu
* (c) Software Lab. Alexander Burger
*/
@@ -1229,6 +1229,8 @@ any token(any x, int c) {
byteSym(Chr, &i, &y);
}
y = Pop(c1);
+ if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N'))
+ return Nil;
if (x = findHash(y, h = Intern + ihash(y)))
return x;
x = consSym(Nil,y);
diff --git a/src/main.c b/src/main.c
@@ -1,4 +1,4 @@
-/* 30may10abu
+/* 04jun10abu
* (c) Software Lab. Alexander Burger
*/
@@ -29,6 +29,7 @@ any ApplyArgs, ApplyBody, DbVal, DbTail;
any Nil, DB, Meth, Quote, T;
any Solo, PPid, Pid, At, At2, At3, This, Dbg, Zap, Ext, Scl, Class;
any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye;
+bool Break;
sig_atomic_t Signal[SIGIO+1];
static int TtyPid;
@@ -476,7 +477,7 @@ void err(any ex, any x, char *fmt, ...) {
}
}
Chr = ExtN = 0;
- Env.brk = NO;
+ Break = NO;
Alarm = Line = Nil;
f.pid = 0, f.fd = STDERR_FILENO, pushOutFiles(&f);
if (InFile && InFile->name) {
diff --git a/src/pico.h b/src/pico.h
@@ -1,4 +1,4 @@
-/* 20may10abu
+/* 04jun10abu
* (c) Software Lab. Alexander Burger
*/
@@ -129,7 +129,6 @@ typedef struct stkEnv {
parseFrame *parser;
void (*get)(void);
void (*put)(int);
- bool brk;
} stkEnv;
typedef struct catchFrame {
@@ -256,6 +255,7 @@ extern any ApplyArgs, ApplyBody, DbVal, DbTail;
extern any Nil, DB, Meth, Quote, T;
extern any Solo, PPid, Pid, At, At2, At3, This, Dbg, Zap, Ext, Scl, Class;
extern any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye;
+extern bool Break;
extern sig_atomic_t Signal[SIGIO+1]; // SIGIO is highest used signal number
/* Prototypes */
diff --git a/src64/defs.l b/src64/defs.l
@@ -1,13 +1,14 @@
-# 03mar10abu
+# 05jun10abu
# (c) Software Lab. Alexander Burger
# Constants
-(equ HEAP (* 1024 1024)) # Heap size in bytes
-(equ CELLS (/ HEAP 16)) # Number of cells in a single heap (65536)
-(equ ZERO (short 0)) # Short number '0'
-(equ ONE (short 1)) # Short number '1'
-(equ TOP (hex "10000")) # Character top
-(equ DB1 (hex "1A")) # Name of '{1}'
+(equ HEAP (* 1024 1024)) # Heap size in bytes
+(equ CELLS (/ HEAP 16)) # Number of cells in a single heap (65536)
+(equ STACK (* 4 1024 1024)) # Default stack segment size
+(equ ZERO (short 0)) # Short number '0'
+(equ ONE (short 1)) # Short number '1'
+(equ TOP (hex "10000")) # Character top
+(equ DB1 (hex "1A")) # Name of '{1}'
# Pointer offsets
(equ I 8)
diff --git a/src64/err.l b/src64/err.l
@@ -1,4 +1,4 @@
-# 02jun10abu
+# 09jun10abu
# (c) Software Lab. Alexander Burger
# Debug print routine
@@ -79,7 +79,7 @@
end
ld (Chr) 0 # Init globals
ld (ExtN) 0
- ld (EnvBrk) 0
+ ld (Break) 0
ld (Alarm) Nil
ld (Sigio) Nil
ld (LineX) ZERO
@@ -159,7 +159,11 @@
ld (EnvYoke) 0
ld (EnvTrace) 0
ld L 0 # Init link register
- ld S (Stack0) # and stack pointer
+ ld S (Stack0) # stack pointer
+ lea A (S 4096) # and stack limit
+ sub A (StkSize)
+ ld (StkLimit) A
+ ld (Stacks) 0 # Free all stack segments
jmp restart # Restart interpreter
: ErrTok asciz "!? "
: Dashes asciz " -- "
@@ -364,6 +368,16 @@
: ProtErr asciz "Protected symbol"
### Error messages ###
+(code 'stkErrE)
+ ld X E
+(code 'stkErrX)
+ ld E 0
+(code 'stkErrEX)
+ ld Y StkErr
+ ld (StkLimit) 0 # Temporarily without stack limit
+ jmp errEXYZ
+: StkErr asciz "Stack overflow"
+
(code 'argErrAX)
ld E A
(code 'argErrEX)
@@ -440,11 +454,24 @@
jmp errEXYZ
: RenErr asciz "Can't rename"
-(code 'makeErrEX)
+(code 'makeErrX)
+ ld E 0
ld Y MakeErr
jmp errEXYZ
: MakeErr asciz "Not making"
+(code 'reentErrEX)
+ ld Y ReentErr
+ jmp errEXYZ
+: ReentErr asciz "Reentrant coroutine"
+
+(code 'yieldErrX)
+ ld E 0
+(code 'yieldErrEX)
+ ld Y YieldErr
+ jmp errEXYZ
+: YieldErr asciz "No coroutine"
+
(code 'msgErrYX)
ld A Y
(code 'msgErrAX)
diff --git a/src64/flow.l b/src64/flow.l
@@ -1,4 +1,4 @@
-# 02jun10abu
+# 09jun10abu
# (c) Software Lab. Alexander Burger
(code 'redefMsgEC)
@@ -311,10 +311,9 @@
while nz
ld Y ((Y) I) # Follow link
loop
- ld A (Y) # End of bindings in A
add (Y -I) (L -I) # Increment 'eswp' by 'cnt'
if z # Last pass
- sub A II
+ lea A ((Y) -II) # Last binding in A
do
xchg ((A)) (A I) # Exchange next symbol value with saved value
sub A II
@@ -452,10 +451,9 @@
while nz
ld Y ((Y) I) # Follow link
loop
- ld A (Y) # End of bindings in A
add (Y -I) (L -I) # Increment 'eswp' by 'cnt'
if z # Last pass
- sub A II
+ lea A ((Y) -II) # Last binding in A
do
xchg ((A)) (A I) # Exchange next symbol value with saved value
sub A II
@@ -2481,19 +2479,19 @@
push Z
push L
ld X (E CDR)
- ld E (X) # Get tag
- ld X (X CDR) # X on body
- eval # Evaluate tag
- sub S "(EnvEnd-Env)" # Build catch frame
+ ld E (X) # Eval tag
+ eval
+ sub S "EnvEnd-Env" # Build catch frame
save (Env) (EnvEnd) (S) # Save environment
push ZERO # 'fin'
push E # 'tag'
push (Catch) # Link
ld (Catch) S # Close catch frame
- prog X # Run body
+ ld X (X CDR) # Run body
+ prog X
: caught
pop (Catch) # Restore catch link
- add S "(EnvEnd-Env)+8+8" # Clean up
+ add S (pack II "+(EnvEnd-Env)") # Clean up
pop L
pop Z
pop Y
@@ -2535,7 +2533,7 @@
# (finally exe . prg) -> any
(code 'doFinally 2)
push X
- sub S "(EnvEnd-Env)" # Build catch frame
+ sub S "EnvEnd-Env" # Build catch frame
save (Env) (EnvEnd) (S) # Save environment
ld X (E CDR)
push (X) # 'exe' -> 'fin'
@@ -2552,7 +2550,272 @@
ld E (L I) # Get result
drop
pop (Catch) # Restore catch link
- add S "(EnvEnd-Env)+8+8" # Clean up
+ add S (pack II "+(EnvEnd-Env)") # Clean up
+ pop X
+ ret
+
+# (co 'sym [. prg]) -> any
+(code 'doCo 2)
+ push X
+ ld X (E CDR) # Get tag
+ call evSymX_E # Evaluate to a symbol
+ atom (X CDR) # 'prg'?
+ if z # Yes
+ push Y
+ push Z
+ push L
+ sub S "EnvMid-Env" # Space for env
+ ld Y (Stack0) # Search through stack segments
+ ld C (Stacks) # Segment bitmask
+ do
+ sub Y (StkSize) # Next segment
+ shr C 1 # In use?
+ if c # Yes
+ cmp E (Y -I) # Found tag?
+ continue ne # No
+ null (Y -II) # Already active?
+ jz reentErrEX # Yes
+ push Y # Resume coroutine: Save 'seg'
+ push (StkLimit) # and 'lim'
+ push (EnvCo7) # Link
+ ld (EnvCo7) S # Close coroutine frame
+ save (Env) (EnvMid) (S III) # Save environment
+: resumeCoroutine
+ ld S (Y -II) # Restore stack pointer
+ ld (Y -II) 0 # Mark as active
+ lea A (Y 4096) # Set stack limit
+ sub A (StkSize)
+ ld (StkLimit) A
+ push (EnvApply) # Save current routine's apply stack
+ ld C (EnvBind) # Current routine's bindings
+ load (Env) (EnvMid) (Y (pack -II "-(EnvMid-Env)")) # Restore environment
+ ld X (EnvBind) # Reversed bindings
+ do
+ null X # More reversed bindings?
+ while nz # Yes
+ ld Y (X) # Link address in Y
+ null (X -I) # Env swap zero?
+ if z # Yes
+ lea Z (Y -II) # End of bindings in Z
+ do
+ xchg ((Z)) (Z I) # Exchange symbol value with saved value
+ sub Z II
+ cmp Z X # More?
+ until lt # No
+ end
+ ld A (Y I) # Get down link
+ ld (Y I) C # Undo reversal
+ ld C X
+ ld X A
+ loop
+ ld (EnvBind) C # Set local bindings
+ pop C # Get main routine's apply stack
+ ld X (EnvApply) # Local apply stack
+ null X # Any?
+ if z # No
+ ld (EnvApply) C # Set local apply stack
+ else
+ ld X (X) # End if frame in X
+ do
+ ld A (X I) # Get link
+ null A # More?
+ while ne # No
+ ld X A # Follow link
+ loop
+ ld (X I) C # Clear link
+ end
+ pop X # Get saved L
+ null X # Any?
+ if nz # Yes
+ ld Y (X) # Pointer to link
+ do
+ ld A (Y) # Get link
+ null A # Found end?
+ while nz # No
+ ld Y (A) # Next frame
+ loop
+ ld (Y) L # Link to main stack
+ ld L X
+ end
+ pop Z
+ pop Y
+ pop X
+ ret
+ end
+ until z
+ ld Y (Stack0) # Find unused stack segment
+ ld Z 1 # New mask
+ ld C (Stacks) # Segment bitmask
+ do
+ sub Y (StkSize) # Next segment
+ test C Z # Free?
+ while nz # No
+ add Z Z # Next bit
+ jc stkErrEX # Overflow
+ loop
+ or (Stacks) Z # Mark segment as used
+ push Y # Save 'seg'
+ push (StkLimit) # and 'lim'
+ push (EnvCo7) # Link
+ ld (EnvCo7) S # Close coroutine frame
+ save (Env) (EnvMid) (S III) # Save environment
+ ld (EnvMake) 0 # Init local 'make' env
+ ld (EnvYoke) 0
+ lea A (Y 4096) # Calculate stack limit
+ sub A (StkSize)
+ ld (StkLimit) A
+ ld S Y # Set stack pointer
+ push E # Save 'tag'
+ push 0 # Mark 'stk' as active
+ sub S "EnvMid-Env" # Space for 'env'
+ ld X (X CDR) # Run 'prg'
+ prog X
+ xor (Stacks) Z # Not yielded: Mark segment as unused
+ ld S (EnvCo7) # Restore stack pointer
+ load (Env) (EnvMid) (S III) # Restore environment
+ pop (EnvCo7) # Restore coroutine link
+ pop (StkLimit) # 'lim'
+ add S (pack I "+(EnvMid-Env)") # Clean up
+ pop L
+ pop Z
+ pop Y
+ pop X
+ ret
+ end
+ ld X (Stack0) # Search through stack segments
+ ld C (Stacks) # Segment bitmask
+ ld A 1
+ do
+ sub X (StkSize) # Next segment
+ shr C 1 # In use?
+ if c # Yes
+ cmp E (X -I) # Found tag?
+ if eq # Yes
+ null (X -II) # Active?
+ ldz E Nil
+ if nz # No
+ xor (Stacks) A # Clear in segment bitmask
+ ld E TSym # Return T
+ end
+ pop X
+ ret
+ end
+ end
+ while nz
+ add A A
+ loop
+ ld E Nil # Return NIL
+ pop X
+ ret
+
+# (yield 'any ['sym]) -> any
+(code 'doYield 2)
+ push X
+ push Y
+ push Z
+ ld X E
+ ld Z (EnvCo7) # Get coroutine
+ null Z # Any?
+ jz yieldErrX # No
+ ld Y (E CDR)
+ ld E (Y) # Eval 'any'
+ eval
+ link
+ push E # <L I> Result
+ link
+ ld Y (Y CDR) # Next arg
+ ld E (Y)
+ eval # Eval optional 'sym'
+ ld Y 0 # Preload "no target"
+ cmp E Nil # Any?
+ if ne # Yes
+ ld Y (Stack0) # Search for target coroutine
+ ld C (Stacks) # Segment bitmask
+ do
+ sub Y (StkSize) # Next segment
+ shr C 1 # In use?
+ if c # Yes
+ cmp E (Y -I) # Found tag?
+ continue ne # No
+ null (Y -II) # Already active?
+ jz reentErrEX # Yes
+ break T
+ end
+ jz yieldErrEX
+ loop
+ end
+ ld E (L I) # Get result
+ drop
+ ld C (Z (pack III "+(EnvMid-Env)")) # Main routine's link
+ cmp L C # Local stack?
+ ldz L 0
+ if ne # Yes
+ ld X (L) # Pointer to link
+ do
+ ld A (X) # Get link
+ cmp A C # Reached main routine's link?
+ while ne # No
+ ld X A # Follow link
+ loop
+ ld (X) 0 # Clear link
+ end
+ push L # End of segment
+ push Y # Save taget coroutine
+ ld X (EnvApply) # Get apply stack
+ null X # Any?
+ if nz # Yes
+ cmp X (Z (pack III "+(EnvMid-EnvApply)")) # Local apply stack?
+ if eq # No
+ ld (EnvApply) 0 # Clear it
+ else
+ ld X (X) # End of frame in X
+ do
+ ld A (X I) # Get link
+ cmp A (Z (pack III "+(EnvMid-EnvApply)")) # Reached main routine's stack?
+ while ne # No
+ ld X A # Follow link
+ loop
+ ld (X I) 0 # Clear link
+ end
+ end
+ ld C 0 # Back link
+ ld X (EnvBind) # Reverse bindings
+ null X # Any?
+ if nz # Yes
+ do
+ cmp X (Z III) # Reached main routine's bindings?
+ while ne # No
+ ld Y X # Keep bind frame in Y
+ null (X -I) # Env swap zero?
+ if z # Yes
+ add X I # X on bindings
+ do
+ xchg ((X)) (X I) # Exchange symbol value with saved value
+ add X II
+ cmp X (Y) # More?
+ until eq # No
+ end
+ ld A (Y) # A on bind link
+ ld X (A I) # X on next frame
+ ld (A I) C # Set back link
+ ld C Y
+ loop
+ end
+ ld (EnvBind) C # Store back link in coroutine's env
+ pop Y # Restore taget coroutine
+ ld X (Z II) # Get segment
+ ld (X -II) S # Save stack pointer
+ save (Env) (EnvMid) (X (pack -II "-(EnvMid-Env)")) # Save environment
+ null Y # Target coroutine?
+ jnz resumeCoroutine # Yes
+ ld S Z # Set stack pointer
+ load (Env) (EnvMid) (S III) # Restore environment
+ pop (EnvCo7) # Restore coroutine link
+ pop (StkLimit) # 'lim'
+ add S (pack I "+(EnvMid-Env)") # Clean up
+ pop L
+ pop Z
+ pop Y
pop X
ret
@@ -2566,7 +2829,7 @@
eval/ret
(code 'brkLoadE_E)
- null (EnvBrk) # Already in breakpoint?
+ null (Break) # Already in breakpoint?
if z # No
cc isatty(0) # STDIN
nul4 # on a tty?
@@ -2588,7 +2851,7 @@
push At
link
ld (EnvBind) L # Close bind frame
- ld (EnvBrk) L # Set break env
+ ld (Break) L # Set break env
push 0 # Init env swap
sub S IV # <L -V> OutFrame
ld Y S
@@ -2611,7 +2874,7 @@
pop (Up) # and '^'
pop L # Restore link
pop (EnvBind) # Restore bind link
- ld (EnvBrk) 0 # Leave breakpoint
+ ld (Break) 0 # Leave breakpoint
pop Y
pop X
end
@@ -2624,7 +2887,7 @@
push X
push Y
ld X E
- null (EnvBrk) # Breakpoint?
+ null (Break) # Breakpoint?
jz brkErrX # No
link
push (Dbg) # Save '*Dbg'
@@ -2632,7 +2895,7 @@
push (Run) # and '*Run'
link
ld (Dbg) Nil # Switch off debug mode
- ld C (EnvBrk) # Get break env
+ ld C (Break) # Get break env
ld (At) (C II) # Set '@'
ld (Run) (C IV) # and '*Run'
call popOutFiles # Leave debug I/O env
@@ -2647,7 +2910,7 @@
eval
end
call pushInFilesY # Restore debug I/O env
- lea Y ((EnvBrk) -V)
+ lea Y ((Break) -V)
call pushOutFilesY
pop L # Restore debug env
pop (Run)
diff --git a/src64/gc.l b/src64/gc.l
@@ -1,4 +1,4 @@
-# 19may10abu
+# 09jun10abu
# (c) Software Lab. Alexander Burger
# Mark data
@@ -105,7 +105,7 @@
call markE
ld E (Transient I)
call markE
- ### Mark stack ###
+ ### Mark stack(s) ###
ld Y L
do
null Y # End of stack?
@@ -143,6 +143,35 @@
call markE
ld Y (Y) # Next frame
loop
+ ld Y (Stack0) # Search through stack segments
+ ld C (Stacks) # Segment bitmask
+ do
+ sub Y (StkSize) # Next segment
+ shr C 1 # In use?
+ if c # Yes
+ null (Y -II) # Active?
+ continue z # Yes
+ push Y
+ push C
+ ld Y ((Y -II)) # Else get saved L
+ do
+ null Y # End of stack?
+ while ne # No
+ ld Z (Y) # Keep end of frame in Z
+ do
+ add Y I # End of frame?
+ cmp Y Z
+ while ne # No
+ ld E (Y) # Next item
+ call markE # Mark it
+ loop
+ ld Y (Y) # Next frame
+ loop
+ pop C
+ pop Y
+ continue T
+ end
+ until z
# Mark externals
ld Y Extern
ld Z 0 # Clear TOS
@@ -298,6 +327,39 @@
loop
loop
50 ### Clean up ###
+ ld Y (Stack0) # Search through stack segments
+ ld C (Stacks) # Segment bitmask
+ ld A 1
+ do
+ sub Y (StkSize) # Next segment
+ shr C 1 # In use?
+ if c # Yes
+ test ((Y -I)) 1 # 'tag' symbol gone?
+ if nz # Yes
+ xor (Stacks) A # Clear in segment bitmask
+ else
+ null (Y -II) # Active?
+ if nz # No
+ ld X (Y (pack -II "-(EnvMid-EnvApply)")) # Saved apply stack
+ do
+ null X # End of stack?
+ while ne # No
+ ld Z (X) # Keep end of frame in Z
+ add X II
+ do
+ off (X) 1 # Clear
+ add X II # Next gc mark
+ cmp X Z # End of frame?
+ until ge # Yes
+ ld X (Z I) # Next frame
+ loop
+ end
+ end
+ jmp 60
+ end
+ while nz
+60 add A A
+ loop
ld Y (EnvApply) # Apply stack
do
null Y # End of stack?
@@ -309,7 +371,7 @@
add Y II # Next gc mark
cmp Y Z # End of frame?
until ge # Yes
- ld Y (Z) # Next frame
+ ld Y (Z I) # Next frame
loop
### Sweep ###
ld X 0 # Avail list
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 20may10abu
+# 08jun10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -16,6 +16,9 @@
word 0
: Stack0 word 0 # Initial stack pointer
+: Stacks word 0 # Stack segment bitmask
+: StkSize word STACK # Stack segment size
+: StkLimit word 0 # Stack limit: StackN-StkSize+4096
: Link word 0 # Saved link register
: Catch word 0 # Catch frames
: Termio word 0 # Raw mode terminal I/O
@@ -49,6 +52,7 @@
: Sigio word Nil # Sigio handler
: LineX word ZERO # Console line
: LineC word -1
+: Break word 0 # Breakpoint
: GcCount word CELLS # Collector count
: Sep0 word (char ".") # Decimal separator
: Sep3 word (char ",") # Thousand separator
@@ -129,6 +133,7 @@
initSym NIL "sigio" doSigio
initSym NIL "protect" doProtect
initSym NIL "heap" doHeap
+ initSym NIL "stack" doStack
initSym NIL "adr" doAdr
initSym NIL "env" doEnv
initSym NIL "up" doUp
@@ -232,6 +237,8 @@
initSym NIL "catch" doCatch
initSym NIL "throw" doThrow
initSym NIL "finally" doFinally
+ initSym NIL "co" doCo
+ initSym NIL "yield" doYield
initSym NIL "!" doBreak
initSym NIL "e" doE
initSym NIL "$" doTrace
@@ -525,18 +532,17 @@
: EnvNext word 0 # Next vararg
: EnvApply word 0 # Apply frames
: EnvMeth word 0 # Method frames
-: EnvTask word Nil # Task list
: EnvMake word 0 # 'make' env
: EnvYoke word 0
+: EnvMid # Must be aligned
+: EnvCo7 word 0 # Coroutines
+: EnvTask word Nil # Task list
: EnvParseX word 0 # Parser status
: EnvParseC word 0
: EnvParseEOF word -1
-: EnvSort word 0 # Sort function
: EnvProtect word 0 # Signal protection
: EnvTrace word 0 # Trace level
-: EnvBrk word 0 # Breakpoint
- align 8 # Padding
-: EnvEnd
+: EnvEnd # Must be aligned
initData
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 02jun10abu
+# 08jun10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -56,7 +56,7 @@
10 sub Z Y # Length
ld C Z # Keep in Z
inc C # Space for null byte
- cc malloc(C)
+ call allocC_A
ld (Home) A # Set 'Home'
movn (A) (Y) Z # Copy path including "/"
add Z (Home) # Pointer to null byte
@@ -73,6 +73,7 @@
or A CNT
ld (Pid) A
ld (Stack0) S # Save top level stack pointer
+ lea (StkLimit) (S (- 4096 STACK)) # Set stack limit
ld L 0 # Init link register
call heapAlloc # Allocate initial heap
ld E Nil # Init internal symbols
@@ -208,11 +209,17 @@
ret
# Allocate memory
+(code 'allocC_A 0)
+ cc malloc(C) # Allocate memory of size C
+ null A # OK?
+ jz NoMemory # No
+ ret
(code 'allocAE_A 0)
cc realloc(A E) # Reallocate pointer in A to size E
null A # OK?
jnz Ret # Return
- ld X Alloc # Else no memory
+: NoMemory
+ ld X Alloc # No memory
jmp giveupX
: Alloc asciz "No memory"
@@ -422,7 +429,8 @@
if nz # Yes
null (Termio) # Already in raw mode?
if z # No
- cc malloc(TERMIOS) # Allocate space for termio structure
+ ld C TERMIOS # Allocate space for termio structure
+ call allocC_A
ld (Termio) A # Save it
ld C A # Pointer in C
movn (C) (OrgTermio) TERMIOS # Copy original termio structure
@@ -555,6 +563,31 @@
or E CNT
ret
+# (stack ['cnt]) -> cnt
+(code 'doStack 2)
+ push X
+ ld X E
+ ld E (E CDR) # Arg?
+ atom E
+ if z # Yes
+ null (Stacks) # Stack segments allocated?
+ if z # No
+ ld E (E) # Eval 'cnt'
+ call evCntEX_FE
+ shl E 20 # [MB]
+ ld (StkSize) E # Set new stack size
+ lea A ((Stack0) 4096) # and stack limit
+ sub A E
+ ld (StkLimit) A
+ jmp 10
+ end
+ end
+ ld E (StkSize) # Return current stack size
+10 shr E 16 # Make short number in MB
+ or E CNT
+ pop X
+ ret
+
# (adr 'var) -> num
# (adr 'num) -> var
(code 'doAdr 2)
@@ -996,6 +1029,8 @@
push X
push Y
push Z
+ cmp S (StkLimit) # Stack check
+ jlt stkErrE
ld X (E CDR) # Get CDR
ld Y (C) # Parameter list in Y
ld Z (C CDR) # Body in Z
@@ -1390,7 +1425,7 @@
ld E (E CDR) # Ignore variable
ld C ((E)) # Get buffer size
shr C 4 # Normalize
- cc malloc(C) # Allocate buffer
+ call allocC_A # Allocate buffer
push A # Save it
ld Z A # Buffer pointer in Z
do
diff --git a/src64/subr.l b/src64/subr.l
@@ -1,4 +1,4 @@
-# 19may10abu
+# 04jun10abu
# (c) Software Lab. Alexander Burger
# (car 'var) -> any
@@ -1099,7 +1099,7 @@
push X
ld X E
null (EnvMake) # In 'make'?
- jz makeErrEX # No
+ jz makeErrX # No
push Y
ld Y (E CDR) # Y on args
atom Y # Any?
@@ -1133,7 +1133,7 @@
push X
ld X E
null (EnvMake) # In 'make'?
- jz makeErrEX # No
+ jz makeErrX # No
push Y
ld Y (E CDR) # Y on args
do
@@ -1164,7 +1164,7 @@
push X
ld X E
null (EnvMake) # In 'make'?
- jz makeErrEX # No
+ jz makeErrX # No
push Y
ld Y (E CDR) # Y on args
do
@@ -1188,7 +1188,7 @@
push X
ld X E
null (EnvMake) # In 'make'?
- jz makeErrEX # No
+ jz makeErrX # No
push Y
ld Y (E CDR) # Y on args
do
@@ -3844,7 +3844,6 @@
atom E # List?
if z # Yes
push Z
- push (EnvSort) # Save sort function
link
push E # Save 'lst'
ld E ((Y CDR)) # Eval 'fun'
@@ -3852,10 +3851,10 @@
ld A Nil # Init local elements
cmp E Nil # User function?
if eq # No
- ld (EnvSort) cmpDfltA_F # Use default sort function
+ ld Z cmpDfltA_F # Use default sort function
xchg E (S) # <L VII> out[1]
else
- ld (EnvSort) cmpUserAX_F # Use user supplied sort function
+ ld Z cmpUserAX_F # Use user supplied sort function
xchg E (S) # 'fun'
push A
push A # <L VIII> Apply args
@@ -3877,7 +3876,7 @@
atom (L V) # in[1] list?
if z # Yes
ld A Y # in
- call (EnvSort) # Less?
+ call (Z) # Less?
if ge # No
lea Y (L V) # &in[1]
end
@@ -3907,7 +3906,7 @@
end
ld (L II) Y # last[0] = p
lea A (L II) # last
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
xchg (L -I) (L -II) # Exchange tail[0] and tail[1]
end
@@ -3921,25 +3920,25 @@
ld (L II) Y # last[0] = p
ld (L V) (Y CDR) # in[1] = cdr(in[1])
lea A (L II) # last
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
xchg (L -I) (L -II) # Exchange tail[0] and tail[1]
end
else # Both in[0] and in[1] are lists
lea A (L II) # last
ld (A) (L IV) # last[0] = in[0]
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
lea A (L II) # last
ld (A) (L V) # last[0] = in[1]
- call (EnvSort) # Less?
+ call (Z) # Less?
if ge # No
ld Y (L V) # p = in[1]
ld (L I) Y
ld (L V) (Y CDR) # in[1] = cdr(in[1])
else
lea A (L IV) # in
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
ld Y (L IV) # p = in[0]
ld (L I) Y
@@ -3954,14 +3953,14 @@
else
lea A (L II) # last
ld (A) (L V) # last[0] = in[1]
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
ld Y (L IV) # p = in[0]
ld (L I) Y
ld (L IV) (Y CDR) # in[0] = cdr(in[0])
else
lea A (L IV) # in
- call (EnvSort) # Less?
+ call (Z) # Less?
if lt # Yes
ld Y (L IV) # p = in[0]
ld (L I) Y
@@ -3984,7 +3983,6 @@
until nz
ld E (L VI) # Return out[0]
drop
- pop (EnvSort)
pop Z
end
pop Y
@@ -3998,6 +3996,7 @@
(code 'cmpUserAX_F 0)
push Y
+ push Z
lea Z (L VIII) # Point Z to apply args
ld (Z) ((A I)) # Copy CAR of second item
ld (Z I) ((A)) # and CAR of first item
@@ -4007,6 +4006,7 @@
if ne
setc # Set carry if "less"
end
+ pop Z
pop Y
ret
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 01jun10abu
+# 09jun10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 2 26)
+(de *Version 3 0 2 27)
# vi:et:ts=3:sw=3
