commit 17957bf99fa23c5bd45adcac735f31a5e8e57837
parent eb3f4f396d4897be9b0163f8549676bf7db4f6c2
Author: Alexander Burger <abu@software-lab.de>
Date: Tue, 20 Sep 2011 17:51:41 +0200
Balance new namespaces
Diffstat:
| M | lib/tags | | | 100 | ++++++++++++++++++++++++++++++++++++++++---------------------------------------- |
| M | src64/gc.l | | | 49 | +------------------------------------------------ |
| M | src64/sym.l | | | 67 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------- |
3 files changed, 111 insertions(+), 105 deletions(-)
diff --git a/lib/tags b/lib/tags
@@ -8,17 +8,17 @@ $ (2951 . "@src64/flow.l")
- (2209 . "@src64/big.l")
-> (3913 . "@src64/subr.l")
/ (2513 . "@src64/big.l")
-: (2975 . "@src64/sym.l")
-:: (2999 . "@src64/sym.l")
-; (2901 . "@src64/sym.l")
+: (3028 . "@src64/sym.l")
+:: (3052 . "@src64/sym.l")
+; (2954 . "@src64/sym.l")
< (2207 . "@src64/subr.l")
<= (2237 . "@src64/subr.l")
<> (2144 . "@src64/subr.l")
= (2115 . "@src64/subr.l")
=0 (2173 . "@src64/subr.l")
-=: (2930 . "@src64/sym.l")
+=: (2983 . "@src64/sym.l")
== (2059 . "@src64/subr.l")
-==== (1025 . "@src64/sym.l")
+==== (1078 . "@src64/sym.l")
=T (2181 . "@src64/subr.l")
> (2267 . "@src64/subr.l")
>= (2297 . "@src64/subr.l")
@@ -44,7 +44,7 @@ bind (1352 . "@src64/flow.l")
bit? (2748 . "@src64/big.l")
bool (1714 . "@src64/flow.l")
box (819 . "@src64/flow.l")
-box? (1057 . "@src64/sym.l")
+box? (1110 . "@src64/sym.l")
by (1669 . "@src64/apply.l")
bye (3428 . "@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 (3447 . "@src64/io.l")
-chop (1151 . "@src64/sym.l")
+chop (1204 . "@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 (4248 . "@src64/io.l")
ctty (2710 . "@src64/main.l")
-cut (1854 . "@src64/sym.l")
+cut (1907 . "@src64/sym.l")
date (2424 . "@src64/main.l")
dbck (2104 . "@src64/db.l")
de (529 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
def (453 . "@src64/flow.l")
-default (1718 . "@src64/sym.l")
-del (1909 . "@src64/sym.l")
+default (1771 . "@src64/sym.l")
+del (1962 . "@src64/sym.l")
delete (1401 . "@src64/subr.l")
delq (1452 . "@src64/subr.l")
diff (2589 . "@src64/subr.l")
@@ -123,11 +123,11 @@ err (4228 . "@src64/io.l")
errno (1374 . "@src64/main.l")
eval (180 . "@src64/flow.l")
ext (5129 . "@src64/io.l")
-ext? (1092 . "@src64/sym.l")
-extern (958 . "@src64/sym.l")
+ext? (1145 . "@src64/sym.l")
+extern (1011 . "@src64/sym.l")
extra (1259 . "@src64/flow.l")
extract (1218 . "@src64/apply.l")
-fifo (2020 . "@src64/sym.l")
+fifo (2073 . "@src64/sym.l")
file (2790 . "@src64/main.l")
fill (3240 . "@src64/subr.l")
filter (1161 . "@src64/apply.l")
@@ -138,7 +138,7 @@ fish (1613 . "@src64/apply.l")
flg? (2445 . "@src64/subr.l")
flip (1699 . "@src64/subr.l")
flush (5104 . "@src64/io.l")
-fold (3430 . "@src64/sym.l")
+fold (3483 . "@src64/sym.l")
for (2220 . "@src64/flow.l")
fork (3254 . "@src64/flow.l")
format (2089 . "@src64/big.l")
@@ -148,10 +148,10 @@ full (1075 . "@src64/subr.l")
fun? (742 . "@src64/sym.l")
gc (432 . "@src64/gc.l")
ge0 (2707 . "@src64/big.l")
-get (2825 . "@src64/sym.l")
+get (2878 . "@src64/sym.l")
getd (750 . "@src64/sym.l")
-getl (3119 . "@src64/sym.l")
-glue (1292 . "@src64/sym.l")
+getl (3172 . "@src64/sym.l")
+glue (1345 . "@src64/sym.l")
gt0 (2718 . "@src64/big.l")
hash (2976 . "@src64/big.l")
head (1820 . "@src64/subr.l")
@@ -159,7 +159,7 @@ heap (526 . "@src64/main.l")
hear (3228 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1025 . "@src64/db.l")
-idx (2094 . "@src64/sym.l")
+idx (2147 . "@src64/sym.l")
if (1795 . "@src64/flow.l")
if2 (1814 . "@src64/flow.l")
ifn (1855 . "@src64/flow.l")
@@ -167,7 +167,7 @@ in (4188 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2637 . "@src64/subr.l")
info (2747 . "@src64/main.l")
-intern (933 . "@src64/sym.l")
+intern (986 . "@src64/sym.l")
ipid (3199 . "@src64/flow.l")
isa (956 . "@src64/flow.l")
job (1419 . "@src64/flow.l")
@@ -190,11 +190,11 @@ lit (155 . "@src64/flow.l")
load (4165 . "@src64/io.l")
lock (1182 . "@src64/db.l")
loop (2163 . "@src64/flow.l")
-low? (3302 . "@src64/sym.l")
-lowc (3332 . "@src64/sym.l")
+low? (3355 . "@src64/sym.l")
+lowc (3385 . "@src64/sym.l")
lst? (2415 . "@src64/subr.l")
lt0 (2682 . "@src64/big.l")
-lup (2283 . "@src64/sym.l")
+lup (2336 . "@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 (3222 . "@src64/sym.l")
+meta (3275 . "@src64/sym.l")
meth (1084 . "@src64/flow.l")
method (1048 . "@src64/flow.l")
min (2356 . "@src64/subr.l")
@@ -232,17 +232,17 @@ nor (1670 . "@src64/flow.l")
not (1722 . "@src64/flow.l")
nth (685 . "@src64/subr.l")
num? (2426 . "@src64/subr.l")
-off (1655 . "@src64/sym.l")
+off (1708 . "@src64/sym.l")
offset (2677 . "@src64/subr.l")
-on (1640 . "@src64/sym.l")
-onOff (1670 . "@src64/sym.l")
-one (1703 . "@src64/sym.l")
+on (1693 . "@src64/sym.l")
+onOff (1723 . "@src64/sym.l")
+one (1756 . "@src64/sym.l")
open (4332 . "@src64/io.l")
opid (3215 . "@src64/flow.l")
opt (3033 . "@src64/main.l")
or (1630 . "@src64/flow.l")
out (4208 . "@src64/io.l")
-pack (1202 . "@src64/sym.l")
+pack (1255 . "@src64/sym.l")
pair (2394 . "@src64/subr.l")
pass (754 . "@src64/apply.l")
pat? (728 . "@src64/sym.l")
@@ -252,10 +252,10 @@ pick (1369 . "@src64/apply.l")
pipe (4269 . "@src64/io.l")
poll (3320 . "@src64/io.l")
pool (648 . "@src64/db.l")
-pop (1830 . "@src64/sym.l")
+pop (1883 . "@src64/sym.l")
port (5 . "@src64/net.l")
pr (5212 . "@src64/io.l")
-pre? (1468 . "@src64/sym.l")
+pre? (1521 . "@src64/sym.l")
prin (5028 . "@src64/io.l")
prinl (5042 . "@src64/io.l")
print (5068 . "@src64/io.l")
@@ -265,15 +265,15 @@ prior (2713 . "@src64/subr.l")
prog (1750 . "@src64/flow.l")
prog1 (1758 . "@src64/flow.l")
prog2 (1775 . "@src64/flow.l")
-prop (2856 . "@src64/sym.l")
+prop (2909 . "@src64/sym.l")
protect (516 . "@src64/main.l")
prove (3527 . "@src64/subr.l")
-push (1745 . "@src64/sym.l")
-push1 (1781 . "@src64/sym.l")
-put (2773 . "@src64/sym.l")
-putl (3037 . "@src64/sym.l")
+push (1798 . "@src64/sym.l")
+push1 (1834 . "@src64/sym.l")
+put (2826 . "@src64/sym.l")
+putl (3090 . "@src64/sym.l")
pwd (2674 . "@src64/main.l")
-queue (1977 . "@src64/sym.l")
+queue (2030 . "@src64/sym.l")
quit (1089 . "@src64/main.l")
quote (139 . "@src64/flow.l")
rand (3003 . "@src64/big.l")
@@ -294,8 +294,8 @@ seed (2961 . "@src64/big.l")
seek (1275 . "@src64/apply.l")
send (1128 . "@src64/flow.l")
seq (1081 . "@src64/db.l")
-set (1539 . "@src64/sym.l")
-setq (1572 . "@src64/sym.l")
+set (1592 . "@src64/sym.l")
+setq (1625 . "@src64/sym.l")
sigio (487 . "@src64/main.l")
size (2806 . "@src64/subr.l")
skip (3501 . "@src64/io.l")
@@ -307,25 +307,25 @@ stack (555 . "@src64/main.l")
state (1999 . "@src64/flow.l")
stem (1989 . "@src64/subr.l")
str (4019 . "@src64/io.l")
-str? (1071 . "@src64/sym.l")
+str? (1124 . "@src64/sym.l")
strip (1576 . "@src64/subr.l")
-sub? (1501 . "@src64/sym.l")
+sub? (1554 . "@src64/sym.l")
sum (1460 . "@src64/apply.l")
super (1215 . "@src64/flow.l")
sym (4005 . "@src64/io.l")
sym? (2434 . "@src64/subr.l")
-symbols (885 . "@src64/sym.l")
+symbols (934 . "@src64/sym.l")
sync (3188 . "@src64/io.l")
sys (3051 . "@src64/flow.l")
t (1741 . "@src64/flow.l")
tail (1911 . "@src64/subr.l")
tell (3260 . "@src64/io.l")
-text (1330 . "@src64/sym.l")
+text (1383 . "@src64/sym.l")
throw (2483 . "@src64/flow.l")
tick (3167 . "@src64/flow.l")
till (3610 . "@src64/io.l")
time (2557 . "@src64/main.l")
-touch (1107 . "@src64/sym.l")
+touch (1160 . "@src64/sym.l")
trim (1759 . "@src64/subr.l")
try (1169 . "@src64/flow.l")
type (909 . "@src64/flow.l")
@@ -334,23 +334,23 @@ unify (3935 . "@src64/subr.l")
unless (1891 . "@src64/flow.l")
until (2075 . "@src64/flow.l")
up (697 . "@src64/main.l")
-upp? (3317 . "@src64/sym.l")
-uppc (3381 . "@src64/sym.l")
+upp? (3370 . "@src64/sym.l")
+uppc (3434 . "@src64/sym.l")
use (1563 . "@src64/flow.l")
usec (2662 . "@src64/main.l")
-val (1520 . "@src64/sym.l")
+val (1573 . "@src64/sym.l")
version (3047 . "@src64/main.l")
wait (3150 . "@src64/io.l")
when (1874 . "@src64/flow.l")
while (2051 . "@src64/flow.l")
-wipe (3177 . "@src64/sym.l")
+wipe (3230 . "@src64/sym.l")
with (1322 . "@src64/flow.l")
wr (5229 . "@src64/io.l")
-xchg (1595 . "@src64/sym.l")
+xchg (1648 . "@src64/sym.l")
xor (1691 . "@src64/flow.l")
x| (2887 . "@src64/big.l")
yield (2707 . "@src64/flow.l")
yoke (1196 . "@src64/subr.l")
-zap (1121 . "@src64/sym.l")
-zero (1688 . "@src64/sym.l")
+zap (1174 . "@src64/sym.l")
+zero (1741 . "@src64/sym.l")
| (2847 . "@src64/big.l")
diff --git a/src64/gc.l b/src64/gc.l
@@ -1,4 +1,4 @@
-# 15sep11abu
+# 20sep11abu
# (c) Software Lab. Alexander Burger
# Mark data
@@ -1053,51 +1053,4 @@
or E BIG # Make number
ret
-# Deep copy of a cell structure
-(code 'copyC_E 0)
- ld A (C) # CAR
- ld C (C CDR) # CDR
- atom A # CAR atomic?
- if nz # Yes
- atom C # CDR also atomic?
- if nz # Yes
- call cons_E
- ld (E) A
- ld (E CDR) C
- ret
- end
- push A # Save CAR
- call copyC_E # Recurse on CDR
- ld C E # Result in C
- call consC_E
- pop (E) # Cons CAR
- ld (E CDR) C
- ret
- end
- atom C # CDR atomic?
- if nz # Yes
- push C # Save CDR
- ld C A # Recurse on CAR
- call copyC_E
- ld A E # Result in A
- call consA_E
- ld (E) A
- pop (E CDR) # Cons with CDR
- ret
- end
- # Both are non-atomic
- push A # Save CAR
- call copyC_E # Recurse on CDR
- pop C
- link
- push E # <L I> Result
- link
- call copyC_E # Recurse on CAR
- ld A E # Result in A
- call consA_E
- ld (E) A
- ld (E CDR) (L I) # Cons with CDR
- drop
- ret
-
# vi:et:ts=3:sw=3
diff --git a/src64/sym.l b/src64/sym.l
@@ -820,6 +820,7 @@
pop X
ret
+# Build sorted list from tree
(code 'consTreeXE_E 0)
atom X # Tree empty?
jnz ret # Yes
@@ -879,6 +880,54 @@
90 drop # Return E
ret
+# Build balanced copy of a namespace
+(code 'balanceXY 0) # ACE
+ ld E Nil # Build list
+ call consTreeXE_E
+ link
+ push E # <L I> Save list
+ link
+ ld A E # Get list in A
+ ld C 0 # Calculate length
+ do
+ atom A # More cells?
+ while z # Yes
+ inc C # Increment length
+ ld A (A CDR) # Next cell
+ loop
+ call balanceCEY
+ drop
+ ret
+
+(code 'balanceCEY 0)
+ do
+ null C # Length zero?
+ jz ret # Yes
+ push C # <S II> Save length
+ push E # <S I> and list
+ inc C # (length + 1) / 2
+ shr C 1
+ push C # <S> Rest length
+ do
+ dec C # nth
+ while nsz
+ ld E (E CDR)
+ loop
+ push (E CDR) # Save rest
+ ld E (E) # Next symbol
+ ld X (E TAIL) # Get name
+ call nameX_X
+ call internEXY_FE # Insert
+ pop E # Retrieve rest
+ ld C (S II) # Get length
+ sub C (S) # minus rest length
+ call balanceCEY # Recurse
+ pop C # Retrieve rest length
+ dec C # Decrement
+ pop E # Retrieve list
+ add S I # Drop length
+ loop # Tail recurse
+
# (symbols) -> sym
# (symbols 'sym1) -> sym2
# (symbols 'sym1 'sym2) -> sym3
@@ -902,13 +951,12 @@
if nz # No
atom (E) # Value must be a cell
jnz symNsErrEX
- xchg (Intern) E # Set new symbol namespace, return old
else
link
push E # <L II> Save new symbol namespace
ld E (Y)
eval+ # Eval source symbol namespace
- push E # Save source
+ push E # <L I> Source
link
num E # Need symbol
jnz symErrEX
@@ -917,13 +965,18 @@
ld C (E) # Get source
atom C # Must be a cell
jnz symNsErrEX
- call copyC_E # Copy source
- ld A (L II) # Get new symbol namespace
- ld (A) E # Store source copy
- ld E (Intern) # Return old symbol namespace
- ld (Intern) A # Store new
+ ld X (C) # Source short names
+ call cons_Y # Create namespace cell
+ ld (Y) Nil # Initialize
+ ld (Y CDR) Nil
+ ld ((L II)) Y # Set in new symbol namespace
+ call balanceXY # Balanced copy of short names
+ ld X (((L I)) CDR) # Source long names
+ call balanceXY # Balanced copy of long names
+ ld E (L II) # Get new symbol namespace
drop
end
+ xchg (Intern) E # Set new symbol namespace, return old
end
pop Y
pop X
