6502.org Forum  Projects  Code  Documents  Tools  Forum
It is currently Sat Apr 27, 2024 3:32 pm

All times are UTC




Post new topic Reply to topic  [ 7 posts ] 
Author Message
PostPosted: Sun Nov 13, 2022 9:45 pm 
Offline

Joined: Fri May 05, 2017 9:27 pm
Posts: 851

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



Top
 Profile  
Reply with quote  
PostPosted: Mon Nov 14, 2022 10:22 am 
Online
User avatar

Joined: Sun Jun 30, 2013 10:26 pm
Posts: 1927
Location: Sacramento, CA, USA
From S.(+LOOP):
Code:
   (+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?

_________________
Got a kilobyte lying fallow in your 65xx's memory map? Sprinkle some VTL02C on it and see how it grows on you!

Mike B. (about me) (learning how to github)


Top
 Profile  
Reply with quote  
PostPosted: Mon Nov 14, 2022 4:49 pm 
Offline

Joined: Fri Apr 15, 2016 1:03 am
Posts: 135
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:

\ 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:

\ 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:
: 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



Top
 Profile  
Reply with quote  
PostPosted: Mon Nov 14, 2022 9:19 pm 
Offline

Joined: Fri May 05, 2017 9:27 pm
Posts: 851
barrym95838 wrote:
From S.(+LOOP):
Code:
   (+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.


Top
 Profile  
Reply with quote  
PostPosted: Mon Nov 14, 2022 9:50 pm 
Offline

Joined: Fri May 05, 2017 9:27 pm
Posts: 851
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:
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.


Top
 Profile  
Reply with quote  
PostPosted: Thu Nov 17, 2022 2:04 am 
Offline

Joined: Fri May 05, 2017 9:27 pm
Posts: 851

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:
: LABEL  HERE [COMPILE] TO ;

All the labels are predefined before the code to be tested is assembled.
Code:
0 VALUE (+LOOP).BRANCH
0 VALUE N.BRANCH



Top
 Profile  
Reply with quote  
PostPosted: Sun Jan 22, 2023 9:13 pm 
Offline

Joined: Fri May 05, 2017 9:27 pm
Posts: 851

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:
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:
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:
: 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:
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:
: 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:
>SYSL = ADR 3
<SYSL = ADR 4

And some helper words I've already presented in a previous post.
Code:
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:
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:
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:
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



Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 7 posts ] 

All times are UTC


Who is online

Users browsing this forum: No registered users and 8 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot post attachments in this forum

Search for:
Jump to: