commit 420d0dcb5f2b0648b7f2dc716bed7687a9d30163
parent 11f5095169a79ede5f4663297d76890cb7467894
Author: Alexander Burger <abu@software-lab.de>
Date: Tue, 14 Jun 2011 11:09:32 +0200
Numbers and strings in 'native' structure arguments
Diffstat:
| M | CHANGES | | | 1 | + |
| M | doc/refN.html | | | 33 | ++++++++++++++++++++++++++------- |
| M | lib/tags | | | 36 | ++++++++++++++++++------------------ |
| M | src64/main.l | | | 97 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------- |
4 files changed, 132 insertions(+), 35 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXjun11 picoLisp-3.0.7
+ Numbers and strings in 'native' structure arguments
Signal portability problems
'dbSync' on arbitrary objects
UB-Tree support in "lib/db.l"
diff --git a/doc/refN.html b/doc/refN.html
@@ -160,13 +160,32 @@ structures, e.g.
(N (B . 7)) # {long; byte[7];} -> (1234 (1 2 3 4 5 6 7))
</code></pre>
-<p>Arguments can be numbers (passed as 64-bit integers), fixpoint numbers
-(passed as cons pairs consisting of a the value and the scale), symbols (passed
-as strings), or a list with a variable in the CAR (to recieve the returned
-structure data, ignored when the CAR is <code>NIL</code>), a cons pair for the
-size- and value-specification in the CADR, and an optional sequence of
-initialization bytes (positive numbers) or unsigned integers (negative numbers)
-in the CDDR.
+<p>Arguments can be
+<ul>
+<li>numbers (passed as 64-bit integers)
+<li>fixpoint numbers, passed as cons pairs consisting of a the value and the
+ scale. If the scale is positive, the number is passed as a
+ <code>double</code>, otherwise as a <code>float</code>.
+<li>symbols (passed as strings), or
+<li>structures, as a list with
+ <ul>
+ <li>a variable in the CAR (to recieve the returned structure data, ignored
+ when the CAR is <code>NIL</code>)
+ <li>a cons pair for the size- and value-specification in the CADR (see the
+ value and size specifications above), and
+ <li>an optional sequence of initialization items in the CDDR, where each
+ may be
+ <ul>
+ <li>a positive number, stored as an unsigned byte value
+ <li>a negative number, whose absolute value is stored as an unsigned
+ integer
+ <li>a pair <code>(num . cnt)</code> where '<code>num</code>' is stored in
+ a field of '<code>cnt</code>' bytes
+ <li>a pair <code>(sym . cnt)</code> where '<code>sym</code>' is stored as
+ a null-terminated string in a field of '<code>cnt</code>' bytes
+ </ul>
+ </ul>
+</ul>
<p>The number of fixpoint arguments is limited to six. For NaN or negative
infinity <code>NIL</code>, and for positive infinity <code>T</code> is returned.
diff --git a/lib/tags b/lib/tags
@@ -32,9 +32,9 @@ and (1616 . "@src64/flow.l")
any (3933 . "@src64/io.l")
append (1338 . "@src64/subr.l")
apply (713 . "@src64/apply.l")
-arg (2265 . "@src64/main.l")
-args (2241 . "@src64/main.l")
-argv (2885 . "@src64/main.l")
+arg (2342 . "@src64/main.l")
+args (2318 . "@src64/main.l")
+argv (2962 . "@src64/main.l")
as (144 . "@src64/flow.l")
asoq (3005 . "@src64/subr.l")
assoc (2970 . "@src64/subr.l")
@@ -65,7 +65,7 @@ call (3082 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1957 . "@src64/flow.l")
catch (2459 . "@src64/flow.l")
-cd (2640 . "@src64/main.l")
+cd (2717 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -88,7 +88,7 @@ circ (816 . "@src64/subr.l")
circ? (2402 . "@src64/subr.l")
clip (1799 . "@src64/subr.l")
close (4338 . "@src64/io.l")
-cmd (2867 . "@src64/main.l")
+cmd (2944 . "@src64/main.l")
cnt (1413 . "@src64/apply.l")
co (2540 . "@src64/flow.l")
commit (1494 . "@src64/db.l")
@@ -99,9 +99,9 @@ connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1225 . "@src64/subr.l")
ctl (4216 . "@src64/io.l")
-ctty (2665 . "@src64/main.l")
+ctty (2742 . "@src64/main.l")
cut (1795 . "@src64/sym.l")
-date (2379 . "@src64/main.l")
+date (2456 . "@src64/main.l")
dbck (2103 . "@src64/db.l")
de (529 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
@@ -111,7 +111,7 @@ del (1850 . "@src64/sym.l")
delete (1401 . "@src64/subr.l")
delq (1452 . "@src64/subr.l")
diff (2589 . "@src64/subr.l")
-dir (2798 . "@src64/main.l")
+dir (2875 . "@src64/main.l")
dm (541 . "@src64/flow.l")
do (2133 . "@src64/flow.l")
e (2914 . "@src64/flow.l")
@@ -128,7 +128,7 @@ extern (898 . "@src64/sym.l")
extra (1259 . "@src64/flow.l")
extract (1218 . "@src64/apply.l")
fifo (1961 . "@src64/sym.l")
-file (2745 . "@src64/main.l")
+file (2822 . "@src64/main.l")
fill (3240 . "@src64/subr.l")
filter (1161 . "@src64/apply.l")
fin (2033 . "@src64/subr.l")
@@ -165,7 +165,7 @@ ifn (1857 . "@src64/flow.l")
in (4156 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2637 . "@src64/subr.l")
-info (2702 . "@src64/main.l")
+info (2779 . "@src64/main.l")
intern (873 . "@src64/sym.l")
ipid (3201 . "@src64/flow.l")
isa (956 . "@src64/flow.l")
@@ -182,7 +182,7 @@ lieu (1154 . "@src64/db.l")
line (3667 . "@src64/io.l")
lines (3820 . "@src64/io.l")
link (1172 . "@src64/subr.l")
-lisp (1945 . "@src64/main.l")
+lisp (2022 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (155 . "@src64/flow.l")
@@ -224,7 +224,7 @@ nand (1651 . "@src64/flow.l")
native (1383 . "@src64/main.l")
need (919 . "@src64/subr.l")
new (830 . "@src64/flow.l")
-next (2248 . "@src64/main.l")
+next (2325 . "@src64/main.l")
nil (1734 . "@src64/flow.l")
nond (1934 . "@src64/flow.l")
nor (1672 . "@src64/flow.l")
@@ -238,7 +238,7 @@ onOff (1611 . "@src64/sym.l")
one (1644 . "@src64/sym.l")
open (4300 . "@src64/io.l")
opid (3217 . "@src64/flow.l")
-opt (2988 . "@src64/main.l")
+opt (3065 . "@src64/main.l")
or (1632 . "@src64/flow.l")
out (4176 . "@src64/io.l")
pack (1142 . "@src64/sym.l")
@@ -271,7 +271,7 @@ push (1686 . "@src64/sym.l")
push1 (1722 . "@src64/sym.l")
put (2696 . "@src64/sym.l")
putl (2948 . "@src64/sym.l")
-pwd (2629 . "@src64/main.l")
+pwd (2706 . "@src64/main.l")
queue (1918 . "@src64/sym.l")
quit (1090 . "@src64/main.l")
quote (139 . "@src64/flow.l")
@@ -282,7 +282,7 @@ raw (450 . "@src64/main.l")
rd (5112 . "@src64/io.l")
read (2624 . "@src64/io.l")
replace (1499 . "@src64/subr.l")
-rest (2294 . "@src64/main.l")
+rest (2371 . "@src64/main.l")
reverse (1678 . "@src64/subr.l")
rewind (5078 . "@src64/io.l")
rollback (1888 . "@src64/db.l")
@@ -322,7 +322,7 @@ text (1270 . "@src64/sym.l")
throw (2485 . "@src64/flow.l")
tick (3169 . "@src64/flow.l")
till (3578 . "@src64/io.l")
-time (2512 . "@src64/main.l")
+time (2589 . "@src64/main.l")
touch (1047 . "@src64/sym.l")
trim (1759 . "@src64/subr.l")
try (1169 . "@src64/flow.l")
@@ -335,9 +335,9 @@ up (698 . "@src64/main.l")
upp? (3228 . "@src64/sym.l")
uppc (3292 . "@src64/sym.l")
use (1565 . "@src64/flow.l")
-usec (2617 . "@src64/main.l")
+usec (2694 . "@src64/main.l")
val (1461 . "@src64/sym.l")
-version (3002 . "@src64/main.l")
+version (3079 . "@src64/main.l")
wait (3118 . "@src64/io.l")
when (1876 . "@src64/flow.l")
while (2053 . "@src64/flow.l")
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 09jun11abu
+# 14jun11abu
# (c) Software Lab. Alexander Burger
(code 'Code)
@@ -1539,18 +1539,95 @@
loop
break T
end
- atom E # Fill bytes?
+ atom E # Fill structure?
while z # Yes
ld A (E) # Next value
- shr A 4 # Byte?
- if nc # Yes
- ld (Z) B # Store in buffer
- inc Z # Increment buffer pointer
- dec C # Buffer full?
+ atom A # Byte or unsigned?
+ if nz # Yes
+ shr A 4 # Byte?
+ if nc # Yes
+ ld (Z) B # Store byte in buffer
+ inc Z # Increment buffer pointer
+ dec C # Buffer full?
+ else
+ st4 (Z) # Store unsigned in buffer
+ add Z 4 # Size of unsigned
+ sub C 4 # Buffer full?
+ end
else
- st4 (Z) # Store in buffer
- add Z 4 # Size of int
- sub C 4 # Buffer full?
+ push C
+ push X
+ push Y
+ ld Y Z # Y on buffer
+ ld C (A CDR) # Get length
+ shr C 4 # Normalize
+ add Z C # Size of buffer
+ push C # Save it
+ ld A (A) # 'num' or 'sym'
+ num A # (num . cnt)?
+ if nz # Yes
+ cnt A # Short?
+ if nz # Yes
+ shr A 4 # Normalize
+ if c # Sign?
+ neg A # Yes
+ end
+ else
+ test A SIGN # Get sign
+ push F # Save
+ off A (| SIGN BIG) # Get cell pointer
+ ld X (A CDR) # High word
+ ld A (A) # Low word
+ shr X 5 # Get highest four bits
+ rcr A 1
+ shr X 1
+ rcr A 1
+ shr X 1
+ rcr A 1
+ shr X 1
+ rcr A 1
+ pop F # Negative
+ if nz # Yes
+ neg A # Negate
+ end
+ end
+ ? *LittleEndian
+ do
+ ld (Y) B # Store byte
+ inc Y # Increment pointer
+ shr A 8
+ dec C # Done?
+ until z # Yes
+ =
+ ? (not *LittleEndian)
+ ld Y Z
+ do
+ dec Y # Decrement pointer
+ ld (Y) B # Store byte
+ shr A 8
+ dec C # Done?
+ until z # Yes
+ =
+ else
+ sym A # (sym . cnt)?
+ if nz # Yes
+ ld X (A TAIL) # Get name
+ call nameX_X
+ ld C 0
+ do
+ call symByteCX_FACX # Next byte
+ while nz
+ ld (Y) B # Store it
+ inc Y # Increment pointer
+ loop
+ set (Y) 0 # Null byte
+ end
+ end
+ pop A # 'cnt'
+ pop Y
+ pop X
+ pop C
+ sub C A # Buffer full?
end
until z # Yes
pop Z
