commit 7b792341cd588db9f4227749ebcde177212f1c58
parent 95fd604242ff8a626af4be932bfccde5703527ff
Author: Alexander Burger <abu@software-lab.de>
Date: Mon, 20 Jun 2011 12:58:49 +0200
Use full 64 bits in native arguments
Diffstat:
| M | lib/tags | | | 36 | ++++++++++++++++++------------------ |
| M | src64/big.l | | | 4 | ++-- |
| M | src64/main.l | | | 97 | +++++++++++++++++++++++++++---------------------------------------------------- |
3 files changed, 53 insertions(+), 84 deletions(-)
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 (2342 . "@src64/main.l")
-args (2318 . "@src64/main.l")
-argv (2962 . "@src64/main.l")
+arg (2311 . "@src64/main.l")
+args (2287 . "@src64/main.l")
+argv (2931 . "@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 (2717 . "@src64/main.l")
+cd (2686 . "@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 (2944 . "@src64/main.l")
+cmd (2913 . "@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 (2742 . "@src64/main.l")
+ctty (2711 . "@src64/main.l")
cut (1795 . "@src64/sym.l")
-date (2456 . "@src64/main.l")
+date (2425 . "@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 (2875 . "@src64/main.l")
+dir (2844 . "@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 (2822 . "@src64/main.l")
+file (2791 . "@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 (2779 . "@src64/main.l")
+info (2748 . "@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 (2022 . "@src64/main.l")
+lisp (1983 . "@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 (2325 . "@src64/main.l")
+next (2294 . "@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 (3065 . "@src64/main.l")
+opt (3034 . "@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 (2706 . "@src64/main.l")
+pwd (2675 . "@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 (2371 . "@src64/main.l")
+rest (2340 . "@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 (2589 . "@src64/main.l")
+time (2558 . "@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 (2694 . "@src64/main.l")
+usec (2663 . "@src64/main.l")
val (1461 . "@src64/sym.l")
-version (3079 . "@src64/main.l")
+version (3048 . "@src64/main.l")
wait (3118 . "@src64/io.l")
when (1876 . "@src64/flow.l")
while (2053 . "@src64/flow.l")
diff --git a/src64/big.l b/src64/big.l
@@ -1,4 +1,4 @@
-# 22apr11abu
+# 20jun11abu
# (c) Software Lab. Alexander Burger
### Destructive primitives ###
@@ -3022,6 +3022,6 @@
add E C
pop Y
pop X
- jmp boxCntE_E # Return short number
+ jmp boxE_E # Return short number
# vi:et:ts=3:sw=3
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 14jun11abu
+# 20jun11abu
# (c) Software Lab. Alexander Burger
(code 'Code)
@@ -1480,21 +1480,11 @@
neg E # Yes
end
else
- test E SIGN # Get sign
- push F # Save
- off E (| SIGN BIG) # Get cell pointer
- ld A (E CDR) # High word
- ld E (E) # Low word
- shr A 5 # Get highest four bits
- rcr E 1
- shr A 1
- rcr E 1
- shr A 1
- rcr E 1
- shr A 1
- rcr E 1
- pop F # Negative
- if nz # Yes
+ test E SIGN # Sign?
+ if z # No
+ ld E (E DIG)
+ else
+ ld E (E (- DIG SIGN))
neg E # Negate
end
end
@@ -1573,21 +1563,11 @@
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
+ test A SIGN # Sign?
+ if z # No
+ ld A (A DIG)
+ else
+ ld A (A (- DIG SIGN))
neg A # Negate
end
end
@@ -1733,26 +1713,7 @@
add C 8 # Size of long/pointer
end
ld E A # Number
- null E # Negative?
- if ns # No
- test E (hex "F000000000000000") # Fit in short?
- if z # Yes
- shl E 4 # Make short number
- or E CNT
- else
- call boxNumE_E # Make bignum
- end
- else
- neg E # Negate
- test E (hex "F000000000000000") # Fit in short?
- if z # Yes
- shl E 4 # Make negative short number
- or E (| SIGN CNT)
- else
- call boxNumE_E # Make bignum
- or E SIGN # Set negative
- end
- end
+ call boxE_E
else
cmp E SSym # 'S'?
if eq # Yes
@@ -1894,19 +1855,19 @@
link # Apply args
push (Z I) # 'fun'
xchg A E # First arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E C # Second arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E A # Third arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E X # Fourth arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E Y # Fifth arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld Z S # Z on last argument
link # Close frame
@@ -2069,19 +2030,19 @@
link # Apply args
push ZERO # Space for 'fun'
xchg C E # First arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E C # Second arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E X # Third arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E Y # Fourth arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld E Z # Fifth arg
- call boxCntE_E # Make number
+ call boxE_E # Make number
push E
ld Z S # Z on last argument
link # Close frame
@@ -2253,16 +2214,24 @@
end
ret # 'z' if null, 's' if negative
-(code 'boxCntE_E 0)
+(code 'boxE_E 0)
null E # Positive?
if ns # Yes
+ test E (hex "F000000000000000") # Fit in short number?
+ jnz boxNumE_E # No
shl E 4 # Make short number
or E CNT
ret
end
neg E # Else negate
- shl E 4 # Make short number
- or E 10 # with SIGN
+ test E (hex "F000000000000000") # Fit in short?
+ if z # Yes
+ shl E 4 # Make negative short number
+ or E (| SIGN CNT)
+ ret
+ end
+ call boxNumE_E # Make bignum
+ or E SIGN # Set negative
ret
(code 'putStringB 0)
