Compare commits

...

10 commits

28 changed files with 634 additions and 136 deletions

View file

@ -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! ;

Binary file not shown.

View file

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

View file

@ -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! ;

Binary file not shown.

View file

@ -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 )
: fixcursor texty 8 << textx | movecursor ;
dbg" statusbar"
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 ;
: call ( st -- ) s" ATDT" xmit dup xmit nl noisy offhook dialtone dialst ;
: xmit-iter each i emit 3 ms next ;
: 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
i 8 >> textpen ! i emit
next ;
: embed-write ( fp p -- ) dup embed-size swap embed-data <rot fwrite ;
: rand-write ( fp size -- ) dup prngstate ! ( write the same file every time )
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
15 textx! s" days of your limited trial!" xmit nl nl 200 sleep-csec
blue bg! lcyan fg! s" - you have used 13246 / 30" xmit-line
15 textx! s" days of your limited trial!" xmit-line nl nl nl 200 delay
lgray fg! ;
: go splash 0 15 textxy!
s" 5551212" connect s" CONNECT 57600" xmit nl rick-welcome ;
: go init-statusbar splash
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 }

BIN
dialtest.com Executable file

Binary file not shown.

Binary file not shown.

View file

@ -32,15 +32,17 @@ 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 ;
: embed-file ( fp -- )
>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 )

View file

@ -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 )

274
iter.jrt
View file

@ -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
we call the "next" stack.
state, which we call the "next" stack. Typically the top of the next
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: )
( -- more nextcount )
( It must take care of updating the i-stack directly. if there are
no more values, it must remove the values from the i-stack and return
0 in the "more" place.
:asm n-<next ( n |n| args... -- args... |n| )
MOV AX SS
MOV ES AX
POP CX
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
stack by this word. For simple iterators this will be 1, for the space
the iterator word takes. If "more" is 0, this number of items will be
dropped. This is always returned even if there are more items to iterate
over, in order to support efficient cancellation. ">cancel" will push a word
onto the next-stack that will query the iterator below it to determine how
many items need to be dropped. It will drop one item from the i-stack if the
iterator indicates that there are more items.
:asm n->next ( args... n |n| -- |n| args... )
MOV AX SS
MOV ES AX
POP CX
JCXZ 1 @>
MOV DI @[ SS: nexttop @]
STD ( next-stack grows down )
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
of a cancellation, such as dropping multiple items off the i-stack, or
aborting a task, it should check the "cancelled" flag to determine whether
to perform it. An iterator that returns 0 0 will not cause any further
changes to occur to the iteration stacks, which allows it to be in complete
control of this scenario if needed.
( iterators are pointers to an array containing two function pointers:
xt-iter xt-cancel
The xt-iter word must take care of updating the stacks directly. If
there are no more values, it must remove the values from the i-stack,
drop itself from the next-stack, and return 0. "finished" and "finish?"
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
more convenient to specify the count last when writing iterators, but it's
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 iteration if cell + else @ then >r ;
: iterate 0 nextpeek @ execute ;
: cancel 0 nextpeek cell + @ execute ;
: finished ( -- 0 ) cancel 0 ;
: finish? ( f -- f ) if 1 else finished then ;
: 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 ;
: single >i :| nextdrop :| idrop 0 1 |; >next 1 1 |; >next ;
: 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 ;
defiter nothing
' nextdrop cancel!
:asm tail ( TODO: support CREATE words )
LODSW
MOV BX AX
INC BX INC BX
MOV SI BX
defiter >single-done
:iter single >i ;
:next nextdrop 1 >single-done ;
: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 -- )
begin dup while swap >next 1- repeat drop ;
: gen-save ( 0 0 extra-args... extra-arg-count -- 1 cnext )
>r r@ gen-save-args <r 2 + >rot drop drop 1 swap ;
: gen-restore ( arg-count -- args... )
begin dup while <next swap 1- repeat drop ;
:asm 2r>next
MOV BX @[ SS: nexttop @]
( bp grows up. top: BP-2, second: BP-4
nexttop grows down. top: nexttop, second: nexttop+2 )
SUB BX 4 # ( make room for 2 more items on next stack )
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 ;
: _resume ( cpcancel -- c f args... )
nextdrop 0 0 <rot
cancelled @ if <next ub@ n-nextdrop execute rdrop return then
drop <next dup 1+ >r rswap ub@ gen-restore ;
: _suspend ( cpresume -- )
rswap r@ ub@ swap >r gen-save <r <r >next >next ;
:asm _resume>args ( |n| yieldpoint xt-next -- argcount |n| |r| resumepoint )
MOV BX @[ SS: nexttop @]
MOV DI @[ SS: 2 @+ BX]
ADD BX 4 #
MOV @[ SS: nexttop @] BX
XOR AH AH
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
does> @ w>t gen-arg-count @ >t ; }
: colonpair ( xt-first xt-second -- xt )
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 ;
:yield yield >i :| ' idrop _resume idrop |; _suspend ;
:yield yield> >i :| ' idrop _resume <i |; _suspend ;
:yield map <i >next >i :| :| idrop <next >i cancel |;
_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 ;
: shadow-i <i >next >i ; : 2>i >i >i ; : 2idrop idrop idrop ;
: unmap idrop <next >i ; : mapcancel unmap cancel ;
: unsuspend rdrop rdrop <r 1+ >r ; ( don't yield at all, skip past the yielder )
: suspend? not if unsuspend 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 ;

BIN
jort.com

Binary file not shown.

View file

@ -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 | ;

100
rick.jrt Executable file
View file

@ -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 ;

View file

@ -1 +1 @@
ÛÛÛÛÛÛ»  ÛÛ»  ÛÛÛÛÛÛ» ÛÛ»  ÛÛ» ÜÛ» ÛÛÛÛÛÛÛ»          ÛÛÉÍÍÛÛ» ÛÛº ÛÛÉÍÍÍͼ ÛÛº ÛÛɼ ßͼ ÛÛÉÍÍÍͼ     ÿ ÛÛÛÛÛÛɼ ÛÛº ÛÛº      ÛÛÛÛÛɼ      ÛÛÛÛÛÛÛ»        ( 2 7 3 ) 5 5 5 - 1 2 1 2 ÛÛÉÍÍÛÛ» ÛÛº ÛÛº      ÛÛÉÍÛÛ»      ÈÍÍÍÍÛÛº        ÛÛº  ÛÛº ÛÛº ÈÛÛÛÛÛÛ» ÛÛº  ÛÛ»     ÛÛÛÛÛÛÛº        Èͼ  Èͼ Èͼ  ÈÍÍÍÍͼ Èͼ  Èͼ     ÈÍÍÍÍÍͼ        ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜ     ÛÿÜÜÜÜÛ ÛÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÿÛÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÜÜÛ ÛÿÜÜÜÜÛ ÛÿÛÜÜÜÜ ÛÿÛÜÜÜÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÜÜÜÿÛ ÛÿÛÜÛÿÛ ÛÿÛÜÛÿÛ ÛÜÜÜÜÿÛ ÛÿÜÜÜÛÜ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÛ ÛÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ 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 ß ßßß ß ßßß ßÜÜÜÜß
ÛÛÛÛÛÛ»  ÛÛ»  ÛÛÛÛÛÛ» ÛÛ»  ÛÛ» ÜÛ» ÛÛÛÛÛÛÛ»          ÛÛÉÍÍÛÛ» ÛÛº ÛÛÉÍÍÍͼ ÛÛº ÛÛɼ ßͼ ÛÛÉÍÍÍͼ     ÿ ÛÛÛÛÛÛɼ ÛÛº ÛÛº      ÛÛÛÛÛɼ      ÛÛÛÛÛÛÛ»        ( 2 7 3 ) 5 5 5 - 1 2 1 2 ÛÛÉÍÍÛÛ» ÛÛº ÛÛº      ÛÛÉÍÛÛ»      ÈÍÍÍÍÛÛº        ÛÛº  ÛÛº ÛÛº ÈÛÛÛÛÛÛ» ÛÛº  ÛÛ»     ÛÛÛÛÛÛÛº        Èͼ  Èͼ Èͼ  ÈÍÍÍÍͼ Èͼ  Èͼ     ÈÍÍÍÍÍͼ        ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜ ÜÜÜ ÜÜÜÜÜÜÜ ÜÜÜÜÜÜÜ     ÛÿÜÜÜÜÛ ÛÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÿÛÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÛ ÛÿÛ ÛÿÜÜÜÜÛ ÛÿÜÜÜÜÛ ÛÿÛÜÜÜÜ ÛÿÛÜÜÜÜ ÛÿÛÜÛÿÛ ÛÿÜÜÜÿÛ ÛÿÜÜÜÿÛ ÛÿÛÜÛÿÛ ÛÿÛÜÛÿÛ ÛÜÜÜÜÿÛ ÛÿÜÜÜÛÜ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÛ ÛÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ ÛÜÜÜÜÜÛ 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 ß ßßß ß ßßß ßÜÜÜÜß

1
rickmenu.bin Executable file
View file

@ -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           ³         ³                                                                     ³         ÔÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     

BIN
swine.com

Binary file not shown.

View file

@ -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
' theme-menu s" Themes" 2 defitem
' leave s" Quit" 3 defitem
' instructions s" Instructions" 1 defitem
' difficulty-menu s" Difficulty" 2 defitem
' theme-menu s" Themes" 3 defitem
' leave s" Quit" 4 defitem
' main :chain textmode reseed! hidecursor title-menu textmode ;

View file

@ -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:
Select a square with the arrow keys, and press the space bar or enter to dig.
Waddles will tell you how many truffles are nearby by marking the square with
a number. This is the number of neighbouring squares (including diagonals)
that have truffles.
HOW TO PLAY: Select a square with the arrow keys, and press the space bar or
enter to dig. Waddles will tell you how many truffles are nearby by marking
the square with a number. This is the number of neighbouring squares
(including diagonals) that have truffles.
If you select a square with no truffles nearby, the neighbouring squares will
automatically be cleared out. If you select a square with a truffle, it's
game over!
If you select a square with no truffles nearby, the neighbouring squares
will automatically be cleared out. If you select a square with a truffle,
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,

View file

@ -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 ! ;

View file

@ -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 ;

Binary file not shown.

View file

@ -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

BIN
zipmin.com Executable file

Binary file not shown.

Binary file not shown.

View file

@ -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!
begin dup fgetc dup EOF != while >t repeat drop close ;
: readcom ( filename ) open >r
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

BIN
zipstub.min Executable file

Binary file not shown.

Binary file not shown.