********************************************************************************
       TITL 'CONTROL BLOCK 0'
 
CIF    EQU  >74AA             * GROM ADDRESS'S
CALL   EQU  >750A             *
COMPCT EQU  >73D8             *
DELREP EQU  >7EF4             *
GETSTR EQU  >736C             *
GREAD  EQU  >7EB4             *
GREAD1 EQU  >7EA6             *
GVWITE EQU  >7FDA             *
GWITE1 EQU  >7ECA             *
GWRITE EQU  >7ED8             *
IO     EQU  >7B48             *
MEMCHG EQU  >72CE             *
MEMCHK EQU  >72D8             *
MVDN   EQU  >7F7E             *
MVDN2  EQU  >7F8A             *
NFOR   EQU  >7000             *
NNEXT  EQU  >7230             *
NSTRCN EQU  >7442             *
PSCAN  EQU  >7C56             *
RESOLV EQU  >7946             *
SCROLL EQU  >7ADA             *
SUBXIT EQU  >78D2             *
VGWITE EQU  >7FC0             *
*
********************************************************************************
       TITL 'EQUATES'
 
*
LWCNS  EQU  >6000
*
WRVDP  EQU  >4000             Write enable for VDP
XVDPRD EQU  >8800             Read VDP data
XVDPWD EQU  >8C00             Write VDP data
XGRMRD EQU  >9800             Read GROM data
GRMWAX EQU  >9C02->9800       Write GROM address
GRMRAX EQU  >9802->9800       Read GROM address
GRMWDX EQU  >9C00->9800       GROM write data
*
KEYTAB EQU  >CB00             ADDRESS OF KEYWORD TABLE
*
NEGPAD EQU  >7D00
PAD0   EQU  >8300
PAD1   EQU  >8301
PAD5F  EQU  >835F
PADC2  EQU  >83C2
*
VAR0   EQU  >8300
MNUM   EQU  >8302
MNUM1  EQU  >8303
PABPTR EQU  >8304
CCPPTR EQU  >8306
CCPADR EQU  >8308
RAMPTR EQU  >830A
CALIST EQU  RAMPTR
BYTE   EQU  >830C
PROAZ  EQU  >8310
VAR5   EQU  PROAZ
PZ     EQU  >8312
LINUM  EQU  PZ
OEZ    EQU  >8314
QZ     EQU  >8316
XFLAG  EQU  QZ
VAR9   EQU  QZ
DSRFLG EQU  >8317
FORNET EQU  DSRFLG
STRSP  EQU  >8318
CZ     EQU  >831A
STREND EQU  CZ
WSM    EQU  CZ
SREF   EQU  >831C * Temporary string pointer
WSM2   EQU  SREF  * Temporary string pointer
WSM4   EQU  >831E * Start of current statement
SMTSRT EQU  WSM4  * Start of current statement
WSM6   EQU  >8320 * Screen address
VARW   EQU  WSM6  * Screen address
VARW1  EQU  >8321
ERRCOD EQU  >8322 * Return error code from ALC
WSM8   EQU  ERRCOD * Return error code from ALC
ERRCO1 EQU  >8323
STVSPT EQU  >8324 * Value-stack base
RTNADD EQU  >8326
NUDTAB EQU  >8328
VARA   EQU  >832A * Ending display location
PGMPTR EQU  >832C * Program text pointer
PGMPT1 EQU  >832D
EXTRAM EQU  >832E * Line number table pointer
EXTRM1 EQU  >832F
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
SYMTAB EQU  >833E * Symbol table pointer
SYMTA1 EQU  >833F
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 level
LSUBP  EQU  >8348 * Last subprogram block on stack
FAC    EQU  >834A * Floating-point ACcurmulator
FAC1   EQU  >834B
FAC2   EQU  >834C
FAC4   EQU  >834E
FAC5   EQU  >834F
FAC6   EQU  >8350
FAC7   EQU  >8351
FAC8   EQU  >8352
FAC9   EQU  >8353
FAC10  EQU  >8354
FLTNDX EQU  FAC10
FDVSR  EQU  FAC10
FAC11  EQU  >8355
SCLEN  EQU  FAC11
FDVSR1 EQU  FAC11
FAC12  EQU  >8356
FDVSR2 EQU  FAC12
FAC13  EQU  >8357
FAC14  EQU  >8358
FAC15  EQU  >8359
FAC16  EQU  >835A
FDVSR8 EQU  >835C * Floating-point ARGument
ARG    EQU  FDVSR8 * Floating-point ARGument
ARG1   EQU  >835D
ARG2   EQU  >835E
ARG3   EQU  >835F
ARG4   EQU  >8360
ARG8   EQU  >8364
ARG9   EQU  >8365
ARG10  EQU  >8366
FAC33  EQU  >836B
TEMP2  EQU  >836C
FLTERR EQU  TEMP2
TYPE   EQU  >836D
VSPTR  EQU  >836E * Value stack pointer
VSPTR1 EQU  >836F
STKDAT EQU  >8372
STKADD EQU  >8373
STACK  EQU  >8373
PLAYER EQU  >8374
KEYBRD EQU  >8375
SIGN   EQU  KEYBRD
JOYY   EQU  >8376 * Exponent in floating-point
EXP    EQU  JOYY
JOYX   EQU  >8377
RANDOM EQU  >8378
TIME   EQU  >8379
MOTION EQU  >837A
VDPSTS EQU  >837B
STATUS EQU  >837C
CHRBUF EQU  >837D
YPT    EQU  >837E
XPT    EQU  >837F
RAMFLG EQU  >8389 * ERAM flag
STKEND EQU  >83BA
STND12 EQU  STKEND-12
CRULST EQU  >83C0
SAVEG  EQU  >83CB
SADDR  EQU  >83D2
RAND16 EQU  >83D4
*
WS     EQU  >83E0
R0LB   EQU  >83E1
R1LB   EQU  >83E3
R2LB   EQU  >83E5
R3LB   EQU  >83E7
R4LB   EQU  >83E9
R5LB   EQU  >83EB
R6LB   EQU  >83ED
R7LB   EQU  >83EF
R8LB   EQU  >83F1
R9LB   EQU  >83F3
R10LB  EQU  >83F5
R11LB  EQU  >83F7
R12LB  EQU  >83F9
R13LB  EQU  >83FB
R14LB  EQU  >83FD
R15LB  EQU  >83FF
*
GDST   EQU  >8302
AAA11  EQU  >8303
GDST1  EQU  >8303
VARY   EQU  >8304
VARY2  EQU  >8306
BCNT2  EQU  >8308
CSRC   EQU  >830C
ADDR1  EQU  >834C
ADDR11 EQU  >834D
BCNT1  EQU  >834E
ADDR2  EQU  >8350
ADDR21 EQU  >8351
GSRC   EQU  >8354
DDD11  EQU  >8355
GSRC1  EQU  >8355
BCNT3  EQU  >8356
DEST   EQU  >8358
DEST1  EQU  >8359
RAMTOP EQU  >8384
* VDP variables
SYMBOL EQU  >0376 * Saved symbol table pointer
ERRLN  EQU  >038A * On-error line pointer
TABSAV EQU  >0392 * Saved main symbol table ponter
VROAZ  EQU  >03C0 * Temporary VDP Roll Out Area
FPSIGN EQU  >03DC
CRNBUF EQU  >0820 * CRuNch BUFfer address
CRNEND EQU  >08BE * CRuNch buffer END
********************************************************************************
       AORG >6000
       TITL 'XML359'
 
* PAGE SELECTOR FOR PAGE 1
PAGE1  EQU  $                 >6000
C2     DATA 2                 0
* PAGE SELECTOR FOR PAGE 2
PAGE2  EQU  $                 >6002
C7     BYTE >00
CBH7   BYTE >07               2
CBHA   BYTE >0A
CBH94  BYTE >94               4
C40    DATA 40                6
C100   DATA 100               8
C1000  DATA >1000             A
       DATA 0                 C
FLTONE DATA >4001             E
*************************************************************
* XML table number 7 for Extended Basic - must have         *
*     it's origin at >6010                                  *
*************************************************************
*           0      1      2      3      4      5     6
       DATA COMPCG,GETSTG,MEMCHG,CNSSEL,PARSEG,CONTG,EXECG
*           7      8    9     A    B    C      D
       DATA VPUSHG,VPOP,PGMCH,SYMB,SMBB,ASSGNV,FBSYMB
*             E     F
       DATA SPEED,CRNSEL
*************************************************************
* XML table number 8 for Extended Basic - must have         *
*     it's origin at >6030                                  *
*************************************************************
*           0   1      2    3      4  5     6      7
       DATA CIF,CONTIN,RTNG,SCROLL,IO,GREAD,GWRITE,DELREP
*           8    9    A      B      C      D      E
       DATA MVDN,MVUP,VGWITE,GVWITE,GREAD1,GWITE1,GDTECT
*           F
       DATA PSCAN
 
* Determine if and how much ERAM is present
GDTECT MOVB R11,@PAGE1        First enable page 1 ROM
*-----------------------------------------------------------*
* Replace following line      6/16/81                       *
* (Extended Basic must be made to leave enough space at     *
* top of RAM expansion for the "hooks" left by the 99/4A    *
* for TIBUG.)                                               *
*      SETO R0                Start at >FFFF                *
* with                                                      *
*      LI   R0,>FFE7          Start at >FFE7                *
*************************************************************
* RXB 2020 change for PRAM command                          *
       MOV  @RAMTOP,R0        PRAM sets RAMTOP value
*-----------------------------------------------------------*
       MOVB R11,*R0           Write a byte of data
       CB   R11,*R0           Read and compare the data
       JEQ  DTECT2            If matches-found ERAM top
*-----------------------------------------------------------*
* Change the following line   6/16/81                       *
*      AI   R0,->2000         Else drop down 8K             *
       LI   R0,>DFFF          Else drop down 8K
*-----------------------------------------------------------*
       MOVB R11,*R0           Write a byte of data
       CB   R11,*R0           Read and compare the data
       JEQ  DTECT2            If matches-found ERAM top
       CLR  R0                No match so no ERAM
DTECT2 MOV  R0,@RAMTOP        Set the ERAM top
       RT                     And return to GPL
CNSSEL LI   R2,CNS
       JMP  PAGSEL
CRNSEL LI   R2,CRUNCH
* Select page 2 for CRUNCH and CNS
PAGSEL INCT @STKADD           Get space on subroutine stack
       MOVB @STKADD,R7        Get stack pointer
       SRL  R7,8              Shift to use as offset
       MOVB R11,@PAD0(R7)     Save return addr to GPL interpeter
       MOVB @R11LB,@PAD1(R7)
       MOVB R11,@PAGE2        Select page 2
       BL   *R2               Do the conversion
       MOVB R11,@PAGE1        Reselect page 1
       MOVB @STKADD,R7        Get subroutine stack pointer
       DECT @STKADD           Decrement pointer
       SRL  R7,8              Shift to use as offset
       MOVB @PAD0(R7),R11     Restore return address
       MOVB @PAD1(R7),@R11LB
       RT                     Return to GPL interpeter
GETCH  MOVB @R6LB,*R15
       NOP
       MOVB R6,*R15
       INC  R6
       MOVB @XVDPRD,R8
GETCH1 SRL  R8,8
       RT
GETCHG MOVB R6,@GRMWAX(R13)
       MOVB @R6LB,@GRMWAX(R13)
       INC  R6
       MOVB *R13,R8
       JMP  GETCH1
GETCGR MOVB *R6+,R8
       JMP  GETCH1
*
CBHFF  EQU  $+2
POPSTK LI   R5,-8
       MOVB @VSPTR1,*R15
       LI   R6,ARG
       MOVB @VSPTR,*R15
       A    R5,@VSPTR
STKMOV MOVB @XVDPRD,*R6+
       INC  R5
       JNE  STKMOV
       RT
*
PUTSTK INCT @STKADD
       MOVB @STKADD,R4
       SRL  R4,8
       MOVB @GRMRAX(13),@PAD0(R4)
       MOVB @GRMRAX(13),@PAD1(R4)
       DEC  @PAD0(R4)
       RT
*
GETSTK MOVB @STKADD,R4
       SRL  R4,8
       DECT @STKADD
       MOVB @PAD0(R4),@GRMWAX(R13)
       MOVB @PAD1(R4),@GRMWAX(R13)
       RT
********************************************************************************
       AORG >6126
       TITL 'REFS359'
 
ROUNUP EQU  >0F64   Uses XML >01 Rounding of floating point numbers
SCOMPB EQU  >0D42   Set SCOMP with direct return without GPL status
CFI    EQU  >12B8   CFI (XML >12)
SMULT  EQU  >0E8C   SMUL (XML >0D)
FDIV   EQU  >0FF4   FDIV (XML >09)
OVEXP  EQU  >0FC2   Overflow (XML >04)
FMULT  EQU  >0E88   FMUL (XML >08)
SSUB   EQU  >0D74   SSUB (XML >0C)
FADD   EQU  >0D80   FADD (XML >06)
SDIV   EQU  >0FF8   SDIV (XML >0E)
FSUB   EQU  >0D7C   FSUB (XML (>07)
SADD   EQU  >0D84   SADD (XML >0B)
ROUNU  EQU  >0FB2   Rounding with digit number in >8354 (XML >02)
RESET  EQU  >006A   Clear condition bit in GPL status (GPL interpreter)
NEXT   EQU  >0070   GPL interpreter
CSN01  EQU  >11B2   CSN (XML >10) (Without R3 loaded with >1FC8)
FCOMP  EQU  >0D3A   FCOMP (XML >0A)
FCOMPB MOV  R11,R3
       B    @FCOMP+22
GETV   EQU  >187C   Read 1 byte from VDP, Entry over data address pointer
GETV1  EQU  >1880   Same >187C but does not fetch address, is preloaded first
SAVREG EQU  >1E8C   Set substack pointer and Basic byte
SAVRE2 EQU  >1E90   Same >1E8C but does not set R8 into >8342
SETREG EQU  >1E7A   Substack pointer in R9 and actual Basic byte in R8
STVDP3 EQU  >18AA   Write R6 in VDP (R1=Address+3), 
*                   used for variable table and string pointer
STVDP  EQU  >18AE   Write R6 in VDP (R1=Address+3), 
*                   used for variable table and string pointer. (R3 Preloaded)
FBS    EQU  >15E0   Pointer fetch var list
FBS001 EQU  >15E6   Fetch length byte
********************************************************************************
 
       AORG >612C
       TITL 'CPT'
 
*
* The CHARACTER PROPERTY TABLE
* There is a one-byte entry for every character code
* in the range LLC(lowest legal character) to
* HLC(highest legal character), inclusive.
LLC    EQU  >20
CPNIL  EQU  >00               " $ % ' ?
CPDIG  EQU  >02               digit (0-9)
CPNUM  EQU  >04               digit, period, E
CPOP   EQU  >08               1 char operators(!#*+-/<=>^ )
CPMO   EQU  >10               multiple operator ( : )
CPALPH EQU  >20               A-Z, @, _
CPBRK  EQU  >40               ( ) , ;
CPSEP  EQU  >80               space
CPALNM EQU  CPALPH+CPDIG      alpha-digit
*-----------------------------------------------------------*
* Following lines are for adding lowercase character set in *
* 99/4A,                      5/12/81                       *
CPLOW  EQU  >01               a-z                           *
CPULNM EQU  CPALNM+CPLOW      Alpha(both upper and lower)+  *
*                             digit-legal variable characters
CPUL   EQU  CPALPH+CPLOW      Alpha(both upper and lower)   *
*-----------------------------------------------------------*
CPTBL  EQU  $-LLC
       BYTE CPSEP               SPACE
       BYTE CPOP              ! EXCLAMATION POINT
       BYTE CPNIL             " QUOTATION MARKS
       BYTE CPOP              # NUMBER SIGN
       BYTE CPNIL             $ DOLLAR SIGN
       BYTE CPNIL             % PERCENT
       BYTE CPOP              & AMPERSAND
       BYTE CPNIL             ' APOSTROPHE
       BYTE CPBRK             ( LEFT PARENTHESIS
       BYTE CPBRK             ) RIGHT PARENTHESIS
       BYTE CPOP              * ASTERISK
       BYTE CPOP+CPNUM        + PLUS
       BYTE CPBRK             , COMMA
       BYTE CPOP+CPNUM        - MINUS
       BYTE CPNUM             . PERIOD
       BYTE CPOP              / SLANT
       BYTE CPNUM+CPDIG       0 ZERRO
       BYTE CPNUM+CPDIG       1 ONE
       BYTE CPNUM+CPDIG       2 TWO
       BYTE CPNUM+CPDIG       3 THREE
       BYTE CPNUM+CPDIG       4 FOUR
       BYTE CPNUM+CPDIG       5 FIVE
       BYTE CPNUM+CPDIG       6 SIX
       BYTE CPNUM+CPDIG       7 SEVEN
       BYTE CPNUM+CPDIG       8 EIGHT
       BYTE CPNUM+CPDIG       9 NINE
LBCPMO BYTE CPMO              : COLON
       BYTE CPBRK             : SEMICOLON
       BYTE CPOP              < LESS THAN
       BYTE CPOP              = EQUALS
       BYTE CPOP              > GREATER THAN
       BYTE CPNIL             ? QUESTION MARK
       BYTE CPALPH            @ COMMERCIAL AT
       BYTE CPALPH            A UPPERCASE A
       BYTE CPALPH            B UPPERCASE B
       BYTE CPALPH            C UPPERCASE C
       BYTE CPALPH            D UPPERCASE D
       BYTE CPALPH+CPNUM      E UPPERCASE E
       BYTE CPALPH            F UPPERCASE F
       BYTE CPALPH            G UPPERCASE G
       BYTE CPALPH            H UPPERCASE H
       BYTE CPALPH            I UPPERCASE I
       BYTE CPALPH            J UPPERCASE J
       BYTE CPALPH            K UPPERCASE K
       BYTE CPALPH            L UPPERCASE L
       BYTE CPALPH            M UPPERCASE M
       BYTE CPALPH            N UPPERCASE N
       BYTE CPALPH            O UPPERCASE O
       BYTE CPALPH            P UPPERCASE P
       BYTE CPALPH            Q UPPERCASE Q
       BYTE CPALPH            R UPPERCASE R
       BYTE CPALPH            S UPPERCASE S
       BYTE CPALPH            T UPPERCASE T
       BYTE CPALPH            U UPPERCASE U
       BYTE CPALPH            V UPPERCASE V
       BYTE CPALPH            W UPPERCASE W
       BYTE CPALPH            X UPPERCASE X
       BYTE CPALPH            Y UPPERCASE Y
       BYTE CPALPH            Z UPPERCASE Z
       BYTE CPALPH            [ LEFT SQUARE BRACKET
       BYTE CPALPH            \ REVERSE SLANT
       BYTE CPALPH            ] RIGHT SQUARE BRACKET
       BYTE CPOP              ^ CIRCUMFLEX
       BYTE CPALPH            _ UNDERLINE
*-----------------------------------------------------------*
* Following "`" and lowercase characters are for            *
* adding lowercase character set in 99/4A, 5/12/81          *
*-----------------------------------------------------------*
       BYTE CPNIL             ` GRAVE ACCENT
       BYTE CPALPH+CPLOW      a LOWERCASE a
       BYTE CPALPH+CPLOW      b LOWERCASE b
       BYTE CPALPH+CPLOW      c LOWERCASE c
       BYTE CPALPH+CPLOW      d LOWERCASE d
       BYTE CPALPH+CPLOW      e LOWERCASE e
       BYTE CPALPH+CPLOW      f LOWERCASE f
       BYTE CPALPH+CPLOW      g LOWERCASE g
       BYTE CPALPH+CPLOW      h LOWERCASE h
       BYTE CPALPH+CPLOW      i LOWERCASE i
       BYTE CPALPH+CPLOW      j LOWERCASE j
       BYTE CPALPH+CPLOW      k LOWERCASE k
       BYTE CPALPH+CPLOW      l LOWERCASE l
       BYTE CPALPH+CPLOW      m LOWERCASE m
       BYTE CPALPH+CPLOW      n LOWERCASE n
       BYTE CPALPH+CPLOW      o LOWERCASE o
       BYTE CPALPH+CPLOW      p LOWERCASE p
       BYTE CPALPH+CPLOW      q LOWERCASE q
       BYTE CPALPH+CPLOW      r LOWERCASE r
       BYTE CPALPH+CPLOW      s LOWERCASE s
       BYTE CPALPH+CPLOW      t LOWERCASE t
       BYTE CPALPH+CPLOW      u LOWERCASE u
       BYTE CPALPH+CPLOW      v LOWERCASE v
       BYTE CPALPH+CPLOW      w LOWERCASE w
       BYTE CPALPH+CPLOW      x LOWERCASE x
       BYTE CPALPH+CPLOW      y LOWERCASE y
       BYTE CPALPH+CPLOW      z LOWERCASE z
 
       EVEN
********************************************************************************
       AORG >6188
       TITL 'BASSUP'
 
* General Basic support routines (not includeing PARSE)
 
*
ERRBS  EQU  >0503             BAD SUBSCRIPT ERROR CODE
ERRTM  EQU  >0603             ERROR STRING/NUMBER MISMATCH
*
STCODE DATA >6500
C6     DATA >0006
*
* Entry to find Basic symbol table entry for GPL
*
FBSYMB BL   @FBS              Search the symbol table
       DATA RESET             If not found - condition reset
SET    SOCB @BIT2,@STATUS     Set GPL condition
       B    @NEXT             If found - condition set
* GPL entry for COMPCT to take advantage of common code
COMPCG  LI   R6,COMPCT        Address of COMPCT
       JMP  SMBB10            Jump to set up
* GPL entry for GETSTR to take advantage of common code
GETSTG LI   R6,GETSTR         Address of MEMCHK
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
SMBB   LI   R6,SMB            Address of SMB routine
       JMP  SMBB10            Jump to set up
* GPL entry for ASSGNV to take advantage of common code
ASSGNV LI   R6,ASSG           Address of ASSGNV routine
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
SYMB   LI   R6,SYM            Address of SYM routine
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
VPUSHG LI   R6,VPUSH          Address of VPUSH routine
SMBB10 MOV  R11,R7            Save return address
       BL   @PUTSTK           Save current GROM address
       BL   @SETREG           Set up Basic registers
       INCT R9                Get space on subroutine stack
       MOV  R7,*R9            Save the return address
       BL   *R6               Branch and link to the routine
       MOV  *R9,R7            Get return address
       DECT R9                Restore subroutine stack
       BL   @SAVREG           Save registers for GPL
       BL   @GETSTK           Restore GROM address
       B    *R7               Return to GPL
*************************************************************
* Subroutine to find the pointer to variable space of each  *
* element of symbol table entry. Decides whether symbol     *
* table entry pointed to by FAC, FAC+1 is a simple variable *
* and returns proper 8-byte block in FAC through FAC7       *
*************************************************************
SMB    INCT R9                Get space on subroutine stack
       MOV  R11,*R9           Save return address
       MOV  @FAC,@FAC4        Copy pointer to table entry
       A    @C6,@FAC4         Add 6 so point a value space
       BL   @GETV             Get 1st byte of table entry
       DATA FAC               Pointer is in FAC
*
       MOV  R1,R4             Copy for later use.
       MOV  R1,R2             Copy for later use.
       SLA  R1,2              Check for UDF entry
       JOC  BERMUV            If UDF - then error
       MOV  R4,R4             Check for string.
       JLT  SMB02             Skip if it is string.
       CLR  @FAC2             Clear for numeric case.
*
* In case of subprogram call check if parameter is shared by
* it's  calling program.
*
SMB02  SLA  R1,1              Check for the shared bit.
       JNC  SMB04             If it is not shared skip.
       BL   @GET              Get the value space pointer
       DATA FAC4                in the symbol table.
       MOV  R1,@FAC4          Store the value space address.
*
* Branches to take care of string and array cases.
* Only the numeric variable case stays on.
*
SMB04  MOVB R4,R4             R4 has header byte information.
       JLT  SMBO50            Take care of string.
SMB05  SLA  R4,5              Get only the dimension number.
       SRL  R4,13
       JNE  SMBO20             go to array case.
*
* Numeric ERAM cases are special.
* If it is shared get the actual v.s. address from ERAM.
* Otherwise get it from VDP RAM.
*
       MOVB @RAMTOP,R4        Check for ERAM.
       JEQ  SMBO10            Yes ERAM case.
       SLA  R2,3              R2 has a header byte.
       JNC  SMB06             Shared bit is not ON.
       BL   @GETG             Get v.s. pointer from ERAM
       DATA FAC4
       JMP  SMB08
SMB06  BL   @GET              Not shared.
       DATA FAC4              Get v.s. address from VDP RAM.
*
SMB08  MOV  R1,@FAC4          Store it in FAC4 area.
*
* Return from the SMB routine.
*
SMBO10 MOV  *R9,R11           Restore return address
       DECT R9                Restore stack
       RT                     And return
BERMUV B    @ERRMUV           * INCORRECT NAME USAGE
*
* Start looking for the real address of the symbol.
*
SMBO50 CI   R8,LPARZ*256      String - now string array?
       JEQ  SMB05             Yes, process as an array
SMB51  MOV  @STCODE,@FAC2     String ID code in FAC2
       MOV  @FAC4,@FAC        Get string pointer address
       BL   @GET              Get exact pointer to string
       DATA FAC
*
       MOV  R1,@FAC4          Save pointer to string
       MOV  R1,R3             Was it a null?
       JEQ  SMB57             Length is 0 - so is null
       DEC  R3                Otherwise point at length byte
       BL   @GETV1            Get the string length
       SRL  R1,8              Shift for use as double
SMB57  MOV  R1,@FAC6          Put into FAC entry
       JMP  SMBO10            And return
*
* Array cases are taken care of here.
*
SMBO20  MOV R4,@FAC2          Now have a dimension counter
*                              that is initilized to maximum.
*  *FAC+4,FAC+5 already points to 1st dimension maximum in
*    in symbol table.
       CLR  R2                Clear index accumulator
SMBO25 MOV  R2,@FAC6          Save accumulator in FAC
       BL   @PGMCHR           Get next character
       BL   @PSHPRS           PUSH and PARSE subscript
       BYTE LPARZ,0           Up to a left parenthesis or less
*
       CB   @FAC2,@STCODE     Dimension can't be a string
       JHE  ERRT              It is - so error
* Now do float to interger conversion of dimension
       CLR  @FAC10            Assume no error
       BL   @CFI              Gets 2 byte integer in FAC,FAC1
       MOVB @FAC10,R4         Error on conversion?
       JNE  ERR3              Yes, error BAD SUBSCRIPT
       MOV  @FAC,R5           Save index just read
       BL   @VPOP             Restore FAC block
       BL   @GET              Get next dimension maximum
       DATA FAC4              FAC4 points into symbol table
*
       C    R5,R1             Subscript less-then maximum?
       JH   ERR3              No, index out of bounds
BIT2   EQU  $+1               Constant >20 (Opcode is >D120)
       MOVB @BASE,R4          Fetch option base to check low
       JEQ  SMBO40            If BASE=0, INDEX=0 is ok
       DEC  R5                Adjust BASE 1 index
       JLT  ERR3              If subscript was =0 then error
       JMP  SMBO41            Accumulate the subscripts
SMBO40 INC  R1                Adjust size if BASE=0
SMBO41 MPY  @FAC6,R1          R1,R2 has ACCUM*MAX dimension
       A    R5,R2             Add latest to accumulator
       INCT @FAC4             Increment dimension max pointer
       DEC  @FAC2             Decrement remaining-dim count
       JEQ  SMBO70            All dimensions handled ->done
       CI   R8,COMMAZ*256     Otherwise, must be at a comma
       JEQ  SMBO25            We are, so loop for more
ERR1   B    @ERRSYN           Not a comma, so SYNTAX ERROR
*
* At this point the required number of dimensions have been
*  scanned.
* R2 Contains the index
* R4 Points to the first array element or points to the
*  address in ERAM where the first array element is.
SMBO70 CI   R8,RPARZ*256      Make sure at a right parenthesis
       JNE  ERR1              Not, so error
       BL   @PGMCHR           Get nxt token
       BL   @GETV             Now check string or numeric
       DATA FAC                array by checking s.t.
*
       JLT  SMB71             If MSB set is a string array
       SLA  R2,3              Numeric, multiply by 8
       MOVB @RAMTOP,R3        Does ERAM exist?
       JEQ  SMBO71            No
       BL   @GET              Yes, get the content of value
       DATA FAC4               pointer
*
       MOV  R1,@FAC4          Put it in FAC4
SMBO71 A    R2,@FAC4          Add into values pointer
       JMP  SMBO10            And return in the normal way
SMB71  SLA  R2,1              String, multiply by 2
       A    R2,@FAC4          Add into values pointer
       JMP  SMB51             And build the string FAC entry
ERR3   LI   R0,ERRBS          Bad subscript return vector
ERRX   B    @ERR              Exit to GPL
ERRT   LI   R0,ERRTM          String/number mismatch vector
       JMP  ERRX              Use the long branch
*************************************************************
* Subroutine to put symbol name into FAC and to call FBS to *
* find the symbol table for the symbol                      *
*************************************************************
SYM    CLR  @FAC15            Clear the caharacter counter
       LI   R2,FAC            Copying string into FAC
       MOV  R11,R1            Save return address
*-----------------------------------------------------------*
* Fix "A long constant in a variable field in INPUT,        *
*      ACCEPT, LINPUT, NEXT and READ etc. may crash the     *
*      sytem" bug,            5/22/81
* Insert the following 2 lines
       MOVB R8,R8
       JLT  ERR1              If token
SYM1   MOVB R8,*R2+           Save the character
       INC  @FAC15            Count it
       BL   @PGMCHR           Get next character
       JGT  SYM1              Still characters in the name
       BL   @FBS              Got name, now find s.t. entry
       DATA ERR1              Return vector if not found
*
       B    *R1               Return to caller if found
*************************************************************
* ASSGNV, callable from GPL or 9900 code, to assign a value *
* to a symbol (strings and numerics) . If numeric, the      *
* 8 byte descriptor is in the FAC. The descriptor block     *
* (8 bytes) for the destination variable is on the stack.   *
* There are two types of descriptor entries which are       *
* created by SMB in preparation for ASSGNV, one for         *
* numerics and one for strings.                             *
*                     NUMERIC                               *
* +-------------------------------------------------------+ *
* |S.T. ptr | 00 |       |Value ptr |                     | *
* +-------------------------------------------------------+ *
*                     STRING
* +-------------------------------------------------------+ *
* |Value ptr| 65 |       |String ptr|String length        | *
* +-------------------------------------------------------+ *
*                                                           *
* CRITICAL NOTE: Becuase of the BL @POPSTK below, if a      *
* string entry is popped and a garbage collection has taken *
* place while the entry was pushed on the stack, and the    *
* entry was a permanent string the pointer in FAC4 and FAC5 *
* will be messed up. A BL @VPOP would have taken care of    *
* the problem but would have taken a lot of extra code.     *
* Therefore, at ASSG50-ASSG54 it is assumed that the        *
* previous value assigned to the destination variable has   *
* been moved and the pointer must be reset by going back to *
* the symbol table and getting the correct value pointer.   *
*************************************************************
ASSG   MOV  R11,R10           Save the retun address
       BL   @ARGTST           Check arg and variable type
       STST R12               Save status of type
       BL   @POPSTK           Pop destination descriptor
*                              into ARG
       SLA  R12,3             Variable type numeric?
       JNC  ASSG70            Yes, handle it as such
* Assign a string to a string variable
       MOV  @ARG4,R1          Get destination pointer
*                             Dest have non-null  value?
       JEQ  ASSG54            No, null->never assigned
* Previously assigned - Must first free the old value
       BL   @GET              Correct for POPSTK above
       DATA ARG               Pointer is in ARG
*
       MOV  R1,@ARG4          Correct ARG+4,5 too
*-----------------------------------------------------------*
* Fix "Assigning a string to itself when memory is full can *
*      destroy the string" bug, 5/22/81                     *
* Add the following 2 lines and the label ASSG80            *
       C    R1,@FAC4          Do not do anything in assign- *
*                              ing a string to itself case  *
       JEQ  ASSG80            Detect A$=A$ case, exit       *
*-----------------------------------------------------------*
       CLR  R6                Clear for zeroing backpointer
       BL   @STVDP3           Free the string
ASSG54 MOV  @FAC6,R4          Is source string a null?
       JEQ  ASSG57            Yes, handle specially
       MOV  @FAC,R3           Get address of source pointer
       CI   R3,>001C          Got a temporay string?
       JNE  ASSG56            No, more complicated
       MOV  @FAC4,R4          Pick up direct ptr to string
* Common string code to set forward and back pointers
ASSG55 MOV  @ARG,R6           Ptr to symbol table pointer
       MOV  R4,R1             Pointer to source string
       BL   @STVDP3           Set the backpointer
ASSG57 MOV  @ARG,R1           Address of symbol table ptr
       MOV  R4,R6             Pointer to string
       BL   @STVDP            Set the forward pointer
ASSG80 B    *R10              Done, return
* Symbol-to-symbol assigments of strings
* Must create copy of string
ASSG56 MOV  @FAC6,@BYTE       Fetch length for GETSTR
* NOTE: FAC through FAC+7 cannot be destroyed
*       address^of string length^of string
       BL   @VPUSH            So save it on the stack
       MOV  R10,@FAC          Save return link in FAC since
*                              GETSTR does not destroy FAC
       BL   @GETSTR           Call GPL to do the GETSTR
       MOV  @FAC,R10          Restore return link
       BL   @VPOP             Pop the source info back
* Set up to copy the source string into destination
       MOV  @FAC4,R3          R3 is now copy-from
       MOV  @SREF,R5          R5 is now copy-to
       MOV  R5,R4             Save for pointer setting
* Registers to be used in the copy
* R1 - Used for a buffer
* R3 - Copy-from address
* R2 - # of bytes to be moved
* R5 - copy-to address
       MOV  @FAC6,R2          Fetch the length of the string
       ORI  R5,WRVDP          Enable the VDP write
ASSG59 BL   @GETV1            Get the character
       MOVB @R5LB,*R15        Load out destination address
       INC  R3                Increment the copy-from
       MOVB R5,*R15           1st byte of address to
       INC  R5                Increment for next character
       MOVB R1,@XVDPWD        Put the character out
       DEC  R2                Decrement count, finished?
       JGT  ASSG59            No, loop for more
       JMP  ASSG55            Yes, now set pointers
* Code to copy a numeric value into the symbol table
ASSG70 LI   R2,8              Need to assign 8 bytes
       MOV  @ARG4,R5          Destination pointer(R5)
*                              from buffer(R4), (R2)bytes
       MOV  @RAMTOP,R3        Does ERAM exist?
       JNE  ASSG77            Yes, write to ERAM
*                             No, write to VDP
       MOVB @R5LB,*R15        Load out 2nd byte of address
       ORI  R5,WRVDP          Enable the write to the VDP
       MOVB R5,*R15           Load out 1st byte of address
       LI   R4,FAC            Source is FAC
ASSG75 MOVB *R4+,@XVDPWD      Move a byte
       DEC  R2                Decrement the counter, done?
       JGT  ASSG75            No, loop for more
       B    *R10              Yes, return to the caller
ASSG77 LI   R4,FAC            Source is in FAC
ASSG79 MOVB *R4+,*R5+         Move a byte
       DEC  R2                Decrement the counter, done?
       JGT  ASSG79            No, loop for more
       B    *R10              Yes, return to caller
* Check for required token
SYNCHK MOVB *R13,R0           Read required token
*
       CB   R0,@CHAT          Have the required token?
       JEQ  PGMCH             Yes, read next character
       BL   @SETREG           Error return requires R8/R9 set
       B    @ERRSYN           * SYNTAX ERROR
*      PGMCH - GPL entry point for PGMCHR to set up registers
PGMCH  MOV  R11,R12           Save return address
       BL   @PGMCHR           Get the next character
       MOVB R8,@CHAT          Put it in for GPL
       B    *R12              Return to GPL
       RT                     And return to the caller
PUTV   MOV  *R11+,R4
       MOV  *R4,R4
PUTV1  MOVB @R4LB,*R15
       ORI  R4,WRVDP
       MOVB R4,*R15
       NOP
       MOVB R1,@XVDPWD
       RT
* MOVFAC - copies 8 bytes from VDP(@FAC4) or ERAM(@FAC4)
*          to FAC
MOVFAC MOV @FAC4,R1           Get pointer to source
       LI  R2,8               8 byte values
       LI  R3,FAC             Destination is FAC
       MOV @RAMTOP,R0         Does ERAM exist?
       JNE MOVFA2             Yes, from ERAM
*                             No, from VDP RAM
       SWPB R1
       MOVB R1,*R15           Load 2nd byte of address
       SWPB R1
       MOVB R1,*R15           Load 1st byte of address
       LI   R5,XVDPRD
MOVF1  MOVB *R5,*R3+          Move a byte
       DEC  R2                Decrement counter, done?
       JGT  MOVF1             No, loop for more
       RT                     Yes, return to caller
MOVFA2 MOVB *R1+,*R3+
       DEC  R2
       JNE  MOVFA2
       RT
       RT                     And return to caller
********************************************************************************
       AORG >6464
       TITL 'PARSES'
 
*      BASIC PARSE CODE
* REGISTER USAGE
*    RESERVED FOR GPL INTERPRETER  R13, R14, R15
*          R13 contains the read address for GROM
*          R14 is used in BASSUP/10 for the VDPRAM pointer
*    RESERVED IN BASIC SUPPORT
*          R8 MSB current character (like CHAT in GPL)
*          R8 LSB zero
*          R10 read data port address for program data
*   ALL EXITS TO GPL MUST GO THROUGH "NUDG05"
*
 
*                         ~~~TOKENS~~~
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               STATEMENT SEPERATOR
TREMZ  EQU  >83               TAIL REMARK
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
BREAKZ EQU  >8E               BREAK
NEXTZ  EQU  >96               NEXT
SUBZ   EQU  >A1               SUB
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
COMMAZ EQU  >B3               COMMA
RPARZ  EQU  >B6               RIGHT PARENTHESIS )
LPARZ  EQU  >B7               LEFT PARENTHESIS (
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQZ    EQU  >BE               EQUAL (=)
GTZ    EQU  >C0               GREATER THEN (>)
PLUSZ  EQU  >C1               PLUS (+)
MINUSZ EQU  >C2               MINUS (-)
DIVIZ  EQU  >C4               DIVIDE (/)
EXPONZ EQU  >C5               EXPONENT
STRINZ EQU  >C7               STRING
LNZ    EQU  >C9               LINE NUMBER
ABSZ   EQU  >CB               ABSOLUTE
SGNZ   EQU  >D1               SIGN
*
C24    DATA 24                CONSTANT 24
EXRTNA DATA EXRTN             RETURN FOR EXEC
*
ERRSO  LI   R0,>0703          Issue STACK OVERFLOW message
       B    @ERR
*
* GRAPHICS LANGUAGE ENTRY TO PARSE
*
PARSEG BL   @SETREG           Set up registers for Basic
       MOVB @GRMRAX(R13),R11   Get GROM address
       MOVB @GRMRAX(R13),@R11LB
       DEC  R11
*
* 9900 ENTRY TO PARSE
*
PARSE  INCT R9                Get room for return address
       CI   R9,STKEND         Stack full?
       JH   ERRSO             Yes, too many levels deep
       MOV  R11,*R9           Save the return address
P05    MOVB R8,R7             Test for token beginning
       JLT  P10               If token, then look it up
       B    @PSYM             If not token is a symbol
P10    BL   @PGMCHR           Get next character
       SRL  R7,7              Change last character to offset
       AI   R7,->B7*2         Check for legal NUD
       CI   R7,NTABLN         Within the legal NUD address?
       JH   CONT15            No, check for legal LED
       MOV  @NTAB(R7),R7      Get NUD address
       JGT  B9900             If 9900 code
P17    EQU  $                 R7 contains offset into nudtab
       ANDI R7,>7FFF          If GPL code, get rid of MSB
       A    @NUDTAB,R7        Add in table address
NUDG05 BL   @SAVREG           Restore GPL pointers
       MOVB R7,@GRMWAX(R13)    Write out new GROM address
       SWPB R7                Bare the LSB
       MOVB R7,@GRMWAX(R13)    Put it out too
       B    @RESET            Go back to GPL interpreter
P17L   JMP  P17
*
* CONTINUE ROUTINE FOR PARSE
*
CONTG  BL   @SETREG           GPL entry-set Basic registers
CONT   MOV  *R9,R6            Get last address from stack
       JGT  CONT10            9900 code if not negative
       MOVB R6,@GRMWAX(R13)    Write out new GROM address
       SWPB R6                Bare the second byte
       MOVB R6,@GRMWAX(R13)    Put it out too
       MOV  R13,R6            Set up to test precedence
CONT10 CB   *R6,R8            Test precedence
       JHE  NUDNDL            Have parsed far enough->return
       SRL  R8,7              Make into table offset
       AI   R8,->B8*2         Minimum token for a LED (*2)
       CI   R8,LTBLEN         Maximum token for a LED (*2)
CONT15 JH   NOLEDL            If outside legal LED range-err
       MOV  @LTAB(R8),R7      Pick up address of LED handler
       CLR  R8                Clear 'CHAT' for getting new
       BL   @PGMCHR           Get next character
B9900  B    *R7               Go to the LED handler
NUDE10 DECT R9                Back up subroutine stack
       INC  R7                Skip over precedence
       JMP  NUDG05            Goto code to return to GPL
NOLEDL B    @NOLED
NUDNDL JMP  NUDND1
* Execute one or more lines of Basic
EXECG  EQU  $                 GPL entry point for execution
       BL   @SETREG           Set up registers
       CLR  @ERRCOD           Clear the return code
       MOVB @PRGFLG,R0        Imperative statement?
       JEQ  EXEC15            Yes, handle it as such
* Loop for each statement in the program
EXEC10 EQU  $
       MOVB @FLAG,R0          Now test for trace mode
       SLA  R0,3              Check the trace bit in FLAG
       JLT  TRACL             If set->display line number
EXEC11 MOV  @EXTRAM,@PGMPTR   Get text pointer
       DECT @PGMPTR           Back to the line # to check
*                              break point
       BL   @PGMCHR           Get the first byte of line #
       STST R0                Save status for breakpnt check
       INC  @PGMPTR           Get text pointer again
       BL   @PGMCHR           Go get the text pointer
       SWPB R8                Save 1st byte of text pointer
       BL   @PGMCHR           Get 2nd byte of text pointer
       SWPB R8                Put text pointer in order
       MOV  R8,@PGMPTR        Set new text pointer
       CLR  R8                Clean up the mess
       SLA  R0,2              Check breakpoint status
       JLT  EXEC15            If no breakpoint set - count
       JNC  BRKPNT            If breakpoint set-handle it
EXEC15 EQU  $                                                  <****************
C3     EQU  $+2               Constant data 3                  <
CB3    EQU  $+3               Constant byte 3                  <
       LIMI 3                 Let interrupts loose             <
C0     EQU  $+2               Constant data 0                  <
       LIMI 0                 Shut down interrupts             <
       CLR  @>83D6            Reset VDP timeout                < CRU
       LI   R12,>24           Load console KBD address in CRU  < KEY
       LDCR @C0,3             Select keyboard section          < SCAN
       LI   R12,6             Read address                     < SECTION
       STCR R0,8              SCAN the keyboard                < MUST
       CZC  @C1000,R0         Shift-key depressed?             < BE
       JNE  EXEC16            No, execute the Basic statement  < PATCHED
       LI   R12,>24           Test column 3 of keyboard        < TO
       LDCR @CB3,3            Select keyboard section          < WORK
       LI   R12,6             Read address                     < ON
       STCR R0,8              SCAN the keyboard                < A
       CZC  @C1000,R0         Shift-C depressed?               < GENEVE
       JEQ  BRKP1L            Yes, so take Basic breakpoint    < COMPUTER
EXEC16 MOV  @PGMPTR,@SMTSRT   Save start of statement
       INCT R9                Get subroutine stack space
       MOV  @EXRTNA,*R9       Save the GPL return address
       BL   @PGMCHR           Now get 1st character of stmt
       JEQ  EXRTN3            If EOL after EOS
EXEC17 JLT  EXEC20            If top bit set->keyword
       B    @NLET             If not->fake a 'LET' stmt
EXEC20 MOV  R8,R7             Save 1st token so can get 2nd
       INC  @PGMPTR           Increment the perm pointer
       MOVB *R10,R8           Read the character
       SRL  R7,7              Convert 1st to table offset
       AI   R7,->AA*2         Check for legal stmt token
       JGT  ERRONE            Not in range -> error
       MOV  @STMTTB(R7),R7    Get address of stmt handler
       JLT  P17L              If top bit set -> GROM code
       B    *R7               If 9900 code, goto it!
EXRTN  BYTE >83               Unused bytes for data constant
CBH65  BYTE >65                since NUDEND skips precedences
       CI   R8,SSEPZ*256      EOS only?
       JEQ  EXEC15            Yes, continue on this line
EXRTN2 MOVB @PRGFLG,R0        Did we execute an imperative
       JEQ  EXEC50            Yes, so return to top-level
       S    @C4,@EXTRAM       No, so goto the next line
       C    @EXTRAM,@STLN     Check to see if end of program
       JHE  EXEC10            No, so loop for the next line
       JMP  EXEC50            Yes, so return to top-level
*
* STMT handler for ::
*
SMTSEP MOVB R8,R8             EOL?
       JNE  EXEC17            NO, there is another stmt
EXRTN3 DECT R9                YES
       JMP  EXRTN2            Jump back into it
* Continue after a breakpoint
CONTIN BL   @SETREG           Set up Basic registers
EXC15L JMP  EXEC15            Continue execution
BRKP1L JMP  BRKPN1
TRACL  JMP  TRACE
* Test for required End-Of-Statement
EOL    MOVB R8,R8             EOL reached?
       JEQ  NUDND1            Yes
       CI   R8,TREMZ*256      Higher then tail remark token?
       JH   ERRONE            Yes, its an error
       CI   R8,ELSEZ*256      Tail, ssep or else?
       JL   ERRONE            No, error
*
* Return from call to PARSE
* (entered from CONT)
*
NUDND1 MOV  *R9,R7            Get the return address
       JLT  NUDE10            If negative - return to GPL
       DECT R9                Back up the subroutine stack
       B    @2(R7)            And return to caller
*      (Skip the precedence word)
NUDEND MOVB R8,R8             Check for EOL
       JEQ  NUDND1            If EOL
NUDND2 CI   R8,STRINZ*256     Lower than a string?
       JL   NUDND4            Yes
       CI   R8,LNZ*256        Higher than a line #?
       JEQ  SKPLN             Skip line numbers
       JL   SKPSTR            Skip string or numeric
NUDND3 BL   @PGMCHR           Read next character
       JEQ  NUDND1            If EOL
       JMP  NUDND2            Continue scan of line
NUDND4 CI   R8,TREMZ*256      Higher than a tail remark?
       JH   NUDND3            Yes
       CI   R8,SSEPZ*256      Lower then stmt sep(else)?
       JL   NUDND3            Yes
       JMP  NUDND1            TREM or SSEP
SKPSTR BL   @PGMCHR
       SWPB R8                Prepare to add
       A    R8,@PGMPTR        Skip it
       CLR  R8                Clear lower byte
SKPS01 BL   @PGMCHR           Get next token
       JMP  NUDEND            Go on
SKPLN  INCT @PGMPTR           Skip line number
       JMP  SKPS01            Go on
*
* Return from "CALL" to GPL
RTNG   BL   @SETREG           Set up registers again
       JMP  NUDND1            And jump back into it!
*************************************************************
* Handle Breakpoints
BRKPNT MOVB @FLAG,R0          Check flag bits
       SLA  R0,1              Check bit 6 for breakpoint
       JLT  EXC15L            If set then ignore breakpoint
BRKPN2 LI   R0,BRKFL
       JMP  EXIT              Return to top-level
BRKPN1 MOVB @FLAG,R0          Move flag bits
       SLA  R0,1              Check bit 6 for breakpoint
       JLT  EXEC16            If set then ignore breakpoint
       JMP  BRKPN2            Bit not set
*
* Error handling from 9900 code
*
ERRSYN EQU  $                 These all issue same message
ERRONE EQU  $
NONUD  EQU  $
NOLED  EQU  $
       LI   R0,ERRSN          *SYNTAX ERROR return code
EXIT   EQU  $
ERR    MOV  R0,@ERRCOD        Load up return code for GPL
* General return to GPL portion of Basic
EXEC50 MOV  @RTNADD,R7        Get return address
       B    @NUDG05           Use commond code to link back
* Handle STOP and END statements
STOP
END    DECT R9                Pop last call to PARSE
       JMP  EXEC50            Jump to return to top-level
* Error codes for return to GPL
ERRSN  EQU  >0003             ERROR SYNTAX
ERROM  EQU  >0103             ERROR OUT OF MEMORY
ERRIOR EQU  >0203             ERROR INDEX OUT OF RANGE
ERRLNF EQU  >0303             ERROR LINE NOT FOUND
ERREX  EQU  >0403             ERROR EXECUTION
* >0004 WARNING NUMERIC OVERFLOW
BRKFL  EQU  >0001             BREAKPOINT RETURN VECTOR
ERROR  EQU  >0005             ON ERROR
UDF    EQU  >0006             FUNCTION REFERENCE
BREAK  EQU  >0007             ON BREAK
CONCAT EQU  >0008             CONCATENATE (&) STRINGS
WARN   EQU  >0009             ON WARNING
* Warning routine (only OVERFLOW)
WARNZZ MOV  @C4,@ERRCOD       Load warning code for GPL
       LI   R11,CONT-2        To optimize for return
* Return to GPL as a CALL
CALGPL INCT R9                Get space on subroutine stack
       MOV  R11,*R9           Save return address
       JMP  EXEC50            And go to GPL
* Trace a line (Call GPL routine)
TRACE  MOV  @C2,@ERRCOD       Load return vector
       LI   R11,EXEC11-2      Set up for return to execute
       JMP  CALGPL            Call GPL to display line #
* Special code to handle concatenate (&)
CONC   LI   R0,CONCAT         Go to GPL to handle it
       JMP  EXIT              Exit to GPL interpeter
*************************************************************
*              NUD routine for a numeric constant           *
* NUMCON first puts pointer to the numeric string into      *
* FAC12 for CSN, clears the error byte (FAC10) and then     *
* converts from a string to a floating point number. Issues *
* warning if necessary. Leaves value in FAC                 *
*************************************************************
NUMCON MOV  @PGMPTR,@FAC12    Set pointer for CSN
       SWPB R8                Swap to get length into LSB
       A    R8,@PGMPTR        Add to pointer to check end
       CLR  @FAC10            Assume no error
       BL   @SAVRE2           Save registers
       LI   R3,GETCH          Adjustment for ERAM in order
       MOVB @RAMFLG,R4         to call CSN
       JEQ  NUMC49
       LI   R3,GETCGR
NUMC49 BL   @CSN01            Convert String to Number
       BL   @SETREG           Restore registers
       C    @FAC12,@PGMPTR    Check to see if all converted
       JNE  ERRONE            If not - error
       BL   @PGMCHR           Now get next char from program
       MOVB @FAC10,R0         Get an overflow on conversion?
       JNE  WARNZZ            Yes, have GPL issue warning
       B    @CONT             Continue the PARSE
*
* ON ERROR, ON WARNING and ON BREAK
ONERR  LI   R0,ERROR          ON ERROR code
       JMP  EXIT              Return to GPL code
ONWARN LI   R0,WARN           ON WARNING code
       JMP  EXIT              Return to GPL code
ONBRK  LI   R0,BREAK          ON BREAK code
       JMP  EXIT              Return to GPL code
*
* NUD routine for "GO"
*
GO     CLR  R3                Dummy "ON" index for common
       JMP  ON30              Merge into "ON" code
*
* NUD ROUTINE FOR "ON"
*
ON     CI   R8,WARNZ*256      On warning?
       JEQ  ONWARN            Yes, goto ONWARN
       CI   R8,ERRORZ*256     On error?
       JEQ  ONERR             Yes, got ONERR
       CI   R8,BREAKZ*256     On break?
       JEQ  ONBRK             Yes, goto ONBRK
*
* Normal "ON" statement
*
       BL   @PARSE            PARSE the index value
       BYTE COMMAZ            Stop on a comma or less
CBH66  BYTE >66               Unused byte for constant
       BL   @NUMCHK           Ensure index is a number
       CLR  @FAC10            Assume no error in CFI
       BL   @CFI              Convert Floating to Integer
       MOVB @FAC10,R0         Test error code
       JNE  GOTO90            If overflow, BAD VALUE
       MOV  @FAC,R3           Get the index
       JGT  ON20              Must be positive
GOTO90 LI   R0,ERRIOR         Negative, BAD VALUE
GOTO95 JMP  ERR               Jump to error handler
ON20   EQU  $                 Now check GO TO/SUB
       CI   R8,GOZ*256        Bare "GO" token?
       JNE  ON40              No, check other possibilities
       BL   @PGMCHR           Yes, get next token
ON30   CI   R8,TOZ*256        "GO TO" ?
       JEQ  GOTO50            Yes, handle GO TO like GOTO
       CI   R8,SUBZ*256       "GO SUB" ?
       JMP  ON50              Merge to common code to test
ON40   CI   R8,GOTOZ*256      "GOTO" ?
       JEQ  GOTO50            Yes, go handle it
       CI   R8,GOSUBZ*256     "GOSUB" ?
ON50   JNE  ERRONE            No, so is an error
       BL   @PGMCHR           Get next token
       JMP  GOSUB2            Goto gosub code
ERR1B  JMP  ERRONE            Issue error message
* NUD routine for "GOSUB"
GOSUB  CLR  R3                Dummy index for "ON" code
* Common GOSUB code
GOSUB2 EQU  $                 Now build a FAC entry
       LI   R1,FAC            Optimize to save bytes
       MOV  R3,*R1+           Save the "ON" index
*                              in case of garbage collection
       MOVB @CBH66,*R1+       Indicate GOSUB entry on stack
       INC  R1                Skip FAC3
       MOV  @PGMPTR,*R1       Save current ptr w/in line
       INCT *R1+              Skip line # to correct place
       MOV  @EXTRAM,*R1       Save current line # pointer
       BL   @VPUSH            Save the stack entry
       MOV  @FAC,R3           Restore the "ON" index
       JMP  GOTO20            Jump to code to find the line
* NUD routine for "GOTO"
GOTO   CLR  R3                Dummy index for "ON" code
* Common (ON) GOTO/GOSUB THEN/ELSE code to fine line
*
* Get line number from program
GOTO20 CI   R8,LNZ*256        Must have line number token
       JNE  ERR1B             Don't, so error
GETL10 BL   @PGMCHR           Get MSB of the line number
       MOVB R8,R0             Save it
       BL   @PGMCHR           Read the character
       DEC  R3                Decrement the "ON" index
       JGT  GOTO40            Loop if not there yet
*
* Find the program line
*
       MOV  @STLN,R1          Get into line # table
       MOVB @RAMFLG,R2        Check ERAM flag to see where?
       JEQ  GOTO31            From VDP, go handle it
       MOV  R1,R2             Copy address
GOT32  C    R1,@ENLN          Finished w/line # table?
       JHE  GOTO34            Yes, so line doesn't exist
       MOVB *R2+,R3           2nd byte match?
       ANDI R3,>7FFF          Reset possible breakpoint
       CB   R3,R0             Compare 1st byte of #, Match?
       JNE  GOT35             Not a match, so move on
       CB   *R2+,R8           2nd byte match?
       JEQ  GOTO36            Yes, line is found!
GOT33  INCT R2                Skip line pointer
       MOV  R2,R1             Advance to next line in table
       JMP  GOT32             Go back for more
GOT35  MOVB *R2+,R3           Skip 2nd byte of line #
       JMP  GOT33             And jump back in
GOTO31 MOVB @R1LB,*R15        Get the data from the VDP
       LI   R2,XVDPRD         Load up to read data
       MOVB R1,*R15           Write out MSB of address
GOTO32 C    R1,@ENLN          Finished w/line # table
       JHE  GOTO34            Yes, so line doesn't exist
       MOVB *R2,R3            Save in temporary place for
*                              breakpoint checking
       ANDI R3,>7FFF          Reset possible breakpoint
       CB   R3,R0             Compare 1st byte of #, Match?
       JNE  GOTO35            Not a match, so move on
       CB   *R2,R8            2nd byte match?
       JEQ  GOTO36            Yes, line is found!
GOTO33 MOVB *R2,R3            Skip 1st byte of line pointer
       AI   R1,4              Advance to next line in table
       MOVB *R2,R3            Skip 1nd byte of line pointer
       JMP  GOTO32            Go back for more
GOTO35 MOVB *R2,R3            Skip 2nd byte of line #
       JMP  GOTO33            And jump back in
GOTO34 LI   R0,ERRLNF         LINE NOT FOUND error vector
       JMP  GOTO95            Jump for error exit
GOTO36 INCT R1                Adjust to line pointer
       MOV  R1,@EXTRAM        Save for execution of the line
       DECT R9                Pop saved link to goto
       B    @EXEC10           Reenter EXEC code directly
GOTO40 BL   @PGMCHR           Get next token
       BL   @EOSTMT           Premature end of statement?
       JEQ  GOTO90            Yes =>BAD VALUE for index
       CI   R8,COMMAZ*256     Comma next ?
       JNE  ERR1C             No, error
GOTO50 BL   @PGMCHR           Yes, get next character
       JMP  GOTO20            And check this index value
ERR1C  JMP  ERR1B             Linking becuase long-distance
ERR51  LI   R0,>0903          RETURN WITHOUT GOSUB
       JMP  GOTO95            Exit to GPL
* NUD entry for "RETURN"
RETURN C    @VSPTR,@STVSPT    Check bottom of stack
       JLE  ERR51             Error -> RETURN WITHOUT GOSUB
       BL   @VPOP             Pop entry
       CB   @CBH66,@FAC2      Check ID for a GOSUB entry
       JNE  RETU30            Check for ERROR ENTRY
*
* Have a GOSUB entry
*
       BL   @EOSTMT           Must have EOS after return
       JNE  RETURN            Not EOS, then error return?
       MOV  @FAC4,@PGMPTR     Get return ptr w/in line
       MOV  @FAC6,@EXTRAM     Get return line pointer
       B    @SKPS01           Go adjust it and get back
* Check ERROR entry
RETU30 CB   @CBH69,@FAC2      ERROR ENTRY?
       JEQ  RETU40            Yes, take care of error entry
       CB   @CBH6A,@FAC2      Subprogram entry?
       JNE  RETURN            No, look some more
       BL   @VPUSH            Push it back. Keep information
       JMP  ERR51             RETURN WITHOUT GOSUB error
*
* Have an ERROR entry
* RETURN, RETURN line #, RETURN or RETURN NEXT follows.
*
RETU40 CLR  R3                In case of a line number
       CI   R8,LNZ*256        Check for a line number
       JEQ  GETL10            Yes, treat like GOTO
       MOV  @FAC4,@PGMPTR     Get return ptr w/in line
       MOV  @FAC6,@EXTRAM     Get return line pointer
       BL   @EOSTMT           EOL now?
       JEQ  BEXC15            Yes, treat like GOSUB rtn.
       CI   R8,NEXTZ*256      NEXT now?
       JNE  ERR1C             No, so its an error
       B    @SKPS01           Yes, so execute next statement
BEXC15 B    @EXEC15           Execute next line
CBH6A  BYTE >6A               Subprogram call stack ID
       EVEN
*************************************************************
*         EOSTMT - Check for End-Of-STateMenT               *
*         Returns with condition '=' if EOS                 *
*           else condition '<>' if not EOS                  *
*************************************************************
EOSTMT MOVB R8,R8             EOL or non-token?
       JEQ  EOSTM1            EOL-return condition '='
       JGT  EOSTM1            Non-token return condition '<>'
       CI   R8,TREMZ*256      In the EOS range (>81 to >83)?
       JH   EOSTM1            No, return condition '<>'
       C    R8,R8             Yes, force condition to '='
EOSTM1 RT
*************************************************************
*         EOLINE - Tests for End-Of-LINE; either a >00 or a *
*                  '!'                                      *
*         Returns with condition '=' if EOL else condition  *
*                  '<>' if not EOL                          *
*************************************************************
EOLINE MOVB R8,R8             EOL?
       JEQ  EOLNE1            Yes, return with '=' set
       CI   R8,TREMZ*256      Set condition on a tall remark
EOLNE1 RT                     And return
SYMB20 LI   R0,UDF            Long distance
       B    @GOTO95
* NUD for a symbol (variable)
PSYM   BL   @SYM              Get symbol table entry
       BL   @GETV             Get 1st byte of entry
       DATA FAC               SYM left pointer in FAC
*
       SLA  R1,1              UDF reference?
       JLT  SYMB20            Yes, special code for it
       BL   @SMB              No, get value space pointer
       CB   @FAC2,@CBH65      String reference?
       JEQ  SYMB10            Yes, special code for it
       BL   @MOVFAC           No, numeric ->copy into FAC
SYMB10 B    @CONT             And continue the PARSE
* Statement entry for IF statement
IF     BL   @PARSE            Evaluate the expression
       BYTE COMMAZ            Stop on a comma
CBH67  BYTE >67               Unused byte for a constant
       BL   @NUMCHK           Ensure the value is a number
       CLR  R3                Create a dummy "ON" index
       CI   R8,THENZ*256      Have a "THEN" token
       JNE  ERR1C             No, error
       NEG  @FAC              Test if condition true i.e. <>0
       JNE  IFZ10             True - branch to the special #
       BL   @PGMCHR           Advance to line number token
       CI   R8,LNZ*256        Have the line # token?
       JNE  IFZ20             No, must look harder for ELSE
       INCT @PGMPTR           Skip the line number
       BL   @PGMCHR           Get next token
IFZ5   CI   R8,ELSEZ*256      Test if token is ELSE
       JEQ  IFZ10             We do! So branch to the line #
       B    @EOL              We don't, so better be EOL
GETL1Z B    @GETL10           Get 1st token of clause
IFZ10  BL   @PGMCHR           Get 1st token of clause
       CI   R8,LNZ*256        Line # token?
       JEQ  GETL1Z            Yes, go there
       BL   @EOSTMT           EOS?
JEQ1C  JEQ  ERR1C             Yes, its an error
       LI   R8,SSEPZ*256      Cheat to do a continue
       DEC  @PGMPTR           Back up to get 1st character
       B    @CONT             Continue on
*
* LOOK FOR AN ELSE CLAUSE SINCE THE CONDITION WAS FALSE
*
IFZ20  LI   R3,1              IF/ELSE pair counter
       BL   @EOLINE           Trap out EOS following THEN/ELSE
       JEQ  JEQ1C             error
IFZ25  CI   R8,ELSEZ*256      ELSE?
       JNE  IFZ27             If not
       DEC  R3                Matching ELSE?
       JEQ  IFZ10             Yes, do it
       JMP  IFZ35             No, go on
IFZ27  CI   R8,IFZ*256        Check for it
       JNE  IFZ28             Not an IF
       INC  R3                Increment nesting level
       JMP  IFZ35              And go on
IFZ28  CI   R8,STRINZ*256     Lower than string?
       JL   IFZ30             Yes
       CI   R8,LNZ*256        Higher or = to a line #
       JEQ  IFZ40             = line #
       JL   IFZ50             Skip strings and numerics
IFZ30  BL   @EOLINE           EOL?
       JEQ  IFZ5              Yes, done scanning
IFZ35  BL   @PGMCHR           Get next character
       JMP  IFZ25               And go on
*
* SKIP LINE #'s
*
IFZ40  INCT @PGMPTR           Skip the line #
       JMP  IFZ35             Go on
*
* SKIP STRINGS AND NUMERICS
*
IFZ50  BL   @PGMCHR           Get # of bytes to skip
       SWPB R8                Swap for add
       A    R8,@PGMPTR        Skip it
       CLR  R8                Clear LSB of R8
       JMP  IFZ35
********************************************************************************
 
       TITL 'PARSES2'
 
*************************************************************
*                   'LET' statement handler                 *
* Assignments are done bye putting an entry on the stack    *
* for the destination variable and getting the source value *
* into the FAC. Multiple assignments are handled by the     *
* stacking the variable entrys and then looping for the     *
* assignments. Numeric assignments pose no problems,        *
* strings are more complicated. String assignments are done *
* by assigning the source string to the last variable       *
* specified in the list and changing the FAC entry so that  *
* the string assigned to the next-to-the-last variable      *
* comes from the permanent string belonging to the variable *
* just assigned.                                            *
* e.g.    A$,B$,C$="HELLO"                                  *
*                                                           *
*         C$-------"HELLO" (source string)                  *
*                                                           *
*         B$-------"HELLO" (copy from C$'s string)          *
*                                                           *
*         A$-------"HELLO" (copy from B$'s string)          *
*************************************************************
NLET   CLR  @PAD0             Counter for multiple assign's
NLET05 BL   @SYM              Get symbol table address
*-----------------------------------------------------------*
* The following code has been taken out for checking is     *
* inserted in SMB             5/22/81                       *
*      BL   @GETV             Get first byte of entry       *
*      DATA FAC               SYM left pointer in FAC       *
*      SLA  R1,1              Test if a UDF                 *
*      JLT  ERRMUV            Is a UDF - so error           *
*-----------------------------------------------------------*
       BL   @SMB              Get value space pointer
       BL   @VPUSH            Push s.t. pointer on stack
       INC  @PAD0             Count the variable
       CI   R8,EQZ*256        Is the token an '='?
       JEQ  NLET10            Yes, go into assignment loop
       CI   R8,COMMAZ*256     Must have a comma now
       JNE  ERR1CZ            Didn't - so error
       BL   @PGMCHR           Get next token
       JGT  NLET05            If legal symbol character
       JMP  ERR1CZ            If not - error
ERRMUV LI   R0,>0D03          MULTIPLY USED VARIABLE
       B    @ERR
NLET10 BL   @PGMCHR           Get next token
       BL   @PARSE            PARSE the value to assign
       BYTE TREMZ             Parse to the end of statement
STCOD2 BYTE >65               Wasted byte (STCODE copy)
* Loop for assignments
NLET15 BL   @ASSG             Assign the value to the symbol
       DEC  @PAD0             One less to assign, done?
       JEQ  LETCON            Yes, branch out
       CB   @FAC2,@STCOD2     String or numeric?
       JNE  NLET15            Numeric, just loop for more
       MOV  R6,@FAC4          Get pointer to new string
       MOV  @ARG,@FAC         Get pointer to last s.t. entry
       JMP  NLET15            Now loop to assign more
LETCON B    @EOL              Yes, continue the PARSE
ERR1CZ B    @ERR1C            For long distance jump
       DATA NONUD             (SPARE)             >80
       DATA NONUD             ELSE                >81
       DATA SMTSEP            ::                  >82
       DATA NUDND1            !                   >83
       DATA IF                IF                  >84
       DATA GO                GO                  >85
       DATA GOTO              GOTO                >86
       DATA GOSUB             GOSUB               >87
       DATA RETURN            RETURN              >88
       DATA NUDEND            DEF                 >89
       DATA NUDEND            DIM                 >8A
       DATA END               END                 >8B
       DATA NFOR              FOR                 >8C
       DATA NLET              LET                 >8D
       DATA >8002             BREAK               >8E
       DATA >8004             UNBREAK             >8F
       DATA >8006             TRACE               >90
       DATA >8008             UNTRACE             >91
       DATA >8016             INPUT               >92
       DATA NUDND1            DATA                >93
       DATA >8012             RESTORE             >94
       DATA >8014             RANDOMIZE           >95
       DATA NNEXT             NEXT                >96
       DATA >800A             READ                >97
       DATA STOP              STOP                >98
       DATA >8032             DELETE              >99
       DATA NUDND1            REM                 >9A
       DATA ON                ON                  >9B
       DATA >800C             PRINT               >9C
       DATA CALL              CALL                >9D
       DATA NUDEND            OPTION              >9E
       DATA >8018             OPEN                >9F
       DATA >801A             CLOSE               >A0
       DATA STOP              SUB                 >A1
       DATA >8034             DISPLAY             >A2
       DATA NUDND1            IMAGE               >A3
       DATA >8024             ACCEPT              >A4
       DATA NONUD             ERROR               >A5
       DATA NONUD             WARNING             >A6
       DATA SUBXIT            SUBEXIT             >A7
       DATA SUBXIT            SUBEND              >A8
       DATA >800E             RUN                 >A9
STMTTB DATA >8010             LINPUT              >AA
NTAB   DATA NLPR              LEFT PARENTHISIS    >B7
       DATA NONUD             CONCATENATE         >B8
       DATA NONUD             SPARE               >B9
       DATA NONUD             AND                 >BA
       DATA NONUD             OR                  >BB
       DATA NONUD             XOR                 >BC
       DATA O0NOT             NOT                 >BD
       DATA NONUD             =                   >BE
       DATA NONUD             <                   >BF
       DATA NONUD             >                   >C0
       DATA NPLUS             +                   >C1
       DATA NMINUS            -                   >C2
       DATA NONUD             *                   >C3
       DATA NONUD             /                   >C4
       DATA NONUD             ^                   >C5
       DATA NONUD             SPARE               >C6
       DATA NSTRCN            QUOTED STRING       >C7
       DATA NUMCON        UNQUOTED STRING/NUMERIC >C8
       DATA NONUD             LINE NUMBER         >C9
       DATA >8026             EOF                 >CA
       DATA NABS              ABS                 >CB
       DATA NATN              ATN                 >CC
       DATA NCOS              COS                 >CD
       DATA NEXP              EXP                 >CE
       DATA NINT              INT                 >CF
       DATA NLOG              LOG                 >D0
       DATA NSGN              SGN                 >D1
       DATA NSIN              SIN                 >D2
       DATA NSQR              SQR                 >D3
       DATA NTAN              TAN                 >D4
       DATA >8036             LEN                 >D5
       DATA >8038             CHRZ                >D6
       DATA >803A             RND                 >D7
       DATA >8030             SEGZ                >D8
       DATA >802A             POS                 >D9
       DATA >802C             VAL                 >DA
       DATA >802E             STR                 >DB
       DATA >8028             ASC                 >DC
       DATA >801C             PI                  >DD
       DATA >8000             REC                 >DE
       DATA >801E             MAX                 >DF
       DATA >8020             MIN                 >E0
       DATA >8022             RPTZ                >E1
NTABLN EQU  $-NTAB
LTAB   DATA CONC              &                   >B8
       DATA NOLED             SPARE               >B9
       DATA O0OR              OR                  >BA
       DATA O0AND             AND                 >BB
       DATA O0XOR             XOR                 >BC
       DATA NOLED             NOT                 >BD
       DATA EQUALS            =                   >BE
       DATA LESS              <                   >BF
       DATA GREATR            >                   >C0
       DATA PLUS              +                   >C1
       DATA MINUS             -                   >C2
       DATA TIMES             *                   >C3
       DATA DIVIDE            /                   >C4
       DATA LEXP              ^                   >C5
LTBLEN EQU  $-LTAB
*************************************************************
*                     Relational operators                  *
* Logical conparisons encode the type of comparison and use *
* common code to PARSE the expression and set the status    *
* bits.                                                     *
*                                                           *
* The types of legal comparisons are:                       *
*                             0 EQUAL                       *
*                             1 NOT EQUAL                   *
*                             2 LESS THAN                   *
*                             3 LESS OR EQUAL               *
*                             4 GREATER THAN                *
*                             5 GREATER THAN OR EQUAL       *
*                                                           *
* This code is saved on the subroutine stack                *
*************************************************************
LESS   LI   R2,2              LESS-THAN code for common rtn
       CI   R8,GTZ*256        Test for '>' token
       JNE  LT10              Jump if not
       DECT R2                Therefore, NOT-EQUAL code
       JMP  LT15              Jump to common
C4     EQU  $+2               Constant 4
GREATR LI   R2,4              GREATER-THEN code for common
LT10   CI   R8,EQZ*256        Test for '=' token
       JNE  LTST01            Jump if '>='
LT15   BL   @PGMCHR           Must be plain old '>' or '<'
       JMP  LEDLE             Jump to test
EQUALS SETO R2                Equal bit for common routine
LEDLE  INC  R2                Sets to zero
LTST01 INCT R9                Get room on stack for code
       MOV  R2,*R9            Save status matching code
       BL   @PSHPRS           Push 1st arg and PARSE the 2nd
       BYTE GTZ               Parse to a '>'
CBH69  BYTE >69               Used in RETURN routine
       MOV  *R9,R4            Get the type code from stack
       DECT R9                Reset subroutine stack pointer
       MOVB @LTSTAB(R4),R12   Get address bias to baranch to
       SRA  R12,8             Right justify
       BL   @ARGTST           Test for matching arguments
       JEQ  LTST20            Handle strings specially
       BL   @SCOMPB           Floating point comparison
LTST15 B    @LTSTXX(R12)      Interpret the status by code
LTSTXX EQU  $
LTSTGE JGT  LTRUE             Test if GREATER or EQUAL
LTSTEQ JEQ  LTRUE             Test if EQUAL
LFALSE CLR  R4                FALSE is a ZERO
       JMP  LTST90            Put it into FAC
LTSTNE JEQ  LFALSE            Test if NOT-EQUAL
LTRUE  LI   R4,>BFFF          TRUE is a minus-one
LTST90 LI   R3,FAC            Store result in FAC
       MOV  R4,*R3+           Exp & 1st byte of manitissa
       CLR  *R3+              ZERO the remaining digits
       CLR  *R3+              ZERO the remaining digits
       CLR  *R3+              ZERO the remaining digits
       JMP  LEDEND            Jump to end of LED routine
LTSTLE JEQ  LTRUE             Test LESS-THAN or EQUAL
LTSTLT JLT  LTRUE             Test LESS-THEN
       JMP  LFALSE            Jump to false
LTSTGT JGT  LTRUE             Test GREATER-THAN
       JMP  LFALSE            Jump to false
* Data table for offsets for types
LTSTAB BYTE LTSTEQ-LTSTXX     EQUAL               (0)
       BYTE LTSTNE-LTSTXX     NOT EQUAL           (1)
       BYTE LTSTLT-LTSTXX     LESS THEN           (2)
       BYTE LTSTLE-LTSTXX     LESS or EQUAL       (3)
       BYTE LTSTGT-LTSTXX     GREATER THEN        (4)
       BYTE LTSTGE-LTSTXX     GREATER or EQUAL    (5)
LTST20 MOV  @FAC4,R10         Pointer to string1
       MOVB @FAC7,R7          R7 = string2 length
       BL   @VPOP             Get LH arg back
       MOV  @FAC4,R4          Pointer to string2
       MOVB @FAC7,R6          R6 = string2 length
       MOVB R6,R5             R5 will contain shorter length
       CB   R6,R7             Compare the 2 lengths
       JLT  CSTR05            Jump if length2 < length1
       MOVB R7,R5             Swap if length1 > length2
CSTR05 SRL  R5,8              Shift for speed and test zero
       JEQ  CSTR20            If ZERO-set status with length
CSTR10 MOV  R10,R3            Current character location
       INC  R10               Increment pointer
       BL   @GETV1            Get from VDP
       MOVB R1,R0             And save for comparison
       MOV  R4,R3             Current char location in ARG
       INC  R4                Increment pointer
       BL   @GETV1            Get from VDP
       CB   R1,R0             Compare the characters
       JNE  LTST15            Return with status if <>
       DEC  R5                Otherwise, decrement counter
       JGT  CSTR10            And loop for each character
CSTR20 CB   R6,R7             Status set by length compare
       JMP  LTST15            Return to do test of status
* ARITHMETIC FUNCTIONS
PLUS   BL   @PSHPRS           Push left arg and PARSE right
       BYTE MINUSZ,0          Stop on a minus!!!!!!!!!!!!!!!
       LI   R2,SADD           Address of add routine
LEDEX  CLR  @FAC10            Clear error code
       BL   @ARGTST           Make sure both numerics
       JEQ  ARGT05            If strings, error
       BL   @SAVREG           Save registers
       BL   *R2               Do the operation
       BL   @SETREG           Restore registers
       MOVB @FAC10,R2         Test for overflow
       JNE  LEDERR            If overflow ->error
LEDEND B    @CONT             Continue the PARSE
LEDERR B    @WARNZZ           Overflow - issue warning
MINUS  BL   @PSHPRS           Push left arg and PARSE right
       BYTE MINUSZ,0          Parse to a minus
       LI   R2,SSUB           Address of subtract routine
       JMP  LEDEX             Common code for the operation
TIMES  BL   @PSHPRS           Push left arg and PARSE right
       BYTE DIVIZ,0           Parse to a divide!!!!!!!!!!!!!
       LI   R2,SMULT          Address of multiply routine
       JMP  LEDEX             Common code for the operation
DIVIDE BL   @PSHPRS           Push left arg and PARSE right
       BYTE DIVIZ,0           Parse to a divide
       LI   R2,SDIV           Address of divide routine
       JMP  LEDEX             Common code for the operation
*************************************************************
* Test arguments on both the stack and in the FAC           *
*      Both must be of the same type                        *
*  CALL:                                                    *
*      BL   @ARGTST                                         *
*      JEQ                    If string                     *
*      JNE                    If numeric                    *
*************************************************************
ARGTST MOV  @VSPTR,R6         Get stack pointer
       INCT R6
       MOVB @R6LB,*R15        Load 2nd byte of stack address
       NOP                    Kill some time
       MOVB R6,*R15           Load 1st byte of stack address
       NOP                    Kill some time
       CB   @XVDPRD,@CBH65    String in operand 1?
       JNE  ARGT10            No, numeric
       CB   @FAC2,@CBH65      Yes, is other the same?
       JEQ  ARGT20            Yes, do string comparison
ARGT05 B    @ERRT             Data types don't match
NUMCHK
ARGT10 CB   @FAC2,@CBH65      2nd operand can't be string
       JEQ  ARGT05            If so, error
ARGT20 RT                     Ok, so return with status
* VPUSH followed by a PARSE
PSHPRS INCT R9                Get room on stack
       CI   R9,STKEND         Stack full?
       JH   VPSH27            Yes, error
       MOV  R11,*R9           Save return on stack
       LI   R11,P05           Optimize for the parse
* Stack VPUSH routine
VPUSH  LI   R0,8              Pushing 8 byte entries
       A    R0,@VSPTR         Update the pointer
       MOV  @VSPTR,R1         Now get the new pointer
       MOVB @R1LB,*R15        Write new address to VDP chip
       ORI  R1,WRVDP          Enable the write
       MOVB R1,*R15           Write 1st byte of address
       LI   R1,FAC            Source is FAC
VPSH15 MOVB *R1+,@XVDPWD      Move a byte
       DEC  R0                Decrement the count, done?
       JGT  VPSH15            No, more to move
       MOV  R11,R0            Save the return address
       CB   @FAC2,@CBH65      Pushing a string entry?
       JNE  VPSH20            No, so done
       MOV  @VSPTR,R6         Entry on stack
       AI   R6,4              Pointer to the string is here
       MOV  @FAC,R1           Get the string's owner
       CI   R1,>001C          Is it a tempory string?
       JNE  VPSH20            No, so done
VPSH19 MOV  @FAC4,R1          Get the address of the string
       JEQ  VPSH20            If null string, nothing to do
       BL   @STVDP3           Set the backpointer
VPSH20 MOV  @VSPTR,R1         Check for buffer-zone
C16    EQU  $+2
       AI   R1,16             Correct by 16
       C    R1,@STREND        At least 16 bytes between stack
*                              and string space?
       JLE  VPOP18            Yes, so ok
       INCT R9                No, save return address
       MOV  R0,*R9             on stack
       BL   @COMPCT           Do the garbage collection
       MOV  *R9,R0            Restore return address
       DECT R9                Fix subroutine stack pointer
       MOV  @VSPTR,R1         Get value stack pointer
       AI   R1,16             Buffer zone
       C    R1,@STREND        At least 16 bytes now?
       JLE  VPOP18            Yes, so ok
VPSH23 LI   R0,ERROM          No, so MEMORY FULL error
VPSH25 BL   @SETREG           In case of GPL call
       B    @ERR
VPSH27 B    @ERRSO            STACK OVERFLOW
* Stack VPOP routine
VPOP   LI   R2,FAC            Destination in FAC
       MOV  @VSPTR,R1         Get stack pointer
       C    R1,@STVSPT        Check for stack underflow
       JLE  VPOP20            Yes, error
       MOVB @R1LB,*R15        Write 2nd byte of address
       LI   R0,8              Popping 8 bytes
       MOVB R1,*R15           Write 1st byte of address
       S    R0,@VSPTR         Adjust stack pointer
VPOP10 MOVB @XVDPRD,*R2+      Move a byte
       DEC  R0                Decrement the counter, done?
       JGT  VPOP10            No, finish the work
       MOV  R11,R0            Save return address
       CB   @FAC2,@CBH65      Pop a string?
       JNE  VPOP18            No, so done
       CLR  R6                For backpointer clear
       MOV  @FAC,R3           Get string owner
       CI   R3,>001C          Pop a temporary?
       JEQ  VPSH19            Yes, must free it
       BL   @GET1             No, get new pointer from s.t.
       MOV  R1,@FAC4          Set new pointer to string
VPOP18 B    *R0               And return
VPOP20 LI   R0,ERREX          * SYNTAX ERROR
       JMP  VPSH25
* The returned status reflects the character
* RAMFLG = >00   | No ERAM or imperative statements
*          >FF   | With ERAM and a program is being run
PGMCHR MOVB @RAMFLG,R8        Test ERAM flag
       JNE  PGMC10            ERAM and a program is being run
* Next label is for entry from SUBPROG.
PGMSUB MOVB @PGMPT1,*R15      Write 2nd byte of address
       LI   R10,XVDPRD        Read data address
       MOVB @PGMPTR,*R15      Write 1st byte of address
       INC  @PGMPTR           Increment the perm pointer
       MOVB *R10,R8           Read the character
       RT                     And return
PGMC10 MOV  @PGMPTR,R10
       INC  @PGMPTR
       MOVB *R10+,R8          Write 2nd byte of a address
       RT
********************************************************************************
       AORG >6C9A
       TITL 'GETPUTS'

* (VDP to VDP) or (RAM to RAM) 
* GET,GET1          : Get two bytes of data from VDP
*                   : R3 : address in VDP
*                   : R1 : where the one byte data stored
* PUT1              : Put two bytes of data into VDP
*                   : R4 : address on VDP
*                   : R1 : data
* GETG,GETG2        : Get two bytes of data from ERAM
*                   : R3 : address on ERAM
*                   : R1 : where the two byte data stored
* PUTG2             : Put two bytes of data into ERAM
*                   : R4 : address on ERAM
*                   : R1 : data
* PUTVG1            : Put one byte of data into ERAM
*                   : R4 : address in ERAM
*                   : R1 : data
 
* Get two bytes from RAM(R3) into R1
GET    MOV  *R11+,R3
       MOV  *R3,R3
GET1   MOVB @R3LB,*R15
       MOVB R3,*R15
       NOP
       MOVB @XVDPRD,R1
       MOVB @XVDPRD,@R1LB
       RT
* Put two bytes from R1 to RAM(R4)
PUT1   MOVB @R4LB,*R15
       ORI  R4,WRVDP
       MOVB R4,*R15
       NOP
       MOVB R1,@XVDPWD
       MOVB @R1LB,@XVDPWD
       RT
* Get two bytes from ERAM(R3) to R1
GETG   MOV  *R11+,R3
       MOV  *R3,R3
GETG2  EQU  $
       MOVB *R3+,R1
       MOVB *R3,@R1LB
       DEC  R3
       RT
* Put two bytes from R1 to ERAM(R4)
PUTG2  EQU  $
       MOVB R1,*R4+
       MOVB @R1LB,*R4
       DEC  R4                Preserve R4
       RT
********************************************************************************
       AORG >6CE2
       TITL 'NUD359'
 
LEXP   CB   @FAC2,@CBH63      Must have a numeric
       JH   ERRSNM            Don't, so error
       BL   @PSHPRS           Push 1st and parse 2nd
       BYTE EXPONZ,0          Up to another wxpon or less
       BL   @STKCHK           Make sure room on stack
       LI   R2,PWRZZ          Address of power routine
       JMP  COMM05            Jump into common routine
* ABS
NABS   CI   R8,LPARZ*256      Must have a left parenthesis
       JNE  SYNERR            If not, error
       BL   @PARSE            Parse the argument
       BYTE ABSZ              Up to another ABS
CBH63  BYTE >63               Use the wasted byte
       CB   @FAC2,@CBH63      Must have numeric arg
       JH   ERRSNM            If not, error
       ABS  @FAC              Take the absolute value
BCONT  B    @CONT             And continue
* ATN
NATN   LI   R2,ATNZZ          Load up arctan address
       JMP  COMMON            Jump into common rountine
* COS
NCOS   LI   R2,COSZZ          Load up cosine address
       JMP  COMMON            Jump into common routine
* EXP
NEXP   LI   R2,EXPZZ          Load up exponential address
       JMP  COMMON            Jump into common routine
* INT
NINT   LI   R2,GRINT          Load up greatest integer address
       JMP  COMMON            Jump into common routine
* LOG
NLOG   LI   R2,LOGZZ          Load up logarithm code
       JMP  COMMON            Jump to common routine
* SGN
NSGN   CI   R8,LPARZ*256      Must have left parenthesis
       JNE  SYNERR            If not, error
       BL   @PARSE            Parse the argument
       BYTE SGNZ,0            Up to another SGN
       CB   @FAC2,@CBH63      Must have a numeric arg
       JH   ERRSNM            If not, error
       LI   R4,>4001          Floating point one
       MOV  @FAC,R0           Check status
       JEQ  BCONT             If 0, return 0
       JGT  BLTST9            If positive, return +1
       B    @LTRUE            If negative, return -1
BLTST9 B    @LTST90           Sets up the FAC w/R4 and 0s
ERRSNM B    @ERRT             STRING-NUMBER MISMATCH
SYNERR B    @ERRONE           SYNTAX ERROR
* SIN
NSIN   LI   R2,SINZZ          Load up sine address
       JMP  COMMON            Jump into common routine
* SQR
NSQR   LI   R2,SQRZZ          Load up square-root address
       JMP  COMMON            Jump into common routine
* TAN
NTAN   LI   R2,TANZZ          Load up tangent address
COMMON BL   @STKCHK           Make sure room on stacks
       CI   R8,LPARZ*256      Must have left parenthesis
       JNE  SYNERR            If not, error
       INCT R9                Get space on subroutine stack
       MOV  R2,*R9            Put address of routine on stack
       BL   @PARSE            Parse the argument
       BYTE >FF,0             To end of the arg
       MOV  *R9,R2            Get address of function back
       DECT  R9               Decrement subroutine stack
COMM05 CB   @FAC2,@CBH63      Must have a numeric arg
       JH   ERRSNM            If not, error
       CLR  @FAC10            Assume no error or warning
       BL   @SAVREG           Save Basic registers
       MOV  R2,@PAGE2         Select page 2
       BL   *R2               Evaluate the function
       MOV  R2,@PAGE1         Reselect Page 1
       BL   @SETREG           Set registers up again
       MOVB @FAC10,R0         Check for error or warning
       JEQ  BCONT             If not error, continue
       SRL  R0,9              Check for warning
       JEQ  PWARN             Warning, issue it
       LI   R0,>0803          BAD ARGUMENT code
       B    @ERR
PWARN  B    @WARNZZ           Issue the warning message
STKCHK CI   R9,STND12         Enough room on the subr stack?
       JH   BSO               No, memory full error
       MOV  @VSPTR,R0         Get the value stack pointer
       AI   R0,48             Buffer-zone of 48 bytes
       C    R0,@STREND        Room between stack & strings
       JL   STKRTN            Yes, return
       INCT R9                Get space on subr stack
       MOV  R11,*R9+          Save return address
       MOV  R2,*R9+           Save COMMON function code
       MOV  R0,*R9            Save v-stack pointer+48
       BL   @COMPCT           Do a garbage collection
       C    *R9,@STREND       Enough space now?
       JHE  BMF               No, MEMORY FULL error
       DECT R9                Decrement stack pointer
       MOV  *R9,R2            Restore COMMON function code
       DECT R9                Decrement stack pointer
RETRN  MOV *R9,R11            Restore return address
       DECT R9                Decrement stack pointer
STKRTN RT
BMF    B    @VPSH23           * MEMORY FULL
BSO    B    @ERRSO            * STACK OVERFLOW
*************************************************************
* LED routine for AND, OR, NOT, and XOR                     *
*************************************************************
O0AND  BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE ANDZ,0            Stop on AND or less
       BL   @CONVRT           Convert both to integers
       INV  @FAC              Complement L.H.
       SZC  @FAC,@ARG         Perform the AND
O0AND1 MOV  @ARG,@FAC         Put back in FAC
O0AND2 BL   @CIF              Convert back to floating
       B    @CONT             Continue
O0OR   BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE ORZ,0             Stop on OR or less
       BL   @CONVRT           Convert both to integers
       SOC  @FAC,@ARG         Perform the OR
       JMP  O0AND1            Convert to floating and done
O0NOT  BL   @PARSE            Parse the arg
       BYTE NOTZ,0            Stop on NOT or less
       CB   @FAC2,@CBH63      Get a numeric back?
       JH   ERRSN1            No, error
       CLR  @FAC10            Clear for CFI
       BL   @CFI              Convert to Integer
       MOVB @FAC10,R0         Check for an error
       JNE  SYNERR            Error
       INV  @FAC              Perform the NOT
       JMP  O0AND2            Convert to floating and done
O0XOR  BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE XORZ,0            Stop on XOR or less
       BL   @CONVRT           Convert both to integer
       MOV  @ARG,R0           Get R.H. into register
       XOR  @FAC,R0           Do the XOR
       MOV  R0,@FAC           Put result back in FAC
       JMP  O0AND2            Convert and continue
*************************************************************
* NUD for left parenthesis                                  *
*************************************************************
NLPR   CI   R8,RPARZ*256      Have a right paren already?
       JEQ  ERRSY1            If so, syntax error
       BL   @PARSE            Parse inside the parenthesises
       BYTE LPARZ,0           Up to left parenthesis or less
       CI   R8,RPARZ*256      Have a right parenthesis now?
       JNE  ERRSY1            No, so error
       BL   @PGMCHR           Get next token
BCON1  B    @CONT             And continue
*************************************************************
* NUD for unary minus                                       *
*************************************************************
NMINUS BL   @PARSE            Parse the expression
       BYTE MINUSZ,0          Up to another minus
       NEG  @FAC              Make it negative
NMIN10 CB   @FAC2,@CBH63      Must have a numeric
       JH   ERRSN1            If not, error
       JMP  BCON1             Continue
*************************************************************
* NUD for unary plus                                        *
*************************************************************
NPLUS  BL   @PARSE            Parse the expression
       BYTE PLUSZ,0
       JMP  NMIN10            Use common code
*************************************************************
* CONVRT - Takes two arguments, 1 form FAC and 1 from the   *
*          top of the stack and converts them to integer    *
*          from floating point, issuing appropriate errors  *
*************************************************************
CONVRT INCT R9
       MOV  R11,*R9           SAVE RTN ADDRESS
       BL   @ARGTST           ARGS MUST BE SAME TYPE
       JEQ  ERRSN1            AND NON-STRING
       CLR  @FAC10            FOR CFI ERROR CODE
       BL   @CFI              CONVERT R.H. ARG
       MOVB @FAC10,R0         ANY ERROR OR WARNING?
       JNE  ERRBV             YES
       MOV  @FAC,@ARG         MOVE TO GET L.H. ARG
       BL   @VPOP             GET L.H. BACK
       BL   @CFI              CONVERT L.H.
       MOVB @FAC10,R0         ANY ERROR OR WARNING?
       JEQ  RETRN             No, get rtn off stack and rtn
*                             Yes, issue error
ERRBV  B    @GOTO90           BAD VALUE
ERRSN1 B    @ERRT             STRING NUMBER MISMATCH
ERRSY1 B    @ERRONE           SYNTAX ERROR
********************************************************************************
       AORG >6ED6
       TITL 'SPEEDS'
 
 
BSYNCH B    @SYNCHK
BERSYN B    @ERRSYN
BERSNM B    @ERRT
SPEED  MOVB *R13,R0           Read XML code
       SRL  R0,8              Shift for word value
       JEQ  BSYNCH            0 is index for SYNCHK
       DEC  R0                Not SYNCHK, check further
       JEQ  PARCOM            1 is index for PARCOM
       DEC  R0                Not PARCOM, check further
       JEQ  RANGE             2 is index for RANGE
* All otheres assumed to be SEETWO
*************************************************************
* Find the line specified by the number in FAC              *
* Searches the table from low address (high number) to      *
*  high address (low number).                               *
*************************************************************
SEETWO LI   R10,SET           Assume number will be found
       LI   R7,GET1           Assume reading from the VDP
       MOVB @RAMTOP,R0        But correct
       JEQ  SEETW2               If
       LI   R7,GETG2              ERAM is present
SEETW2 MOV  @ENLN,R3          Get point to start from
       AI   R3,-3             Get into table
SEETW4 BL   *R7               Read the number from table
       ANDI R1,>7FFF          Throw away possible breakpoint
       C    R1,@FAC           Match the number needed?
       JEQ  SEETW8            Yes, return with condition set
       JH   SEETW6            No, and also passed it =>return
       AI   R3,-4             No, but sitll might be there
       C    R3,@STLN          Reached end of table?
       JHE  SEETW4            No, so check further
       MOV  @STLN,R3          End of table, default to last
SEETW6 LI   R10,RESET         Indicate not found
SEETW8 MOV  R3,@EXTRAM        Put pointer in for GPL
       B    *R10              Return with condition
RANGE  MOV  R11,R12           Save return address
       CB   @FAC2,@CBH63      Have a numeric
       JH   BERSNM            Otherwise string number mismatch
       CLR  @FAC10            Assume no conversion error
       BL   @CFI              Convert from float to integer
       MOVB @FAC10,R0         Get an error?
       JNE  RANERR            Yes, indicate it
       MOVB *R13,R0           Read lower limit
       SRL  R0,8              Shift for word compare
       MOVB *R13,R1           Read 1st byte of upper limit
       SWPB R1                Kill time
       MOVB *R13,R1           Read 2nd byte of upper limit
       SWPB R1                Restore upper limit
       MOV  @FAC,R2           Get the value
       JLT  RANERR            If negative, error
       C    R2,R0             Less then low limit?
       JLT  RANERR            Yes, error
       C    R2,R1             Greater then limit?
       JH   RANERR            Yes, error
       B    *R12              All ok, so return
RANERR BL   @SETREG           Set up registers for error
       B    @GOTO90           * BAD VALUE
* Make sure at a left parenthesis
LPAR   CB   @CHAT,@LBLPZ      At a left parenthesis
       JNE  BERSYN            No, syntax error
* Parse up to a comma and insure at a comma
PARCOM BL   @PUTSTK           Save GROM address
       BL   @SETREG           Set up R8/R9
       BL   @PARSE            Parse the next item
       BYTE COMMAZ            Up to a comma
LBLPZ  BYTE LPARZ
       CI   R8,COMMAZ*256     End on a comma?
       JNE  BERSYN            No, syntax error
       BL   @PGMCHR           Yes, get character after it
       BL   @SAVREG           Save R8/R9 for GPL
       BL   @GETSTK           Restore GROM address
       B    @RESET            Return to GPL reset
********************************************************************************
       AORG >6F98
       TITL 'MVUPS'

* (RAM to RAM) 
* WITH ERAM    : Move the contents in ERAM FROM a higher
*                 address to a lower address
*                ARG    : byte count
*                VAR9   : source address
*                VAR0   : destination address
 
MVUP   MOV  @ARG,R1           Get byte count
       MOV  @VAR9,R3          Get source
       MOV  @VAR0,R5          Get destination
MVUP05 MOVB *R3+,*R5+         Move a byte
       DEC  R1                Decrement the counter
       JNE  MVUP05            Loop if more to move
       RT
********************************************************************************
       AORG >6FAC
       TITL 'GETNBS'
 
* Get a non-space character
GETNB  MOV  R11,R0            Save return address
GETNB1 BL   @GETCHR           Get next character
       CI   R1,' '*256        Space character?
       JEQ  GETNB1            Yes, get next character
       B    *R0               No, return character condition
* Get the next character
GETCHR C    @VARW,@VARA       End of line?
       JH   GETCH2            Yes, return condition
       MOVB @VARW1,*R15       No, write LSB of VDP address
       LI   R1,>A000          Negative screen offset (->60)
       MOVB @VARW,*R15        Write MSB of VDP address
       INC  @VARW             Increment read-from pointer
       AB   @XVDPRD,R1        Read and remove screen offset
       CI   R1,>1F00          Read an edge character?
       JEQ  GETCHR            Yes, skip it
       RT                     Return
GETCH2 CLR  R1                Indicate end of line
       RT                     Return
*-----------------------------------------------------------*
* Remove this routine from CRUNCH because CRUNCH is running *
* out of space                5/11/81                       *
*-----------------------------------------------------------*
*      Calculate and put length of string/number into       *
*      length byte                                          *
LENGTH MOV  R11,R3            Save retun address
       MOV  @RAMPTR,R0        Save current crunch pointer
       MOV  R0,R8             Put into r8 for PUTCHR below
       S    R5,R8             Calculate length of string
       DEC  R8                RAMPTR is post-incremented
       MOV  R5,@RAMPTR        Address of length byte
       BL   @PUTCHR           Put the length in
       MOV  R0,@RAMPTR        Restore crunch pointer
       B    *R3               And return
* FILL IN BYTES OF MODULE WITH COPY OF ORIGINAL?
       DATA >0000
       DATA >EF71             ?????
********************************************************************************
 
       AORG >7000
       TITL 'CNS359'
 
*
*      CONVERT THE NUMBER IN THE FAC TO A STRING
* CALL  : FAC NUMBER
*         R0  0 for free format(R1 & R2 are ignored)
*             Bit 0 on for fixed format
*             Bit 1 on for an explicit sign
*             Bit 2 on to output the sign of a positive
*             NO. as a plus sign ('+') instead of a space
*              (bit 1 must also be on)
*             Bit 3 on for E-notation output
*             Bit 4 also on for extended E-notation
*         R1 and R2 specify the field size.
*         R1  Number of places in the field to the left of
*              the decimal point including an explicit sign
*              and excluding the dicimal point.
*         R2  Number of places in the field to the right of
*              the decimal point.
*         R1 and R2 exclude ths 4 positions for the exponent
*              if bit 3 is on.
* ERRORS:   The field has more than 14 significant digits if
*            the number is too big to fit in the field. The
*            field is filled with asterisks.
*           The original contents of the FAC are lost.
 
 
LWCNP  DATA >0004
LWCNE  DATA >0008
LWCNF  DATA >0010
* Integer power of ten table
CNSITT DATA 10000
       DATA 1000
LW100  BYTE 0
LB100  BYTE 100
LW10   BYTE 0
LB10   BYTE 10
       DATA 1
LBSPC  BYTE ' '
LBAST  BYTE '*'
LBPER  BYTE '.'
LBE    BYTE 'E'
LBZER  BYTE '0'
       EVEN
 
CNS    MOV  R11,R10           In ROLOUT: use R10 to return
       BL   @ROLOUT
       INCT R9
       MOV  R13,*R9
       LI   R6,FAC11          Optimize for space and speed
       MOVB *R6+,R0           @FAC11=0 if free format output
       SRL  R0,8              Put in LSB
       MOVB *R6+,R1           @FAC12 places to left of dec
       SRL  R1,8              Put in LSB
       MOVB *R6+,R2           @FAC13 places to right of dec
       SRL  R2,8              Put in LSB
       MOVB @LBSPC,*R6+       Put extra space at beginning
*                              for CNSCHK
       LI   R3,'-'*256        Assume number is negative
       ABS  @FAC              Is number negative?
       JLT  CNS01             Yes, its sign is known
       LI   R3,' '*256        No, assume a space will be used
       CZC  @LWCNP,R0         Do positive numbers get a plus
*                              sign?
       JEQ  CNS01             No, use a space
       LI   R3,'+'*256        Yes, get a plus sign
CNS01  MOVB R3,*R6+           Put sign in buffer
       MOV  R0,@WSM           Is free fomat output specified
       JNE  CNSX              No, use fix format output
* FREE FORMAT FLOATING OUTPUT
       MOV  @FAC,R4           Is it 0?
       JNE  CNSF1             No
       DEC  R6
       LI   R4,' 0'           Yes, convert to a '0' and quit
       MOVB R4,*R6+
       MOVB @R4LB,*R6+
       CLR  R4                Put 0 at end of string
       MOVB R4,*R6
       LI   R4,>5902          Put the beginning of string
*                              in FAC11, LENGTH in FAC12
*                              FAC15=59, LENGTH=2
       MOVB R4,@FAC11
       MOVB @R4LB,@FAC12
       B    @ROLIN            RT in ROLIN
CNSF1  BL   @CNSTEN           Get base ten exponent, is NO.
*                              less then one?
       JLT  CNSF02            Yes, it can't be printed as an
*                              integer
       CI   R13,9             No, is number to big to print
       JGT  CNSF02            Yes, round NO. for E-notataion
*                              output
       MOVB @FAC,@R0LB        No, check if the number is an
*                              integer, get exponent, high
*                              byte is still zero
       AI   R0,PAD0           R0=PAD+FAC+2-64
       AI   R0,>C             Get pointer to first
*                              fractional byte
CNSF01 CLR  R1
       MOVB *R0+,R1           Is next byte of fraction zero?
       JNE  CNSF02            No, print NO. in fixed point
*                              format
       CI   R0,FAC8           Yes, reached end of number?
       JL   CNSF01            No, continue looking at
*                              fractional bytes
       CLR  R10               Yes, number is an integer,
*                              set integer flag
       JMP  CNSF05            Go print the number,
*                              no rounding is necessary
CNSF02 LI   R1,5              Assume rounding for E-notation
       CI   R13,9             Is NO. too big for fixed point
*                              output?
       JGT  CNSF04            Yes, round for E-notataion
       CI   R13,-4            No, is number to small for
*                              fixed point output?
       JLT  CNSF04            Yes, round for E-notation output
       C    *R1+,*R1+         Force R1 to =9
       CI   R13,-2            No, will NO. be printed with
*                              maximum number for fixed
*                              format significant digits?
       JGT  CNSF04            Yes, round accordingly
       INC  R1                No, round number for maximum
*                              significant digits (R1=10)
       A    R13,R1            That can be printed for this
*                              number
CNSF04 BL   @CNSRND           Round NO. accordingly,
*                              rounding can change the
*                              exponent and so the print
*                              format to be used
       SETO R10               Set non-integer flag
CNSF05 CI   R13,9             Decide which print format to
       JGT  CNSG               use, too big for fixed format
       CI   R13,-6            Use E-notation number in range
*                              for max fixed point digits?
       JGT  CNSF08            Yes, use fixed format output
       CI   R13,-10           No, NO. too small for fixed
*                              format?
       JLT  CNSG              Yes, use E-notation ouput
*                             No, the NO. of significant
*                              digits will determine fixed
*                              format ouput or not
       LI   R0,FAC8           Get pointer to last byte
*                              of FAC1
       CLR  R1                Clear low byte of least
*                              significant byte regester
       LI   R3,4              4=15-11 Get NO. of
*                              digits+2-exponent scale factor
       A    R7,R3             Take into acccount a leading
*                              zero in FAC1
CNSF06 DECT R3                Decrement sig digit count for
*                              last zero byte
       DEC  R0                Point to next higher byte of FAC
       MOVB *R0,R1            Is next byte all zero?
       JEQ  CNSF06            Yes, continue looking for LSB
*                             No, found the LSB, this loop
*                              will always terminate since
*                              FAC1 never 0
       CLR  R0                Take into account if the LSB is
*                              divisible by ten
       SWPB R1                Is divisible by ten
       DIV  @LW10,R0          Divide LSB by ten
       MOV  R1,R1             Is the remainder zero?
       JNE  CNSF07            No, significant digit count is
*                              correct
       DEC  R3                Yes, LSB has a trailing zero
CNSF07 C    R3,R13            Too many significant digits for
*                              fixed format?
       JGT  CNSG              Yes, use E-notation
* FREE FORMAT FIXED POINT AND INTEGER FLOATING OUTPUT
CNSF08 S    R7,R13            Make the exponent even
       JLT  CNSF12             are there digits to left of
*                              decimal point? Jump if not
*                             Yes, print decimal point with
*                              the number
       LI   R4,3              Figure out where the decimal
*                              point goes in
       A    R13,R4            The number's digits
CNSF10 LI   R3,12             Convert the maximum number of
*                              decimal digits, leading and
*                              trailing zeros are suppressed
*                              later
       BL   @CNSDIG           Convert number to decimal digits
       BL   @CNSUTR           Remove trailing zeros
       JMP  CNSG01            Suppress leading zeros and
CNSF12 SETO R0                 figure out how many zeros
*                              there are
       S    R13,R0            Between decimal point and
*                              first digit
       BL   @CNSPER           Put decimal point and zeros
*                              in buffer
       CLR  R4                Don't print another decimal
*                              point in the number
       JMP  CNSF10            Convert NO. to decimal digits
*                              finish up
* FREE FORMAT E-NOTATION FLOATING OUTPUT
CNSG   LI   R3,8              Get maximum NO. of digits to
*                              print
       LI   R4,3              Figure out where to put decimal
*                              point
       S    R7,R4             Take a leading zero into account
       BL   @CNSDIG           Convert NO. to decimal digits
       BL   @CNSUTR           Suppress trailing zeros
       BL   @CNSEXP           Put exponent into buffer
CNSG01 B    @CNSMLS           Suppress leading zeros and
*                              finish up
* FIXED FORMAT OUTPUT
* WSM       R0 format specifications
* WSM2      R1 format specifications
* WSM4      R2 format specifications
* WSM6      Number of digit places to left of decimal point
* WSM8      Number of digit places to right of decimal point
CNSX   MOV  R1,@WSM2          Save R1 format specifications
       MOV  R2,@WSM4          Save R2 format specifications
       CZC  @LWCNE,R0         Is E-notation to be used?
       JNE  CNSX01            Yes, remove place for sign from
*                              left of DP count
       CI   R3,'-'*256        No, is number negative?
       JEQ  CNSX01            Yes, remove sign from digit count
       CZC  @LWCNS,R0         No, is explicit sign specified?
       JEQ  CNSX02            No, digit count correct as is
CNSX01 DEC  R1                Remove place for sign form left
*                              of DP digit count
       JGT  CNSX02            Any places for digits left?
       CI   R3,'-'*256        No, is number negative?
       JEQ  CNSX02            Yes, can't do anything about it
       CLR  R1                No, see if NO. digits to left
*                              of DP will work
CNSX02 MOV  R1,@WSM6          Save number of digits to left
*                              of DP
       JLT  CNSJ04            Field to small if there are
*                              negative places
       DEC  R2                Take decimal point from right
*                              of DP count
       JGT  CNSX03            Are there still places left?
       CLR  R2                No, don't print any digits there
CNSX03 MOV  R2,@WSM8          Save right of DP digit count
       MOV  R1,R4             Compute how many significant
*                              digits are to be printed
       A    R2,R4
       JEQ  CNSJ04            None, error
*   FALL INTO NO-TO FIXED FORMAT FLOATING OUTPUT
*
* Fixed format floating output
       BL   @CNSTEN           Get base ten exponent of the FAC
       CZC  @LWCNE,R0         Is E-format call for?
       JNE  CNSK              Yes, go do it
* FIXED FORMAT FLOATING F-FORMAT OUTPUT
       C    R13,@WSM6         Are there too many digits in
*                              the number for the field size?
       JLT  CNSJ00            No, ok
CNSJ04 B    @CNSAST
CNSJ00 MOV  R13,R1            No, get exponent
       A    R2,R1             Compute where rounding should
*                              take place
       CI   R1,-1             Is the NO. too small for the
*                              field?
       JLT  CNSVZR            Yes, result is zero
       BL   @CNSRND           No, round NO. to the proper
*                              place
       S    R7,R13            Convert exponent to an even
*                              number
       JLT  CNSJ01            Any digits to left of DP?
       SETO R0                Yes, compute how many zero are
*                              needed before the number to
*                              fill out the field to the
*                              proper size
       A    @WSM6,R0
       S    R13,R0
       BL   @CNSZER           Put zeros in the buffer if
*                              needed
       LI   R3,3              Compute the number of digits to
*                              convert
       A    R13,R3            Take into account the number's
*                              size
       MOV  R3,R4             Yes, compute where the DP will
*                              go
       A    @WSM8,R3          Take into account the NO. of
*                              decimal palces
       JMP  CNSJ02            Go convert the number
CNSJ01 MOV  @WSM8,R3          Number is less then one
       JEQ  CNSVZR            NO. decimal places, print zero
       MOV  @WSM6,R0          Get size of field to right of DP
       INC  R0                Add one for CNSZER
       BL   @CNSZER           Fill field with zeros, they
*                              will be suppressed
       MOV  R6,R12            Save pointer to DP
       SETO R0                Compute NO. of zeros after DP
       S    R13,R0            And before the number
       BL   @CNSPER           Put them and a DP into the
*                              buffer
       A    R13,R3            Figure out how many digits to
*                              convert
       AI   R3,3              Scale accordingly
       CLR  R4                Do not print a decimal point
CNSJ02 BL   @CNSDIG           Convert the NO. decimal digits
       MOV  @WSM4,R0          Is a decimal point required?
       JNE  CNSJ03            Yes, it is already there
       MOVB R0,*R12           No, overwrite it with zero
CNSJ03 B    @CNSCHK           Go finish up
* FIXED FORMAT OUTPUT OF ZERO
CNSVZR MOV  @WSM6,R0          Get left of DP field size
       INC  R0                Adjust it for CNSZER
       BL   @CNSZER           Put in correct amount of zeros
       MOV  R6,R12            Save pointer to where DP will
*                              go
       MOV  @WSM4,R0          Is a DP called for?
       JEQ  CNSV01            No, don't print one
       BL   @CNSPER           Yes, print it & some zeros
*                              after if needed
CNSV01 MOV  @WSM,R0           Get R0 format specification
       CZC  @LWCNE,R0         Is E-format called for?
       JEQ  CNSJ03            No, finish up
       JMP  CNSK01            Yes, print an exponent
* FIXED FORMAT FLOATING E-FORMAT OUTPUT
CNSK   MOV  @FAC,R5           Is it zero?
       JNE  CNSK1             No, go to CNSK1
       CLR  R7                Yes, do it differently:
       CLR  R13                R7,R13 set to be 0 and jump
       JMP  CNSVZR             to CNSVZR
CNSK1  A    R2,R1             Get total number of digits to
*                              print
       DEC  R1                Compute where rounding should
*                              occur
       BL   @CNSRND           Round number for E-format output
       MOV  @WSM6,R3          Get number of digits to left
*                             of DP
       S    R3,R13            Compute what exponent should be
*                              printed
       INC  R13               Scale properly
       S    R7,R3             Consider only even exponents
       INCT R3                Compute number of digits to
*                              print & where to put the
*                              decimal point
       MOV  R3,R4
       A    @WSM8,R3          Take digits to right of DP
*                              into account
       BL   @CNSDIG           Convert number to decimal digits
       MOV  @WSM4,R0          Is a decimal point needed?
       JNE  CNSK01            Yes, leave it alone
       DEC  R6                No, overwrite it with exponent
CNSK01 BL   @CNSEXP           Put exponent into the buffer
       JMP  CNSJ03            Finish up and zero suppress
* ROUND THE NUMBER IN FAC
* CALL    R1     Number of decimal digits to right of most
*                 significant digit to round to
*         R13    Base ten exponent
*         R7     0 if R13 is even, 1 if R13 is odd
*         BL     CNSRND
*         STATUS Bits reflect exponent
*         R13    Base ten exponent of rounded result
*         R7     0 if R13 is even, 1 if R13 is odd
*      DESTORYS: R0-R3,R12,R10
*      ASSUMES R12 GE -1
CNSRND INCT R9                Save return address
       MOV  R11,*R9
       S    R1,R13            Compute base ten exponent of
*                              place to round to
       S    R7,R1             Take position of first digit
*                              into account
       SRA  R1,1              Compute address in FAC of byte
*                             to be looked at
       INCT R1                To determine if rounding occurs
       LI   R3,49*256         Assume 50 will be added to that
*                              byte
       SRA  R13,1             Rounding to an even ten's place?
       JNC  CNSR01            Yes, assumption was correct
       LI   R3,4*256          No,add 5 to byte to be looked at
CNSR01 CI   R1,7              Is all of FAC significant?
       JGT  CNSR05            Yes, no need to round
       LI   R7,FAC            No, get pointer into FAC
       CLR  R12               The number is positive
       MOVB *R7,R13           Get current FAC exponent
       MOVB R13,R10           Save it to see if it will change
       SRL  R13,8             Put exponent in the low byte
       A    R1,R7             Get address of byte to look at
       AB   R3,*R7            Add NO. to add to round-1 into
*                              correct byte
       MOV  R3,R11            In ROUNUP: Change R3 value
       MOV  R10,R4            In ROUNUP: Use R10 to return
       LI   R10,CNSROV
       MOVB @FAC,R5           In ROUNUP: Get the exponent value
*                                        from EXP and EXP+1, so
*                                        now provide
       SRL  R5,8
       MOV  R5,@EXP
       MOVB R5,@SIGN          Clear sign which is used in ROUNUP
       MOV  R9,R5             In ROUNUP: R9 value may be
*                                        changed
       B    @ROUNUP           Propigate carry upwards in FAC
CNSROV MOV  R4,R10
       MOV  R11,R3
       MOV  R5,R9
       CLR  R1                Label prevents getting an
*                              overflow warning
       CI   R7,FAC1           Did rounding occur at first
*                              byte of FAC?
       JNE  CNSR02            No, go clear rest of FAC
       CB   @FAC,R10          Yes, did exponent change?
       JNE  CNSR03            Yes, FAC is correctly zeroed
*                              as is
CNSR02 CI   R3,4*256          Did rounding occur on a byte
*                              boundry?
       JNE  CNSR04            Yes, clear rest of bytes in FAC
       CLR  R0                No, make this digit divisible
*                              by ten
       MOVB *R7,@R1LB         Get byte where rounding occured
       DIV  @LW10,R0          Divide by ten to get quotient
       MPY  @LW10,R0          Pack quotient back in, ignore
       MOVB @R1LB,*R7         Put the byte back into the FAC
CNSR03 INC  R7                Point to next byte of FAC
CNSR04 MOVB R1,*R7+           Zero next byte of FAC
       CI   R7,FAC8           Done zeroing the rest of the
*                              FAC?
       JL   CNSR04            No, continue to do it
CNSR05 MOV  *R9,R11           Yes, restore return address
       DECT R9                Get new base ten exponent of FAC
*
* GET BASE TEN EXPONENT OF THE NUMBER IN THE FAC
* CALL     BL        CSNTEN
*        STATUS      Status bits reflect exponent
*          R13       Base ten exponent
*          R7        0 if R13 is even, 1 it R13 is odd
CNSTEN LI   R13,->4000        Negative bias
       AB   @FAC,R13          Get base 1 hundred exponent of
*                              FAC
       SRA  R13,7             Multiply it by two and put it
*                              in the low byte
       CLR  R7                High bit of FAC1 is always off
       CB   @FAC1,@CBHA       Is first digit of FAC one
*                              decimal digit?
       JLT  CNST01            Yes, base ten exponent is even
       INC  R13               No, take this into account in
*                              base ten exponent
       INC  R7                This makes the base ten
*                              exponent odd
CNST01 MOV  R13,R13           Set stauts bits to reflect
*                              base ten exponent
       RT
*
* CONVERT FACTION OF FLOATING NUMBER IN FAC TO ASCII DIGITS
* CALL        R3     Number of decimal digits+1 to convert
*             R4     Number of digits the decimal point is to
*                     the left of
*             R6     Text pointer to where to put result
* BL       CNSDIG
*             R3(MB) 0
*             R6     Updated to point to end of digits
*             R12    Pointer to decimal point
* DESTORYS: R0-R2,R4
*
CNSDIG INCT R9                Save return address
       MOV  R11,*R9
       CLR  @FAC8             Clear guard digits in case they
*                              are printed
       CLR  R1                Clear high byte of current byte
*                              of FAC register
       LI   R2,FAC1           Get pointer to first byte of FAC
       BL   @CNSD03           Check for a leading dec point
CNSD01 CLR  R0                Clear high word of this byte
*                              of FAC for divide
       MOVB *R2+,@R1LB        Get next byte of FAC
       DIV  @LW10,R0          Separate the two decimal digits
       BL   @CNSD02           Put the first one in the buffer
       MOV  R1,R0             Get the one's place digit
       LI   R11,CNSD01        Set up return addressto loop and
*                              get the next byte of the FAC
*                              after this digit is printed
CNSD02 AI   R0,'0'            Convert this decimal digit to
*                              ASCII
       MOVB @R0LB,*R6+        Put this ASCII digit into buffer
CNSD03 DEC  R4                Is it time for decimal point?
       JNE  CNSD04            No, check for end of number
       MOV  R6,R12            Yes, save ptr to decimal point
       MOVB @LBPER,*R6+       Put decimal point in buffer
* VSPTR (Value stack pointer) at CPU >6E, make sure not to
*  destroy it here
CNSD04 CI   R6,FAC33          Field overflow?
       JHE  CNSD06            Yes, put a zero byte at the
*                              end and return
       DEC  R3                No, all digits been printed?
       JGT  CNSDRT            No, return & print next digit
CNSD06 MOVB R3,*R6            Yes, put a zero byte at the end
*                              of the number
CNSD05 MOV  *R9,R11           Restore return address
       DECT R9
CNSDRT RT
********************************************************************************
 
       TITL 'CNS3592'
 
* PUT EXPONENT INTO THE BUFFER
* CALL        R6     Text pointer into buffer
*             R13    Exponent
*   BL      CNSEXP
*             R6     Updated to point after exponent
* DESTORYS:   R0,R13
*
CNSEXP INCT R9                Save return address
       MOV  R11,*R9+
       MOV  R12,*R9           Save contents of registers
       MOVB @LBE,*R6+         Put an "E" into the buffer
       LI   R0,'-'*256        Assume the exponent is negative
       ABS  R13               Is exponent negative?
       JLT  CNSE01            Yes, sign is correct
       LI   R0,'+'*256        No, get sign for positive exp
CNSE01 MOVB R0,*R6+           Put the exponent's sign into
*                              buffer
       CI   R13,100           Is the exponent to big?
       JLT  CNSE02            No, convert it to ASCII
       MOV  @WSM,R0           Is free format output?
       JEQ  CNSE04            Yes, get the asterisk
       CZC  @LWCNF,R0         No, is extended exp specified?
       JNE  CNSE02            Yes, convert it to ASCII
CNSE04 LI   R0,'*'*256        No, get an asterisk
       MOVB R0,*R6+           Put two asterisks in the buffer
*                              for the exponent
       MOVB R0,*R6+           Because it is too big
       JMP  CNSE03            Go finish up
CNSE02 BL   @CNSINT           Convert the exp to ASCII digit
       AI   R6,-5             Point back to start of exp
       MOV  @WSM,R0           Is free format output?
       JEQ  CNSE05            Yes
       CZC  @LWCNF,R0         No, is extended exp specified?
       JEQ  CNSE05            No
       MOVB @2(R6),*R6+       Yes, move 3(instead of 2)
*                              significant
       MOVB @2(R6),*R6+        digits of exponent up pass the
       MOVB @2(R6),*R6+        leading zeros from CNSINT
       JMP  CNSE03
CNSE05 MOVB @3(R6),*R6+       Move significant digits of
*                              exponent up pass the leading
*                              zeros from
       MOVB @3(R6),*R6+        CNSINT
CNSE03 MOVB @LW10,*R6         Put a zero byte at the end of
*                              the number
       MOV  *R9,R12           Restore original contents of
*                              R12
       DECT R9
       JMP  CNSD05            POP address and return
* CONVERT AN UNSIGNED INTEGER INTO A STRING OF 5 ASCII DIGITS
* CALL        R6     Text pointer
*             R13    Integer
*   BL      CNSINT
*             R6     Updated to point after number
* DESTROYS:   R0,R12,R13
CNSINT LI   R0,CNSITT         Get pointer to integer power of
*                              ten table
CNSI01 CLR  R12               Clear high word of integer for
*                              divide
       DIV  *R0+,R12          Divide by next power of ten
       AI   R12,'0'           Convert quotient to ASCII
       MOVB @R12LB,*R6+       Put next digit into the buffer
       CI   R0,CNSITT+10      Divided by all the powers of ten?
       JL   CNSI01            No, compute the next digit of
*                              the NO.
       MOVB R12,*R6           Yes, put a zero byte at the
*                              end of the number
       RT
* PUT SOME ZEROS IN THE BUFFER AND MAYBE A DECIMAL POINT
* CALL        R0     Number of zeros+1
*             R6     Text pinter into buffer
*   BL     CNSPER :  To put in a decimal point before zeros
*   BL     CNSZER :  Updated to point after the zeros
* DESTROYS:   R0
CNSPER MOVB @LBPER,*R6+       Put a decimal point in the buffer
       JMP  CNSZER            Then some zeros
CNSZ01 MOVB @LBZER,*R6+       Put a zero in the buffer
CNSZER DEC  R0                Are there more zeros to put in?
       JGT  CNSZ01            Yes, go put in another zero
       MOVB R0,*R6            No, put a null byte after the
*                              zeros
       RT
* SUPPRESS LEADING ZEROS AND FLOAT THE SIGN
* CALL
*   JMP    CNSMLS : Entry to finish up after zero suppressing
*   BL     CNSLEA : Entry to return afterwards
*            R1     ASCII sign in high byte
*            R6     Pointer to start of number
* DESTROYS:  R0-R1
CNSMLS LI   R11,CNSSTR        Entry to finish up number
*                              afterward
CNSLEA LI   R6,FAC15          Get pointer to sign
       MOVB *R6,R1            Get sign
CNSL01 MOVB @LBSPC,*R6+       Put a space where the zero
*                              or sign was
       CB   *R6,@LBZER        Is the next byte zero?
       JEQ  CNSL01            Yes, suppress it
       MOVB *R6,R0            No, is this the end of
*                              the number?
       JEQ  CNSL02            Yes, put the zero back in,
*                              NO. is 0
       CB   R0,@LBE           No, is this the start of
*                              the exponent?
       JEQ  CNSL02            Yes, put the zero back in,
*                              NO. is 0
       CB   R0,@LBPER         No, is this the decimal point?
       JNE  CNSL03            No, put the sign back in
       MOV  @WSM,R0           Yes, is free format output?
       JNE  CNSL03            No, then put the sign
*                              back in fix fomat output
       MOVB @1(R6),R0         Yes, any digits to right of DP?
       JEQ  CNSL02            No, put the sign back
       CB   R0,@LBE           Does exponent start after DP?
       JNE  CNSL03            No, put the sign back
CNSL02 DEC  R6                Yes, point back to where the
*                              zero was
       MOVB @LBZER,*R6        Put the zero back in, the NO.
*                              is 0
CNSL03 DEC  R6                Point back to where the sign
*                              will go
       MOVB R1,*R6            Put the sign back in the buffer
       RT
* REMOVE TRAILING ZEROS
* CALL      R3      0
*           R6      Pointer to one past end of number
*           R12     Pointer to decimal point
*           R10     Zero if an integer is being printed
*   BL   CNSUTR
*           R6      Pointer to new end of number
* DESTROYS: NONE
CNSU01 DEC  R6                Point back to next digit in
*                              the NO.
CNSUTR CB   @-1(R6),@LBZER    Is the last digit in the NO. 0?
       JEQ  CNSU01            Yes, look back for a non-zero
*                              digit
       MOV  R10,R10           No, is an integer being printed?
       JNE  CNSU02            No, put a null at the end of
*                              the NO.
       MOV  R12,R6            Yes, end of number is where DP
*                              is all digits after the
*                              decimal point should be zero
CNSU02 MOVB R3,*R6            Put a zero byte at the end of
*                              the number
       RT
* SET UP A POINTER TO THE BEGINNING OF A FIXED FORMAT FIELD
* AND SEE IF THE FIELD IS LARGE ENOUGH AND FINISH UP
* CALL      R12     Pointer to decimal point or where it
*                    would go
*   JMP   CNSCHK
*           R6      Pointer to beginning of number
* DESTROYS: R0,R1
CNSCHK BL   @CNSLEA           Suppress leading zeros and fix
*                              up the sign
       MOV  R12,R6            Point to decimal point
       S    @WSM2,R6          Point to where the beginning of
*                              the field is
       CB   @-1(R6),@LBSPC    Does number extend before the
*                              field beginning?
       JNE  CNSAST            Yes, error
       MOV  @WSM,R0           No, get R0 format specification
       CZC  @LWCNS,R0         Is an explicit sign required?
       JEQ  CNSSTR            No, finish up and return
       CB   *R6,@LBSPC        Yes, is first character of
*                              number a space?
       JEQ  CNSSTR            Yes, finish up and return
       CB   *R6,R1            No, is first character of
*                              number the sign?
       JEQ  CNSSTR            Yes, finish up and return
*                             No, error
* ASTRISK FILL A FIXED FORMAT FIELD AND FINISH UP
* CALL
*   JMP   CNSAST
*           R6        Pointer to the beginning of the string
* DESTROYS: R0,R1
CNSAST LI   R6,WSM            Optimize for speed and space
       MOV  *R6+,R0           Get R0 format spacification
       MOV  *R6+,R1           Get left of decimal point size
       A    *R6+,R1           Compute length of field
       CZC  @LWCNE,R0         Is E-format being used?
       JEQ  CNSA01            No, field length is correct
       C    *R1+,*R1+         Yes, increase field length for
*                              the exponent (Increments R1
*                              by 4)
       CZC  @LWCNF,R0         Is extended E-format being used?
       JEQ  CNSA01            No, field length is correct
       INC  R1                Yes, increase field length for
*                              the exponent (Increments R1
*                              by 1)
CNSA01 LI   R6,FAC15          Get pointer to beginning of buffer
       MOV  R6,R0             Get a pointer to put asterisks
*                              in the buffer
CNSA02 MOVB @LBAST,*R0+       Put an asterisk into the buffer
       DEC  R1                Is the field filled yet?
       JGT  CNSA02            No, continue asterisk filling it
       MOVB R1,*R0            Yes, put a zero byte at the end
*                              of string
*                             Finish up and return
* FINSH UP -- COMPUTE THE LENGTH OF THE STRING AND RETURN
* CALL       R6    Pointer to first character in the string,
*                   the string ends with a zero byte
* DESTROYS:  R0-R1
CNSSTR MOV  R6,R0             Get pointer to beginning of the
*                              string
CNSS01 MOVB *R0+,R1           Look for end of string,
*                              found it?
       JNE  CNSS01            No, keep looking
       DEC  R0                Yes, point to back to the
*                              zero byte
       S    R6,R0             Compute length of string
       MOVB @R0LB,@FAC12      Put length of string in FAC12
       LI   R0,PAD0
       S    R0,R6             Put beginning of string
*                              in FAC11
       MOVB @R6LB,@FAC11
       MOV  *R9,R13           Restore GROM address
       DECT R9                Off the stack
       B    @ROLIN            In ROLIN return
********************************************************************************
       AORG >748E
       TITL 'TRINSICS'
 
CBH411 DATA >4101
 
CBH3F  BYTE >3F
CBH44  BYTE >44
       EVEN
*
* VROAZ  EQU >03C0            VDP roll out area
* FPSIGN EQU >03DC
* PROAZ  EQU PAD0+>10         Processor roll out area
* PZ     EQU PAD0+>12
* QZ     EQU PAD0+>16
* CZ     EQU PAD0+>1A
* SGNZ   EQU PAD0+>75
* EXPZ   EQU PAD0+>76
* OEZ    EQU PAD0+>14
EXC127 EQU  >00
FHALF  EQU  >08
SQRTEN EQU  >10
LOG10E EQU  >18
LN10   EQU  >20
PI2    EQU  >28
RPI2   EQU  >30
PI4    EQU  >38
TANPI8 EQU  >40
TAN3P8 EQU  >48
SQRP   EQU  >50
SQRQ   EQU  >6A
FPOS1  EQU  >6A
EXPP   EQU  >7C
EXPQ   EQU  >96
LOGP   EQU  >B8
LOGQ   EQU  >E2
SINP   EQU  >010C
ATNP   EQU  >014E
 
*************************************************************
* INVOLUTION                                                *
* FAC           - exponent                                  *
* Top of stack  - Base                                      *
* If integer Base and integer exponent do multiplies to     *
* keep result exact, otherwise, use logarithm to calculate  *
* value.                                                    *
*************************************************************
PWRZZ  MOV  R11,R10
       BL   @SAVRTN           Save return
       BL   @POPSTK           Get Base into ARG
       MOV  @FAC,R0           If exponent=0
       JEQ  PWRG01            Then result = 1
       MOV  @ARG,R0           If Base=0
       JEQ  PWRG02            Then return 0 or warning
       A    @C8,@VSPTR        Use Base on stack
       BL   @PUSH             Check to see if E is floating
*                              integer
       BL   @GRINT            Convert 1 copy of exp to int
       MOVB @C8,@SIGN         Assume sign is positive
       BL   @XTFACZ           FAC=ARG     STACK=INT(ARG)
       BL   @SCOMPB           Integer exponent?
       JNE  PWRZZ3            No, try floating code
* COMPUTE INTEGER POWER B^E
       BL   @PUSH             Put Exp above Base on stack
       MOVB @C8,@FAC10        Assume no error
       BL   @CFI              Try to convert E to integer
CCBH7  ABS  @FAC              Absolute value of exponent
       MOV  @FAC,R12          Save integer exponent
       BL   @POP              Return E to FAC; B on stack
       MOVB @FAC10,R0         If E>32767
       JNE  PWRZZ1            Return to floating point code
       BL   @XTFACZ           Get Base in accumulator
       BL   @PUSH             Put E on stack for later sign
*                              check
       DEC  R12               Reduce exponent by one since
*                              accumulator starts with Base
       JEQ  PWRJ40            If 0 then done already
PWRJ30 SRL  R12,1             Check l.s. bit
       JNC  PWRJ10            If 0, skip the work
       BL   @SMULT            Multiply in this power
       A    @C8,@VSPTR        Restore stack
PWRJ10 MOV  R12,R12           Finished?
       JEQ  PWRJ40            Yes
       BL   @XTFACZ           No, exchange: B in FAC,
*                              accumulator on stack
       BL   @PUSH             Copy B onto stack
       BL   @SMULT            Square it for new B
       BL   @XTFACZ           Restore order: B on stack
*                              accumulator in FAC
       JMP  PWRJ30            Loop for next bit
PWRJ40 S    @C16,@VSPTR       Done, clean up
       MOV  @VSPTR,R3         Get stack pointer
       AI   R3,8              Test exponent sign now
       BL   @GETV1            Get it
       JLT  PWRJ41            If negative, compute negative
PWRRTN B    @ROLIN2           Use commone code to return
PWRJ41 MOVB @FAC10,R0         If overflow has occured
       JNE  PWRJ45            Go make it zero
       BL   @MOVROM           Get a floating point one
       DATA FPOS1              into ARG
*
       BL   @FDIV             Compute the inverse
       JMP  PWRRTN            And return
PWRJ45 CLR  @FAC              If overflow, the result=0
       MOVB @FAC,@FAC10       Indicate no error
       JMP  PWRRTN            And return
PWRG02 MOVB @FAC,R0           Is Exp negative?
       JLT  PWRG05            Yes, divide by 0 =>put in overflow
       JMP  PWRJ45            No, result is zero and return
PWRG01 LI   R0,FAC            Need to put floating 1 in FAC
       BL   @MOVRM1           Get the floating 1
       DATA FPOS1              into FAC
*
       JMP  PWRRTN            And return
PWRZZ3 BL   @GETV             Check for negative
       DATA VSPTR             On the stack
*
       JGT  PWRZZ2            If ok
       MOVB @ERRNIP,@FAC10    Else error code
       S    @C8,@VSPTR        Throw away entry on stack
       JMP  PWRRTN            And return
* INTEGER EXPONENT OUT OF INTEGER RANGE
PWRZZ1 BL   @GETV             Positive or negative Base?
       DATA VSPTR
*
       JGT  PWRZZ2            Positive Base
* NEGATIVE BASE - So see if exponent is even or odd to set
*                  the sign of the result
PWRZZ4 CLR  R1                For double
       MOVB @FAC,R1           Get exponent
       ABS  R1                Work with positive
       CI   R1,>4600          Too big to have one's byte?
       JGT  PWRZZ2            Yes, assume number is even
       SWPB R1                Get in low order byte
       AI   R1,>830B          No, get one's radix digit
*                              location in FAC
       MOVB *R1,R1            Get the digit
       SLA  R1,7              If last bit set, set top bit
PWRZZ2 LI   R4,FPSIGN         Save sign of result
       BL   @PUTV1             in a permanent place
       BL   @XTFACZ           Base in FAC; Exponent on stack
       ABS  @FAC              Must work with positive
       BL   @LOGZZ            Compute LOG(B) in FAC
       BL   @SMULT            Compute E*LOG(B) in FAC
       BL   @EXPZZ            Let exp give error on warning
       LI   R3,FPSIGN         Check sign of result
       BL   @GETV1
       JLT  PWRZZ5            If E is negative
       JMP  PWRRTN            If E is positive
ERRNIP EQU  $
PWRZZ5 NEG  @FAC              Make it negative
       JMP  PWRRTN
PWRG05 BL   @OVEXP            Return overflow
       JMP  PWRRTN            And return
*************************************************************
* EXPONENTIAL FUNCTION                                      *
* FAC   =   EXP(FAC)                                        *
* CALL      BL   @EXPZZ                                     *
* WARNING:  WRNOV             Overflow                      *
* STACK LEVELS USED:                                        *
*      X : = FAC * LOG10(E)                                 *
*      So EXP(FAC) = 10^X                                   *
*      Make sure X is in range LOG100(X) = LOG10(X)/2       *
*      N : = INT(X)                                         *
*      R : = X-N, 0 <= R < 1                                *
*      IF R < .5 THEN R : = R                               *
*                ELSE S : = R-5                             *
* A rational function approximation is used for 10^S        *
* (HART EXPD 1444)                                          *
* EXP : = IF R .LT. .5 THEN 10^N * 10^S                     *
*                      ELSE 10^N * 10^.5 * 10^S             *
*************************************************************
EXPZZ  MOV  R11,R10
       BL   @ROLOUT           Get workspace and save return
       BL   @MOVROM           Get LOG10(E)
       DATA LOG10E               into ARG
*
       BL   @FMULT            X : = FAC * LOG10(E)
       BL   @PUSH             Save X
       BL   @GRINT            Compute N : = INT(X)
       BL   @MOVROM           Get floating 127
       DATA EXC127              into ARG
*
       BL   @FCOMPB           Is N > 127?
       JEQ  EXP03             If = 127
       JLT  EXP01             If > 127
       NEG  @ARG              Check negative range
       BL   @FCOMPB           Is N < -127?
       JLT  EXP03             N > -127
       JEQ  EXP03             N = -127
* N is out of range
EXP01  S    @C8,@VSPTR        Pop X off stack
       MOV  @FAC,@EXP         Recall exponent sign
       MOVB @C8,@SIGN         Result is positive
       BL   @OVEXP            Take over or underflow action
       JMP  BROLIN            Restore CPU RAM and return
EXP03  BL   @PUSH             Save value on stack
       BL   @CFI              Convert to integer exponent
       MOV  @FAC,R12          Get it in REG to mpy by 2
       SLA  R12,1             Compute 2*N
       BL   @POP              Restore value
       BL   @SSUB             Compute R = X - N
       BL   @MOVROM           Get a floating .5
       DATA FHALF              into ARG
*
       BL   @FCOMPB           Is .5 > R?
       JGT  EXP04             Yes, S=R
       NEG  @ARG              -.5
       BL   @FADD             Compute S : = R - .5
       INC  R12               Remember R >= .5, (2*N+1)
*                              save a copy of S
EXP04  BL   @PUSH             Save a copy of S
       BL   @POLYW            Compute S * P(S^2)
       DATA EXPP              Poly to evaluate
*
       BL   @XTFACZ           FAC = S, stack = S * P(S^2)
       BL   @POLYX            Compute Q(S^2)
       DATA EXPQ              Poly to evaluate
*
       BL   @POPSTK           S * P(S^2) -> ARG
       A    @C8,@VSPTR
       BL   @PUSH             Save comp of Q(S^2)
       BL   @FADD             Q(S^2) + S * P(S^2)
       LI   R3,FAC            Save FAC in a temp
       LI   R4,CZ
       MOV  *R3+,*R4+         1st two bytes
       MOV  *R3+,*R4+         2nd two bytes
       MOV  *R3+,*R4+         3rd two bytes
       MOV  *R3,*R4           Last two bytes
       BL   @POP              FAC = Q(S^S), stack = S*P(S^2)
       BL   @XTFACZ           Revese same
       BL   @SSUB             Compte Q(S^2)-S*P*(S^2)
       LI   R3,CZ             Get fac back from temp
       LI   R4,ARG
       MOV  *R3+,*R4+         1st two bytes
       MOV  *R3+,*R4+         2nd two bytes
       MOV  *R3+,*R4+         3rd two bytes
       MOV  *R3,*R4           Last rwo bytes
       BL   @FDIV             Compute Q-P/Q-P
EXPSQT SRA  R12,1             Check flag that was set above
       JNC  EXPSQ5            If not set
       BL   @MOVROM           Get SQR(10)
       DATA SQRTEN             into ARG
*
       BL   @FMULT            Multipy by SQU(10) if N odd
EXPSQ5 BL   @MOVROM           Need a floating 1
       DATA FPOS1              into ARG
*
       SRA  R12,1             Check odd power of ten
       JNC  EXPSQ8            If not odd power
       MOVB @CBHA,@ARG1       Odd power of ten (>0A)
EXPSQ8 AB   @R12LB,@ARG       Add in power of 100 to Exp
       BL   @FMULT
BROLIN B    @ROLIN
*************************************************************
* LOGARITHM FUNCTION                                        *
* FAC       : = LOG(FAC)                                    *
* ERRORS    : ERRLOG     LOG of negative number or zero     *
*                         attempted.                        *
* STACK LEVELS USED:                                        *
*    IF FAC <= 0 THEN ERRLOG                                *
*    LOG(FAC)=LN(FAC)=LOG10(FAC)*LN(10)                     *
*    FAC      : = A * 10^N,     .1 <= A < 1                 *
*    S        : = A * SQR(10),  1/SQR(10) <= S < SQR(10)    *
*    LOG10(A) : = LOG10(S/SQR(10))                          *
*             : = LOG10(S) - LOG10(SQR(10))                 *
*             : = LOG10(S) - .5                             *
*    LOG      : = (N - .5 + LOG10(S)) * LN(10)              *
*             : = (N - .5 * LN(10) + LN(S)                  *
* A rational function approximation is used for LN(S)       *
* (HART LOGE 2687)                                          *
*************************************************************
LOGZZ  MOV  R11,R10
       BL   @ROLOUT           Get workspace and save return
       MOV  @FAC,R0           Check for negative or zero
       JGT  LOGZZ3            If positive
       MOVB @ERRLOG,@FAC10    Load error code
       JMP  BROLIN            Restore CPU and return
ERRLOG EQU  $
LOGZZ3 BL   @TENCNS           Get base 10 exponent
       JNE  LOGZZ5
       BL   @MOVROM           Get a floating 1
       DATA FPOS1              into ARG
*                         Make it a floating 10
       MOVB @CBHA,@ARG1        by putting in >0A
       BL   @FMULT            Multipy FAC by 10
       BL   @TENCNS           Get new exponent of 10
       JMP  LOGZ5A            Compensate for Mult
LOGZZ5 INC  @EXP              Compenstat for where radix
*                              point is
LOGZ5A MOVB @CBH3F,@FAC       Put A in proper range
*                              by putting in >3F
       MOV  @EXP,R12
       BL   @MOVROM           Get SQR(10)
       DATA SQRTEN             into ARG
*
       BL   @FMULT            S : = A * SQR(10)
       BL   @FORMA            Z : = (S-1) / (S+1)
       BL   @PUSH             Push Z
       BL   @POLYW            Compute Z * P(Z^2)
       DATA LOGP
*
       BL   @XTFACZ
       BL   @POLYX            Compute Q(Z^2)
       DATA LOGQ              Poly to evaluate
*
       BL   @SDIV             Compute Z*P(Z^2)/Q(Z^2)
       BL   @PUSH             Push it
       LI   R0,ARG            Build entry in ARG
       MOV  R12,*R0+          Put in exponent
       CLR  *R0+               and
       CLR  *R0+                clear the
       CLR  *R0                        rest
* STATUS WAS SET BY THE MOVE ABOVE
       JEQ  LOGZZ7            If zero exponent
       ABS  @ARG              Work with ABS value
       MOV  @ARG,R0             in register
       CI   R0,99             Too large?
       JGT  LOGZZ9            Yes
       MOVB @FLTONE,@ARG      Exponent = >40
LOGZZ6 MOVB R12,R12           Exponent positive?
       JEQ  LOGZZ7            Yes
       NEG  @ARG              No, make it negative
LOGZZ7 BL   @MOVRM5           Need a floating .5
       DATA FHALF              in FAC
*
       BL   @FSUB             Compute N - .5
       BL   @MOVROM           Need LN(10)
       DATA LN10               into ARG
*
       BL   @FMULT            Compute (N - .5) * LN(10)
       BL   @SADD             Add to LN(S)
       JMP  BROLIN            Restore CPU and return
LOGZZ9 S    @C100,@ARG        Subtract first 100
       MOVB @ARG1,@ARG2
       MOV  @CBH411,@ARG      Load exponent and
*                              leading digit of >4101
       JMP  LOGZZ6
*************************************************************
* EVALUATE X * P(X^^2)                                      *
* ON CALL  : PZ          Pointer to polynomial coefficients *
*          : FAC         Contains X                         *
*      BL    @POLYW                                         *
*          : FAC         Returns  X * P(X^^2)               *
*************************************************************
POLYW  MOV  *R11+,@PZ         Get the poly to evaluate
       MOV  R11,R10
       BL   @SAVRTN           Save return address
       BL   @PUSH             Push the argument
       BL   @POLYX1           Compute P(X^^2)
       BL   @SMULT            Compute X*P(X^^2)
       JMP  PWRTN2            And return
POLY   MOV  *R11+,@PZ
       MOV  R11,R10
       BL   @SAVRTN           Save return address
       JMP  POLY01            And merge in below
POLYX  MOV  *R11+,@PZ
POLYX1 MOV  R11,R10
       BL   @SAVRTN           Save return address
       BL   @PUSH             Need to copy FAC
*                              into ARG to square it
       BL   @SMULT            Square X (SMULT pops into ARG)
POLY01 BL   @PUSH             Push the argument
       MOV  @PZ,R3            Get the poly to evaluate
       LI   R0,FAC             into FAC
       BL   @MOVRM2
       JMP  POLY03
POLY02 BL   @POPSTK           Get X back
       A    @C8,@VSPTR        Keep it on stack
       BL   @FMULT            Multiply previous result by X
       MOV  @PZ,R3
       LI   R0,ARG            Get polynomial to evaluate
       BL   @MOVRM2            into ARG
       BL   @FADD             Add in this coefficient
POLY03 A    @C8,@PZ           Point to next coefficient
*                              and get first two bytes
*                               into ARG
       CB   *R13,@CBH80       Read first byte
*                              and test it to see if done
       JNE  POLY02            No, continue computing poly
       S    @C8,@VSPTR        Pop X off stack
       JMP  PWRTN2            Return with poly in FAC
*
FORMA  MOV  R11,R10
       BL   @SAVRTN           Save return address
       BL   @PUSH             Save X on stack
       BL   @FORMA2
       BL   @FORMA2
       BL   @XTFACZ           Swap (X-1) and X
       BL   @MOVROM           Get a floating 1
       DATA FPOS1              into ARG
*
       BL   @FADD             X+1
       BL   @SDIV             (X-1)/(X+1)
       JMP  PWRTN2            And return
FORMA2 MOV  R11,R10
       BL   @SAVRTN           Save return address
       BL   @MOVROM           Get a floating .5
       DATA FHALF              int ARG
*
       NEG  @ARG
       BL   @FADD             X - .5
PWRTN2 B    @ROLIN2
*************************************************************
* SQUARE ROOT FUNCTION                                      *
* Reference for scientific function approximations.         *
* JOHN F. HART ET AL, Comper approximations,                *
*  JOHN WILEY & SONS, 1968                                  *
* FAC    : = SQR(FAC)                                       *
* ERRORS :   ERRSQR      Square root of negative number     *
*                         attempted                         *
* STACK LEVELS USED:                                        *
*     IF FAC = 0 THEN SQR : = 0                             *
*     IF FAC < 0 THEN ERRSQR                                *
*     FAC : = A * 100^N,        .01 <= A < 1                *
*     SQR : = 10^N * SQR(A)                                 *
* Newton's method with a fixed number of iterations is used *
* to approximate SQR(A):                                    *
* A rational function approximation is used for Y(0)        *
*      (HART SQRT 0231)                                     *
* Y(N+1) = (Y(n))/2                                         *
*************************************************************
SQRZZ  MOV  R11,R10
       BL   @ROLOUT           Get workspace and save return
       MOV  @FAC,R12          Check exponent
       JEQ  SQR03             FAC is zero, return zero
       JLT  SQR02             FAC is < 0, error
       MOVB @CBH3F,@FAC       Create A in range .01 <= A <1
*                              by loading >3F
       AI   R12,>C100         Remove bias (-63)
       SRA  R12,8             Sign extend
       SLA  R12,1             Save 2 * N
       BL   @PUSH             Save A
       BL   @PUSH             Save A again
       BL   @POLY             Compute P(A)
       DATA SQRP              Poly to evaluate
*
       BL   @XTFACZ           Stack : = P(A), FAC : = A
       BL   @POLY             Compute Q(A)
       DATA SQRQ              Poly to evaluate
*
       BL   @SDIV             Compute P(A)/Q(A)
       MOV  @CC3,@PZ          Save in permanent
SQR01  BL   @POPSTK           Pop into ARG
       A    @C8,@VSPTR        But keep it on stack
       BL   @PUSH             Push Y(N)
       BL   @FDIV             Compute A/Y(N)
       BL   @SADD             Compute A/Y(N) + Y(N)
       BL   @MOVROM           Nead a floating .5
       DATA FHALF              into ARG
*
       BL   @FMULT            Compute .5 * (A/Y(N) + Y(N))
       DEC  @PZ               Decrement loop counter
       JNE  SQR01             Loop three times
       S    @C8,@VSPTR        Pop off stack
       B    @EXPSQT           To finish up
SQR02  MOVB @ERRSQR,@FAC10    Load error code for return
ERRSQR EQU  $
SQR03  B    @ROLIN            Restore CPU RAM and return
*************************************************************
* COSINE FUNCTION                                           *
* FAC         : = COS(FAC)                                  *
* COS(FAC)    : = SIN(FAC + PI/2)                           *
*************************************************************
COSZZ  MOV  R11,R12
       BL   @MOVROM           Need to get PI/2
       DATA PI2                into ARG
*
       BL   @FADD             Compute FAC + PI/2
       MOV  R12,R11           And fall into SIN code
********************************************************************************
 
 
       TITL 'TRINSICS2'
 
*************************************************************
* SINE FUNCTION                                             *
* FAC          : = SIN(FAC)                                 *
* STACK LEVELS USED:                                        *
*     IF FAC < 0 THEN SIN(FAC) : = -SIN(-FAC)               *
*     X       : = 2/PI*FAC                                  *
*     K       : = INT(X)                                    *
*     R       : = X-K, 0 <= R < 1                           *
*     Q       : = K MOD 4                                   *
*  SO K       : = 4*N+Q                                     *
*    FAC      : = PI/2 * K + PI/2 * R                       *
*             : = 2*PI*N + PI/2*Q + PI/2*R                  *
*    SIN(FAC) : = SIN(P/2*Q+PI/2*R)                         *
* QUADRANT  Q     Identity                                  *
* I         0     SIN(FAC)    : = SIN(PI/2*R)               *
* II        1     SIN(FAC)    : = SIN(PI/2+PI/2*R           *
*                             : = SIN(PI-*(PI/2+PI/2R))     *
*                             : = SIN(PI/2*(1-R))           *
* III       2     SIN(FAC)    : = SIN(PI+PI/2*R)            *
*                             : = SIN(PI-(PI+PI/2*R))       *
*                             : = SIN(PI/2 * (R-1))         *
* IV        3     SIN(FAC)    : = SIN(3*PI/2 + PI/2*R       *
*                             : = SIN(3*PI/2 + PI/2*R-2*PI) *
*                             : = SIN(PI/2 * (R-1))         *
* QUADRANT  Q  ARGUMENT TO APPROXIMATION POLYNOMIAL         *
* I         0    R      = R         0 <= R   <  1           *
* II        1  1-R      = 1-R       0 <  1-R <= 1           *
* III       2   -R      = -R       -1 <  -R  <= 0           *
* IV        3    R-1    = -(1-R)   -1 <= R-1 <  0           *
*                                                           *
* A polynomial approximation is used for SIN(P/2*R)         *
*                      -1 <= R < 1                          *
* (HART SIN 3344)                                           *
*************************************************************
SINZZ  MOV  R11,R10
       BL   @ROLOUT           Get workspace and save return
       BL   @MOVROM           Get 2/PI
       DATA RPI2               into ARG
*
       BL   @FMULT            X : = 2/PI*FAC
       MOVB @FAC,R12          Save sign
       ABS  @FAC              Consider positive numbers
       CB   @FAC,@CBH44       Check exponent range
*                              by checking with >44
       JGT  TRIERR            ERR in range of exponent
       BL   @PUSH             Save X
       BL   @GRINT            K : = INT(K)
       CLR  R1                Assume Q is zero
       CLR  R0
       MOVB @FAC,R0           Is FAC zero?
       JEQ  SIN02             Yes, Q is zero
       AI   R0,>BA00          Bias exponent (->46 byte)
*                              is K too big for (K MOD 4)
*                              to have a significance?
       JGT  SIN01             Yes, defualt Q to zero
       AI   R0,>51*256        (FAC+7-PAD0)*256
CBH80  EQU  $+1               CONSTANT >80
       SRL  R0,8
       AI   R0,PAD0
       MOVB *R0,@R1LB         No, get 10's and 1's place of K
CC3    EQU  $+2
SIN01  ANDI R1,3              Q : = (K MOD 4)
SIN02  MOV  R1,@QZ
       BL   @SSUB             R : = X-K
       MOV  @QZ,R1
       SRL  R1,1              Is Q even?
       MOV  R1,@QZ
       JNC  SIN03             Yes
       BL   @MOVROM           Get a floating 1
       DATA FPOS1              into ARG
*
       BL   @FSUB             Compute 1-R
SIN03  MOV  @QZ,R1            Quadrant III or IV?
       JEQ  SIN04             No
       INV  R12               Yes, change sign or result
SIN04  BL   @POLYW            Evaluate it
       DATA SINP               get poly P's coefficients
*
       JMP  ATNSGN              and set sign
TRIERR MOVB @CCBH7,@FAC10     TRIG error (>7 in FAC10)
       JMP  ATNSG3
*************************************************************
* TANGENT FUCTION                                           *
* FAC            : = TAN(FAC)                               *
* TAN(FAC)       : = SIN(FAC)/COS(FAC)                      *
*************************************************************
TANZZ  MOV  R11,R10
       BL   @SAVRTN           Save return address
       BL   @PUSH             Save FAC on stack
       BL   @SINZZ            Compute SIN
       BL   @XTFACZ
       BL   @COSZZ            Compute COS
       BL   @POPSTK           Pop stack into ARG
       CB   @FAC10,@CCBH7     Check for error
       JEQ  PWRTN3            If error
       MOV  @FAC,R0           Is COS = zero?
       JEQ  TAN01             Yes
       BL   @FDIV             No, TAN : = SIN(ARG)/COS(ARG)
PWRTN3 B    @ROLIN2
TAN01  MOVB @ARG,@SIGN
       BL   @OVEXP            Issue overflow message
       JMP  PWRTN3            Clean up and exit
*************************************************************
* INVERSE TANGENT FUCTION                                   *
* FAC            : = ATN(FAC)                               *
* STACK LEVELS USED:                                        *
*     IF FAC <  0 THEN ARCTAN(FAC) = -ARCTAN(-FAC)          *
*     IF 0   <= FAC <= TAN(PI/8)                            *
*                 THEN T = FAC, ARCTAN(FAC) : = ARCTAN(T)   *
*     IF TAN(PI/8) < FAC < TAN(3*PI/8)                      *
*                 THEN T = (FAC-1) / (FAC+1),               *
*                      ARCTAN(FAC) : = PI/4 + ARCTAN(T)     *
*     IF TAN(3*PI/8) <= FAC                                 *
*                 THEN T = -1/FAC,                          *
*                      ARCTAN(FAC) : = PI/2 + ARCTAN(T)     *
*                                                           *
* A polynomial approximation is used for ARCTAN(T),         *
*              -TAN(PI/8) <= T <= TAN(PI/8)                 *
* (HART ARCTN 4967)                                         *
*************************************************************
ATNZZ  MOV  R11,R10
       BL   @ROLOUT           Get workspace and save return
       MOVB @FAC,R12          Save sign
       ABS  @FAC              Use ABS(FAC)
       CLR  @QZ               Assume ARG is in range
       BL   @MOVROM           Need TAN(PI/8)
       DATA TANPI8             into ARG
*
       BL   @FCOMPB           Is TAN(3*PI/8) >= ARG?
       JEQ  ATN02             If =
       JGT  ATN02             If >
       BL   @MOVROM           Need TAN(3*PI/8)
       DATA TAN3P8             into ARG
*
       BL   @FCOMPB           Is TAN(3*PI/8) > ARG?
       JGT  ATN01             Yes, use case 2
       BL   @MOVROM           Get a floating 1
       DATA FPOS1              into ARG
*
       NEG  @ARG              Use case 3 to compute
       BL   @FDIV             T = -1/ARG
       LI   R3,PI2            Get PI/2
       JMP  ATN02A            Add it in at the end
ATN01  BL   @FORMA            Case 2 : T : = (ARG-1)/(ARG+1)
       LI   R3,PI4            Get PI/4
ATN02A MOV  R3,@QZ            Set up to evaluate
ATN02  BL   @POLYW            ATN(T) : = T * P(T^^2)
       DATA ATNP              Poly to evlauate
*
       MOV  @QZ,R3            Case 1?
       JEQ  ATNSGN            Yes, don't add anything in
       LI   R0,ARG
       BL   @MOVRM2
       BL   @FADD             Add in the constant
ATNSGN INV  R12               Check sign of result
       JLT  ATNSG3            If sign is already on
       NEG  @FAC               else negate it
ATNSG3 B    @ROLIN            And return
*************************************************************
* GREATEST INTEGER FUNCTION                                 *
*************************************************************
GRINT  MOV  R11,R7            Save return address
       MOVB @FAC,@SIGN        Save result sign
       ABS  @FAC              Absolute value
       MOVB @FAC,R5           Get exponent
       SRL  R5,8              Make it into word
       MOV  R5,@EXP           For rounding
       CI   R5,>40            Exponent < 0?
       JLT  BITINT            Yes, handle it
       CI   R5,>45            Exponent > 10^5 ?
       JGT  INT02             Yes, handle it
       AI   R5,->46           Locate position
       MOVB @R5LB,@FAC10      Save for rounding
       CLR  R2
       LI   R3,FAC8
       A    R5,R3             Point to 1st fractional digit
INT01  SOCB *R3,R2            Remember if non-zero
       MOVB @R2LB,*R3+        Clear the digit
       INC  R5
       JNE  INT01
       MOVB @SIGN,R0          Get the sign
       JGT  INT03             If non-negative(i.e. Positive)
       MOVB R2,R2
       JEQ  INT02
       AB   @CCBH7,@FAC10     Where to round up
       BL   @ROUNU            Do the rounding
       JMP  INT03
INT02  MOVB @SIGN,R0          Check the sign
       JGT  INT03             If positive don't negate
       NEG  @FAC              Make result negative
INT03  CLR  @FAC10            Indicate no error
       B    *R7          <<<< Return from here
BITINT LI   R0,FAC            Zero or -1
       LI   R1,>BFFF          Default to -1
       MOVB @SIGN,R2          Negative or Positive?
       JLT  INT04             If really negative put in -1
       CLR  R1                If Positive put in a 0
INT04  MOV  R1,*R0+           Copy in 0 or -1
       CLR  *R0+               and
       CLR  *R0+                clear
       CLR  *R0                  the
       JMP  INT03                 rest
* MOVE 8 BYTES FROM ROM(R3) TO CPU AT R0
MOVRM5 LI   R0,FAC            Move to FAC
       JMP  MOVRM1            Merge into common code
MOVROM LI   R0,ARG            Move to ARG
MOVRM1 MOV  *R11+,R3          Constant to load
MOVRM2 LI   R2,8              Constants are 8 bytes long
       A    @INTRIN,R3        Add in GROM offset                      <<<<<<<<<<
       MOVB R3,@GRMWAX(R13)    Write MSB of address
       SWPB R3                Bare the LSB
       MOVB R3,@GRMWAX(R13)    Write the LSB
MOVRM4 MOVB *R13,*R0+         Read a byte
       DEC  R2                Moved them all yet?
       JNE  MOVRM4            No, copy the next one
       RT                     Yes, return
* ROLL OUT CPU AREA FOR WORKSPACE
ROLOUT LI   R1,PROAZ          Processor roll out area
CVROAZ EQU  $+2
       LI   R3,VROAZ          VDP roll out area
       MOVB @R3LB,*R15
       ORI  R3,WRVDP
       MOVB R3,*R15
       LI   R0,26
ROLOT1 MOVB *R1+,@XVDPWD
       DEC  R0
       JNE  ROLOT1
       CLR  @FAC8             And save return address
* SAVE RETURN ADDRESS
SAVRTN INCT @STKADD
       MOVB @STKADD,R9
       SRL  R9,8
       AI   R9,PAD0
       MOV  R10,*R9
       RT
* ROLL IN CPU AREA AFTER WORK IS DONE
ROLIN  LI   R1,PROAZ          Processor roll out area
       MOVB @CVROAZ+1,*R15    LSB of address
       MOVB @CVROAZ,*R15      MSB of address
       LI   R0,26             Number of bytes rolled out
ROLIN1 MOVB @XVDPRD,*R1+
       DEC  R0
       JNE  ROLIN1
       CLR  @FAC8
ROLIN2 MOVB @STKADD,R9
       SRL  R9,8
       AI   R9,PAD0
       MOV  *R9,R11
       DECT @STKADD
       RT
* PUSH FAC ONTO STAK
C8     EQU  $+2
PUSH   LI   R0,8              Number to push
       A    R0,@VSPTR         Bump stack pointer
       MOV  @VSPTR,R1         Get stack poiter
       MOVB @R1LB,*R15
       ORI  R1,WRVDP
       MOVB R1,*R15
       LI   R1,FAC
PUSH1  MOVB *R1+,@XVDPWD
       DEC  R0
       JGT  PUSH1
       RT
* POP VALUE OFF STACK INTO FAC
POP    LI   R2,FAC
       MOVB @VSPTR1,*R15      LSB of address
       LI   R0,8
       MOVB @VSPTR,*R15       MSB of address
       S    R0,@VSPTR
POP1   MOVB @XVDPRD,*R2+
       DEC  R0
       JGT  POP1
       RT
* EXCHANGE TOP OF STACK AND FAC
XTFACZ MOV  R11,R10           Save return address
       BL   @PUSH             Put FAC on top
       LI   R3,8              Working with 8 byte entries
       MOV  R3,R5             Need another copy for below
       S    R3,@VSPTR         Point back to old top
       BL   @POP              Put it in FAC
       A    R3,@VSPTR         Restore pointer to old top
       MOV  @VSPTR,R4         Place to move to
       A    R4,R3             Place to move from
XTFAC1 BL   @GETV1            Get a byte
       BL   @PUTV1            Put a byte
       INC  R3
       INC  R4
       DEC  R5                Done?
       JNE  XTFAC1            No
       B    *R10              Yes, retrun
* GET BASE 10 EXPONENT OF THE NUMBER IN FAC
* EXP:      Gets the base 10 exponent
* OEZ:      0 if exp is even and 1 if exp is odd
TENCNS CLR  R0                Get base 100 exponent
       MOVB @FAC,R0           Put in MSB
       AI   R0,>C000          Remove bias (SUBT >64 from MSB)
       SLA  R0,1              Multiply it by 2
       SRA  R0,8              Sign fill high order byte
       CLR  R3                 and put in LSB
       CB   @FAC1,@CBHA       1st digit of FAC one decimal
*                              digit?
       JLT  CNST10            Yes, base 10 exponent is even
       INC  R0                No, take this into account in
*                              exponent
       INC  R3                This makes base 10 exp odd
CNST10 MOV  R0,@EXP
       MOV  R3,R3             Set condition for return
       RT
*************************************************************
* MISCELLANEOUS CONSTANTS:
* CBH411
* EXC127    BYTE >41,1,27,0,0,0,0,0          127
* FHALF     BYTE >3F,50                      .5
* ZER3      BYTE 0,0,0,0,0,0
* SQRTEN    BYTE >40,3,16,22,77,66,01,69     SQR(10)
* LOG10E    BYTE >3F,43,42,94,48,19,03,25    LOG10(E)
* LN10      BYTE >40,2,30,25,85,09,29,94     LN(10)
* CBH7      EQU  $+3
* PI2       BYTE >40,1,57,7,96,32,67,95      PI/2
* RPI2      BYTE >3F,63,66,19,77,23,67,58    2/PI
* PI4       BYTE >3F,78,53,98,16,33,97,45    PI/4
* CBHA      EQU  $+7
* CBH3F
* TANPI8    BYTE >3F,41,42,13,56,23,73,10    TAN(PI/8)=SQR(2)-1
* TAN3P8    BYTE >40,2,41,42,13,56,23,73     TAN(3*PI/8)=SQR(2)+1
**          SQR POLYNOMIALS  (HART SQRT 0231)
* SQRP      BYTE >3F,58,81,22,90,00,00,00    P02=.58812 29E+00
*           BYTE >3F,52,67,87,50,00,00,00    P01=.52678 75E+00
*           BYTE >3E,58,81,20,00,00,00,00    P00=.58812 E-02
*           DATA SGNBIT
* FLTONE
* FPOS1
* SQRQ      BYTE >40,01,00,00,00,00,00,00    Q01=.1 E+01
*           BYTE >3F,09,99,99,80,00,00,00    Q00=.99999 8 E-01
*           DATA SGNBIT
**          EXPPONENT POLYNOMIALS  (HART EXPD 1444)
**          P02 = .18312 36015 92753 84761 54 E+02
* EXPP      BYTE >40,18,31,23,60,15,92,75
**          P01 = .83140 67212 93711 03487 3446 E+03
*           BYTE >41,08,31,40,67,21,29,37
*           P00 = .51780 91991 51615 35743 91297 E+04
*           BYTE >41,51,78,09,19,91,51,62
*           DATA SGNBIT
**          Q03 = .1 E+01
* EXPQ      BYTE >40,1,0,0,0,0,0,0
**          Q02 = .15937 41523 60306 52437 552 E+03
*           BYTE >41,01,59,37,41,52,36,03
**          Q01 = .27093 16940 85158 99126 11636 E+04
*           BYTE >41,27,09,31,69,40,85,16
**          Q00 = .44976 33557 40578 41762 54723 E+04
*           BYTE >41,44,97,63,35,57,40,58
*           DATA SGNBIT
**          LOG POLYNOMIALS  (HART LOGE 2687)
**          P04 = .35670 51030 88437 69 E+00
* LOGP      BYTE >3F,35,67,05,10,30,88,44
**          P03 = -.11983 03331 36876 1464 E+02
*           BYTE >BF,>F5,98,30,33,31,36,88
**          P02 = .63775 48228 86166 05782 E+02
*           BYTE >40,63,77,54,82,28,86,17
**          P01 = -.10883 71223 55838 3228 E+03
*           BYTE >BE,>FF,08,83,71,22,35,58
**          P00 = .57947 38138 44442 78265 7 E+02
*           BYTE >40,57,94,73,81,38,44,44
*           DATA SGNBIT
* LOGQ
**          Q04 = .1 E+01
*           BYTE >40,01,0,0,0,0,0,0
**          Q03 = -.13132 59772 88464 0339 E+02
*           BYTE >BF,>F3,13,25,97,72,88,46
**          Q02 = .47451 82236 02606 00365 E+02
*           BYTE >40,47,45,18,22,36,02,61
**          Q01 = -.64076 45807 52556 00596 E+02
*           BYTE >BF,>C0,07,64,58,07,52,56
**          Q00 = .28973 69069 22217 71601 9 E+02
*           BYTE >40,28,97,36,90,69,22,22
*           DATA SGNBIT
**          SIN POLYNOMIAL  (HART SIN 3344)
* SINP
**          REFLECTS CHANGE IN 99/4 CONSTANT TO CORRECT VALUES
**          OF SIN AND COS >1
**          P07 = -.64462 13674 9 E-09
**          BYTE >C4,>FA,44,62,13,67,49,00
**          P07 = -.64473 16000 0 E-09
*           BYTE >C4,>FA,44,73,16,00,00,00
**          P06 = .56882 03332 688 E-07
* CBH44     EQU  $+2
*           BYTE >3C,05,68,82,03,33,26,88
**          P05 = -.35988 09117 03133 E-05
*           BYTE >C2,>FD,59,88,09,11,70,31
**          P04 = .16044 11684 69828 31 E-03
*           BYTE >3E,01,60,44,11,68,46,98
**          P03 = -.46817 54131 06023 168 E-02
*           BYTE >C1,>D2,81,75,41,31,06,02
**          P02 = .79692 62624 56180 0806 E-01
*           BYTE >3F,07,96,92,62,62,45,62
**          P01 = -.64596 40975 06219 07082 E+00
*           BYTE >C0,>C0,59,64,09,75,06,22
**          P00 = .15707 96323 79489 63959 E+01
*           BYTE >40,01,57,07,96,32,67,95
*           DATA SGNBIT
**          ATN POLYNOMIAL  (HART ARCTN 4967)
* ATNP
**          P09 = -.25357 18798 82 E-01
*           BYTE >C0,>FE,53,57,18,79,88,20
**          P08 = .50279 13843 885 E-01
*           BYTE >3F,05,02,79,13,84,38,85
**          P07 = -.65069 99940 1396 E-01
*           BYTE >C0,>FA,50,69,99,94,01,40
**          P06 = .76737 12439 1641 E-01
*           BYTE >3F,07,67,37,12,43,91,64
**          P05 = -.90895 47919 67196 E-01
*           BYTE >C0,>F7,08,95,47,91,96,72
**          P04 = .11111 04992 50526 62 E+00
*           BYTE >3F,11,11,10,49,92,50,53
**          P03 = -.14285 71269 75961 157 E+00
*           BYTE >C0,>F2,28,57,12,69,75,96
**          P02 = .19999 99997 89961 5228 E+00
*           BYTE >3F,19,99,99,99,97,89,96
**          P01 = -.33333 33333 32253 4275 E+00
*           BYTE >C0,>DF,33,33,33,33,32,25
**          P00 = .99999 99999 99999 08253 E+00
*           BYTE >40,01,0,0,0,0,0,0
*           DATA SGNBIT
********************************************************************************

       AORG >7B88
       TITL 'CRUNCHS'
 
QUOTE  EQU  >22
COMMA  EQU  >2C
 
LISTZ  EQU  >02
OLDZ   EQU  >05
SAVEZ  EQU  >07
MERGEZ EQU  >08
RETURZ EQU  >88
UNBRKZ EQU  >8F
DATAZ  EQU  >93
RESTOZ EQU  >94
REMZ   EQU  >9A
CALLZ  EQU  >9D
IMAGEZ EQU  >A3
RUNZ   EQU  >A9
COLONZ EQU  >B5
QUOTEZ EQU  >C7
UNQSTZ EQU  >C8
USINGZ EQU  >ED
 
MAXKEY EQU  10
*
* CRUNCH copies a line (normally in LINBUF) to CRNBUF in the
* process, it turns the line number (if any) binary, and
* converts all reserved words to tokens. CALL is a GPL XML
* followed by a single byte which indicates the type of
* crunch to be done. Possible types include:
*              >00 - Normal crunch
*              >01 - crunch as a data statement (input stmt)
*        REGISGERS:
*      R0 - R1   Scratch
*      R2 - R3   Scratch
*      R4        Points to R8LB
*      R5        Points to length byte of string/numeric
*      R6        Indicates numeric copy mode (numeric/line #)
*      R7        Mode of copy (strings, names, REMs, etc)
*      R8        Character buffer
*      R9        Points to name during keyword scan
*      R11 - R12 Links
*      R13       GROM read data pointer
*      R15       VDP write address pointer
*
CRUNCH MOV  R11,R12           Save return link
       MOVB *R13,R3           Read call code
       BL   @PUTSTK           Save GROM address
       CLR  @FAC              Assume no line number
       LI   R4,R8LB           Set up W/S low-byte pointer
       CLR  R8                Initialize character buffer
       BL   @GETNB            Scan line for 1st good char
       MOVB R1,*R4            Save character
       JEQ  CRU28             If empty line, return
* Now check crunch call mode, normal or input statement
       SRL  R3,8              Normal curnch call?
       JEQ  CRU01             Yes, crunch the statement
* Initialize for input statement crunch
       LI   R2,CRU84          No, must be crunch input stmt
       LI   R10,CRU83           so set up move indicators
       LI   R7,CRU80
       JMP  CRU10             And jump into it
* Initialize for normal line crunch
CRU01  INC  @BUFLEV           Indicate CRNBUF is destroyed
       CLR  @ARG4             Assume no symbol
       MOVB R8,@PRGFLG        Clear program flag
       BL   @GETINT           Try to read a line number
       MOV  R0,@FAC           Put line number into final
       JEQ  CRU02             If no line number
       BL   @GETNB            Skip all leading spaces
       MOVB R1,*R4            Save character in R8LB
       JEQ  CRU28             If nothing left in line
CRU02  LI   R7,CRU16          Set normal scan move
       LI   R6,CRU96          Set normal numeric scan mode
       JMP  CRU10             Merge into normal scan code
* Main loop of the input copy routine. Sets R8LB to next
* character, R0 to its character property byte
* R7 indicates dispatch mode.
CRU04  LI   R6,CRU96          Set normal numeric mode
CRU05  LI   R7,CRU16          Set normal scan mode
CRU06  BL   @PUTCHR           Copy into crunch buffer
CRU08  BL   @GETCHR           Get next input character
       CLR  R0                Assume nil property
       MOVB R1,*R4            Copy to crunch buffer
       JEQ  CRU12             Finish up if we reach a null
*-----------------------------------------------------------*
* Replace following line for adding lowercase character     *
* set to 99/4A                5/12/81                       *                  *
*  CRU10 MOVB @CPTBL(R8),R0     Fetch char's prop table vec *
CRU10  CB   *R4,@ENDPRO       Higher then "z"               *
       JHE  CRU09             Yes, give CPNIL property      *
       MOVB @CPTBL(R8),R0     Fetch char's prop table value *
       B    *R7               Dispatch to appropriate code  *
CRU09  MOVB CPNIL,R0          Don't go to CPT, just take    *
*                              CPNIL prop                   *
*-----------------------------------------------------------*
CRU12  B    *R7               Dispatch to appropriate code
CRU14  MOV  R8,R8             End of line?
       JNE  CRU06             Not yet
CRU15  MOV  @RAMPTR,R3        Now check for trailing spaces
       DEC  R3                Backup to read last character
       BL   @GETV1            Go read it
       CB   R1,@CBH20         Last character a space?
       JNE  CRU28             No, so end of line, exit
       DEC  @RAMPTR           Yes, backup pointer to delete
       JMP  CRU15             And test new last character
*-----------------------------------------------------------*
* The following two lines are added for adding lowercase    *
* character set for 99/4A     5/13/81                       *
ENDPRO BYTE >7B               ASCII code for char after "z" *
       EVEN                                                 *
*-----------------------------------------------------------*
*
* Normal scan mode -- figures out what to do with this char
CRU16 MOVB  *R4,*R4           At end of line?
       JEQ  CRU28             Yes, clean up and return
       MOVB R0,R0             Set condition on char prop
       JLT  CRU08             Ignore separators (spaces)
       MOV  @RAMPTR,R9        Save crunch pointer
       SLA  R0,2              Scan property bits 1 and 2
       JOC  CRU32             Break chars are 1 char tokens
       JLT  CRU18             Alpha, prepare to pack name
       SLA  R0,2              Scan property bits 3 and 4
       JNC  CRU20             Jump if not multi-char oper
       BL   @GETCHR           Check next char to see if we
       SRL  R1,8               have a 2 char operator
       JEQ  CRU32             If read end of line-single oper
       BL   @BACKUP           Backup read pointer
       CB   @CPTBL(R1),@LBCPMO Next char also a multi-oper?
       JNE  CRU32             No, want single-char oper
       BL   @PUTCHR           Copy in first char to oper
       JMP  CRU36             And scan keyword table
* Set name copy mode
CRU18  LI   R7,CRU76          Alphabetic: set name copy mode
*-----------------------------------------------------------*
* Insert following 2 lines for adding lowercase character   *
* set in 99/4A                5/12/81                       *
       SRL  R0,2              Adjust R0 for LOWUP routine   *
       BL   @LOWUP            Translate lowercase to upper  *
*                              if necessary                 *
*-----------------------------------------------------------*
       JMP  CRU06             And resume copy
* Handle single character operators
CRU20  JLT  CRU32             Bit 4: single character oper
       SLA  R0,2              Scan property bits 5 and 6
       JOC  CRU24             If numeric
       JLT  CRU26             If digit only
       CI   R8,QUOTE          Is it a string quote?
       JNE  ERRIVN            No, unknown char so error
       MOV  R7,R10            Yes, save current mode
CRU22  LI   R8,QUOTEZ         Convert char to quote token
       BL   @PUTCHR           Put in token
       LI   R7,CRU68          Set string, copy mode
       MOV  @RAMPTR,R5        Save pointer to length byte
       JMP  CRU06             Continue copy w/quote token
CRU24  CI   R8,'.'            A decimal point
       JNE  CRU26             No, decode as numeric/line #
       LI   R6,CRU96          Yes, decode as numeric
CRU26  B    *R6               Handle numeric or line #
BERRSY B    @CERSYN           Long distance SYNTAX ERROR
CRU27  BL   @PUTCHR           Put out last char before end
       INC  @VARW             Skip last character
* Here for successful completion of scan
CRU28  SWPB R8                Mark end of line with a null
       BL   @PUTCHR           Put the end of line in
CRNADD EQU  $+2
       LI   R0,CRNBUF         Get start of crunch buffer
       NEG  R0                Negate for backwards add
       A    @RAMPTR,R0        Calculate line length
       MOVB @R0LB,@CHAT       Save length for GPL
       BL   @GETSTK           Restore GROM address
       B    *R12              Return with pointer beyond null
* Keyword table scanning routine. Name has already been
* copied into crunch area starting at R9; RAMPTR point just
* beyond name in input line.
* R3 is name length, R1 indexes into the table
CRU32  BL   @BACKUP           Fix pointer for copy(next line)
CRU36  BL   @GETCHR           Read last character
       MOVB R1,*R4            Put into output buffer
       BL   @PUTCHR           Copy into crunch buffer
CRU38  MOV  @RAMPTR,R3        Get end pointer
       S    R9,R3             Sub start to get length of name
       CI   R3,MAXKEY         Is longer than any keyword?
       JH   CRU61             Yes, can't be a keyword
       MOV  R3,R2             Get name length and
       DEC  R2                 corremt 0 length name indexing
       SLA  R2,1              Turn it into an index
       AI   R2,KEYTAB         Add in address of table list
       MOVB R2,@GRMWAX(R13)    Load address to GROM
       SWPB R2
       MOVB R2,@GRMWAX(R13)
       MOVB *R13,R2           Read address of correct table
       MOVB *R13,@R2LB        Both bytes
* R2 now contains the address of the correct table
CRU40  MOVB R2,@GRMWAX(R13)   Load address of table
       MOV  R3,R0             Copy of length for compare
       MOVB @R2LB,@GRMWAX(R13)
       MOVB @R9LB,*R15        Source is in VDP
       A    R3,R2             Address of next keyword in table
       MOVB R9,*R15
       INC  R2                Skip token value
CRU42  CB   @XVDPRD,*R13      Compare the character
       JL   CRU61A            If no match possible
       JNE  CRU40             No match, but match possible
       DEC  R0                Compared all?
       JNE  CRU42             No, check next one
       MOV  R9,@RAMPTR        Name matched so throw out name
       MOVB *R13,*R4          Read the token value
       CLR  @ARG4             Indicate keyword found
* Check for specially crunched statements
       LI   R7,CRU14          Assume a REM statement
       LI   R0,SPECTB-1       Now check for special cases
***********************************************************                    <
* For GRAM KRACKER XB or RichGKXB or SXB substitute with: *                    <
*      CI   R8,>000B                                      *                    <
***********************************************************                    <
       CI   R8,MERGEZ         Is this a command?                               <
       JH   CRU47             No, continue on
       MOV  @FAC,R3           Yes, attempt to put in program?
       JNE  ERRCIP            Yes, *COMMAND ILLEGAL IN PROGRAM*
       CI   R9,CRNBUF         Command 1st token in line?
       JNE  BERRSY            No, *SYNTAX ERROR*
CRU47  INC  R0                Skip offset value
       CB   *R4,*R0+          In special table?
       JEQ  CRU53A            Yes, handle it
       JH   CRU47             If still possible match
***********************************************************                    <
* For GRAM KRACKER XB or RichGKXB or SXB substitute with: *                    <
*      CI   R8,>000C                                      *                    <
***********************************************************                    <
       CI   R8,MERGEZ         A specially scanned command?                     <
       JL   CRU27             Yes, exit crunch
       LI   R0,LNTAB          Now check for line number
CRU48  CB   *R4,*R0+          In table?
       JEQ  CRU52             Yes, change to line # crunch
       JH   CRU48             May still be in table
       CI   R8,COMMAZ         Just crunch a comma?
       JEQ  CRU50             Yes, so retain current numeric
       CI   R8,TOZ            Just crunch a TO?
       JNE  CRU53             No, so reset to normal numeric
CRU50  B    @CRU05            Yes, resume normal copy
CRU52  LI   R6,CRU100         Set line number scan mode
       JMP  CRU50             Set normal scan mode
ERRIVN INC  @ERRCOD           *ILLEGAL VARIABLE NAME
ERRCIP INC  @ERRCOD           *COMMAND ILLEGAL IN PROGRAM
ERRNQT INC  @ERRCOD           *NONTERMINATED QUOTED STING
CBH20  EQU  $+1
ERRNTL A    @C4,@ERRCOD       *NAME TO LONG
       JMP  CRU28             Exit back to GPL
OFFSET EQU  $
CRU53  B    @CRU04            Stmt sep resets to normal scan
CRU53A MOVB *R0,R1            Pick up offset from table
       SRL  R1,8              Make into offset
       B    @OFFSET(R1)       Goto special case handler
* Process a LIST statement
CRU57  BL   @PUTCHR           Put the list token in
       BL   @GETNB            Get next character
       CI   R1,QUOTE*256      Device name available?
       JNE  CRU28             No, no more to crunch, exit
       LI   R10,CRU106        Yes, set after string scan mode
       B    @CRU22            Crunch the device name
* Process an IMAGE statement
CRU54  LI   R10,CRU83B        Image after, string copy mode
       JMP  CRU59             Handle similar to data stmt
* Process a DATA statement
CRU58  LI   R10,CRU83         After-datum skip spaces
CRU59  C    @RAMPTR,@CRNADD   Image & data must be 1st on line
       JNE  JNESY1            If not, error
       LI   R2,CRU84          (non)quote string copy mode
CRU60  LI   R7,CRU80          Now set check-for-quote mode
CRU74  B    @CRU06            And copyin statement token
* Here when don't find something in the keyword table
CRU61  CI   R3,15             Is it longer than name can be?
       JH   ERRNTL            Yes, name to long
CRU61A MOV  @ARG4,R0          Symbol name last time too?
       JNE  JNESY1            Yes, can't have 2 in a row
       DEC  @ARG4             Indicate symbol noe
CRU62  LI   R7,CRU16          No keyword,; leave in CRNBUF
       LI   R6,CRU96          Assume normal numeric scan
CRU64  B    @CRU08            And continue to scan line
* Process a SUB statement
CRU65  MOV  @RAMPTR,R3        Get the current crunch pointer
       DEC  R3                Point at last character put in
       BL   @GETV1            Read it
       CB   R1,@GOZTOK        Was it a GO?
       JEQ  CRU52             Yes, SUB is part of GO SUB
* Process a CALL SUB statement
CRU66  LI   R7,CRU93          Set name copy
       JMP  CRU74             And get next character
CRU32L B    @CRU32
* Now the various mode copy routines; string, names, image,
*  and data statements
CRU68  MOV  R8,R8             Premature end of line?
       JEQ  ERRNQT            Yes, *NONTERMINATED QUOTED STRING
       CI   R8,QUOTE          Reach end of string?
       JNE  CRU74             No, continue copying
       BL   @GETCHR           Get next character
       MOVB R1,R1             Read end of line?
       JEQ  CRU70             Yes, can't be double quote
       CI   R1,QUOTE*256      Is it two quotes in a row?
       JEQ  CRU74             Yes, copy in a normal quote
       BL   @BACKUP           No, backup & rtn to normal scan
CRU70  MOV  R10,R7            Needed for image/data stmts
CRU72  BL   @LENGTH           Calculate length of string
       JMP  CRU64             Resume scan
* Names
*-----------------------------------------------------------*
* Replace following two lines for adding lowercase          *
* character set in 99/4A      5/12/81                       *
*  CRU76  ANDI R0,CPALNM*256    Is this char alpha or digit *
*         JEQ  CRU74            Yes, continue packing       *
CRU76  ANDI R0,CPULNM*256     Is this char alpha (both are  *
*                              upper and lower) or a digit? *
       JNE  CRU78             Yes, continue packing         *
*-----------------------------------------------------------*
*                             No, finish w/name packing
       CI   R8,'$'            Does name end with a $?
       JEQ  CRU32L            Yes, include it in name
       MOVB *R4,*R4           At an end of line?
       JEQ  CRU79             Yes, don't back up pointer
       BL   @BACKUP           Backup for next char
CRU79  B    @CRU38            Jump to name/keyword check
CRU82  B    @CRU22
*-----------------------------------------------------------*
* Add following 2 lines for adding lowercase character set  *
* for 99/4A                   5/12/81                       *
CRU78  BL   @LOWUP            Translate lower to upper if   *
*                              necessary                    *
       JMP  CRU74             Continue packing              *
*-----------------------------------------------------------*
* DATA: Scan spaces after a quoted string datum
CRU83  CI   R8,COMMA          Hit a comma?
       JEQ  CRU85A            Yes, get back into scan
* IMAGE: Scan spaces after a quoted string datum
CRU83B MOVB R0,R0             At a space?
       JLT  CRU64             Yes, ignore it
       MOV  R8,R8             At end of line?
       JEQ  CRU62             Yes, exit scan
JNESY1 JMP  JNESYN            No, unknown character
* DATA: Scan imbedded blanks and check trailing blanks
CRU83A MOV  @VARW,@ARG2       Save input pointer
       BL   @GETNB            Look for next non-blank
       MOVB R1,R1             At end of line?
       JEQ  CRU92             Yes, end string and exit
       CI   R10,CRU83B        Scanning an image?
       JEQ  CRU83C            Yes, commas are not significant
       CI   R1,COMMA*256      Hit a comma?
       JEQ  CRU85             Yes, ignore trailing spaces
CRU83C MOV  @ARG2,@VARW       No, restore input pointer
       JMP  CRU74              and include imbedded space
* DATA: Scan unquoted strings
CRU84  JLT  CRU83A            If hit a space-end of string
       MOV  R8,R8             At end-of-line?
       JEQ  CRU92             Yes, put in length and exit
       CI   R8,COMMA          Reached a comma?
       JNE  CRU74             No, scan unquoted string
       CI   R10,CRU83B        Scanning an IMAGE stmt?
       JEQ  CRU74             Commas are not significant
CRU85  BL   @LENGTH           Yes, end the string
CRU85A LI   R8,COMMAZ         Load a comma token
       INC  @VAR5             Count comma for input stmt
       JMP  CRU60             And resume in string mode
* IMAGE/DATA: Check for leading quote mark
CRU80  JLT  CRU64             Ignore leading separators
       CI   R8,QUOTE          Quotoed string?
       JEQ  CRU82             Yes, like any string, R10 ok
       MOV  R8,R8             End of line?
       JEQ  BCRU28            Yes, end it
       CI   R10,CRU83B        Scanning an IMAGE?
       JEQ  CRU88             Yes, ignore commas
       CI   R8,COMMA          At a comma?
       JEQ  CRU85A            Yes, put it in directly
CRU88  MOV  R2,R7             No, set unquote string copy mode
* IMAGE & DATA: Scan unquoted strings
CRU86  LI   R8,UNQSTZ         Load unquoted string token
       BL   @PUTCHR           Put the token in
       MOV  @RAMPTR,R5        Save current crunch pointer
       BL   @BACKUP           Back up to scan again
CRU87  JMP  CRU74             Resume scan
* CALL and SUB statements
*-----------------------------------------------------------*
* Replace following 2 lines for adding lowercase character  *
* set for 99/4A               5/12/81                       *
*  CRU94 ANDI R0,CPALNM*256     Still an alpha-numeric      *
*        JNE  CRU74             Yes, include in name        *
CRU94  ANDI R0,CPULNM*256     Still an alpha(U & L)-numeric *
       JNE  CRU91             Yes, transfer L to U, then    *
*                              include in name              *
*-----------------------------------------------------------*
       MOV  R8,R8             At end of line?
       JEQ  CRU92             Yes, get out now
CRU90  BL   @BACKUP           No, reset read pointer
CRU92  LI   R7,CRU16          Normal scanning mode
       JMP  CRU72             Calculate & put in string length
*-----------------------------------------------------------*
* Add following lines for adding lowercase character set    *
* for 99/4A                   5/12/81                       *
CRU91  BL   @LOWUP            Transfer lowercase char to    *
*                              uppercase char if necessary  *
       B    @CRU74            Include in name               *
*-----------------------------------------------------------*
* CALL and SUB statements before hit name
CRU93  JLT  CRU64             If a space, ignore it
       MOV  R0,R0             Premature EOL or NIL char, prop?
       JEQ  CERSYN            Yes, *SYNTAX ERROR
*-----------------------------------------------------------*
* Replace following line for adding lowercase character set *
* for 99/4A                   5/12/81                       *
*         ANDI R0,CPALPH*256    An alphabetic to start name?*
       ANDI R0,CPUL*256       An alphabetic (both U & L) to *
*                              start name?                  *
*-----------------------------------------------------------*
       JEQ  CERSYN            No, syntax error
       LI   R7,CRU94          Set up to copy name
       JMP  CRU86             Put in the unqst token
* Numerics
CRU96  LI   R7,CRU98          Set after-initialize scan
       CLR  @ARG              Clear the 'E' flag
       JMP  CRU86             Set up for the numeric
CRU98  MOV  R8,R8             At end of line?
       JEQ  CRU92             Yes end the number
       SLA  R0,2              Scan property bit 2
       JLT  CRU99A            If alpha, might ge 'E'
       SLA  R0,3              Scan property bits 4 and 5
       JNC  CRU99             Bit 4=oper, if not oper, jmp
       MOV  @ARG,R0           If operator, follow an 'E'?
CRU99  CLR  @ARG              Previous char no longer an 'E'
       JLT  CRU87             If still numeric
       JMP  CRU90             No longer numeric
CRU99A CI   R8,'E'            'E' to indicate an exponent?
       JNE  CRU90             No, so end the numeric
       MOV  @ARG,R0           An 'E' already encountered?
JNESYN JNE  CERSYN            Yes, so error
       SETO @ARG              No, indicated 1 encountered now
       JMP  CRU87             And include it in the number
* Line numbers
CRU100 MOV  R8,R8             At end of line?
       JEQ  BCRU28            Yes, exit crunch
       BL   @GETINT           Try to get a line number
       MOV  R0,R0             Get a line number?
       JEQ  CRU105            No, back to normal numeric mode
       LI   R8,LNZ            Load a line number token
       BL   @PUTCHR           Put it out
       MOV  R0,R8             Set up to put out binary #
       SWPB R8                Swap to put MSB of # 1st
       BL   @PUTCHR           Put out 1st byte of line #
       SRL  R8,8              Bare the 2nd byte of line #
       JMP  CRU87             Jump back into it
CRU105 B    @CRU04            Back to normal numeric mode
* Handle a list statement
CRU106 JLT  CRU93             If space, ignore it
       MOV  R8,R8             At end of line?
       JEQ  BCRU28            Yes, exit crunch
       CI   R8,':'            Get a colon?
       JNE  CERSYN            No, *SYNTAX ERROR
       LI   R8,COLONZ         Need to put colon in
       B    @CRU27            And exit crunch
* Error handling routine
ERRLTL INC  @ERRCOD           * LINE TO LONG      3
       DECT @RAMPTR           Backup so can exit to GPL
ERRBLN INC  @ERRCOD           * BAD LINE NUMBER   2
CERSYN INC  @ERRCOD           * SYNTAX ERROR      1
BCRU28 B    @CRU28            Exit back to GPL
* Back up pointer in input line to rescan last character
BACKUP DEC  @VARW             Back up the pointer
       MOVB @VARW1,*R15       Write LSB of address
       NOP
       MOVB @VARW,*R15        Write MSB of address
       LI   R0,>7F00          >7F is an edge character                <<<<<<<<<<
       SB   @XVDPRD,R0        At an edge chracter?
       JEQ  BACKUP            Yes, back up one more
       RT                     And return to caller
* Put a character into the crunch buffer
PUTCHR MOV  @RAMPTR,R1        Fetch the current pointer
       CI   R1,CRNEND         At end of buffer?
       JH   ERRLTL            Yes, LINE TO LONG
       MOVB @R1LB,*R15        Put out LSB of address
       ORI  R1,WRVDP          Enable VDP write
       MOVB R1,*R15           Put out MSB of address
       INC  @RAMPTR           Increment the pointer
       MOVB *R4,@XVDPWD       Write out the byte
       RT                     And return
*-----------------------------------------------------------*
* Move LENGTH to GETNB, becuase CRUNCH is running out of    *
* space, 1/21/81                                            *
* Calculate and put length of string/number into length     *
* byte                                                      *
* LENGTH MOV  R11,R3            Save return address         *
*        MOV  @RAMPTR,R0        Save current crunch pointer *
*        MOV  R0,R8             Put into R8 for PUTCHR below*
*        S    R5,R8             Calculate length of string  *
*        DEC  R8                RAMPTR is post-incremented  *
*        MOV  R5,@RAMPTR        Address of length byte      *
*        BL   @PUTCHR           Put the length in           *
*        MOV  R0,@RAMPTR        Restore crunch pointer      *
*        B    *R3               And return                  *
*-----------------------------------------------------------*
*
* Get a small non-negative integer
* CALL: VARW - TEXT POINTER, points to second character
*       R8   - First character in low byte
*       BL     @GETINT
*       R0   - NUMBER
*       VARW - Text pointer, if there is a number, points to
*               character after number. If there is not a
*               number, unchanged.
*       R8   - 0 in high byte
*       DESTROYS: R1, R2
GETINT MOV  R11,R3            Save return address
       MOV  R8,R0             Get possible digit
       LI   R2,10             Get radix in register for speed
       AI   R0,-'0'           Convert from ASCII to binary
       C    R0,R2             Is the character a digit?
       JL   GETI02            Yes, there is a number!
       CLR  R0                No, indicate no number
       B    *R3               Done, no number
GETI01 MPY  R2,R0             Multiply previous by radix
       MOV  R0,R0             Overflow?
       JNE  ERRBLN            Yes, bad line number
       MOV  R1,R0             Get low order word of product
       A    R8,R0             Add in next digit
       JLT  ERRBLN            If number went negative, error
GETI02 BL   @GETCHR           Get next character
       MOVB R1,*R4            Put into normal position
       JEQ  GETI03            If read end of line
       AI   R8,-'0'           Convert from ASCII to binary
       C    R8,R2             Is this character a digit?
       JL   GETI01            Yes, try to pack it in
       DEC  @VARW             No point to 1st char after number
GETI03 CLR  R8                Clean up our mess
       MOV  R0,R0             Hit a natural zero?
       JEQ  ERRBLN            Yes, its an error
       B    *R3               And return
* The LINE NUMER TABLE
* All tokens which appear in the table must have numerics
* which follow them crunched as line numbers.
LNTAB  BYTE ELSEZ
GOZTOK BYTE GOZ                                                       <<<<<<<<<<
       BYTE GOTOZ
       BYTE GOSUBZ
       BYTE RETURZ
       BYTE BREAKZ
       BYTE UNBRKZ
       BYTE RESTOZ
       BYTE ERRORZ
       BYTE RUNZ
       BYTE THENZ
       BYTE USINGZ
       BYTE >FF               Indicate end of table
       EVEN
*************************************************************
* Table of specially crunched statements                    *
* 2 bytes - special token                                   *
*  Byte 1 - token value                                     *
*  Byte 2 - "address" of special handler                    *
*           Offset from label OFFSET in this assembly of    *
*           the special case handler                        *
*************************************************************
SPECTB BYTE LISTZ,CRU57-OFFSET
       BYTE OLDZ,CRU58-OFFSET
       BYTE SAVEZ,CRU58-OFFSET
       BYTE MERGEZ,CRU58-OFFSET
       BYTE SSEPZ,CRU53-OFFSET
       BYTE TREMZ,CRU74-OFFSET
       BYTE DATAZ,CRU58-OFFSET
       BYTE REMZ,CRU74-OFFSET
       BYTE CALLZ,CRU66-OFFSET
       BYTE SUBZ,CRU65-OFFSET
       BYTE IMAGEZ,CRU54-OFFSET
       BYTE >FF
       EVEN
*
* TRANSFER LOWERCASE CHARACTER TO UPPERCASE CHARACTER
* R0 - Last digit indicates whether this character is a
*       lowercase character
LOWUP  ANDI R0,CPLOW*256      Is lowercase prop set?
       JEQ  LU01              No, just return
       SB   @CBH20,*R4        Change lower to upper
LU01   RT
********************************************************************************
       
       AORG >7FFA
PAGER  CLR  @>6000      * RESTORE PAGE ONE
       B    *R9
********************************************************************************
       END 
 
   
 
  
