Here is the new source for STC Fleet Forth's DO LOOP words with leepivonka's idea for an inline JMP at the end of (LOOP) and (+LOOP) .
Code: Select all
SUBR S.(+LOOP)
0 ,X LDA 1 ,X LDY INX INX
XSAVE STX TSX CLC
$103 ,X ADC $103 ,X STA TYA
LABEL (LOOP).BRANCH
$104 ,X ADC $104 ,X STA
VS IF
INX INX INX INX INX INX
TXS XSAVE LDX
PHP RTI
THEN
XSAVE LDX
RTS
END-CODE
SUBR S.(LOOP)
XSAVE STX TSX
0 # LDA SEC
$103 ,X INC
(LOOP).BRANCH 0= BRAN
XSAVE LDX
RTS END-CODE
SUBR S.UNLOOP
PLA TAY PLA N STA
PLA PLA PLA PLA
PLA PLA
N LDA PHA TYA PHA
RTS
END-CODE
SUBR S.(DO)
PLA N STA PLA N 1+ STA
2 # LDY
N )Y LDA PHA DEY
N )Y LDA PHA CLC
3 ,X LDA $80 # ADC PHA
3 ,X STA 2 ,X LDA PHA SEC
0 ,X LDA 2 ,X SBC TAY
1 ,X LDA 3 ,X SBC PHA
TYA PHA
INX INX INX INX
CLC
N LDA 3 # ADC N STA
0= IF N 1+ INC THEN
N ) JMP END-CODE
SUBR S.(?DO)
0 ,X LDA 2 ,X CMP
S.(DO) 0= NOT BRAN
1 ,X LDA 3 ,X CMP
S.(DO) 0= NOT BRAN
INX INX INX INX
PLA N STA PLA N 1+ STA
2 # LDY CLC
N )Y LDA PHA DEY
N )Y LDA PHA
PHP RTI
END-CODE
I've also fixed a bug. The previous version of S.(?DO) did not drop the loop parameters from the data stack if the loop is skipped.
Here is what was assembled.
Code: Select all
S.(+LOOP) DIS
31225 0 ,X LDA
31227 1 ,X LDY
31229 INX
31230 INX
31231 141 STX XSAVE
31233 TSX
31234 CLC
31235 259 ,X ADC
31238 259 ,X STA
31241 TYA
31242 260 ,X ADC
31245 260 ,X STA
31248 31261 BVC
31250 INX
31251 INX
31252 INX
31253 INX
31254 INX
31255 INX
31256 TXS
31257 141 LDX XSAVE
31259 PHP
31260 RTI
31261 141 LDX XSAVE
31263 RTS
39
OK
S.(LOOP) DIS
31279 141 STX XSAVE
31281 TSX
31282 0 # LDA
31284 SEC
31285 259 ,X INC
31288 31242 ^^ BEQ ' S.(+LOOP) >BODY 17 +
31290 141 LDX XSAVE
31292 RTS
14
OK
S.UNLOOP DIS
31308 PLA
31309 TAY
31310 PLA
31311 133 STA N
31313 PLA
31314 PLA
31315 PLA
31316 PLA
31317 PLA
31318 PLA
31319 133 LDA N
31321 PHA
31322 TYA
31323 PHA
31324 RTS
17
OK
S.(DO) DIS
31338 PLA
31339 133 STA N
31341 PLA
31342 134 STA N 1+
31344 2 # LDY
31346 133 )Y LDA N
31348 PHA
31349 DEY
31350 133 )Y LDA N
31352 PHA
31353 CLC
31354 3 ,X LDA
31356 128 # ADC
31358 PHA
31359 3 ,X STA
31361 2 ,X LDA
31363 PHA
31364 SEC
31365 0 ,X LDA
31367 2 ,X SBC
31369 TAY
31370 1 ,X LDA
31372 3 ,X SBC
31374 PHA
31375 TYA
31376 PHA
31377 INX
31378 INX
31379 INX
31380 INX
31381 CLC
31382 133 LDA N
31384 3 # ADC
31386 133 STA N
31388 31392 BNE
31390 134 INC N 1+
31392 133 ) JMP N
57
OK
S.(?DO) DIS
31409 0 ,X LDA
31411 2 ,X CMP
31413 31338 ^^ BNE ' S.(DO) >BODY
31415 1 ,X LDA
31417 3 ,X CMP
31419 31338 ^^ BNE ' S.(DO) >BODY
31421 INX
31422 INX
31423 INX
31424 INX
31425 PLA
31426 133 STA N
31428 PLA
31429 134 STA N 1+
31431 2 # LDY
31433 CLC
31434 133 )Y LDA N
31436 PHA
31437 DEY
31438 133 )Y LDA N
31440 PHA
31441 PHP
31442 RTI
34
OK
S.I DIS
31453 141 STX XSAVE
31455 TSX
31456 CLC
31457 259 ,X LDA
31460 261 ,X ADC
31463 TAY
31464 260 ,X LDA
31467 262 ,X ADC
31470 141 LDX XSAVE
31472 DEX
31473 DEX
31474 0 ,X STY
31476 1 ,X STA
31478 RTS
26
OK
S.J DIS
31490 141 STX XSAVE
31492 TSX
31493 INX
31494 INX
31495 INX
31496 INX
31497 INX
31498 INX
31499 31456 JMP ' S.I >BODY 3 +
12
OK
S.LEAVE DIS
31516 PLA
31517 PLA
31518 PLA
31519 PLA
31520 PLA
31521 PLA
31522 PHP
31523 RTI
8
OK
S.?LEAVE DIS
31539 INX
31540 INX
31541 254 ,X LDA W
31543 255 ,X ORA W 1+
31545 31516 ^^ BNE ' S.LEAVE >BODY
31547 RTS
9
OK
I have not incorporated the idea to place the unlooping code inline because this either requires:
a branch address to be compiled inline with LEAVE (or whatever LEAVE compiles)
or the exit point for the loop would be different for (LOOP) , LEAVE and (?DO) when the parameters are the same.
Consider the following loop in TYPE from the ITC Fleet Forth:
Code: Select all
: ID. ( NFA -- )
1+
BEGIN
COUNT $7F 2DUP AND QEMIT >
UNTIL
[ HERE >A ]
DROP PAUSE ;
: TYPE ( ADR CNT -- )
0
?DO
COUNT EMIT
LOOP -;
A> HERE 2- @ 2- !
It compiles to this:
Code: Select all
SEE TYPE
TYPE
7227 3293 0
7229 2358 (?DO) 7212 ' ID. >BODY 19 +
7233 5331 COUNT
7235 2931 EMIT
7237 2149 (LOOP) 7233
14
OK
SEE ID.
ID.
7193 4793 1+
7195 5331 COUNT
7197 3308 CLIT 127
7200 5295 2DUP
7202 4507 AND
7204 3794 QEMIT
7206 4467 >
7208 2259 ?BRANCH 7195
7212 2478 DROP
7214 2897 PAUSE
7216 2469 EXIT
25
OK
Notice that there is nothing in the definition after LOOP's branch. All exits from this loop go through address 7212 compiled after (?DO) . If there were a LEAVE or ?LEAVE in this loop, it would branch to address 7212 because it would be the third loop parameter. (LOOP) and (+LOOP) also use the third loop parameter as a destination address. If the size of string to TYPE is zero, ?DO branches to this address. I would like the STC version of DO LOOP's to have the same behavior.
Another factor is that there can be multiple occurrences of LEAVE or ?LEAVE in a DO LOOP and they can be nested within other control structures such as a BEGIN loop or an IF statement. LEAVE is still supposed to be able to exit the loop even in these cases.
Scott Ballantyne's Blazin' Forth had DO LOOP's which only had two parameters. It had non standard versions of the mark and resolve words (which he gave slightly different names) and a word called ADD>MARK so every LEAVE and ?LEAVE in a DO LOOP would be chained together and resolved as the chain was unlinked by LOOP or +LOOP. Blazin' Forth used the same technique to handle multiple WHILE's in BEGIN loops.
Blazin' Forth's control flow code was not what I would call elegant by any stretch of the imagination and made adding new control flow structures more difficult than it should have been.
Here are some words to help with building the test cases. In the complete STC system they will be defined differently.
Code: Select all
: STC.COMPILE ( -- )
R> DUP 2+ >R $20 C, @ >BODY , ;
: STC.DO ( >SYSL <SYSL -- )
STC.COMPILE S.(DO) [ HERE >A ]
>MARK 2+ <MARK 2+ ; IMMEDIATE
: STC.?DO ( >SYSL <SYSL -- )
STC.COMPILE S.(?DO)
BRANCH [ A> , ] -; IMMEDIATE
: STC.LOOP ( -- >SYSL <SYSL )
STC.COMPILE S.(LOOP) [ HERE >A ]
$4C C,
2- <RESOLVE 2- >RESOLVE ; IMMEDIATE
: STC.+LOOP ( -- >SYSL <SYSL )
STC.COMPILE S.(+LOOP)
BRANCH [ A> , ] -; IMMEDIATE
The control flow data for compiling DO LOOP's in Fleet Forth.
Code: Select all
>SYSL = ADR 3
<SYSL = ADR 4
And some helper words I've already presented in a previous post.
Code: Select all
SUBR S.U. ( U -- )
>FORTH
CR U. ERR
>ASSEM
RTS
END-CODE
VARIABLE INTERVAL INTERVAL ON
SUBR S.INTERVAL
>FORTH
INTERVAL @
>ASSEM
RTS
END-CODE
Here are the test words.
Code: Select all
CODE DO.LOOP.TEST
STC.DO
S.I JSR
S.U. JSR
STC.LOOP
NEXT JMP END-CODE
CODE DO.+LOOP.TEST
STC.DO
S.I JSR
S.U. JSR
S.INTERVAL JSR
STC.+LOOP
NEXT JMP END-CODE
CODE LEAVE.TEST
STC.DO
S.I JSR
S.U. JSR
S.LEAVE JSR
STC.LOOP
NEXT JMP END-CODE
CODE ?LEAVE.TEST
STC.DO
S.I JSR
S.U. JSR
S.I JSR
S.?LEAVE JSR
STC.LOOP
NEXT JMP END-CODE
CODE ?DO.LEAVE.TEST
STC.?DO
S.I JSR
S.U. JSR
S.LEAVE JSR
STC.LOOP
NEXT JMP END-CODE
CODE ?DO.?LEAVE.TEST
STC.?DO
S.I JSR
S.U. JSR
S.I JSR
S.?LEAVE JSR
STC.LOOP
NEXT JMP END-CODE
Here is what gets compiled.
Code: Select all
SEE DO.LOOP.TEST
DO.LOOP.TEST
31780 31338 JSR ' S.(DO) >BODY
31783 124 ,X AND
31785 31453 JSR ' S.I >BODY
31788 31705 JSR ' S.U. >BODY
31791 31279 JSR ' S.(LOOP) >BODY
31794 31785 JMP
17
OK
31783 @ U. 31797 OK
EAD DIS
31797 2174 JMP NEXT
3
OK
SEE DO.+LOOP.TEST
DO.+LOOP.TEST
31820 31338 JSR ' S.(DO) >BODY
31823 RTS
4
OK
31823 @ U. 31840 OK
31825 DIS
31825 31453 JSR ' S.I >BODY
31828 31705 JSR ' S.U. >BODY
31831 31751 JSR ' S.INTERVAL >BODY
31834 31225 JSR ' S.(+LOOP) >BODY
31837 31825 JMP
15
OK
EAD DIS
31840 2174 JMP NEXT
3
OK
SEE LEAVE.TEST
LEAVE.TEST
31860 31338 JSR ' S.(DO) >BODY
31863 DEY
31864 FUTURE EXPANSION
4
OK
31863 @ U. 31880 OK
31865 DIS
31865 31453 JSR ' S.I >BODY
31868 31705 JSR ' S.U. >BODY
31871 31516 JSR ' S.LEAVE >BODY
31874 31279 JSR ' S.(LOOP) >BODY
31877 31865 JMP
15
OK
EAD DIS
31880 2174 JMP NEXT
3
OK
SEE ?LEAVE.TEST
?LEAVE.TEST
31901 31338 JSR ' S.(DO) >BODY
31904 124 ,X LDY
31906 31453 JSR ' S.I >BODY
31909 31705 JSR ' S.U. >BODY
31912 31453 JSR ' S.I >BODY
31915 31539 JSR ' S.?LEAVE >BODY
31918 31279 JSR ' S.(LOOP) >BODY
31921 31906 JMP
23
OK
31904 @ U. 31924 OK
EAD DIS
31924 2174 JMP NEXT
3
OK
SEE ?DO.LEAVE.TEST
?DO.LEAVE.TEST
31948 31409 JSR ' S.(?DO) >BODY
31951 124 # CPX
31953 31453 JSR ' S.I >BODY
31956 31705 JSR ' S.U. >BODY
31959 31516 JSR ' S.LEAVE >BODY
31962 31279 JSR ' S.(LOOP) >BODY
31965 31953 JMP
20
OK
31951 @ U. 31968 OK
EAD DIS
31968 2174 JMP NEXT
3
OK
SEE ?DO.?LEAVE.TEST
?DO.?LEAVE.TEST
31993 31409 JSR ' S.(?DO) >BODY
31996 32123 BPL
31998 31453 JSR ' S.I >BODY
32001 31705 JSR ' S.U. >BODY
32004 31453 JSR ' S.I >BODY
32007 31539 JSR ' S.?LEAVE >BODY
32010 31279 JSR ' S.(LOOP) >BODY
32013 31998 JMP
23
OK
31996 @ U. 32016 OK
EAD DIS
32016 2174 JMP NEXT
3
OK
Fleet Forth's SEE attempted to disassemble the inline addresses after S.(DO) and S.(?DO) .
The test results.
Code: Select all
5 0 DO.LOOP.TEST
0
1
2
3
4 OK
0 5 DO.+LOOP.TEST
5
4
3
2
1
0 OK
11111 INTERVAL ! OK
1 0 DO.+LOOP.TEST
0 OK
0 0 DO.+LOOP.TEST
0
11111
22222
33333
44444
55555 OK
-11111 INTERVAL ! OK
1 0 DO.+LOOP.TEST
0
54425
43314
32203
21092
9981 OK
0 0 DO.+LOOP.TEST
0 OK
-1 INTERVAL ! OK
0 0 DO.+LOOP.TEST
0 OK
5 0 LEAVE.TEST
0 OK
5 0 ?LEAVE.TEST
0
1 OK
5 0 DO.?LEAVE.TEST
5 0 DO.?LEAVE.TEST
^^^^^^^^^^^^^^
WHAT?
.S EMPTY OK
1 2 3 OK
.S 1 2 3 OK
5 0 ?DO.?LEAVE.TEST
0
1 OK
.S 1 2 3 OK
0 0 ?DO.?LEAVE.TEST OK
.S 1 2 3 OK
5 0 ?DO.LEAVE.TEST
0 OK
.S 1 2 3 OK
0 0 ?DO.LEAVE.TEST OK
.S 1 2 3 OK
SP! OK
0 0 ?DO.?LEAVE.TEST OK
.S EMPTY OK
0 0 ?DO.LEAVE.TEST OK
.S EMPTY OK