commit c419e490c79ecfe3a2bb31d2571074aa1f46574c
parent 11491bcdc48960d75b088af36a06d1b45a086213
Author: Alexander Burger <abu@software-lab.de>
Date: Fri, 16 Sep 2011 13:38:58 +0200
Namespace support (64-bit)
Diffstat:
9 files changed, 265 insertions(+), 133 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXsep11 picoLisp-3.0.8
+ Namespace support with 'symbols' (64-bit)
Bug in '@' lambda bindings (32-bit)
GC bug in 64-bit bignums
Bug in 64-bit 'exec' error handling
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")
-: (2925 . "@src64/sym.l")
-:: (2949 . "@src64/sym.l")
-; (2851 . "@src64/sym.l")
+: (2975 . "@src64/sym.l")
+:: (2999 . "@src64/sym.l")
+; (2901 . "@src64/sym.l")
< (2207 . "@src64/subr.l")
<= (2237 . "@src64/subr.l")
<> (2144 . "@src64/subr.l")
= (2115 . "@src64/subr.l")
=0 (2173 . "@src64/subr.l")
-=: (2880 . "@src64/sym.l")
+=: (2930 . "@src64/sym.l")
== (2059 . "@src64/subr.l")
-==== (975 . "@src64/sym.l")
+==== (1025 . "@src64/sym.l")
=T (2181 . "@src64/subr.l")
> (2267 . "@src64/subr.l")
>= (2297 . "@src64/subr.l")
@@ -29,7 +29,7 @@ adr (594 . "@src64/main.l")
alarm (471 . "@src64/main.l")
all (780 . "@src64/sym.l")
and (1614 . "@src64/flow.l")
-any (3942 . "@src64/io.l")
+any (3965 . "@src64/io.l")
append (1338 . "@src64/subr.l")
apply (713 . "@src64/apply.l")
arg (2310 . "@src64/main.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? (1007 . "@src64/sym.l")
+box? (1057 . "@src64/sym.l")
by (1669 . "@src64/apply.l")
bye (3428 . "@src64/flow.l")
caaaar (271 . "@src64/subr.l")
@@ -82,12 +82,12 @@ cdddr (245 . "@src64/subr.l")
cddr (79 . "@src64/subr.l")
cdr (17 . "@src64/subr.l")
chain (1141 . "@src64/subr.l")
-char (3424 . "@src64/io.l")
-chop (1101 . "@src64/sym.l")
+char (3447 . "@src64/io.l")
+chop (1151 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
circ? (2402 . "@src64/subr.l")
clip (1799 . "@src64/subr.l")
-close (4347 . "@src64/io.l")
+close (4370 . "@src64/io.l")
cmd (2912 . "@src64/main.l")
cnt (1413 . "@src64/apply.l")
co (2538 . "@src64/flow.l")
@@ -98,16 +98,16 @@ cond (1909 . "@src64/flow.l")
connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1225 . "@src64/subr.l")
-ctl (4225 . "@src64/io.l")
+ctl (4248 . "@src64/io.l")
ctty (2710 . "@src64/main.l")
-cut (1804 . "@src64/sym.l")
+cut (1854 . "@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 (1668 . "@src64/sym.l")
-del (1859 . "@src64/sym.l")
+default (1718 . "@src64/sym.l")
+del (1909 . "@src64/sym.l")
delete (1401 . "@src64/subr.l")
delq (1452 . "@src64/subr.l")
diff (2589 . "@src64/subr.l")
@@ -115,19 +115,19 @@ dir (2843 . "@src64/main.l")
dm (541 . "@src64/flow.l")
do (2131 . "@src64/flow.l")
e (2912 . "@src64/flow.l")
-echo (4378 . "@src64/io.l")
+echo (4401 . "@src64/io.l")
env (606 . "@src64/main.l")
-eof (3501 . "@src64/io.l")
-eol (3492 . "@src64/io.l")
-err (4205 . "@src64/io.l")
+eof (3524 . "@src64/io.l")
+eol (3515 . "@src64/io.l")
+err (4228 . "@src64/io.l")
errno (1374 . "@src64/main.l")
eval (180 . "@src64/flow.l")
-ext (5106 . "@src64/io.l")
-ext? (1042 . "@src64/sym.l")
-extern (908 . "@src64/sym.l")
+ext (5129 . "@src64/io.l")
+ext? (1092 . "@src64/sym.l")
+extern (958 . "@src64/sym.l")
extra (1259 . "@src64/flow.l")
extract (1218 . "@src64/apply.l")
-fifo (1970 . "@src64/sym.l")
+fifo (2020 . "@src64/sym.l")
file (2790 . "@src64/main.l")
fill (3240 . "@src64/subr.l")
filter (1161 . "@src64/apply.l")
@@ -137,42 +137,42 @@ find (1322 . "@src64/apply.l")
fish (1613 . "@src64/apply.l")
flg? (2445 . "@src64/subr.l")
flip (1699 . "@src64/subr.l")
-flush (5081 . "@src64/io.l")
-fold (3380 . "@src64/sym.l")
+flush (5104 . "@src64/io.l")
+fold (3430 . "@src64/sym.l")
for (2220 . "@src64/flow.l")
fork (3254 . "@src64/flow.l")
format (2089 . "@src64/big.l")
free (2046 . "@src64/db.l")
-from (3520 . "@src64/io.l")
+from (3543 . "@src64/io.l")
full (1075 . "@src64/subr.l")
fun? (742 . "@src64/sym.l")
gc (432 . "@src64/gc.l")
ge0 (2707 . "@src64/big.l")
-get (2775 . "@src64/sym.l")
+get (2825 . "@src64/sym.l")
getd (750 . "@src64/sym.l")
-getl (3069 . "@src64/sym.l")
-glue (1242 . "@src64/sym.l")
+getl (3119 . "@src64/sym.l")
+glue (1292 . "@src64/sym.l")
gt0 (2718 . "@src64/big.l")
hash (2976 . "@src64/big.l")
head (1820 . "@src64/subr.l")
heap (526 . "@src64/main.l")
-hear (3205 . "@src64/io.l")
+hear (3228 . "@src64/io.l")
host (184 . "@src64/net.l")
id (1025 . "@src64/db.l")
-idx (2044 . "@src64/sym.l")
+idx (2094 . "@src64/sym.l")
if (1795 . "@src64/flow.l")
if2 (1814 . "@src64/flow.l")
ifn (1855 . "@src64/flow.l")
-in (4165 . "@src64/io.l")
+in (4188 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2637 . "@src64/subr.l")
info (2747 . "@src64/main.l")
-intern (883 . "@src64/sym.l")
+intern (933 . "@src64/sym.l")
ipid (3199 . "@src64/flow.l")
isa (956 . "@src64/flow.l")
job (1419 . "@src64/flow.l")
journal (968 . "@src64/db.l")
-key (3353 . "@src64/io.l")
+key (3376 . "@src64/io.l")
kill (3231 . "@src64/flow.l")
last (2044 . "@src64/subr.l")
le0 (2693 . "@src64/big.l")
@@ -180,21 +180,21 @@ length (2741 . "@src64/subr.l")
let (1469 . "@src64/flow.l")
let? (1530 . "@src64/flow.l")
lieu (1154 . "@src64/db.l")
-line (3676 . "@src64/io.l")
-lines (3829 . "@src64/io.l")
+line (3699 . "@src64/io.l")
+lines (3852 . "@src64/io.l")
link (1172 . "@src64/subr.l")
lisp (1982 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (155 . "@src64/flow.l")
-load (4142 . "@src64/io.l")
+load (4165 . "@src64/io.l")
lock (1182 . "@src64/db.l")
loop (2163 . "@src64/flow.l")
-low? (3252 . "@src64/sym.l")
-lowc (3282 . "@src64/sym.l")
+low? (3302 . "@src64/sym.l")
+lowc (3332 . "@src64/sym.l")
lst? (2415 . "@src64/subr.l")
lt0 (2682 . "@src64/big.l")
-lup (2233 . "@src64/sym.l")
+lup (2283 . "@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 (3172 . "@src64/sym.l")
+meta (3222 . "@src64/sym.l")
meth (1084 . "@src64/flow.l")
method (1048 . "@src64/flow.l")
min (2356 . "@src64/subr.l")
@@ -232,60 +232,60 @@ nor (1670 . "@src64/flow.l")
not (1722 . "@src64/flow.l")
nth (685 . "@src64/subr.l")
num? (2426 . "@src64/subr.l")
-off (1605 . "@src64/sym.l")
+off (1655 . "@src64/sym.l")
offset (2677 . "@src64/subr.l")
-on (1590 . "@src64/sym.l")
-onOff (1620 . "@src64/sym.l")
-one (1653 . "@src64/sym.l")
-open (4309 . "@src64/io.l")
+on (1640 . "@src64/sym.l")
+onOff (1670 . "@src64/sym.l")
+one (1703 . "@src64/sym.l")
+open (4332 . "@src64/io.l")
opid (3215 . "@src64/flow.l")
opt (3033 . "@src64/main.l")
or (1630 . "@src64/flow.l")
-out (4185 . "@src64/io.l")
-pack (1152 . "@src64/sym.l")
+out (4208 . "@src64/io.l")
+pack (1202 . "@src64/sym.l")
pair (2394 . "@src64/subr.l")
pass (754 . "@src64/apply.l")
pat? (728 . "@src64/sym.l")
path (1244 . "@src64/io.l")
-peek (3408 . "@src64/io.l")
+peek (3431 . "@src64/io.l")
pick (1369 . "@src64/apply.l")
-pipe (4246 . "@src64/io.l")
-poll (3297 . "@src64/io.l")
+pipe (4269 . "@src64/io.l")
+poll (3320 . "@src64/io.l")
pool (648 . "@src64/db.l")
-pop (1780 . "@src64/sym.l")
+pop (1830 . "@src64/sym.l")
port (5 . "@src64/net.l")
-pr (5189 . "@src64/io.l")
-pre? (1418 . "@src64/sym.l")
-prin (5005 . "@src64/io.l")
-prinl (5019 . "@src64/io.l")
-print (5045 . "@src64/io.l")
-println (5076 . "@src64/io.l")
-printsp (5061 . "@src64/io.l")
+pr (5212 . "@src64/io.l")
+pre? (1468 . "@src64/sym.l")
+prin (5028 . "@src64/io.l")
+prinl (5042 . "@src64/io.l")
+print (5068 . "@src64/io.l")
+println (5099 . "@src64/io.l")
+printsp (5084 . "@src64/io.l")
prior (2713 . "@src64/subr.l")
prog (1750 . "@src64/flow.l")
prog1 (1758 . "@src64/flow.l")
prog2 (1775 . "@src64/flow.l")
-prop (2806 . "@src64/sym.l")
+prop (2856 . "@src64/sym.l")
protect (516 . "@src64/main.l")
prove (3527 . "@src64/subr.l")
-push (1695 . "@src64/sym.l")
-push1 (1731 . "@src64/sym.l")
-put (2723 . "@src64/sym.l")
-putl (2987 . "@src64/sym.l")
+push (1745 . "@src64/sym.l")
+push1 (1781 . "@src64/sym.l")
+put (2773 . "@src64/sym.l")
+putl (3037 . "@src64/sym.l")
pwd (2674 . "@src64/main.l")
-queue (1927 . "@src64/sym.l")
+queue (1977 . "@src64/sym.l")
quit (1089 . "@src64/main.l")
quote (139 . "@src64/flow.l")
rand (3003 . "@src64/big.l")
range (997 . "@src64/subr.l")
rank (3033 . "@src64/subr.l")
raw (449 . "@src64/main.l")
-rd (5123 . "@src64/io.l")
-read (2633 . "@src64/io.l")
+rd (5146 . "@src64/io.l")
+read (2656 . "@src64/io.l")
replace (1499 . "@src64/subr.l")
rest (2339 . "@src64/main.l")
reverse (1678 . "@src64/subr.l")
-rewind (5089 . "@src64/io.l")
+rewind (5112 . "@src64/io.l")
rollback (1889 . "@src64/db.l")
rot (848 . "@src64/subr.l")
run (311 . "@src64/flow.l")
@@ -294,37 +294,38 @@ seed (2961 . "@src64/big.l")
seek (1275 . "@src64/apply.l")
send (1128 . "@src64/flow.l")
seq (1081 . "@src64/db.l")
-set (1489 . "@src64/sym.l")
-setq (1522 . "@src64/sym.l")
+set (1539 . "@src64/sym.l")
+setq (1572 . "@src64/sym.l")
sigio (487 . "@src64/main.l")
size (2806 . "@src64/subr.l")
-skip (3478 . "@src64/io.l")
+skip (3501 . "@src64/io.l")
sort (3962 . "@src64/subr.l")
sp? (719 . "@src64/sym.l")
-space (5023 . "@src64/io.l")
+space (5046 . "@src64/io.l")
split (1592 . "@src64/subr.l")
stack (555 . "@src64/main.l")
state (1999 . "@src64/flow.l")
stem (1989 . "@src64/subr.l")
-str (3996 . "@src64/io.l")
-str? (1021 . "@src64/sym.l")
+str (4019 . "@src64/io.l")
+str? (1071 . "@src64/sym.l")
strip (1576 . "@src64/subr.l")
-sub? (1451 . "@src64/sym.l")
+sub? (1501 . "@src64/sym.l")
sum (1460 . "@src64/apply.l")
super (1215 . "@src64/flow.l")
-sym (3982 . "@src64/io.l")
+sym (4005 . "@src64/io.l")
sym? (2434 . "@src64/subr.l")
-sync (3165 . "@src64/io.l")
+symbols (885 . "@src64/sym.l")
+sync (3188 . "@src64/io.l")
sys (3051 . "@src64/flow.l")
t (1741 . "@src64/flow.l")
tail (1911 . "@src64/subr.l")
-tell (3237 . "@src64/io.l")
-text (1280 . "@src64/sym.l")
+tell (3260 . "@src64/io.l")
+text (1330 . "@src64/sym.l")
throw (2483 . "@src64/flow.l")
tick (3167 . "@src64/flow.l")
-till (3587 . "@src64/io.l")
+till (3610 . "@src64/io.l")
time (2557 . "@src64/main.l")
-touch (1057 . "@src64/sym.l")
+touch (1107 . "@src64/sym.l")
trim (1759 . "@src64/subr.l")
try (1169 . "@src64/flow.l")
type (909 . "@src64/flow.l")
@@ -333,23 +334,23 @@ unify (3935 . "@src64/subr.l")
unless (1891 . "@src64/flow.l")
until (2075 . "@src64/flow.l")
up (697 . "@src64/main.l")
-upp? (3267 . "@src64/sym.l")
-uppc (3331 . "@src64/sym.l")
+upp? (3317 . "@src64/sym.l")
+uppc (3381 . "@src64/sym.l")
use (1563 . "@src64/flow.l")
usec (2662 . "@src64/main.l")
-val (1470 . "@src64/sym.l")
+val (1520 . "@src64/sym.l")
version (3047 . "@src64/main.l")
-wait (3127 . "@src64/io.l")
+wait (3150 . "@src64/io.l")
when (1874 . "@src64/flow.l")
while (2051 . "@src64/flow.l")
-wipe (3127 . "@src64/sym.l")
+wipe (3177 . "@src64/sym.l")
with (1322 . "@src64/flow.l")
-wr (5206 . "@src64/io.l")
-xchg (1545 . "@src64/sym.l")
+wr (5229 . "@src64/io.l")
+xchg (1595 . "@src64/sym.l")
xor (1691 . "@src64/flow.l")
x| (2887 . "@src64/big.l")
yield (2707 . "@src64/flow.l")
yoke (1196 . "@src64/subr.l")
-zap (1071 . "@src64/sym.l")
-zero (1638 . "@src64/sym.l")
+zap (1121 . "@src64/sym.l")
+zero (1688 . "@src64/sym.l")
| (2847 . "@src64/big.l")
diff --git a/src64/err.l b/src64/err.l
@@ -1,4 +1,4 @@
-# 24aug11abu
+# 16sep11abu
# (c) Software Lab. Alexander Burger
# Debug print routine
@@ -76,6 +76,7 @@
pop E # Retrieve reason
end
ld (Chr) 0 # Init globals
+ ld (Intern) pico
ld (ExtN) 0
ld (Break) 0
ld (Alarm) Nil
@@ -386,6 +387,10 @@
ld Y ProtErr
jmp errEXYZ
+(code 'symNsErrEX)
+ ld Y SymNsErr
+ jmp errEXYZ
+
### Error messages ###
(code 'stkErr)
ld E 0
diff --git a/src64/gc.l b/src64/gc.l
@@ -1,4 +1,4 @@
-# 19jul11abu
+# 15sep11abu
# (c) Software Lab. Alexander Burger
# Mark data
@@ -1053,4 +1053,51 @@
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/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 09jul11abu
+# 16sep11abu
# (c) Software Lab. Alexander Burger
(data 'Data)
@@ -71,8 +71,7 @@
: DbLog word 0 # Transaction log file
# GC relevant data
-:: Intern word Nil # Short internal names
- word Nil # Long internal names
+:: Intern word pico # Current namespace of internal symbols
:: Transient word Nil # Short transient names
word Nil # Long transient names
: Alarm word Nil # Alarm handler
@@ -136,7 +135,11 @@
word Nil # CDR when NIL is accessed as an empty list
word 0 # Padding
+ word Nil # Short internal names
+ word Nil # Long internal names
+
# Protected symbols
+ initSym pico "pico" .-24
initSym OS "*OS" TgOS
initSym DB "*DB" Db1
initFun Meth "meth" doMeth
@@ -306,6 +309,7 @@
initFun NIL "fun?" doFunQ
initFun NIL "getd" doGetd
initFun NIL "all" doAll
+ initFun NIL "symbols" doSymbols
initFun NIL "intern" doIntern
initFun NIL "extern" doExtern
initFun NIL "====" doHide
@@ -1177,6 +1181,7 @@
: ErrTok asciz "!? "
: Dashes asciz " -- "
: ProtErr asciz "Protected symbol"
+: SymNsErr asciz "Bad symbol namespace"
: StkErr asciz "Stack overflow"
: ArgErr asciz "Bad argument"
: NumErr asciz "Number expected"
diff --git a/src64/ht.l b/src64/ht.l
@@ -1,4 +1,4 @@
-# 23apr11abu
+# 15sep11abu
# (c) Software Lab. Alexander Burger
(data 'HtData)
@@ -217,7 +217,7 @@ align 8 asciz "<hr>"
call prExtNmX # Print external
else
push Y
- ld Y Intern
+ ld Y ((Intern))
call isInternEXY_F # Internal symbol?
ld C 0
if eq # Yes
diff --git a/src64/io.l b/src64/io.l
@@ -1,4 +1,4 @@
-# 24aug11abu
+# 16sep11abu
# (c) Software Lab. Alexander Burger
# Close file descriptor
@@ -849,7 +849,7 @@
ld B NIX # Output NIX
call (PutBinBZ)
else
- ld Y Intern
+ ld Y ((Intern))
call isInternEXY_F # Internal symbol?
ld C INTERN # Yes
ldnz C TRANSIENT # No
@@ -2114,16 +2114,34 @@
end
ret
-(code 'rdAtomBYL_E) # X
+(code 'rdAtomBY_E) # X
+ link
+ push (Intern) # <L II> Current symbol namespace
+ push ZERO # <L I> Result
ld C 4 # Build name
- lea X (L I) # Safe
+ ld X S
+ link
call byteSymBCX_CX # Pack first char
ld A Y # Get second
do
null A # EOF?
while ns # No
+ cmp B (char "~") # Tilde?
+ if eq # Yes
+ ld X (L I) # Get name so far
+ call findSymX_E # Find or create symbol
+ ld X 0 # Clear error context
+ atom (E) # Value must be a cell
+ jnz symNsErrEX
+ ld (Intern) E # Switch symbol namespace
+ ld C 4 # Build new name
+ lea X (L I) # Safe
+ ld (X) ZERO
+ call (Get_A) # Get next char
+ continue T
+ end
memb Delim "(DelimEnd-Delim)" # Delimiter?
- jeq 10 # Yes
+ break eq # Yes
cmp B (char "\\") # Backslash?
if eq # Yes
call (Get_A) # Get next char
@@ -2131,7 +2149,7 @@
call byteSymBCX_CX # Pack char
call (Get_A) # Get next
loop
-10 ld X (L I) # Get name
+ ld X (L I) # Get name
ld A (Scl) # Scale
shr A 4 # Normalize
ld (Sep3) 0 # Thousand separator
@@ -2145,6 +2163,8 @@
call findSymX_E # Find or create symbol
end
end
+ ld (Intern) (L II) # Restore current symbol namespace
+ drop
ret
(code 'rdList_E)
@@ -2238,20 +2258,16 @@
end
push X
push Y
- link
- push ZERO # <L I> Safe
- link
push E
ld Y A # Save first char
ld B (char ".") # Restore dot
- call rdAtomBYL_E # Read atom
+ call rdAtomBY_E # Read atom
call consE_A # Make a pair
ld (A) E
ld (A CDR) Nil
pop E
ld (E CDR) A # Store in last cell
ld E A
- drop
pop Y
pop X
else
@@ -2292,20 +2308,17 @@
(code 'readA_E)
push X
push Y
- link
- push ZERO # <L I> Safe
- link
- push A # <L -I> Top flag
+ push A # <S> Top flag
ld C (char "#")
call skipC_A
null A # EOF?
if s # Yes
- null (L -I) # Top?
+ null (S) # Top?
jz eofErr # No: Error
ld E Nil # Yes: Return NIL
jmp 99
end
- null (L -I) # Top?
+ null (S) # Top?
if nz # Yes
ld C (InFile) # And reading file?
null C
@@ -2316,7 +2329,7 @@
cmp B (char "(") # Opening a list?
if eq # Yes
call rdList_E # Read it
- null (L -I) # Top?
+ null (S) # Top?
if nz # Yes
cmp (Chr) (char "]") # And super-parentheses?
if eq # Yes
@@ -2352,7 +2365,9 @@
ld X Uni # Maintain '*Uni' index
cmp (X) TSym # Disabled?
jeq 99 # Yes
- ld (L I) E # Else save expression
+ link
+ push E # Else save expression
+ link
ld Y E
call idxPutXY_E
atom E # Pair?
@@ -2361,6 +2376,7 @@
else
ld E Y # 'read' value
end
+ drop
jmp 99
end
cmp B (char "`") # Backquote?
@@ -2368,8 +2384,11 @@
call (Get_A) # Skip '`'
ld A 0
call readA_E # Read expression
- ld (L I) E # Save it
+ link
+ push E # Save it
+ link
eval # Evaluate
+ drop
jmp 99
end
cmp B (char "\"") # String?
@@ -2383,8 +2402,11 @@
end
call testEscA_F
jnc eofErr
+ link
+ push ZERO # <L I> Result
ld C 4 # Build name
- lea X (L I) # Safe
+ ld X S
+ link
do
call byteSymBCX_CX # Pack char
call (Get_A) # Get next
@@ -2398,6 +2420,7 @@
ld Y Transient
ld E 0 # No symbol yet
call internEXY_FE # Check transient symbol
+ drop
jmp 99
end
cmp B (char "{") # External symbol?
@@ -2460,8 +2483,8 @@
ld Y A # Save in Y
call (Get_A) # Next char
xchg A Y # Get first char
- call rdAtomBYL_E # Read atom
-99 drop
+ call rdAtomBY_E # Read atom
+99 pop A
pop Y
pop X
ret
@@ -4768,7 +4791,7 @@
ret
end
push Y
- ld Y Intern
+ ld Y ((Intern))
call isInternEXY_F # Internal symbol?
if eq # Yes
cmp X (hex "2E2") # Dot?
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 24aug11abu
+# 16sep11abu
# (c) Software Lab. Alexander Burger
(code 'Code)
@@ -89,10 +89,10 @@
ld L 0 # Init link register
call heapAlloc # Allocate initial heap
ld E Nil # Init internal symbols
- lea Z (E IV) # Skip padding
+ lea Z (E VI) # Skip padding and 'pico' cell
do
ld X (E TAIL) # Get name
- ld Y Intern
+ ld Y "pico-24" # From initial symbol namespace
call internEXY_FE # Store to internals
ld E Z
cnt (Z TAIL) # Short name?
diff --git a/src64/sym.l b/src64/sym.l
@@ -1,4 +1,4 @@
-# 24aug11abu
+# 16sep11abu
# (c) Software Lab. Alexander Burger
### Compare long names ###
@@ -256,7 +256,7 @@
(code 'findSymX_E 0) # Y
ld E 0 # No symbol yet
- ld Y Intern
+ ld Y ((Intern))
call internEXY_FE # New internal symbol?
jnc Ret # No
ld (E) Nil # Init to 'NIL'
@@ -534,7 +534,7 @@
push Y
ld X (E TAIL)
call nameX_X # Get name
- ld Y Intern # Internal symbol?
+ ld Y ((Intern)) # Internal symbol?
call isInternEXY_F
pop Y
pop X
@@ -786,8 +786,8 @@
cmp (E) Nil # Internal trees?
if eq # Yes
cmp (E CDR) Nil # Short names?
- ldz E (Intern) # Yes
- ldnz E (Intern I)
+ ldz E (((Intern))) # Yes
+ ldnz E (((Intern)) I)
else
cmp (E) TSym # Transient trees?
ldnz E Extern # No: External symbols
@@ -800,9 +800,9 @@
else
cmp E Nil # Nil?
if eq # Yes
- ld X (Intern I) # Internal symbols
+ ld X (((Intern)) I) # Internal symbols
call consTreeXE_E
- ld X (Intern)
+ ld X (((Intern)))
else
cmp E TSym # T?
if eq # Yes
@@ -879,6 +879,56 @@
90 drop # Return E
ret
+# (symbols) -> sym
+# (symbols 'sym) -> sym
+# (symbols 'sym1 'sym2) -> sym
+(code 'doSymbols 2)
+ push X
+ push Y
+ ld X E
+ ld Y (E CDR) # Y on args
+ atom Y # Any?
+ if nz # No
+ ld E (Intern) # Return current symbol namespace
+ else
+ ld E (Y) # Eval first
+ eval
+ num E # Need symbol
+ jnz symErrEX
+ sym E
+ jz symErrEX
+ ld Y (Y CDR) # Second arg?
+ atom Y # Any?
+ 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
+ link
+ num E # Need symbol
+ jnz symErrEX
+ sym E
+ jz symErrEX
+ 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 current symbol namespace
+ ld (Intern) A # Store new
+ drop
+ end
+ end
+ pop Y
+ pop X
+ ret
+
# (intern 'sym) -> sym
(code 'doIntern 2)
push X
@@ -894,7 +944,7 @@
cmp X ZERO # Any?
if ne # Yes
push Y
- ld Y Intern # Insert internal
+ ld Y ((Intern)) # Insert internal
call internEXY_FE
pop Y
pop X
@@ -1031,7 +1081,7 @@
push Y
ld X (E TAIL) # Get name
call nameX_X
- ld Y Intern # Internal symbol?
+ ld Y ((Intern)) # Internal symbol?
call isInternEXY_F
ldz E Nil # Return NIL
pop Y
@@ -1090,7 +1140,7 @@
push Y
ld X (E TAIL)
call nameX_X # Get name
- ld Y Intern
+ ld Y ((Intern))
call uninternEXY # Unintern symbol
pop Y
end
