ASMB,R,Q,C
      HED <<RTE BASIC - PRE-EXEC/SEG #3>>     92076-1X004 REV.2040
      NAM BASC3,5 92076-1X004 REV.2040 800727 92076-16001 
* 
* 
* 
**************************************************************
* (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  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.  *
**************************************************************
* 
* 
*   NAME:   BASC3 
*   SOURCE: 92076-18004 
*   RELOC:  PART OF 92076-16001 
*   PGRM:   B.J.L.
* 
* 
      ENT BASC3,CKOVF 
      EXT FNDPS,SGMNT,OUTER,SSYMT,TRAP,BCKSP,GETCR,DIGCK
      EXT WRITF,CLOSE,RDYPT,SPEC3,COMFL,.SBT
      EXT LIMSG,HPIBT,OPEN,NAMR 
      COM TEMPS(32),PNTRS(81),FILBF(16),FLDCB(144),SPEC(10) 
* 
* PNTRS INCREASED TO 81 800727****
* REMOVED GMS.C, $SISZ, $LOW AND ADDED LIMSG  800626****
*TEMPS INCREASED TO 32  800107**********************
***REMOVED CALLS TO EXEC,OPEN.  ADDED CALL TO NAMR, .SBT 790820** 
*PNTRS INCREASED TO 79   790830***********************************
*PNTRS INCREASED TO 80   791010***********************************
**********************************************
*                                            *
*    SEGMENT #3: PRE-EXECUTION PROCESSING    *
*                                            *
**********************************************
* 
*  THIS PART OF THE INTERPRETER IS LOADED BY THE BASIC MAIN CONTROL 
*    ONCE TO PERFORM BASIC SYTEM INITIALIZATION AND ALSO
*    WHENEVER THE 'RUN' COMMAND IS GIVEN. IT WILL CONSTRUCT THE 
*    SYMBOL TABLE, CHECK FOR-NEXT LOOPS AND DETERMINE ARRAY STORAGE 
*    ALLOCATIONS FOR THE USER PROGRAM. UPON COMPLETION, IT RETURNS
*    TO THE MAIN CONTROL PROGRAM WHICH THENS LOADS THE EXECUTION
*    SEGMENT AND BRANCHES TO IT.
      SKP 
*************************** 
*                         * 
* 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
********CHANGED FOR L USAGE OF GETST 790409************************ 
TTYPR EQU PNTRS+34  CONSOLE TTY L.U. #
TTYP1 EQU PNTRS+35  3RD AND 4TH CHAR
TTYP2 EQU PNTRS+36  5TH AND 6TH CHAR
TTYP3 EQU PNTRS+37  SECURITY CODE OF FILE 
TTYP4 EQU PNTRS+38  CRN # OF FILE 
********************************************************************* 
DCB   EQU PNTRS+39  DATA CONTROL BLOCK ADDRESS
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
*****************************790712******************************** 
COMN  EQU PNTRS+57  COMMAND FILE NAME:SC:CRN
MANT1 EQU PNTRS+62  MANTISSA #1 
MANT2 EQU PNTRS+63  MANTISSA #2 
EXPNT EQU PNTRS+64  EXPONENT
***************************CHANGED 790830*************************
***************************CHANGED 791010*************************
INNAM EQU PNTRS+65  NAME RTN. FROM CRETS (3 WORDS)
INNUM EQU PNTRS+68  SCRATCH FILE # AND COUNTER
HSTPT EQU PNTRS+69  HIGH-STACK POINTER
TSTPT EQU PNTRS+70  TEMPORARY STACK POINTER 
LSTPT EQU PNTRS+71  LOW-STACK POINTER 
LSTAK EQU PNTRS+72  LOW-STACK ADDRESS 
PRADD EQU PNTRS+73  PROGRAM EXECUTION 
DSTRT EQU PNTRS+74  DATA
NXTDT EQU PNTRS+75    STATEMENT 
DCCNT EQU PNTRS+76      POINTERS
NXTST EQU PNTRS+77      NEXT STMT NUMBER 
********MOVED FROM BEHIND TTYPR FOR L 790409***************** 
PRINT EQU PNTRS+78      LISTING LU# 
ERTTY EQU PNTRS+79      ERROR LU# 
TRAPF EQU PNTRS+80  TRAP BUSY FLAG  800727***** 
*******************************790830*****************************
*READR NOP            **REMOVED 790828****
*PUNCH NOP            ***REMOVED 790828*****
******************************************************************* 
      SKP 
TEMPT BSS 15        TEMPORARIES 
* 
ERBS  DEF ERR-1 
MBUF  DEF TEMPS 
FILB  DEF FILBF 
* 
      SUP PRESS MULTIPLE LISTINGS 
      SPC 1 
.0    DEC 0 
.1    DEC 1 
.2    DEC 2 
.3    DEC 3 
.4    DEC 4 
.5    DEC 5 
*.7    DEC 7            ****REMOVED 790820*** 
*.8    DEC 8            ****REMOVED 790820****
.9    DEC 9 
.10   DEC 10
.12   DEC 12
.13   DEC 13
.15   DEC 15
.16   DEC 16
.20   DEC 20
*.26   DEC 26       **REMOVED 790820*********** 
.57   DEC 57
.28   DEC 28      T     ****REMOVED 790820*** 
.30   DEC 30
.32   DEC 32
.33   DEC 33
.34   DEC 34
.37   DEC 37
.43   DEC 43
.45   DEC 45
.63   DEC 63
.128  DEC 128 
.144  DEC 144 
.256  DEC 256 
.400  DEC 400      *ADDED FOR L20*800626**
.9999 DEC 9999
CALOP OCT 50000 
*DATOP OCT 51000         ***REMOVED 790820**********
*RSTOP OCT 55000          ***REMOVED 790820**** 
*B20   OCT 20               ***REMOVED 790820****** 
B54   OCT 54
B63   OCT 63
B65   OCT 65
B67   OCT 67
B72   OCT 72
B377  OCT 377 
*B400  OCT 400                *****REMOVED 790820*****
B757  OCT 757 
B1000 OCT 1000
B777  OCT 777 
*D72   OCT -72              ****REMOVED 790820**********************
HIMSK OCT 177400
MK400 OCT 177377   ******ADD FOR L 790411*****
SLASH OCT 57
STDIM OCT 5001      STANDARD DIMENSIONS FOR ARRAYS
STRDM OCT 400       STANDARD DIMENSIONS FOR STRINGS 
*PRNOP OCT 53000            ***REMOVED 790820************ 
COMOP OCT 34000     COMMON OPERATOR 
FILOP OCT 63000 
OPMSK OCT 77000 
DEFOP OCT 35000 
*INF   OCT 77777            ***REMOVED 790820************ 
STAR  ASC 1,* 
ZERO  ASC 1,0 
M1    DEC -1
M2    DEC -2
M3    DEC -3
M4    DEC -4
M5    DEC -5
M6    DEC -6
*M8    DEC -8               ***REMOVED 790820*************
*M9    DEC -9               ***REMOVED 790820************** 
M16   DEC -16 
M40   DEC -40 
M99   DEC -99 
M256  DEC -256
*M400  DEC -400             ***REMOVED 790820*******************
*M2000 DEC -2000     SIZE OF MNEMONIC TABLE SPACE***REMOVED 790820*** 
MNEG  OCT 100000   MAXIMUM NEGATIVE FLOATING
      OCT 376         POINT NUMBER
********************REMOVED 790820***************************** 
*SGTBA DEF SEG1 
*SEG1  ASC 3,BASC1
*      ASC 3,BASC2
*      ASC 3,BASC3
*      ASC 3,BASC4
*      ASC 3,BASC5
*      ASC 3,BASC6
*      ASC 3,BASC7
*      ASC 3,BASC8
**************************790820**************************************
HOLD  NOP 
HOLD1 NOP 
SEG#  DEC -8
* 
      SKP 
****************************
*                          *
* PRE-EXECUTION PROCESSING *
*                          *
****************************
BASC3 NOP 
* 
***************************************************** 
*                                                   * 
**  BASIC SYSTEM INITIALIZATION - ONCE ONLY CODE   ** 
*                                                   * 
***************************************************** 
* 
      LDA PFLAG     IS THIS AN
      CPA .9999       AN INITIALIZATION?
      RSS           YES!
      JMP PREEX     NO, DO PRE-EXECUTION
* 
*******REMOVE FOR L 790409************* 
*     LDA $OPSY     IS THIS 
*     CPA M9          AN RTE-IV SYSTEM? 
*     JMP RTE4      YES!
****************************************************************
      SPC 1 
*********MOVED FROM JUST BEFORE PREEX 790409******* 
*****************************790710***************************
*******************REMOVED FOR L20  800626****
*     LDA $LOW,I    GET ADDRESS TO SHORT ID SEGS. 
*     ADA .4        AND OFFSET TO FWAM (WORD 5) AFTER 790924
*     STA TEMP1     FIRST SEGMENT.
*AGAIN LDA TEMP1,I   GET FWAM AFTER 
*     STA HOLD      SEG. AND SAVE 
*     CMA,INA       NEGATE FOR TEST 
*     STA HOLD1     SAVE THIS VALUE FOR TEST 2
*     ADA FWAM      IS THE NEW FWAM > THE CURRENT ONE?
*     SSA 
*     JMP FINI      YES, GO REPLACE THE OLD FWAM WITH NEW 
*     LDA HOLD1     NO, TEST FOR 2ND LARGEST FWAM 
*     ADA FWAMM 
*     SSA,RSS 
* 
*     JMP FINI1     NO, GO CHECK FOR MORE SEGS. 
*     LDA HOLD      REPLACE CURRENT FWAMM WITH NEW
*     STA FWAMM 
*     JMP FINI1    *****790924***** 
*FINI  LDA FWAM      MOVE THE LARGEST FWAM TO 2ND LARGEST 
*     STA FWAMM     FWAM
*     LDA HOLD      REPLACE THE OLD FWAM WITH THE NEW 
*     STA FWAM      AND INITIALIZE THE POINTERS 
*FINI1 ISZ SEG#      SEG CNT (-8 INITIALLY) 
*     RSS           STILL SOME LEFT 
*     JMP FINI2     DONE! 
*     LDA TEMP1 
*     ADA $SISZ     GO TO NEXT SHORT ID SEG.
*     STA TEMP1     FOR ADDRESS 
*     JMP AGAIN 
*FINI2 JSB GMS.C     B=LWAM IN BACKGROUND AREA  
*************************************************************** 
*  DEFINE COMPILER BUFFERS AND USER AREA
*************************************************************** 
      SPC 1 
* ADDED NEW CALL TO L20 ROUTINE WHICH IS ALSO IN L10 TO GET 
* THE LONGEST AND 2ND LONGEST SEGMENT.  ALSO PUT IN HOOK FOR  
* NOT RUNNING OUT OF ROOM FOR THE MNEMONIC TABLE. 
*                     800626
****************************************************************
      JSB LIMSG     GO GET THE LONGEST AND 2ND LONGEST
      DEF DEFN      SEGMENT AND LAST WORD AVAILABLE IN    
      DEF FWAM      PARTITIONED AREA. 
      DEF FWAMM     2ND LONGEST 
      DEF LWBM
DEFN  LDA FWAMM     CALCULATE OUT IF ENOUGH ROOM  
      ADA .400      FOR MNEMONIC TABLE
      STA HOLD
      CMA,INA       IF NEEDED SPACE (4 WORDS/ENTRY) 
      ADA FWAM      IS NOT THERE, FOR FWAM USE THE  *800701** 
      SSA,RSS       VALUE OF THE 2ND LONGEST SEGMENT*800701** 
      JMP DEFN1     AND THE SPACE NEEDED.  ELSE USE 
      LDA HOLD      THE VALUE OF THE LONGEST SEGMENT
      STA FWAM
*****************************800626************************************ 
DEFN1 LDB LWBM         **800701** 
      ADB M40       SET 
      STB .INBF       INPUT BUFFER ADDRESS
      ADB M40       SET OUTPUT
      STB .OTBF       BUFFER ADDRESS
      ADB M1        SET SYMBOL TABLE
      STB SYMTA       ADDRESS 
      ADB M99       SET SYNTAX
      STB SBUFA       BUFFER ADDRESS
      ADB M1        SET LAST WORD 
      STB LWBM        BASIC AVAILABLE MEMORY
      CLB           INITIALIZE
      STB SMFLG         AND SIMULATE FLAG 
      STB TYPE
      STB PBPTR 
      STB PBUFF 
      STB FWAMB 
      STB INNUM     INITIALIZE INVOKE SC FILE  790904 
* 
      LDA .32       INITIALIZE
      STA BLANK       DELETE CHARACTER FOR GETCR
      CLA           SET LINE NUMBER TO
      STA .LNUM       ZERO INITIALLY
      STA MNNAM         AND CLEAR MNEM TBL FLAG 
      STA LOTRC           AND TRACE 
      STA HITRC             LIMITS
      STA SMFLG               AND SIM FLAG
      STA BRKP1     CLEAR 
      STA BRKP2       POSSIBLE
      STA BRKP3         PHONY 
      STA BRKP4           BREAKPOINTS 
      STA SLSTM     CLEAR SLOW STMT FLAG
      CCA           INITIALIZE
      STA FLTYP       TYPE 0 FILE 
      LDA SLASH     INITIALIZE CHAR 
      STA DLMTR       EDIT DELIMTER 
      SPC 1 
*  SET LOGICAL UNIT NUMBERS 
      SPC 1 
      CLA,INA       SET UP
      STA REC#        RECORD NUMBER 
********MOVED THIS SETUP TO THE MAIN 790409*********************
*     LDA TTYPR     LOCAL TTY OUTPUT
*     ADA D72       IS THERE A
*     SSA,RSS         COMMAND FILE? 
*     JMP RTESY     YES, JUMP OVER LU SETTINGS
*     LDA TTYPR 
*     SZA,RSS         L.U. # ENTERED? 
*     CLA,INA       NO, SET TO #1 
*     IOR B400      SET ECHO BIT
*     STA TTYPR 
*     LDA ERTTY     LOCAL TTY INPUT 
*     SZA,RSS         L.U. # ENTERED? 
*     LDA TTYPR     NO, SET TO LOCAL TTY
*     STA ERTTY 
*     LDA PRINT     LIST OUTPUT 
*     SZA,RSS         L.U. # ENTERED? 
*     LDA TTYPR     NO, SET TO CONSOLE L.U.#
*     STA PRINT 
*     LDA READR     AUXILLARY INPUT 
*     SZA,RSS         L.U. # ENTERED? 
*     LDA .5        NO, SET TO #5 
*     IOR B400      YES, ADD CONTROL BIT
*     STA READR 
*     LDA PUNCH     AUXILLARY OUTPUT
*     SZA,RSS         L.U. # ENTERED? 
*     LDA .4        NO, SET TO #4 
*     STA PUNCH 
* 
**************REMOVED FOR L 790409*********************************** 
*RTESY LDA $OPSY     RTE-IV?
*     CPA M9
*     JMP READY     (YES, SKIP OVER ID SEG SEARCH)*** 
*     SPC 1 
*     LDA M8        SET UP
*     STA TEMP1       SEGMENT COUNTER 
*NXTSG CLA           INITIALIZE KEYWORD PNTR
*     STA TEMP2       TO START OF KEYWORD TABLE 
*CKSEG LDA TEMP1     GET SEGMENT COUNT
*     ADA .8       FORM POINTER 
*     MPY .3          TO SEGMENT'S ASCII
*     ADA SGTBA         NAME AND SAVE IT
*     STA TEMP3 
*     LDB 1657B     GET START OF KEYWORD TABLE
*     ADB TEMP2       FORM PTR TO I.D. ENTRY
*     LDB 1,I       GET ADDRESS OF I.D. ENTRY 
*     SZB,RSS        END OF TABLE?
*     JSB ERROR       YES - ERROR - EXIT
CERR4 NOP           790924
*     LDA 1,I        GET NAME(1)
*     CPA TEMP3,I     SAME AS SEGMENT? ('BA'?)
*     INB,RSS          YES, MOVE PNTR TO NAME(2)
*     JMP NXTEN         NO, INDEX TO NEXT ENTRY 
*     LDA 1,I       GET NAME(2) 
*     ISZ TEMP3      MOVE NAME POINTER
*     CPA TEMP3,I     SAME AS SEGMENT? ('SC'?)
*     INB,RSS          YES, MOVE PNTR TO NAME(3)
*     JMP NXTEN         NO, INDEX TO NEXT ENTRY 
*     LDA 1,I       GET NAME(3) 
*     AND M256       ISOLATE UPPER CHAR 
*     IOR .32         MERGE IN ASCII BLANK
*     ISZ TEMP3     MOVE NAME POINTER 
*     CPA TEMP3,I    SAME AS SEGMENT? ('1,2,3,4,5,6,7,8'?)
*     JMP *+3         YES, GO CHECK ADDRESSES 
*NXTEN ISZ TEMP2     MOVE PNTR TO NEXT I.D. ENTRY 
*     JMP CKSEG      -GO CHECK I.D. ENTRY 
* 
*     LDA 1,I       TEST FOR SHORT ID SEGMENT 
*     AND B20 
*     ADB .2
*     SZA,RSS       SHORT ID SEGMENT? 
*     ADB .7        NO! 
*     LDA 1,I       GET ADDRESS OF LAST WORD
*     INA             INCREMENT TO GET NEW FWAM 
*     LDB FWAM      GET CURRENT FWAM
*     CMB,INB 
*     ADB 0          IS IT GREATER THAN 
*     SSB             NEW FWAM? 
*     JMP *+4       NO! 
*     LDB FWAM      SET MNEM TBL
*     STB FWAMM       TO NEXT TO LONGEST SEG
*     STA FWAM      SET NEW FWAM TO LONGEST SEG 
*     ISZ TEMP1     INDEX SEGMENT CNTR, IS IT = 0?
*     JMP NXTSG      NO, LOCATE NEXT SEGMENT
* 
************************************************************************* 
*****REMOVED LABEL 'READY' 790820***********************
      LDA FWAM
      STA PBUFF     SET PROGRAM BUFFER ADDRESS
      STA PBPTR     SET PROGRAM BUFFER POINTER
      STA FWAMB 
*******CHANGED FOR L 790411********** 
      LDA TTYPR 
      AND MK400     CHECK FOR COMMAND FILE AGAINST 'PRINT'
      CPA PRINT     IS LOGLU = TTYPR? 
      JMP RDYPT     YES, START UP BASIC 
      JMP COMFL     NO, EXECUTE COMMAND NAMR
************************************************************* 
      SPC 1 
********************************************************************
*SETBR LDA FWAM    *****REMOVE THIS*****
*      ADA M2000   * FOR PCO 1901 
*      STA FWAMM   *
*      JMP READY   *
********************************************************************
* 
      SKP 
* 
* 
******************************************************************* 
*RTE4  JSB EXEC      GET        *****REPLACE FOR 1901 PCO****** 
*     DEF *+5 
*     DEF .26         SIZE OF AVAILABLE MEMORY
*     DEF FWAM
*     DEF TEMP1 
*     DEF TEMP2 
*     LDB FWAM      COMPUTE 
*     ADB TEMP1       LWAM
*     ADB M1        BASKUP TO LAST WORD OF AVAIL MEMORY 
*     JMP DEFN      INITIALIZE POINTERS 
*******MOVED TO BEHIND CHECH FOR INITIALIZATION IN THIS SEG. 790409 
*RTE4  JSB GMS.C     GET FWAM AND LWAM FOR THIS SEG.
*     STA HOLD      SAVE THE RETURNED FWAM VALUE
*     CMA,INA       NEGATE FOR TEST 
*     STA HOLD1     SAVE THIS VALUE FOR TEST 2
*     ADA FWAM      IS THE NEW FWAM > THE CURRENT ONE 
*     SSA 
*     JMP FINI      YES, GO REPLACE THE OLD FWAM WITH NEW 
*     LDA HOLD1     NO, TEST FOR 2ND LARGEST FWAM 
*     ADA FWAMM 
*     SSA,RSS 
*     JMP FINI2     NO, MAKE SURE B=LWAM OF LARGEST 
*     LDA HOLD      REPLACE CURRENT FWAMM WITH NEW
*     STA FWAMM 
*FINI2 LDB TEMP1     B=LWAM OF LARGEST FWAM 
*     JMP DEFN      GO CONTINUE INITIALIZATION OF POINTERS
*FINI  LDA FWAM      MOVE THE LARGEST FWAM TO 2ND LARGEST 
*     STA FWAMM     FWAM
*     LDA HOLD      REPLACE THE OLD FWAM WITH THE NEW 
*     STA FWAM
*     JMP DEFN      AND INITIALIZE THE POINTERS (B=LWAM OF LARGEST) 
**********************************************************************
PREEX JSB SPEC3     PRE-EXECUTION PROCESSING FOR SPEC SYNTAX
      SPC 1 
       JMP OUTER    SPEC SYNTAX ERROR RETURN
* 
***************************790710**************************** 
***REMOVED LABEL 'BAS3' 790820**************************
      JSB HPIBT     CLEAR OUT HPIB TABLE FOR L
***************************790710*****************************
      LDB FILB      INITIALIZE
      STB FILBK       FILE BLOCK PTR
      STB TEMP8 
      LDA PBUFF     NULL
      CPA PBPTR       PROGRAM?
      JMP RDYPT     YES 
      STA MPTR      INITIALIZE PROGRAM POINTER
      LDA M16       INITIALIZE FILE 
      STA TEMP3       BLOCK COUNTERS
      ADA M1
      STA TEMP4 
      CLA           INITIALIZE COMMON 
      STA COML        SIZE TO ZERO
      STA TEMP6         AND ALSO DCB SIZE 
      LDA PFLAG     CHAINED OR
      CPA .2          INVOKE? 
      JMP MLO12      MLO12 YES, SKIP ZEROING OF FILE PTRS 
      LDA TEMP6 
      STA 1,I       INITIALIZE FILE 
      INB             BLOCK TO
      ISZ TEMP3         ALL ZEROS 
      JMP *-3 
* 
*THE FOLLOWING SECTION IS CHANGED TO ALLOW FOR CHECKING OF OVERSIZED
*COMMON AND TOO MANY FILES IN CHAINED/INVOKED PROGRAMS.  ALSO, FOR
*CONDITIONS OF COMMON DECLARATIONS CAUSING MP'S!. 
* 
      STA PAFIL      CLEAR PA'S DCB SIZE
      STA PACOM      CLEAR PA'S COMMON SIZE 
      STA PAFLC      CLEAR PA'S > COMMON SIZE 
      STA PAFLF      CLEAR PA'S > DCB SIZE
* 
MLO12 LDB PBUFF     START OF PROGRAM
MLO10 CPB PBPTR     ALL COMMON
      JMP MLO1A       STMTS CHECKED? *800123* 
      ADB .2        NO
      LDA 1,I       GET NEXT STMT TYPE
      INB 
      AND OPMSK 
      CPA COMOP     COMMON STMT?
      RSS           YES!
      JMP MLO11     NO! 
      LDA 1,I       FETCH COMMON SIZE 
      ADA COML        AND UPDATE
      SSA           IF SET OVERFLOW *800128*
      JMP OVERR     ERROR *800128*
      STA COML          COMMON COUNTER
      STB HOLD      PROTECT THYSELF 
      JSB CKOVF     CHECK OVERFLOW EACH COM STATEMENT 
************************CHANGED 800123******************************
      LDB HOLD
MLO11 ADB M2        STATEMENT SIZE
      ADB 1,I       CALCULATE ADDRESS 
      ADB M1         OF NEXT STATEMENT
      JMP MLO10 
* 
MLO1A LDB PFLAG     IS THIS CHAIN INVOKE
      CPB .2
      RSS           YES 
      JMP MLO14 
      LDA COML      MAKE SURE COMMON LEN. IS IN A *800128*
      CMA,INA        CHECK FOR NEW COMMON SIZE > PA'S 
      ADA PACOM     *800122*
      SSA            IF +, THEN OK
      JMP COMER      IF -, ISSUE SON'S COMMON > PA'S*800205*
      SZA            IF =, SET COMMON FLAG(PAFLC) TO 0
      JMP MLO1B 
      STA PAFLC 
      RSS 
MLO1B ISZ PAFLC      + BUT NOT EQUAL TO 
      JMP ML140 
      SPC 1 
MLO14 LDA COML       SET COMMON SIZE INTO PACOM 
      STA PACOM      IN CASE OF CHAIN/INVOKE LATER
******************************800123********************************* 
ML140 LDB PBUFF     GET START OF PROG 
      CPB PBPTR     END OF PROG?
      JMP MLO15     YES 
      ADB .2        NO, GET 
      LDA 1,I         THE STATEMENT 
      AND OPMSK         OP CODE 
      CPA FILOP     FILES STATEMENT?
      JSB FILES     YES, ALLOCATE DCB FOR IT
      ADB M1        SET 
      ADB 1,I         (B) TO
      ADB M1            NEXT STATEMENT
      JMP ML140+1 
**********************ADDED 800205**********************************
COMER CLA 
      STA .LNUM 
      JSB ERROR 
CERR1 EQU * 
      SPC 1 
MLO15 STB FCORE      SET FOR-TABLE POINTER
      LDA PFLAG      CHECK FOR CHAIN/INVOKE 
      CPA .2         IF SO, GO CHECK FOR # OF FILES 
      JMP ML150      IN PA
      LDA TEMP6      ELSE, SET FILE SIZE INTO PAFIL 
      STA PAFIL      IN CASE OF CHAIN/INVOKE LATER
      JMP ML152      NO CHAIN SO DON'T NEED TO MOVE *800123*
ML150 LDA PAFLC      CHECK FOR PA'S/SON'S COMMON SIZE 
      SZA,RSS 
      JMP ML151      NO,PA/SON EQUAL OR ONLY PROGRAM
      LDA PACOM      MAKE PA'S COMMON SON'S COMMON SIZE 
      STA COML
ML151 LDA PAFLF      CHECK FOR PA'S/SON'S # OF FILES
      SZA,RSS 
      JMP ML152      NO,PA/SON FILES EQUAL OR ONLY PROGRAM
      LDA PAFIL      MAKE PA'S FILE SIZE SON'S FILE SIZE
      STA TEMP6 
ML152 LDA COML      ANY COMMON
***************************800205************************************ 
      ADA TEMP6       OR DCB'S
      INA 
      JSB CKOVF     IS BLOCK TOO BIG? 
      CMA,INA       ALLOCATE COMMON 
      ADA LWBM        NEXT TO DCB'S 
      STA SYMTA     SYM TBL END = COM START -1
      STA SYMTF     SYM TBL START(EMPTY)
      INA 
      ADA TEMP6     OFFSET FOR DCB'S
      STA COML        START OF COMMON 
      SPC 1 
MLOP1 LDB MPTR,I
      STB .LNUM    SET LINE NUMBER
      LDB MPTR
      ISZ MPTR
      ADB MPTR,I   COMPUTE LOCATION OF NEXT 
      STB MNPTR    STATEMENT AND STORE THIS 
      ISZ MPTR
      LDA MPTR,I   FETCH THE FIRST WORD IN THE
      ARS            STATEMENT AND SAVE 
      ALF,ALF       THE STATEMENT TYPE
      AND .63 
      STA TYP 
      CPA .30       NO, REM STATEMENT?
      STB MPTR      YES, SET TO SKIP IT 
      CPA .28       COMMON? 
      ISZ MPTR        YES, SKIP 
      CPA .28           OVER
      ISZ MPTR            SIZE
      CPA B63       NO, FILES STATEMENT?
      STB MPTR      YES, SET TO SKIP IT!
      CPA .43       NO, PRINT STATEMENT?
      STB MPTR      YES, SET TO SKIP IT 
      CPA B65       SPECIAL SYNTAX? 
      STB MPTR      YES, SET TO SKIP
      CPA B67       IMAGE STATEMENT?
      STB MPTR      SET TO SKIP IT
      CCA           NO, SET 
      STA MWDNO       'FIRST VARIABLE'
      JMP MLOP2+1       FLAG
* 
MLO13 AND B777      YES, ISOLATE OPERAND
      LDB MPTR
      CPA B757      IS THIS A USER DEFINED FUNCTION?
      JMP *+4       YES, SO INCREMENT PAST CALL#-PARAMETER COUNT
*                 INDEX THE PROGRAM POINTER BY
      SZA,RSS      AN AMOUNT APPROPRIATE TO THE 
      ADB .2       OPERAND. THE FOLLOWING APPLIES 
      CPA .3       OPERAND = 0  ADD 2 TO POINTER
      INB          OPERAND =3  ADD 1 TO POINTER 
      STB MPTR
* 
      SKP 
*  PROCESS OPERAND
      SPC 1 
MLOP2 ISZ MPTR      INCREMENT WORD-OF-STATEMENT PTR 
      LDA MPTR      STATEMENT 
      CPA MNPTR       EXHAUSTED?
      JMP MLOP5     YES 
      LDA MPTR,I    NO
      AND OPMSK     'QUOTE' 
      CPA B1000       OPERATOR? 
      JMP MLP4A     YES, SET TO SKIP
      CPA CALOP     CALL OPERATOR?
      JMP MLOP2     YES! SKIP 
      LDA MPTR,I    NO
      SSA           'CONSTANT' OPERAND? 
      JMP MLO13     YES 
      AND B777      NO
      SZA,RSS       NULL OPERAND? 
      JMP MLOP2     YES 
      STA MBOX1     NO, SAVE IT 
      AND .15       PROGRAMMER-DEFINED
      CPA .15         FUNCTION? 
      JMP MLOP6     YES 
      ADA M4        NO
      SSA           ARRAY VARIABLE? 
      JMP MLOP7     YES 
      SPC 1 
*  PROCESS SIMPLE VARIABLE
      SPC 1 
      LDA MBOX1     NO, SIMPLE VARIABLE 
      JSB SSYMT     ALREADY IN
      SSB,RSS         SYMBOL TABLE? 
      JMP MLOP3     YES 
      LDA MNEG      NO
      LDB MNEG+1    ENTER 
      STA MBOX1+1     IT WITH 
      STB MBOX1+2       'UNDEFINED' 
      LDA M3              VALUE 
      JSB ESYMT 
MLOP3 LDB TYP 
      LDA MBOX1 
      CPB .34       NEXT STATEMENT? 
      JMP MLOP4     YES 
      SPC 1 
*  PROCESS 'FOR' STATEMENT
      SPC 1 
      CPB .33       NO, FOR STATEMENT?
      ISZ MWDNO     YES, FIRST VARIABLE?
      JMP MLOP2     NO
      ISZ FCORE     DEMAND
      LDB FCORE       SPACE 
      CPB SYMTF         FOR NEW 
      JMP MER8-1          ENTRY 
      STA FCORE,I   SAVE VARIABLE NAME
      JMP MLOP2 
      SPC 1 
*  PROCESS 'NEXT' STATEMENT 
      SPC 1 
MLOP4 LDB FCORE     FOR-TABLE 
      CPB PBPTR       EMPTY?
      JSB ERROR     YES 
MER3  CPA FCORE,I   NO, MATCH LATEST ENTRY? 
      RSS           YES 
      JMP MER3-1    NO
      ADB M1        REMOVE
      STB FCORE       MATCHED 
      JMP MLOP2         ENTRY 
      SPC 1 
      SPC 1 
*  PROCESS 'END' STATEMENT
      SPC 1 
MLP4A XOR MPTR,I    SET POINTER TO
      ADA .3          CLOSING 
      ARS              QUOTES 
      ADA MPTR
      STA MPTR
      JMP MLOP2+1 
      SPC 1 
MLOP5 CPA PBPTR     PROGRAM EXHAUSTED?
      RSS           YES 
      JMP MLOP1     NO
      LDA TYP       YES 
      CPA .37       END STATEMENT?
      JMP M1LOP     YES 
      JSB ERROR     NO
      SPC 1 
*  PROCESS 'DEF' STATEMENT
      SPC 1 
MLOP6 LDA MPTR,I    ISOLATE 
      AND OPMSK       PRECEDING OPERATOR
      CPA DEFOP     'DEF' ? 
      RSS           YES 
      JMP MLOP2    NO GO TO PROCESS NEXT WORD 
      LDA MBOX1    SEARCH SYMBOL TABLE FOR
      JSB SSYMT        THE FUNCTION 
      SSB,RSS 
      JSB ERROR    FOUND. ERROR MULTIPLY DEFINED
MER4  LDA MPTR
      ADA .3       ENTER THE FUNCTION INTO THE
      STA MBOX1+1  SYMBOL TABLE TOGETHER WITH 
      LDA M2       ITS ENTRY POINT IN THE SOURCE
      JSB ESYMT    CODE 
      JMP MLOP2    GO TO PROCESS THE NEXT WORD
      SPC 1 
*  PROCESS ARRAY VARIABLE 
      SPC 1 
MLOP7 CPA M4        IF STRING VARIABLE
      INA             FORCE TO SINGLE DIMENSION 
      STA 1         (B)=ARRAY TYPE
      LDA TYP 
      CPA .57       DIM STATEMENT?
      JMP MLOP8     YES 
      CPA .28       NO, COM STATEMENT?
      JMP MLOP8     YES 
      JSB MSYMT     NO, LOOK FOR IT IN SYMBOL TABLE 
      JMP MLOP2     FOUND 
      CLA           NOT THERE 
      STA MBOX1+1   ENTER IT WITH 
      STA MBOX1+2     DIMENSIONS AND
      STA MBOX1+3       DIMENSIONALITY
      JMP MLOP0           UNDEFINED 
      SPC 1 
*  PROCESS 'COM' AND 'DIM' STATEMENT
      SPC 1 
MLOP8 ISZ MPTR     PROCESS COM OR DIM STMT
      ISZ MPTR
      LDA MPTR,I   PICK UP FIRST DIMENSION
      ALF,ALF      SHIFT TO M. S. PART OF WORD
      CPB M3       IS THIS A SINGLE DIMENSION ARRAY 
      JMP *+5      YES, JUMP
      ISZ MPTR     NO, INDEX POINTER TO THE LOC.
      ISZ MPTR     OF SECOND DIMENSION AND PACK 
      IOR MPTR,I   INTO A WITH THE FIRST DIMENSION
      RSS 
      IOR .1
      STA MBOX1+2  SET UP TO STORE PACKED 
      STA MBOX1+3  DIMENSIONS IN FORMAL AND ACTUAL
      CLA           SLOTS AND UNDEFINED FLAG IN 
      STA MBOX1+1  STORAGE ALLOCATION SLOT
      SPC 1 
      JSB MSYMT     IN SYMBOL TABLE?
      JMP MLOP9     NO
      LDA TYP       YES 
      CPA .28 
      RSS          IS STMT A COM
      JMP MLOP0    NO, JUMP 
      LDA MBOX1+2  YES PICK UP PACKED DIMENSIONS
      JSB MDIM     COMPUTE STORAGE REQUIRED 
      SWP 
      LDA MBOX1     IS IT A 
      AND .15         STRING
      SZA,RSS           VARIABLE? 
      JMP STRM1     YES!
      LDA COML     POINTER TO NEXT FREE LOC IN COM
STRM2 STA MBOX1+1  STORE IN STORAGE ALLOCATION SLOT 
      ADA 1        UPDATE POINTER BY THE AMOUNT OF
      STA COML     STORAGE ASSIGNED.
MLOP0 LDA M4       ENTER THE FOUR WORD ENTRY
      JSB ESYMT    PREVIOUSLY SET UP IN MBOX1 INTO
      JMP MLOP2    SYMBOL TABLE AND CONTINUE
      SKP 
* 
STRM1 BRS           SET UP
      INB             POINTER 
      BRS               FOR STRINGS 
      LDA COML,I    SET UP
      AND B377
      STA COML,I      STRING HEADER 
      LDA MBOX1+2 
      AND M256
      IOR COML,I
      STA COML,I
      LDA COML      INCREMENT 
      INA             TO FIRST WORD OF STRING DATA
      JMP STRM2 
MLOP9 ADB .2        CHECK THE FORMAL DIMENSIONS 
      LDA 1,I      LOCATION TO SEE IF THE DIMENSION 
      SZA           IS ALREADY DEFINED
      JSB ERROR    ERROR, DOUBLY DIMENSIONED
MER5  LDA TYP 
      CPA .28       COM STMT? 
      JSB ERROR     ERROR MISPLACED COM STMT
MER5A LDA MBOX1+2 
      STA 1,I      STORE THESE DIMENSIONS IN FORMAL 
      INB          AND ACTUAL SLOTS IN SYMBOL TABLE 
      STA 1,I      ENTRY
      JMP MLOP2    GO TO PROCESS NEXT WORD
      SPC 1 
*  CHECK FOR UNMATCHED 'FOR' STATEMENTS 
      SPC 1 
M1LOP LDA FCORE     ALL FORS
      CPA PBPTR       MATCHED?
      RSS           YES 
      JSB ERROR     NO
MER6  LDB SYMTF 
      SPC 1 
*  CHECK ARRAY VARIABLE DIMENSIONS
      SPC 1 
M2LOP CPB SYMTA     MORE SYMBOLS? 
      RSS           NO, EXECUTE PROGRAM!
      JMP M7LOP     YES 
      LDA FCORE 
      LDB FCORE 
      ADA .20       ALLOCATE LIST SPACE 
      STA FCORE 
      CLA 
MCLOP STA 1,I         AND CLEAR ALL SLOTS 
      INB 
      CPB FCORE 
       RSS
      JMP MCLOP 
      JSB STNUM     SET UP STATEMENT NUMBER ADDRESSES 
      CLA           ZERO OUT TRAP BUSY FLAG 800727**
      STA TRAPF     800727**
      LDA .1        SET UP TRAP 
      JSB TRAP        TABLE (B)=-1 IF TABLE IS IN USE 
      NOP 
      CPB M1       IS TRAP BUSY? 800727** 
      STB TRAPF     YES,INDICATE FOR SEG 4 800727** 
* 
* 
      LDB .4  
      JMP SGMNT     GOTO SEGMENT #4 
* 
M7LOP LDA 1,I       YES 
      AND .15       ACCOUNT FOR 
      ADB .2          A FUNCTION
      CPA .15       IS IT?
      JMP M2LOP     YES 
      INB 
      SZA,RSS       STRING SYMBOL?
      JMP M5LOP     YES!
      ADA M4        SIMPLE VARIABLE 
      SSA,INA,RSS   IS IT?
      JMP M2LOP     YES 
      SZA,RSS       NO, # OF SUBSCRIPTS KNOWN?
      JSB ERROR     NO
* 
      SKP 
MER10 INA           SAVE
      STA MBOX1+1     FLAG
      STB MBOX1     SAVE POINTER
      LDA 1,I       DEFINED 
      SZA             ARRAY?
      JMP M3LOP     YES 
      LDA STDIM     NO, LOAD
      ISZ MBOX1+1     APPROPRIATE 
      ADA .9            STANDARD DIMENSIONS 
      STA 1,I       RECORD AS 
      ADB M1          FORMAL AND ACTUAL 
      STA 1,I           DIMENSIONS
      SPC 1 
*  ALLOCATE ARRAY STORAGE 
      SPC 1 
M3LOP JSB MDIM      SAVE STORAGE
      STA MBOX1+1     REQUIREMENT 
      LDB MBOX1     LOAD
      ADB M2          ADDRESS OF
      LDA 1,I           ELEMENT SPACE 
      SZA           DEFINED IN COM? 
      JMP M4LOP     YES 
      LDA FCORE     NO, USE CURRENT 
      STA 1,I         FREE-CORE ADDRESS 
      ADA MBOX1+1   UPDATE FREE-CORE
      STA FCORE       ADDRESS 
      CMA,INA       OUT 
      ADA SYMTF       OF
      SSA               SPACE?
      JMP OVERR     YES 
      LDB MBOX1+1     DIMENSIONS TO 
      CMB,INB           'UNDEFINED' 
      ADB FCORE 
M6LOP LDA MNEG
      STA 1,I 
      INB 
      LDA MNEG+1
      STA 1,I 
      INB 
      CPB FCORE     DONE? 
      RSS 
      JMP M6LOP     NO! 
M4LOP LDB MBOX1     ADVANCE POINTER 
      INB             TO NEXT SYMBOL
      JMP M2LOP 
      SPC 1 
*  SET UP STRING SYMBOLS
      SPC 1 
M5LOP LDA 1,I       DEFINED?
      AND M256
      SZA,RSS       DEFINED?
      LDA STRDM     NO, LOAD STANDARD DIMENSIONS
      STA 1,I 
      ADB M1
      STA 1,I 
      STA MBOX1     SAVE DIMENSION
      ADB M1
      LDA 1,I       DEFINED IN COMMON?
      SZA 
      JMP M8LOP     YES!
      LDA FCORE     NO, SET UP
      STA 1,I         ADDRESS OF STRING IN SYMBOL TBL 
      LDA MBOX1     SET UP DIMENSIONS 
      STA FCORE,I     IN STRING HEADER
      ISZ 1,I       BUMP ADDRESS TO ACTUAL STRING DATA
      ALF,ALF       COMPUTE 
      INA             THE NUMBER
      ARS               OF WORDS IN 
      INA                 STRING
      ADA FCORE 
      STA FCORE 
      CMA,INA 
      ADA SYMTF     MORE CORE?
      SSA 
      JMP OVERR     NO! 
M8LOP ADB .3
      JMP M2LOP     CHECK NEXT SYMBOL 
* 
OVERR CLA 
      STA .LNUM     SET SO AS NOT TO PRINT ERROR
      JSB ERROR     OUT OF SPACE ERROR
MER7  EQU * 
* 
      SKP 
* 
*  PROCESS FILES STATEMENT
* 
*  FOR EACH FILE FOUND IN A FILES STATEMENT A 
*  144 WORD DATA CONTROL BLOCK IS CREATED AND A POINTER 
*  TO IT IS PLACED IN ITS ORDINAL POSITION IN THE 16
*  WORD ARRAY 'FILBK' .  THE FILE IS THE OPENED. IF AN
*  ERROR OCCURS AN APPROPIATE ERROR IS PRINTED.  IF 
*  A SNOWFLAKE (*) IS FOUND IN PLACE OF A FILE NAME,
*  A DCB IS RESERVED FOR OPENING DURING EXECUTION TIME
*  WITH THE ASSIGN STATEMENT.  IF A ZERO IS FOUND THAT
*  ORDINAL POSITION IS RESERVED FOR A LOGICAL UNIT NUMBER 
*  REFERENCE. 
* 
*    ON ENTRY AND EXIT A AND B ARE PRESERVED
* 
* B=PTR TO INTERPRETIVE CODE
* A=CURRENT OP CODE 
* TEMP6=POINTER TO ACTUAL DCB AREA
* TEMP4=M17, CTR USED TO KEEP TRACK OF TOTAL NUMBER OF FILE PROCESSED 
* TEMP8=PTR TO 'FILBK' WHICH IS BLOCK OF 16 WRDS USED TO POINT TO DCBS
* 
* 
FILES NOP 
      STA TEMP9     SAVE
      STB TEM10       REGISTERS 
      INB           MOVE PTR TO FIRST CHAR
      CLE,ELB       SET UP CHARACTER ADDRESS
      STB INBFA       USING E FOR ODD/EVEN FLAG 
      LDA TEM10     SET THE 
      LDA 0,I           COUNT 
      AND B377            EQUAL 
      CMA                   TO
      STA ICCNT               - #CHARS -1 
FILE1 JSB GETCR     GET THE 1ST CHAR OF FILE NAME 
      JMP FILE2     RETURN IF EOL!
************************790820********************************
*THIS NEW PIECE OF CODE UTILIZIES THE RLIB ROUTINE 'NAMR' 
*TO PARSE THE FILENAME OR LU SPECIFIED IN THE 'FILES' 
*STATEMENT.  THIS WAY THE FMP ROUTINES OF  'READF', 
*'WRITF' CAN BE USED TO FURTHER THE INDEPENDENCE OF BASIC 
*FROM THE SYSTEM. 
* 
* 
      CLB           CLEAR CHAR. COUNT AND RESET THE STARTING
      STB LENTH     CHAR. POINTER FOR NAMR
      LDB .1
      STB ISTRC 
      LDB DEST      MOVE THE NAME TO BE PARSED FROM 
TOP   JSB .SBT
      ISZ LENTH     INCREMENT CHAR. COUNT 
      STB STORE 
      JSB GETCR     RETRIEVE NEXT CHAR. 
      JMP KAPUT      EOL? YES *791004 
      CPA B54        IS A COMMA? *791004
      JMP DONE       YES, GO PARSE THIS FILE
      LDB STORE     NO
      JMP TOP       GO AGAIN FOR MORE!!!
* 
********************CHANGED 791005******************************* 
KAPUT CCA           BACKUP THE CHAR COUNT FOR EXIT
      ADA ICCNT 
      STA ICCNT 
**************************791005********************************* 
DONE  JSB NAMR      PARSE THE NAME
      DEF REPT
      DEF BUFR      RESULTING BUFFER
      DEF NAMBF     SOURCE BUFFER 
      DEF LENTH     # OF CHAR. TO PARSE 
      DEF ISTRC     STARTING CHAR. IN STRING
* 
*DUE TO THE REQUIREMENT OF NAMR'S RESULTING BUFFER BEING OF 
*SIZE OF 10 WORDS, THE NAME MUST BE MOVED TO THE OLD NAME 
*BUFFER IN BASIC FOR CONVERSION EASE. 
* 
**************CHANGED 791004****************************
REPT LDA DUM1       GET ADDRESS TO RESULTING
     STA POINT      BUFFER
     LDA DUM2       GET ADDRESS TO NAME IN
     STA PNTLU      COMMON
     LDA M3         ****791008 SET UP WORDS 
     STA DUM3       ****791008 COUNTER
**********************791004***************************** 
REPT1 LDA POINT,I   PICK UP RESULTING BUFFER 791005 
      STA PNTLU,I   MOVE TO NAME IN COMMON WITH 
      ISZ POINT     SECURITY CODE AND CRN#
      ISZ PNTLU     BEHIND THE 3-WORD NAME
*********************CHANGED 790928********************************** 
      ISZ DUM3      ****791008
      JMP REPT1     791005
      ISZ POINT     INCREMENT PASSED TYPE WORD 4
      LDA POINT,I   MOVE SECURITY CODE AND CRN# 
      STA PNTLU,I 
      ISZ POINT 
      ISZ PNTLU 
      LDA POINT,I 
      STA PNTLU,I 
***********************790928*****************************************
      ISZ TEMP4     INCREMENT COUNT.  IF MORE THAN
      JMP MER1
      CLA           16 ERROR (CLEAR LINE NUMBER)
      STA .LNUM 
      JSB ERROR     TOO MANY! 
****************************ADDED 800208******************************* 
MER1  LDB NAME      PICK UP FIRST WORD OF NAME TO 
      LDA BUFR+3    CHECK FOR LEGAL LU REFERENCE BY 
      CPA .1        EXAMINING WORD 4 OF NAMR'S BUFFER FOR 
      JMP MER2      TYPE=1; IF SO, NAME BETTER=0 OR ERROR 
      CPA .0        IF NULL ISSUE BAD FILES STATEMENT ERROR 
      RSS 
      JMP CERR2 
      CLA 
      STA .LNUM 
      JSB ERROR 
MER2  CPB .0        IS NAME A 0?
      JMP FILE3     GO INCREMENT COUNT AND GET NEXT CHAR. 
      CLA 
      STA .LNUM 
      JSB ERROR     NO, ERROR 
***************************800208************************************** 
CERR2  LDA .144      SET UP 
      ADA TEMP6       TOTAL COUNT OF
      STA TEMP6         DCB BLOCK 
      JSB CKOVF     IS DCB BLOCK TOO BIG? 
      ADA COML      OFFSET FOR COMMON BLOCK 
      CMA,INA 
      ADA LWBM      INITIALIZE FILE BLOCK 
      CPB STAR      IS NAME A '*'?
      CMA,INA       YES, COMPLEMENT IT FOR LATER OPEN 
      LDB PFLAG      CHAIN OR INVOKE? 
      CPB .2
      JMP CHAIN     YES,DETERMINE WHETHER TO LEAVE OPEN 
FILE4 LDB NAME      RESTORE NAME CHARACTERS 
      STA TEMP8,I     WITH DCB POINTERS 
      ISZ TEMP8     GOTO NEXT FILE BLOCK PTR
      STA TEMP3 
      CPB STAR      IS NAME A '*'?
      JMP FILE1     YES, DON'T OPEN BUT CREATE DCB
      JSB OPEN      CHANGED BACK TO OPEN(OPENF NOT NEEDED!!)
      DEF *+7         NAMED       **800208**
      DEF TEMP3,I       FILE
      DEF FERR            WITH
      DEF NAME              SPECIFIED 
      DEF B101           ********CHANGED TO ECHO FOR LU IF LU****** 
*                                NO EFFECT ON FILENAME OPEN 790820****
      DEF SC                    CODE AND
      DEF LU                      CARTRIDGE # 
* 
      LDA FERR      WAS THERE 
      SSA,RSS         AN OPEN ERROR?
      JMP FILE1     NO! 
      STA TEMP3     YES, PRINT
*ADDED 800208** 
      CLA           ZERO LINE NUMBER
      STA .LNUM 
      JMP OUTER       MESSAGE AND ABORT 
* 
*************ADDED 800107*************************************
CHAIN LDB TEMP6      CHECK FOR FILE SIZE > PA'S 
      CMB,INB 
      ADB PAFIL 
      SSB            IF +, THEN OK
      JMP COMER      IF -, ERROR SON>PA *800205*
      SZB            IF 0, SON=PA SET PAFLF=0 
      JMP CHAN
      STB PAFLF 
      RSS 
CHAN  ISZ PAFLF 
**********************CHANGED 800210********************************* 
      LDB TEMP8,I   CHECK FOR * CONDITION IN PA 
      SSB,RSS       ONLY TIME WILL OPEN FILE IN SON 
      JMP FILE3     NO, GO ON TO NEXT FILE
      SSA           "*" TYPE FILE IN SON ALSO?
      JMP FILE3     YES, GO ON TO NEXT FILE 
      CMB,INB       USE PA'S ADDRESS FOR DCB
      STB 0 
      JMP FILE4     ELSE GO OPEN NEW FILE 
**************************800210************************************* 
* 
FILE2 LDA TEMP9     RESTORE 
      LDB TEM10       REGISTERS 
      JMP FILES,I 
* 
FILE3 ISZ TEMP8 
      JMP FILE1 
* 
*********************ADDED 790820*********************************
*********ADDED 790820******************** 
BUFR  BSS 10        **791003**
POINT NOP           **791004
PNTLU NOP           **791004
DUM1  DEF BUFR      **791004
DUM2  DEF NAME      **791004
DUM3  NOP           **791008
ISTRC NOP 
LENTH NOP 
STORE NOP 
DEST  DBL NAMBF 
NAMBF BSS 14
B101  OCT 101 
PAFLF NOP           **ADDED 800107**
PAFLC NOP           **ADDED 800107**
*********************790820***************************************
      SPC 3 
* 
*  CHECK FOR COMMON AND/OR DCB BLOCK OVERFLOW 
*   A = BLOCK SIZE
* 
CKOVF NOP 
      STA TEMP5     SAVE A REG
      ADA PBPTR     WILL WE 
      ADA .256        DESTROY 
      CMA,INA           THE PROGRAM 
      ADA LWBM            IF WE 
      SSA                   CONTINUE? 
      JMP OVERR     YES!, OUT OF STORAGE
      LDA TEMP5 
      JMP CKOVF,I 
      SKP 
* 
      SPC 3 
* 
*     SUBROUTINE TO STORE A BYTE
*     CALLING SEQUENCE
*     JSB SYBTE 
*     A REG CONTAINS BYTE 
*     B REG CONTAINS BYTE ADDRESS 
* 
SBYTE NOP 
      AND B377      MASK ALL BUT LOWER 8 BITS 
      STA TEMP7     SAVE IN TEMP LOCATION 
      CLE,ERB       CHANGE FROM BYTE TO WORD ADD
      LDA 1,I       GET WORD
      SEZ,RSS       RIGHT OR LEFT HALF
      ALF,ALF       LEFT
      AND HIMSK     MASK ALL BUT UPPER 8 BITS 
      IOR TEMP7     OR IN NEW BYTE
      SEZ,RSS       LEFT OR RIGHT 
      ALF,ALF       LEFT
      STA 1,I       STORE WORD BACK 
      ELB,CLE       GET BYTE ADDRESS AGAIN
      JMP SBYTE,I   RETURN
      SPC 2 
************************* 
*                       * 
* ENTER SYMBOL IN TABLE * 
*                       * 
************************* 
ESYMT NOP 
      STA MBIN1    SAVE NEGATIVE OF LENGTH OF ENTRY 
      ADA SYMTF 
      STA SYMTF    MOVE SYMBOL TABLE START LOCATOR
      STA MBIN2    UP BY THE LENGTH OF ENTRY
      CMA,INA      CHECK THAT THE SYMBOL TABLE AND
      ADA FCORE     FOR TABLE DO NOT OVERLAP
      SSA,RSS 
      JSB ERROR    OVERLAP ERROR
MER8  LDB MBUF     POINTER TO REQD ENTRY
NEX   LDA 1,I      TRANSFER ENTRY TO THE SYMBOL 
      STA MBIN2,I  TABLE
      INB 
      ISZ MBIN2 
      ISZ MBIN1 
      JMP NEX 
      JMP ESYMT,I   RETURN
* 
* 
********************************* 
*                               * 
* SEARCH SYMBOL TABLE FOR ARRAY * 
*                               * 
********************************* 
MSYMT NOP          B GIVES ARRAY TYPE -3 = 1 DIM, 
      STB MBIN1    -2 = 2DIM, -1 = UNDIMENSIONED
      LDA MBOX1    LOAD IDENTIFIER
      JSB SSYMT     SEARCH SYMBOL TABLE 
      SSB,RSS 
      JMP MSYMT,I  FOUND, RETURN
      ISZ MBIN1    IF ARRAY UNDIMENSIONED 
      RSS 
      JMP MSYM     JUMP TO NOT FOUND EXIT 
      ISZ MBIN1    SET UP TO CHECK THAT ARRAY DOES
      AND .15 
      SZA,RSS       STRING? 
      JMP MSYM      YES, DONT CHECK FURTHER 
      LDA MBOX1 
      ADA .2       NOT APPEAR IN THE TABLE WITH 
      ADA M1       DIFFERENT DIMENSIONS. CHANGE 
      JSB SSYMT       TYPE 2 TO 1 & TYPE 1 TO 2 AND 
      SSB,RSS      SEARCH AGAIN 
      JSB ERROR    FOUND, INCONSISTENT DIMENSIONS 
MSYM  ISZ MSYMT    NOT FOUND, INCREMENT RETURN
      JMP MSYMT,I  ADDRESS AND RETURN 
* 
************************************* 
*                                   * 
* COMPUTE STORAGE REQUIRED BY ARRAY * 
*                                   * 
************************************* 
MDIM  NOP 
      STA 1         STORE PACKED DIMS. TEMPORALILY
      AND B377
      STA TEMP8     STORE # OF COLUMNS
      LDA 1 
      ALF,ALF 
      AND B377      A = # OF ROWS 
      ALS           DOUBLE FOR FLOATING POINT 
      MPY TEMP8     COMPUTE 2*ROWS:COLUMNS
      SSA           RESULT < 32768 ?
      JSB ERROR     NO, ERROR DIMENSIONS TOO LARGE
MER9  JMP MDIM,I    YES, RETURN 
      SKP 
**********************************
*                                *
*  WRITE OUT REMAINDER OF FILES  *
*                                *
**********************************
* 
WRREC NOP 
      LDB DCB       IS
      ADB .2          FILE
      LDB 1,I             TYPE 0? 
      SZB,RSS 
      JMP WRXIT     YES, CLOSE IT 
      LDB DCB       HAS 
      ADB .13         BUFFER
*     JSB RDCB1     (CHECK FOR NEW DCB)***OUT FOR L 
      LDA 1,I           BEEN
      SLA,RSS             WRITTEN ON? 
      JMP WRXIT     NO, SO DON'T WRITE
      AND MNEG      YES, CLEAR IT 
*     JSB WDCBB     (CHECK FOR NEW DCB)***OUT FOR L 
      STA 1,I 
      INB           NOW CORRECT 
      CCA             RECORD
      ADA 1,I           COUNTER 
      SZA                 UNLESS
      STA 1,I                START OF FILE
      ADB M2        RESET 
      LDA DCB         WORD
      ADA .16           LOCATION
      STA 1,I 
      JSB WRITF       OUT 
      DEF *+6           NEXT
      DEF DCB,I           RECORD
      DEF FERR
      DEF TEMP6,I 
      DEF .128
      DEF .0
      JSB CKERR     CHECK FOR ERROR 
WRXIT JSB CLOSE     CLOSE 
      DEF *+4 
      DEF DCB,I       THE 
      DEF FERR
      DEF .0            FILE
      JMP WRREC,I 
* 
* 
CKERR NOP 
      LDA FERR      IS THERE
      SSA,RSS         A FILE MANAGER ERROR? 
      JMP CKERR,I   NO! 
      STA TEMP3     YES!
      JMP OUTER     PRINT MESSAGE AND ABORT 
      SKP 
**********************************************************************
* 
*THIS ROUTINE WILL UPDATE THE IB AND WR BITS IN THE NEW DCB WORD 7
*BASED ON INFORMATIOIN IN THE OLD DCB WORD 13.  SINCE BASIC 
*ASSUMES THE INFORMATION TO BE IN WORD 13, THIS ROUTINE WILL ALLOW
*FOR AN EASY CONVERSION TO THE NEW DCB LAYOUT.
* 
*UPON ENTRY THE A AND B REGISTERS ARE AS FOLLOWS: 
* 
*     A=VALUE OF THE OLD DCB WORD 13
*     B=ADDRESS TO THE OLD DCB WORD 13
* 
*A TEST IS DONE ON THE ENTRY POINT $BMON WHICH WILL HAVE BIT 0
*SET IF THE HOST SYSTEM IS AN RTE-4B OR THE NEW DCB LAYOUT. 
* 
*RETURN POINTS: 
* 
*     P+1 FOR THE OLD DCB-TYPE SYSTEMS
*     P+2 FOR THE NEW DCB-TYPE SYSTEMS
* 
*UPON RETURN, THE A AND B REGISTERS WILL HAVE THE SAME VALUES AS UPON 
*ENTRY. 
* 
************************************************************************
*WDCBB NOP
*     STA ASTOR     SAVE THE A AND B REGS.
*     STB BSTOR 
*     LDA $BMON     IS THIS A 4B SYSTEM? A(0)=1 
*     SLA 
*     JMP DCB4B     YES,GO UPDATE WORD 7
*     LDA ASTOR     NO, RESTORE THE A 
*     JMP WDCBB,I   AND RETURN TO P+1 
*DCB4B ADB M6        PICK UP NEW DCB WORD 7 
*     STB ADDR1 
*     LDA 1,I 
*     LDB ASTOR     CHECK VALUES IN OLD DCB 
*     SSB,RSS       FOR IB=1
*     JMP CLIB1     NO
*     IOR .4        YES 
*CHKWR SLB,RSS       AND WR=1 
*     JMP CLWR      NO
*     IOR .1        YES 
*PUTIT STA ADDR1,I   AND STORE IN WORD 7
*     LDA ASTOR     RESTORE ORG. VALUE OF A AND 
*     LDB BSTOR     B 
*     ISZ WDCBB     AND RETURN TO P+2 
*     JMP WDCBB,I 
*CLIB1 AND M5        CLEAR IB (BIT2) IN NEW DCB 
*     JMP CHKWR 
*CLWR  AND M2        CLEAR WR (BIT1) IN NEW DCB 
*     JMP PUTIT 
*ASTOR NOP
*BSTOR NOP
*ADDR1 NOP
*ASTR1 NOP
      SKP 
**********************************************************************
* 
*THIS ROUTINE WILL TAKE THE VALUES FOR THE IB AND WR BITS IN THE
*NEW DCB WORD 7 AND POSITION THEM INTO THE FORMAT FOR THE OLD DCB 
*WORD 13.  THE TWO DIFFERENT DCB'S ARE: 
* 
*      OLD DCB WORD 13: 
* 
*      15                     1  0
*      IB                    EF  WR 
* 
*      NEW DCB WORD 7:
* 
*      15                  2  1  0
*      SC                 IB EF WR
* 
*SINCE BASIC ASSUMES THIS FLAG INFORMATION TO BE IN WORD 13, THIS ROUTINE 
*WILL ALLOW FOR AN EASY CONVERSION TO THE NEW DCB LAYOUT. 
* 
*UPON ENTRY THE A AND B REGISTERS ARE AS FOLLOWS: 
* 
*     A IS MEANINGLESS
*     B=ADDRESS TO THE OLD DCB WORD 13
* 
*A TEST IS DONE ON THE ENTRY POINT $BMON WHICH WILL HAVE BIT 0 SET
*IF THE HOST SYSTEM IS AN RTE-4B OR THE NEW DCB LAYOUT. 
* 
*RETURN POINTS: 
* 
*     P+1 FOR THE OLD DCB TYPE SYSTEMS
*     P+2 FOR THE NEW DCB TYPE SYSTEMS
* 
*UPON RETURN, THE REGISTERS WILL BE AS FOLLOWS: 
* 
*     A=VALUE OF THE IB AND WR BITS IN THE WORD 13 FORMAT 
*     B=ADDRESS TO THE OLD DCB WORD 13
* 
**********************************************************************
*RDCB1 NOP
*     STB BSTOR     SAVE ADDR. OF OLD DCB WORD 13 
*     LDB $BMON     IS THIS A 4B SYSTEM? B(0)=1 
*     SLB 
*     JMP B4DCB     YES, GO POSITION THE IB AND WR BITS 
*     LDB BSTOR     NO, RESTORE THE ADDR. AND 
*     JMP RDCB1,I   RETURN TO P+1 
*B4DCB LDB DCB       GET WORD 7 OF NEW DCB
*     ADB .7
*     LDA 1,I 
*     STA ASTOR 
*     AND .4        CHECK FOR IB (BIT2) SET 
*     SZA,RSS 
*     JMP CL15      NO, CLEAR BIT 15
*     LDA ASTOR     YES, SET BIT 15 
*     IOR MNEG      WITH MASK 100000
*B4END AND INTFL     MASK OFF MEANINGLESS BITS (100003) 
*     LDB BSTOR     RESTORE ADDR. AND 
*     ISZ RDCB1     RETURN TO P+2 
*     JMP RDCB1,I 
*CL15  LDA ASTOR     CLEAR BIT 15 
*     AND INF       WITH MASK 77777 
*     JMP B4END 
      SKP 
********************************************
*                                          *
*  SETUP ADDRESSES INSTEAD OF GOTO'S ETC.  *
*                                          *
********************************************
STNUM NOP 
      LDA PBUFF 
      STA RENQ
      ADA M1
      STA RENP      SEEK EMBEDDED 
REN12 JSB RENSK     STATEMENT REFERENCES
      JMP STNUM,I   NONE LEFT 
      LDA RENP,I    IF REFERENCE IS 
      CPA COMMA     COMMA?
      JMP REN12     YES, CONTINUE MIGHT BE GOTO-OF ETC. 
      JSB RENS0     SET STMT NUMBER TO ABSOLUTE ADDRESS 
      JMP REN12 
* 
RENSK NOP 
      LDB M5
      STB RENCT     SET 'IF' COUNTER
      LDB PSTIF 
      STB RENAD     SET PAST IF STMT PTR
      ISZ RENP      INCREMENT POINTER 
      LDB RENQ      ADDRESS OF BEGINNING OF NEXT STMT 
      LDA USFLG     PRINT USING 
      SZA             LAST STMT?
      JMP RENS2     YES, SKIP OVER REST OF STMT!
      CPB RENP      STATEMENT FINISHED? 
      JMP RENS2     YES 
RENS1 ISZ RENSK     NO, RETURN WITH RENP
      JMP RENSK,I   SET TO NEXT REFERENCE 
      STB RENQ      UPDATE TO NEXT STATEMENT
RENS2 CLA           SET PRINT USING FLAG
      STA USFLG       CLEAR 
      CPB PBPTR     PROGRAM EXHAUSTED?
      JMP RENSK,I   YES 
      STB RENR      SAVE CURRENT STATEMENT ADDRS
      ISZ RENQ
      LDB RENQ
      ISZ RENQ      EXTRACT 
      LDA RENQ,I    STATEMENT 
      AND OPMSK     TYPE
      ADB 1,I       SET (B) TO
      ADB M1        NEXT STATEMENT
      CPA RESOP     <RESTORE STATEMENT> ? 
      JMP RENS5     YES 
      CPA GOTOP     NO, <GOTO STATEMENT> ?
      JMP RENS3     YES 
      CPA GOSOP     NO, <GOSUB STATEMENT>?
      JMP RENS3     YES 
      CPA FALOP     NO, <FAIL STATEMENT>? 
      JMP RENS3     YES 
      CPA CALOP     NO, <CALL STATEMENT>? 
      RSS           YES 
*     CPA TRPOP     NO, <TRAP STATEMENT>?  **800421** 
*     JMP CKTRP     YES!  *800421** 
      CPA IFOP      NO, <IF STATEMENT>? 
      RSS           YES!
      CPA PRTOP     NO, <PRINT USING STATMENT>? 
      RSS 
      JMP RENS2-1 
REN2A LDA RENAD,I   GET PAST 'IF' OPERATOR
RENS3 IOR INTFL     CREATE REFERNCE HEADER
      STB RENQ      SET POINTER TO NEXT STMT
      ADB M1        SET PTR TO
RENS4 STB RENP        PROSPECTIVE HEADER? 
      ADB M1
      CPB RENR      END OF STATEMENT? 
      JMP RENS6     YES!
RENS8 CPA 1,I       PRECEDED BY REFERENCE HEADER? 
      JMP RENS7     YES 
      ISZ RENAD     GOTO NEXT OPERATOR
      LDA RENAD,I     PAST 'IF' 
      IOR INTFL 
      ISZ RENCT     DONE? 
      JMP RENS8     NO! 
      LDA PSTIF 
      STA RENAD 
      LDA M5
      STA RENCT 
      LDA OFOP      YES, LOAD HEADER FOR
      CPA 1,I 
      JMP RENS1 
      LDA USEOP     <PRINT USING>?
      CPA 1,I 
      JMP RENS1 
      JMP RENS4     REFERENCE LIST
RENS5 CPA RENQ,I    ANY REFERENCE?
      JMP RENS2-1   NO
      JMP RENS3     YES 
RENS6 LDB RENQ      'THEN','GOTO', OR 'GOSUB' 
      JMP RENS2       NOT FOUND 
* 
RENS7 CPA USEOP     <PRINT USING>?
      STA USFLG     SET 'PRINT USING' FLAG SO AS TO SKIP OVER REST OF STMT
      JMP RENS1     NO! 
* 
RENS0 NOP 
      LDA RENP,I    GET STMT NUMBER 
      JSB FNDPS     GO ON AND FIND ADDRESS
      NOP 
      JMP NOSTM     NO  SUCH STATEMENT NUMBER!
      STB RENP,I    STUFF IN ADDRESS
      JMP RENS0,I 
* 
NOSTM LDA RENR,I    SET 
      STA .LNUM       LINE NUMBER FOR ERROR 
      JSB ERROR     PRINT NO SUCH LINE NUMBER ERROR MESS
MER11 EQU * 
* 
* 
INTFL OCT 100003
RENCT DEC -3
RENAD DEF THNOP 
RENP  BSS 1 
RENQ  BSS 1 
RENR  BSS 1 
USFLG NOP 
COMMA OCT 102003
PSTIF DEF *+1       THESE 
THNOP OCT 60000       SIX 
GOTOP OCT 37000         ITEMS MUST
GOSOP OCT 43000 
RESOP OCT 55000             BE CONTIGUOUS 
PRTOP OCT 53000 
IFOP  OCT 40000 
OFOP  OCT 177003
TRPOP OCT 66000 
USEOP OCT 161003
FALOP OCT 57000 
      SKP 
*********************** 
*                     * 
* PRINT ERROR MESSAGE * 
*                     * 
*********************** 
ERROR NOP 
      LDB ERROR     ERROR SOURCE IN (B) 
      LDA ERBS      ERROR ADDRESS IN (A)
      INA           MOVE TO NEXT ERROR
      CPB 0,I       SAME AS ACTUAL ERROR? 
      CMA,INA,RSS   YES, MAKE ERROR NEGATIVE
      JMP *-3       NO
      ADA ERBS      MAKE ERROR POSITIVE 
      CMA,INA 
      ADA .34       ADJUST FOR SEG 1 ERRORS 
      STA TEMP3     SAVE IT 
      JMP OUTER     PRINT ERROR MESSAGE 
*************** 
*             * 
* ERROR TABLE * 
*             * 
*************** 
ERR   DEF MER5A     COM STATEMENT OUT OF ORDER
      DEF MER4      FUNCTION DEFINED TWICE
      DEF MER6      UNMATCHED FOR 
      DEF MER3      NEXT WITHOUT MATCHING FOR 
      DEF MSYM      DIMENSIONS NOT COMPATIBLE 
      DEF MLOP6     LAST STATEMENT NOT 'END'
      DEF MER5      VARIABLE DIMENSIONED TWICE
      DEF MER10     ARRAY OF UNKNOWN DIMENSIONS 
      DEF MER9      ARRAY TOO LARGE 
      DEF MER7      OUT OF STORAGE
      DEF MER1      TOO MANY FILES
      DEF MER2      BAD FILES STATEMENT 
      DEF MER8      SYMBOL TABLE OVERFLOW 
      DEF CERR1     CHAINED/INVOKED PROG. COMMON AND FILES BAD
      DEF CERR2     MUST SPECIFY 0  FOR LU  *800208*
      DEF CERR3     INVALID FILE NAME     **ZEROED  790823* 
      DEF CERR4     MISSING SEGMENTS
      DEF MER11     NO SUCH STATEMENT 
**************************ADDED 790823************************* 
CERR3 NOP 
*************************790823******************************** 
      SKP 
MBOX1 EQU TEMPS 
MBIN1 EQU TEMPT+1 
MBIN2 EQU TEMPT+2 
MNPTR EQU TEMPT+3 
TYP   EQU TEMPT+4 
NAME  EQU TEMPT+5 
SC    EQU TEMPT+8 
LU    EQU TEMPT+9 
COML  EQU TEMPT+10
MWDNO EQU TEMPT+11
MPTR  EQU SBPTR 
FERR  EQU TEMPS+1 
TEMP1 EQU TEMPS+2 
TEMP2 EQU TEMPS+3 
TEMP3 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
PACOM EQU TEMPS+30    **CORRECTED 800122 TO 30 FROM 31**
PAFIL EQU TEMPS+31    **CORRECTED 800122 TO 31 FROM 32**
* 
      END BASC3