diff --git a/dialer.com b/dialer.com index b31789e..9a60ab9 100755 Binary files a/dialer.com and b/dialer.com differ diff --git a/dialer.jrt b/dialer.jrt index 57a7fb9..74dbad9 100755 --- a/dialer.jrt +++ b/dialer.jrt @@ -63,7 +63,9 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div , : connect ( st -- ) call noisy 200 sleep-csec handshake ; import embed.jrt -array rick-welcome-rle { s" rickclub.bin" embed-rle } +array rick-welcome-rle +{ : lines-of pagew 2* * take ; + s" rickclub.bin" open filebytes 18 lines-of encode-rle } : xmit-screen ( rle -- ) 0 0 textxy! rle-decode each i 8 >> textpen ! i emit diff --git a/embed.jrt b/embed.jrt index 05ccd21..b6050ae 100755 --- a/embed.jrt +++ b/embed.jrt @@ -32,8 +32,8 @@ var rle-run : >rle-done 0 rle-run ! target rle-start @ !t ; -: encode-rle ( -- , with iterator that returns bytes ) - >rle-start each i iteration if i 8 << | >rle else drop then next >rle-done ; +: encode-rle ( call with iterator that returns bytes ) + >rle-start each i iterate if i 8 << | >rle else drop then next >rle-done ; : embed-rle ( host-filename -- ) open filebytes encode-rle ; : embed ( host-filename -- ) target 0 w>t open filebytes each i >t next target swap !t ; diff --git a/iter.jrt b/iter.jrt index 6545f1d..20c236c 100755 --- a/iter.jrt +++ b/iter.jrt @@ -57,6 +57,24 @@ nexttop :drop nextdrop itop :push >i nexttop :push >next +:asm r>next + MOV BX @[ SS: nexttop @] + DEC BX DEC BX + DEC BP DEC BP + MOV AX @[ BP] + MOV @[ SS: nexttop @] BX + MOV @[ SS: BX] AX + NEXT + +:asm next>r + MOV BX @[ SS: nexttop @] + MOV AX @[ SS: BX] + INC BX INC BX + MOV @[ SS: nexttop @] BX + MOV @[ BP] AX + INC BP INC BP + NEXT + : next always more convenient to check the flag first when consuming the result. ) : get-next ( -- c f ) 0 nextpeek execute swap ; : n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ; -: iteration get-next if drop 1 else n-nextdrop 0 then ; -: EACH_ r ; +: iterate get-next if drop 1 else n-nextdrop 0 then ; +: EACH_ r ; { ( Because we dereference pointers on the return stack, we must run this from the caller's segment. Copy the definition into the host segment. ) - : EACH_ r ; + : EACH_ r ; : each ' EACH_ , here >i 0 , ; immediate : continue ' GOTO_ , i cell - , ; immediate : next ['] continue here next 0 cancelled ! 0 swap |; >next ; { : break ' >cancel , ['] continue ; immediate :timm break t, >cancel CONTINUE ; } +: cancel >cancel iterate drop ; : nothing :| 0 1 |; >next ; : single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ; @@ -123,29 +142,109 @@ nexttop :push >next >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ; : pchars ( st -- ) 1- >i :| i 1 else drop 0 then 1 |; >next ; -:asm tail ( TODO: support CREATE words ) - LODSW - MOV BX AX - INC BX INC BX - MOV SI BX - NEXT - -: gen-save-args ( extra-args... extra-arg-count -- ) +( +: gen-save-args [ extra-args... extra-arg-count -- ] begin dup while swap >next 1- repeat drop ; -: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext ) +: gen-save [ 0 0 extra-args... extra-arg-count -- 1 cnext ] >r r@ gen-save-args rot drop drop 1 swap ; -: gen-restore ( arg-count -- args... ) +: gen-restore [ arg-count -- args... ] begin dup while cancel iteration drop ; -: _resume ( cpcancel -- c f args... ) +:asm _resume ( cpcancel -- 0 0 args... ) + POP DX + MOV AX SS + MOV ES AX + PUSH FALSE + PUSH FALSE + MOV DI @[ SS: nexttop @] + + ( make SP affect the nextstack and DI affect the data stack. ) + STD ( data stack grows down ) + XCHG DI SP + ( PUSH decrements and then stores; STOSW stores then decrements. ) + SCASW ( pre-decrement ) + + POP BX ( points to xt of the girl calling this, discard ) + POP BX ( points to the following the yield ) + XOR CX CX + MOV CL @[ BX] + CMP @[ cancelled @] 0 # + JNZ 0 @> + ( not cancelled; move CX values from next-stack to data-stack ) + JCXZ 2 @> +1 :> + POP AX + STOSW + LOOP 1 <@ +2 <: + ( fix return stack to return to the yielded code ) + INC BX + MOV @[ BP] BX + INC BP INC BP + ( fix SP - DI is one word past the end of the stack ) + CLD SCASW XCHG SP DI + ( fix nexttop ) + MOV @[ SS: nexttop @] DI + NEXT +0 <: + ( cancelled! ) + ( fix SP ) + CLD SCASW XCHG SP DI + ( throw away next values ) + SHL CX 1 # + ADD DI AX + ( update nexttop ) + MOV @[ SS: nexttop @] DI + ( abort the current word ) + DEC BP DEC BP + MOV SI @[ BP] + ( run the "cancel" xt in DX ) + MOV BX DX + JMP @[ BX] + +( : _resume [ cpcancel -- c f args... ] nextdrop 0 0 r rswap ub@ gen-restore ; -: _suspend ( cpresume -- ) - rswap r@ ub@ swap >r gen-save next >next ; + drop r rswap ub@ gen-restore ; ) -: GENSTART_ next :| ' noop _resume |; >next ; +:asm _suspend ( 0 0 cpresume -- 1 n ) + POP DX + MOV AX SS + MOV ES AX + MOV DI @[ SS: nexttop @] + DEC BP DEC BP ( top of return stack points to arg count ) + MOV BX @[ BP] + XOR CX CX + MOV CL @[ BX] + STD ( next-stack grows down ) + SCASW ( pre-decrement ) + JCXZ 1 @> +0 :> + POP AX + STOSW + LOOP 0 <@ +1 <: + MOV AX BX + STOSW + MOV AX DX + STOSW + CLD SCASW + MOV @[ SS: nexttop @] DI + ( data stack contains 0 0, must become 1 argcount+2 ) + POP AX + POP AX + MOV AX 1 # + PUSH AX + MOV CL @[ BX] + INC CX INC CX + PUSH CX + NEXT + +( : _suspend [ cpresume -- ] + rswap r@ ub@ swap >r gen-save rswap r>next r>next ; ) + +: GENSTART_ r>next :| ' noop _resume |; >next ; { var gen-arg-count :timm (( t:| t, GENSTART_ gen-arg-count @ >t ; @@ -162,7 +261,10 @@ nexttop :push >next :yield map next >i :| :| idrop i cancel |; _resume idrop i |; _suspend 1+ ; : _pass-suspend rdrop :| ' cancel _resume |; _suspend ; +: _return rdrop r ; ( don't yield at all, skip past the yielder ) :yield pass _pass-suspend ; -:yield filter if _pass-suspend else r then ; +:yield filter if _pass-suspend then _return ; -: chars pchars (( each i b@ map next )) ; +: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ; +: readbytes ( -- ) (( each i b@ map next )) ; +: chars ( p -- ) pchars readbytes ; diff --git a/swine.com b/swine.com index 9ab8383..e4bc0d3 100755 Binary files a/swine.com and b/swine.com differ diff --git a/zipoff.com b/zipoff.com index 62e922e..f72130d 100755 Binary files a/zipoff.com and b/zipoff.com differ diff --git a/zipstub.seg b/zipstub.seg index ab41e08..1b88236 100755 Binary files a/zipstub.seg and b/zipstub.seg differ