ASMB,Q,C HED HEADER FOR FILES &F4X1 AND %F4X1 . NAM F4X1,8 92834-16002 REV.2030 800714 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * END ASMB,Q,C HED FTN4X COMPILER (FTN4X:MAIN) NAM FTN4X,3,90 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ADDRESS OF CURRENT A.T. ENTRY. EXT F.ABT ABORT COMPILER POINT. EXT F.AT ADDRESS TYPE OF CURRENT ITEM. ENT F.AT. SUBSCRIPT INFO FLAG EXT F.CC CHARACTER COUNT ENT F.CCW FTN OPTION WORD ENT F.CSN CURRENT SEGMENT NUMBER. ENT F.CSZ COMMON SIZE ENT F.D DO TABLE POINTER EXT F.D0 ARRAY (ELEMENT) SIZE. ENT F.D.T ADDRESS OF '.' FUN. TABLE ENT F.DID ADDR OF F.IDI ENT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DNI DEF TO NAME BUFFER (NID). ENT F.DO LWAM - END OF DO TABLE ENT F.DPJ DEF TO CURRENT PROC. JUMP TABLE. ENT F.DTY DEFAULT TYPE TABLE. ENT F.E EQUIVALENCE TABLE ADDR. ENT F.EMA F.A OF EMA MASTER. ENT F.EMS EMA SIZE DOUBLE WORD, (INTERNAL FORMAT) ENT F.END END FLAG ENT F.ER0 'RX' OF ERRX LIB ERROR ROUTINE ENT F.FES TWPE FOR FIRST EXECUTABLE STMT. ENT F.FNS FIRST NON-SPECIFICATION CHECK. ENT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). ENT F.IDI GENERAL DATA BUFFER. EXT F.IM CURRENT ITEM MODE. EXT F.IU CURRENT ITEM USAGE. ENT F.IMF IMPLICIT FLAG. ENT F.L # WORDS ON STACK 2 ENT F.LCF LABELLED COMMON FLAG. ENT F.LFF LOCICAL IF FLAG ENT F.LO END OF ASSIGNMEXT TABLE+1 ENT F.LSF EXPECT FIRST STATEMEXT FLAG ENT F.LSN F.A OF LAST STATEMEXT NUMBER ENT F.LSP LAST OPERATION FLAG ENT F.MSG MSEG SIZE ON $EMA(...) ENT F.NAR NUMBER OF ALTERNATE RETURNS. EXT F.NT CURRENT NAME TAG. EXT F.NXN NO INPUT FLAG ENT F.PCT F.A OF TEMP FOR PCOUNT(). ENT F.PTF PERMENENT TEMP FLAG. ENT F.PTY PROGRAM TYPE. ENT F.REL F.RPL OF ENTRY POINT. ENT F.RES F.A OF CURRENT RESULT. ENT F.RPL PROGRAM LOCATION COUNTER ENT F.S1B BOTTOM OF STACK 1 ENT F.S1T TOP OF STACK 1 ENT F.S2T TOP OF STACK 2 ENT F.SBF 0= MAIN, ELSE SUBROUTINE ENT F.SEE RETURN POINT FROM SEGMENT 1. ENT F.SEG LOAD A NEW SEGMENT ENT F.SEQ CODE-GENERATING STATEMENT COUNTER. ENT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 ENT F.SID STATEMEXT ID PHASE FLAG ENT F.SLF STATEMEXT LEVEL FLAG ENT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL ENT F.SPS ADDRESS OF CURRENT STATEMENT PROCESSOR. ENT F.STA FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ ENT F.STB STRING BACK FLAG (LOGICAL IF) ENT F.SVL SAVE # WDS ON OPER STACK (F.L) ENT F.SXF COMPLEX CONSTANT FLAG ENT F.T # WORDS ON STACK 1 ENT F.TYP TYPE STMT FLAG ENT F.XID EXTERNAL ID COUNTER. ENT F.UFM ADDR OF UNIT-FILE MAP. ENT F.#M # NON-DISC I/O CONNECTIONS. ENT F.#N # DISC I/O CONNECTIONS. ENT F.#S BUFFER SIZE MULTIPLE. ENT F.#B # OF BUFFER BLOCKS. ENT F.$CC SAVED F.CC AT $ STATEMENT BREAK. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM. ENT APT.F ALLOCATE 'PERMANENT' TEMP CELL. EXT BNI.F CLEAR NAME BUFFER TO BLANKS. ENT CAT.F COMMON CODE FOR ALLOCATING TEMPS. EXT DAT.F DEFINE F.AT . EXT DL.F DEFINE LOCATION OF CURRENT A.T. ENTRY. EXT ER.F ERROR PRINT SUBROUTINE. EXT FA.F FETCH ASSIGNS. ENT MVW.F MOVE WORDS, FTN-STYLE. ENT NEW.F SUB TO CLEAR TEMPS FOR A NEW MODULE EXT WAR.F WARNING PRINT SUBROUTINE. EXT WS1.F WRITE TO FIRST PASS FILE. * * EXTERNAL IN THE SEGMENTS. * EXT F.GRX TO SECOND LEVEL OF GRD.F EXT F.RCO ACCESS TO RCO.F: RELATE COMMON. EXT FER.F DO PROGRAM ENTRANCE STUFF. * * ENTRIES TO KEEP THE GENERATOR HAPPY. * ENT F.GRD GET REGISTER DATA. * * THIS FORTRAN IV COMPILER RUNS UNDER VARIOUS OP * SYSTEMS THROUGH SUITABLE INTERFACE ROUTINES. * * OPSYSTEM INTERFACE: * * EXT .MVW MOVE WORDS INSTRUCTION. EXT SEG.F SEGMENT TRANSLATOR EXT WRT.C EXT C.TTY EXT C.BIN BINARY FCB (MUST BE IN MAIN) EXT C.SAU SOURCE FCB (MUST BE IN MAIN) EXT C.SC0 CARD FILE FCB (MUST BE IN MAIN). EXT C.TRN COMPILER LIB. DATA STORE EXT OLY.C SEGMENT LOAD SPC 1 SUP A EQU 0 A-REGISTER B EQU 1 B-REGISTER SKP * ****************************** * * MAIN ENTRY TO THE COMPILER * * ****************************** SPC 1 FTN4 BSS 0 DST F.IDI SAVE THE RUN REGS. LDB K4 GO TO SEGMENT 4 JMP F.SEG SPC 2 * ************************* * * COMPILE A NEW PROGRAM * * ************************* SPC 1 NEW.F NOP CLA STA F.NXN RESET NO INPUT FLAG STA F.SID CLEAR THE SCAN SWITCH LDA K73 STA F.LSP SET PATH TO THIS STATMENT TRUE STA F.CC SET F.CC=73 JMP NEW.F,I RETURN SPC 2 F.STA NOP FTN READ YET FLAG F.CCW DEC 1 COMPILE OPTION CONTROL WORD (PRINT CON REC.) F.DNB DEF NBUF K4 DEC 4 F.ER0 ASC 1,R0 F.DO NOP LWAM; END OF F.DO TABLE F.D.T DEF ..TBL * F.LO NOP END OF ASSIGNMENT TABLE + 1. F.S1B NOP BEGIN OPERAND STACK F.S1T NOP END OPERAND STACK F.S2T NOP END OPERATOR STACK K73 DEC 73 F.D NOP DO-TABLE POINTER F.LSF NOP F.LSN NOP LAST STATEMENT NUMBER FLAG F.STB NOP ADDRESS OF STRING-BACK ENTRY. * NBUF EQU * START OF NAM RECORD DEF C.TRN DUMMY REF. TO FOURCE LOAD WITH MAIN DEF C.BIN ALSO A DUMMY DEF C.SAU DITTO. DEF C.SC0 DITTO. F.PTY EQU NBUF+9 PROGRAM TYPE. BSS 60-*+NBUF RESERVE ROOM OF NAM RECORD SKP * ****************** * * SEGMENT LOADER * * ****************** SPC 1 * ENTRY (B) = SEGMENT NUMBER. * F.SEG STB F.CSN SET THE SEGMENT NUMBER JSB SEG.F GET SEGMENT ID DEF F.CSN FOR SEGMENT STB SEG SET FOR CALL JSB OLY.C LOAD SEGMENT (NO RETURN) SEG NOP * JSB WRT.C SEGMENT LOAD FAILED DEF C.TTY TELL HIM DEF NOSEG DEF L.NOS NOP (IN CASE ERROR) HLT 0 FOURCE MP (OR HLT IF SUCH A SYSTEM) * NOSEG ASC 12,/FTN4X: SEGMENT MISSING!, L.NOS DEC 12 F.CSN NOP CURRENT SEGMENT NUMBER. F.SEQ NOP SEQUENCE COUNTER FOR CODE-GEN STMTS. F.SLF NOP STATEMENT LEVEL FLAG F.SID NOP STID FLAG F.END NOP SPC 2 * ********************** * * MOVE WORDS ROUTINE * * ********************** SPC 1 * CALL: JSB MVW.F * DEF * DEF * DEC <# WDS> * MVW.F NOP LDB MVW.F (B) = ADDR ADDR DEST. ISZ MVW.F LDA MVW.F (A) = ADDR ADDR SOURCE. ISZ MVW.F LDA A,I RESOLVE ADDRESSES. RAL,CLE,SLA,ERA JMP *-2 LDB B,I RBL,CLE,SLB,ERB JMP *-2 JSB .MVW MOVE THE BLOCK. DEF MVW.F,I NOP ISZ MVW.F BUMP PAST WORD COUNT, JMP MVW.F,I AND EXIT. SKP * ********************************* * * FIRST NON-SPECIFICATION CHECK * * ********************************* SPC 1 * INPUT: (A)=STATEMENT TYPE HIERARCHY. * (B)=STATEMENT KEYWORD ORDINAL. SPC 1 F.FNS STB T2FNS SAVE ORDINAL. CLB STB F.END RESET '$'-END FLAG STA F.SLF LEVEL OF THIS STMT LDB F.SEQ SAVE SEQUENCE DATA. STB T1FNS CPA K8 FORMAT ? JMP FNS16 YES. SKIP ALL THIS JUNK. CPA K4 IS IT EXECUTABLE ? ISZ F.SEQ YES. BUMP COUNTER. CPA K5 IF END STMT. JMP FNS07 CHECK FOR RELAT COMMON YET ADA KM3 SSA JMP F.SEE * LDA F.SPF EXECUTABLE. SZA IF NOT ZERO OR CPA K1 ONE JMP F.SEE THEN * FNS02 CLB,INB IT IS AN EXECUTABLE CPB F.CSN EVALUATOR IN MEMORY? JMP F.SEE YES. GO TO ITS RETURN POINT. JMP F.SEG NO. LOAD IT. RETURN TO F.SEE (B=1) * K1 DEC 1 K5 DEC 5 K8 DEC 8 KM3 DEC -3 KM2 DEC -2 T1FNS NOP * FNS07 LDB F.SPF COMMON RELATED YET?? ADB KM2 ZERO OR ONE IF NOT SSB,RSS WELL? JMP FNS02 YES. NOW (CONDITIONALLY) LOAD F4.1 * JSB F.RCO,I NO. GO DO IT. FNS06 LDA K2 AND SET PGM LEVEL TO 2. STA F.SPF JMP FNS02 NOW GO TO F4.1 SKP * WHEN LOADED, F4.1 DOES NOTHING EXCEPT RETURN HERE. * F.SEE LDB F.SLF CPB F.SPF SPECIFICATION FLAG JMP FNS12 F.SLF EQUALS CURRENT STMNT LEVEL * CMB,INB ADB F.SPF F.SPF-F.SLF LDA K34 SSB,RSS JMP FNS17 F.SPF .GT. F.SLF, STMNT OUT OF ORDER * CLA,INA TEST IF JUST A SPEC STMT. CPA F.SLF WELL? JMP FNS05 YES SKIP TEST FOR RELATE COM * CMA A=-2 ADA F.SPF IF CURRENT LEVEL IS LESS THAN TWO SSA,RSS THEN JMP FNS05 (NO) * JSB F.RCO,I RELATE COMMON ITEMS LDA F.SLF PROCESSING FIRST DATA STATEMENT ? CPA K2 JMP FNS05 YES. LEAVE SEGMENT 0 IN MEMORY. JMP FNS06 NO. GO ADVANCE PGM LVL & LOAD SEGMNT 1. * FNS05 LDA F.SLF LDB F.SPF GET CURRENT STMT. LEVEL CPB K4 IF AT 4 ALREADY THEN JMP FNS08 WE HAVE ALREADY DONE THE ENTRY * CPA K5 IF END RSS DO NOT ADVANCE STA F.SPF ADVANCE PROGRAM STMT LEVEL ADA KM3 AT 1ST STMT FCT OR 1ST EXECUTABLE, SSA,RSS INCL END ? (I.E., NEW LEVEL = 3,4,5 ?) JSB FER.F YES, PRODUCE ENTRANCE CODE. FNS08 LDA F.LSN LAST STATEMENT NUMBER STA F.A SZA,RSS JMP FNS20 NONE; GO TO PROCESSOR. * LDA F.SLF FORMAT STATEMENT LDB F.LFF OR TRUE BRANCH OF LOGICAL IF ? SZB,RSS CPA K8 JMP FNS20 YES. DON'T DEFINE STATEMENT #. * LDA K77 LDB F.SPF STATEMENT LEVEL FLAG ADB KM3 SSB EXECUTABLE? JMP FNS15 NO. GRIPE ABOUT STMT NO. * JSB FA.F YES. ALREADY DEFINED ? (FOR FORMAT)? LDB F.AT I.E., IS F.AT=REL ? LDA K27 (ERROR #) CPB REL JMP FNS15 YES. GO ISSUE WARNING 27. * LDA REL NO. SET F.AT=REL SO KNOW HAS BEEN SEEN. JSB DAT.F LDA KK37 OUTPUT OPCODE TO DEFINE IT. JSB WS1.F LDA F.A AND THE F.A JSB WS1.F LDA F.A SAVE THE SEQUENCE # SO WE CAN OPTIMIZE INA OUT 'GOTO NEXTLINE' LDB T1FNS CMB DON'T CONFUSE WITH DEFAULT VALUE. STB A,I JMP FNS20 EXIT. SPC 1 FNS12 LDA F.LSP LAST OPERATION FLAG ADA F.LSN LAST STATEMENT NUMBER FLAG CLB,INB STB F.LSP FNS14 SZA JMP FNS08 LDA K35 FNS15 JSB WAR.F NO PATH TO THIS STATEMENT CLA IN CASE IT'S DECLARATION WITH STA F.LSN STMT #, ZAP IT. JMP FNS20 SPC 1 FNS16 LDA F.LSN LAST STATEMENT # FLAG JMP FNS14 * FNS17 LDB F.SLF GET THE LEVEL FLAG CPB K2 DATA STATEMENT? CLB,RSS YES IT CAN BE OUT OF ORDER JSB ER.F NO BAIL OUT * CPB F.CSN IF SPEC. SEGMENT IN MEMORY JMP FNS08 GO FINISH UP * LDA K77 (IN CASE ERROR) CPB F.LSN STATEMENT NUMBER?? RSS NO. JSB WAR.F YES. ERROR. * CLB NOW LOAD SEGMENT 0. JMP F.SEG * K2 DEC 2 K27 DEC 27 K34 DEC 34 K35 DEC 35 K77 DEC 77 KK37 BYT 1,45 DEFINE STMT # OPERATOR. REL OCT 1000 F.AT = REL. SKP * GO TO PROCESSOR. THE LOOK-UP OF THE PROCESSOR * ADDRESS MUST BE DELAYED SO THAT IF A SEGMENT * IS LOADED, IT CAN UPDATE 'F.DPJ'. * FNS20 LDB T2FNS KEYWORD ORDINAL. ADB F.DPJ GET ADDR PROCESSOR. LDB B,I STB F.SPS SET IT FOR USE BY THE PROCESSOR, JMP B,I AND GO THERE. * T2FNS NOP KEYWORD ORDINAL. SKP * ****************** * * ASSIGN ADDRESS * * ****************** SPC 1 * TO ASSIGN STORAGE TO A SINGLE VARIABLE OR ARRAY * INPUT: F.A=POINTS AT THE CANDIDATE FOR STORAGE ASSIGNMENT * OUTPUT: STORAGE IS ASSIGNED FOR THE ELEMENT(IF NOT YET * ASSIGNED) POINTED AT BY F.A * EACH ELEMENT HAS ITS AT SET TO REL AND ITS AF SET * TO THE ELEMENTS RELATIVE LOCATION WITHIN THE OBJECT * OUTPUT & RPL BUMPED BY SIZE OF THE ELEMENT OR ARRAY. SPC 1 AA.F NOP LDA F.NT A NAME? SZA JMP AA.F,I NO. RETURN. LDA F.AT CPA B2000 STRAB RSS NOT YET ASSIGNED JMP AA.F,I ALREADY ASSIGNED LDA F.IU CPA VAR JMP AA02 F.IU=VAR CPA ARR RSS F.IU=ARR JMP AA.F,I NEITHER VAR NOR ARRAY AA02 JSB DL.F DEFINE LOCATION DLD F.D0 CHECK THAT SIZE < 32768. SZA,RSS I.E., UPPER WORD = 0, SSB AND LOWER WORD >= 0. JMP AA03 NO. MEM OFL. ADB F.RPL O.K., ADD TO LOC. STB F.RPL RPL=RPL+F.D0 SSB,RSS JMP AA.F,I * AA03 LDA K84 RPL OVER FLOW JMP F.ABT ABORT * VAR OCT 400 F.IU=VAR. ARR OCT 600 F.IU=ARR. K84 DEC 84 B2000 OCT 2000 SKP * ***************************** * * ALLOCATE 'PERMANENT' TEMP * * ***************************** SPC 1 APT.F NOP STA F.IM SAVE THE TYPE. ALF INDEX INTO THE TEMP TABLE. LDB DFINT ADA B ISZ A,I BUMP TO THE NEXT ONE. LDA A,I AND GET IT. ADA B2000 USE 2ND HALF OF RANGE ALLOCATED. JSB CAT.F COMMON CODE TO DO IT. JMP APT.F,I DONE. SPC 2 * COMMON CODE FOR ATC.F & APT.F * CAT.F NOP ENTER WITH (A)=TEMP #, F.IM=TYPE. RAL PUT THE TYPE IN BITS 14:11, IOR F.IM BY SHIFTING TWICE. INA SET BIT 15 WHILE WE'RE AT IT. RAR DONE. <15>=1, <14:11>=TYPE, <10:0>=NUMBER. STA T0CAT SAVE TEMP CELL NAME CLA STA F.NT NAME TAG = 0 (VARIABLE) STA F.PTF (ALSO CLEAR PERMANENT TEMP FLAG) LDA VAR STA F.IU ITEM USAGE = VARIABLE JSB BNI.F CLEAR NAME TO BLANKS LDA T0CAT SET UP THE FIRST TWO CHARACTERS AND B377 AS THE IDENT HIGH AND LOW BYTES. LDB A (B) = LOW BYTE. XOR T0CAT (A) = HIGH BYTE. ALF,ALF (RIGHT-JUSTIFY) DST F.DNI,I THERE THEY GO. JSB AI.F ASSIGN NAME TO A.T. LDA F.A RETURN ASSIGN TAB PTR TO TEMP CELL LDB F.A JMP CAT.F,I SPC 1 T0CAT BSS 1 DFINT DEF F.INT-1 B377 OCT 377 * ****************************************** * * GLOBAL VARIABLES,BUFFERS,AND CONSTANTS * * ****************************************** SPC 1 F.LSP NOP LAST OPERATION FLAG. F.SPS NOP ADDR OF CURRENT STMT PROCESSOR. F.LFF NOP LOGICAL IFF FLAG. F.GRD DEF F.GRX,I POINTER TO GRD.F F.DID DEF F.IDI ADDR OF F.IDI F.DTY DEF TYPET ADDR OF DEFAULT TYPE TABLE. F.DPJ NOP ADDR OF CURRENT PROC. JUMP TABLE. F.RES NOP F.A OF CURRENT RESULT. SPC 2 * ********************** * * DEFAULT TYPE TABLE * * ********************** * * THIS TABLE CONTAINS THE DEFAULT OR IMPLICIT TYPE FOR EACH OF THE * LETTERS (WHICH MAY START AN IDENTIFIER). IT IS INITIALIZED BY THE * INITIALIZATION SEGMENT BEFORE EACH MODULE, AND IS MODIFIED BY ANY * 'IMPLICIT' STATEMENT ENCOUNTERED. EACH BYTE IS THE LEFT BYTE OF * THE CORRESPONDING F.IM, E.G. F.IM=REA=020000, LEFT BYTE = 40. * TYPET BYT 40,40,40,40,40,40,40,40 A-H, REAL. BYT 20,20,20,20,20,20 I-N, INTEGER. BYT 40,40,40,40,40,40,40,40,40,40,40,40 O-Z, REAL. SKP * ******************* * * INITIALIZE TO 0 * * ******************* SPC 1 ABS COMEN-F.AT.-1 LENGTH OF AREA TO ZAP F.AT. OCT 0 SUBSCRIPT INFORMATION FLAG F.REL BSS 1 ENTRY POINT. F.RPL BSS 1 RELATIVE PROGRAM LOCATION F.SFF BSS 1 SUBROUTINE/FUNCTION FLAG (SET IF * A FUNCTION) F.SPF OCT 0 SPECIFICATION FLAG (SET TO * CURRENT STATEMENT LEVEL) F.SBF NOP SUBPR FLAG(0=MAIN,ELSE SUBPROG.) F.L NOP NUMBER OF WORDS ON STACK 2 F.SVL NOP SAVED COPY OF F.L F.SXF NOP COMPLEX CONSTANT FLAG F.T NOP NO. WORDS ON STACK 1 F.TYP NOP TYPE STATEMENT FLAG F.CSZ NOP COMMON SIZE F.MSG NOP MSEG SIZE. F.EMS OCT 0,0 DOUBLE WORD EMA SIZE F.EMA NOP F.A OF EMA MASTER. F.INT BSS 13 TEMP CELL NUMBERS. F.IDI BSS 14 GENERAL DATA BUFFER. F.E NOP EQUIVALENCE TABLE POINTER. F.XID NOP EXTERNAL ID COUNTER. F.IMF NOP IMPLICIT FLAG. F.NAR NOP NUMBER OF ALTERNATE RETURNS. F.LCF NOP LABELLED COMMON FLAG. F.#M NOP # NON-DISC. F.#N NOP # DISC. F.#S NOP BUFFER SIZE. F.#B NOP NUMBER OF BUFFER BLOCKS. F.UFM NOP ADDR OF UNIT-FILE MAP. F.PTF NOP PERMANENT TEMP FLAG. F.FES NOP TWPE OF 1ST EXECUTABLE. F.$CC NOP SAVED F.CC AT $ STATEMENT BREAK. F.PCT NOP F.A OF TEMP USED BY PCOUNT(). F.FRF NOP FUNCTION RESULT F.A (NON-STMT FCT). SPC 1 * ******************** * * .EXTERNAL TABLE * * ******************** SPC 1 * THIS TABLE OF EXTERNAL ORDINALS FOR DOT-FUNCTION * SUBROUTINES IS CLEARED TO ZERO AT THE BEGINNING OF * COMPILATION. * ..TBL BSS 348 SPC 1 COMEN EQU * LOCATION OF END OF COMMON AREA ORG * END FTN4 ASMB,Q,C HED ASSIGNMEXT TABLE ROUTINES NAM FA.F,8 92834-16002 REV.2030 800707 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE OF THE HP FTN4X COMPILER CONTAINS THE * ASSIGNMEXT TABLE ROUTINES. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) ENT F..E DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE ENT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY ENT F.AF ADDRESS FIELD CURREXT F.A ENT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. SUBSCRIPT INFO FLAG ENT F.CSL CHARACTER STRING LENGTH. ENT F.D0 ARRAY ELEMEXT SIZE ENT F.DCF DIM, COM FLAG EXT F.DID ADDRESS OF F.IDI ENT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. ENT F.DNI ADDRESS OF NID ENT F.DP BASE OF USER SYMBOL TABLE EXT F.E EQUIVALENCE TABLE POINTER ENT F.EM EMA FLAG BIT IN A.T. ENT F.EXF EXTERNAL STATEMEXT FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC ENT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) ENT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LCF LABELLED COMMON FLAG. EXT F.LO END OF ASSIGNMEXT TABLE+1 ENT F.LUB ADDRESS OF LOWER/UPPER BOUNDS TABLE. ENT F.NC NAME CHANGE FLAG. ENT F.ND NUMBER OF DIMENSIONS ENT F.NT NAME TAG 0= VAR, 1=CONSTANT. ENT F.NTF NAME TAG FLAG EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. ENT F.R MISC A.T. FLAG EXT F.RPL PROGRAM LOCATION COUNTER ENT F.S SUBROUTINE FLAG. EXT F.S1T TOP OF STACK 1 ENT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 ENT F.SFA F.A OF STMT FCT IF CURRENTLY IN ONE. EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.TC NEXT CHARACTER ENT F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT AI.F ASSIGN ITEM ENT AST.F ALLOCATE SPACE IN SYMBOL TABLE. ENT BNI.F CLEAR NID TO BLANKS ENT CFC.F CHECK FOR CONSTANT. ENT CDI.F CLEAR IDI ROUTINE ENT CSN.F CHECK STATEMENT NUMBER TYPE ENT DAD.F DOUBLE INTEGER ADD. ENT DAF.F DEFINE (F.AF) ENT DAT.F DEFINE (AT) ENT DEM.F DEFINE (F.EM)=1 ENT DIM.F DEFINE (F.IM) ENT DIU.F DEFINE (F.IU) ENT DL.F DEFINE LOCATION SUBROUTINE ENT DMP.F DOUBLE INTEGER MULTIPLY. ENT DS.F DEFINE (F.S)=1 ENT DSB.F DOUBLE INTEGER SUBTRACT. ENT EDO.F ESTABLISH DATA WITH OFFSET. ENT EIC.F ESTABLISH INTEGER CONSTANT. ENT EJC.F ESTABLISH DOUBLE INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE ENT ESC.F ESTABLISH CONSTANT SUBROUTINE ENT ESD.F ESTABLISH DEF SUBROUTINE ENT FA.F FETCH ASSIGNS ENT FC.F FETCH VALUE OF CONSTANT. ENT FID.F FETCH (ID) TO NID (UNPACK) ENT GCD.F GET CONSTANT DIMENSION AS DOUBLE INT. ENT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. ENT GFC.F GET FIRST (CONSTANT) SYMBOL TABLE ENTRY. ENT GFD.F GET FIRST (DEF) SYMBOL TABLE ENTRY. ENT GNA.F GET NEXT SYMBOL TABLE EXTRY ENT IN4.F INIT FOR FA.F MODULE ENT ITS.F INTEGER TEST ENT NAM.F COPY SYMBOL NAME. ENT NCT.F TEST FOR NOT A CONSTANT ENT NET.F TEST FOR NOT EMA. ENT NST.F TEST FOR NOT A SUBROUTINE NAME ENT NTI.F MOVE NID TO F.IDI (PACKS) ENT NWE.F RETURN (B) = # WORDS IN ITEM TYPE F.IM ENT NWI.F SET F.D0 TO # WORDS IN ARRAY ENT TCT.F TEST (A) = F.TC ELSE ER 28 ENT TS.F TAG SUBPROGRAM SUB. ENT TV.F TAG VARIABLE EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * GENERAL LIB EXT * EXT .MVW MOVE WORDS * A EQU 0 B EQU 1 SUP * * IN4.F NOP INITILIZE CODE CLA ZERO OUT THE STA DSTH+1 SYMBOL TABLE STA DSTH+2 LIST HEADS. STA DSTH+3 STA DSTH+4 JMP IN4.F,I RETURN * K1 OCT 1 SKP * THE ASSIGNMENT TABLE * * WORD -1 IS ALWAYS PRESENT AND GIVES THE ADDRESS OF THE NEXT ENTRY. * WORD 0 IDENTIFIES THE ENTRY AND IS SPLIT UP INTO FIELDS: * * !---------------!-----------!-------!-------!---!---!---!---!---! * ! IM ! AT ! IU ! NC ! R ! E ! S !EM !NT ! * !---------------!-----------!-------!-------!---!---!---!---!---! * !15 14 13 12 ! 11 10 9 ! 8 7 ! 6 5 ! 4 ! 3 ! 2 ! 1 ! 0 ! * !---------------!-----------!-------!-------!---!---!---!---!---! * (170000) (7000) (600) (140) 20 10 (4) (2) (1) * * * IM = ITEM MODE: * * 0: --- STMT NUMBER 6: DBL: DOUBLE PRECISION*6 * 1: INT: INTEGER*2 7: ADDR: TEMPORARY ADDRESS * 2: REA: REAL*4 8: DBI: INTEGER*4 * 3: LOG: LOGICAL*2 9: LO4: LOGICAL*4 * 4: TWPE: OBJECT CODE 10: RE8: DOUBLE PRECISION*8 * 5: CPX: COMPLEX*8 11: STR: CHARACTER * 12: ZPX: COMPLEX*16 * * * AT = ADDRESS TYPE. MEANING OF WORD 1 (F.AF) * * 0: --- ABSOLUTE (NOT USED) * 1: REL: RELATIVE RELATIVE ADDRESS * 2: STR-ABS: UNDEFINED OR NOT DEF * * REFERENCED YET * HOLLERITH CONST - # WORDS. * 3: BCOM: LABELLED COMMON PTR TO BCOMI OR DIM ENTRY * 4: COM: BLANK COMMON OFFSET INTO COMMON * 5: DUM: DUMMY PARAMETER RELATIVE ADDR OF DEF TO IT * 6: DIM: DIMENSION ENTRY RELATIVE ADDRESS OF ARRAY * (OR POINTER TO BCOM ENTRY) * 7: BCOMI: LBL COMMON OFFSET OFFSET FROM START OF BLOCK * LBL COMMON MASTER 0 OR - EXT ID # * * * IU = ITEM USAGE: HOW USED * * 0: --- NOT YET USED * 1: SUB: SUBROUTINE * 2: VAR/CON: VARIABLE OR CONSTANT * 3: ARR: ARRAY * * * NC = MISC FLAGS * * STATEMENT #'S: TYPE (FORMAT/EXECUTABLE). * SUBROUTINES: EXTERNAL/INTRINSIC/GENERIC FLAGS. * DIMENSION: F.VDM = VARIABLE DIMENSION FLAG. * F.DIS = DOUBLE INTEGER SUBSCRIPT FLAG. SKP * R = MISC FLAG * * BCOMI ENTRY: WHETHER EMA OFFSET REFORMATTED YET. * DEF ENTRY: FLAGS WHETHER GENERATED YET. * SUBPRG ENTRY: INDICATES HAS BEEN USED AS FUNCTION. * * * S = SUBROUTINE FLAG. * * SUBPRG ENTRY: INDICATED HAS BEEN USED AS SUBROUTINE. * * * E = MISC FLAG. * * PASS 1: EXPLICIT TYPING FLAG. * PASS 2,3: REFERENCE FLAG. * * * EM = EMA FLAG. NT = NAME TAG * * 0: IN LOCAL MEMORY 0: NAMED ITEM * 1: IN EMA 1: UNNAMED ITEM SPC 4 * SPECIAL NOTE ON ADDRESS TEMPS: * * NOTE: FOR ADDRESS TEMPS (F.IM=ADDR), IF A 'DEF' IS DONE TO THE * TEMP, THE TEMP REPLACES THE DEF: ITS F.AF IS SET TO THE ADDR * OF THE DEF. IF WE ARE IN AN IMPLIED DO, THO, F.RPL IS RELATIVE * TO A TWPE ENTRY; IN THIS CASE, AN OFFSET MECHANISM IS USED: * F.AF IS SET TO THE F.A OF THE TWPE ENTRY + 100000B, AND WORD 2 IS * SET TO THE OFFSET. WE MAY DESTROY WORD 2 AT WILL SINCE ADDRESS * TEMPS ARE RENAMED IN END.F ANYWAY. NO ONE WILL FIND AT THE ENTRY * UNTIL END.F NOW, SINCE IT LOOKS LIKE A VARIABLE, AND ALL SEARCHING * FOR THEM IS COMPLETED IN PASS ONE. * ************************************************************************ * * OBJECT CODE OR LOAD ADDRESS ENTRIES * * 0) IM: TWPE * AT: STR-ABS / REL * IU: 0 * NT: 0 * * 1) AF: REL ADDR IN PROGRAM (0 IF UNDEF) * * USED AS INTERNAL ADDRESS CONSTANTS OR HOLLERITH ADDRESSES. * THE SPECIAL CASE OF HOLLERITH VS. END-OF-LOOP ADDRESS, WITHIN * A PARAM LIST, CAN BE DISTINGUISHED BY F.AT, WHICH IS REL FOR * HOLLERITH (ALREADY DEFINED) OR STR-ABS FOR ADDRESSES. SKP ************************************************************************ * * VARIABLE NAMES: * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: ABS,REL,STR-ABS,COM,BCOM,DUM * IU: VAR/CON,ARR (ZERO IF NAME OF CURRENT PROGRAM) * E: 1 IFF EXPLICITLY TYPED. * EM: 0/1 FOR LOCAL/EMA * NT: 0 * * 1) AF: ADDRESS (AT=REL OR DUM),COMMON OFFSET (AT=COM) * POINTER TO DIM ENTRY (IU=ARR) (THIS BEFORE BCOM) * POINTER TO BCOMI ENTRY (AT=BCOM,IU#ARR) * * 2) WORDS 2-N: SYMBOL, 2 CHARS/WORD, PADDED WITH A BLANK IF REQ'D. * THE LAST CHARACTER (POSSIBLY BLANK) HAS BIT 7 = 1. * ************************************************************************ * * MASTER OR LABEL ENTRY FOR LABELED COMMON * OR SUBPROGRAM NAME ENTRY * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: BCOMI(COM), STR-ABS(EXT SUB), REL(STMT FCT), DUM(DUMMY SUB) * IU: SUB * EM: 0/1 AS LOCAL/EMA. * NT: 0 * * 1) AF: 0 OR - EXT ID NUMBER (BCOM MASTER OR EXT SUB). * ADDRESS OF A TWO-WORD BLOCK CONTAINING THE ADDRESS OF THE * FUNCTION AND THE F.A OF THE FIRST FORMAL PARAM (IF ANY). * REL ADDRESS OF DEF FOR DUMMY SUB. * * 2) WORDS 2-N HAVE SYMBOL (SEE VARIABLES). * ************************************************************************ * * TEMPORARY VARABLES * * 0) IM: INT,LOG,REA,DBL,CPX,ADDR,DBI,LO4,RE8,STR,ZPX * AT: REL * IU: VAR/CON * NT: 0 * * 1) AF: REL ADDR OF TEMP * ( IF IM=ADDR, IS IM OF REFERENCED ITEM) * * 2) TEMP I.D.: <1> , WHERE SEQ# IS IN [1,2047] * * NOTE: SEE ABOVE FOR SPECIAL CONSIDERATIONS FOR ADDRESS TEMPS. SKP ************************************************************************ * * STATEMENT NUMBERS * * 0) IM: 0 * AT: REL,STR-ABS * IU: 0 * NC: TYPE: 0/2/3 = UNKNOWN/NON-FORMAT/FORMAT * NT: 0 * * 1) AF: PROGRAM ADDRESS OF STATEMENT (AT=REL) * POINTER TO THIS ENTRY IF UNDEFINED (AT=STR-ABS) * * 2-N) ASCII STATEMENT #, PREFIXED BY '@', AS A SYMBOL. * ************************************************************************ * * DIMENSION ENTRY * * 0) IM: # OF DIMENSIONS, 1-7. * AT: DIM * IU: 0 * NC: F.VDM: 1 IFF VARIABLE DIMENSION(S). * F.DIS: 1 IFF DOUBLE INTEGER DIMENSION(S). (EMA ONLY) * NT: 1 * * 1) AF: ARRAYS ADDRESS (AT=REL,DUM) OR COMMON OFFSET (AT=COM) * OR POINTER TO BCOMI ENTRY (AT=BCOM) * (NOTE THESE AT'S ARE OF THE VARIABLE ENTRY, THIS AT IS DIM) * * 2) WORD 2: F.A OF: NON-FORMAL: CONSTANT OFFSET TO ELEMENT (0...0) * FORMAL: DEF TO ELEMENT (0...0) * * 3) WORDS 3 to 2*N+2: LB1,UB1,...,LB7,UB7, LOWER & UPPER BOUNDS. * WHEN ENTRY CODE GENERATED, UPPER BOUNDS * REPLACED BY DIMENSION SIZES. * ************************************************************************ * * BLOCK COMMON INFO. ENTRY * * 0) IM: 0 * AT: BCOMI * IU: 0 * EM: 0/1 FOR LOCAL/EMA * NT: 1 * * 1) OFFSET FROM START OF BLOCK. * EMA: LOWER BITS. * EMA FORMAL: F.A OF TEMP FOR BASE ADDR. (REVERSED) * * 2) F.A OF BLOCK NAME. * * 3) EMA: UPPER BITS. * EMA FORMAL: F.A OF TEMP FOR ADDR OF (0,..,0). (DBL INT SUB ONLY) SKP ************************************************************************ * * CONSTANTS * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: REL,STR-ABS * IU: VAR/CON * NT: 1 * ************************************************************************ * * DATA WITH OFFSET * * 0) IM: INT,REA,LOG,CPX,DBL,DBI,LO4,RE8,STR,ZPX * AT: REL,COM,BCOM * IU: ARR * NT: 1 * * 1) AF: F.A OF ITEM OFFSET IS FROM * * 2) THE OFFSET * ************************************************************************ * * DEF POINTERS * * 0) IM: 0 * AT: REL,COM,STR-ABS * IU: VAR * R: 1 IFF DEFINED * NT: 1 * * 1) AF: REL ADDR OF DEF (* IF UNDEF) * * 2) + REL ADDR, CONTENTS OF DEF * 100000B + F.A OF ITEM DEF POINTS TO * ************************************************************************ * * DEF POINTERS (EXTERNAL WITH OFFSET) * * 0) IM: 0 * AT: BCOMI * IU: VAR * R: 1 IFF DEFINED * NT: 1 * * 1) AF: REL ADDR OF DEF (* IF UNDEF) * * 2) OFFSET * * 3) F.A OF ITEM WITH EXT I.D. SKP ************************************************************************ * * CHARACTER ITEM EXTENSION. * * 0) # CHARACTERS; 0 = DESCRIPTOR ONLY. * * 1) REL ADDR OF DESCRIPTOR. * * 2) BYTE ADDR OF DATA, IF KNOWN. SKP * ***************** * * FETCH ASSIGNS * * ***************** SPC 1 FA.F NOP LDB F.A LDA B,I AND B170K 170000B STA F.IM F.IM=IM(F.A) LDA B,I AND B7000 STA F.AT F.AT=AT(F.A) LDA B,I AND B600 STA F.IU F.IU=IU(F.A) LDA B,I AND B140 STA F.NC F.NC=NC(F.A) LDA B,I AND B20 STA F.R F.R=R(F.A) LDA B,I AND B10 STA F..E F..E=E(F.A) LDA B,I AND K4 STA F.S F.S=S(F.A) LDA B,I AND K2 STA F.EM F.EM=EM(F.A) LDA B,I AND K1 STA F.NT F.NT=NT(F.A) INB LDA B,I (A)=GF(F.A) STA X5 STA F.AF JSB NWE.F # WDS PER ELEMENT. STB F.D0+1 F.D0=NO. OF WDS FOR THIS ITEM MODE CLA CLEAR THE UPPER STA F.D0 HALF OF THE DOUBLE WORD LDA F.IU CPA ARR ARRAY OR DATA WITH OFFSET ? RSS JMP FA02 NO. LDA F.NT YES. WHICH ? SZA JMP FA03 DATA WITH OFFSET. SKP * ARRAY. SET UP DIM ENTRY FIELDS. * LDB X5 (B)=ADDR OF SUBSCRIPT INFO ENTRY LDA B,I AND B20 STA F.R F.R=R(X5) LDA B,I AND B100 STA F.VDM F.VDM=NC(X5), UPPER BIT. LDA B,I AND B40 STA F.DIS F.DIS=NC(X5), LOWER BIT. LDA B,I AND B170K ALF STA F.ND F.ND=IM(X5), (# OF DIMENSIONS) ADB K3 STB F.LUB F.LUB=ADDR BOUNDS LIST. * * SET UP F.AF = 2ND WD OF 1ST LINKED ENTRY, EXIT. * FA03 LDB X5 INB LDA B,I (A)=GF(X5) STA F.AF FA02 LDA F.A,I IF STATEMENT FUNCTION, AND KK10 I.E. F.AT=REL AND F.IU=SUB, LDB A (WANT F.AF IN A-REG) LDA F.AF (A)=F.AF FOR RETURN. CPB KK11 WELL ? LDA A,I THEN SET F.AF TO THE REAL VALUE. STA F.AF (NOP/CHANGE) LDB F.IM CHARACTER STRING ? CPB CHAR RSS (YES) JMP FA.F,I NO. EXIT. * DLD A,I YES. GET TRUE F.AF & LENGTH. STA F.AF SET ADDR DESCRIPTOR, STB F.CSL AND THE CHAR LENGTH. JMP FA.F,I EXIT. * F..E BSS 1 F.EM BSS 1 THE EMA FLAG. F.S BSS 1 SUBROUTINE FLAG. F.VDM BSS 1 VARIABLE DIMENSIONS FLAG. F.DIS BSS 1 DOUBLE INTEGER SUBSCRIPT FLAG. F.LUB BSS 1 ADDRESS OF LUWER/UPPER BOUNDS TABLE. F.CSL BSS 1 CHARACTER STRING LENGTH. DUM OCT 5000 AT=5 TWPE OCT 40000 CHAR OCT 130000 F.IM=CHAR. B100 OCT 100 B200 OCT 200 SUB EQU B200 IU=1 REL OCT 1000 AT=1 X5 BSS 1 ASSIGN TABLE POINTER FOR ARRAY . B7000 OCT 7000 TO ENTRACT AT FIELD BCOMI EQU B7000 B20 OCT 20 B140 OCT 140 K8 DEC 8 B10 EQU K8 KM2 DEC -2 KK10 OCT 007600 MASK OVER F.AT & F.IU KK11 OCT 001200 F.AT=REL & F.IU=SUB, STMT FCT. F.IM NOP ITEM MODE: REAL, CPX, INT, ETC. F.IU NOP ITEM USAGE: DUMMY, RELATIVE, ETC. F.NC NOP NAME CHANGE FLAG F.ND NOP # OF DIMENSIONS F.NT NOP NAME TAG: 0 IF VAR, 1 IF CONST F.AT NOP ADDRESS TYPE F.AF NOP ADDRESS FIELD F.R NOP MISC FLAG. F.D0 NOP WORDS/ARRAY ELEMENT NOP F.D0 IS A DOUBLE WORD SPC 4 * ***************************** * * DETERMINE S.T. ENTRY TYPE * * ***************************** * * ENTRY: F.IM, F.AT, F.IU, F.NT SET UP. * EXIT: (A)=F.STY = TYPE, IN RANGE [-2,3]. (B DESTROYED) * * THE TYPES ARE: * * -2 DIMENSION OR BCOM OFFSET * -1 TWPE * 0 ANY NAMED ITEM. * 1 DATA WITH OFFSET. * 2 CONSTANT. * 3 DEF. * STY.F NOP LDA KM2 (A=-2) LDB F.AT. SZB JMP STY01 F.AT. # 0: -2 CCA (A=-1) LDB F.IM CPB TWPE JMP STY01 F.IM=TWPE: -1 LDA F.NT SZA,RSS JMP STY01 F.NT=0: 0 LDB F.IU (A=1) CPB ARR JMP STY01 F.NT=1, F.IU=ARR: 1 INA (A=2) LDB F.IM SZB,RSS F.NT=1, F.IU#ARR, F.IM#0: 2 INA F.NT=1, F.IU#ARR, F.IM=0: 3 STY01 STA F.STY JMP STY.F,I * F.STY NOP SKP * ********************* * * MOVE NID TO F.IDI * * ********************* SPC 1 * ALSO SETS F.NWN = # WORDS IN SYMBOL. SPC 1 NTI.F NOP LDA NID+4 PACK 3RD WORD ALF,ALF IOR NID+5 STA F.IDI+2 LDB K3 ASSUME 3 WORDS. CPA TWOBS BLANKS ? LDB K2 YES, ONLY 2. STB F.NWN TENTATIVE WORD COUNT. LDA NID+2 PACK 2ND WORD ALF,ALF IOR NID+3 STA F.IDI+1 CLB,INB B=1 CPA TWOBS BLANKS ? STB F.NWN YES, ONLY ONE WORD. LDA NID PACK 1ST WORD ALF,ALF IOR NID+1 STA F.IDI JMP NTI.F,I SPC 2 NID BSS 6 F.DNI DEF NID F.NWN NOP # WORDS IN PACKED NAME. TWOBS ASC 1, SKP * ********************* * * SET F.IDI TO ZERO * * ********************* SPC 1 CDI.F NOP SET F.IDI TO ZERO. CLA STA F.IDI STA F.IDI+1 STA F.IDI+3 STA F.IDI+2 STA F.IDI+4 JMP CDI.F,I SPC 2 * *********************** * * CLEAR NID TO BLANKS * * *********************** SPC 1 BNI.F NOP LDA B40 STA NID STA NID+1 STA NID+2 STA NID+3 STA NID+4 STA NID+5 JMP BNI.F,I SKP * *************** * * ASSIGN ITEM * * *************** * * SPECIAL ALGORITHM: IN ORDER TO IMPLEMENT LOCAL SCOPE OF STATEMENT * FUNCTION FORMAL PARAMETERS, THEY ARE ATTACHED ONLY TO THE FUNCTION * ENTRY, THRU ITS F.AF . WE ARE IN A STATEMENT FUNCTION WHEN F.SLF * IS 2; IN THIS CASE, F.SFA IS THE F.A OF THE FUNCTION, WITH THE * SIGN BIT SET IF WE ARE DEFINING FORMAL PARAMETERS. IF F.SLF#2, * FA.F SETS F.SFA=0 TO SIMPLIFY TESTING. * NOW IF SEARCHING FOR A NAMED ITEM (TYPE 0), AND F.SFA#0: * * FIRST, SET T3AI=-1. * * F.SFA<0: SEARCH NORMAL LIST, THEN: * * NO MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) * =0 : O.K. * MATCH: T3AI=-1: T3AI_0; GO SEARCH (F.SFA+2) * (USE F.IM OF MATCHED ITEM) * =0 : O.K. (ERROR, CAUGHT LATER.) * * * F.SFA>0: SET LIST HEAD TO F.SFA+2, THEN: * * NO MATCH: T3AI=-1: T3AI_0; GO SEARCH NORMAL LIST. * =0 : O.K. * MATCH: T3AI=-1: O.K. * =0 : O.K. * * STATEMENT FUNCTION FORMAL PARAMETERS ARE NEVER MOVED, * ALWAYS INSERTED AT END OF LIST (INSTEAD OF AT START). * * FOR NAMED ITEMS, IF F.IM=0, F.AT MUST BE BCOMI. (COMMON LABELS) SPC 2 * TEST FOR CASES WE DON'T SEARCH FOR. * AI.F NOP CLA IF NOT STATEMENT FUNCTION, LDB F.SPF CPB K3 (3=STMT FCT) RSS (YES, LEAVE IT) STA F.SFA THEN CLEAR OUT THE FLAG. STA F.SFD CLEAR THE STMT FCT DUMMY FLAG. LDA F.NT IS ITEM A NAME? IOR F.AT. (DIM/BCOMI DON'T SET F.NT) SZA I.E., F.NT=F.AT.=0 ? JMP AI03 NO. * JSB NTI.F YES, F.IDI=NID CCB FIND LAST WORD OF NAME. ADB F.NWN ADB F.DID LDA B,I AND MARK IT. SSA,RSS (UNLESS IT'S A CONSTANT ORDINAL) IOR B200 BY SETTING BIT 7. STA B,I AI03 JSB STY.F DETERMINE TYPE. SSA IS IT A SEARCHABLE TYPE ? JMP AI50 NO. JUST GO ADD IT. * LDA F.STY YES. SET UP COMPARE ROUTINE ADDRESS. ADA DSTC LDA A,I STA STC JSB NWE.F COMPUTE # WORDS (IN CASE CONSTANT). STB F.D0+1 & SAVE. (GARBAGE IS O.K.) * * SET UP & PERFORM SEARCH. * AT FIRST CUT, JUST COMPARE WORD 2 OF EACH. * CCA SET T3AI=-1 IN CASE STMT FCT. STA T3AI LDA F.STY TYPE. LDB F.SFA STATEMENT FUNCTION INFO. CMB,SSB,INB,SZB IF F.SFA>0, SZA AND TYPE=0 (NAMED), JMP AI04 (NO - NORMAL) * AI4A LDA F.SFA YES, STATEMENT FUNCTION EXPRESSION PART, RAL,CLE,ERA (CLEAR POSSIBLE SIGN BIT) INA THE F.AF OF THE STMT FCT POINTS TO 2-WORD LDA A,I BLOCK, WITH 1ST WD = REL ADDR, ADA K2 2ND=LINK. (A)=ADDR+1 OF LINK. RSS AI04 ADA DSTH (A) = (ADDRESS OF PTR TO FIRST ENTRY)+1 STA F.A USED TO EASILY INSERT FIRST ELEMENT. STA T4AI (REMEMBER FOR LATER) AI02 LDB F.IDI (B) = FIRST WORD OF I.D. PART LDA F.A (A) = F.A+2 ADA K2 * AI022 ADA KM3 REMEMBER WHERE LINK OF LAST ONE WAS. STA T0AI (MUCHO TIME SPENT IN THIS LOOP!) LDA A,I LINK TO NEXT ENTRY. SZA,RSS END OF TABLE? JMP AI120 YES, GO SET UP NEW SYMBOL. * ADA K2 NO, EASY CHECK, FIRST ID WORD. CPB A,I & IF IT MATCHES THEN RSS WORRY ABOUT MORE. JMP AI022 ELSE IT WAS QUICK! * ADA KM2 SET UP CORRECT F.A STA F.A JMP STC,I GO TO TAILORED COMPARE ROUTINE. * * NEW ENTRY!!! * AI120 LDA F.STY GO TO UNIQUE INSERT CODE. ADA DSTI LDA A,I JMP A,I SKP F.DP NOP ADDRESS OF USER A.T. KM3 DEC -3 KK01 DEF 0,I K2 DEC 2 F.S2B NOP END OF A.T. F.A NOP A.T. CURRENT ADDRESS F.SFA NOP F.A OF STMT FCT, IF CURRENTLY IN ONE. STC NOP T0AI NOP T2AI NOP T3AI NOP T4AI NOP * * LINKED LIST HEADS, COMPARE/INSERT ROUTINE ADDRESSES. * DSTH DEF *+2 LINKED LIST HEADS. NOP NAMED ITEMS. NOP DATA WITH OFFSET. NOP CONSTANTS. NOP DEFS. * DSTC DEF *+1 COMPARE ROUTINES. DEF AI000 NAMED. DEF AI100 DATA WITH OFFSET. DEF AI200 CONSTANTS. DEF AI300 DEFS. * DSTI DEF *+1 INSERT ROUTINES. DEF AI050 NAMED. DEF AI150 DATA WITH OFFSET. DEF AI250 CONSTANTS. DEF AI350 DEFS. SPC 4 * NAMED ITEM COMPARE. * AI000 LDA F.DID GET THE ADDRESS OF WHAT WE WANT STA T1AI SET FOR LOOP LDB F.A INDEX TO THE ADB K2 FIRST I.D. WORD. * AI05 LDA B,I CPA T1AI,I MATCH?? (ALWAYS, FIRST TIME) INB,RSS YEP, STEP B TO NEXT WORD OF TABLE JMP AI02 ID FIELD NOT MATCHED REJECT THE ENTRY ISZ T1AI AND B15.7 IS THIS THE LAST WORD ? SZA,RSS JMP AI05 NO, TRY THE NEXT WORD. * LDA F.A,I MATCH. IS IT A COMMON LABEL ? AND B7000 I.E., IS F.AT=BCOMI ? LDB F.LCF AND LOOKING FOR ONE ? CPA BCOMI IF LOOKING & GOT IT, SZB,RSS RSS (NO) JMP AI06 THEN ACCEPT. * SZB,RSS IF NOT LOOKING, CPA BCOMI AND DIDN'T GET IT, JMP AI02 (NO. REJECT) * LDA F.SFA MATCH. IN STMT FCT FORMALS DEF ? SSA JMP AI5A YES. * SZA,RSS NO. STMT FCT EXPRESSION PART ? JMP AI06 NO. * LDA T4AI YES. DID WE MATCH A STMT FCT FORMAL ? CPA DSTH RSS NO. ISZ F.SFD YES. SET FLAG. JMP AI06 DONE. * AI5A LDA F.A,I STMT FCT FORMALS DEF; AND B170K EXTRACT F.IM OF MATCHED ITEM. STA F.IM LDA T4AI WHICH LIST WERE WE SEARCHING ? CPA DSTH WAS IT THE NAMED ITEM LIST ? JMP AI4A YES. GO SEARCH THE FORMALS LIST NOW. * LDA K76 DOUBLE DEFINED FORMAL... JSB ER.F DOWN THE TUBES... * K76 DEC 76 SKP * NAMED ITEM MATCH. TAG AS VARIABLE OR SUBROUTINE. * AI06 JSB FA.F FETCH ASSIGN LDA F.NTF NO TAG FLAG SET? SZA JMP AI08 YES, DO NOT TAG ITEM LDA F.IU F.IU FLAGGED? SZA JMP AI09 YES. CHECK FOR DUMMY ITEM LDA F.SPF CURRENT STATEMENT LEVEL CPA K4 RSS EXECUTABLE STATEMENT JMP AI01 NO * LDA F.AT YES CPA DUM JMP AI07 F.AT=DUM * AI01 LDA F.SPF SPEC STATEMENT? SZA (YES IF LEVEL 0 OR 1) CPA K1 SPECIFICATION STATEMENT? JMP AI08 YES * AI07 LDA F.TC F.TC=( ? CPA B50 JMP AI13 YES, SUBPROGRAM JSB TV.F NO, TAG VARIABLE JMP AI08 GO CLEAN UP & EXIT. AI09 CPA ARR JMP AI08 DO NOT RE-TYPE DUMMY ARRAY CPA SUB JMP AI08 DO NOT RE-TYPE DUMMY SUBPROG LDA F.AT CPA REL F.AT=REL? JMP AI08 YES LDA F.IDI SSA JMP AI08 TEMP CELL JMP AI01 TAG ITEM AS 'SUB' IF F.TC=( SPC 1 AI13 LDA F.DCF DIM,COM,EQV FLAG SET? SZA,RSS JSB TS.F NO. TAG SUBPROGRAM JMP AI08 SKP * DATA WITH OFFSET COMPARE. * AI100 DLD F.A,I (B) = F.AF LDA F.A,I AND B170K (A) = F.IM CPB F.AF BOTH MUST MATCH. RSS JMP AI02 NO. CPA F.IM JMP AI10 YES. THAT'S IT. GO FA.F & EXIT. JMP AI02 NO. * * CONSTANTS COMPARE. * AI200 LDA F.A,I F.IM MUST MATCH. AND B170K CPA F.IM RSS JMP AI02 NO. * LDB F.D0+1 (# WDS, IN CASE NOT CHAR) CPA CHAR CHARACTER ? RSS (YES) JMP AI202 NO. NORMAL. * DLD F.A,I (B) = EXTENSION ADDR. DLD B,I (B) = LENGTH. CPB F.CSL SAME AS WE'RE LOOKING FOR ? RSS (YES) JMP AI02 NO. MISMATCH. * INB YES. ROUND UP TO WORD COUNT. CLE,ERB (B) = # WORDS TO MATCH. AI202 CMB,INB NEGATE LENGTH. STB T1AI LOOP COUNTER. LDA F.A T2AI = S.T. ADDRESS. ADA K2 STA T2AI LDB F.DID (B) = F.IDI ADDRESS. * AI201 LDA T2AI,I S.T. WORD. CPA B,I MATCH ? (ALWAYS, FIRST TIME) INB,RSS YES. BUMP F.IDI PTR. JMP AI02 NO. ISZ T2AI BUMP S.T. PTR ISZ T1AI COUNT. DONE ? JMP AI201 NO. JMP AI10 YES. GO FA.F & EXIT. * * 'DEF' COMPARE. * AI300 LDB F.AT NORMAL OR EXT+OFFSET ? CPB BCOMI JMP AI310 E+O, GO DO THAT. * LDA F.A,I NORMAL. F.AT MUST MATCH. AND B7000 CPA F.AT JMP AI10 YES, GO FA.F & EXIT. JMP AI02 NO. * AI310 LDA F.A E+O, OFFSET MUST MATCH. GET OFFSET BASE. ADA K3 LDA A,I CPA F.IDI+1 MATCH ? JMP AI10 YES, GO FA.F & EXIT. JMP AI02 NO. SKP * BUILD A BCOMI OR DIM ENTRY, UNLINKED. * AI50 INA,SZA,RSS OR MAYBE TWPE ? JMP AI52 YES. * CLA DIM/BCOMI. F.IU = 0. STA F.IU CLA,INA F.NT=1 STA F.NT LDB F.AT. WHICH IS IT ? CPB BCOMI JMP AI51 BCOMI. * LDA F.ND DIM. SET F.IM = # DIM. RAR,RAR RAR,RAR IOR F.VDM ALSO F.VDM, WHILE WE'RE AT IT. IOR F.DIS AND F.DIS STA F.IM LDB F.ND NOW SET UP TOTAL # BOUNDS, BLS TWO PER DIMENSION. STB T1AI T1AI = NUMBER OF WORDS TO COPY. ADB K3 ALLOW 3 MORE. JSB AST.F ALLOCATE THE SPACE. STB F.A F.A = TABLE ADDR. STB F.AF SET F.AF = F.A ADB K3 (B) = FWA DIMENSIONS. LDA F.DID (A) = SOURCE. JSB .MVW DEF T1AI NOP JMP AI53 GO SET F.AT=DIM, PACK & EXIT. * AI51 LDA F.EM BCOMI. F.IM=0, BUT SET F.EM STA F.IM LDB K3 NORMALLY USE 3 WORDS, SZA BUT IF EMA, INB USE 4. JSB AST.F STB F.A F.A = A.T. ADDR, STB F.AF SET F.AF = F.A, AI53 LDA F.AT. SET F.AT TO DIM/BCOMI, JMP AI14 PACK FIELDS & EXIT. * * BUILD A TWPE ENTRY, UNLINKED. * AI52 LDB K2 ALLOCATE TWO WORDS. JSB AST.F STB F.A SET F.A = TABLE ADDR. STB F.AF SET F.AF=F.A JMP AI15 GO FINISH UP. * * NAMED SYMBOL INSERT. * AI050 LDA F.SFA NOT IN A STATEMENT FUNCTION SZA OR, ISZ T3AI ON SECOND PART OF STMT FCT SEARCH ? JMP AI052 YES. INSERT NORMALLY. * SSA DEFINING THE FORMALS ? JMP AI4A YES. GO LOOK IN FORMALS LIST NOW. * CLA NO. WASN'T FORMAL, MUST BE NORMAL VAR, JMP AI04 SO GO SEARCH THEM. * AI052 LDB F.NWN COMPUTE SYMBOL LENGTH IN WORDS + 3 ADB K3 JMP AI12 GO ALLOCATE, LINK, COPY SYMBOL & PACK FIELDS. * * INSERT CONSTANT. * AI250 LDB F.D0+1 # WDS IN CONSTANT. LDA F.IM CHARACTER ? CPA CHAR RSS (YES) JMP AI252 NO. (B) = LENGTH. * LDB F.CSL YES. COMPUTE WORD LENGTH. INB CLE,ERB LDA B IS IT MORE THAT 10 WORDS ? ADA KM11 SSA,RSS CLB YES. NOT KEPT WITH TABLE ENTRY. AI252 ADB K3 + 3 MORE. JMP AI12 STANDARD STUFF. * * INSERT DEF OR DATA WITH OFFSET. * AI150 EQU * AI350 LDB K4 JUST STANDARD WITH 4 WORDS. LDA F.AT EXCEPT: DEF TO EXTERNAL WITH OFFSET. CPA BCOMI INB WHICH IS 5 WORDS. SKP * ALLOCATE SPACE AND INSERT AT END OF LIST. * (MOVED TO BEGINNING LATER.) * AI12 STB T1AI T1AI = # WORDS ALLOCATED. JSB AST.F ALLOCATE (B) WORDS. STB F.A SET LINK OF LAST ENTRY TO POINT HERE. INB (HASN'T BEEN BUMPED YET) STB T0AI,I SET PREVIOUS LINK. CLB SET NEW LINK TO ZERO. STB F.A,I ISZ F.A (MOVE PAST LINK) * * SET UP F.AF & COPY F.IDI INTO NEW ENTRY. * LDA F.IU IF F.IU = SUB, LDB F.A CPA SUB CLB SET F.AF=0 STB F.AF ELSE SET F.AF = F.A * LDA T1AI LENGTH IS T1AI-3 ADA KM3 STA T1AI LDB K2 TO WORD 2 OF A.T. ENTRY. ADB F.A LDA F.DID FROM F.IDI JSB .MVW DO IT. DEF T1AI NOP * * IF CHARACTER STRING, BUILD EXTENSION. * LDA F.IM WELL ? CPA CHAR RSS (YES) JMP AI15 NO. * LDB K3 YES. 3-WORD EXTENSION. JSB AST.F STB F.AF LINKED THRU F.AF CLA 1ST WD = 0 (ADDR DESCRIPTOR). STA B,I INB LDA F.CSL 2ND WD = F.CSL, LENGTH. STA B,I INB CLA 3RD WD = 0 (BYTE ADDR OF DATA). STA B,I * * SET UP F.AT, PACK FIELDS, AND EXIT. * AI15 LDA STRAB (NORMAL F.AT=STRAB) * AI14 STA F.AT ADDRESS TYPE IOR F.IM ITEM MODE IOR F.IU ITEM USAGE IOR F.NT NAME TAG LDB F.AF (A,B) = WORDS 0,1 DST F.A,I PUT 'EM AWAY. * LDA F.NT NAMED ? SZA,RSS JMP AI06 YES, MUST DETERMINE USAGE. JMP AI08 NO. ALL DONE. SKP * DONE WITH SYMBOL. IF IT'S A SEARCHABLE TYPE AND * NOT A STATEMENT FUNCTION FORMAL, MOVE TO START. * AI10 JSB FA.F FETCH ASSIGNS IF NOT ALREADY. AI08 LDA F.STY TYPE. (B<0 IF NOT SEARCHABLE) LDB T4AI HEAD OF LAST LIST SEARCHED. SZA,RSS IF SYMBOL WAS NAMED, CPB DSTH BUT NOT SEARCHING NAMED LIST, SSA OR NOT A SEARCHABLE TYPE, JMP AI11 THEN DON'T MOVE TO START. * CCB NOW GET CURRENT ITEM'S LINK. ADB F.A STB T1AI (SAVE IT'S ADDR) LDB B,I SET PREV LINK TO CURRENT, STB T0AI,I WHICH DELETES CURRENT ITEM. CCB COMPUTE ADDR OF LIST HEAD. ADB T4AI IN B. LDA B,I GET HEAD OF THIS LIST. STA T1AI,I SET INTO CURRENT LINK. LDA F.A SET HEAD TO POINT TO THIS ITEM. STA B,I * AI11 CLB ZAP: STB F.NTF NO TAG FLAG. STB F.AT. SPECIAL DIM/BCOMI FLAG. STB F.LCF LABELLED COMMON FLAG. LDA F.IM (A) = F.IM JMP AI.F,I EXIT. * F.NTF NOP NON ZERO IF NOT TO BE TAGGED AS NAME K4 DEC 4 B50 OCT 50 K3 DEC 3 B40 OCT 40 K32 EQU B40 KM11 DEC -11 T1AI BSS 1 TEMP CELL F.EXF NOP ENT FLAG F.DCF NOP DIM,COM FLAG B15.7 OCT 100200 BITS 15 & 7 SKP * ALLOCATE SYMBOL TABLE SPACE. * ALLOCATE (B) WORDS, RETURN (B)=START. * AST.F NOP STB T1AST SAVE SIZE. CMB ALSO -1-SIZE. STB T2AST LDA F.LO SET UP ADDR OF BLOCK. STA T0AST ADA T1AST MOVE END OF A.T. OUT. STA F.LO NEW END OF A.T. = STA F.S2B NEW FWA OF STACK 2. LDA F.S2T OLD LWA OF STACK 2 ADA T1AST + SIZE OF BLOCK = STA F.S2T NEW LWA OF STACK 2. * * CHECK FOR MEM OFL. * LDA F.S1T LWA FREE SPACE = FWA OF STACK 1, LDB F.SPF UNLESS: SPECIFICATION LEVEL ? SZB I.E., F.SPF=0 CPB K1 OR 1 ? LDA F.E YES, LWA FREE SPACE = FWA EQUIV TBL. CMA,INA ADA F.S2T (LWA STACK 2) - (LWA FREE SPACE) SSA,RSS COLLISION ? JMP F.OFE YES, DATA POOL OVERFLOW. * * MOVE STACK 2 UP IN MEMORY. * LDA F.S2T START WITH NEW LWA+1 OF STACK 2. INA (AS IF JUST STORED THERE) AST01 ADA T2AST -1-SIZE BACKS UP TO NEXT ITEM. LDB A,I GET DATA FROM OLD ADDR. ADA T1AST + SIZE = NEW ADDR IN STACK 2. STB A,I PUT IT THERE. CPA F.S2B DID WE JUST MOVE 1ST WD OF STACK 2 ? RSS YES. THEN WE'RE DONE. JMP AST01 NO. GO MOVE ANOTHER. * LDB T0AST (B)=FWA OF ALLOCATED SPACE. JMP AST.F,I EXIT. * T0AST NOP FWA OF ALLOCATED BLOCK. T1AST NOP SIZE OF BLOCK. T2AST NOP -SIZE-1 OF BLOCK. SKP * ******************************** * * (B)=NO. OF WORDS PER ELEMENT * * ******************************** SPC 1 NWE.F NOP LDB F.IM ITEM MODE. BLF ALIGN. ADB DNWPE GET FROM TABLE. LDB B,I JMP NWE.F,I * DNWPE DEF *+1 WORDS/ELEMENT TABLE, BY ITEM MODE. DEC 0 NONE: 0 DEC 1 INTEGER: 1 DEC 2 REAL: 2 DEC 1 LOGICAL: 1 DEC 1 TWPE: 1 DEC 4 COMPLEX: 4 DEC 3 EXTENDED: 3 DEC 1 ADDRESS: 1 DEC 2 DOUBLE INTEGER: 2 DEC 2 DOUBLE LOGICAL: 2 DEC 4 DOUBLE PRECISION: 4 DEC -1 CHARACTER: SPECIAL DEC 8 DOUBLE COMPLEX: 8 SKP * **************************************** * * GET FIRST ASSIGNMENT POINTER (NAMES) * * **************************************** SPC 1 * EXIT: AFTER THE NEXT GNA.F CALL, (F.A) WILL POINT TO THE * FIRST A.T. NAME ENTRY (OR ZERO IF NONE). SPC 1 GFA.F NOP LDA DSTH JUST SET F.A = DUMMY HEAD OF LIST. STA F.A JMP GFA.F,I EXIT SPC 3 * ******************************************** * * GET FIRST ASSIGNMENT POINTER (CONSTANTS) * * ******************************************** SPC 1 GFC.F NOP LDA DSTH JUST SET F.A = DUMMY HEAD OF LIST. ADA K2 STA F.A JMP GFC.F,I EXIT SPC 3 * **************************************** * * GET FIRST ASSIGNMENT POINTER (DEF'S) * * **************************************** SPC 1 GFD.F NOP LDA DSTH JUST SET F.A = DUMMY HEAD OF LIST. ADA K3 STA F.A JMP GFD.F,I EXIT SPC 3 * ******************************* * * GET NEXT ASSIGNMEXT POINTER * * ******************************* SPC 1 * ENTRY: F.A=CURRENT POINTER TO ASSIGNMENT TABLE ENTRY * EXIT : (A)=F.A=POINTER TO NEXT ENTRY IN THE ASSIGNMENT TABLE * (A)=0 MEANS END REACHED. SPC 1 GNA.F NOP CCA BACK UP TO POINTER. ADA F.A LDA A,I STA F.A AND SET IT'S ADDRESS JMP GNA.F,I SKP * ******************* * * DEFINE LOCATION * * ******************* SPC 1 * DEFINE: AF(F.A)=RPL (PRESENT LOCATION COUNTER) * F.AT(F.A)=REL SPC 1 DL.F NOP LDA REL JSB DAT.F DEFINE AT LDA F.RPL JSB DAF.F DEFINE F.AF JMP DL.F,I SPC 1 * ************** * * FETCH F.ID * * ************** SPC 1 * COPY NAME FROM TABLE ENTRY TO NID IN A1 FORMAT. * FID.F NOP JSB BNI.F CLEAR NID TO BLANKS LDA F.A,I NAMED ? SLA JMP FID.F,I NO. NO ID FIELD. LDA F.DNI LOC. OF 1ST WD OF NID BUFFER STA T1FID LDB F.A ADB K2 FID02 LDA B,I ALF,ALF AND B177 STA T1FID,I STORE 1ST CHAR INTO NID BUFFER ISZ T1FID BUMP NID BUFFER LOC BY 1 LDA B,I AND B177 STA T1FID,I STORE 2ND CHAR INTO NID BUFFER ISZ T1FID BUMP NID BUFFER LOC LDA B,I END BIT SET ? INB BUMP ID FIELD LOC AND B15.7 (IF ZERO, QUIT) SZA,RSS WELL ? JMP FID02 MORE TO DO. JMP FID.F,I DONE. * T1FID BSS 1 NID BUFFER POINTER SPC 1 B177 OCT 177 VAR OCT 400 IU=2 SKP * ******************** * * COPY SYMBOL NAME * * ******************** SPC 1 * ENTRY: JSB NAM.F (F.A SET UP) * DEF * EXIT: 3 WORDS COPIED. SPC 1 NAM.F NOP JSB FID.F COPY FROM A.T. ENTRY TO NID BUFFER. JSB NTI.F PACK IT. LDB NAM.F GET & RESOLVE ADDRESS. ISZ NAM.F LDB B,I RBL,CLE,SLB,ERB JMP *-2 LDA F.DID SOURCE ADDR. JSB .MVW MOVE 3 WORDS. DEF K3 NOP JMP NAM.F,I EXIT. SKP * ****************** * * TAG SUBPROGRAM * * ****************** SPC 1 TS.F NOP LDA F.IU ALREADY TAGGED 'VAR' ? CPA VAR RSS (YES) JMP TS01 NO. * LDB F.AT YES. IS IT A FORMAL PARAM ? CPB DUM JMP TS03 YES. LEAVE ALONE. (ELSE ERROR) * TS01 CPA SUB OTHERWISE, MUST BE UNUSED OR SUB. RSS JSB NUTST NO USAGE TEST * TS03 LDA SUB JSB DIU.F DEFINE F.IU AS SUBPROG LDA F.AT CPA DUM JMP TS02 IT IS DUMMY * JSB FA.F FETCH ASSIGN LDA F.AT CPA REL JMP TS.F,I EXIT, SUB ALREADY DEFINED * CLA ELSE CLEAR THE F.AF FIELD SO THAT LDB F.A CAN TELL IT'S EXTERNAL SUB, NOT REF'D. INB STA B,I AF(F.A)=0 JMP TS.F,I * TS02 LDA K22 FORMAL PARAM USED AS SUB: LDB F.SFD IS IT A STMT FCT FORMAL ? SZB JSB WAR.F YES, DUMMY ARG SUBSCRIPTED IN ASF JMP TS.F,I * TSE22 LDA K22 JSB ER.F VARIABLE RENAMED AS SUBROUTINE SPC 2 K22 DEC 22 K47 DEC 47 B600 OCT 600 ARR EQU B600 B170K OCT 170000 (FOR F.IM) F.SFD NOP #0 IFF CURRENT ITEM IS STMT FCT FORMAL. SKP SPC 2 * *********** * * F.TC TEST * * *********** SPC 1 * ENTRY: (A)=CORRECT TERMINATING CHAR. SPC 1 TCT.F NOP CPA F.TC JMP TCT.F,I F.TC=(A),EXIT LDA K28 JSB ER.F IMPROPER TERMINATING CHARACTER SPC 2 * ********************* * * NON-CONSTANT TEST * * ********************* SPC 1 NCT.F NOP LDA F.NT SZA,RSS JMP NCT.F,I EXIT, ITEM NOT A CONSTANT LDA K24 JSB ER.F CONSTANT MUST NOT BE PRESENT SPC 2 * ********************** * * CHECK FOR CONSTANT * * ********************** SPC 1 * INPUT: (B)=F.A TO BE CHECKED. * OUTPUT: SKIP IF CONSTANT, AND: (B)=ADDR CONSTANT * (A)=FIRST WORD SPC 1 CFC.F NOP SZB IN REGISTER ? CPB K1 JMP CFC.F,I YES, NOT CONSTANT. LDA B,I F.NT & F.IM SLA,RSS NAMED ? JMP CFC.F,I YES, NOT CONSTANT. AND B170K F.IM SZA,RSS TYPED ? JMP CFC.F,I NO, NOT CONSTANT. LDA B,I GET F.IU AND B600 CPA ARR ARRAY ? JMP CFC.F,I YES, NOT CONSTANT. (DATA WITH OFFSET) ISZ CFC.F ELSE CONSTANT. ADB K2 IF CONST, ITS ADDR. LDA B,I IF CONST, ITS FIRST WORD. JMP CFC.F,I SKP * *********************** * * NON-SUBROUTINE TEST * * *********************** SPC 1 NST.F NOP LDA K25 LDB F.IU CPB SUB JSB ER.F SUBPROGRAM NAME NOT ALLOWED JMP NST.F,I EXIT SPC 2 * **************** * * NON-EMA TEST * * **************** SPC 1 NET.F NOP LDB F.EM LDA K47 SZB WELL ? JSB ER.F EMA: ERROR 47. JMP NET.F,I ELSE DONE. SPC 2 * **************** * * INTEGER TEST * * **************** SPC 1 ITS.F NOP LDA F.IM F.IM=INTEGER? CPA INT RSS YES, O.K. CPA DBI OR DOUBLE INTEGER ? JMP ITS.F,I YES, ALSO O.K. EXIT. * LDA K26 NO JSB ER.F ITEM NOT AN INTEGER * DBI OCT 100000 SPC 2 * ***************** * * NO USAGE TEST * * ***************** SPC 1 NUTST NOP LDA F.IU IS ITEM NAME ALREADY USED? SZA,RSS JMP NUTST,I NO, EXIT LDA K22 YES, NAME ALREADY BEING USED JSB ER.F SPC 2 INT OCT 10000 IM=1 INTEGER K24 DEC 24 K25 DEC 25 K26 DEC 26 K28 DEC 28 SPC 2 * **************** * * TAG VARIABLE * * **************** SPC 1 TV.F NOP LDA F.IU CPA VAR RSS JSB NUTST NO USAGE TEST LDA VAR JSB DIU.F DEFINE F.IU JMP TV.F,I SPC 2 * ************* * * DEFINE F.IM * * ************* SPC 1 * ENTRY: (A)=NEW ITEM MODE SPC 1 DIM.F NOP STA F.IM F.IM=(A) LDA F.A,I AND KK15 =B007777 IOR F.IM STA F.A,I IM(F.A)=F.IM JMP DIM.F,I SPC 2 * ********************** * * ESTABLISH CONSTANT * * ********************** SPC 1 * INPUT: (A)=MODE OF ITEM SPC 1 ESC.F NOP STA F.IM CLA,INA STA F.NT F.NT=1 FOR CONSTANT LDA VAR STA F.IU SET F.IU=VAR JMP ESC.F,I EXIT SPC 2 * ****************************** * * ESTABLISH INTEGER CONSTANT * * ****************************** SPC 1 * INPUT: (A)=CONSTANT. * OUTPUT: (A)=F.A OF CONSTANT. SPC 1 EIC.F NOP STA F.IDI VALUE. LDA INT ESTABLISH IT. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RETURN (A)=F.A JMP EIC.F,I SPC 2 * ************************************* * * ESTABLISH DOUBLE INTEGER CONSTANT * * ************************************* SPC 1 * INPUT: (A,B)=CONSTANT. * OUTPUT: (A)=F.A OF CONSTANT. SPC 1 EJC.F NOP DST F.IDI VALUE. LDA DBI ESTABLISH IT. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RETURN (A)=F.A JMP EJC.F,I SKP * **************** * ESTABLISH DEF * * **************** * * THIS ROUTINE ESTABLISHES A 3 OR 4 WORD ASSIGNMENT TABEL ENTRY * WHICH IF REFERENCED WILL CAUSE A DEF TO BE GENERATED -- * EITHER ALONG THE WAY OR AT THE END OF THE CODE GENERATION. * * CALLING SEQUENCE: * * LDA OFFSET (ONLY ZERO ALLOWED IF ENTRY IS UNDEFINED) * LDB F.A POINTER TO ASSIGNMENT TABEL ENTRY TO BE DEFED * JSB ESD.F * RETURN A=0 * ESD.F NOP STA T1ESD SAVE THE OFFSET STB F.A AND THE A.T. ADDR. JSB FA.F FETCH THE ASSIGNS. LDA F.AT GET LOCATION INFO LDB F.AF ADDRESS TO B CPA BCOM LABELED COMMON REFERENCE? JMP ESD02 YES DO SPECIAL * ADB T1ESD ADD THE OFFSET CPB F.AF IF OFFSET IS ZERO JMP ESD03 THEN USE A POINTER INSTEAD. * ADB K8 SEE IF TOO NEGATIVE FOR SIMPLE. SSB,RSS JMP ESD04 NO. USE SIMPLE DEF. * LDA T1ESD YES. DATA WITH OFFSET: (A)=OFFSET, LDB F.A (B)=BASE F.A JSB EDO.F WHICH CAN TAKE A FULL-WORD OFFSET. ESD03 LDB F.A AT THIS POINT, OFFSET = 0. ADB KK01 SO GENERATE A S.T. REF. RSS ESD04 ADB KM8 DIRECT REF, RESTORE ADDRESS. LDA F.AT CHECK ADDR TYPE: CPA COM IF IN COMMON RSS LDA STRAB USE COM ELSE USE STR-ABS FOR AT STB F.IDI SET VALUE NEEDED * ESD01 STA F.AT SET UP F.AT FOR SEARCH, STA T1ESD AND SAVE FOR LATER (AI.F CHANGES IT) CLA ESTABLISH CONSTANT JSB ESC.F NT=0 IM=0 IU=VAR JSB AI.F ASSIGN ITEM LDA T1ESD RESTORE F.AT JSB DAT.F CLA CLEAR A AND JMP ESD.F,I RETURN * ESD02 LDB F.A IN LABELLED COMMON, LDA T1ESD CAN TRY TO REMOVE DATA WITH OFFSET. JSB CDO.F STA T1ESD OLD OR REVISED OFFSET. LDB F.AF F.A OF BCOMI ENTRY. INB DLD B,I GET THE OFFSET AND F.A OF ADA T1ESD THE MASTER ADD THE OFFSET DST F.IDI STOR FOR THE NEW ID LDA BCOMI SET REQUIRED F.AT JMP ESD01 GO FINISH * T1ESD NOP COM OCT 4000 F.AT=COM BCOM OCT 3000 STRAB OCT 2000 KM8 DEC -8 SKP * ****************************** * * ESTABLISH DATA WITH OFFSET * * ****************************** SPC 1 * ENTRY: AS ESD.F, AND F.IM = TYPE OF NEW ITEM. * EDO.F NOP STA T1EDO SAVE OFFSET, WHILE LDA F.IM SAVE TYPE OF RESULT. STA T2EDO LDA T1EDO RESTORE OFFSET, JSB CDO.F AND RESOLVE DATA WITH OFFSET. STB T1EDO T1EDO=F.A=F.A OF MASTER. * LDB T2EDO F.IM OF NEW. IF TYPES MATCH, CPB F.IM SZA AND THE OFFSET IS ZERO, RSS (NO) JMP EDO.F,I THEN USE THE MASTER ITSELF. * STA F.IDI ELSE CREATE NEW. F.IDI=OFFSET, STB F.IM F.IM=TYPE, CLA,INA F.NT=1 STA F.NT LDA ARR F.IU=ARR STA F.IU CLA SET F.AT=0 (JUST IN CASE) STA F.AT LDA T1EDO F.AF = F.A OF MASTER. (FOR COMPARE) STA F.AF JSB AI.F ENTER. LDA T1EDO,I EXTRACT F.AT OF MASTER. AND B7000 JSB DAT.F AND SET THAT FOR NEW ENTRY. LDB F.A SET F.AF TO F.A OF MASTER. INB LDA T1EDO STA B,I JMP EDO.F,I EXIT. SPC 1 T1EDO NOP T2EDO NOP SKP * **************************** * * RESOLVE DATA WITH OFFSET * * **************************** SPC 1 * ENTRY: (A) = ADDITIONAL OFFSET. * (B) = F.A, POSSIBLY DATA WITH OFFSET. * * EXIT: (A) = TOTAL OFFSET. * (B) = F.A = NON-OFFSET F.A * AND ASSIGNS OF (B) FETCHED. * CDO.F NOP STB F.A SET UP F.A, STA T1CDO AND REMEMBER OFFSET. JSB FA.F FETCH ASSIGNS. JSB STY.F IS THE MASTER A DATA WITH OFFSET ? CPA K1 RSS JMP CDO01 NO. * ISZ F.A YES. FETCH: DLD F.A,I THE F.A OF THE MASTER & THE OFFSET. STA F.A REPLACE ITEM WITH THE MASTER. ADB T1CDO ADD OFFSET TO INPUT OFFSET. STB T1CDO JSB FA.F FETCH ITS ASSIGNS FOR BELOW. CDO01 LDA T1CDO RETURN (A) = TOTAL OFFSET, LDB F.A (B) = F.A JMP CDO.F,I EXIT. * T1CDO NOP OFFSET. SKP * ************* * * DEFINE F.IU * * ************* SPC 1 * ENTRY: (A)=NEW F.IU (SUBR, VAR, OR 0) SPC 1 DIU.F NOP STA F.IU F.IU=(A) LDA F.A,I AND KK16 =B177177 IOR F.IU STA F.A,I IU(F.A)=F.IU JMP DIU.F,I * KK15 OCT 007777 KK16 OCT 177177 KK17 OCT 170777 SPC 2 * ************* * * DEFINE F.AT * * ************* SPC 1 * ENTRY: (A)=NEW AT(F.A) SPC 1 DAT.F NOP STA F.AT F.AT=(A) LDA F.A,I AND KK17 =B170777 IOR F.AT STA F.A,I JMP DAT.F,I SPC 2 * ***************** * * DEFINE F.EM=1 * * ***************** SPC 1 DEM.F NOP LDA K2 JUST SET IT. STA F.EM IOR F.A,I STA F.A,I JMP DEM.F,I EXIT. SPC 2 * **************** * * DEFINE F.S=1 * * **************** SPC 1 DS.F NOP LDA K4 JUST SET IT. STA F.S IOR F.A,I STA F.A,I JMP DS.F,I EXIT. SKP * ************* * * DEFINE AF * * ************* SPC 1 * ENTRY: (A)=NEW F.AF SPC 1 DAF.F NOP STA F.AF F.AF=(A) LDB F.A LDA B,I AND B600 GET F.IU FIELD CPA ARR JSB DAF.G IU(F.A)=ARR LDA F.A,I TEST IF LABELED COMMON AND B7000 CPA BCOM WELL? JSB DAF.G YES INDEX TO THE INFO ENTRY LDA F.IM IF CHARACTER, CPA CHAR JSB DAF.G ALSO GO TO NEXT ENTRY, CPA CHAR RSS BUT USE FIRST WORD. INB POINT TO 2ND WD OF THIS ENTRY. LDA F.AF GET THE VALUE STA B,I STORE IT JMP DAF.F,I RETURN SPC 1 DAF.G NOP INB LDB B,I (B)=GF(F.A) JMP DAF.G,I SPC 2 * ************************** * * CHECK STATEMENT NUMBER * * ************************** SPC 1 CSN.F NOP AND B40 BIT 5 = TYPE BIT. XOR B,I SET TYPE BIT OR CHECK IT. ALF,ALF CHECK DEFINED FLAG. CCE (SET DEFINE BIT) RAL,ELA E = DEFINE BIT. ALF,RAL RESTORE POSITION. RAL SEZ,RSS WAS IT DEFINED ? STA B,I NO. SET TYPE & DEFINE BIT. AND B40 GET TYPE DIFFERENCE (IF WAS DEF) SEZ IF NEW DEFINITION SZA,RSS OR OLD BUT SAME TYPE JMP CSN.F,I THEN O.K., SO EXIT. LDA K32 ELSE ERROR 32. JSB ER.F SKP * ****************** * * FETCH CONSTANT * * ****************** SPC 1 FC.F NOP JSB CDI.F CLEAR F.IDI BUFFER TO 0 JSB NWE.F (B) = # WDS IN CONSTANT. STB T1FC LDA F.A FROM A.T. ENTRY WORD 2 ADA K2 LDB F.DID TO F.IDI JSB .MVW DEF T1FC NOP JMP FC.F,I EXIT. * T1FC NOP # WORDS TO MOVE. SKP * ************************************ * * F.D0 := NUMBER OF WORDS FOR ITEM * * ************************************ SPC 1 * AT THIS POINT, RCO.F MUST HAVE BEEN CALLED. IT HAS CHANGED * THE UPPER BOUNDS INTO THE DIMENSION SIZES (FOR NON-FORMAL ARRAYS). * NWI.F NOP LDA F.IU CPA ARR RSS JMP NWI.F,I * LDA F.ND SET UP COUNTER. CMA,INA STA T1NWI LDA F.LUB SET UP POINTER INTO BOUNDS TABLE. STA T2NWI * * LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, * MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). * NWI01 ISZ T2NWI SKIP LOWER BOUND. LDB T2NWI,I GET UPPER BOUND. ISZ T2NWI (SKIP IT) JSB GCD.F JMP RPLOV SOMEONE GOOFED! * SSA DID SOMETHING GO WRONG ? JMP RPLOV YES. * JSB DMP.F MULTIPLY & REPLACE RUNNING PRODUCT. DEF F.D0 JMP RPLOV OFL. * DST F.D0 ISZ T1NWI INCR LOOP COUNTER. MORE ? JMP NWI01 YES. DO IT. JMP NWI.F,I NO. ALL DONE. (A,B) = PRODUCT. SKP RPLOV LDA K84 OFL IN SIZE CALC. CATASTROPHE! JMP F.ABT * T1NWI NOP LOOP COUNTER. T2NWI NOP BOUNDS TABLE POINTER. K84 DEC 84 SKP * ************************** * * GET CONSTANT DIMENSION * * ************************** SPC 1 * ENTRY: (B) = F.A OF CONSTANT. (MUST BE INT*2 OR INT*4) * EXIT: (A,B) = DOUBLE INTEGER VALUE OF CONSTANT. * RETURNS TO (P+1) IF NOT CONSTANT. (A,B) GARBAGE. * (P+2) IF CONSTANT. * GCD.F NOP STB T1GCD SAVE F.A IN QUESTION. JSB CFC.F CONSTANT ? JMP GCD.F,I NO. FORGET IT. * ISZ GCD.F YES. BUMP RETURN. LDB T1GCD RESTORE F.A LDA B,I (A) = 1ST WD A.T. ENTRY: ELA E=1 IFF INT*4 . ADB K2 GET CONSTANT. DLD B,I IF INT*4, THAT'S ALL. SEZ WELL ? JMP GCD.F,I YES. DONE. * LDB A INT*2. CONVERT IT. ASR 16 SWP JMP GCD.F,I DONE. * T1GCD NOP SKP * ********************************* * * DOUBLE INTEGER ADD (INTERNAL) * * ********************************* SPC 1 * CALLING SEQUENCE: DLD * JSB DAD.F * DEF * --> OVERFLOW OCCURED. (A,B)=LEAST 32 BITS. * --> NO OVERFLOW. (A,B)=SUM. * DAD.F NOP DST T1DAD SAVE ARG1. LDA DAD.F,I GET ARG2. ISZ DAD.F DLD A,I CLE ADD LOWERS. ADB T1DAD+1 CLO PROPOGATE CARRY. DON'T WORRY ABOUT SEZ THE CASE: ARG2U=32767, CARRY, AND INA ARG1U<0, EVEN THOUGH IT'S A SPURIOUS ADA T1DAD (ADD UPPERS) OVERFLOW. SOS OVERFLOW ? ISZ DAD.F NO. NORMAL RETURN. JMP DAD.F,I EXIT. * T0DAD BSS 1 T1DAD BSS 2 ARG1. T2DAD BSS 2 ARG2. SPC 2 * ************************************** * * DOUBLE INTEGER SUBTRACT (INTERNAL) * * ************************************** SPC 1 DSB.F NOP STA T1DAD SAVE (A) WHILE... LDA DSB.F,I GET ARG2 ADDR. ISZ DSB.F STA DSB01 & PUT IN DAD.F CALL. LDA T1DAD RESTORE (A), CMA COMPLEMENT (A,B), CMB JSB DAD.F SUBTRACT ARG2, DSB01 DEF *-* JMP DSB.F,I (IF OFL) * CMA AND COMPLEMENT AGAIN. CMB ISZ DSB.F TAKE GOOD RETURN. JMP DSB.F,I SKP * ************************************** * * DOUBLE INTEGER MULTIPLY (INTERNAL) * * ************************************** SPC 1 * CALLING SEQUENCE: DLD * JSB DMP.F * DEF * --> OVERFLOW. (A,B)=LEAST 32 BITS. * --> NO OVERFLOW. (A,B)=RESULT. * * NOTE: IF EITHER ARGUMENT IS NEGATIVE, OVERFLOW WILL BE * SET, BUT THE RESULT WILL BE THE CORRECT LEAST 32 BITS. * * ALGORITHMIC NOTE: SINCE OVERFLOW IS EXPLICITLY SET WHEN EITHER * OF THE ARGUMENTS IS NEGATIVE, THE CROSS-PRODUCTS CAN BE TAKEN * WITHOUT SIGN CORRECTION: IN XU*YL: * XU<0: OFL ALREADY SET. * XU=0: RESULT ZERO ANYWAY. * XU>0, YL<0: SIGNIFICANT BITS OCCUR IN THE UPPER WORD OF THE * CROSS-PRODUCT, BUT WILL BE CAUGHT BY THE FACT * THAT THE CROSS-PRODUCT IS NEGATIVE. * OF COURSE, THE UPPER WORD OF THE CROSS-PRODUCT IS ONLY NEEDED * TO DETECT OVERFLOW ANYWAY, AND SIGN CORRECTION AFFECT ONLY THE * UPPER WORD. * DMP.F NOP DST T1DAD SAVE ARG1. CLB INITIALIZE OVERFLOW FLAG: RRL 1 (B) = 1 IF ARG1<0, ELSE 0. STB T0DAD LDA DMP.F,I GET ARG2. ISZ DMP.F DLD A,I STB T2DAD+1 (DON'T NEED ARG2U AGAIN) SSA IF ARG2<0, ISZ T0DAD SET THE OVERFLOW FLAG. LDB T1DAD ARE BOTH UPPER WORDS NONZERO ? SZA SZB,RSS RSS NO. THEIR PRODUCT IS ZERO. ISZ T0DAD YES. RESULT UNCHANGED, BUT OFL. * MPY T1DAD+1 YU*XL SZB,RSS TOO BIG ? SSA ISZ T0DAD YES. SET OFL. STA T2DAD SAVE LSB (FIRST CROSS-PRODUCT) * LDA T2DAD+1 DO YL*XU MPY T1DAD SZB,RSS TOO BIG ? SSA ISZ T0DAD YES, SET OFL. ADA T2DAD ADD FIRST CROSS-PRODUCT. SSA IF TOO BIG, ISZ T0DAD SET OFL. STA T2DAD SAVE SUM OF CROSS-PRODUCTS. * LDA T2DAD+1 DO YL*XL. MPY T1DAD+1 STA T1DAD SAVE LOWER PART. LDA T2DAD+1 CORRECT FOR XL<15>. SSA ADB T1DAD+1 LDA T1DAD+1 CORRECT FOR YL<15>. SSA ADB T2DAD+1 SSB TOO BIG ? ISZ T0DAD IF SO, SET OFL. * ADB T2DAD ADD CROSS-PRODUCTS. SSB IF TOO BIG, ISZ T0DAD SET OFL. LDA T0DAD IF OFL NEVER OCCURED, SZA,RSS ISZ DMP.F SKIP ERROR RETURN. LDA B (A) = UPPER RESULT. LDB T1DAD (B) = LOWER RESULT. JMP DMP.F,I EXIT. END ASMB,Q,C HED GLOBALS & INITIALIZATION FOR IC.F NAM IN6.F,8 92834-16002 REV.2030 800226 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE CONTAINS THOSE DATA ITEMS REFERENCED IN IC.F WHICH * MUST BE PRESERVED THROUGHOUT PASS ONE, EVEN THOUGH SEGMENT LOADS * OCCUR. THEY ARE REFERENCED BY OFFSET FROM THE SYMBOL: F.$IC * * SINCE THEY MUST BE INITIALIZED ONLY ONCE PER MODULE, THE * INITIALIZATION ROUTINE IS ALSO LOCATED HERE: IN6.F * ENT F.$IC BASE OF GLOBALS. ENT F.NXN NO INPUT FLAG. ENT F.TC LAST CHARACTER READ. ENT F.NCR NO-CROSS-REFERENCE FLAG. * ENT IN6.F IC.F INITIALIZATION. * * * A EQU 0 B EQU 1 SUP SPC 2 * THE FORMAT OF A CARD BUFFER IS: * * WORDS 0-2: ROOM FOR LINE # FOR LISTING. * 3-43: UP TO 82 CHARACTERS (ROOM TO ADD BLANK AFTER 72) * 44: LENGTH, IN WORDS. * 45: CLIB LINE #. * 46-48: LEFT OVER, NOT CURRENTLY USED. * -------- * TOTAL: 49 WORDS. SKP * INITIALIZE IC.F * IN6.F NOP STB CRD#1 SET CARD BUFFER POINTER ADB K49 FOR BOTH BUFFERS STB CRD#2 SSA IF CALL JUST TO MOVE THE CARD BUFFERS JMP IN6.1 SKIP UNRELATED GARBAGE * CLB,SEZ,INB,RSS IF A NEW COMPILE JMP NOTNW NO * STB FTNF SET THE FTN FLAG CLA ALSO ITS STA CD#F LENGTH, STA CD#P AND SIZE. STA CD#1 AND CLEAR THE LOCAL CARD BUFFERS STA CD#2 ALSO SET NOTNW CLA CLEAR THE NO. CARDS IN STA FIRST SET FIRST FLAG IN6.1 CLA ENTRY FOR BUFFER MOVE ONLY STA CD# TO ZERO LDB DCD#1 SET UP BUFFER JSB SETCA NO. ONE INCASE SNC.F CALLED FIRST CLA,INA STA LIFCC INITIAL COLUMN COUNTER JMP IN6.F,I RETURN * DCD#1 DEF CRD#1 DEF TO CARD BUFFER ADDRESSES K49 DEC 49 SKP * GLOBALS. * F.$IC EQU * BASE ADDR. GLOBALS REF'D BY OFFSET. * EOSF NOP END-OF-STATEMENT FLAG. FIRST NOP FIRST-CARD FLAG. LINOL NOP ADDR OF (ASCII) LINE # IN CURRENT BUFFER. CBA NOP ADDR OF CARD TEXT IN CURRENT BUFFER. CRD#1 DEF *-* ADDR BUFFER # 1. CD#1 NOP CARD NUMBER (WITHIN STMT) FOR BFR #1. CRD#2 DEF *-* ADDR BUFFER # 2. CD#2 NOP CARD NUMBER (WITHIN STMT) FOR BFR #2. CD# NOP CURRENT CARD NUMBER. DCD# NOP PTR TO CURRENT CARD BUFFER CARD NUMBER. CD#F NOP # CARDS IN CARD FILE. CD#P NOP CURRENT POSITION IN CARD FILE. CICNT NOP ADDR WORD COUNT IN CURRENT BUFFER. MLIN NOP ADDR CLIB LINE NUMBER IN CURRENT BUFFER. LIFCC NOP COL # OF START OF 1ST CARD CURRENT STMT. FTNF NOP FLAG INDICATING FTN DIRECTIVE IN PROCESS. * * GLOBALS REF'D DIRECTLY. * F.NXN NOP NO INPUT FLAG. F.TC NOP LAST CHARACTER READ. F.NCR NOP NO-CROSS-REFERENCE FLAG. SPC 2 * CARD BUFFER SETUP ROUTINE. * SETCA NOP SET UP BUFFER POINTER ROUTINE STB DCD# SET LOCAL POINTER TO CARD #. ISZ DCD# LDB B,I GET POINTED TO ADDRESS. STB LINOL SAVE THE LINE NUMBER LOCATION IN BUFF. ADB K3 SKIP OVER LINE NUMBER. STB CBA SET CURRENT BUFFER ADDRESS. ADB K41 INDEX TO CARD LENGTH AREA. STB CICNT SET POINT TO IT. INB AND TO THE LINE COUNT. STB MLIN JMP SETCA,I RETURN * K3 DEC 3 K41 DEC 41 * END ASMB,Q,C HED FTN4X - SCRATCH FILE 1 ACCESS. NAM WS1.F,8 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * * ENTRIES IN THIS MODULE. * ENT CRP.F WRITE A CROSS-REFERENCE PAIR. ENT ES1.F WRITE EOF ON SCRATCH FILE 1. ENT IN3.F INITIALIZE MODULE WS1.F ENT RS1.F READ WORD FROM SCRATCH FILE 1. ENT WS1.F WRITE WORD TO SCRATCH FILE 1. * * EXTERNALS IN OTHER MODULES. * EXT F.A A.T. PTR EXT F.ABT FTN4 ABORT JUMP TARGET. EXT F.CCW FTN OPTION WORD. EXT F.DP FWA ASSIGNMENT TABLE. EXT F.LNN CURRENT LINE NUMBER. EXT F.LO LWA+1 A.T. * EXT EJP.F NEW PAGE ON LISTING. EXT PSL.F WRITE LISING LINE. EXT SKL.F SKIP LINE(S) ON LISING. * * OP SYSTEM INTERFACE. * EXT C.SC1 FCB FOR 1ST PASS FILE. * EXT RED.C CLIB READ PROCESSOR. IFZ EXT RWN.C CLIB REWIND PROCESSOR. (ON IFZ) XIF EXT WRT.C CLIB WRITE PROCESSOR. SPC 2 A EQU 0 B EQU 1 SUP SPC 2 IN3.F NOP INITIALIZATION: CLA JUST SET BUFFER EMPTY, STA COUNT JMP IN3.F,I SKP * **************** * * WRITE A WORD * * **************** SPC 1 WS1.F NOP LDB DBUFR COMPUTE ADDR FOR THIS WORD: ADB COUNT (FWA) + (# WDS BEFORE) STA B,I PUT IT THERE. ISZ COUNT BUMP COUNT. CPB DBUFE FULL ? RSS YES. JMP WS1.F,I NO. DONE. * JSB WRT.C YES. WRITE IT OUT. DEF C.SC1 DEF BUFFR DEF COUNT JMP ERROR (IF ERROR) * CLA NOW SET IT EMPTY. STA COUNT JMP WS1.F,I ALL DONE. SPC 2 * *************** * * READ A WORD * * *************** SPC 1 RS1.F NOP RS1.0 CCB DECREMENT COUNT. ADB COUNT STB COUNT SSB,RSS WAS IT EMPTY ? JMP RS1.1 NO. * JSB RED.C YES. READ ANOTHER RECORD. DEF C.SC1 DEF BUFFR DEF BFSIZ JMP ERROR IF ERROR. * SSB EOF ? (-1) JMP RS1.2 YES. RETURN A=B=-1. * STB COUNT NO. SET UP COUNT, LDA DBUFR AND POINTER. STA T1RS1 JMP RS1.0 GO SEE IF ANY DATA IN RECORD. * RS1.1 LDB T1RS1,I (A)=(B)=DATA. ISZ T1RS1 (BUMP POINTER TO NEXT WORD.) RS1.2 LDA B JMP RS1.F,I DONE. SKP * *************** * * WRITE E-O-F * * *************** SPC 1 * WRITE E-O-F, REWIND, CHECK FOR 'E' OPTION. * ES1.F NOP JSB WS1.F WRITE EXTRA JUNK WORD: 2 LOOK-AHEADS. LDA COUNT ANYTHING IN BUFFER ? SZA,RSS JMP ES1.0 NO. * JSB WRT.C YES. WRITE THE RECORD. DEF C.SC1 DEF BUFFR DEF COUNT (NOTE: F4.2 REWINDS THE FILE) JMP ERROR * * SET BUFFER EMPTY. CHECK FOR 'E' OPTION. * ES1.0 CLA SET BUFFER EMPTY. STA COUNT LDA F.CCW 'E' OPTION ? ALF,ALF SLA,RSS JMP ES1.F,I NO. EXIT. JMP ES1.5 YES. GO DUMP PASS FILE, SYMBOL TABLE. SPC 2 T1RS1 NOP POINTER FOR READING. COUNT NOP # WDS IN BUFFER. DBUFR DEF BUFFR FWA BUFFER. BUFFR BSS 60 BUFFER. DBUFE DEF *-1 LWA BUFFER (MUST FOLLOW 'BUFFR') BFSIZ ABS DBUFE-BUFFR+1 BUFFER SIZE, IN WORDS. SKP * 'E' OPTION. DUMP THE PASS FILE CONTENTS. * ES1.5 EQU * CODE DEPENDS ON AN 'IFZ' . IFZ JSB RWN.C YES. REWIND PASS FILE NOW. DEF C.SC1 JMP ERROR * JSB EJP.F DO THE TITLE. LDA K12 LDB DTTL1 JSB PSL.F CLA LEAVE BLANK LINE. JSB SKL.F * ES1.1 JSB RS1.F START A RECORD. CPA KM1 IF END, JMP ES1.3 SKIP OUT. * LDB A COMPUTE ADDITIONAL LENGTH. BRS,BRS WAS IN UPPER 8 BITS. BRS,BRS BRS,BRS BRS,BRS CMB,SSB,RSS (B) = -(TOTAL LENGTH), UNLESS CCB IT WAS OPERAND. THEN TOT LEN = 1. STB T2ES1 SAVE AS COUNTER. RSS SKIP READ FIRST TIME: (A)=DATA. ES1.2 JSB RS1.F READ ANOTHER WORD. STA T1ES1 SAVE IT. LDB KM6 6 DIGITS. JSB COD.F CONVERT. DEF LINE1+5 LDA T1ES1 ASCII TOO. JSB ALM.F STA LINE1+9 LDA K11 WRITE LINE. LDB DLIN1 JSB PSL.F ISZ T2ES1 MORE IN THIS RECORD ? JMP ES1.2 YES. DO THEM. JMP ES1.1 NO. GO FOR ANOTHER RECORD. * ES1.3 JSB RWN.C REWIND PASS FILE. DEF C.SC1 JMP ERROR * CLA SET BUFFER EMPTY. STA COUNT SKP * DUMP THE SYMBOL TABLE. * JSB EJP.F TITLE FOR SYMBOL TABLE. LDA K11 LDB DTTL2 JSB PSL.F CLA JSB SKL.F LDA F.DP SET UP LOOP. STA T1ES1 * ES1.4 LDA T1ES1 CONVERT ADDRESS. LDB KM5 5 DIGITS. JSB COD.F CONVERT. DEF LINE2+5 LDA T1ES1,I CONVERT CONTENTS. LDB KM6 6 DIGITS. JSB COD.F CONVERT. DEF LINE2+9 LDA T1ES1,I OUTPUT ASCII: AND KK02 REMOVE SYMBOL END BIT. JSB ALM.F IF NOT PRINTABLE, CHANGE TO BLANK. STA LINE2+13 LDA K15 OUTPUT THE LINE. LDB DLIN2 JSB PSL.F ISZ T1ES1 ADVANCE IN MEMORY. LDA T1ES1 DONE ? CPA F.LO JMP ES1.F,I YES. EXIT. JMP ES1.4 NO. LOOP. * T1ES1 NOP T2ES1 NOP KM1 DEC -1 KM5 DEC -5 KM6 DEC -6 K11 DEC 11 K12 DEC 12 K15 DEC 15 KK02 OCT 177577 MASK TO REMOVE SYMBOL END MARK. DTTL1 DEF TTL1 TITLE # 1. TTL1 ASC 12, FIRST PASS FILE. DTTL2 DEF TTL2 TITLE # 2. TTL2 ASC 11, SYMBOL TABLE. DLIN1 DEF LINE1 LINE1 ASC 11, 777777 'ZZ' DLIN2 DEF LINE2 LINE2 ASC 15, 77777: 777777 'ZZ' SKP * ************************************ * * MAP NON-PRINTING CHARS TO BLANKS * * ************************************ * * ALM.F : (A) => (A), TWO CHARACTERS. (B LOST) * ALM.F NOP CLB DO FIRST CHAR. RRR 8 (A)=1ST CHAR, (B)=2ND CHAR, IN UPPER. JSB AM.F SWP SAVE & DO 2ND CHAR. ALF,ALF (A) = 2ND CHAR. BLF,BLF (B) = 1ST CHAR, IN UPPER. JSB AM.F IOR B MERGE JMP ALM.F,I EXIT * * AM.F : (A) => (A), ONE CHARACTER. (B PRESERVED) * AM.F NOP ADA BM177 (A)=CHAR-177 SSA,RSS RUBOUT OR 8-BIT ? CLA,RSS YES. CHANGE TO BLANK. ADA B137 (A)=CHAR-40 SSA CONTROL CHAR ? CLA YES. CHANGE TO BLANK. ADA B40 (A)=CHAR. JMP AM.F,I EXIT. * B40 OCT 40 B137 OCT 137 BM177 OCT -177 SKP * ************************** * * CONVERT OCTAL TO ASCII * * ************************** * * CALL: LDA * LDB <- # DIGITS> * JSB COD.F * DEF WORD ADDRESS, MUST BE DIRECT. * COD.F NOP SUBR TO CONVERT TO OCTAL DIGITS. STB T2COD T2COD = - # DIGITS TO DO. CMB (B) = (# DIGITS) - 1 ADB COD.F,I FORM BYTE ADDRESS OF ADB COD.F,I THE LAST BYTE. ISZ COD.F CLE,ERB (B) = ADDR, (E) = ODD/ EVEN BIT. * COD01 STA T1COD SAVE DATA. AND K7 (A) = NEXT DIGIT. IOR "0" MAKE ASCII. SEZ,RSS WHICH BYTE ? ALF,ALF FIRST, POSITION IT. STA T0COD SAVE NEW BYTE. LDA B,I DATA WORD. AND B377 CLEAR UPPER BYTE. SEZ WAS THAT RIGHT ? XOR B,I NO RESTORE & CLEAR OTHER. IOR T0COD INSERT NEW CHAR. STA B,I CMB (NEEDED TO SUBTRACT 1 & PRESERVE E) SEZ,CME,RSS BACK UP. WAS FIRST BYTE ? INB YES. PREVIOUS WORD. CMB LDA T1COD CLEAR & SHIFT PAST DIGIT. AND KM8 RAR,RAR RAR ISZ T2COD COUNT. DONE ? JMP COD01 NO. LOOP. JMP COD.F,I YES. EXIT. * T0COD NOP T1COD NOP T2COD NOP KM8 DEC -8 K7 DEC 7 B377 OCT 377 "0" OCT 60 XIF JMP ES1.F,I (IF CODE NOT ASSEMBLED: EXIT) SKP * ************************ * * WRITE CROSS-REF PAIR * * ************************ SPC 1 * WRITE TO THE PASS FILE THE CROSS-REF OPERATOR AND * A CROSS-REF PAIR OF THE FORM: * * WORD 1: SYMBOL TABLE ADDR OF IDENTIFIER. (F.A) * WORD 2: SOURCE LINE NUMBER OF OCCURANCE. (F.LNN) SPC 1 CRP.F NOP LDA F.CCW 'C' OPTION ? AND K16 SZA,RSS JMP CRP.F,I NO. IGNORE IT. LDA KK30 COUNT & OPERATOR. JSB WS1.F LDA F.A JSB WS1.F LDA F.LNN JSB WS1.F JMP CRP.F,I DONE. * K16 DEC 16 KK30 BYT 2,36 K99 DEC 99 SPC 2 ERROR LDA K99 ERROR. ABORT, DISASTR 99. JMP F.ABT * END ASMB,Q,C HED LISTING ROUTINES. NAM PSL.F,8 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE CONTAINS ROUTINES TO PRINT LINES ON THE LISTING. * THIS INCLUDES: SOURCE LINES. * ERROR MESSAGES. * MISCELANEOUS COMMENTS. * MIXED LISTING. * CROSS-REF. * SYMBOL TABLE. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) ENT F.ABT ABORT COMPILE ENTRY ENT F.CC CURRENT COL EXT F.CCW FTN OPTION WORD EXT F.CSN CURRENT SEGMENT NUMBER. EXT F.D LOW ADDR OF DO STACK. ENT F.DEB DEF TO ERROR BIT TABLE. EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO HIGH ADDR + 1 DO STACK. EXT F.END END SWITCH (0: EOF NOT ALLOWED) ENT F.EQE EQUIVALENCE ERROR FLAG ENT F.ERF ERROR FLAG (# OF ER.F CALLS) ENT F.ERX ERROR EXIT ADDRESS ENT F.ERN ERROR ARRAY ENT F.FLN FIRST LINE NUMBER OF MODULE. ENT F.LNA ADDRESS OF CURRENT LINE ENT F.LNL LENGTH OF CURRENT LINE ENT F.LNN LINE # OF CURRENT LINE ENT F.LOP NO. LINES LEFT ON THIS PAGE. EXT F.LSP LAST OPERATION FLAG ENT F.OFE DATA POOL OVERFLOW ERROR ENTRY. ENT F.OPT ADDR OF OPTIONS IN TITLE. ENT F.PAS PASS NUMBER. EXT F.SEG LOAD A NEW SEGMENT EXT F.STA FLAG THAT IS 0 UNTIL FTN STMT ENT F.TIM TIME ARRAY ADDRESS IN HEAD ENT F.TL LENGTH OF TITLE, INCL 2 WDS BLANKS. ENT F.TTL START OF TITLE (AFTER 4 BLANKS) * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * ENT ASC.F CONVERT TO 4 ASCII DIGITS ENT CER.F COMPILER ERROR. ENT EJP.F PAGE EJECT SUBROUTINE ENT ER.F ERROR PRINT SUBROUTINE ENT IN1.F INITIALIZATION FOR PSL.F ENT MPN.F MOVE PROGRAM NAME (TO NAM REC, ETC) ENT PCC.F PRINT COMPILER COMMENT. ENT PSL.F PRINT LINE ON PRINTER ENT SKL.F SKIP LINES ON LIST ENT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD TO PASS FILE 1. * * COMPILER LIBRARY ROUTINES USED * EXT C.LST LIST FCB EXT SPC.C SPACE ROUTINE EXT WRT.C WRITE FILE ROUTINE * * LIBRARY ROUTINES * EXT .MVW * SUP * A EQU 0 B EQU 1 SPC 2 * ************************* * * MODULE INITIALIZATION * * ************************* SPC 1 IN1.F NOP SZA IF NEW # LINES PER PAGE, STA LINEP SET IT. CLB,SEZ,RSS NEW COMPILE ? JMP IN1.F,I NO, DONE. STB PGNUM SET PAGE # BACK TO ZERO. CCB FORCE A PAGE EJECT. STB F.LOP JMP IN1.F,I EXIT. SKP * ********************* * * PRINT SOURCE LINE * * ********************* SPC 1 * ENTRY: (B)=BUFFER LOCATION * (A)=NO. OF WORDS TO BE PRINTED * PRINTS LINE, PRECEDED BY PAGE HEADER AND TWO BLANK LINES IF AT * TOP OF PAGE. * PSL.F NOP STA PBFL SAVE NO. OF WORDS TO BE PRINTED STB PBFP SAVE TEXT ADDR LDA F.LOP INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA,RSS AT TOP OF FORM? JSB PHEDR YES. PRINT HEADER ISZ F.LOP JSB WRT.C WRITE THE LINE DEF C.LST THE FCB PBFP DEF PBFP THE BUFFER DEF PBFL IT'S LENGTH JMP EXIT NOTHING TO DO BUT EXIT IF ERROR ON LIST JMP PSL.F,I OK RETURN * * ROUTINE TO CAUSE PAGE EJECT IN LISTING. * EJP.F NOP CLB CPB F.LOP AT TOP OF PAGE? JMP EJP.F,I YES. IGNORE LDA F.LOP GET NUMBER LEFT ON THE PAGE STB F.LOP SET NUMBER LEFT TO ZERO ADA KM6 SET TO SKIP 6 EXTRA ON TTY'S LDB F.CCW GET THE OPTION WORD BLF,BLF TEST IF TTY FORMAT DESIRED SSB,RSS IF NOT LDA KM2 REPLACE FORM FEED WITH SPC TWO LINES FOR CRT'S. JSB SKPCL CALL COMP. LIB. SKIP ROUTINE JMP EJP.F,I RETURN SKP * ROUTINE TO SKIP (A)+1 LINES IN LISTING. * SKL.F NOP LDB F.LOP SZB,RSS AT TOP OF PAGE? JMP SKL.F,I YES. IGNORE. (SHOULDN'T GET HERE) * INA ADB A SSB TEST IF NEAR BOTTOM JMP SKPBN NOT NEAR BOTTOM. JSB EJP.F AT BOTTOM; DO FORMFEED INSTEAD JMP SKL.F,I SKPBN STB F.LOP JSB SKPCL SKIP ROUTINE JMP SKL.F,I * * INTERNAL ROUTINE TO SKIP (A) LINES. * SKPCL NOP SSA COUNT NEGATIVE ? JMP SKP02 YES. GO CALL SPC.C * CMA,INA,SZA,RSS NEGATE COUNT. ZERO ? JMP SKPCL,I YES. DO NOTHING. * STA T1PSL COUNTER. SKP01 JSB WRT.C WRITE A BLANK LINE. DEF C.LST DEF BLNKS DEF K1 JMP EXIT ERROR. EXIT. * ISZ T1PSL COUNT. DONE ? JMP SKP01 NO. MORE. JMP SKPCL,I YES. EXIT. * SKP02 STA T1PSL NEGATIVE COUNT. CALL SPC.C JSB SPC.C FOR A PAGE EJECT ? DEF C.LST DEF T1PSL NOP IGNORE SKIPPING ERRORS, FOR SOME REASON. JMP SKPCL,I EXIT. SKP * ROUTINE TO PRINT HEADER AT TOP OF PAGE. * PHEDR NOP AT TOP OF PAGE; PRINT HEADER ISZ PGNUM LDA PGNUM CLE SUPPRESS LEADING ZEROES. JSB ASC.F SWP (A,B) = 1234 AND B377 CHANGE FIRST DIGIT TO BLANK. IOR B20K RRL 8 (A,B) = 234- DST PAGE SET PAGE. ASSUME < 1000. JSB WRT.C WRITE HEADER. DEF C.LST LIST FCB DEF HEADR ADDRESS OF HEAD DEF F.HDL LENGTH OF HEAD JMP EXIT EXIT IF LIST ERROR LDA F.TL SET UP TRUE TITLE LENGTH, ADA K2 WITH 4 BLANKS ACCOUNTED FOR. STA TTLEN JSB WRT.C THEN TITLE, IF ANY. DEF C.LST DEF TITLE DEF TTLEN LENGTH. JMP EXIT IF LIST ERROR. CLA,INA THEN ONE BLANK LINE. JSB SKPCL LDA LINEP SET # LINES LEFT. CMA,INA AS NEGATIVE IN F.LOP STA F.LOP JMP PHEDR,I SPC 2 PBFL NOP # WDS TO BE PRINTED. LINEP DEC 55 (IN CASE DISASTER) F.LOP NOP PGNUM NOP T1PSL NOP BLNKS ASC 1, K1 DEC 1 KM6 DEC -6 KM2 DEC -2 K2 DEC 2 B20K BYT 40,0 BLANK IN UPPER BYTE. * F.HDL DEC 35 LENGTH OF HEADER. HEADR ASC 03, PAGE , PAGE ASC 03,001 , PAGE #. HEADN ASC 03,FTN. , PROGRAM NAME. ASC 05, OPTS: , F.OPT ASC 06, , OPTIONS. F.TIM ASC 15,HH:MM AM DAY., XX MON., 19XX, CLIB TIME MSG. * F.TL DEC 1 TITLE LENGTH, WITHOUT EXTRA BLANKS. TTLEN NOP COMPUTED TRUE LENGTH. TITLE ASC 2, , 2 BLANKS COLUMNS BEFORE TITLE. F.TTL BSS 33 TITLE. MAX 66 CHARS. SKP * ************************** * * PRINT COMPILER COMMENT * * ************************** SPC 1 * PCC.F PRINTS A LINE JUST LIKE PSL.F, BUT IF THE LISTING HAS BEEN * DELAYED UNTIL PASS TWO, AND WE ARE CURRENTLY IN PASS ONE, THE * LINE IS NOT PRINTED IMMEDIATELY, BUT IS WRITTEN TO THE PASS FILE. * * CALLING SEQUENCE: SEE PSL.F * * ENTRY. SEE WHAT PASS WE'RE ON. * PCC.F NOP STA T1PCC SAVE THE LINE LENGTH. CLA,INA PASS 1 ? CPA F.PAS JMP PCC02 YES. * PCC01 LDA T1PCC RESTORE (A), JSB PSL.F PRINT LINE IMMEDIATELY, JMP PCC.F,I AND EXIT. * PCC02 LDA F.CCW PASS ONE. 'M' OR 'Q' OPTIONS ? AND B4002 SZA,RSS JMP PCC01 NO. PRINT IMMEDIATELY. * * DELAYED LIST. SEND TO PASS FILE. * STB T2PCC SAVE BUFFER ADDR. LDA T1PCC COMBINE LINE LENGTH ALF,ALF IOR K56 AND OPCODE. JSB WS1.F WRITE THAT. LDA T1PCC SET UP COUNT. CMA,INA,SZA,RSS NEGATE. ZERO ? JMP PCC.F,I YES. DONE. * STA T1PCC NO. T1PCC = COUNTER. PCC03 LDA T2PCC,I WRITE A WORD AT A TIME. JSB WS1.F ISZ T2PCC BUMP BUFFER POINTER. ISZ T1PCC BUMP COUNTER. DONE ? JMP PCC03 NO. LOOP. JMP PCC.F,I YES. EXIT. * T1PCC NOP LINE LENGTH / COUNTER. T2PCC NOP BUFFER POINTER. K56 DEC 56 DELAYED PRINT OPCODE. B4002 OCT 4002 Q & M OPTIONS. SKP * ***************** * * ERROR COMMENT * * ***************** SPC 1 * TO PRINT ERROR COMMENT. INPUT: (A) = ERROR NUMBER. * ERROR CLASS DETERMINED BY ER.F & F.ERN * CURRENT LINE DESCRIBED BY F.LNA F.LNL F.LNN F.CC SPC 1 WAR.F NOP STA ERTYP SAVE ERROR NUMBER. CLE (SUPPRESS LEADING ZERO) JSB PD.F CONVERT TYPE TO ASCII. STA ERBFX STA F.LSP SET LAST OPERATION FLAG. * * SET THE BIT IN THE ERROR BIT VECTOR. * LDA ERTYP GET WORD OFFSET. ARS,ARS ARS,ARS ADA F.DEB WORD IN VECTOR. STA T1WAR LDA ERTYP GET BIT OFFSET. AND B17 CMA -(BIT #)-1, LEFT TO RIGHT. CLB,INB WAR06 RBR SHIFT UNTIL BIT IS POSITIONED. INA,SZA JMP WAR06 * LDA T1WAR,I SET THE BIT. IOR B STA T1WAR,I * * SEE IF LISTING DELAYED TILL PASS 2. * CLA,INA IF [Q OR (M&L)] AND PASS 1, DELAY IT. LDB F.ERN UNLESS DISASTER. CPA F.PAS PASS 1 ? SZB AND NOT DISASTER ? JMP WAR01 NO. * LDA F.END END SWITCH SET ? SZA JMP WAR01 YES. DON'T DELAY. * LDA F.CCW OPTIONS. AND B4003 Q,M,L. CPA K3 -Q,+M,+L ? JMP WAR04 YES. DELAY. ALF +Q ? SSA JMP WAR04 YES. DELAY. SKP * SKIP A LINE, CONVERT LINE #. * WAR01 ISZ WARNF (COUNT THE ERROR) CLA SKIP A LINE. JSB SKL.F LDA F.LNN CONVERT LINE #. CLE SUPPRESS LEADING ZEROES. JSB ASC.F SWP DST ERBFY * * LIMIT COL TO LINE LENGTH. IF < 2, IGNORE. * LDA F.CC (A) = COL #. ADA KM2 COL - 2 SSA,INA WELL ? (COL - 1) JMP WAR03 YUP. JUST MESSAGE. LDB F.LNL GET CURRENT CARD LENGTH BLS IN CHARACTERS STB T1WAR SAVE IT CMB,INB IF ERROR IS OFF ADB A THE CARD CLE,SSB,RSS THEN (E=0: ZERO SUPPR IN PD.F) LDA T1WAR USE LAST CHAR. ON THE CARD STA T1WAR SAVE THE COLUMN NUMBER JSB PD.F MAKE TWO ASCII DIGITS STA ERBFZ ERROR COLUMN * * INSERT '?', WRITE LINE, RESTORE. * LDB F.LNA GET THE BUFFER ADDRESS CLE,ELB CONVERT TO CHAR ADDRESS ADB T1WAR ADD THE COLUMN NUMBER CLE,ERB ADDRESS TO B, UPPER, LOWER TO E STB T0WAR SAVE THE ADDRESS LDA B,I AND ITS CONTENTS STA T2WAR FOR TO RESTORE IT LDA "?B" ASSUME EVEN COLUMN. SEZ,RSS TRUE ? JMP WAR02 YES. LDA B,I NO. GET WORD. XOR "?" CNANGE LOWER CHAR TO "?" AND B377 ISOLATE THE UPPER CHARACTER XOR B,I WAR02 STA B,I IN THE BUFFER AFTER THE BAD GUY LDB F.LNA GET THE ADDRESS LDA T1WAR AND THE CHARACTER COUNT ADA K2 ADJUST FOR BLANKS AND ODD ARS CONVERT TO WORDS JSB PSL.F PRINT IT LDA T2WAR RESTORE THE BUFFER STA T0WAR,I JUST IN CASE SKP * SET UP AND PRINT THE ERROR MESSAGE. * WAR03 LDA DWARN ASSUME "WARNING" LDB ER.F CALLED FROM ER.F ? SZB LDA DERRO YES. " ERROR " LDB F.ERN CALLED FROM BOM.F ? SZB LDA DDISA YES. "DISASTR" LDB DERBW JSB .MVW DEF K4 NOP LDA K27 (LENGTH IF COL COUNTER) LDB F.CC IF COL < 01 ADB KM2 SSB THEN LDA K22 SKIP THE 'COLUMN ZZ'. LDB F.LNN IF NO LINE #, SZB,RSS THEN LDA K16 SKIP THE 'AT LINE XXXX'. LDB ERCK1 "ERR N DETECTED ..." JSB PSL.F PRINT ERROR MESSAGE CLA SKIP A LINE. JSB SKL.F JMP WAR05 CLEAR ER.F & EXIT. * * DELAY TILL PASS 2. JUST 'PASS' IT ALONG.... * WAR04 LDA K25 SEND ERROR OPERATOR. JSB WS1.F LDA ER.F ERROR CLASS. JSB WS1.F LDA F.LNN LINE # (DIFFERENT FOR EQUIV) JSB WS1.F LDA F.CC COLUMN #. JSB WS1.F LDA ERTYP ERROR CLASS. JSB WS1.F WAR05 CLA CLEAR ER.F FLAG. STA ER.F JMP WAR.F,I EXIT. SKP * GLOBALS DESCRIBING THE CURRENT LINE. * F.PAS NOP PASS NUMBER. F.LNA NOP ADDRESS F.LNL NOP LENGTH (WORDS) F.LNN NOP LINE # F.FLN NOP FIRST LINE # OF MODULE. F.CC NOP CURRENT COLUMN * * THE ERROR LINE. * ERCK1 DEF *+1 ADDRESS OF ERROR MESSAGE. ASC 02, ** ERBFV ASC 04,FTN. ** ERBFW ASC 04,WWWWWWW ERBFX ASC 10,XX DETECTED AT LINE ERBFY ASC 06,0000 COLUMN ERBFZ ASC 01,ZZ K27 DEC 27 FULL LENGTH OF ERROR MESAGE. K22 DEC 22 LENGTH WITHOUT COLUMN #. K16 DEC 16 LENGTH WITHOUT LINE # OR COLUMN #. K25 BYT 4,31 OPERATOR FOR ERROR. * DERBW DEF ERBFW ADDRESS OF ERROR/WARNING/DISASTR DERRO DEF *+1 ASC 4, ERROR DWARN DEF *+1 ASC 4,WARNING DDISA DEF *+1 ASC 4,DISASTR SPC 1 * F.ERN NOP ERROR ARRAY NOP CUMULATIVE ERROR COUNT NOP CUMULATIVE WARNING COUNT F.ERF NOP NO OF ERRORS WARNF NOP NO. OF WARNINGS. * F.DEB DEF *+1 DEF TO ERROR BIT VECTOR. OCT 0,0,0,0,0,0,0 ERROR BITS 0-111. * T0WAR NOP T1WAR NOP T2WAR NOP "?" OCT 77 "?B" ASC 1,? B377 OCT 377 B4003 OCT 4003 K4 DEC 4 B17 OCT 17 SKP * *************** * * FATAL ERROR * * *************** SPC 1 * TO PRINT AN ERROR MESSAGE & ABORT CURRENT STATEMENT. * INPUT (A) = ERROR TYPE. * F.EQE = SPECIAL PROCESSING FLAG: * =0 NORMAL. EXIT THRU F.EQX . * >0 RECOVERY. EXIT THRU F.EQE . * <0 EQUIVALENCE. JSB THRU F.EQE BEFORE WAR.F . SPC 1 ER.F NOP CPA K84 DATA / CODE OVERFLOW ? JMP F.ABT YES. PUNT. ISZ F.ERF STEP ERROR COUNT. STA ERTYP SAVE ERROR NUMBER. LDA F.EQE EQUIVALENCE ? CMA,SSA,RSS JSB A,I YES, SPECIAL PROCESSING. LDA ERTYP ISSUE MESSAGE. JSB WAR.F LDA F.DO CUT DO STACK. STA F.D LDA F.EQE RECOVERY ? SZA SSA JMP F.ERX,I NO. EXIT THRU NORMAL (F.ERX) EXIT. JMP F.EQE,I YES. EXIT THRU (F.EQE). SPC 1 F.ERX DEF 0 ERROR EXIT ADDRESS. F.EQE DEF 0 SPECIAL PROCESSING FLAG. ERTYP NOP ERROR NUMBER. K84 DEC 84 SPC 2 * ***************** * * ABORT COMPILE * * ***************** SPC 1 F.OFE LDA K3 DATA POOL OVERFLOW. F.ABT ISZ F.ERN BUMP DISASTER COUNT. CLB SET F.CC=0 STB F.CC TO SUPPRESS ECHO & COLUMN #. JSB WAR.F ISSUE MESSAGE. LDA F.CCW TURN OFF C,T OPTIONS. AND BM31 STA F.CCW LDB K3 GO TO SEGMENT 3 JMP EXIT2 TO WRITE THE ERROR DIRECTORY. * EXIT LDB K4 LOAD SEGMENT 4 TO QUIT. EXIT2 STB F.STA JMP F.SEG * BM31 OCT -31 SKP * ****************** * * COMPILER ERROR * * ****************** SPC 1 CER.F NOP ISZ F.ERN BUMP DISASTER COUNT. LDA F.CSN GET CURRENT SEGMENT NUMBER. ALF,ALF IN HIGH BYTE. ADA CECSN PUT IN MSG. STA CECSN CCB GET ADDRESS OF JSB. ADB CER.F JSB COD.F CONVERT FOR PRINTING. DEF CENUM JSB WRT.C WRITE MESSAGE. DEF C.LST DEF CEMSG DEF CELEN JMP EXIT IF ERROR ON WRITE. JMP EXIT ALSO IF NO ERROR ON WRITE. * CEMSG ASC 12, *** COMPILER ERROR AT: CECSN ASC 1,0/ CENUM ASC 3,177777 ASC 15,B *** PLEASE REPORT TO HP *** CELEN ABS *-CEMSG KM3 DEC -3 B3407 OCT 3407 DIGIT MASK. SPC 2 * *************************** * * CONVERT TO OCTAL DIGITS * * *************************** SPC 1 * CALL: LDB * JSB COD.F * DEF <3-WORD ASCII BUFFER> * COD.F NOP LDA COD.F GET THE RESULT ADDR. ISZ COD.F LDA A,I RESOLVE INDIRECTS. RAL,CLE,SLA,ERA JMP *-2 STA T2COD * LDA KM3 CONVERT 6 DIGITS, 2 AT A TIME. STA T1COD LSR 2 SET UP SO ONLY GET 1 BIT FIRST TIME. CER01 RRL 3 MOVE LEFT DIGIT THIS PAIR TO (A). ALF,RAL LEAVE 5 BITS. RRL 3 MOVE RIGHT DIGIT IN. AND B3407 ISOLATE THE DIGITS. ADA "00" FORM ASCII, STA T2COD,I PUT IN BUFFER. ISZ T2COD BUMP BUFFER POINTER. ISZ T1COD BUMP COUNTER. JMP CER01 IF MORE. JMP COD.F,I ELSE DONE. * T1COD NOP COUNTER FOR 3 LOOPS. T2COD NOP RESULT POINTER. SKP * ******************************** * * CONVERT TO FOUR ASCII DIGITS * * ******************************** SPC 1 * ENTRY: (A) = VALUE TO CONVERT. * (E) = 1 TO PRODUCE LEADING ZEROES, 0 TO SUPPRESS. * EXIT: (B,A) = 4 ASCII CHARACTERS. * * NOTE: IF VALUE IS NOT IN RANGE (0,9999) THEN THE RESULT * WILL BE " ??" . * ASC.F NOP ERB (SAVE E-REG) CMA,SSA,RSS < 0 ? (A = -N-1) JMP ASC01 YES. * ADA K10K > 9999 ? (A = -N+9999) CMA,SSA,RSS (A = N-10000) JMP ASC01 YES. * ADA K10K NO. RESTORE ORIGINAL VALUE. ELB RESTORE E-REG. CLB CLEAR FOR DIV. DIV K100 SEPERATE HIGH AND LOW DIGITS STB T1FC SAVE THE LOW ONES JSB PD.F CONVERT THE HIGH DIGITS CPA BLNKS IF DIGITS PRODUCED IN FIRST PART, CLE,RSS (NO - CONTINUE TO SUPPRESS) CCE THEN FORCE LEADING ZERO IN SECOND. STA T2FC SAVE FIRST TWO. LDA T1FC GET THE LOW JSB PD.F CONVERT LDB T2FC RESTORE THE HIGH TO B JMP ASC.F,I RETURN * ASC01 LDB BLNKS OUT OF RANGE. RETURN " ??" LDA "??" JMP ASC.F,I * T1FC NOP T2FC NOP "00" ASC 1,00 "??" ASC 1,?? K10 DEC 10 K100 DEC 100 K10K DEC 10000 SKP * *************** * * PACK DIGITS * * *************** SPC 1 * ENTRY: (A)=TWO DIGIT DECIMAL NUMBER BINARIZED * (E)=0 TO SUPPRESS LEADING OR BOTH ZEROES. * EXIT: (A)=ASCII EQUIVALENT OF ENTRY (A) SPC 1 PD.F NOP CLB DIV K10 ALF,ALF SEZ,SZA,RSS IS ZERO & SUPPRESSED ? ADB B170K YES. MAKE IT BLANK: ' ' - '0' CPB B170K BOTH ZERO & SUPPRESSED ? ADB BM20 YES. MAKE FINAL BLANK: ' ' - '00' ADA B ADA "00" ADD THE ASCII BITS JMP PD.F,I * B170K BYT -20,0 ' ' - '0' BM20 OCT -20 IN LOWER. SPC 2 * **************************************** * * MOVE PROGRAM NAME TO PBUF,ERBF,HEADN * * **************************************** SPC 1 MPN.F NOP STA T1MPN SAVE MOVE FROM LOC. LDB HDLP7 JSB .MVW MOVE NAME TO F.HDL+7,8,9 DEF K3 NOP LDA T1MPN LDB F.DNB ADB K3 JSB .MVW MOVE NAME TO NBUF+3,4,5 DEF K3 NOP LDA T1MPN LDB DERBV JSB .MVW MOVE NAME TO ERBF+1,2,3 DEF K3 NOP JMP MPN.F,I SPC 1 T1MPN NOP MOVE FROM LOC. K3 DEC 3 SPC 1 DERBV DEF ERBFV ADDRESS LOCATION IN ERROR BUFFER. HDLP7 DEF HEADN SPC 1 END ASMB,L HED FTN4X - SEGMENT NAME ADDRESS FETCH NAM SEG.F,8 92834-16002 REV.2030 800226 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ENT SEG.F * A EQU 0 B EQU 1 * * THIS ROUTINE FORMS A SEGMENT NAME, F4X.N, WHERE N IS THE * SEGMENT NUMBER PASSED AS AN INPUT PARAMETER. UPON RETURN, * THE B-REGISTER CONTAINS THE ADDRESS OF THE SEGMENT NAME. * * CALLING SEQUENCE: JSB SEG.F * DEF SEG# SEGMENT NUMBER * * RETURNS: B = ADDRESS OF THE SEGMENT'S NAME * (5 CHARACTERS) * * SEG.F NOP ENTRY LDB SEG.F,I GET ADDRESS OF SEGMENT # LDB B,I GET THE SEGMENT NUMBER BLF,BLF PUT IN UPPER BYTE. ADB "0" ADD TO FORM "N " STB NAM SAVE IN NAME ARRAY LDB NAMA GET ADDRESS ISZ SEG.F STEP RETURN JMP SEG.F,I RETURN * "0" ASC 1,0 NAMA DEF *+1 ASC 2,F4X. NAME = F4X.N NAM NOP * END ASMB,Q,C HED FTN4X COMPILER (SEG: F4X.0) SPECIFICATION STATEMENTS ** NAM F4X.0,5 92834-16002 REV.2030 800812 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ***************************************** * FORTRAN-4 COMPILER OVERLAY 0 ***************************************** * * THIS OVERLAY PROCESSES COMMON, DIMENSION, AND * EQUIVALENCE STATEMENTS, PROGRAM AND DATA STATEMENTS, * AND TYPE DECLARATIONS. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..E EXPLICIT TYPING FLAG. EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE ENTRY. EXT F.AF ADDRES FIELD OF CURRENT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. SUBSCRIPT INFO FLAG EXT F.BGN RETURN FROM F4.0 EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD. EXT F.CRT TEST FOR C/R & GO ON TO NEXT STMT. EXT F.D DO TABLE POINTER EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DCF DIM, COM FLAG EXT F.DID ADDRESS OF F.IDI EXT F.DIS DOUBLE INTEGER SUBSCRIPTING FLAG. EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO LWAM - END OF DO TABLE EXT F.DPJ DEF TO CURRENT PROC. JUMP TABLE. EXT F.DPK DEF TO F.PAK BUFFER. EXT F.DTY IMPLICIT TYPE TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EIM EXPECTED ITEM MODE. EXT F.EM EMA FLAG BIT IN A.T. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.EXF EXTERNAL STATEMEXT FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IMF IMPLICIT FLAG. EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LCF LABELLED COMMON FLAG. EXT F.LNN CURRENT LINE NUMBER. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.ND NUMBER OF DIMENSIONS EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.P1E PASS 1 ERROR RECOVERY POINT. EXT F.PTY PROGRAM TYPE IN NAM RECORD. EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SLF STATEMEXT LEVEL FLAG EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.SPS STATEMEXT PROCESSOR SWITCH EXT F.SXF COMPLEX CONSTANT FLAG EXT F.TC NEXT CHARACTER EXT F.TYP TYPE STATEMEXT FLAG EXT F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR & FETCH CONSTANT. EXT CRP.F CROSS REF PAIR SUB. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DEM.F DEFINE (F.EM) TRUE. EXT DIM.F DEFINE (F.IM) EXT DEM.F SET THE F.EM BIT. EXT DIU.F DEFINE (F.IU) EXT DMP.F DOUBLE INTEGER MULTIPLY. EXT DSB.F DOUBLE INTEGER SUBTRACT. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT EL.F EXCHANGE LINKS OF (F.A) & (B). EXT ER.F ERROR PRINT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT FL.F FETCH LINK OF (B). EXT GCD.F GET CONSTANT DIMENSION (AS DBL INT) EXT GFA.F GET FIRST NAMED S.T. ENTRY. EXT GNA.F GET NEXT S.T. ENTRY. EXT IC.F GET NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDL.F INPUT DUMMY LIST. EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT IN6.F INIT FOR IC.F MODULE EXT INM.F INPUT NAME EXT IOP.F INPUT OPERATOR EXT ISY.F INPUT SYMBOL EXT ITS.F INTEGER TEST EXT KWS.F KEYWORD SEARCH. EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT MVW.F FTN MOVE WORDS. EXT NCT.F TEST FOR NOT A CONSTANT EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT NTI.F MOVE NID TO F.IDI (PACKS) EXT NWI.F SET F.D0 TO # WORDS IN ARRAY EXT PAK.F PACK & OUTPUT ASCII DATA. EXT RP.F INPUT ')' EXT TCT.F TEST (A) = F.TC ELSE ER 28 EXT TS.F TAG SUBPROGRAM SUB. EXT TV.F TAG VARIABLE EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD TO PASS FILE # 1. * * OTHER ENTRY POINTS THIS SEGMENT. * ENT F.BCM BLANK COMMON HEADER. ENT F.CIO ITEM OFFSET (2-WORD INTEGER) * ENT CIO.F COMPUTE ITEM OFFSET. ENT NDS.F NON-DUMMY/SUBROUTINE TEST. * * SPECIAL ACCESS FOR 'RCO.F' * ENT F.RCO JUST POINTS TO RCO.F EXT RCO.F MAIN CAN'T ACCESS IT DIRECTLY. * * FORMAT PROCESSOR IN 'DSP.F'. * EXT F.FMT STMT PROC FOR FORMAT. * * OTHER LIB ROUTINES * EXT .MVW * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 0 OVERLAY # SKP * *-----------------------* * * START HERE. * * *-----------------------* * F4.0 LDA DFP1E SET THE ERROR RECOVERY ADDRESS. STA F.ERX LDA DFPJT AND THE PROC. JUMP TABLE ADDR. STA F.DPJ LDA F.SLF IF BACK IN TO DO CPA K2 A DATA STATEMENT JMP F.DAT JUST GO DO IT * JSB MVW.F MOVE THE CARD BUFFER, DEF F.IDI+1,I TO HERE, DEF F.IDI,I FROM HERE. DEC 98 98 WORDS. LDB F.IDI+1 NOW PASS THE ADDRESS OF CARD BUFFER CCA,CLE TO JSB IN6.F THE ONE WHO MUST KNOW * JMP F.BGN BACK TO READ THE FIRST CARD SPC 1 DFP1E DEF F.P1E PASS 1 ERROR RECOVERY ADDRESS. DFPJT DEF F.PJT DEF TO PROC. JUMP TABLE FOR SEG 0. F.RCO DEF RCO.F SPECIAL ACCESS TO RCO.F K9 DEC 9 SKP * ************************ * * PROCESSOR JUMP TABLE * * ************************ SPC 1 * THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY * THE DISPATCHER. THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS * 0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE * MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS. * THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . * THE ORDINALS FOR THE FIRST 3 ENTRIES ARE SPECIAL-CASED IN THE * DISPATCHER, AND ARE NOT TRUE ORDINALS. * DEF 0 DO (-2) DEF 0 ASSIGNMENT STMT (-1) F.PJT DEF 0 STMT FCT. (0) DEF 0 IF (1) DEF F.EMP EMA DEF 0 END DEF 0 CALL DEF 0 GO TO DEF 0 READ DEF 0 STOP DEF F.REA REAL DEF F.DAT DATA DEF 0 THEN DEF 0 ELSE DEF 0 OPEN DEF 0 WRITE DEF 0 PRINT DEF 0 PAUSE DEF 0 ENDIF DEF 0 CLOSE DEF 0 RETURN DEF F.FMT FORMAT DEF 0 REWIND DEF F.COM COMMON DEF 0 ASSIGN DEF 0 ENCODE DEF 0 DECODE DEF 0 END FILE DEF F.INP INTEGER DEF F.CPX COMPLEX DEF F.LOG LOGICAL DEF F.PRO PROGRAM DEF 0 INQUIRE DEF F.FUN FUNCTION DEF 0 CONTINUE DEF F.EXT EXTERNAL DEF F.IMP IMPLICIT DEF F.DIM DIMENSION DEF 0 BACKSPACE DEF F.BLK BLOCK DATA DEF F.SUB SUBROUTINE DEF F.EQU EQUIVALENCE DEF F.DBL DOUBLE PRECISION SKP * ************ * * EXTERNAL * * ************ SPC 1 F.EXT CLA,INA STA F.EXF SET EXT FLAG JSB INM.F INPUT NAME JSB TS.F TAG SUBPROGRAM SPC 1 * ***************** * * , OR C/R TEST * * ***************** SPC 1 CCRT CLB STB F.LSF CLEAR THE EXPECT FIRST STMT. FLAG LDA F.TC CPA B54 ',' ? JMP F.SPS,I YES. MORE TO PROCESS * STB F.EXF NO. CLEAR EXTERNAL FLAG JMP F.CRT C/R TEST * TYPES ASC 13,NONE REAL INTEGER COMPLEX , ASC 13,LOGICAL DOUBLEPRECISION , DIMPT DEF IMPT-1 ORDINAL TO TYPE TRANSLATION. IMPT OCT 20000,10000,50000,30000,60000 REA EQU IMPT B10K EQU IMPT+1 INT EQU IMPT+1 CPX EQU IMPT+2 LOG EQU IMPT+3 DBL EQU IMPT+4 T1IMP NOP T2IMP NOP T3IMP NOP BM101 OCT -101 K5 DEC 5 B51 OCT 51 B54 OCT 54 B55 OCT 55 B377 OCT 377 B170K OCT 170000 SKP * ************ * * IMPLICIT * * ************ SPC 1 * GET TYPE, HANDLE 'IMPLICIT NONE'. * F.IMP LDB F.IMF HAVE WE SEEN AN 'IMPLICIT NONE' ? LDA K5 IF SO, SSB JSB ER.F ERROR 5. * JSB KWS.F NO. LOOK FOR TYPE. DEF TYPES LDB A (B) = ORDINAL. LDA K28 (ERROR NUMBER) CMB,INB,SZB,RSS GOT ONE ? (B=-ORD) JSB ER.F NO. ERROR. * CMB,SZB 'NONE' ? (B=ORD-1) JMP IMP01 NO. NORMAL TYPE. * LDB F.IMF YES. IS IT THE FIRST IMPLICIT ? LDA K5 SZB JSB ER.F NO. ERROR 5. * CCA YES. SET THE FLAG: -1 = NONE. STA F.IMF JSB ICH.F READ THE C/R. JMP F.CRT THAT'S ALL. * IMP01 CLA,INA NORMAL IMPLICIT. SET FLAG = 1. STA F.IMF ADB DIMPT GET TYPE. LDA B,I JSB MTY.F MODIFY IT IF APPROPRIATE. JSB ICH.F REQUIRE '(' HERE. CPA B50 JMP IMP03 O.K. LDA K9 NO. UNEXPECTED CHAR. JSB ER.F SKP * GET THE RANGE, IN FORM X OR X-Y. * IMP03 JSB ICH.F GET FIRST CHAR OF SET STA T1IMP SET IT SZB IF IT IS NOT SEZ ALF JMP TYP11 GO REPORT THE ERROR * CCA IN CASE SINGLE LETTER, STA T2IMP SET COUNT TO 1. JSB ICH.F GET THE NEXT CHAR CPA B55 '-' IF '-' THEN PART OF RANGE RSS YES. JMP IMP04 NO. ALREADY SET UP. * JSB ICH.F GET THE FINAL CHAR OF A RANGE SZB TEST FOR SEZ ALF JMP TYP11 NOPE BITCH * CMA COMPUTE NEG. NO TO DO ADA T1IMP AND STA T2IMP SET FOR THE LOOP SSA,RSS IF LETTERS BACKWARD JMP TYP11 REPORT ERROR * JSB ICH.F GET NEXT CHAR. * * SET DEFAULTS FOR ALL IN RANGE TO SPECIFIED TYPE. * IMP04 LDB T1IMP GET THE CHARACTER ADB BM101 SUBTRACT 'A' CLE,ERB COMPUITE TYPE ADDRESS IN THE TABLE ADB F.DTY AND GET CURRENT LDA B,I TYPE SEZ ROTATE ALF,ALF IF NEEDED STA T3IMP SAVE RESULT FOR DUP IMPLICIT TEST XOR F.MFL GET THE NEW TYPE AND B377 KEEP THE OLD LOW ORDER BYTE XOR F.MFL RULES OF WOO CHAR REPLACE IOR B400 SET LEAST BIT IN BYTE AS FLAG. SEZ IS CHAR IS TO BE IN LOW WORD ALF,ALF PUT IT THERE STA B,I RESTORE WORD TO THE TABLE LDA K5 WARNING 5 LDB T3IMP IF SECOND REF TO SAME BLF,BLF CHAR SLB JSB WAR.F * ISZ T1IMP STEP TO THE NEXT CHAR ISZ T2IMP STEP THE COUNT (DONE?) JMP IMP04 N0 - DO NEXT CHAR SKP * APPLY IMPLICIT TYPING TO ALL SYMBOLS SO FAR. * JSB GFA.F SET UP TO SCAN NAMED SYMBOLS. IMP05 JSB GNA.F NEXT. SZA,RSS SEE IF DONE. JMP IMP06 YES. * JSB FA.F NO. SET ADDR & FETCH ASSIGNS. LDA F..E EXPLICITLY TYPED ? SZA IF SET JMP IMP05 YES. IGNORE IT. * LDA F.A GET THE FIRST ADA K2 CHAR OF THE NAME LDA A,I TO A ALF,ALF ROTATE AND AND B377 ISOLATE ADA BM101 SUBTRACT 'A' CLE,ERA CONVERT TO CHAR ADDRESS ADA F.DTY ADD THE ADDRESS OF THE TYPE TABLE LDA A,I GET THE TYPE FROM THE TABLE SEZ USE RIGHT END ALF,ALF AND B170K ISOLATE THE MODE JSB DIM.F DEFINE NEW IM JMP IMP05 GO GET NEXT SYMBOL. * * CHECK DELIMITER AFTER RANGE. * IMP06 LDA F.TC YES - GET DELIMITER CPA B54 ',' IF COMMA JMP IMP03 GO DO NEXT CHAR * CPA B51 ')' IF CLOSE THEN RSS OK ELSE JMP TYP11 UNEXPECTED CHAR * JSB ICH.F GET THE NEXT CHAR JMP CCRT GO TEST FOR COMMA SKP * ******* * * EMA * * ******* SPC 1 F.EMP CLA,INA SET DIMENSION FLAG. STA F.DCF JSB INM.F INPUT NAME. LDA F.IU ALREADY DECLARED AS AN ARRAY ? CPA ARR RSS YES. LEAVE IT ALONE. JSB TV.F NO. TAG VARIABLE. LDA F.AT VERIFY A DUMMY CPA DUM RSS JMP EMP2 NO, ERROR JSB DEM.F MAKE IT TYPE EMA. JSB IDC.F PROCESS ANY DIMENSION INFO. JMP CCRT CHECK FOR "," OR "C/R" * EMP2 LDA K94 ERROR 94: NOT DUMMY OR MENTIONED TWICE. JSB ER.F * K94 DEC 94 SPC 3 * *********************************** * * NON-DUMMY & NON-SUBPROGRAM TEST * * *********************************** SPC 1 NDS.F NOP JSB NST.F NON-SUBPROGRAM TEST LDB F.A MUST NOT CPB F.SBF SUBPROGRAM NAME JSB ER.F A SET BY NST.F TO 25 LDA K37 LDB F.AT CPB DUM DUMMY? JSB ER.F ILLEGAL USE OF DUMMY VARIABLE JMP NDS.F,I SPC 1 K37 DEC 37 SKP * ********************* * * TYPE MODIFICATION * * ********************* SPC 1 * ENTRY: (A) = TENTATIVE TYPE. * F.TC = LAST CHAR OF TYPE. * EXIT: F.MFL = TYPE MODIFIED BY 'J', 'Y' AND *N. SPC 1 MTY.F NOP LDB A (B) = TENTATIVE TYPE. LDA F.CCW CHECK FOR 'Y' OPTION AND B1000 SZA,RSS JMP MTY01 NO. CPB DBL YES. TYPE = DOUBLE ? LDB RE8 YES, CHANGE TO REAL*8. MTY01 LDA F.CCW GET 'J' OPTION. AND B10K SZA,RSS JMP MTY02 NO. CPB INT TYPE = INTEGER ? LDB DBI YES, CHANGE TO INTEGER*4. CPB LOG TYPE = LOGICAL ? LDB LO4 YES, CHANGE TO LOGICAL*4. * MTY02 STB F.MFL SAVE TYPE (SO FAR) JSB EXN.F FOLLOWED BY '*N' ? CPA B52 RSS JMP MTY.F,I NO. * JSB ICH.F YES. SWALLOW IT. JSB ICH.F NEXT. DIGIT ? SZB JMP TYP11 NO. ERROR. * ADA BM60 YES. (A) = ITS VALUE. STA F.IDI SAVE. JSB EXN.F LOOK AT NEXT ONE. SZB DIGIT ? JMP MTY05 NO. THAT'S O.K. * JSB ICH.F YES, READ IT OFFICIALLY. ADA BM60 YES. (A) = ITS VALUE. LDB F.IDI (B) = FIRST DIGIT. BLS,BLS 4*FIRST ADB F.IDI 5*FIRST BLS 10*FIRST ADB A WHOLE #. STB F.IDI SAVE IT. MTY05 LDB F.IDI BLF B<11:4> = LENGTH. ADB F.MFL B<15:12> = DEFAULT TYPE. LDA DFTLT SET UP TO SCAN TYPE-LENGTH TABLE. STA T1MTY SKP * SCAN TYPE-LENGTH TABLE FOR MATCH. * MTY03 LDA T1MTY,I NEXT ENTRY. AND BM20 TYPE & LENGTH PART. CPB A MATCH ? JMP MTY04 YES. GOT IT. ISZ T1MTY BUMP TO NEXT ENTRY. SZA MORE ? JMP MTY03 YES. JMP TYP11 NO. ILLEGAL STATEMENT. * MTY04 XOR T1MTY,I MATCH. FETCH NEW TYPE. RAR,RAR ALIGN. RAR,RAR STA F.MFL SAVE FINAL TYPE. JMP MTY.F,I EXIT. * T1MTY NOP F.MFL NOP CURRENT F.IM OF TYPE SPECIFICATION. BM60 OCT -60 SPC 2 * TYPE-LENGTH TABLE. FORMAT IS: * BITS 15:12 - UNMODIFIED TYPE. * 11:4 - LENGTH. * 3:0 - MODIFIED TYPE. * DFTLT DEF *+1 TYPE-LENGTH TABLE. ABS 10040B+1 INTEGER*2 = INT ABS 10100B+8 INTEGER*4 = DBI ABS 20100B+2 REAL*4 = REA ABS 20140B+6 REAL*6 = DBL ABS 20200B+10 REAL*8 = RE8 ABS 30040B+3 LOGICAL*2 = LOG ABS 30100B+9 LOGICAL*4 = LO4 ABS 50200B+5 COMPLEX*8 = CPX ABS 50400B+12 COMPLEX*16 = ZPX ABS 60140B+6 DOUBLE*6 = DBL ABS 60200B+10 DOUBLE*8 = RE8 OCT 100041 INTEGER*2(J) = INT OCT 100110 INTEGER*4(J) = DBI OCT 110043 LOGICAL*2(J) = LOG OCT 110111 LOGICAL*4(J) = LO4 OCT 120146 DOUBLE*6(Y) = DBL OCT 120212 DOUBLE*8(Y) = RE8 ABS 0 (END-OF-TABLE) SKP * *********** * * INTEGER * * *********** SPC 1 F.INP LDA INT JMP TYP02 SPC 1 * ******** * * REAL * * ******** SPC 1 F.REA LDA REA JMP TYP02 SPC 1 * ******************** * * DOUBLE PRECISION * * ******************** SPC 1 F.DBL LDA DBL JMP TYP02 SPC 1 * *********** * * COMPLEX * * *********** SPC 1 F.CPX LDA CPX JMP TYP02 SPC 1 * *********** * * LOGICAL * * *********** SPC 1 F.LOG LDA LOG TYP02 JSB MTY.F MODIFY TYPE BY 'Y', 'J' & *N. SKP * PROCESS ITEMS IN TYPE DECLARATIONS. * LDA DTP17 SUBSEQUENT ITEMS SKIP PREV JUNK. STA F.SPS TYP17 LDA F.LSF LAST STATEMENT FLAG SZA JMP TYP06 1ST STATEMENT OF PROGRAM CLA,INA STA F.TYP SET TYPE FLAG JSB INM.F INPUT NAME TYP03 LDA F.A,I GET OLD EXPLICIT TYPE FLAG AND K8 (CAN'T USE F..E INCASE IT IS DUM,ARR ALREADY) SZA,RSS IF NOT SET THEN JMP TYP05 PROCEED ALL OK * LDA F.IM GET OLD MODE CPA F.MFL SAME AS NEW ONE?? JMP TYP05 RETYPE IM THE SAME * LDA K83 JSB WAR.F RETYPE DIFFERENTLY JMP TYP08 SPC 1 TYP05 LDA F.MFL IOR K8 SET EXPLICID TYPE FLAG JSB DIM.F DEFINE F.IM JSB FA.F FETCH ASSIGN LDB F.IU LDA VAR SZB JMP TYP08 LDB F.AT CPB STRAB JMP TYP08 JSB DIU.F SET F.IU=VAR/CON TYP08 CLA STA F.TYP RESET TYPE FLAG TO INPUT DIMENSION. JSB IDC.F INPUT DIMENSION IF THERE. JMP CCRT SKP * FIRST LINE OF PROG. MAY BE FUNCTION STATEMENT. * TYP06 JSB EXN.F STRIP OFF PRECEDING BLANKS AND JSB IDN.F INPUT DNA: EAT SIX CHARS. LDA F.TC CPA B117 IS NEXT CHAR "O"? JMP TYP0F YES. "O" IN "FUNCTION". CLA,INA STA F.TYP SET TYPE FLAG LDA F.IM SZA JSB AI.F ASSIGN ITEM SZA JMP TYP01 LDA K17 NO MODE: JSB ER.F ILLEGAL OPERAND SPC 1 TYP0F JSB NTI.F PACK NAME TO F.IDI LDB F.DID GET DEF TO IT LDA B,I TEST FOR 'FUNCTION' CPA "FU" INB,RSS SO FAR SO GOOD JMP TYP11 BAD NEWS * LDA B,I NOW CPA "NC" "NC" INB,RSS OK JMP TYP11 BAD * LDA B,I LAST ONE HERE CPA "TI" OK? JSB ICH.F GET THE "N" CPA "N" IF NOT "N" JMP FUN01 * TYP11 LDA K28 ILLEGAL STATEMENT JSB ER.F TERMINATE STATEMENT (NO RETURN) SPC 1 TYP01 LDA F.A STA TYP.A SAVE F.A LDA K24 LDB F.NT SZB,RSS JMP TYP10 JSB WAR.F OPERAND NOT A NAME. RSS TYP10 JSB CRP.F OUTPUT CROSS REF. PAIR. LDA TYP.A STA F.A RESTORE F.A JMP TYP03 SPC 1 DTP17 DEF TYP17 B400 OCT 400 VAR EQU B400 F.IU=2, VARIABLE OR CONSTANT STRAB OCT 2000 F.AT=2, STR-ABS - UNDEFINED TYP.A NOP SAVE F.A B1000 OCT 1000 B100K OCT 100000 DBI EQU B100K LO4 OCT 110000 RE8 OCT 120000 K83 DEC 83 BM20 OCT 177760 K17 DEC 17 K24 DEC 24 B117 OCT 117 'O' "N" OCT 116 "FU" ASC 1,FU "NC" ASC 1,NC "TI" ASC 1,TI K28 DEC 28 SPC 2 * SHORTEN DOUBLE INTEGER * SDI.F NOP LDA F.IM IS IT DOUBLE ? CPA DBI JMP SDI01 YES. * CPA LO4 DOUBLE LOGICAL ? LDA LOG YES, JUST CHANGE F.IM JMP SDI02 * * SDI01 DLD F.IDI TRY TO SHORTEN. SWP ASL 16 SOC FITS ? JMP SDI.F,I NO. LEAVE IT. * STB F.IDI YES. CHANGE TO SINGLE. LDA INT SDI02 STA F.IM JMP SDI.F,I EXIT. SKP * *********************************** * * INPUT DIMENSION (CONDITIONALLY) * * *********************************** SPC 1 IDC.F NOP LDA F.TC NEXT CHAR '(' ? CPA B50 JSB IND.F YES, INPUT DIMENSION. JMP IDC.F,I EXIT. SPC 1 ARR OCT 600 F.IU=3, ARRAY SPC 1 * ************* * * DIMENSION * * ************* SPC 1 F.DIM CLA,INA STA F.DCF SET DIM FLAG JSB INM.F INPUT NAME JSB IND.F INPUT DIMENSION. JMP CCRT CHECK FOR ',' OR 'C/R' . * IND.F NOP LDA F.AT DUMMY CHECK CCB CPA DUM CLB STB T0DIM T0=0 IF DUMMY, ELSE =-1 LDA F.A STA T2DIM T2=F, SAVE F JSB NST.F NON-SUBPROGRAM TEST LDB F.A CHECK IF NAME OF CURRENT MODULE CPB F.SBF IF SO SEND JSB ER.F ERROR 25 (A SET BY NST.F) * LDA K54 LDB F.IU CPB ARR JSB ER.F ARRAY NAME DEFINED TWICE LDA B52 LDB F.TC CPB B50 '(' RSS JSB ER.F ERR 42: ARRAY WITHOUT DECLARATOR LDA T0DIM JSB ISP.F INPUT SUBSCRIPT JSB MVW.F COPY BOUNDS INFO TO F.IDI: DEF F.IDI DEF DSTBL,I DEC 14 14 WORDS: UP TO 7 DIM, UPPER/LOWER. LDA NS NO. OF SUBSCRIPTS STA F.ND FOR AI.F (ALSO NEEDS F.VDM) LDA DIM SET F.AT. = DIM AS SPECIAL FLAG STA F.AT. JSB AI.F TO AI.F, TO BUILD A DIM ENTRY. LDB F.A SET LOWER BOUND CORRECTION TO ZERO. ADB K2 (FLAG TO AEA.F THAT IT IS DOING CLA PROLOGUE CODE, IF PROCESSING FORMAL.) STA B,I ISZ T2DIM EXCHANGE LINKS LDA F.A (USE LOCAL BECAUSE LDB T2DIM,I FETCH LINK IS FOLLED BY STA T2DIM,I POSSIBLE BCOM INA FLAG STB A,I CCB RECOVER ORGIONAL ADB T2DIM F.A STB F.A F.A=ORIGONAL F.A LDA ARR JSB DIU.F DEFINE F.IU=ARR JMP IND.F,I SPC 1 K3 DEC 3 K14 DEC 14 T0DIM BSS 1 SET T0 0(DUMMY) OR -1 T2DIM BSS 1 SAVE F K54 DEC 54 B50 OCT 50 NS BSS 1 NUMBER OF SUBSCRIPTS DIM OCT 6000 F.AT = DIM SKP * ********************** * * INPUT LIST ELEMENT * * ********************** SPC 1 * TO INPUT AN ITEM THAT CAN BE CONTAINED WITHIN A LIST AND INSURE * THAT THE ITEM HAS NOT BEEN TYPED AS DUMMY OR SUBPROGRAM, AND * COMPUTE THE WORD OFFSET INTO THE ITEM (USING SUBSCRIPTS). * CALLED ONLY BY THE DATA STATEMENT PROCESSOR. * * EXIT: F.A = A.T. ADDR OF ITEM. * (A) = WORD OFFSET FROM START OF ITEM. SPC 1 ILE.F NOP JSB NDS.F NON-DUMMY & NON-SUBPROGRAM TEST LDA F.IU CPA ARR JMP ILE01 F.IU=ARR * JSB TV.F TAG VARIABLE CLA SIMPLE VARIABLE, OFFSET = 0. JMP ILE.F,I DONE. * ILE01 JSB ISP.F INPUT SUBS. A>0: CONST, NO LOWER BOUNDS. JSB FA.F FETCH ASSIGNS (F.ND) LDB NS NO. OF SUBSCRIPTS CMB,INB ADB F.ND (# DIM) - (# SUBS) LDA K38 (ERROR #) SSB MORE SUBS THAN DIMS ? JSB ER.F YES. ERROR. * LDA F.D0+1 SAVE # WORDS/ELEMENT ACROSS CIO.F CALL. STA T1ILE LDA NS (A) = # SUBS. CCB COMPUTE ADDR LAST SUBSCRIPT. ADB A (# SUBS) - 1 BLS *2 ADB DSTBL (B) = ADDR LAST SUBSCR. JSB CIO.F COMPUTE ITEM OFFSET. LDA T1ILE RESTORE F.DO (2ND WD ONLY) STA F.D0+1 LDA F.CIO+1 (A) = OFFSET, ALWAYS ONE WORD (NON-EMA). JMP ILE.F,I EXIT. * * THE SUBSCRIPT TABLE. * DSTBL DEF *+1 BSS 14 MUST FOLLOW DSTBL. * T1ILE NOP TO SAVE F.D0 ACROSS CIO.F CALL. K38 DEC 38 SKP * *********************** * * COMPUTE ITEM OFFSET * * *********************** SPC 1 * CIO.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE * BASE OF THE ARRAY. THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F . * * ENTRY: F.A = A.T. ADDR OF ITEM. * (A) = # SUBSCRIPTS (MAY BE ZERO). * (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST) * IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO. * EXIT: F.CIO = TWO-WORD OFFSET IN INTERNAL FORM. SPC 1 CIO.F NOP STB T1CIO SAVE ADDR LAST SUBSCR. CLB INITIALIZE F.CIO = 0 STB F.CIO STB F.CIO+1 STB T0CIO CLEAR OVERFLOW FLAG. CMA,INA,SZA,RSS NEGATE # SUBS. JMP CIO03 IF NONE, DONE. (CLEAR OFL & EXIT) * STA T2CIO ELSE SAVE AS LOOP COUNTER. JSB FA.F SET UP: F.D0 = # WDS PER ELEMENT. DLD F.D0 SAVE THAT. DST T5CIO LDA T2CIO -(#SUBS) CMA (#SUBS)-1 ALS *2 ADA F.LUB ADDR LOWER BOUND LAST SUBSCR. STA T4CIO * * LOOP THRU SUBS & DIMS COMPUTING OFFSET. * CIO01 LDB T4CIO,I F.A OF (NEGATED) LOWER BOUND. JSB GCD.F (A,B) = LOWER BOUND. ISZ T0CIO NOT CONSTANT: SOMEONE GOOFED! DST T6CIO SAVE. CLA (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. CLB DLD T1CIO,I SUBSCRIPT. JSB DAD.F SUBTRACT LOWER BOUND. DEF T6CIO ISZ T0CIO IF TOO BIG. SSA ALSO BAD IF NEGATIVE. ISZ T0CIO SKP JSB DAD.F ADD RUNNING SUM. DEF F.CIO ISZ T0CIO IF TOO BIG. ISZ T2CIO WAS THAT FIRST SUBSCR ? RSS NO. JMP CIO02 YES. DONE. * DST F.CIO SAVE CURRENT VALUE. LDA T4CIO BACK UP TO PREVIOUS DIMENSION. ADA KM2 STA T4CIO DLD A,I (B) = F.A OF ITS SIZE. JSB GCD.F GET VALUE. ISZ T0CIO IF NOT CONSTANT. JSB DMP.F MULTIPLY PREV DIM SIZE BY DEF F.CIO CURRENT VALUE. ISZ T0CIO IF TOO BIG. DST F.CIO SAVE. LDA T1CIO BACK UP TO PREVIOUS SUBSCR. SZA IF FORCED ZERO SUBSCR, DON'T CHANGE. ADA KM2 STA T1CIO JMP CIO01 ARROUND WE GO * CIO02 JSB DMP.F * # WORDS PER ELEMENT. DEF T5CIO ISZ T0CIO IF TOO BIG. DST F.CIO SAVE OFFSET. JSB NWI.F COMPUTE F.D0 = TOTAL SIZE. DLD F.CIO COMPUTE OFFSET - SIZE. JSB DSB.F DEF F.D0 ISZ T0CIO IF OFL. SSA,RSS IF OFFSET >= SIZE, ISZ T0CIO ALSO SET OVERFLOW. LDA T0CIO OVERFLOW INDICATOR. CIO03 CLO SZA IF OVERFLOW OCCURED, STO RETURN OVERFLOW=1. JMP CIO.F,I DONE. F.CIO = OFFSET. * F.CIO OCT 0,0 COMPUTED ITEM OFFSET VALUE. T0CIO NOP OVERFLOW FLAG. T1CIO NOP ADDR CURRENT SUBSCRIPT. T2CIO NOP LOOP COUNTER. T4CIO NOP ADDR F.A ENTRY CURRENT LOWER BOUND. T5CIO BSS 2 # WORDS PER ELEMENT. T6CIO BSS 2 TEMP. * KM2 DEC -2 K39 DEC 39 DUM OCT 5000 F.AT=5, RELATIVE WITHIN DUMMY LOC K8 DEC 8 K19 DEC 19 K11 DEC 11 B72 OCT 72 B100 OCT 100 SKP * ******************* * * INPUT SUBSCRIPT * * ******************* SPC 1 * TO INPUT THE SUBSCRIPT LIST. * ENTRY: (A)=0 DIMENSIONS OF FORMAL PARAMETER. * >0 SUBSCRIPTS, MUST BE CONSTANT. * <0 DIMENSIONS OF NON-FORMAL, MUST BE CONSTANT. * * EXIT: NS=NO. OF SUBSCRIPTS * S-TABLE: DIMENSIONS: F.A'S OF LOWER & UPPER BOUNDS, * AS IN A.T. * SUBSCRIPTS: 2-WORD VALUES OF SUBSCRIPTS. * F.VDM: 100B IF ANY VARIABLE DIMENSIONS. * F.DIS: 40B IF ANY DOUBLE INTEGER BOUNDS. * ISP.F NOP STA T0ISP T0ISP = INDICATOR OF ALLOWABLE SUBSCRIPTS. CLB STB F.VDM CLEAR VARIABLE DIMENSIONS FLAG. STB F.DIS AND DOUBLE INTEGER SUBSCRIPTING FLAG. STB NS NO. OF SUBSCRIPTS =0 LDB DSTBL T4ISP = S-TABLE POINTER. STB T4ISP LDA B50 MUST BE FOLLOWED BY '('. JSB TCT.F * * START OF SUBSCRIPT INPUT LOOP. * ISP01 CCA SET T3ISP TO -1 TO INDICATE THAT STA T3ISP LOWER BOUND MAY BE ALLOWED HERE. ISP02 LDA T0ISP RESTORE (A) SZA JMP ISP06 DIMENSIONS NOT DUMMY. * JSB EXN.F EXAMINE NEXT CHARACTER SOC LETTER ? JMP ISP06 NO. CHARACTER IS A DIGIT OR DELIMITER. SKP * INPUT VARIABLE DIMENSION. * JSB IOP.F INPUT THE JSB TV.F DIMENSION JSB NCT.F MUST NOT BE A CONSTANT LDA F.VDM SET THE VARIABLE DIMENSIONS FLAG. IOR B100 STA F.VDM LDA F.AT MUST BE FORMAL PARAMETER, CPA DUM RSS CPA COM OR IN COMMON, RSS CPA BCOM OR IN LABELLED COMMON. JMP ISP10 * LDA K39 NON-DUMMY DIMENSION VARIABLE JSB ER.F NAME USED WITH DUMMY ARRAY NAME * * INPUT A CONSTANT DIMENSION OR SUBSCRIPT. * ISP06 JSB IDN.F INPUT DNA JSB SDI.F SHORTEN IF DOUBLE. JSB ITS.F INTEGER TEST LDA K19 LDB F.NT IS IT A CONSTANT? SZB,RSS JSB ER.F NO. LOSE. LDA T0ISP ARE WE DOING SUBSCRIPT OR DIMENSION ? CMA,SSA,INA,SZA SUBSCRIPT OR DIMENSION ? (SKIP IF <=0) RSS SUBSCRIPT. SKIP. JMP ISP09 DIMENSION. GO CHECK OUT LOWER BOUNDS. * * SUBSCRIPT. PUT CONSTANT VALUE IN S-TABLE. * LDA F.IM CONSTANTS ONLY. 1/2 WORD INT ? ELA E=1 IFF INT*4 DLD F.IDI (A,B) = CONST IF INT*4 (ELSE IS (A) ONLY) SEZ WHICH ? JMP ISP08 INT*4, GOT IT. * LDB A INT*2, EXTEND IT. ASR 16 SWP ISP08 DST T4ISP,I PUT IN S-TABLE. ISZ T4ISP ISZ T4ISP JMP ISP20 GO LOOK FOR ',' OR ')'. SKP * DIMENSION, LOWER BOUNDS ALLOWED. * ISP09 JSB AI.F ENTER CONSTANT IN A.T. LDB F.A GET ITS VALUE. JSB CFC.F NOP (CAN'T HAPPEN) LDB F.IM AND ITS TYPE. CPA B100K IF (UPPER) BITS = 100000, LDB DBI THEN ALWAYS TREAT AS DBI, LDA F.CCW UNLESS 'S' OPTION. RAL SSA LDB F.IM LDA B40 F.DIS BIT (CAN'T BE EMAP L.B.) CPB DBI CONSTANT DOUBLE INT BOUND OR -32768 ? STA F.DIS YES. SET THE F.DIS BIT. ISP10 LDA F.A (A) = F.A OF BOUND. ISZ T3ISP DO WE ALREADY HAVE A LOWER BOUND ? JMP ISP12 YES. CAN'T HAVE ANOTHER. * LDB F.TC NO. IS THIS A LOWER BOUND ? CPB B72 I.E., FOLLOWED BY ':' ? RSS JMP ISP11 NO. GO SET LOWER BOUND = 1. * STA T4ISP,I YES. SET LOWER BOUND IN PLACE, ISZ T4ISP ADVANCE TO UPPER BOUND, JMP ISP02 AND GO GET THAT. * ISP11 STA T5ISP NO LOWER BOUND. SAVE F.A OF UPPER WHILE.. CLA,INA WE INVENT A LOWER BOUND = 1, JSB EIC.F STA T4ISP,I PUT IN S-TABLE, ISZ T4ISP AND BUMP TO PLACE FOR UPPER BOUND. LDA T5ISP NOW (A) = F.A OF UPPER BOUND. ISP12 STA T4ISP,I PUT UPPER BOUND IN S-TABLE. ISZ T4ISP * * VERIFY THAT UPPER BOUND >= LOWER BOUND. * LDB T4ISP FETCH LOWER BOUND IF CONSTANT. ADB KM2 LDB B,I (B)=F.A OF LOWER BOUND. JSB GCD.F WELL ? JMP ISP20 NOT CONST. * DST T6ISP CONSTANT. SAVE IT. CCB FETCH UPPER BOUND IF CONSTANT. ADB T4ISP LDB B,I (B)=F.A OF UPPER BOUND. JSB GCD.F WELL ? JMP ISP20 NOT CONST. * JSB DSB.F CONST. TAKE: (UPPER)-(LOWER) DEF T6ISP JMP ISP99 OVERFLOW. TOO BIG. * SSA LOWER > UPPER ? JMP ISP90 YES. CAN'T HAVE THAT EITHER. * SZA SIZE > 65536 ? JMP ISP15 YES. ALWAYS DOUBLE INTEGER. * LDA F.CCW NO. IS 'S' OPTION SET ? RAL SSA,RSS IF SO, <= 65536 IS SINGLE. SSB,RSS ELSE <= 32768 IS SINGLE. JMP ISP20 SINGLE. * ISP15 LDA B40 DOUBLE INTEGER DIM, SET THE BIT. STA F.DIS SET F.DIS * * BUMP # SUBSCRIPTS, CHECK FOR END. * ISP20 ISZ NS LDA NS AT LIMIT CPA K7 OF 7 DIMENSION ? JMP ISP22 YES. * LDA F.TC NO. MORE ? CPA B54 I.E., DELIMETER IS ',' ? JMP ISP01 YES. GET ANOTHER. * ISP22 JSB RP.F NO. MUST END WITH ')' . JMP ISP.F,I DONE. * ISP90 LDA K11 LOWER BOUND > UPPER BOUND. JSB ER.F * ISP99 LDA K84 DIMENSION OVERFLOW. JMP F.ABT SPC 2 K84 DEC 84 T0ISP NOP SAVE ENTRY (A) VALUE T3ISP NOP LOWER BOUND FLAG. T4ISP NOP S-TABLE POINTER. T5ISP NOP TEMP FOR F.A OF UPPER. T6ISP BSS 2 TEMP FOR VALUE OF UPPER. SKP * ******************** * * COMMON PROCESSOR * * ******************** SPC 1 * IF UNLABELLED, GO FIND LAST ELEMENT. * F.COM CLA,INA STA F.DCF SET COMMON FLAG CLA CLEAR THE EMA FLAG. STA T1COM JSB EXN.F EXAMINE NEXT CHAR. CPA B57 '/' ? RSS YES, PROBABLY LABELLED. JMP COM07 NO, BLANK. * COM03 JSB ICH.F READ THE '/'. COM04 JSB EXN.F LOOK FOR ANOTHER. CPA B57 IS IT '//' ? JMP COM06 YES, BLANK. * * LABELLED. PROCESS LABEL. * JSB IDN.F INPUT COMMON LABEL. LDB F.NT MAKE SURE IT'S A NAME. SZB,RSS I.E., F.NT=0 SZA,RSS AND F.IM#0. JMP COM09 IF NOT. STB F.IM YES. SET F.IM=0, ISZ F.LCF AND SET FLAG FOR AI.F . JSB AI.F ENTER IN ASSIGNMENT TABLE. LDA F.AT GET ITS TYPE CPA BCOMI IF ALREADY BCOMI THEN JMP COM08 ADDING TO EXISTING LABEL * LDA BCOMI DEFINE F.AT JSB DAT.F TO BCOM JSB TS.F FLAG AS A SUBROUTINE (IT IS EXTERNAL) LDA F.A NOW REDEFINE F.AF JSB DAF.F (TS.F SETS IT TO ZERO) COM08 LDA F.EM SAVE EMA FLAG. STA T1COM LDB F.A SET FOR TRACK DOWN LDA F.TC DO WE HAVE THE PROPER DELIMITER? CPA B57 WELL '/' JMP COM10 GOOD GO TRACK DOWN THE END OF TH LIST * COM09 LDA K4 ERROR WRONG DELIMITER, CONSTANT JSB ER.F OR MORE THAN 6 CHAR. ABANDON THE STMT. SKP * CHAIN THRU COMMON LIST TO FIND END. * COM06 JSB ICH.F READ THE SECOND / IN // COM07 LDB F.BCM SET UP BLANK COMMON HEADER. COM10 STB CT01 SET HEAD COM11 STB CT02 SET CURRENT ADDRESS JSB FL.F FETCH LINK CPA CT01 POINT AT HEAD? JMP COM12 YES THIS IS IT STA B NO AROUND JMP COM11 WE GO. * * GET AND CHECK OUT VARIABLE NAME. * COM12 JSB INM.F GET THE VARABLE NAME JSB NDS.F NON-DUMMY & NON-SUBPROGRAM TEST. LDA F.A UP DATE STA LCOM LAST COMMON LDA K36 SEE IF ALREADY IN COMMON. LDB F.AT CPB COM JSB ER.F ILLEGAL USE OF COMMON NAME CPB BCOM IF ALREAD IN COMMON JSB ER.F ILLEGAL TO RE-ENTER IT. LDA F.IU IF NOT YET TAGED SZA,RSS TAG JSB TV.F TAG AS VARIABLE LDA T1COM IF EMA COMMON, SZA JSB DEM.F SET EMA. * * IF LABELLED, BUILD & LINK-IN A BCOMI ENTRY. * LDB CT01 LABELLED ? LDA COM (A=F.AT FOR BLANK) CPB F.BCM JMP COM13 BLANK. SKIP THIS. * LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F BUILD BCOMI ENTRY. (USES F.EM) LDA CT01 TO DESCRIBE IT LDB F.A SET POINTER ADB K2 TO STA B,I THE MASTER ENTRY LDB LCOM EXCHANGE LINKS JSB EL.F OF (F.A)=BCOMI, (B)=ITEM. LDA BCOMI SET F.AT TO JSB DAT.F BCOMI LDA LCOM RESTORE STA F.A F.A OF THE VARABLE LDA BCOM (A) = F.AT FOR BCOM. SKP * DEF F.AT, INPUT ANY DIM'S, LINK INTO LIST & GO ON. * COM13 JSB DAT.F DEFINE F.AT=COM OR BCOM JSB FA.F RESTORE ASSIGNS FOR DIM PROCESSOR JSB IDC.F INPUT DIMENSION (IF THERE) LDB CT02 EXCHANGE LINKS. JSB EL.F OF (F.A)=ITEM, (B)=PREV. ITEM. LDA F.TC DELIMITER: CPA B57 IF "/", JMP COM04 THEN START OF NEW BLOCK. * CPA B54 ELSE MUST BE COMMA, RSS (YES) JMP F.CRT OR END OF STATEMENT. * JSB EXN.F COMMA. FOLLOWED BY "/" ? CPA B57 JMP COM03 YES. START OF NEW BLOCK. * LDA LCOM NO. SET UP CT02 FOR NEXT ITEM. STA CT02 JMP COM12 AND GO GET IT. SPC 1 LCOM BSS 1 LAST COMMON ASSIGNMENT POINTER K36 DEC 36 COM OCT 4000 F.AT=4 (COMMON) BCOM OCT 3000 F.AT=BCOM BCOMI OCT 7000 F.AT=BCOMI CT01 NOP CT02 NOP T1COM NOP F.EM OF MASTER. K2 DEC 2 K4 DEC 4 B15 OCT 15 B57 OCT 57 NOP 1ST COMMON ASSIGN PTR. DEF *-1 DUMMY LINK TO SELF F.BCM DEF *-2 LINK TO DUMMY B40 OCT 40 SKP * ************************* * * EQUIVALENCE PROCESSOR * * ************************* SPC 1 * ADDS EQUIVALENCE GROUPS TO THE EQUIVALENCE TABLE IN THE FORM: * (-1) (LINE#) (ITEM#1),,,,,(ITEM#N) * WHERE THE ITEMS HAVE THE FORM: * (F.A) (#SUBS) (LAST SUB),,,,(FIRST SUB) * (WHICH, SINCE THE EQUIVALENCE TABLE GROWS DOWNWARDS, PUTS * THE SUBSCRIPTS IN FOREWARDS ORDER FOR CIO.F PROCESSING.) * AND ITEMS WITHOUT SUBSCRIPTS ARE PADDED WITH ONE EXTRA * WORD (LEAVING ROOM FOR 2-WORD OFFSET LATER). SPC 1 F.EQU LDA F.E COPY F.E STA T2GRE (WILL UPDATE AFTER A GOOD GROUP) EQU01 JSB ICH.F REQUIRE '(' CPA B50 CCA,RSS (A=-1) JMP EQU90 NO. ERROR. * JSB GREW2 WRITE (-1). LDA F.LNN WRITE (LINE #) JSB GREW2 * EQU02 JSB ISY.F GET SYMBOL. LDA F.A WRITE (F.A) JSB GREW2 JSB NDS.F MUST NOT BE DUMMY OR SUBROUTINE. CLA DEFAULT IS ZERO-DIM. STA NS LDB F.TC ANY SUBSCRIPTS ? CLA,INA (MUST BE CONSTANT) CPB B50 WELL ? JSB ISP.F YES. GET THEM. LDA NS (A) = # OF SUBSCR. JSB GREW2 WRITE (# SUBS) SZA,RSS ANY SUBSCRIPTS ? JMP EQU04 IF NONE. * ALS 2*(# SUBS) ADA DSTBL LWA+1 SUBSCRIPT LIST. EQU03 ADA KM2 GO BACK TO PREV. SUBSCR. STA T1EQU INA WRITE 2ND WORD FIRST. LDA A,I JSB GREW2 2ND WORD. LDA T1EQU,I FIRST WORD. JSB GREW2 LDA T1EQU WAS THAT THE FIRST ONE ? CPA DSTBL JMP EQU05 YES. DONE. JMP EQU03 NO. KEEP GOING. * EQU04 JSB GREW2 NO SUBSCR. LEAVE EXTRA WORD. * EQU05 LDA F.TC MORE IN THIS GROUP ? CPA B54 (IE COMMA) JMP EQU02 YES. DO THEM. * JSB RP.F REQUIRE ')' LDB T2GRE MAKE THE GROUP PERMANENT. STB F.E CPA B54 ANOTHER GROUP ? JMP EQU01 YES. DO IT. * CPA B15 END ? JMP F.CRT YES. ALL DONE. * EQU90 LDA K28 SYNTAX ERROR IN EQUIVALENCE. JSB ER.F DOWN THE TUBES. * T1EQU NOP * * SUBROUTINES TO READ & WRITE 'DO' STACK. * GRER2 NOP READ EQUIV TABLE INTO (A) USING (T2GRE) CCB BACK UP T2GRE. ADB T2GRE STB T2GRE LDA B,I (A) = DATA. JMP GRER2,I EXIT. * GREW2 NOP WRITE (A) INTO EQUIV TABLE USING (T2GRE) LDB F.LO TOP OF A.T. + 1 CMB -F.LO-1 (F.LO: MIN ALLOWABLE F.E) ADB T2GRE (T2GRE-1)-F.LO SSB NEW T2GRE < F.LO ? JMP F.OFE YES, MEM OVERFLOW. * ADB F.LO NEW T2GRE = T2GRE-1 STB T2GRE STA B,I STORE DATA. JMP GREW2,I EXIT. * T2GRE NOP POINTER INTO DO STACK. SKP * ********************** * * FUNCTION PROCESSOR * * ********************** SPC 1 F.FUN CLA CLEAR EXPLICIT TYPING FLAG. STA F.MFL FUN01 CLA,INA SET FUNCTION FLAG. STA F.SFF JMP SUBP0 START IT UP. SPC 1 * ************************ * * SUBROUTINE PROCESSOR * * ************************ SPC 1 F.SUB CLA CLEAR EXPLICIT TYPING FLAG. STA F.MFL SUBP0 LDB F.LSF 1ST STATEMENT? SZB JMP SUBP1 YES * NFSTM LDA K34 JSB ER.F PROG/SUBR/FUNCTION NOT 1ST STATM SPC 1 K7 DEC 7 K34 DEC 34 SPC 1 SUBP1 CLA SET STMT. LEVEL BACK TO ZERO STA F.SPF INCASE IT IS A TYPED FUNCTION LDA K7 SUBR/FUNC = TYPE 7 STA F.PTY ISZ F.DCF SET DIM,COM FLAG TO FOOL AI.F IN CASE OF '(' JSB INM.F INPUT NAME JSB SPN.F SET THE PROGRAM NAME. LDB F.A STB F.SBF SET SUBPROGRAM FLAG CLA SET F.AF=0 JSB DAF.F TO TERMINATE FORMALS LINKED LIST. LDA F.MFL MODE FLAG SET? LDB A IOR K8 SET EXPLICIT TYPE FLAG SZB TYPE BEING SET? JSB DIM.F YES. DEFINE F.IM LDA F.TC CPA B54 STRING AFTER? JMP SUBP6 YES GO HANDLE * CPA B15 JMP SUBP6 F.TC=C/R: NO ARGUMENTS. * JSB IDL.F INPUT DUMMY LIST. LDB F.SBF RESTORE F.A OF SUBR/FUCT, STB F.A JSB DAF.F SO CAN SET F.AF = F.A OF 1ST FORMAL. SUBP4 LDA F.DO INITIALIZE ????????????????????? STA F.D F.D=F.DO JMP PROG9 C/R TEST SPC 1 SUBP6 LDB F.SFF FUNCTION? LDA B52 SZB JSB WAR.F YES. WARNING 42: NO ARGUMENT LIST JMP SUBP4 SKP * ********************************** * * BLOCK DATA STATEMENT PROCESSOR * * ********************************** * F.BLK LDA K2 SET PROGRAM TYPE SWITCH STA F.SFF TO 2 LDA F.LSF TEST IF FIRST STATEMENT SZA,RSS WELL? JMP NFSTM NO GO BITCH * LDA K7 SET UP TO INPUT STA F.PTY PROGRAM NAME JSB IDN.F INPUT POSSIBLE BLOCK DATA NAME LDA F.NT GET ONE? SZA JMP PROG1 NO BITCH * JMP PROG9 GO TEST FOR PRAM STRING. SPC 3 * ******************** * * SET PROGRAM NAME * * ******************** SPC 1 SPN.F NOP JSB NTI.F MOVE NID TO F.IDI LDA F.DID JSB MPN.F MOVE PROG NAME TO PBUF,ERBF,HEAD JMP SPN.F,I EXIT. SPC 1 T1PRO BSS 1 TO SAVE PBUF POINTER. T2PRO BSS 1 T3PRO BSS 1 K35 DEC 35 K93 DEC 93 BL2B ASC 1, SKP * ******************************* * * PROGRAM STATEMENT PROCESSOR * * ******************************* * * READ "PROGRAM PNAME,(TYPE,PRIOR,RES,EMULT,HR,MIN,SEC,MS)" * TEXT FOLLOWING ")" TO EXTEND NAM RECORD SPC 1 F.PRO LDA F.LSF 1ST STATEMENT? SZA,RSS JMP NFSTM NO, ERROR LDA K4 STA F.PTY DEFAULT LG BKGND DISK RESIDENT JSB EXN.F EXAMINE NEXT CHAR. SZB,RSS DIGIT? JMP PROG1 YES. LOSE. CPA B15 'C/R' CLA,INA,RSS JMP PROG4 STA F.CC F.CC=1 JMP PROG6 SPC 1 PROG1 LDA K24 JSB ER.F ILLEGAL CONSTANT. SPC 1 PROG4 JSB IDN.F INPUT PROGRAM NAME SZA IF NO NAME F.IM=0 JSB SPN.F NAMED. SET THE PROGRAM NAME. LDA F.TC CPA B50 '(' JMP PROG7 CPA B54 ',' JMP PROG7 PROG6 JMP F.CRT C/R TEST SPC 1 PROG7 LDA F.DNB ADDR OF PBUF+9 ADA K9 STA T1PRO PARAM POINTER ADA K8 SET UP THE NAM BUFFER STOP STA T2PRO POINTER PROG8 JSB EXN.F EXAMINE NEXT CHARACTER SZB,RSS DIGIT? JMP PROG2 YES. JSB ICH.F NO. READ IT FOR REAL. CPA B54 F.TC = ',' ? RSS JMP PROG3 ISZ T1PRO NO. NULL PARAM. PROGA LDB T2PRO LOC OF PBUF+17 CPB T1PRO ALL PARAMS READ? JMP PROG3 YES. JMP PROG8 SPC 1 PROG2 JSB IDN.F INPUT DO NOT ASSIGN JSB SDI.F SHORTEN IF DOUBLE INTEGER. LDB F.IM MUST BE SINGLE INTEGER NOW. LDA K14 ELSE ERROR 14. CPB INT RSS O.K. JSB ER.F * LDA F.IDI DIGIT STRING JUST INPUT STA T1PRO,I STORE INTO PBUF ISZ T1PRO BUMP PBUF POINTER LDA F.TC CPA B54 ',' JMP PROGA PROG3 CPA B51 ")" ? JSB ICH.F GET THE NEXT CHARACTER PROG9 LDA F.TC DELIMETER ? CPA B54 IF COMMA THEN RSS SET UP NAM RECORD COMMENT JMP PRO12 NOT COMMA MUST BE CARRAGE RETURN * LDA F.DNB SET UP TO ACCESS THE NAM BUFFER ADA K17 STA T2PRO ADDRESS OF WORD 17 LDA K35 STA T3PRO CHARACTER COUNT PRO10 JSB IC.F CPA B15 JMP PRO12 END OF STMT. * LDB T3PRO CPB K121 IF NO MORE ROOM, JMP PRO11 TEST FOR ALL BLANKS. * SLB,INB ALF,SLA,ALF XOR T2PRO,I XOR B40 INSERT/REMOVE BLANK STA T2PRO,I STUFF CHAR IN NAM REC STB T3PRO SLB,BRS ISZ T2PRO BUMP POINTER CPA BL2B IF TRAILING BLANKS, JMP PRO10 DON'T UPDATE WORD COUNT. * STB F.DNB,I ELSE UPDATE WORD COUNT, JMP PRO10 AND GO FOR MORE. * PRO11 CPA B40 87TH CHAR: IF BLANK, JSB ICH.F LOCATE NEXT NON-BLANK (ERROR IF ANY) PRO12 LDB F.PTY NOW CHECK PROG TYPE. LDA K61 CPB K5 IF TYPE = 5, JSB WS1.F ISSUE A SEGMENT START OPCODE. JMP F.CRT MUST NOW BE END OF STMT. * K26 DEC 26 K121 DEC 121 K61 DEC 61 K72 DEC 72 SKP * ****************** * * DATA PROCESSOR * * ****************** SPC 1 * CAUTION: F.SPS IS NOT ALWAYS SET. * INITIALIZE DO TABLE FOR LIST ITEMS. * F.DAT LDA F.DO SET TO WRITE INTO DO TABLE. STA T2GRE * * NEXT LIST ITEM: GET SYMBOL & DO ERROR CHECKING. * DATA0 JSB ISY.F INPUT SYMBOL JSB NDS.F CAN'T BE DUMMY OR SUBROUTINE. LDA F.IU IF NOT ARRAY, CPA ARR RSS JSB TV.F MUST BE VARIABLE. (REQ'D FOR AA.F) LDA K93 LDB F.EM EMA ? CLE,SZB (E=0) JSB ER.F YES. CAN'T DO EMA. LDB F.SFF BLOCK DATA ? CPB K2 CME YES. MUST BE LABELLED COMMON. LDA K72 (ERROR NUMBER FOR COMMON) LDB F.AT HOW 'BOUT BLANK COMMON ? CPB COM JSB ER.F YUP. IT NEITHER. CPB BCOM LABELLED COMMON ? CME YES. MUST BE BLOCK DATA. SEZ EITHER OF ABOVE VIOLATED ? JSB ER.F YES. ERROR 72. CPB BCOM IF NOT BLOCK COMMON, RSS JSB AA.F ASSIGN VARIABLES NOW. * * IF ARRAY NAME ONLY, USE WHOLE ARRAY, * OTHERWISE USE SIMPLE ITEM OR ARRAY ELEMENT. * LDA F.IU ITEM USAGE. LDB F.TC NEXT CHAR. CPA ARR IF NOT ARRAY, CPB B50 OR ARRAY AND FOLLOWED BY '(', JMP DATA1 THEN JUST DO SIMPLE ITEM. * JSB NWI.F ELSE WHOLE ARRAY. SET F.D0 = # WORDS. CLA,RSS (A) = OFFSET = 0. DATA1 JSB ILE.F INPUT LIST ELEMENT: (A) = OFFSET. SKP * SAVE THE OFFSET, F.A & # WORDS IN DO TABLE. * JSB GREW2 OFFSET. LDA F.A F.A JSB GREW2 LDA F.D0+1 NUMBER OF WORDS PER ITEM JSB GREW2 * * IF ',' THEN READ MORE ITEMS, ELSE READ '/' & DATA. * LDA F.TC CPA B54 , ? JMP DATA0 YES. GET MORE VARIABLES. * LDA B57 ELSE MUST BE '/' JSB TCT.F F.TC-TEST LDA T2GRE REMEMBER END OF DO TABLE. STA T3DAT CLA START READING VALUES: STA KBAR REPEAT COUNT = 0 (NONE) STA T2DAT # WDS LEFT CURRENT ITEM = 0. LDA F.DO SET UP TO READ LIST BACK. STA T2GRE * * READ ANOTHER LIST ITEM. * DATA6 LDA T2DAT ANY LEFT IN CURRENT ITEM ? SZA JMP DATA4 YES, DO THAT FIRST. * JSB GRER2 T4DAT = OFFSET. STA T4DAT JSB GRER2 F.A = ITEM. STA F.A JSB GRER2 T2DAT = # WORDS IN ITEM. STA T2DAT JSB FA.F FETCH ITEM ASSIGNS. LDA F.IM T0DAT = LIST ITEM MODE. STA F.EIM (SET UP FOR IDN.F: DBL VS RE8) STA T0DAT LDA KBAR UNFINISHED REPEAT COUNT ? SZA JMP DAT13 YES. USE THAT CONSTANT. SKP * READ ANOTHER DATA VALUE. * DATA4 JSB EXN.F IS IT A QUOTED STRING ? CPA B47 JMP DAT30 YES. DONE ELSEWHERE... * JSB IDN.F INPUT DO NOT ASSIGN SZA JMP DATA5 F.IM .NE. 0, GOT ONE. * LDA B50 '(' OTHERWISE, MUST BE COMPLEX CONSTANT. JSB TCT.F F.TC-TEST ISZ F.SXF SET COMPLEX FLAG. JSB IDN.F TRY AGAIN. CPA CPX COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? RSS YES. (IF NAME, CAUGHT LATER) JMP ERDAT NO. GENERAL TYPE MISMATCH ERROR. * * MAKE SURE IT'S A CONSTANT. IF FOLLOWED BY '*', * PROCESS THE REPEAT COUNT. * DATA5 LDA B54 LDB F.NT SZB,RSS JSB ER.F ERR 44: NAME IN CONSTANT LIST. JSB SDI.F ALWAYS USE SHORT INTEGERS IF POSSIBLE. LDB F.TC B=NEXT CHAR LDA KBAR ALREADY HAVE REPEAT ? SZA JMP DAT04 YES. DON'T CHECK FOR ANOTHER. * ISZ KBAR NO. SET KBAR=1 IN CASE NO REPEAT. CPB B52 WELL ? RSS YES. PROCESS IT. JMP DAT04 NO. USE REPEAT = 1. * LDB F.IM REPEAT MUST BE SINGLE INTEGER. LDA K26 ELSE ERROR 26. CPB INT RSS JSB ER.F NO, ERROR. * LDB F.IDI SET KBAR = REPEAT COUNT. STB KBAR SSB,RSS MAKE SURE REPEAT > 0. SZB,RSS WELL ? JMP ERD71 NEGATIVE OR ZERO, ERROR. JMP DATA4 YES. GO GET REPEATED DATA. * B47 OCT 47 SINGLE QUOTE. ZPX OCT 140000 F.IM = ZPX SKP * CHECK FOR HOLLERITH DATA. IF SO, SET T5DAT = -COUNT. * DAT04 LDA F.IM SAVE F.IM OF CONSTANT. STA T1DAT CLA SET T5DAT=0, STA T5DAT THE HOLLERITH DATA LENGTH. CPB B110 F.TC = 'H' ? RSS YES. JMP DAT13 NO. NOT HOLLERITH. * LDB F.IM YES. MUST BE SINGLE INTEGER. CPB INT RSS YES, O.K. JMP ERDAT ELSE ERROR. * LDB F.IDI AND > 0. LDA K20 CMB,SSB,INB,SZB (NEGATE, SKIP IF WAS <= 0) RSS O.K. (E=1) JSB ER.F BAD HOLLERITH COUNT. (ERR 20) * STB T7DAT SAVE FOR LOOP COUNTER. BRS - # WORDS HOLLERITH. STB T5DAT SAVE AS FLAG. ADB F.D0+1 MORE THAN ONE ELEMENT ? SSB JMP DAT15 YES. LONG HOLLERITH. * * COPY SHORT HOLLERITH DATA TO F.IDI * LDA F.DID NO. JUST COPY TO F.IDI RAL (BYTE ADDR) STA T6DAT LDA BL2B SET F.IDI TO BLANKS. STA F.IDI STA F.IDI+1 STA F.IDI+2 STA F.IDI+3 DAT14 JSB IC.F COPY THE CHARACTERS. XOR B40 (CHANGES BLANK TO THE CHAR) LDB T6DAT (B) = CHAR ADDR TO PUT IT. CLE,SLB,ERB (B) = WORD ADDR. HIGH OR LOW BYTE ? RSS LOW. LEAVE CHAR LOW. ALF,ALF HIGH. MOVE IT UP. XOR B,I CHANGE BLANK TO THE CHAR. STA B,I ISZ T6DAT BUMP ADDRESS. ISZ T7DAT BUMP COUNTER. JMP DAT14 LOOP. * JSB ICH.F READ THE DELIMETER. SKP * CHECK ITEM SIZE, MODE VS. DATA. * DAT13 LDA F.D0+1 ITEM SIZE. ADA T5DAT - HOLLERITH SIZE. SSA IF HOLLERITH BIGGER, JMP ERDAT SEND ERROR * LDA T5DAT IF HOLLERITH, SZA JMP DATA9 THEN O.K. * LDA T1DAT ELSE MUST CHANGE STA F.IM DOUBLE INTEGER JSB SDI.F BACK TO SINGLE IF POSSIBLE, LDA F.IM SO THAT STA T1DAT AFTER REPEAT, DON'T FAIL. CPA T0DAT DOES TYPE MATCH ? JMP DATA9 YES. O.K. * ALF IS MIXED SINGLE/DOUBLE INT ? IOR T0DAT (A) = 4/ITEM TYPE, 8/0, 4/CONST TYPE. CPA KK02 DBLINT / INT ? RSS YES. JMP DAT11 NO. GO CHECK LOGICAL. * LDB F.IDI CHANGE CONST TO DOUBLE INT. ASR 16 SWP DST F.IDI LDA DBI REMEMBER WE DID IT. STA T1DAT JMP DATA9 VOILA ! * DAT11 CPA KK05 LOG / DBLLOG ? RSS YES. O.K. AS IS. JMP ERDAT ALL ELSE IS BAD. SKP * START OUTPUT OF REGULAR DATA ITEM WITH REPEAT. * DATA9 LDA F.D0+1 SEND OPERATOR. ADA K3 HAS F.A, OFFSET, REPEAT. ALF,ALF IOR K51 JSB WS1.F LDA F.A F.A JSB WS1.F LDA T4DAT OFFSET. JSB WS1.F CLB COMPUTE # ITEMS LEFT IN ARRAY. LDA T2DAT DIV F.D0+1 (A) = # ITEMS LEFT. LDB KBAR B = REPEAT LEFT CMB,INB ADB A (#ITEMS) - (#CONST) SSB,RSS TAKE THE SMALLER OF THE TWO. LDA KBAR STA T6DAT CAN SEND REPEAT OF THAT MANY. LDB T5DAT IF HOLLERITH, SZB IOR B100K SET SIGN TO FLAG THAT. JSB WS1.F * * SEND THE DATA TO THE PASS FILE. * LDA F.D0+1 THIS MANY WORDS. CMA,INA STA T7DAT LDA F.DID FROM HERE. STA T8DAT DAT17 LDA T8DAT,I COPY THEM. JSB WS1.F ISZ T8DAT ISZ T7DAT JMP DAT17 JMP DAT08 DONE. GO UPDATE STATE. SKP * LONG HOLLERITH. MUST FILL PART OF AN ARRAY. * DAT15 CLB SEE IF EXACT # OF ITEMS. LDA F.IDI DIV F.D0+1 SZB I.E., REMAINDER = 0 ? (OR QUOTIENT ODD) JMP ERD71 NO. ILLEGAL PARTIAL ITEM. * LDB KBAR REPEAT > 1 ? CPB K1 CLE,SLA,ERA (REST OF EXACT-MULTIPLE CHECK) JMP ERD71 YES. ERROR. * LDA T2DAT EXCEEDS SPACE LEFT IN ARRAY ? ADA T5DAT SSA JMP ERD71 YES, ERROR. * * INITIALIZE, SEND DATA TO PAK.F * CCA INITIALIZE PAK.F : LDB T4DAT OFFSET. JSB PAK.F * DAT16 JSB IC.F COPY THE DATA TO THE BUFFER. JSB PAK.F ISZ T7DAT COUNT. DONE ? JMP DAT16 NO. LOOP. * * FINISH UP & UPDATE OFFSET, AMT REMAINING. * LDA KM2 FLUSH THE BUFFER. JSB PAK.F (B) SET TO (F.AF + T4DAT + #WDS OUTPUT) CMB,INB COMPUTE # WDS OUTPUT. ADB T4DAT (B) = -(# WDS OUTPUT) LDA B UPDATE OFFSET. CMA,INA + # WDS. ADA T4DAT T4DAT _ T4DAT + # WDS. STA T4DAT ADB T2DAT T2DAT = T2DAT - # WDS. STB T2DAT * JSB ICH.F GET DELIM. CLB SET REPEAT = 0 & CHECK STATE. JMP DAT09 * K1 DEC 1 K20 DEC 20 SKP * QUOTED HOLLERITH CONSTANT. * DAT30 JSB IC.F READ THE QUOTE. CLA IF REPEAT = 0, CPA KBAR (SKIPPED REGULAR CHECK) ISZ KBAR SET IT TO ONE. LDA KBAR SET MAMIMUM SIZE: IF KBAR > 1, LDB F.D0+1 MAX SIZE IS SIMPLE ITEM SIZE, CPA K1 ELSE LDB T2DAT MAX SIZE IS SPACE REMAINING IN ITEM. BLS CHANGE TO # CHARS, CMB AND SET UP AS COUNTER. STB T7DAT T7DAT = -(MAX # CHARS)-1 CCA SET UP PAK.F LDB T4DAT OFFSET. JSB PAK.F * * COPY STRING. * DAT32 JSB IC.F NEXT CHAR, INCL BLANKS. CPA B47 QUOTE ? RSS (YES) JMP DAT34 NO. * JSB IC.F YES. TWO IN A ROW ? CPA B47 RSS YES: TREAT AS ONE. JMP DAT36 NO. DONE. * DAT34 ISZ T7DAT IS THAT ONE TOO MANY ? RSS JMP ERD71 * JSB PAK.F NO. SEND IT. JMP DAT32 AND GO FOR MORE. * * END. BLANK FILL SINGLE ITEM (ALL IF AT /). * DAT36 CPA B40 HAVE CHAR AFTER END; IF BLANK, JSB ICH.F SKIP IT & READ NEXT NON-BLANK. LDA F.D0+1 COMPUTE # CHARS LEFT IN ITEM: CLE,ELA STA T5DAT T5DAT = TOTAL # IN AN ITEM. LDB T7DAT (B) = -(# LEFT)-1 INB -(# LEFT TOTAL) LDA F.TC AT END OF CURRENT DATA LIST (/) ? CPA B57 JMP DAT40 YES. FILL WHOLE ITEM. * ASR 16 DIV T5DAT (B) = REM = # TILL BOUNDARY. DAT40 SZB,RSS IF NONE, JMP DAT38 DON'T BOTHER. * STB T5DAT ELSE BLANK FILL. DAT37 LDA B40 JSB PAK.F ISZ T7DAT THIS SHOULD NEVER SKIP (MAX = -1) ISZ T5DAT JMP DAT37 * * FINISH UP REPEATED (SHORT) ITEM. * DAT38 CLA,INA IS IT REPEATED ? CPA KBAR JMP DAT39 NO. GO DO LONG VERSION. * LDA F.DPK SHORT. JUST COPY TO F.IDI LDB F.DID JSB .MVW DEF F.D0+1 NOP LDA F.D0+1 SET UP T5DAT AS HOLLERITH FLAG. STA T5DAT JMP DATA9 GO SEND IT WITH REPEAT COUNT. * * FINISH UP NON-REPEATED (POSSIBLY LONG) ITEM. * DAT39 LDA KM2 NO. TERMINATE PAK.F JSB PAK.F CMB,INB COMPUTE # WDS SENT. ADB T4DAT (B) = -(# WDS SENT) LDA B UPDATE OFFSET & # WDS LEFT. CMA,INA ADA T4DAT T4DAT _ T4DAT + # WDS. STA T4DAT ADB T2DAT T2DAT _ T2DAT - # WDS. STB T2DAT CLB REPEAT = 0 NOW. JMP DAT09 DONE. SKP * UPDATE OFFSET, # WDS LEFT, REPEAT COUNT. * DAT08 LDA T6DAT THIS MAY ITEMS. MPY F.D0+1 OF THIS SIZE. LDB T4DAT ADD TO OFFSET. ADB A STB T4DAT CMA,INA SUBTRACT FROM # WDS LEFT IN ITEM. ADA T2DAT STA T2DAT LDB T6DAT UPDATE REPEAT COUNT. CMB,INB ADB KBAR DAT09 STB KBAR LDA F.TC MORE DATA ITEMS ? CPA B54 I.E., COMMA NEXT OR INB REPEAT WASN'T ZERO. SZB,RSS WELL ? JMP DAT20 OUT OF DATA. MUST BE OUT OF LIST. * LDA T2DAT MORE DATA. MUST BE MORE LIST. LDB T2GRE CPB T3DAT IS LIST EXHAUSTED ? SZA JMP DATA6 NO. GO GET NEW LIST ITEM. JMP ERD71 YES. MORE DATA THAN VARIABLES. * DAT20 LDA T2DAT OUT OF DATA. HOW 'BOUT LIST ? LDB T2GRE CPB T3DAT ANY LEFT IN TABLE ? SZA OR IN ARRAY ? RSS YES. MORE VARIABLES THAN DATA. JMP DAT21 NO. O.K. * LDA K71 YES. WARNING, BUT NOT ERROR. JSB WAR.F * DAT21 LDA B57 MUST END WITH '/' JSB TCT.F TEST F.TC JSB EXN.F AT END OF STATEMENT ? CPA B15 JMP DAT22 YES. * CPA B54 NO. IF OPTIONAL COMMA, JSB ICH.F SKIP IT. JMP F.DAT AND PROCESS NEXT LIST. * DAT22 JSB ICH.F READ C/R. JMP F.CRT AND FINISH STATEMENT. SPC 2 KK02 OCT 100001 DBLINT / INT KK05 OCT 110003 DBLLOG / LOG K51 DEC 51 DATA OPERATOR. B110 OCT 110 "H" T0DAT NOP SAVE F.IM OF LIST ELEMENT T1DAT NOP SAVE F.IM OF DATA ELEMENT T2DAT NOP SAVED END OF DO TABLE. T3DAT NOP SAVE # WORDS IN ARRAY T4DAT NOP OFFSET INTO ARRAY. T5DAT NOP HOLLERITH COUNT. T6DAT NOP SCRATCH. T7DAT NOP SCRATCH. T8DAT NOP SCRATCH. KBAR NOP REPEAT INDICATOR IN DATA PROCESSOR * * ERROR IN DATA STATEMENT. * ERD71 LDA K71 COUNT MISMATCH / BAD REPEAT COUNT. JSB ER.F ERDAT LDA K73 ERROR 73. JSB ER.F * K71 DEC 71 B52 OCT 52 K73 DEC 73 * * END F4.0 ASMB,Q,C HED RELATE COMMON, EQUIVALENCE, AND ASSIGN ARRAY PHASE. NAM RCO.F,8 92834-16002 REV.2030 800727 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE: * * 1) (RCO.F) COMPUTES OFFSETS OF ITEMS EXPLICITLY DECLARED TO * TO BE IN COMMON. * 2) (GREQU) RESOLVES THE EQUIVALENCE CLASSES AND ASSIGNS * ADDRESSES TO THEIR MEMBERS. * 3) (APSEC) FOR NON-FORMAL ARRAYS, ASSIGNS ADDRESSES (IF NOT IN * COMMON OR EQUIV GROUP) & COMPUTES OFFSET TO (0,0,0). * * IT IS CALLED WHEN THE FIRST 'DATA' OR EXECUTABLE STATEMENT IS * ENCOUNTERED. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE. EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.AT. FLAG TO AI.F TO BUILD BCOMI OR DIM ENTRY. EXT F.CC CHARACTER COUNT EXT F.CSZ COMMON SIZE EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.DO LWAM - END OF DO TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EM EMA FLAG BIT IN A.T. EXT F.EMS EMA SIZE DOUBLE WORD. EXT F.EQE EQUVALENCE ERROR FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LNN LINE # OF CURRENT LINE. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.ND NUMBER OF DIMENSIONS EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF F.A OF PROG NAME IF SUBPROG. EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT VALUE. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DEM.F DEFINE (F.EM) = 1. EXT DMP.F DOUBLE INTEGER MULTIPLY. EXT DSB.F DOUBLE INTEGER SUBTRACT. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT EJC.F ESTABLISH DOUBLE INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FL.F FETCH LINK OF (B). EXT GCD.F CHECK FOR & GET INT CONST, 2 WORDS. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT NAM.F COPY SYMBOL NAME. EXT PCC.F PRINT COMPILER COMMENT. EXT PSL.F PRINT SOURCE LINE (IMMEDIATELY). EXT TV.F TAG VARIABLE. EXT WAR.F ISSUE WARNING. * * EXTERNALS IN THE SEGMENT. * EXT F.BCM BLANK COMMON HEADER. EXT F.CIO ITEM OFFSET (DOUBLE INTEGER) * EXT CIO.F COMPUTE ITEM OFFSET. * * ENTRY IN THIS MODULE. * ENT RCO.F SPC 2 A EQU 0 B EQU 1 SUP SKP * ***************** * * RELATE COMMON * * ***************** RCO03 LDB F.BCM END OF LABELED COMMON CLA CLEAR THE FLAG STA F.LCM JMP RCO02 GO DO BLANK COMMON * RCO04 LDA T1RCO GET CURRENT MASTER ENTRY ADDRESS STA F.A RESTORE IT FOR GNA.F CLA SET UP TO ZAP THE F.AF OF THE MASTER LDB F.SFF AND IF BLOCK DATA SUBPROGRAM CPB K2 LDA T0RCO+1 SET F.AF OF MASTER TO SIZE JSB DAF.F SET MASTER ENTRY F.A JSB CCS.F CHECK SIZE. LDA F.EM GET EMA FLAG SZA,RSS THIS THE EMA ENTRY? JMP RCO01 NO, LOOK FOR NEXT BLOCK * DLD T0RCO YES, SAVE SIZE. DST F.EMS JMP RCO01 LOOK FOR NEXT BLOCK * RCO.F NOP ISZ F.LCM DO LABELED COMMON FIRST JSB GFA.F SEARCH A.T. FOR COMMON LABELS. RCO01 JSB GNA.F SZA,RSS END OF TABLE?? JMP RCO03 YES GO DO BLANK COMMON * LDA F.A,I CHECK IF LABELED COMMON MASTER AND B7601 ISOLATE NT,AT,IU FIELDS CPA B7200 IF NT=0 & AT=BCOMI & IU=SUB RSS THIS IS A MASTER ENTRY JMP RCO01 NOT SO TRY NEXT ENTRY * LDB F.A SAVE THE ADDRESS OF MASTER RCO02 STB T1RCO ENTRY JSB FL.F FETCH LINK STA T2RCO T2RCO = LINK. CLB SET COMMON SIZE STB T0RCO TO ZERO STB T0RCO+1 RCO05 LDA T2RCO GO TO NEXT ONE. STA F.A F.A=NEXT LINK CPA T1RCO END OF LIST? CLB,INB,RSS YES SKIP OUT JMP RCOM2 NO DO NEXT ENTRY * CPB F.LCM DOING LABELED COMMON?? JMP RCO04 YES SET FOR NEXT ENTRY * LDB T0RCO+1 SET COMMON SIZE. STB F.CSZ JSB CCS.F CHECK IT FOR OFL. JMP GREQU DO EQUIV. GROUPS * RCOM2 JSB FA.F FETCH ASSIGN JSB NW2.F F.D0: # WDS FOR ITEM LDB F.A JSB FL.F FETCH LINK STA T2RCO T2RCO = LINK. LDA T0RCO+1 JSB DAF.F DEFINE F.AF=T0 LDA F.EM IS IT IN EMA ? SZA,RSS THEN JMP RCO06 NOT IN EMA SKIP IT * LDA T0RCO GET THE HIGH ORDER BITS ADB K2 INDEX TO PLACE FOR THEM. STA B,I SET IN THE SYMBOL TABLE RCO06 DLD T0RCO GET COMMON SIZE. JSB DAD.F ADD ELEMENT SIZE. DEF F.D0 CCA (IF OFL, MAKE SURE IS CAUGHT) DST T0RCO JSB CCS.F CHECK FOR OFL. JMP RCO05 DO NEXT ONE IN THE LIST * T0RCO DEC 0,0 SIZE. T1RCO NOP F.A OF MASTER. T2RCO NOP LINK TO NEXT ITEM. F.LCM NOP LABELLED COMMON FLAG. K84 DEC 84 K2 DEC 2 B7200 OCT 7200 NT=0, AT=BCOMI, IU=SUB. B7601 OCT 7601 F.NT & F.AT & F.IU * * SUBROUTINE TO CHECK T0RCO FOR OVERFLOW. * CCS.F NOP DLD T0RCO SZA,RSS MUST HAVE UPPER BITS=0, SSB AND LOWER POSITIVE. RSS NO. ERROR. JMP CCS.F,I YES. EXIT. * LDB F.EM WELL, MAYBE. IS IT EMA ? SZB SSA YES. IS BIT 31 CLEAR ? RSS NO. TRUE OVERFLOW. JMP CCS.F,I YES ON BOTH. IT FITS. * LDA K84 OVERFLOW. JMP F.ABT SKP * ********************* * * GROUP EQUIVALENCE * * ********************* SPC 1 * THIS SECTION RESOLVES THE EQUIVALENCE DECLARATIONS SAVED IN THE * EQUIVALENCE TABLE, (F.DO-1) TO (F.E). THE INITIAL FORM OF THE * TABLE IS DESCRIBED IN F.EQU . AT THIS POINT ALL OTHER * DECLARATIONS HAVE BEEN PROCESSESED SO THE SUBSCRIPTS GIVEN IN * THE EQUIVALENCE ITEMS CAN NOW BE RESOLVED INTO WORD OFFSETS FROM * THE START OF THE ITEM. THIS IS THE INITIAL "PACK" PHASE. AT THE * END OF THE PACK PHASE, EACH ITEM IN THE EQUIVALENCE TABLE IS * A 3-WORD FRAME CONTAINING THE F.A OF THE ITEM AND THE 2-WORD * OFFSET FROM ITS START TO THE SUBSCRIPTED ADDRESS. * * EQUIVALENCE PROCESSING IS DONE BY EXTRACTING EQUIVALENCE CLASSES. * (ONE OR MORE EQUIVALENCE GROUPS EACH CONTAINING AT LEAST ONE * ITEM IN ANOTHER GROUP IN THE CLASS, SUCH THAT NO ITEM IS IN * A GROUP OUTSIDE THE CLASS. THE CLASS DESCRIBES A SET OF ITEMS * IN LOCK-STEP WITH EACH OTHER.) THE FOLLOWING ALGORITHM IS USED * TO EXTRACT A CLASS FROM THE REMAINING EQUIVALENCE DATA: * 1) THE FIRST GROUP IS IN THE CLASS. AS EACH GROUP IS PUT IN * THE CLASS, IT IS MARKED 'KNOWN'. * 2) FOR EACH KNOWN ITEM, SEARCH FOR A MATCHING ONE: * IF NONE FOUND, GO ON TO NEXT KNOWN ITEM. * IF FOUND & KNOWN, OFFSETS MUST MATCH. GO ON. * IF FOUND & UNKNOWN, ADD GROUP CONTAINING ITEM * TO THE CLASS & RESTART STEP (2). * IF NO NEW GROUPS ADDED TO CLASS, THE CLASS IS COMPLETE. * THE ADDRESS OF A (HYPOTHETICAL) SIMPLE ITEM IN THE FIRST GROUP * OF THE CLASS IS CONSIDERED TO BE THE REFERENCE ADDRESS. THE * REFERENCE OFFSET IS THE OFFSET FROM THIS ADDRESS TO THE ADDRESS * OF A SIMPLE ITEM IN THE CURRENT GROUP. (FOR THE FIRST GROUP, * ZERO.) THE LOCATIONS 'ULIM' AND 'LLIM' ARE THE OFFSETS TO THE * LWA+1 OF THE ITEM AT THE HIGH END OF THE CLASS AND THE LWA OF THE * ITEM AT THE LOW END, BASED ON THE REFERENCE ADDRESS. THE SIZE * OF A CLASS IS (ULIM-LLIM). * * AS EACH CLASS IS COMPLETED, IT IS ALLOCATED TO LOCAL SPACE, COMMON * OR LABELLED COMMON (INCLUDING EMA) AND THE ADDRESSES OF THE ITEMS * IN THE CLASS ARE DEFINED. THE CLASS IS THEN REMOVED FROM THE * EQUIVALENCE TABLE AND A SCAN FOR THE NEXT CLASS IS STARTED. SPC 3 * START. PACK EQUIVALENCE TABLE. * GREQU LDA F.DO ANY ITEMS IN TABLE ? CPA F.E JMP ASPEC NO. SKIP EQUIVALENCE PROCESSING. * STA T1GRE YES. T1GRE = ADDRESS OF LAST WORD READ. STA T2GRE T2GRE = ADDRESS OF LAST WORD WRITTEN. JMP GRE01 GO START. SKP GRE00 STA T4GRE T4GRE = LINE # FOR ERRORS. JSB GREW2 LEAVE IN TABLE. GRE01 JSB GRER1 COPY F.A OR GROUP START MARK. STA F.A JSB GREW2 JSB GRER1 READ # SUBS OR LINE #. LDB F.A (B) = F.A OR -1 SSB WHICH ? JMP GRE00 NEW GROUP. SAVE LINE #. * STA T3GRE T3GRE = # SUBS. JSB FA.F FETCH ASSIGNS (F.IU, F.ND, F.D0) LDB F.A MUST NOT BE DUMMY OR SUBROUTINE. LDA K22 (ELSE ERROR 22.) CPB F.SBF CHECK FOR PROGRAM NAME, JMP GRE99 * LDB F.AT FORMAL PARAM, CPB DUM JMP GRE99 * LDB F.IU OR SUBROUTINE. CPB SUB JMP GRE99 * CPB ARR ARRAY ? RSS YES. JSB TV.F NO. MAKE IT VAR. LDA F.ND (A) = DECLARED # DIM (GARBAGE IF VAR) LDB F.IU SIMPLE VARIABLE ? CPB VAR CLA YES, # DIM = 0. LDB T3GRE # SUBSCRIPTS. CMB,INB -(#SUBS) ADB A (#DIM)-(#SUBS) SSB MORE SUBS THAN DIMS ? JMP GRE02 YES, ERROR. * LDA T3GRE (A) = # SUBS. LDB T1GRE SET (B) TO ADDR OF LAST SUBSCR ADB KM2 WHICH IS NEXT THING FROM # SUBS. JSB CI2.F COMPUTE ITEM OFFSET. SOC OUT OF BOUNDS ? JMP GRE17 YES, CALL IT IMPOSSIBLE. * LDA F.CIO+1 WRITE IT OUT. JSB GREW2 LDA F.CIO JSB GREW2 LDA T3GRE ADVANCE PAST SUBSCRIPTS IN TABLE. ALS TWO WORDS EACH. SZA,RSS (IF NONE, SKIP A WORD ANYWAY) INA CMA,INA JUST SET SUBTRACT FROM T1GRE. ADA T1GRE STA T1GRE CPA F.E END ? RSS YES. DONE. JMP GRE01 NO. GET NEXT ITEM. * LDA T2GRE SHORTEN TABLE TO CURRENT SIZE. STA F.E JMP GRE04 GO START THE CLASS DETERMINATION. * GRE02 LDA K38 MORE SUBSCRIPTS THAN DIMENSIONS. JMP GRE99 REPORT IT, DELETE TABLE & EXIT. SKP * START NEW EQUIVALENCE CLASS. * GRE04 LDA F.DO ANYTHING LEFT ? CPA F.E JMP ASPEC NO. DONE WITH EQUIV. * STA T1GRE T1GRE = PTR TO START OF 1ST GROUP. CLA T0GRE = REFERENCE OFFSET (INITIALLY ZERO). STA T0GRE STA T0GRE+1 STA LLIM LLIM = OFFSET OF FWA CLASS. STA LLIM+1 STA ULIM ULIM = OFFSET OF LWA+1 CLASS. STA ULIM+1 STA T6GRE T6GRE = ADDRESS LEVEL. STA T7GRE T7GRE = COMMON BLOCK NAME. LDA STRAB T5GRE = ADDRESS TYPE. STA T5GRE JSB GRER1 SKIP (-1) GROUP START. * * START NEW GROUP. T1GRE = ADDR OF GROUP. * T0GRE = REFERENCE OFFSET. * GRE06 JSB GRER1 SAVE LINE #. STA T4GRE GRE08 LDA T1GRE IF THIS WAS LAST GROUP, CPA F.E THEN NO GROUP MARK. JMP GRE10 YES. DONE WITH GROUP. * JSB GRER1 READ F.A OR GROUP MARK. CPA KM1 WHICH ? JMP GRE10 GROUP MARK. * STA F.A ITEM. SAVE F.A IOR B100K SET SIGN ON ITEM F.A TO MARK IT. STA T1GRE,I JSB FA.F FETCH ASSIGNS. * * CHECK OUT ADDRESS TYPES, SAVE BLOCKNAME. * LDB F.AT DEFINED ? CPB STRAB JMP GRE9B NO. ALL'S FAIR. * LDA T5GRE COMMON. FIRST ONE ? CPA STRAB RSS YES. JMP GRE9A NO. GO CHECK FOR CONSISTENT BLOCK. * STB T5GRE YES. SET TYPE OF COMMON. LDA F.AF SET BLOCKNAME. ADA K2 INDEX TO THE F.A LDA A,I (A) = F.A OF MASTER. STA T7GRE LDA T1GRE SAVE ADDR OF FRAME STA TAGRE FOR BCOM OFFSET RESOLUTION LATER. GRE9A LDA F.AT COMMON. MUST BE SAME TYPE. CPA T5GRE RSS YES. O.K. JMP GRE17 NO. ERROR. * CPA COM BLANK OR LABELLED ? JMP GRE9B BLANK. O.K. * LDA F.AF LABELLED. BLOCKNAME MUST MATCH. ADA K2 GET F.A OF MASTER. LDA A,I CPA T7GRE RSS SAME. O.K. JMP GRE17 NO. ERROR. * GRE9B LDA T6GRE SET ADDRES LEVEL TO MAX. IOR F.EM STA T6GRE * JSB NW2.F COMPUTE # WORDS. JSB GRER1 ADVANCE T1GRE TO OFFSET (LOWER) JSB GRER1 (UPPER). DLD T0GRE REFERENCE OFFSET. JSB DSB.F - OFFSET. DEF T1GRE,I = CLASS OFFSET. JMP GRE98 IF OFL. * DST T1GRE,I REPLACE ARRAY OFFSET WITH CLASS OFFSET. JSB DSB.F (CLASS OFFSET) - LLIM DEF LLIM JMP GRE98 IF OFL. * SSA,RSS NEW OFFSET SMALLER ? (OR MORE NEGATIVE) JMP GRE9D NO. * DLD T1GRE,I YES. UPDATE LLIM. DST LLIM GRE9D DLD F.D0 SIZE JSB DAD.F + CLASS OFFSET. DEF T1GRE,I JMP GRE98 IF OFL * DST T8GRE SAVE IT. JSB DSB.F (OFFSET+SIZE) - ULIM DEF ULIM JMP GRE98 IF OFL. * SSA WHICH IS BIGGER ? JMP GRE08 ULIM. LEAVE IT. * DLD T8GRE OFFSET+SIZE. NEW ULIM. DST ULIM JMP GRE08 GO FOR NEXT ITEM IN GROUP. SKP * GROUP HAS BEEN ADDED TO CLASS. * SEARCH FOR CONFLICTS AND OTHER GROUPS IN CLASS. * GRE10 LDA F.DO SET UP SCANS. STA T1GRE T1GRE = OUTER LOOP POINTER. * GRE11 STA T4GRE T4GRE = LINE # (GARBAGE 1ST TIME) GRE12 LDA T1GRE END OF OUTER LOOP ? CPA F.E JMP GRE24 YES. NO NEW GROUPS, CLASS COMPLETE. JSB GRER1 GET F.A OR GROUP START. STA F.A * JSB GRER1 ADVANCE T1GRE TO OFFSET OR LINE #. LDB F.A RECALL F.A CPB KM1 GROUP START ? JMP GRE11 YES. SAVE LINE # & GO ON. * JSB GRER1 ADVANCE TO 2ND WD OF OFFSET. LDA F.A (A) = F.A SSA,RSS UNKNOWN ITEM ? JMP GRE12 YES. INGORE IN OUTER LOOP. * * INNER LOOP. * LDA F.DO SET UP INNER LOOP. STA T2GRE T2GRE = POINTER. * GRE13 LDA T2GRE T8GRE = LOCATION OF CURRENT GROUP. INA (A = ADDR OF GROUP MARK) STA T8GRE (GARBAGE FIRST TIME) GRE14 LDA T2GRE END ? CPA F.E JMP GRE12 YES, ADVANCE OUTER LOOP. * JSB GRER2 NO. GET F.A OR GROUP START (INNER LOOP) STA T3GRE SAVE. JSB GRER2 ADVANCE T2GRE TO OFFSET (OR LINE #) LDA T3GRE IS IT GROUP START ? CPA KM1 JMP GRE13 YES, SAVE LOCATION. * JSB GRER2 ADVANCE TO 2ND WORD OF OFFSET. LDA T3GRE CPA F.A DUPLICATE MARKED ITEMS ? JMP GRE16 YES. OFFSETS MUST MATCH. * IOR B100K SAME NAME IN NEW GROUP ? CPA F.A JMP GRE18 YES. JMP GRE14 NO. GO ON TO NEXT ONE. SKP GRE16 DLD T1GRE,I T0GRE = ORIGINAL OFFSET. DST T0GRE DLD T2GRE,I (A,B) = DUPLCATE ITEM'S OFFSET. CPA T0GRE MATCH ? RSS JMP GRE17 NO. ERROR. CPB T0GRE+1 UPPERS TOO. JMP GRE14 YES. JUST REDUNDANT EQUIVALENCE. * GRE17 LDA K40 NO. IMPOSSIBLE EQUIVALENCE GROUP. JMP GRE99 GO TELL LINE # & NAME. * * ADD NEW GROUP TO CLASS. * GRE18 DLD T1GRE,I T0GRE = BASE OF ITEM IN BOTH GROUPS. JSB DAD.F + OFFSET IN NEW GROUP. DEF T2GRE,I JMP GRE98 IF OFL. * DST T0GRE = NEW REFERENCE OFFSET. LDA T8GRE T1GRE = ADDRESS OF NEW GROUP. STA T1GRE JMP GRE06 GO ADD THE GROUP TO THE CLASS. * LLIM OCT 0,0 LOWER LIMIT OF CLASS. ULIM OCT 0,0 UPPER LIMIT OF CLASS + 1 T0GRE OCT 0,0 REFERENCE ADDRESS. T1GRE NOP POINTER INTO EQUIV TABLE. T2GRE NOP POINTER INTO EQUIV TABLE. T3GRE NOP TEMP T4GRE NOP LINE # OF CURRENT GROUP. T5GRE NOP F.AT OF CLASS. T6GRE NOP F.EM OF CLASS. T7GRE NOP F.A OF BCOM MASTER FOR CLASS. T8GRE OCT 0,0 ADDR START OF CURRENT GROUP (INNER LOOP) TAGRE NOP ADDR OF FRAME OF A BCOM ITEM THIS CLASS. ARR OCT 600 F.IU=ARR VAR OCT 400 F.IU=VAR STRAB OCT 2000 F.AT=STRAB COM OCT 4000 F.AT=COM BCOM OCT 3000 F.AT=BCOM BCOMI OCT 7000 F.AT=BCOMI KM1 DEC -1 KM2 DEC -2 K10 DEC 10 K22 DEC 22 K38 DEC 38 B100K OCT 100000 K40 DEC 40 SKP * MISCELLANEOUS SUBROUTINES FOR EQUIVALENCE. * GRER1 NOP READ EQUIV TABLE INTO (A) USING (T1GRE) CCB BACK UP T1GRE. ADB T1GRE STB T1GRE LDA B,I (A) = DATA. JMP GRER1,I EXIT. * GRER2 NOP READ EQUIV TABLE INTO (A) USING (T2GRE) CCB BACK UP T2GRE. ADB T2GRE STB T2GRE LDA B,I (A) = DATA. JMP GRER2,I EXIT. * GREW2 NOP WRITE (A) INTO EQUIV TABLE USING (T2GRE) LDB F.LO TOP OF A.T. + 1 CMB -F.LO-1 (F.LO: MIN ALLOWABLE F.E) ADB T2GRE (T2GRE-1)-F.LO SSB NEW T2GRE < F.LO ? JMP F.OFE YES, MEM OVERFLOW. * ADB F.LO NEW T2GRE = T2GRE-1 STB T2GRE STA B,I STORE DATA. JMP GREW2,I EXIT. SKP * COMPLETE EQUIV CLASS. ASSIGN ADDRESSES OR OFFSETS. * GRE24 DLD ULIM COMPUTE SIZE = (ULIM-LLIM) JSB DSB.F DEF LLIM JMP GRE98 IF OFL. * SZA,RSS > 32767 ? SSB RSS YES. JMP GRE25 NO. ALWAYS O.K. * LDA T6GRE > 32767. EMA ? SZA,RSS JMP GRE98 NO. TOO BIG. * GRE25 LDA T5GRE WHAT KIND ? CPA STRAB RSS NORMAL. JMP GRE27 COMMON OR BCOM. * CLA SET T0GRE = F.RPL - LLIM LDB F.RPL (THIS IS THE VALUE WHICH, WHEN ADDED JSB DSB.F TO THE ITEM OFFSET, GIVES THE PROPER DEF LLIM RELOCATABLE ADDRESS FOR THE ITEM.) JMP GRE98 IF OFL. * DST T0GRE JSB DAD.F + BIGGEST OFFSET GIVES NEW F.RPL DEF ULIM JMP GRE98 * STB F.RPL SZA,RSS ROOM ? SSB JMP F.OFE NO. YOU LOOSE... * LDA REL YES. WILL MARK F.AT = REL. STA T5GRE JMP GRE50 GO ON. * GRE27 LDA TAGRE COMMON. GET ADDR OF ITEM OFFSET ADA KM2 OF THE ITEM KNOWN TO BE IN COMMON. STA GRE28 SET UP FOR LATER. LDA TAGRE,I (A) = KNOWN ITEM F.A + SIGN. RAL,CLE,ERA CLEAR SIGN. STA F.A SAVE & FETCH ASSIGNS. JSB FA.F LDB T5GRE WHICH COMMON ? CPB BCOM JMP GRE40 LABELLED. * LDB A (F.AF) CLA (A,B) = COMMON OFFSET. JSB DSB.F - ITEM'S EQUIV OFFSET GRE28 DEF *-* JMP GRE98 IF OFL. * DST T0GRE GIVES THE DISPLACEMENT. JSB DAD.F + MAX OFFSET = SIZE. DEF ULIM (IGNORE UPPER WORD) JMP GRE98 IF OFL. * LDA DCSZ (A) = ADDR OF SIZE. (POSSIBLY INDIRECT) JMP GRE42 GO UPDATE SIZE IF BIGGER. SKP GRE40 LDB T6GRE EMA ? SZB JMP GRE44 YES. * DLD A,I (B) = ITEM'S OFFSET. CLA (A,B) JSB DSB.F - ITEM EQUIV OFFSET. DEF GRE28,I JMP GRE98 IF OFL. * DST T0GRE GIVES DISPLACEMENT. JSB DAD.F + MAX OFFSET = SIZE. DEF ULIM (IGNORE UPPER WORD) JMP GRE98 IF OFL. * LDA F.SFF BLOCK DATA ? CPA K2 CLA,INA,RSS YES. (A=1) JMP GRE43 NO. DONE HERE. * ADA T7GRE (A) = ADDR OF SIZE. GRE42 STA T3GRE SAVE ADDR SIZE. LDA B (A) = NEW SIZE. CMA,INA ADA T3GRE,I OLD - NEW SSA NEW BIGGER ? STB T3GRE,I YES. UPDATE. GRE43 SSB TOO BIG ? JMP F.OFE YES. PUNT. JMP GRE50 NO. START THE SCAN. * GRE44 INA GET EMA OFFSET. LDB A,I LOWER IS AT F.A+1 ADA K2 LDA A,I UPPER IS AT F.A+3 JSB DSB.F (EMA OFFSET) - (ITEM OFFSET) DEF GRE28,I JMP GRE98 IF OFL. * DST T0GRE GIVES DISPLACEMENT. JSB DAD.F + MAX OFFSET GIVES SIZE. DEF ULIM JMP GRE98 IF OFL. * DST T8GRE SAVE SIZE. DLD F.EMS OLD SIZE JSB DSB.F (OLD SIZE) - (NEW SIZE) DEF T8GRE JMP GRE98 IF OFL. * SSA,RSS WHICH IS BIGGER ? JMP GRE50 OLD. * DLD T8GRE NEW. SET IT AS SIZE. DST F.EMS SKP * LOOP THRU ITEMS IN CLASS, DEFINING THEIR ADDRESSES. * GRE50 LDA F.DO SET T1GRE AS READ POINTER. STA T1GRE STA T2GRE AND T2GRE AS WRITE POINTER. JSB GRER1 SKIP INITIAL GROUP HEAD. * * JUST COPY GROUPS NOT IN CLASS. * GRE52 JSB GRER1 SEE IF IN CLASS. COPY LINE #. STA T4GRE T4GRE = LINE #. JSB GRER1 GET F.A FIRST ITEM. SSA MARKED ? JMP GRE55 YES. PROCESS IT. * STA F.A NO. SAVE F.A, THEN CCA 'COPY' THE DISCARDED GROUP HEAD, JSB GREW2 LDA T4GRE AND THE LINE #, JSB GREW2 LDA F.A AND GO FINISH COPYING 1ST ITEM. JMP GRE51 * GRE53 LDA T1GRE AT END ? CPA F.E JMP GRE65 YES. * JSB GRER1 COPY UNTIL NEW GROUP. CPA KM1 WELL ? JMP GRE52 YES. GO CHECK IT. * GRE51 JSB GREW2 NO. COPY F.A JSB GRER1 OFFSET LOWER. JSB GREW2 JSB GRER1 OFFSET UPPER. JSB GREW2 JMP GRE53 UNTIL GROUP HEAD. * * GROUP IS IN CLASS. PROCESS EACH ITEM. * GRE54 LDA T1GRE AT END ? CPA F.E JMP GRE65 YES. * JSB GRER1 NEXT F.A OR GROUP HEAD. CPA KM1 WHICH ? JMP GRE52 NEW GROUP. GO SEE IF IN CLASS. * GRE55 RAL,CLE,ERA CLEAR SIGN. STA F.A SET F.A (SIGN HAS BEEN CLEARED) STA TAGRE (ALSO FOR EMA LATER) JSB FA.F FETCH ASSIGNS. JSB GRER1 ADVANCE TO 1ST WD OFFSET. JSB GRER1 DLD T1GRE,I (A,B) = ITEM OFFSET. JSB DAD.F (A,B) = ITEM ADDRESS OR COMMON OFFSET. DEF T0GRE JMP GRE98 IF OFL. * DST T1GRE,I SAVE IT. SSA IF NEGATIVE, JMP GRE97 MUST BE NEG EXTENSION OF COMMON. SKP * IF NOT BLOCK COMMON, JUST DEFINE F.AT & F.AT . * BLOCK COMMON: IF DEFINED, MUST ALREADY MATCH. * IF NOT, MUST DEFINE IT. * LDB T5GRE LABELLED COMMON ? CPB BCOM RSS YES. JMP GRE62 NO, GO DEFINE F.AT & F.AF * CPB F.AT DEFINED ? JMP GRE63 YES. ADDRESSES MUST MATCH. * LDA T6GRE SET F.EM FOR AI.F STA F.EM LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F CREATE THE TABLE ENTRY. LDB T7GRE (B) = ADDR OF MASTER. LDA F.A (A) = ADDR NEW BCOMI ENTRY. ADA K2 INDEX TO PLACE FOR MASTER ADDR. STB A,I & PUT IT THERE. INA ADDR OF UPPER WORD EMA ADDR. STA T3GRE SAVE. LDA T6GRE EMA FLAG. LDB T1GRE,I (B) = UPPER WORD. SZA EMA ? STB T3GRE,I YES. SET UPPER WORD. LDA BCOMI DEFINE THE F.AT JSB DAT.F LDA F.A (A) = ADDR BCOMI ENTRY. LDB TAGRE (B) = ADDR ORIGINAL ENTRY. STB F.A RESTORE F.A TO THERE. JSB DAF.F LINK IN THE BCOMI ENTRY. LDA T6GRE IF EMA, SZA JSB DEM.F SET THE EMA BIT. JSB FA.F & FETCH ASSIGNS AGAIN. JMP GRE64 NOW GO DEFINE F.AT & F.AF SKP * VERIFY ALREADY IN LABELLED COMMON, VERIFY ADDR. * GRE63 DLD T1GRE,I (B) = CORRECT (LOWER) OFFSET. LDA F.AF ADDR OF BCOMI ENTRY. INA ADDR OF DEFINED OFFSET. CPB A,I SAME ? RSS JMP GRE17 NO. IMPOSSIBLE. * LDB T6GRE YES. EMA ? SZB,RSS JMP GRE54 NO. DONE. * LDB T1GRE,I CORRECT UPPER OFFSET. ADA K2 ADDR OF DEFINED VALUE. CPB A,I SAME ? JMP GRE54 YES. JMP GRE17 NO. IMPOSSIBLE. * * REL/COM: IF COM & ALREADY DEF, SEE IF SAME. * GRE62 LDA F.AT WELL ? CPA COM RSS JMP GRE64 NO. * DLD T1GRE,I YES. (B) = CORRECT OFFSET. CPB F.AF SAME ? JMP GRE54 YES. JMP GRE17 NO. IMPOSSIBLE. * * DEFINE (LOWER) ADDRESS/OFFET. * GRE64 LDA T5GRE SET F.AT OF NEW ITEM. JSB DAT.F DLD T1GRE,I SET (LOWER) WORD OFFSET. LDA B JSB DAF.F JMP GRE54 ALL DONE! * * DONE WITH THIS CLASS. CUT THE TABLE BACK TO * REFLECT THE NEW (GREW2) LENGTH & TRY FOR ANOTHER. * GRE65 LDA T2GRE NEW LWA STA F.E JMP GRE04 MAY BE EMPTY NOW. SKP DEQMS DEF EQMSG EQMSG ASC 7, INVOLVING: EQNAM ASC 3,XXXXXX DCSZ DEF F.CSZ DEF TO BLANK COMMON SIZE IN MAIN. REL OCT 1000 K41 DEC 41 DGR95 DEF GRE95 ERROR RETURN POINT. SPC 2 * IMPOSSIBLE EQUIVALENCE CLASS. * OUTPUT ERROR MSG WITH GROUP LINE # AND ITEM NAME. * GRE97 LDA K41 NEGATIVE EXTENSION OF COMMON. JMP GRE99 GRE98 LDA K84 ADDRESS SPACE OVERFLOW. GRE99 LDB F.LNN DUMMY UP LINE #. STB T5GRE LDB T4GRE STB F.LNN LDB F.CC ALSO COLOUMN. STB T6GRE CLB STB F.CC LDB DGR95 SET ERROR RETURN POINT. STB F.EQE JSB ER.F ISSUE MSG & RETURN. GRE95 CLA RESET ERROR RETURN POINT. STA F.EQE LDA T5GRE RESTORE LINE #. STA F.LNN LDA T6GRE & F.CC STA F.CC LDA F.A CLEAR SIGN OF F.A RAL,CLE,ERA STA F.A JSB NAM.F COPY NAME TO MESSAGE. DEF EQNAM LDA K10 TEN WORDS. LDB DEQMS FROM HERE. JSB PCC.F TO OUTPUT. SKP * ************************ * * ASSIGN SPECIFICATION * * ************************ SPC 1 * TO ASSIGN STORAGE TO ARRAYS NOT ALREADY ASSIGNED (BY EQUIV). * * TOP OF LOOP. GET ANOTHER ARRAY. * ASPEC JSB GFA.F SET UP TO SCAN A.T. LDA F.A KEEP THE F.A IN T1ASP. STA T1ASP ASP01 LDA T1ASP RESTORE F.A STA F.A JSB GNA.F GET NEXT F.A STA T1ASP KEEP IT IN T1ASP. SZA,RSS JMP CAI00 END OF ASSIGNMENT TABLE * JSB FA.F FETCH ASSIGNS LDA F.IU IF NOT AN ARRAY, CPA ARR RSS JMP ASP01 THEN SKIP IT (ASSIGN AT 'END'). * * ASSIGN SPACE IF NOT DONE ALREADY AND NOT FORMAL. * LDA F.AT IF A DUMMY, CPA DUM JMP ASP01 DON'T ASSIGN SPACE. * JSB NW2.F F.D0=# OF WDS FOR ITEM JSB AA.F ASSIGN ADDRESS JMP ASP01 * * B40 OCT 40 INT OCT 010000 F.IU=INT DBI OCT 100000 F.IU=DBI DUM OCT 5000 F.AT=DUM SUB OCT 200 F.IU=SUB T1ASP NOP F.A OF CURRENT ARRAY. SKP * ********************** * * COMPUTE ARRAY INFO * * ********************** SPC 1 * IN THIS SECTION, FOR EACH ARRAY: * 1) IF IN EMA, CHECKED FOR DOUBLE INTEGER SUBSCRIPTS. * 2) IF NON-FORMAL: * A) OFFSET TO ELEMENT (0,0,0) COMPUTED. * B) EACH LOWER BOUND NEGATED. * C) EACH UPPER BOUND REPLACED BY DIMENSION SIZE. * * THIS SECTION MUST BE EXECUTED BEFORE THE ROUTINES * 'NWI.F' AND 'CIO.F' ARE CALLED, AS THEY USE THE MODIFIED * ARRAY INFORMATION. * CAI00 JSB GFA.F SET UP SCAN OF NAMED ITEMS. LDA F.A KEEP F.A IN T1ASP STA T1CAI CAI01 LDA T1CAI RESTORE F.A STA F.A JSB GNA.F GET NEXT ITEM. STA T1CAI SZA,RSS DONE ? JMP RCO.F,I YES. ALL DONE WITH SPECS. * JSB FA.F NO. FETCH ASSIGNS. LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP CAI01 NO. SKIP IT. SKP * CHECK WHETHER ANY DIMENSIONS ARE DOUBLE INTEGER. * IF CONSTANT DBL INT DIM FOR NON-EMA, PUNT. * LDA F.EM EMA ? SZA JMP CAI02 YES. * LDB F.DIS NO. CONSTANT DOUBLE INT SUBSCR ? SZB JMP CAI10 YES. ERROR. JMP CAI05 NO. ALL'S O.K. * CAI02 LDA F.LUB SET UP BOUNDS POINTER. STA T2CAI LDA F.ND SET UP LOOP COUNTER. ALS *2 FOR LOWER & UPPER BOTH. CMA,INA STA T3CAI CAI03 LDA T2CAI,I NEXT BOUND. ISZ T2CAI STA F.A GET ITS F.IM JSB FA.F LDA F.IM CPA DBI IS IT INTEGER*4 ? JMP CAI04 YES. DOUBLE INT SUBSCR. * ISZ T3CAI COUNT 'EM UP. JMP CAI03 MORE. JMP CAI05 DONE. SINGLE INT SUBSCR. * CAI04 DLD T1CAI,I FOUND ONE. SET THE F.DIS BIT, LDA B,I IN FIRST WORD OF DIM ENTRY. IOR B40 MEANING 'DOUBLE INTEGER SUBSCRIPT' STA B,I SKP * IF NOT FORMAL PARAM, LOOP THRU THE BOUNDS * AND: 1) NEGATE THE LOWER BOUNDS. * 2) REPLACE UPPER BOUNDS BY DIMENSION SIZE. * * CAI05 LDA T1CAI RESTORE F.A & ASSIGNS. STA F.A JSB FA.F LDA F.AT F.AT = DUM ? CPA DUM JMP CAI01 YES. FORMAL, SKIP IT. * LDA F.LUB SET UP BOUNDS LOOP. STA T2CAI T2CAI = BOUNDS POINTER. LDA F.ND # DIMENSIONS. CMA,INA STA T3CAI T3CAI = LOOP COUNTER. LDA F.DIS SINGLE OR DOUBLE ? SZA JMP CAI07 DOUBLE. * CAI06 LDB T2CAI,I SINGLE. GET LOWER BOUND VALUE. JSB CFC.F NOP CMA,INA NEGATE. STA T4CAI & SAVE FOR COMPUTING SIZE. CPA B100K -32768 ? JMP CAI6A YES. USE DOUBLE INTEGER. * JSB EIC.F NO. SET UP AS SINGLE INTEGER. JMP CAI6B * CAI6A LSL 16 (A,B) = 000000 100000 JSB EJC.F SET UP DOUBLE INTEGER LOWER BOUND. CAI6B STA T2CAI,I & REPLACE LOWER BOUND. ISZ T2CAI LDB T2CAI,I GET UPPER BOUND VALUE. JSB CFC.F NOP ADA T4CAI UPPER - LOWER. INA,SZA DIMENSION SIZE = UPPER-LOWER+1 SSA > 32767 ? (0 = 65536) JMP CAI6C YES. USE DOUBLE INTEGER. * JSB EIC.F NO. USE SINGLE INTEGER. JMP CAI6D * CAI6C LDB A USE DOUBLE. CLA SZB,RSS (IF ZERO, REALLY 65536) CLA,INA JSB EJC.F * CAI6D STA T2CAI,I REPLACE UPPER BOUND WITH DIM SIZE. ISZ T2CAI ADVANCE TO NEXT DIMENSION. ISZ T3CAI COUNT. DONE ? JMP CAI06 NO. LOOP. JMP CAI08 YES. GO COMPUTE OFFSET. SKP * ADJUST BOUNDS FOR DOUBLE INTEGER DIMENSIONS. * CAI07 LDB T2CAI,I DOUBLE SUBSCR. LOOP. JSB GCD.F GET VALUE OF LOWER. NOP STA T4CAI & SAVE. STB T5CAI CMA NEGATE. CMB,INB,SZB,RSS INA DST F.IDI SET UP NEW CONSTANT. LDA DBI JSB ESC.F JSB AI.F LDA F.A REPLACE LOWER BOUND. STA T2CAI,I ISZ T2CAI LDB T2CAI,I GET VALUE OF UPPER. JSB GCD.F NOP JSB DSB.F UPPER - LOWER. DEF T4CAI NOP INB,SZB,RSS ADD ONE. INA DST F.IDI BUILD THE NEW CONSTANT. LDA DBI JSB ESC.F JSB AI.F LDA F.A STA T2CAI,I REPLACE UPPER WITH SIZE. ISZ T2CAI BUMP BOUNDS POINTER. ISZ T3CAI COUNT. DONE ? JMP CAI07 NO. LOOP. SKP * COMPUTE THE OFFSET FROM THE * START OF THE ARRAY TO ELEMENT (0,0,0). * CAI08 LDA T1CAI RESTORE F.A STA F.A JSB FA.F & ASSIGNS. LDA F.ND COMPUTE OFFSET. CLB B=0 FORCES ALL SUBSCRIPTS = 0. JSB CIO.F LDA F.CIO+1 (A)=OFFSET IF NON-EMA. STA F.IDI SET THAT UP, LDA INT AND THE TYPE. LDB F.EM WHICH IS IT ? SZB,RSS IF NON-EMA, JMP CAI09 WE'RE READY. * DLD F.CIO ELSE SET TWO-WORD VALUE. DST F.IDI (DIDN'T NEGATE LOWER BOUNDS HERE) LDA DBI CAI09 JSB ESC.F SET IT UP. JSB AI.F DLD T1CAI,I (B) = F.A OF DIM ENTRY THIS ARRAY. ADB K2 = PLACE TO PUT OFFSET F.A LDA F.A PUT IT THERE. STA B,I JMP CAI01 GO GET NEXT SYMBOL. * * DOUBLE INTEGER BOUNDS ON NON-EMA, PUNT. * CAI10 LDA T1CAI RESTORE F.A & GET NAME. STA F.A JSB NAM.F DEF CAIMS+1 LDB DCAIM ISSUE MESSAGE FIRST. LDA K15 JSB PSL.F PRINT IMMEDIATELY. LDA K84 THEN DISASTER. JMP F.ABT * T1CAI NOP SAVED F.A T2CAI NOP BOUNDS TABLE POINTER. T3CAI NOP BOUNDS LOOP COUNTER. T4CAI NOP TEMP FOR CALCULATION. T5CAI NOP DITTO. DCAIM DEF CAIMS CAIMS ASC 15, ( ) HAS ILLEGAL BOUNDS. K15 DEC 15 SKP * ************************************ * * F.D0 := NUMBER OF WORDS FOR ITEM * * ************************************ SPC 1 * AT THIS POINT, RCO.F MUST NOT HAVE BEEN CALLED. THE LOWER AND * UPPER BOUNDS MUST BE INTACT. * NW2.F NOP LDA F.IU CPA ARR RSS JMP NW2.F,I * LDA F.ND SET UP COUNTER. CMA,INA STA T1NWI LDA F.LUB SET UP POINTER INTO BOUNDS TABLE. STA T2NWI * * LOOP THRU BOUNDS TABLE; FOR EACH DIMENSION, * MULTIPLY F.D0 BY THE SIZE (2-WORD COMPUTATION). * NWI01 LDB T2NWI,I GET LOWER BOUND. ISZ T2NWI (& GO PAST) JSB GCD.F JMP RPLOV NOT CONSTANT! * DST T3NWI SAVE, WHILE WE... LDB T2NWI,I GET UPPER BOUND. ISZ T2NWI (SKIP IT) JSB GCD.F JMP RPLOV SOMEONE GOOFED! * JSB DSB.F UPPER - LOWER. DEF T3NWI JMP RPLOV IF OFL. * INB,SZB,RSS + 1. INA SSA DID SOMETHING GO WRONG ? JMP RPLOV YES. * JSB DMP.F MULTIPLY & REPLACE RUNNING PRODUCT. DEF F.D0 JMP RPLOV OFL. * DST F.D0 ISZ T1NWI INCR LOOP COUNTER. MORE ? JMP NWI01 YES. DO IT. JMP NW2.F,I NO. ALL DONE. (A,B) = PRODUCT. SKP RPLOV LDA K84 OFL IN SIZE CALC. CATASTROPHE! JMP F.ABT * T1NWI NOP LOOP COUNTER. T2NWI NOP BOUNDS TABLE POINTER. T3NWI DEC 0,0 TEMP FOR DIM SIZE CALC. SKP * *********************** * * COMPUTE ITEM OFFSET * * *********************** SPC 1 * CI2.F COMPUTES THE OFFSET, IN WORDS, OF AN ARRAY ELEMENT FROM THE * BASE OF THE ARRAY. THE NAME & SUBSCRIPTS MAY BE READ WITH ILE.F . * * NOTE: THE BOUNDS REFORMATTING MUST NOT HAVE BEEN DONE YET. IF IT * HAS, THEN CIO.F SHOULD BE USED. * * ENTRY: F.A = A.T. ADDR OF ITEM. * (A) = # SUBSCRIPTS (MAY BE ZERO). * (B) = ADDR OF LAST SUBSCRIPT (FOLLOWED BY NEXT-TO-LAST) * IF ZERO, ALL SUBSCRIPTS ASSUMED TO BE ZERO. * EXIT: F.CIO = TWO-WORD OFFSET IN INTERNAL FORM. SPC 1 CI2.F NOP STB T1CIO SAVE ADDR LAST SUBSCR. CLB INITIALIZE F.CIO = 0 STB F.CIO STB F.CIO+1 STB T0CIO CLEAR OVERFLOW FLAG. CMA,INA,SZA,RSS NEGATE # SUBS. JMP CIO03 IF NONE, DONE. (CLEAR OFL & EXIT) * STA T2CIO ELSE SAVE AS LOOP COUNTER. JSB FA.F SET UP: F.D0 = # WDS PER ELEMENT. DLD F.D0 SAVE THAT. DST T5CIO LDA T2CIO -(#SUBS) CMA (#SUBS)-1 ALS *2 ADA F.LUB ADDR LOWER BOUND LAST SUBSCR. STA T4CIO * * LOOP THRU SUBS & DIMS COMPUTING OFFSET. * CIO01 LDB T4CIO,I F.A OF LOWER BOUND. JSB GCD.F (A,B) = LOWER BOUND. ISZ T0CIO NOT CONSTANT: SOMEONE GOOFED! DST T6CIO SAVE. CLA (A,B)=0 IN CASE FORCED ZERO SUBSCRIPTS. CLB DLD T1CIO,I SUBSCRIPT. JSB DSB.F SUBTRACT LOWER BOUND. DEF T6CIO ISZ T0CIO IF TOO BIG. SSA ALSO BAD IF NEGATIVE. ISZ T0CIO JSB DAD.F ADD RUNNING SUM. DEF F.CIO ISZ T0CIO IF TOO BIG. ISZ T2CIO WAS THAT FIRST SUBSCR ? RSS NO. JMP CIO02 YES. DONE. * DST F.CIO SAVE CURRENT VALUE. LDA T4CIO BACK UP TO PREVIOUS DIMENSION. ADA KM2 STA T4CIO LDB A,I GET LOWER BOUND OF PREVIOUS. JSB GCD.F ISZ T0CIO IF NOT CONSTANT. DST T6CIO SAVE, WHILE WE DLD T4CIO,I GET THE UPPER BOUND. JSB GCD.F ISZ T0CIO (IF NOT CONSTANT) JSB DSB.F UPPER - LOWER. DEF T6CIO ISZ T0CIO (IF OFL) INB,SZB,RSS + 1 = PREV DIM SIZE. INA JSB DMP.F MULTIPLY PREV DIM SIZE BY DEF F.CIO CURRENT VALUE. ISZ T0CIO IF TOO BIG. DST F.CIO SAVE. LDA T1CIO BACK UP TO PREVIOUS SUBSCR. SZA IF FORCED ZERO SUBSCR, DON'T CHANGE. ADA KM2 STA T1CIO JMP CIO01 ARROUND WE GO * CIO02 JSB DMP.F * # WORDS PER ELEMENT. DEF T5CIO ISZ T0CIO IF TOO BIG. DST F.CIO SAVE OFFSET. JSB NW2.F COMPUTE F.D0 = TOTAL SIZE. DLD F.CIO COMPUTE OFFSET - SIZE. JSB DSB.F DEF F.D0 ISZ T0CIO IF OFL. SSA,RSS IF OFFSET >= SIZE, ISZ T0CIO ALSO SET OVERFLOW. LDA T0CIO OVERFLOW INDICATOR. CIO03 CLO SZA IF OVERFLOW OCCURED, STO RETURN OVERFLOW=1. JMP CI2.F,I DONE. F.CIO = OFFSET. * T0CIO NOP OVERFLOW FLAG. T1CIO NOP ADDR CURRENT SUBSCRIPT. T2CIO NOP LOOP COUNTER. T4CIO NOP ADDR F.A ENTRY CURRENT LOWER BOUND. T5CIO BSS 2 # WORDS PER ELEMENT. T6CIO BSS 2 TEMP. * END ASMB,Q,C HED FTN4X COMPILER (F4X.1:EXPRESSION --> POSTFIX) ** NAM F4X.1,5 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 1 *************************************** * * THIS OVERLAY IS THE EXPRESSION EVALUATOR. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F..E DIMENSIONS CONSTANT BIT FROM ASSIGNS TABLE EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.DPJ DEF TO CURRENT PROCESSOR JUMP TABLE. EXT F.EM EMA FLAG BIT IN A.T. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.FES TWPE ENTRY FOR 1ST EXECUTABLE. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.P1E PASS 1 ERROR RECOVERY POINT. EXT F.S1T TOP OF STACK 1 *** OBSOLETE ? *** EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEE RETURN FROM F4.1 EXT F.SFA F.A OF CURRENT STATEMENT FUNCTION. EXT F.SIM SAVED ITEM MODE (NEG CONSTS) EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SLF LEVEL OF CURRENT STATEMENT. EXT F.STC SAVE F.TC (NEG CONSTS) EXT F.SVL SAVE # WORDS ON OPER STACK (F.L) EXT F.SXF COMPLEX CONSTANT FLAG EXT F.TC NEXT CHARACTER * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM TO A.T. EXT DAT.F DEFINE (AT) EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT. EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT ICH.F INPUT A CHARACTER. EXT II.F INPUT ITEM EXT WS1.F OUTPUT WORD TO SCRATCH FILE # 1. * * ENTRY POINTS FOR ROUTINES IN THIS SEGMENT * ENT EE.F EXPRESSION ANALIZER (THE WHOLE REASON FOR EXISTANCE) ENT PU2.F PUSH ONTO OPERATOR STACK ENT FER.F FORM PROGRAM ENTRANCE * * STATEMENT PROCESSORS IN THIS SEGMENT. * EXT F.ASS ASSIGNMEXT STATEMENT PROCESSOR EXT F.ASP ASSIGN STMT. PROCESSOR EXT F.BSP BACKSPACE STMT. PROCESSOR EXT F.CAL CALL STATEMENT PROCESSOR EXT F.CLP CLOSE STATEMENT PROCESSOR. EXT F.CON CONTINUE STMT. PROCESSOR EXT F.DCP DECODE PROCESSOR. EXT F.DOP DO STATEMENT PROCESSOR EXT F.ECP ENCODE PROCESSOR. EXT F.EDP END IF STATEMENT PROCESSOR. EXT F.EFP ENDFILE STMT. PROCESSOR EXT F.ELP ELSE STATEMENT PROCESSOR. EXT F.ENP END STATEMENT PROCESSOR. EXT F.GOP GO TO STATEMENT PROCESSOR EXT F.IFP IF STATEMENT PROCESSOR EXT F.IQP INQUIRE STATEMENT PROCESSOR. EXT F.OPP OPEN STATEMENT PROCESSOR. EXT F.PAP PAUSE STMT. PROCESSOR EXT F.PNT PRINT STMT. PROCESSOR. EXT F.RDP READ STATEMENT PROCESSOR EXT F.RTN RETURN STMT. PROCESSOR EXT F.RWP REWIND STMT. PROCESSOR EXT F.SFP STATEMEXT FUNCTION PROCESSOR EXT F.STP STOP STMT. PROCESSOR EXT F.THP THEN STATEMENT PROCESSOR. EXT F.WRP WRITE STATEMEXT PROCESSOR * * THE FORMAT PROCESSOR IN 'DSP.F' * THE MODIFIED STMT # FETCHER. * EXT F.FMT FORMATS. EXT ISD.F INPUT STMT #, MODIFY IF 'DO' TERM. SPC 2 A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 1 OVERLAY NUMBER SKP * ************************ * * PROCESSOR JUMP TABLE * * ************************ SPC 1 * THIS TABLE IS INDEXED BY THE KEYWORD ORDINAL DETERMINED BY * THE DISPATCHER. THE PROCESSORS ARE LOCATED IN BOTH SEGMENTS * 0 AND 1; THIS TABLE IS DUPLICATED IN EACH SEGMENT, SO THAT THE * MAIN HAS NO REFERENCES TO TYPE 7 ROUTINES IN THE SEGMENTS. * THE SEGMENTS MUST SET UP 'F.DPJ' ON ENTRY TO POINT TO F.PJT . * THE ORDINALS FOR THE FIRST 3 ENTRIES ARE SPECIAL-CASED IN THE * DISPATCHER, AND ARE NOT TRUE ORDINALS. * DEF F.DOP DO (-2) DEF F.ASS ASSIGNMENT STMT (-1) F.PJT DEF F.SFP STMT FCT. (0) DEF F.IFP IF (1) DEF 0 EMA DEF F.ENP END DEF F.CAL CALL DEF F.GOP GO TO DEF F.RDP READ DEF F.STP STOP DEF 0 REAL DEF 0 DATA DEF F.THP THEN DEF F.ELP ELSE DEF F.OPP OPEN DEF F.WRP WRITE DEF F.PNT PRINT DEF F.PAP PAUSE DEF F.EDP ENDIF DEF F.CLP CLOSE DEF F.RTN RETURN DEF F.FMT FORMAT DEF F.RWP REWIND DEF 0 COMMON DEF F.ASP ASSIGN DEF F.ECP ENCODE DEF F.DCP DECODE DEF F.EFP END FILE DEF 0 INTEGER DEF 0 COMPLEX DEF 0 LOGICAL DEF 0 PROGRAM DEF F.IQP INQUIRE DEF 0 FUNCTION DEF F.CON CONTINUE DEF 0 EXTERNAL DEF 0 IMPLICIT DEF 0 DIMENSION DEF F.BSP BACKSPACE DEF 0 BLOCK DATA DEF 0 SUBROUTINE DEF 0 EQUIVALENCE DEF 0 DOUBLE PRECISION SKP * *************************** * * HANDLE PROGRAM ENTRANCE * * *************************** * * CALLED AT FIRST STATEMENT FUNCTION AND AT FIRST EXECUTABLE. * FER.F NOP LDA F.FES ALREADY GENERATED ENTRY SEQUENCE ? SZA,RSS JMP FER02 NO. GO DO IT. * SSA YES. WAS IT DUE TO STATEMENT FUNCTION ? JMP FER.F,I NO. JUST EXIT. * LDA KK37 YES. DEFINE THE TWPE ENTRY. JSB WR2.F LDA F.FES JSB WR2.F JMP FER.F,I THAT'S ALL. * * IF BLOCK DATA OR MAIN, NO PARAMS. * FER02 LDA F.SFF IF BLOCK DATA LDB F.SBF OR MAIN PROG SZB CPA K2 JMP FER03 THERE IS NO ENTRY * * SET F.AT=DUM FOR ALL FORMALS. * STB F.A JSB FA.F SET UP F.AF FOR LOOPING. * FER00 LDA F.AF GET THE LINK TO THE NEXT DUMMY STA F.A SET AS CURRENT. SZA,RSS IF END OF LIST JMP FER03 GO OUTPUT THE OPERATOR. * JSB FA.F SET UP ASSIGNS (INCL F.AF) LDA DUM TYPE IT "DUM" JSB DAT.F JMP FER00 GO FOR MORE. SKP * WRITE PROGRAM ENTRY OPERATOR TO PASS FILE & EXIT. * FER03 LDA KK31 OPCODE=31, ONE ARGUMENT. JSB WR2.F LDA F.SBF ALSO F.A OF SUB/FCT. JSB WR2.F LDA F.SLF IF DUE TO STATEMENT FUNCTION, CCB (B=-1 TO FLAG NOT STMT FCT) CPA K3 RSS (YES) JMP FER04 NO. SET FLAG TO -1. * LDA TWPE YES. SET UP THE JUMP AROUND. JSB ESC.F JSB AI.F LDB F.A F.FES = F.A OF A TWPE ENTRY. FER04 STB F.FES JMP FER.F,I * DUM OCT 5000 TWPE OCT 40000 F.IM=TWPE. CPX OCT 50000 ZPX OCT 140000 K2 DEC 2 KK31 BYT 1,37 KK37 BYT 1,45 B377 OCT 377 SKP * *------------------* * * START HERE * * *------------------* * F4.1 LDA DFP1E JUST SET UP ERROR RECOVERY; STA F.ERX LDA DFPJT AND ADDRESS OF PROC. JUMP TABLE. STA F.DPJ JMP F.SEE NOTHING ELSE TO DO HERE. * DFP1E DEF F.P1E PASS 1 ERROR RECOVERY ADDRESS. DFPJT DEF F.PJT DEF TO PROCESSOR JUMP TABLE. EQFLG NOP EQUALS FLAG SKP * *********************** * * EXPRESSION ANALYZER * * *********************** SPC 1 * CALLING SEQUENCE: * * (POSSIBLY SET F.IM &/OR F.SIM) * (POSSIBLE SET (A)=#SOFT LEFT PARENS) * JSB EE.F * BYT FLAGS,TYPE * -->(A) = # SOFT LEFT PARENS UNUSED. * * WHERE THE FLAGS ARE: * * BIT 15: SOFT PAREN & F.SIM BIT. IF SET, * (A) MUST CONTAIN # OF SOFT PARENS, * AND F.SIM MUST BE SET BY AN IDN.F * CALL. * BIT 8: TEMP FLAG FOR PASS 2. * * THE TYPES ARE: * * 0, STATEMENT FUNCTION. * 1, SUBROUTINE CALL STATEMENT. * * 2, DO INITIAL PARAMETER. * 3, ARRAY ELEMENT IN I/O LIST. * 4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. * 5, COMPUTED GO TO INDEX EXPRESSION. * * 6, ASSIGNMENT STATEMENT. * 7, IF EXPRESSION. * * 8, INPUT LIST-STYLE EXPRESSION. * * 9, OUTPUT LIST-STYLE EXPRESSION. * * AND THE STARRED (*) TYPES REQUIRE THAT F.IM AND F.TC BE * SET UP AS IF AN II.F CALL HAD BEEN MADE, AND THE OTHER * TYPES REQUIRE THAT THE NEXT ICH.F CALL GETS THE FIRST * CHARACTER OF THE EXPRESSION. * * INITIALIZE F.SIM & SOFT PAREN COUNT. * EE.F NOP LDB EE.F,I SET UP SOFT LEFT PAREN COUNT. SSB,RSS IF FLAG NOT SET, CLA THEN COUNT IS ZERO. STA T1EE CLA ALSO ZERO OUT F.SIM SSB,RSS IF THE FLAG ISN'T SET. STA F.SIM SKP * SEND START OP TO PASS FILE & INIT LOCALS. * LDA KK32 SEND COUNT & OPERATOR TO PASS FILE. JSB WS1.F LDA EE.F,I (A) = TYPE & FLAGS. JSB WS1.F SEND THRU PASS FILE. LDA EE.F,I GET IT BACK, ISZ EE.F AND B377 EXTRACT TYPE IN LOW 4 BITS, STA TYPEX AND SAVE IT. LDA F.L SAVE NO.OF WORDS ON OPERATOR STA F.SVL STACK ON ENTRY (USUALLY 0) CLA STA EQFLG EQFEG =0 (NO '=' OP. ALLOWED) STA EMAFL CLEAR EMA ASSIGNMENT FLAG. STA INAFL CLEAR INVERSE ASSIGN FLAG. CCA STA OPCOD INITIALIZE OPCOD TO -1. STA PRIOR INITIALIZE PRIORITY TO -1. STA LASTC SET PREVIOUS F.TC TO -1 AS A FLAG. * * TYPE-DEPENDENT INITIALIZATION. * LDA F.IM (IN CASE ALREADY UNDER WAY.) LDB EEJT1 SELECT NEXT OP BY JUMP TABLE. ADB TYPEX LDB B,I JMP B,I EEJT1 DEF *+1 DEF EE030 STMT FCT. DEF EE003 SUBR CALL. DEF EE007 DO INITIAL; ITEM ALREADY SCANNED. DEF EE030 UNIT # ? DEF EE030 DO TERMINAL / STEP-SIZE. DEF EE030 COMPUTED GOTO. DEF EE009 ASSIGNMENT: ITEM ALREADY SCANNED. DEF EE11 IF: STACK '('. DEF EE035 INPUT ITEM: ITEM ALREADY SCANNED. DEF EE005 OUTPUT ITEM: DITTO, BUT CHECK UNARY OP. SKP * SUBR CALL: IF SIMPLE, DO IT NOW. * EE003 LDB F.TC CPB B50 IS F.TC A LEFT PARENTHESIS? JMP EE035 YES; PROCESS ARG LIST. * LDA F.A SUBROUTINE CALL (NO ARGS) JSB WR1.F OPND = SUB NAME, LDA K33 THEN OPERATOR. JSB WR2.F JMP EXIT * * FOR OUTPUT LIST, IF NO ITEM, ALLOW FOR UNARY OP. * EE005 LDB F.TC FOR +/- CHECK. CPB B53 IF +, RSS CPB B55 OR -, SZA AND NO ITEM YET, JMP EE035 (NO. REGULAR START) JMP EE038 THEN JOIN UNARY +/- IN PROGRESS. * * DO INITIAL. EXPECT '='. * EE007 CCA JUST SET EQFLG = -1. STA EQFLG JMP EE035 AND START WITH ITEM ALREADY SCANNED. * * ASSIGNMENT. EXPECT '=', SET EMA FLAG. * EE009 CCA STA EQFLG JMP EE036 SPC 2 T1EE NOP SOFT LEFT PAREN COUNT. KM1 DEC -1 KK32 BYT 1,40 COUNT & OPERATOR. K33 DEC 33 SKP * ********************************** * * EXPRESSION EVALUATOR MAIN BODY * * ********************************** SPC 1 * IF + OR -, DECIDE IF UNARY OR BINARY. * EE03 LDB F.TC SAVE CURRENT F.TC AS EE01 STB LASTC PREVIOUS F.TC. EE030 JSB EXN.F EXAMINE NEXT CHARACTER. CPA B53 IF '+' JMP EE031 CPA B55 OR '-', RSS SEE IF IT IS UNARY JMP EE034 NEITHER; INPUT ITEM AND CONT. EE031 LDA LASTC A '+' OR '-' IS THE NEXT CHAR. CPA B75 IF LAST F.TC WAS AN '=' JMP EE032 CPA B50 OR '(', JMP EE032 CPA B54 OR COMMA, JMP EE032 THEN '+' OR '-' IS UNARY. SSA IF NEGATIVE, BEGINNING OF EXPR., JMP EE032 THEN '+' OR '-' IS UNARY. LDA KM11 STA TKM9 COUNTER FOR 11 LOG. & REL. OPS. LDB RELOP EE131 LDA B,I (A)=RELATIONAL OPERATOR CPA LASTC IF LASTC IS REL OP JMP EE032 THEN '+' OR '-' IS UNARY ADB K2 ISZ TKM9 LOOKED AT ALL OF THEM? JMP EE131 NO. JSB ICH.F NONE OF ABOVE; IT IS A BINARY CLA '+' OR '-'. INCREMENT F.CC PAST IT STA F.IM F.IM=0 FOR BINARY + OR - JMP EE035 SET F.IM IN A TO 0 AND PROCESS IT. SPC 1 EE032 JSB II.F INPUT OPERATOR OR SIGNED CONSTANT SZA IF F.IM#0, THEN IT IS A SIGNED JMP EE035 CONSTANT. GO PROCESS IT. EE038 LDB F.TC MUST BE + OR - A VARIABLE. CPB B53 IF A '+', IGNORE IT JMP EE01 SAVE IT AS LAST F.TC EE033 LDA B40 CHANGE F.TC = UNARY - TO BLANK. JMP EE14A PROCESS UNARY '-' DIRECTLY. SPC 1 B40 OCT 40 LASTC NOP KM11 DEC -11 TKM9 NOP COUNTER RELOP DEF OR. SKP * ***************** * * GET NEXT ITEM * * ***************** * * OPERATORS & DELIMS DONE ELSEWHERE. * EE034 LDA F.SIM DELAYED CONSTANT ? SZA,RSS JMP EE037 NO. * STA F.IM YES. SET IT UP. LDB F.STC STB F.TC CLB STB F.SIM CLEAR THE FLAG. JSB AI.F ENTER INTO A.T. JMP EE035 ALREADY WAS INPUT! * EE037 JSB II.F ELSE INPUT AN ITEM. EE035 LDB F.TC CCE,SZA,RSS IS F.IM=0? JMP EE08 YES, NO OPERAND TO STACK * * CHECK FOR MISSING OPERATOR. * CHECK ITEM USAGE. * OUTPUT OPERAND TO PASS FILE. * CLB,RSS CLEAR THE EMA ASSIGNMENT FLAG, EE036 LDB F.EM (SET IT PROPERLY FOR FIRST ITEM) STB EMAFL SINCE ONLY APPLIES TO FIRST ITEM. LDB LASTC IF CHARACTER PRECEDING CPB B51 NAME OR CONSTANT IS ')', JMP EE16 ERROR 53 - MISSING OPERATOR LDA F.TC IF CURRENT F.TC IS .NOT., CPA NO JMP EE16 MISSING OPERATOR. LDB F.IU ITEM USAGE ZERO ? SZB,RSS JMP EE045 YES, ILG USE OF NAME. LDA F.A WRITE F.A TO PASS FILE. JSB WR1.F LDB F.TC IS F.TC A '(' ? CPB B50 JMP EE04 YES, MAKE SURE F.IU=SUB OR ARR JMP EE09 FIND OUT WHAT OP OR DELIM IS. SKP * ITEM FOLLOWED BY '('. MUST BE SUB OR ARRAY. * EE04 LDB F.A IS IT THE CURRENT FUNCTION/SUB ? LDA K75 CPB F.SBF JSB ER.F YES. RECURSION ILLEGAL. LDB F.IU ELSE WHAT IS IT ? CPB ARR F.IU = ARRAY? JMP EE05 YES, '(' IS VALID. STACK. * CPB SUB F.IU=SUBPROGRAM? RSS YES, '(' IS VALID. JMP EE045 NO. ILLEGAL USE. * LDA TYPEX IF SUBROUTINE CALL, (TYPE=1), CMA,INA (-1 IFF SUB CALL) AND LASTC AND PROCESSING THE SUBROUTINE NAME, INA,SZA,RSS WELL ? JMP EE043 YES. GO STACK IT. * LDA F.A,I NO. FUNCTION REF, FLAG IT. IOR B20 STA F.A,I EE043 LDA KK26 ('[' IS CODE=26, PRIOR=1.) JSB PU2.F STACK OPERATOR. LDA OPCOD SEND TO PASS FILE TOO. JSB WR2.F JMP EE48 GO CHECK FOR ALT RTNS. * EE045 LDA K22 ILLEGAL USAGE OF NAME JSB ER.F * * ARRAY REFERENCE. * EE05 LDA KK27 STACK '<' AS CODE=27, PRIOR=1. LDB EMAFL IF THIS IS A TARGET EMA VARIABLE CCE,SZB,RSS THEN (E=1) JMP EE06 (NO) * RAL,ERA SET THE SIGN BIT TO REMEMBER THAT. STB INAFL ALSO SET INVERSE ASSIGN FLAG. EE06 JSB PU2.F STACK OPERATOR LDA OPCOD ALSO SEND TO PASS FILE. JSB WR2.F JMP EE03 INPUT NEXT ELEMENT SPC 1 B20 OCT 20 B50 OCT 50 B53 OCT 53 B54 OCT 54 B55 OCT 55 K22 DEC 22 K75 DEC 75 KK26 BYT 32,1 CODE=26, PRIORITY=1 (LEFT BRAKT) KK27 BYT 33,1 CODE=27, PRIORITY=1 (LEFT BRACE) SUB OCT 200 ARR OCT 600 F.IU=3 (ARRAY) NO ASC 1,NO INAFL NOP INV ASS FLAG: CHANGES = TO INVERSE =. EMAFL NOP EMA FLAG: CURRENT ITEM IS FIRST & EMA. SKP * ************************* * * OPERATOR OR DELIMITER * * ************************* SPC 1 * CHECK FOR '('. * CHECK FOR ADJACENT OPERATORS. * EE08 CPB B50 IS F.TC = '('? JMP EE11 YES, IT MUST START A SUB EXPRES. EE09 LDA F.IM F.IM OF PRESENT ITEM IS 0? SZA JMP EE095 NO - PROCESS OPERAND-TC COMBINATION. LDA LASTC YES - PREVIOUS CHARACTER IN THIS CPB NO IF PRESENT OPERATOR IS .NOT. JMP EE096 CPA B51 2 ADJACENT SPECIAL CHARACTER JMP EE095 COMBINATION MUST BE A ')' OR * CPB B51 MAYBE AN EMPTY PARAM LIST ? RSS MUST END WITH RIGHT PAREN. JMP EE16 (NO. ERROR 53) * LDA OPCOD YUP. HOW ABOUT BEFORE IT... CPA SOP[ WAS LAST A FUNCT/SUB LEFT PAREN ? JMP EE095 YES. EMPTY PARAM LIST. JMP EE16 ERROR 53 - MISSING OPERAND. * EE096 CPA NO IF PREVIOUS OPERATOR IS .NOT., JMP EE16 ERROR 53 - ADJACENT OPERATORS JMP EE14 PROCESS DIRECTLY * * CHECK FOR ')' ',' 'C/R' * EE095 CLA (A=0) CPB B51 F.TC = ) ? JMP EE12 YES CPB B54 NO, IS F.TC = ',' JMP EE12 YES CPB B15 NO, IS F.TC = 'C/R' ? RSS CPB B47 OR SINGLE QUOTE, RSS CPB B72 OR COLON ? JMP EE115 YES. (A)=0. JMP EE14 GO SEARCH FOR THE OPERATOR. * EE12 LDB OPCOD ')' OR ','; CHECK FOR: CPB SOP[ TOS IS START OF SUBR CALL, THEN IT LDA K59 MIGHT BE EMA CALL-BY-REF; GET OP. CPB SOPPR TOS IS LEFT PAREN, THEN IT MIGHT LDA K60 BE EMA CALL-BY-VALUE; GET OP. CPB SOP< TOS IS START OF ARRAY REF, THEN FORCE LDA K60 SUBSCRIPT MAPPING BEFORE ARRAY MAPPING. STA VREFF SAVE THAT AS THE VALUE/REFERENCE FLAG. * LDA K3 SET CURRENT PRIORITY OF DELIMITER EE115 STA CPRIO TO 3 AND CURRENT OPCOD=0, THEN CLA GENERATE CODE USING F.TC LATER STA CCODE TO 'REMEMBER' WHAT DELIMITER JMP EE40 WAS SCANNED. SPC 1 B52 OCT 52 B75 OCT 75 KK25 BYT 31,1 CODE=25, PRIORITY=1 (LEFT PAREN) K59 DEC 59 OPCODE FOR CALL-BY-REF SIGNAL. K60 DEC 60 OPCODE FOR CALL-BY-VALUE SIGNAL. SPC 1 * LEFT PAREN. TAKE CARE WITH COMPLEX CONSTANTS. * EE11 STB F.SXF SET TO NON-ZERO AS A FLAG LDA KK25 STACK '(' AS CODE=25,PRIOR=1. JSB PU2.F STACK THE '(' JSB II.F INPUT NEXT ITEM LDB F.NT (B)= ITS NAME TAG CPA CPX IF ITS ITEM MODE IS COMPLEX AND RSS CPA ZPX SZB,RSS IT IS A CONSTANT, JMP EE110 NOT A COMPLEX CONSTANT STACK WAS RIGHT JSB PO2.F SHOULD NOT HAVE STACKED THE '(' SO FIX IT JMP EE035 A COMPLEX CONSTANT WAS INPUT. * EE110 LDA LASTC IF PREVIOUS F.TC IS A ')' CPA B51 JMP EE16 ERROR 53 - MISSING OPERATOR. LDA B50 STA LASTC SET PREVIOUS F.TC TO '('. LDA F.IM GET F.IM OF ITEM JUST INPUT. SZA JMP EE035 LDB F.TC IF CHAR INPUT IS CPB B53 UNARY +, THEN JMP EE01 IGNORE IT AND INPUT NEXT ITEM. CPB B55 UNARY -, THEN JMP EE033 PROCESS AS UNARY MINUS JMP EE035 OTHERWISE PROCESS CURRENT ITEM SKP * ***************************** * * SEARCH TABLE FOR OPERATOR * * ***************************** SPC 1 * THE SEARCH PROPER. * EE02 JSB ICH.F SHOVE F.CC PAST SECOND '*' LDA DSTAR CHANGE F.TC TO '**' EE14A STA F.TC EE14 CLA (A) WILL BE CODE FOR OPERATOR LDB OPTBL INB EE15 STB T0EE SEARCH OP. TABLE FOR INA MATCH WITH F.TC. LDB B,I (B) = THIS OP IN TABLE. CPB F.TC IS THIS IT ? JMP EE17 YUP ! LDB T0EE NO. ADVANCE IN TABLE. ADB K2 CPB EOPTB END OF TABLE ? JMP EE16 YES. ERROR. JMP EE15 NO. GO ON. * * GOT IT. CHECK FOR '**'. * EE17 STA CCODE FIRST, SAVE CODE. CPB B52 IS IT '*' SO FAR ? RSS YES. JMP EE19 NO. JSB EXN.F YES. LOOK AT NEXT CHAR. LDB B52 CPB F.TC IS IT '*' ? JMP EE02 YES. SET UP '**'. STB F.TC NO. RESTORE F.TC . * * DON'T ALLOW A SECOND '='. * EE19 CPB B75 IS OPERATOR AN '='? RSS YES, MAKE SURE IT IS LEGAL. JMP EE18 NO, PROCESS OPR * LDA INAFL YES. IS INVERSE ASSIGN SET ? LDB K19 SZA IF SO, STB CCODE CHANGE OPCODE. (PRIORITY IS SAME) ISZ EQFLG IS '=' ALLOWED AND NONE SEEN YET? JMP EE16 NO,'=' IS ILLEGAL IN PRESENT EXP SKP * SET UP CODE & PRIORITY. * IF PRIOR > TOP-OF-STACK, STACK IT, ELSE USE IT. * EE18 ISZ T0EE YES, OPERATOR IS LEGAL, PROCESS. LDB T0EE,I CPRIO _ PRIORITY OF OPERATOR STB CPRIO LDA CCODE (A) _ CODE (ORDINAL) OF OPERATOR. ALF,ALF IOR B (A) _ CODE, PRIORITY CMB,INB CHECK OP PRIORITY AGAINST TOP OP ADB PRIOR CPA KK07 IF OPERATOR IS **, ADB KM1 EVALUATE RIGHT-TO-LEFT. SSB,RSS IS PRIORITY > TOP OP. PRIORITY? JMP EE20 NO, GENERATE CODE JSB PU2.F YES, STACK OP, INPUT NEXT ITEM JMP EE03 SPC 1 K3 DEC 3 B15 OCT 15 EOPTB DEF EOPT B47 OCT 47 ' B72 OCT 72 : B51 OCT 51 DSTAR ASC 1,** KK07 BYT 7,13 CODE=7, PRIORITY=11 (**). CCODE NOP CURRENT OPERATOR CODE CPRIO NOP CURRENT OPERATOR PRIORITY OPTBL DEF TABLE-1 OPERATOR TABLE T0EE NOP SPC 5 * *********************** * * HANDLE THE OPERATOR * * *********************** SPC 1 * CHECK FOR END & MISMATCHED PARENS. * EE42 SSA IF OPCOD < 0, JMP EXIT END OF INPUT EXPRESSION. EE20 LDA OPCOD NEXT OPERATOR CODE CPA SOP< IF '<' '(' OF ARRAY JMP EE44 ERROR - MISMATCHED PARENS. CPA SOPPR IF '(' JMP EE44 ERROR - MISMATCHED PARENS. CPA SOP[ IF '[' JMP EE44 ERROR - MISMATCHED PARENS. * * WRITE OPERATOR TO PASS FILE. * JSB WR2.F JSB PO2.F POP OPERATOR OFF STACK 2. SKP * CONTINUE POPPING OPERATORS OF SAME OR GREATER PRIOR. * EE40 LDA CPRIO CMA,INA ADA PRIOR COMPARE OPERATOR PRIORITIES SSA,RSS IF PRIOR=0, CONTINUE GEN. CODE * * NOW HANDLE THIS OPERATOR. * LDA CCODE SZA,RSS IF CCODE = 0 JMP EE41 THEN CURRENT OP IS ')',',' OR C/R ALF,ALF NO, STACK OPERATOR IOR CPRIO (A) = CCODE,CPRIO JSB PU2.F STACK OPERATOR JMP EE03 * SOPPR OCT 31 SOP[ OCT 32 SOP< OCT 33 K34 DEC 34 TYPEX NOP TYPE OF EXPRESSION. OPCOD NOP TOP OPERATOR CODE. PRIOR NOP TOP OPERATOR PRIORITY. VREFF NOP EMA CALL-BY-(VALUE/REFERENCE) FLAG. SKP * ************************** * * HANDLE ')' ',' 'C/R' * * ************************** SPC 1 * C/R: END OF EXPR. * COMMA: IF TOP IS SUB OR ARR ([,<), KEEP GOING. * ELSE IF DO PARAMETER, EMPTY OP STACK. * ELSE ERROR. * EE41 LDA F.TC CPA B15 IF DELIMITER IS CARRIAGE RETURN, RSS CPA B47 OR SINGLE QUOTE, RSS CPA B72 OR COLON, JMP EXIT GO TO END OF EXPRESSION EVAL. * LDA VREFF ')' OR ','; SEE WHETHER SZA CALL-BY-VALUE/REF SET. JSB WS1.F YES, OUTPUT THAT INFO. LDA F.TC (RESTORE CHAR) CPA B51 IF DELIMITER IS ')', JMP EE43 GO HANDLE IT. * * COMMA. * LDA OPCOD NO, MUST BE ',' CPA SOP[ IF TOP OPERATOR IS '['. JMP EE48 GO CHECK FOR ALTERNATE RETURNS. * CPA SOP< IF TOP OPERATOR IS '<' JMP EE03 CONTINUE SCAN OF EXPRESSION. * LDB EEJT2 CHECK TYPE OF INPUT EXPR. ADB TYPEX LDB B,I JMP B,I EEJT2 DEF *+1 DEF EE16 STMT FCT - ERROR. DEF EE16 SUBR CALL - ERROR. DEF EE42 DO INITIAL - O.K. DEF EE42 UNIT # - O.K. DEF EE42 DO TERM / STEP-SIZE - O.K. DEF EE16 COMPUTED GOTO - ERROR. DEF EE16 ASSIGNMENT - ERROR. DEF EE16 IF - ERROR. DEF EE42 INPUT ITEM - O.K. DEF EE42 OUTPUT ITEM - O.K. * EE16 LDA K17 ERROR, ILLEGAL OP OR DELIMITER. JSB ER.F SKP * RIGHT PAREN. MATCH WITH TOP OF STACK. * EE43 LDA OPCOD CPA SOPPR IS TOP OPERATOR '('? JMP EE45 YES * CPA SOP< IS IT AND ARRAY? JMP EE46 YES. MAY BE EMA ASSIGNMENT. * CPA SOP[ HOW ABOUT END OF FUNCTION SUB ? JMP EE47 YES. * SSA,RSS WAS STACK EMPTY ? JMP EE49 NO. * ADA T1EE YES. DECREMENT # LEFT PARENS AVAIL. SSA WAS THERE ONE ? JMP EE49 NO. * STA T1EE YES. UPDATE # LEFT. JMP EE50 AND CONTINUE WITH MATCHED PARENS. * EE49 LDA TYPEX INPUT LIST ITEM ? CPA K8 RSS YES. CPA K9 OUTPUT LIST ITEM ? RSS YES. CPA K4 DO TERM OR STEP-SIZE ? RSS YES. CPA K3 UNIT # ? JMP EXIT YES. * * TRUE LEFT PAREN. MAKE SURE END OF 'IF' CAUGHT. * EE44 LDA K9 JSB ER.F ERROR - MISMATCHED PARENTHESIS. EE45 JSB PO2.F POP OFF '(' EE50 LDA OPCOD SSA,RSS IF (A) <0, OPERATOR STACK EMPTY JMP EE03 NO, CONTINUE EXPRESSION SCAN LDA TYPEX YES, CPA K7 IF INPUT EXPRESSION IS AN 'IF' JMP EXIT END OF IF STATEMENT EXPRESSION CPA K8 LIKEWISE FOR INPUT LIST ITEM. JMP EXIT JMP EE03 NO, CONTINUE STATEMENT SCAN. SKP * COMMA IN SUBROUTINE/FCT REF. CHECK FOR ALT RTNS. * EE48 JSB EXN.F WELL ? LDB B54 (RESTORE F.TC FOR LASTC) STB F.TC CPA B52 * ? RSS CPA B46 OR & ? RSS JMP EE03 NO. * JSB ICH.F YES. READ THE * OR &. CLA,INA (A=1: STMT # IS NON-FORMAT) JSB ISD.F AND THE STATEMENT #. LDA F.A SEND AS OPERAND. JSB WR1.F LDA F.TC MUST END WITH: CPA B54 ',' RSS CPA B51 OR ')' JMP EE41 YES. BACK WHERE WE STARTED. JMP EE16 NO. ERROR. SKP * ARRAY. CHECK FOR EMA ASSIGNMENT. * EE46 LDA F.S2T,I WELL ? (SIGN BIT ON STACK ENTRY) SSA,RSS JMP EE47 NO. * JSB PO2.F YES. POP THE '<', AND JMP EE03 GO GET NEXT OPERATOR. * * SUBROUTINE OR NORMAL ARRAY. * EE47 LDA K34 WRITE OPERATOR TO PASS FILE. JSB WR2.F JSB PO2.F POP THE OPERATOR. LDA PRIOR IS TOP OPERATOR PRIORITY SSA,RSS -1? (THEN OPERATOR STK IS EMPTY) JMP EE03 NO. * CLA,INA YES CPA TYPEX CALL STATEMENT? RSS (YES) JMP EE03 NO. * JSB ICH.F YES. INPUT C/R. F.CAL CHECKS FOR IT. * K19 DEC 19 INVERSE ASSIGN OPCODE. SKP * ****************** * * EXPRESSION END * * ****************** SPC 1 EXIT LDB TYPEX IF STATEMENT FUNCTION, (0), SZB JMP EXIT1 (NO) * LDA F.SFA GET ITS TYPE. STA F.A JSB FA.F LDA F.IM IS IT... CPA DBL REAL*6, RSS CPA RE8 REAL*8, RSS CPA CPX OR COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? CLA,INA,RSS (A=1) JMP EXIT1 NO. RESULT FITS IN REGISTER. * JSB WR2.F YES. ISSUE ASSIGNMENT. EXIT1 LDA K35 WRITE OPERATOR TO TERMINATE. JSB WR2.F LDA T1EE RETURN (A) = # SOFT PARENS LEFT. JMP EE.F,I SPC 1 DBL OCT 60000 RE8 OCT 120000 B46 OCT 46 & K9 DEC 9 K35 DEC 35 K17 DEC 17 K4 DEC 4 K7 DEC 7 K8 DEC 8 SKP * **************** * * PUSH STACK 2 * * **************** SPC 1 * STACK 2 IS THE OPERATOR STACK. IT IS IN LOWER CORE THAN * IS STACK 1, JUST ABOVE THE ASSIGNMENT TABLE, AND GROWS * TOWARD HIGH CORE. THIS ROUTINE IS ENTERED WITH (A) = * WORD TO BE STACKED. SPC 1 PU2.F NOP PUSH STACK 2 TO STACK OPERATORS ISZ F.L F.L=F.L+1 LDB F.S2B ADB F.L STB F.S2T CPB F.S1T IF TOP TWO POINTERS SAME, JMP F.OFE DATA POOL OVERFLOW. STA F.S2T,I STACK OPERATOR JSB SPC.F UPDATE OPCOD, PRIOR OF TOP OP. JMP PU2.F,I SPC 2 * *************** * * POP STACK 2 * * *************** SPC 1 PO2.F NOP UNSTACK AND DISCARD OPERATORS CCB STB PRIOR REINITIALIZE OPCODE AND PRIOR TO 0. STB OPCOD ADB F.L STB F.L F.L=F.L-1 ADB F.S2B STB F.S2T NEW PTR TO TOP OPERATOR LDB F.L CPB F.SVL IS OPERATOR STACK EMPTY? RSS YES, EXIT JSB SPC.F NO, UPDATE OPCOD, PRIOR OF TOP OP. JMP PO2.F,I SPC 2 * ****************************** * * SEPARATE CODE AND PRIORITY * * ****************************** SPC 1 SPC.F NOP LDA F.S2T,I (A) _ TOP WORD IN OPERATOR STACK AND B377 STA PRIOR PRIOR _ PRIORITY OF TOP OPERATOR XOR F.S2T,I RAL,CLE,ERA CLEAR POSSIBLE SIGN BIT ALF,ALF STA OPCOD OPCOD _ CODE OF TOP OPERATOR JMP SPC.F,I SKP * ********************** * * WRITE TO PASS FILE * * ********************** SPC 1 WR1.F NOP OPERAND. IOR KK01 SET SIGN BIT. JSB WS1.F WRITE TO PASS FILE. JMP WR1.F,I EXIT. SPC 2 WR2.F NOP RAL,CLE,ERA CLEAR SIGN BIT. JSB WS1.F WRITE IT TO PASS FILE. JMP WR2.F,I EXIT. SPC 1 KK01 OCT 100000 SKP * OPERATOR TABLE WORD 1: THE OPERATOR. * 2-WORD ENTRIES WORD 2: ITS PRIORITY. SPC 1 TABLE OCT 75 =, OCT 1 PRIORITY=1, CODE=1 SPC 1 OCT 53 +, DEC 8 PRIORITY=8, CODE=2 SPC 1 OCT 55 -, DEC 8 PRIORITY=8, CODE=3 SPC 1 OCT 40 UNARY - (BLANK) DEC 9 PRIORITY=9, CODE=4 SPC 1 OCT 52 *, DEC 10 PRIORITY=10, CODE=5 SPC 1 OCT 57 /, DEC 10 PRIORITY=10, CODE=6 SPC 1 ASC 1,** **, DEC 11 PRIORITY=11, CODE=7 SPC 1 OR. ASC 1,OR LOGICAL OR, OCT 4 PRIORITY=4, CODE=8 SPC 1 ASC 1,AN LOGICAL AND OCT 5 PRIORITY=5, CODE=9 SPC 1 ASC 1,NO LOGICAL NOT, OCT 6 PRIORITY=6, CODE=10 SPC 1 ASC 1,LT RELATIONAL LESS THAN, OCT 7 PRIORITY=7, CODE=11 SPC 1 ASC 1,LE RELATIONAL LESS OR EQUAL TO, OCT 7 PRIORITY=7, CODE=12 SPC 1 ASC 1,EQ RELATIONAL EQUAL, OCT 7 PRIORITY=7, CODE=13 SPC 1 ASC 1,NE RELATIONAL NOT EQUAL, OCT 7 PRIORITY=7, CODE=14 SPC 1 ASC 1,GE RELATIONAL GREATER OR EQUAL TO, OCT 7 PRIORITY=7, CODE=15 SPC 1 ASC 1,GT RELATIONAL GREATER THAN, OCT 7 PRIORITY=7, CODE=16 SPC 1 ASC 1,EV LOGICAL EQUIVALENCE, OCT 3 PRIORITY=3, CODE=17 SPC 1 ASC 1,XO EXCLUSIVE OR, (ALSO .NEQV. & .EOR.) OCT 3 PRIORITY=3, CODE=18 SPC 1 ASC 1,== INVERSE ASSIGN, OCT 0 PRIORITY=0, CODE=19 * EOPT EQU * * UNS END F4.1 ASMB,Q,C HED EXECUTABLE STATEMENT PARSING FOR FTN4X. NAM EX.F,8 92834-16002 REV.2030 800814 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * * THIS MODULE PARSES ALL EXECUTABLE STATEMENTS. * * EXT'S WITH A LEADING 'F.' ARE VARIABLES OR JUMP TARGETS * * THE COLUMN THE EXT STARTS IN DEFINES THE SUBROUTINE IT IS * DEFINED IN AS FOLLOWS * 2 -- OA.F (WRITE PASS FILE ROUTINES) * 3 -- NEX.F (STATEMEXTS THAT DON'T CONTAIN EXPRESSIONS) * 4 -- FA.F (THE ASSIGNMEXT TABLE ROUTINES) * 5 -- EX.F (STATEMEXTS USING THE EXPRESSION EVALUATOR) * 6 -- IC.F (THE CHARACTER INPUT ROUTINES) * 7 -- IDN.F (THE TOKEN INPUT ROUTINES) * 8 -- FTN4 ( THE MAIN) EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.AT ADDRESS TYPE OF CURRENT F.A EXT F.CC CHARACTER COUNT EXT F.CRT TEST FOR C/R & GO ON TO NEXT STMT. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D DO TABLE POINTER EXT F.D0 ITEM SIZE. EXT F.DID ADDRESS OF F.IDI EXT F.DO LWAM - END OF DO TABLE EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.LFF LOCICAL IF FLAG EXT F.LNN CURRENT LINE #. EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSN STMT # OF CURRENT STATEMENT. EXT F.LSP LAST OPERATION FLAG EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NTF NO-TAG FLAG. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEG SEGMENT LOADER. EXT F.SEQ SEQUENCE COUNTER, CODE-GENERATING STMTS. EXT F.SFA STATEMENT FUNCTION F.A EXT F.SFF SUBROUTINE/FUNCTION FLAG. (SUB=0) EXT F.STB STRING BACK JUMP FLAG EXT F.STS TO STATEMEXT SCAN EXT F.TC NEXT CHARACTER EXT F.VDM CURRENT ITEM'S VARIABLE DIMENSION BIT. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CDI.F CLEAR IDI. EXT CRP.F ISSUE CROSS-REF PAIR. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (F.AT) EXT DS.F DEFINE (F.S)=1 EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ESC.F ESTABLISH CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDL.F INPUT DUMMY LIST. EXT IDN.F INPUT ITEM, DO NOT ASSIGN. EXT II.F INPUT ITEM EXT IIV.F INPUT INTEGER VARABLE EXT ISC.F INPUT STRING CONSTANT. EXT ISN.F INPUT STATEMEXT NUMBER EXT ISY.F INPUT SYMBOL EXT ITS.F INTEGER TEST EXT IVN.F INPUT VARIABLE/ARRAY NAME. EXT KWP.F KEYWORD SEARCH, IN PROGRESS. EXT KWS.F KEYWORD SEARCH ROUTINE. EXT MVW.F INTERNAL MOVE WORDS. EXT NCT.F TEST FOR NOT A CONSTANT EXT NET.F TEST FOR NOT EMA. EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT NWI.F COMPUTE # WORDS IN ITEM. EXT RP.F INPUT ')' EXT SCP.F SAVE CURREXT STATPMEXT POSITION. EXT TCT.F TEST (A) = F.TC ELSE ER 28 EXT TS.F TAG SUBPROGRAM SUB. EXT TV.F TAG VARIABLE EXT UC.F UNINPUT COLUMN EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) EXT WS1.F WRITE WORD ON SCRATCH FILE 1. * * EXTERNALS IN EX.F . * ENT F.ASP ASSIGN STATEMENT PROCESSOR. ENT F.ASS ASSIGNMENT STATEMENT PROCESSOR. ENT F.BSP BACKSPACE STATEMENT PROCESSOR. ENT F.CAL CALL STATEMENT PROCESSOR. ENT F.CLP CLOSE STATEMENT PROCESSOR. ENT F.CON CONTINUE STATEMENT PROCESSOR. ENT F.DCP DECODE STATEMENT PROCESSOR. ENT F.DOP DO STATEMEXT PROCESSOR ENT F.ECP ENCODE STATEMENT PROCESSOR. ENT F.EDP END IF STATEMENT PROCESSOR. ENT F.EFP ENDFILE STATEMENT PROCESSOR. ENT F.ELP ELSE STATEMENT PROCESSOR. ENT F.ENP END STATEMENT PROCESSOR. ENT F.GOP GO TO STATEMENT PROCESSOR ENT F.IFP IF STATEMEXT PROCESSOR ENT F.IQP INQUIRE STATEMENT PROCESSOR. ENT F.OPP OPEN STATEMENT PROCESSOR. ENT F.PAP PAUSE STATEMENT PROCESSOR. ENT F.PNT PRINT STATEMENT PROCESSOR. ENT F.RDP READ STATEMEXT PROCESSOR ENT F.RTN RETURN STATEMENT PROCESSOR. ENT F.RWP REWIND STATEMENT PROCESSOR. ENT F.SFP STATEMEXT FUNCTION PROCESSOR ENT F.STP STOP STATEMENT PROCESSOR. ENT F.THP THEN STATEMENT PROCESSOR. ENT F.WRP WRITE STATEMEXT PROCESSOR * ENT ISD.F INPUT STMT #, MODIFY FOR DO TERM. * * * EXTERNALS IN THE SEGMENT * EXT APT.F ALLOCATE PERMANENT TEMP. EXT EE.F EXPRESSION EVALUATOR EXT PU2.F PUSH ONTO STACK 2 SUB * * SYSTEM ROUTINES. * EXT .MVW * A EQU 0 B EQU 1 SUP SKP * ******************* * * IF ( PROCESSOR * * ******************* SPC 1 * ANALYZE EXPRESSION. CHECK WHAT FOLLOWS. * F.IFP JSB ICH.F MAKE SURE IS 'IF(' LDA B50 JSB TCT.F TEST F.TC=(A) ? JSB EE.F EXPRESSION EVALUATOR BYT 0,7 LDA B51 ')' JSB TCT.F F.TC-TEST JSB EXN.F EXAMINE NEXT CHARACTER SZB DIGIT? JMP IFLP6 NO. STATEMENT TO FOLLOW * * 2-WAY OR 3-WAY. GET STMT #'S & OUTPUT. * STB T3IFL SET DEFAULT OF 2-WAY. CLA,INA INPUT FIRST STMT # (NON-FORMAT) JSB ISD.F LDA F.A T1IFL = 1ST STMT #. STA T1IFL LDA B54 , JSB TCT.F CLA,INA INPUT SECOND STMT # (NON-FORMAT). JSB ISD.F LDA F.A T2IFL = 2ND STMT #. STA T2IFL LDB F.TC LDA KK39A (A=OP FOR 2-WAY) CPB B54 ',' ? CLA,INA,RSS YES. THIRD STMT # FOLLOWS JMP IFLP2 NO. 2-WAY. A=OP. JSB ISD.F INPUT THIRD STATEMENT #. LDA F.A T3IFL = 3RD STMT #. STA T3IFL LDA KK39B SEND 3-WAY OPCODE. IFLP2 JSB WS1.F OPCODE. LDA F.SEQ SEQUENCE COUNTER. JSB WS1.F LDA T1IFL 1ST STMT # JSB WS1.F LDA T2IFL 2ND STMT # JSB WS1.F LDA T3IFL 3RD STMT # SZA (IF THERE) JSB WS1.F JMP RTNP1 SKP * CLEAN UP & EXIT. * RTNP1 LDA F.LFF IF LOGICAL IF FLAG SZA,RSS NOT SET STA F.LSP RESET LAST OPERATION FLAG CILDT LDA F.LFF ILLEGAL DO TERM SZA ONLY IF NOT IN LOGICAL IF. JMP F.CRT ELSE IT'S O.K. * ILTRM CLA,INA SET LAST STATEMENT STA F.LSF FLAG ILLEGAL TERMINATION JMP F.CRT GO TEST FOR END OF STATEMENT SPC 2 * LOGICAL IF FOLLOWED BY STATEMENT. * IFLP6 LDB F.LFF LOGICAL IF FLAG SET ? LDA K52 SZB JSB ER.F YES. LOGICAL IF WITHIN LOGICAL IF LDB F.TC LOAD THE NEXT CHARACTER. CPB B15 END OF CARD? JMP IFLP1 YES. BITCH. LDA KK40 SEND THE LOGICAL IF OPCODE. JSB WS1.F LDA F.SEQ AND THE SEQUENCE COUNTER. JSB WS1.F LDA TWPE FORM TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A SAVE THE F.A AS STRING-BACK ENTRY. STA F.STB STA F.LFF SET THE LOGICAL IF FLAG JSB WS1.F SEND F.A OF IT TO PASS 2. JSB EXN.F EXAMINE NEXT CHARACTER JSB SCP.F SAVE CURRENT CARD POSITION FOR RESCAN JMP F.STS TO STATEMENT SCAN * IFLP1 ISZ F.CC SET "F.CC" TO 1. LDA K89. ERROR 89. JSB ER.F SPC 2 B15 OCT 15 C/R B51 OCT 51 ')' B54 OCT 54 ',' K52 DEC 52 K89. DEC 89 KK39A BYT 3,47 2-WAY OPCODE. KK39B BYT 4,47 3-WAY OPCODE. KK40 BYT 2,50 LOGICAL IF OPCODE. KK41 BYT 2,51 SIMPLE GOTO OPCODE. T1IFL NOP T2IFL NOP T3IFL NOP SKP * ****************** * * THEN PROCESSOR * * ****************** SPC 1 F.THP LDB F.LFF IN LOGICAL IF ? LDA K10 SZB,RSS JSB ER.F NO. ERROR 10. * LDA KM3 YES. ALLOCATE THREE WORDS ON DO STACK. JSB DPO.F LDA B100K TOS = 100000 (ENDIF TARGET) LDB F.STB TOS+1 = ELSE TARGET = FALSE BRANCH F.A ADB B100K (SET SIGN TO FLAG THAT IT'S BLOCK IF) DST F.D,I PUT ON STACK. THP01 JSB ICH.F ADVANCE TO THE C/R. JMP ILTRM ALWAYS ILLEGAL DO TERMINATOR. * K10 DEC 10 K50 DEC 50 KM2 DEC -2 KK55 BYT 2,67 ENDIF OPERATOR. SPC 2 * ******************* * * ENDIF PROCESSOR * * ******************* SPC 1 F.EDP JSB EET.F DO SOME ERROR CHECKING. LDA KK55 OUTPUT ENDIF OPCODE. JSB WS1.F LDA F.D,I AND ENDIF TARGET. ISZ F.D JSB WS1.F LDA F.D,I AND ELSE TARGET. ISZ F.D JSB WS1.F ISZ F.D (SKIP UNUSED THIRD WORD ON STACK) JMP THP01 DONE. SPC 2 * SUBR TO CHECK IF VALID ELSE, ELSEIF, ENDIF. * EET.F NOP LDA K50 IF TRUE BRANCH OF LOGICAL IF, LDB F.LFF SZB JSB ER.F THEN ERROR 50. LDB F.LSN STATEMENT NUMBER ?? LDA K77 IF SO, WARNING. SZB JSB WAR.F LDA K30 IF DO STACK EMPTY, LDB F.D CPB F.DO JSB ER.F THEN NO MATCHING 'THEN'. INB IF TOP ENTRY IN DO STACK LDB B,I IS FOR A DO LOOP, SSB,RSS JSB ER.F THEN NESTING ERROR. * JMP EET.F,I ELSE O.K. * K30 DEC 30 K77 DEC 77 SKP * ****************** * * ELSE PROCESSOR * * ****************** SPC 1 F.ELP JSB EXN.F CHECK NEXT CHARACTER AFTER 'ELSE'. CPA B15 END OF LINE ? JMP ELP00 YES. JUST AN ELSE. * JSB ICH.F ELSE MUST BE 'ELSE IF' LDA "I" JSB TCT.F JSB ICH.F LDA "F" JSB TCT.F CCA,RSS ELSEIF. FLAG=-1. ELP00 CLA ELSE. FLAG=0. STA T1ELP SAVE ELSE/ELSEIF FLAG. JSB EET.F DO SOME ERROR CHECKING. DLD F.D,I ARE WE CURRENTLY IN AN ELSE PART ? LDA K30 CPB B100K JSB ER.F YES. TWO ELSE'S IN A ROW. * LDB F.D,I ENDIF TARGET. CPB B100K DOES IT EXIST ? RSS JMP ELP01 YES. (DUE TO ELSEIF) * LDA TWPE NO. CREATE ONE. JSB ESC.F JSB AI.F LDA F.A AND PUT IT ON STACK. STA F.D,I ELP01 LDA KK54 OUTPUT OPERATOR FOR ELSE. JSB WS1.F LDA F.D,I WITH: ENDIF TARGET. JSB WS1.F DLD F.D,I LDA B AND ELSE TARGET. JSB WS1.F LDB F.D ZAP THE ELSE TARGET, LDA B100K TO SHOW THAT WE'RE IN THE INB ELSE PART NOW, AND ONLY STA B,I ENDIF IS LEGAL FROM NOW ON. ISZ T1ELP IS IT ELSE OR ELSEIF ? JMP THP01 ELSE. DONE. SKP * ELSEIF PROCESSING. * JSB ICH.F VERIFY '(' LDA B50 JSB TCT.F JSB EE.F GET LOGICAL EXPRESSION. BYT 0,7 LDA B51 VERIFY ')' JSB TCT.F JSB KWS.F VERITY 'THEN' DEF "THEN ADA K30 CPA K30 FOUND ? JSB ER.F NO. * LDA KK40 LOGICAL IF OPCODE. JSB WS1.F LDA F.SEQ SEQUENCE COUNTER (NOT USED HERE) JSB WS1.F LDA TWPE FORM THE TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A AND SEND IT. JSB WS1.F LDA F.A ALSO USE IT AS THE ELSE TARGET. IOR B100K LDB F.D INB STA B,I JMP THP01 DONE. * KK54 BYT 2,66 ELSE OPERATOR. T1ELP NOP ELSE/ELSEIF FLAG. "I" BYT 0,111 "F" BYT 0,106 "THEN ASC 3,THEN SKP * ******************* * * GO TO PROCESSOR * * ******************* SPC 1 F.GOP JSB EXN.F EXAMINE NEXT CHARACTER SZB CHAR. A DIGIT? JMP GOTO2 NO * CLA,INA INPUT (NON-FORMAT) STMT #. JSB ISD.F LDA F.LFF ON TRUE SIDE OF LOGICAL IF ? SZA JMP GOTO1 YES. SPECIAL CASE. * STA F.LSP NO. RESET LAST OP FLAG. LDA KK41 OUTPUT SIMPLE 'GOTO'. JSB WS1.F LDA F.SEQ WITH SEQUENCE COUNTER. JSB WS1.F LDA F.A AND STMT #. JSB WS1.F JMP RTNP1 DONE. ILLEGAL DO TERMINATOR. * GOTO1 LDA F.A LOGICAL IF. SET F.AF OF THE CMA STRINGBACK ENTRY TO THE ISZ F.STB COMPLEMENT OF THE F.A OF STA F.STB,I THE TARGET STATEMENT #. CLA CLEAR THE STRINGBACK FLAG. STA F.STB JMP RTNP1 THAT'S ALL. SPC 2 * ***************** * * ASSIGNED GOTO * * ***************** SPC 1 GOTO2 SEZ CHAR A LETTER ? JMP GOTO4 NO. DELIMITER. * ISZ F.NTF ASSIGNED; INPUT INTEGER VARIABLE JSB IIV.F (NO-TAG FLAG IN CASE LEFT PAREN AFTER) LDA F.A SAVE ITS F.A FOR LATER. STA T1GOT CLA SET DEFAULT COUNT = 0. STA T1IBL LDA F.TC BRANCH LIST ? CPA B15 JMP GOTO3 NO. END OF STMT. * CPA B54 YES. OPTIONAL COMMA ? RSS YES. HAVE ALREADY READ IT. JSB UC.F NO. BACK UP SO CAN RE-READ LEFT PAREN. JSB IBL.F INPUT BRANCH LIST GOTO3 LDA KK42 OUTPUT ASSIGNED GOTO OPERATOR. JSB WS1.F LDA T1GOT AND VARIABLE. JSB WS1.F LDA T1IBL AND LENGTH OF BRANCH LIST. JSB WS1.F LDA F.LFF UNLESS IN TRUE PART OF LOGICAL IF, SZA,RSS STA F.LSP RESET LAST OP FLAG. JMP RTNP1 DONE. MAKE SURE NOT END OF 'DO'. SKP * ***************** * * COMPUTED GOTO * * ***************** SPC 1 GOTO4 JSB IBL.F COMPUTED; INPUT BRANCH LIST CPA B54 NEXT CHAR = , ? RSS (IT'S OPTIONAL) JSB UC.F NO. UNINPUT COLUMN JSB EE.F EVALUATE GOTO INDEX EXPR. BYT 0,5 LDA KK43 OUTPUT COMPUTED GOTO OPERATOR. JSB WS1.F LDA F.SEQ AND SEQUENCE COUNTER. JSB WS1.F LDA T1IBL AND LENGTH OF BRANCH LIST. JSB WS1.F LDA F.LFF UNLESS IN TRUE PART OF LOGICAL IF, SZA,RSS STA F.LSP RESET LAST OP FLAG. JMP RTNP1 DONE. MAKE SURE ISN'T 'DO' END. SPC 2 B50 OCT 50 '(' B100K OCT 100000 T1IBL NOP NO. OF STMT NUMBERS T1GOT NOP KK42 BYT 2,52 ASSIGNED GOTO OPERATOR. KK43 BYT 2,53 COMPUTED GOTO OPERATOR. SPC 2 * ********************* * * INPUT BRANCH LIST * * ********************* SPC 1 IBL.F NOP CLA STA T1IBL LENGTH = 0. JSB ICH.F MUST START WITH '('. LDA B50 '(' JSB TCT.F IBL02 CLA,INA INPUT (NON-FORMAT) STMT #. JSB ISD.F LDA F.A SEND OUT AS AN OPERAND. IOR B100K JSB WS1.F ISZ T1IBL INCREMENT NUMBER OF STMNT NOS. LDA F.TC CPA B54 ',' ? JMP IBL02 YES. GET ANOTHER STMT NO. JSB RP.F )-INPUT OPERATOR JMP IBL.F,I DONE. SKP * **************** * * DO PROCESSOR * * **************** SPC 1 * INPUT STMT #. * F.DOP LDA K50 LDB F.LFF IN LOGICAL IF ? SZB JSB WAR.F DO IN LOG IF STATEMENT CLA,INA INPUT STMT # (NON-FORMAT) JSB ISN.F LDA F.TC IF COMMA, CPA B54 RSS LEAVE IT THERE, JSB UC.F ELSE BACK UP TO LAST DIGIT. LDA F.A T1DOP = F.A OF STMT #. STA T1DOP * * INPUT INDEX, PROCESS REST OF LINE. * JSB IIV.F INPUT INTEGER VARIABLE LDA B75 MUST BE FOLLOWED BY '='. JSB TCT.F F.TC TEST. LDA F.A T2DOP = ITS F.A STA T2DOP CLB MUST END WITH 'C/R'. JSB DCM.F COMMON 'DO' PROCESSING. LDA KK44 END OF DO STATEMENT. JSB WS1.F LDA T2DOP ALSO INDEX F.A JSB WS1.F * * PUT STMT #, CONTROL VAR, & TWPE ON STACK. * LDA KM3 ALLOCATE 3 WORDS. JSB DPO.F LDA T1DOP (D) = STMT #. LDB T2DOP (D+1) = CONTROL VARIABLE. DST F.D,I LDA TWPE FORM TWPE ENTRY. JSB ESC.F JSB AI.F LDA F.A LDB F.D (D+2) = F.A OF TWPE ENTRY. ADB K2 STA B,I JMP ILTRM EXIT. * T1DOP NOP F.A OF STMT # IN DO STMT. T2DOP NOP F.A OF INDEX IN DO STMT. B75 OCT 75 = KK44 BYT 1,54 OPCODE FOR 'DO', STEP=1. SKP * ************************ * * COMMON DO PROCESSING * * ************************ SPC 1 * INPUT: (A) = F.A OF LOOP INDEX. * (B) = END REQUIREMENT: 0=C/R, -1=). * * VERIFY THAT THE INDEX IS UNIQUE. * DCM.F NOP STB T1DCM (SAVE END FLAG) LDB F.D VERIFY UNIQUE: SEARCH DO TABLE. DCM01 CPB F.DO END ? JMP DCM03 ALL CHECKED: OK. INB CPA B,I THIS ONE ? JMP ERR51 YES, ERROR. ADB K2 JMP DCM01 NEXT ! ERR51 LDA K51 ERROR 51 JSB ER.F NESTED DO WITH SAME CONTR VAR * * EVALUATE INITIAL,FINAL,STEP. * DCM03 JSB EE.F EVALUATE INITIAL INDEX BYT 0,2 LDA B54 , JSB TCT.F JSB EE.F EVALUATE FINAL VALUE. BYT 0,4 LDB F.TC CPB B54 F.TC = ',' ? RSS JMP DCM04 NO. NO STEP SIZE. JSB EE.F YES. EVALUATE STEP SIZE BYT 0,4 * * CHECK NEXT CHARACTER. * DCM04 LDB B15 NORMAL DO: WANT 'C/R'. LDA K9 (ELSE ERROR 9) ISZ T1DCM WHICH ? JMP DCM05 NORMAL. LDB B51 IMPLIED DO: WANT ')'. LDA K28 (ELSE ERROR 28) DCM05 CPB F.TC IS IT RIGHT ? JMP DCM.F,I YES, EXIT. JSB ER.F NO, ERROR. SPC 1 T1DCM NOP K28 DEC 28 K51 DEC 51 SKP * ****************************** * * INPUT STMT #'S IN DO LOOPS * * ****************************** SPC 1 * INPUTS A STATEMENT NUMBER, USING ISN.F, AND CHECKS * WHETHER THE STMT # ENDS A DO LOOP; IN THAT CASE, THE TWPE FOR * THE END OF THE INNERMOST LOOP (WITH THAT LABEL) WHICH CONTAINS * THE CURRENT STATEMENT IS RETURNED IN F.A INSTEAD OF THE ACTUAL * STMT # F.A . * * ENTRY: (A) = -1/0/+1 AS IN ISN.F * ISD.F NOP JSB ISN.F INPUT STATEMENT #. LDA F.A (A) = STMT # F.A LDB F.D TOP OF DO STACK. ISD01 CPB F.DO ALL CHECKED ? JMP ISD.F,I YES. NOT FOUND, EXIT WITH (F.A) INTACT. * CPA B,I NO. CHECK NEXT ENTRY. JMP ISD02 GOT ONE. * ADB K3 NOT THIS ONE. GO ON TO NEXT. JMP ISD01 * ISD02 ADB K2 GOT ONE. GET IT'S TWPE ENTRY. LDB B,I STB F.A AND RTN IN F.A LDA B,I SET THE F..E FLAG IN THE TWPE, IOR K8 TO INDICATE THAT IT WAS USED. STA B,I JMP ISD.F,I EXIT. SPC 2 * *************************** * * DATA POOL OVERFLOW TEST * * *************************** SPC 1 * INPUT: (A) = DELTA-D. RETURN NEW D IN B SPC 1 DPO.F NOP ADA F.D STA F.D F.D=(A) LDB A CMA,INA ADA F.LO ADA F.L (A)=LO+F.L-D SSA JMP DPO.F,I EXIT * JMP F.OFE DATA POOL OVERFLOW BAIL OUT!@*?##@@'** SKP * **************** * * READ & WRITE * * **************** SPC 1 * STANDARD-UNIT VERSIONS. * F.RDP JSB EXN.F NEXT IS '(' ? CPA B50 JMP RDP01 YES. KEYWORD FORM. * CLA,RSS READ: 0. F.PNT CLA,INA PRINT: 1. STA T0IOK LDA KK64 OPCODE 64, JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F CLA SET F.IM=0 FOR RFM.F STA F.IM JSB RFM.F READ THE FORMAT; SEND THRU PASS FILE. LDA K66 OPCODE 66, TO FINISH IT. JSB WS1.F LDA F.TC CHECK DELIMETER: CPA B54 IF COMMA, JSB IOL.F GO PROCESS LIST. JMP IOK52 TERMINATE STATEMENT. (REQUIRE C/R) SPC 2 * KEYWORD VERSIONS. * F.WRP CLA,INA,RSS STATEMENT TYPE = 1. RDP01 CLA READ; TYPE = 0. JMP IOK01 GO PROCESS KEYWORDS. SKP * **************************************************** * * OPEN, CLOSE, INQUIRE, BACKSPACE, ENDFILE, REWIND * * **************************************************** SPC 1 F.OPP LDA K2 OPEN. TYPE = 2. (4) JMP IOK01 * F.CLP LDA K3 CLOSE. TYPE = 3. (10B) JMP IOK01 * F.IQP LDA K4 INQUIRE. TYPE = 4. (20B) JMP IOK01 * F.BSP CCA,RSS BACKSPACE. CODE = -1. F.EFP CLA ENDFILE. CODE = 0. RSS F.RWP CLA,INA REWIND. CODE = +1. STA T1IOK SAVE TYPE. LDA KK22 SEND SPECIAL OPCODE WITH CODE. JSB WS1.F LDA T1IOK JSB WS1.F JSB EXN.F IS IT A KEYWORD LIST ? LDB A (B) = FIRST CHAR. LDA K5 (A) = STATEMENT TYPE, IN CASE KEYWORDS. CPB B50 STARTING WITH '('. JMP IOK01 YES. GO PROCESS THAT. * JSB EE.F NO. GET UNIT # NOW. BYT 0,3 LDA KK64 DO SPECIAL SEQUENCE: JSB WS1.F OPCODE 64, LDA K5 WITH STATEMENT TYPE. JSB WS1.F LDA KK65 OPCODE 65, JSB WS1.F LDA K.UNT ONLY VALUE IS UNIT #. JSB WS1.F LDA K66 OPCODE 66 TO END IT. JSB WS1.F JMP F.CRT THAT'S ALL. * K3 DEC 3 K5 DEC 5 KK22 BYT 1,26 SKP * INITIALIZE KEYWORD FETCH LOOP. * IOK01 STA T0IOK SAVE TYPE. ADA DBTBL GET CORRESPONDING BIT. LDA A,I STA T1IOK AND SAVE THAT TOO. LDA KK64 SEND OPCODE TO START STATEMENT. JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F JSB ICH.F READ & LDA B50 REQUIRE '(' JSB TCT.F IOK02 LDA NKWRD CLEAR OUT THE 'USED' BITS. CMA,INA STA T2IOK LDA KWIT FWA-1 OF TABLE. IOK03 INA CLEAR ANOTHER. LDB A,I RBL,CLE,ERB STB A,I ISZ T2IOK JMP IOK03 * CLA CLEAR OUT FLAGS. STA T2IOK UNIT FMT POSITIONAL FLAG. STA T4IOK FMT=* FLAG. STA T5IOK SEC/TER FLAG. * * GET ANOTHER KEYWORD. * IOK04 CLA FLAG F.IM: IDN.F NOT CALLED. STA F.IM JSB EXN.F BECAUSE: ONLY CALLED FOR NAMES (HERE). SEZ,RSS (E=0: LETTER/DIGIT) SZB,RSS (B#0: NON-DIGIT) JMP IOK05 NOT LETTER; NOT KEYWORD. * JSB IDN.F LETTER. GET KEYWORD OR NAME. JSB UC.F REREAD THE DELIMETER. JSB ICH.F SEZ IF LONG NAME, CPA B75 OR ENDS WITH '=', JMP IOK07 THEN NORMAL KEYWORD. SKP * VALUE, NOT KEYWORD. CHECK THAT THAT'S O.K. * IOK05 LDB T2IOK MAKE SURE THAT VALUE ALLOWED HERE: ISZ T2IOK (UNIT->FMT, FMT->ILLEGAL) CLA CPB K1 FORMAT ? LDA K.FMT YES. SZB,RSS UNIT # ? LDA K.UNT YES. STA T3IOK SAVE (MISSING) KEYWORD ORDINAL. SZA EITHER OF THE ABOVE ? JMP IOK11 YES. JMP IOK99 NO. ERROR 15. * * TRUE KEYWORD. SEARCH FOR IT. * IOK07 LDA K2 BUT FIRST, DISALLOW ANY MORE POSITIONAL. STA T2IOK JSB UC.F AND BACK UP SO CAN REREAD THE '='. JSB KWP.F START MATCH IN PROGRESS. DEF IOKWL SZA,RSS FOUND ? JMP IOK99 NO. ERROR. * IOK09 STA T3IOK YES. SAVE ORDINAL. CLA SET F.IM TO INDICATE THAT STA F.IM NO ATTEMPT MADE TO READ VALUE. * * CHECK IF DUPLICATE OR ALLOWED; * SPECIAL-CASE 'FMT', 'ERR', AND 'END'. * IOK11 LDB KWIT GET TABLE ENTRY. ADB T3IOK LDA B,I SSA DUPLICATE KEYWORD ? JMP IOK99 YES. * IOR B100K NO. SET 'USED' BIT. STA B,I AND T1IOK ALLOWED ? SZA,RSS JMP IOK99 NO. SKP * CHECK FOR ILLEGAL COMBINATION. THIS IS DONE ON THE * FLY SO THAT THE CURSOR IS POSITIONED PROPERLY. * LDA T4IOK NOT ALLOWED WITH 'REC': 'FMT=*', IOR T5IOK SEC/TER, IOR T.END END, IOR T.ZBF ZBUF, IOR T.ZLN ZLEN. AND T.REC ONE OF ABOVE WITH 'REC' ? SSA JMP IOK98 YES. ILLEGAL. * LDA T.ZBF ZBUF .OR. ZLEN, IOR T.ZLN AND T5IOK AND SEC/TER ? SSA JMP IOK98 YES. ILLEGAL. * LDA T.FIL FILE .AND. UNIT, AND T.UNT LDB T0IOK ON INQUIRE ? CPB K4 (INQUIRE=4) SSA,RSS RSS (NO) JMP IOK98 YES. ILLEGAL. * * IS ALLOWED & LEGAL. SPECIAL-CASE FMT,ERR,END,UNIT. * LDA T3IOK 'FMT' ? CPA K.FMT JMP IOK30 YES. * CPA K.ERR 'ERR' RSS OR CPA K.END 'END' ? JMP IOK40 YES. * LDB F.IM 'UNIT', CPA K.UNT AND NO VALUE YET ? SZB (YES) JMP IOK17 NO. * JSB EXN.F YES. IS IT 'UNIT=*' ? CPA B52 RSS (YES) JMP IOK15 NO. (UNIT ALWAYS R-VALUED) * JSB ICH.F YES. READ THE '*', STA T4IOK DISALLOW 'REC' IN THE FUTURE. LDA T.REC ALSO IN THE PAST. SSA JMP IOK98 * LDA T0IOK CHECK THAT READ OR WRITE. SZA CPA K1 RSS (YES) JMP IOK98 NO. ILLEGAL IN ANY OTHER. * JSB ICH.F AND THE DELIMITER. LDA KK65B WRITE TO THE PASS FILE: JSB WS1.F OP FOR ALTERNATE FORM, LDA K.UNT KEYWORD NUMBER, IOR B100K WITH WHOLE ITEM BIT, JSB WS1.F CLA THEN VALUE = 0. JSB WS1.F JMP IOK28 CHECK DELIMITER. * * DETERMINE WHETHER R-VALUED OR L-VALUED. * IOK17 CPA K.FIL IF FILE, JMP IOK15 THEN ALWAYS R-VALUED. * CPA K.IOS IF IOSTAT, JMP IOK13 THEN ALWAYS L-VALUED. * LDA T0IOK ELSE SEE IF INQUIRE: CPA K4 IF SO, THEN L-VALUED; IOK13 CCB,RSS L-VALUED: LIKE INPUT, NO EXPRESSIONS. IOK15 CLB R-VALUED: LIKE OUTPUT, EXPRESSIONS O.K. ADB KK09 SET UP EXPRESSION TYPE. STB IOK24 SKP * PARSE THE EXPRESSION. * LDA KWIT FIRST, SEE IF CHARACTER DATA. ADA T3IOK LDA A,I ALF,ALF SLA WELL ? (BIT 8) JMP IOK35 YES. GO DO THAT. * LDA F.IM NO. CALLED IDN.F YET ? SZA,RSS JMP IOK22 NO. GO CALL II.F * JSB AI.F YES. ENTER NAME IN A.T., JSB CRP.F AND CROSS-REF IT. RSS (SKIP II.F) IOK22 JSB II.F GET FIRST ITEM IN EXPRESSION. LDA IOK24 INPUT-TYPE OR OUTPUT-TYPE. CPA KK09 JMP IOK26 OUTPUT-TYPE. * JSB NCT.F INPUT-TYPE. NO CONSTANTS/DELIMETERS, JSB NST.F OR FUNCTIONS, JSB NET.F AND MUST NOT BE EMA. LDB F.TC AND REQUIRE NEXT CHAR TO BE: CPB B50 '(' RSS CPB B51 ')' RSS CPB B54 OR COMMA. RSS JMP IOL53 ELSE ERROR 17. * IOK26 LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP IOK23 NO. GO DO IT, FINALLY. * LDA F.TC YES. ALL BY ITSELF ? CPA B54 I.E., FOLLOWED BY COMMA, RSS CPA B51 OR RIGHT PAREN ? JMP IOK42 YES. SEND WITH "WHOLE ITEM" BIT. * IOK23 JSB EE.F GET KEYWORD EXPRESSION. IOK24 ABS *-* LOOKS LIKE I/O LIST ITEM. IOK25 LDA KK65 SEND GENERAL KEYWORD OPCODE. JSB WS1.F LDA T3IOK AND KEYWORD ORDINAL. JSB WS1.F SKP * IF R/W UNIT, PROCESS OPTIONAL 'REC OR :SEC:TER . * LDA T0IOK READ OR WRITE ? SZA CPA K1 RSS (YES) JMP IOK28 NO. DON'T CHECK FURTHER. * LDA T3IOK UNIT ? RAL,CLE,ERA CPA K.UNT RSS (YES) JMP IOK28 NO. NO OTHERS HAVE SPECIAL SYNTAX. * LDB F.TC YES. RECORD NUMBER ? LDA K.REC (JUST IN CASE) CPB B47 I.E. LU'REC ? JMP IOK09 YES. TREAT QUOTE AS: ",REC=" . * CPB B72 NO. HOW 'BOUT COLON ? RSS (YES) JMP IOK28 NO. * LDA T.ZBF YES. DON'T ALLOW: ZBUF, IOR T.ZLN ZLEN, IOR T.REC REC. CMA,SSA,RSS WELL ? JMP IOK98 YES. ILLEGAL WITH SECONDARIES. * STA T5IOK NO. SET T5IOK<15> AS FLAG. JSB EE.F GET 'SEC' VALUE. BYT 1,3 LDA KK65 SEND KEYWORD OPCODE, JSB WS1.F LDA K.SEC WITH 'SEC' ORDINAL. JSB WS1.F LDA F.TC IS 'TER' PRESENT ? CPA B72 JMP IOK32 YES. GET IT. * CLA NO. CREATE ZERO, JSB EIC.F IOR B100K AND SEND THRU TO APPEAR ON STACK. JSB WS1.F JMP IOK33 * IOK32 JSB EE.F GET 'TER' VALUE. BYT 1,3 IOK33 LDA KK65 AND SEND THAT VALUE, TOO. JSB WS1.F LDA K.TER JSB WS1.F SKP * CHECK SYNTAX AFTER VALUE. * IF END, CHECK KEYWORD COMBINATIONS AGAIN. * IOK28 LDA F.TC HOW DOES IT END ? CPA B54 ',' ? JMP IOK04 YES. GET NEXT ONE. * LDA B51 REQUIRE ')'. JSB TCT.F LDA T.ZBF IF EITHER OF ZBUF/ZLEN, XOR T.ZLN THEN MUST BE BOTH. SSA JMP IOK98 NO. ERROR. * LDA T.UNT UNIT PRESENT ? SSA JMP IOK49 YES. THEN ALL'S O.K. * LDA T1IOK NO. ENCODE OR DECODE ? AND B300 SZA JMP IOK49 YES. THAT'S RIGHT. * LDA T0IOK INQUIRE & 'FILE' PRESENT ? LDB T.FIL CPA K4 INQUIRE=4, SSB,RSS INQUIRE. 'FILE' ? JMP IOK98 NOT INQUIRE OR NO FILE. ERROR. JMP IOK49 YES. INQUIRE BY FILE, O.K. * KK09 BYT 1,11 EE.F PARAM: OUTPUT ITEM, NO TEMP INIT. KM1 DEC -1 * * GET FORMAT SPECIFIER. * IOK30 JSB RFM.F COMMON WITH STD UNIT & DECODE/ENCODE. JMP IOK28 SKP * READ CHARACTER DATA ITEM. * IOK35 LDA IOK24 L-VALUE OR R-VALUE ? CPA KK09 RSS R-VALUE. JMP IOK36 L-VALUE. CAN'T BE CONSTANT. * JSB EXN.F R-VALUE. CONSTANT STRING ? CPA B47 RSS YES. JMP IOK36 NO. THEN SAME AS L-VALUE. * JSB ICH.F YES. READ THE QUOTE. JSB ISC.F INPUT THE CONSTANT STRING. JMP IOK42 AND GO SEND IT. * IOK36 JSB IVN.F GET ITEM. (DIDN'T CALL IDN.F YET) JSB FSD.F FAKE A STRING DESCRIPTOR. JMP IOK42 GO SEND THE TEMP AS THE VALUE. * * READ STATEMENT NUMBER FOR END= AND ERR=. * IOK40 LDA F.IM MUST NOT BE NAMED. SZA JMP IOK99 NAMED. * CLA,INA GET NON-FORMAT STMT #. JSB ISN.F IOK42 LDA F.A PASS THRU FOR STACK. IOR B100K JSB WS1.F LDA T3IOK SET THE "WHOLE ITEM" BIT. IOR B100K STA T3IOK JMP IOK25 SKIP THE EXPRESSION STUFF. SKP * COMMON FORMAT READER. * SENDS FORMAT THRU PASS FILE WITH OPCODE 65. * FORMAT '*' HAS VALUE 0. 'WHOLE ITEM' BIT SET. * RFM.F NOP LDA F.IM ALREADY HAVE NAME ? SZA JMP RFM06 YES. GO ANALYZE. * JSB EXN.F NO. CHECK FIRST CHAR. SZB DIGIT ? JMP RFM02 NO. NOT STMT #. * CCA YES. GET (FORMAT) STATEMENT #. JSB ISN.F JMP RFM08 GO WRITE TO PASS FILE. * RFM02 CPA B52 '*' ? RSS (YES) JMP RFM03 NO. * LDA T.REC YES. LIST-DIRECTED; CMA,SSA,RSS ILLEGAL WITH 'REC'. JMP IOK98 'REC', ERROR. * STA T4IOK NO. SET T4IOK<15> AS FMT=* FLAG. JSB ICH.F READ THE '*', JSB ICH.F & DELIMETER. CLA AND SET F.A = 0. STA F.A JMP RFM08 GO WRITE TO PASS FILE. * RFM03 CPA B47 CONSTANT STRING ? (SINGLE QUOTE) RSS (YES) JMP RFM04 NO. * JSB ICH.F YES. READ THE QUOTE, JSB ISC.F AND GET THE STRING. JMP RFM08 AND GO WRITE. * RFM04 LDA K17 (ERROR #) SEZ LETTER ? (NOT DIGIT HERE) JSB ER.F NO. ERROR 17. * JSB IDN.F YES. GET NAME. RFM06 JSB AI.F VARIABLE/ARRAY NAME. JSB CRP.F LDA F.IU IF NOT ARRAY, CPA ARR RSS JSB TV.F THEN MUST BE VARIABLE, * RFM08 LDA KK65B WRITE TO PASS FILE, USING JSB WS1.F ALTERNATE FORM OF OPCODE 65: LDA K.FMT FIRST IS AS ALWAYS, IOR B100K WHOLE ITEM BIT. JSB WS1.F LDA F.A SECOND IS F.A JSB WS1.F JMP RFM.F,I DONE. SPC 2 * SET UP A FAKE STRING DESCRIPTOR. * FSD.F NOP LDB F.IM IF STATEMENT NUMBER, LDA MAX (SIZE IS MAX IF SO) SZB,RSS JMP FSD01 THEN SKIP CHECKS. * JSB ITS.F ELSE MUST BE INTEGER. JSB NET.F MUST NOT BE EMA. LDA F.IU IF ARRAY, LDB F.VDM AND VARIABLE DIMENSIONS, CPA ARR SZB,RSS THEN COMPUTE SIZE LATER, JSB NWI.F ELSE COMPUTE SIZE NOW. LDA F.D0+1 (A) = SIZE. FSD01 STA T7IOK SAVE ITS SIZE. LDA F.A AND ITS F.A . STA T6IOK LDA CHAR AND SET UP CHAR TEMP. CLB (F.CSL=0, DESCRIPTOR ONLY) STB F.CSL JSB APT.F DLD F.A,I (B)=EXTENSION ADDR. LDA T6IOK 1ST WD WOULD NORMALLY BE IOR B100K THE DESCRIPTOR ADDR, BUT STA B,I HERE IT'S F.A,I OF ITEM. INB LDA T7IOK 2ND WD = BYTE LENGTH. CLE,ELA STA B,I JMP FSD.F,I EXIT. F.A = THE DESCRIPTOR. * MAX DEC 32767 SKP * END OF I/O STATEMENT. * IOK49 JSB ICH.F READ CHAR AFTER ')'. IOK50 LDA K66 SEND END OPERATOR. JSB WS1.F LDA T0IOK IS IT READ OR WRITE ? SZA CPA K1 RSS IF SO, PROCESS LIST. JMP F.CRT ELSE TEST FOR C/R. * * FOR READ/WRITE/DECODE/ENCODE, GET LIST. * JSB UC.F UNINPUT COLUMN JSB IOL.F I/O LIST PROCESSOR. IOK52 LDA K47 TERMINATE I/O STATEMENT. JSB WS1.F JMP F.CRT WRAP IT UP. (C/R TEST) * IOK98 LDA K18 ERR 18, ILLEGAL COMBINATION OF KEYWORDS. JSB ER.F IOK99 LDA K15 ERR 15, UNRECOGNIZED OR ILLEGAL KEYWORD. JSB ER.F SKP T0IOK NOP STATEMENT TYPE; 0-5. T1IOK NOP 2**(T0IOK) T2IOK NOP UNIT, FMT AS POSITIONAL FLAG. T3IOK NOP ORDINAL OR CURRENT KEYWORD. T4IOK NOP FMT=* FLAG. T5IOK NOP SEC/TER FLAG. T6IOK NOP GENERAL TEMP. T7IOK NOP GENERAL TEMP. KK64 BYT 1,100 OPCODE 64, ONE ARG. KK65 BYT 1,101 OPCODE 65, ONE ARG. KK65B BYT 2,101 OPCODE 65, TWO VALUES. K66 DEC 66 K15 DEC 15 K18 DEC 18 K47 DEC 47 B47 OCT 47 SINGLE QUOTE. B72 OCT 72 COLON. B300 OCT 300 CHAR OCT 130000 F.IM=CHAR. SPC 2 * BIT TABLE. EACH WORD CONTAINS 2**(WORD ORDINAL). MAX = 5. * DBTBL DEF *+1 INDEXED THRU HERE. K1 OCT 1 0 K2 OCT 2 1 K4 OCT 4 2 K8 OCT 10 3 OCT 20 4 OCT 40 5 B100 OCT 100 (6,7: DECODE, ENCODE USE 0,1 & 100,200) SPC 2 * SOME KEYWORD ORDINALS. * K.END EQU K1 K.ERR EQU K2 K.FMT DEC 3 K.REC EQU K4 K.FIL DEC 6 K.RCL DEC 10 K.UNT DEC 11 K.IOS DEC 19 K.SEC DEC 31 K.TER DEC 32 K.SDS DEC 33 SKP * I/O STATEMENT KEYWORD LIST. * IOKWL ASC 21,END= ERR= FMT= REC= USE= FILE= FORM= NAME=, ASC 21, NODE= RECL= UNIT= ZBUF= ZLEN= BLANK= EXIS, ASC 21,T= NAMED= ACCESS= DIRECT= IOSTAT= NUMBER= , ASC 21,OPENED= STATUS= BUFSIZ= MAXREC= NEXTREC= F, ASC 18,ORMATTED= SEQUENTIAL= UNFORMATTED= , * * KEYWORD INFO TABLE. ONE-WORD ENTRIES; BITS 7:0 ARE THE LOGICAL * SUM OF THE BITS FOR EACH STATEMENT TYPE THIS KEYWORD ALLOWED FOR: * READ=1 WRITE=2 OPEN=4 CLOSE=10 INQUIRE=20 * BACKSPACE/ENDFILE/REWIND=40 DECODE=100 ENCODE=200 * BIT 8: CHARACTER ITEM. (ELSE INTEGER) * BIT 15: SET IFF ALREADY SEEN. * KWIT DEF * T.END BYT 0,001 01 END READ BYT 0,377 02 ERR ALL BYT 1,003 03 FMT READ/WRITE T.REC BYT 0,003 04 REC READ/WRITE BYT 1,024 05 USE OPEN/INQUIRE T.FIL BYT 1,024 06 FILE OPEN/INQUIRE BYT 1,024 07 FORM OPEN/INQUIRE BYT 1,020 08 NAME INQUIRE BYT 0,024 09 NODE OPEN/INQUIRE BYT 0,024 10 RECL OPEN/INQUIRE T.UNT BYT 0,077 11 UNIT ALL (SPECIAL DECODE/ENCODE) T.ZBF BYT 0,003 12 ZBUF READ/WRITE T.ZLN BYT 0,003 13 ZLEN READ/WRITE BYT 1,024 14 BLANK OPEN/INQUIRE BYT 0,020 15 EXIST INQUIRE BYT 0,020 16 NAMED INQUIRE BYT 1,024 17 ACCESS OPEN/INQUIRE BYT 1,020 18 DIRECT INQUIRE BYT 0,377 19 IOSTAT ALL BYT 0,020 20 NUMBER INQUIRE BYT 0,020 21 OPENED INQUIRE BYT 1,014 22 STATUS OPEN/CLOSE BYT 0,004 23 BUFSIZ OPEN BYT 0,024 24 MAXREC OPEN/INQUIRE BYT 0,020 25 NEXTREC INQUIRE BYT 1,020 26 FORMATTED INQUIRE BYT 1,020 27 SEQUENTIAL INQUIRE BYT 1,020 28 UNFORMATTED INQUIRE NKWRD ABS *-KWIT-1 # OF KEYWORDS. SKP * *************************** * * ENCODE-DECODE PROCESSOR * * *************************** SPC 1 * SET UP TYPE, KEYWORD MASK; REQUIRE '(', INITIALIZE. * F.DCP CLB,RSS DECODE. TYPE=0. F.ECP CLB,INB ENCODE. TYPE=1. STB T0IOK LDA K2 ALSO, SET UP IOK FOR NO POSITIONAL. STA T2IOK LDA B100 KEYWORD CHECK MASK: SZB DECODE=100B, RAL ENCODE=200B. STA T1IOK JSB ICH.F READ THE '(' LDA B50 REQUIRE IT. JSB TCT.F LDA KK64 OPCODE 64, JSB WS1.F LDA T0IOK WITH STATEMENT TYPE. JSB WS1.F * * GET THE POSITIONAL PARAMETERS: RECL, FMT, SDES. * JSB EE.F GET THE CHARACTER COUNT: BYT 1,3 (IT LOOKS LIKE A UNIT NUMBER) LDA KK65 OPCODE 65, JSB WS1.F LDA K.RCL WITH 'RECL' KEYWORD #. JSB WS1.F LDA B54 REQUIRE COMMA. JSB TCT.F CLA SET F.IM=0 FOR RFM.F STA F.IM JSB RFM.F GET THE FORMAT; SEND THRU PASS FILE. LDA B54 REQUIRE COMMA. JSB TCT.F JSB IVN.F INPUT BUFFER NAME. JSB NET.F DON'T ALLOW EMA. JSB FSD.F FAKE A STRING DESCRIPTOR. LDA F.A FORCE BUFFER F.A THRU ON STACK. IOR B100K JSB WS1.F LDA KK65 OPCODE 65, JSB WS1.F LDA K.SDS WITH 'SDES' KEYWORD ORDINAL. JSB WS1.F * * JOIN KEYWORD PROCESSOR TO FINISH IT. * LDA F.TC KEYWORDS TO FOLLOW ? CPA B54 JMP IOK02 YES. GO PROCESS THEM. * JSB RP.F NO. REQUIRE & SKIP ')'. JMP IOK50 WRAP IT UP & GET LIST. SKP * ******************************** * * I/O STATEMENT LIST PROCESSOR * * ******************************** SPC 1 * INITIALIZE. * IOL.F NOP READ() OR WRITE() JSB EXN.F FIRST, SEE IF LIST EMPTY. CPA B15 WELL ? JMP IOL.F,I YES. NOTHING TO DO. * CLA NO. CLEAR SOME STATE. STA F.L NUMBER SYNTAX ENTRIES STACKED LDA F.S2B MAKE SURE STACK CUT BACK. STA F.S2T * * NEW LIST ITEM. COUNT NUMBER OF LEADING LEFT PARENS. * IOL01 CLA STA T1IOL T1IOL = # OF '(' BEFORE START OF ITEM. STA T2IOL T2IOL = # OF ')' WITHIN ITEM. IOL03 JSB ICH.F PAREN ? CPA B50 RSS (YES) JMP IOL05 NO. GO GET ITEM. * JSB NR.F START NEW GROUP, ISZ T1IOL AND COUNT THE PAREN. JMP IOL03 TRY FOR MORE. * * IF INPUT, JUST GET THE ITEM. * IOL05 JSB UC.F (UNREAD THE CHAR AFTER THE PAREN) LDA T0IOK INPUT OR OUTPUT ? SZA JMP IOL11 OUTPUT. TRY FOR CONST OR EXPR. * JSB II.F INPUT. GET NAME. SZA,RSS DID WE GET NAME ? (OR CONST) JMP IOL53 NO. ERROR. * JSB NCT.F YES. DON'T ALLOW CONSTANTS, JSB NST.F OR FUNCTION CALLS. LDA F.TC CHECK FOR IMPLIED DO CONTROL: CPA B75 IS F.TC AN '=' ? JMP IOL24 YES. * CPA B50 '(' RSS CPA B51 OR ')' RSS CPA B54 OR ',' RSS CPA B15 OR 'C/R' RSS JMP IOL53 NOPE. ILLEGAL IN INPUT LIST. SKP * IF ARRAY NAME BY ITSELF, DO WHOLE ARRAY. * IOL07 LDB F.IU ARRAY ? CPB ARR RSS (YES) JMP IOL55 NO. THEN NOT WHOLE ARRAY. * LDA F.TC YES. SIMPLE LIST ITEM, I.E. CPA B54 FOLLOWED BY COMMA, RSS CPA B51 RIGHT PAREN, RSS CPA B15 OR C/R ? RSS (YES) JMP IOL55 NO. THEN NOT WHOLE ARRAY. * LDA F.A YES. WHOLE ARRAY. IOR B100K SEND ITEM THRU FOR STACK. JSB WS1.F LDA K62 THEN THE WHOLE ARRAY OPERATOR. JSB WS1.F JMP IOL91 AND DONE. * * GET POSSIBLE SUBSCRIPTS ON INPUT ITEM. * IOL55 JSB EE.F GET INPUT LIST ELEMENT. BYT 1,10 TEMPS ? TYPE = 8. LDA K63 AND TELL PASS 2 TO PROCESS IT. JSB WS1.F * * DELIMETER AFTER LIST ITEM OR SUBLIST. * IOL91 LDB F.TC WHAT IS IT ? CPB B51 ')' ? JMP IOL22 YES, NEW RECORD AND MATCH PARENS. * CPB B54 ',' ? JMP IOL01 YES,SCAN NEXT ITEM OR SUBLIST. * CPB B15 C/R ? JMP IOL27 YES, FIX UP LOAD ADDRESS POINTERS. * IOL53 LDA K17 ELSE CONSTRUCTION ERROR: JSB ER.F ILLEGAL DELIMITER. SPC 2 TWPE OCT 40000 F.IM=4 DUMMY TWO WORD ENTRY CPX OCT 50000 F.IM=5 COMPLEX. ZPX OCT 140000 F.IM=12 DOUBLE COMPLEX. RE8 OCT 120000 F.IM=10 DOUBLE PRECISION. ARR OCT 600 F.IU=ARR K22 DEC 22 B52 OCT 52 * K17 DEC 17 K62 DEC 62 K63 DEC 63 SKP * ANALYZE OUTPUT LIST ITEM. * IOL11 JSB II.F TRY FOR AN OPERAND. SZA,RSS DID WE GET ONE ? JMP IOL15 NO. TRY FOR EXPRESSION. * LDB F.TC YES. SEE WHAT'S AFTER IT. CPB B75 IF '=', JMP IOL24 THEN DO LOOP CONTROL. * CPB B15 IF C/R, JMP IOL07 SIMPLE ITEM. (CHECK FOR ARRAY) * CPB B54 IF COMMA, RSS (YES) JMP IOL15 NO. GO TRY FOR EXPRESSION. * * COMMA AFTER ITEM. PROBABLY SIMPLE ITEM, BUT * COULD BE START OF COMPLEX CONSTANT. CHECK IT. * LDB F.NT YES. CHECK FOR COMPLEX CONST: CPA REA MUST BE TYPE REAL, RSS CPA RE8 OR REAL*8, SZB,RSS AND CONSTANT. JMP IOL07 NO. SIMPLE LIST ITEM. (CHECK ARRAY) * STA T4IOL YES. SAVE TYPE FOR CHECK LATER. JSB EXN.F SEE IF FOLLOWED BY '('. LDB B54 (RESTORE COMMA) STB F.TC LDB T1IOL AND ALSO MUST HAVE A LEFT PAREN. SZB IF NO LEFT PAREN AT START, CPA B50 OR LEFT PAREN AFTER COMMA, JMP IOL07 THEN STILL SIMPLE LIST ITEM. * LDA F.A NO. SAVE F.A OF FIRST CONSTANT. STA T3IOL JSB II.F GET NEXT THING IN LIST. LDB F.NT IF CONSTANT, CPA T4IOL AND SAME TYPE AS FIRST CONSTANT, SZB,RSS JMP IOL13 NO. NOT COMPLEX CONSTANT. * LDB F.TC YES. ENDS WITH ')' ? CPB B51 JMP IOL14 YES. SKP * NOT COMPLEX CONSTANT. OUTPUT THE REAL CONSTANT * WHICH WAS SAVED, THEN PROCESS THE ITEM AFTER COMMA. * IOL13 LDA T3IOL NOT CPX CONST: MUST OUTPUT 1ST CONSTANT. IOR B100K JSB WS1.F LDA K63 JSB WS1.F CLA THEN ZAP PAREN COUNT. STA T1IOL JMP IOL15 AND PROCESS SECOND ITEM/EXPRESSION. * * COMPLEX CONSTANT. FORM IT, AND ASSUME START OF EXPR. * IOL14 LDA F.DID FORM CONSTANT: LDB F.DID FIRST, MOVE SECOND PART UP. ADB F.D0+1 BY 2 OR 4 WORDS. JSB .MVW DEF F.D0+1 NOP LDA T3IOL NOW COMPUTE ADDRESS OF FIRST PART, ADA K2 LDB F.DID AND MOVE IT TO THE START. JSB .MVW DEF F.D0+1 NOP LDB F.IM SET UP PROPER TYPE: LDA CPX IF REAL*4, IS COMPLEX*8. CPB RE8 LDA ZPX IF REAL*8, IS COMPLEX*16. JSB ESC.F JSB AI.F JSB ICH.F GET DELIMITER AFTER IT. ISZ T2IOL COUNT ONE PAREN USED. * * START OF EXPRESSION. CALL EE.F . * IOL15 LDA T2IOL PASS THE COUNT OF LEADING LEFT PARENS. CMA,INA ADA T1IOL JSB EE.F TO EXPRESSION ANALYZER. BYT 201,11 OUTPUT, TEMPS?, USE F.SIM & PARENS. * * ACCOUNT FOR RIGHT PARENS IN EXPRESSION WHICH * MATCHED LEFT PARENS ALREADY STACKED UP. * CMA,INA - (# LEFT PARENS STILL UNUSED) ADA T1IOL + TOTAL = # USED. CMA,INA,SZA,RSS ANY ? JMP IOL19 NO. GO OUTPUT LIST OPCODE. * STA T2IOL YES. ACCOUNT FOR THEM. IOL17 JSB MPL.F ONCE FOR EACH RIGHT PAREN USED. ISZ T2IOL JMP IOL17 * IOL19 LDA K63 OUTPUT OPCODE FOR LIST ITEM. JSB WS1.F JMP IOL91 DONE. SKP * PROCESS ')': START NEW RECORD & MAKE SURE MATCHED. * IOL22 JSB MPL.F START NEW RECORD FOR ')' AND MATCH IT JSB ICH.F READ DELIMETER. JMP IOL91 PROCESS DELIMETER AFTER SUBLIST. * * PROCESS IMPLIED DO CONTROL INFO. * IOL24 LDA T1IOL IF CONTROL VARIABLE FOLLOWS SZA ONE OR MORE LEFT PARENS, JMP IOL53 THEN EMPTY LIST - ERROR. * JSB ITS.F CONTR. VAR. MUST BE INTEGER JSB NCT.F CONTR. VAR. MUST NOT BE CONSTANT JSB TV.F MUST BE VARIABLE * * START NEW RECORD, PROCESS 'DO' STUFF. * LDA F.A (SAVE F.A OVER NR.F) STA CONTR IOR B100K (A) = F.A,I JSB NR.F START NEW RECORD FOR INITIAL. CODE LDA CONTR (RESTORE) STA F.A CCB REQUIRE THAT IT ENDS ON ')'. JSB DCM.F COMMON DO PROCESSOR. * * FIND MATCHING '(', ISSUE OPCODE TO PASS 2. * JSB MPL.F START NEW RECORD, FIND MATCHING '(' LDA A,I GET THE F.A OF THE JUMP TARGET RAL,ERA SET INDIRECT (THRU TWPE ENTRY). STA T1DOP SAVE IT. LDA KK48 ISSUE OP. JSB WS1.F LDA CONTR WITH F.A OF INDEX (CONTROL). JSB WS1.F LDA T1DOP AND F.A OF JUMP TARGET. JSB WS1.F JSB ICH.F READ THE DELIMITER. JMP IOL91 PROCESS DELIMITER AFTER SUBLIST. * * ROUTINE TO START ')' RECORD & FIND MATCHING ')'. * MPL.F NOP A ')' FOUND START NEW RECORD AND LDA B51 (A) = ')'. JSB NR.F THEN CCA FIND THE MATCHING '(' LDB KM2 LOOK DOWN THE STACK ADA F.S2T JSB MP.F MATCH IT JMP MPL.F,I RETURN SKP * END. SCAN SKELETON OF LIST TO DETERMINE ORDER THAT THE ENTRIES * SHOULD ACTUALLY APPEAR. OUTPUT OPCODES TO PASS 2 TO DEFINE THE * LOAD ADDRESSES (TWPE'S) SO THAT THE ORDER WILL BE CORRECT. * * THE SKELETON WILL LOOK LIKE: * * (A (B &C )D (E &F )G &H )I * * WHERE THE INTERPRETATION IS: ( LIST PROPER. * & 'DO' INITIALIZE. * ) 'DO' LOOPING. * * AND THE DESIRED LOAD ORDER IS: H,A,C,B,D,F,E,G,I. * * THIS IS ACCOMPLISHED BY OUTPUTTING THE LOAD REQUESTS IN ORDER * EXCEPT THAT LOOP INITIALIZATION IS OUTPUT JUST BEFORE THE LOOP IT * CONTROLS, BY FINDING THE MATCHING RIGHT PAREN AND BACKING UP ONE. * * START & INCREMENT SCAN OF STACK 2. * IOL27 CCA ADA F.S2B INITIALIZE STACK POINTER STA T0IOL * IOL28 LDA T0IOL POINT TO ADA K2 NEXT SYNTAX ELEMENT STACKED. STA T0IOL LDB F.S2T CMB,INB ADB A (B) _ STACK POINTER - STACK TOP SSB,RSS PAST TOP? JMP IOL33 YES, DONE PROCESSING LIST * * ): OUTPUT. &: IGNORE. (: FIND MATCHING ')'. * LDB A,I B = TYPE INDICATION. CPB B50 '(' ? JMP IOL29 YES, FIND MATCHING ')'. CPB B51 NO. ')' ? JMP IOL31 YES, OUTPUT. JMP IOL28 NO, MUST BE & (INDEX VAR), SKIP IT. SKP * '('. FIND MATCHING ')', OUTPUT THE LOOP INDEX INIT. * IOL29 LDB K2 SEARCH UP THE STACK FOR MATCHING JSB MP.F RIGHT PARENTHESIS. ADA KM3 POINTS TO SYNTAX ELEM. BEFORE ). STA T1IOL LDB A,I IS PREVIOUS SYNTAX ELEMENT AN SSB,RSS IMPLIED DO CONTROL VARIABLE? JMP IOL31 NO, JUST PARENS, DO '(' NOW. JSB ILA.F YES. OUTPUT THE INIT NOW. * * LOOK FOR A DUPLICATE INDEX VAR. * LDA T1IOL,I (A) = F.A,I TO DO CONTROL VAR. LDB T1IOL (B) = STK2 WORD WHICH CONTAINS(A) IOL30 ADB KM2 NEXT SYNTAX BELOW(B) IN STK2 CPB T0IOL IS NEXT SYNTAX THE ( OF DO BODY? JMP IOL31 YES, INSERT LOAD ADDRESS FOR BODY CPA B,I NO, IS IT IDENTICAL TO CONT. VAR? JMP ERR51 YES, ERROR-REPEATED CONT. VAR. JMP IOL30 NO, LOOK AT NEXT SYNTAX IN STK2. * * OUTPUT CURRENT ITEM, WHATEVER. * IOL31 LDA T0IOL ADDRESS-1 OF WORD IN STACK2 CONTAINING JSB ILA.F PTR TO LOAD ADDR. INSERT IT. JMP IOL28 CONTINUE FIXING UP LOAD ADDRS. * * CLEAR STACK & EXIT. * IOL33 CLA SET NUMBER OF ELEMENTS STACKED STA F.L ON STACK 2 TO 0. LDB F.S2B STB F.S2T JMP IOL.F,I DONE PROCESSING I/O LIST. * T0IOL NOP 0=READ, 1=WRITE. T1IOL NOP # LEFT PARENS BEFORE EXPRESSION. T2IOL NOP # RIGHT PARENS WITHIN EXPRESSION. T3IOL NOP F.A OF FIRST PART SUSPECTED CPX CONST. T4IOL NOP F.IM OF FIRST PART. CONTR NOP PTR TO IMPLIED DO CONTR. VAR. KK48 BYT 1,60 'DO' OPERATOR. KM3 DEC -3 REA OCT 20000 F.IM = REA SKP * ************** * * NEW RECORD * * ************** SPC 1 * ENTRY: (A) = '(', ')', OR F.A,I * NR.F NOP COMPLETE INFO FOR PREVIOUS JSB PU2.F STACK SYNTAX OF I/O LIST ON STK2 LDA TWPE LOAD F.IM=4 FOR TWO WORD PSEUDO ENT JSB ESC.F ESTABLISH DUMMY A.T.ENTRY JSB AI.F AND ASSIGN IT TO TABLE LDA F.A STACK ON TOP OF I/O LIST JSB PU2.F SYNTAX,THE A.T. POINTER TO THIS LDA KK49 SEND 'NR.F' OPERATOR. JSB WS1.F LDA F.A JSB WS1.F JMP NR.F,I SPC 2 * *********************** * * INSERT LOAD ADDRESS * * *********************** SPC 1 ILA.F NOP INA GET 2ND WORD OF STACK FRAME LDA A,I I.E., THE TWPE ENTRY. STA T1ILA SAVE IT. LDA KK50 OUTPUT 'ILA.F' OPERATOR. JSB WS1.F LDA T1ILA AND F.A OF TWPE TO DEFINE. JSB WS1.F JMP ILA.F,I SPC 2 T1ILA NOP KK49 BYT 1,61 'NR.F' OPERATOR. KK50 BYT 1,62 'ILA.F' OPERATOR. SKP * ********************* * * MATCH PARENTHESES * * ********************* SPC 1 MP.F NOP MATCH PAREN IN STACK 2 STA T0MP LOCATION OF PAREN TO BE MATCHED STB T1MP SEARCH UP STK IS +2, DOWN IS -2 CLB INITIALIZE PAREN COUNTER MP01 LDA T0MP,I WORD 1 OF 2 WORD STACK 2 ENTRY CPA B50 IS SYNTAX '('? INB YES, BUMP COUNT CPA B51 NO, IS SYNTAX ')'? ADB KM1 YES, DECREMENT COUNT LDA T0MP SZB,RSS IS COUNT = 0? JMP MP03 YES, FINISH UP ADA T1MP UPDATE POINTER IN STACK TO STA T0MP POINT TO NEXT SYNTAX ELEMENT CMA,INA ADA F.S2B (A) _ F.S2B - POINTER SSA,RSS PAST BOTTOM OF STACK? JMP MP02 YES. MISMATCH ERROR. LDA T0MP CMA,INA ADA F.S2T (A) _ F.S2T - POINTER SSA,RSS PAST TOP OF STACK? JMP MP01 NO, CONTINUE SEARCH MP02 LDA K9 YES, MISMATCH ERROR JSB ER.F NO RETURN SPC 1 MP03 CCE,INA RETURN POINTER TO STK WORD +1 JMP MP.F,I FOR LOAD ADDRESS STARTING RECORD * T0MP BSS 1 T1MP BSS 1 K9 DEC 9 SKP * ****************** * * CALL PROCESSOR * * ****************** SPC 1 F.CAL JSB ISY.F INPUT NAME. LDB F.A CHECK FOR RECURSION: LDA K75 (ERROR #) CPB F.SBF SAME AS THIS PROG UNIT ? JSB ER.F YES. ERROR. LDA F.IU NO. GET USAGE. CPA SUB RSS JSB TS.F TAG SUBPROGRAM JSB DS.F SET F.S=1 TO INDICATE USED AS SUBR. JSB EE.F EVALUATE SUBROUTINE CALL BYT 0,1 JMP F.CRT * SUB OCT 200 F.IU=1 SUBPROGRAM SPC 2 * ********************************** * * ASSIGNMENT STATEMENT PROCESSOR * * ********************************** SPC 1 F.ASS JSB II.F INPUT ITEM JSB NCT.F NON-CONSTANT TEST JSB NST.F NON-SUBPROGRAM TEST JSB EE.F EVALUATE ASSIGNMENT STMT. BYT 0,6 JMP F.CRT * STRAB OCT 2000 STR-ABS F.AT = UNDEFINED SKP * ******************************** * * STATEMENT FUNCTION PROCESSOR * * ******************************** SPC 1 F.SFP JSB ISY.F INPUT SYMBOL LDA K22 IF THIS IS THE SAME NAME AS THE CURRENT LDB F.SBF SUBROUTINE MODULE CPB F.A THEN JSB ER.F TOO BAD ! * LDA K22 IF ALREADY USED LDB F.AT AS CPB STRAB ANY THING OTHER THAN TYPE RSS NO GOOD SKIP THE ERROR JSB ER.F TOO BAD ALSO! JSB TS.F ELSE TAG AS SUBROUTINE. (F.AF=0) LDA REL AND SET F.AT=DUM. JSB DAT.F LDA F.A SAVE F.A OF FUNCTION. IOR B100K WITH SIGN SET FOR AI.F STA F.SFA LDA TWPE ALLOCATE TWO-WORD BLOCK. JSB ESC.F JSB AI.F CLA INITIALIZE IT TO ZERO. CLB DST F.A,I LDA F.A GET EXTENSION ADDR, LDB F.SFA RESTORE F.A TO STMT FCT, RBL,CLE,ERB (CLEAR SIGN) STB F.A JSB DAF.F AND SET F.AF TO POINT TO EXT. * JSB IDL.F INPUT THE DUMMY LIST. LDA B75 REQUIRE '='. JSB TCT.F LDA KK31 PROG ENTRY OPCODE = 31, JSB WS1.F ONE ARG. LDA F.SFA WHICH IS F.A OF FCT. RAL,CLE,ERA WITHOUT SIGN BIT, STA F.SFA LIKEWISE REMOVE SIGN FROM HERE. JSB WS1.F JSB EE.F INPUT THE EXPRESSION. BYT 0,0 TYPE = 'STATEMENT FUNCTION' JMP F.CRT ALL DONE ! * K75 DEC 75 KK31 BYT 1,37 PROG ENTRY OPERATOR. REL OCT 1000 AT=1, REL DUM OCT 5000 AT=5, DUM SKP * ************************ * * PAUSE-STOP PROCESSOR * * ************************ SPC 1 * SET UP OPCODE. * F.STP LDB KK23 STOP OPCODE = 23. RSS F.PAP LDB KK24 PAUSE OPCODE = 24. STB T2PAS T2PAS = OPCODE. * * GET OCTAL NUMBER. * LDA KM6 SET LIMIT OF 5 DIGITS. STA T3PAS JSB CDI.F SET TO ZERO. PAST1 JSB ICH.F INPUT CHAR. CPA B15 C/R ? JMP PAST4 YES, DONE. * ISZ T3PAS TOO MANY ? RSS JMP PAST2 YES. ERROR. * SZB DIGIT ? JMP PAST2 NO, ERROR. * ADA BM70 8 OR 9 ? SSA,RSS JMP PAST2 YES, ERROR. * ADA K8 (A) = VALUE. LDB F.IDI UPDATE RUNNING VALUE. BLF,RBR IOR B STA F.IDI F.IDI=F.IDI+F.TC (BINARIZED) JMP PAST1 NO, TRY FOR MORE. * * ERRORS. * PAST2 LDA K16 TOO MANY OR ILLEGAL DIGITS. JSB WAR.F ONLY A WARNING. PAST5 JSB ICH.F SKIP TO C/R. CPA B15 RSS JMP PAST5 * CLA,RSS PAST4 LDA F.IDI (A) = VALUE. JSB EIC.F SET UP AS CONSTANT. STA T3PAS SAVE FOR A MOMENT. LDA T2PAS ISSUE OPCODE. JSB WS1.F LDA T3PAS THEN F.A OF CONSTANT. JSB WS1.F LDA T2PAS WHICH WAS IT ? CPA KK23 JMP RTNP1 STOP. 'NO PATH'. JMP CILDT PAUSE. JUST CHECK DO TERMINATION. SKP T2PAS NOP T3PAS NOP # OF OCTAL DIGITS KK23 BYT 1,27 'STOP' OPCODE. KK24 BYT 1,30 'PAUSE' OPCODE. K16 DEC 16 BM70 OCT -70 KM6 DEC -6 K7 DEC 7 K20 DEC 20 K21 DEC 21 SKP * ********************** * * CONTINUE PROCESSOR * * ********************** SPC 1 F.CON LDA F.LSP LAST OPERATION FLAG ADA F.LSN LAST STATEMENT NUMBER FLAG STA F.LSP F.LSP=F.LSP+F.LSN CLA STA F.LSF JSB ICH.F INPUT THE NEXT CHARACTER. LDB F.LFF LDA K89 89 SZB TRUE BRANCH OF LOGICAL "IF"? JSB WAR.F YES, COMMENT ON EFFECTIVE "NOP". JMP F.CRT C/R TEST SPC 2 * ******************** * * ASSIGN PROCESSOR * * ******************** SPC 1 F.ASP CLA INPUT ANY KIND OF STMT #. JSB ISD.F LDA F.A SAVE ITS F.A . STA T0ASP LDA "T" 'T' JSB TCT.F F.TC-TEST JSB ICH.F INPUT CHARACTER LDA "O" 'O' JSB TCT.F F.TC-TEST JSB IIV.F INPUT INTEGER VARIABLE LDA K37 LDB F.AT CPB DUM JSB WAR.F ILLEGAL USAGE OF DUMMY VARIABLE LDA KK36 'ASSIGN' OPCODE. JSB WS1.F LDA T0ASP THE STMT # F.A JSB WS1.F LDA F.A THE VARIABLE F.A JSB WS1.F JMP F.CRT C/R TEST * K89 DEC 89 KK36 BYT 2,44 'ASSIGN' OPERATOR. K37 DEC 37 "T" OCT 124 K79 DEC 79 "O" EQU K79 T0ASP NOP SAVE ASSI PTR OF STMT FUNC NAME SKP * ******************** * * RETURN PROCESSOR * * ******************** SPC 1 F.RTN JSB ICH.F INPUT A CHAR. LDB F.SBF SUBPROGRAM FLAG SET ? SZB JMP RTN01 YES. O.K. * LDA K7 NO. WARNING: RETURN IN MAIN. JSB WAR.F LDA K20 A = END OPCODE. JMP RTN04 * RTN01 LDA F.SFF SUBROUTINE OR FUNCTION ? SZA JMP RTN03 FUNCTION. NO ALTERNATE RETURNS. * LDA F.TC SUB. IS THERE AN ALT RTN VALUE ? CPA B15 JMP RTN02 NO. GO USE ZERO. * JSB UC.F BACK UP FOR EE.F'S BENEFIT. JSB EE.F YES. SAME AS A UNIT NUMBER. BYT 0,3 JMP RTN03 GO SEND OPCODE. * RTN02 CLA SET UP A CONSTANT ZERO. JSB EIC.F IOR B100K JSB WS1.F SO IT WILL BE ON STACK. RTN03 LDA K21 RETURN OPERATOR. RTN04 JSB WS1.F WRITE OP. JMP RTNP1 DONE. SKP * ***************** * * END STATEMENT * * ***************** SPC 1 F.ENP CLA SET LINE NUMBER TO ZERO STA F.LNN TO SUPPRESS IN ERROR MESSAGES. LDA K30 IF DO STACK IS NOT EMPTY, LDB F.D THEN THERE IS AN UNCOMPLETED CPB F.DO DO LOOP OR IF-THEN-ELSE. RSS (EMPTY, O.K.) JSB WAR.F COMPLAIN. * LDA K50 LIKEWISE IF TRUE BRANCH OF LOGICAL IF. LDB F.LFF SZB JSB WAR.F * CLA SET F.CC=0 TO SUPPRESS ERRORS. STA F.CC JSB EIC.F CREATE ZERO. IOR B100K WRITE TO PASS FILE AS OPERAND, JSB WS1.F JUST IN CASE 'RETURN'. LDA K20 'END' OPCODE. LDB F.SBF SUBPROGRAM FLAG SET ? SZB INA YES, CHANGE TO 'RETURN' LDB F.LSP PATH HERE ? ADB F.LSN SZB JSB WS1.F YES, WRITE THE OPCODE. LDB K2 SET SEGMENT 2. JMP F.SEG GO LOAD THE SEGMENT * END ASMB,Q,C HED FTN4X, SEGMENT F4X.2 - INTRINSIC FUNCTIONS PHASE. NAM F4X.2,5 92834-16002 REV.2030 800613 * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1980. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * REPRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * *************************************************************** * NAME: PART OF FTN4X * * SOURCE: PART OF 92834-18002 * * RELOC: PART OF 92834-16002 * * PGMR: B.G. * *************************************** * ************************************ * FORTRAN-4 COMPILER SEGMENT 2 * ************************************ * * THIS SEGMENT IS THE INTRINSIC/GENERIC FUNCTION PHASE. * (ALSO DOES 'IMPLICIT NONE' CHECKING.) * IT IS EXECUTED BETWEEN PASS 1 AND PASS 2. * * GENERAL EXTERNALS. * EXT F.A ASSIGNMENT TABLE ADDR (CURRENT ENTRY). EXT F.ABT ABORT COMPILE. EXT F.CCW OPTIONS WORD. EXT F..E EXPLICIT TYPING BIT. EXT F.EQE LOCAL ERROR RECOVERY ADDRESS. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IM CURRENT ITEM MODE. EXT F.IMF IMPLICIT FLAG. EXT F.PCT F.A OF TEMP FOR PCOUNT(). EXT F.S SUBROUTINE FLAG. EXT F.SBF F.A OF CURRENT MODULE. EXT F.SEG SEGMENT LOADER. EXT F.SFF SUBROUTINE/FUNCTION/BLOCKDATA FLAG. * EXT APT.F ALLOCATE PERMANENT TEMP. EXT AST.F ALLOCATE SPACE IN SYMBOL TABLE. EXT DAF.F DEFINE (F.AF) EXT DIM.F DEFINE (F.IM) EXT ES1.F WRITE E-O-F ON PASS FILE 1. EXT FA.F FETCH ASSIGNS. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE ENTRY. EXT NAM.F COPY SYMBOL NAME. EXT PCC.F PRINT COMPILER COMMENT. EXT WAR.F ISSUE WARNING MESSAGE. EXT WS1.F WRITE WORD ON PASS FILE 1. * * LIBRARY. * EXT .MVW MOVE WORDS. * EXT C.SC0 CARD FILE / 2ND PASS FILE. EXT C.SC1 1ST PASS FILE. * EXT EOF.C CLIB WRITE EOF. EXT RWN.C CLIB REWIND. SPC 2 A EQU 0 B EQU 1 SUP * DEC 2 SEGMENT NUMBER. SKP * ENTRIES IN THE INTRINSICS TABLE USED IN THIS SEGMENT * HAVE THE FOLLOWING FORMAT: * * * !-------------------------------!-------------------------------! * ! CHAR 1 ! CHAR 2 ! * !-------------------------------!-------------------------------! * ! CHAR 3 ! CHAR 4 ! * !-------------------------------!-------------------------------! * ! CHAR 5 ! CHAR 6 ! * !---!---!-------!---------------!---------------!---------------! * ! 0 ! S !A=#PRMS! B=# EXT VER ! C=# GEN VER ! D=DEFLT TYPE ! * !---!---!---!---!-----------!---!---------------!---------------! * ! IJXY=OPT. ! E=TYPE ! DOT FCT ORDINAL IF DCL EXTERNAL ! * !-----------!---------------!-------------------!---------------! * // (repeat above 1-word entry B-1 times) // * !-------------------------------!---------------!---------------! * ! 0 ! G=ARG TYPE ! H=FCT TYPE ! * !---------------------------!---!---------------!---------------! * ! DOT FUNCTION DESCRIPTION ! DOT FUNCTION ORDINAL ! * !---------------------------!-----------------------------------! * // (repeat above 2-word entry C-1 times) ! * !---------------------------------------------------------------! * * THE TABLE IS JUST A LINEAR LIST OF THESE ENTRIES, TERMINATED * BY A ZERO WORD. * * * THIS SEGMENT SEARCHES FOR MATCHES BETWEEN THE SYMBOL TABLE AND * THE INTRINSICS TABLE. WHEN IT FINDS A MATCH, IT BUILDS A SYMBOL * TABLE ENTRY OF THE FOLLOWING FORM: * * * !---!-------!---------------!-----------------------------------! * ! S ! #PRMS ! # ENTRIES ! DOT FCT ORDINAL IF DCL EXTERNAL ! * !---!-------!---------------!---!---------------!---------------! * ! 0 ! ARG TYPE ! FCT TYPE ! * !---------------------------!---!---------------!---------------! * ! DOT FUNCTION DESCRIPTION ! DOT FUNCTION ORDINAL ! * !---------------------------!-----------------------------------! * // (repeat above pair as specified in count above) // * !---------------------------------------------------------------! * * THE F.AF FIELD OF THE ORIGINAL A.T. ENTRY GETS THE ADDRESS OF THE * NEW SYMBOL TABLE ENTRY. SKP * THE ALGORITHM FOR CREATION OF THE NEW SYMBOL TABLE ENTRY, GIVEN THE * SYMBOL A.T. ENTRY AND THE INTRINSIC TABLE ENTRY IS: * * 1) Copy number of parameters verbatim. * * 2) If symbol is not explicitly typed, make its type the default type, * as modified by the 'J' and 'Y' options. * * 3) Search the first section of the intrinsics table for a type which * matches the function type. If the IJXY field is nonzero, the * appropriate option must be on. Copy that to the new entry. * If none were found, the function didnt't have a specific name, * or it was retyped to a type for which no specific form existed. * If explicitly typed, it is not considered intrinsic, else it is * one of those generics with no specific (e.g. LOG), which is O.K. * but it can't be used as an EXTERNAL then (set dot fct value = 0). * * 4) Scan the second section of the intrinsics table. Copy each entry * unless: * a) Type was explicitly declared and function type of the * entry is different. * b) Function type is different from argument type and * function type is not default for current 'J' or 'Y' * option. * * 5) Set the number of entries found into the count field. SPC 4 * FOR 'ALIAS' FUNCTIONS & SUBROUTINES, A SYMBOL TABLE ENTRY IS SET UP * WITH THE FTN NAME, WITH THE F.AF POINTING TO ANOTHER SYMBOL TABLE * ENTRY, WHICH HAS THE TRUE NAME AND HAS THE DOT FUNCTION INTO IN * ITS F.AF WORD. ALIAS ENTRIES HAVE F.NC=2. SKP * EQUATED SYMBOLS TO AID IN BUILDING INTRINSICS TABLE. * * SYMBOLS HAVE THE FORM 'X.V' WHERE: X=FIELD INDICATOR, * V=VALUE INDICATOR. * * E.G., 'D.INT' INDICATES THE FIELD 'D' WITH VALUE 'INT'. * * A.0 EQU 00000B NONE # PARAMETERS. A.1 EQU 10000B 1 A.2 EQU 20000B 2 A.VAR EQU 30000B VARIABLE. * B.0 EQU 0000B 0 # OF 'EXTERNAL' VERSIONS. B.1 EQU 0400B 1 B.2 EQU 1000B 2 B.4 EQU 2000B 4 * C.1 EQU 020B 1 # OF 'SPECIFIC' VERSIONS. C.2 EQU 040B 2 C.3 EQU 060B 3 C.4 EQU 100B 4 C.5 EQU 120B 5 C.7 EQU 160B 7 C.12 EQU 300B 12 * D.NON EQU 0 (NONE) DEFAULT TYPE. D.INT EQU 1 INTEGER*2 D.REA EQU 2 REAL*4 D.CPX EQU 5 COMPLEX*8 D.DBL EQU 6 REAL*6 D.RE8 EQU 12B REAL*8 * I EQU 20000B (HALF-SIZE 'CAUSE CAN'T EQU TO NEG) J EQU 30000B BITS 15:14 SPECIFY WHICH OPTION TO CHECK: X EQU 40000B 0=NEITHER, 1=I/J, 2=X/Y, 3=UNUSED. Y EQU 50000B OPTION VALUE IN BIT 13: I=X=0, J=Y=1. * E.INT EQU 01000B INTEGER*2 EXTERNAL FCT TYPE. E.REA EQU 02000B REAL*4 E.CPX EQU 05000B COMPLEX*8 E.DBL EQU 06000B REAL*6 E.DBI EQU 10000B INTEGER*4 E.RE8 EQU 12000B REAL*8 E.ZPX EQU 14000B COMPLEX*16 * G.INT EQU 020B INTEGER*2 ARGUMENT TYPE. G.REA EQU 040B REAL*4 G.CPX EQU 120B COMPLEX*8 G.DBL EQU 140B REAL*6 G.DBI EQU 200B INTEGER*4 G.RE8 EQU 240B REAL*8 G.ZPX EQU 300B COMPLEX*16 G.SUB EQU 0 SUBROUTINE (NON-GENERIC) * H.INT EQU 1 INTEGER*2 FUNCTION TYPE. H.REA EQU 2 REAL*4 H.CPX EQU 5 COMPLEX*8 H.DBL EQU 6 REAL*6 H.DBI EQU 10B INTEGER*4 H.RE8 EQU 12B REAL*8 H.ZPX EQU 14B COMPLEX*16 * R.REG EQU 40000B REG. PRESERVED. DOT FCT OPTIONS. R.OPM EQU 20000B OPNDS IN MEM. R.RTN EQU 10000B RTN ADDR. R.ER0 EQU 04000B DO JSB ERR0. * S.1 EQU 40000B SUBROUTINE CALL ALLOWABLE. SKP * THE INTRINSICS TABLE. * DEF SQRT2 IFTBL ASC 3,SQRT SQRT. ABS A.1+B.1+C.5+D.REA ABS E.REA+%QRT ABS G.REA+H.REA ABS R.REG+R.ER0+SQRT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DSQRT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SQRT ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CSQRT ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZSQR * DEF SQRT3 SQRT2 ASC 3,DSQRT DSQRT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$SQRT ABS E.RE8+/SQRT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DSQRT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SQRT * DEF SIN1 SQRT3 ASC 3,CSQRT CSQRT. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+CSQRT ABS E.ZPX+.ZSQR ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CSQRT ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZSQR * * SIN. * DEF SIN2 SIN1 ASC 3,SIN SIN. ABS A.1+B.1+C.5+D.REA ABS E.REA+%IN ABS G.REA+H.REA ABS R.REG+R.ER0+SIN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SIN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CSIN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZSIN * DEF SIN3 SIN2 ASC 3,DSIN DSIN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DSIN ABS E.RE8+/SIN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.SIN * DEF COS1 SIN3 ASC 3,CSIN CSIN. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#SIN ABS E.ZPX+%ZSIN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CSIN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZSIN * DEF COS2 COS1 ASC 3,COS COS. ABS A.1+B.1+C.5+D.REA ABS E.REA+%OS ABS G.REA+H.REA ABS R.REG+R.ER0+COS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DCOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.COS ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CCOS ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZCOS * DEF COS3 COS2 ASC 3,DCOS DCOS. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DCOS ABS E.RE8+/COS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DCOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.COS * DEF TAN1 COS3 ASC 3,CCOS CCOS. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#COS ABS E.ZPX+%ZCOS ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CCOS ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZCOS * DEF TAN2 TAN1 ASC 3,TAN TAN. ABS A.1+B.1+C.5+D.REA ABS E.REA+%AN ABS G.REA+H.REA ABS R.REG+R.ER0+TAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DTAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.TAN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+.CTAN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZTAN * DEF TAN3 TAN2 ASC 3,DTAN DTAN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$TAN ABS E.RE8+/TAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DTAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.TAN * DEF TANH1 TAN3 ASC 3,CTAN CTAN. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+%CTAN ABS E.ZPX+%ZTAN ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+.CTAN ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZTAN * DEF TANH2 TANH1 ASC 3,TANH TANH. ABS A.1+B.1+C.3+D.REA ABS E.REA+%ANH ABS G.REA+H.REA ABS R.REG+TANH ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DTANH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TANH * DEF ATN.1 TANH2 ASC 3,DTANH DTANH. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DTANH ABS E.RE8+.TANH ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DTANH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TANH * DEF ATN.2 ATN.1 ASC 3,ATAN ATAN. ABS A.1+B.1+C.3+D.REA ABS E.RE8+%TAN ABS G.REA+H.REA ABS R.REG+ATAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ATAN * DEF AT2.1 ATN.2 ASC 3,DATAN DATAN. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DATAN ABS E.RE8+.ATAN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATAN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ATAN * DEF AT2.2 AT2.1 ASC 3,ATAN2 ATAN2. ABS A.2+B.1+C.3+D.REA ABS E.REA+ATAN2 ABS G.REA+H.REA ABS R.OPM+R.RTN+ATAN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF AT2.3 AT2.2 ASC 3,DATAN2 DATAN2. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DATN2 ABS E.RE8+/ATN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF LOG1 AT2.3 ASC 3,DATN2 DATN2. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DATN2 ABS E.RE8+/ATN2 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DATN2 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.ATN2 * DEF LOG2 LOG1 ASC 3,LOG LOG. ABS A.1+B.0+C.5+D.NON ABS G.REA+H.REA ABS R.REG+R.ER0+ALOG ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOG ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CLOG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZLOG * DEF LOG3 LOG2 ASC 3,ALOG ALOG. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOG ABS G.REA+H.REA ABS R.REG+R.ER0+ALOG * DEF LOG4 LOG3 ASC 3,DLOG DLOG. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOG ABS E.RE8+/LOG ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOG ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOG * DEF L10.1 LOG4 ASC 3,CLOG CLOG. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#LOG ABS E.ZPX+%ZLOG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CLOG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZLOG * DEF L10.2 L10.1 ASC 3,LOG10 LOG10. ABS A.1+B.0+C.3+D.NON ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF L10.3 L10.2 ASC 3,ALOG10 ALOG10. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOGT ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT * DEF ALGT1 L10.3 ASC 3,DLOG10 DLOG10. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOGT ABS E.RE8+/LOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF ALGT2 ALGT1 ASC 3,ALOGT ALOGT. ABS A.1+B.1+C.1+D.REA ABS E.REA+%LOGT ABS G.REA+H.REA ABS R.REG+R.ER0+ALOGT * DEF EXP1 ALGT2 ASC 3,DLOGT DLOGT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$LOGT ABS E.RE8+/LOGT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DLOGT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.LOGT * DEF EXP2 EXP1 ASC 3,EXP EXP. ABS A.1+B.1+C.5+D.REA ABS E.REA+%XP ABS G.REA+H.REA ABS R.REG+R.ER0+EXP ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DEXP ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.EXP ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CEXP ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZEXP * DEF EXP3 EXP2 ASC 3,DEXP DEXP. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+$EXP ABS E.RE8+/EXP ABS G.DBL+H.DBL ABS R.OPM+R.RTN+R.ER0+DEXP ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.EXP * DEF SINH1 EXP3 ASC 3,CEXP CEXP. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+#EXP ABS E.ZPX+%ZEXP ABS G.CPX+H.CPX ABS R.OPM+R.RTN+R.ER0+CEXP ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+R.ER0+.ZEXP * DEF SINH2 SINH1 ASC 3,SINH SINH. ABS A.1+B.1+C.2+D.REA ABS E.REA+%SINH ABS G.REA+H.REA ABS R.REG+R.ER0+.SINH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DSNH * DEF COSH1 SINH2 ASC 3,DSINH DSINH. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DSNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DSNH * DEF COSH2 COSH1 ASC 3,COSH COSH. ABS A.1+B.1+C.2+D.REA ABS E.REA+%COSH ABS G.REA+H.REA ABS R.REG+R.ER0+.COSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DCSH * DEF ASIN1 COSH2 ASC 3,DCOSH DCOSH. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DCSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DCSH * DEF ASIN2 ASIN1 ASC 3,ASIN ASIN. ABS A.1+B.1+C.2+D.REA ABS E.REA+%ASIN ABS G.REA+H.REA ABS R.REG+R.ER0+.ASIN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DASN * DEF ACOS1 ASIN2 ASC 3,DASIN DASIN. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DASN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DASN * DEF ACOS2 ACOS1 ASC 3,ACOS ACOS. ABS A.1+B.1+C.2+D.REA ABS E.REA+%ACOS ABS G.REA+H.REA ABS R.REG+R.ER0+.ACOS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACS * DEF ASNH1 ACOS2 ASC 3,DACOS DACOS. ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DACS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACS * DEF ASNH2 ASNH1 ASC 3,ASINH ASINH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ASNH ABS G.REA+H.REA ABS R.REG+.ASNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DASH * DEF ACSH1 ASNH2 ASC 3,DASINH DASINH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+.DASH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DASH * DEF ACSH2 ACSH1 ASC 3,ACOSH ACOSH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ACSH ABS G.REA+H.REA ABS R.REG+R.ER0+.ACSH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACH * DEF ATNH1 ACSH2 ASC 3,DACOSH DACOSH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DACH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DACH * DEF ATNH2 ATNH1 ASC 3,ATANH ATANH ABS A.1+B.1+C.2+D.REA ABS E.REA+%ATNH ABS G.REA+H.REA ABS R.REG+R.ER0+.ATNH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DATH * DEF ABS1 ATNH2 ASC 3,DATANH DATANH ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%DATH ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+R.ER0+.DATH * DEF ABS2 ABS1 ASC 3,ABS ABS. ABS A.1+B.1+C.7+D.REA ABS E.REA+%BS ABS G.INT+H.INT OCT 100001 ABS G.DBI+H.DBI OCT 100002 ABS G.REA+H.REA OCT 100003 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DABS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ABS ABS G.CPX+H.REA ABS R.OPM+R.RTN+CABS ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZABS * DEF ABS3 ABS2 ASC 3,IABS IABS. ABS A.1+B.2+C.2+D.INT ABS E.INT+%ABS ABS E.DBI+%JABS ABS G.INT+H.INT OCT 100001 ABS G.DBI+H.DBI OCT 100002 * DEF ABS4 ABS3 ASC 3,DABS DABS. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DABS ABS E.RE8+.ABS ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DABS ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.ABS * DEF MOD1 ABS4 ASC 3,CABS CABS. ABS A.1+B.2+C.2+D.REA ABS E.REA+CABS ABS E.RE8+.ZABS ABS G.CPX+H.REA ABS R.OPM+R.RTN+CABS ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZABS * DEF MOD2 MOD1 ASC 3,MOD MOD. ABS A.2+B.2+C.5+D.INT ABS E.INT+MOD ABS E.DBI+%JMOD ABS G.INT+H.INT ABS R.OPM+R.RTN+MOD ABS G.DBI+H.DBI ABS R.REG+.DMOD ABS G.REA+H.REA ABS R.OPM+R.RTN+AMOD ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMOD ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MOD * DEF MOD3 MOD2 ASC 3,AMOD AMOD. ABS A.2+B.1+C.1+D.REA ABS E.REA+AMOD ABS G.REA+H.REA ABS R.OPM+R.RTN+AMOD * DEF SIGN1 MOD3 ASC 3,DMOD DMOD. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DMOD ABS E.RE8+.MOD ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMOD ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MOD * DEF SIGN2 SIGN1 ASC 3,SIGN SIGN. ABS A.2+B.1+C.5+D.REA ABS E.REA+%IGN ABS G.INT+H.INT ABS R.OPM+ISIGN ABS G.DBI+H.DBI ABS R.OPM+.JSGN ABS G.REA+H.REA ABS R.OPM+SIGN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIGN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.SIGN * DEF SIGN3 SIGN2 ASC 3,ISIGN ISIGN. ABS A.2+B.2+C.2+D.INT ABS E.INT+%IGN ABS E.DBI+%JSGN ABS G.INT+H.INT ABS R.OPM+ISIGN ABS G.DBI+H.DBI ABS R.OPM+.JSGN * DEF DIM1 SIGN3 ASC 3,DSIGN DSIGN. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+DSIGN ABS E.RE8+.SIGN ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DSIGN ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.SIGN * DEF DIM2 DIM1 ASC 3,DIM DIM. ABS A.2+B.1+C.5+D.REA ABS E.REA+DIM ABS G.INT+H.INT ABS R.OPM+R.RTN+IDIM ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JDIM ABS G.REA+H.REA ABS R.OPM+R.RTN+DIM ABS G.DBL+H.DBL ABS R.OPM+R.RTN+.XDIM ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DDIM * DEF DIM3 DIM2 ASC 3,IDIM IDIM. ABS A.2+B.2+C.2+D.INT ABS E.INT+IDIM ABS E.DBI+.JDIM ABS G.INT+H.INT ABS R.OPM+R.RTN+IDIM ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JDIM * DEF MIN.1 DIM3 ASC 3,DDIM DDIM. ABS A.2+B.2+C.2+D.DBL ABS E.DBL+.XDIM ABS E.RE8+.DDIM ABS G.DBL+H.DBL ABS R.OPM+R.RTN+.XDIM ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.DDIM * DEF MIN.2 MIN.1 ASC 3,MIN MIN. ABS A.VAR+B.0+C.5+D.NON ABS G.INT+H.INT ABS R.OPM+R.RTN+MIN0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMN0 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMIN1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMIN1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MIN1 * DEF MIN.3 MIN.2 ASC 3,MIN0 MIN0. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MIN0 ABS E.DBI+.JMN0 ABS G.INT+H.INT ABS R.OPM+R.RTN+MIN0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMN0 * DEF MIN.4 MIN.3 ASC 3,AMIN1 AMIN1. ABS A.VAR+B.1+C.1+D.REA ABS E.REA+AMIN1 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMIN1 * DEF AMN.0 MIN.4 ASC 3,DMIN1 DMIN1. ABS A.VAR+B.2+C.2+D.DBL ABS E.DBL+DMIN1 ABS E.RE8+.MIN1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMIN1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MIN1 * DEF MN1.1 AMN.0 ASC 3,AMIN0 AMIN0. ABS A.VAR+B.2+C.2+D.REA ABS I+I+E.REA+AMIN0 ABS J+J+E.REA+.AMNJ ABS G.INT+H.REA ABS R.OPM+R.RTN+AMIN0 ABS G.DBI+H.REA ABS R.OPM+R.RTN+.AMNJ * DEF MAX.1 MN1.1 ASC 3,MIN1 MIN1. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MIN1 ABS E.DBI+.JMN1 ABS G.REA+H.INT ABS R.OPM+R.RTN+MIN1 ABS G.REA+H.DBI ABS R.OPM+R.RTN+.JMN1 * DEF MAX.2 MAX.1 ASC 3,MAX MAX. ABS A.VAR+B.0+C.5+D.NON ABS G.INT+H.INT ABS R.OPM+R.RTN+MAX0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMX0 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMAX1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMAX1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MAX1 * DEF MAX.3 MAX.2 ASC 3,MAX0 MAX0. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MAX0 ABS E.DBI+.JMX0 ABS G.INT+H.INT ABS R.OPM+R.RTN+MAX0 ABS G.DBI+H.DBI ABS R.OPM+R.RTN+.JMX0 * DEF MAX.4 MAX.3 ASC 3,AMAX1 AMAX1. ABS A.VAR+B.1+C.1+D.REA ABS E.REA+AMAX1 ABS G.REA+H.REA ABS R.OPM+R.RTN+AMAX1 * DEF AMX.0 MAX.4 ASC 3,DMAX1 DMAX1. ABS A.VAR+B.2+C.2+D.DBL ABS E.DBL+DMAX1 ABS E.RE8+.MAX1 ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DMAX1 ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.MAX1 * DEF MX.1 AMX.0 ASC 3,AMAX0 AMAX0. ABS A.VAR+B.2+C.2+D.REA ABS I+I+E.REA+AMAX0 ABS J+J+E.REA+.AMXJ ABS G.INT+H.REA ABS R.OPM+R.RTN+AMAX0 ABS G.DBI+H.REA ABS R.OPM+R.RTN+.AMXJ * DEF AIMG1 MX.1 ASC 3,MAX1 MAX1. ABS A.VAR+B.2+C.2+D.INT ABS E.INT+MAX1 ABS E.DBI+.JMX1 ABS G.REA+H.INT ABS R.OPM+R.RTN+MAX1 ABS G.REA+H.DBI ABS R.OPM+R.RTN+.JMX1 * DEF CNJG1 AIMG1 ASC 3,AIMAG AIMAG. ABS A.1+B.2+C.2+D.REA ABS E.REA+AIMAG ABS E.RE8+.ZAIM ABS G.CPX+H.REA ABS R.OPM+R.RTN+AIMAG ABS G.ZPX+H.RE8 ABS R.OPM+R.RTN+.ZAIM * DEF AINT1 CNJG1 ASC 3,CONJG CONJG. ABS A.1+B.2+C.2+D.CPX ABS E.CPX+CONJG ABS E.ZPX+.ZCJG ABS G.CPX+H.CPX ABS R.OPM+R.RTN+CONJG ABS G.ZPX+H.ZPX ABS R.OPM+R.RTN+.ZCJG * DEF DINT AINT1 ASC 3,AINT AINT. ABS A.1+B.1+C.3+D.REA ABS E.REA+%INT ABS G.REA+H.REA ABS R.REG+AINT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF DDNT1 DINT ASC 3,DINT DINT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DDINT ABS E.RE8+.YINT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF INT1 DDNT1 ASC 3,DDINT DDINT. ABS A.1+B.2+C.2+D.DBL ABS E.DBL+DDINT ABS E.RE8+.YINT ABS G.DBL+H.DBL ABS R.OPM+R.RTN+DDINT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.YINT * DEF INT2 INT1 ASC 3,INT INT. ABS A.1+B.2+C.12+D.INT ABS E.INT+%FIX ABS E.DBI+%FIXD ABS G.INT+H.INT OCT 100000 ABS G.DBI+H.DBI OCT 100000 ABS G.REA+H.INT OCT 100000 ABS G.REA+H.DBI OCT 100000 ABS G.DBL+H.INT OCT 100000 ABS G.DBL+H.DBI OCT 100000 ABS G.RE8+H.INT OCT 100000 ABS G.RE8+H.DBI OCT 100000 ABS G.CPX+H.INT OCT 100000 ABS G.CPX+H.DBI OCT 100000 ABS G.ZPX+H.INT OCT 100000 ABS G.ZPX+H.DBI OCT 100000 * DEF INT3 INT2 ASC 3,IFIX IFIX ABS A.1+B.2+C.2+D.INT ABS E.INT+%FIX ABS E.DBI+%FIXD ABS G.REA+H.INT OCT 100000 ABS G.REA+H.DBI OCT 100000 * DEF ANNT1 INT3 ASC 3,IDINT IDINT. ABS A.1+B.4+C.4+D.INT ABS X+X+E.INT+IDINT ABS X+X+E.DBI+%XFXD ABS Y+Y+E.INT+%TFXS ABS Y+Y+E.DBI+%TFXD ABS G.DBL+H.INT OCT 100000 ABS G.DBL+H.DBI OCT 100000 ABS G.RE8+H.INT OCT 100000 ABS G.RE8+H.DBI OCT 100000 * DEF DNNT1 ANNT1 ASC 3,ANINT ANINT. ABS A.1+B.1+C.2+D.REA ABS E.REA+%ANNT ABS G.REA+H.REA ABS R.REG+.ANNT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TNNT * DEF NINT1 DNNT1 ASC 3,DNINT DNINT ABS A.1+B.1+C.1+D.RE8 ABS E.RE8+%TNNT ABS G.RE8+H.RE8 ABS R.OPM+R.RTN+.TNNT * DEF IDNT1 NINT1 ASC 3,NINT NINT. ABS A.1+B.2+C.4+D.INT ABS E.INT+%NINT ABS E.DBI+%NJNT ABS G.REA+H.INT ABS R.REG+.NINT ABS G.REA+H.DBI ABS R.REG+.NJNT ABS G.RE8+H.INT ABS R.OPM+.IDNT ABS G.RE8+H.DBI ABS R.OPM+.JDNT * DEF REAL1 IDNT1 ASC 3,IDNINT IDNINT. ABS A.1+B.2+C.2+D.INT ABS Y+Y+E.INT+%IDNT ABS Y+Y+E.DBI+%JDNT ABS G.RE8+H.INT ABS R.OPM+.IDNT ABS G.RE8+H.DBI ABS R.OPM+.JDNT * DEF FLT1 REAL1 ASC 3,REAL REAL. ABS A.1+B.2+C.7+D.REA ABS I+I+E.REA+%LOAT ABS J+J+E.REA+%FLTD ABS G.INT+H.REA OCT 100000 ABS G.DBI+H.REA OCT 100000 ABS G.REA+H.REA OCT 100000 ABS G.DBL+H.REA OCT 100000 ABS G.RE8+H.REA OCT 100000 ABS G.CPX+H.REA OCT 100000 ABS G.ZPX+H.RE8 OCT 100000 * DEF SNGL1 FLT1 ASC 3,FLOAT FLOAT. ABS A.1+B.2+C.2+D.REA ABS I+I+E.REA+%LOAT ABS J+J+E.REA+%FLTD ABS G.INT+H.REA OCT 100000 ABS G.DBI+H.REA OCT 100000 * DEF DBLE1 SNGL1 ASC 3,SNGL SNGL. ABS A.1+B.2+C.2+D.REA ABS X+X+E.REA+SNGL ABS Y+Y+E.REA+.NGL ABS G.DBL+H.REA OCT 100000 ABS G.RE8+H.REA OCT 100000 * DEF CMPL1 DBLE1 ASC 3,DBLE DBLE. ABS A.1+B.2+C.12+D.DBL ABS E.DBL+DBLE ABS E.RE8+.BLE ABS G.INT+H.DBL OCT 100000 ABS G.INT+H.RE8 OCT 100000 ABS G.DBI+H.DBL OCT 100000 ABS G.DBI+H.RE8 OCT 100000 ABS G.REA+H.DBL OCT 100000 ABS G.REA+H.RE8 OCT 100000 ABS G.DBL+H.DBL OCT 100000 ABS G.RE8+H.RE8 OCT 100000 ABS G.CPX+H.DBL OCT 100000 ABS G.CPX+H.RE8 OCT 100000 ABS G.ZPX+H.DBL OCT 100000 ABS G.ZPX+H.RE8 OCT 100000 * DEF IAND1 CMPL1 ASC 3,CMPLX CMPLX. ABS A.2+B.2+C.2+D.CPX ABS E.CPX+CMPLX ABS E.ZPX+.ZMPX ABS G.REA+H.CPX ABS R.OPM+R.RTN+CMPLX ABS G.RE8+H.ZPX ABS R.OPM+R.RTN+.ZMPX * DEF IOR1 IAND1 ASC 3,IAND IAND. ABS A.2+B.2+C.2+D.INT ABS E.INT+%AND ABS E.DBI+%DAND ABS G.INT+H.INT OCT 100005 ABS G.DBI+H.DBI ABS R.REG+.DAND * DEF IXOR1 IOR1 ASC 3,IOR IOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+%OR ABS E.DBI+%DOR ABS G.INT+H.INT OCT 100006 ABS G.DBI+H.DBI ABS R.REG+.DOR * DEF IEOR1 IXOR1 ASC 3,IXOR IXOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+IXOR ABS E.DBI+%DXOR ABS G.INT+H.INT OCT 100007 ABS G.DBI+H.DBI ABS R.REG+.DXOR * DEF NOT IEOR1 ASC 3,IEOR IEOR. ABS A.2+B.2+C.2+D.INT ABS E.INT+IXOR ABS E.DBI+%DXOR ABS G.INT+H.INT OCT 100007 ABS G.DBI+H.DBI ABS R.REG+.DXOR * DEF ISHFT NOT ASC 3,NOT NOT. ABS A.1+B.2+C.2+D.INT ABS E.INT+%OT ABS E.DBI+%DNOT ABS G.INT+H.INT OCT 100010 ABS G.DBI+H.DBI OCT 100011 * DEF ISSW1 ISHFT ASC 3,ISHFT ISHFT. ABS A.2+B.2+C.2+D.INT ABS E.INT+%ISH ABS E.DBI+%JSH ABS G.INT+H.INT OCT 100004 ABS G.DBI+H.DBI OCT 100004 * DEF PCNT1 ISSW1 ASC 3,ISSW ISSW. ABS A.1+B.1+C.1+D.INT ABS E.INT+%SSW ABS G.INT+H.INT ABS R.REG+ISSW * DEF EXEC1 PCNT1 ASC 3,PCOUNT PCOUNT. .PCNT ABS A.0+B.0+C.2+D.INT ABS H.INT OCT 100012 ABS H.DBI OCT 100012 * DEF DEXC1 EXEC1 ASC 3,EXEC EXEC. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+EXEC ABS E.REA+EXEC ABS G.SUB+H.DBI ABS R.OPM+R.RTN+EXEC ABS G.SUB+H.REA ABS R.OPM+R.RTN+EXEC * DEF REIO1 DEXC1 ASC 3,DEXEC DEXEC. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+DEXEC ABS E.REA+DEXEC ABS G.SUB+H.DBI ABS R.OPM+R.RTN+DEXEC ABS G.SUB+H.REA ABS R.OPM+R.RTN+DEXEC * DEF XLUE1 REIO1 ASC 3,REIO REIO. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+REIO ABS E.REA+REIO ABS G.SUB+H.DBI ABS R.OPM+R.RTN+REIO ABS G.SUB+H.REA ABS R.OPM+R.RTN+REIO * DEF 0 XLUE1 ASC 3,XLUEX XLUEX. ABS S.1+A.VAR+B.2+C.2+D.REA ABS E.DBI+XLUEX ABS E.REA+XLUEX ABS G.SUB+H.DBI ABS R.OPM+R.RTN+XLUEX ABS G.SUB+H.REA ABS R.OPM+R.RTN+XLUEX * * * END OF INTRINSICS TABLE. SKP * ORDINALS IN DOT-FUNCTION TABLE. * EXEC EQU 72 REIO EQU 90 XLUEX EQU 91 * SQRT EQU 102 DSQRT EQU 103 .SQRT EQU 104 CSQRT EQU 105 %QRT EQU 106 $SQRT EQU 107 /SQRT EQU 108 * SIN EQU 109 DSIN EQU 110 .SIN EQU 111 CSIN EQU 112 %IN EQU 113 /SIN EQU 115 #SIN EQU 116 * COS EQU 117 DCOS EQU 118 .COS EQU 119 CCOS EQU 120 %OS EQU 121 /COS EQU 123 #COS EQU 124 * TAN EQU 125 DTAN EQU 126 .TAN EQU 127 %AN EQU 128 $TAN EQU 129 /TAN EQU 130 * TANH EQU 131 DTANH EQU 132 .TANH EQU 133 %ANH EQU 134 * ATAN EQU 135 DATAN EQU 136 .ATAN EQU 137 %TAN EQU 138 * ATAN2 EQU 139 DATN2 EQU 140 .ATN2 EQU 141 /ATN2 EQU 122 * ALOG EQU 142 DLOG EQU 143 .LOG EQU 144 CLOG EQU 145 %LOG EQU 146 $LOG EQU 147 /LOG EQU 148 #LOG EQU 149 * ALOGT EQU 150 DLOGT EQU 151 .LOGT EQU 152 %LOGT EQU 153 $LOGT EQU 154 /LOGT EQU 155 * EXP EQU 156 DEXP EQU 157 .EXP EQU 158 CEXP EQU 159 %XP EQU 160 $EXP EQU 161 /EXP EQU 162 #EXP EQU 163 * DABS EQU 164 .ABS EQU 165 CABS EQU 166 %ABS EQU 167 %JABS EQU 168 %BS EQU 169 * .DMOD EQU 170 AMOD EQU 171 DMOD EQU 172 .MOD EQU 173 MOD EQU 174 %JMOD EQU 175 * ISIGN EQU 176 .JSGN EQU 177 SIGN EQU 178 DSIGN EQU 179 .SIGN EQU 180 %IGN EQU 181 %JSGN EQU 182 * IDIM EQU 183 .JDIM EQU 184 DIM EQU 185 .XDIM EQU 186 .DDIM EQU 187 * MIN0 EQU 188 .JMN0 EQU 189 AMIN1 EQU 190 DMIN1 EQU 191 .MIN1 EQU 192 * AMIN0 EQU 193 .AMNJ EQU 194 * MIN1 EQU 195 .JMN1 EQU 196 * MAX0 EQU 197 .JMX0 EQU 198 AMAX1 EQU 199 DMAX1 EQU 200 .MAX1 EQU 201 * AMAX0 EQU 202 .AMXJ EQU 203 * MAX1 EQU 204 .JMX1 EQU 205 * AIMAG EQU 206 CONJG EQU 207 * AINT EQU 208 DDINT EQU 209 .YINT EQU 210 %INT EQU 211 * %FIX EQU 220 %FIXD EQU 221 IDINT EQU 222 %XFXD EQU 223 %TFXS EQU 224 %TFXD EQU 225 * FLOAT EQU 226 .FLTD EQU 227 SNGL EQU 228 .NGL EQU 229 %LOAT EQU 231 %FLTD EQU 232 * DBLE EQU 237 .BLE EQU 238 * CMPLX EQU 241 * %AND EQU 242 %DAND EQU 243 .DAND EQU 244 * %OR EQU 245 %DOR EQU 246 .DOR EQU 247 * IXOR EQU 248 %DXOR EQU 249 .DXOR EQU 250 * %OT EQU 251 %DNOT EQU 252 * %ISH EQU 256 %JSH EQU 257 * %SSW EQU 258 ISSW EQU 259 * .SINH EQU 270 %SINH EQU 271 .COSH EQU 272 %COSH EQU 273 .ASIN EQU 274 %ASIN EQU 275 .ACOS EQU 276 %ACOS EQU 277 .ASNH EQU 278 %ASNH EQU 279 .ACSH EQU 280 %ACSH EQU 281 .ATNH EQU 282 %ATNH EQU 283 .CTAN EQU 284 %CTAN EQU 285 .DSNH EQU 286 %DSNH EQU 287 .DCSH EQU 288 %DCSH EQU 289 .DASN EQU 290 %DASN EQU 291 .DACS EQU 292 %DACS EQU 293 .DASH EQU 294 .DACH EQU 296 %DACH EQU 297 .DATH EQU 298 %DATH EQU 299 * .ZMPX EQU 307 .ZSQR EQU 317 .ZSIN EQU 318 %ZSIN EQU 319 .ZCOS EQU 320 %ZCOS EQU 321 .ZTAN EQU 322 %ZTAN EQU 323 .ZLOG EQU 324 %ZLOG EQU 325 .ZEXP EQU 326 %ZEXP EQU 327 .ZABS EQU 328 .ZAIM EQU 329 .ZCJG EQU 330 * .NINT EQU 331 %NINT EQU 332 .NJNT EQU 333 %NJNT EQU 334 .IDNT EQU 335 %IDNT EQU 336 .JDNT EQU 337 %JDNT EQU 338 .ANNT EQU 339 %ANNT EQU 340 .TNNT EQU 341 %TNNT EQU 342 * DEXEC EQU 343 SKP * ***************** * * SEGMENT ENTRY * * ***************** SPC 1 * SET UP SOME INFO ABOUT THE 'Y' AND 'I' OPTIONS. * F4.2 LDA DEXIT SET UP ERROR RECOVERY ADDRESS. STA F.ERX LDB F.CCW OPTIONS WORD. LDA DBL MODIFIES DBL=REAL*6 BLF,BLF 'Y' OPTION IS IN BIT 9=>1 RBR,SLB =>0, IS IT SET ? LDA RE8 YES, DEFAULT IS RE8=REAL*8. STA MDBL MDBL=MODIFIED DBL. XOR DBL COMPUTE THE OTHER ONE. XOR RE8 STA ODBL ODBL=NON-DEFAULT OF THE TWO. * LDA INT 'J' CHANGES INT=INTEGER*2 LDB F.CCW WELL ? BLF,SLB BIT 12=>0, IS OPTION SET ? LDA DBI YES, DEFAULT TO DBI=INTEGER*4. STA MINT MINT=MODIFIED INT. XOR INT COMPUTE OTHER ONE. XOR DBI STA OINT OINT=NON-DEFAULT OF THE TWO. * LDA F.CCW CONSTRUCT IJXY FIELD FOR REQ'D I/J. RRR 12 AND K1 I=0, J=1. IOR K2 + SELECTION BITS. STA JOPT * LDA F.CCW DITTO, X/Y. RRR 9 AND K1 IOR K4 STA YOPT * * SCAN SYMBOL TABLE FOR EXTERNAL SUBROUTINES. * LDA DISP1 SET UP LOCAL ERROR RECOVERY. STA F.EQE JSB GFA.F SET UP F.A, DUMMY LIST HEAD. ISP01 JSB GNA.F GET NEXT ITEM. SZA,RSS DONE ? JMP IMP01 YES. GO DO 'IMPLICIT NONE' CHECKING. * CPA F.SBF CURRENT MODULE ? JMP ISP01 YES. SKIP. * LDA F.A,I GET F.AT & F.IU . AND B7600 CPA B2200 IS F.AT=STRAB & F.IU=SUB ? JMP ISP04 YES. JMP ISP01 NO. NOT AN EXTERNAL SUBROUTINE. SKP * GOT ONE. SEARCH INTRINSICS TABLE FOR IT. * ISP04 JSB NAM.F YES. EXTRACT ITS NAME. DEF NAME LDA DIFTB SET UP LOOP. ISP05 STA T1ISP T1ISP = INTRINSICS TABLE POINTER. LDB A,I (B) = CHARS 1,2. CPB NAME 1&2 SAME ? RSS YES. JMP ISP06 NO. WRONG ONE. * INA DLD A,I CHARS 3,4,5,6. CPA NAME+1 3&4 SAME ? RSS YES. JMP ISP06 NO. WRONG ONE. * CPB NAME+2 5&6 SAME ? JMP ISP10 YES. MATCH. * ISP06 CCA NO. SKIP THIS ENTRY. ADA T1ISP GET ADDR OF NEXT. LDA A,I SZA,RSS MORE ? JMP ISP01 NO. NOT INTRINSIC. JMP ISP05 YES. GO CHECK IT OUT. * DEXIT DEF EXIT SEGMENT ERROR RECOVERY ADDR. DISP1 DEF ISP01 LOCAL ERROR RECOVERY ADDR. NAME BSS 3 NAME FROM SYMBOL TABLE. DIFTB DEF IFTBL ADDR OF FIRST ENTRY. T1ISP NOP ADDR OF CURRENT ENTRY. T2ISP NOP GENERAL COUNTER.ENTRY. T3ISP NOP GENERAL POINTER.ENTRY. T4ISP NOP POINTER SIZE BUILT TABLE. B7600 OCT 7600 B2200 OCT 2200 MDBL NOP MODIFIED 'DBL'. ODBL NOP OTHER ONE. MINT NOP MODIFIED 'INT'. OINT NOP OTHER ONE. JOPT NOP MATCHING REQ'D 'J' OPTION BITS. YOPT NOP MATCHING REQ'D 'Y' OPTION BITS. B10K OCT 010000 INT EQU B10K DBI OCT 100000 DBL OCT 060000 RE8 OCT 120000 K1 DEC 1 K2 DEC 2 K4 DEC 4 K7 DEC 7 SKP * GOT AN INTRINSIC. PROCESS IT. * FIRST, SET UP ITS TYPE. * ISP10 ISZ T1ISP SKIP OVER THE NAME. ISZ T1ISP ISZ T1ISP JSB FA.F FETCH SYMBOL ASSIGNS. LDA F..E EXPLICITLY TYPED ? SZA JMP ISP11 YES. LEAVE IT. * LDA T1ISP,I NO. GET THE TYPE. AND B17 ALF,ALF POSITION IT. ALF CPA DBL IF DBL, LDA MDBL MAY CHANGE TO RE8. CPA INT IF INT, LDA MINT MAY CHANGE TO DBI. JSB DIM.F CHANGE F.IM TO DEFAULT TYPE. * * IF SUBROUTINE, USE FIRST EXTERNAL NAME. * ISP11 LDA F.S USED AS SUB ? SZA,RSS JMP ISP12 NO. * STA T4ISP YES. (TABLE = 1 WORD) DLD T1ISP,I IS THAT ALLOWED ? RAL SSA,RSS JMP ISP01 NO. THEN NOT AN INTRINSIC. * LSL 7 YES. GET THE DOT ORDINAL. LSR 7 (B) = DOT ORDINAL. JMP ISP27 GO INSERT IN TABLE & PROCEED. SKP * DETERMINE THE EXTERNAL NAME. IF CAN'T FIND TYPE, * AND EXPLICITLY RETYPED, THEN NOT INTRINSIC. * ISP12 LDA T1ISP,I GET THE NUMBER OF THEM. AND B7400 ALF,ALF STA T4ISP SAVE THAT. CMA,INA T2ISP = COUNTER. STA T2ISP LDA T1ISP T3ISP = POINTER. STA T3ISP ISP13 ISZ T3ISP NEXT CANDIDATE.. LDA T3ISP,I ALF,RAR GET ITS TYPE. AND B170K CPA F.IM MATCH ? RSS YES. JMP ISP14 NO. GO CHECK NEXT. * LDA T3ISP,I YES. CHECK OUT I/J & X/Y STUFF. ALF,RAR TO BITS 2:0 AND K7 THE FLAG BITS. SZA IF NO OPTION REQUIRED, CPA JOPT OR IF ITS 'J' & CORRECT ? RSS YES. CPA YOPT OR 'Y' AND CORRECT ? JMP ISP15 YES. MATCH COMPLETE. * ISP14 ISZ T2ISP NO. BUMP COUNTER. JMP ISP13 IF MORE. * LDA F..E NOT FOUND. WAS IT EXPLICITLY TYPED ? SZA JMP ISP01 YES. THEN NOT AN INTRINSIC. JMP ISP17 NO. JUST A GENERIC WITH NO SPECIFICS. * ISP15 LDA T3ISP,I FOUND. SET INTO TABLE. AND B777 ISP17 STA TABLE BITS <8:0> OF FIRST WORD. SKP * COPY EACH SPECIFIC NAME INTO TABLE, UNLESS: * 1) EXPLICIT TYPING & DOESN'T MATCH, OR * 2) FCT TYPE # ARG TYPE AND FCT TYPE IS * NOT DEFAULT FOR 'Y' OR 'J' OPTIONS. * LDA T1ISP,I GET THE NUMBER OF SPECIFIC NAMES. AND B360 ALF,ALF ALF CMA,INA T2ISP = COUNTER. STA T2ISP LDA T1ISP COMPUTE ADDR OF FIRST ONE. ADA T4ISP SKIP TO LAST EXTERNAL ENTRY. STA T3ISP T3ISP = POINTER (BUMP ONE FIRST). LDA DTBL1 SET POINTER TO TABLE. STA T4ISP ISP20 ISZ T3ISP ON TO NEXT ENTRY... LDA T3ISP,I GET THE FUNCTION TYPE. AND B17 ALF,ALF ALIGN IT. ALF LDB F..E FUNCTION IS EXPLICITLY TYPED ? SZB,RSS JMP ISP22 NO. * CPA F.IM YES. IS IT RIGHT TYPE ? JMP ISP24 YES. COPY IT. JMP ISP26 NO. SKIP IT. * ISP22 LDB A NOT EXPL. TYPED. FCT TYPE = ARG TYPE ? LDA T3ISP,I GET ARG TYPE. ALF,ALF AND B170K CPA B WELL ? JMP ISP24 SAME. HAVE TO KEEP IT. * CPB ODBL DIFFERENT. IS IT A NON-DEFAULT TYPE ? RSS YES. CPB OINT JMP ISP26 YES. SKIP IT. * ISP24 DLD T3ISP,I COPY ENTRY TO TABLE. DST T4ISP,I ISZ T4ISP ISZ T4ISP ISP26 ISZ T3ISP ADVANCE TO NEXT ENTRY. (OTHER ISZ AT TOP) ISZ T2ISP DONE ? JMP ISP20 NO. LOOK FOR MORE. SKP * FINISH BUILDING TABLE. * LDB DTBL1 COMPUTE NUMBER OF SPECIFIC NAMES. CMB,INB ADB T4ISP (LWA+1) - FWA = COUNT*2 STB T4ISP T4ISP = (TABLE SIZE)-1. BLF,BLF PUT IN BITS <12:9>, FIRST WORD. ADB TABLE ISP27 LDA T1ISP,I GET # PARAMS & S-BIT. AND B70K WERE IN BITS <14:12>, RAL PUT IN BITS <15:13>, FIRST WORD. IOR B STA TABLE ISZ T4ISP T4ISP = # WORDS IN TABLE. * * ALLOCATE SPACE IN A.T. AREA FOR THE TABLE, * AND COPY IT THERE. SET F.AF=TABLE ADDR, F.NC=1. * LDB T4ISP ALLOCATE SPACE. JSB AST.F STB T3ISP SAVE ITS ADDR. LDA DTABL COPY TABLE. JSB .MVW DEF T4ISP NOP LDA T3ISP SET F.AF OF SYMBOL TO TABLE ADDR. JSB DAF.F LDA F.A,I SET F.NC=1. IOR B40 STA F.A,I LDA T1ISP IS THIS 'PCOUNT' ? CPA DPCNT RSS (YES) JMP ISP01 NO. DONE WITH THIS SYMBOL. * LDA F.A YES. ALLOCATE TEMP FOR ENTRY. STA T1ISP BUT FIRST, SAVE F.A . LDA INT ALLOCATE THE TEMP. JSB APT.F STA F.PCT LDA T1ISP RESTORE F.A STA F.A JMP ISP01 NOW DONE. * B17 OCT 17 B40 OCT 40 B777 OCT 777 B360 OCT 360 B7400 OCT 7400 B70K OCT 70000 B170K OCT 170000 DPCNT DEF .PCNT USED TO CHECK FOR PCOUNT. DTABL DEF TABLE DTBL1 DEF TABLE+1 TABLE BSS 15 MAX 7 SPECIFIC AT A TIME. K6 DEC 6 B10 OCT 10 SKP * ***************** * * IMPLICIT NONE * * ***************** SPC 1 * THE CHECKING FOR 'IMPLICIT NONE' SCANS THE NAMED PART OF THE * SYMBOL TABLE, AND COMPLAINS ABOUT SYMBOLS WHICH: * * 1) ARE NORMAL NAMED VARIABLES, ARRAYS, OR SUBPROGRAMS. * 2) ARE NOT INTRINSIC. * 3) ARE NOT SUBROUTINES. * 4) ARE NOT EXPLICITLY TYPED. * * START SYMBOL TABLE SCAN. * IMP01 LDA F.IMF IMPLICIT NONE ? SSA,RSS JMP EXIT NO. DON'T BOTHER. * CCA YES. CLEAR THE MESSAGE FLAG. STA T1IMP JSB GFA.F SET UP SCAN. IMP02 JSB GNA.F GET NEXT ITEM. SZA,RSS DONE ? JMP EXIT YES. GO EXIT. * LDA F.A,I EXPLICITLY TYPED ? AND B10 (IF NOT PROPER TYPE OF ENTRY, SZA THIS CHECK DOESN'T HURT.) JMP IMP02 YES. SKIP IT. * LDB F.A NO. SEE IF TEMP OR STMT #. ADB K2 LDA B,I FIRST WORD OF NAME. SSA TEMP ? JMP IMP02 YES. SKIP IT. * AND BM400 NO. GET FIRST CHAR. CPA B40K IS IT @ ? JMP IMP02 YES. STMT #, SKIP IT. * LDA F.A NO. NAME OF THIS MODULE ? LDB F.SFF AND IT'S A SUBROUTINE ? CPA F.SBF SZB RSS (NO. ERROR) JMP IMP02 YES. SKIP IT. * LDA F.A,I NO. GET USAGE. AND B600 CPA SUB IF SUBROUTINE, RSS MUST CHECK FURTHER. JMP IMP10 NO. UNTYPED VARIABLE/ARRAY! SKP * F.IU=SUB. CHECK COMMON BLOCK, SUBROUTINE, INTRINSIC. * LDA F.A,I GET F.AT AND B7000 CPA BCOMI COMMON LABEL ? (F.AT=BCOMI) JMP IMP02 YES. SKIP IT. * LDA F.A,I SUBROUTINE OR FUNCTION ? AND B20 SZA,RSS JMP IMP02 SUBROUTINE (OR EXTERNAL ONLY), SKIP. * LDA F.A,I GET F.NC AND B140 CPA B40 INTRINSIC ? JMP IMP02 YES. SKIP IT. * * UNTYPED NAME. COMPLAIN. * IMP10 LDA K87 WARNING 87. ISZ T1IMP HAVE WE PUT OUT THE MESSAGE YET ? RSS YES. NOT AGAIN. JSB WAR.F NO. PUT IT OUT. * JSB NAM.F COPY THE ITEM NAME. DEF IMMSG+1 TO HERE. LDA K4 PRINT MESSAGE: 4 WORDS, LDB DIMSG FROM HERE. JSB PCC.F DO IT. JMP IMP02 GO FOR MORE. * T1IMP NOP INDICATOR WHETHER MSG DONE YET. B20 OCT 20 B140 OCT 140 SUB OCT 200 F.IU=SUB B600 OCT 600 F.IU MASK. B7000 OCT 7000 F.AT MASK. BCOMI EQU B7000 F.AT=BCOMI B40K BYT 100,0 '@',0 BM400 OCT 177400 K87 DEC 87 DIMSG DEF IMMSG ADDR OF MESSAGE. IMMSG ASC 4, MESSAGE BUFFER. SPC 2 * SEGMENT EXIT. * EXIT CLA CLEAR OUT THE LOCAL ERROR RECOVERY. STA F.EQE CCA WRITE (-1) TO END PASS FILE. JSB WS1.F JSB ES1.F FLUSH LAST PASS FILE RECORD. JSB EOF.C WRITE EOF ON 1ST PASS FILE. DEF C.SC1 JMP PASER * JSB RWN.C REWIND 1ST PASS FILE. DEF C.SC1 JMP PASER * JSB RWN.C REWIND CARD FILE: DEF C.SC0 IT BECOMES 2ND PASS FILE. JMP PASER * LDB K6 GO TO SEGMENT 6. JMP F.SEG * PASER LDA K99 ACCESS ERROR ON SCRATCH FILE. JMP F.ABT * K99 DEC 99 * END F4.2