commit 1e3dd1f0ffd4be6910098c22b99a6e5220661ed9
parent bc651b35b90895e2cbeb09380afb90b834f276f0
Author: Commit-Bot <unknown>
Date: Thu, 10 Jun 2010 09:56:41 +0000
Automatic commit from picoLisp.tgz, From: Thu, 10 Jun 2010 09:56:41 GMT
Diffstat:
| M | lib/tags | | | 24 | ++++++++++++------------ |
| M | src64/flow.l | | | 111 | +++++++++++++++++++++++++++++++++++++++++++++++++------------------------------ |
| M | src64/glob.l | | | 8 | ++++---- |
3 files changed, 85 insertions(+), 58 deletions(-)
diff --git a/lib/tags b/lib/tags
@@ -1,5 +1,5 @@
-! (2823 . "@src64/flow.l")
-$ (2925 . "@src64/flow.l")
+! (2850 . "@src64/flow.l")
+$ (2952 . "@src64/flow.l")
% (2251 . "@src64/big.l")
& (2472 . "@src64/big.l")
* (2070 . "@src64/big.l")
@@ -46,7 +46,7 @@ bool (1735 . "@src64/flow.l")
box (837 . "@src64/flow.l")
box? (999 . "@src64/sym.l")
by (1535 . "@src64/apply.l")
-bye (3400 . "@src64/flow.l")
+bye (3427 . "@src64/flow.l")
caaaar (271 . "@src64/subr.l")
caaadr (288 . "@src64/subr.l")
caaar (99 . "@src64/subr.l")
@@ -61,7 +61,7 @@ caddar (409 . "@src64/subr.l")
cadddr (435 . "@src64/subr.l")
caddr (156 . "@src64/subr.l")
cadr (45 . "@src64/subr.l")
-call (3056 . "@src64/flow.l")
+call (3083 . "@src64/flow.l")
car (5 . "@src64/subr.l")
case (1976 . "@src64/flow.l")
catch (2476 . "@src64/flow.l")
@@ -113,7 +113,7 @@ diff (2561 . "@src64/subr.l")
dir (2497 . "@src64/main.l")
dm (561 . "@src64/flow.l")
do (2150 . "@src64/flow.l")
-e (2886 . "@src64/flow.l")
+e (2913 . "@src64/flow.l")
echo (4177 . "@src64/io.l")
env (605 . "@src64/main.l")
eof (3317 . "@src64/io.l")
@@ -138,7 +138,7 @@ flip (1686 . "@src64/subr.l")
flush (4839 . "@src64/io.l")
fold (3341 . "@src64/sym.l")
for (2239 . "@src64/flow.l")
-fork (3223 . "@src64/flow.l")
+fork (3250 . "@src64/flow.l")
format (1770 . "@src64/big.l")
free (2034 . "@src64/db.l")
from (3336 . "@src64/io.l")
@@ -165,12 +165,12 @@ inc (1937 . "@src64/big.l")
index (2609 . "@src64/subr.l")
info (2401 . "@src64/main.l")
intern (875 . "@src64/sym.l")
-ipid (3168 . "@src64/flow.l")
+ipid (3195 . "@src64/flow.l")
isa (974 . "@src64/flow.l")
job (1440 . "@src64/flow.l")
journal (977 . "@src64/db.l")
key (3167 . "@src64/io.l")
-kill (3200 . "@src64/flow.l")
+kill (3227 . "@src64/flow.l")
last (2029 . "@src64/subr.l")
length (2685 . "@src64/subr.l")
let (1490 . "@src64/flow.l")
@@ -233,7 +233,7 @@ on (1581 . "@src64/sym.l")
onOff (1611 . "@src64/sym.l")
one (1644 . "@src64/sym.l")
open (4108 . "@src64/io.l")
-opid (3184 . "@src64/flow.l")
+opid (3211 . "@src64/flow.l")
opt (2687 . "@src64/main.l")
or (1651 . "@src64/flow.l")
out (4002 . "@src64/io.l")
@@ -311,13 +311,13 @@ super (1231 . "@src64/flow.l")
sym (3798 . "@src64/io.l")
sym? (2406 . "@src64/subr.l")
sync (3020 . "@src64/io.l")
-sys (3027 . "@src64/flow.l")
+sys (3054 . "@src64/flow.l")
t (1762 . "@src64/flow.l")
tail (1896 . "@src64/subr.l")
tell (3090 . "@src64/io.l")
text (1270 . "@src64/sym.l")
throw (2502 . "@src64/flow.l")
-tick (3136 . "@src64/flow.l")
+tick (3163 . "@src64/flow.l")
till (3403 . "@src64/io.l")
time (2211 . "@src64/main.l")
touch (1049 . "@src64/sym.l")
@@ -344,7 +344,7 @@ wr (4970 . "@src64/io.l")
xchg (1536 . "@src64/sym.l")
xor (1712 . "@src64/flow.l")
x| (2552 . "@src64/big.l")
-yield (2712 . "@src64/flow.l")
+yield (2716 . "@src64/flow.l")
yoke (1187 . "@src64/subr.l")
zap (1063 . "@src64/sym.l")
zero (1629 . "@src64/sym.l")
diff --git a/src64/flow.l b/src64/flow.l
@@ -1,4 +1,4 @@
-# 09jun10abu
+# 10jun10abu
# (c) Software Lab. Alexander Burger
(code 'redefMsgEC)
@@ -2579,28 +2579,28 @@
push (StkLimit) # and 'lim'
push (EnvCo7) # Link
ld (EnvCo7) S # Close coroutine frame
- save (Env) (EnvMid) (S III) # Save environment
+ ld Z S # Point Z to main frame
+ save (Env) (EnvMid) (Z III) # Save environment
: resumeCoroutine
ld S (Y -II) # Restore stack pointer
ld (Y -II) 0 # Mark as active
lea A (Y 4096) # Set stack limit
sub A (StkSize)
ld (StkLimit) A
- push (EnvApply) # Save current routine's apply stack
- ld C (EnvBind) # Current routine's bindings
load (Env) (EnvMid) (Y (pack -II "-(EnvMid-Env)")) # Restore environment
ld X (EnvBind) # Reversed bindings
+ ld C (Z III) # Main bindings
do
null X # More reversed bindings?
while nz # Yes
ld Y (X) # Link address in Y
null (X -I) # Env swap zero?
if z # Yes
- lea Z (Y -II) # End of bindings in Z
+ lea A (Y -II) # End of bindings in A
do
- xchg ((Z)) (Z I) # Exchange symbol value with saved value
- sub Z II
- cmp Z X # More?
+ xchg ((A)) (A I) # Exchange symbol value with saved value
+ sub A II
+ cmp A X # More?
until lt # No
end
ld A (Y I) # Get down link
@@ -2609,21 +2609,25 @@
ld X A
loop
ld (EnvBind) C # Set local bindings
- pop C # Get main routine's apply stack
- ld X (EnvApply) # Local apply stack
- null X # Any?
- if z # No
- ld (EnvApply) C # Set local apply stack
- else
- ld X (X) # End if frame in X
- do
- ld A (X I) # Get link
- null A # More?
- while ne # No
- ld X A # Follow link
- loop
- ld (X I) C # Clear link
- end
+ ld X EnvInFrames # Pointer to input frames
+ ld C (Z (pack III "+(EnvMid-EnvInFrames)")) # Local input frames
+ call joinLocalCX # Join locals
+ ld X EnvOutFrames # Pointer to output frames
+ ld C (Z (pack III "+(EnvMid-EnvOutFrames)")) # Local output frames
+ call joinLocalCX # Join locals
+ ld X EnvCtlFrames # Pointer to ctlput frames
+ ld C (Z (pack III "+(EnvMid-EnvCtlFrames)")) # Local ctlput frames
+ call joinLocalCX # Join locals
+ ld X EnvMeth # Pointer to method frames
+ ld C (Z (pack III "+(EnvMid-EnvMeth)")) # Local method frames
+ call joinLocalCX # Join locals
+ ld X EnvApply # Local apply stack
+ do
+ null (X) # Any?
+ while nz # Yes
+ ld X ((X)) # Follow link
+ loop
+ ld (X) (Z (pack III "+(EnvMid-EnvApply)")) # Join
pop X # Get saved L
null X # Any?
if nz # Yes
@@ -2714,7 +2718,7 @@
push Y
push Z
ld X E
- ld Z (EnvCo7) # Get coroutine
+ ld Z (EnvCo7) # Get main
null Z # Any?
jz yieldErrX # No
ld Y (E CDR)
@@ -2761,23 +2765,26 @@
end
push L # End of segment
push Y # Save taget coroutine
- ld X (EnvApply) # Get apply stack
- null X # Any?
- if nz # Yes
- cmp X (Z (pack III "+(EnvMid-EnvApply)")) # Local apply stack?
- if eq # No
- ld (EnvApply) 0 # Clear it
- else
- ld X (X) # End of frame in X
- do
- ld A (X I) # Get link
- cmp A (Z (pack III "+(EnvMid-EnvApply)")) # Reached main routine's stack?
- while ne # No
- ld X A # Follow link
- loop
- ld (X I) 0 # Clear link
- end
- end
+ ld X EnvApply # Pointer to apply stack
+ do
+ ld A (X)
+ cmp A (Z (pack III "+(EnvMid-EnvApply)")) # Local apply stack?
+ while ne # Yes
+ lea X ((A) I) # Get link
+ loop
+ ld (X) 0 # Cut off
+ ld X EnvMeth # Pointer to method frames
+ ld C (Z (pack III "+(EnvMid-EnvMeth)")) # Local method frames
+ call cutLocalCX # Cut off locals
+ ld X EnvCtlFrames # Pointer to ctlput frames
+ ld C (Z (pack III "+(EnvMid-EnvCtlFrames)")) # Local ctlput frames
+ call cutLocalCX # Cut off locals
+ ld X EnvOutFrames # Pointer to output frames
+ ld C (Z (pack III "+(EnvMid-EnvOutFrames)")) # Local output frames
+ call cutLocalCX # Cut off locals
+ ld X EnvInFrames # Pointer to input frames
+ ld C (Z (pack III "+(EnvMid-EnvInFrames)")) # Local input frames
+ call cutLocalCX # Cut off locals
ld C 0 # Back link
ld X (EnvBind) # Reverse bindings
null X # Any?
@@ -2809,7 +2816,7 @@
null Y # Target coroutine?
jnz resumeCoroutine # Yes
ld S Z # Set stack pointer
- load (Env) (EnvMid) (S III) # Restore environment
+ load (Env) (EnvMid) (Z III) # Restore environment
pop (EnvCo7) # Restore coroutine link
pop (StkLimit) # 'lim'
add S (pack I "+(EnvMid-Env)") # Clean up
@@ -2819,6 +2826,26 @@
pop X
ret
+(code 'cutLocalCX 0)
+ do
+ cmp C (X) # More locals?
+ if eq # No
+ ld (X) 0 # Cut off
+ ret
+ end
+ ld X (X) # Next frame
+ loop
+
+(code 'joinLocalCX 0)
+ do
+ null (X) # More locals?
+ if z # No
+ ld (X) C # Join
+ ret
+ end
+ ld X (X) # Next frame
+ loop
+
# (! . exe) -> any
(code 'doBreak 2)
ld E (E CDR) # exe
diff --git a/src64/glob.l b/src64/glob.l
@@ -1,4 +1,4 @@
-# 08jun10abu
+# 10jun10abu
# (c) Software Lab. Alexander Burger
(data 'Globals 0)
@@ -534,12 +534,12 @@
: EnvMeth word 0 # Method frames
: EnvMake word 0 # 'make' env
: EnvYoke word 0
-: EnvMid # Must be aligned
-: EnvCo7 word 0 # Coroutines
-: EnvTask word Nil # Task list
: EnvParseX word 0 # Parser status
: EnvParseC word 0
: EnvParseEOF word -1
+: EnvMid # Must be aligned
+: EnvCo7 word 0 # Coroutines
+: EnvTask word Nil # Task list
: EnvProtect word 0 # Signal protection
: EnvTrace word 0 # Trace level
: EnvEnd # Must be aligned
