commit 706c71633b5dc73a8006c35a76664d47df47d119
parent b387c096a163b42798c02e5fde91b38fcf40804f
Author: Commit-Bot <unknown>
Date: Mon, 2 Aug 2010 18:37:58 +0000
Automatic commit from picoLisp.tgz, From: Mon, 02 Aug 2010 18:37:58 GMT
Diffstat:
9 files changed, 203 insertions(+), 147 deletions(-)
diff --git a/doc/refN.html b/doc/refN.html
@@ -146,7 +146,8 @@ following arguments are the arguments to the native function.
I int # Integer (signed 32 bit)
N long # Long or pointer (signed 64 bit)
S string # String (UTF-8)
- 1.0 double # Scaled fixpoint number
+ -1.0 float # Scaled fixpoint number
+ +1.0 double # Scaled fixpoint number
</code></pre>
<p>or nested lists of these atoms with size specifications to denote arrays and
diff --git a/doc64/asm b/doc64/asm
@@ -1,4 +1,4 @@
-# 29jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
@@ -164,8 +164,8 @@
call adr # Call 'adr'
cc adr(src ..) # C-Call to 'adr' with 'src' arguments
cc adr reg # C-Call to 'adr' with end of stacked args in 'reg'
- darg # Pass double argument in 'A' with scale 'C'
dval # Set up double value pointed to by 'C'
+ fval # Set up float value pointed to by 'C'
fix # Convert double with scale 'E' to fixnum in 'E'
ret # Return
diff --git a/lib/math64.l b/lib/math64.l
@@ -1,48 +1,48 @@
-# 28jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
(setq
- "Fix1" (0 . 1.0)
- "Fix2" (0 . 1.0) )
+ "Dbl1" (0 . 1.0)
+ "Dbl2" (0 . 1.0) )
(de pow (X Y)
- (set "Fix1" X "Fix2" Y)
- (native "@" "pow" 1.0 "Fix1" "Fix2") )
+ (set "Dbl1" X "Dbl2" Y)
+ (native "@" "pow" 1.0 "Dbl1" "Dbl2") )
(de exp (X)
- (set "Fix1" X)
- (native "@" "exp" 1.0 "Fix1") )
+ (set "Dbl1" X)
+ (native "@" "exp" 1.0 "Dbl1") )
(de log (X)
- (when (gt0 (set "Fix1" X))
- (native "@" "log" 1.0 "Fix1") ) )
+ (when (gt0 (set "Dbl1" X))
+ (native "@" "log" 1.0 "Dbl1") ) )
(de sin (A)
- (set "Fix1" A)
- (native "@" "sin" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "sin" 1.0 "Dbl1") )
(de cos (A)
- (set "Fix1" A)
- (native "@" "cos" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "cos" 1.0 "Dbl1") )
(de tan (A)
- (set "Fix1" A)
- (native "@" "tan" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "tan" 1.0 "Dbl1") )
(de asin (A)
- (set "Fix1" A)
- (native "@" "asin" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "asin" 1.0 "Dbl1") )
(de acos (A)
- (set "Fix1" A)
- (native "@" "acos" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "acos" 1.0 "Dbl1") )
(de atan (A)
- (set "Fix1" A)
- (native "@" "atan" 1.0 "Fix1") )
+ (set "Dbl1" A)
+ (native "@" "atan" 1.0 "Dbl1") )
(de atan2 (X Y)
- (set "Fix1" X "Fix2" Y)
- (native "@" "atan2" 1.0 "Fix1" "Fix2") )
+ (set "Dbl1" X "Dbl2" Y)
+ (native "@" "atan2" 1.0 "Dbl1" "Dbl2") )
# vi:et:ts=3:sw=3
diff --git a/lib/openGl.l b/lib/openGl.l
@@ -1,8 +1,8 @@
-# 29jul10abu
+# 02aug10abu
# 27jul10jk
# (c) Software Lab. Alexander Burger
-(load "@lib/math.l" "@lib/native.l")
+(load "@lib/math.l")
### Constant Definitions ###
# Primitives
@@ -127,28 +127,18 @@
*GluLib "/usr/lib/libGLU.so"
*GlutLib "/usr/lib/libglut.so" )
-### Inline-C functions ###
-(gcc "glut" (list *GlutLib)
- (glClearColor (Red Green Blue Alpha) "GlClearColor" NIL Red Green Blue Alpha 1.0) )
-
-#include <GL/glut.h>
-#include <GL/glu.h>
-#include <GL/gl.h>
-
-void GlClearColor(long red, long green, long blue, long alpha, int scl) {
- glClearColor((GLclampf)red / (float)scl, (GLclampf)green / (float)scl,
- (GLclampf)blue / (float)scl, (GLclampf)alpha / (float)scl );
-}
-/**/
-
# Pre-consed fixpoint arguments
(setq
- "Fix1" (0 . 1.0)
- "Fix2" (0 . 1.0)
- "Fix3" (0 . 1.0)
- "Fix4" (0 . 1.0)
- "Fix5" (0 . 1.0)
- "Fix6" (0 . 1.0) )
+ "Flt1" (0 . -1.0)
+ "Flt2" (0 . -1.0)
+ "Flt3" (0 . -1.0)
+ "Flt4" (0 . -1.0)
+ "Dbl1" (0 . 1.0)
+ "Dbl2" (0 . 1.0)
+ "Dbl3" (0 . 1.0)
+ "Dbl4" (0 . 1.0)
+ "Dbl5" (0 . 1.0)
+ "Dbl6" (0 . 1.0) )
### Native functions ###
(de glutInit ()
@@ -184,45 +174,49 @@ void GlClearColor(long red, long green, long blue, long alpha, int scl) {
(de glEnd ()
(native `*GlutLib "glEnd") )
+(de glClearColor (Red Green Blue Alpha)
+ (set "Flt1" Red "Flt2" Green "Flt3" Blue "Flt4" Alpha)
+ (native `*GlutLib "glClearColor" NIL "Flt1" "Flt2" "Flt3" "Flt4") )
+
(de glClearDepth (Depth)
- (set "Fix1" Depth)
- (native `*GlutLib "glClearDepth" NIL "Fix1") )
+ (set "Dbl1" Depth)
+ (native `*GlutLib "glClearDepth" NIL "Dbl1") )
(de glColor3f (Red Green Blue)
- (set "Fix1" Red "Fix2" Green "Fix3" Blue)
- (native `*GlutLib "glColor3f" NIL "Fix1" "Fix2" "Fix3") )
+ (set "Dbl1" Red "Dbl2" Green "Dbl3" Blue)
+ (native `*GlutLib "glColor3f" NIL "Dbl1" "Dbl2" "Dbl3") )
(de glColor4f (Red Green Blue Alpha)
- (set "Fix1" Red "Fix2" Green "Fix3" Blue "Fix4" Alpha)
- (native `*GlutLib "glColor4f" NIL "Fix1" "Fix2" "Fix3" "Fix4") )
+ (set "Dbl1" Red "Dbl2" Green "Dbl3" Blue "Dbl4" Alpha)
+ (native `*GlutLib "glColor4f" NIL "Dbl1" "Dbl2" "Dbl3" "Dbl4") )
(de glNormal3f (X Y Z)
- (set "Fix1" X "Fix2" Y "Fix3" Z)
- (native `*GlutLib "glNormal3f" NIL "Fix1" "Fix2" "Fix3") )
+ (set "Dbl1" X "Dbl2" Y "Dbl3" Z)
+ (native `*GlutLib "glNormal3f" NIL "Dbl1" "Dbl2" "Dbl3") )
(de glOrtho (Left Right Bottom Top Near Far)
- (set "Fix1" Left "Fix2" Right "Fix3" Bottom "Fix4" Top "Fix5" Near "Fix6" Far)
- (native `*GlutLib "glOrtho" NIL "Fix1" "Fix2" "Fix3" "Fix4" "Fix5" "Fix6") )
+ (set "Dbl1" Left "Dbl2" Right "Dbl3" Bottom "Dbl4" Top "Dbl5" Near "Dbl6" Far)
+ (native `*GlutLib "glOrtho" NIL "Dbl1" "Dbl2" "Dbl3" "Dbl4" "Dbl5" "Dbl6") )
(de glRotatef (X Y Z)
- (set "Fix1" X "Fix2" Y "Fix3" Z)
- (native `*GlutLib "glRotatef" NIL "Fix1" "Fix2" "Fix3") )
+ (set "Dbl1" X "Dbl2" Y "Dbl3" Z)
+ (native `*GlutLib "glRotatef" NIL "Dbl1" "Dbl2" "Dbl3") )
(de glTranslatef (X Y Z)
- (set "Fix1" X "Fix2" Y "Fix3" Z)
- (native `*GlutLib "glTranslatef" NIL "Fix1" "Fix2" "Fix3") )
+ (set "Dbl1" X "Dbl2" Y "Dbl3" Z)
+ (native `*GlutLib "glTranslatef" NIL "Dbl1" "Dbl2" "Dbl3") )
(de glVertex3f (X Y Z)
- (set "Fix1" X "Fix2" Y "Fix3" Z)
- (native `*GlutLib "glVertex3f" NIL "Fix1" "Fix2" "Fix3") )
+ (set "Dbl1" X "Dbl2" Y "Dbl3" Z)
+ (native `*GlutLib "glVertex3f" NIL "Dbl1" "Dbl2" "Dbl3") )
(de glutSolidCube (Size)
- (set "Fix1" Size)
- (native `*GlutLib "glutSolidCube" NIL "Fix1") )
+ (set "Dbl1" Size)
+ (native `*GlutLib "glutSolidCube" NIL "Dbl1") )
(de glutWireCube (Size)
- (set "Fix1" Size)
- (native `*GlutLib "glutWireCube" NIL "Fix1") )
+ (set "Dbl1" Size)
+ (native `*GlutLib "glutWireCube" NIL "Dbl1") )
(de glColorMaterial (Face Mode)
(native `*GlutLib "glColorMaterial" NIL Face Mode) )
diff --git a/lib/tags b/lib/tags
@@ -32,9 +32,9 @@ and (1643 . "@src64/flow.l")
any (3792 . "@src64/io.l")
append (1329 . "@src64/subr.l")
apply (597 . "@src64/apply.l")
-arg (2198 . "@src64/main.l")
-args (2174 . "@src64/main.l")
-argv (2819 . "@src64/main.l")
+arg (2207 . "@src64/main.l")
+args (2183 . "@src64/main.l")
+argv (2828 . "@src64/main.l")
as (146 . "@src64/flow.l")
asoq (2942 . "@src64/subr.l")
assoc (2907 . "@src64/subr.l")
@@ -65,7 +65,7 @@ call (3102 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1984 . "@src64/flow.l")
catch (2484 . "@src64/flow.l")
-cd (2574 . "@src64/main.l")
+cd (2583 . "@src64/main.l")
cdaaar (464 . "@src64/subr.l")
cdaadr (487 . "@src64/subr.l")
cdaar (179 . "@src64/subr.l")
@@ -87,7 +87,7 @@ chop (1093 . "@src64/sym.l")
circ (816 . "@src64/subr.l")
clip (1786 . "@src64/subr.l")
close (4180 . "@src64/io.l")
-cmd (2801 . "@src64/main.l")
+cmd (2810 . "@src64/main.l")
cnt (1297 . "@src64/apply.l")
co (2566 . "@src64/flow.l")
commit (1503 . "@src64/db.l")
@@ -98,9 +98,9 @@ connect (201 . "@src64/net.l")
cons (747 . "@src64/subr.l")
copy (1216 . "@src64/subr.l")
ctl (4120 . "@src64/io.l")
-ctty (2599 . "@src64/main.l")
+ctty (2608 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2313 . "@src64/main.l")
+date (2322 . "@src64/main.l")
dbck (2092 . "@src64/db.l")
de (549 . "@src64/flow.l")
dec (2323 . "@src64/big.l")
@@ -110,7 +110,7 @@ del (1852 . "@src64/sym.l")
delete (1392 . "@src64/subr.l")
delq (1443 . "@src64/subr.l")
diff (2563 . "@src64/subr.l")
-dir (2732 . "@src64/main.l")
+dir (2741 . "@src64/main.l")
dm (561 . "@src64/flow.l")
do (2158 . "@src64/flow.l")
e (2932 . "@src64/flow.l")
@@ -126,7 +126,7 @@ extern (900 . "@src64/sym.l")
extra (1284 . "@src64/flow.l")
extract (1102 . "@src64/apply.l")
fifo (1963 . "@src64/sym.l")
-file (2679 . "@src64/main.l")
+file (2688 . "@src64/main.l")
fill (3177 . "@src64/subr.l")
filter (1045 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
@@ -163,7 +163,7 @@ ifn (1884 . "@src64/flow.l")
in (4016 . "@src64/io.l")
inc (2256 . "@src64/big.l")
index (2611 . "@src64/subr.l")
-info (2636 . "@src64/main.l")
+info (2645 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
@@ -179,15 +179,15 @@ lieu (1163 . "@src64/db.l")
line (3526 . "@src64/io.l")
lines (3679 . "@src64/io.l")
link (1163 . "@src64/subr.l")
-lisp1 (1778 . "@src64/main.l")
-lisp2 (1794 . "@src64/main.l")
-lisp3 (1800 . "@src64/main.l")
-lisp4 (1806 . "@src64/main.l")
-lisp5 (1812 . "@src64/main.l")
-lisp6 (1818 . "@src64/main.l")
-lisp7 (1824 . "@src64/main.l")
-lisp8 (1830 . "@src64/main.l")
-lisp9 (1836 . "@src64/main.l")
+lisp1 (1787 . "@src64/main.l")
+lisp2 (1803 . "@src64/main.l")
+lisp3 (1809 . "@src64/main.l")
+lisp4 (1815 . "@src64/main.l")
+lisp5 (1821 . "@src64/main.l")
+lisp6 (1827 . "@src64/main.l")
+lisp7 (1833 . "@src64/main.l")
+lisp8 (1839 . "@src64/main.l")
+lisp9 (1845 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
@@ -229,7 +229,7 @@ nand (1678 . "@src64/flow.l")
native (1366 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (2181 . "@src64/main.l")
+next (2190 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -243,7 +243,7 @@ onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2922 . "@src64/main.l")
+opt (2931 . "@src64/main.l")
or (1659 . "@src64/flow.l")
out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -276,7 +276,7 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2563 . "@src64/main.l")
+pwd (2572 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
quit (1075 . "@src64/main.l")
quote (141 . "@src64/flow.l")
@@ -287,7 +287,7 @@ raw (465 . "@src64/main.l")
rd (4953 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2227 . "@src64/main.l")
+rest (2236 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -328,7 +328,7 @@ text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
till (3437 . "@src64/io.l")
-time (2446 . "@src64/main.l")
+time (2455 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -341,9 +341,9 @@ up (712 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2551 . "@src64/main.l")
+usec (2560 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2936 . "@src64/main.l")
+version (2945 . "@src64/main.l")
wait (3016 . "@src64/io.l")
when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
diff --git a/src64/arch/x86-64.l b/src64/arch/x86-64.l
@@ -1,4 +1,4 @@
-# 29jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
# Byte order
@@ -573,62 +573,45 @@
(asm jgt (Adr A)
(_jmp "ja" "jbe") )
-(asm darg ()
- (prinst "movapd" "%xmm4" "%xmm5") # Push float stack
- (prinst "movapd" "%xmm3" "%xmm4")
- (prinst "movapd" "%xmm2" "%xmm3")
- (prinst "movapd" "%xmm1" "%xmm2")
- (prinst "movapd" "%xmm0" "%xmm1")
- (prinst "testb" "$0x02" "%al") # Short number?
- (prinst "jz" "2f") # No: Skip
- (prinst "shr" "$4" "%rdx") # Normalize scale
- (prinst "shr" "$4" "%rax") # and number
- (prinst "jnc" "1f") # Carry?
- (prinst "neg" "%rax") # Yes: Negate
- (prinl "1:")
- (prinst "cvtsi2sd" "%rax" "%xmm0") # Convert to fixnum
- (prinst "cvtsi2sd" "%rdx" "%xmm7")
- (prinst "divsd" "%xmm7" "%xmm0")
- (prinst "jmp" "4f")
- (prinl "2:")
- (prinst "cmp" "$Nil" "%rax") # NIL?
- (prinst "mov" "$0x7FF0000000000000" "%rax") # +inf
- (prinst "jnz" "3f") # No: Skip
- (prinst "mov" "$0xFFF0000000000000" "%rax") # -inf
- (prinl "3:")
- (prinst "push" "%rax") # Push value
- (prinst "movsd" "(%rsp)" "%xmm0") # into float stack
- (prinst "add" "$8" "%rsp") # Drop buffer
- (prinl "4:") )
-
(asm dval ()
(prinst "movsd" "(%rdx)" "%xmm0") )
+(asm fval ()
+ (prinst "movss" "(%rdx)" "%xmm0") )
+
(asm fix ()
(prinst "sub" "$8" "%rsp") # Space for buffer
(prinst "shr" "$4" "%rbx") # Normalize scale
- (prinst "cvtsi2sd" "%rbx" "%xmm7") # Mulitply with scale
+ (prinst "jc" "1f") # Jump if negative
+ (prinst "cvtsi2sd" "%rbx" "%xmm7") # Mulitply double with scale
(prinst "mulsd" "%xmm7" "%xmm0")
(prinst "movsd" "%xmm0" "(%rsp)") # Keep result
(prinst "call" "lround")
+ (prinst "jmp" "2f")
+ (prinl "1:")
+ (prinst "cvtsi2ss" "%rbx" "%xmm7") # Mulitply float with scale
+ (prinst "mulss" "%xmm7" "%xmm0")
+ (prinst "movss" "%xmm0" "4(%rsp)") # Keep result
+ (prinst "call" "lroundf")
+ (prinl "2:")
(prinst "mov" "%rax" "%rbx") # Get into E
(prinst "or" "%rax" "%rax") # Negative?
- (prinst "js" "1f") # Yes: Skip
+ (prinst "js" "3f") # Yes: Skip
(prinst "shl" "$4" "%rbx") # Make positive short
(prinst "orb" "$2" "%bl")
- (prinst "jmp" "3f")
- (prinl "1:")
+ (prinst "jmp" "5f")
+ (prinl "3:")
(prinst "neg" "%rbx") # Negate
- (prinst "js" "2f") # Still negative: Overflow
+ (prinst "js" "4f") # Still negative: Overflow
(prinst "shl" "$4" "%rbx") # Make negative short
(prinst "orb" "$10" "%bl")
- (prinst "jmp" "3f")
- (prinl "2:") # Infinite/NaN
+ (prinst "jmp" "5f")
+ (prinl "4:") # Infinite/NaN
(prinst "mov" "$Nil" "%rbx") # Preload NIL
(prinst "testb" "$0x80" "7(%rsp)") # Float value negative?
- (prinst "jnz" "3f") # Yes: Skip
+ (prinst "jnz" "5f") # Yes: Skip
(prinst "mov" "$TSym" "%rbx") # Load T
- (prinl "3:")
+ (prinl "5:")
(prinst "add" "$8" "%rsp") ) # Drop buffer
(asm cc (Adr A Arg M)
@@ -671,11 +654,80 @@
# Don't use SSE registers in varargs for static calls
(when (member Adr '("printf" "fprintf" "sprintf"))
(prinst "xor" "%al" "%al") ) )
- (for R Reg
- (prinst "cmp" "%rsp" Arg)
- (prinst "jz" "1f")
- (prinst "pop" R) )
+ (prinst "lea" "5f(%rip)" "%r11")
+ (mapc
+ '((R X)
+ (prinl "1:")
+ (prinst "cmp" "%rsp" Arg)
+ (prinst "jz" "9f")
+ (prinst "pop" "%r10")
+ (prinst "or" "%r10" "%r10")
+ (prinst "jz" "7f")
+ (prinst "call" "*%r11")
+ (prinst "add" "$8" "%rsp")
+ (prinst "jmp" "1b")
+ (prinl "5:")
+ (unless (= R "%r9")
+ (prinst "lea" "(5f-5b)(%r11)" "%r11") )
+ (prinst "shr" "$4" "%r10")
+ (prinst "jc" "3f")
+ (prinst "testb" "$0x02" "8(%rsp)")
+ (prinst "jz" "2f")
+ (prinst "cvtsi2sd" "%r10" "%xmm7")
+ (prinst "mov" "8(%rsp)" "%r10")
+ (prinst "shr" "$4" "%r10")
+ (prinst "jnc" "1f")
+ (prinst "neg" "%r10")
+ (prinl "1:")
+ (prinst "cvtsi2sd" "%r10" X)
+ (prinst "divsd" "%xmm7" X)
+ (prinst "ret")
+ (prinl "2:")
+ (prinst "cmpq" "$Nil" "8(%rsp)")
+ (prinst "mov" "$0x7FF0000000000000" "%r10")
+ (prinst "jnz" "1f")
+ (prinst "mov" "$0xFFF0000000000000" "%r10")
+ (prinl "1:")
+ (prinst "mov" "%r10" "8(%rsp)")
+ (prinst "movsd" "8(%rsp)" X)
+ (prinst "ret")
+ (prinl "3:")
+ (prinst "testb" "$0x02" "8(%rsp)")
+ (prinst "jz" "2f")
+ (prinst "cvtsi2ss" "%r10" "%xmm7")
+ (prinst "mov" "8(%rsp)" "%r10")
+ (prinst "shr" "$4" "%r10")
+ (prinst "jnc" "1f")
+ (prinst "neg" "%r10")
+ (prinl "1:")
+ (prinst "cvtsi2ss" "%r10" X)
+ (prinst "divss" "%xmm7" X)
+ (prinst "ret")
+ (prinl "2:")
+ (prinst "cmpq" "$Nil" "8(%rsp)")
+ (prinst "mov" "$0x7F800000" "%r10")
+ (prinst "jnz" "1f")
+ (prinst "mov" "$0xFF800000" "%r10")
+ (prinl "1:")
+ (prinst "mov" "%r10" "8(%rsp)")
+ (prinst "movss" "8(%rsp)" X)
+ (prinst "ret")
+ (prinl "7:")
+ (prinst "pop" R) )
+ Reg
+ '("%xmm0" "%xmm1" "%xmm2" "%xmm3" "%xmm4" "%xmm5") )
+ (prinst "mov" "%rax" "%r11")
+ (prinl "1:")
+ (prinst "cmp" "%rsp" "%rax")
+ (prinst "jz" "1f")
+ (prinst "sub" "$16" "%rax")
+ (prinst "sub" "$8" "%r11")
+ (prinst "mov" "8(%rax)" "%r10")
+ (prinst "or" "%r10" "(%r11)")
+ (prinst "jmp 1b")
(prinl "1:")
+ (prinst "mov" "%r11" "%rsp")
+ (prinl "9:")
# Maximally 6 SSE registers in varargs for dynamic calls
(prinst "mov" "$6" "%al") ) )
((get 'call 'asm) Adr A)
diff --git a/src64/lib/asm.l b/src64/lib/asm.l
@@ -1,4 +1,4 @@
-# 29jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
# *LittleEndian *Registers optimize
@@ -392,7 +392,6 @@
(cmp4 (source) "*Mode")
(cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode")
(cnt (source) "*Mode")
- (darg)
(dbg)
(dec (destination) "*Mode")
(div (source) "*Mode")
@@ -403,6 +402,7 @@
(eval/ret)
(exec (reg (read)))
(fix)
+ (fval)
(hx2 (read))
(inc (destination) "*Mode")
(initCode)
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 29jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -1482,6 +1482,7 @@
end
end
push E # Pass long argument
+ push 0 # as Integer/pointer value
else
sym E # String?
if nz # Yes
@@ -1491,18 +1492,20 @@
ld S Z # Drop buffer
pop Z
push A # Pass pointer argument
+ push 0 # as Integer/pointer value
else
- ld C (E CDR) # Double?
+ ld C (E CDR) # Fixpoint?
cnt C
if nz # Yes
- ld A (E) # Get number
- darg # Pass double argument
+ push (E) # Pass number or flag
+ push C # as fixpoint value
else
ld E C # Ignore variable
ld C ((E)) # Get buffer size
shr C 4 # Normalize
call allocC_A # Allocate buffer
push A # Pass pointer argument
+ push 0 # as Integer/pointer value
push Z
ld Z A # Buffer pointer in Z
do
@@ -1560,7 +1563,7 @@
if z # No
sym E # String?
jnz 10 # Yes
- cnt (E CDR) # Double?
+ cnt (E CDR) # Fixpoint?
if z # No
cmp (E) Nil # Variable?
if ne # Yes
@@ -1589,8 +1592,14 @@
if nz # Yes
null C # Pointer?
if nz # Yes
- dval # Get double value
- add C 8 # Size of double
+ test E SIGN # Negative?
+ if z # No
+ dval # Get double value
+ add C 8 # Size of double
+ else
+ fval # Get float value
+ add C 4 # Size of float
+ end
end
fix # Get fixpoint number or flg
else
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 28jul10abu
+# 02aug10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 9)
+(de *Version 3 0 3 10)
# vi:et:ts=3:sw=3
