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 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:
Mlib/tags | 24++++++++++++------------
Msrc64/flow.l | 111+++++++++++++++++++++++++++++++++++++++++++++++++------------------------------
Msrc64/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