refactor iterator definitions to define a "blank" iterator, which is then

modified by subsequent definitions.

asm.jrt

@@ -86,7 +86,8 @@ array patchtable 10 2 cells * allot
 : L! [ ' ' , ] 2 cells + target swap ! ;
 
 array anonlabels 10 cells allot
-: <@ ( labelid -- ) cells anonlabels + @ @+ ;
+: L<@ ( labelid -- addr ) cells anonlabels + @ ;
+: <@ ( labelid -- ) L<@ @+ ;
 : :> ( labelid -- ) cells anonlabels + target swap ! ;
 
 : memreg create , does> @ oparg-base ! oparg-complete! ;

assemble.jrt

@@ -5,9 +5,7 @@ s" asm.jrt" loadfile
 :init segalloc ' comseg redefine ;
 
 : writecom ( filename -- )
-  overwrite >r 0x100 
+  overwrite >r target 0x100 - 0x100 r@ comseg farfwrite <r close ;
-  begin dup target < while dup b@t r@ fputc 1+ repeat 
-  drop <r close ;
 : writeself overwrite >r here 0x100 - 0x100 r@ fwrite <r close ;
 
 s" assemble.com" writeself

common.jrt

@@ -1,3 +1,4 @@
+: 2drop drop drop ;
 : !+ ( v p -- ) dup @ <rot + swap ! ;
 : b!+ ( v p -- ) dup b@ <rot + swap b! ;
 : b!| ( f p -- ) dup b@ <rot | swap b! ;

dialer.jrt

@@ -1,5 +1,21 @@
-1 var, quiet
+0 var, quiet
+0 var, quick
 
+: quiet? quiet @ quick @ or ; : quick? quick @ ;
+: noisy quiet? if rdrop then ;
+: slow quick? if rdrop then ;
+var last-delay
+: delay-base
+  timer @ dup last-delay @ - dup 0 >= swap 5 < and if drop last-delay @ then ;
+: delay dup not quick? and if drop else
+    delay-base + dup last-delay !
+    begin dup timer @ > while suspend repeat drop
+  then ;
+
+var ms-error
+: ms ms-error @ + 8 /mod ms-error ! delay ;
+
+dbg" modem sounds"
 array dtmf-col 1209 freq>div , 1336 freq>div , 1477 freq>div ,
 array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div ,
 
@@ -11,8 +27,6 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div ,
 -2 const D*
 -1 const D#
 
-: noisy quiet @ if rdrop then ;
-
 : dtmf ( digit -- f1 f2 ) 1- 
   dup 0 < if abs 3 % 3 swap else 3 /mod then 
   cells dtmf-col + @ swap cells dtmf-row + @ ;
@@ -26,7 +40,7 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div ,
 
 : dialst ( st -- ) chars each i dialch next ;
 : dialtone [ 350 freq>div lit 440 freq>div lit ] 200 arp ;
-: offhook 30 sleep-csec 3 2 boop 15 sleep-csec 7 2 boop 10 sleep-csec ;
+: offhook noisy 30 sleep-csec 3 2 boop 15 sleep-csec 7 2 boop 10 sleep-csec ;
 
 2100 freq>div const carrier-div
 980 freq>div const hs-low
@@ -53,24 +67,203 @@ array dtmf-row 697 freq>div , 770 freq>div , 852 freq>div , 941 freq>div ,
   45 probe-hi 50 probe-lo 15 probe-hi 60 probe-lo 60 probe-hi 
   300 fullduplex ;
 
-( terminal words )
+dbg" statusbar"
-: fixcursor texty 8 << textx | movecursor ;
+var status
+var status-timer
+var status-bg
+
+: disconnect-status 
+  s" DISCONNECTED" status ! 0 status-timer ! magenta status-bg ! ;
+: connect-status 
+  s" CONNECTED" status ! ticks status-timer ! green status-bg ! ;
+disconnect-status
+
+: connected? status-bg @ green = ;
+: space-to ( x -- ) textx - sp draw-hrepeat ;
+: .digit ( v -- ) [ key 0 lit ] + draw-char ;
+: .2digit ( v -- ) 10 /mod swap 10 % .digit .digit ;
+: .: [ key : lit ] draw-char ;
+: draw-status-timer
+  ticks status-timer @ - 18 / 60 /mod swap 60 /mod swap 
+  .2digit .: .2digit .: .2digit ;
+
+: draw-status
+  status-bg @ bg! white fg! 0 0 textxy!
+  1 space-to status @ draw-text
+  connected? if 70 space-to draw-status-timer 
+             else 65 space-to s" | ESC for menu" draw-text then
+  80 space-to ;
+
+: init-statusbar
+  :| begin textstate draw-status textstate! suspend again |;
+  spawn-task drop ;
+
+dbg" terminal"
+: sleep-key begin key-waiting? not while suspend repeat wait-key ;
+: pause sleep-key drop ;
+
+: fixcursor 
+  texty 24 - dup 0 > if times each 1 24 scrollup next 24 texty! else drop then 
+  texty 8 << textx | movecursor ;
+
 : nl nextline fixcursor ;
 : emit draw-char fixcursor ;
-: xmit ( st -- ) chars each i emit 1 sleep-csec next ;
+: xmit-iter each i emit 3 ms next ;
-: call ( st -- ) s" ATDT" xmit dup xmit nl noisy offhook dialtone dialst ;
+: xmit ( st -- ) chars xmit-iter ;
+: xmit-line xmit nl ;
+: repeated ( v n -- ) times >arg (( each dup map next drop )) ;
 
-: connect ( st -- ) call noisy 200 sleep-csec handshake ;
+{ :timm x" t" t, xmit ;
+  :timm l" t" t, xmit-line ; }
 
+79 const MAXLINE
+array linebuf MAXLINE 1+ allot
+
+: printable? ( k -- f ) key>ch dup 0x20 >= swap 0x7e <= and ;
+: bs? ( k -- f ) key>scan dup %bs = swap %left = or ;
+: bs textx 1- dup textx! sp draw-char textx! fixcursor ;
+: enter? ( k -- f ) key>scan %enter = ;
+: readline linebuf begin sleep-key
+  dup enter? not while
+    dup printable? if over linebuf MAXLINE + < 
+      if key>ch 2dup swap b! emit 1+ else drop then else
+    dup bs? if drop dup linebuf > if bs 1- then else
+    drop then then
+  repeat drop 0 swap b! linebuf ;
+
+
+: call ( st -- ) white fg! x" ATDT" dup xmit-line 
+  quiet? if drop else offhook dialtone dialst then ;
+: successful-call ( st -- ) call noisy 200 sleep-csec handshake ;
+: hangup ( -- ) offhook nl disconnect-status white fg! l" NO CARRIER" ;
+
+: connect ( cp st -- ) 
+  successful-call connect-status l" CONNECT 57600" execute hangup ;
+
+dbg" downloading"
 import embed.jrt
-array rick-welcome-rle { s" rickclub.bin" embed-rle }
 
-: xmit-screen ( rle -- ) 0 0 textxy! rle-decode each
+: embed-write ( fp p -- ) dup embed-size swap embed-data <rot fwrite ; 
-    i 8 >> textpen ! i emit
+: rand-write ( fp size -- ) dup prngstate ! ( write the same file every time )
-  next ;
+  times each rand over fputc next drop reseed! ;
 
-: rick-welcome rick-welcome-rle xmit-screen ;
+{ : deffile ( filename desc file sizer writer ) ARRAY w>t w>t w>t w>t w>t ; 
+  : defembed ( filename desc -- ) 
+    over T] open target swap embed-file 
+    t' embed-size t' embed-write deffile ; 
+  : deffake ( filename desc size -- ) t' noop t' rand-write deffile ; }
 
+: filename ( file -- st ) 4 cells + @ ;
+: filedesc ( file -- st ) 3 cells + @ ;
+: filedata ( file -- data ) 2 cells + @ ;
+: filesize ( file -- n ) dup filedata swap cell + @ execute ;
+: write-file ( file -- ) 
+  dup filename overwrite >r r@ over filedata <rot @ execute <r close ;
+
+: snapshot 1 0 pagecopy ; : restore 0 1 pagecopy ;
+
+: xmit-desc ( st -- ) 
+  chars (( each i [ key \ lit ] = if nl else pass then next )) 
+  xmit-iter ;
+
+array numstr 7 allot
+key 0 const $0
+: char>> ( st ch -- st+1 ) over b! 1+ ;
+: digit>> ( st state n div -- st state n )
+  /mod swap dup if ( st state n digit )
+    $0 + >r <rot <r char>> ( state n st )
+    <rot drop 1 <rot
+  else drop over if <rot $0 char>> >rot then then ;
+: nsep>> ( st state n -- st state n )
+  over if <rot [ key , lit ] char>> >rot then ;
+: n>st ( n -- st )
+  numstr 0 <rot 
+  10000 digit>> 1000 digit>> nsep>> 100 digit>> 10 digit>>
+  swap drop $0 + char>> 0 char>> drop numstr ;
+
+: draw-download-progress ( size progress -- )
+  12 12 textxy! dup n>st draw-text
+  swap 40 / / 20 12 textxy! 0xb2 draw-hrepeat ;
+
+: download-file ( file -- ) dup write-file
+  >r textstate <r snapshot green bg! white fg! 1 boxstyle!
+  10 10 textxy! 60 4 filled draw-box
+  12 11 textxy! s" Downloading " draw-text dup filename draw-text
+  filesize 0 62 12 textxy! over n>st draw-text
+  20 12 textxy! 40 0xb0 draw-hrepeat
+  2dup draw-download-progress
+  30 delay
+  begin 15 delay 256 rand 0x1f & + + 2dup > while 
+    2dup draw-download-progress repeat
+  drop dup draw-download-progress 60 delay restore textstate! ;
+
+dbg" BBSes"
+
+: tolower ( ch -- ch ) 
+  dup [ key A lit ] >= over [ key Z lit ] <= and 
+  if [ key a key A - lit ] + then ;
+
+: readch ( -- ch )
+  begin sleep-key key>ch dup printable? not while drop repeat ;
+
+: inputch readch tolower dup emit nl ;
+
+: xmit-screen ( rle -- ) 
+  rle-decode textpen @ 
+  (( each i 8 >> textpen ! pass next )) xmit-iter 
+  textpen ! ;
+{ : lines-of pagew 2* * take ; }
+
+import rick.jrt
+
+dbg" menu"
+var menu-onclose
+: close-menu ( cp -- ) menu-onclose ! restore suspend ;
+: menu-options ((
+  0 s" Phone Book:" yield2
+  :| :| ' rick s" 5551212" connect |; close-menu |; 
+    s" Rick's Clubhouse BBS" yield2
+  0 0 yield2
+  quiet @ if :| 0 quiet !save |; s" Enable modem sounds" yield2 else
+             :| 1 quiet !save |; s" Disable modem sounds" yield2 then
+  :| connected? if hangup then textmode exit |; s" Exit to DOS" yield2 )) ;
+
+var selection
+: option-walk ( cpstop -- )
+  >r selection @ 0 menu-options each
+    i if dup selection ! then r@ execute if break then 1+ 
+  next 2drop rdrop ;
+
+: prev-option :| 2dup 1+ <= |; option-walk ;
+: next-option :| i if 2dup < else 0 then |; option-walk ;
+: choose menu-options selection @ nth execute ;
+: first-option 0 selection ! next-option prev-option ;
+
+25 const menux 7 const menuy 
+pagew menux 2* - const menuw
+
+: draw-options
+  menux 2 + menuy 1+ textxy!
+  0 menu-options each
+    dup selection @ = if green else magenta then bg!
+    textx j if j draw-text then menux menuw + 2 - space-to nextline textx!
+  1+ next drop ;
+: draw-menubox
+  magenta bg! white fg! 1 boxstyle!
+  menux menuy textxy!
+  menuw menu-options count 2 + filled draw-box ;
+
+: menu-interact sleep-key key>scan
+    dup %enter = if choose then
+    dup %up    = if prev-option then
+    dup %down  = if next-option then
+        %esc   = if ' noop close-menu then ;
+
+: menu-loop begin draw-options menu-interact menu-onclose @ until ;
+: popup-menu snapshot textstate 0 menu-onclose ! first-option
+  draw-menubox menu-loop textstate! menu-onclose @ execute 0 menu-onclose ! ;
+
+dbg" startup"
 { : X ( v -- v ) 2* 1 | ;
   : o ( v -- v ) 2* ; }
 7 const logoh
@@ -142,21 +335,21 @@ var curr-logobit
     next drop
   next nextline textx! next ;
 
-: animate-logo
+: animate-logo draw-logo slow
   logobit-count 3 * times each draw-logo 10 sleep-csec nextlogo next ;
 
 : splash
-  blue bg! lgray fg! 32 fill-page lcyan fg! animate-logo 
+  blue bg! lgray fg! sp fill-page lcyan fg! animate-logo 
   nl nl 15 textx! lblue bg! lred fg! s" Unregistered version" xmit 
-  blue bg! lcyan fg! s" - you have used 13246 / 30" xmit nl 
+  blue bg! lcyan fg! s" - you have used 13246 / 30" xmit-line
-  15 textx! s" days of your limited trial!" xmit nl nl 200 sleep-csec 
+  15 textx! s" days of your limited trial!" xmit-line nl nl nl 200 delay 
   lgray fg! ;
 
-: go splash 0 15 textxy! 
+: go init-statusbar splash
-  s" 5551212" connect s" CONNECT 57600" xmit nl rick-welcome ;
+  popup-menu begin sleep-key key>scan %esc = if popup-menu then again ;
 
 ' go ' main redefine
 
 dbg" saving"
+{ here s", dialer.com" s" dialtest.com" writeenv }
 
-{ s" dialer.com" writecom }

embed.jrt

@@ -32,15 +32,17 @@ var rle-run
 
 : >rle-done 0 rle-run ! target rle-start @ !t ;
 
-: encode-rle ( -- , with iterator that returns bytes )
+: encode-rle ( call with iterator that returns bytes )
-  >rle-start each i iteration if i 8 << | >rle else drop then next >rle-done ;
+  >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 -- ) 
+: embed-file ( fp -- ) 
-  target 0 w>t open filebytes each i >t next target swap !t ;
+  >r target 0 w>t 0xffff target r@ T] fread <r close
+  T] fcount @t target + target! target swap !t ;
+: embed ( host-filename -- ) open embed-file ;
 }
 
-: embed-size ( embed -- v ) dup @ swap - ;
 : embed-data ( embed -- p ) cell + ;
+: embed-size ( embed -- v ) dup @ swap embed-data - ;
 
 : rle-decode ( p -- )
   >arg (( dup @ swap cell + +arg ( pend p )

file.jrt

@@ -55,24 +55,36 @@
   NEXT
 
 0 VAR, fcount
-:ASM fread
+:ASM farfread
+  POP DS ( seg )
+0 :>
   MOV AH 0x3f #
   POP BX ( fp )
   POP DX ( buffer )
   POP CX ( length )
   INT 0x21 #
+  MOV BX CS
+  MOV DS BX
   MOV t& fcount @+ AX ( save number of bytes read )
   NEXT
 
-:ASM fwrite
+DEF fread 0 L<@ w>t
+
+:ASM farfwrite
+  POP DS ( seg )
+0 :>
   MOV AH 0x40 #
   POP BX ( fp )
   POP DX ( buffer )
   POP CX ( length )
   INT 0x21 #
+  MOV BX CS
+  MOV DS BX
   MOV t& fcount @+ AX ( save number of bytes written )
   NEXT
 
+DEF fwrite 0 L<@ w>t
+
 -1 CONST EOF
 0 VAR, fbuffer
 :t fgetc ( fp -- c )

iter.jrt

@@ -1,8 +1,10 @@
 ( iteration control stacks
   We create two new stacks - a small stack to hold the "current" value
   of the loop, or the "i" stack, and a larger stack to hold any extra 
-  state, as well as the cp of a word that moves to the next value, which
+  state, which we call the "next" stack. Typically the top of the next
-  we call the "next" stack.
+  stack would contain an "iterator" that knows how to advance to the next 
+  value and how to be cancelled, depending on the needs of the calling code.
+
   With these two new stacks, we can create a generic loop construct for
   iterating over streaming values. Not only that, but those values can be 
   arbitrarily filtered and transformed simply by pushing a new value onto
@@ -39,10 +41,23 @@ nexttop :peek nextpeek
   MOV BX @[ SS: r@ @]
   INC BX INC BX
   MOV @[ SS: <r @] BX
+  NEXT ; 
+  : :ndrop ( pixp -- )
+:ASM >r ( c -- )
+  MOV BX @[ SS: r@ @]
+  POP CX
+  SHL CX 1 #
+  ADD BX CX
+  MOV @[ SS: <r @] BX
   NEXT ; }
 
 itop    :drop idrop
+itop    :ndrop n-idrop
 nexttop :drop nextdrop
+nexttop :ndrop n-nextdrop
+
+: iterdrop ( n-next -- ) n-nextdrop idrop ;
+: 1-iterdrop nextdrop idrop ; 
 
 { : :push ( pixp -- )
 :ASM >r
@@ -61,108 +76,219 @@ nexttop :push >next
 : <next 0 nextpeek nextdrop ;
 : i 0 ipeek ; : j 1 ipeek ;
 
-( iterator words must have the following shape: )
+:asm n-<next ( n |n| args... -- args... |n| )
-( -- more nextcount )
+  MOV AX SS
-( It must take care of updating the i-stack directly. if there are
+  MOV ES AX
-  no more values, it must remove the values from the i-stack and return 
+  POP CX
-  0 in the "more" place.
+  JCXZ 2 @>
+  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 )
+1 :>
+  POP AX
+  STOSW
+  LOOP 1 <@
+  ( fix SP - DI is one word past the end of the stack )
+  CLD SCASW XCHG SP DI
+  ( update nexttop )
+  MOV @[ SS: nexttop @] DI
+2 <:
+  NEXT
 
-  "nextcount" must be the number of items that are being taken up on the next
+:asm n->next ( args... n |n| -- |n| args... )
-  stack by this word. For simple iterators this will be 1, for the space
+  MOV AX SS
-  the iterator word takes. If "more" is 0, this number of items will be 
+  MOV ES AX
-  dropped. This is always returned even if there are more items to iterate 
+  POP CX
-  over, in order to support efficient cancellation. ">cancel" will push a word 
+  JCXZ 1 @>
-  onto the next-stack that will query the iterator below it to determine how 
+  MOV DI @[ SS: nexttop @]
-  many items need to be dropped. It will drop one item from the i-stack if the
+  STD ( next-stack grows down )
-  iterator indicates that there are more items.
+  SCASW ( pre-decrement )
+0 :>
+  POP AX
+  STOSW
+  LOOP 0 <@
+  CLD SCASW ( correct DI - off by one word )
+  MOV @[ SS: nexttop @] DI
+1 <:
+  NEXT
 
-  If an iterator requires any more complex cleanup to happen as the result
+( iterators are pointers to an array containing two function pointers: 
-  of a cancellation, such as dropping multiple items off the i-stack, or
+  xt-iter xt-cancel
-  aborting a task, it should check the "cancelled" flag to determine whether 
+  The xt-iter word must take care of updating the stacks directly. If 
-  to perform it. An iterator that returns 0 0 will not cause any further
+  there are no more values, it must remove the values from the i-stack, 
-  changes to occur to the iteration stacks, which allows it to be in complete
+  drop itself from the next-stack, and return 0. "finished" and "finish?"
-  control of this scenario if needed.
+  are useful words to help with this.
+
+  The xt-cancel word should remove all of the iterator's state from the
+  iteration stacks and return nothing. "n-nextdrop" and "iterdrop" are useful 
+  words to help with this. If the iterator is itself making use of an 
+  iterator below it on the stack, the xt-cancel word should call "cancel" to 
+  recursively clean that up once it's done.
 
   Note that all "next" words _must_ be defined in the target Forth!
   This means that any iterator that dereferences near memory, such as "links",
   WILL NOT WORK on the host Forth! )
 
-( get-next returns the result of the iterator in swapped order - it is usually
+: iterate 0 nextpeek @ execute ;
-  more convenient to specify the count last when writing iterators, but it's 
+: cancel 0 nextpeek cell + @ execute ;
-  always more convenient to check the flag first when consuming the result. )
+
-: get-next ( -- c f ) 0 nextpeek execute swap ;
+: finished ( -- 0 ) cancel 0 ;
-: n-nextdrop ( c -- ) dup if begin nextdrop 1- dup not until then drop ;
+: finish? ( f -- f ) if 1 else finished then ;
-: iteration get-next if drop 1 else n-nextdrop 0 then ;
+
-: EACH_ <r iteration if cell + else @ then >r ;
+: EACH_ <r iterate if cell + else @ then >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 iteration if cell + else @ then >r ;
+  : EACH_ <r iterate if cell + else @ then >r ;
   : each ' EACH_ , here >i 0 , ; immediate
   : continue ' GOTO_ , i cell - , ; immediate
   : next ['] continue here <i ! ; immediate
   :timm each t, EACH_ patchpt >i ;
   : CONTINUE t, GOTO_ i cell - w>t ;
   :timm continue CONTINUE ;
-  :timm next CONTINUE <i patch!t ; }
+  :timm next CONTINUE <i patch!t ;
+  : blankiter, t' finished w>t t' 1-iterdrop w>t ; }
+
+{ : defiter CREATE blankiter, DOES} >next ;
+{ : :iter CREATE blankiter, startcolon DOES} 
+  >r r@ [ 2 cells lit ] + execute <r >next ;
+
+{ : iter! ( val off -- ) cells latest entry>tcp + !t ;
+  : next! 2 iter! ;                 : cancel! 3 iter! ;
+  : :next target next! startcolon ; : :cancel target cancel! startcolon ; }
+
+defiter >cancel 
+:cancel nextdrop cancel ;
 
-0 var, cancelled
-: >cancel :| 1 cancelled ! nextdrop get-next if idrop then 
-             0 cancelled ! 0 swap |; >next ;
 { : break ' >cancel , ['] continue ; immediate
   :timm break t, >cancel CONTINUE ; }
 
-: nothing :| 0 1 |; >next ;
+defiter nothing
-: single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
+' nextdrop cancel!
-: times ( n -- ) >i :| <i dup if 1- >i 1 then 1 |; >next ;
-: links ( p -- )
-  dup if >i :| <i @ dup if >i 1 then 1 |; >next else nothing then ;
-: +for? ( n -- f ) <i + dup 1 nextpeek = if drop 0 else >i 1 then ;
-: for ( start lim -- ) >next 1- >i :| 1 +for? 2 |; >next ;
-: for+ ( start lim inc -- )
-  >next >next 1 nextpeek - >i :| 2 nextpeek +for? 3 |; >next ;
-: pchars ( st -- ) 1- >i :| <i 1+ dup b@ if >i 1 else drop 0 then 1 |; >next ;
 
-:asm tail ( TODO: support CREATE words )
+defiter >single-done
-  LODSW
+:iter single >i ;
-  MOV BX AX
+:next nextdrop 1 >single-done ;
-  INC BX INC BX
+
-  MOV SI BX
+:iter times ( n -- ) >i ;
+:next <i dup 1- >i finish? ;
+
+defiter >links
+:next <i @ dup >i finish? ;
+: links ( p -- ) dup if >i >links else nothing then ;
+
+: +for? ( n -- f ) <i + dup >i 1 nextpeek != finish? ;
+
+:iter for ( start lim -- ) >next 1- >i ;
+:next 1 +for? ;
+:cancel 2 iterdrop ;
+
+:iter for+ ( start lim inc -- ) >next >next 1 nextpeek - >i ;
+:next 2 nextpeek +for? ;
+:cancel 3 iterdrop ;
+
+:iter pchars ( st -- ) 1- >i ;
+:next <i 1+ dup >i b@ finish? ;
+
+: nth ( i -- v ) 0 each 2dup = if drop i break then 1+ next swap drop ;
+: count 0 each 1+ next ;
+
+:asm _suspend>args 
+( iter |r| yieldpoint -- argcount |r| yieldpoint iter )
+  MOV DI @[ -2 @+ BP]
+  POP @[ BP]
+  INC BP INC BP
+  XOR AH AH
+  MOV AL @[ DS: DI]
+  PUSH AX
   NEXT
 
-: gen-save-args ( extra-args... extra-arg-count -- )
+:asm 2r>next
-  begin dup while swap >next 1- repeat drop ;
+  MOV BX @[ SS: nexttop @]
-: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext ) 
+  ( bp grows up. top: BP-2, second: BP-4
-  >r r@ gen-save-args <r 2 + >rot drop drop 1 swap ;
+    nexttop grows down. top: nexttop, second: nexttop+2 )
-: gen-restore ( arg-count -- args... )
+  SUB BX 4 # ( make room for 2 more items on next stack )
-  begin dup while <next swap 1- repeat drop ;
+  MOV AX @[ -4 @+ BP]
+  MOV @[ SS: 2 @+ BX] AX
+  MOV AX @[ -2 @+ BP]
+  MOV @[ SS: BX] AX
+  SUB BP 4 # ( pop two off return stack )
+  MOV @[ SS: nexttop @] BX
+  NEXT
 
-: cancel >cancel iteration drop ;
+:asm _resume>args ( |n| yieldpoint xt-next -- argcount |n| |r| resumepoint )
-: _resume ( cpcancel -- c f args... )
+  MOV BX @[ SS: nexttop @]
-  nextdrop 0 0 <rot 
+  MOV DI @[ SS: 2 @+ BX]
-  cancelled @ if <next ub@ n-nextdrop execute rdrop return then
+  ADD BX 4 #
-  drop <next dup 1+ >r rswap ub@ gen-restore ;
+  MOV @[ SS: nexttop @] BX
-: _suspend ( cpresume -- ) 
+  XOR AH AH
-  rswap r@ ub@ swap >r gen-save <r <r >next >next ;
+  MOV AL @[ DS: DI]
+  INC DI
+  PUSH AX ( argcount )
+  MOV @[ BP] DI
+  INC BP INC BP
+  NEXT
 
-: GENSTART_ <r >next :| ' noop _resume |; >next ;
+: _resume _resume>args n-<next rswap ;
+: _suspend 
+  ( args... iter |r| yieldpoint ret -- 1 |r| ret |n| args... yieldpoint iter )
+  rswap _suspend>args n->next 2r>next 1 ;
+: _cancel _resume>args n-nextdrop rdrop ;
+
+defiter >genstart
+:next _resume>args n-<next ;
+' _cancel cancel!
+: GENSTART_ <r >next >genstart ;
+
+( yielding from a generator has three moving parts:
+  suspend: run immediately when the generator yields. takes care of updating
+           the i-stack appropriately, as well as potentially saving any
+           yield-specific state to the next-stack. After this runs, the 
+           generator's extra parameters are pushed to the next-stack, along
+           with the generator's "resume" pointer and the yielder's iterator.
+  resume: run when the generator is resumed by iterating. Before this runs,
+          the yielder will take care of placing the "resume" pointer back
+          on the stack and restoring the generator's arguments, so the
+          stack environments should match what they were when the suspension
+          happened. This deals with cleaning up after the yielder so the
+          rest of the generator can run.
+  cancel: run when the generator is aborted. Before this runs, the next-stack
+          is cleared of the "resume" pointer and all of the generator's
+          arguments. This should remove any yield-specific data from the
+          iteration stacks, and potentially call "cancel" to clean up the
+          iterator underneath if the yielder is intended to map or filter
+          another iterator. )
 
 { var gen-arg-count 
   :timm (( t:| t, GENSTART_ gen-arg-count @ >t ;
-  :timm )) t|; t, execute 0 gen-arg-count ! ;
+  :timm )) t, 0 t|; t, execute 0 gen-arg-count ! ;
   : +arg  1 gen-arg-count !+ ; :timm +arg +arg ;
   : -arg -1 gen-arg-count !+ ; :timm -arg -arg ;
   :timm >arg t, >next +arg ;
-  : :yield } create immediate target , startcolon 
+  : colonpair ( xt-first xt-second -- xt )
-           does> @ w>t gen-arg-count @ >t ; }
+    target <rot gencolon w>t swap w>t t, return ;
+  : :yield ( xt-suspend xt-resume xt-cancel -- )
+    } t' _cancel swap colonpair swap t' _resume swap colonpair
+    target >r w>t w>t gencolon w>t r@ compilenum t, _suspend t, return
+    create immediate <r 2 cells + , does> @ w>t gen-arg-count @ >t ; }
 
-:yield yield0 :| ' noop _resume |; _suspend ;
+: shadow-i <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
-:yield yield  >i :| ' idrop _resume idrop |; _suspend ;
+: unmap idrop <next >i ; : mapcancel unmap cancel ;
-:yield yield> >i :| ' idrop _resume <i |; _suspend ;
+: unsuspend rdrop rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
-:yield map    <i >next >i :| :| idrop <next >i cancel |; 
+: suspend? not if unsuspend then ;
-                             _resume idrop <next >i |; _suspend 1+ ;
-: _pass-suspend rdrop :| ' cancel _resume |; _suspend ;
-:yield pass _pass-suspend ;
-:yield filter if _pass-suspend else <r 1+ >r then ;
 
-: chars pchars (( each i b@ map next )) ;
+(       suspend    resume      cancel )
+         ' noop    ' noop      ' noop :yield yield0 [
+           ' >i   ' idrop     ' idrop :yield yield
+           ' >i      ' <i     ' idrop :yield yield>
+          ' 2>i  ' 2idrop         dup :yield yield2
+     ' shadow-i   ' unmap ' mapcancel :yield map
+         ' noop    ' noop    ' cancel :yield pass
+     ' suspend?    ' noop    ' cancel :yield filter
+
+: take ( n -- ) >arg (( each dup if pass else break then 1- next drop )) ;
+: readbytes ( -- ) (( each i b@ map next )) ;
+: chars ( p -- ) pchars readbytes ;

keys.jrt

@@ -10,6 +10,16 @@
   PUSH AX
   NEXT
 
+:asm key-waiting? ( -- f )
+  MOV AH 1 #
+  INT 0x16 #
+  JNZ 0 @>
+  PUSH FALSE
+  NEXT
+0 <:
+  PUSH TRUE
+  NEXT
+
 : key>scan 8 >> ;
 : key>ch 0xff & ;
 : scanup 0x80 | ;

rick.jrt

@@ -0,0 +1,100 @@
+dbg" Rick's Clubhouse BBS"
+array rick-welcome-rle 
+{ s" rickclub.bin" open filebytes 18 lines-of encode-rle }
+array rick-menu-rle
+{ s" rickmenu.bin" open filebytes 7 lines-of encode-rle }
+
+dbg" login"
+: login
+  l" To login as a guest, leave your name blank."
+  begin 
+    x" Enter your name: " readline nl 
+    dup b@ while x" Sorry, I don't recognize " xmit l" !" nl
+  repeat nl
+  cyan fg!
+  l" Welcome, guest! We hope you decide to apply for a full membership." 
+  l" Guest accounts have limited access." 
+  l" If you have any questions, feel free to page the sysop - I'll be happy"
+  l" to chat with you if I'm around!" 
+  l"    -- Rick" nl ;
+
+deferred rick-menu noop
+
+: page-rick 
+  x" Paging Sysop..."
+  5 times each 100 delay [ key . lit ] emit next nl
+  l" Sorry, guess they're not home!" 
+  ' rick-menu ;
+
+dbg" files"
+s" swine.com" 
+s" Swine Meeper - A fun freeware puzzler. Find all the truffles!"
+defembed swine.com
+
+s" dirtrect.com"
+s" A simple textmode graphics demo advertising the game development collective\called Dirty Rectangles."
+defembed dirtrect.com
+
+s" assemble.com"
+s" This claims to be some kind of combination Forth system / 8086 assembler??\I don't know Forth and I don't have any documentation for it, and it\doesn't use a standard assembly syntax, so your guess is as good as mine."
+defembed assemble.com
+
+(
+s" kpshrink4.kps"
+s" KP Shrinker 4.0 - Compressor and decompressor for KPS files\Requires an earlier version of PK Shrinker to extract."
+59943 deffake kpshrink4.kps
+
+s" mazecr3d.kps"
+s" Maze Crazy 3D - Explore a fascinating maze filled with twists and turns\in 3 incredible dimensions! Includes instructions for building a PC adapter\for the Virtua Glove."
+48371 deffake mazecr3d.kps
+)
+
+: rick-filelist ((
+    swine.com yield 
+    dirtrect.com yield
+    assemble.com yield
+  )) ;
+
+: list-files 1 each 
+    blue bg! yellow fg! x" [" dup .digit x" ]"
+    lcyan fg! black bg! sp emit i filename xmit 
+    cyan fg! x"  (" i filesize n>st xmit l"  bytes)"
+    lgray fg! nl i filedesc xmit-desc nl
+  nl 1+ next drop ;
+
+: select-file
+  black bg! white fg!
+  x" Type the number of a file, or Q to return to the menu: " inputch
+  dup [ key q lit ] = if drop ' rick-menu return then
+  [ key 1 lit ] - dup 0 >= over rick-filelist count < and if
+    rick-filelist nth
+    lblue fg! x" Downloading " dup filename xmit l" ..."
+    download-file l" Done!" else
+  drop lred fg! l" Sorry, that is not a valid selection." then 
+  ' select-file ;
+
+: rick-files nl rick-filelist list-files ' select-file ;
+
+dbg" menu"
+
+:noname ( -- cp )
+  nl rick-menu-rle xmit-screen nl
+  0 begin
+    yellow fg! black bg!
+    nl x" Your selection: " inputch
+    dup [ key m lit ] = if 
+      lred fg! l" Sorry, message boards are not available to guests." then
+    dup [ key g lit ] = if
+      lred fg! l" Sorry, games are not available to guests." then
+    dup [ key p lit ] = if swap drop ' page-rick swap then
+    dup [ key f lit ] = if swap drop ' rick-files swap then
+        [ key h lit ] = if
+      lcyan fg! l" Thank you for calling!" 300 delay return then
+  dup until ; ' rick-menu redefine
+
+: rick
+  black bg! white fg!
+  sp [ pagew 3 * lit ] repeated xmit-iter 
+  rick-welcome-rle xmit-screen login 
+  ' rick-menu begin execute dup not until ;
+

rickclub.bin

@@ -1 +1 @@
-   ÛÛÛÛÛÛ»  ÛÛ»  ÛÛÛÛÛÛ» ÛÛ»  ÛÛ» ÜÛ» ÛÛÛÛÛÛÛ»                                     ÛÛÉÍÍÛÛ» ÛÛº ÛÛÉÍÍÍͼ ÛÛº ÛÛɼ ßͼ ÛÛÉÍÍÍͼ       ÿ                             ÛÛÛÛÛÛɼ ÛÛº ÛÛº      ÛÛÛÛÛɼ      ÛÛÛÛÛÛÛ»        (273) 555-1212               ÛÛÉÍÍÛÛ» ÛÛº ÛÛº      ÛÛÉÍÛÛ»      ÈÍÍÍÍÛÛº                                     ÛÛº  ÛÛº ÛÛº ÈÛÛÛÛÛÛ» ÛÛº  ÛÛ»     ÛÛÛÛÛÛÛº                                     Èͼ  Èͼ Èͼ  ÈÍÍÍÍͼ Èͼ  Èͼ     ÈÍÍÍÍÍͼ                                     ÜÜÜÜÜÜÜ ÜÜÜ     ÜÜÜ ÜÜÜ ÜÜÜÜÜÜ  ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜ  	       ÛÿÜÜÜÜÛ ÛÿÛ     ÛÿÛ ÛÿÛ ÛÿÜÜÿÛÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÜÜÛ ÛÿÜÜÜÜÛ         ÛÿÛÜÜÜÜ ÛÿÛÜÜÜÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÜÜÜÿÛ ÛÿÛÜÛÿÛ ÛÿÛÜÛÿÛ ÛÜÜÜÜÿÛ ÛÿÜÜÜÛÜ         ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÛ ÛÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ                                                                                             SYSOP:ÿRick Toews                              ßÛßßÜ  ßÛßßÜ   ÜßßßÜ            ÚOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄO¿O               Û   Û  Û   Û Û                 ³O O OYOoOuOrO OfOrOiOeOnOdOlOyO OlOoOcOaOlO OcOoOmOpOuOtOeOrO O O³O              ßÛßßßÛ ßÛßßßÛ  ßßÜÜ             ³O O O O O O O O O O O OhOaOnOgOoOuOtO!O O O O O O O O O O O O O O³O               Û   Û  Û   Û      Û            ÀOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÙO              ß ßßß  ß ßßß  ßÜÜÜÜß                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      
+   ÛÛÛÛÛÛ»  ÛÛ»  ÛÛÛÛÛÛ» ÛÛ»  ÛÛ» ÜÛ» ÛÛÛÛÛÛÛ»                                     ÛÛÉÍÍÛÛ» ÛÛº ÛÛÉÍÍÍͼ ÛÛº ÛÛɼ ßͼ ÛÛÉÍÍÍͼ       ÿ                             ÛÛÛÛÛÛɼ ÛÛº ÛÛº      ÛÛÛÛÛɼ      ÛÛÛÛÛÛÛ»        (273) 555-1212               ÛÛÉÍÍÛÛ» ÛÛº ÛÛº      ÛÛÉÍÛÛ»      ÈÍÍÍÍÛÛº                                     ÛÛº  ÛÛº ÛÛº ÈÛÛÛÛÛÛ» ÛÛº  ÛÛ»     ÛÛÛÛÛÛÛº                                     Èͼ  Èͼ Èͼ  ÈÍÍÍÍͼ Èͼ  Èͼ     ÈÍÍÍÍÍͼ                                     ÜÜÜÜÜÜÜ ÜÜÜ     ÜÜÜ ÜÜÜ ÜÜÜÜÜÜ  ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜ  	       ÛÿÜÜÜÜÛ ÛÿÛ     ÛÿÛ ÛÿÛ ÛÿÜÜÿÛÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÜÜÛ ÛÿÜÜÜÜÛ         ÛÿÛÜÜÜÜ ÛÿÛÜÜÜÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÜÜÜÿÛ ÛÿÛÜÛÿÛ ÛÿÛÜÛÿÛ ÛÜÜÜÜÿÛ ÛÿÜÜÜÛÜ         ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÛ ÛÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ                                                                                             SYSOP:ÿRick Fehr                               ßÛßßÜ  ßÛßßÜ   ÜßßßÜ            ÚOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄO¿O               Û   Û  Û   Û Û                 ³O O OYOoOuOrO OfOrOiOeOnOdOlOyO OlOoOcOaOlO OcOoOmOpOuOtOeOrO O O³O              ßÛßßßÛ ßÛßßßÛ  ßßÜÜ             ³O O O O O O O O O O O OhOaOnOgOoOuOtO!O O O O O O O O O O O O O O³O               Û   Û  Û   Û      Û            ÀOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÄOÙO              ß ßßß  ß ßßß  ßÜÜÜÜß                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                      

rickmenu.bin

@@ -0,0 +1 @@
+                        ÕÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͸                             ÕÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ;  ððð M A I N   M E N U ððð  ÔÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ͸         ³                                                                     ³         ³  M)essage Boards            Door G)ames          F)ile Area         ³         ³  P)age Sysop                                     H)ang Up           ³         ³                                                                     ³         ÔÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     

swine.jrt

@@ -59,8 +59,6 @@ array board maxw maxh * allot
 : revealed? ( p -- f )   b@ FREVEALED & ;
 : squarecount ( p -- c ) b@ NEIGHBOUR-MASK & ;
 
-:yield yield2 >i >i :| idrop idrop ' noop _resume |; _suspend ;
-
 : 8-neighbours ( x y -- ) >arg >arg (( 
   over 1- over 1- yield2
   over 1- over    yield2
@@ -391,11 +389,22 @@ array title-text t", SWINE MEEPER"
   blue bg! yellow fg! clear
   17 3 textxy! title-text draw-spaced-text ;
 
-4 ' draw-title defmenu title-menu
+import embed.jrt
+array instructiontext { s" swine.txt" embed }
+
+: instructions
+  lgray bg! blue fg! clear
+  2 1 textxy!
+  instructiontext dup embed-data swap @ for each
+    i b@ dup 32 >= if draw-char else 10 = if 2 texty 1+ textxy! then then
+  next wait-key drop ;
+
+5 ' draw-title defmenu title-menu
 ' start           s" Start Game"   0 defitem
-' difficulty-menu s" Difficulty" 1 defitem
+' instructions    s" Instructions" 1 defitem
-' theme-menu      s" Themes"     2 defitem
+' difficulty-menu s" Difficulty"   2 defitem
-' leave           s" Quit"       3 defitem
+' theme-menu      s" Themes"       3 defitem
+' leave           s" Quit"         4 defitem
 
 ' main :chain textmode reseed! hidecursor title-menu textmode ;
 

swine.txt

@@ -1,18 +1,15 @@
-                  S * W * I * N * E   M * E * E * P * E * R
-
 Waddles, your trusty pig, is ready to go on the hunt for truffles! Leash him
 up and make your way through the grove. But be warned! Digging too close can
 cause damage to the truffles' mycelia, which can take years to recover from!
 
-HOW TO PLAY:
+HOW TO PLAY: Select a square with the arrow keys, and press the space bar or 
-Select a square with the arrow keys, and press the space bar or enter to dig. 
+enter to dig. Waddles will tell you how many truffles are nearby by marking 
-Waddles will tell you how many truffles are nearby by marking the square with
+the square with a number. This is the number of neighbouring squares 
-a number. This is the number of neighbouring squares (including diagonals)
+(including diagonals) that have truffles.
-that have truffles.
 
-If you select a square with no truffles nearby, the neighbouring squares will
+If you select a square with no truffles nearby, the neighbouring squares 
-automatically be cleared out. If you select a square with a truffle, it's
+will automatically be cleared out. If you select a square with a truffle, 
-game over!
+it's game over!
 
 You can use the "F" key to flag and unflag a square as containing a truffle
 without digging there. If you select a square that has already been dug up,

text.jrt

@@ -6,7 +6,8 @@
 0 var, textpageid
 0 var, textpage
 
-: page! dup textpageid ! 12 << textpage ! ;
+: id>page 12 << ;
+: page! dup textpageid ! id>page textpage ! ;
 
 :asm showpage
   POP AX
@@ -172,3 +173,40 @@ var boxstyle
   swap 2 - over boxmiddle
   boxbottom ;
 
+:asm segwordmove ( dst src count seg  -- )
+  MOV BX DS
+  MOV AX SI
+  POP ES
+  MOV DX ES
+  MOV DS DX
+  POP CX
+  POP SI
+  POP DI
+  CMP DI SI
+  JL 0 @> ( if dst < src, then copy from the top )
+  STD
+  SHL CX 1 #
+  ADD DI CX
+  ADD SI CX
+  SHR CX 1 #
+  CMPSW ( decrement back to the beginning of the copy )
+0 <:
+  REPZ MOVSW
+  CLD
+  MOV SI AX
+  MOV DS BX
+  NEXT
+
+32 const sp
+
+: scrollup ( y ybottom -- )
+  >r r@ over - pagew * swap 
+  pagew 2* * textpage @ + 
+  dup pagew 2* + <rot SCREENSEG segwordmove 
+  textpos @ 0 <r textxy! pagew sp draw-hrepeat textpos ! ;
+
+: pagecopy ( dstpage srcpage -- )
+  id>page swap id>page swap [ pagew pageh * lit ] SCREENSEG segwordmove ;
+
+: textstate textpen @ textpos @ boxstyle @ ;
+: textstate! boxstyle ! textpos ! textpen ! ;

timer.jrt

@@ -60,7 +60,7 @@ var timer
 ( the timer is set to run at just under 150hz, so a "csec" is closer to 7.5ms
   than 10ms. )
 : over-csec ( csec -- ) 
-  timer @ + >arg (( begin yield0 dup timer @ <= until drop )) ;
+  timer @ + >arg (( begin dup timer @ > while yield0 repeat drop )) ;
 : sleep-csec ( cs -- ) over-csec each suspend next ;
 
 ' init :chain [ 0xffff 3 >> lit ] set-timer-div timer-isr install-isr ;

tinyjort.jrt

@@ -489,6 +489,8 @@ dbg" flow control words and misc."
 :t :init initscripts @ here initscripts ! , ] ;
 : :INIT [ t& initscripts lit ] dup @t swap target swap !t w>t ] compt ;
 
+:INIT 0 inptr @ b! ; ( ensure input buffer starts empty )
+
 :t doinit initscripts @ 
    [ target ] dup BZ_ [ patchpt ] dup cell + >r @ GOTO_ [ swap w>t ]
    [ patch!t ] drop ;
@@ -505,9 +507,10 @@ dbg" boot"
   POP AX
   ADD AX 4096 #
   MOV SS AX
-  MOV t& lastseg @+ AX
   MOV SP 0x100 #
+  MOV t& lastseg @+ AX
   MOV BP 0x00 #
+  CLD
   NEXT
 
 target t& &here !t

zipoff.jrt

@@ -39,6 +39,7 @@ array $DOFAR
 asm-com
 
 : tdict-lookup word tdict dict-lookup ;
+: T] tdict-lookup not if err return then state if , then ; immediate
 : te tdict-lookup interpretword ; immediate
 : tlookup ( -- tcp ) tdict-lookup not if dup err then cell + @ ;
 : t' tlookup interpretnumber ; immediate
@@ -98,9 +99,11 @@ s" coredefs.jrt" loadfile
 :timm until t, BZ_ w>t ;
 
 : t", begin key dup [ key " lit ] != while >t repeat drop 0 >t ;
-:timm s" state if t, INLINEDATA_ patchpt t", patch!t else target t", then ;
+: t" t, INLINEDATA_ patchpt t", patch!t ;
+:timm s" state if t" else target t", then ;
 
-: startcolon t& $DOCOLON w>t ] ;
+: gencolon t& $DOCOLON w>t ;
+: startcolon gencolon ] ;
 : t:| t, INLINEDATA_ patchpt startcolon ;
 : t|; t, return patch!t ;
 :timm :| t:| ;
@@ -126,7 +129,8 @@ s" coredefs.jrt" loadfile
 
 dbg" CREATE"
 : CREATE DEF t& $DOCREATE w>t 0 w>t ;
-: FINISHCREATE ' latest ' tdict with-dict codepointer cell + @ cell + !t ;
+: entry>tcp codepointer cell + @ ;
+: FINISHCREATE ' latest ' tdict with-dict entry>tcp cell + !t ;
 : DOES} target lit ' FINISHCREATE , ' return , } ; immediate
 
 ( s" blah.jrt" loadfile doesn't work in target mode because s" writes
@@ -143,20 +147,21 @@ dbg" CREATE"
 
 var comfilename
 
-: readcom ( filename ) open 0x100 target! 
+: readcom ( filename ) open >r 
-  begin dup fgetc dup EOF != while >t repeat drop close ;
+  0x100 0xffff over r@ comseg farfread 
+  fcount @ + target! <r close ;
 
 DEFERRED init noop
 DEFERRED main noop
 DEFERRED cleanup noop
 
-tdict-lookup cleanup drop ' cleanup redefine
+T] cleanup ' cleanup redefine
 
 :init 
   ( we write a fake all-null PSP so openself can fail gracefully )
   0 target! 0xff ALLOT 
   comfilename @ readcom } 
-  [ tdict-lookup init drop , ] ;
+  T] init ;
 
 : writeenv ( comfile wrapper -- ) 
   swap comfilename !
@@ -165,7 +170,7 @@ tdict-lookup cleanup drop ' cleanup redefine
 
 dbg" boot"
 
-} : start init main cleanup terminate ; {
+} : exit cleanup terminate ; : start init main exit ; {
 
 9 <: ( actual entry point )
   MOV SI t& start #
@@ -177,9 +182,11 @@ dbg" boot"
   MOV BP 0x00 #
   NEXT
 
+here s", zipstub.min" s" zipmin.com" writeenv
+
 } import common.jrt {
 
-tdict-lookup init drop execute
+T] init execute
 
 here s", zipstub.seg" s" zipoff.com" writeenv