**
***  MULTIPLY INTEGER IN (A)  **
**
MPY   NOP           ADDRESS OF MULTIPLIER IN MPY,I
      LDB M2        SET -2 IN
      STB MBY10       SIGN TEMP
      LDB MPY,I     LOAD
      LDB 1,I         MULTIPLIER
      CLE,SSA       (A) NEGATIVE?
      CMA,CME,INA   YES, COMPLEMENT (A) AND (E)
      SSB           (B) NEGATIVE?
      CMB,CME,INB   YES, COMPLEMENT (B) AND (E)
      SEZ           (E) = 0?
      ISZ MBY10     NO, SET SIGN OF RESULT NEGATIVE
      STB NORML     SAVE MULTIPLIER
      LDB M16       SET
      STB MVTOH       COUNTER
      CLB           ZERO PRODUCT
      ELA           BIAS (A) TO LEFT
MPY1  ERA,CLE,SLA   SHIFT, TEST,
      ADB NORML       AND ADD UPON
      ERB               NON-ZERO BIT
      ISZ MVTOH     DONE?
      JMP MPY1      NO
      ERA,CLE       YES, ADJUST FINAL RESULT
      ISZ MBY10     NEGATIVE RESULT?
      JMP MPY2      NO
      CMB           YES,
      CMA,INA,SZA,RSS  COMPLEMENT
      INB                RESULT
MPY2  CLO
      ISZ MPY
      JMP MPY,I
**
***  FIND AND STORE ONE-CHARACTER OPERATORS  **
**
SYMCK NOP           CHARACTER IN (A)
      STB COUNT     -(ENTRIES TO BE SEARCHED)
      ALF,ALF       POSITION
      IOR .32         CHARACTER
      LDB SYMCK,I   STARTING TABLE ENTRY - 2
      ISZ SYMCK     SET RETURN ADDRESS
SYMC1 ADB .2        UPDATE TABLE POINTER
      CPA 1,I       MATCH?
      JMP SYMC2
      ISZ COUNT     NO, CONTINUE SEARCH?
      JMP SYMC1     YES
      ALF,ALF       NO, RESTORE
      AND B177        CHARACTER
      JMP SYMCK,I       AND EXIT
SYMC2 CCA           GET
      ADA 1           INFORMATION
      LDA 0,I           WORD
      AND OPMSK           AND
      STA SBPTR,I           STORE IT
      CPA B1400
      JMP FSC1A,I
      ISZ SYMCK     RETURN VIA
      JMP SYMCK,I     (P+2)
**
***  FIND CALLED SUBROUTINE  **
**
FNDSB NOP
      STB TEMP2     SAVE SUBROUTINE NUMBER
      LDB ASBTB     LOAD (B) WITH SUBROUTINE TABLE
FNDS1 CPB SBTBE     END OF TABLE?
      JSB ERROR     YES
CALER LDA 1,I       NO, EXTRACT
      AND .63         SUBROUTINE NUMBER
      CPA TEMP2     DESIRED ONE?
      JMP FNDSB,I   YES
      ADB .2        NO, MOVE TO
      JMP FNDS1       NEXT TABLE ENTRY
      SPC 5
*               ************************************************
*               SUBROUTINE TO COMPUTE THE STORAGE REQUIRED BY AN
*               ARRAY WHOSE PACKED DIMENSIONS ARE IN A UPON ENTRY
*               ************************************************
*
*               THE SUBROUTINE RETURNS IN A THE NUMBER OF LOCATIONS
*               REQUIRED FOR THE SPECIFIED DIMENSIONS
*               = 2*DIM1*DIM2
*
MDIM  NOP
      STA 1         STORE PACKED DIMS. TEMPORALILY
      AND MSK0
      STA .FLUN     STORE # OF COLUMNS
      LDA 1
      ALF,ALF
      AND MSK0      A = # OF ROWS
      ALS           DOUBLE FOR FLOATING POINT
      JSB MPY
      DEF .FLUN     COMPUTE 2*ROWS*COLUMNS
      SSA           RESULT < 32768 ?
      JSB ERROR     NO, ERROR DIMENSIONS TOO LARGE
MER9  JMP MDIM,I    YES, RETURN
      SKP
**
***  ROUND A SUBSCRIPT TO AN INTEGER  **
**
*
*  RETURNS INTEGER IN (1,32767) (BIASED BY -1)
*  OR EXITS TO ERROR.
*
SBFIX NOP           SUBSCRIPT IN (A) AND (B)
      JSB IFIX      24-BIT INTEGER?
      JMP E6M1A,I   NO
      SEZ,RSS       YES, ROUND AND
      ADB M1          BIAS BY -1
      SZA,RSS       15-BIT
      SSB             POSITIVE INTEGER?
      JMP E6M1A,I   NO
      JMP SBFIX,I   YES
**
***  INTEGERIZE FLOATING POINT NUMBER  **
**
IFIX  NOP
      STO
      STA GETCR     SAVE (A)
      JSB .FLUN     EXPONENT
      SSA             NON-NEGATIVE?
      JMP IFIX3     NO
      ADA M16       YES, EXPONENT
      SSA             <= 15?
      CLO           YES
      ADA M8        EXPONENT
      SSA,RSS         <= 23?
      JMP IFIX,I    NO, ALL SIGNIFICANCE IS INTEGER
      ADA M8        MOVE BINARY POINT TO END OF (B)
      STA .FLUN     SAVE SHIFT COUNT
      LDA GETCR     RETRIEVE (A)
      JMP IFIX2
IFIX1 CLE,SLA,ARS   SHIFT (A) RIGHT
      CME           SHIFT (B)
      SLB,ERB         RIGHT
      STO           NOTE IF A 1 IS LOST
IFIX2 ISZ .FLUN     DONE?
      JMP IFIX1     NO
      ISZ IFIX      YES
      JMP IFIX,I
IFIX3 LDA GETCR     RETRIEVE (A)
      CLE,SSA       TRUNCATE
      CCA,RSS         TO
      CLA,RSS           -1
      CCB,RSS             OR
      CLB                   0
      JMP IFIX2+2
      SKP
**
***  TAKE ARITHMETIC INVERSE  **
**
ARINV NOP           NUMBER IN (A) AND (B)
      STA OUTLN     SWAP
      LDA 1
      LDB OUTLN       REGISTERS
      CMB,CLE       COMPLEMENT HIGH PART
      XOR M256      COMPLEMENT LOW PART
      ADA B400      ADD IN 1
      SEZ,RSS       OVERFLOW?
      JMP ARIN2     NO
      INB           YES, INCREMENT HIGH MANTISSA
      CPB FLGBT     OVERFLOW?
      JMP ARIN1     YES
      CPB UNNRM     NO, NEGATIVE UNNORMALIZED?
      RSS           YES
      JMP ARIN2     NO
ARIN1 ADB UNNRM     FIX HIGH MANTISSA
      SLA,RAR       POSITION EXPONENT
      IOR MSK4      FILL IN BITS IF NEGATIVE
      SSB,RSS       POSITIVE?
      INA,RSS       YES, BUMP EXPONENT
      ADA M1        NO, DECREMENT EXPONENT
      RAL           POSITION
      AND MSK0        EXPONENT
ARIN2 STA OUTLN     SWAP
      LDA 1
      LDB OUTLN       REGISTERS
      JMP ARINV,I
**
***  UNPACK LOW WORD OF NUMBER  **
**
.FLUN NOP           WORD IN (B)
      LDA 1         (A) = (B)
      AND MSK0      EXTRACT EXPONENT IN (A)
      CMB           SUBTRACT OFF
      ADB 0           EXPONENT FROM
      CMB               MANTISSA IN (B)
      SLA,RAR       NEGATIVE EXPONENT?
      IOR MSK4      YES, FILL IN LEADING BITS
      JMP .FLUN,I   NO
**
***  STACK (B) ON LOW-CORE STACK  **
**
SLWST NOP
      ISZ LSTPT     ADVANCE 'LOW
      LDA LSTPT       STACK' POINTER
      CPA HSTPT     STACK OVERFLOW?
E1    JSB ERROR     YES
      STB LSTPT,I   NO, STACK (B)
      JMP SLWST,I
      SKP
**
***  BUMP HIGH STACK POINTER  **
**
BHSTP NOP
      CCB           ADVANCE
      ADB HSTPT
      STB HSTPT       POINTER
      CPB LSTPT     OVERFLOW?
      JMP E1        YES
      JMP BHSTP,I   NO
**
***  FETCH TOP OF STACK  **
**
STTOP NOP
      JSB OPCHK     VALIDATE
      JSB RSCHK       OPERAND
      LDB HSTPT,I   SAVE
      LDA 1,I       LOAD
      INB
      LDB 1,I         NUMBER
      JMP STTOP,I
**
***  VERIFY LEGITIMACY OF OPERAND  **
**
OPCHK NOP
      LDB HSTPT,I   OPERAND ADDRESS TO (B)
      LDA 1,I       HIGH PART OF
      CPA MNEG        OPERAND 100000B?
      INB,RSS       YES
      JMP OPCH1     NO
      LDA 1,I       LOW PART
      CPA MNEG+1      776B?
      JSB ERROR     YES
E8    ADB M1
OPCH1 CPB TSTPT     TEMPORARY OPERAND?
      RSS           YES
      JMP OPCHK,I   NO
      LDA TSTPT     UNSTACK
      ADA M2          THE TEMPORARY
      STA TSTPT         OPERAND
      JMP OPCHK,I   EXIT WITH ADDRESS IN (B)
**
***  ALLOT SPACE FOR INTERMEDIATE RESULT  **
**
RSCHK NOP
      LDA TSTPT     ALLOT
      ADA .2
      STA TSTPT       SPACE
      ADA M1        OVERFLOW INTO
      CPA LSTAK       LOW-CORE STACK?
      RSS           YES
      JMP RSCHK,I   NO
      LDA LSTAK     SAVE
      INA             LOWER
      STA TEMP3         STACK BOUND
      ADA .9        UPDATE
      STA LSTAK       STACK BOTTOM
      LDA LSTPT     SET
      INA             SOURCE
      STA TEMP2         ADDRESS
      ADA .9        UPDATE
      STA LSTPT       STACK TOP
      INA           SET DESTINATION
      STA TEMP4       ADDRESS
      CMA,INA       OVERFLOW
      ADA HSTPT       INTO
      SSA               HIGH-CORE STACK?
      JMP E1        YES
      JSB MVTOH     NO, MOVE
      JMP RSCHK,I     LOW-CORE STACK
**
***  CHECK FOR DIGIT  **
**
DIGCK NOP          CHARACTER IN (A)
      LDB 0
      ADB D72      ASCII 72B
      SSB,RSS        OR GREATER?
      JMP DIGCK,I  YES, RETURN WITH CHARACTER
      ADB .10       NO, ASCII 60B
      SSB            OR GREATER?
      JMP DIGCK,I  NO
      ISZ DIGCK    YES, SET 'SUCCESS' EXIT,
      LDA 1          LOAD DIGIT INTO (A),
      JMP DIGCK,I      AND RETURN
**
***  CHECK FOR LETTER  **
**
LETCK NOP          CHARACTER IN (A)
      LDB 0
      ADB D133     ASCII 133B
      SSB,RSS        OR GREATER?
      JMP LETCK,I  YES, EXIT WITH CHARACTER IN (A)
      ADB .26       NO, ASCII 101B
      SSB,RSS        OR GREATER?
      ISZ LETCK     YES
      JMP LETCK,I  NO
*
*  ON END-OF-FILE CONDITION RETURN TO P+1 ELSE
*  RETURN TO P+2 WITH NON-BLANK CHARACTER IN (A)
*
GETCR NOP
      ISZ CCNT      ANY CHARACTERS LEFT?
      RSS
      JMP GETCR,I   NO, END-OF-FILE EXIT
      LDB BADDR     LOAD BUFFER ADDRESS
      ISZ BADDR     UPDATE FOR NEXT TIME
      CLE,ERB       SET CHARACTER FLAG
      LDA 1,I       LOAD CURRENT BUFFER WORD
      SEZ,RSS       FIRST CHARACTER?
      ALF,ALF       YES, POSITION IT
      AND B177      MASK EXTRANEOUS BITS
      CPA BLANK     BLANK?
      JMP GETCR+1   YES, FETCH NEXT CHARACTER
      ISZ GETCR     UPDATE RETURN ADDRESS
      JMP GETCR,I     AND EXIT
**
***  BACKSPACE OVER ONE CHARACTER  **
**
BCKSP NOP
      CCA          BACKSPACE
      ADA CCNT       OVER
      STA CCNT         LAST
      CCA                CHARACTER IN
      ADA BADDR            INPUT
      STA BADDR              BUFFER
      JMP BCKSP,I
**
***  PRINT A NUMBER  **
**
ENOUT NOP
      CCE           SET SIGN FLAG TRUE
      JSB NUMOA,I   OUTPUT THE NUMBER
      JSB OUTLN     END-OF-LINE ACTION
      LDA .32       OUTPUT
      JSB OUTCR       A BLANK
      LDB MLBX1+1   FIELD
      ADB CCNT
      SZB             FULL?
      JMP *-5       NO
      JMP ENOUT,I
**
***  SPACE FOR A COMMA  **
**
EDELM NOP
      LDB CCNT      NO, LOAD CHARACTER COUNT
EDEL1 SZB,RSS       ZERO?
      JMP EDELM,I   YES
      ADB M15       NO, SUBTRACT ZONE WIDTH
      SSB,RSS       NEGATIVE RESULT?
      JMP EDEL1     NO
      STB OUTLN     YES, SAVE BLANK COUNT
      LDA .32       FETCH BLANK
      JSB OUTCR     OUTPUT
      ISZ OUTLN
      JMP *-3         BLANKS
      LDB CCNT      LINE
      ADB M76
      SSB,RSS         FULL?
      JSB OUTLN     YES
      JMP EDELM,I
      SKP
**
***  OUTPUT A COMPLETED LINE  **
**
OUTLN NOP
      LDA TYPE      FETCH 'CHARACTERS PRINTED' COUNT
      SLA           CORRECT FOR START ON
      INA             ODD PRINT POSITION
      ADA CCNT      OUTPUT
      LDB .BUFA       A
      JSB WRITE,I       LINE
      LDB MLBX1+1   CORRECT
      ADB CCNT
      STB MLBX1+1     MARKER
      CLA           RESET COUNT OF
      STA TYPE        CHARACTERS PRINTED
      JSB PRNIA,I   CLEAN UP
      JMP OUTLN,I
**
***  ADD A CHARACTER TO OUTPUT BUFFER  **
**
OUTCR NOP           CHARACTER IN (A)
      STA IFIX      SAVE CHARACTER
      ISZ CCNT      COUNT IT
      LDB CCNT      FIRST CHARACTER
      SLB             OF BUFFER WORD?
      ISZ BADDR     YES, MOVE TO FRESH WORD
      LDA BADDR,I   LOAD BUFFER WORD
      SLB           SAVE
      ALF,ALF         OTHER
      AND M256          CHARACTER
      IOR IFIX      ADD NEW CHARACTER
      SLB           POSITION
      ALF,ALF         WORD AND
      STA BADDR,I       STORE IT
      JMP OUTCR,I
*
*
TEMP  EQU TEMPS+1
TEMP1 EQU TEMPS+2
TEMP2 EQU TEMPS+3
TEMP3 EQU TEMPS+4
TEMP4 EQU TEMPS+5
COUNT EQU TEMPS+6
STEMP EQU TEMPS+4
MANT1 EQU SYMCK
MANT2 EQU MDIM
EXPON EQU LETCK
DPFLG EQU BCKSP
ARYAD EQU OUTCR
EOL   EQU CONST
FINBP EQU *         FIRST UNUSED WORD OF BASE PAGE
      HED BASIC INTEPRETER CONTROL
*
***************  BASIC INTERPRETER CONTROL *************************
*
*   THIS PROGRAM INTERPRETS THE SYSTEM COMMANDS AND PROVIDES
*     I/O  CONTROL FOR THE BASIC INTERPRETER. ALL USER
*     COMMUNICATION IS DONE THRU THIS PROGRAM. USER RESPONSES ARE
*     CHECKED FOR SYSTEM COMMANDS AND IF A VALID COMMAND IS
*     DETECTED  THIS PROGRAM INITIATES APPROPRIATE ACTION.
*
      ORG 2000B
*
*  DATA LOCAL TO MONITOR
*
RDYA  DEF READY
READY ASC 2,READ
      OCT 54415
LFEED DEF LF
QMRKA DEF QMARK
STOPA DEF STCMD
CMNDA DEF CMNDS
*
ENTRY CLC 0,C       STARTING POINT, TURN OFF ALL I/O
      STF 0         TURN ON INTERRUPT SYSTEM
      LDA LWBM      LOADED
      CPA LWAM        BY 'BOSS'?
      JMP FLUSH     NO
      STA LWAM      YES, RESET
      INA             POINTER
      STA SYMTA         VALUES
*
FLUSH LDA FWAM
      STA PBUFF     SET PROGRAM BUFFER ADDRESS
      STA PBPTR     SET PROGRAM BUFFER POINTER
      LDA .32       INITIALIZE
      STA BLANK       DELETE CHARACTER FOR GETCR
      CLA           SET LINE NUMBER
      STA .LNUM       TO 0 INITIALLY
*
RDYPT LDA TLSTR     SET TO
      STA LISTR       COMMAND MODE
      CLA
      STA DRQST     CLEAR DATA REQUEST FLAG
      STA TFLAG     CLEAR PHOTO READER INPUT FLAG
      STA TTYFL     CLEAR TTY TAPE FLAG
      JSB WRITE,I   DO A RETURN AND LINE FEED.
      LDA M6
      LDB RDYA
      JSB WRITE,I   PRINT *READY* ON TTY
*
PEXMK LDA TLSTR     SHIFT TO
      STA LISTR       COMMAND MODE
      LDA TFLAG
      SZA           IS TAPE FLAG SET?
      JMP PTAPE+1   YES, GET RECORD FROM PHOTO RDR
      SKP
DATAI LDB LFEED     LOAD ADDRESS OF LINE FEED
      STB RSYM      STORE ADDRESS OF READY SYMBOL
      LDA TTYFL     TTY TAPE
      SZA             INPUT?
      JMP GTRCD     YES, SUPPRESS LINE FEED
      CCA           NO
      LDB RSYM      LOAD LF OR '?' ADDRESS
      JSB WRITE,I   PRINT LF OR '?', NO CR-LF
*
GTRCD JSB IMOFF,I   TURN OFF KEYBOARD INTERRUPT MODE
      LDA .72
      LDB .BUFA
      JSB REED,I    GET RECORD FROM TTY
      CPA M2
      JMP RBOUT     RUBOUT IN RECORD, INPUT AGAIN
*
RPRCS CMA,SSA,RSS   SET A=-1-# CHARS AND CHECK FOR
      JSB ERROR     RECORD TOO LONG
RTLE  STA CCNT      -1-# CHARACTERS < 0,SET CCNT
      LDA .BUFA     LOAD BUFFER ADDRESS
      CLE,ELA       SHIFT LEFT,LEAST BIT USED AS
      STA BADDR      ODD/EVEN FLAG
      JSB GETCR     FETCH FIRST CHARACTER
      JMP DATAI     NULL RECORD, INPUT AGAIN
      LDB DRQST
      SZB,RSS       DATA REQUEST?
      JMP CKRCD     NO DATA REQUEST,GO CHECK RECORD
      CPA S         ASCII S  FIRST CHARACTER?
      JSB STOP      ASSUME STOP REQUESTED
      CLA           LINE
      JSB WRITE,I     FEED
      JSB BCKSP     BACKSPACE
      LDA RMODE     RETURN TO
      STA LISTR       RUN MODE
      LDB DRQST
      CLA
      STA DRQST     CLEAR DATA REQUEST FLAG
      JSB IMON,I    DATA REQUEST,TURN ON INTRPT MODE
      JMP 1,I       GO TO DATA REQUEST CALLING POINT
*
      ASC 1,\
      DEF *-1
RBOUT LDB *-1       OUTPUT 'X' WITH
      CLA,INA         CARRIAGE RETURN
      JSB WRITE,I       AND LINE FEED
      JMP GTRCD
*
*  THIS SECTION REQUESTS DATA INPUT
*
DRQST NOP           EXIT/ENTRY AND FLAG
      LDB TLSTR     SHIFT TO
      STB LISTR       COMMAND MODE
      LDB QMRKA
      JMP DATAI+1   PRINT '?' AND WAIT
      SKP
*
*  THIS SECTION CHECKS RECORD FOR SYSTEM COMMANDS.
*
CKRCD LDB SBUFA
      STB SBPTR     INITIALIZE SYNTAX BUFFER POINTER
      STA SBPTR,I   PUT FIRST CHAR IN SYNTAX BUFFER
      JSB LETCK     IS CHARACTER A LETTER
      JMP SYNTX     NO, TRY SYNTAX
*
      LDA TBLAD     LOAD SYS CMND TABLE START POINT
      LDB M8        LOOK FOR A
      JSB TSRCH,I     SYSTEM COMMAND
      JSB ERROR     NOT A VALID COMMAND
*
INVSC EQU *         INVALID CMND ERROR REFERENCE
*
      ALF,ALF       ENTRY FOUND
      ARS           MOVE JMP ADDR TO LEAST BITS POS.
      ADA CMNDA     ADD START ADDR. OF CMND ROUTINES
      STA STOP      SAVE (A)
      CLA           OUTPUT
      JSB WRITE,I     A CR-LF
      JMP STOP,I    EXECUTE COMMAND
      SKP
*
*  THIS SETS UP AND EXECUTES THE SYSTEM COMMANDS
*
CMNDS EQU *        COMMAND LIST REFERENCE
*
RUN   JSB IMON,I    TURN ON TTY INTERRUPT MODE
      JMP RUNA,I    GO TO RUN ENTRY POINT
*
SCRTH JMP FLUSH     SCRATCH CURRENT PROGRAM
*
TLIST LDA TLSTR     LIST PROGRAM, TFLAG = 0
      CLB,RSS
*
PLIST LDA PLSTR     PUNCH PROGRAM, TFLAG # 0
      STA LISTR     SET DRIVER ADDRESS
      STB TFLAG     SET DEVICE FLAG
      JSB IMON,I    TURN ON TTY INTERRUPT MODE
      JMP LISTA,I   GO TO LIST ENTRY POINT
*
PTAPE JSB IMON,I    PTAPE COMMAND
      LDA .72
      LDB .BUFA
      JSB PREAD,I   GET RECORD FROM PHOTO READER
      CPA M2        END OF TAPE?
      JMP EOTR      YES,GO SEE IF START OR END
      CPA M3        PHOTO READER READY?
      JSB ERROR     NO
PRERR SZA,RSS       YES
      JMP PTAPE+1   NULL RECORD
      STA TFLAG     SET FLAG # 0
      JMP RPRCS     GO PROCESS RECORD
*
EOTR  LDB TFLAG
      SZB,RSS       START OR END OF TAPE?
      JMP PTAPE+1   START
      JMP RDYPT     GO TO READY POINT
*
*   STOP COMMAND SERVICE
*
STOP  NOP
      JSB IMOFF,I   TURN OFF KEYBOARD INTERRUPT MODE
      LDB TLSTR     SHIFT TO
      STB LISTR       COMMAND MODE
      LDA MNEG
      INA,SZA
      JMP *-1       DELAY FOR 100 MILLISECONDS
      JSB WRITE,I   CARRIAGE-RETURN LINE-FEED
      LDA .4
      LDB STOPA
      JSB WRITE,I    PRINT *STOP*
      JMP RDYPT
      SKP
*
**  SET LINE FEED SUPPRESSION
*
TAPE  STA TTYFL     SET TO 'TAPE' MODE
      JMP GTRCD
*
**  RETURN TO 'BOSS' EXECUTIVE
*
BYEC  CLA
      JMP 77B
