# fbForth fbForth—TI Forth with File-based Block I/O [Post #1 UPDATED: 04/13/2021]

## Recommended Posts

1 hour ago, TheBF said:

The Forth code I posted is used with a tolerance of 8 typically and it seems to work great even in Forth.

It works to a point, but, for a tolerance of 8 pixels, that method hits all pixels (289) in a 17x17-pixel square, when it should be hitting only the pixels (197) in a 17-pixel-diameter circle. That is 47% more pixels than it should be hitting—seems a bit much to me.

...lee

##### Share on other sites

I guess it's a requirements compromise then. The code ran significantly faster than what I had (which was already 2X faster than the TI-Forth code) and when I used it in a test the result seemed to work just like the other version to my eye. Sprites collided and bounced back.

Different horses for different courses... ?

##### Share on other sites

I think I found a problem with COINC and COINCXY in TI Forth, which I converted to ALC for fbForth. and would, of course, still be a problem! Here is the high-level Forth code from TI Forth:

```: COINC     ( spr#1 spr#2 tol  --- f ) ( 0= no coinc  1= coinc )
DUP * DUP + >R        ( STACK: spr#1 spr#2 R: tol*tol+tol*tol)
SPRDIST R>            ( STACK: dist^2 2*tol^2)
> 0=   ;              ( within tolerance? STACK: flag)```

As you can see the test, for distance d of the top left corners of two sprites from each other with a tolerance t, is d2 <= 2t2. I have no idea why the TI gurus doubled t2. If you make a square with one sprite’s upper left corner in the center and each edge t pixels from the center (making each side 2t pixels) the tolerance circle (radius = t) is inscribed within the  square. With the above test, the 2t-pixel square is inscribed within the tolerance circle, which now has its radius equal to half the diagonal of the square = (2t2)1/2, which is larger by a factor of √2. A tolerance of 8 pixels is now 11.3 pixels!

Convince me I am wrong.

...lee

##### Share on other sites

Lol. I don't think I can.

I am just now over looking over what I translated it into.

I did the same thing, just faster.  I am writing a little "collider" to compare how well different COINC routines work.

It's like a particle collider for sprites with one sprite coming from opposite sides of the screen.

Perhaps they were purposely expanding the window to create a higher chance of coincidence?

Even in Forth it's hard catch the asynchronous automotion sprites.

```HEX
\ text macros improve speed of coicidence detection
: 2(X^2)   ( n -- 2(n^2) S" DUP * 2* " EVALUATE ;  IMMEDIATE
: <=       ( n n -- ? )  S" 1- <" EVALUATE ; IMMEDIATE

\ simple machine code optimizers for DIST
CODE RDROP ( -- )
05C7 ,    \ RP INCT,
NEXT,
ENDCODE

CODE DXY  ( x2 y2 x1 y1 --- dx dy )   \ Common factor for SP.DIST,SP.DISTXY
C036 ,  \ *SP+ R0 MOV,      \ pop x1->R0
6136 ,  \ *SP+ TOS SUB,     \ pop y1-y2->tos
6016 ,  \ *SP  R0 SUB,      \ x1-x2->R0, keep stack location
C0C4 ,  \  TOS R3 MOV,      \ dup tos in r3, MPY goes into R4
38C4 ,  \  TOS R3 MPY,      \ r3^2, result->r4 (tos)
C080 ,  \  R0  R2  MOV,     \ dup R0
3802 ,  \  R2  R0  MPY,     \ RO^2
C581 ,  \  R1 *SP  MOV,     \ result to stack
NEXT,                       \ 16 bytes
ENDCODE

( factored DIST out from SPRDISTXY in TI-Forth)
: DIST     ( x2 y2 x1 y1 -- distance^2) \ distance between 2 coordinates
DXY  2DUP +                 \ sum the squares (DXY is code word)
DUP >R                      \ push a copy
OR OR 8000 AND              \ check out of range
IF RDROP 7FFF             \ throw away the copy, return 32K
ELSE R>                     \ otherwise return the calculation
THEN ;

: SP.DIST   ( #1 #2 -- dist^2 )         \ distance between 2 sprites
POSITION ROT POSITION DIST ;

: SP.DISTXY ( x y # -- dist^2 ) POSITION DIST ;

( 0 means no coinc  )
: COINC     ( sp#1 sp#2 tol -- ? ) 2(X^2) >R SP.DIST  R> <= ;
```

##### Share on other sites
1 hour ago, TheBF said:

Perhaps they were purposely expanding the window to create a higher chance of coincidence?

I think I would rather trust the user to increase the tolerance. I just wish I could guess why they did it. Perhaps I should again try to grok how GPL does it using coincidence tables (see here). I think I had it once upon a time. It just does not seem worth the effort.

...lee

##### Share on other sites

I agree that the user should control it and that it is all too much effort for something that needs to be fast on a very slow machine.

That's why I believe the pixel coordinate comparison makes more sense.  The data is sitting there so just read it and difference it.

My preliminary colliider tests showed that this VDP x,y comparison method works very well.

I have some stuff on my plate but this week but I want to run the tests with a deferred word COINC and plug in different methods and view the sprites and where they actually collide.

I will take a look at the GPL and see if any of it clicks.

##### Share on other sites
7 hours ago, Lee Stewart said:

I think I would rather trust the user to increase the tolerance. I just wish I could guess why they did it. Perhaps I should again try to grok how GPL does it using coincidence tables (see here). I think I had it once upon a time. It just does not seem worth the effort.

...lee

OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see.  It would be helpful to see how much code it takes to process these tables.

Is there a way to find that code in the GPL interpreter?

##### Share on other sites
54 minutes ago, TheBF said:

OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see.  It would be helpful to see how much code it takes to process these tables.

Is there a way to find that code in the GPL interpreter?

Yes. I believe so. It should be in the commented code of the console ROM for the GPL interpreter (see this thread: The TI-99/4A Operating System). I will take a look.

...lee

##### Share on other sites
1 hour ago, TheBF said:

OK I don't fully understand all the logic but it again seems to be an exercise that leads to slower determination of coincidence albeit it creates symmetrical coincidence around the object from what I can see.  It would be helpful to see how much code it takes to process these tables.

Is there a way to find that code in the GPL interpreter?

I don’t know whether this is enough of the code to get the gist, but here it is:

Spoiler
```TSTRTN B    @RETNC           RESTORE PROGRAM COUNTER
* COINCIDENCE ROUTINE FOR INSERTION INTO REL4 INTERPRETER
* UPON ENTRACE TO THIS ROUTINE AT LABEL 'COINC' THE
* REGISTERS ARE ASSUMED TO BE SET UP:
*  MSBY   R2=Y2 IN MSBY AND X2 IN LSBY;
*  MSBY   R0=Y1 IN MSBY AND X1 IN LSBY;
* IT IS ALSO ASSUMED THAT THE GROM'S INTERNAL ADDRESS IS SET
* UP PREPARED TO READ (FOLLOWING THE COINC INSTRUCTION):
*   - A ONE BYTE GRANULARITY VALUE, FOLLOWED BY:
*   - A TWO BYTE ADR. POINTING TO THE COINCIDENCE TABLE.
*     THE TABLE IS ASSUMED TO RESIDE IN GROM, AND HAVE THE
*  FOLLOWING FORMAT:
*      BYTE 0- TV = VERTICAL BIT SIZE OF TABLE LESS 1
*      BYTE 1- TH = HORIZ.   BIT SIZE OF TABLE LESS 1
*      BYTE 2- V1 = VERTICAL DOT SIZE OF OBJECT 1/2**GR
*      BYTE 3- H1 = HORIZ.   DOT SIZE OF OBJECT 1/2**GR
*      BYTES 4 ON - THE BIT TABLE ITSELF; THE BITS ARE
* ARRANGED SUCH THAT THE FIRST (TH+1) BITS REPRESENT BOOLEAN
* CONICIDENCE VALUES CORRESPONDING TO A DELTA Y (Y1-Y2) OF -V1
* THRU -V1+TV AND DELTA X (X1-CX2) VALUES -H1 THRU -H1+TH
*
* ENTRY = BR TABLE
COINC  MOV  R0,R8
MOV  R8,R3            FIRST GET DELTA Y AND DELTA X
SB   R2,R3            R3= Y1-Y2= DELTA Y
SWPB R8               GET X1 IN MSBY
SWPB R2               GET X2 IN MSBY
SB   R2,R8            R8 X1-X2 = DELTA X
MOVB *R13,R0          SET RESLN AND TABLE POINTER
SRL  R0,8             R0 = GRAN
MOVB *R13,R5
SWPB R5
MOVB *R13,R5
SWPB R5               R5 = TABLE POINTER
BL   @PUTSTK          SAVE GROM PC
*
* NOW GET TV,TH,V1,H1, OUT OF THE 1ST 4 BYTES OF TABLE
*
MOVB R5,@GWAOFF(R13)  PUT OUT TABLE POINTER LSBY
SWPB R5
MOVB R5,@GWAOFF(R13)  PUT OUT TABLE POINTER MSBY
SWPB R5
MOVB *R13,R2          R2=TV(MSBY)
NOP
MOVB *R13,R1          R1=TH(MSBY)
NOP
MOVB *R13,R6          R6=V1(MSBY)
NOP
MOVB *R13,R7          R7=H1(MSBY)
* NOW ON WITH THE SHOW, THE REGISTERS ARE NOW SET UP AS:
*      R0= GRANULARITY;
* MSBY R1= TH = CONICIDENCE TABLE HORIZONTAL SIZE -1
* MSBY R2= TV = CONICIDENCE TABLE VERTICAL   SIZE -1
* MSBY R3= Y1 - Y2 = DELTA Y
* MSBY R8= X1 - X2 = DELTA X
*      R5= PNTR TO COINCIDENCE TABLE IN GROM
* MSBY R6= V1 = VERTICAL SIZE OF OBJECT ONE IN DOTS
* MSBY R7= H1 = HORIZ.   SIZE OF OBJECT ONE IN DOTS
*
MOV  R0,R0            IF GRANULARITY IS 0, DON'T SHIFT
JEQ  DNTSHF            BECAUSE 9900 SHIFT BY 0 IS 16
SRA  R3,R0            DIVIDE DELTA Y BY (2** GRAN)
SRA  R8,R0            DIVIDE DELTA X BY (2** GRAN)
DNTSHF AB   R7,R8            R8 = B = H1 + DELTA X
JLT  NOCOIN
AB   R6,R3            R3 = A = V1 +DELTA Y
JLT  NOCOIN
CB   R3,R2            A::TV
JGT  NOCOIN
CB   R8,R1            B::TH
JGT  NOCOIN           RANGE TEST PASSED?
SRL  R1,8             NOW COMPUTE TABLE INDEX
INC  R1               R1=TH+1
SRL  R3,8             R3=A
MPY  R3,R1            R2=A*(TH+1)
SRL  R8,8             R8=B
A    R8,R2            R2= INDEX. COMPUTE TABLE & BIT POSN
MOV  R2,R0            R0 = INDEX ALSO
ANDI R2,>FFF8         R2 = ROUNDED DOWN TO LOWER MULT OF 8
S    R2,R0            R0 = BIT DISPLACEMENT (0= LEFTMOST)
SRA  R2,3             R2 = BYTE INDEX INTO TABLE
A    R5,R2            R2 = ACTUAL ADDRESS OF BYTE
C    *R2+,*R2+        INC PNTR BY 4 FOR 4 BYTE HEADER
MOVB R2,@GWAOFF(R13)  PULL PROPER BYTE FROM GROM
INC  R0
MOVB @R2LSB,@GWAOFF(R13)
LI   R2,>2000
MOVB *R13,R3          R3 = THE BYTE FROM THE TABLE
SLA  R3,R0            GET PROPER BIT INTO THE STATUS CARRY
JOC  YUP              IF BIT IS 0, NO COINCIDENCE
NOCOIN CLR  R2               NO, WE HAVE COINCIDENCE
YUP    MOVB R2,@STATUS       YES, WE HAVE COINCIDENCE
JMP  TSTRTN```

Personally, I am not sure it is worth the effort. I am chewing on using just the tolerance square, as I think you are (were) doing—a lot quicker, for sure. I may try to use a user-settable flag to do it either way, but I only have 162 bytes left in that bank. It might be enough.

...lee

##### Share on other sites
56 minutes ago, Lee Stewart said:

I don’t know whether this is enough of the code to get the gist, but here it is:

Reveal hidden contents
```
TSTRTN B    @RETNC           RESTORE PROGRAM COUNTER
* COINCIDENCE ROUTINE FOR INSERTION INTO REL4 INTERPRETER
* UPON ENTRACE TO THIS ROUTINE AT LABEL 'COINC' THE
* REGISTERS ARE ASSUMED TO BE SET UP:
*  MSBY   R2=Y2 IN MSBY AND X2 IN LSBY;
*  MSBY   R0=Y1 IN MSBY AND X1 IN LSBY;
* IT IS ALSO ASSUMED THAT THE GROM'S INTERNAL ADDRESS IS SET
* UP PREPARED TO READ (FOLLOWING THE COINC INSTRUCTION):
*   - A ONE BYTE GRANULARITY VALUE, FOLLOWED BY:
*   - A TWO BYTE ADR. POINTING TO THE COINCIDENCE TABLE.
*     THE TABLE IS ASSUMED TO RESIDE IN GROM, AND HAVE THE
*  FOLLOWING FORMAT:
*      BYTE 0- TV = VERTICAL BIT SIZE OF TABLE LESS 1
*      BYTE 1- TH = HORIZ.   BIT SIZE OF TABLE LESS 1
*      BYTE 2- V1 = VERTICAL DOT SIZE OF OBJECT 1/2**GR
*      BYTE 3- H1 = HORIZ.   DOT SIZE OF OBJECT 1/2**GR
*      BYTES 4 ON - THE BIT TABLE ITSELF; THE BITS ARE
* ARRANGED SUCH THAT THE FIRST (TH+1) BITS REPRESENT BOOLEAN
* CONICIDENCE VALUES CORRESPONDING TO A DELTA Y (Y1-Y2) OF -V1
* THRU -V1+TV AND DELTA X (X1-CX2) VALUES -H1 THRU -H1+TH
*
* ENTRY = BR TABLE
COINC  MOV  R0,R8
MOV  R8,R3            FIRST GET DELTA Y AND DELTA X
SB   R2,R3            R3= Y1-Y2= DELTA Y
SWPB R8               GET X1 IN MSBY
SWPB R2               GET X2 IN MSBY
SB   R2,R8            R8 X1-X2 = DELTA X
MOVB *R13,R0          SET RESLN AND TABLE POINTER
SRL  R0,8             R0 = GRAN
MOVB *R13,R5
SWPB R5
MOVB *R13,R5
SWPB R5               R5 = TABLE POINTER
BL   @PUTSTK          SAVE GROM PC
*
* NOW GET TV,TH,V1,H1, OUT OF THE 1ST 4 BYTES OF TABLE
*
MOVB R5,@GWAOFF(R13)  PUT OUT TABLE POINTER LSBY
SWPB R5
MOVB R5,@GWAOFF(R13)  PUT OUT TABLE POINTER MSBY
SWPB R5
MOVB *R13,R2          R2=TV(MSBY)
NOP
MOVB *R13,R1          R1=TH(MSBY)
NOP
MOVB *R13,R6          R6=V1(MSBY)
NOP
MOVB *R13,R7          R7=H1(MSBY)
* NOW ON WITH THE SHOW, THE REGISTERS ARE NOW SET UP AS:
*      R0= GRANULARITY;
* MSBY R1= TH = CONICIDENCE TABLE HORIZONTAL SIZE -1
* MSBY R2= TV = CONICIDENCE TABLE VERTICAL   SIZE -1
* MSBY R3= Y1 - Y2 = DELTA Y
* MSBY R8= X1 - X2 = DELTA X
*      R5= PNTR TO COINCIDENCE TABLE IN GROM
* MSBY R6= V1 = VERTICAL SIZE OF OBJECT ONE IN DOTS
* MSBY R7= H1 = HORIZ.   SIZE OF OBJECT ONE IN DOTS
*
MOV  R0,R0            IF GRANULARITY IS 0, DON'T SHIFT
JEQ  DNTSHF            BECAUSE 9900 SHIFT BY 0 IS 16
SRA  R3,R0            DIVIDE DELTA Y BY (2** GRAN)
SRA  R8,R0            DIVIDE DELTA X BY (2** GRAN)
DNTSHF AB   R7,R8            R8 = B = H1 + DELTA X
JLT  NOCOIN
AB   R6,R3            R3 = A = V1 +DELTA Y
JLT  NOCOIN
CB   R3,R2            A::TV
JGT  NOCOIN
CB   R8,R1            B::TH
JGT  NOCOIN           RANGE TEST PASSED?
SRL  R1,8             NOW COMPUTE TABLE INDEX
INC  R1               R1=TH+1
SRL  R3,8             R3=A
MPY  R3,R1            R2=A*(TH+1)
SRL  R8,8             R8=B
A    R8,R2            R2= INDEX. COMPUTE TABLE & BIT POSN
MOV  R2,R0            R0 = INDEX ALSO
ANDI R2,>FFF8         R2 = ROUNDED DOWN TO LOWER MULT OF 8
S    R2,R0            R0 = BIT DISPLACEMENT (0= LEFTMOST)
SRA  R2,3             R2 = BYTE INDEX INTO TABLE
A    R5,R2            R2 = ACTUAL ADDRESS OF BYTE
C    *R2+,*R2+        INC PNTR BY 4 FOR 4 BYTE HEADER
MOVB R2,@GWAOFF(R13)  PULL PROPER BYTE FROM GROM
INC  R0
MOVB @R2LSB,@GWAOFF(R13)
LI   R2,>2000
MOVB *R13,R3          R3 = THE BYTE FROM THE TABLE
SLA  R3,R0            GET PROPER BIT INTO THE STATUS CARRY
JOC  YUP              IF BIT IS 0, NO COINCIDENCE
NOCOIN CLR  R2               NO, WE HAVE COINCIDENCE
YUP    MOVB R2,@STATUS       YES, WE HAVE COINCIDENCE
JMP  TSTRTN```

Personally, I am not sure it is worth the effort. I am chewing on using just the tolerance square, as I think you are (were) doing—a lot quicker, for sure. I may try to use a user-settable flag to do it either way, but I only have 162 bytes left in that bank. It might be enough.

...lee

Wow!  That is a lot of code.

Thanks for finding it.

back of the napkin...  (0 wait state thinking just to compare things)

So it is 58 lines of code if we say the 9900 averages 18 clocks per instruction that is on the order of 350 uS.

With 20 clocks as an average that's 386 uS.

My difference method in Forth, including putting 3 parameters on the stack is ~1,500 uS. measured with the 9901 timer.

Three parameters uses 234 uS. leaving 1266uS for the routine.

In code I should be able to make that 5x faster... 253 uS.

Still not that much better.

Will have to do some tests.

##### Share on other sites
1 hour ago, TheBF said:

back of the napkin...  (0 wait state thinking just to compare things)

So it is 58 lines of code if we say the 9900 averages 18 clocks per instruction that is on the order of 350 uS.

With 20 clocks as an average that's 386 uS

Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check!

...lee

##### Share on other sites
10 minutes ago, Lee Stewart said:

Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check!

Oops! Just remembered there are no sprites in TI Basic—so, just need to check XB code.

...lee

##### Share on other sites
55 minutes ago, Lee Stewart said:

Well—remember that, even though all that code is executing on the no-wait, 16-bit bus, the tables are very slow GROM accesses. I do not know whether TI Basic or XB use the GPL COINC instruction, but, if they do, I would think there would need to be VRAM access, as well—also slow. I seem to remember, though, that the Basics use the tolerance square—now, I need to check!

OK—Here is the RXB source (includes all of XB source) that includes the COINC routine. Look particularly at the CODIST routine for the distance between two sprites and its use by the COINC routine. Though there is a DIST routine, which is used for XB’s CALL DISTANCE( ) for both inter-sprite and sprite-to-pixel distances, it appears DIST is not used for COINC and that my memory was correct in that XB uses only the tolerance square, dx and dy without calculating the actual distance:

Spoiler
```***********************************************************
TITL 'RXB 2015'
***********************************************************
GROM >A000
***********************************************************
TITL 'EQUATES EXEC-359'
***********************************************************
***********************************************************
*    EQUATES FOR ROUTINES FROM OTHER GROM SECTIONS
* GROM >0000
GRINT  EQU  >0022             Greatest integer
* GROM >6000 EQUATES
SPRINT EQU  >6016             Initialize sprites
CHRTBL EQU  >6018             RXB CALL CHRTBL load char set
CHRTAB EQU  >601C             Load default character set
SZRUN  EQU  >601E
KILSYM EQU  >6022             KILL SYMBOL TABLE ROUTINE
AUTO1  EQU  >602E             Get arguments for LIST comman
TOPL02 EQU  >6030             RTN address for failing AUTOL
EDITLN EQU  >6032             Edit a line into the program
GRSUB1 EQU  >6034             Read data (2 bytes) from ERAM
GWSUB  EQU  >6036             Write a few bytes of data to
MSGBRK EQU  >6048             * BREAKPOINT
MSGTA  EQU  >6053             Message "try again"
TOPLEV EQU  >6372             RXB CALL USER branch
CHKEND EQU  >6A78             Check end of statement
DISO   EQU  >6A7C
ENTER  EQU  >6A7E
ENT09  EQU  >6A80
WARNZZ EQU  >6A82             WARNING MESSAGE ROUTINE
ERRZZ  EQU  >6A84             ERROR MESSAGE ROUTINE
ERRZ   EQU  >6A84             ERRor routine
SZNEW  EQU  >63A5             RXB CALL NEW branch
TOPL15 EQU  >63DD             RXB CALL USER branch
SZSIZE EQU  >65C9             RXB CALL SIZE branch
* GROM >8000
DISPL1 EQU  >8000
DELET  EQU  >8002
PRINT  EQU  >8004
INPUT  EQU  >8006
OPEN   EQU  >8008
CLOSE  EQU  >800A
RESTOR EQU  >800C
CLSALL EQU  >8012             RXB branch
EOF    EQU  >801C
ACCEPT EQU  >801E
SRDATA EQU  >8020
REC    EQU  >8022
GRSUB2 EQU  >802C
GRSUB3 EQU  >802E
LINPUT EQU  >8030
CHARS  EQU  >9CEA             RXB Character Definitions
* GROM >E000
GE025  EQU  >E025             RXB branch EA module
***********************************************************
*    Equates for XMLs
SYNCHK EQU  >00               SYNCHK XML selector
FILSPC EQU  >01               Fill-space utility
PARCOM EQU  >01               PARse to a COMma selector
CSTRIN EQU  >02               Copy-string utility
RANGE  EQU  >02               RANGE selector
SEETWO EQU  >03               SEETWO XML selector
FMUL   EQU  >08               Floating MULtiply
FDIV   EQU  >09               Floating DIVide
FCOMP  EQU  >0A               Floating COMPare
SSUB   EQU  >0C               Stack SUBtract
CSNUM  EQU  >10               Convert String to Number
CFI    EQU  >12               Convert to two byte integer
FLTINT EQU  >12               Convert floating to integer
COMPCT EQU  >70               PREFORM A GARBAGE COLLECTION
GETSTR EQU  >71               SYSTEM GET STRING
MEMCHK EQU  >72               MEMORY check routine: VDP
XCNS   EQU  >73               Convert number to string
* Warning Defualt changfd in >0079
PARSE  EQU  >74               Parse a value
CONT   EQU  >75               Continue parsing
EXECG  EQU  >76               Execute a XB stmt or program
VPUSH  EQU  >77               Push on value stack
VPOP   EQU  >78               Pop off value stack
PGMCHR EQU  >79               GET PROGRAM CHARACTER
SYM    EQU  >7A               Find SYMBOL entry
SMB    EQU  >7B               Find symbol table entry
ASSGNV EQU  >7C               Assign VARIABLE
SCHSYM EQU  >7D               Search symbol table
SPEED  EQU  >7E               SPEED UP XML
CRUNCH EQU  >7F               Crunch an input line
CIF    EQU  >80               Convert INTEGER to FLOATING P
RTNB   EQU  >82               Return
SCROLL EQU  >83               SCROLL THE SCREEN
IO     EQU  >84               IO utility (KW table search)
GWRITE EQU  >86               WRITE DATA TO ERAM
DELREP EQU  >87               REMOVE CONTENT FROM VDP/ERAM
MVDN   EQU  >88               MOVE DATA IN VDP/ERAM
MVUP   EQU  >89               MOVE DATA IN VDP/ERAM
VGWITE EQU  >8A               MOVE DATA FROM VDP TO ERAM
GVWITE EQU  >8B               WRITE DATA FROM GRAM TO VRAM
GDTECT EQU  >8E               ERAM DETECT&ROM PAGE 1 ENABLE
SCNSMT EQU  >8F               SCAN STATEMENT FOR PRESCAN
***********************************************************
*    Temporary workspaces in EDIT
VAR0   EQU  >8300            TEMPORARY
SP00   EQU  >8300            SPRITE value
PTFBSL EQU  >8300            Ptr to 1st byte in SPEAK list
PHLEN  EQU  >8300            PHrom data LENgth
VARV   EQU  >8301            TEMPORARY
ACCUM  EQU  >8302            # OF BYTES ACCUMULATOR (4 BYTE
STPT   EQU  >8302            TWO BYTES
MNUM   EQU  >8302            Ussually a counter
AAA1   EQU  >8302
SP02   EQU  >8302            SPRITE value
PTLBSL EQU  >8302            Ptr to last byte in SPEAK list
VARY   EQU  >8304
PABPTR EQU  >8304            Pointer to current PAB
SP04   EQU  >8304            SPRITE value
PTEBSL EQU  >8304            Ptr to end byte in SPEAK list
* NOTE: PTEBSL points to the end of the temporary speak lis
*       whereas PTLBSL points to the last byte actually use
*       i.e.    PTFBSL <= PTLBSL <= PTEBSL
VARY2  EQU  >8306            Use in MVDN only
DFLTLM EQU  >8306            Default array limit (10)
CCPPTR EQU  >8306            OFFSET WITHIN RECORED (1)
*                             or Pointer to current column
SP06   EQU  >8306            SPRITE value
PTFCIS EQU  >8306            Ptr to 1st character in string
RECLEN EQU  >8307            LENGTH OF CURRENT RECORD (1)
*                             or Actual buffer address or c
VARC   EQU  >8308
CCC1   EQU  >8308
SPSAL  EQU  >8308            Location of sprite attribute l
PTCCIS EQU  >8308            Ptr to current character in st
CALIST EQU  >830A            Call list for resolving refs
RAMPTR EQU  >830A            Pointer for crunching
SPTMP  EQU  >830A            Temporary variable
PTLCIS EQU  >830A            Ptr to last character in strin
VAR2   EQU  >830B
BYTES  EQU  >830C            BYTE COUNTER
*                             or String length for GETSTR
NMPTR  EQU  >830C            Pointer save for pscan
BBB1   EQU  >830C
PTFCIP EQU  >830C            Ptr to 1st character in phrase
CHSAV  EQU  >830E
CURINC EQU  >830E            Increment for auto-num mode
VAR4   EQU  >830E
PTCCIP EQU  >830E            Ptr to current character in ph
TOPSTK EQU  >8310            Top of data stack pointer
VAR5   EQU  >8310            VAR5 through VAR5+3 used in RA
PTLCIP EQU  >8310            Ptr to last character in phras
VAR6   EQU  >8311
LINUM  EQU  >8312            Used to determine end of scan
PTFBPH EQU  >8312            Ptr to 1st byte in PHrom
VAR7   EQU  >8312            Used in CHARLY
STRPTR EQU  >8312            RXB PATCH CODE
NMLEN  EQU  >8314            Current line for auto-num
CURLIN EQU  >8314            Current line for auto-num
*                             or Starting line number for L
PTCCPH EQU  >8314            Ptr to current byte in PHrom
VAR9   EQU  >8314             Used in CHARLY
XFLAG  EQU  >8316            SCAN FLAG-BITS USED AS BELOW
PTLCPH EQU  >8316            Ptr to last byte in PHrom
DSRFLG EQU  >8317            INTERNAL =60, EXTERNAL =0 (1)
OPTFLG EQU  >8317            Option flag byte during OPEN
FORNET EQU  >8317            Nesting level of for/next
FNUM   EQU  >8317            Current file number for search
***********************************************************
*    Permanent workspace variables
STRSP  EQU  >8318            String space begining
STREND EQU  >831A            String space ending
SREF   EQU  >831C            Temporary string pointer
SMTSRT EQU  >831E            Start of current statement
VARW   EQU  >8320            Screen address (CURSOR)
ERRCOD EQU  >8322            Return error code from ALC
STVSPT EQU  >8324            Value-stack base
RTNG   EQU  >8326            Return vector from 9900 code
NUDTAB EQU  >8328            Start of NUD table
VARA   EQU  >832A            Ending display location
PGMPTR EQU  >832C            Program text pointer (TOKEN)
EXTRAM EQU  >832E            Line number table pointer
STLN   EQU  >8330            Start of line number table
ENLN   EQU  >8332            End of line number table
DATA   EQU  >8334            Data pointer for READ
LNBUF  EQU  >8336            Line table pointer for READ
INTRIN EQU  >8338            Add of intrinsic poly constant
SUBTAB EQU  >833A            Subprogram symbol table
IOSTRT EQU  >833C            PAB list/Start of I/O chain
SYMTAB EQU  >833E            Symbol table pointer
FREPTR EQU  >8340            Free space pointer
CHAT   EQU  >8342            Current charater/token
BASE   EQU  >8343            OPTION BASE value
PRGFLG EQU  >8344            Program/imperative flag
FLAG   EQU  >8345            General 8-bit flag
BUFLEV EQU  >8346            Crunch-buffer destruction leve
LSUBP  EQU  >8348            Last subprogram block on stack
* FAC  EQU  >834A            Floating-point ACcurmulator
CCHAR  EQU  >834A            Current character
FAC1   EQU  FAC+1
SPLFLG EQU  >834B            SPelL out phrase FLaG
FAC2   EQU  FAC+2
AAA    EQU  FAC+2
TOTTIM EQU  >834C            TOTal wait TIMe
*       routine STDATA is counting on this fact!
FAC3   EQU  FAC+3
FAC4   EQU  FAC+4
CCC    EQU  FAC+4
FFF    EQU  FAC+4
FAC5   EQU  FAC+5
PTLCIL EQU  >834F            Pointer To Last Character In L
FAC6   EQU  FAC+6
BBB    EQU  FAC+6
EEE    EQU  FAC+6
FAC7   EQU  FAC+7
TIMLEN EQU  >8351             TIMe LENgth of timing charact
FAC8   EQU  FAC+8
FAC9   EQU  FAC+9
FAC10  EQU  FAC+10
DDD1   EQU  FAC+10
TEMP1  EQU  >8354            TEMPorary CPU location 1
FAC11  EQU  FAC+11
FAC12  EQU  FAC+12
FFF1   EQU  FAC+12
TEMP2  EQU  >8356            TEMPorary CPU location 2
FAC13  EQU  FAC+13
FAC14  EQU  FAC+14
EEE1   EQU  FAC+14
FAC15  EQU  FAC+15
FAC16  EQU  FAC+16
WRITE  EQU  >835A            Address of speech peripheral
*                             WRITE byte interface
FAC17  EQU  FAC+17
* ARG  EQU  >835C            Floating-point ARGument
ARG1   EQU  ARG+1
PHDATA EQU  >835D            PHrom DATA
ARG2   EQU  ARG+2
PTCBED EQU  >835E            Ptr To Current Byte Ext Data
ARG3   EQU  ARG+3
ARG4   EQU  ARG+4
LENCST EQU  >8360            LEN of Current ext data STring
ARG5   EQU  ARG+5
ARG6   EQU  ARG+6
LENWST EQU  >8362            LEN of Whole ext data STring
ARG7   EQU  ARG+7
ARG8   EQU  ARG+8
STRLEN EQU  >8364            STRing LENgth
TEMP4  EQU  >8364
TEMP5  EQU  >8366
* NOTE: BYTE1, BYTE2, and BYTE3 must be in consecutive memo
*       locations, and in the following order for SPGET to
*       work!
BYTE1  EQU  >8366            BYTE 1
BYTE2  EQU  >8367            BYTE 2
BYTE3  EQU  >8368            BYTE 3
TEMP6  EQU  >8368
SPKSTS EQU  >8369            SPeaK StaTus
* FPERAD EQU  >836C          Value stack pointer
ARG11  EQU  ARG+11
ARG15  EQU  ARG+15
ARG16  EQU  ARG+16
* VSPTR  EQU  >836E          Value stack pointer
***********************************************************
*    GPL Status Block
HIVDP  EQU  >8370             Highest VDP Available
* SUBSTK EQU  >8373           SUBROUTINE STACK
KEYBD  EQU  >8374             KEYBOARD SELCTION
RKEY   EQU  >8375             KEY CODE
EXPZ   EQU  >8376             Exponent in floating-point
JOYY   EQU  >8376             JOYSTICK Y POSITION
JOYX   EQU  >8377             JOYSTICK X POSITION
RANDOM EQU  >8378             RANDOM NUMBER GENERATOR
TIMER  EQU  >8379             TIMING REGISTER
MOTION EQU  >837A             NUMBER OF MOVING SPRITES
VDPSTS EQU  >837B             VDP STATUS REGISTER
VDPSTT EQU  >837B             VDP STATUS REGISTER
ERCODE EQU  >837C             STATUS REGISTER
CB     EQU  >837D             Character Buffer
***********************************************************
RAMTOP EQU  >8384            Highest address in ERAM
RAMFRE EQU  >8386            Free pointer in the ERAM
RSTK   EQU  >8388            Subroutine stack base
*                             (Starts at >8A)
RAMFLG EQU  >8389            ERAM flag
GRAMFL EQU  >8389            GRAM / VDP flag
STKMIN EQU  >83AF            Base of data stack
STKMAX EQU  >83BD            Top of data stack
PRTNFN EQU  >83CE            Sound - previous tone finished
***********************************************************
SCRNBS EQU  >02E0             Screen base addr for last lin
ENDSCR EQU  >02FE             END of SCReen address
SPRSAL EQU  >0300             Sprite attribute list
LODFLG EQU  >0371             Auto-boot flag
START  EQU  >0372             Line to start execution at
* Temporary
NOTONE EQU  >0374             NO-TONE for SIZE in ACCEPT us
*                              in FLMGRS (4 bytes used)
SYMBOL EQU  >0376             Saved symbol table pointer
ONECHR EQU  >0378             Used for CHRZ
VRMSND EQU  >0379             Sound blocks
SPGMPT EQU  >0382             Saved PGMPTR for continue
SBUFLV EQU  >0384             Saved BUFLEV for contiue
SEXTRM EQU  >0386             Saved EXTRAM for continue
SAVEVP EQU  >0388             Saved VSPRT for continue
ERRLN  EQU  >038A             On-error line pointer
CSNTMP EQU  >0390             Use as temporary stored place
*                          or CSN TEMPORARY FOR FAC12
TABSAV EQU  >0392             Saved main symbol table ponte
AUTTMP EQU  >0394             AUTOLD TEMPORARY IN SIDE ERRZ
SLSUBP EQU  >0396             Saved LSUBP for continue
SFLAG  EQU  >0398             Saved on-warning/break bits
SSTEMP EQU  >039A             To save subprogram program ta
SSTMP2 EQU  >039C             Same as above. Used in SUBPRO
MRGPAB EQU  >039E             MERGEd temporary for pab ptr
RNDX2  EQU  >03A0             Random number generator seed
RNDX1  EQU  >03A5             Random number generator seed
INPUTP EQU  >03AA             INPUT TEMPORARY FOR PTR TO PR
SPNUM  EQU  >03AA             Sprite number temporary, also
*                              in INPUTP in FLMGR
ACCVRW EQU  >03AC             Temoporary used in ERRZZ, als
*                              used in FLMGRS
*                             or temporary for @VARW, @VARA
ACCVRA EQU  >03AE             TRY AGAIN
VALIDP EQU  >03B0             Use as two values passing fro
*                          or PTR TO STANDARD STRING IN VAL
VALIDL EQU  >03B2             VALIDATE code to READL1
*                          or Length of string in validate
SIZCCP EQU  >03B4             SIZE TEMPORARY FOR CCPADR
SIZREC EQU  >03B6             SIZE TEMPORARY FOR RECLEN
*
ACCTRY EQU  >03B7             ACCEPT "TRY AGAIN" FLAG
SIZXPT EQU  >03B8             Save XPT in SIZE when "try ag
CSNTP1 EQU  >03BA             CSN TEMPORARY FOR FAC10
*
OLDTOP EQU  >03BC             Temporary used in ERRZZ, also
*                          or Old top of memory for RELOCA
CPTEMP EQU  >03BC             CCPPTR, RECLEN temp in INPUT
NEWTOP EQU  >03BE             New top of memory for RELOCA
VROAZ  EQU  >03C0             Temporary roll-out area
SPRVB  EQU  >07FF             Sprite velocity block.
CRNBUF EQU  >0820             CRuNch BUFfer address
CRNEND EQU  >08BE             CRuNch buffer END
VRAMVS EQU  >0958             Default base of value stack
***********************************************************
*    IMMEDITATE VALUES
NUMBR  EQU  >00               NUMERIC validate
LISTZ  EQU  >02
X2     EQU  >03
OLDZ   EQU  >05
RESEQZ EQU  >06
SAVEZ  EQU  >07
MERGEZ EQU  >08
DWNARR EQU  >0A
UPARR  EQU  >0B
CHRTN  EQU  >0D
BKGD   EQU  >20               BACKGROUND CHARACTER
OFFSET EQU  >60               OFFSET FOR VIDEO TABLES
STRVAL EQU  >65               Value in accum. is string val
***********************************************************
* Editting command equates & keys or symbols
BREAK  EQU  >02               Break key
DLETE  EQU  >03               Delete key
INSRT  EQU  >04               Insert key
RECALL EQU  >06               Edit-buffer recall
CLRLN  EQU  >07               Clear-line key
BACK   EQU  >08               Back-space key
FORW   EQU  >09               Forward-space key
DOWN   EQU  >0A               Down-arrow key
UPMV   EQU  >0B               Up-arrow key
VWIDTH EQU  >1C               Screen width (PRINT)
SPACE  EQU  >20               Space key
QUOTE  EQU  >22               "
NUMBER EQU  >23               #
DOLLAR EQU  >24               \$
CURSOR EQU  >1E+OFFSET        CURSOR
EDGECH EQU  >1F+OFFSET        EDGE character
PLUS   EQU  >2B               +
COMMAT EQU  >2C               ,
MINUS  EQU  >2D               -
HYPEN  EQU  >2D               +
PERIOD EQU  >2E               .
ZERO   EQU  >30               0
NINE   EQU  >39               9
COLON  EQU  >3A               :
SEMICO EQU  >3B               ;
LESS   EQU  >3C               <
GREAT  EQU  >3E               >
A      EQU  >41               A
F      EQU  >46               F
***********************************************************
*    BASIC TOKEN TABLE
*      EQU  >80               spare token
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               ::
TREMZ  EQU  >83               \$
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
RETURZ EQU  >88               RETURN
DEFZ   EQU  >89               DEF
DIMZ   EQU  >8A               DIM
ENDZ   EQU  >8B               END
FORZ   EQU  >8C               FOR
LETZ   EQU  >8D               LET
BREAKZ EQU  >8E               BREAK
UNBREZ EQU  >8F               UNBREAK
TRACEZ EQU  >90               TRACE
UNTRAZ EQU  >91               UNTRACE
INPUTZ EQU  >92               INPUT
DATAZ  EQU  >93               DATA
RESTOZ EQU  >94               RESTORE
RANDOZ EQU  >95               RANDOMIZE
NEXTZ  EQU  >96               NEXT
STOPZ  EQU  >98               STOP
DELETZ EQU  >99               DELETE
REMZ   EQU  >9A               REM
ONZ    EQU  >9B               ON
PRINTZ EQU  >9C               PRINT
CALLZ  EQU  >9D               CALL
OPTIOZ EQU  >9E               OPTION
OPENZ  EQU  >9F               OPEN
CLOSEZ EQU  >A0               CLOSE
SUBZ   EQU  >A1               SUB
DISPLZ EQU  >A2               DISPLAY
IMAGEZ EQU  >A3               IMAGE
ACCEPZ EQU  >A4               ACCEPT
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
SUBXTZ EQU  >A7               SUBEXIT
SUBNDZ EQU  >A8               SUBEND
RUNZ   EQU  >A9               RUN
LINPUZ EQU  >AA               LINPUT
*      EQU  >AB               spare token (LIBRARY)
*      EQU  >AC               spare token (REAL)
*      EQU  >AD               spare token (INTEGER)
*      EQU  >AE               spare token (SCRATCH)
*      EQU  >AF               spare token
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
STEPZ  EQU  >B2               STEP
COMMAZ EQU  >B3               ,
SEMICZ EQU  >B4               ;
COLONZ EQU  >B5               :
RPARZ  EQU  >B6               )
LPARZ  EQU  >B7               (
CONCZ  EQU  >B8               &          (CONCATENATE)
*      EQU  >B9               spare token
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQUALZ EQU  >BE               =
LESSZ  EQU  >BF               <
GREATZ EQU  >C0               >
PLUSZ  EQU  >C1               +
MINUSZ EQU  >C2               -
MULTZ  EQU  >C3               *
DIVIZ  EQU  >C4               /
CIRCUZ EQU  >C5               ^
*      EQU  >C6               spare token
STRINZ EQU  >C7               QUOTED STRING
UNQSTZ EQU  >C8               UNQUOTED STRING
NUMZ   EQU  >C8               ALSO NUMERICAL STRING
NUMCOZ EQU  >C8               ALSO UNQUOTED STRING
LNZ    EQU  >C9               LINE NUMBER CONSTANT
*      EQU  >CA               spare token
ABSZ   EQU  >CB               ABS
ATNZ   EQU  >CC               ATN
COSZ   EQU  >CD               COS
EXPZZ  EQU  >CE               EXP
INTZ   EQU  >CF               INT
LOGZ   EQU  >D0               LOG
SGNZZ  EQU  >D1               SGN
SINZ   EQU  >D2               SIN
SQRZ   EQU  >D3               SQR
TANZ   EQU  >D4               TAN
LENZ   EQU  >D5               LEN
CHRZZ  EQU  >D6               CHR\$
RNDZ   EQU  >D7               RND
SEGZZ  EQU  >D8               SEG\$
POSZ   EQU  >D9               POS
VAL    EQU  >DA               VAL
STRZZ  EQU  >DB               STR\$
ASCZ   EQU  >DC               ASC
PIZ    EQU  >DD               PI
RECZ   EQU  >DE               REC
MAXZ   EQU  >DF               MAX
MINZ   EQU  >E0               MIN
RPTZZ  EQU  >E1               RPT\$
*      EQU  >E2               unused
*      EQU  >E2               unused
*      EQU  >E3               unused
*      EQU  >E4               unused
*      EQU  >E5               unused
*      EQU  >E6               unused
*      EQU  >E7               unused
NUMERZ EQU  >E8               NUMERIC
DIGITZ EQU  >E9               DIGIT
UALPHZ EQU  >EA               UALPHA
SIZEZ  EQU  >EB               SIZE
ALLZ   EQU  >EC               ALL
USINGZ EQU  >ED               USING
BEEPZ  EQU  >EE               BEEP
ERASEZ EQU  >EF               ERASE
ATZ    EQU  >F0               AT
BASEZ  EQU  >F1               BASE
*      EQU  >F2               spare token (TEMPORARY)
VARIAZ EQU  >F3               VARIABLE
RELATZ EQU  >F4               RELATIVE
INTERZ EQU  >F5               INTERNAL
SEQUEZ EQU  >F6               SEQUENTIAL
OUTPUZ EQU  >F7               OUTPUT
UPDATZ EQU  >F8               UPDATE
APPENZ EQU  >F9               APPEND
FIXEDZ EQU  >FA               FIXED
PERMAZ EQU  >FB               PERMANENT
TABZ   EQU  >FC               TAB
NUMBEZ EQU  >FD               #
VALIDZ EQU  >FE               VALIDATE
*      EQU  >FF               ILLEGAL VALUE
*****************************************************
***********************************************************
* NOTE: FILES EXECSD, SUBS AND PART OF PSCANS ARE IN GROM 5
*       AS BELOW:
*      EXECS                  >A000 - >AD92        5
*      SUBS                   >AD98 - >B4DC        2
*      PSCANS                 >B4E0 - >B7FA        5
*
* Some of the error calls at the end of EXECS file are
* shared and directly addressed by SUBS file. Any change in
* EXECS file which affects the address of error calls will
* affect error reference in SUBS file. Make sure to edit
* SUBS file in that situation.
***********************************************************
XML  CONT              XML CONT used by subprogram
BR   LITS05            Build FAC entry and GETSTR
BR   EXEC              Execute a program
BR   LINE
BR   DATAST
BR   ASC
BR   EXEC1
BR   EXEC6D            Save information on a break
BR   CONV1
BR   SQUISH            Called in error routine in PS
BR   VALCD
BR   INTRND
BR   \$
GA01C  BR   LNKRTN            Routine to go back to XB prog
GA01E  BR   SPCOL             Clear breakpoint in line # ro
BR   UBSUB             Spare
BR   \$
*                     ***     branches here since it will a
STRI 'SOUND'           SOUND
DATA XSOUND
STRI 'CLEAR'           CLEAR
DATA CLEAR
STRI 'COLOR'           COLOR
DATA COLOR
STRI 'GCHAR'           GCHAR
DATA GCHAR
STRI 'HCHAR'           HCHAR
DATA HCHAR
STRI 'VCHAR'           VCHAR
DATA VCHAR
STRI 'CHAR'            CHAR
DATA CHARLY
STRI 'KEY'             KEY
DATA ZKEY
STRI 'JOYST'           JOYST
DATA ZJOYST
STRI 'SCREEN'          KEY
DATA BORDER
STRI 'VERSION'         VERSION
DATA VERS
STRI 'ERR'             ERR
DATA ERRWXY
***********************************************************
*        START EXECUTION OF A PROGRAM OR STATEMENT
* DATA:
*      RAM(START) points into line number table at the
*      first line to execute
*      @PGMFLG contains >FF if executing a program or zero
*      if imperative statement
***********************************************************
EXEC   CZ   @PRGFLG           If program
BS   GA0AE
DST  [email protected],@EXTRAM   Line to start execution at
DINCT @EXTRAM          Pointer to text pointer
CALL INTRND            Initialize random number
EXEC1  ST   X2,@XPT           Initialize screen display
BR   GA0B2
GA0AE  DST  CRNBUF,@PGMPTR    Executing out of crunch buffe
GA0B2  DST  EXEC20,@RTNG      Address of return from ALC
DST  NUDTB,@NUDTAB     NUD table address for ALC
XML  EXECG             Execute XB
EXEC20 CASE @ERRCOD+1         Check type of return
BR   EXECND            0 - NORMAL END
BR   EXECBK            1 - BREAKPOINT
BR   EXECTR            2 - TRACE
BR   ERORZ             3 - ERROR
BR   WARNGZ            4 - WARNING
BR   ONERR             5 - ON ERROR
BR   UDF               6 - FUNCTION
BR   ONBRK             7 - ON BREAK
BR   CONCAT            8 - CONCATENATE STRINGS "&"
BR   ONWARN            9 - ON WARNING
BR   GPLCAL            A - CALL STATEMENT
WARNGZ CH   >B0,@SUBSTK
BS   ERRSO
* Stack overflow
*                    ALLOW ROOM ON STACK FOR WARNING CALLS
WRNN01 CALL WARNZZ        ONLY WARNING MSG FROM XB SUPPORT
BYTE 2       *         NUMERIC OVERFLOW
BR   CLRRTN            Clear ERRCOD and return
*                    NORMAL END OF EXECUTION
EXECND CZ   @PRGFLG           If imperative mode
BR   ERRRDY
CALL CHRTAB            Load the default character se
ERRRDY CALL ERRZZ             Display * READY *
BYTE 0
* TRACE-MODE turned on - display line number
EXECTR CLR  @VARW             Clear upper address byte
ST   @XPT,@VARW+1      Get current x-pointer
DCH  NLNADD+22,@VARW   If might go off screen
BR   GA102
XML  SCROLL            SCROLL to next line
GA102  ST   LESS+OFFSET,V*VARW Display open bracket "("
CALL ASC               Convert line # into ASCII
ST   GREAT+OFFSET,V*VARW Display close bracket ")"
ST   @VARW+1,@XPT
CLRRTN DCLR @ERRCOD           Clear the return vector
* BREAKPOINT OR BREAK-KEY RECIEVED
EXECBK CZ   @PRGFLG           If break or program
BS   ERRBRK
DST  @EXTRAM,@FAC8     @FAC8 : Source addr in ERAM
DDECT @FAC8            Point to the line #
CALL UBSUB1            Reset the breakpoint
SCAN                   Get break key out of queue
EXEC6C DST  @PGMPTR,[email protected]  Save text pointer
EXEC6D DST  @EXTRAM,[email protected]  Save line number table pointe
DST  @VSPTR,[email protected]   Save value stack pointer
DST  @BUFLEV,[email protected]  Save crunch buffer level
DST  @LSUBP,[email protected]   Save last subprogram on stack
ST   @FLAG,[email protected]     Save FLAG for continue
AND  >63,[email protected]       Only warning and break bits
ERRBRK CALL ERRZZ             * BREAKPOINT
BYTE 1
***********************************************************
*               NUD / STATEMENT BRANCH TABLE
***********************************************************
NUDTB  BR   RECX              'RECORD'              0
BR   NBREAK            'BREAK'               0
BR   NUNBRK            'UNBREAK'             0
BR   NTRACE            'TRACE'               0
BR   NUNTRC            'UNTRACE'             0
BR   PRINTX            'PRINT'               0
BR   SZRUNX            'RUN'                 0
BR   LINPUX            Reserved for LINPUT   1
BR   RESTOX            'RESTORE'             1
BR   NRNDMZ            'RANDOMIZE'           1
BR   INPUTX            'INPUT'               1
BR   OPENX             'OPEN'                1
BR   CLOSEX            'CLOSE'               1
BR   NPI               'PI'                  1
BR   NMAX              'MAX'                 1
BR   NMIN              'MIN'                 2
BR   RPTZ01            'RPT\$'                2
BR   ACCEPX            'ACCEPT'              2
BR   EOFX              'EOF'                 2
BR   ASC01             'ASC'                 2
BR   POS01             'POS'                 2
BR   VAL01             'VAL'                 2
BR   STRZ01            'STR\$'                2
BR   SEGZ01            'SEG\$'                3
BR   DELETX            'DELETE'              3
BR   DISPLX            'DISPLAY'             3
BR   LEN01             'LEN'                 3
BR   CHRZ01            'CHR\$'                3
*RXB PATCH CODE FOR BASIC RND REPLACEMENT ***********
BR   NRND              'RND'                 3
* The following are long branches to another GROM
EOFX   B    EOF
SZRUNX B    SZRUN
RECX   B    REC
PRINTX B    PRINT
RESTOX B    RESTOR
INPUTX B    INPUT
OPENX  B    OPEN
CLOSEX B    CLOSE
ACCEPX B    ACCEPT
DISPLX B    DISPL1
DELETX B    DELET
LINPUX B    LINPUT
***********************************************************
* FLAGS USED IN EXECUTION MODE:    this needs to be checked
*  @FLAG   BIT   RESET               SET
*           0
*           1    Warning PRINT       PRINT off
*           2    Warning NEXT        STOP
*           3    Not in UDF          Executing a UDF
*           4    TRACE mode          Normal mode
*           5
*           6    BREAK allowed       BREAK not allowed
*           7    No LST/EDT protect  LIST/EDIT protected
***********************************************************
* ON WARNING {NEXT | STOP | PRINT}
* ON WARNING NEXT  - Causes warning messages to be ignored
*                    and execution to continue as if a
*                    warning never occurred
* ON WARNING STOP  - Causes a warning to be treated as an
*                    error - i.e. the message is displayed
*                    and execution is halted
* ON WARNING PRINT - Causes the default warning handling to
*                    be in effect, i.e. any warning
*                    messages are printed and execution
*                    continues
***********************************************************
ONWARN XML  PGMCHR            GET OPTION
CEQ  PRINTZ,@CHAT      If print
BR   GA1B7
AND  >F9,@FLAG         Turn on print and contiue
B    ONWRN5
GA1B7  CEQ  STOPZ,@CHAT
BR   GA1C4
AND  >FD,@FLAG         Turn on print
OR   >04,@FLAG         Turn on stop
BR   ONWRN5
GA1C4  CEQ  NEXTZ,@CHAT       * SYNTAX ERROR
BR   ERRSYN
OR   >02,@FLAG         Turn off print
AND  >FB,@FLAG         Turn off stop
ONWRN5 XML  PGMCHR            Check for EOS
ONWRN7 CALL CHKEND            Error if not EOS
BR   ERRSYN            If not EOS
DCLR @ERRCOD
XML  CONT              Continue
***********************************************************
* ON ERROR {line number | STOP}
* ON ERROR line number - causes the error routine to build
*                        an error stack entry and pass
*                        control to the line specified in
*                        the most-recently executed
*                        on-error-statement
* ON ERROR STOP - causes the default error handling
*                 conditions to be in effect. i.e. any
*                 errors that occur cause execution to halt
*                 an a message to be displayed
***********************************************************
ONERR  XML  PGMCHR            Get option
CEQ  LNZ,@CHAT         If line # then find the line
BR   GA20E
XML  PGMCHR            Get upper byte
ST   @CHAT,@FAC
XML  PGMCHR            Get lower byte
ST   @CHAT,@FAC1
DST  @ENLN,@FAC2
DSUB 3,@FAC2           Pointing to 1st line #
* Consider both ERAM and RAM cases to get line # from the
* line number table. Also reset the break bit.
ONERR2 CALL GRSUB3            Get 2 bytes from either RAM/E
BYTE FAC2            * FAC2 has the address
DCEQ @EEE1,@FAC        If found
BS   ONERR4
BR   ERRLNF
DSUB 4,@FAC2           Goto next line
BR   ONERR2
ONERR4 DINCT @FAC2
DST  @FAC2,[email protected]
BR   GA216
GA20E  CEQ  STOPZ,@CHAT       * SYNTAX ERROR
BR   ERRSYN
DCLR [email protected]           Back to default error handlin
GA216  BR   ONWRN5            Finish up same as ON WARNING
***********************************************************
* ON BREAK {NEXT | STOP}
* ON BREAK NEXT - Causes any breakpoints which have been
*                 set on statements to be ignored when the
*                 statement is encountered and also masks
*                 the shift-C key so that it is ignored
* ON BREAK STOP - Causes the default break handling to be
*                 in force., i.e. execution is halted and
*                 the BREAKPOINT message is displayed on
*                 the screen
***********************************************************
ONBRK  XML  PGMCHR            Get next char to find option
CEQ  STOPZ,@CHAT       If stop option specified
BR   GA225
AND  >BF,@FLAG         break allowed
B    GA22D             Don't change this to BR GA22D
GA225  CEQ  NEXTZ,@CHAT       If next option number
BR   ERRSYN            specified then syntax error
OR   >40,@FLAG         If next option specified then
*                              break NOT allowed
GA22D  BR   ONWRN5            Finish up same as ON WARNING
***********************************************************
* GPLCAL - If a call is made to a subprogram that does not
*  not exist either in the BASIC program itself or in the
*  internal GPL subprogram list then one final attempt is
*  made to find the subprogram at execution time by
*  searching for the subprogram in the console or a
*
*  Input: the subprogram name is in the FAC and the length
*         of the name is in FAC15
***********************************************************
GPLCAL CZ   @RAMFLG           Can't try if CPU program
BR   ERRSNF
DSRL 8,@FAC15          Make name length a double
DSUB @FAC15,@PGMPTR    Point back at name
DDEC @PGMPTR           Point at name length
DST  @PGMPTR,@FAC12    Set pointer to name
BYTE 10              * Search subprogram lists
BR   ONWRN7            If all ok, check-end and rtn
***********************************************************
*                     NUD FOR PI
***********************************************************
NPI    MOVE 8,[email protected],@FAC    Load constant PI
XML  CONT
CONPI  BYTE >40,3,14,15,92,65,35,90
* 3.1415992653590E+00
***********************************************************
*                     NUD FOR MAX
***********************************************************
NMAX   CALL MAXMIN            Combine MAX and MIN
GT
BR   GA263
NMAXZ1 MOVE 8,@ARG,@FAC
GA263  XML  CONT
***********************************************************
*                     NUD FOR MIN
***********************************************************
NMIN   CALL MAXMIN            Combine MAX and MIN again
GT
BR   NMAXZ1
XML  CONT
***********************************************************
*                COMMON MAX / MIN ROUTINE
***********************************************************
MAXMIN CALL LPAR              Skip "(" parse, and insure ,
CH   >63,@FAC2         Must be numeric
BS   ERRSNM
XML  VPUSH             Push l.h. arg on stack
XML  PARSE             PARSE up to ")"
BYTE RPARZ
CH   >63,@FAC2         Must be numeric
BS   ERRSNM
XML  SPEED             Must be
BYTE SYNCHK        *    at a
BYTE RPARZ         *      right parenthesis
MOVE 8,@FAC,@ARG       Save in ARG for compare
XML  VPOP              Get l.h. arg back
XML  FCOMP             Compare operands
RTN
* Initialize random number generator
INTRND MOVE 10,[email protected],[email protected]
RTN
X2SEED BYTE >42,>03,>23,>15,>00 * =   33521, X2 INITIAL VAL
X1SEED BYTE >43,>02,>3E,>2A,>17 * = 2624223, X1 INITIAL VAL
***********************************************************
*                                                         *
* RXB PATCH REPLACEMENT CODE FOR RND WITH TI BASIC RND    *
*                                                         *
***********************************************************
*           PSEUDO-RANDOM NUMBER GENERATOR
*      X(N+1) = (A*X(N)+C) MOD M;  RND = X/M
*    WHERE:                 X = X2 * 1E7 + X1
*                           A = A2 * 1E7 + A1
*                           C = C2 * 1E7 + C1
*                           M = 1E14
* ASSUMPTIONS:
*  (1) All numbers are integers; fractional parts are
*      truncated
*  (2) If the variables listed below start in the ranges
*     specified. They will also end in the ranges specified
*
* CONSTANTS: 0 <= A2 < 5E6 ; 0 <= C2 < 1E7
*            0 <= A1 < 5E6 ; 0 <= C1 < 1E7
* VARIABLES: 0 <= X2 < 1E7 ; 0 <= T1 <= 1E14 ; 0 <= T2 < 1E
*            0 <= X1 < 1E7 ; 0 <= T3 <= 1E14 ; 0 <= T4 < 1E
*
*        STACK USAGE:
*            CONSTANT REFS      CONTANT REFS    CONTANT REF
* +---------+      IN/OUT            IN/OUT          IN/OUT
* | STACK+4 | X2*A1(F)(H)       --    ----      --    ----
* +---------+
* | STACK+3 |   T2 (C)(J)       --    ----      --    ----
* +---------+
* | STACK+2 |   T1 (B)(D)   new X1   (E)(N)     --    ----
* +---------+
* | STACK+1 |old X1(A)(G)       T3   (K)(L) new X2   (M)(P)
* +---------+
***********************************************************
* COMPUTE NEW VALUE FOR X1, SAVE IT IN [email protected]
*                             STACK
*                               SREFS   FAC CONTENTS
* NRND   MOVE 5,[email protected],@FAC        FAC = X1
*        MOVE 5,[email protected],@FAC        fAC = X1
*        CLR  @FAC5                 FAC = CLR
*        DCLR @FAC6                 FAC = CLR
*        XML  VPUSH          (A)    FAC = X1
*        MOVE 8,[email protected],@ARG        ARG = A1
*        XML  FMUL                  FAC = X1*A1
*        MOVE 8,[email protected],@ARG        ARG = C1
*        XML  FADD               T1=FAC = X1*A1+C1
*        XML  VPUSH          (B)    FAC = T1
*        MOVE 8,[email protected],@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = T1/1E7
*        CALL GRINT              T2=FAC = INT(T1/1E7)
*        XML  VPUSH          (C)    FAC = T2
*        MOVE 8,[email protected],@ARG        ARG = 1E7
*        XML  FMUL                  FAC = T2*1E7
*        DSUB 8,@VSPTR
*        XML  SSUB           (D) X1=FAC = T1-T2*1E7
*        MOVE 5,@FAC,[email protected]        FAC = X1 (new)
*        XML  VPUSH          (E)    FAC = X1
* COMPUTE NEW VALUE FOR X2, SAVE IT IN [email protected]
*        MOVE 5,[email protected],@FAC        FAC = X2
*        CLR  @FAC5                 FAC = CLR
*        DCLR @FAC6                 FAC = CLR
*        MOVE 8,[email protected],@ARG        ARG = A1
*        XML  FMUL                  FAC = X2*A1
*        XML  VPUSH          (F)    FAC = X2*A1
*        DSUB 24,@VSPTR
*        XML  VPOP           (G)    FAC = X1
*        MOVE 8,[email protected],@ARG        ARG = A2
*        XML  FMUL                  FAC = X1*A2
*        XML  SADD           (H)    FAC = X2*A1+X1*A2
*        MOVE 8,[email protected],@ARG        ARG = C2
*        XML  FADD                  FAC = X2*A1+X1*A2
*        XML  SADD           (J) T3=FAC = X2*A1+X1*A2
*        DSUB 16,@VSPTR
*        XML  VPUSH          (K)    FAC = T3
*        MOVE 8,[email protected],@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = T3/1E7
*        CALL GRINT              T4=FAC = INT(T3/1E7)
*        MOVE 8,[email protected],@ARG        ARG = 1E7
*        XML  FMUL                  FAC = T4*1E7
*        XML  SSUB           (L) X2=FAC = T3-T4*1E7
*        MOVE 5,@FAC,[email protected]        FAC = X2 (new)
* COMPUTE NEW VALUE FOR RND, LEAVE IT IN FAC
*        MOVE 8,[email protected],@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = X2/1E7
*       XML  VPUSH          (M)    FAC = X2/1E7
*        XML  VPOP           (N)    FAC = X1
*        XML  FMUL                  FAC = X1/1E7
*        XML  FMUL                  FAC = X1/1E14
*        XML  SADD           (P)RND=FAC = (X2/1E7)+(X1/1E14)
*        XML  CONT
***********************************************************
* CONSTANTS FOR THE RANDOM NUMBER ROUTINE
* RNDA2  BYTE >43,>01,>2B,>59,>52,>00,>00,>00 * = 1438982
* RNDA1  BYTE >42,>2A,>08,>15,>00,>00,>00,>00 * = 0420821
* RNDC2  BYTE >43,>02,>0B,>20,>30,>00,>00,>00 * = 2113248
* RNDC1  BYTE >43,>06,>36,>05,>13,>00,>00,>00 * = 6540519
RNDEP  BYTE >43,>0A,>00,>00,>00,>00,>00,>00 * = 1E7
RNDEM  BYTE >3C,>0A,>00,>00,>00,>00,>00,>00 * = 1/1E7
***********************************************************
* RXB BASIC RND REPLACEMENT FROM TI BASIC
NRND   ST   >3F,@FAC       * Exponent
ST   >4B,@VAR5      * Loop counter
NRND1  RAND >63            * 0?
CZ   @RANDOM        * No, go on
BR   NRND3
DEC  @FAC           * 0?
CZ   @FAC           * End with 0
BS   NRND4          * Go on
BR   NRND1
NRND2  RAND >63            * Till 100
NRND3  ST   @RANDOM,*VAR5  * All digits
CEQ  >51,@VAR5      * Till >8351
BS   NRND5
INC  @VAR5          * Increase loop counter
BR   NRND2
NRND4  CLR  @FAC1          * Set 0
NRND5  XML  CONT
************************************************************
STRFCH XML  PGMCHR
XML  PARSE
BYTE RPARZ
RTN
STRGET CALL STRFCH
CEQ  >65,@FAC2
BR   ERRSNM      * STRING NUM MISMATCH
RTN
NUMFCH CALL STRFCH
CEQ  >65,@FAC2
BS   ERRSNM      * STRING NUM MISMATCH
RTN
CFIFCH XML  CFI
CEQ  >03,@FAC+10
BS   ERRBV       * NUMERIC OVERFLOW
RTN
GETNUM CALL SUBLP3
CEQ  >B3,@CHAT
BR   ERRSYN
RTN
ROWCOL CALL GETNUM
DCGT 24,@FAC
BS   ERRBV
DDEC @FAC
ST   @XPT,@MNUM
ST   @FAC1,@YPT
CALL GETNUM
DCGT 32,@FAC
BS   ERRBV
DDEC @FAC
ST   @FAC1,@XPT
RTN
NGOOD  XML  PGMCHR
NGOOD1 CHE  >80,@CHAT
BS   ERRSYN         * ?
CALL SNDER
CEQ  >65,@FAC2
BR   ERRSNM         * STRING NUMBER MISMATCH
DST  >001C,@FAC
DST  @SREF,@FAC4
DST  @BYTES,@FAC6
BR   SNDASS
SNDER  XML  SYM
XML  SMB
XML  VPUSH
RTN
CIFSND XML  CIF
SNDASS XML  ASSGNV
RTN
GETLP  ST   @CB,@VAR0
ST   @CB,@VARV
SUB  OFFSET,@VARV
ST   @VARV,[email protected](@STRPTR)
DINC @STRPTR
RTN
PUTLP  ST   [email protected](@FAC4),@VAR0
DINC @FAC4
RTN
HFMT   FMT
DATA >E000
FEND
RTN
VFMT   FMT
DATA >E000
BYTE >9E
FEND
RTN
SUBLP3 CALL NUMFCH
CALL CFIFCH
RTN
CLRFAC CLR  @FAC
MOVE 7,@FAC,@FAC1
RTN
***********************************************************
*
* RXB PATCH CODE TO RESET ADDRESS FOR NRNDMZ **************
B    NRNDMZ
***********************************************************
*                   RANDOMIZE STATEMENT
***********************************************************
NRNDMZ CALL CHKEND            Seed provider?
BS   RNDM1             No
* RANDOMIZE given a see value
* (99,000,000,000,001 possible starting positions)
* (Place-value is ignored in the input number)
XML  PARSE             Parse the seed
BYTE TREMZ           * Up to end of statement
CALL CKSTNM
DCZ  @FAC              Check FAC for zero
BS   GA3B6
ST   >46,@FAC          0 < FAC < 1E14
XML  VPUSH             Let FAC = X2*1E7+X1
MOVE 8,[email protected],@ARG        ARG = 1/1E7
XML  FMUL                  FAC = X2+X1/1E7
CALL GRINT                 FAC = X2
MOVE 5,@FAC,[email protected]        FAC = X2
MOVE 8,[email protected],@ARG        ARG = 1E7
XML  FMUL                  FAC = X2*1E7
XML  SSUB                  FAC = X1
MOVE 5,@FAC,[email protected]        FAC = X1
XML  CONT                  FAC = X1
GA3B6  DST  @FAC,[email protected]          FAC = 0
DST  @FAC,[email protected]          FAC = 0
XML  CONT
* RANDOMIZE given number seed value (use GPL RAND function)
* (16K possible starting positions)
RNDM1  DST  >4201,@FAC            FAC = >4201
CLR  @FAC4                 FAC4= >00
CALL RNDMZ
DATA RNDX1
CALL RNDMZ             Set up seed
DATA RNDX2
XML  CONT              Continue on
RNDMZ  FETCH @FAC8            Fetch address of seed (high b
FETCH @FAC9            Fetch address of seed (low by
RAND 99                GPL Randomize
ST   @RANDOM,@FAC2     >00<=FAC+2<=FF
SRL  2,@FAC2           >00<=FAC+2<=3F
RAND 99                GPL Randomize
ST   @RANDOM,@FAC3     >00<=FAC+3<=FF
SRL  2,@FAC3           >00<=FAC+3<=3F
MOVE 5,@FAC,V*FAC8     Put in seed
RTN
CKSTNM CEQ  >65,@FAC2
BS   ERRSNM
RTN
FLT1   BYTE >40,>01,>00,>00,>00,>00,>00,>00
***********************************************************
*                 EXTENDED STRING PACKAGE
* THE ROUTINES ARE:
*  LITS05 - Move a string literal from the program to the
*            string space
*  INTARG - Checks that an argument is a numeric and
*            converts it from floating point to an integer
*  PUSSTR - Checks that an argument is a string and pushes
*            it on the stack
*  CONCAT - Concatenates 2 strings together
*  SEG\$   - Segments a string
*  LEN    - Puts the length of a string in the FAC
*  CHR\$   - Converts an integer into its ASCII character
*  STR\$   - Converts a number into its string equivalent
*  VAL    - Converts a string into its numeric equivalent
*  POS    - Gives the position of one string within another
*  RPT\$   - Generates a single string with multiple copies
*            of the original string
*
*      AN ENTRY IN THE FAC LOOKS LIKE:
* +------------+-----+----+-------------+-----------------+
* |addr of ptr | >65 | xx | addr of str | length of str   |
* +------------+-----+----+-------------+-----------------+
*     FAC       FAC2  FAC3   FAC4           FAC6
***********************************************************
* Support routine for functions to build FAC entry
LITS05 CLR  @FAC6             Need as a double-byte value
DST  @FAC6,@BYTES      LENGTH FOR GETSTR
ST   @RAMTOP,@FAC8     Copy ERAM flag for later
LITS07 XML  GETSTR            ALLOCATE STRING SPACE
LITS08 DST  >001C,@FAC        SAVE ADDR OF STRING  (SREF)
DST  @SREF,@FAC4       SAVE ADDR OF STRING
DST  >6500,@FAC2       INDICATES A STRING CONSTANT
*********** COPY STRING INTO STRING SPACE *****************
LITS09 DCZ  @BYTES            If non-null string
BS   GA42B
CZ   @FAC8
BR   GA420
MOVE @BYTES,V*TEMP5,V*SREF
RTN
*                             Else source string in ERAM
GA420  DST  @BYTES,@FFF1      FFF1 : BYTE COUNT
DST  @SREF,@EEE1       EEE1 : DESTINATION ADDR ON VD
DST  @TEMP5,@DDD1      DDD1 : Source addr in ERAM
XML  GVWITE            Move data from ERAM to VDP
GA42B  RTN
LITS06 CLR  @FAC8             SET FLAG TO VDP
BR   LITS07            JUMP INTO CODE
***********************************************************
* PUSSTR - Insures that the entry in the FAC is a string
*           and pushes it onto the stack.
***********************************************************
PUSSTR CEQ  >65,@FAC2
BR   ERRSNM
XML  VPUSH             PUSH THE ARGUMENT
RTN
***********************************************************
* CONCAT - CONCATENATES TWO STRINGS TOGETHER
*         INPUT  : FLOATING POINT ACCUMULATOR ENTRIES
*         OUTPUT : CONCATENATED STRING AND (POSSIBLE)
*                  ZEROED BACK-POINTERS FOR THE OLD STRINGS
*         USES   : TEMP2, TEMP4 AND TEMP5 AS TEMPORARIES
***********************************************************
CONCAT CLR  @ERRCOD+1         CLEAR THE ERROR CODE
CALL PUSSTR            Push the string & get next to
XML  PARSE             GET THE R.H. ARGUMENT
BYTE CONCZ
CEQ  >65,@FAC2         If not string - error
BR   ERRSNM
DST  @FAC6,@BYTES      GET R.H. LENGTH
DCH  255,@BYTES
BR   GA45B
DST  255,@BYTES        TRUNCATE IF TOO LONG
WRNST1 CALL WARNZZ            Display warning
BYTE 19                * STRING TRUNCATED message
GA45B  DST  @BYTES,@TEMP6     Keep length for later
XML  VPUSH
XML  GETSTR            Alloccate the result string
XML  VPOP              Retrieve R.H.
MOVE 8,@FAC,@ARG
XML  VPOP              Retrieve L.H.
DST  @FAC4,@TEMP5      Set ptr to L.H. ARG(for FREST
DST  @FAC6,@BYTES      Length of L.H. ARG
CLR  @FAC8             Force VDP mode
CALL LITS08            Set up FAC & copy L.H. ARG in
DCZ  @ARG6             If R.H. =0 don't copy
BS   CONC06
DST  @SREF,@TEMP4      Get ptr to new string
DADD @FAC6,@TEMP4      Ptr to where 2nd string begin
DSUB @FAC6,@TEMP6      Length of 2nd string
*                                      (possibly truncated)
BS   CONC06
MOVE @TEMP6,V*ARG4,V*TEMP4     Copy in 2nd string

* NOTE: FAC6 already contained length of 1st ARG from the
*       parse that was done on it
CONC06 XML  CONT              Done.
***********************************************************
* SEG\$(A\$,X,Y) - Extracts the desiginated string from A\$.
*     X specifies the character position within A\$ at
*     which the extraction begins. Y specifies the number
*     of characters to extract.
*     If X or Y is negative an error occurs. If X=0 an
*     error occurs. If Y=0 or X > Y then a null string is
*     is returned. If the ramaining length in A\$ starting
*     at the postion specified by X is less than the length
*     specified by Y, then the remainder of A\$ starting at
*     position X is returned.
*   INPUT - Control is turned over to SEG\$ from PARSE. The
*     only requirement is that a SEG\$ was encountered.
*   OUTPUT - The Floating Point Accumulator is set up with
*     the header for the segmented string.
*   USES - TEMP2 (Others in calls to GETSTR and LITS08)
***********************************************************
SEGZ01 CALL LPAR              Insure "(" parse and check ",
CALL PUSSTR            Push string and get next toke
XML  SPEED             Get the position
BYTE PARCOM       *     within the source string
CALL INTARG            CHECK & CONVERT ARG TO INTEGE
DCZ  @FAC               CAN'T HAVE VALUE OF 0
BS   ERRBV
XML  VPUSH             PUSH THE ARG
XML  PARSE             Get extraction length
BYTE RPARZ
XML  SPEED             Must have
BYTE SYNCHK       *     ended on
BYTE RPARZ        *      a right parenthesis
CALL INTARG            CHECK & CONVERT ARG TO INTEGE
DST  @FAC,@ARG         Move extraction length
XML  VPOP              Get position back
DST  @FAC,@ARG2        Move position
XML  VPOP              Retrieve source string
DST  @ARG2,@TEMP2      Get position within string
DCH  @FAC6,@TEMP2      If position > length =>null
BS   SEGZ08
DADD @ARG,@TEMP2       Compute end of substring
DSUB @FAC6,@TEMP2      Compute length beyond end
DDEC @TEMP2             string
DCGE 0,@TEMP2
BR   SEGZ06            Fine if substring is shorter
DST  @FAC6,@ARG        Else, truncate length of
*                              substring
DSUB @ARG2,@ARG        Subtract position from source
*                              length
DINC @ARG              Increment to include last cha
SEGZ06 DST  @ARG,@BYTES       # of bytes needed for substri
XML  VPUSH             Save source string entry
XML  GETSTR            ALLOCATE RESULT STRING
XML  VPOP              Restore source string entry
DST  @FAC4,@TEMP5      Pointer to source for FRESTR
*                              LITS08
DADD @ARG2,@TEMP5      Pointer to start of substring
DDEC @TEMP5            Decrement since zero-based
DST  @BYTES,@FAC6      Set length of string
CLR  @FAC8             FORCE VDP MODE
CALL LITS08            Copy in & set up FAC
XML  CONT
SEGZ08 DCLR @ARG              Extract a null string
BR   SEGZ06            >>>JUMP ALWAYS<<<
***********************************************************
* LEN(A\$) - Calculate the length of a string and leave the
*           result in the FAC.
*  CONTROL - Turned over to NLEN from the parser.
*  USES    - No temporaries.
***********************************************************
LEN01  CALL PARFF             Insure left parenthesis & par
BR   ERRSNM             If not string value
DST  @FAC6,@FAC        Length
LEN02  XML  CIF               Convert integer to floating p
XML  CONT
***********************************************************
* CHR\$(X) - Takes integer value X and converts the number
*           into the ASCII representation for that number.
*  CONTROL - Turned over to NCHR by the parser.
*  OUTPUT  - FAC is set up with the string entry
*  USES    - Uses temproraries when invoking LITS06(LITSTR)
***********************************************************
CHRZ01 CALL PARFF             Insure left parenthesis & par
CALL INTARG            Convert into integer
DST  1,@BYTES          Create a length 1 string
ST   @FAC1,[email protected]    Move the value to VDP(for LIT
CALL LITS06            Create string and set up FAC
DST  1,@FAC6           Length of string
XML  CONT
***********************************************************
* ASC(A\$) - Takes the numeric value of the first character
*           in A\$.
***********************************************************
ASC01  CALL PARFF             Insure left parenthesis & par
BR   ERRSNM             If not string
BS   ERRBA
ST   V*FAC4,@FAC1      Get the first character
CLR  @FAC
BR   LEN02             USE COMMON CODE >>>JUMP ALWAY
***********************************************************
* STR\$(X) - Takes as its imput an integer X and converts it
*           to its string representation.
*  CONTROL - Turned over to STR\$ by the parser.
*  USES    - The usual temporaries used by string function
*            when it calls LITS06. Uses the Roll-out area
*            for a temporary storage area when allocating
*            the result string.
*  OUTPUT  - FAC is set up in the usual manner for a string
***********************************************************
STRZ01 CALL PARFF             Insure left parenthesis & par
BS   ERRSNM             If not numeric-error
CLR  @FAC11            Select XB floating type
XML  XCNS              Convert the number to string
BR   GA53E
INC  @FAC11            Suppress it out
DEC  @FAC12            Shorten the length
GA53E  CLR  @BYTES            Prepare for 2-byte value
ST   @FAC12,@BYTES+1   Get length of string
MOVE @BYTES,*FAC11,[email protected]    Put the string in VDP
CALL LITS06            Allocate and set up FAC
DST  @BYTES,@FAC6      Put in the length
XML  CONT
***********************************************************
* VAL(A\$) - Takes as its input a string, A\$, and converts
*           the string into a number if the string is a
*           valid representation of a number.
*  CONTROL - From the parser.
*  OUTPUT  - FAC contains the floating point number.
***********************************************************
VAL01  CALL PARFF             Insure left parenthesis & par
BR   ERRSNM             If not string - error
CZ   @FAC7             Can't have null string
BS   ERRBA
CALL VALCD             So bad argument error
BS   ERRBA
XML  CONT
* Short routine to parse a single argument enclosed in
*  parenthesis for a function or a subprogram and set
*  condition based upon whether the value parsed was a
*  string or a numeric.
PARFF  CEQ  LPARZ,@CHAT
BR   ERRSYN
XML  PARSE
BYTE >FF               *
CEQ  >65,@FAC2
RTNC
VALCD  DST  @FAC4,@TEMP5      Pointer to string
DADD @FAC6,@TEMP5      Pointer to trailing length by
DST  @FAC6,@BYTES      For suppressing trailing blan
DINC @BYTES            Prepare for undue subtraction
GA57C  DDEC @TEMP5            Keep track of end of string
DDEC @BYTES            Decrease length of string
BS   RTNSET            End up with empty string,
CEQ  SPACE,V*TEMP5     Wild trailing blanks
BS   GA57C
DINC @BYTES            Allow for terminator
XML  VPUSH             Save the ptr to the string
XML  GETSTR            Get a new string
XML  VPOP              Retrieve the ptr to the strin
DST  @FAC4,@TEMP5      Get the ptr to the string
CLR  @FAC8             Force VDP mode
CALL LITS09            Copy the string and set up FA
DADD @SREF,@BYTES      Point to the trailing length
DDEC @BYTES            Point at the last character
ST   SPACE,V*BYTES     Put in the terminator
DST  @SREF,@FAC12      Address for the conversion
GA5A4  CEQ  SPACE,V*FAC12     While leading spaces
BR   GA5AE
BR   GA5A4
GA5AE  CLR  @FAC2             Get rid of string (in case=0)
CLR  @FAC10            Assume no error
XML  CSNUM             Convert it
DCEQ @BYTES,@FAC12     Convert all of it?
BS   WRNNO             Yes, check overflow & return
RTNSET CEQ  @VAR0,@VAR0       No, return with condition set
RTNC
***********************************************************
* POS(A\$,B\$,X) - Attempts to match the string, B\$, in A\$
*    beginning at character # X in A\$. If X is > LEN(A\$), a
*    match is not found or A\$ is the null string then the
*    returned value is 0. If B\$ is the null string then the
*    returned value is 1. Otherwise, the returned value is
*    the column # of the 1st character matched in A\$
*  CONTROL - Fromn the parser. Returned through common code
*            IN LEN.
*  USES    - Not temporaries - Utilizes FAC and ARG.
***********************************************************
POS01  CALL LPAR              Insure "(", parse , insure ",
CALL PUSSTR            STACK THE STRING AND GET TOKE
XML  SPEED             Parse the match string and
BYTE PARCOM      *      insure end on comma
CALL PUSSTR            STACK THE STRING AND GET TOKE
XML  PARSE             Get position
BYTE RPARZ
XML  SPEED             Must have
BYTE SYNCHK          *  ended on a
BYTE RPARZ           *   right parenthesis
CALL INTARG            Check and convert it
DCZ  @FAC              Value out of range
BS   ERRBV
DST  @FAC,@BYTES       Keep the offset
DDEC @BYTES            Correct for position 0
XML  VPOP              Get match string back
MOVE 8,@FAC,@ARG       Put match in ARG
XML  VPOP              Get source back
CZ   @FAC7             If source null
BS   POS12
CH   @BYTES+1,@FAC7    OFFSET > LENGTH?
BR   POS12             Yes, no match possible
CZ   @ARG7             If null string
BS   POS06
POS02  CHE  @ARG7,@FAC7       Enough space left for a match
BR   POS12             No, no match possible
DST  @FAC4,@FAC        Get first ARG
DST  @ARG4,@ARG        Get second ARG
ST   @ARG7,@ARG8       And length of second
POS04  CEQ  V*FAC,V*ARG       Compare the characters
BR   POS10             Didn't match
DINC @FAC              Next in source
DINC @ARG              Next in match
DEC  @ARG8             Reached end of match?
BR   POS04             Not yet, so loop
POS06  INC  @BYTES+1          Matched! Correct for 1 index
POS08  DST  @BYTES,@FAC       Character position of match
BR   LEN02             Convert to floating point
* NOTE: Utilizes the LEN code to do the conversion and
*       finish up.
POS10  INC  @BYTES+1          Step index of match character
DEC  @FAC7             Move 1 position down 1st
DINC @FAC4              Argument
BR   POS02             Try to match again
* JUMP ALWAYS
POS12  CLR  @BYTES+1          NO MATCH POSSIBLE
BR   POS08
***********************************************************
* RPT\$(A\$,X) - Creates a string consisting of X copies of
*              A\$. If X is negative or non-numeric, an
*              exception occurs. If A\$ is not a string, an
*              exception occurs.
***********************************************************
RPTZ01 CALL LPAR              Insure "(", parse, insure ","
CALL PUSSTR            Insure a string and push it
XML  PARSE             Parse second argument
BYTE RPARZ
XML  SPEED             Must have
BYTE SYNCHK       *     ended on a
BYTE RPARZ        *      right parenthesis
CALL INTARG            Check numeric and convert
DMUL [email protected](@VSPTR),@FAC  Compute result length
DCZ  @FAC1
BS   GA649
WRNST2 CALL WARNZZ            Give truncation message
BYTE 19                * STRING TRUNCATED message
DST  255,@FAC2         Make it a maximum string
GA649  DST  @FAC2,@BYTES      Copy requested string length
XML  GETSTR            Get the new string
XML  VPOP              Retrieve the original string
* At this point BYTES should still contain the length
DST  @FAC6,@ARG        Copy original length in ARG
DCZ  @BYTES            Zero copies requested
BR   GA659
DCLR @ARG              So we copy zero!!!!!!!
GA659  DEX  @ARG,@BYTES       Original length to BYTE
DST  @FAC4,@TEMP5      And also original start addr
CLR  @FAC8             Clear flag for LITS08
CALL LITS08            Create FAC and copy on copy
* ARG contains total length now.
DST  @ARG,@FAC6        Store new length
RPTZ02 DSUB @BYTES,@ARG       Subtract one copy
DCZ  @ARG              <<<<<THE WAY OUT
BS   XMLCON
DCH  @ARG,@BYTES
BR   GA679
DST  @ARG,@BYTES       Truncate string
GA679  MOVE @BYTES,V*TEMP5,V*SREF
BR   RPTZ02
**********************************************************
***********************************************************
*                   TRACE STATEMENT
***********************************************************
NTRACE OR   >10,@FLAG         Set the trace bit
XMLCON XML  CONT              Continue on
***********************************************************
*                 UNTRACE STATEMENT
***********************************************************
NUNTRC AND  >EF,@FLAG         Reset the trace bit
XML  CONT              Continue on
***********************************************************
*          BREAK AND UNBREAK STATEMENTS
***********************************************************
NBREAK ST   >FF,@ARG          BREAK flag
CALL CHKEND            Check for end of statement
BR   LINEGP            If not goto LINEGP
DDEC @PGMPTR           Back up so CON will rescan en
CZ   @PRGFLG           Rative without line #
BR   EXEC6C
ERROLP CALL ERRZZ             Only legal in a program
BYTE 27
NUNBRK CLR  @ARG              UNBREAK flag for common
CALL CHKEND            Check for end of statement
BS   UNBK01            If end then goto UNBK01
LINEGP CALL LINE              Get line #
DST  @ENLN,@ARG2
DSUB >03,@ARG2         1st line #
BR   WRNLNF
CALL GRSUB3            Read line # of data from ERAM
BYTE >5E           *   (use GREAD1) or VDP
* @ARG2: Source addr in ERAM/VDP, reset possible breakpoint
DCEQ @FAC,@EEE1        If line found
BS   LNGP2
DSUB 4,@ARG2           Next line in VDP or ERAM
BR   LNGP1
* JUMP ALWAYS
LNGP2  CZ   @RAMTOP           If ERAM exists
BS   GA6DA
AND  >7F,@EEE1         Assume UNBREAK flag
CZ   @ARG              If BREAK flag
BS   GA6D1
OR   >80,@EEE1         Set the breakpoint
GA6D1  CALL GWSUB             Write a few bytes of data to
*                              ERAM (use GWRITE)
BYTE >5E,>58,>01     * ARG2,EEE1,1
*                            @ARG2: Destination addr on ERA
*                            @EEE1: Data
*                            1    : Byte count
B    LNGP2B
GA6DA  AND  >7F,V*ARG2        Assume UNBREAK flag first
CZ   @ARG              If BREAK flag
BS   LNGP2B
OR   >80,V*ARG2        Set the breakpoint
LNGP2B CALL CHKEND            Check for end of statement
BS   LNGP4             If end then continue
XML  SPEED             Must be
BYTE SYNCHK         *     at a
BYTE COMMAZ         *       comma now
BR   LINEGP
* JUMP ALWAYS
WRNLNF CALL WARNZZ            Note: warning not error
BR   LNGP2B            And contiue on
* JUMP ALWAYS
UNBK01 CALL UBSUB             Clear all bkpt in line # tabl
LNGP4  XML  CONT              Contiue
*     CLEAR ALL BREAKPOINTS
UBSUB  DST  @STLN,@FAC8       END OF LINE # BUFFER
GA6FF  CALL UBSUB1            Reset one line # at a time
DADD 4,@FAC8           Got to the next line
DCH  @ENLN,@FAC8       End of table
BR   GA6FF
RTN
UBSUB1 CALL GRSUB3            Read the line # from ERAM/VDP
*                             Reset possible bkpt too
BYTE >52            *  @FAC8: Source addr on ERAM/VD
CALL GWSUB             Write a few bytes of data to
*                              ERAM(use GWRITE) or VDP
BYTE >52,>58,>01    *  FAC8,EEE1,1
*                          @FAC8: Destination adr in ERAM/V
*                          @EEE1: Data
*                          1    : Byte count
RTN
***********************************************************
*                USER DEFINED FUNCTIONS
* Subroutine to store away the information of the tokens in
* a function reference, go into the 'DEF' statement,
* calculate the value of the expression and then resume
* execution of the user's program after the reference.
* An entry in the FAC and on the stack for a function
* reference looks like:
* +--------+-----+---------------------+--------+---------+
* | PGMPTR | >68 | string/numeric flag | SYMTAB | FREPTR  |
* +--------+-----+---------------------+--------+---------+
*  FAC      FAC2  FAC3                  FAC4     FAC6
*
* The 'PGMPTR' is where execution resumes after evaluating
* the function. String (80)/numeric(00) flag is function
* type. SYMTAB is the old symbol table pointer and FREPTR
* is the old free space pointer. These are restored after
* the function is evaluated.
***********************************************************
UDF    CZ   @PRGFLG           If imperative
BR   GA720
CZ   @RAMTOP+1         And ERAM, error
BR   ERROLP
GA720  CLR  @FAC7             Assume no args
DCLR @ERRCOD           Clear the error code for cont
CLR  @ARG2             Safety for VPUSH
CLR  @FAC2             Sagety for VPUSH
CEQ  LPARZ,@CHAT
BR   GA73B
XML  VPUSH             Save ptr to function definiti
XML  PARSE             PARSE to get arg value
BYTE >FF
MOVE 8,@FAC,@ARG       Save PARSE result
XML  VPOP              Get S.T. ptr to function defi
INC  @FAC7             Indicate theat we have an arg
GA73B  ST   @FAC7,@TEMP5      Move the parmeter count
DST  @FAC,@TEMP4       S.T. ptr to definition
XML  VPUSH             Allow room for UDF result
MOVE 8,@ARG,@FAC       Retrieve parse result
XML  VPUSH             Save parse result
ST   V*TEMP4,@FAC2     Get S.T. declarations
ST   @FAC2,@FAC3       Do this to save string bit
* NOTE: THIS IS TO ALLOW THE CHECKING AFTER THE FUNCTION HA
*       BEEN EVALUATED TO MAKE SURE THE FUNCTION
*       TYPE (STRING/NUMERIC) MATCHES THE RESULT IT PRODUCE
AND  >07,@FAC2         Mask all but # of parameters
CEQ  @TEMP5,@FAC2
BR   ERRIAL
* Incorrect argument list error above.
DST  @PGMPTR,@FAC      Will resume execution here
ST   >70,@FAC2         Entering parameter into symbo
*                    table while in UDF statement executing
AND  >80,@FAC3         Mask all but string bit
DSUB 16,@VSPTR         Get below parse result

DST  @SYMTAB,@FAC4     Save current symbol table ptr
DST  @FREPTR,@FAC6     Save current free space ptr
XML  VPUSH             Save the return info
DADD 8,@VSPTR          Get back to parse result
*********** SHIFT EXECUTION TO FUNCTION DEFINITION ********
DST  [email protected](@TEMP4),@PGMPTR    Set text ptr to definiti
XML  PGMCHR            Get 1st character in the defi
CH   >A4,@SUBSTK       Stack overflow
BS   ERRSO
MOVE 24,@VAR0,[email protected]  Roll out temporaries
OR   >08,@FLAG         Set function flag for ENTER
ST   >80,@XFLAG        Make calls look like ENTERX
CEQ  EQUALZ,@CHAT
BR   GA79C
* NOTE: This is to keep the global/local variables correct
*       the event that a function uses another function in
*       its evaluation.
CLR  @FAC15            Create a dummy entry in table
CALL ENT09              for no-paremter function
DDECT @PGMPTR          Back up to equal sign
CLR  [email protected](@VSPTR)       This is to keep ASSGNV(called
*                              below) not to screw up in
*                              case FAC2 happens to have a
*                              value (greater) >65
BR   GA79F
GA79C  CALL ENTER             Enter the parameter
GA79F  XML  PGMCHR            Get the '=' (Checked in PSCAN
AND  >F7,@FLAG         Reset to normal ENTERs
MOVE 24,[email protected],@>8300
ST   >68,[email protected](@VSPTR)  Correct stack entry ID
DST  [email protected],[email protected](@SYMTAB)  Fudge link to
*                                   get global values
DST  @SYMTAB,@FAC      Set up for SMB
XML  SMB               Get value space
MOVE 8,@FAC,@FAC8      Destination
XML  VPOP              Get arg back
MOVE 8,@FAC,@ARG       Argument value
MOVE 8,@FAC8,@FAC      Destination
XML  VPUSH             Push to destination
MOVE 8,@ARG,@FAC       Argument value
CEQ  >65,@FAC2         If a string
BR   GA7E2
DCEQ >001C,@FAC        If not temp
BS   GA7E2
DST  V*FAC,@FAC4       Get new location of string
*                             Parameter was allocated in S.
GA7E2  XML  PGMCHR            Skip the '='
XML  ASSGNV            Assign the value to the param
XML  PARSE             PARSE to end of function defi
BYTE TREMZ
**** CHECK FOR TYPE MATCH (STRING/STRING OR NUM/NUM)*******
**** BETWEEN THE RESULT AND THE FUNCTION TYPE *************
CEQ  >65,@FAC2         If result string
BR   GA7F6
CZ   [email protected](@VSPTR)       If functional
BS   ERRSNM
BR   GA7FC              not a string
GA7F6  CZ   [email protected](@VSPTR)       If functional
BR   ERRSNM
***** NOW RESTORE SYMBOL TABLE AND RESUME *****************
***** EXECUTION AT THE ORIGINAL LINE **********************
DST  [email protected](@VSPTR),@PGMPTR Manual pop to get ptr back
DDEC @PGMPTR           Back up text pointer
XML  PGMCHR            Get next token
XML  CONT
*                             in case entry is a string
*                             (must free the string)
MOVE 4,[email protected](@VSPTR),@SYMTAB  Restore old symbol table
*                             pointer and free space pointe
*                             This handles the freeing of t
*                             string value which was assign
*                             to the parameter.
CGE  0,V*TEMP5         If string parmeter
BS   GA84C
DST  [email protected](@TEMP5),@TEMP5 Where the string is
DCZ  @TEMP5            If non-null string
BS   GA833
DST  [email protected](@TEMP5),@TEMP2 Get backpointer
DCHE @SYMTAB,@TEMP2    If not used
BS   GA833
DCLR [email protected](@TEMP5)      Free up the string
* This handles the special case of F\$(X\$)=X\$
* The result, which was permanent, must be made a temp.
GA833  CEQ  >65,@FAC2         If string result
BR   GA84A
DCHE @SYMTAB,@FAC      If came from argument
BS   GA84A
DCZ  @FAC4             If non-null
BS   GA846
DCLR [email protected](@FAC4)       Clear the backpointer
GA846  DST  >001C,@FAC        Make it a temp
GA84A  BR   GA856             If numeric parameter
GA84C  CZ   @RAMTOP           If ERAM exist
BS   GA856
DADD 8,@RAMFRE         Remove 8 bytes of value
GA856  DSUB 8,@VSPTR          Trash the stack entry
RTN                    And retrun
ATTNUT XML  PARSE
BYTE RPARZ
CALL CKSTNM            CHECK FOR NUMERIC OR STRING
XML  SPEED             Insure argument is in
BYTE RANGE          *   range of 0-30
BYTE 0
DATA 30
SRL  1,@FAC1           0,1 : 0000        ATTENUATION
*                             2,3 : 0001
*                             4,5 : 0010
*                             6,7 : 0011        ETC...
OR   >F0,@FAC1         REGISTER BITS
RTN
***********************************************************
* SUBROUTINE TO SET POINTER TO EACH DATUM
***********************************************************
DATAST DDEC @LNBUF            Point to 1st byte of line ptr
CALL GRSUB2            Read 2 bytes from VDP or ERAM
BYTE LNBUF           *  (use GREAD1), @LNBUF: Source
*                           *  address in ERAM or VDP
DST  @EEE1,@DATA       Put it in @DATA
CALL SRDATA            Look for 'DATA' on the line
BR   DATST1            OK, FOUND ANOTHER 'DATA' STMT
DDECT @LNBUF           NO
DCEQ  @STLN,@LNBUF
BS   GA887
DDEC @LNBUF            Point to 1st token address
BR   DATAST
GA887  CLR  @DATA             Indicate no data
DATST1 RTN
***********************************************************
* Subroutine to get line number and goto routine to display
* it on the screen.
***********************************************************
ASC    CZ   @RAMFLG
BR   GA897
DST  [email protected](@EXTRAM),@ARG2   Get line # in
BR   GA8A5
GA897  DST  2,@FFF1           @FFF1 : Byte count
DST  @EXTRAM,@DDD1     @DDD1 : Source addr in ERAM
DDECT @DDD1
DST  @EEE1,@ARG2       @EEE1 : Destination addr on C
GA8A5  AND  >7F,@ARG2         Reset the breakpoint if any
B    DISO
***********************************************************
* Code to decode error returned from ALC
***********************************************************
ERORZ  CASE @ERRCOD           DECODE ERROR FROM INTERPRETER
BR   ERRSYN            0 SYNTAX ERROR
BR   ERRMEM            1 MEMORY FULL
BR   ERRSYN            4 SYNTAX
BR   ERRSNM            6 STRING-NUMBER MISMATCH
BR   ERRSO             7 STACK OVERFLOW
BR   ERRRWG            9 RETURN WITHOUT GOSUB
BR   ERRIAL            A INCORRECT ARGUMENT LIST
BR   ERRFNN            B FOR/NEXT NESTING
BR   ERRNWF            C NEXT WITHOUT FOR
BR   ERRMUV            D IMPROPERLY USED NAME
BR   ERRIAL            E INCORRECT ARGUMENT LIST
BR   ERRRSC            F RECURSIVE SUBPROGRAM CALL
BR   ERROLP           11 ONLY LEGAL IN A PROGRAM
BR   ERRSNS           12 MUST BE IN SUBPROGRAM
***********************************************************
* SUBROUTINE TO GET LINE # FOLLOWING 'BREAK', 'UNBREAK',
* 'RESTORE'
***********************************************************
LINE   CEQ  LNZ,@CHAT         Should be line # reference
BR   ERRSYN
XML  PGMCHR            Get high order line #
ST   @CHAT,@FAC        Build result in FAC, FAC1
XML  PGMCHR
ST   @CHAT,@FAC1       Low order line #
XML  PGMCHR            Get token following line #
RTN
CONV1  CLR  @FAC10
XML  CSNUM             Convert String to Number
***********************************************************
ST   @FAC10,[email protected]
DST  @FAC12,[email protected] Save those in temporary, becaus
*                            in ERROV : WARNING routine hav
*                            FAC12 and FAC10 values changed
***********************************************************
WRNNO  CZ   @FAC10            Numeric overflow
BS   GA8F9
CALL WARNZZ
BYTE 2
GA8F9  RTN
***********************************************************
*                SUBROUTINE FOR 'GCHAR'
***********************************************************
GCHAR  CALL GPHV              Get X,Y values
GCHAR2 CALL NUMVAR            Get pointer to return variabl
MOVE 8,[email protected],@FAC     Clear FAC
ST   @CB,@FAC1         Get the character
SUB  OFFSET,@FAC1      Remove screen offset
CHE  100,@FAC1
BR   GA919
EX   @FAC1,@FAC2
DIV  100,@FAC1
INC  @FAC
GA919  XML  ASSGNV            Assign the value to the symbo
* RXB PATCH CODE
BR   GCHARA
***********************************************************
*               SUBROUTINE FOR 'COLOR'
***********************************************************
COLOR  XML  SPEED             Must be
BYTE SYNCHK        *     at a
BYTE LPARZ         *       left parenthesis
* RXB PATCH CODE
COL08  DCLR @VAR0             Clear ALL pointer
CEQ  ALLZ,@CHAT        ALL?
BR   COL09             No.
ST   ALLZ,@VAR0        Yes, store it in pointer
DCLR @FAC              Set 0
XML  PGMCHR            Skip ALL token.
CALL COMMA2            Skip comma.
BR   COL21             Start ALL RXB routine
COL09  CEQ  NUMBEZ,@CHAT      If sprite number specified
BR   COL20
CALL CHAR1             Check sprite number (SPNUM3)
COL10  CALL SPCOL             Put the color in SAL
CEQ  COMMAZ,@CHAT      More color changes
BR   LNKRTN
CALL CHAR2             Skip and get sprite number (S
BR   COL10
* This part for regular color change routine
COL20  XML  SPEED             Parse the character
BYTE PARCOM         *   set and insure a comma
XML  SPEED             Insure in range of
BYTE RANGE          *   0<= x <= 14
* RXB PATCH CODE
*      BYTE 0,0,14
BYTE 0,0,16
XML  VPUSH             Push table set address
XML  SPEED             Parse the foreground color
BYTE PARCOM         *   and insure a comma
CALL RAN16             Error if >16 or <1
ST   @FAC1,@VAR4       Save it
SLL  4,@VAR4           Foreground color in 4 MSBits
XML  PARSE             Get background color
BYTE RPARZ
CALL RAN16             Error if >16 or <1
OR   @FAC1,@VAR4       Background color in 4 LSBits
XML  VPOP              Get color table address
ST   @VAR4,V*FAC       Load the colors into the tabl
* RXB PATCH CODE
CEQ  ALLZ,@VAR0        ALL in pointer.
BR   COL22             No.
MOVE 14,V*FAC,[email protected](@FAC) Fill color table with values
COL22  CEQ  COMMAZ,@CHAT      End of call. Go back.
BR   LNKRTN
XML  PGMCHR            Skip ","
BR   COL08             Take care of the next set
*      CALL SPCOL -- Changes color of sprite.
*                    Called also from SPRITE.
SPCOL  XML  PARSE
BYTE RPARZ          *  Get the color number
CALL RAN16             Check range 1 - 16
ST   @FAC1,[email protected](@SPSAL) Store in SAL
RTN
***********************************************************
* INTARG - Insures that the value in FAC is a numeric,
*          converts it to integer, issues error message if
*          necessary or returns.
***********************************************************
INTARG CH   >63,@FAC2         If string - error
BS   ERRSNM
CLR  @FAC10            ASSUME NO ERROR OR WARNING
XML  FLTINT
CZ   @FAC10            If error
BR   ERRBV
CGE  0,@FAC            Can't be < zero
BR   ERRBV
RTN
* FAC IS SET UP WITH F.P. 1
JOYXY  ST   @VAR0,@FAC1
CZ   @VAR0             If <>0
BR   GA995
CLR  @FAC              (>0000000000000000)
BR   GA99D
GA995  CGE  0,@VAR0
BS   GA99D
ST   >BF,@FAC
GA99D  XML  ASSGNV            Assign the value
RTN
ST   @FAC1,@VAR0       Keyboard selection
CALL NUMVAR            Get variable for key-code
CEQ  COMMAZ,@CHAT      If not comma - error
BR   ERRSYN
XML  PGMCHR            Get next character
CALL NUMVAR            Get variable for key-status
ST   @VAR0,@KEYBD      Keyboard selection
MOVE 8,[email protected],@FAC     Set up float
SCAN                   SCAN the keyboard
CLR  @KEYBD            Clear the code(No affect on s
RTNC                   Return scan condition code
NUMVAR XML  SYM               Get the symbol name
CLOG >C0,V*FAC         Can't be string or function
BR   ERRMUV            It is, IMPROPERLY USED NAME E
XML  SMB               Get value pointer
XML  VPUSH             Put on stack for ASSGNV
RTN                    And return
ATTREG DATA >8000,>A000,>C000,
BYTE >9F,>BF,>DF,>FF,>00,>06
COMB   CEQ  LPARZ,@CHAT       If not '(' - error
BR   ERRSYN
RTN
SQUISH MOVE 8,V*FAC8,@FAC     Sneak it out
DST  @VSPTR,@FAC14     Now move stack to squish it
DSUB @FAC8,@FAC14        out - # of bytes to move
BS   SQU05             If none to move
MOVE @FAC14,[email protected](@FAC8),[email protected](@FAC8)
SQU05  DSUB 8,@VSPTR
RTN
***********************************************************
*                 SUBPROGRAM FOR CLEAR
***********************************************************
CLEAR  ALL  SPACE+OFFSET      Clear the screen
ST   3,@XPT            Initialize screen pointer
***********************************************************
*               SUBPROGRAM FOR VERSION
***********************************************************
VERS   CALL COMB              Insure have left parenthesis
CALL ERRC05            Get symbol information
*----------------------------------------------------------
* Change version number to 110     6/16/1981
DST  2015,@FAC              8/17/2014
XML  CIF               Convert to floating point
*----------------------------------------------------------
* INIALIZATION DATA FOR SOUND
FLTS   BYTE >42,>0B,>12,>22,>00,>00,>00,>00
SNDREG BYTE >01,>FF,>01,>04,>9F,>BF,>DF,>FF,>00
***********************************************************
*                SUBPROGRAM FOR 'SOUND'
* Builds 2 blocks in VDP RAM
* 1st BLOCK : >01,<ATTENUATION FOR NOISE>,<INTERRUPT COUNT>
* 2nd BLOCK : >04,>9F,>BF,>DF,>FF,>00
***********************************************************
XSOUND DCEQ VRMSND,@>83CC     Insure previous sound started
BS   XSOUND
MOVE 9,[email protected],[email protected]
CALL LPAR              Duration in milliseconds
CGE  0,@FAC            Don't wait for completion
BS   GAA39
DNEG @FAC                of previous sound
DCLR @PRTNFN           Make GPL interpeters stop pre
GAA39  XML  SPEED             Insure duration
BYTE RANGE           *  is in range
BYTE 1               *   of 1 - 4250
DATA 4250
* Convert duration into 1/60s of a second
DMUL 6,@FAC            Duration * 6
DDIV 100,@FAC          (duration * 6) / 100
CZ   @FAC1             If duration =0
BR   GAA4D
INC  @FAC1             Set it to 1/60th of a second
GAA4D  ST   @FAC1,[email protected]+2    3rd byte of the 1st block
*                          | INTERUPT COUNT
***********************************************************
*      SOUND TABLE OF 10 BYTES IN CPU RAM (>00 - >09)
* >00 - >05 : FREQUENCY CONTROL
* >06 - >08 : ATTENUATION CONTROL
* >09       : NOISE CONTROL(non-zero = noise encountered)
* >0A       : POINTER FOR CURRENT FREQENCY CONTROL
* >0B       : POINTER FOR CURRENT ATTENUATION CONTROL
*                    >00 , >01 FOR REG 0;
*                    >02 , >03 FOR REG 1;
*                    >04 , >05 FOR REG 2;
* REG0 : >8000, REG1 : >A000, REG3 : >C000
* INITIALIZE ATTENUATION CONTROL
* REG0 : >9F, REG1 : >BF, REG2 : >DF
***********************************************************
MOVE 12,[email protected],@>8300
SOUND1 XML  SPEED             Parse the frequency value
BYTE PARCOM         *   and insure a comma
CALL CKSTNM            Must be a numeric
CGE  0,@FAC            Noise if negative
BR   SOUND2
MOVE 8,[email protected],@ARG     Constant 111834
XML  FDIV              P = 111834/FREQUENCY
XML  SPEED             Insure in range
BYTE RANGE
BYTE 3               * Range: 3 - 1023
DATA 1023
* GET THE 4 L.S.Bits BITS AND 6 M.S.Bits OF 'P'
DSRC 4,@FAC
SRL  4,@FAC
DOR  @FAC,*STADDR  1st byte of frequency control byt
*                         BIT   7   6   5   4   3   2   1
*                               1  <REG>    0  <L.S.B. 4 OF
*                         2nd byte of frequency control byt
*                               0   0   <M.S.B. 6 of 'P'
CALL ATTNUT            Get attenuation
*                        BIT    7   6   5   4   3   2   1
*                               1   <REG>   1   0   0   0
AND  @FAC1,*VAR2         1   <REG>   1   <ATTN/2 DB>
INC  @VAR2             Advance pointer for next time
* CHECK FOR END OF SOUND CALL
SOUND3 CEQ  RPARZ,@CHAT       End of statement?
BS   SOUND5
XML  SPEED             If not right parenthesis
BYTE SYNCHK        *    then must be at
BYTE COMMAZ        *      a comma
CEQ  6,@STADDR         If not 3 regs yet
BR   SOUND1
* 3 sound regs already - so must be noise control
XML  SPEED             Get frequency (should be nois
BYTE PARCOM        *     and insure a comma
CALL CKSTNM            Must be a numeric value
CGE  0,@FAC            If not noise-error
BS   ERRBV
* NOISE CONTROL
SOUND2 CEQ  >FF,@>8309        * BAD ARGUMENT ERROR
BR   ERRBA
DNEG @FAC              -(FREQUENCY)
XML  SPEED             Insure in range
BYTE RANGE         *    of 1 - 8
BYTE 1             *
DATA 8
DEC  @FAC1             0 - 7 (2nd BIT: 'T')
*                                           OTH, 1ST BITS:
ST   @FAC1,@>8309
OR   >E0,@>8309        Noise control byte:
*                        BIT  7   6   5   4   3   2   1   0
*                             1   1   1   0   0  <T>  < S >
* PUT ATTENUATION IN THE 2ND BYTE OF 1ST BLOCK
CALL ATTNUT
ST   @FAC1,[email protected]+1
*                             1   1   1   1   < ATTN/2  DB>
BR   SOUND3            Go check for end of list
SOUND5 CLR  @VAR5             Pointer to sound table
SND05  CZ   @PRTNFN           Wait untild previous
BS   SOUND6
SCAN                   Is finished and
BR   SND05              look for a break-key
CEQ  BREAK,@RKEY       If not break-key
BR   SND05
BR   EXEC6C            If BREAK-KEY encountered
SOUND6 ST   *VAR5,@>8400      SOUND ADDRESS PORT
INC  @VAR5             Next byte in table
CEQ  >0A,@VAR5         If not finished
BR   SOUND6
DST  VRMSND,@FAC       Where the 2 blocks are
I/O  1,@FAC            Start sound from VDP list
***********************************************************
*                SUBPROGRAM FOR 'HCHAR'
***********************************************************
HCHAR  CALL HVCHR             Get X, Y values character, #
DCZ  @FAC              If 0 characters
BS   HCHAR2
HCHAR1 BYTE >08,>E0,>00,>FB  * FMT '@VAR0'   Display horizo
DDEC @FAC              Done yet?
BR   HCHAR1            No, finish it
* RXB PATCH CODE
HCHAR2 CEQ  COMMAZ,@CHAT
BS   HCHAR
XPTRTN ST   @MNUM,@XPT        Restore X-pointer
LNKRTN XML  SPEED             Must be at
BYTE SYNCHK        *     a right
BYTE RPARZ         *      parenthesis
LNKRT2 CALL CHKEND            Check end of statement
BR   ERRSYN            If not end-of-stmt , error
***********************************************************
*                SUBPROGRAM FOR 'VCHAR'
***********************************************************
VCHAR  CALL HVCHR             Get X, Y values character, #
DCZ  @FAC              If 0 characters
BS   VCHAR2
VCHAR1 BYTE >08,>E0,>00,>9E,>FB * FMT '@VAR0',>31 Display v
DDEC @FAC              Done yet?
BS   VCHAR2            Yes, return
CZ   @YPT              If not at start of colunm
BR   VCHAR1
INC  @XPT              Move X-ptr to right one colun
B    VCHAR1
* RXB PATCH CODE
VCHAR2 CEQ  COMMAZ,@CHAT
BS   VCHAR
BR   XPTRTN
***********************************************************
*               SUBPROGRAM FOR 'CHAR'
***********************************************************
CHARLY CALL COMB
CHAR5  XML  PGMCHR            Skip "(" or ","
* RXB PATCH CODE
CEQ  ALLZ,@CHAT
BR   GAB1F
XML  PGMCHR
CALL COMMA2
ST   ALLZ,@VAR0
DST  32,@FAC
BR   GAB28
GAB1F  XML  SPEED             Get the first value
BYTE PARCOM         *    and insure a comma
XML  SPEED             Insure in range
BYTE RANGE          *   of 32 - 143
* RXB PATCH CODE
BYTE 30
DATA 159
GAB28  DSLL 3,@FAC            Convert chr number to address
DST  @FAC,@VARY        Save it
XML  PARSE             Get string
BYTE RPARZ
CEQ  >65,@FAC2         MUST BE STRING
BR   ERRSNM
MOVE 4,@FAC4,@VAR5     VAR5 pointer to string value
* Start defining character description.
*    VARY    Address of RAM for character description.
*    VAR5    Pointer to string value.
*    VAR7    Length of string value.
*    VAR9    Temporary counter.
*    VAR9+1  Temporary counter.
DCH  64,@VAR7          Max 4 characters at a time
BR   CHAR40
DST  64,@VAR7          IGNORE THE EXCESSES
CHAR40 DCHE SPRVB,@VARY       Don't have space for
BS   CHARL4
ST   ZERO,@FAC         Floating Point Accumulator (>
MOVE 15,@FAC,@FAC1
DCZ  @VAR7             Fill with zero
BS   CHAR50
DCHE 16,@VAR7
BS   GAB6B
MOVE @VAR7,V*VAR5,@FAC Move whatever
DCLR @VAR7
BR   CHAR50
GAB6B  MOVE 16,V*VAR5,@FAC    Move one character
DSUB 16,@VAR7          Less num of bytes to move
CHAR50 ST   >4A,@VAR9         Move pointer (>4A=FAC)
ST   1,@VAR9+1
B    GAB84
GAB82  INC  @VAR9+1
GAB84  CGT  8,@VAR9+1
BS   GABC3
CLR  @BYTES            Clear dot-building byte
CHARL2 SLL  4,@BYTES          For loop(2 chars per byte)
ST   *VAR9,@ARG
CHE  ZERO,@ARG         If < 0
BR   ERRBV
CGT  NINE,@ARG         If in 0-9
BR   CHARL3
CHE  A,@ARG            If > 9 but < A
BR   ERRBV
CH   F,@ARG            If > F
BS   ERRBV
CHARL3 SUB  ZERO,@ARG         Character - >30
CH   10,@ARG           If in A-F
BR   GABB1
SUB  7,@ARG            Correct for that too
GABB1  OR   @ARG,@BYTES       Dot expression
INC  @VAR9
CLOG 1,@VAR9           1st half of row finished?
BR   CHARL2            Yes, do 2nd half
*                              (each takes half byte)
DINC @VARY
BR   GAB82             Load characters on next row
GABC3  DCZ  @VAR7             More char to describe
BR   CHAR40
* RXB PATCH CODE
CEQ  ALLZ,@VAR0
BR   CHARL4
DCLR @VAR0
CHRFIL MOVE 8,[email protected]>0400,[email protected]>0408(@VAR0)
DCEQ 94*8,@VAR0
BR   CHRFIL
CHARL4 CEQ  COMMAZ,@CHAT      More specified?
BS   CHAR5
BR   LNKRTN            Return
***********************************************************
*              SUBPROGRAM FOR 'KEY'
***********************************************************
KEY    CALL SPAR              GET KEY UNIT
* RXB PATCH LABEL ************
GABD1  XML  SPEED             Insure in range
BYTE RANGE          *   of 0 - 5
BYTE 0
DATA 5
CALL KEYJOY            Get variables for code and st
*                              and scan keyboard
*                             KEYJOY returns key status
BS   KEY1B             KEY STATUS = 1
DNEG @FAC              Assume status = -1
CEQ  >FF,@RKEY         But correct if = 0
BR   KEY1B
DCLR @FAC              KEY STATUS = 0
KEY1B  XML  ASSGNV            Assign value in variable
DST  >4001,@FAC        Re-store F.P. 1 in FAC
CZ   @RKEY             If key-code = 0
BS   KEY2
CEQ  >FF,@RKEY         No key depressed,
BS   KEY1C              key code assigned to -1
* FORMAT FOR KEYCODES ABOVE 99 ADDED FOR 99/4A HIGHEST
* KEYCODE (OTHER THAN >FF) IS >C6=198
* 5/7/81
CHE  100,@RKEY
BR   GAC04
INC  @FAC
SUB  100,@RKEY
ST   @RKEY,@FAC2       FLOATING FORMAT (>4001__00000
B    GAC07
GAC04  ST   @RKEY,@FAC1       FLOATING FORMAT (>40__0000000
GAC07  BR   KEY2A
KEY1C  DNEG @FAC              KEY CODE ASSIGNED TO -1
BR   KEY2A
KEY2   DCLR @FAC              (>000000000000000)
KEY2A  XML  ASSGNV            ASSIGN VALUE TO VARIABLE
* RXB PATCH CODE *************
*      BR   LNKRTN
BR   SUBRTN
***********************************************************
* RXB PATCH WAS    SUBPROGRAM FOR 'JOYSTICK'
***********************************************************
CALL SPAR              KEY UNIT
XML  SPEED             Insure in range
BYTE RANGE          *   of 1 - 4
BYTE 1
DATA 4
CALL KEYJOY            GET VARIABLES FOR X, Y
*                              AND SCAN KEYBOARD
ST   @JOYY,@VAR0       JOYSTICK Y POSITION
CALL JOYXY             -4 to +4
DST  >4001,@FAC        Re-store F.P. 1 in FAC
ST   @JOYX,@VAR0       JOYSTICK X POSITION
CALL JOYXY             -4 to +4
BR   LNKRTN
***********************************************************
* INSURE LEFT PARENTHESIS AND THEN PARSE TO A COMMA
***********************************************************
* RXB PATCH CODE
LPAR   CEQ  COMMAZ,@CHAT
BS   CPAR
XML  SPEED             Must be
BYTE SYNCHK          *  at a
BYTE LPARZ           *    left parenthesis
BR   GAC35
CPAR   XML  SPEED
BYTE SYNCHK
BYTE COMMAZ
* RXB PATCH LABEL ***********
GAC35  XML  PARSE             Do the parse
BYTE COMMAZ          * Stop on a comma
XML  SPEED             Must be
BYTE SYNCHK          *  at a
BYTE COMMAZ          *   comma
RTN
***********************************************************
* SUBROUTINE FOR 'RANGE' USED IN ALL SOUND AND GRAPHICS
***********************************************************
RAN16  XML  SPEED             Insure in range
BYTE RANGE          *   of 1 to 16
BYTE 1
DATA 16
DEC  @FAC1             Adjust to internal range
RTN
***********************************************************
* SUBROUTINE TO GET ROW, COLUMN VALUES
***********************************************************
* RXB PATCH CODE
GPHV   CALL LPAR              Insure '(', parse, insure ','
* RXB PATCH CODE
GPHVRC XML  SPEED             Insure in range
BYTE RANGE           *  of 1 - 24
BYTE 1
DATA 24
DEC  @FAC1             Adjust to internal range
ST   @XPT,@MNUM
ST   @FAC1,@YPT        Set row pointer
XML  SPEED             Get column value
BYTE PARCOM          *  and insure a comma
XML  SPEED             Insure in range
BYTE RANGE           *  of 1 to 32
BYTE 1
DATA 32
DEC  @FAC1             Internal range: 0 - 31
ST   @FAC1,@XPT        Set column pointer
RTN
*  Subroutine to control border color
* Character background is also affected since transparent
*  is used.
BORDER CALL PARFF             Insure '(' , and parse
CALL RAN16             Check 1 - 16 & put in interna
* Get ROW, COLUMN VALUES AND NUMBER OF CHARACTERS
HVCHR  CALL GPHV              Get X, Y VALUES
XML  PARSE
BYTE RPARZ
CALL INTARG
ST   @FAC1,@VAR0       SAVE THE CHARACTER
DST  1,@FAC            ASSUME 1 CHARACTER
CEQ  RPARZ,@CHAT       If not right parenthesis
BS   GAC95
XML  SPEED             Must be
BYTE SYNCHK          *   at a
BYTE COMMAZ          *    comma
XML  PARSE             # OF CHARACTERS
BYTE RPARZ
CALL INTARG            FLOATING TO INTEGER
GAC95  RTN
***********************************************************
* ERRWXY - Is the subroutine for CALL ERR(W,X,Y,Z)
*  The parameters indicate:
*   W - The error code # of the error
*   X - Indicates whether execution(-1) error or
*       I/O (0-255) error on LUNO 0-255
*   Y - Indicates the severity code of the error
*   Z - Line number of the error
*   ERR Can be called with 2 forms:
*       CALL ERR(W,X,Y,Z) and CALL ERR(W,X)
*   If ERR is called and no error has occured then all
*   values returned are zero.
***********************************************************
ERRWXY DST  @VSPTR,@FAC8      Get a temp VSPTR
GAC99  DCH  @STVSPT,@FAC8     While not a bottom of stack
BR   GACD0
ST   [email protected](@FAC8),@ARG   Keep ID code in ARG area
CEQ  >69,@ARG          *** ERROR entry
BR   GACAF
CALL SQUISH            Squish it out of the stack
XML  VPUSH             Put permanent copy of error
*                              entry on stack
BR   ERR10             Jump out now
* Jump always
GACAF  CEQ  >67,@ARG          *** FOR entry
BR   GACBA
DSUB 32,@FAC8          Skip it
BR   GACCE
GACBA  CEQ  >66,@ARG          *** GOSUB entry
BR   GACC5
DSUB 8,@FAC8           Skip it
BR   GACCE
GACC5  CEQ  >6A,@ARG          * SYNTAX ERROR
BR   ERRSYN
DSUB 16,@FAC8          Skip it
GACCE  BR   GAC99
GACD0  DST  >0080,@FAC        No error entry there so
DST  >6900,@FAC2        fake one
DCLR @FAC4
DCLR @FAC6
ERR10  XML  VPUSH             Push the temporary entry on
*                              top of stack
* Code to get "W" in
CALL COMB              Check for left parenthesis
CALL ERRC05            Pick up user's symbol
ST   [email protected](@VSPTR),@FAC1 Get error code
XML  CIF               Convert it to floating
XML  ASSGNV            Assign it
* Code to get "X" in
CALL ERRCOM            Check syntax & get user's sym
CLOG >80,[email protected](@VSPTR)  If execution
MOVE 8,[email protected],@FAC     Make it such
DNEG @FAC              Make it a negative
GAD03  ST   [email protected](@VSPTR),@FAC1 Get I/O LUNO number
XML  CIF               Convert it to floating
* Code to get "Y" in
CEQ  RPARZ,@CHAT       If long form of CALL ERR
CALL ERRCOM            Check syntax & get user's sym
ST   [email protected](@VSPTR),@FAC1 Get severity code
AND  >7F,@FAC1         Reset execution  /  I/O flag
XML  CIF               Convert it
XML  ASSGNV            Assign it
* Code to get "Z" in
CALL ERRCOM            Check syntax & get symbol
DST  [email protected](@VSPTR),@FAC2 Get line pointer
DST  @FAC2,@FAC
DCZ  @FAC2             If line number exists
DDECT @FAC2            Point to the line #
CALL GRSUB1            Read line # (2 bytes) from VD
BYTE >4C             * @FAC2: Source addr on ERAM/VD
DST  @EEE,@FAC         Put the line # in FAC
AND  >7F,@FAC          Reset the breakpoint if any
XML  ASSGNV            Assign it
GAD42  XML  VPOP              Trash the temporary entry
B    LNKRTN            Return from subprogram
* Must be long branch because of AND above
ERRCOM CEQ  COMMAZ,@CHAT      Check for comma
BR   ERRSYN
ERRC05 XML  PGMCHR            Get the next character
XML  SYM               Collect name & s.t. entry
XML  SMB               Get value space
XML  VPUSH             Push it
CLR  @FAC              Set up for conversion
RTN
* CHANGE IN ADDRESS OF THE ERROR CALLS WILL AFFECT
* THE FILE SUBS.....
*     ERROR messages called from this file
ERRSYN CALL ERRZZ             * SYNTAX ERROR
BYTE 3             *   (shared by SUBS)
ERRSNM CALL ERRZZ             * STRING-NUMBER MISMATCH
BYTE 7             *   (shared by SUBS)
ERRMUV CALL ERRZZ             * IMPROPERLY USED NAME
BYTE 9
ERRMEM CALL ERRZZ             * MEMORY FULL
BYTE 11
ERRSO  CALL ERRZZ             * STACK OVERFLOW
BYTE 12
ERRNWF CALL ERRZZ             * NEXT WITHOUT FOR
BYTE 13
ERRFNN CALL ERRZZ             * FOR/NEXT NESTING
BYTE 14
ERRSNS CALL ERRZZ             * MUST BE IN SUBPROGRAM
BYTE 15
ERRRSC CALL ERRZZ             * RECURSIVE SUBPROGRAM CALL
BYTE 16
ERRRWG CALL ERRZZ             * RETURN WITHOUT GOSUB
BYTE 18
ERRBS  CALL ERRZZ             * BAD SUBSCRIPT
BYTE 20
BYTE 22
ERRBA  CALL ERRZZ             * BAD ARGUMENTS
BYTE 28
ERRBV  CALL ERRZZ             * BAD VALUE
BYTE 30            *   (shared by SUBS)
ERRIAL CALL ERRZZ             * INCORRECT ARGUMENT LIST
BYTE 31            *   (shared by SUBS)
BYTE 37
* Other error messages appear in this program
* ERRRDY      * READY                        DATA 0
* ERRBRK      * BREAK POINT                  DATA 1
* ERROLP      * ONLY LEGAL IN A PROGRAM      DATA 27
*
* WRNN01      * NUMERIC OVERFLOW             DATA 2
* WRNS02
* WRNST1      * STRING TRUNCATED             DATA 19
* WRNST2
*
***********************************************************
* SPRITE SUBROUTINES BRANCH TABLE
CHAR1  BR   SPNUM3            Called in CHARLY.    EXEC
CHAR2  BR   SPNUM2            Called in CHARLY.    EXEC
BR   \$                 Called in CHARLY.    EXEC
STRI 'SPRITE'         SPRITE
DATA SPRTE
STRI 'DELSPRITE'      DELSPRITE
DATA SPRDEL
STRI 'POSITION'       POSITION
DATA SPRPOS
STRI 'COINC'          CONIC
DATA ZSCOI
STRI 'MAGNIFY'        MAGNIFY
DATA SPRMAG
STRI 'MOTION'         MOTION
DATA SPRMOV
STRI 'LOCATE'         LOCATE
DATA SPRLOC
STRI 'PATTERN'        PATTERN
DATA SPRPAT
STRI 'DISTANCE'       DISTANCE
DATA ZSDIST
STRI 'SAY'            SAY
DATA SAY
STRI 'SPGET'          SPGET
DATA SPGET
STRI 'CHARSET'        CHARSET
DATA CHRSET
STRI 'ONKEY'          ONKEY
DATA  ZONKEY
STRI 'MOVES'          MOVES
DATA MOVES
STRI 'HPUT'           HPUT
DATA HPUT
STRI 'VPUT'           VPUT
DATA VPUT
STRI 'HGET'           HGET
DATA HGET
STRI 'VGET'           VGET
DATA VGET
STRI 'EXECUTE'        EXECUTE
DATA EXECUT
STRI 'GMOTION'        GMOTION
DATA GMOT
STRI 'RMOTION'        RMOTION
DATA RMOT
STRI 'HEX'            HEX
DATA HEX
STRI 'IO'             IO
DATA RXBIO
STRI 'INVERSE'        INVERSE
DATA INV
STRI 'SWAPCHAR'       SWPCHAR
DATA SWCHR
STRI 'DUPCHAR'        DUPCHAR
DATA DUPCHR
STRI 'SWAPCOLOR'      SWAPCOLOR
DATA SWCLR
STRI 'DUPCOLOR'       DUPCOLOR
DATA DUPCLR
***********************************************************
* CALL SPRITE(#SPRITE,CHAR,COLOR,Y,X,(YSPEED,XSPEED),...)
***********************************************************
SPRTE  CALL SPNUM1            Check sprite mode and skip "(
CALL SPNUM2            Get sprite number
SPRT3  CALL SPCHR             Put character number for spri
XML  SPEED
BYTE SYNCHK
BYTE COMMAZ         *  Check for comma and skip it
CALL GA01E             Put sprite color in SAL  (SPC
XML  SPEED             Insure at a comma
BYTE SYNCHK
BYTE COMMAZ
CALL SPLOC             Put location of sprite in SAL
DST  @SP04+1,V*SPSAL   Put in location of sprite
* Finish defining SAL. Check if velocity is specified
SPRT4  CEQ  COMMAZ,@CHAT      Finished!!!!!
BR   GB0F2
XML  PGMCHR
CEQ  NUMBEZ,@CHAT      Next sprite specified
BR   GAEBB
CALL SPNUM3            Get the next sprite number
BR   SPRT3             And go!
GAEBB  CALL SPMOVE            Get the velocity first
BR   SPRT4
***********************************************************
* CALL DELSPRITE(#SPR,.......)  or CALL DESPRITE(ALL)
***********************************************************
SPRDEL CALL SPNUM1            Insure at '('
SPDEL1 XML  PGMCHR            Skip "(" or ","
CEQ  NUMBEZ,@CHAT      If sprite number
BR   GAEF6
XML  PGMCHR            Skip "#"
XML  PARSE             Parse the sprite number
BYTE RPARZ
CALL SPNUM4            Check and convert number
DCLR [email protected]>0480(@SPSAL)   Stop motion if moving
DST  >C000,V*SPSAL     Hide the sprite off screen
*----------------------------------------------------------
* Add following 7 lines for speeding up XBASIC
CEQ  @MOTION,[email protected]   Check current sprite
BR   SPDEL2
* no. against sprite motion count
* yes, change to as low as possible
GAEE1  DEC  @MOTION
BS   SPDEL2
DSUB 4,@SPSAL
DCZ  [email protected]>0480(@SPSAL)
BS   GAEE1
*----------------------------------------------------------
SPDEL2 CEQ  COMMAZ,@CHAT      If more sprites
BS   SPDEL1
BR   GAEFD
GAEF6  XML  SPEED             Must have 'ALL' else error
BYTE SYNCHK
BYTE ALLZ
CALL SPRINT            Reinitialize all sprites
***********************************************************
* CALL POSTION(#SPR,Y,X,...)
***********************************************************
SPRPOS CALL SPNUM1            Check for sprites and skip "(
SPRP02 CALL SPNUM2            Check sprite number
CALL PREPN             Prepare Y-position return var
XML  SPEED             Insure at a comma
BYTE SYNCHK
BYTE COMMAZ
DST  V*SPSAL,@SP00     Read X, Y position
ST   @SP00,@FAC1       Get Y position
CEQ  >FE,@FAC1
BR   GAF1C
DINCT @FAC             Get 256 as an output
BR   GAF1E
GAF1C  INCT @FAC1             Regular adjustment for user
GAF1E  CALL SPRP03            Check, convert & assign value
CALL PREPN             Prepare X-pos return variable
ST   @SP00+1,@FAC1     Get X position
DINC @FAC              Adjust for the user
CALL SPRP03            Check, convert & assign value
CEQ  COMMAZ,@CHAT      If not finished
BS   SPRP02
BR   GB0F2             Return
SPRP03 XML  CIF               Convert integer to float
DCEQ >C000,@SP00       If hidden sprite
BR   GAF3D
DCLR @FAC              Return value zero
GAF3D  XML  ASSGNV            Assign to variable
RTN
***********************************************************
* CALL COINC(#SPR,#SPR,TOLERANCE,CODE)
* CALL COINC(#SPR,YLOC,XLOC,TOLERANCE,CODE)
* CALL COINC(ALL)
***********************************************************
SPRCOI CALL SPNUM1
XML  PGMCHR            Skip "("
CEQ  ALLZ,@CHAT        Check coinc of all sprites
BR   GAF56
XML  PGMCHR            Skip "ALL"
CALL COMMA2            Check and skip ","
CLOG >20,@VDPSTT       Check VDP status
* RXB PATCH CODE ************
*      BS   NULRTN
BS   NR
BR   GAF6C
* RXB PATCH CODE ************
GAF56  CALL CODIST            Get distance of 2 sprites
CALL COMMA             Get tolerance level
XML  SPEED
BYTE RANGE           * Check against range
BYTE 0               * FAC has tolerance level
DATA 255
DCH  @FAC,@SP00        Y-loc out of range
* RXB PATCH CODE ************
*      BS   NULRTN
BS   NR
DCH  @FAC,@SP04        X-loc out of range
* RXB PATCH CODE ************
*      BS   NULRTN
BS   NR
* If no conincidence just return zero
GAF6C  CALL PREPN             Prepare for numeric output
DST  >BFFF,@FAC        Store -1 in FAC
* RXB PATCH CODE ************
*      BR   ASSRTN
BR   AR
***********************************************************
* CALL MAGNIFY(magnification factor=1 - 4)
***********************************************************
SPRMAG CALL SPNUM1            Insure at "("
XML  PGMCHR            Skip the "("
XML  PARSE             Parse the magnification facto
BYTE RPARZ
XML  SPEED
BYTE RANGE
BYTE 1
DATA 4
* Next statement adding >DF to subtract 1 from FAC
ADD  >DF,@FAC1         Turn on screen and interrupt
MOVE 1,@FAC1,#1        Store it to VDP register 1
BR   GB0F2
***********************************************************
* CALL MOTION(#SPR,YSPEED,XSPEED,...)
***********************************************************
SPRMOV CALL SPNUM1            Insure at "("
* RXB PATCH CODE *************
* SPRMV2 CALL SPNUM2            Get sprite number
SPRMV2 B    SPGS              GO or STOP
SPRMV3 CALL SPMOVE            Store velocity
SPRMV4 CEQ  COMMAZ,@CHAT      Loop if more
BS   SPRMV2
BR   GB0F2
***********************************************************
* CALL LOCATE(#SPR,YLOC,XLOC,...)
***********************************************************
SPRLOC CALL SPNUM1            Insure at "("
SPRLC2 CALL SPNUM2            Check sprite number
DST  @SP04+1,V*SPSAL   Put in sprite location
CEQ  COMMAZ,@CHAT      Loop if more
BS   SPRLC2
BR   GB0F2
***********************************************************
* CALL PATTERN(#SPR,CHAR,...)
***********************************************************
SPRPAT CALL SPNUM1            Insure at "("
SPRPT2 CALL SPNUM2            Get sprite number
CALL SPCHR             Set the sprite character
CEQ  COMMAZ,@CHAT      Loop if more
BS   SPRPT2
BR   GB0F2
***********************************************************
* CALL DISTANCE(#1,#2,DISTANCE)
* CALL DISTANCE(#1,Y,X,DISTANCE)
***********************************************************
DIST   CALL SPNUM1            Insure at "("
* RXB PATCH LABEL ************
GAFC4  XML  PGMCHR            Skip "("
CALL CODIST            Get distance in Y and X
CALL PREPN             Prepare return variable
DMUL @SP00,@SP00       X=X*X
DMUL @SP04,@SP04       Y=Y*Y
OVF                    Checking overflow bit
BS   OVER              If overflow-indicate maximum
DST  @SP02,@FAC        Put distance squared in FAC
DCH  >7FFF,@SP02       If bigger then 128
BR   GAFE5
OVER   DST  >7FFF,@FAC        Put maximum value
GAFE5  XML  CIF               Convert to floating format
* RXB PATCH CODE
*      BR   ASSRTN            Assign value and return
BR   AR
***********************************************************
* CODIST routine gets locations of two sprites or one
*  sprite and Y and X position specified by a user and
*  calculates absolute value of Y and X distance.
***********************************************************
CODIST CLR  @SP00
MOVE 7,@SP00,@SP00+1   Clear up first 8 bytes
CEQ  NUMBEZ,@CHAT      Check for #
BR   ERRSYN
CALL SPNUM3            Get the first sprite
DST  V*SPSAL,@SP00+1   Location of first sprite
INC  @SP00+1           Increment to make range 1-256
ST   @SP02,@SP02+1     Put X in SP02+1
CLR  @SP02             Y in SP00+1
CEQ  NUMBEZ,@CHAT      Get 2nd sprite
BR   GB011
CALL SPNUM3            Get the next sprite
DST  V*SPSAL,@SP04+1   Location of second sprite
BR   GB017
GB011  CALL SPLOC             Get Y and X location
CALL COMMA2            Check for comma and skip
GB017  INC  @SP04+1           Increment to make range 1-256
DSUB @SP04,@SP00       Difference in Y at SP00
DABS @SP00             Get absolute value
CLR  @SP04+1           Clear byte before X
DSUB @SP02,@SP04+1     Difference in Y at SP04
DABS @SP04+1           get the absolute value
ST   @SP06,@SP04+1     Put in the right place
RTN
***********************************************************
* CHRSET restores the standard character set and the
*  standard colors for the standard character set
*  (black on transparent)
***********************************************************
CHRSET CALL CHKEND            Must be at EOS now
BR   ERRSYN            Else its an erro
ST   94,@FAC2          Number of characters
CLR  [email protected]>03F8           EDGE CHAR ADDRESS
MOVE 896,[email protected]>03F8,[email protected]>03F9 Clear bytes
CHRLP  MOVE 7,[email protected](@FAC4),[email protected](@FAC) Get GROM Def
DEC  @FAC2             Character Count-1
BR   CHRLP             0?
ST   >10,[email protected]>080F       Set 1st set to black on tranp
MOVE 16,[email protected]>080F,[email protected]>0810  Ripple for res
******************************
* SPNUM1 ROUTINE             *
******************************
SPNUM1 CEQ  LPARZ,@CHAT       Should be "("
BR   ERRSYN
RTN
******************************
* SPNUM2 ROUTINE             *
******************************
SPNUM2 XML  PGMCHR            Get the next character
SPNUM6 CEQ  NUMBEZ,@CHAT      Must be "#"
BR   ERRSYN
SPNUM3 XML  PGMCHR            Get next character
CALL COMMA             Parse up to comma and skip it
SPNUM4 XML  SPEED
BYTE RANGE           * Verify the value is in range
BYTE 1               * Sprite number 1 - 28
DATA 28
*----------------------------------------------------------
* Insert a line here in sprite handling code for speeeding
*  up XB    5/22/81
* RXB PATCH LABLE ************
SPNUM5 ST   @FAC1,[email protected]     Keep sprite number
*----------------------------------------------------------
DEC  @FAC1             Adjust for internal use
DSLL 2,@FAC            Get location of SAL
DADD >0300,@FAC        Sprite # * 4 + >0300
DST  @FAC,@SPSAL       Save SAL location
RTN
******************************
* SPLOC ROUTINE              *
******************************
SPLOC  CALL COMMA             Parse up to comma and skip it
XML  SPEED
BYTE RANGE           * Range of Y: 1 - 256
BYTE 1
DATA 256
DECT @FAC1             Adjust for internal use: FF -
DST  @FAC,@SP04        Store in SP04 area
XML  PARSE
BYTE RPARZ           * Parse to ")" or less
XML  SPEED
BYTE RANGE           * Get X value. Range: 1 - 256
BYTE 1
DATA 256
DEC  @FAC1             Adjust for internal use: 0 -
ST   @FAC1,@SP06       SP04+1=Y-loc and SP06=X-loc
RTN
******************************
* SPCHR ROUTINE              *
******************************
SPCHR  XML  PARSE
BYTE RPARZ
XML  SPEED
BYTE RANGE           * Check upper range
* RXB PATCH CODE
*      BYTE 32              * Character value 32 - 144
*      DATA 143
BYTE 30
DATA 159
ST   @FAC1,[email protected](@SPSAL) Store the character value
RTN
******************************
* SPMOVE ROUTINE             *
******************************
SPMOVE CALL COMMA             Parse up to comma and skip
CALL RANGEV            Check if numeric and convert
*                              to integer
ST   @FAC1,@SPTMP      Store Y velocity
XML  PARSE             Get X velocity
BYTE RPARZ           * Check for ")" or less
CALL RANGEV            Numeric check and convert
*                              to integer
SPMOVF ST   @SPTMP,@FAC     * @FAC=Y velocity, @FAC1=X velo
DST  @FAC,[email protected]>0480(@SPSAL)  Store velocities in SAL
*----------------------------------------------------------
* Add the following 3 lines for speeding up XB
CH   @MOTION,[email protected]   Check current sprite
BR   GB0BD              against sprite motion
*                                counter
ST   [email protected],@MOTION       higher? Yes, replace it
*----------------------------------------------------------
GB0BD  RTN
RANGEV CH   >63,@FAC2         The same as INTARG
BS   ERRSNM
CLR  @FAC10
XML  FLTINT
CZ   @FAC10
BR   ERRBV
DCGE 0,@FAC            If positive number,
BR   GB0DB
DCH  >007F,@FAC         should be 0 - 127
BS   ERRBV
BR   GB0E1             If negative number,
GB0DB  DCHE >FF80,@FAC         Should be -1 to -128
BR   ERRBV
GB0E1  RTN                    Otherwise its ok.
******************************
* COMMA ROUTINE              *
******************************
COMMA  XML  PARSE
BYTE COMMAZ
COMMA2 CEQ  COMMAZ,@CHAT
BR   ERRSYN
XML  PGMCHR            Get next character
RTN
******************************
* LINK BACK TO XB            *
******************************
NULRTN CALL PREPN
ASSRTN XML  ASSGNV
GB0F2  B    GA01C                               (LNKRTN)
*******************************
* PREPARE FOR PASSING ARGUMENT*
*******************************
PREPN  XML  SYM               Pick up name & search table
XML  SMB               Evaluate any subscripts
CH   >63,@FAC2         If not numeric, error
BS   ERRIAL
XML  VPUSH             Save entry on stack
CLR  @FAC              Clear FAC for new value
MOVE 7,@FAC,@FAC1
RTN
***********************************************************
* CALL SAY(....................)
*  Decode given parameter(s). Store all data first, then go
*   speak it all at once.
***********************************************************
BR   ERRSYN
DST  @VSPTR,@FAC2      Save current top of stack on
XML  VPUSH              the stack
DST  255,@BYTES        255 bytes = 85 3 byte entires
XML  GETSTR            Get temp speech list string
DST  >001C,@FAC        Indicate it is temp string (S
DST  >6500,@FAC2       Indicate it is string entry
DST  @SREF,@FAC4       Save pointer to temp string
DST  @BYTES,@FAC6      Length is 255
XML  VPUSH             Make it semi-permenant
* Set up pointers into the speak list
DST  @FAC4,@PTFBSL     Front points to begining
DST  @FAC4,@PTLBSL     Last now points to beginning
DST  @PTFBSL,@PTEBSL
DADD @FAC6,@PTEBSL     End points to the end+1
CALL WAIT              Wait till no one is speaking
DIRSPK CALL GETPRM            Get next parameter
BS   NEXT1             If non-null ASCII string
DST  @FAC4,@PTFCIS     Set up pointer to first char
DST  @FAC6,@PTLCIS     Set ptr-to-last-char-in-strin
DDEC @PTLCIS            and subtracting 1
* Make a speech list
DST  @PTFCIS,@PTCCIS   Start at beginning of string
CLR  @TOTTIM           Clear total time delay
CALL GETTIM            Get first timing mark
CALL TIMING            Get any subsequent marks
* The total first time delay is in TOTTIM now
GB158  DCH  @PTLCIS,@PTCCIS   While more string
BS   GB1A7
CALL PHRASE            Get next phrase
* If spell flag is 0, try to look the phrase up. If it
* can not be found, then set the spell flag, and it will be
* spelled out. If found, save on speak list.
CZ   @SPLFLG           There is a phrase
BR   GB173
CALL LOOKUP            Try to look it up in the PHRO
BR   GB170
ST   1,@SPLFLG         Set the spell flag
BR   GB173
GB170  CALL STDATA            Store data in list
* If spell flag is 1, set time delay to >3C, and take the
* phrase one character at a time (spell it). Look up each
* Regardless, store data on speak list.
GB173  CEQ  1,@SPLFLG         Need to spell it out?
BR   GB1A0
DST  @PTLCIP,@PTLCIL   Est last char to spell out
ST   >3C,@TOTTIM       >3C used because sounds good
*                      Take each single character
* Skip over any embedded spaces encountered in a phrase
GB17E  CEQ  SPACE,V*PTFCIP
BR   GB188
DINC @PTFCIP
BR   GB17E
* Set first and last pointers to same one character
GB188  DST  @PTFCIP,@PTLCIP
CALL LOOKUP            Try to look it up
BR   GB196
GB196  CALL STDATA            Store data on speak list
DINC @PTFCIP           Go on to next character
DCH  @PTLCIL,@PTFCIP   Until done all
BR   GB17E
* At this point, get next timing group. The first timing
* character has already been found, and it's value is still
* in TIMLEN. Therefore, initiatory call to GETTIM not
* needed. Simply clear TOTTIM and call TIMING.
GB1A0  CLR  @TOTTIM
CALL TIMING
BR   GB158
* At this point, finished all the phrases in this string.
* TOTTIM should equal >FE, it indicate end of sting If it
* doesn't equal >FE, it indicates that a timing group was
* put on the end of the string. Therefore, save the timing
* group with a null data address to show it is only timing.
GB1A7  CEQ  >FE,@TOTTIM
BS   NEXT1
CALL STDATA
* Next item could be direct string.
NEXT1  CEQ  COMMAZ,@CHAT      If direct string present
BR   SPEAK
CALL GETPRM            Get the next parameter
BS   NEXT2             If non-null direct string
ST   >FF,@TOTTIM       Mark TOTTIM as direct string
XML  VPUSH             Save direct string on stack
CALL STDATA            And add to the speak list
* If the next character is a comma, loop thru it again
NEXT2  CEQ  COMMAZ,@CHAT
BS   DIRSPK
* If end fall into SPEAK
***********************************************************
* SPEAK will actually speak the speech list. It tests the
* timing byte to see if it is an >FF. If it is, then the
* data following it points to a direct speech data string
* in VDP. If it is not, then the data following it points
* to a PHROM speech data list. In the first case, this
* routine will issue a speak external command to the PHROM
* and then feed bytes out to the PHROM as it requests them.
* In the second case, the address will be loaded out to the
* PHROM, and then a speak command will be issued.
***********************************************************
GB1CE  DCHE @PTLBSL,@PTFBSL   More speech list to go
BS   GB258
CALL WAIT              Yes, wait until previous
*                              speech is though
CEQ  >FF,V*PTFBSL      External speech data
BS   GB1FE
NEG  @TIMER             and neg it to correct
DST  [email protected](@PTFBSL),@PTFBPH   Put addr into PTFBPH
LOOP1  CGE  0,@TIMER          Wait for time delay
BR   LOOP1
CZ   @PTFBPH           If there is data
BS   GB1FC
ST   >50,@VAR0(@WRITE)  and issue speak command
GB1FC  BR   CONTIN
GB1FE  DINC @PTFBSL           Speak external, skip over >FF
DST  V*PTFBSL,@PTCBED  Set up pointer to 1st byte
DST  [email protected](@PTCBED),@PTCBED    in external speech data
ST   [email protected](@PTCBED),@LENWST  Get Len of whole string
DIRSPH SUB  3,@LENWST         Minus 3 bytes overhead
BR   ERRBV
CALL WAIT              Wait for go ahead
DINCT @PTCBED          Skip spk ext & 1st byte len
ST   V*PTCBED,@LENCST  Get len of current string
DINC @PTCBED           Skip len byte to 1st real byt
ST   16,@TEMP2         Do 1st 16 bytes (fill buff)
ST   >60,@VAR0(@WRITE) Start Speak External
LOOPR  ST   V*PTCBED,@VAR0(@WRITE) Write byte to PHROM
DINC @PTCBED           Go to next byte
DEC  @LENWST           1 less char in whole string
BS   CONTIN            Finished whole string?
DEC  @LENCST           1 less char in curr string
BS   DIRSPH            Finished current string?
DEC  @TEMP2            1 less char in this loop
BR   LOOPR             Not finished curr loop yet?

* If the next statement is true, it means that speak was
* probably interupted and that it is shot at this point.
* Therefore, we are going to quit now.
CLOG >80,@SPKSTS
BS   CONTIN
CLOG >40,@SPKSTS       Loop till buff below half
BS   GB241
ST   8,@TEMP2          Put 8 more bytes to PHROM
BR   LOOPR              and go do these
CONTIN B    GB1CE             We've said it all!!
* Now pop all entries off stack that we put on!
GB258  XML  VPOP              Free up a temporary string
DCEQ @FAC2,@VSPTR
BR   GB258
***********************************************************
* SPGET subprogram. Load speech data from external device.
*       Use standard file I/O
***********************************************************
SPGET  CEQ  LPARZ,@CHAT       Must have left parenthesis
BR   ERRSYN
CALL WAIT              Wait till no one is speaking
NXTPAR CALL GETPRM            Get the next parameter
DCZ  @FAC6             If non-null ASCII string
BS   GB318
DST  @FAC4,@PTFCIS     Pointer to 1st char in string
DST  @FAC6,@PTLCIS     Pointer to last-char-in-strin
DDEC @PTLCIS             and subtracting 1
DST  @PTFCIS,@PTCCIS   Set curr char to first char
CLR  @TOTTIM           Clear total time delay
CALL GETTIM            Get first timing mark
CALL TIMING            Get any subsquent marks
* Get one phrase, and look it up. If the phrase is not foun
* substitute in 'UHOH'.
DCH  @PTLCIS,@PTCCIS   Possible phrase
BS   GB318
CALL PHRASE            Yes, go get it
CEQ  1,@SPLFLG         Spell flag set then set
BR   GB29C
DST  @PTFCIP,@PTLCIP    last ptr to first (1 char)
GB29C  CALL LOOKUP            Look up the phrase
BR   GB2AA
ST   >51,@STRLEN        'UHOH' data length
* Data must be in PHRADD and PHLEN, so move it
ST   @STRLEN,@PHLEN
* There must be a variable to put this data in. If not, err
XML  SPEED
BYTE SYNCHK
BYTE COMMAZ
XML  SYM               Find symbol in table
XML  SMB               Evaluate andy subscripts
XML  VPUSH             Save for assignment
CLR  @BYTES            Two byte value
ST   @PHLEN,@BYTES+1   Length of string needed
XML  GETSTR            Get a string for the data
DST  >001C,@FAC        Now build string FAC entry
DST  >6500,@FAC2       String ID
DST  @SREF,@FAC4       Pointer to string
DST  @BYTES,@FAC6      Length of string
DST  >6000,V*SREF      Mark string as speech data
ST   @PHLEN,[email protected](@SREF) Put in string length
DSUB 3,[email protected](@SREF)       minus thei info
* Going to copy string from PHROM to VDP. The actual data
* from PHROM is in bit-reversed order, so must reverse the
* order after reading in the order. Remember that 3 bytes
* PHLEN are our own overhead, so don't copy all
GB2EB  CH   3,@PHLEN
BR   GB316
ST   >10,@VAR0(@WRITE) Issue read byte command
* the following code is somewhat tricky. It will bit
* reverse the contents of BYTE3 into BYTE1 through
* BYTE2 by means of word shifts. Note the definition of
* BYTE1 , BYTE2, and BYTE3 in EQU's. You might try an
* example if it isn't clear what is going on.
CLR  @BYTE2
ST   >08,@TEMP1
RNDAG  DSRC 1,@BYTE2
DSLL 1,@BYTE1
DEC  @TEMP1
BR   RNDAG
* Store the bit-corrected byte into the string & inc str pt
ST   @BYTE1,[email protected](@SREF)
DINC @SREF
DEC  @PHLEN            Dec the string length
BR   GB2EB             Go do next char if there is o
GB316  XML  ASSGNV            Assign the string to variable
GB318  CEQ  COMMAZ,@CHAT      If more go do
BS   NXTPAR
BR   GB0F2
***********************************************************
* GETPAM gets the next string paameter passed to the
* routine. If that parameter is non-exist or null, then
* condition bit is set. If the parameter is there then
* condition bit is reset and the FAC entry describes the
* string. In either case, return with condition is done.
***********************************************************
GETPRM XML  PGMCHR            Get next token
CEQ  COMMAZ,@CHAT      Go set condition no parm
BS   SETCB
XML  PARSE
BYTE RPARZ
CEQ  >65,@FAC2         If not string, error
BR   ERRSNM
DCZ  @FAC6             Set cond if null string
RTNC                   Else return
SETCB  CEQ  @VAR0,@VAR0       Set condition bit
RTNC
***********************************************************
* Get the next phrase out of the current string. The phrase
* may begin with a #, which means it will continue to the
* next #, or it many begin with an ordinary character, in
* which case it will end with the character just before the
* first timing character encountered. In either case, the
* end of the string will indicate a legal end of phrase if
* it occurs before the usual indicator!
***********************************************************
BR   GB370
DINC @PTCCIS           Yes, inc CC ptr past #
GB33C  CEQ  SPACE,V*PTCCIS    Skip spaces
BR   GB346
DINC @PTCCIS
BR   GB33C
GB346  CEQ  NUMBER,V*PTCCIS   All spaces?
BR   GB34F
DINC @PTCCIS           Yes, skip this # too
RTN                    And ignore this phrase
GB34F  DST  @PTCCIS,@PTFCIP   Save 1st char in phrase
GB352  DINC @PTCCIS           Go on to next char
* Got to watch for end of string. If encountered before a
* #, act like char after string is #. Then last char will
* be char before, or the last char in the string!!
DCH  @PTLCIS,@PTCCIS
BS   FNDNUM
ST   V*PTCCIS,@CCHAR   No, get char in CCHAR
CEQ  NUMBER,@CCHAR     If not # continue looking
BR   GB352
FNDNUM DST  @PTCCIS,@PTLCIP   Last char in phrase is one
DDEC @PTLCIP            before the #
DINC @PTCCIS           Point to char after #
CALL GETTIM            Get 1st timing char after phr
CLR  @SPLFLG           Indicate don't spell
BR   GB38B             No # as 1st char in phrase
GB370  DST  @PTCCIS,@PTFCIP   Curr char is 1st char phrase
CLR  @SPLFLG           Assume don't spell
CHE  >41,@CCHAR        If not alphabetic   (>41="A")
BS   GB37C
INC  @SPLFLG            set spell flag
* Need to find end of phrase, which is char before next
* timing char we find. Therefore, look for a timing char!
GB37C  DINC @PTCCIS
CALL GETTIM
CEQ  >FF,@TIMLEN       If not timing, loop
BS   GB37C
DST  @PTCCIS,@PTLCIP   Char before curr char is
DDEC @PTLCIP            the last char in phrase
GB38B  RTN
***********************************************************
* TIMING will loop through chars in string until it finds
* non-timing char. Non-timing chars have TIMLEN values of
* >FE or >FF. GETTIM must be called before this routine to
* establish a correct value of TIMLEN. Also, most likely
* TOTTIM should have been cleared.
***********************************************************
TIMING CHE  >FE,@TIMLEN
BS   GB39B
DINC @PTCCIS
CALL GETTIM
BR   TIMING
GB39B  RTN
***********************************************************
* GETTIM will examine the current char in the string and
* set TIMLEN to the appropriate time delay value. TIMLEN
* can take on the following values:
*           >00 if char is timing '+'
*           >06 if char is timing ' '
*           >0C if char is timing '-'
*           >12 if char is timing ','
*           >1E if char is timing ';'
*           >30 if char is timing ':'
*           >3C if char is timing '.'
*           >FE if char is out of stirng bounds
*           >FF if char is not timing
* Note that to test timing, some manipulation of PTCCIS
* would be neccesary, so it is stored and used in TEMP1
***********************************************************
GETTIM ST   V*PTCCIS,@CCHAR   Get the char
DST  @PTCCIS,@TEMP1     store curr ptr in TEMP1
DCH  @PTLCIS,@TEMP1     out of string bounds?
BR   GB3AC
ST   >FE,@TIMLEN       Yes, load value and return
RTN
GB3AC  CH   SEMICO,@CCHAR     Can not be timing
BS   NOTIME
CEQ  SPACE,@CCHAR
BR   GB3C5
ST   6,@TIMLEN
GB3B9  CEQ  SPACE,[email protected](@PTCCIS) While spaces
BR   GB3C4
DINC @PTCCIS           Skip them
BR   GB3B9
GB3C4  RTN
GB3C5  CEQ  PLUS,@CCHAR
BR   GB3D4
DINC @TEMP1            Need to test the next char
CALL NUMERC            Is it numeric
BS   NOTIME            Was numeric => not timing cha
CLR  @TIMLEN           Not numeric => set as no timi
RTN
GB3D4  CEQ  COMMAT,@CCHAR
BR   GB3DD
ST   >12,@TIMLEN
RTN
GB3DD  CEQ  PERIOD,@CCHAR
BR   GB3F4
DDEC @TEMP1            Go back to preceding char
CALL NUMERC            Is it numeric?
BR   PTIME             No, so it is timing
DINCT @TEMP1           Yes, on to following char
CALL NUMERC            Is it numeric too?
BS   NOTIME            Yes, both numeric => not timi
PTIME  ST   >3C,@TIMLEN       Both not numeric  => timing
RTN
GB3F4  CEQ  HYPEN,@CCHAR
BR   GB404
DINC @TEMP1            Check next char
CALL NUMERC            Is it numeric?
BS   NOTIME            Was numeric => not a timing c
ST   >0C,@TIMLEN       Was not numeric => set as tim
RTN
GB404  CEQ  COLON,@CCHAR
BR   GB40D
ST   >30,@TIMLEN
RTN
GB40D  CEQ  SEMICO,@CCHAR
BR   NOTIME
ST   >1E,@TIMLEN
RTN
NOTIME ST   >FF,@TIMLEN       Set as no timing char present
RTN
***********************************************************
* NUMERC tests the char pointed to by PTCCIS and verifies
* the following:
*  1 - it is within the current string boundaries
*  2 - it is numeric (i.e. between '0' and '9')
* If both of the above conditions are true, COND is set
* upon return, otherwise COND is reset
***********************************************************
NUMERC DCH  @PTLCIS,@TEMP1
BS   GB430
DCH  @TEMP1,@PTFCIS
BS   GB430
CHE  >30,V*TEMP1
BR   GB430
CH   >39,V*TEMP1
BR   SETCB
GB430  RTNC
***********************************************************
* LOOKUP is a prolong routine to SEARCH. In each PHROM,
* there may be 2 trees, one starting at >0000 and the other
* at >8000. Either may or may not be present. Presences is
* determined if a >AA byte is at the starting location.
* LOOKUP determines if the tree at >0000 is in, and if so,
* calls SEARCH with that addr. If that tree is not present
* or the phrase couldn't be found in it, LOOKUP then checks
* if the tree at >8000 is present, and again, if so, calls
* SEARCH with that tree address. If the word was found in
* the first tree, or after searching the second tree, the
* routine will return.
***********************************************************
LOOKUP DCLR @BYTE1            BYTE1 contains addr of curr t
TRYAGN DST  @BYTE1,@PTFBPH    Look for >AA tree header
ST   >10,@VAR0(@WRITE) Put out read byte command
BR   GB44E
DINC @PTFBPH           Skip the tree header
CALL SEARCH            Go search this PHROM tree
DCZ  @DATAAD           Phrase found => exit
BR   FOUND
GB44E  DADD >8000,@BYTE1      Go to start of next PHROM tre
* Note >8000 + >8000 = >0000 => tried both trees
DCZ  @BYTE1
BR   TRYAGN
DCLR @DATAAD           Didnt find phrase in either t
FOUND  RTN
***********************************************************
* SEARCH actually searches the PHROM tree for the phrase.
* The PHROM tree organization is as follows:
*        (i.e. this is one phrase node)
*              phrase ASCII length      1 byte
*              actual ASCII characters  n bytes
*              less then pointer        2 bytes
*              greater then pointer     2 bytes
*              speech data pointer      3 bytes
*              speech data length       1 byte
* The comparison of two words proceeds on a char by char
* basis, where length is secondary to char values, i.e.
* move > answer; number < we; eight < eighty; etc...
***********************************************************
ST   >10,@VAR0(@WRITE) Issue read byte command
CLR  @PTLCPH           Length of phrase => PTLCPH
ST   @VAR0(@READ),@PTLCPH+1 (stored as 2 byte value
DST  @PTFBPH,@PTCCPH   Set up curr char as 1 beyond
DINC @PTCCPH            length byte
DST  @PTFCIP,@PTCCIP   Reset current ptr into phrase
* Compare two characters
NEXT   ST   >10,@VAR0(@WRITE) Issue read byte command
ST   @VAR0(@READ),@PHDATA Get char in from PHROM
CEQ  V*PTCCIP,@PHDATA  Compare the char
BR   GB4D1
DINC @PTCCPH           Equal, advance both pointers
DINC @PTCCIP
CEQ  SPACE,V*PTCCIP    Skip extra spaces
BR   GB4A1
GB48D  CEQ  SPACE,[email protected](@PTCCIP) While spaces
BR   GB498
DINC @PTCCIP           Skip them
BR   GB48D
* By skipping extra spaces, might have reached end of phras
* If this is true, next char in phrase = #. If so, advance
* the pointer to be beyond end of phrase.
GB498  CEQ  NUMBER,[email protected](@PTCCIP)
BR   GB4A1
DINC @PTCCIP
GB4A1  DCH  @PTLCPH,@PTCCPH   End of PHROM word?
BR   GB4C6
DCH  @PTLCIP,@PTCCIP   Yes, end of phrase
BR   GB4C0
DST  @PTLCPH,@PTFBPH   Yes, word found
* Skip 5 bytes down from last char to data pointer
ST   >10,@VAR0(@WRITE) Issue read byte command
ST   @VAR0(@READ),@STRLEN Get length of speech data
RTN
GB4C0  DST  3,@PTFBPH         Move 3 bytes past PTLCPH
BR   NXTPHR
GB4C6  DCH  @PTLCIP,@PTCCIP   2 characters
BR   NEXT
DST  1,@PTFBPH         Phrase linger: use LT ptr
BR   NXTPHR
* Two characters compared were not equal
GB4D1  DST  3,@PTFBPH         3 bytes past last to GT
CH   V*PTCCIP,@PHDATA  After phrase
BR   NXTPHR
DDECT @PTFBPH          Back up 2 bytes to LT link
* Go get next phrase out of the PHROM to compare
DCZ  @DATAAD           More leaves on this tree
BR   GB4E8
RTN                    No, return empty handed
BR   SEARCH            Go compare this new word!
* The program should never reach this point!! It should
* return somewhere up above.
***********************************************************
* found in PTFBPH. Note that the PHROM is expecting five
* nybbles to be written out as the address.
***********************************************************
DST  @PTFBPH,@TEMP2     address into temporary areas
SRL  4,@TEMP1          Isolate the MSN of the MSB
SRL  4,@TEMP1+1        Isolate the MSN of the LSB
DAND >0F0F,@TEMP2      Isolate the LSN of the MSB, L
DOR  >4040,@TEMP1      Include a 4 as MSN of all 4 n
ST   @TEMP2+1,@VAR0(@WRITE) Write out the LSN of th
ST   @TEMP1+1,@VAR0(@WRITE) Write out the LSN of th
ST   @TEMP2,@VAR0(@WRITE)   Write out the MSN of th
ST   @TEMP1,@VAR0(@WRITE)   Write out the MSN of th
ST   >40,@VAR0(@WRITE)      Write out 0 as fifth ny
RTN
***********************************************************
***********************************************************
ST   >10,@VAR0(@WRITE) Get high byte of addr
ST   >10,@VAR0(@WRITE) Get low byte of addr
RTN
***********************************************************
* STDATA will store the data in DATAAD and TOTTIM onto the
* speech list. It will also check that there is room on the
* speech list for this entry, and abort with error if not.
***********************************************************
STDATA DCEQ @PTEBSL,@PTLBSL   Is there room?
MOVE 3,@TOTTIM,V*PTLBSL   Put data in list
DADD 3,@PTLBSL              and inc top of list
RTN
***********************************************************
* WAIT loops until the speech peripheral goes idle.
***********************************************************
*    ( Loop until nobody is talking)
CLOG >80,@SPKSTS
BR   WAIT
RTN
***********************************************************
***********************************************************
RTN
***********************************************************
*                    ERROR MESSAGES
***********************************************************
*      The following calls are in EXECS file.
* ERRSYN CALL ERRZZ           * SYNTAX ERROR
*        BYTE 3
* ERRSNM CALL ERRZZ           * STRING-NUMBER MISMATCH
*        BYTE 7
* ERRBV  CALL ERRZZ           * BAD VALUE
*        BYTE 30
* ERRIAL CALL ERRZZ           * INCORRECT ARGUMENT LIST
*        BYTE 31
***********************************************************
ERRSSL  CALL ERRZZ          * SPEECH STRING TOO LONG
BYTE 21
***********************************************************
MOVES   CALL SPNUM1         MOVES(TYPE\$,BYTES,\$,TO)
*                            or MOVES(TYPE\$,BYTES,FROM,\$)
MOVESA CALL STRGET          * ( or ,
DST  V*FAC4,@VAR5    * TYPE "VRG"
CALL GETNUM          * ,BYTES
DCZ  @FAC            0?
DST  @FAC,@BYTES     SAVE NUMBER OF BYTES
CALL STRFCH          * ,FROM
CEQ  36,@VAR5
BR   MOVESX
CHE  @FAC6,@BYTES+1
BS   MOVESB
CLR  @BYTES
ST   @FAC6,@BYTES+1
BR   MOVESB
MOVESX CALL CFIFCH
DST  @FAC,@FAC4
MOVESB DST  @FAC4,@VARY
CEQ  36,@VAR6
BR   MOVESN
DCHE 256,@BYTES
BS   ERRBV
XML  GETSTR
CALL NGOOD
DST  @SREF,@FAC
BR   MOVESC
MOVESN CALL SUBLP3          * ,TO
MOVESC DST  @FAC,@VARY2
CEQ  36,@VAR5        * VDP FROM
BR   MTYPES
ST   86,@VAR5
MTYPES CEQ  36,@VAR6
BR   MTYPE
ST   86,@VAR6
MTYPE  CEQ  86,@VAR5        * VDP FROM
BR   MTYPE3
CEQ  86,@VAR6        * VDP TO
BR   MTYPE1
MTYPE0 MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE1 CEQ  82,@VAR6        * RAM TO
BR   MTYPE2
MOVE @BYTES,[email protected](@VARY),@0(@VARY2)
MTYPE2 CEQ  71,@VAR6        * GRAM TO
BR   MTYPE3
MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE3 CEQ  82,@VAR5        * RAM FROM
BR   MTYPE7
CEQ  86,@VAR6        * VDP TO
BR   MTYPE5
MTYPE4 MOVE @BYTES,@0(@VARY),[email protected](@VARY2)
MTYPE5 CEQ  82,@VAR6        * RAM TO
BR   MTYPE6
MOVE @BYTES,@0(@VARY),@0(@VARY2)
MTYPE6 CEQ  71,@VAR6        * GRAM TO
BR   MTYPE7
MOVE @BYTES,@0(@VARY),[email protected](@VARY2)
MTYPE7 CEQ  71,@VAR5        * GRAM FROM
BR   MOVESD
CEQ  86,@VAR6        * VDP TO
BR   MTYPE9
MTYPE8 MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MTYPE9 CEQ  82,@VAR6        * RAM TO
BR   MTYPEA
MOVE @BYTES,[email protected](@VARY),@0(@VARY2)
MTYPEA CEQ  71,@VAR6        * GRAM TO
BR   MOVESD
MOVE @BYTES,[email protected](@VARY),[email protected](@VARY2)
MOVESD CEQ  >B3,@CHAT
BS   MOVESA
BR   LNKRTN
******************************************************
* CALL HEX(variable,variabel,...)                    *
******************************************************
HEX    CALL SPNUM1
HEXAGN CALL STRFCH            Get STRING or NUMBER
CEQ  >65,@FAC2         STRING?
BS   HEXSTR            Yes
CALL CFIFCH            No
DST  @FAC,@TEMP2
DST  >0004,@BYTES
XML  GETSTR
DST  @SREF,@STRPTR
ST   @TEMP2,@VAR0
SRL  4,@VAR0
CALL HEXNS
ST   @TEMP2,@VAR0
SLL  4,@VAR0
SRL  4,@VAR0
CALL HEXNS
ST   @TEMP2+1,@VAR0
SRL  4,@VAR0
CALL HEXNS
ST   @TEMP2+1,@VAR0
SLL  4,@VAR0
SRL  4,@VAR0
CALL HEXNS
CEQ  COMMAZ,@CHAT
BR   ERRSYN
CALL NGOOD
BR   HEXDON
HEXNS  CHE  >0A,@VAR0
BR   HEXNS2
ST   @VAR0,V*STRPTR
DINC @STRPTR
RTN
HEXSTR DCLR @TEMP2
DST  @FAC4,@STRPTR
DCHE 5,@FAC6
BS   HEXS4
CASE @FAC7
BR   HEXS0
BR   HEXS1
BR   HEXS2
BR   HEXS3
BR   HEXS4
HEXS4  CALL HEXSN
SLL  4,@VAR0
HEXS3  CALL HEXSN
HEXS2  CALL HEXSN
SLL  4,@VAR0
HEXS1  CALL HEXSN
HEXS0  XML  PGMCHR
CALL SNDER
CALL CLRFAC
DST  @TEMP2,@FAC
CALL CIFSND
HEXDON CEQ  COMMAZ,@CHAT
BS   HEXAGN
BR   LNKRTN
HEXSN  ST   V*STRPTR,@VAR0
CHE  103,@VAR0         * g ?
BS   ERRBA
CHE  97,@VAR0          * a ?
BR   HEXSN2
SUB  32,@VAR0          * -32
HEXSN2 CHE  71,@VAR0          * G ?
BS   ERRBA
CHE  65,@VAR0          * A ?
BR   HEXSN3
SUB  55,@VAR0          * -55
BR   HEXSN4
HEXSN3 CHE  58,@VAR0          * : ?
BS   ERRBA
CHE  48,@VAR0          * 0 ?
BR   ERRBA
SUB  48,@VAR0          * -48
HEXSN4 DINC @STRPTR
RTN
**************************
RXBIO  CALL SPNUM1       * IO
IOAGN  CALL GETNUM       * TYPE 0-6
CHE  >07,@FAC1
BS   ERRBV
ST   @FAC1,@VARY
CASE @VARY        * BITS/BYTES
BR   SOG
BR   SOV
BR   CRUI
BR   CRUO
BR   CSW
BR   CSR
BR   CSV
SOG    I/O  0,@FAC
BR   IODONE
SOV    I/O  1,@FAC
BR   IODONE
CRUI   CALL CRUSET
I/O  2,@VAR4
XML  PGMCHR
CALL SNDER
CALL CLRFAC
ST   @VAR0,@FAC1
CALL CIFSND       * VARIABLE1
CHE  >09,@VARY
BS   CRUI16
BR   IODONE
CRUI16 XML  PGMCHR
CALL SNDER
CALL CLRFAC
ST   @VARV,@FAC1
CALL CIFSND       * VARIABLE2
BR   IODONE
CRUO   CALL CRUSET
CALL SUBLP3       * VARIABLE1
DCHE >0100,@FAC
BS   ERRBV
CHE  >09,@VARY
BS   CRUO16
ST   @FAC1,@VAR0
BR   CRUO8
CRUO16 DST  @FAC,@VAR0
CALL SUBLP3       * VARIABLE2
DCHE >0100,@FAC
BS   ERRBV
ST   @FAC1,@VARV
CRUO8  I/O  3,@VAR4
BR   IODONE
I/O  4,@VAR4
BR   IODONE
I/O  5,@VAR4
BR   IODONE
I/O  6,@VAR4
IODONE CEQ  >B3,@CHAT
BS   IOAGN
BR   LNKRTN
CRUTMP DST  @FAC,@VAR4
DCLR @VAR5
DCLR @VAR0
RTN
CRUSET CZ   @FAC1
BS   ERRBV
CHE  >11,@FAC
BS   ERRBV
ST   @FAC1,@VARY
CALL CRUTMP
ST   @VARY,@VAR5
RTN
DST  @FAC,@VAR5
RTN
*******************************
HVPNUM CLR  @FAC11            Select XB FLP
XML  XCNS
BR   HVPUTN
INC  @FAC11            Supress space out
DEC  @FAC12            Shorten length
HVPUTN CLR  @BYTES
ST   @FAC12,@BYTES+1        Length
XML  GETSTR
MOVE @BYTES,*FAC11,V*SREF   Store in VDP rollout
DST  @BYTES,@FAC6           Store length
RTN
*******************************
HPUT   CALL SPNUM1            * HPUT
HPAGIN CALL ROWCOL            Get ROW & COL
CALL STRFCH            Get string or number
CEQ  >65,@FAC2         String?
BS   HPUTS             Yes
CALL HVPNUM            No, XCNS
HPUTS  DCZ  @FAC6
BS   HPOUT
DCLR @FAC
HPUTLP CALL PUTLP
CALL HFMT
DDEC @FAC6
BR   HPUTLP
HPOUT  CEQ  >B3,@CHAT
BS   HPAGIN
BR   XPTRTN
**************************
VPUT   CALL SPNUM1            * VPUT
VPAGIN CALL ROWCOL            Get ROW & COL
CALL STRFCH            Get string or number
CEQ  >65,@FAC2         String?
BS   VPUTS             Yes
CALL HVPNUM            No, CNS
VPUTS  DCZ  @FAC6
BS   VPOUT
DCLR @FAC
VPUTLP CALL PUTLP
CALL VFMT
DDEC @FAC6
BS   VPOUT
CZ   @YPT
BR   VPUTLP
INC  @XPT
B    VPUTLP
VPOUT  CEQ  >B3,@CHAT
BS   VPAGIN
BR   XPTRTN
****************************
HVGETS CALL ROWCOL
CALL GETNUM
DCGT >00FF,@FAC
DST  @FAC,@BYTES
DST  @FAC,@TEMP1
XML  GETSTR
DST  @SREF,@STRPTR
RTN
****************************
HGET   CALL SPNUM1             * HGET
HAGAIN CALL HVGETS
LP2    CALL GETLP
CALL HFMT
DDEC @TEMP1
BR   LP2
HDONE  CALL NGOOD
CEQ  >B3,@CHAT
BS   HAGAIN
BR   XPTRTN
**************************
VGET   CALL SPNUM1              * VGET
VAGAIN CALL HVGETS
LP1    CALL GETLP
CALL VFMT
DDEC @TEMP1
BS   VDONE
CZ   @YPT
BR   LP1
INC  @XPT
B    LP1
VDONE  CALL NGOOD
CEQ  >B3,@CHAT
BS   VAGAIN
BR   XPTRTN
***************************
GMOT   CALL SPNUM1              * GMOTOIN
GMAGN  CALL SPNUM2
ST   >02,@TEMP1
DST  [email protected]>0480(@SPSAL),@TEMP2
GMO1   CALL PREPN
ST   @TEMP2,@FAC+1
CH   >7F,@FAC+1
BR   GMO2
NEG  @FAC+1
DNEG @FAC
GMO2   CALL CIFSND
CEQ  >01,@TEMP1
BS   GMO3
XML  SPEED
DATA >00B3
GMO3   EX   @TEMP2,@TEMP2+1
DEC  @TEMP1
BR   GMO1
CEQ  >B3,@CHAT
BS   GMAGN
BR   LNKRTN
**************************
RMOT   CALL SPNUM1              *    RMOTION
RMAGN  XML  PGMCHR
CEQ  >EC,@CHAT
BR   NOALL
XML  SPEED
DATA >00EC
DST  >001C,@VAR0
NXALL  DST  @VAR0,@FAC
CALL SPNUM5
BR   RMALL
NOALL  DST  >0001,@VAR0
CEQ  >FD,@CHAT
BR   ERRSYN
CALL NUMFCH
CALL SPNUM4
RMALL  DST  [email protected]>0480(@SPSAL),@TEMP1
ST   >02,@TEMP2
RMOTLP CZ   @TEMP1
BS   J2
CEQ  >80,@TEMP1
BS   J3
CH   >7F,@TEMP1
BS   J1
NEG  @TEMP1
BR   J2
J1     ABS  @TEMP1
J2     EX   @TEMP1,@TEMP1+1
DEC  @TEMP2
BR   RMOTLP
DST  @TEMP1,[email protected]>0480(@SPSAL)
J3     DDEC @VAR0
BR   NXALL
CEQ  >B3,@CHAT
BS   RMAGN
BR   LNKRTN
*****************************************
S1ET9F XML  SPEED  * CHECK FROM
DATA >021E  * 30 TO 159
DATA >009F  *
RTN         *
*****************************************
INV    CALL SPNUM1            * INVERSE(CHAR#)
INVAGN XML  PGMCHR
CEQ  >EC,@CHAT
BR   INOALL
XML  SPEED
DATA >00EC
DST  >001E,@FAC
DSLL 3,@FAC
DST  >01C8,@TEMP1
BR   INVLP
INOALL XML  PARSE
BYTE >B6
CALL S1ET9F
DSLL 3,@FAC
DST  >0004,@TEMP1
INVLP  DINV [email protected]>0300(@FAC)
DDEC @TEMP1
BR   INVLP
INVNOK CEQ  >B3,@CHAT
BS   INVAGN
BR   LNKRTN
*****************************************
SSDSLL CALL STRFCH
CALL S1ET9F
DSLL 3,@FAC
RTN
*****************************************
SWCHR  CALL SPNUM1      * SWAPCHAR(CHAR#,CHAR#)
SWCHAG CALL SSDSLL
DST  @FAC,@VAR4
CEQ  >B3,@CHAT
BR   ERRSYN
CALL SSDSLL
DST  @FAC,@VAR5
MOVE 8,[email protected]>0300(@VAR4),@FAC
MOVE 8,[email protected]>0300(@VAR5),[email protected]>0300(@VAR4)
MOVE 8,@FAC,[email protected]>0300(@VAR5)
CEQ  >B3,@CHAT
BS   SWCHAG
BR   LNKRTN
******************************************
DUPCHR CALL SPNUM1      * DUPCHAR(CHAR#,CHAR#)
DCHAGN CALL SSDSLL
DST  @FAC,@VAR4
CEQ  >B3,@CHAT
BR   ERRSYN
CALL SSDSLL
MOVE 8,[email protected]>0300(@VAR4),[email protected]>0300(@FAC)
CEQ  >B3,@CHAT
BS   DCHAGN
BR   LNKRTN
******************************************
S00T10 XML  SPEED  * CHECK FROM
DATA >0200  * 0 TO 16
DATA >0010  *
RTN         *
******************************************
SWCLR  XML  SPEED      * SWAPCOLOR(SET#,SET#)
DATA >00B7
SCOL10 CEQ  >FD,@CHAT
BR   SCOL20
CALL SPNUM3
ST   [email protected]>0003(@FAC),@VAR4
DST  @FAC,@VAR5
CEQ  >FD,@CHAT
BR   ERRSYN
CALL STRFCH
CALL SPNUM4
ST   [email protected]>0003(@FAC),[email protected]>0003(@VAR5)
ST   @VAR4,[email protected]>0003(@FAC)
CEQ  >B3,@CHAT
BR   LNKRTN
XML  PGMCHR
BR   SCOL10
SCOL20 XML  SPEED
BYTE >01
CALL S00T10
DST  @FAC,@VAR4
XML  PARSE
BYTE >B6
CALL S00T10
ST   V*FAC,@VAR0
ST   V*VAR4,V*FAC
ST   @VAR0,V*VAR4
CEQ  >B3,@CHAT
BR   LNKRTN
XML  PGMCHR
BR   SCOL20
******************************************
DUPCLR XML  SPEED        * DUPCOLOR(SET#,SET#)
DATA >00B7
DCOL10 CEQ  >FD,@CHAT
BR   DCOL20
CALL SPNUM3
ST   [email protected]>0003(@FAC),@VAR4
CEQ  >FD,@CHAT
BR   ERRSYN
CALL STRFCH
CALL SPNUM4
ST   @VAR4,[email protected]>0003(@FAC)
CEQ  >B3,@CHAT
BR   LNKRTN
XML  PGMCHR
BR   DCOL10
DCOL20 XML  SPEED
BYTE >01
CALL S00T10
ST   V*FAC,@VAR0
XML  PARSE
BYTE >B6
CALL S00T10
ST   @VAR0,V*FAC
CEQ  >B3,@CHAT
BR   LNKRTN
XML  PGMCHR
BR   DCOL20
*******************************************************
* CPU PROGRAM FOR >8300 SCATCH PAD SUBROUTINE EXECUTE *
*******************************************************
*                          AORG >8300
CPUPGM DATA >8302 * CPUPGM DATA >8302  First address. *
DATA >0420 *        BLWP >834A  Switch contex  *
DATA >834A *                    FAC not used   *
DATA >04E0 *        CLR  @>837C Clear for GPL  *
DATA >837C *                                   *
*        END                        *
*******************************************************
EXECUT CALL SPNUM1
EXAGN  CALL SUBLP3
MOVE 12,@VAR0,[email protected]   Save CPU values
MOVE 12,[email protected],@VAR0   Restore CPU values
CEQ  >B3,@CHAT          Comma?
BS   EXAGN              Repeat
BR   LNKRTN
***********************************************************
STRI 'SIZE'            SIZE
DATA \$+2
B    SZSIZE
STRI 'CLSALL'          CLSALL
DATA \$+2
CALL CLSALL            Close all open files
BR   LNKRT2
STRI 'BYE'             BYE
DATA \$+2
CALL CLSALL            Close all open files
EXIT
STRI 'NEW'             NEW
DATA \$+2
RXBNEW CLR  [email protected]          Clear AUTOLOAD flag
CALL CLSALL
B    SZNEW
STRI 'BIAS'            BIAS
DATA \$+2
CALL SPNUM1            (
BIASAG CALL GETNUM            Get number
DST  @FAC,@VAR0        Save number
CALL STRGET            Get string
DST  @FAC4,@VARY       Save location
DST  @FAC6,@VARY2      Save length
BIASLP ST   V*VARY,@FAC1      * Character.
DCZ  @VAR0             0?
BS   BIASM             Yes.
BR   BIASSV
BIASM  SUB  96,@FAC1          MINUS OFFSET
BIASSV ST   @FAC1,V*VARY      Store it
DINC @VARY             Next one in string
DDEC @VARY2            Counter-1
BR   BIASLP            Loop till zero
CEQ  >B3,@CHAT         ,?
BS   BIASAG            Yes
BR   LNKRTN            Done return
STRI 'EALR'            EALR
DATA \$+2
CALL EASAVE
BYTE >33
STRI 'EAPGM'           EAPGM
DATA \$+2
CALL EASAVE            Get path
BYTE >35
STRI 'EAED'            EAED
DATA \$+2
XEAED  CALL EASAVE            Get path
BYTE >31
EASAVE CALL SPNUM1            (
CALL STRGET            Get path
ST   @FAC,[email protected]>2256      Save length
MOVE @FAC6,[email protected](@FAC4),[email protected]>2257 Load buffer
ST   >0D,[email protected]>2257(@FAC6) Put ENTER key at end
FETCH @CHAT            Get character
EAMENU CALL CLSALL            Close all open files
B    GE025             Got to EA CART
DATA \$+2
CALL CLSALL            Close all open files
BR   RXBRUN            Run it
STRI 'RUN'             RUN(pathname) duplicat XBPGM
DATA XBPGM
STRI 'XBPGM'           XBPGM
DATA \$+2
XBPGM  CALL SPNUM1
CALL CLSALL            Close all open files
CALL STRGET            Get string
DCZ  @FAC6             Zero string length?
BS   RXBXBP            Yes
CLR  [email protected]>2254           Clear buffer
MOVE 50,[email protected]>2254,[email protected]>2255 Ripple clear
DST  >994A,[email protected]>2254     Set flag
ST   @FAC7,[email protected]>2256     Save length byte
MOVE @FAC6,[email protected](@FAC4),[email protected]>2257 Save string
CLR  [email protected]>35D7           Clear RXB MENU Flag
RXBXBP CEQ  >B3,@CHAT         Comma?
BR   RXBRUN            No
CALL RXBFIL            Set files
RXBRUN B    TOPLEV            RUN IT
STRI 'FILES'           FILES
DATA \$+2
CALL SPNUM1            (
CALL CLSALL            Close all open files
CALL RXBFIL            Set files
BR   RXBNEW            Go do a NEW
RXBFIL CALL SUBLP3            Get Files value
DCZ  @FAC              Zero?
BS   ERRBV             Yes, BAD VALUE error
DCHE 16,@FAC           16 or more to high
BS   ERRBV             Yes, BAD VALUE error
CEQ  RPARZ,@CHAT       )?
BR   ERRSYN            SYNTAX ERROR
XML  PGMCHR            Skip )
DCLR @FAC2             Clear
DST  >0116,[email protected]     Set files buffer space
CALL DSKDSR
RTN
***********************************************************
* CALL KEY(string,keyunit,Nvarible,Nvariable...)
* CALL KEY(keyunit,Nvariable,Nvarible...)
***********************************************************
ZKEY   CALL KEY               Get key
CEQ  COMMAZ,@CHAT
BS   ZKEY
BR   LNKRTN
***********************************************************
KEYJOY ST   @FAC1,@VAR0       Keyboard selection
CALL NUMVAR            Get variable for key-code
CEQ  COMMAZ,@CHAT      If not comma - error
BR   ERRSYN            SYNTAX error
XML  PGMCHR            Get next character
CALL NUMVAR            Get variable for key-status
ST   @VAR0,@KEYBD      Keyboard selection
MOVE 8,[email protected],@FAC     Set up float
CALL KEYSTR            * RXB KEY STRING COMPARISON *
ST   @STATUS,@VARY     Save stutus
RTNC                   Return scan condition co
***********************************************************
KEYSTR DCEQ >994A,@TOPSTK     Flag set?
BR   RSCAN3            No.
DST  @CCPPTR,@ACCUM    Copy length.
CLR  @BYTE3            Zero out counter
RSCAN  CEQ  ONZ,@BYTE1        ON flag?
BR   RSCAN0            No
SCAN                   Get a key
B    RSCAN1            Jump past normal KEY
RSCAN0 SCAN                   Any key?
BR   RSCAN0            No.
RSCAN1 DCZ  @CCPPTR           Length 0?
BS   RSCAN4            Yes.
RSCAN2 INC  @BYTE3            Counter +1
CEQ  V*VARC,@RKEY      Same?
BS   RSCAN5            Yes.
DDEC @ACCUM            Length -1
BR   RSCAN2            No matcth.
CEQ  ONZ,@BYTE1        ON flag?
BS   RSCAN4            Yes
B    KEYSTR            Restart.
RSCAN3 SCAN                   Normal key scan.
RSCAN4 CLR  @KEYBD            Clear key unit
DCLR @TOPSTK           Clear flag.
RTNC                   Return save condition
RSCAN5 CALL RSCAN4
CEQ  @VAR0,@VAR0       Force condition bit on
RTNC                   Return save condition
***********************************************************
* CALL ONKEY(string,keyunit,variable,variable)
* GOTO line#,line#,line#...
***********************************************************
ZONKEY ST   ONZ,@BYTE1
CZ   @PRGFLG           Program mode?
CALL KEY               Get normal key,status
CZ   @VARY             Was a key pressed?
BR   GOTON0            No ONZ flag stays set
CLR  @BYTE1            Clear ONZ flag
GOTON0 CEQ  RPARZ,@CHAT       )
BR   ERRSYN            SYNTAX ERROR
XML  PGMCHR            Skip )
CEQ  GOTOZ,@CHAT       GOTO flag?
BR   ERRSYN            SYNTAX ERROR
CLR  @BYTE2            Zero out Counter
ONLP   INC  @BYTE2            Counter +1
XML  PGMCHR            Skip GO
CEQ  LNZ,@CHAT         Line# token?
BR   ERRSYN            SYNTAX ERROR
XML  PGMCHR            Skip line# token
ST   @CHAT,@FAC        Store high byte line#
XML  PGMCHR            Skip high byte line#
ST   @CHAT,@FAC1       Store low byte line#
XML  PGMCHR            Skip low byte line#
CEQ  @BYTE3,@BYTE2     \$ counter = line# counter
BR   ONKEY1            No
DST  @FAC,@VARY        Save line#
ONKEY1 CEQ  COMMAZ,@CHAT      ,?
BS   ONLP              Yes, keep going
DST  @VARY,@FAC        Get saved line#
CEQ  ONZ,@BYTE1        ONZ flag?
**********************************************************
GKEY1  DST  @ENLN,@FAC2        Get last address
DSUB 3,@FAC2            Point to first LINE#
GKEY2  CALL GRSUB3             Read from VDP/RAM
BYTE FAC2
DCEQ @EEE1,@FAC         Same?
BS   GKEY3              Yes, found line#
DCH  @STLN,@FAC2        No line# left
DSUB 4,@FAC2            Next LINE#
BR   GKEY2              Loop
GKEY3  DST  @FAC2,@EXTRAM      Got LINE#
DADD 4,@EXTRAM          Point to begining of line
DST  @EXTRAM,@PGMPTR    Set pointer to line to run
DINCT @PGMPTR           Point to tokens
**********************************************************
*                  SUBPROGRAM FOR 'JOYSTICK'
**********************************************************
JOYST  CALL SPAR              KEY UNIT
* RXB PATCH LABEL ************
JOYRPT XML  SPEED             Insure in range
BYTE RANGE          *   of 1 - 4
BYTE 1
DATA 4
*                             GET VARIABLES FOR X, Y
*                              AND SCAN KEYBOARD
ST   @FAC1,@VAR0       Keyboard selection
CALL NUMVAR            Get variable for key-code
CEQ  COMMAZ,@CHAT      If not comma - error
BR   ERRSYN
XML  PGMCHR            Get next character
CALL NUMVAR            Get variable for key-status
ST   @VAR0,@KEYBD      Keyboard selection
MOVE 8,[email protected],@FAC     Set up float
SCAN                   SCAN the keyboard
CLR  @KEYBD            Clear the code(No affect on s
ST   @JOYY,@VAR0       JOYSTICK Y POSITION
CALL JOYXY             -4 to +4
DST  >4001,@FAC        Re-store F.P. 1 in FAC
ST   @JOYX,@VAR0       JOYSTICK X POSITION
CALL JOYXY             -4 to +4
RTN
***********************************************************
ZJOYST CALL JOYST
JOYAGN CEQ  COMMAZ,@CHAT
BR   LNKRTN
CALL CPAR2
CALL JOYRPT
BR   JOYAGN
************************************************************
SUBRTN RTN
***************************
ERRFE  CALL ERRZZ         *
BYTE 34            *
DSKDSR DCHE 256,@VAR0     *
BR   DSRDSS        *
DSRDSS DST  VROAZ,@FAC12  *
BYTE >0A           *
ST   @ERCODE,@VAR2 *
SRL  4,@FAC6       *
CZ   @FAC6         *
BR   ERRFE         *
CEQ  >20,@VAR2     *
BS   ERRFE         *
RTN                *
***************************
* GCHAR PATCH FOR COMMA
GCHARA CEQ  COMMAZ,@CHAT      ,?
BS   GCHAR
BR   XPTRTN
***********************************************************
* MOTION PATCH for GO and STOP
SPGS   XML  PGMCHR            ( or ,
CEQ  ALLZ,@CHAT        ALL?
BR   SPGS1             No.
XML  PGMCHR            Skip ALL
XML  PGMCHR            Skip ,
DST  1,@FAC            First sprite
CALL SPNUM5            Get sprite table
CALL SPMOVE            Store velocity
ST   28,@FAC           Last sprite
DCLR @VAR0             Index
SPGSA  MOVE 2,[email protected]>0780,[email protected]>0780(@VAR0)
DEC  @FAC              Sprite -1
BR   SPGSA             Done?
B    SPRMV4            No.
SPGS1  CEQ  NUMBEZ,@CHAT      #?
BR   SPGS2             No.
CALL SPNUM6            Standard routine.
B    SPRMV3
SPGS2  CEQ  GOZ,@CHAT         GO?
BR   SPGS3             No.
AND  >BF,@>83C2        GO!!!
B    SPGS4             Done.
SPGS3  CEQ  STOPZ,@CHAT       STOP?
BR   ERRSYN            No
OR   >40,@>83C2        STOP!!!
SPGS4  XML  PGMCHR            Skip GO or STOP
B    SPRMV4
***********************************************************
SPAR   CEQ  LPARZ,@CHAT       (?
BS   SPAR1             Yes.
CEQ  COMMAZ,@CHAT      ,?
BR   ERRSYN            No.
SPAR1  XML  PGMCHR            Skip ( or ,
XML  PARSE             Get string or value.
BYTE RPARZ
CEQ  >65,@FAC2         String?
BR   SPAR2             No.
DST  @FAC6,@VARY2      Save length.
DST  >994A,@TOPSTK     Set flag.
CALL LPAR
RTN
SPAR2  XML  SPEED
BYTE SYNCHK
BYTE COMMAZ
RTN
*****************************
CPAR2  XML  SPEED           * Similar to LPAR
DATA COMMAZ          * Syntax check ,
BR   GAC35           * Parse value
*****************************
ZSCOI  CALL SPRCOI       *    COINC
COINLP CEQ  >B3,@CHAT    *
BR   LNKRTN       *
XML  PGMCHR       *
CALL GAF56        *
BR   COINLP       *
**************************
NR     CALL PREPN        *
AR     XML  ASSGNV       *
RTN               *
**************************
ZSDIST CALL DIST         *    DISTANCE
DISLP  CEQ  >B3,@CHAT    *
BR   LNKRTN       *
CALL GAFC4        *
BR   DISLP        *
*********************************************************      ```

...lee

##### Share on other sites

Very nice that you know where to find all this.

So we are keeping "kosher" if we use similar methods.

##### Share on other sites
59 minutes ago, TheBF said:

Very nice that you know where to find all this.

So we are keeping "kosher" if we use similar methods.

I think so. My corrigenda keep growing. I really must update my website ere long.

...lee

##### Share on other sites

Been busy today but finally tried my sprite collider with some different versions of COINC.

So my new COINC is this.  [email protected] reads 2 bytes. The code word SPLIT, splits the word into 2 bytes on the stack.

This version measures 66 ticks of the 9901 clock include parameters

```: COINC ( spr#1 spr#2 tol -- ?)  \ 1.4 mS, 1.1 mS optimized
>R  SP.Y [email protected] SPLIT
ROT SP.Y [email protected] SPLIT
( -- col row  col row)
ROT - ABS [email protected]  <
-ROT - ABS R>  <
AND ;```

The original TI code has been named COINC.TI  is being tested with my new SP.DIST which is about 2X faster than the original.

My minor change is to change the DUP + to the code word 2*. This is called COINC.NEW

My improved version times at 78 ticks

The TI version is 83 ticks.

The test:

1. Fire 2 sprites at each other at automotion speed 100

2. Report the distance between the sprites. (uses SQRT on the output of SP.DIST to a real value)

Assumption:

A faster COINC routine will halt with less overlap of the sprites ie: a greater distance.

Here is the code.
The word DETECTOR is a deferred word so we can change the action with the different versions of COINC

The video shows the result.

Spoiler
```\ coincidence test

NEEDS RED        FROM DSK1.COLORS
NEEDS AUTOMOTION FROM DSK1.AUTOMOTION
NEEDS DEFER      FROM DSK1.DEFER

DEFER DETECTOR  ' COINC IS DETECTOR

MARKER /REMOVE
: SQRT ( n -- n ) -1 TUCK DO   2+  DUP +LOOP  2/ ;

: COINC.NEW ( sp#1 sp#2 tol -- ? ) DUP * 2* -ROT SP.DIST >= ;

: COINC.TI  ( spr#1 spr#2 tol  --- f ) ( 0= no coinc  1= coinc )
DUP * DUP + >R        ( STACK: spr#1 spr#2 R: tol*tol+tol*tol)
SP.DIST R>            ( STACK: dist^2 2*tol^2)
> 0=   ;              ( within tolerance? STACK: flag)

STOPMOTION

DECIMAL

: COLLIDE ( speed -- )
PAGE ." Coincidence Collider"
[CHAR] A  DKRED  0   100  0 SPRITE
[CHAR] B  DKGRN  240 100  1 SPRITE

1 OVER NEGATE  1 MOTION
0 OVER  0 MOTION
0 22 AT-XY ." Speed= " .
0 23 AT-XY ." Press key to fire..."
KEY DROP
AUTOMOTION
BEGIN
0 1 7 DETECTOR
?TERMINAL ABORT" halted"
UNTIL
STOPMOTION
CR ." Distance= " 0 1 SP.DIST SQRT .
;```

##### Share on other sites
1 hour ago, TheBF said:

Been busy today but finally tried my sprite collider with some different versions of COINC.

Nice! I may try your collider tomorrow. Then, I need to pore over those three pages of fbForth 2.0:12 ALC to see how it compares, what with all the bank switching.

On another note, did you notice that XB first checks the sprite coincidence status bit before even trying its COINC code, bailing if it is not set? That certainly makes its execution time a lot shorter with no hit (most of the time), but a bit longer with a hit—potentially (I think) missing the hit. What do you think?

...lee

##### Share on other sites

I missed that but it I have that commented out in mine.

It's like

```: COINC
COINCALL 0= IF EXIT THEN
...CONTINUED CODE HERE```

I will run that on the collider too. It should make the internal loop spin faster but sometimes the overhead of making decisions is slower than just doing the test.

I will remove the BREAK code in the loop now that it is reliable as well. Numbers should change a little.

##### Share on other sites
11 hours ago, Lee Stewart said:

Nice! I may try your collider tomorrow.

Current ALC for COINC caught it at 2. Removing just that one, unnecessary JMP, I mentioned in the posted code, took it to 3!

...lee

##### Share on other sites

Surely theres room for error hit/miss. Maybe 50 percent, ok joking... but at least 1-2

##### Share on other sites

I have made a lot of changes to the graphics primitives relating to sprites, which now do less stack thrashing and have a bit more inline code for reading/writing VRAM than it had before. I still need to make a few more changes that are unnecessarily BL-ing and, then of course, there is that pesky thing called “testing”. Fortunately, all of this code refactoring has, so far, only cost me 14 bytes in Bank 1!

...lee

##### Share on other sites
1 hour ago, Lee Stewart said:

I have made a lot of changes to the graphics primitives relating to sprites, which now do less stack thrashing and have a bit more inline code for reading/writing VRAM than it had before. I still need to make a few more changes that are unnecessarily BL-ing and, then of course, there is that pesky thing called “testing”. Fortunately, all of this code refactoring has, so far, only cost me 14 bytes in Bank 1!

...lee

I knew you deserved that wizard's hat.

Felicitations

• 2
• 1

##### Share on other sites

As discussed above, I need to contrive a better method for deciding whether and how much SAMS memory is available to fbForth 2.0. If there is any, my method will conclude there is 32 MiB—wrong!

One way, I suppose, would be to write to the highest page, shift the address right one bit and check if the written info is there, if it is, I did not have the bank I thought, so rinse and repeat until there is a change. I do not know if that method will produce the least code, but it’s a start.

...lee

##### Share on other sites

I believe I now have a good method for determining whether SAMS is present and how much if it is. It is ten bytes more than the previous code. The opening comments in the spoiler explain how the test is designed. Basically, the leftmost page bit of a test amount of SAMS is set and >000E added. If SAMS is present but not that high, page >000E will be redundantly mapped and the test will fail because that was the page that was written to in the first place. As the left bit is right-shifted to lower SAMS and if SAMS is present, the test will eventually succeed. At that point, the register with the roaming bit will have a value equal to half the number of pages. Doubling that number gets the right number of pages and decrementing it gets the top page#.

The working assumption is that we do not need to worry about any SAMS below 128 KiB, so, if it fails at that amount, the "tracking" register will shift to>0008 and the loop will exit.

Spoiler
```;[*++ Check for presence of SAMS card.
***++ SAMS flag will be set to highest available page #.

* To test, Map >000E + lowest bank not in next lower SAMS to >E000.
* For 32 MiB, this is >1000 + >000E. We initially store >1000 in
* R3 to allow shifting each round before MOVing to R0 to then
* add >000E for the next test. If the test fails at >001E, the last
* viable SAMS (128 KiB), R3 will go to >0008, at which point the loop
* exits, setting R3 to 0, effectively reporting "no SAMS".
*
* Set up SAMS check.
*
LI   R2,>994A          check-value
MOV  R2,@>E000         check-value to check-location
; Classic99 emulator can do 32 MiB
LI   R3,>1000          lowest page above next lower SAMS to R3
LI   R1,>401C          load >E000 for SAMS register
LI   CRU,>1E00         CRU address of SAMS
*
*
SAMS_CHECK:
MOV  R3,R0             lowest bank above next lower SAMS range
AI   R0,>000E          get >000E pages higher
SWPB R0                set up page# for SAMS register
SBO  0                 enable SAMS registers
MOV  R0,*R1            poke SAMS register
SBZ  0                 disable SAMS registers
C    @>E000,R2         compare possible copy with test value
JNE  SAMS_EXIT         exit if SAMS mapped
SRL  R3,1              shift down by ^2 to next lower possibility
CI   R3,>0008          too far?
JGT  SAMS_CHECK        try half as much if not >0008
CLR  R3                no-SAMS..set flag to 0
JMP  SAMS_EXIT0        we're outta here
SAMS_EXIT:
SLA  R3,1              double value (highest page# + 1)
DEC  R3                decrement to highest page#
SAMS_EXIT0:
MOV  R3,@ARG           save SAMS flag to ARG (hoping it survives!)
JEQ  FRTHCP            go to copying Forth inner interpreter if no SAMS
*                             ...no need to restore anything if no SAMS
*
* Remap default bank >0E to >E000.
* R1 and CRU should still have correct values.
*
LI   R0,>0E00          load SAMS bank >000E
SBO  0                 enable SAMS registers
MOV  R0,*R1            poke SAMS register
SBZ  0                 disable SAMS registers
;]*```

I may fiddle with it to see whether I can reduce the code because that bank only has 134 bytes left.

...lee

##### Share on other sites

You may have noticed the time of my last post (2:17 AM). I had no intention of staying up that late last night, but at one point I added something to the code that caused the assembly to blow up. I panicked, thinking that somehow I had screwed up more than just the file I was editing because the surfeit of error messages made no sense. I finally figured out that the problem was a couple of odd characters I had included in a comment as is my wont—the open and close quotes (“ [alt+0147] and ” [alt+0148]). I am in such a habit of using them in any text I type that it did not occur to me to even look there. I did narrow it down to the comments, but was thinking that I might have hit some source-code size maximum. At one point, I thought the ‘#’ was the culprit. While poring over the added comments for anything else odd, those quotes sort of reached out and slapped me! Oh, well....

...lee

## Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

×   Pasted as rich text.   Paste as plain text instead

Only 75 emoji are allowed.

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.