commit eb5bd8c900a2427201369b5ac58299be5a16d06e
parent df19d85c224e42d7a3843a249c76c7348a332767
Author: Commit-Bot <unknown>
Date: Tue, 27 Jul 2010 18:36:54 +0000
Automatic commit from picoLisp.tgz, From: Tue, 27 Jul 2010 18:36:54 GMT
Diffstat:
11 files changed, 477 insertions(+), 342 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXsep10 picoLisp-3.0.4
+ 'native' fixpoint handling
OpenGL (64-bit) in "lib/openGl.l"
Faster bignum division (64-bit)
diff --git a/ReleaseNotes b/ReleaseNotes
@@ -1,4 +1,4 @@
-22jul10abu
+27jul10abu
(c) Software Lab. Alexander Burger
@@ -11,3 +11,7 @@ A. In the 64-bit version bignum division is now faster by a factor between 20
32-bit version).
B. An OpenGL library (64-bit) is now part of the standard release.
+
+C. The 'native' function now also accepts up to six fixpoint arguments of the
+ form (value . 1.0), and can return scaled fixpoint numbers if the return spec
+ is a number (typically 1.0).
diff --git a/doc/refN.html b/doc/refN.html
@@ -137,7 +137,7 @@ assigned as values to be cached and used in subsequent calls. The third
<code>sym|lst</code> argument is a return value specification, while all
following arguments are the arguments to the native function.
-<p>The return value specification may either be one of the symbols
+<p>The return value specification may either be one of the atoms
<pre><code>
NIL void
@@ -146,10 +146,11 @@ 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
</code></pre>
-<p>or nested lists of these symbols with size specifications to denote arrays
-and structures, e.g.
+<p>or nested lists of these atoms with size specifications to denote arrays and
+structures, e.g.
<pre><code>
(N . 4) # long[4]; -> (1 2 3 4)
@@ -157,12 +158,16 @@ and 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), symbols (passed as
-strings), or a list with a variable in the CAR (to recieve the returned
+<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 in the CDDR.
+<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.
+
<pre><code>
: (native "@" "getenv" 'S "TERM") # Same as (sys "TERM")
-> "xterm"
@@ -171,6 +176,10 @@ initialization bytes in the CDDR.
abc7XYZ
-> 8
+: (native "@" "printf" 'I "This is %.3f^J" (123456 . 1000))
+This is 123.456
+-> 16
+
: (use Tim
(native "@" "time" NIL '(Tim (8 B . 8))) # time_t 8 # Get time_t structure
(native "@" "localtime" '(I . 9) (cons NIL (8) Tim)) ) # Read local time
diff --git a/doc64/asm b/doc64/asm
@@ -1,4 +1,4 @@
-# 13jun10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
@@ -77,115 +77,118 @@
========================================================================
Instruction set:
- nop # No operation
+ nop # No operation
Move Instructions:
- ld dst src # Load 'dst' from 'src' [---]
- ld2 src # Load 'A' from two bytes 'src' (unsigned)
- ld4 src # Load 'A' from four bytes 'src' (unsigned)
- ldc dst src # Load if Carry 'dst' from 'src'
- ldnc dst src # Load if not Carry 'dst' from 'src'
- ldz dst src # Load if Zero 'dst' from 'src'
- ldnz dst src # Load if not Zero 'dst' from 'src'
- lea dst src # Load 'dst' with effective address of 'src'
- st2 dst # Store two bytes from 'A' into 'dst'
- st4 dst # Store four bytes from 'A' into 'dst'
- xchg dst dst # Exchange 'dst's
- movn dst src cnt # Move 'cnt' bytes from 'src' to 'dst'
- mset dst cnt # Set 'cnt' bytes of memory to B
- movm dst src end # Move memory 'src'..'end' to 'dst' (aligned)
- save src end dst # Save 'src'..'end' to 'dst' (non-overlapping)
- load dst end src # Load 'dst'..'end' from 'src' (non-overlapping)
+ ld dst src # Load 'dst' from 'src' [---]
+ ld2 src # Load 'A' from two bytes 'src' (unsigned)
+ ld4 src # Load 'A' from four bytes 'src' (unsigned)
+ ldc dst src # Load if Carry 'dst' from 'src'
+ ldnc dst src # Load if not Carry 'dst' from 'src'
+ ldz dst src # Load if Zero 'dst' from 'src'
+ ldnz dst src # Load if not Zero 'dst' from 'src'
+ lea dst src # Load 'dst' with effective address of 'src'
+ st2 dst # Store two bytes from 'A' into 'dst'
+ st4 dst # Store four bytes from 'A' into 'dst'
+ xchg dst dst # Exchange 'dst's
+ movn dst src cnt # Move 'cnt' bytes from 'src' to 'dst'
+ mset dst cnt # Set 'cnt' bytes of memory to B
+ movm dst src end # Move memory 'src'..'end' to 'dst' (aligned)
+ save src end dst # Save 'src'..'end' to 'dst' (non-overlapping)
+ load dst end src # Load 'dst'..'end' from 'src' (non-overlapping)
Arithmetics:
- add dst src # Add 'src' to 'dst'
- addc dst src # Add 'src' to 'dst' with Carry
- sub dst src # Subtract 'src' from 'dst'
- subc dst src # Subtract 'src' from 'dst' with Carry
-
- inc dst # Increment 'dst' [z..]
- dec dst # Increment 'dst' [z..]
- not dst # One's complement negation of 'dst'
- neg dst # Two's complement negation of 'dst'
-
- and dst src # Bitwise AND 'dst' with 'src'
- or dst src # Bitwise OR 'dst' with 'src'
- xor dst src # Bitwise XOR 'dst' with 'src'
- off dst src # Clear 'src' bits in 'src'
- test dst src # Bit-test 'dst' with 'src'
-
- shl dst src # Shift 'dst' left into Carry by 'src' bits
- shr dst src # Shift 'dst' right into Carry by 'src' bits
- rol dst src # Rotate 'dst' left by 'src' bits
- ror dst src # Rotate 'dst' right by 'src' bits
- rcl dst src # Rotate 'dst' with Carry left by 'src' bits
- rcr dst src # Rotate 'dst' with Carry right by 'src' bits
-
- mul src # Multiplication of 'A' and 'src' into 'D' [...]
- div src # Division of 'D' by 'src' into 'A', 'C' [...]
-
- zxt # Zero-extend 'B' to 'A'
-
- setc # Set Carry flag
- clrc # Clear Carry flag
- setz # Set Zero flag
- clrz # Clear Zero flag
+ add dst src # Add 'src' to 'dst'
+ addc dst src # Add 'src' to 'dst' with Carry
+ sub dst src # Subtract 'src' from 'dst'
+ subc dst src # Subtract 'src' from 'dst' with Carry
+
+ inc dst # Increment 'dst' [z..]
+ dec dst # Increment 'dst' [z..]
+ not dst # One's complement negation of 'dst'
+ neg dst # Two's complement negation of 'dst'
+
+ and dst src # Bitwise AND 'dst' with 'src'
+ or dst src # Bitwise OR 'dst' with 'src'
+ xor dst src # Bitwise XOR 'dst' with 'src'
+ off dst src # Clear 'src' bits in 'src'
+ test dst src # Bit-test 'dst' with 'src'
+
+ shl dst src # Shift 'dst' left into Carry by 'src' bits
+ shr dst src # Shift 'dst' right into Carry by 'src' bits
+ rol dst src # Rotate 'dst' left by 'src' bits
+ ror dst src # Rotate 'dst' right by 'src' bits
+ rcl dst src # Rotate 'dst' with Carry left by 'src' bits
+ rcr dst src # Rotate 'dst' with Carry right by 'src' bits
+
+ mul src # Multiplication of 'A' and 'src' into 'D' [...]
+ div src # Division of 'D' by 'src' into 'A', 'C' [...]
+
+ zxt # Zero-extend 'B' to 'A'
+
+ setc # Set Carry flag
+ clrc # Clear Carry flag
+ setz # Set Zero flag
+ clrz # Clear Zero flag
Comparisons:
- cmp dst src # Compare 'dst' with 'src' [z.c]
- cmp4 src # Compare four bytes in 'A' with 'src'
- cmpn dst src cnt # Compare 'cnt' bytes 'dst' with 'src'
- slen dst src # Set 'dst' to the string length of 'src'
- memb src cnt # Find B in 'cnt' bytes of memory
- null src # Compare 'src' with 0 [zs.]
- zero src # Test if ZERO [z..]
- nul4 # Compare four bytes in 'A' with 0 [zs.]
+ cmp dst src # Compare 'dst' with 'src' [z.c]
+ cmp4 src # Compare four bytes in 'A' with 'src'
+ cmpn dst src cnt # Compare 'cnt' bytes 'dst' with 'src'
+ slen dst src # Set 'dst' to the string length of 'src'
+ memb src cnt # Find B in 'cnt' bytes of memory
+ null src # Compare 'src' with 0 [zs.]
+ zero src # Test if ZERO [z..]
+ nul4 # Compare four bytes in 'A' with 0 [zs.]
Byte addressing:
- set dst src # Set 'dst' byte to 'src'
- nul src # Compare byte 'src' with 0
+ set dst src # Set 'dst' byte to 'src'
+ nul src # Compare byte 'src' with 0
Types:
- cnt src # Non-'z' if small number
- big src # Non-'z' if bignum
- num src # Non-'z' if number
- sym src # Non-'z' if symbol
- atom src # Non-'z' if atom
+ cnt src # Non-'z' if small number
+ big src # Non-'z' if bignum
+ num src # Non-'z' if number
+ sym src # Non-'z' if symbol
+ atom src # Non-'z' if atom
Flow Control:
- jmp adr # Jump to 'adr'
- jz adr # Jump to 'adr' if Zero
- jnz adr # Jump to 'adr' if not Zero
- js adr # Jump to 'adr' if Sign
- jns adr # Jump to 'adr' if not Sign
- jc adr # Jump to 'adr' if Carry
- jnc adr # Jump to 'adr' if not Carry
-
- 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'
-
- ret # Return
- begin src # Called from C-function with 'src' arguments
- return src # Return to C-function
+ jmp adr # Jump to 'adr'
+ jz adr # Jump to 'adr' if Zero
+ jnz adr # Jump to 'adr' if not Zero
+ js adr # Jump to 'adr' if Sign
+ jns adr # Jump to 'adr' if not Sign
+ jc adr # Jump to 'adr' if Carry
+ jnc adr # Jump to 'adr' if not Carry
+
+ 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 src src # Pass double argument 'src' and scale 'src'
+ dval src # Set up double value 'src'
+ fix src # Convert double with scale 'src' to fixnum in 'A' [.sc]
+
+ ret # Return
+ begin src # Called from C-function with 'src' arguments
+ return src # Return to C-function
Stack Manipulations:
- push src # Push 'src' [---]
- pop dst # Pop 'dst' [---]
- link # Setup frame
- tuck src # Extend frame
- drop # Drop frame
+ push src # Push 'src' [---]
+ pop dst # Pop 'dst' [---]
+ link # Setup frame
+ tuck src # Extend frame
+ drop # Drop frame
Evaluation:
- eval # Evaluate expression in 'E'
- eval+ # Evaluate expression in partial stack frame
- eval/ret # Evaluate expression and return
- exec reg # Execute lists in 'reg', ignore results
- prog reg # Evaluate expressions in 'reg', return last result
+ eval # Evaluate expression in 'E'
+ eval+ # Evaluate expression in partial stack frame
+ eval/ret # Evaluate expression and return
+ exec reg # Execute lists in 'reg', ignore results
+ prog reg # Evaluate expressions in 'reg', return last result
System:
- init # Init runtime system
- dbg # Debug breakpoint
+ init # Init runtime system
+ dbg # Debug breakpoint
========================================================================
diff --git a/lib/math64.l b/lib/math64.l
@@ -1,72 +1,48 @@
-# 21jul10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
-(load "@lib/native.l")
+(setq
+ "Arg1" (0 . 1.0)
+ "Arg2" (0 . 1.0) )
-(de log (X)
- (and (gt0 X) ("log" X 1.0)) )
-
-(gcc "math" NIL
- (pow (X Y) "Pow" 'N X Y 1.0)
- (exp (X) "Exp" 'N X 1.0)
- ("log" (X) "Log" 'N X 1.0)
- (sin (A) "Sin" 'N A 1.0)
- (cos (A) "Cos" 'N A 1.0)
- (tan (A) "Tan" 'N A 1.0)
- (asin (A) "Asin" 'N A 1.0)
- (acos (A) "Acos" 'N A 1.0)
- (atan (A) "Atan" 'N A 1.0)
- (atan2 (X Y) "Atan2" 'N X Y 1.0) )
-
-#include <math.h>
+(de pow (X Y)
+ (set "Arg1" X "Arg2" Y)
+ (native "@" "pow" 1.0 "Arg1" "Arg2") )
-static long mkNum(int scl, double d) {
- if (isnan(d) || isinf(d) < 0)
- return 0x8000000000000000;
- if (isinf(d) > 0)
- return 0x7FFFFFFFFFFFFFFF;
- return round((double)scl * d);
-}
+(de exp (X)
+ (set "Arg1" X)
+ (native "@" "exp" 1.0 "Arg1") )
-long Pow(long x, long y, int scl) {
- return mkNum(scl, pow((double)x / (double)scl, (double)y / (double)scl));
-}
-
-long Exp(long x, int scl) {
- return mkNum(scl, exp((double)x / (double)scl));
-}
-
-long Log(long x, int scl) {
- return mkNum(scl, log((double)x / (double)scl));
-}
+(de log (X)
+ (when (gt0 (set "Arg1" X))
+ (native "@" "log" 1.0 "Arg1") ) )
-long Sin(long a, int scl) {
- return mkNum(scl, sin((double)a / (double)scl));
-}
+(de sin (A)
+ (set "Arg1" A)
+ (native "@" "sin" 1.0 "Arg1") )
-long Cos(long a, int scl) {
- return mkNum(scl, cos((double)a / (double)scl));
-}
+(de cos (A)
+ (set "Arg1" A)
+ (native "@" "cos" 1.0 "Arg1") )
-long Tan(long a, int scl) {
- return mkNum(scl, tan((double)a / (double)scl));
-}
+(de tan (A)
+ (set "Arg1" A)
+ (native "@" "tan" 1.0 "Arg1") )
-long Asin(long a, int scl) {
- return mkNum(scl, asin((double)a / (double)scl));
-}
+(de asin (A)
+ (set "Arg1" A)
+ (native "@" "asin" 1.0 "Arg1") )
-long Acos(long a, int scl) {
- return mkNum(scl, acos((double)a / (double)scl));
-}
+(de acos (A)
+ (set "Arg1" A)
+ (native "@" "acos" 1.0 "Arg1") )
-long Atan(long a, int scl) {
- return mkNum(scl, atan((double)a / (double)scl));
-}
+(de atan (A)
+ (set "Arg1" A)
+ (native "@" "atan" 1.0 "Arg1") )
-long Atan2(long x, long y, int scl) {
- return mkNum(scl, atan2((double)x / (double)scl, (double)y / (double)scl));
-}
-/**/
+(de atan2 (X Y)
+ (set "Arg1" X "Arg2" Y)
+ (native "@" "atan2" 1.0 "Arg1" "Arg2") )
# vi:et:ts=3:sw=3
diff --git a/lib/openGl.l b/lib/openGl.l
@@ -1,5 +1,5 @@
-# 24jul10abu
-# 22jul10jk
+# 27jul10abu
+# 27jul10jk
# (c) Software Lab. Alexander Burger
(load "@lib/math.l" "@lib/native.l")
@@ -105,6 +105,7 @@
(def 'GLUT_KEY_F10 10)
(def 'GLUT_KEY_F11 11)
(def 'GLUT_KEY_F12 12)
+
# Directional keys
(def 'GLUT_KEY_LEFT 100)
(def 'GLUT_KEY_UP 101)
@@ -131,9 +132,16 @@
### Inline-C functions ###
(gcc "glut" (list *GlutLib)
(glClearColor (Red Green Blue Alpha) "GlClearColor" NIL Red Green Blue Alpha 1.0)
+ (glClearDepth (Depth) "GlClearDepth" NIL Depth 1.0)
(glColor3f (Red Green Blue) "GlColor3f" NIL Red Green Blue 1.0)
+ (glColor4f (Red Green Blue Alpha) "GlColor4f" NIL Red Green Blue Alpha 1.0)
+ (glNormal3f (X Y Z) "GlNormal3f" NIL X Y Z 1.0)
(glOrtho (Left Right Bottom Top Near Far) "GlOrtho" NIL Left Right Bottom Top Near Far 1.0)
+ (glRotatef (X Y Z) "GlRotatef" NIL Angle X Y Z 1.0)
+ (glTranslatef (X Y Z) "GlTranslatef" NIL X Y Z 1.0)
(glVertex3f (X Y Z) "GlVertex3f" NIL X Y Z 1.0)
+ (glutSolidCube () "GlutSolidCube")
+ (glutWireCube () "GlutWireCube")
(glutDisplayFunc () "GlutDisplayFunc")
(glutCreateMenu () "GlutCreateMenu")
(glutKeyboardFunc () "GlutKeyboardFunc")
@@ -157,6 +165,11 @@ void GlClearColor(long red, long green, long blue, long alpha, int scl) {
(GLclampf)alpha / (float)scl );
}
+void GlClearDepth(long depth, int scl) {
+ glClearDepth(
+ (double)depth / (double)scl );
+}
+
void GlColor3f(long red, long green, long blue, int scl) {
glColor3f(
(double)red / (double)scl,
@@ -164,6 +177,21 @@ void GlColor3f(long red, long green, long blue, int scl) {
(double)blue / (double)scl );
}
+void GlColor4f(long red, long green, long blue, long alpha, int scl) {
+ glColor4f(
+ (double)red / (double)scl,
+ (double)green / (double)scl,
+ (double)blue / (double)scl,
+ (double)alpha / (double)scl );
+}
+
+void GlNormal3f(long vx, long vy, long vz, int scl) {
+ glNormal3f(
+ (double)vx / (double)scl,
+ (double)vy / (double)scl,
+ (double)vz / (double)scl );
+}
+
void GlOrtho(long left, long right, long bottom, long top, long near, long far, long scl) {
glOrtho(
(double)left / (double)scl,
@@ -174,6 +202,21 @@ void GlOrtho(long left, long right, long bottom, long top, long near, long far,
(double)far / (double)scl );
}
+void GlRotatef(long angle, long vx, long vy, long vz, int scl) {
+ glRotatef(
+ (double)angle / (double)scl,
+ (double)vx / (double)scl,
+ (double)vy / (double)scl,
+ (double)vz / (double)scl );
+}
+
+void GlTranslatef(long vx, long vy, long vz, int scl) {
+ glTranslatef(
+ (double)vx / (double)scl,
+ (double)vy / (double)scl,
+ (double)vz / (double)scl );
+}
+
void GlVertex3f(long vx, long vy, long vz, int scl) {
glVertex3f(
(double)vx / (double)scl,
@@ -181,6 +224,16 @@ void GlVertex3f(long vx, long vy, long vz, int scl) {
(double)vz / (double)scl );
}
+void GlutSolidCube(long size, int scl) {
+ glutSolidCube(
+ (double)size / (double)scl );
+}
+
+void GlutWireCube(long size, int scl) {
+ glutWireCube(
+ (double)size / (double)scl );
+}
+
static void displayCallback(void) {
lisp("displayCallback", 0, 0, 0, 0, 0);
}
@@ -239,6 +292,9 @@ void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
(de glutCreateWindow (Name)
(native `*GlutLib "glutCreateWindow" NIL Name) )
+(de glutSwapBuffers ()
+ (native `*GlutLib "glutSwapBuffers") )
+
(de glMatrixMode (Mode)
(native `*GlutLib "glMatrixMode" NIL Mode) )
@@ -254,6 +310,12 @@ void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
(de glEnd ()
(native `*GlutLib "glEnd") )
+(de glColorMaterial (Face Mode)
+ (native `*GlutLib "glColorMaterial" NIL Face Mode) )
+
+(de glDepthFunc (Num)
+ (native `*GlutLib "glDepthFunc" NIL Num) )
+
(de glEnable (Num)
(native `*GlutLib "glEnable" NIL Num) )
@@ -272,10 +334,20 @@ void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
(de glFlush ()
(native `*GlutLib "glFlush") )
-#(de gluPerspective (Fovy Aspect ZNear ZFar)
-# (native `*GlutLib "gluPerspective" NIL Fovy Aspect ZNear ZFar) )
-# Why does the above give me this:
-# [DLL] /usr/lib/libglut.so: undefined symbol: gluPerspective
+(de glPopMatrix ()
+ (native `*GlutLib "glPopMatrix") )
+
+(de glPushMatrix ()
+ (native `*GlutLib "glPushMatrix") )
+
+(de glShadeModel (Num)
+ (native `*GlutLib "glShadeModel" NIL Num) )
+
+(de glViewport (X Y W H)
+ (native `*GlutLib "glViewport" NIL X Y W H) )
+
+(de gluPerspective (Fovy Aspect ZNear ZFar)
+ (native `*GluLib "gluPerspective" NIL Fovy Aspect ZNear ZFar) )
(de glutMainLoop ()
(native `*GlutLib "glutMainLoop") )
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 (2037 . "@src64/main.l")
-args (2013 . "@src64/main.l")
-argv (2658 . "@src64/main.l")
+arg (2073 . "@src64/main.l")
+args (2049 . "@src64/main.l")
+argv (2694 . "@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 (2413 . "@src64/main.l")
+cd (2449 . "@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 (2640 . "@src64/main.l")
+cmd (2676 . "@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 (2438 . "@src64/main.l")
+ctty (2474 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2152 . "@src64/main.l")
+date (2188 . "@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 (2571 . "@src64/main.l")
+dir (2607 . "@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 (2518 . "@src64/main.l")
+file (2554 . "@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 (2475 . "@src64/main.l")
+info (2511 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
@@ -220,7 +220,7 @@ nand (1678 . "@src64/flow.l")
native (1362 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (2020 . "@src64/main.l")
+next (2056 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -234,7 +234,7 @@ onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2761 . "@src64/main.l")
+opt (2797 . "@src64/main.l")
or (1659 . "@src64/flow.l")
out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -267,7 +267,7 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2402 . "@src64/main.l")
+pwd (2438 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
quit (1071 . "@src64/main.l")
quote (141 . "@src64/flow.l")
@@ -278,7 +278,7 @@ raw (461 . "@src64/main.l")
rd (4953 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2066 . "@src64/main.l")
+rest (2102 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -319,7 +319,7 @@ text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
till (3437 . "@src64/io.l")
-time (2285 . "@src64/main.l")
+time (2321 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -332,9 +332,9 @@ up (708 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2390 . "@src64/main.l")
+usec (2426 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2775 . "@src64/main.l")
+version (2811 . "@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 @@
-# 02jun10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
# Byte order
@@ -573,6 +573,37 @@
(asm jgt (Adr A)
(_jmp "ja" "jbe") )
+(asm darg (Src S Src2 S2)
+ (prinst "movapd" "%xmm4" "%xmm5")
+ (prinst "movapd" "%xmm3" "%xmm4")
+ (prinst "movapd" "%xmm2" "%xmm3")
+ (prinst "movapd" "%xmm1" "%xmm2")
+ (prinst "movapd" "%xmm0" "%xmm1")
+ (prinst "cvtsi2sd" (src Src S) "%xmm0")
+ (prinst "cvtsi2sd" (src Src2 S2) "%xmm7")
+ (prinst "divsd" "%xmm7" "%xmm0") )
+
+(asm dval (Src S)
+ (prinst "movsd" (src Src S) "%xmm0") )
+
+(asm fix (Src S)
+ (prinst "sub" "$8" "%rsp") # Space for buffer
+ (prinst "movsd" "%xmm0" "(%rsp)") # Get value
+ (prinst "mov" "6(%rsp)" "%ax") # Mantisse [s111 1111 1111 xxxx]
+ (prinst "and" "$0x7FF0" "%rax") # Infinite/NaN?
+ (prinst "cmp" "$0x7FF0" "%rax")
+ (prinst "pop" "%rax") # Keep value
+ (prinst "jz" "1f") # Yes: Skip
+ (prinst "cvtsi2sd" (src Src S) "%xmm7") # Mulitply with scale
+ (prinst "mulsd" "%xmm7" "%xmm0")
+ (prinst "call" "lround")
+ (prinst "clc") # No carry: Normal value
+ (prinst "jmp" "2f")
+ (prinl "1:")
+ (prinst "or" "%rax" "%rax") # Set sign flag
+ (prinst "stc") # Carry: Special value
+ (prinl "2:") )
+
(asm cc (Adr A Arg M)
(unless (== 'cc (caar (seek '((L) (== (cadr L) *Statement)) *Program)))
(prinst "mov" "%rdx" "%r12") )
@@ -610,21 +641,21 @@
(off Lea) ) )
Arg
M )
- # Don't use SSE registers if varargs
+ # Don't use SSE registers in varargs for static calls
(when (member Adr '("printf" "fprintf" "sprintf"))
- (prinst "xor" "%rax" "%rax") ) )
+ (prinst "xor" "%al" "%al") ) )
(for R Reg
(prinst "cmp" "%rsp" Arg)
(prinst "jz" "1f")
(prinst "pop" R) )
(prinl "1:")
- # Don't use SSE registers if varargs
- (prinst "xor" "%rax" "%rax") ) )
+ # Maximally 6 SSE registers in varargs for dynamic calls
+ (prinst "mov" "$6" "%al") ) )
((get 'call 'asm) Adr A)
- (if (lst? Arg)
- (when (gt0 (- (length Arg) 6))
- (prinst "lea" (pack (* @ 8) "(%rsp)") "%rsp") )
- (prinst "mov" Arg "%rsp") )
+ (and
+ (lst? Arg)
+ (gt0 (- (length Arg) 6))
+ (prinst "lea" (pack (* @ 8) "(%rsp)") "%rsp") )
(unless (== 'cc (caadr (memq *Statement *Program)))
(prinst "mov" "%r12" "%rdx")
(prinst "xor" "%r12" "%r12") ) )
diff --git a/src64/lib/asm.l b/src64/lib/asm.l
@@ -1,4 +1,4 @@
-# 02jun10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
# *LittleEndian *Registers optimize
@@ -392,14 +392,17 @@
(cmp4 (source) "*Mode")
(cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode")
(cnt (source) "*Mode")
+ (darg (source) "*Mode" (source) "*Mode")
(dbg)
(dec (destination) "*Mode")
(div (source) "*Mode")
(drop)
+ (dval (source) "*Mode")
(eval)
(eval+)
(eval/ret)
(exec (reg (read)))
+ (fix (source) "*Mode")
(hx2 (read))
(inc (destination) "*Mode")
(initCode)
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 24jul10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -1477,57 +1477,73 @@
neg E # Negate
end
end
+ push E # Pass long argument
else
- push Z
sym E # String?
if nz # Yes
+ push Z
call bufStringE_SZ # Write to stack buffer
cc strdup(S) # Make new string
- ld E A # Get string pointer
ld S Z # Drop buffer
+ pop Z
+ push A # Pass pointer argument
else
- ld E (E CDR) # Ignore variable
- ld C ((E)) # Get buffer size
- shr C 4 # Normalize
- call allocC_A # Allocate buffer
- push A # Save it
- ld Z A # Buffer pointer in Z
- do
- ld E (E CDR)
- cnt E # Fill rest?
- if nz # Yes
- ld A E # Byte value
- shr A 4 # in B
- do
- sub C 1 # Done?
- while ns # No
- ld (Z) B # Store byte in buffer
- inc Z # Increment buffer pointer
- loop
- break T
+ ld C (E CDR) # Double?
+ cnt C
+ if nz # Yes
+ shr C 4 # Normalize scale
+ ld A (E) # and number
+ shr A 4
+ if c # Sign?
+ neg A # Yes
end
- atom E # Fill bytes?
- while z # Yes
- ld A (E) # Next byte value
- shr A 4 # in B
- ld (Z) B # Store in buffer
- inc Z # Increment buffer pointer
- dec C # Buffer full?
- until z # Yes
- pop E # Get allocated memory
+ darg A C # Pass double argument
+ 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 Z
+ ld Z A # Buffer pointer in Z
+ do
+ ld E (E CDR)
+ cnt E # Fill rest?
+ if nz # Yes
+ ld A E # Byte value
+ shr A 4 # in B
+ do
+ sub C 1 # Done?
+ while ns # No
+ ld (Z) B # Store byte in buffer
+ inc Z # Increment buffer pointer
+ loop
+ break T
+ end
+ atom E # Fill bytes?
+ while z # Yes
+ ld A (E) # Next byte value
+ shr A 4 # in B
+ ld (Z) B # Store in buffer
+ inc Z # Increment buffer pointer
+ dec C # Buffer full?
+ until z # Yes
+ pop Z
+ end
end
- pop Z
end
- push E # Push argument
add X I # Next arg
loop
- ld X S # Start of args
+ ld X S # Start of args in X
+ off S 15 # Align stack to cell boundary
+ ld A S # Keep end of duplicated args in A
ld C L # Top of args
sub C X # Bytes
- sub S C # Duplicate args
- movm (S) (X) (L)
+ sub S C # Space for args
+ movm (S) (X) (L) # Duplicate args
ld Y (Z) # Get function pointer
- cc (Y) X # Call C-function
+ cc (Y) A # Call C-function
+ ld S X # Drop duplicated args
ld E (Z -II) # Get result specification
ld C 0 # No pointer yet
push (Link) # Save L
@@ -1544,6 +1560,8 @@
num E # Number?
if z # No
sym E # String?
+ jnz 10 # Yes
+ cnt (E CDR) # Double?
if z # No
cmp (E) Nil # Variable?
if ne # Yes
@@ -1552,8 +1570,8 @@
call natRetACE_CE # Extract value
ld (((Y))) E # Store in variable
end
+10 cc free(X) # Free string or buffer
end
- cc free(X) # Free string or buffer
end
sub Y I
loop
@@ -1568,151 +1586,169 @@
(code 'natRetACE_CE 0)
cmp E Nil # NIL?
if ne
- cmp E ISym # 'I'?
- if eq # Yes
+ cnt E # Scale?
+ if nz # Yes
+ shr E 4 # Normalize
null C # Pointer?
if nz # Yes
- ld4 (C)
- add C 4 # Size of int
+ dval (C) # Get double value
+ add C 8 # Size of double
end
- ld E (hex "FFFFFFFF") # Sign-extend integer
- and E A # into E
- ld A (hex "80000000")
- xor E A
- sub E A # Negative?
- if ns # No
- shl E 4 # Make short number
- or E CNT
+ fix E # Get fixpoint number
+ if nc
+ ld E A # Normal value
+ null E # Negative?
+ if ns # No
+ shl E 4 # Make short number
+ or E CNT
+ else
+ neg E # Negate
+ shl E 4 # Make negative short number
+ or E (| SIGN CNT)
+ end
else
- neg E # Negate
- shl E 4 # Make negative short number
- or E (| SIGN CNT)
+ ld E Nil # Special value
+ if ns # Infinite?
+ ld E TSym
+ end
end
else
- cmp E NSym # 'N'?
+ cmp E ISym # 'I'?
if eq # Yes
null C # Pointer?
if nz # Yes
- ld A (C)
- add C 8 # Size of long/pointer
+ ld4 (C)
+ add C 4 # Size of int
end
- ld E A # Number
- null E # Negative?
+ ld E (hex "FFFFFFFF") # Sign-extend integer
+ and E A # into E
+ ld A (hex "80000000")
+ xor E A
+ sub E A # Negative?
if ns # No
- test E (hex "F000000000000000") # Fit in short?
- if z # Yes
- shl E 4 # Make short number
- or E CNT
- else
- cmp E (hex "7FFFFFFFFFFFFFFF") # Infinity?
- if eq # Yes
- ld E TSym # Return T
- else
- call boxNumE_E # Make bignum
- end
- end
+ shl E 4 # Make short number
+ or E CNT
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
- cmp E (hex "8000000000000000") # NaN or negative infinity?
- if eq # Yes
- ld E Nil # Return NIL
- else
- call boxNumE_E # Make bignum
- or E SIGN # Set negative
- end
- end
+ shl E 4 # Make negative short number
+ or E (| SIGN CNT)
end
else
- cmp E SSym # 'S'?
+ cmp E NSym # 'N'?
if eq # Yes
null C # Pointer?
if nz # Yes
ld A (C)
- add C 8 # Size of pointer
+ 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
- ld E A # Make transient symbol
- call mkStrE_E
else
- cmp E CSym # 'C'?
+ cmp E SSym # 'S'?
if eq # Yes
null C # Pointer?
if nz # Yes
- call fetchCharC_AC # Fetch char
- end
- ld E Nil # Preload
- null A # Char?
- if nz # Yes
- call mkCharA_A # Make char
- ld E A
+ ld A (C)
+ add C 8 # Size of pointer
end
+ ld E A # Make transient symbol
+ call mkStrE_E
else
- cmp E BSym # 'B'?
+ cmp E CSym # 'C'?
if eq # Yes
null C # Pointer?
if nz # Yes
- ld B (C)
- inc C # Size of byte
+ call fetchCharC_AC # Fetch char
+ end
+ ld E Nil # Preload
+ null A # Char?
+ if nz # Yes
+ call mkCharA_A # Make char
+ ld E A
end
- zxt # Byte
- ld E A
- shl E 4 # Make short number
- or E CNT
else
- atom E # Atomic?
- if z # No: Arrary or structure
+ cmp E BSym # 'B'?
+ if eq # Yes
null C # Pointer?
- ldz C A # Yes: Load into C
- push X
- push Y
- push Z
- ld X E # Get specification in X
- ld E (X)
- call natRetACE_CE # First item
- call cons_Y # Make cell
- ld (Y) E
- ld (Y CDR) Nil
- link
- push Y # <L I> Result
- link
- do
- ld Z (X CDR)
- cnt Z # (sym . cnt)
- if nz
- shr Z 4 # Normalize
- do
- dec Z # Decrement count
- while nz
- ld E (X) # Repeat last type
- call natRetACE_CE # Next item
- call cons_A # Cons into cell
- ld (A) E
- ld (A CDR) Nil
- ld (Y CDR) A # Append to result
- ld Y A
- loop
- break T
- end
- atom Z # End of specification?
- while z # No
- ld X Z
- ld E (X) # Next type
- call natRetACE_CE # Next item
- call cons_A # Cons into cell
- ld (A) E
- ld (A CDR) Nil
- ld (Y CDR) A # Append to result
- ld Y A
- loop
- ld E (L I) # Get result
- drop
- pop Z
- pop Y
- pop X
+ if nz # Yes
+ ld B (C)
+ inc C # Size of byte
+ end
+ zxt # Byte
+ ld E A
+ shl E 4 # Make short number
+ or E CNT
+ else
+ atom E # Atomic?
+ if z # No: Arrary or structure
+ null C # Pointer?
+ ldz C A # Yes: Load into C
+ push X
+ push Y
+ push Z
+ ld X E # Get specification in X
+ ld E (X)
+ call natRetACE_CE # First item
+ call cons_Y # Make cell
+ ld (Y) E
+ ld (Y CDR) Nil
+ link
+ push Y # <L I> Result
+ link
+ do
+ ld Z (X CDR)
+ cnt Z # (sym . cnt)
+ if nz
+ shr Z 4 # Normalize
+ do
+ dec Z # Decrement count
+ while nz
+ ld E (X) # Repeat last type
+ call natRetACE_CE # Next item
+ call cons_A # Cons into cell
+ ld (A) E
+ ld (A CDR) Nil
+ ld (Y CDR) A # Append to result
+ ld Y A
+ loop
+ break T
+ end
+ atom Z # End of specification?
+ while z # No
+ ld X Z
+ ld E (X) # Next type
+ call natRetACE_CE # Next item
+ call cons_A # Cons into cell
+ ld (A) E
+ ld (A CDR) Nil
+ ld (Y CDR) A # Append to result
+ ld Y A
+ loop
+ ld E (L I) # Get result
+ drop
+ pop Z
+ pop Y
+ pop X
+ end
end
end
end
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 22jul10abu
+# 27jul10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 7)
+(de *Version 3 0 3 8)
# vi:et:ts=3:sw=3
