picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

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:
Mdoc/refN.html | 3++-
Mdoc64/asm | 4++--
Mlib/math64.l | 46+++++++++++++++++++++++-----------------------
Mlib/openGl.l | 78++++++++++++++++++++++++++++++++++++------------------------------------------
Mlib/tags | 52++++++++++++++++++++++++++--------------------------
Msrc64/arch/x86-64.l | 136++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------
Msrc64/lib/asm.l | 4++--
Msrc64/main.l | 23++++++++++++++++-------
Msrc64/version.l | 4++--
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