The word PAGEMARGIN encloses a call to PAGE in the dictionary when only a few bytes are left at the end of a page. C->S sign-extends a char to a 16-bit single. ?COMP aborts unless STATE is compiling.
Instead of putting the "word family" on the stack I used three counters that are initialized to 0 by ':' and tested for zero-ness by ';' The opener (e.g. IF) adds one to the counter. Middle words like ELSE or WHILE first decrement and then increment the counter, leaving it in the same state it started in but aborting if the counter goes negative (meaning there was no open conditional phrase in that family). The closers (e.g. THEN) decrement the counter.
METHOD is sort of a lite-objects thing I came up with. Put fields at the beginning of a child word and code immediately following, and the defining word retrives the fields to the stack, does what a Constructor would do in Java, then uses METHOD to transfer control to the child. I suppose it would even be possible to use a field to select from a few different code paths, so a child definition could have different behaviors (like QUAN words in MMSforth). For now it's just enough code to get the job done without working out yet another objects-in-Forth scheme.
?>MARK ?>RESOLVE are used to create and later resolve a forward branch.
?<RESOLVE creates and simultaneously resolves a backward branch.
Code: Select all
create pairs 3 allot
: 0pairs ( -- ) pairs 3erase ;
: ?nopairs ( -- ) pairs 3c@ or [ 6 ] ?error ;
: +/-pairs ( family -- |family| ) dup 0<
if negate pairs + dup -2 +! then
pairs + dup 1 +!
c@ c->s 0< [ 6 ] ?error ;
plusminuspairs
stx z ; stash the data stack pointer
ldx tos
bpl pluspairs
dex
txa
eor #$ff ; negate
sta tos ; return the absolute value
tax
dec pairs-1,x
dec pairs-1,x
pluspairs
inc pairs-1,x
bmi pairs03
ldx z
jmp next
pairs03
ldy #6 ; UNPAIRED CONDITIONALS
comperror
jmp error
: method ( addr -- ) rdrop 2- >r ;
: control ( cfa family == ) ( -- cfa |family| )
<builds
, c,
does>
?comp @+ swap c@+ +/-pairs swap method ; immediate
: control, ( cfa -- ) [ $fc ] pagemargin , ;
: ?>mark ( cfa family -- addr ) drop control, here 0 c, ;
: ?>resolve ( addr -- ) here 1+ over - swap c! ;
: ?<resolve ( addr cfa family -- ) drop control, dup>r here 2- c, r> ;
' (do) 3 control do ] ?>mark ; immediate
which makes this:
(C:$008a) m ._do
>C:7428 20 d6 73 56 09 03 f1 73 ec 08
jsr docontrol ; the "does>" part of CONTROL
.word pdo ; (do)
.byt 3 ; 3 = do-loop family
.word _qtomark ; ?>mark
.word exit ; semicolon compiles this
' (?do) 3 control ?do ] ?>mark ; immediate
' (loop) -3 control loop ] ?<resolve ?>resolve ; immediate
' (+loop) -3 control +loop ] ?<resolve ?>resolve ; immediate
' unloop -3 control leave ] +/-pairs drop xt, ; immediate
' (?leave) -3 control ?leave ] +/-pairs drop xt, ; immediate
' ?branch 2 control if ] ?>mark ; immediate
' branch -2 control else ] +/-pairs ?>mark swap ?>resolve ; immediate
0 -2 control then ] 2drop ?>resolve ; immediate
0 1 control begin ] 2drop here 1- ; immediate
' ?branch -1 control while ] +/-pairs ?>mark ; immediate
' ?branch -1 control until ] q<resolve drop ; immediate
' branch -1 control again ] ?<resolve drop ; immediate
' ?branch 2 control repeat ] 2>r swap 2r> ?<resolve drop ?>resolve ; immediate