ASMB,Q,C HED ** FTN4 COMPILER (SEG: F4.4) INITIALIZE THE COMPILER ** NAM F4.4,5 92060-16098 REV.2026 800423 * ***************************************** * FORTRAN-4 COMPILER OVERLAY 4 ***************************************** * * THIS OVERLAY SETS UP THE SYMBOL TABLE AND ENTERS THE FIXED ENTRIES * IT ALSO INITIALIZES THE COMPILER AND READS THE FTN STATEMENT IF * SETTING UP FOR THE FIRST MODULE IN THIS COMPILE. * *************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1977. 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: F4.4, PART OF FTN4 COMPILER. * * SOURCE: 92060-18098 * * RELOC: 92060-16098 * * PGMR: BILL GIBBONS. * *************************************************************** * * 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..DP BASE OF SYMBOL TABLE EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AT. SUBSCRIPT INFO FLAG EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTION WORD EXT F.D DO TABLE POINTER EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DO LWAM - END OF DO TABLE EXT F.DP BASE OF USER SYMBOL TABLE EXT F.DTY IMPLICIT TYPE TABLE EXT F.E EQUIVALENCE TABLE POINTER EXT F.EMA F.A OF EMA EXT ENTRY, WINDOW SIZE EXT F.EQE EQUVALENCE ERROR FLAG EXT F.EQF EQUIVALENCE FLAG EXT F.ER0 'RX' OF ERRX LIB ERROR ROUTINE EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERN ERROR ARRAY EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.INT TEMP VARIABLE ARRAY EXT F.HDL LENGTH OF HEAD MESSAGE EXT F.LLT ADDRESS OF LINE LOCATION TABLE (SET BY INIT) EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSP LAST OPERATION FLAG EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NXN NO INPUT FLAG EXT F.PAK PACK BUFFER WORD EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SEG LOAD A NEW SEGMENT EXT F.SID STATEMEXT ID PHASE FLAG EXT F.STA FLAG THAT IS ZERO UNTIL THE FTN STATEMEXT IS READ EXT F.TC NEXT CHARACTER EXT F.TIM TIME ARRAY ADDRESS IN HEAD * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT BOM.F DISASTOR ERROR REPORT (NO RETURN) EXT CDI.F CLEAR IDI ROUTINE EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT ER.F ERROR PRINT SUBROUTINE EXT IA.F INPUT (A) CHARACTERS SUBROUTINE EXT IC.F GET NEXT CHARACTER EXT ICH.F GET NEXT NON BLANK CHAR. AND TYPE IT EXT IDN.F INPUT DO NOT ASSIGN (GET NEXT OPERAND) EXT IN2.F INIT FOR OA.F MODULE EXT IN3.F INIT FOR ENX.F MODULE EXT IN4.F INIT FOR FA.F MODULE EXT IN5.F INIT FOR EX.F MODULE EXT IN6.F INIT FOR IC.F MODULE EXT IN7.F INIT FOR IDN.F MODULE EXT INM.F INPUT NAME EXT MCC.F RESET TO FIRST COLUMN OF STATEMEXT EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT NEW.F SUB TO CLEAR TEMPS FOR A NEW MODULE EXT NTI.F MOVE NID TO F.IDI (PACKS) EXT SNC.F START NEXT CARD SUBROUTINE EXT TS.F TAG SUBPROGRAM SUB. * * COMPILER LIBRARY ENTS * EXT SUP.C COMP LIB SUPER EXT C.BIN BINARY FCB EXT RWN.C REWIND ROUTINE EXT C.SAU INPUT FCB EXT OPN.C OPEN ROUTINE EXT EOF.C EOF WRITE ROUTINE EXT END.C END ROUTINE EXT C.LST LIST FCB EXT GMM.C GET MAIN MEMORY EXT END.C TERMINATE EXT PRM.C GET PRAMETER EXT C.SC1 SCRATCH FILE FCB EXT C.SC0 SCRATCH FILE FCB EXT C.TTY TTY FCB EXT WRT.C WRITE TO FCB ROUTINE * * FTN UNIQUE SUB * EXT SEG.F GET SEGMENT ID SUB * * LIBRARY ROUTINES * * EXT .MVW MOVE WORDS MACRO EXT Z$DBL 3/4 WORD DEFAULT OPTION * A EQU 0 B EQU 1 K4 DEC 4 SEGMENT NUMBER SUP * * WE BEGIN ************* * BEGIN LDB F.STA THE COMPILER LIB. FIRST ENTRY? CCA SET F.CC TO NOT PRINT STA F.CC CARD ON ERROR SZB F.STA =0 IF FIRST JMP NEW NO JUST A NEW MODULE * STB BOM.F CLEAR THE DISASTER FLAG LDA DFTM MAKE SURE THE DEF RAL,CLE,SLA,ERA IS DIRECT LDA A,I STA DFTM DLD F.IDI RESTORE THE REG'S AND JSB SUP.C CALL THE COMP LIB SUPER DFTM DEF F.TIM ADDRESS OF TIME ARRAY NOP ADB K10 ADD LENGTH OF PREAMBLE TO TIME LENGTH STB F.HDL SET HEAD LENGTH FOR MAIN * LDA PRMPT GET PROMPT CHAR. ']' JSB OPN.C OPEN THE INPUT FILE DEF C.SAU LIST FCB JMP INERR OPEN TRM * JSB OPN.C OPEN THE LIST DEVICE DEF C.LST JMP TRML IF ERROR JUST EXIT UNL IFN LST JSB PRM.C DEF K4 STA DBLU SZA,RSS JMP XDBUG ADA N35 SSA,RSS JMP XDBUG JSB DBUG EXT DBUG DEF *+2 DEF DBLU * XDBUG EQU * XIF LST CLB WANT A RELOCATABLE JSB OPN.C OPEN THE BINARY OUTPUT FILE DEF C.BIN JMP BERR * BERX JSB OPN.C OPEN THE SCRATCH FILE DEF C.SC1 JMP ERROR * JSB OPN.C OPEN THE CARD FILE DEF C.SC0 JMP ERROR * CCB NEW SSB,RSS IF TERMINATE CALL JMP TRM GO TO TERM CODE * JSB GMM.C GET MAIN MENORY BOUNDS DEF K6 SIX SEGMENTS (NOW) DEF LSE.F NAME OF LOCAL SEG. NAME FINDER * STB F.DO SET TOP OF SYMBOL TABLE STA F.CRB SET ADDRESS OF CARD BUFFER JSB GMM.C NOW GET THE END OF SEGMENT 2 (IT DEF K1 DOESN'T USE THE CARD BUFFER) DEF LS2.F ROUTINE TO GET NAME OF SEGMENT 2 ONLY STA L..DP TENATIVE BASE OF SYMBOL TABLE LDB F.CRB SEE IF CARD ADB K98 BUFFER EXTENDS BEYOND CMA,INA IT ADA B IF SO SSA,RSS SET STB L..DP NEW BASE OF SYMBOL TABLE ABOVE THE CARD BUFFER LDA L..DP ADA LFIX CACULATE START OF USER TABLE ADA N1 STA L.DP USER DATA POOL CMA MAKE SURE THERE IS ROOM ADA F.DO IF NEGATIVE RESULT THEN NO ROOM FOR FIX-EXT SSA TABLE SO QUIT ON SYMBOL TABLE OVERFLOW JMP ERR3 THERE IS ROOM * LDA DK4 GET THE SIZE OF THIS SEGMENT STA DSNO AND JSB GMM.C DEF K1 DEF LS2.F STA T1 SAVE IT ADA LFIX CHECK IF ROOM ABOVE ADA K8 FOR FIX-EXT-TBL ADA K98 KEEP ROOM FOR CARD BUFFER TOO CMA ADA F.DO SSA IF NO ROOM JMP ERR3 ABORT * LDB F.DO SET UP TO MOVE ADB KM8 FIX-EXT-TBL ADB MLFIX TO HIGH MEMORY STB F..DP ADB LFIX SET USER BASE FOR THIS LOCATION ADA N1 STA F.DP FOR NOW SEG F4.0 MOVES IT DOWN LDA F..DP SET ADA KM98 CARD BUFFER STA F.CRB LOCATION CLB NOW CLEAR THE CARD BUFFER STB A,I PLANT A ZERO INB AND ADB A JSB .MVW WATCH IT GROW DEF K98 (IT SLOPS OVER BY ONE BUT NOP WE DON'T HAVE THE FIX-EXT-TABLE THERE YET LDA F.CRB NOW PLANT THE REQUIRED BLANKS ADA K2 FOR BETWEEN THE LINE NUMBER LDB BLNK STB A,I ADA K49 DO FOR BOTH BUFFERS STB A,I JMP NEWMD GO FINISH UP * ERR3 LDA K3 03 SYMBOL TABLE OVERFLOW JMP ABT REPORT ERROR AND EXIT * K2 DEC 2 T1 NOP MLFIX ABS DFIX+1-LFIX NEGATIVE OF FIX-EXT TBL LENGTH L..DP NOP L.DP NOP DK4 DEF K4 UNL IFN LST DBLU NOP XIF LST K3 DEC 3 K6 DEC 6 K10 DEC 10 K5 DEC 5 N1 DEC -1 RSAVE NOP NOLIN NOP NUMBER OF LINES/PAGE K98 DEC 98 KM98 DEC -98 KM8 DEC -8 K49 DEC 49 * NEWMD JSB NEW.F GO TO MAIN TO INITIALIZE DLD F.ERN+1 GET THE ERROR SUM ADA F.ERF ADD TOTALS FOR THIS MODULE ADB F.ERF+1 DST F.ERN+1 CLA CLEAR THE COUNTERS FOR CLB THE NEW MODULE DST F.ERF CLA LDB F.CRB SET TOP OF BUFFER ADDRESS FOR DST F.LLT SET EQUV LINE LOCATION TABLE JSB RWN.C REWIND THE SCRATCH FILE DEF C.SC1 JMP ERROR OPEN ERROR LDA F.STA GET STATUS FLAG SZA IF NOT FIRST MODULE JMP NOFTN SKIP READING THE FTN STATEMENT * JSB PRM.C GET THE NO LINES/PAGE DEF K4 SZA,RSS IF ZERO LDA K55 USE 55 LINES/ PAGE INA COMPENSATE FOR CALCULATION METHOD STA NOLIN GET NUMBER TO A FOR INITIALIZE ADA KN10 IF LESS THAN CLB,CCE TEN SSA STB NOLIN USE INFINITE SIZE PAGE * JSB INIT INITIALIZE ALL THE FLAGS * * READ "FTN/FTN4,B,L,A/M,T" * * * ********************* * * COMPILER ENTRANCE * * ********************* SPC 1 * WHERE IN WE BUILD THE OPTION CONTROL WORD FROM THE 'FTN' CONTROL * STATEMENT. * * THE FORMAT OF THE WORD IS (ONE BIT PER LETTER LEAST BIT IS ZERO): * * QXY EFD BCT AML * * Q = LIST LOAD ADDRESS OF EACH STATEMENT. * X = USE 48 BIT DOUBLE PRECISION (VS 64-BIT) * Y = USE 64 BIT DOUBLE PRECISION (VS 48-BIT) * E = USE .EMAP ARRAY CALLING SEQUENCE (VS ..MAP) * F = DO FULL FORM FEEDS EVEN IF A TTY. * D = COMPILE LINES THAT START WITH 'D' (VS THEIR COMMENTS) * B = SET INTERNALLY IF BINARY OUTPUT FILE IS PRESENT * C = PRODUCE A CROSS REFERENCE * T = PRODUCE A SYMBOL TABLE LISTING * A = PRODUCE AN ASSEMBLY LISTING * M = PRODUCE A MIXED LISTING * L = PRODUCE A SOURCE LISTING * JSB IC.F FORCE A CARD READ IN CLA,INA SET TO GET FIRST STA F.CC CHAR CCA STA F.STA SET FTN STMNT. READ FLAG STA F.EQF NOT PROCESSING EQUIV STA F.NXN SET NO INPUT FLAG. JSB IDN.F INPUT DO NOT ASSIGN JSB NTI.F MOVE NID TO F.IDI DLD F.IDI CPA "FT" 'FT' JMP CME04 CME02 CLA,INA FTN4 CONTROL CARD MISSING JMP F.ABT EXIT TRANSLATOR. SPC 1 CME04 LDA B GET NEXT TWO CHAR. ALF,ALF TO LOW A AND B377 ISOLATE CPA "N" 'N' JMP CME06 JMP CME02 FTN CONTROL CARD MISSING SPC 1 CME05 JSB ICH.F NEXT CHARACTER. CME06 LDB F.TC CPB B15 JMP PCONT CPB B54 ',' RSS JMP CME08 ERROR IN FTN CARD JSB ICH.F INPUT CHARACTER LDB A SAVE CHARACTER IN (B) JSB CCO.F CONVERT CONTROL OPTION. SZA,RSS FOUND ? JMP CME10 NO. IOR NLTEM YES. SET THE OPTION(S) STA NLTEM AND B3000 X & Y OPTIONS. CPA B3000 BOTH SET NOW ? JMP CME08 YES, ERROR. LDA B THE OPTION BY ITSELF. IOR DUPS REPEATED ? CPA DUPS JMP CME08 YES, ERROR. STA DUPS JMP CME05 GO FOR MORE. CME10 LDB OPTSE B = CHAR. CPB B15 JMP PCONT ENDS ON COMMA. ADB BM61 CHECK FOR DIGIT. SW.N SSB JMP CME08 ADB KM9. SSB,RSS JMP CME08 NONE OF THE ABOVE. ADB ERR0 DIGIT; BUILD ERR ROUTINE NAME STB F.ER0 CLB STB SW.N JMP CME05 SPC 1 CME08 LDA K2 JMP F.ABT ERROR IN FTN CONTROL CARD SPC 1 PCONT CLA END OF CTRL STMT. STA F.NXN LDA NLTEM X OR Y SELECTED ? AND B3000 SZA JMP PCON1 YES. LDB Z.DBL NO... Y DEFAULT ? CPB K4 LDA B1000 YES, SET Y. PCON1 STA NEWOP IOR NLTEM SET THE STA F.CCW CONTROL WORD SPC 1 JSB IN2.F INITIALIZE OA.F AGAIN CLA JSB IN7.F GET IDN TO PICK THE 'Y' BIT JSB PRM.C GET THE OPTIONAL CONTROL PRAMS DEF K5 STB AD SET THE PARAMETER ADDRESS LDA KM6 SET COUNTER FOR NO. OF PRAMS STA COUNT CLOP LDB AD START LOOP CLE,ERB CONVERT TO A WORD ADDRESS LDA B,I GET THE WORD SEZ,RSS ROTATE IF ALF,ALF NEEDED AND B377 ISOLATE THE WORD SZA,RSS ANY ZERO'S INVALIDATE THE WHOLE THING JMP NIXOP SO BAIL OUT * LDB A PUT CHAR TO B JSB CCO.F CONVERT CONTROL OPTION. AND KK01 DISALLOW X,Y. IOR NEWOP STA NEWOP SET DOWN THE NEW WORD ISZ AD STEP THE ADDRESS ISZ COUNT AND THE COUNT JMP CLOP DO THE NEXT CHAR. * STA F.CCW IF WE GET HERE THEN SET THE NEW CONTROL WORD NIXOP LDA DNIX SET F.EQE TO POINT TO HERE INCASE STA F.EQE OF ERROR 90 (FIRST STMT. IS A CONTINUE) CLE CLEAR E FOR IN6.F (NOT A NEW MODULE) JSB INIT SET UP TO CHECK FOR CONTINUED LINES JSB SNC.F DISMISS THE FTN STATEMENT CLA CLEAR THE ERROR SWITCH STA F.EQE SO OTHER ERRORS DO STD. THING LDA F.CCW MODIFY THE CONTROL WORD IOR B40 ALWAYS DO BINARY LDB BFLG UNLESS SZB,RSS NO XOR B40 FILE GIVEN FOR OUTPUT STA F.CCW SET THE FLAG WORD * JMP PPNM FINISH SETTING UP * DNIX DEF NIXOP * ERROR LDA K99 ERROR ON PASS FILE WRITE IT JMP ABT IS AN ERROR 99 * BERR CPA KM201 IF NO BINARY FILE JMP NOBIN GO SET IT UP * LDA K97 OPEN ERROR ON BINARY FILE JMP ABT * NOBIN CLA CLEAR THE STA BFLG BINARY FLAG JMP BERX CONTINUE THE SET UP SPC 2 CCO.F NOP CONVERT CONTROL OPTIONS. LDA DOPTS SET UP POINTER. STA T1CME STB OPTSE USE ORIGINAL VALUE TO END TABLE. CLA,INA START WITH L=1. CCO01 CPB T1CME,I THIS ONE ? JMP CCO02 YUP. RAL NO. TRY NEXT. ISZ T1CME JMP CCO01 CCO02 LDB A SAVE ACTUAL OPTION. CPA K2 M ? IOR B14 YES, SET A & T. CPA K4 A ? IOR B10 YES, SET T. CPA B4000 Q ? IOR K1 YES, SET L. CPA OPTSX NOT FOUND ? CLA IF SO, RETURN A=0. JMP CCO.F,I EXIT. A=OPTIONS, B=SINGLE OPTION. * DOPTS DEF *+1 OPTIONS TABLE. OCT 114 L = 1 OCT 115 M = 2 OCT 101 A = 4 OCT 124 T = 10 OCT 103 C = 20 OCT 102 B = 40 OCT 104 D = 100 OCT 106 F = 200 OCT 105 E = 400 OCT 131 Y = 1000 OCT 130 X = 2000 OCT 121 Q = 4000 OPTSE BSS 1 MISSING = 10000 OPTSX OCT 10000 * N35 DEC -35 ************DBUG ONLY************************** PRMPT ASC 1,]_ PROMPT WITH ']' NLTEM NOP T1CME NOP TEMP FOR CME & CCO. DUPS NOP FOR CATCHING DUPLICATES. BM61 OCT -61 KM9. DEC -9 "N" OCT 116 'N' "FT" ASC 1,FT ERR0 OCT 51072 ASC 1,R0 +10 Z.DBL DEF Z$DBL+0 3/4 WORD DEFAULT. KM6 DEC -6 AD NOP COUNT NOP B377 OCT 377 NEWOP NOP B15 OCT 15 B14 OCT 14 B54 OCT 54 ',' K8 DEC 8 B10 EQU K8 K55 DEC 55 KN10 DEC -10 K99 DEC 99 K67 DEC 67 KM201 DEC -201 B40 OCT 40 B1000 OCT 1000 B3000 OCT 3000 B4000 OCT 4000 KK01 OCT 174777 BFLG OCT 40 BINARY FLAG (SET FOR BINARY) K97 DEC 97 DMAN DEF NOFTN ERROR RETURN ON INPUT ERROR * INIT NOP CALL ALL THE INIT SUBS IN THE MAIN LDA NOLIN PASS THE LINE COUNT LDB F.CRB AND THE CARD BUFFER ADDRESS JSB IN6.F TO IC.F CCA SET THE STA F.EQF NOT PROCESSING EQU'S FLAG CLA JSB IN2.F OA.F CLA JSB IN3.F ENX.F CLA JSB IN4.F FA.F CLA JSB IN5.F EX.F CLA JSB IN7.F IDN.F JMP INIT,I RETURN * * NOFTN CLE JSB INIT CALL INIT SUBS LDA MFLC MOVE "FTN. " JSB MPN.F TO NBUF,ERBF,HEADL LDA DMAN SET UP ERROR RETURN STA F.EQE FOR POSSIBLE INPUT ERROR JSB SNC.F TEST FOR END$ CARD CLA,INA STA F.CC SET CC=1 STA F.NXN SET NO INPUT FLAG LDA K2 JSB IA.F INPUT 2 CHARS. LDA F.PAK CPA EN 'EN' ? RSS YES JMP MAIN4 NO * LDA K2 JSB IA.F INPUT 2 CHARS. LDA F.PAK CPA EN+1 'D$' ? JMP TRM YES. NO MORE; WRAP IT UP. * MAIN4 CLA STA F.EQE CLEAR THE ERROR RETURN FLAG STA F.NXN RESET NO INPUT FLAG STA SUBFN CLEAR CARD INPUT FOR PROGRAM. INA STA F.CC SET CC=1 STA F.SID AND THE SCAN FLAG SKP * ************************* * * POSSIBLE PROGRAM NAME * * ************************* SPC 1 PPNM JSB IN4.F MAKE SURE FA.F GETS THE Y BIT LDA F.ER0 STA ER.R0 NAME OF ERROR ROUTINE. LDA F.CCW Y OPTION ? AND B1000 SZA,RSS JMP PPNM1 NO. LDA .DSIN YES, ADD ERROR RETURNS FOR IOR B60 .SIN, .COS, & .ATN2 STA .DSIN LDA .DCOS IOR B60 STA .DCOS LDA .DAT2 IOR B60 STA .DAT2 STA .DAT3 PPNM1 LDB F..DP SET UP TO MOVE IN THE LDA DFIX FIX-EXTERNAL SYMBOLES JSB .MVW USE MOVE WORDS DEF LFIX LENGTH OF TABLE NOP LDB F.DNB GET ADDRESS OF NAM RECORD BUFFER LDA PRNM GET ADDRESS OF PROTO NAM RECORD JSB .MVW MOVE PROTO TO BUFFER DEF K17. 17 WORDS NOP LDA DTYP SET UP THE IMPLICIT TYPE LDB F.DTY TABLE JSB .MVW IN F.IDN DEF K13 IT IS 13 WORDS LONG NOP LDA MFLC GET THE DEFAULT NAME JSB MPN.F AND REINSERT IT IN THE NAM BUFFER LDB INITB CLEAR RBL,CLE,SLB,ERB LDB B,I CLA STA B,I LDA F.AT.-1 GET SIZE OF AREA STA RSAVE SAVE IT STB A INB JSB .MVW CLEAR THE AREA DEF RSAVE NOP JSB CDI.F SET F.IDI TO 0. LDA PPNK3 MOVE FROM KK36 LDB PPNK4 TO F.INT RBL,CLE,SLB,ERB REMOVE POSSIBLE INDIRECT LDB B,I JSB .MVW INITIALIZE TEMP CELL START LOCS. DEF K7 NOP LDA F..DP DATA POOL START LOCATION ADA LFIX STA F.LO END OF ASSI TABLE LOC. +1 STA F.S2B STA F.S2T F.S2T=F.S2B=LO STA F.LSF F.LSF NON-0 (EXPECT 1ST STATEMNT) STA F.LSP ADA N1 COMPUTE START OF USER SYMBOL TABLE STA F.DP AND SET IT LDA F.DO LAST AVAILABLE MEMORY LOCATION STA F.E STA F.D STA F.S1B STA F.S1T F.S1T=F.S1B=D CCA STA F.EQF F.EQF=-1 STA F.EMA NO EMA IS -1 SUBFN JSB IC.F READ THE "PROGRAM" STATEMENT. CLA,INA SET F.CC STA F.CC TO 1 STA F.NXN SET NO INPUT FLAG JSB IC.F GET THE FIRST CHAR. IN THE LINE CPA "$" IS IT A CONTROL STMT.? JMP EMA YES GO TEST FOR EMA * NOEMA LDA L..DP PASS THE ACTUAL S.T. BASE TO F4.0 STA F.IDI IN F.IDI CLB GO TO SEGMENT STB F.NXN CLEAR THE NO INPUT FLAG CLA,INA RESET STA F.CC THE COLUMN COUNTER JMP F.SEG 0. * MFLC DEF KK32 KK32 ASC 3,FTN. DEFAULT OBJ PROG NAME PPNK3 DEF KK36 PPNK4 DEF F.INT INITB DEF F.AT. INIT. TO 0 AREA BEGIN ADDR. EN ASC 2,END$ * PRNM DEF *+1 PROTO NAM RECORD K17. DEC 17,0,0,0,0,0,0,0,0,3,99,0,0,0,0,0,0 K13 DEC 13 B60 OCT 60 DTYP DEF *+1 BLNK ASC 4, BLANKS HAPPEN TO BE REAL (A-H) OCT 10020,10020,10020 THESE ARE INTEGER (I-N) ASC 6, MORE REALS (M-Z) K1 DEC 1 K7 DEC 7 KK36 OCT -1000,-2000,-3000,-4000,-5000,-6000,-7000 K14 DEC 14 K20 DEC 20 K25 DEC 25 F.CRB NOP CARD BUFFER ADDRESS "$" OCT 44 ** * LSE.F NOP LOCAL SEGMENT NAME FINDER LDA LSE.F,I TO FIND ALL BUT ISZ LSE.F SEGMENT 2 LDA A,I GET NUMBER OF REQUESTED SEGMENT CPA K4 IGNOR 4 (CURRENT) CLA CPA K2 AND 2 CLA SET TO 0 STA LS2.F SET FOR CALL JSB SEG.F CALL THE EXTERNAL NAME FINDER DEF LS2.F JMP LSE.F,I RETURN * * LS2.F NOP ROUTINE TO FINE NAME OF SEGMENT 2 ONLY JSB SEG.F USE EXTERNAL NAME FINDER DSNO DEF K2 PASS 2 AT ALL TIMES ISZ LS2.F JMP LS2.F,I RETURN * INERR JSB OPN.C ERROR ON SOURCE FILE TRY LIST DEF C.LST JMP TRMSL IF PROBLEMS SKIP ON OUT * LDA K67 INPUT FILE PROBLEMS ABT JSB BOM.F DISASTOR SEND THE MESSAGE TRM LDA F.CCW CHECK IF BINARY FILE AND B40 IF SO SZA,RSS THEN JMP NXBIN * JSB EOF.C MUST EOF ON IT DEF C.BIN JMP EOFBE ERROR REPORT IT * NXBIN DLD F.ERN+1 ACCUMULATE THE ERROR TOTALS ADA F.ERF ADB F.ERF+1 STA ERMX SET THE NUMBER OF ERRORS STB TOTER AND THE TOTAL ERROR COUNT LDA BOM.F DISASTOR EXIT? SZA SKIP IF NOT CLA,INA SET DISASTOR COUNT OTHERWISE STA DISCT PUT COUNT IN MATRIX ADA ERMX SUBTRACT CMA,INA THE ERRORS FROM THE TOTAL COUNT ADA B TO GET THE WARNINGS STA WAR SET THE # OF WARNINGS JSB EOF.C CLOSE THE LIST FILE DEF C.LST JMP EOFLI IF ERROR REPORT IT * TRM1 CLA CLEAR CLB THE ERROR COUNTERS DST F.ERN+1 FOR POSSIBLE RE RUN STA F.STA ALSO THE BEEN HERE FLAG LDA DISCT GET THE DISASTER COUNT JSB ASC.F CONVERT IT CPA "00" IF NONE LDA "NO" USE NO STA ENMES+6 SET IN THE MESSAGE DLD "NOX" DST ENMES+12 DST ENMES+18 LDA ERMX GET THE ERROR COUNT SZA,RSS IF NONE JMP EXIT2 SKIP * JSB ASC.F ELSE CONVERT IT STA ENMES+13 SET STB ENMES+12 IN THE MESSAGE EXIT2 LDA WAR GET THE WARNNING COUNT SZA,RSS IF NONE JMP EXIT3 SKIP * JSB ASC.F CONVERT IT STA ENMES+19 STB ENMES+18 EXIT3 JSB WRT.C SEND THE NEWS DEF C.TTY TO THE TTY DEF ENMES DEF K25 NOP IGNOR ERRORS EXIT JSB END.C END IT ALL DEF TOTER SEND THE ERROR MATRIC JMP EXIT TRY AGAIN IF CLOSE ERROR * TOTER NOP DISCT NOP ERROR MATRIX ERMX NOP WAR NOP DEC 2026 DATE CODE * TRML LDA K14 GET COUNT FOR MESSAGE RSS SKIP DOUBLE FAILURE TRMSL LDA K20 BOTH SOURCE AND LIST FAILED TO OPEN CLB CLEAR THE STB ERMX ERROR STB WAR AND WARNING COUNTS STB TOTER