commit bcd614cc0cc59bc96709f360bd815e2e18b38ed5
parent eb5bd8c900a2427201369b5ac58299be5a16d06e
Author: Commit-Bot <unknown>
Date: Wed, 28 Jul 2010 10:21:13 +0000
Automatic commit from picoLisp.tgz, From: Wed, 28 Jul 2010 10:21:13 GMT
Diffstat:
11 files changed, 368 insertions(+), 263 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXsep10 picoLisp-3.0.4
+ Generic C-callbacks 'lisp1' .. 'lisp9'
'native' fixpoint handling
OpenGL (64-bit) in "lib/openGl.l"
Faster bignum division (64-bit)
diff --git a/doc/refL.html b/doc/refL.html
@@ -272,6 +272,34 @@ href="refN.html#noLint">noLint</a></code>.
...
</code></pre>
+<dt><a name="lisp1"><code>(lisp1 'fun) -> num</code></a>
+<dt><code>.. (lisp9 'fun) -> num</code>
+<dd>Installs a callback function <code>fun</code>, and returns a pointer
+<code>num</code> suitable to be passed to a C function via 'native'. Maximally
+nine callback functions can be installed that way. 'fun' should be a function of
+maximally five numbers, and should return a number. See also <code><a
+href="refN.html#native">native</a></code>.
+
+<pre><code>
+(load "lib/native.l")
+
+(gcc "ltest" NIL
+ (cbTest (Fun) cbTest 'N Fun) )
+
+long cbTest(int(*fun)(int,int,int,int,int)) {
+ return fun(1,2,3,4,5);
+}
+/**/
+
+: (cbTest
+ (lisp1
+ '((A B C D E)
+ (msg (list A B C D E))
+ (* A B C D E) ) ) )
+(1 2 3 4 5)
+-> 120
+</code></pre>
+
<dt><a name="list"><code>(list 'any ['any ..]) -> lst</code></a>
<dd>Returns a list of all <code>any</code> arguments. See also <code><a
href="refC.html#cons">cons</a></code>.
diff --git a/doc/refN.html b/doc/refN.html
@@ -195,7 +195,7 @@ This is 123.456
<p>which accepts a symbol name as the first argument, and up to 5 numbers.
<code>lisp()</code> calls that symbol with the five numbers, and expects a
numeric return value. All numbers in this context should not be larger than 60
-bits (signed).
+bits (signed). See also <code><a href="refL.html#lisp1">lisp[1-9]</a></code>.
<dt><a name="need"><code>(need 'cnt ['lst ['any]]) -> lst</code></a>
<dd>Produces a list of at least <code>cnt</code> elements. When called without
diff --git a/lib/math64.l b/lib/math64.l
@@ -1,48 +1,48 @@
-# 27jul10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
(setq
- "Arg1" (0 . 1.0)
- "Arg2" (0 . 1.0) )
+ "Fix1" (0 . 1.0)
+ "Fix2" (0 . 1.0) )
(de pow (X Y)
- (set "Arg1" X "Arg2" Y)
- (native "@" "pow" 1.0 "Arg1" "Arg2") )
+ (set "Fix1" X "Fix2" Y)
+ (native "@" "pow" 1.0 "Fix1" "Fix2") )
(de exp (X)
- (set "Arg1" X)
- (native "@" "exp" 1.0 "Arg1") )
+ (set "Fix1" X)
+ (native "@" "exp" 1.0 "Fix1") )
(de log (X)
- (when (gt0 (set "Arg1" X))
- (native "@" "log" 1.0 "Arg1") ) )
+ (when (gt0 (set "Fix1" X))
+ (native "@" "log" 1.0 "Fix1") ) )
(de sin (A)
- (set "Arg1" A)
- (native "@" "sin" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "sin" 1.0 "Fix1") )
(de cos (A)
- (set "Arg1" A)
- (native "@" "cos" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "cos" 1.0 "Fix1") )
(de tan (A)
- (set "Arg1" A)
- (native "@" "tan" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "tan" 1.0 "Fix1") )
(de asin (A)
- (set "Arg1" A)
- (native "@" "asin" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "asin" 1.0 "Fix1") )
(de acos (A)
- (set "Arg1" A)
- (native "@" "acos" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "acos" 1.0 "Fix1") )
(de atan (A)
- (set "Arg1" A)
- (native "@" "atan" 1.0 "Arg1") )
+ (set "Fix1" A)
+ (native "@" "atan" 1.0 "Fix1") )
(de atan2 (X Y)
- (set "Arg1" X "Arg2" Y)
- (native "@" "atan2" 1.0 "Arg1" "Arg2") )
+ (set "Fix1" X "Fix2" Y)
+ (native "@" "atan2" 1.0 "Fix1" "Fix2") )
# vi:et:ts=3:sw=3
diff --git a/lib/openGl.l b/lib/openGl.l
@@ -1,8 +1,8 @@
-# 27jul10abu
+# 28jul10abu
# 27jul10jk
# (c) Software Lab. Alexander Burger
-(load "@lib/math.l" "@lib/native.l")
+(load "@lib/math.l")
### Constant Definitions ###
# Primitives
@@ -122,159 +122,19 @@
(def 'GLUT_MIDDLE_BUTTON 1)
(def 'GLUT_RIGHT_BUTTON 2)
-
### OpenGL library interface ###
(default
*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)
- (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")
- (glutMotionFunc () "GlutMotionFunc")
- (glutMouseFunc () "GlutMouseFunc")
- (glutReshapeFunc () "GlutReshapeFunc")
- (glutSpecialFunc () "GlutSpecialFunc")
- (glutTimerFunc () "GlutTimerFunc") )
-
-#include <GL/glut.h>
-#include <GL/glu.h>
-#include <GL/gl.h>
-
-extern long lisp(char*,long,long,long,long,long);
-
-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 );
-}
-
-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,
- (double)green / (double)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,
- (double)right / (double)scl,
- (double)bottom / (double)scl,
- (double)top / (double)scl,
- (double)near / (double)scl,
- (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,
- (double)vy / (double)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);
-}
-void GlutDisplayFunc(void) {glutDisplayFunc(displayCallback);}
-
-static void createMenuCallback(int val) {
- lisp("createMenuCallback", val, 0, 0, 0, 0);
-}
-void GlutCreateMenu(void) {glutCreateMenu(createMenuCallback);}
-
-static void keyboardCallback(unsigned char key, int xv, int yv) {
- lisp("keyboardCallback", key, xv, yv, 0, 0);
-}
-void GlutKeyboardFunc(void) {glutKeyboardFunc(keyboardCallback);}
-
-static void motionCallback(int xv, int yv) {
- lisp("motionCallback", xv, yv, 0, 0, 0);
-}
-void GlutMotionFunc(void) {glutMotionFunc(motionCallback);}
-
-static void mouseCallback(int button, int state, int xv, int yv) {
- lisp("mouseCallback", button, state, xv, yv, 0);
-}
-void GlutMouseFunc(void) {glutMouseFunc(mouseCallback);}
-
-static void reshapeCallback(int width, int height) {
- lisp("reshapeCallback", width, height, 0, 0, 0);
-}
-void GlutReshapeFunc(void) {glutReshapeFunc(reshapeCallback);}
-
-static void specialCallback(int key, int xv, int yv) {
- lisp("specialCallback", key, xv, yv, 0, 0);
-}
-void GlutSpecialFunc(void) {glutSpecialFunc(specialCallback);}
-
-static void timerCallback(int val) {
- lisp("timerCallback", val, 0, 0, 0, 0);
-}
-void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
-/**/
-
+# 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) )
### Native functions ###
(de glutInit ()
@@ -310,6 +170,50 @@ void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
(de glEnd ()
(native `*GlutLib "glEnd") )
+(de glClearColor (Red Green Blue Alpha)
+ (set "Fix1" Red "Fix2" Green "Fix3" Blue "Fix4" Alpha)
+ (native `*GlutLib "glClearColor" NIL "Fix1" "Fix2" "Fix3" "Fix4") )
+
+(de glClearDepth (Depth)
+ (set "Fix1" Depth)
+ (native `*GlutLib "glClearDepth" NIL "Fix1") )
+
+(de glColor3f (Red Green Blue)
+ (set "Fix1" Red "Fix2" Green "Fix3" Blue)
+ (native `*GlutLib "glColor3f" NIL "Fix1" "Fix2" "Fix3") )
+
+(de glColor4f (Red Green Blue Alpha)
+ (set "Fix1" Red "Fix2" Green "Fix3" Blue "Fix4" Alpha)
+ (native `*GlutLib "glColor4f" NIL "Fix1" "Fix2" "Fix3" "Fix4") )
+
+(de glNormal3f (X Y Z)
+ (set "Fix1" X "Fix2" Y "Fix3" Z)
+ (native `*GlutLib "glNormal3f" NIL "Fix1" "Fix2" "Fix3") )
+
+(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") )
+
+(de glRotatef (X Y Z)
+ (set "Fix1" X "Fix2" Y "Fix3" Z)
+ (native `*GlutLib "glRotatef" NIL "Fix1" "Fix2" "Fix3") )
+
+(de glTranslatef (X Y Z)
+ (set "Fix1" X "Fix2" Y "Fix3" Z)
+ (native `*GlutLib "glTranslatef" NIL "Fix1" "Fix2" "Fix3") )
+
+(de glVertex3f (X Y Z)
+ (set "Fix1" X "Fix2" Y "Fix3" Z)
+ (native `*GlutLib "glVertex3f" NIL "Fix1" "Fix2" "Fix3") )
+
+(de glutSolidCube (Size)
+ (set "Fix1" Size)
+ (native `*GlutLib "glutSolidCube" NIL "Fix1") )
+
+(de glutWireCube (Size)
+ (set "Fix1" Size)
+ (native `*GlutLib "glutWireCube" NIL "Fix1") )
+
(de glColorMaterial (Face Mode)
(native `*GlutLib "glColorMaterial" NIL Face Mode) )
@@ -361,72 +265,37 @@ void GlutTimerFunc(int msec, int val) {glutTimerFunc(msec, timerCallback, val);}
(de glutPostRedisplay ()
(native `*GlutLib "glutPostRedisplay") )
-
### Callbacks ###
-# Keep references in global symbols, to protect from garbage collection
-
# Display Function
(de displayPrg Prg
- (setq *GlutDisplayPrg Prg)
- (glutDisplayFunc) )
-
-(de displayCallback ()
- (run *GlutDisplayPrg) )
+ (native `*GlutLib "glutDisplayFunc" NIL (lisp1 (cons NIL Prg))) )
# CreateMenu Function
(de createMenu (Fun)
- (setq *CreateMenuFunc Fun)
- (glutCreateMenu) )
-
-(de createMenuCallback (Val)
- (*CreateMenuFunc Val) )
+ (native `*GlutLib "glutCreateMenu" NIL (lisp2 Fun)) )
# Keyboard Function
(de keyboardFunc (Fun)
- (setq *GlutKeyboardFunc Fun)
- (glutKeyboardFunc) )
-
-(de keyboardCallback (Key Xv Yv)
- (*GlutKeyboardFunc Key Xv Yv) )
+ (native `*GlutLib "glutKeyboardFunc" NIL (lisp3 Fun)) )
# Motion Function
(de motionFunc (Fun)
- (setq *GlutMotionFunc Fun)
- (glutMotionFunc) )
-
-(de motionCallback (Xv Yv)
- (*GlutMotionFunc Xv Yv) )
+ (native `*GlutLib "glutMotionFunc" NIL (lisp4 Fun)) )
# Mouse Function
(de mouseFunc (Fun)
- (setq *GlutMouseFunc Fun)
- (glutMouseFunc) )
-
-(de mouseCallback (Button State Xv Yv)
- (*GlutMouseFunc Button State Xv Yv) )
+ (native `*GlutLib "glutMouseFunc" NIL (lisp5 Fun)) )
# Reshape Function
(de reshapeFunc (Fun)
- (setq *GlutReshapeFunc Fun)
- (glutReshapeFunc) )
-
-(de reshapeCallback (Width Height)
- (*GlutReshapeFunc Width Height) )
+ (native `*GlutLib "glutReshapeFunc" NIL (lisp6 Fun)) )
# Special Function
(de specialFunc (Fun)
- (setq *GlutSpecialFunc Fun)
- (glutSpecialFunc) )
-
-(de specialCallback (Key Xv Yv)
- (*GlutSpecialFunc Key Xv Yv) )
+ (native `*GlutLib "glutSpecialFunc" NIL (lisp7 Fun)) )
# Timer Function
(de timerFunc (Msec Fun Val)
- (setq *GlutTimerFunc Fun)
- (glutTimerFunc Msec Val) )
-
-(de timerCallback (Val)
- (*GlutTimerFunc Val) )
+ (native `*GlutLib "glutTimerFunc" NIL Msec (lisp8 Fun) Val) )
# vi:et:ts=3:sw=3
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 (2073 . "@src64/main.l")
-args (2049 . "@src64/main.l")
-argv (2694 . "@src64/main.l")
+arg (2259 . "@src64/main.l")
+args (2235 . "@src64/main.l")
+argv (2880 . "@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 (2449 . "@src64/main.l")
+cd (2635 . "@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 (2676 . "@src64/main.l")
+cmd (2862 . "@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 (2474 . "@src64/main.l")
+ctty (2660 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2188 . "@src64/main.l")
+date (2374 . "@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 (2607 . "@src64/main.l")
+dir (2793 . "@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 (2554 . "@src64/main.l")
+file (2740 . "@src64/main.l")
fill (3177 . "@src64/subr.l")
filter (1045 . "@src64/apply.l")
fin (2020 . "@src64/subr.l")
@@ -144,7 +144,7 @@ free (2034 . "@src64/db.l")
from (3370 . "@src64/io.l")
full (1066 . "@src64/subr.l")
fun? (734 . "@src64/sym.l")
-gc (446 . "@src64/gc.l")
+gc (439 . "@src64/gc.l")
ge0 (2691 . "@src64/big.l")
get (2750 . "@src64/sym.l")
getd (742 . "@src64/sym.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 (2511 . "@src64/main.l")
+info (2697 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
@@ -179,6 +179,15 @@ lieu (1163 . "@src64/db.l")
line (3526 . "@src64/io.l")
lines (3679 . "@src64/io.l")
link (1163 . "@src64/subr.l")
+lisp1 (1797 . "@src64/main.l")
+lisp2 (1810 . "@src64/main.l")
+lisp3 (1818 . "@src64/main.l")
+lisp4 (1826 . "@src64/main.l")
+lisp5 (1834 . "@src64/main.l")
+lisp6 (1842 . "@src64/main.l")
+lisp7 (1850 . "@src64/main.l")
+lisp8 (1858 . "@src64/main.l")
+lisp9 (1866 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
@@ -220,7 +229,7 @@ nand (1678 . "@src64/flow.l")
native (1362 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (2056 . "@src64/main.l")
+next (2242 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -234,7 +243,7 @@ onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2797 . "@src64/main.l")
+opt (2983 . "@src64/main.l")
or (1659 . "@src64/flow.l")
out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -267,7 +276,7 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2438 . "@src64/main.l")
+pwd (2624 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
quit (1071 . "@src64/main.l")
quote (141 . "@src64/flow.l")
@@ -278,7 +287,7 @@ raw (461 . "@src64/main.l")
rd (4953 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2102 . "@src64/main.l")
+rest (2288 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -319,7 +328,7 @@ text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
till (3437 . "@src64/io.l")
-time (2321 . "@src64/main.l")
+time (2507 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -332,9 +341,9 @@ up (708 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2426 . "@src64/main.l")
+usec (2612 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2811 . "@src64/main.l")
+version (2997 . "@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 @@
-# 27jul10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
# Byte order
@@ -589,7 +589,7 @@
(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 "mov" "6(%rsp)" "%ax") # Mantissa [s111 1111 1111 xxxx]
(prinst "and" "$0x7FF0" "%rax") # Infinite/NaN?
(prinst "cmp" "$0x7FF0" "%rax")
(prinst "pop" "%rax") # Keep value
diff --git a/src64/gc.l b/src64/gc.l
@@ -1,4 +1,4 @@
-# 13jun10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
# Mark data
@@ -77,7 +77,7 @@
do
or (X) 1 # Set mark bit
add X II # Next symbol
- cmp X GcMarkEnd
+ cmp X GcSymEnd
until gt
ld X (Heaps) # Heap pointer
do
@@ -91,20 +91,13 @@
null X # Done?
until eq # Yes
### Mark ###
- ld E (Alarm) # Mark globals
- call markE
- ld E (Sigio)
- call markE
- ld E (LineX)
- call markE
- ld E (Intern) # Mark internal symbols
- call markE
- ld E (Intern I)
- call markE
- ld E (Transient) # Mark transient symbols
- call markE
- ld E (Transient I)
- call markE
+ ld Y Intern # Mark globals
+ do
+ ld E (Y) # Next global
+ call markE # Mark it
+ add Y I
+ cmp Y GcMarkEnd # Done?
+ until eq # Yes
### Mark stack(s) ###
ld Y L
do
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 11jun10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -43,9 +43,6 @@
: Extn word 0
: StrX word 0 # String status
: StrC word 0
-: Alarm word Nil # Alarm handler
-: Sigio word Nil # Sigio handler
-: LineX word ZERO # Console line
: LineC word -1
: Break word 0 # Breakpoint
: GcCount word CELLS # Collector count
@@ -70,11 +67,24 @@
: DbJnl word 0 # Journal file
: DbLog word 0 # Transaction log file
-# Symbol trees
+# GC relevant data
:: Intern word Nil # Short internal names
word Nil # Long internal names
:: Transient word Nil # Short transient names
word Nil # Long transient names
+: Alarm word Nil # Alarm handler
+: Sigio word Nil # Sigio handler
+: LineX word ZERO # Console line
+: Lisp1 word Nil # Lisp callbacks
+: Lisp2 word Nil
+: Lisp3 word Nil
+: Lisp4 word Nil
+: Lisp5 word Nil
+: Lisp6 word Nil
+: Lisp7 word Nil
+: Lisp8 word Nil
+: Lisp9 word Nil
+: GcMarkEnd
# Symbol Table
@@ -135,6 +145,15 @@
initSym NIL "quit" doQuit
initSym NIL "errno" doErrno
initSym NIL "native" doNative
+ initSym NIL "lisp5" doLisp5
+ initSym NIL "lisp2" doLisp2
+ initSym NIL "lisp7" doLisp7
+ initSym NIL "lisp1" doLisp1
+ initSym NIL "lisp3" doLisp3
+ initSym NIL "lisp6" doLisp6
+ initSym NIL "lisp8" doLisp8
+ initSym NIL "lisp4" doLisp4
+ initSym NIL "lisp9" doLisp9
initSym NIL "args" doArgs
initSym NIL "next" doNext
initSym NIL "arg" doArg
@@ -504,6 +523,8 @@
word Db1
word Nil
+: GcSymEnd
+
# Version number
:: Version
word (short `(car *Version))
@@ -515,8 +536,6 @@
word (short `(cadddr *Version))
word Nil
-: GcMarkEnd
-
# Structures
: EnvCo # Coroutine environment
:: Chr word 0 # Single-char buffer
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 27jul10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -1793,6 +1793,192 @@
end
ret
+# (lisp1 'fun) -> num
+(code 'doLisp1 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp1) E # Set callback function
+ ld E cbLisp1 # Return function pointer
+: boxPtr
+ test E (hex "F000000000000000") # Fit in short number?
+ jnz boxNumE_E # No
+ shl E 4 # Else make short number
+ or E CNT
+ ret
+
+# (lisp2 'fun) -> num
+(code 'doLisp2 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp2) E # Set callback function
+ ld E cbLisp2 # Return function pointer
+ jmp boxPtr
+
+# (lisp3 'fun) -> num
+(code 'doLisp3 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp3) E # Set callback function
+ ld E cbLisp3 # Return function pointer
+ jmp boxPtr
+
+# (lisp4 'fun) -> num
+(code 'doLisp4 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp4) E # Set callback function
+ ld E cbLisp4 # Return function pointer
+ jmp boxPtr
+
+# (lisp5 'fun) -> num
+(code 'doLisp5 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp5) E # Set callback function
+ ld E cbLisp5 # Return function pointer
+ jmp boxPtr
+
+# (lisp6 'fun) -> num
+(code 'doLisp6 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp6) E # Set callback function
+ ld E cbLisp6 # Return function pointer
+ jmp boxPtr
+
+# (lisp7 'fun) -> num
+(code 'doLisp7 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp7) E # Set callback function
+ ld E cbLisp7 # Return function pointer
+ jmp boxPtr
+
+# (lisp8 'fun) -> num
+(code 'doLisp8 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp8) E # Set callback function
+ ld E cbLisp8 # Return function pointer
+ jmp boxPtr
+
+# (lisp9 'fun) -> num
+(code 'doLisp9 2)
+ ld E ((E CDR)) # Eval arg
+ eval
+ ld (Lisp9) E # Set callback function
+ ld E cbLisp9 # Return function pointer
+ jmp boxPtr
+
+(code 'cbLisp1 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp1) # 'fun'
+: cbLisp
+ xchg A E # First arg
+ call boxCntE_E # Make number
+ push E
+ ld E C # Second arg
+ call boxCntE_E # Make number
+ push E
+ ld E A # Third arg
+ call boxCntE_E # Make number
+ push E
+ ld E X # Fourth arg
+ call boxCntE_E # Make number
+ push E
+ ld E Y # Fifth arg
+ call boxCntE_E # Make number
+ push E
+ ld Z S # Z on last argument
+ link # Close frame
+ lea Y (S VI) # Pointer to 'fun' in Y
+ call applyXYZ_E # Apply
+ ld A E # Return value
+ shr A 4 # Normalize
+ if c # Sign?
+ neg A # Yes
+ end
+ drop
+ pop L # Restore C frame pointer
+ pop Z
+ return 5
+
+(code 'cbLisp2 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp2) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp3 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp3) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp4 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp4) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp5 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp5) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp6 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp6) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp7 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp7) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp8 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp8) # 'fun'
+ jmp cbLisp
+
+(code 'cbLisp9 0)
+ begin 5 # Arguments in A, C, E, X and Y
+ push Z
+ push L # Save C frame pointer
+ ld L (Link) # Restore link register
+ link # Apply args
+ push (Lisp9) # 'fun'
+ jmp cbLisp
+
(code 'lisp 0)
begin 6 # Function name in A, arguments in C, E, X, Y and Z
push L # Save C frame pointer
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 27jul10abu
+# 28jul10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 8)
+(de *Version 3 0 3 9)
# vi:et:ts=3:sw=3
