Design considerations for an STC Fleet Forth

[JimBoyd]

I've been thinking about implementing an STC version of Fleet Forth. Since I will be using a metacompiler to build the kernel, I wanted to be able to test words which will need to be modified.
Here is an idea for the DO LOOP words. They are not to be compiled inline as they will be subroutines.
To test these words, they were defined with Fleet Forth's Assembler's SUBR , which creates a word which returns its PFA (like a variable) and switches to assembling.

Code: Select all

SUBR S.(LOOP)
   PLA  N STA  PLA  N 1+ STA
   PLA  TAY  INY
   0= IF
      SEC  PLA  0 # ADC
      LABEL (+LOOP).BRANCH
      VS IF
         PLA  PLA
         PHP  RTI
      THEN
      PHA
   THEN
   TYA  PHA
   LABEL  N.BRANCH
   2 # LDY  CLC
   N )Y LDA  PHA  DEY
   N )Y LDA  PHA
   PHP  RTI
   END-CODE

SUBR S.(+LOOP)
   PLA  N STA  PLA  N 1+ STA
   INX  INX  CLC
   PLA  $FE ,X ADC  TAY
   PLA  $FF ,X ADC
   (+LOOP).BRANCH JMP
   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
   PLA  N STA  PLA  N 1+ STA
   N.BRANCH JMP
   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.I  ( -- LOOP-INDEX )
   XSAVE STX  TSX  CLC
   $103 ,X LDA  $105 ,X ADC  TAY
   $104 ,X LDA  $106 ,X ADC
   XSAVE LDX
   DEX  DEX
   0 ,X STY  1 ,X STA
   RTS
   END-CODE

SUBR S.J  ( -- OUTER-LOOP-INDEX )
   XSAVE STX  TSX
   INX  INX  INX  INX
   INX  INX
   S.I 3 + JMP
   END-CODE

SUBR S.LEAVE
   PLA  PLA
   PLA  PLA  PLA  PLA
   PHP RTI
   END-CODE

SUBR S.?LEAVE
   INX  INX
   $FE ,X LDA  $FF ,X ORA
   S.LEAVE 0= NOT BRAN
   RTS
   END-CODE

These subroutines were given names beginning with S. so the text 'SUBR S.' can be replaced with the text 'CODE' using search and replace.
The remaining occurrences of S. such as the following:

Code: Select all

   S.I 3 + JMP

can then be fixed by replacing S. with tick followed by a space.
Here are some convenient helper words for testing.

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

ERR is a deferred word normally set to NOOP . However, when set to (ERR) , it will display the contents of all three stacks.

The test words are code words in Fleet Forth.

Code: Select all

CODE DO.LOOP.TEST
   S.(DO) JSR  >MARK <MARK
      S.I JSR
      S.U. JSR
   S.(LOOP) JSR  <RESOLVE >RESOLVE
   NEXT JMP  END-CODE

CODE DO.+LOOP.TEST
   S.(DO) JSR  >MARK <MARK
      S.I JSR
      S.U. JSR
      S.INTERVAL JSR
   S.(+LOOP) JSR  <RESOLVE >RESOLVE
   NEXT JMP  END-CODE

CODE LEAVE.TEST
   S.(DO) JSR  >MARK <MARK
      S.I JSR
      S.U. JSR
      S.LEAVE JSR
   S.(LOOP) JSR  <RESOLVE >RESOLVE
   NEXT JMP  END-CODE

CODE ?LEAVE.TEST
   S.(DO) JSR  >MARK <MARK
      S.I JSR
      S.U. JSR
      S.I JSR
      S.?LEAVE JSR
   S.(LOOP) JSR  <RESOLVE >RESOLVE
   NEXT JMP  END-CODE

The mark and resolve words are used this way in Fleet Forth.

Code: Select all

: DO  ( -- >SYSL <SYSL )
   COMPILE (DO)
   >MARK 2+ <MARK 2+ ; IMMEDIATE
: LOOP  ( >SYSL <SYSL -- )
   COMPILE (LOOP)
   2- <RESOLVE 2- >RESOLVE ; IMMEDIATE

but with different security codes.

Here are 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
5 0 LEAVE.TEST 
0  OK
5 0 ?LEAVE.TEST 
0 
1  OK

[barrym95838]

From S.(+LOOP):

Code: Select all

   (+LOOP).BRANCH JMP

It's safe to jump into the body of a neighboring IF because THEN doesn't lay down any code to interfere, right?

[leepivonka]

In STC, sometimes inlining a little code can simplify & speed up some runtime routines.
Return stack pushs & pops are easier without the rts address in the way.

A jump pointer can be turned into a JMP abs instruction.
This eliminates the code to do a jmp indexed indirect indexed.
Adds 1 byte at each call site, removes many bytes & cycles in runtime words.

Code: Select all

\ For LOOP compile this:
   ' S.(LOOP) JSR
   addr JMP

\ For +LOOP compile this:
   ' S.(+LOOP) JSR
   addr JMP


\ LOOP runtime
SUBR S.(LOOP)
   XSAVE STX  TSX
   $103 ,X INC  0= IF		\ inc index.lo
      $104 ,X LDA  CLC 	1 # ADC, $104 ,X STA 	 VS IF\ inc index.hi
         LABEL (+LOOP).BRANCH
         INX  INX		\ rdrop rts addr
         INX  INX  INX  INX	\ rdrop index & limit
	 TXS
	 PHP  RTI		\ jmp (end addr)
        THEN
     THEN
   XSAVE LDX
   RTS
   END-CODE

\ +LOOP runtime
SUBR S.(+LOOP)
   0 ,X LDA  1 ,X LDY  INX  INX  \ pop increment
   XSAVE STX  TSX
   CLC  $103 ,X ADC  $103 ,X STA
   TYA  $104 ,X ADC  $104 ,X STA
   (+LOOP).BRANCH BVS
   XSAVE LDX
   RTS
   END-CODE

Moving the UNLOOP code inline at the LOOP & +LOOP call sites makes the runtime routines faster & smaller.
This adds 4 bytes at each call site, but removes some return stack manipulation in the runtime words.
The loop_addr JMP can be changed to a BVS to handle the conditional branch back.
This sample also resolves the end addr references at compile time.

Code: Select all

\ For DO compile this:
   ' S.(DO) JSR
   \ here is the loop address

\ for LEAVE compile this:
   leave_addr JMP

\ For LOOP compile this:
   ' S.(LOOP) JSR
   loop_addr BVC   \ or *+5 BVS; loop_addr JMP if needed
   \ here is the LEAVE address
   PLA  PLA  PLA  PLA	\ rdrop index & limit
 
\ For +LOOP compile this:
   ' S.(+LOOP) JSR
   loop_addr BVC   \ or *+5 BVS; loop_addr JMP if needed
   \ here is the LEAVE address
   PLA  PLA  PLA  PLA	\ rdrop index & limit


\ DO runtime
SUBR S.(DO)
   PLA  N STA  PLA  N 1+ STA		\ pop rts addr
   3 ,X LDA  $80 # EOR  3 ,X STA  PHA	\ fix limit.hi & push
   2 ,X LDA  PHA			\ push limit.lo
   SEC  0 ,X LDA  2 ,X SBC  TAY		\ fix index.lo
   1 ,X LDA  3 ,X SBC  PHA		\ fix index.hi & push
   TYA  PHA				\ push index.lo
   INX  INX  INX  INX			\ 2drop
   N 1+ LDA  PHA  N LDA  PHA  RTS	\ return
   END-CODE

\ LOOP runtime
SUBR S.(LOOP)
   XSAVE STX  TSX
   CLV  $103 ,X INC  0= IF	\ inc index.lo
      $104 ,X LDA  CLC 	1 # ADC, $104 ,X STA	\ inc index.hi
     THEN
   XSAVE LDX
   RTS
   END-CODE

\ +LOOP runtime
SUBR S.(+LOOP)
   0 ,X LDA  1 ,X LDY  INX  INX  \ pop increment
   XSAVE STX  TSX
   CLC  $103 ,X ADC  $103 ,X STA
   TYA  $104 ,X ADC  $104 ,X STA
   XSAVE LDX
   RTS
   END-CODE

Here is a 65816 native example. It's almost all inlined, so there aren't rts addresses to work around.
6502 NMOS probably won't optimize this much, but there are some ideas to use.

Code: Select all

: xx  compiled
  12 3 do  compiled
    i 4 and if leave then  compiled
    i .  compiled
   2 +loop  compiled
  ;  ok
seelatest
04C3 A00C00     LDY #$000C {' SIn_Buf1}         12
04C6 A90300     LDA #$0003 {' SInEnd0+0001}     3
04C9 5A         PHY                             Do
04CA 48         PHA
04CB A301       LDA $01,s                         i
04CD 290400     AND #$0004 {' SIn_Buf0}           4 and
04D0 A8         TAY                               if
04D1 D003       BNE $04D6 {xx+0013}
04D3 4CDB04     JMP $04DB {xx+0018}
04D6 68         PLA                                 leave
04D7 7A         PLY
04D8 4CEA04     JMP $04EA {xx+0027}
                                                   then
04DB A301       LDA $01,s                         i
04DD 2009B5     JSR $B509 {.+0004}                .
04E0 A90200     LDA #$0002 {' SInEnd0}            2
04E3 2066BE     JSR $BE66 {+Loop+001D}           +loop
04E6 30E3       BMI $04CB {xx+0008}
04E8 68         PLA
04E9 7A         PLY
04EA 60         RTS                             ;

 ok
xx 3  ok

[JimBoyd]

barrym95838 wrote:

From S.(+LOOP):

Code: Select all

   (+LOOP).BRANCH JMP

It's safe to jump into the body of a neighboring IF because THEN doesn't lay down any code to interfere, right?

Correct. IF c-commas the opcode for one of the branches, places HERE on the stack and c-commas a zero to reserve the next byte. THEN resolves the branch address. It's similar to how the high level IF and THEN work.

[JimBoyd]

leepivonka wrote:

In STC, sometimes inlining a little code can simplify & speed up some runtime routines.
Return stack pushs & pops are easier without the rts address in the way.

A jump pointer can be turned into a JMP abs instruction.
This eliminates the code to do a jmp indexed indirect indexed.
Adds 1 byte at each call site, removes many bytes & cycles in runtime words.

I had already considered this. The first test case would have been

Code: Select all

CODE DO.LOOP.TEST
   S.(DO) JSR  >MARK <MARK
      S.I JSR
      S.U. JSR
   S.(LOOP) JSR   $4C C,  <RESOLVE >RESOLVE
   NEXT JMP  END-CODE

The prototype will be a simple STC rethreading of Fleet Forth to provide a reference. I really would like to see how much can be done without inlining, except where inlining would result in a smaller size.
After the prototype is up and running, I plan to experiment with various optimizations, including this one, to see how they stack up against the prototype.

[JimBoyd]

Those who have not read my metacompiler posts may be wondering how I'm using labels in a Forth assembler.
When metacompiling, a label is nothing more than a CONSTANT defined in a different vocabulary holding the current value of THERE (the target's HERE). Since the target is built in virtual memory, labels do not 'get in the way' of compiling or assembling words for the target kernel.
To test words by assembling them on the host, even without a metacompiler loaded, I use a different definition of LABEL . If no labels are defined while compiling, only assembling, I write this quick and dirty version of LABEL .

Code: Select all

: LABEL  HERE [COMPILE] TO ;

All the labels are predefined before the code to be tested is assembled.

Code: Select all

0 VALUE (+LOOP).BRANCH
0 VALUE N.BRANCH

[JimBoyd]

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