I wanted to do something in PETTIL, I can't remember precisely what it was. It might have been putting
LEAVE inside of an
IF/
THEN block? The compiler, which I plagiarized from Blazin' Forth wouldn't let me, it would only complain of unbalanced control word pairs. So I rewrote all of the control word logic from the ground up, using Garth's excellent approach of
DO pushing the exit address to the return stack before putting the loop limit and loop index there. I trimmed about 50 bytes from the compiler in doing so, mostly by factoring the heck out of it. In my actual code, only
+/-PAIRS word is implemented as a primitive, rendered here in untested Forth. The rest are actual working code.
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:
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
Login
Register
FAQ
Search
