ASMB,Q,C HED ** 16K FTN4 COMPILER (SEG: F4.0) SPECIFICATION STATEMENTS ** NAM F4.0,5 92060-16094 REV.2026 800423 * ***************************************** * FORTRAN-4 COMPILER OVERLAY 0 ***************************************** * * THIS OVERLAY PROCESSES COMMON, DIMENSION, AND * EQUIVALENCE STATEMENTS, PROGRAM AND DATA STATEMENTS, * AND TYPE DECLARATIONS. * *************************************************************** * (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.0, PART OF FTN4 COMPILER. * * SOURCE: 92060-18094 * * RELOC: 92060-16094 * * 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.AF ADDRESS FIELD CURREXT F.A EXT F.ARF NO. OF SUB. FUN. ARGUMEXTS 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.CIN CURREXT CI BUFFER LINE NUMBER EXT F.CLN INPUT ITEM CURREXT LINE # EXT F.CSZ COMMON SIZE EXT F.D DO TABLE POINTER EXT F.D0 ARRAY ELEMEXT SIZE EXT F.D1 DIMENSION 1 EXT F.D2 DIMENSION 2 EXT F.DCF DIM, COM FLAG EXT F.DEF DATA EXISTS FLAG EXT F.DID ADDRESS OF F.IDI EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.DNI ADDRESS OF NID 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.EFG E - FLAG - SET IF SUBSCRIPT IS DUMMY EXT F.EMA F.A OF EMA EXT ENTRY, WINDOW SIZE EXT F.EMS EMA SIZE DOUBLE WORD, (INTERNAL FORMAT) EXT F.EQE EQUVALENCE ERROR FLAG EXT F.EQF EQUIVALENCE FLAG EXT F.EXF EXTERNAL STATEMEXT FLAG EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.INT TEMP VARIABLE ARRAY EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.L # WORDS ON STACK 2 EXT F.LLT ADDRESS OF LINE LOCATION TABLE (SET BY INIT) EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LPR ( LOC OF EQUIVALENCE GROUP EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.MFL TYPE STMT. MODE FLAG EXT F.ND NUMBER OF DIMENSIONS EXT F.NEQ # OF EQUIVALENCE GROUPS EXT F.NT NAME TAG 0= VAR, 1=CONSTANT. EXT F.NW NO. WORDS THIS TABLE F.A EXTRY. EXT F.OFE DATA POOL OVERFLOW ERROR EXTRY. EXT F.OPF OUTPUT PACK FLAG EXT F.PAK PACK BUFFER WORD EXT F.RPL PROGRAM LOCATION COUNTER EXT F.RPR ) LOC OF EQUIVALENCE GROUP EXT F.S02 RETURN FORM RCOM F.1 EXT F.S03 LOAD F.1 AND PASS CONTROL EXT F.S1T TOP OF STACK 1 EXT F.S2B BOTTOM OF STACK 2 EXT F.S2T TOP OF STACK 2 EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SCC SAVE F.CC 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'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT BNI.F CLEAR NID TO BLANKS EXT CRP.F CROSS REF PAIR SUB. EXT CRT.F TEST FOR CARRAGE RETURN EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (AT) EXT DIM.F DEFIND (F.IM) EXT DIU.F DEFINE (F.IU) EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT EXN.F EXAMINE NEXT CHARACTER EXT FA.F FETCH ASSIGNS EXT FXC.F CHECK IF SUB. IN FIX-EXT TABLE EXT GNA.F GET NEXT SYMBOL TABLE EXTRY 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 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 MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) 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 OAI.F OUTPUT ABS. INSTRUCTION EXT OC.F OUTPUT CONSTANT EXT OLR.F OUTPUT LOAD ADDRESS EXT OW.F OUTPUT WORD EXT PAK.F PACK SUBROUTINE EXT RP.F INPUT ')' EXT SCC.F SAVE F.CC SUBROUTINE 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) * * ENT F.COM ENT F.CPX ENT F.DAT ENT F.DBL ENT F.DIM ENT F.EMP ENT F.EQU ENT F.EXT ENT F.FUN ENT F.IMP IMPLICIT PROCESSOR ENT F.INP ENT F.LOG ENT F.PRO ENT F.RCO ENT F.REA ENT F.SUB ENT F.BLK SPC 1 * * * * * * COMPILER LIB. ROUTINES * EXT GMS.C GET SEGMENT FREE MEMORY BOUNDS * * * 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 F.DNB ADA K9 STA PROK1 LDA F.SLF IF BACK IN TO DO CPA K2 A DATA STATEMENT JMP F.DAT JUST GO DO IT * LDA F..DP SET UP TO MOVE THE ADA KM98 ADJUST FOR CARD BUFFER STA FL.F SAVE IT FOR A WHILE CMA,INA SYMBOL TABLE DOWN TO ADA F.LO ITS FINAL RESTING PLACE STA F4.0 SAVE ITS CURRENT SIZE LDA FL.F CURRENT LOCATION TO A LDB F.IDI FINAL LOCATION FROM F4.4 TO B ADB KM98 ADJUST FOR CARD BUFFER STB FL.F SAVE IT JSB .MVW DO MOVE WORDS DEF F4.0 NUMBER OF WORDS NOP LDA F..DP NOW COMPUTE CMA,INA THE DISTANCE ADA F.IDI MOVED LDB F..DP AND ADJUST ADB A THE POINTERS STB F..DP FOR THE NEW LOCATION LDB F.LO ADB A STB F.LO STB F.S2B STB F.S2T STACK POINTERS TOO ADA F.DP ADJUST USER ORGIN ALSO STA F.DP DONE SO CONTINUE WITH REAL WORD CCA,CLE NOW TELL LDB FL.F WHERE THE CARD BUFFER IS JSB IN6.F TO THE ONE WHO MUST KNOW * JSB GMS.C GET START OF FREE MEMORY STA F.LLT AND SET FOR EQU X-REF. JMP F.BGN BACK TO READ THE FIRST CARD SPC 1 K9 DEC 9 KM98 DEC -98 PROK1 NOP PROGRAM TYPE CODE POINTER SPC 2 * ************** * * FETCH LINK * * ************** SPC 1 FL.F NOP STB F.A LDA B,I AND KK04 CPA ARR INB,RSS IU(F.A)=ARR RSS LDB B,I (B)=GF(F.A) XOR F.A,I GET THE AND B7000 AT FIELD CPA BCOM IF A BLOCK COMMON INB,RSS ELEMENT RSS INDEX ONE LDB B,I MORE LEVEL INB LDA B,I STA NXL NXL=GF(B) JMP FL.F,I SPC 1 NXL BSS 1 NEXT LINK LOCATION KK04 OCT 600 EXTRACT F.IU FIELD B7000 OCT 7000 EXTRACT F.AT FIELD. SKP * ************ * * EXTERNAL * * ************ SPC 1 F.EXT CLA,INA STA F.EXF SET EXT FLAG JSB INM.F INPUT NAME LDB F.AT DUMMY ? CPB DUM RSS JMP EXT01 NO. LDA F.AF,I EMA DUMMY ? AND B7000 LDB A LDA K22 CPB BCOMI JSB ER.F YES, ERROR 22. EXT01 JSB TS.F TAG SUBPROGRAM SPC 1 * ***************** * * , OR C/R TEST * * ***************** SPC 1 CCRT CLB STB F.LSF CLEAR THE EXPECT FIRST STMT. FLAG STB F.EFG CLEAR E FLAG LDA F.TC CPA B54 ',' ? JMP F.SPS,I YES. MORE TO PROCESS * CPA B57 IF A '/' JMP CCRT1 GO TEST IF COMMON STMT. * CCRT0 STB F.EXF CLEAR EXTERNAL FLAG JMP CRT.F C/R TEST SPC 1 CCRT1 LDB F.SPS GET COMMON FLAG CPB COMK1 IF COMMON JMP COM04 GO PROCESS NEW LABEL * JMP CCRT0 ELSE IT IS AN ERROR * K22 DEC 22 B54 OCT 54 SPC 2 * ****************** * * EXCHANGE LINKS * * ****************** SPC 1 * EXCHANGE AF(F.A) & AF(F) SPC 1 EL.F NOP LDA F.A STA T1EL LDB F OLD LINK ADDRESS TO B JSB FL.F FETCH LINK STB T1LF LINK FIELD LDB T1EL SWAP POINTERS STA T1EL JSB FL.F FETCH LINK STA T1LF,I SET CURRENT IN OLD LDA T1EL AND OLD IN STA B,I CURRENT JMP EL.F,I SPC 1 T1EL BSS 1 T1LF BSS 1 F BSS 1 OLD LINK SPC 2 * ************ * * IMPLICIT * * ************ * F.IMP JSB ICH.F GET THE TYPE FOLLOWING THE 'IMPLICIT' LDB KM5 FIVE POSIBILITIES STB T0IMP SET THE COUNTER LDB DTBL GET THE TABLE ADDRESS IMP01 CPA B,I THIS THE TYPE? JMP IMP02 YOU BETCHA GO DO IT * INB NOPE STEP THE ADDRESS ISZ T0IMP END OF LIST? JMP IMP01 NOPE TRY NEXT ENTRY * LDA K10 YES YOU RUMMY WE DON'T HAVE THIS TYPE JSB ER.F B-Y-E * KM5 DEC -5 B55 OCT 55 * IMP02 ADB K5 INDEX INTO THE DEF TABLE LDB B,I GET ADDRESS OF THE STRING STB T0IMP AND SAVE IT LDA B,I GET THE STRING LENGTH AND B377 ISOLATE THE LENGTH STB T1IMP SAVE THE ADDRESS CMA,INA SET COUNT NEGATIVE STA T2IMP AND SAVE IT TOO IMP1 JSB ICH.F BEGIN THE SPELLING TEST ALF,ALF MOVE TO HIGH END AND SAVE STA T3IMP IT JSB ICH.F GET THE NEXT CHAR IOR T3IMP MIRGE WITH THE OTHER ISZ T1IMP STEP THE STRING ADDRESS CPA T1IMP,I IS THIS THE RIGHT CHAR? JMP IMP2 YES STEP THE POINTERS * LDA K10 NO- SEND SPELLING ERROR MESSAGE JSB ER.F B-Y-E * IMP2 ISZ T2IMP STEP THE COUNT JMP IMP1 MORE TO DO AROUND WE GO * LDA F.TC THE TEST IS OK SO FAR CPA B50 "(" IF LAST CHAR WAS '(' RSS SKIP READING IT JSB ICH.F NOPE READ THE '(' CPA B50 IS IT? JMP IMP03 YES ALL OK * LDA K9 UNEXPECTED CHAR JSB ER.F TOO BAD * 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 * JSB ICH.F GET THE NEXT CHAR CPA B55 '-' IF '-' THEN PART OF RANGE JMP IMP05 SO GO SET UP * CCA ELSE ASSUME SIMPLE CHAR STA T2IMP SET COUNT TO 1 * 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 T0IMP,I GET THE NEW TYPE AND B377 KEEP THE OLD LOW ORDER BYTE XOR T0IMP,I RULES OF WOO CHAR REPLACE 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 SSB CHAR JSB WAR.F * ISZ T1IMP STEP TO THE NEXT CHAR ISZ T2IMP STEP THE COUNT (DONE?) JMP IMP04 N0 - DO NEXT CHAR * 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 * IMP05 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. JMP IMP04 AND GO DO IT. * * DTBL DEF TYTBL ADDRES OF THE TYPE SPEC TABLE T0IMP NOP T1IMP NOP T2IMP NOP T3IMP NOP BM101 OCT -101 K10 DEC 10 SPC 2 * ******* * * EMA * * ******* SPC 1 F.EMP CLA,INA SET DIMENSION FLAG. STA F.DCF JSB INM.F INPUT NAME. LDA F.IU USAGE ALREADY ARRAY ? CPA ARR RSS YES. LEAVE IT. JSB TV.F NO. FORCE TO VARIABLE. LDA F.AT VERIFY A DUMMY CPA DUM RSS JMP EMP2 NO, ERROR LDA F.AF,I LINK TO BCOM OR NEXT DUMMY AND B7000 CPA BCOMI PREVIOUSLY DECLARED ? JMP EMP1 YES, ERROR. LDA F.A SAVE F.A & SET UP FOR EL.F STA F LDA K2 BUILD BCOMI ENTRY JSB DDE.F LDA F.EMA LINK TO EMA MASTER ENTRY LDB F.A ADB K2 STA B,I JSB EL.F INSERT BCOMI ENTRY LDA BCOMI SET F.AT TO BCOMI JSB DAT.F LDA F RESTORE F.A STA F.A JSB FA.F RESTORE A.T. STUFF EMP1 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 JMP EMP1 SKIP DIM INFO. * K94 DEC 94 SKP * *********************************** * * 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 SPC 1 * *********** * * INTEGER * * *********** SPC 1 F.INP LDA INT JMP TYP02 SPC 1 INT OCT 10000 F.IM=1, INTEGER SPC 1 * ******** * * REAL * * ******** SPC 1 F.REA LDA REA JMP TYP02 SPC 1 REA OCT 20000 F.IM=2, REAL SPC 1 * ******************** * * DOUBLE PRECISION * * ******************** SPC 1 F.DBL LDA DBL JMP TYP02 SPC 1 DBL OCT 60000 F.IM=6, DOUBLE PRECISION SKP * *********** * * COMPLEX * * *********** SPC 1 F.CPX LDA KKCPX JMP TYP02 SPC 1 KKCPX OCT 50000 F.IM=CPX LOG OCT 30000 F.IM=3, LOGICAL SPC 1 * *********** * * LOGICAL * * *********** SPC 1 F.LOG LDA LOG TYP02 STA F.MFL F.MFL SET TO THE MODE TYPED 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 LDB F.A CHECK IF IN FIX.EXT TBL CMB,INB IF SO ADB F.DP CAN NOT USE THE E-BIT TEST LDA F.MFL GET TYPE IN CASE IT IS SSB,RSS WELL? JMP TYP04 YES FIX.EXT SYMBOL DON'T USE E-BIT * 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 TYP04 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.EFG CLEAR E FLAG IN CASE STA F.TYP RESET TYPE FLAG TO INPUT DIMENSION. JSB IDC.F INPUT DIMENSION IF THERE. JMP CCRT SPC 1 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 F.FUN * 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 K18 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 VAR OCT 400 F.IU=2, VARIABLE OR CONSTANT STRAB OCT 2000 F.AT=2, STR-ABS - UNDEFINED TYP.A NOP SAVE F.A K83 DEC 83 K17 DEC 17 K18 DEC 18 B117 OCT 117 'O' "N" OCT 116 "FU" ASC 1,FU "NC" ASC 1,NC "TI" ASC 1,TI K28 DEC 28 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.AF STA T1DIM T1=AF 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 LDA F.DID COMPUTE ADDRESS OF ADA K2 THIRD DIM LDB S3 AND STB A,I IN F.IDI+2 LDA S1 NOW LDB S2 STORE THE DST F.IDI THE OTHER TWO DIMS LDA NS NO. OF SUBSCRIPTS JSB DDE.F DEFINE THE DIMENSION ENTRY 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 T0DIM BSS 1 SET T0 0(DUMMY) OR -1 T1DIM BSS 1 SAVE F.AF T2DIM BSS 1 SAVE F K54 DEC 54 NS BSS 1 NUMBER OF SUBSCRIPTS S3 BSS 1 SUBSCRIPT NUMBER 3 .. S2 BSS 1 SUBSCRIPT NUMBER 2 . S TABLE S1 BSS 1 SUBSCRIPT NUMBER 1 ..!!DO NOT REARRANGE S1/0 S0 BSS 1 SUBSCRIPT NUMBER 0 .. (EXTEND SIZE FOR EMA) B6000 OCT 6000 * * * *********************************************** * * DEFINE DIMENSION ENTRY (ALSO BCOMI ENTRIES) * * *********************************************** * * DDE.F NOP RAR,RAR MOVE NO. DIMENSIONS RAR,RAR TO THE 'IM' FIELD JSB ESC.F SET F.IM=NS LDA B6000 (A)=DIM STA F.AT. SUBSCRIPT INFORMATION FLAG SET CLA STA F.IU F.IU=0 JSB AI.F ASSIGN ITEM JMP DDE.F,I RETURN 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 SPC 1 ILD.F NOP JSB NDS.F NON-DUMMY & NON-SUBPROGRAM TEST LDA F.IU CPA ARR JMP ILE04 F.IU=ARR JSB TV.F TAG VARIABLE CLA ILE02 STA S1 JMP ILD.F,I SPC 1 K38 DEC 38 SPC 1 ILE04 JSB ISP.F INPUT SUBSCRIPTS JSB FA.F FETCH ASSIGNS LDA K38 LDB NS NO. OF SUBSCRIPTS CMB,INB (B)=-(B) ADB F.ND # OF DIMENSIONS SSB JSB ER.F MORE SUBSCRIPTS THAN DIMENSIONS * LDA DS3 SET UP DEF OF 'S' LIST STA DS IN LOCAL TEMP LDA DFD2 GET DEF OF DEF LIST STA DFD AND SET IT FOR LOOP LDA KM3 SET FOR THREE SUBSCRIPTS STA DDE.F SET COUNTER CLA,CLE INITILIZE STA ILET0 TEMPS STA S0 AND EXTENDED SIZE WORD ILE01 LDA DS,I GET SUBSCRIPT ADA ILET0 ADD WHAT WE HAVE ALREADY RAL,CLE,SLA,ERA PROP THE SIGN (LOW WORD IS 15 BITS) ISZ S0 STEP IF CARRY MPY DFD,I MULTIPLY BY THE DIMENSION DFD EQU *-1 RAL,CLE,ERA CLEAR THE SIGN STA ILET0 SET LOW PART OF RESULT ELB,CLE EXTEND SIGN OF A INTO B STB ILET2 SET TEMP LDA S0 SET CURRENT LOW PART MPY DFD,I MUL TIMES DIMENSION ADA ILET2 ADD THE HIGH BITS FROM BEFORE STA S0 SET THE NEW HIGH ORDER BITS ISZ DS STEP THE ADDRESSES ISZ DFD AND ISZ DDE.F JMP ILE01 ARROUND WE GO * LDA ILET0 GET LOW PART OF RESULT JMP ILE02 AND GO STORE IT * DS3 DEF S3 DFD2 DEF *+1,I DEF F.D2 DEF F.D1 DEF F.D0 DS NOP ILET0 NOP ILET2 NOP