commit 04fced5627613e3b95297f0d5eee6fb069c93671
parent fcc6d579f038bf490b2d9361522c1d525af1d889
Author: Commit-Bot <unknown>
Date: Thu, 5 Aug 2010 10:32:56 +0000
Automatic commit from picoLisp.tgz, From: Thu, 05 Aug 2010 10:32:56 GMT
Diffstat:
9 files changed, 232 insertions(+), 173 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,5 +1,5 @@
* XXsep10 picoLisp-3.0.4
- Generic C-callbacks 'lisp1' .. 'lisp9'
+ Generic 'lisp' C-callbacks
'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,13 +272,14 @@ 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>(64-bit version only) 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>.
+<dt><a name="lisp"><code>(lisp 'sym ['fun]) -> num</code></a>
+<dd>(64-bit version only) Installs under the tag <code>sym</code> a callback
+function <code>fun</code>, and returns a pointer <code>num</code> suitable to be
+passed to a C function via 'native'. If <code>fun</code> is <code>NIL</code>,
+the corresponding entry is freed. Maximally 24 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")
@@ -292,7 +293,7 @@ long cbTest(int(*fun)(int,int,int,int,int)) {
/**/
: (cbTest
- (lisp1
+ (lisp 'cbTest
'((A B C D E)
(msg (list A B C D E))
(* A B C D E) ) ) )
diff --git a/doc/refN.html b/doc/refN.html
@@ -196,7 +196,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). See also <code><a href="refL.html#lisp1">lisp[1-9]</a></code>.
+bits (signed). See also <code><a href="refL.html#lisp">lisp</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/openGl.l b/lib/openGl.l
@@ -1,4 +1,4 @@
-# 04aug10abu
+# 05aug10abu
# 27jul10jk
# (c) Software Lab. Alexander Burger
@@ -278,34 +278,34 @@
### Callbacks ###
# Display Function
(de displayPrg Prg
- (native `*GlutLib "glutDisplayFunc" NIL (lisp1 (cons NIL Prg))) )
+ (native `*GlutLib "glutDisplayFunc" NIL (lisp 'displayPrg (cons NIL Prg))) )
# CreateMenu Function
(de createMenu (Fun)
- (native `*GlutLib "glutCreateMenu" NIL (lisp2 Fun)) )
+ (native `*GlutLib "glutCreateMenu" NIL (lisp 'createMenu Fun)) )
# Keyboard Function
(de keyboardFunc (Fun)
- (native `*GlutLib "glutKeyboardFunc" NIL (lisp3 Fun)) )
+ (native `*GlutLib "glutKeyboardFunc" NIL (lisp 'keyboardFunc Fun)) )
# Motion Function
(de motionFunc (Fun)
- (native `*GlutLib "glutMotionFunc" NIL (lisp4 Fun)) )
+ (native `*GlutLib "glutMotionFunc" NIL (lisp 'motionFunc Fun)) )
# Mouse Function
(de mouseFunc (Fun)
- (native `*GlutLib "glutMouseFunc" NIL (lisp5 Fun)) )
+ (native `*GlutLib "glutMouseFunc" NIL (lisp 'mouseFunc Fun)) )
# Reshape Function
(de reshapeFunc (Fun)
- (native `*GlutLib "glutReshapeFunc" NIL (lisp6 Fun)) )
+ (native `*GlutLib "glutReshapeFunc" NIL (lisp 'reshapeFunc Fun)) )
# Special Function
(de specialFunc (Fun)
- (native `*GlutLib "glutSpecialFunc" NIL (lisp7 Fun)) )
+ (native `*GlutLib "glutSpecialFunc" NIL (lisp 'specialFunc Fun)) )
# Timer Function
(de timerFunc (Msec Fun Val)
- (native `*GlutLib "glutTimerFunc" NIL Msec (lisp8 Fun) Val) )
+ (native `*GlutLib "glutTimerFunc" NIL Msec (lisp 'timerFunc 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 (2207 . "@src64/main.l")
-args (2183 . "@src64/main.l")
-argv (2828 . "@src64/main.l")
+arg (2241 . "@src64/main.l")
+args (2217 . "@src64/main.l")
+argv (2862 . "@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 (2583 . "@src64/main.l")
+cd (2617 . "@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 (2810 . "@src64/main.l")
+cmd (2844 . "@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 (2608 . "@src64/main.l")
+ctty (2642 . "@src64/main.l")
cut (1797 . "@src64/sym.l")
-date (2322 . "@src64/main.l")
+date (2356 . "@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 (2741 . "@src64/main.l")
+dir (2775 . "@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 (2688 . "@src64/main.l")
+file (2722 . "@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 (2645 . "@src64/main.l")
+info (2679 . "@src64/main.l")
intern (875 . "@src64/sym.l")
ipid (3214 . "@src64/flow.l")
isa (978 . "@src64/flow.l")
@@ -179,15 +179,7 @@ lieu (1163 . "@src64/db.l")
line (3526 . "@src64/io.l")
lines (3679 . "@src64/io.l")
link (1163 . "@src64/subr.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")
+lisp (1920 . "@src64/main.l")
list (887 . "@src64/subr.l")
listen (151 . "@src64/net.l")
lit (183 . "@src64/flow.l")
@@ -229,7 +221,7 @@ nand (1678 . "@src64/flow.l")
native (1366 . "@src64/main.l")
need (918 . "@src64/subr.l")
new (852 . "@src64/flow.l")
-next (2190 . "@src64/main.l")
+next (2224 . "@src64/main.l")
nil (1761 . "@src64/flow.l")
nond (1961 . "@src64/flow.l")
nor (1699 . "@src64/flow.l")
@@ -243,7 +235,7 @@ onOff (1613 . "@src64/sym.l")
one (1646 . "@src64/sym.l")
open (4142 . "@src64/io.l")
opid (3230 . "@src64/flow.l")
-opt (2931 . "@src64/main.l")
+opt (2965 . "@src64/main.l")
or (1659 . "@src64/flow.l")
out (4036 . "@src64/io.l")
pack (1144 . "@src64/sym.l")
@@ -276,7 +268,7 @@ push (1688 . "@src64/sym.l")
push1 (1724 . "@src64/sym.l")
put (2698 . "@src64/sym.l")
putl (2950 . "@src64/sym.l")
-pwd (2572 . "@src64/main.l")
+pwd (2606 . "@src64/main.l")
queue (1920 . "@src64/sym.l")
quit (1075 . "@src64/main.l")
quote (141 . "@src64/flow.l")
@@ -287,7 +279,7 @@ raw (465 . "@src64/main.l")
rd (4953 . "@src64/io.l")
read (2530 . "@src64/io.l")
replace (1490 . "@src64/subr.l")
-rest (2236 . "@src64/main.l")
+rest (2270 . "@src64/main.l")
reverse (1665 . "@src64/subr.l")
rewind (4919 . "@src64/io.l")
rollback (1885 . "@src64/db.l")
@@ -328,7 +320,7 @@ text (1272 . "@src64/sym.l")
throw (2510 . "@src64/flow.l")
tick (3182 . "@src64/flow.l")
till (3437 . "@src64/io.l")
-time (2455 . "@src64/main.l")
+time (2489 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
trim (1746 . "@src64/subr.l")
try (1191 . "@src64/flow.l")
@@ -341,9 +333,9 @@ up (712 . "@src64/main.l")
upp? (3232 . "@src64/sym.l")
uppc (3296 . "@src64/sym.l")
use (1592 . "@src64/flow.l")
-usec (2560 . "@src64/main.l")
+usec (2594 . "@src64/main.l")
val (1463 . "@src64/sym.l")
-version (2945 . "@src64/main.l")
+version (2979 . "@src64/main.l")
wait (3016 . "@src64/io.l")
when (1903 . "@src64/flow.l")
while (2080 . "@src64/flow.l")
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 28jul10abu
+# 05aug10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -75,15 +75,55 @@
: 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
+: Lisp word Nil # Lisp callbacks: tag+fun
+ word Nil
+ word Nil # 2
+ word Nil
+ word Nil # 3
+ word Nil
+ word Nil # 4
+ word Nil
+ word Nil # 5
+ word Nil
+ word Nil # 6
+ word Nil
+ word Nil # 7
+ word Nil
+ word Nil # 8
+ word Nil
+ word Nil # 9
+ word Nil
+ word Nil # 10
+ word Nil
+ word Nil # 11
+ word Nil
+ word Nil # 12
+ word Nil
+ word Nil # 13
+ word Nil
+ word Nil # 14
+ word Nil
+ word Nil # 15
+ word Nil
+ word Nil # 16
+ word Nil
+ word Nil # 17
+ word Nil
+ word Nil # 18
+ word Nil
+ word Nil # 19
+ word Nil
+ word Nil # 20
+ word Nil
+ word Nil # 21
+ word Nil
+ word Nil # 22
+ word Nil
+ word Nil # 23
+ word Nil
+ word Nil # 24
+ word Nil
+: LispEnd
: GcMarkEnd
@@ -145,15 +185,7 @@
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 "lisp" doLisp
initSym NIL "args" doArgs
initSym NIL "next" doNext
initSym NIL "arg" doArg
diff --git a/src64/lib/asm.l b/src64/lib/asm.l
@@ -1,4 +1,4 @@
-# 02aug10abu
+# 05aug10abu
# (c) Software Lab. Alexander Burger
# *LittleEndian *Registers optimize
@@ -152,12 +152,12 @@
(list (car L) (cadr L2))
L ) ) ) )
*Program ) ) ) )
- (setq *Program # Remove unreachable statements
- (make
- (while *Program
- (when (memq (car (link (pop '*Program))) '(jmp ret eval/ret))
- (while (and *Program (n== ': (caar *Program)))
- (pop '*Program) ) ) ) ) )
+ (setq *Program # Remove unreachable statements
+ (make
+ (while *Program
+ (when (memq (car (link (pop '*Program))) '(jmp ret eval/ret))
+ (while (and *Program (n== ': (caar *Program)))
+ (pop '*Program) ) ) ) ) )
(setq *Program # Remove zero jumps
(make
(while *Program
diff --git a/src64/main.l b/src64/main.l
@@ -1,4 +1,4 @@
-# 03aug10abu
+# 05aug10abu
# (c) Software Lab. Alexander Burger
### Global return labels ###
@@ -1783,79 +1783,12 @@
end
ret
-# (lisp1 'fun) -> num
-(code 'doLisp1 2)
- push cbLisp1 # Callback function pointer
- push Lisp1 # Address of callback function
-: lispN
- ld E ((E CDR)) # Eval arg
- eval
- pop A # Get address
- ld (A) E # Set callback function
- pop E # Return function pointer
- 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)
- push cbLisp2 # Callback function pointer
- push Lisp2 # Address of callback function
- jmp lispN
-
-# (lisp3 'fun) -> num
-(code 'doLisp3 2)
- push cbLisp3 # Callback function pointer
- push Lisp3 # Address of callback function
- jmp lispN
-
-# (lisp4 'fun) -> num
-(code 'doLisp4 2)
- push cbLisp4 # Callback function pointer
- push Lisp4 # Address of callback function
- jmp lispN
-
-# (lisp5 'fun) -> num
-(code 'doLisp5 2)
- push cbLisp5 # Callback function pointer
- push Lisp5 # Address of callback function
- jmp lispN
-
-# (lisp6 'fun) -> num
-(code 'doLisp6 2)
- push cbLisp6 # Callback function pointer
- push Lisp6 # Address of callback function
- jmp lispN
-
-# (lisp7 'fun) -> num
-(code 'doLisp7 2)
- push cbLisp7 # Callback function pointer
- push Lisp7 # Address of callback function
- jmp lispN
-
-# (lisp8 'fun) -> num
-(code 'doLisp8 2)
- push cbLisp8 # Callback function pointer
- push Lisp8 # Address of callback function
- jmp lispN
-
-# (lisp9 'fun) -> num
-(code 'doLisp9 2)
- push cbLisp9 # Callback function pointer
- push Lisp9 # Address of callback function
- jmp lispN
-
-(code 'cbLisp1 0)
- push Z
- ld Z Lisp1 # Address of callback function
-: cbLisp
+: cbl
begin 5 # Arguments in A, C, E, X and Y
push L # Save C frame pointer
ld L (Link) # Restore link register
link # Apply args
- push (Z) # 'fun'
+ push (Z I) # 'fun'
xchg A E # First arg
call boxCntE_E # Make number
push E
@@ -1886,45 +1819,146 @@
pop Z
ret
-(code 'cbLisp2 0)
+(code 'cbl1 0)
push Z
- ld Z Lisp2 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp3 0)
+ lea Z (Lisp) # Address of callback function
+ jmp cbl
+: cbl2
push Z
- ld Z Lisp3 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp4 0)
+ lea Z (Lisp II)
+ jmp cbl
+: cbl3
push Z
- ld Z Lisp4 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp5 0)
+ lea Z (Lisp (* 2 II))
+ jmp cbl
+: cbl4
push Z
- ld Z Lisp5 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp6 0)
+ lea Z (Lisp (* 3 II))
+ jmp cbl
+: cbl5
push Z
- ld Z Lisp6 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp7 0)
+ lea Z (Lisp (* 4 II))
+ jmp cbl
+: cbl6
push Z
- ld Z Lisp7 # Address of callback function
- jmp cbLisp
-
-(code 'cbLisp8 0)
+ lea Z (Lisp (* 5 II))
+ jmp cbl
+: cbl7
+ push Z
+ lea Z (Lisp (* 6 II))
+ jmp cbl
+: cbl8
+ push Z
+ lea Z (Lisp (* 7 II))
+ jmp cbl
+: cbl9
+ push Z
+ lea Z (Lisp (* 8 II))
+ jmp cbl
+: cbl10
+ push Z
+ lea Z (Lisp (* 9 II))
+ jmp cbl
+: cbl11
+ push Z
+ lea Z (Lisp (* 10 II))
+ jmp cbl
+: cbl12
+ push Z
+ lea Z (Lisp (* 11 II))
+ jmp cbl
+: cbl13
+ push Z
+ lea Z (Lisp (* 12 II))
+ jmp cbl
+: cbl14
+ push Z
+ lea Z (Lisp (* 13 II))
+ jmp cbl
+: cbl15
+ push Z
+ lea Z (Lisp (* 14 II))
+ jmp cbl
+: cbl16
push Z
- ld Z Lisp8 # Address of callback function
- jmp cbLisp
+ lea Z (Lisp (* 15 II))
+ jmp cbl
+: cbl17
+ push Z
+ lea Z (Lisp (* 16 II))
+ jmp cbl
+: cbl18
+ push Z
+ lea Z (Lisp (* 17 II))
+ jmp cbl
+: cbl19
+ push Z
+ lea Z (Lisp (* 18 II))
+ jmp cbl
+: cbl20
+ push Z
+ lea Z (Lisp (* 19 II))
+ jmp cbl
+: cbl21
+ push Z
+ lea Z (Lisp (* 20 II))
+ jmp cbl
+: cbl22
+ push Z
+ lea Z (Lisp (* 21 II))
+ jmp cbl
+: cbl23
+ push Z
+ lea Z (Lisp (* 22 II))
+ jmp cbl
+: cbl24
+ push Z
+ lea Z (Lisp (* 23 II))
+ jmp cbl
-(code 'cbLisp9 0)
+# (lisp 'sym ['fun]) -> num
+(code 'doLisp 2)
+ push X
+ push Y
push Z
- ld Z Lisp9 # Address of callback function
- jmp cbLisp
+ ld X (E CDR) # Get tag
+ call evSymX_E # Evaluate to a symbol
+ ld Y Lisp # Search lisp callback definitions
+ ld Z cbl1
+ do
+ cmp E (Y) # Found tag?
+ jeq 10 # Yes
+ add Y II # Next entry
+ add Z "cbl2-cbl1"
+ cmp Y LispEnd
+ until eq
+ ld Y Lisp # Not found, search for empty slot
+ ld Z cbl1
+ do
+ cmp (Y I) Nil # Empty?
+ if eq # Yes
+ ld (Y) E # Store tag
+10 ld X (X CDR) # X on 'fun'
+ ld E (X) # Eval 'fun'
+ eval
+ ld (Y I) E # Store in slot
+ ld E Z
+ pop Z
+ pop Y
+ pop X
+ test E (hex "F000000000000000") # Fit in short number?
+ jnz boxNumE_E # No
+ shl E 4 # Else make short number
+ or E CNT
+ ret
+ end
+ add Y II # Next entry
+ add Z "cbl2-cbl1"
+ cmp Y LispEnd
+ until eq
+ ld Y CbErr
+ jmp errEXYZ
+: CbErr asciz "Too many callbacks"
(code 'lisp 0)
begin 6 # Function name in A, arguments in C, E, X, Y and Z
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 02aug10abu
+# 05aug10abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 3 10)
+(de *Version 3 0 3 11)
# vi:et:ts=3:sw=3
