Jump to content
IGNORED

fbForth—TI Forth with File-based Block I/O [Post #1 UPDATED: 06/09/2023]


Lee Stewart

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

  • Sad 1
Link to comment
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... ?

Link to comment
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

  • Like 1
Link to comment
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> <= ;

 

  • Like 1
Link to comment
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

  • Like 1
Link to comment
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.

 

  • Like 2
Link to comment
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?

 

Link to comment
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

  • Like 1
Link to comment
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
*      R13 = GROM READ ADR.
*
       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. :ponder:

 

...lee

Link to comment
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
*      R13 = GROM READ ADR.
*
       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. :ponder:

 

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

 

 

 

Link to comment
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

Link to comment
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

Link to comment
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'
***********************************************************
*           GROM ADDRESSES
***********************************************************
*    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
TOPL10 EQU  >601A             Return to main and re-init
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
READL1 EQU  >6A86             Read a line from keyboard
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
NREAD  EQU  >800E
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
FADD   EQU  >06               Floating ADD
FMUL   EQU  >08               Floating MULtiply
FDIV   EQU  >09               Floating DIVide
FCOMP  EQU  >0A               Floating COMPare
SADD   EQU  >0B               Stack ADD
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)
GREAD  EQU  >85               READ DATA FROM ERAM
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
GREAD1 EQU  >8C               READ DATA FROM ERAM
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
PHRADD EQU  >8301            PHRom ADDress
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)
CCPADR EQU  >8308            RAM address of current refs
*                             or Actual buffer address or c
VARC   EQU  >8308
CCPADD EQU  >8308            RAM address of current color
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
STADDR EQU  >830A            Start address - usually for co
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
* NOTE: DATAD must follow immediately after TOTTIM. The
*       routine STDATA is counting on this fact!
FAC3   EQU  FAC+3
DATAAD EQU  >834D            Speech DATA ADdress
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
PHADDR EQU  >8352             PHrom ADDRess
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
READ   EQU  >8358            Address of speech peripheral
*                             READ byte interface
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
***********************************************************
*    VDP addresses
SCRNBS EQU  >02E0             Screen base addr for last lin
NLNADD EQU  >02E2             New LiNe ADDress
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
READZ  EQU  >97               READ
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:
*-------NAME------------------ADDRESS---------BYTES LEFT---
*      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   DELINK            Delink symbol table entry
       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   $
       BR   $         ***     Please let me know it you add
*                     ***     branches here since it will a
*                     ***     the address of link list. Sum
LINK1  DATA LINK2
       STRI 'SOUND'           SOUND
       DATA XSOUND
LINK2  DATA LINK3
       STRI 'CLEAR'           CLEAR
       DATA CLEAR
LINK3  DATA LINK4
       STRI 'COLOR'           COLOR
       DATA COLOR
LINK4  DATA LINK5
       STRI 'GCHAR'           GCHAR 
       DATA GCHAR
LINK5  DATA LINK6
       STRI 'HCHAR'           HCHAR
       DATA HCHAR
LINK6  DATA LINK7
       STRI 'VCHAR'           VCHAR 
       DATA VCHAR
LINK7  DATA LINKA
       STRI 'CHAR'            CHAR 
       DATA CHARLY
LINKA  DATA LINKB
       STRI 'KEY'             KEY
       DATA ZKEY
LINKB  DATA LINKC
       STRI 'JOYST'           JOYST
       DATA ZJOYST
LINKC  DATA LINKD
       STRI 'SCREEN'          KEY
       DATA BORDER
LINKD  DATA LINKE
       STRI 'VERSION'         VERSION
       DATA VERS
LINKE  DATA LINKS1
       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  V@START,@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
       B    TOPL15            Return to top-level
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
       DADD NLNADD-3,@VARW    Make a valid screen address
       DCH  NLNADD+22,@VARW   If might go off screen
       BR   GA102
       XML  SCROLL            SCROLL to next line
       DST  NLNADD,@VARW      Re-initialize screen address
GA102  ST   LESS+OFFSET,V*VARW Display open bracket "("
       DINC @VARW             Increment screen address
       CALL ASC               Convert line # into ASCII
       ST   GREAT+OFFSET,V*VARW Display close bracket ")"
       DSUB NLNADD-4,@VARW    Update the x-pointer
       ST   @VARW+1,@XPT
CLRRTN DCLR @ERRCOD           Clear the return vector
       XML  RTNB              Return to ALC
* 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,V@SPGMPT  Save text pointer
EXEC6D DST  @EXTRAM,V@SEXTRM  Save line number table pointe
       DST  @VSPTR,V@SAVEVP   Save value stack pointer
       DST  @BUFLEV,V@SBUFLV  Save crunch buffer level
       DST  @LSUBP,V@SLSUBP   Save last subprogram on stack
       ST   @FLAG,V@SFLAG     Save FLAG for continue
       AND  >63,V@SFLAG       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   NREADX            'READ'                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
NREADX B    NREAD
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
       DCH  @STLN,@FAC2       Not found
       BR   ERRLNF
       DSUB 4,@FAC2           Goto next line
       BR   ONERR2
ONERR4 DINCT @FAC2
       DST  @FAC2,V@ERRLN
       BR   GA216
GA20E  CEQ  STOPZ,@CHAT       * SYNTAX ERROR
       BR   ERRSYN
       DCLR V@ERRLN           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
*  peripheral. If not found there, then a
*  *SUBPROGRAM NOT FOUND error occurs
*
*  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
       CALL LINK              Issue 'Call Program Link'
       BYTE 10              * Search subprogram lists
       BR   ONWRN7            If all ok, check-end and rtn
       BR   ERRSNF            If not found, error
***********************************************************
*                     NUD FOR PI
***********************************************************
NPI    MOVE 8,G@CONPI,@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,G@X2SEED,V@RNDX2
       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 V@RNDX1
*                             STACK
*                               SREFS   FAC CONTENTS
* NRND   MOVE 5,V@RNDX1,@FAC        FAC = X1
*        MOVE 5,V@RNDX1,@FAC        fAC = X1
*        CLR  @FAC5                 FAC = CLR
*        DCLR @FAC6                 FAC = CLR
*        XML  VPUSH          (A)    FAC = X1
*        MOVE 8,G@RNDA1,@ARG        ARG = A1
*        XML  FMUL                  FAC = X1*A1
*        MOVE 8,G@RNDC1,@ARG        ARG = C1
*        XML  FADD               T1=FAC = X1*A1+C1
*        XML  VPUSH          (B)    FAC = T1
*        MOVE 8,G@RNDEM,@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = T1/1E7
*        CALL GRINT              T2=FAC = INT(T1/1E7)
*        XML  VPUSH          (C)    FAC = T2
*        MOVE 8,G@RNDEP,@ARG        ARG = 1E7
*        XML  FMUL                  FAC = T2*1E7
*        DSUB 8,@VSPTR
*        XML  SSUB           (D) X1=FAC = T1-T2*1E7
*        MOVE 5,@FAC,V@RNDX1        FAC = X1 (new)
*        XML  VPUSH          (E)    FAC = X1
* COMPUTE NEW VALUE FOR X2, SAVE IT IN V@RNDX2
*        MOVE 5,V@RNDX2,@FAC        FAC = X2
*        CLR  @FAC5                 FAC = CLR
*        DCLR @FAC6                 FAC = CLR
*        MOVE 8,G@RNDA1,@ARG        ARG = A1
*        XML  FMUL                  FAC = X2*A1
*        DADD 8,@VSPTR
*        XML  VPUSH          (F)    FAC = X2*A1
*        DSUB 24,@VSPTR
*        XML  VPOP           (G)    FAC = X1
*        DADD 32,@VSPTR
*        MOVE 8,G@RNDA2,@ARG        ARG = A2
*        XML  FMUL                  FAC = X1*A2
*        XML  SADD           (H)    FAC = X2*A1+X1*A2
*        MOVE 8,G@RNDC2,@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,G@RNDEM,@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = T3/1E7
*        CALL GRINT              T4=FAC = INT(T3/1E7)
*        MOVE 8,G@RNDEP,@ARG        ARG = 1E7
*        XML  FMUL                  FAC = T4*1E7
*        XML  SSUB           (L) X2=FAC = T3-T4*1E7
*        MOVE 5,@FAC,V@RNDX2        FAC = X2 (new)
* COMPUTE NEW VALUE FOR RND, LEAVE IT IN FAC
*        MOVE 8,G@RNDEM,@ARG        ARG = 1/1E7
*        XML  FMUL                  FAC = X2/1E7
*       XML  VPUSH          (M)    FAC = X2/1E7
*        DADD 8,@VSPTR
*        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,V@0(@STRPTR)
       DINC @STRPTR
       RTN
PUTLP  ST   V@0(@FAC4),@VAR0
       ADD  OFFSET,@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,G@RNDEM,@ARG        ARG = 1/1E7
       XML  FMUL                  FAC = X2+X1/1E7
       CALL GRINT                 FAC = X2
       MOVE 5,@FAC,V@RNDX2        FAC = X2
       MOVE 8,G@RNDEP,@ARG        ARG = 1E7
       XML  FMUL                  FAC = X2*1E7
       XML  SSUB                  FAC = X1
       MOVE 5,@FAC,V@RNDX1        FAC = X1
       XML  CONT                  FAC = X1
GA3B6  DST  @FAC,V@RNDX2          FAC = 0
       DST  @FAC,V@RNDX1          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
       DADD V@6(@VSPTR),@BYTES    ADD IN L.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
 
       DADD @TEMP6,@FAC6      Add in length of 2nd ARG
* 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,V@ONECHR    Move the value to VDP(for LIT
       DST  ONECHR,@TEMP5     Address of character
       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
       CZ   @FAC7             Bad Argument?
       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
       CEQ  SPACE,*FAC11      If leading space
       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,V@VROAZ    Put the string in VDP
       DST  VROAZ,@TEMP5      Copy-from address(for LITSTR)
       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
       DINC @FAC12            Skip leading blank
       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
       DADD @BYTES,@FAC4      Adjust ptr for offset
       SUB  @BYTES+1,@FAC7    Adjust length
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 V@6(@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
       DADD @BYTES,@SREF      Compute new start address
       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 #
LNGP1  DCHE @STLN,@ARG2       If line not found
       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
       BYTE 38             *  'LINE NOT FOUND'
       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  V@6(@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,V@VROAZ  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  V@2(@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,V@VROAZ,@>8300
       ST   >68,V@-6(@VSPTR)  Correct stack entry ID
       DST  V@SYMBOL,V@2(@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   V@3(@VSPTR)       If functional
       BS   ERRSNM
       BR   GA7FC              not a string
GA7F6  CZ   V@3(@VSPTR)       If functional
       BR   ERRSNM
***** NOW RESTORE SYMBOL TABLE AND RESUME *****************
***** EXECUTION AT THE ORIGINAL LINE **********************
GA7FC  CALL DELINK            Delink the parameter entry
       DST  V@8(@VSPTR),@PGMPTR Manual pop to get ptr back
       DDEC @PGMPTR           Back up text pointer
       XML  PGMCHR            Get next token
       XML  CONT
DELINK DST  @SYMTAB,@TEMP5    Save addr of S.T. entry just
*                             in case entry is a string
*                             (must free the string)
       MOVE 4,V@4(@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  V@6(@TEMP5),@TEMP5 Where the string is
       DCZ  @TEMP5            If non-null string
       BS   GA833
       DST  V@-3(@TEMP5),@TEMP2 Get backpointer
       DCHE @SYMTAB,@TEMP2    If not used
       BS   GA833
       DCLR V@-3(@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 V@-3(@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  V@-2(@EXTRAM),@ARG2   Get line # in
       BR   GA8A5
GA897  DST  2,@FFF1           @FFF1 : Byte count
       DST  @EXTRAM,@DDD1     @DDD1 : Source addr in ERAM
       DDECT @DDD1
       XML  GREAD1            Read data from ERAM
       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   ERRBV             2 BAD VALUE
       BR   ERRLNF            3 LINE NOT FOUND
       BR   ERRSYN            4 SYNTAX
       BR   ERRBS             5 BAD SUBSCRIPT
       BR   ERRSNM            6 STRING-NUMBER MISMATCH
       BR   ERRSO             7 STACK OVERFLOW
       BR   ERRBA             8 BAD ARGUMENT
       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   ERRSNF           10 SUBPROGRAM NOT FOUND
       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,V@CSNTP1
       DST  @FAC12,V@CSNTMP 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,G@FLT1,@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
COL21  DADD >080F,@FAC        Color table addr(>0810 - >081
       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,V@1(@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,V@3(@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
       DCLR @FPERAD
       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,G@FLT1,@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,V@8(@FAC8),V@-16(@FAC8)
SQU05  DSUB 8,@VSPTR
       RTN
***********************************************************
*                 SUBPROGRAM FOR CLEAR
***********************************************************
CLEAR  ALL  SPACE+OFFSET      Clear the screen
       ST   3,@XPT            Initialize screen pointer
       BR   LNKRT2            Return to caller
***********************************************************
*               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
*----------------------------------------------------------
       BR   ASSRTN            Assign and return to caller
* 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,G@SNDREG,V@VRMSND
       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,V@VRMSND+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,G@ATTREG,@>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,G@FLTS,@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'
       INCT @STADDR           Advance ponter for next time
       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,V@VRMSND+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
* LOAD SOUND TABLE
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
       BR   LNKRTN            Return to caller
***********************************************************
*                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
       CALL RETURN            Return to caller
***********************************************************
*                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
       DADD >0300,@FAC        CORRECT FOR OFFSET
       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
       DADD 16,@VAR5          Move pointer
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)
       ST   @BYTES,V*VARY     Load characters
       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,V@>0400,V@>0408(@VAR0)
       DADD 8,@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
       MOVE 1,@FAC1,#7        Load VDP register
       BR   LNKRT2            Return to XB program
* Get ROW, COLUMN VALUES AND NUMBER OF CHARACTERS
HVCHR  CALL GPHV              Get X, Y VALUES
       XML  PARSE
       BYTE RPARZ
       CALL INTARG
       ADD  OFFSET,@FAC1
       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   V@2(@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   V@-8(@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,V@-7(@VSPTR)  If execution
       BR   GAD03
       MOVE 8,G@FLT1,@FAC     Make it such
       DNEG @FAC              Make it a negative
       BR   GAD0B
GAD03  ST   V@-5(@VSPTR),@FAC1 Get I/O LUNO number
       XML  CIF               Convert it to floating
GAD0B  XML  ASSGNV
* Code to get "Y" in
       CEQ  RPARZ,@CHAT       If long form of CALL ERR
       BS   GAD42
       CALL ERRCOM            Check syntax & get user's sym
       ST   V@-7(@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  V@-2(@VSPTR),@FAC2 Get line pointer
       DST  @FAC2,@FAC
       DCZ  @FAC2             If line number exists
       BS   GAD3E
       DDECT @FAC2            Point to the line #
       CALL GRSUB1            Read line # (2 bytes) from VD
*                              or ERAM (use GREAD)
       BYTE >4C             * @FAC2: Source addr on ERAM/VD
       DST  @EEE,@FAC         Put the line # in FAC
       AND  >7F,@FAC          Reset the breakpoint if any
GAD3E  XML  CIF               Convert it
       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
ERRLNF CALL ERRZZ             * LINE NOT FOUND
       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)
ERRSNF CALL ERRZZ             * SUBPROGRAM NOT FOUND
       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
* WRNLNF      * LINE NOT FOUND               DATA 38
*
***********************************************************
* SPRITE SUBROUTINES BRANCH TABLE
CHAR1  BR   SPNUM3            Called in CHARLY.    EXEC
CHAR2  BR   SPNUM2            Called in CHARLY.    EXEC
       BR   $                 Called in CHARLY.    EXEC
* SUBROUTINE LINK LIST
LINKS1 DATA LINKS2
       STRI 'SPRITE'         SPRITE
       DATA SPRTE
LINKS2 DATA LINKS3
       STRI 'DELSPRITE'      DELSPRITE
       DATA SPRDEL
LINKS3 DATA LINKS4
       STRI 'POSITION'       POSITION
       DATA SPRPOS
LINKS4 DATA LINKS5
       STRI 'COINC'          CONIC
       DATA ZSCOI
LINKS5 DATA LINKS6
       STRI 'MAGNIFY'        MAGNIFY
       DATA SPRMAG
LINKS6 DATA LINKS7
       STRI 'MOTION'         MOTION
       DATA SPRMOV
LINKS7 DATA LINKS8
       STRI 'LOCATE'         LOCATE
       DATA SPRLOC
LINKS8 DATA LINKS9
       STRI 'PATTERN'        PATTERN
       DATA SPRPAT
LINKS9 DATA LINKSA
       STRI 'DISTANCE'       DISTANCE
       DATA ZSDIST
LINKSA DATA LINKSB
       STRI 'SAY'            SAY
       DATA SAY
LINKSB DATA LINKSC
       STRI 'SPGET'          SPGET   
       DATA SPGET
LINKSC DATA LINKSD
       STRI 'CHARSET'        CHARSET
       DATA CHRSET
LINKSD DATA LINKSE
       STRI 'ONKEY'          ONKEY
       DATA  ZONKEY
LINKSE DATA LINKSF
       STRI 'MOVES'          MOVES
       DATA MOVES
LINKSF DATA LINKSG
       STRI 'HPUT'           HPUT
       DATA HPUT
LINKSG DATA LINKSH
       STRI 'VPUT'           VPUT
       DATA VPUT
LINKSH DATA LINKSI
       STRI 'HGET'           HGET
       DATA HGET 
LINKSI DATA LINKSJ
       STRI 'VGET'           VGET
       DATA VGET
LINKSJ DATA LINKSK
       STRI 'EXECUTE'        EXECUTE
       DATA EXECUT
LINKSK DATA LINKSL
       STRI 'GMOTION'        GMOTION
       DATA GMOT
LINKSL DATA LINKSM
       STRI 'RMOTION'        RMOTION
       DATA RMOT
LINKSM DATA LINKSN
       STRI 'HEX'            HEX
       DATA HEX
LINKSN DATA LINKSO
       STRI 'IO'             IO
       DATA RXBIO
LINKSO DATA LINKSP
       STRI 'INVERSE'        INVERSE
       DATA INV
LINKSP DATA LINKSQ
       STRI 'SWAPCHAR'       SWPCHAR
       DATA SWCHR
LINKSQ DATA LINKSR
       STRI 'DUPCHAR'        DUPCHAR
       DATA DUPCHR
LINKSR DATA LINKSS
       STRI 'SWAPCOLOR'      SWAPCOLOR
       DATA SWCLR
LINKSS DATA LINKST
       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 V@>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,V@SPNUM   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  V@>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
GAEFD  BR   GB0F2             Return to caller
***********************************************************
* 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
       CALL SPLOC             Read location
       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
       DADD @SP06,@SP02       @SP02=X*X+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  V@>03F8           EDGE CHAR ADDRESS
       MOVE 896,V@>03F8,V@>03F9 Clear bytes
       DST  >0408,@FAC        Start with !
       DST  CHARS,@FAC4       GROM ADDRESS
CHRLP  MOVE 7,G@0(@FAC4),V@1(@FAC) Get GROM Def
       DADD 8,@FAC            GROM ADDRESS
       DADD 7,@FAC4           VDP ADDRESS
       DEC  @FAC2             Character Count-1
       BR   CHRLP             0?
       ST   >10,V@>080F       Set 1st set to black on tranp
       MOVE 16,V@>080F,V@>0810  Ripple for res
       CALL RETURN            Return to the caller
******************************
* 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,V@SPNUM     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
       ADD  >60,@FAC1         Add offset to character numbe
       ST   @FAC1,V@2(@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,V@>0480(@SPSAL)  Store velocities in SAL
*----------------------------------------------------------
* Add the following 3 lines for speeding up XB
       CH   @MOTION,V@SPNUM   Check current sprite
       BR   GB0BD              against sprite motion
*                                counter
       ST   V@SPNUM,@MOTION       higher? Yes, replace it
*----------------------------------------------------------
GB0BD  RTN
RANGEV CH   >63,@FAC2         The same as INTARG
       BS   ERRSNM
       CLR  @FAC10
       DCLR @FPERAD
       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.
***********************************************************
SAY    CEQ  LPARZ,@CHAT       Must start with "("
       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 SETRW             Set PHROM read/write address
       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
       DADD @PTFCIS,@PTLCIS    by adding length-of-string
       DDEC @PTLCIS            and subtracting 1
* Make a speech list
       CALL SETRW             Set speech read/write addrs
       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
       DCZ  @DATAAD           If not found then
       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
* character: if not found, use 'UHOH' data instead.
* 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
* If not found, use data to 'UHOH'
       DCZ  @DATAAD
       BR   GB196
       DST  >71F4,@DATAAD     Put addr of 'UHOH' in
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
       DCLR @DATAAD
       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
       DST  @VSPTR,@DATAAD    Store stack addr on string
       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.
***********************************************************
SPEAK  CALL SETRW             Set read/write address
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
       ST   V*PTFBSL,@TIMER   No, load timer
       NEG  @TIMER             and neg it to correct
       DST  V@1(@PTFBSL),@PTFBPH   Put addr into PTFBPH
       DADD 3,@PTFBSL               and skip to next node
LOOP1  CGE  0,@TIMER          Wait for time delay
       BR   LOOP1
       CZ   @PTFBPH           If there is data
       BS   GB1FC
       CALL LOADAD            Load the addr to PHROM
       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  V@4(@PTCBED),@PTCBED    in external speech data
       DINCT @PTFBSL          Skip addr bytes
       ST   V@-1(@PTCBED),@LENWST  Get Len of whole string
DIRSPH SUB  3,@LENWST         Minus 3 bytes overhead
* All external speech strings start with a >60
       CEQ  >60,V*PTCBED      Bad speech string
       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?
GB241  ST   @VAR0(@READ),@SPKSTS Read status from PHROM
 
* 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
       BR   GB0F2             And return to the caller
***********************************************************
* SPGET subprogram. Load speech data from external device.
*       Use standard file I/O
***********************************************************
SPGET  CEQ  LPARZ,@CHAT       Must have left parenthesis
       BR   ERRSYN
       CALL SETRW             Set PHROM read/write address
       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
       DADD @PTFCIS,@PTLCIS    by adding length-of-string
       DDEC @PTLCIS             and subtracting 1
       CALL SETRW             Set the speech read/write add
       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
       DCZ  @DATAAD           If not there,
       BR   GB2AA
       DST  >71F4,@DATAAD      use 'UHOH' data addr
       ST   >51,@STRLEN        'UHOH' data length
* Data must be in PHRADD and PHLEN, so move it
GB2AA  DST  @DATAAD,@PHRADD
       ST   @STRLEN,@PHLEN
       ADD  3,@PHLEN          For overhead info
* 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
       CALL SETRW             Set up speech read/write addr
       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,V@2(@SREF) Put in string length
       DSUB 3,V@1(@SREF)       minus thei info
* LOADAD expects addr to be in PTFBPH, so move it.
       DST  @PHRADD,@PTFBPH
       CALL LOADAD
* 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
       ST   @VAR0(@READ),@BYTE3 Read the byte
* 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,V@3(@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!
***********************************************************
PHRASE CEQ  NUMBER,@CCHAR     Phrase start with #?
       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
       DADD @TIMLEN,@TOTTIM
       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,V@1(@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
       CALL LOADAD            LOADAD expects addr in PTFBPH
       ST   >10,@VAR0(@WRITE) Put out read byte command
       CEQ  >AA,@VAR0(@READ)  Tree out there?
       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...
***********************************************************
SEARCH CALL LOADAD            Set PHROM to start phrase nod
       ST   >10,@VAR0(@WRITE) Issue read byte command
       CLR  @PTLCPH           Length of phrase => PTLCPH
       ST   @VAR0(@READ),@PTLCPH+1 (stored as 2 byte value
       DADD @PTFBPH,@PTLCPH   Add front ptr giving end ptr
       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,V@1(@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,V@1(@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
       DADD 6,@PTFBPH
       CALL READAD            Set data addr => DATAAD
       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
NXTPHR DADD @PTLCPH,@PTFBPH   Add displacement to last char
       CALL READAD             and get the new address
       DCZ  @DATAAD           More leaves on this tree
       BR   GB4E8
       RTN                    No, return empty handed
GB4E8  DST  @DATAAD,@PTFBPH   Store new addr in PTFBPH
       BR   SEARCH            Go compare this new word!
* The program should never reach this point!! It should
* return somewhere up above.
***********************************************************
* LOADAD will set the addr out in the PHROM to the addr
* found in PTFBPH. Note that the PHROM is expecting five
* nybbles to be written out as the address.
***********************************************************
LOADAD DST  @PTFBPH,@TEMP1    This is destructive, so copy
       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
       DOR  >4040,@TEMP2       to indicate a Load Address C
       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
***********************************************************
* READAD will read an address from the PHROM and store it
* in DATAAD. Note that PTFBPH should contain the addr of
* the PHROM location to be read so LOADAD will work.
***********************************************************
READAD CALL LOADAD            Set the addr of the PHROM
       ST   >10,@VAR0(@WRITE) Get high byte of addr
       ST   @VAR0(@READ),@DATAAD Stroe it in DATAAD
       ST   >10,@VAR0(@WRITE) Get low byte of addr
       ST   @VAR0(@READ),@DATAAD+1 Store it in DATAAD+1
       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?
       BS   ERRSSL
       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)
WAIT   ST   @VAR0(@READ),@SPKSTS  Read status from PHROM
       CLOG >80,@SPKSTS
       BR   WAIT
       RTN
***********************************************************
* SETRW moves addrs of speech read/write from GROM to VDP
***********************************************************
SETRW  MOVE 4,G@>0046,@READ
       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?
       BS   ERRBV           BAD VALUE
       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,V@0(@VARY),V@0(@VARY2)
MTYPE1 CEQ  82,@VAR6        * RAM TO
       BR   MTYPE2
       MOVE @BYTES,V@0(@VARY),@0(@VARY2)
MTYPE2 CEQ  71,@VAR6        * GRAM TO
       BR   MTYPE3
       MOVE @BYTES,V@0(@VARY),G@0(@VARY2)
MTYPE3 CEQ  82,@VAR5        * RAM FROM
       BR   MTYPE7
       CEQ  86,@VAR6        * VDP TO
       BR   MTYPE5
MTYPE4 MOVE @BYTES,@0(@VARY),V@0(@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),G@0(@VARY2)
MTYPE7 CEQ  71,@VAR5        * GRAM FROM
       BR   MOVESD
       CEQ  86,@VAR6        * VDP TO
       BR   MTYPE9
MTYPE8 MOVE @BYTES,G@0(@VARY),V@0(@VARY2)
MTYPE9 CEQ  82,@VAR6        * RAM TO
       BR   MTYPEA
       MOVE @BYTES,G@0(@VARY),@0(@VARY2)
MTYPEA CEQ  71,@VAR6        * GRAM TO
       BR   MOVESD
       MOVE @BYTES,G@0(@VARY),G@0(@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
       ADD  >07,@VAR0
HEXNS2 ADD  >30,@VAR0
       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
       ADD  @VAR0,@TEMP2
HEXS3  CALL HEXSN
       ADD  @VAR0,@TEMP2
HEXS2  CALL HEXSN
       SLL  4,@VAR0
       ADD  @VAR0,@TEMP2+1
HEXS1  CALL HEXSN
       ADD  @VAR0,@TEMP2+1
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
       CALL SUBLP3       * ADDRESS/
       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
CSW    CALL CSLOAD
       I/O  4,@VAR4
       BR   IODONE
CSR    CALL CSLOAD
       I/O  5,@VAR4
       BR   IODONE
CSV    CALL CSLOAD
       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 SUBLP3       * CRU-ADDRESS
       CALL CRUTMP
       ST   @VARY,@VAR5
       RTN
CSLOAD CALL CRUTMP
       CALL SUBLP3       * ADDRESS
       DST  @FAC,@VAR5
       RTN
*******************************
HVPNUM CLR  @FAC11            Select XB FLP
       XML  XCNS
       CEQ  SPACE,*FAC11      Leading space?
       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  @SREF,@FAC4            VDP rollout address
       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
       BS   ERRBV              * BAD VALUE
       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  V@>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  V@>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,V@>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 V@>0300(@FAC)
       DADD >0002,@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,V@>0300(@VAR4),@FAC
       MOVE 8,V@>0300(@VAR5),V@>0300(@VAR4)
       MOVE 8,@FAC,V@>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,V@>0300(@VAR4),V@>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   V@>0003(@FAC),@VAR4
       DST  @FAC,@VAR5
       CEQ  >FD,@CHAT
       BR   ERRSYN
       CALL STRFCH
       CALL SPNUM4
       ST   V@>0003(@FAC),V@>0003(@VAR5)
       ST   @VAR4,V@>0003(@FAC)
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   SCOL10
SCOL20 XML  SPEED
       BYTE >01
       CALL S00T10
       DADD >080F,@FAC
       DST  @FAC,@VAR4
       XML  PARSE
       BYTE >B6
       CALL S00T10
       DADD >080F,@FAC
       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   V@>0003(@FAC),@VAR4
       CEQ  >FD,@CHAT
       BR   ERRSYN
       CALL STRFCH
       CALL SPNUM4
       ST   @VAR4,V@>0003(@FAC)
       CEQ  >B3,@CHAT
       BR   LNKRTN
       XML  PGMCHR
       BR   DCOL10
DCOL20 XML  SPEED
       BYTE >01
       CALL S00T10
       DADD >080F,@FAC
       ST   V*FAC,@VAR0
       XML  PARSE
       BYTE >B6
       CALL S00T10
       DADD >080F,@FAC
       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 *                                   *
       DATA >045B *        RT          Return to GPL. *
                  *        END                        *
*******************************************************
EXECUT CALL SPNUM1
EXAGN  CALL SUBLP3
       MOVE 12,@VAR0,V@VROAZ   Save CPU values
       MOVE 12,G@CPUPGM,@VAR0  Load PGM
       DST  @FAC,@VARY         Load address    
       XML  >F0                Execute address 
       MOVE 12,V@VROAZ,@VAR0   Restore CPU values
       CEQ  >B3,@CHAT          Comma?
       BS   EXAGN              Repeat
       BR   LNKRTN
***********************************************************
LINKST DATA LINKSU
       STRI 'SIZE'            SIZE
       DATA $+2
       B    SZSIZE
LINKSU DATA LINKSV
       STRI 'CLSALL'          CLSALL
       DATA $+2
       CALL CLSALL            Close all open files
       BR   LNKRT2
LINKSV DATA LINKSW
       STRI 'BYE'             BYE
       DATA $+2
       CALL CLSALL            Close all open files
       EXIT
LINKSW DATA LINKSX
       STRI 'NEW'             NEW
       DATA $+2
RXBNEW CLR  V@LODFLG          Clear AUTOLOAD flag
       CALL CLSALL
       B    SZNEW
LINKSX DATA LINKSY
       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.
       ADD  96,@FAC1          ADD OFFSET
       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
LINKSY DATA LINKSZ
       STRI 'EALR'            EALR
       DATA $+2
       CALL EASAVE
       BYTE >33
LINKSZ DATA LINKT1
       STRI 'EAPGM'           EAPGM
       DATA $+2
       CALL EASAVE            Get path
       BYTE >35
LINKT1 DATA LINKT2
       STRI 'EAED'            EAED
       DATA $+2
XEAED  CALL EASAVE            Get path
       BYTE >31
LINKT2 DATA LINKT3
       STRI 'EA'              EA menu
       DATA EAMENU
EASAVE CALL SPNUM1            ( 
       CALL STRGET            Get path
       ST   @FAC,V@>2256      Save length
       ADD  1,V@>2256         Length+1
       MOVE @FAC6,V@0(@FAC4),V@>2257 Load buffer
       ST   >0D,V@>2257(@FAC6) Put ENTER key at end
       FETCH @CHAT            Get character
EAMENU CALL CLSALL            Close all open files
       B    GE025             Got to EA CART
LINKT3 DATA LINKT4
       STRI 'XB'              XB menu
       DATA $+2
XBMENU ST   >FF,V@>35D7       SET RXB MENU Flag
       CALL CLSALL            Close all open files
       BR   RXBRUN            Run it
LINKT4 DATA LINKT5             
       STRI 'RUN'             RUN(pathname) duplicat XBPGM
       DATA XBPGM
LINKT5 DATA LINKT6
       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  V@>2254           Clear buffer 
       MOVE 50,V@>2254,V@>2255 Ripple clear
       DST  >994A,V@>2254     Set flag 
       ST   @FAC7,V@>2256     Save length byte
       MOVE @FAC6,V@0(@FAC4),V@>2257 Save string
       CLR  V@>35D7           Clear RXB MENU Flag
RXBXBP CEQ  >B3,@CHAT         Comma?
       BR   RXBRUN            No
       CALL RXBFIL            Set files
RXBRUN B    TOPLEV            RUN IT
LINKT6 DATA >C010
       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         
       ST   @FAC1,@FAC2       Load file value
       DST  >0116,V@VROAZ     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,G@FLT1,@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  @VARY,@VARC       String address.
       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.
       DINC @VARC             Address +1
       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?
       BS   ERRLNF            ERROR LINE NOT FOUND
       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?
       BS   GKEY1             Yes, load line#
       CALL RETURN            Return to XB
**********************************************************
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
       BR   ERRLNF             ERROR LINE NOT FOUND
       DSUB 4,@FAC2            Next LINE#
       BR   GKEY2              Loop
GKEY3  DST  @FAC2,@EXTRAM      Got LINE#
       DADD 4,@EXTRAM          Point to begining of line
       DINCT @EXTRAM           Point to ADDRESS
       DST  @EXTRAM,@PGMPTR    Set pointer to line to run
       DINCT @PGMPTR           Point to tokens
       CALL RETURN             Return to XB
**********************************************************
*                  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,G@FLT1,@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        *
       ADD  >10,@VROAZ+1  *
DSRDSS DST  VROAZ,@FAC12  *
       CALL LINK          *
       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,V@>0780,V@>0780(@VAR0)
       DADD 4,@VAR0           Index +4
       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  @FAC4,@VARY       Save address.
       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

Link to comment
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.  v@ 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 V@ SPLIT
       ROT SP.Y V@ SPLIT
        ( -- col row  col row)
       ROT - ABS R@  <
      -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. Read until COINC=TRUE 

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 .
;

 

 

 

  • Like 1
Link to comment
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

  • Like 1
Link to comment
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.

 

 

Link to comment
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

  • Like 2
Link to comment
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

  • Like 2
  • Thanks 1
Link to comment
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

  • Like 1
Link to comment
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

  • Like 3
Link to comment
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

  • Sad 1
Link to comment
Share on other sites

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.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

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

Loading...
  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...