ASMB,R
      HED <<RTE BASIC - MAIN CONTROL>>        92065-16001 
      NAM BASIC,3,90 92065-16001 REV.2001  791019 
* 
*     DATE 5-13-77
* 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977.  ALL RIGHTS    *
* RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- *
* PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH-  *
* OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.  *
**************************************************************
* 
* 
*     SOURCE:    92065-18001
* 
* 
************************************************************* 
* 
      ENT FINDV,ERRPT,DRQST,GETCR,OUTCR,BCKSP,LETCK 
      ENT PRMT,REED,WRITE,PEXMK,RDYPT,OUTER,INTCK,KEYBD 
* 
* 
*     EXT DBUG
* 
* 
      ENT DIGCK,FNDPS,OUTIN,ENOUT,NUMOT 
      ENT PRNIN,OUTLN,NUMCK,SSYMT,MVTOH,RUN,COMND 
      ENT PLIST,LOADT,INDCK,.IENT,OLNCK 
      EXT REIO,.FLUN,EXEC 
      EXT MVNAM,FILRD,FILWR,CLFIL 
      EXT BASC5,BASC3,BASC2 
* 
      EXT ..FCM,.PACK,RMPAR,BASC1 
      COM TEMPS(30),PNTRS(61),SPEC(10)
**************************************
*                                    *
*        BASIC MAIN CONTROL          *
*                                    *
**************************************
* 
*  THIS PART OF THE INTERPRETER REMAINS CORE RESIDENT DURING
*    THE EXECUTION OF BASIC. IT INTERPRETS AND EXECUTES ALL 
*    OF THE SYSTEM COMMANDS BY LOADING THE APPROPRIATE SEGMENT
*    AND TRANSFERRING EXECUTION TO IT. UPON COMPLETION, THE 
*    SEGMENTS RETURN EXECUTION TO THIS PROGRAM.IN ADDITION, IT
*    PROVIDES FOR ALL USER COMMUNICATION WITH THE INTERPRETER.
*    THERE ARE 8 SEGMENTS WHICH MAY CALLED BY THE MAIN CONTROL: 
* 
*      SEGMENT #1: CHECKS SYNTAX AND TRANSLITERATES CODE
*      SEGMENT #2: LISTS THE PROGRAM
*      SEGMENT #3: CHECKS THE PROGRAM PRIOR TO EXECUTION
*      SEGMENT #4: EXECUTES THE PROGRAM 
*      SEGMENT #5: EXECUTES COMMANDS
*      SEGMENT #6: EXECUTES MORE COMMANDS 
*      SEGMENT #8: EXECUTES NON-TIME DEPENDENT STATEMENTS 
* 
* 
*   TO RUN BASIC USE: 
* 
*      *ON,BASIC,CONSOLE LU,LIST LU,INPUT LU,OUTPUT LU, ERROR LU
* 
*         OR
* 
*      *ON,BASIC,NA,ME,XX,CONSOLE LU,LIST LU
* 
*         WHERE:  NAMEXX =  THE COMMAND FILE NAME 
* 
*************************** 
*                         * 
* CONSTANTS AND VARIABLES * 
*                         * 
*************************** 
* 
FWAM  EQU PNTRS     FIRST WORD OF AVAILABLE MEMORY
LWBM  EQU PNTRS+1   LAST WORD OF AVAILABLE MEMORY 
.INBF EQU PNTRS+2   INPUT BUFFER ADDRESS
SBUFA EQU PNTRS+3   SYNTAX BUFFER ADDRESS 
SYMTA EQU PNTRS+4   START OF SYMBOL TABLE 
SYMTF EQU PNTRS+5   END OF SYMBOL TABLE 
PBUFF EQU PNTRS+6   FIRST WORD OF USER PROGRAM
PBPTR EQU PNTRS+7   LAST WORD+1 OF USER PROGRAM 
INBFA EQU PNTRS+8   INPUT BUFFER POINTER
ICCNT EQU PNTRS+9   INPUT CHARACTER COUNT 
SBPTR EQU PNTRS+10  SYNTAX BUFFER POINTER 
.LNUM EQU PNTRS+11  CURRENT LINE #
FCORE EQU PNTRS+12  START OF FREE CORE
MNNAM EQU PNTRS+13  MNEMONIC TABLE NAME:SC:LU 
BRNAM EQU PNTRS+18  BRANCH TABLE NAME:SC:LU 
FWAMM EQU PNTRS+23  POINTER TO START OF MNEMONIC TABLE
FWAMB EQU PNTRS+24  POINTER TO START OF BRANCH TABLE
.OTBF EQU PNTRS+25  POINTER TO OUTPUT BUFFER 
OCCNT EQU PNTRS+26  OUTPUT CHARACTER COUNT
OTBFA EQU PNTRS+27  POINTER INTO OUTPUT BUFFER
LUOUT EQU PNTRS+28  CURRENT OUTPUT L.U. # 
LUINP EQU PNTRS+29  CURRENT INPUT L.U. #
SIGN  EQU PNTRS+30  SIGN OF CURRENT NUMBER
BLANK EQU PNTRS+31  CURRENT TERMINATION CHAR
REC#  EQU PNTRS+32  COMMAND FILE RECORD NUMBER
FLTYP EQU PNTRS+33  TYPE 0 FILE FLAG
TTYPR EQU PNTRS+34  CONSOLE TTY L.U. #
PRINT EQU PNTRS+35  LISTING L.U. #
READR EQU PNTRS+36  AUXILLIARY INPUT L.U. # 
PUNCH EQU PNTRS+37  AUXILLIARY OUTPUT L.U. #
ERTTY EQU PNTRS+38  ERROR LIST OUTPUT L.U. #
FLFIL EQU PNTRS+39  FILE SAVERSTORE FLAG
FILBK EQU PNTRS+40  FILE CONTROL BLOCK ADDRESS
PFLAG EQU PNTRS+41  SAVE,LOAD FILE FLAG 
LOLIM EQU PNTRS+42  LOW LIMITS OF PROGRAM 
HILIM EQU PNTRS+43  HIGH LIMITS OF PROGRAM
LORUN EQU PNTRS+44  LOW RUN LIMITS
HIRUN EQU PNTRS+45  HIGH RUN LIMITS 
SLSTM EQU PNTRS+46  EXECUTE SLOW STMTS
LOTRC EQU PNTRS+47  LOW TRACE LIMITS
HITRC EQU PNTRS+48  HIGH TRACE LIMITS 
BRKP1 EQU PNTRS+49  BREAK POINT #1
BRKP2 EQU PNTRS+50  BREAK POINT #2
BRKP3 EQU PNTRS+51  BREAK POINT #3
BRKP4 EQU PNTRS+52  BREAK POINT #4
SMFLG EQU PNTRS+53  SIMULATE FLAG 
TYPE  EQU PNTRS+54  PARTIAL LINE CHARACTER COUNT
DLMTR EQU PNTRS+55  CHAR EDIT DELIMITER 
MERGF EQU PNTRS+56  MERGE FLAG
COMN  EQU PNTRS+57  COMMAND FILE NAME 
SYFLG BSS 1         SYNTAX SEGMENT FLAG 
TEMPT BSS 15
* 
RDYA  DEF READY 
QMRKA DEF QMARK 
ACKNA DEF ACKNW 
      SPC 1 
      SUP PRESS MULTIPLE LISTING
      SPC 1 
.2    DEC 2 
.3    DEC 3 
.4    DEC 4 
.9    DEC 9 
.12   DEC 12
.15   DEC 15
.32   DEC 32
.9999 DEC 9999
B77   OCT 77
B700  OCT 700 
MSK   OCT 177400
M1    DEC -1
M2    DEC -2
M4    DEC -4
M7    DEC -7
M14   DEC -14 
M80   DEC -80 
MSK3  EQU M7
* 
QMARK ASC 1,?_                              : 
ACKNW ASC 1,>_                              : 
READY OCT 6412
      ASC 6,BASIC READY 
      SKP 
**********************
*                    *
* BASIC MAIN CONTROL *
*                    *
**********************
BASIC NOP           ENTRY 
* 
      JSB RMPAR     FETCH LOGICAL 
      DEF *+2         UNIT NUMBERS
      DEF TTYPR 
      LDA .9999     SET FLAG TO 
      STA PFLAG       TO ENABLE BASIC INIT. 
      JSB BASC3     .INIITALIZE CODE
      HLT 01
       SPC 1
RDYPT LDA TTYPR     SET UP
      STA LUOUT       INPUT AND 
      STA LUINP         OUTPUT DEVICE UNITS 
      LDB 1717B     GET 
      ADB .12         CURRENT 
      LDA 1,I           PROGRAM 
      STA READY+1         NAME
      INB                   AND 
      LDA 1,I                 STORE 
      STA READY+2               IN
      INB                         THE 
      LDA 1,I                       READY 
      AND MSK                         MESSAGE 
      ADA .32 
      STA READY+3 
      LDA M14       PRINT 
      LDB RDYA        THE BASIC'S 'NAME'
      JSB WRITE         AND 'READY' 
*     JSB DBUG
*     DEF *+1 
      JMP PRMT      PROMPT! 
      SPC 1 
*  EXECUTION RETURNED HERE FROM SEGMENT #1
      SPC 1 
* 
*  PFLAG MAY HAVE THE FOLLOWING VALUES: 
* 
*     PLFAG = -1  INPUT FROM TAPE 
*     PFLAG = 0   INPUT FROM KEYBOARD 
*     PFLAG = 1   INPUT FROM PROGRAM FILE 
*     PFLAG = 2   INPUT FROM SPECIFIED LU # 
*     PFLAG = 3   LOAD B&M TABLE FLAG 
*     PFLAG = 4   INPUT FROM COMMAND FILE 
*     PFLAG = 5   RUN A PROGRAM BY NAME 
*     PFLAG = 9999 EXECUTE INITIALIZATION IN SEG 3(ONCE ONLY) 
* 
PEXMK LDA PFLAG 
      SZA           IS TAPE FLAG SET? 
      JMP MORTP     GET RECORD FROM PHOTO RDR 
* 
*  EXECUTION RETURNED HERE FROM SEGMENTS #5 AND #6
* 
PRMT  LDA TTYPR     INITIALIZE
      STA LUOUT       INPUT AND 
      STA LUINP         OUTPUT DEVICES UNITS
      CLA,INA       INITIALIZE
      STA LOLIM       LOW LIMIT 
      STA LORUN 
      LDA .9999     INITIALIZE
      STA HILIM       HIGH LIMIT
      STA HIRUN 
      CLA 
      STA DRQST     CLEAR DATA REQUEST FLAG 
      STA PFLAG     CLEAR TAPE INPUT FLAG 
      STA SYFLG     CLEAR SYNTAX SEGMENT FLAG 
      STA MERGF     CLEAR OUT MERGE FLAG
      CCA           SET FOR 
      STA FLTYP       NO TYPE 0 I-O 
      LDA M2
      LDB ACKNA 
      JSB WRITE     PRINT '>' WITH NO CR-LF 
      JMP GTRCD     INPUT RECORD
      SPC 1 
*  PROCESS DATA REQUEST 
      SPC 1 
DRQST NOP 
      LDA LUINP     IS THIS 
      JSB KEYBD     .  A KEYBOARD DEVICE ?
      JMP GTRCD     NO
      LDA M2
      LDB QMRKA 
      JSB WRITE     PRINT '?' AND WAIT
      SPC 1 
*  INPUT RECORD FROM TTY
      SPC 1 
GTRCD LDA M80 
      LDB .INBF 
      JSB REED      GET RECORD FROM TT˙˙
      SPC 1 
*  PROCESS RECORD 
      SPC 1 
RPRCS CMA           SET A = -1˙˙# CHARS 
      STA ICCNT     SET CHAR COUNT
      STA TEMP8     SET FOR ERROR PRINT OUT 
      LDB .INBF     LOAD BUFFER ADDRESS 
      CLE,ELB       SHIFT LEFT,LEAST BIT USED AS
      STB INBFA      ODD/EVEN FLAG
      INA,SZA,RSS   NULL RECORD ? 
      JMP GTRCD       YES, INPUT AGAIN
      LDB DRQST 
      SZB,RSS       DATA REQUEST? 
      JMP RPRC0     NO DATA REQUEST,GO CHECK RECORD 
      CLA 
      STA DRQST     CLEAR DATA REQUEST FLAG 
      JMP 1,I         AND FAKE THE RETURN THRU DRQST
      SPC 1 
*  LOAD SYNTAX SEGMENT AND BRANCH TO IT 
      SPC 1 
RPRC0 JSB GETCR     GET FIRST CHARACTER 
       JMP GTRCD      UNLESS THERE ISN'T ONE
CKRCD LDB SBUFA     INITIALIZE SYNTAX 
      STB SBPTR       BUFFER POINTER
      STA 1,I       PUT FIRST CHAR IN SYNTAX BUFFER 
      CPA DLMTR     LIST NEXT LINE COMMAND? 
      JMP COMND     YES, LIST IT! 
      JSB LETCK     IS THIS A LETTER? 
      JSB BASC1     .GO TO SYNTAX CHECKERE
      JMP COMND     YES, GO TO COMMAND PHASE
* 
* 
      SKP 
*  EXECUTION RETURNED HERE WHEN ERROR OCCURS
*    SET FOR PRINTING ERROR MESSAGE 
      SPC 1 
OUTER CCA           SET L.U. NEGATIVE FOR FLAG
      STA LUOUT       TO INDICATE ERROR MESSAGE 
      JMP PLIST     BRANCH TO LIST SEGMENT
      SPC 1 
*  EXECUTION RETURNED HERE AFTER PRINTING ERROR MESSAGE 
*    SET FOR LOADING SYNTAX SEGMENT AGAIN 
      SPC 1 
ERRPT CLA          CLEAR SYNTAX SEGMENT FLAG
      STA SYFLG 
      STA PFLAG       AND FILE FLAG 
      INA           SET FOR END 
      STA REC#        OF COMMAND FILE INPUT 
      JMP PEXMK     GO WAIT FOR INPUT 
*  PROCESS SYSTEM COMMANDS
      SPC 1 
*  LOAD COMMAND SEGMENT 
      SPC 1 
*     COMES HERE THROUGH SYNTAX SEGMENT (A) CONTAINS FIRST
*     CHARACTER OF COMMAND
* 
COMND CLB           CLEAR SYNTAX FLAG 
      STB SYFLG 
      JSB BASC5     .CALL COMMAND PROCESSOR 
      SPC 1 
*  PROCESS 'RUN' COMMAND
      SPC 1 
RUN   JSB BASC3     .CALL EXECUTE PROCESSOR 
      SPC 1 
      SPC 1 
*  PROCESS 'SAVE' & 'LIST' COMMAND
      SPC 1 
PLIST JSB BASC2     .CALL LIST & SAVE PROCESSOR 
      SPC 1 
*  PROCESS 'LOAD' COMMAND 
      SPC 1 
LOADT LDA READR     SET L.U. TO READER
      LDB PFLAG           .LU  SPECIFIED? 
      CPB .2
      RSS           .OR "RUN FROM" ?
      CPB .5
      LDA LUINP     .YES DO NOT CHANGE LUINPUT
      STA LUINP 
      AND B77       ISOLATE L.U. #
      IOR B700       M˙˙GE IN FUNCTION CODE 
      STA LENTH       SAVE IT 
      JSB EXEC      CALL EXEC 
      DEF *+3 
      DEF .3         TO SET EOT BIT 
      DEF LENTH 
* 
MORTP LDA M80 
      LDB .INBF 
      JSB REED      GET RECORD FROM READER
      CPA M2        END OF TAPE?
      JMP LOAD0     .CHECK FOR RUN FROM COMMAND 
      SZA,RSS 
      JMP MORTP     NULL RECORD 
      JMP RPRCS     GO PROCESS RECORD 
* 
LOAD0 LDA FLFIL     .CHECK FOR FILE INPUT 
      INA,SZA,RSS 
      JSB CLFIL     .YES - CLOSE THE FILE 
      LDA PFLAG 
      CPA .5        .RUN ?
      JMP RUN       .YES EXECUTE PROGRAM
      JMP RDYPT     .NO PROMPT
* 
*********************** 
*                     * 
* UTILITY SUBROUTINES * 
*                     * 
*********************** 
* 
*  THE FOLLOWING SUBROUTINES ARE USED BY THE SEGMENTS OF THE
*    BASIC INTERPRETER AND THEREFORE ARE CORE RESIDENT. THEY
*    ARE DEFINED IN THE SEGMENTS AS BEING EXTERNAL. 
* 
* 
******************************* 
*                             * 
* INDIRECT CHECK              * 
*                             * 
******************************* 
* 
INDCK NOP           CHASE INDIRECT CHAIN
      RSS            AND RETURN DIRECT POINTER IN A 
      LDA 0,I         GO ANOTHER LEVEL
      RAL,CLE,SLA,ERA     SKIP IF NOT INDIRECT
      JMP *-2 
      JMP INDCK,I   REAL ADDRESS, EXIT
* 
********************
*                  *
* 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 
* 
.26   DEC 26
D72   OCT -72 
D133  OCT -133
******************* 
*                 * 
* 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 
      SKP 
***************************** 
*                           * 
* ADD CHAR TO OUTPUT BUFFER * 
*                           * 
***************************** 
OUTCR NOP           CHARACTER IN (A)
      STA TEMP4     SAVE CHARACTER
      ISZ OCCNT     COUNT IT
      LDB OCCNT     FIRST CHARACTER 
      SLB             OF BUFFER WORD? 
      ISZ OTBFA     YES, MOVE TO FRESH WORD 
      LDA OTBFA,I   LOAD BUFFER WORD
      SLB           SAVE
      ALF,ALF         OTHER 
      AND M256          CHARACTER 
      IOR TEMP4     ADD NEW CHARACTER 
      SLB           POSITION
      ALF,ALF         WORD AND
      STA OTBFA,I       STORE IT
      JMP OUTCR,I 
******************************
*                            *
* GET CHAR FROM INPUT BUFFER *
*                            *
******************************
GETCR NOP 
      ISZ ICCNT     ANY CHARACTERS LEFT?
      RSS 
      JMP GETCR,I   NO, END-OF-FILE EXIT
      LDB INBFA     LOAD BUFFER ADDRESS 
      ISZ INBFA     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
* 
B177  OCT 177 
M256  DEC -256
*************************** 
*                         * 
* BACKSPACE OVER ONE CHAR * 
*                         * 
*************************** 
BCKSP NOP 
      CCA          BACKSPACE
      ADA ICCNT      OVER 
      STA ICCNT        LAST 
      CCA                CHARACTER IN 
      ADA INBFA            INPUT
      STA INBFA              BUFFER 
      JMP BCKSP,I 
      SKP 
***************************** 
*                           * 
*  INITIALIZE FOR NEW LINE  * 
*                           * 
***************************** 
* 
PRNIN NOP 
      CCA           INITIALIZE
      ADA .OTBF       BUFFER
      STA OTBFA         POINTER 
      CLA           INITIALIZE
      STA OCCNT       CHARACTER COUNTER 
      JMP PRNIN,I 
      SPC 1 
************************* 
*                       * 
* OUTPUT COMPLETED LINE * 
*                       * 
************************* 
OUTLN NOP 
      LDA OCCNT     OUTPUT
      LDB .OTBF       A 
      JSB WRITE         LINE
      JSB PRNIN     CLEAN UP OUTPUT BUFFER
      STA TYPE      RESET PARTIAL LINE COUNTER
      JMP OUTLN,I 
* 
* 
***************************** 
*                           * 
*  CHECK FOR LINE OVERFLOW  * 
*                           * 
***************************** 
* 
*                     AT ENTRY, A = NUMBER OF CHARACTERS
*                                    TO BE OUTPUT, EXCLUSIVE
*                                    OF TRAILING BLANKS.
*                     THIS ROUTINE CHECKS FOR LINES OVER 72 
*                     CHARACTERS, AND OUTPUTS THEM BEFORE 
*                     FIGURING THE END OF FIELD FOR NUMERIC 
*                     FORMATTING.  THE END OF FIELD COLUMN
*                     NUMBER IS RETURNED IN TEM10.
* 
OLNCK NOP 
      STA BCKSP     SAVE REQUEST LENGTH TEMPORARILY 
      ADA OCCNT     FIGURE LENGTH OF BUFFER 
      ADA TYPE      FIGURE COLUMN OF RESULT 
      CMA,INA 
      ADA .80       TOO MANY CHARACTERS ? 
      SSA 
      JSB OUTLN       YES, OUTPUT LINE FIRST
      LDA BCKSP     RECOVER REQUEST LENGTH
      ADA OCCNT       AND FIGURE
      ADA .3            THE END-OF-FIELD
      STA TEM10           COLUMN NUMBER 
      JMP OLNCK,I 
* 
.80   DEC 80
      SKP 
******************************* 
*                             * 
*  FIND OUT THE  DEVICE TYPE  * 
*                             * 
******************************* 
* 
*  ON INPUT (A) = LU NUMBER 
*  ON EXIT  (A) = DVR NUMBER
*           (B) = SUBCHANNEL #
* 
FINDV NOP 
      STA SLU       .SET UP STATUS EXEC CALL
      JSB EXEC      .  TO FETCH EQUIP TYPE CODE 
      DEF FIND1     .   AND SUBCHANNEL NUMBER 
      DEF .13 
      DEF SLU 
      DEF EQT5
      DEF EQT4
      DEF SBCHN 
* 
FIND1 LDA SBCHN     .FETCH SUBCHANNEL AND 
      AND MSK0      .  REMOVE DOWN BIT
      LDB 0         .LEAVE IN B REG 
      LDA EQT5
      ALF,ALF       .FETCH EQUIP TYPE CODE
      AND B77 
      JMP FINDV,I 
* 
.13   DEC 13
SLU   NOP 
EQT5  NOP 
EQT4  NOP 
SBCHN NOP 
* 
* 
********************************
* 
*     DETERMINE IF LU# IS KEYBOARD DEVICE 
* 
*        A(ENTRY) IS LU#
*        ON EXIT A UNCHANGED
*           EXIT P+1 NOT A KEYBOARD DEVICE
*           EXIT P+2 IS A KEYBOARD DEVICE 
* 
******************************* 
* 
KEYBD NOP 
      STA KEY1      .SAVE LU #
      AND B77       .STRIP OFF CONTROL BITS 
      JSB FINDV     .ISOLATE LU#
      CPA .5        . IS IT DVR05 ? 
      JMP KEY2      .CHECK FOR CTU OR PRINTER 
      SZA           .IS IT DVR00? 
      JMP KEYBD,I   .NO EXIT P+1
KEYS  ISZ KEYBD 
      LDA KEY1      .RESTORE LU # 
      JMP KEYBD,I 
KEY2  SZB,RSS       .IS IT THE DISPLAY? 
      JMP KEYS      .YES
      JMP KEYBD,I 
KEY1  NOP 
.5    DEC 5 
MSK0  OCT 377 
      SKP 
********************
*                  *
* FIND A STATEMENT *
*                  *
********************
* 
* UPON ENTRY (A) = SEQUENCE NUMBER  TO BE FOUND. IF (A) 
* IS LARGER THAN ANY SEQUENCE NUMBER IN THE PROGRAM, EXIT 
* TO (P+1) WITH (B) POINTING TO LAST WORD+1 OF THE PROGRAM
* IF (A) FALLS BETWEEN TWO SEQUENCE NUMBERS, EXIT TO (P+2)
* WITH (B) POINTING TO THE STATEMENT WITH THE LARGER SEQUENCE 
* NUMBER. IF A STATEMENT IN THE PROGRAM HAS THE SEQUENCE
* NUMBER THEN EXIT TO (P+3) WITH (B) POINTING TO THIS STATEMENT.
* 
FNDPS NOP 
      STA TEMP3     SAVE SEQUENCE NUMBER
      LDB PBUFF     STARTING ADDRESS
FNDP1 CPB PBPTR     END OF PROGRAM? 
      JMP FNDP4     YES, EXIT VIA (P+1) 
      LDA TEMP3     SUBTRACT PROGRAM
      CMA,INA         SEQUENCE NUMBER FROM
      ADA 1,I         S-BUFFER SEQUENCE NUMBER
      SZA,RSS       EQUAL?
      ISZ FNDPS     YES, SET EXIT TO (P+3)
      SSA,RSS       NO, P-SEQ NO > S-SEQ NO ? 
      JMP FNDP3     YES, SET EXIT TO (P+2)
      LDA 1         POINT (A) TO
      INA             PROGRAM ADDRESS INCREMENT 
      ADB 0,I       COMPUTE NEW ADDRESS 
      JMP FNDP1 
FNDP3 ISZ FNDPS 
FNDP4 STB TEMP3     SAVE STATEMENT ADDRESS
      JMP FNDPS,I 
***************************** 
*                           * 
* MOVE WORDS TO HIGHER CORE * 
*                           * 
***************************** 
MVTOH NOP 
      LDB TEMP2     FETCH SOURCE ADDRESS
MVTO1 CPB TEMP3     ALL RELOCATION DONE?
      JMP MVTOH,I   YES, EXIT 
      CCA           BACK UP 
      ADB 0 
      ADA TEMP4       SOURCE AND
      STA TEMP4         DESTINATION 
      LDA 1,I       MOVE
      STA TEMP4,I     WORD
      JMP MVTO1 
      SKP 
*********************** 
*                     * 
* SEARCH SYMBOL TABLE * 
*                     * 
*********************** 
* 
*  SSYMT IS CALLED WITH THE IDENTIFIER TO SEARCHED FOR IN 
*  (A).  IT RETURNS WITH THE ADDRESS OF THE MATCHING ENTRY
*  IN (B) OR (B)=-1 IF THERE IS NO MATCHING ENTRY.
* 
*    THE FOLLOWING RULES APPLY WHEN SEARCHING FOR ARRAYS: 
* 
*    1.  TYPE 1 (ONE DIMENSION) SEARCH FOR CORRESPONDING
*    TYPE 1 OR TYPE 3 ARRAY.  IF TYPE  3 IS FOUND CHANGE
*    THE ENTRY TO TYPE 1. 
* 
*    2.  TYPE 2 (TWO DIMENSIONS) SEARCH FOR CORESPONDING
*    TYPES OR TYPE 3 ARRAY.  IF TYPE 3 IS FOUND CHANGE
*    THE ENTRY TYPE TO TYPE 2.
* 
*    3.  TYPE 3 (UNDIMENSIONED) SEARCH FOR CORRESPONDING
*    TYPE 3 OR TYPE 1 OR TYPE 2 ARRAY.
* 
SSYMT NOP 
      STA STEMP    STORE IDENTIFIER 
      AND .15      ISOLATE IDENTIFIER TYPE
      ADA M4
      SSA,INA 
      JMP *+4      JUMP IF ARRAY TYPE 
      LDA STEMP    RESTORE A
      STA 1        STORE IN B 
      JMP SYMT1+3 
      SSA          SKIP IF UNDIMENSIONED
      JMP SYMT1 
      LDA STEMP    RESTORE A
      AND MSK3     177771B SET TYPE TO 1
      STA 1 
      INB          SET TYPE IN B TO 2 
      JMP *+4 
SYMT1 CCB          SET DIMENSIONED FLAG IN B
      LDA .3
      IOR STEMP    SET TYPE TO UNDEFINED
      STA STEMP+1  STORE A
      STB STEMP+2  STORE B
      LDB SYMTF    START OF SYMBOL TABLE
      JMP SYMT4 
SYMT2 LDA 1,I      PICK UP 1ST WORD OF ENTRY
      CPA STEMP    COMPARE WITH IDENTIFIER
      JMP SSYMT,I  MATCH ?  RETURN
      CPA STEMP+1  COMPARE WITH DIFFERENT DIM.
      JMP SYMT3 
      CPA STEMP+2  COMPARE WITH DIFFERENT DIM.
      JMP SYMT3 
      LDA 1,I 
      AND .15      ISOLATE ENTRY TYPE 
      CPA .15      FUNCTION ? 
      JMP *+5      YES
      ADA M4
      SSA          ARRAY ?
      INB          YES INCREMENT POINTER
      INB          INCREMENT POINTER
      ADB .2       ADD 2 TO POINTER 
SYMT4 CPB SYMTA     SYMBOL TABLE EXHAUSTED? ?

      CCB,RSS       YES 
      JMP SYMT2     NO, CHECK NEXT ENTRY FOR MATCH
      LDA STEMP     RETRIEVE SYMBOL 
      JMP SSYMT,I  RETURN WITH B NEGATIVE 
SYMT3 LDA STEMP    RESTORE A
      ISZ STEMP+2  DIMENSIONED IDENTIFIER?
      RSS          NO, SKIP 
      STA 1,I      YES CHANGE 1ST WORD OF ENTRY TO
      JMP SSYMT,I  APPROPRIATE DIMENSION TYPE 
      SKP 
************************* 
*                       * 
* FORMATTER SUBROUTINES * 
*                       * 
************************* 
* 
*  THE FOLLOWING SUBROUTINES ARE USED BY THE SEGMENTS OF THE
*    BASIC INTERPRETER TO PERFORM I/O FORMATTING OPERATIONS.
*    IN GENERAL, THEY PROVIDE FOR ASCII-TO-BINARY AND BINARY- 
*    TO-ASCII CONVERSIONS.
* 
********************
*                  *
*  PRINT A NUMBER  *
*                  *
********************
* 
*  ENTER WITH A FLOATING PT NUMBER IN (A) AND (B). PRINT
*  THE NUMBER AND APPEND BLANKS TO REACH THE PRINT POSITION 
*  SPECIFIED BY TEM10 ON RETURN FROM 'NUMOT'. 
* 
ENOUT NOP 
      CCE           ENABLE SIGN 
      JSB NUMOT     OUTPUT NUMBER 
ENOU0 LDB TEM10     FIELD 
      CMB,INB 
      ADB OCCNT 
      SSB,RSS         FULL? 
      JMP ENOUT,I   YES!
      LDA .32       NO, SO
      JSB OUTCR       OUTPUT A BLANK
      JMP ENOU0         AND TRY AGAIN 
* 
MINFX DEC -0.099999959
MAXFX DEC -999999.5 
NMBFA DEF *+1 
NUMBF BSS 6 
LDVSR DEF *+1 
      DEC 10000 
      DEC 1000
      DEC 100 
.10   DEC 10
M1000 DEC -1000 
      SKP 
************************
**                     *
***  OUTPUT A NUMBER   *
**                     *
************************
* 
*  ENTER WITH A FLOATING POINT NUMBER IN (A) AND (B) AND (E) = 1
*  IF A SIGN IS WANTED.  DETERMINE THE FORM OF THE NUMBER AND 
*  SET TEM10 ACCORDINGLY.  NON-INTEGERS ARE ROUNDED AFTER CONVERSION
*  TO DECIMAL.  TRAILING ZEROS ARE SUPPRESSED ON NUMBERS WITHOUT
*  EXPONENTS. 
* 
NUMOT NOP 
      STA NUMBF     SAVE HIGH MANTISSA
      SEZ,RSS       SIGN? 
      JMP NUMO1     NO
      SSA,RSS       YES, NEGATIVE NUMBER? 
      JMP *+5       NO
      JSB ..FCM     YES, NEGATE NUMBER
      STA NUMBF     SAVE HIGH MANTISSA
      LDA .45       LOAD '-'
      RSS 
      CLA           LOAD '+'
      STA SIGN      SAVE SIGN 
      LDA NUMBF     RETRIEVE HIGH MANTISSA
NUMO1 STB NUMBF+1   SAVE LOW MANTISSA 
      JSB IFIX      INTEGER?
      JMP NUMO2     NO
      SOC           YES, 16-BIT INTEGER?
      JMP NUMO2     NO
*                       * 
**  OUTPUT AN INTEGER  ** 
*                       * 
      STB NUMBF     SAVE INTEGER
      ADB M1000 
      LDA .3
      SSB,RSS       3 DIGIT INTEGER?
      ADA .3        NO, ALL INTEGERS ARE 6 DIGITS OR LESS 
      JSB OLNCK     CHECK FOR LINE OVERFLOW 
      LDA SIGN      YES 
      SZA           SIGN? 
      JSB OUTCR     YES, OUTPUT IT
      LDA NUMBF     NO
      JSB OUTIN     OUTPUT THE INTEGER
      JMP NUMOT,I 
*                                    *
**  OUTPUT A FLOATING POINT NUMBER  **
*                                    *
NUMO2 LDA M2        SET 'FIXED' 
      STA FFLAG       FLAG FALSE
      DLD NUMBF     LOAD NUMBER 
      FAD MAXFX     IS NUMBER 
      SSA,RSS           < 999999.5 ?
      JMP NUMO3     NO
      DLD NUMBF     YES, IS 
      FAD MINFX       NUMBER
*                       LESS THAN 
      SSA,RSS             0.09999995 ?
      ISZ FFLAG     NO, SET 'FIXED' FLAG TRUE 
NUMO3 DLD NUMBF     LOAD NUMBER 
      STA MANT1     UNPACK
      JSB .FLUN 
      STB MANT2       NUMBER
      STA EXP 
      CLA           INITIALIZE
      STA EXPON       DECIMAL EXPONENT
      CPA EXP       ZERO EXPONENT?
      JMP NUMO5     YES 
NUMO0 JSB MBY10     NO
      LDA EXP       MULTIPLY
      CMA,SSA,INA,SZA   NUMBER BY 10
      JMP *+3             UNTIL IT IS 
      ISZ EXPON              GREATER
      JMP NUMO0                 THAN 1
      JSB DBY10     DIVIDE BY 10
      LDA EXPON 
NUMO4 LDB EXP       DIVIDE
      CMB,INB         NUMBER
      SSB,RSS           BY 10 
      JMP NUMO5            UNTIL
      STA EXPON              IT IS
      JSB DBY10                LESS 
      CCA                        THAN 
      ADA EXPON                    1
      JMP NUMO4 
NUMO5 CMA           SET EXPONENT
      STA EXPON       TO TRUE VALUE-1 
      LDB M6        SET DIGIT 
      STB DIGCT       COUNTER 
      LDB NMBFA     SET BUFFER
      STB NMPTR       POINTER 
*                               * 
**  CONVERT MANTISSA TO ASCII  ** 
*                               * 
NUMO6 JSB GETDG     STORE A 
      ADA .48         DECIMAL 
      STA NMPTR,I       DIGIT 
      ISZ NMPTR 
      ISZ DIGCT     SIXTH DIGIT?
      JMP NUMO6     NO
      JSB GETDG     YES,
      ADA M5          NEXT DIGIT
      SSA               >= 5 ?
      JMP NUMO9+1   NO
*                          *
**  ROUND ASCII MANTISSA  **
*                          *
      LDB NMPTR 
NUMO7 ADB M1        LOAD LAST 
      LDA 1,I         DIGIT 
      INA           INCREMENT IT
      CPA .58       WAS IT A 9 ?
      RSS           YES 
      JMP NUMO9     NO
      CPB NMBFA     LEADING DIGIT?
      JMP NUMO8     YES 
      LDA .48       NO, OVERLAY 
      STA 1,I         A 0 
      JMP NUMO7 
NUMO8 ISZ EXPON     BUMP DECIMAL
      NOP             EXPONENT AND
      LDA .49           OVERLAY A 1 
NUMO9 STA 1,I 
      LDA EXPON     IS NUMBER 
      SSA,RSS         LESS THAN 1 ? 
      JMP NMO11     NO
      STA TEMP6     YES 
      LDA .48 
      LDB NMPTR 
NMO10 ISZ TEMP6     COUNT ZEROS 
      NOP             PLUS 1
      ADB M1        LAST
      CPA 1,I         DIGIT 0?
      JMP NMO10     YES 
      LDA TEMP6     NO, ALL SIGNIFICANCE
      SSA             IN SIX DIGITS?
      JMP NMO11     NO
      CCA           YES, SET
      STA FFLAG       'FIXED' FLAG TRUE 
NMO11 LDA .9        COMPUTE 
      ISZ FFLAG       FIELD 
      ADA .3            WIDTH 
      JSB OLNCK     CHECK FOR LINE OVERFLOW 
      LDA SIGN      YES 
      SZA           SIGN? 
      JSB OUTCR     YES, OUTPUT IT
      LDB M7        SET OUTPUT
      STB DIGCT       DIGIT COUNTER 
      LDB NMPTR 
      CCA           FIXED 
      CPA FFLAG       FORMAT? 
      JMP *+5       NO
      LDA EXPON     YES, SET
      CMA             INDICATOR TO
      STA TEMP6         DECIMAL POINT 
      JMP NMO16 
      STA TEMP6     SET INDICATOR FOR DECIMAL POINT 
      JMP NMO14     NO
*                           * 
**  DELETE TRAILING ZEROS  ** 
*                           * 
NMO12 LDA DIGCT     AT RIGHT OF 
      INA             DECIMAL 
      CPA TEMP6         POINT?
      JMP *+6       NO
      STA DIGCT     YES, DELETE ZERO
NMO16 ADB M1        LAST
      LDA 1,I         DIGIT 
      CPA .48           0?
      JMP NMO12     YES 
      CCA           NO, FIXED 
      CPA FFLAG       FORMAT? 
      JMP NMO14     NO
      LDA EXPON     YES, LEADING
      SSA,RSS         DECIMAL POINT?
      JMP NMO14     NO
      STA TEMP6     YES, SET LEADING ZEROS COUNTER
*                     * 
**  OUTPUT MANTISSA  ** 
*                     * 
      LDA .46       OUTPUT A
      RSS             DECIMAL POINT 
NMO13 LDA .48       OUTPUT
      JSB OUTCR       A ZERO
      ISZ TEMP6     MORE LEADING ZEROS? 
      JMP NMO13     YES 
      ISZ DIGCT     NO, COUNT DECIMAL POINT 
NMO14 LDB NMBFA     SET 
      STB NMPTR       DIGIT POINTER 
      JMP *+5 
NMO15 ISZ TEMP6     DECIMAL POINT NEXT? 
      JMP *+3       NO
      LDA .46       YES, LOAD IT
      JMP *+3 
      LDA NMPTR,I   LOAD NEXT 
      ISZ NMPTR       DIGIT 
      JSB OUTCR     OUTPUT CHARACTER
      ISZ DIGCT     MORE DIGITS?
      JMP NMO15     YES 
      ISZ FFLAG     NO, EXPONENT? 
      JMP NUMOT,I   NO
*                         * 
**  OUTPUT THE EXPONENT  ** 
*                         * 
      LDA E 
      JSB OUTCR     OUTPUT AN 'E' 
      LDA .45       OUTPUT
      LDB EXPON 
      SSB             AN
      CMB,INB,RSS 
      LDA .43           EXPONENT
      STB EXPON 
      JSB OUTCR           SIGN
      LDA EXPON 
      CLB           COMPUTE 
      DIV .10 
      ADA .48         EXPONENT'S
      ADB .48 
      STB EXPON         10'S DIGIT
      JSB OUTCR     OUTPUT IT 
      LDA EXPON     OUTPUT
      JSB OUTCR       1'S DIGIT 
      JMP NUMOT,I 
      SKP 
********************* 
*                   * 
* OUTPUT AN INTEGER * 
*                   * 
********************* 
OUTIN NOP           INTEGER IN (A)
      LDB M4        SET DIGIT 
      STB DIGCT       COUNTER 
      LDB LDVSR     SET DIVISOR 
      STB TEMP7       ADDRESS 
      CLB           SUPPRESS
      STB TEMP6       ZEROES
OUTI1 DIV TEMP7,I   DIVIDE INTEGER
      STB TEMP5       CURRENT DIVISOR 
      CPA TEMP6     LEADING ZERO? 
      JMP OUTI2     YES!
      ADA .48       NO, TURN OFF
      STA TEMP6       ZERO SUPPRESSION
      JSB OUTCR     OUTPUT DIGIT
OUTI2 CLB 
      LDA TEMP5     RETRIEVE REMAINDER
      ISZ TEMP7     SET FOR NEXT DIVISOR
      ISZ DIGCT     ALL DIVISOR USED? 
      JMP OUTI1     NO! 
      ADA .48       YES, OUTPUT 
      JSB OUTCR       LAST DIGIT
      JMP OUTIN,I 
* 
.43   DEC 43
.45   DEC 45
.46   DEC 46
.48   DEC 48
.49   DEC 49
.58   DEC 58
E     OCT 105 
M5    DEC -5
M6    DEC -6
* 
******************************
*                            *
* ASCII-TO-BINARY CONVERSION *
*                            *
******************************
NUMCK NOP           CHARACTER IN (A), SIGN SETE
      CLB 
      STB EXP       ZERO
      STB MANT1       ALL 
      STB MANT2         COMPONENTS
      STB EXPON           OF NUMBER 
      STB TEMP3     SET 'NUMBER' FLAG FALSE 
      CCB           SET 'DECIMAL POINT' 
      STB DPFLG       FLAG FALSE
NUMC1 CPA .46       DECIMAL POINT?
      ISZ DPFLG     YES, SET FLAG TRUE
      JMP NUMC2     NO
      CLA           INITIALIZE POST-DECIMAL DIGIT 
      STA EXPON       DIGIT COUNTER TO ZERO 
      JMP NUMC3+1   FETCH A CHARACTER 
NUMC2 JSB DIGCK     DIGIT?
      JMP NUMC7     NO
      ISZ EXPON     YES, COUNT DIGIT
      ALF,ALF       LEFT-JUSTIFY
      ALF,RAR         DIGIT AND 
      STA TEMP4         SAVE IT 
      JSB MBY10     MULTIPLY PREVIOUS NUMBER BY 10
      LDB EXP 
      SZB           ZERO EXPONENT?
      JMP NUMC4     NO
      LDA .4        YES, SET
      STA EXP         EXPONENT TO 4 
      LDA TEMP4     LOAD
      CLB             NUMBER
NUMC3 JSB NORML     NORMALIZE THE NUMBER
      ISZ TEMP3     SET 'NUMBER OCCURRED' FLAG
      JSB GETCR     ANOTHER CHARACTER?
      JMP NUM12     NO
      JMP NUMC1     YES 
NUMC4 ADB M4        COMPUTE 
      CMB             EXPONENT
      LDA TEMP4         BIAS AND
      STB TEMP4           SAVE IT 
      CLB 
NUMC5 ISZ TEMP4     DIGIT POSITIONED? 
      JMP NUMC6     NO
      CLE           YES, ADD IN 
      ADB MANT2       LOW PART
      CLO               OF NUMBER 
      SEZ           OVERFLOW? 
      INA           YES, BUMP (A) 
      ADA MANT1     ADD IN HIGH PART OF NUMBER
      SOS           OVERFLOW? 
      JMP NUMC3     NO
      CLE,ERA       YES, ROTATE 
      ERB             DOWN AND
      ISZ EXP           BUMP
      NOP                 EXPONENT
      JMP NUMC3 
NUMC6 CLE,ERA       SHIFT 
      ERB             DIGIT 
      JMP NUMC5         RIGHT 
NUMC7 CLB           DECIMAL POINT 
      STB TEMP4 
      CPB TEMP3       OR DIGIT FOUND? 
      JMP NUMCK,I   NO, EXIT VIA (P+1)
      CPA E         YES, 'E' ?
      RSS           YES 
      JMP NUM12     NO, NO EXPONENT PART
      JSB GETCR 
      JMP NUMER 
      CPA .43       '+' ? 
      JMP NUMC8     YES 
      CPA .45       NO, '-' ? 
      CCA,RSS       YES 
      JMP NUMC9     NO
      STA TEMP4     NOTE MINUS SIGN 
NUMC8 JSB GETCR 
      JMP NUMER 
NUMC9 JSB DIGCK     DIGIT?
      JMP NUMER     NO
      STA TEMP3     YES, SAVE IT
      JSB GETCR 
      JMP NUM10     SECOND
      JSB DIGCK       DIGIT?
      JMP NUM10     NO
      LDB TEMP3     YES 
      BLS,BLS       MULTIPLY
      ADB TEMP3       PRIOR DIGIT 
      BLS               BY 10 
      ADA 1         ADD NEW DIGIT 
      STA TEMP3     SAVE EXPONENT 
      JSB GETCR 
      JMP NUM10     THIRD 
      JSB DIGCK       DIGIT?
      RSS           NO
      JMP NUMER     YES 
NUM10 LDA TEMP3     LOAD EXPONENT 
      ISZ TEMP4     POSITIVE? 
      CMA,INA       YES, COMPLEMENT IT
      RSS           NO
NUM12 CLA           CLEAR IF NO EXPONENT PART 
      ISZ DPFLG     DECIMAL POINT?
      ADA EXPON     YES, CORRECT EXPONENT 
      SZA,RSS       ZERO EXPONENT?
      JMP NUM14     YES 
      SKP 
      SSA           NO, NEGATIVE EXPONENT?
      JMP NUM13     NO
      CMA,INA       YES, SET
      STA EXPON       COUNTER 
      JSB DBY10     DIVIDE NUMBER BY 10 
      ISZ EXPON     DONE? 
      JMP *-2       NO
      JMP NUM14     YES 
NUM13 STA EXPON     SET COUNTER 
      JSB MBY10     MULTIPLY BY 10
      ISZ EXPON     DONE? 
      JMP *-2       NO
NUM14 LDA MANT1     YES, LOAD 
      LDB MANT2       NUMBER
      ISZ SIGN      POSITIVE? 
      JMP NUM15     YES 
      CMA           NO, 
      CMB,INB,SZB,RSS   COMPLEMENT
      INA                IT 
NUM15 JSB .PACK     PACK NUMBER INTO (A) AND (B)
EXP   BSS 1           EXPONENT
      ISZ SBPTR 
      STA SBPTR,I   STORE 
      ISZ SBPTR       NUMBER IN 
      STB SBPTR,I       PROPER
      ISZ SBPTR           LOCATION
      JSB BCKSP     FETCH 
      JSB GETCR       FIRST 
      LDA .10           UNUSED CHARACTER
      ISZ NUMCK 
NUMER ISZ NUMCK     RETURN
      JMP NUMCK,I     VIA (P+2) OR (P+3)
      SKP 
*************************************** 
*                                     * 
*  INTEGERIZE FLOATING POINT nUMBER   * 
*                                     * 
*************************************** 
* 
*  ENTER WITH A F.P. NUMBER IN (A) AND (B). IF EXPONENT 
*  EXCEEDS 23, NUMBER HAS INTEGER SIGNIFICANCE  EXIT TO (P+1) 
*  ALL OTHER CASES EXIT TO (P+2) WITH 32 BIT INTEGER RIGHT
*  JUSTIFIED IN (A) AND (B). ON EXIT (O) = 1 IF NUMBER IS EXACTLY 
*  REPRESENTABLE AS 16 BIT INTEGER. IF EXPONENT IS NEGATIVE, TRUN-
*  CATE TO 0 OR -1 APPROPRIATELY AND LET (O) = 1. OTHERWISE RIGHT 
*  JUSTIFY INTEGER AND EXIT WITH LAST BIT LOST IN (E).
* 
IFIX  NOP 
      STO           SET OVERFLOW  FLAG
      STA MANT1     SAVE (A)
      CLA 
      OCT 101050    LSR 8, GET EXPONENT 
      ALF,ALF         IN (A) AND
      BLF,BLF           MANTISSA IN (B) 
      SLA,RAR       NEGATIVE EXPONENT?
      IOR SMASK     YES, PROPAGATE SIGN 
      SSA           EXPONENT NON-NEGATIVE?
      JMP IFIX3     NO, RETURN 0 OR -1
      ADA M16 
      SSA           EXPONENT LESS THAN 16?
      CLO           YES, CLEAR OVERFLOW 
      ADA M8
      SSA,RSS       EXPONENT LESS THAN 24?
      JMP IFIX,I    NO, ERROR EXIT, NO FRACTION 
* 
      ADA M8
      STA MANT2     SAVE SHIFT COUNT
      LDA MANT1     RETRIEVE HIGH MANTISSA
      JMP IFIX2 
* 
IFIX1 CLE,SLA,ARS   LONG RIGHT SHIFT
      CME 
      SLB,ERB 
      STO           SET OVERFLOW IF 1 LOST
IFIX2 ISZ MANT2     DONE? 
      JMP IFIX1     NO, SHIFT SOME MORE 
      ISZ IFIX      DONE, SKIP (P+1)
      JMP IFIX,I    RETURN (P+2)
* 
IFIX3 LDA MANT1     NEGATIVE EXPONENT, RETRIEVE (A) 
      CLE,SSA 
      CCA,RSS       TRUNCATE TO -1 OR 0 
      CLA,RSS 
      CCB,RSS 
      CLB 
      JMP IFIX2+2   SKIP RETURN 
* 
SMASK OCT 77600 
M16   DEC -16 
M8    DEC -8
      SKP 
********************************************* 
*                                           * 
*  SUBROUTINE TO COMPUTE THE ENTIER OF A&B  * 
*                                           * 
********************************************* 
* 
*  ENTER WITH NUMBER IN (A) AND (B). IF EXPONENT > 14 THEN
*  EXIT TO (P+1), ELSE EXIT TO (P+2) WITH THE ENTIER OF THE 
*  ARGUMENT IN (A). 
* 
.IENT NOP 
      JSB IFIX
      JMP .IENT,I   OVERFLOW
      XOR 1         (A) SHOULD BE FULL OF SIGN BITS 
      SSA           (B) SHOULD HAVE A SIGN TOO
      JMP .IENT,I   IT DOESNT, ERROR EXIT 
      CPA 1         IF (A) WAS ZERO 
      JMP *+3         ALL IS OK 
      CMA           IF (A) WAS -1 
      CPA 1 
      ISZ .IENT     ALSO OK, SKIP RETURN
      JMP .IENT,I   LEAVE WITH RESULT IN A AND B. 
      SKP 
********************* 
*                   * 
* FORMAT AN INTEGER * 
*                   * 
********************* 
INTCK NOP           CHARACTER IN (A)
      CLB           STORE 
      STB INTGR       PARTIAL RESULT
INTC1 JSB DIGCK     DIGIT?
      JMP INTC2     NO
      CLO 
      LDB INTGR     MULTIPLY
      ADB 1           PARTIAL 
      ADB 1             RESULT
      ADB INTGR           BY
      ADB 1                 10
      ADB 0         ADD LATEST DIGIT
      SOC           OVERFLOW? 
      JMP INTC3     YES 
      STB INTGR     STORE PARTIAL RESULT
      JSB GETCR     NO, FETCH 
      LDA .10         NEXT CHARACTER
      JMP INTC1 
INTC2 LDB INTGR     ZERO
      SZB,RSS         INTEGER?
      JMP INTC3     YES 
      STB SBPTR,I   NO, RECORD IT 
      LDB INTCK,I   INTEGER 
      LDB 1,I         TOO 
      ADB INTGR         LARGE?
      SSB,RSS 
      JMP INTC3     YES 
      LDB INTGR     NO, 
      ISZ SBPTR       RETURN WITH 
      ISZ INTCK         INTEGER IN (B)
INTC3 ISZ INTCK     SET FOR 'FAIL' RETURN 
      JMP INTCK,I 
      SKP 
*********************** 
*                     * 
* GET DIGIT TO OUTPUT * 
*                     * 
*********************** 
GETDG NOP 
      JSB MBY10     MULTIPLY BY 10
      LDB EXP       GET EXPONENT IN (B) 
      CMB,INB         AS NEGATIVE 
      AND HIMSK     KEEP 5 HIGH BITS OF (A) 
      RAL           NORMALIZE TO BIT 15 
      SSB,INB       ROTATE INTEGER
      JMP *-2         INTO (A)
      AND MSK0      EXTRACT 
      STA TEMP5       DIGIT 
      LDB EXP       ROTATE
      CMB,INB 
      RAR             BACK
      SSB,INB 
      JMP *-2 
      XOR MANT1     REMOVE
      LDB MANT2       DIGIT 
      JSB NORML     NORMALIZE REMAINDER 
      LDA TEMP5     LOAD (A) WITH DIGIT 
      JMP GETDG,I 
**********************************
*                                *
* MULTIPLY UNPACKED NUMBER BY 10 *
*                                *
**********************************
MBY10 NOP 
      LDA MANT1     RETURN ON 
      SZA,RSS         ZERO
      JMP MBY10,I       MANTISSA
      LDB EXP       MULTIPLY
      ADB .3          BY
      STB EXP           8 
      LDB MANT2     LOAD MANTISSA 
      CLE,ERA       DIVIDE
      ERB             BY
      CLE,ERA           4 
      ERB,CLE 
      ADB MANT2     DOUBLE
      SEZ             ADD TO
      INA               PRODUCE 
      ADA MANT1           1.25 * MANTISSA 
      SSA,RSS       CORRECT 
      JMP *+5 
      CLE,ERA         ON
      ERB 
      ISZ EXP           OVERFLOW
      NOP 
      STA MANT1 
      STB MANT2 
      JMP MBY10,I 
      SKP 
********************************
*                              *
* DIVIDE UNPACKED NUMBER BY 10 *
*                              *
********************************
DBY10 NOP           MULTIPLY BY DOUBLE-LENGTH TENTH 
      LDA MANT1     RETURN
      SZA,RSS         ON ZERO 
      JMP DBY10,I       MANTISSA
      LDB M2        ADD EXPONENT OF 
      ADB EXP         'TENTH' TO
      STB EXP           MANTISSA EXPONENT 
      LDA MANT2     JUSTIFY 
      CLE,ERA         LOWER ˙˙NTISSA
      MPY TENTH     MULITPLY BY ONE-TENTH (63416) 
      CLE,ELA       SHIFT 
      ELB,CLE         BACK
      ADA 1         ADD IN LOWER MANTISSA*
      SEZ             TENTH*(2)-16
      INB               AND ROUND 
      STB MANT2           TO 16 BITS
      LDA MANT1     DO
      MPY TENTH       SAME FOR
      CLE                 HIGH
      ADA 1                 MANTISSA
      ADA MANT2     (EFFECTIVELY) SUM 
      SEZ             DOUBLE-LENGTH 
      INB               PRODUCTS
      STB MANT1     EXCHANGE
      STA 1           (A) AND (B) 
      LDA MANT1         REGISTERS 
      JSB NORML     NORMALIZE RESULT
      JMP DBY10,I 
* 
TENTH OCT 63146 
HIMSK OCT 174000
******************************* 
*                             * 
* NORMALIZE (A), (B) AND EXP  * 
*                             * 
******************************* 
NORML NOP 
      STA TEMP3     SET LEFT-SHIFT
      CLA             COUNTER 
      STA FERR          TO ZERO 
      LDA TEMP3 
      SZA,RSS       ON
      SZB             ZERO
      JMP NORM3         CLEAR 
      STA EXP             EVERYTHING
      STA MANT1     STORE 
NORM1 STB MANT2       MANTISSA
      JMP NORML,I       AND RETURN
NORM2 ISZ FERR      COUNT LEFT SHIFTS 
NORM3 CLE,ELB       ROTATE (A) AND
      ELA             (B) LEFT INTO (E) 
      SEZ,SSA,RSS   TWO HIGHEST BITS 0? 
      JMP NORM2     YES, + UNNORMALIZED 
      SEZ,SSA       NO, TWO HIGHEST BITS 1? 
      JMP NORM2     YES, - UNNORMALIZED 
      ERA           SHIFT TO
      ERB,CLE         NORMALIZE MANTISSA
      STA MANT1     NO, 
      LDA FERR      COMPUTE 
      CMA,INA         CORRECTED 
      ADA EXP           EXPONENT
      STA EXP             VALUE 
      LDA MANT1 
      JMP NORM1 
      SKP 
      SPC 3 
TEMP1 EQU TEMPS+2 
TEMP2 EQU TEMPS+3 
TEMP3 EQU TEMPS+4 
STEMP EQU TEMPS+4 
TEMP4 EQU TEMPS+5 
TEMP5 EQU TEMPS+6 
TEMP6 EQU TEMPS+7 
TEMP7 EQU TEMPS+8 
TEMP8 EQU TEMPS+9 
TEMP9 EQU TEMPS+10
TEM10 EQU TEMPS+11
FFLAG EQU TEMPT+1 
DPFLG EQU TEMPT+2 
NMPTR EQU TEMPT+3 
DIGCT EQU TEMPT+4 
FERR  EQU TEMPT+5   FILE ERROR FLAG 
MANT1 EQU TEMPT+8 
MANT2 EQU TEMPT+9 
EXPON EQU TEMPT+10
LENTH EQU TEMPT+11
INTGR EQU TEMPT+1 
      SKP 
******************* 
*                 * 
* I/O SUBROUTINES * 
*                 * 
******************* 
* 
*  THE FOLLOWING SUBROUTINES ARE PRIMARILY USED BY THE BASIC
*    MAIN CONTROL FOR DOING I/O. THE INDIVIDUAL SEGMENTS MAY
*    ALSO CONTAIN SOME SPECIALIZED I/O ROUTINES.
* 
*********************** 
*                     * 
*   PRINT A LINE      * 
*                     * 
*********************** 
WRITE NOP           ENTRY 
      SSA,RSS       IF LENGTH > 0, MAKE 
      CMA,INA        NEGATIVE FOR CHARS 
      STA LENTH       SAVE IT 
      STB WBUF1     SAVE BUFFER ADDRESS 
      LDA FLFIL     .CHECK FOR FILE SAVE-RESTORE
      INA,SZA,RSS 
      JMP WRFIL     .YES- CALL FILE WRITE 
      JSB REIO      RE-ENTRANT I/O
      DEF *+5 
      DEF .2          TO PRINT
      DEF LUOUT 
WBUF1 BSS 1             LINE ON 
      DEF LENTH 
      JMP WRITE,I         TTY 
* 
WRFIL JSB FILWR     .WRITE INTO A FILE
      DEF *+3 
      DEF LENTH     .REQUEST LENGTH 
      DEF WBUF1,I   .BUFFER ADDRESS 
* 
      SSB           .ERROR ?
      RSS           .YES - CLOSE THE FILE 
      JMP WRITE,I   .NO CONTINUE
WR1   JSB CLFIL     .GO TO CLOSE FILE ROUTINE 
      JMP RDYPT     . AND GO HOME 
* 
************************
*                      *
*     READ A LINE      *
*                      *
************************
REED  NOP           ENTRY 
      ADA M1        BUMP CHARACTER COUNT BY ONE TO CHECK FOR
      STA LENTH     LONG INPUT LINES
      STB KBUF1       AND ADDRESS 
      LDA FLFIL     .IS THIS A FILE INPUT?
      INA,SZA,RSS 
      JMP RDFIL     .YES READ A RECORD
      JSB REIO      CALL REIO 
      DEF *+5 
      DEF .1          TO READ A 
      DEF LUINP 
KBUF1 BSS 1             LINE OF ASCII 
      DEF LENTH 
* 
      CPB .81       .CHECK FOR INPUT LINES GREATER
      RSS           .  THAN 81 CHARACTERS. IF LONGER
      JMP CONT      .  PRINT AN ERROR  AND STOP 
REED2 LDA RERLN 
      LDB RERBF 
      JSB WRITE 
      JMP PRMT  
* 
CONT  STA MANT1 
      STB LENTH 
      AND .32       END OF
      SZA               TAPE? 
      JMP REED1     .YES SET EOF INDICATOR
      LDA MANT1     .CHECK FOR EOF STATUS 
      AND B200
      SZA           .YES EOF SET EOF INDICATOR
REED1 LDB M2        YES 
      LDA 1         NO, RETURN WITH 
      JMP REED,I      LENGTH IN (A) 
* 
RDFIL JSB FILRD     . READ A RECORD 
      DEF *+3 
      DEF LENTH 
      DEF KBUF1,I 
      SSB           .AN ERROR ? 
      JMP WR1       .CLOSE FILE - GO HOME 
      CPA .82       .GREATER THAN 80 CHARACTERS ??
      JMP REED2     .YES GENERATE AN ERROR
      CPA M1        .AN EOF ? 
      ADA M1        .YES - SO SET THE FLAG
      JMP REED,I
.1    DEC 1 
B200  OCT 200 
.81   DEC 81
.82   DEC 82
RERBF DEF *+1 
      ASC 16,NUMBER OF CHARACTERS EXCEEDS 80
RERLN DEC -32 
* 
* 
      END BASIC