ASMB,Q,C HED HEADER FOR FILES &F4X2 AND %F4X2 . NAM F4X2,8 92834-16003 REV.2030 800715 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * END ASMB,Q,C HED FTN4X COMPILER (F4X.3:SYMBOL TABLE & XREF) NAM F4X.3,5 92834-16003 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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 3 *************************************** * * THIS OVERLAY GENERATES THE SYMBOL TABLE LIST AND CROSS REFERENCE * LISTING FROM THE CREF INFO IN THE INTER PASS FILE * * 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 EXTRY EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CCW FTN OPTION WORD EXT F.DEB DEF TO ERROR BIT VECTOR. EXT F.DNI ADDRESS OF NID EXT F.DO LWAM - END OF DO TABLE EXT F.DP BASE OF A.T. EXT F.EM EMA FLAG BIT IN A.T. EXT F.EMA F.A OF EMA MASTER. EXT F.ERF ERROR ARRAY, CURRENT MODULE. EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURREXT ITEM USAGE (DUM., RELATIVE, ECT.) EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LOP NO. LINES LEFT ON THIS PAGE. EXT F.NC INTRINSICS FLAGS. EXT F.ND NUMBER OF DIMENSIONS EXT F.R MISC A.T. BIT. EXT F.SEG LOAD A NEW SEGMENT * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CER.F COMPILER ERROR REPORT. EXT EJP.F PAGE EJECT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FID.F FETCH (ID) TO NID (UNPACK) EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT NAM.F COPY SYMBOL NAME. EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST * * * * UTILITY LIBRARY ROUTINES * EXT .MVW EXT IFBRK BREAK CHECK ROUTINE * * COMPILER LIBRARY: * EXT RWN.C REWIND FILE ROUTINE EXT RED.C READ FILE ROUTINE EXT C.SC0 SCRATCH FCB EXT GMS.C GET MAIN MEMORY BOUNDS SPC 1 SUP A EQU 0 B EQU 1 SPC 1 DEC 3 OVERLAY # SPC 4 * ************** * * START HERE * * ************** SPC 1 F4.3 BSS 0 BEGIN HERE! CLA SHOULDN'T NEED ERROR RECOVERY ADDR, STA F.ERX BUT ZAP IT ANYWAY. LDA F.ERF+1 TOTAL # ERRORS, WARNINGS THIS MODULE. SZA,RSS JMP TABLS IF NONE, GO DO T & C OPTIONS. * LDA F.LOP IF NOT AT TOP-OF-PAGE, SZA (E.G. DISASTER), JSB EJP.F THEN GO THERE. SKP * ***************************** * * PRINT THE ERROR DIRECTORY * * ***************************** SPC 1 * THIS SECTION SCANS THE ERROR BIT VECTOR IN THE MAIN AND PRINTS * THE ERROR MESSAGES CORRESPONDING TO THE ERRORS AND WARNINGS * WHICH OCCURED IN THIS MODULE. THE TABLE OF MESSAGES IS JUST * ASCII WITH THE LAST CHARACTER IN EACH MESSAGE BEING | IN THE * RIGHT BYTE; IT IS CONVERTED TO BLANK BEFORE PRINTING. * * CHECK FOR ERRORS WHICH DON'T REQUIRE EXPLANATIONS; * IF ONLY THOSE, THEN DON'T PRINT DIRECTORY. * CLA INITIALIZE FLAG TO "NO PRINT". STA T6ERD STA T0ERD (ALSO CLEAR ERROR NUMBER) LDB F.DEB SET POINTER TO BIT VECTOR. LDA DEMSK SET POINTER TO MASKS. STA T2ERD LDA KM7 SET COUNT OF WORDS. STA T3ERD ERD00 LDA B,I NEXT BIT VECTOR WORD. INB AND T2ERD,I APPLY MASK. ISZ T2ERD IOR T6ERD IF PRINTING ERROR, SET FLAG. STA T6ERD ISZ T3ERD DONE ? JMP ERD00 NO. * * INITIALIZE DIRECTORY PRINT. * LDA F.DEB SET ADDR CURRENT BIT TABLE WORD. STA T1ERD LDA DMSGS SET ADDR CURRENT MESSAGE. STA T2ERD LDA KM7 SET COUNTER OF WORDS IN BIT TABLE. STA T3ERD ERD01 LDA KM16 SET COUNTER OF BITS IN CURRENT WORD. STA T4ERD * * COPY CURRENT ERROR MESSAGE TO BUFFER. * ERD02 LDA DMBUF SET BUFFER ADDR. STA T5ERD ERD03 LDA T2ERD,I WORD IN MSG. ISZ T2ERD STA T5ERD,I PUT IN BUFFER. ISZ T5ERD AND B377 TERMINATOR ? CPA B174 (BROKEN BAR) RSS (YES) JMP ERD03 NO. KEEP COPYING. SKP * IF BIT SET, FINISH SETTING UP MESSAGE. * LDA T1ERD,I WORD WITH BIT. CLE,ELA (E)=BIT; CLEAR & SHIFT FOR NEXT TIME. STA T1ERD,I LDB T6ERD PRINT FLAG. SZB IS PRINT FLAG ON, CCB,SEZ,RSS AND BIT SET ? (B=-1) JMP ERD08 NO. DON'T PRINT. * ADB T5ERD YES. CHANGE FINAL | TO BLANK. LDA B,I ADA BM134 STA B,I CPB DMBUF WAS THAT ONLY WORD OF MESSAGE ? JSB CER.F YES. COMPILER ERROR. LDA T0ERD CONVERT ERROR NUMBER. CLE (E=0, SUPPRESS LEADING ZEROES.) JSB ASC.F STA ERNUM PUT IN MSG. * * HANDLE SUBHEADING. * LDA F.LOP AT BOTTOM OF PAGE ? INA,SZA,RSS JSB EJP.F YES. GO TO TOP. LDA F.LOP AT TOP OF PAGE ? SZA JMP ERD04 NO. * LDA K9 FIRST SUB-HEADING. LDB DERH1 JSB PSL.F CLA BLANK LINE. JSB SKL.F LDA K12 SECOND SUB-HEADING. LDB DERH2 JSB PSL.F CLA,INA TWO BLANK LINES. JSB SKL.F ERD04 LDA DEBUF COMPUTE # WORDS IN LINE. CMA,INA -(FWA) ADA T5ERD LWA-FWA+1 LDB DEBUF PRINT LINE. JSB PSL.F SKP * LOOP THRU ALL ERROR BITS. * ERD08 ISZ T0ERD BUMP ERROR NUMBER. ISZ T4ERD NEXT BIT. DONE THIS WORD ? JMP ERD02 NO. * ISZ T1ERD YES. ADVANCE IN TABLE. ISZ T3ERD COUNT WORDS. DONE WITH TABLE ? JMP ERD01 NO. JMP TABLS YES. DO SYMBOL & XREF TABLES. * * CONSTANTS & TEMPS FOR ERROR DIRECTORY. * T0ERD NOP CURRENT ERROR NUMBER. T1ERD NOP POINTER TO BIT VECTOR. T2ERD NOP POINTER TO MESSAGE TEXT. T3ERD NOP COUNTER OF WORDS IN BIT VECTOR. T4ERD NOP COUNTER OF BITS IN THIS WORD. T5ERD NOP POINTER INTO ERROR BUFFER. T6ERD NOP FLAG THAT PRINTED ERROR FOUND. DERH1 DEF *+1 ASC 09, ERROR DIRECTORY DERH2 DEF *+1 ASC 12, NUMBER EXPLANATION DEBUF DEF EBUF DMBUF DEF MBUF EBUF ASC 2, START OF ERROR LIST BUFFER. ERNUM BSS 1 FOR ASCII ERROR NUMBER. ASC 3, MBUF BSS 36 FOR ERROR MESSAGE. K12 DEC 12 KM7 DEC -7 B30 OCT 30 C,T OPTION BITS. B174 OCT 174 | BM134 OCT -134 SPACE - | B377 OCT 377 DEMSK DEF *+1 ERROR MASK: BIT SET IF ALWAYS PRINTED. OCT 177777 0-15 OCT 177777 16-31 OCT 177777 32-47 OCT 177777 48-63 OCT 173777 64-79, EXCEPT 68. OCT 177777 80-95 OCT 177777 96-111 SKP * ERRORS 0-99. * DMSGS DEF *+1 * 0-9: ASC 0001, | ASC 0012,ERROR IN FTN DIRECTIVE.| ASC 0001, | ASC 0013,COMPILER SPACE OVERFLOW. | ASC 0011,INVALID COMMON LABEL.| ASC 0010,REDUNDANT IMPLICIT.| ASC 0001, | ASC 0012,RETURN IN MAIN PROGRAM.| ASC 0012,ILLEGAL COMPLEX NUMBER.| ASC 0012,MISMATCHED PARENTHESIS.| * 10-19: ASC 0012,UNRECOGNIZED STATEMENT.| ASC 0014,UPPER BOUND < LOWER BOUND. | ASC 0020,RETURN # TOO LARGE OR TOO MANY ALTERNATE ASC 05, RETURNS.| ASC 0020,CONSTANT IN FORMAT > 2047 OR ILLEGAL HOL ASC 04,LERITH.| ASC 0020,CONSTANT OR CONSTANT EXPRESSION OVERFLOW ASC 08, OR UNDERFLOW. | ASC 0020,KEYWORD UNRECOGNIZED, REPEATED, OR ILLEG ASC 02,AL.| ASC 0012,ILLEGAL OCTAL CONSTANT.| ASC 0015,MISSING CONSTANT OR OPERAND. | ASC 0017,ILLEGAL COMBINATION OF KEYWORDS. | ASC 0014,INTEGER CONSTANT EXPECTED. | * 20-29: ASC 0020,ILLEGAL CHARACTER COUNT IN HOLLERITH CON ASC 04,STANT. | ASC 0011,VALUE OUT OF RANGE. | ASC 0011,ILLEGAL USE OF NAME. | ASC 0008,STEP SIZE = 0. | ASC 0017,VARIABLE OR ARRAY NAME EXPECTED. | ASC 0018,VARIABLE NAME OR CONSTANT EXPECTED.| ASC 0017,INTEGER (LOGICAL) ITEM EXPECTED. | ASC 0014,DUPLICATE STATEMENT NUMBER.| ASC 0011,UNEXPECTED CHARACTER.| ASC 0017,BLANK LINE HAS STATEMENT NUMBER. | * 30-39: ASC 0020,INCORRECT NESTING. MAY BE DUE TO OTHER ASC 04,ERRORS.| ASC 0019,DO LOOP NESTING PROBLEM. SEE MANUAL.| ASC 0020,UNDEFINED, ILLEGAL OR INCORRECTLY USED S ASC 09,TATEMENT NUMBER. | ASC 0001, | ASC 0012,STATEMENT OUT OF ORDER.| ASC 0014,NO PATH TO THIS STATEMENT. | ASC 0017,VARIABLE APPEARS TWICE IN COMMON.| ASC 0020,FORMAL PARAMETER IN COMMON OR DATA STATE ASC 03,MENT.| ASC 0014,WRONG NUMBER OF SUBSCRIPTS.| ASC 0020,VARIABLE DIMENSION NOT A FORMAL PARAMETE ASC 08,R OR IN COMMON.| * 40-49: ASC 0016,INCONSISTENT EQUIVALENCE GROUP.| ASC 0020,NEGATIVE EXTENSION OF COMMON VIA EQUIVAL ASC 03,ENCE.| ASC 0014,LEFT PARENTHESIS EXPECTED. | ASC 0001, | ASC 0012,NAME IN CONSTANT LIST. | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0020,NAME OF A FUNCTION NOT USED OR NAME OF A ASC 11, SUBROUTINE IS USED. | ASC 0001, | ASC 0015,ILLEGAL USE OF EMA VARIABLE. | ASC 0001, | * 50-59: ASC 0020,ILLEGAL LAST STATEMENT OF DO, OR THEN WI ASC 05,THOUT IF.| ASC 0020,CONTROL VARIABLE OF DO STATEMENT ALREADY ASC 05, IN USE. | ASC 0015,LOGICAL IF WITHIN LOGICAL IF.| ASC 0001, | ASC 0015,ARRAY NAME DIMENSIONED TWICE.| ASC 0001, | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0018,ILLEGAL COMBINATION OF DATA TYPES. | ASC 0020,FUNCTION USED AS SUBROUTINE OR HAS ALTER ASC 07,NATE RETURNS.| ASC 0011,WRONG # OF ARGUMENTS.| * 60-69: ASC 0012,ILLEGAL ARGUMENT TYPE. | ASC 0018,STATEMENT NUMBER AFTER LOGICAL IF. | ASC 0020,NO STATEMENT NUMBERS AFTER ARITHMETIC IF ASC 01,.| ASC 0001, | ASC 0001, | ASC 0001, | ASC 0020,PROGRAM SHOULD (NOT) HAVE EXECUTABLE STA ASC 05,TEMENTS. | ASC 0001, | ASC 0020,EXTERNAL NAME SHORTENED TO 5 CHARACTERS. ASC 01, | ASC 0001, | * 70-79: ASC 0001, | ASC 0020,TOO MANY/FEW CONSTANTS, OR ILLEGAL REPEA ASC 05,T COUNT. | ASC 0015,ITEM MUST (NOT) BE IN COMMON.| ASC 0020,CONSTANT & VARIABLE HAVE DIFFERENT TYPES ASC 01,.| ASC 0001, | ASC 0011,PROGRAM CALLS ITSELF.| ASC 0014,DUPLICATE FORMAL PARAMETER.| ASC 0013,STATEMENT NUMBER IGNORED.| ASC 0001, | ASC 0001, | * 80-89: ASC 0001, | ASC 0001, | ASC 0001, | ASC 0013,ATTEMPT TO RETYPE A NAME.| ASC 0018,OBJECT CODE OR EMA SPACE OVERFLOW. | ASC 0020,PROGRAM NAME CONFLICTS WITH COMMON, EXTE ASC 12,RNAL OR INTRINSIC NAME.| ASC 0001, | ASC 0016,THE GIVEN NAMES WERE NOT TYPED.| ASC 0001, | ASC 0020,LOGICAL IF HAS CONTINUE OR NO STATEMENT. ASC 01, | * 90-99: ASC 0014,ILLEGAL CONTINUATION LINE. | ASC 0020,TWO EXTERNAL NAMES CONFLICT AFTER BEING ASC 06,SHORTENED. | ASC 0020,EXTERNAL NAME CONFLICTS WITH A LIBRARY R ASC 04,OUTINE.| ASC 0016,EMA VARIABLE IN DATA STATEMENT.| ASC 0020,VARIABLE NOT A FORMAL PARAMETER OR GIVEN ASC 04, TWICE.| ASC 0001, | ASC 0008,BREAK DETECTED.| ASC 0020,CANNOT ACCESS RELOCATABLE OUTPUT FILE. | ASC 0020,CANNOT ACCESS SOURCE FILE, OR EOF BEFORE ASC 03, END.| ASC 0016,CANNOT ACCESS SCRATCH FILE(S). | * 100-111: ASC 12, | | | | | | | | | | | | SKP * ************************************** * * SORT THE NAMED ENTRIES IN THE A.T. * * ************************************** SPC 1 * START OF OUTER LOOP: REPEATEDLY SCAN THE NAMED SYMBOL LIST FOR * THE LARGEST SYMBOL LEFT IN THE LIST FOR THAT SCAN. THEN LINK IT * INTO THE START OF THE SORTED LIST AND REMOVE FROM THE UNSORTED. * REPEAT UNTIL NO SYMBOLS REMAIN IN THE UNSORTED LIST. * TABLS LDA F.CCW IS EITHER T OR C SELECTED ? AND B30 SZA,RSS JMP RETRN NO. DONE. * OLOOP CLA SAV.A IS 0 UNTIL 1ST PRINTABLE FOUND. STA SAV.A JSB GFA.F START SCAN. * * START OF INNER LOOP. GET NEXT SYMBOL IN UNSORTED LIST. * LOOPI LDA F.A SAVE OLD F.A STA OLDFA JSB GNA.F GET NEXT SYMBOL TABLE ENTRY. SZA,RSS IF TOP OF S.T. REACHED, JMP LOOPE END OF LOOP THRU ASSIGN. TABLE * JSB FID.F GET SYMBOL ID, TAGS. JSB FA.F LDA F.A TEMP CELL ? ADA K2 LDA A,I SSA,RSS JMP LOOP0 NO, COMPARE TO BEST SO FAR. * * * REJECTED. REMOVE FROM LIST. * CCA GET THIS ITEM'S LINK. ADA F.A LDA A,I LDB OLDFA NOW BACK UP TO PREVIOUS ITEM. STB F.A ADB KM1 & SET ITS LINK TO POINT PAST DELETED ITEM. STA B,I (OLDFA IS WRONG NOW BUT THAT'S O.K.) JMP LOOPI NOW GO ADVANCE. SPC 1 OLDFA NOP F.A OF PREVIOUS ENTRY. SAV.A NOP OLDFA OF LARGEST SO FAR. T.DNI NOP POINTER TO STEP THRU (DID) BSNID DEF SNID SNID BSS 6 KM1 DEC -1 B100 OCT 100 SKP * GOT ONE. SEE IF SMALLEST SO FAR. * LOOP0 LDA SAV.A FIRST PRINTABLE ? SZA,RSS JMP LOOPR YES, THEN SET UP AS AN INITIAL SYMBOL * LDB BSNID COMPARE AGAINST BEST SO FAR. LDA F.DNI STA T.DNI * LOOPF LDA B,I CHARACTER FROM SNID CMA,INA ADA T.DNI,I (NID) - (SNID) INB (ADVANCE) ISZ T.DNI SZA,RSS SAME ? JMP LOOPF YES, KEEP CHECKING. SSA NO. WHICH IS SMALLER ? JMP LOOPI ITEM BEING SCANNED. SKIP IT. * * NEW LARGEST SYMBOL. * LOOPR LDA F.DNI THIS IS ALPHABETICALLY THE LDB BSNID SMALLEST NAME SO FAR THIS SCAN. JSB .MVW .MVW TO SAVE AREA DEF K6 NOP LDA OLDFA REMEMBER OLDFA & SET SAV.A#0. STA SAV.A JMP LOOPI * * THIS SCAN COMPLETE. ADD SYMBOL TO SORTED LIST. * LOOPE CCB FORM ADDR OF LINK OF PREVIOUS ONE. ADB SAV.A SSB (IF NONE, SAV.A=0 SO B=-1 NOW) JMP LOOP7 DIDN'T FIND ANY. ALL DONE SORTING. * CCA FIRST, REMOVE THE ITEM FROM UNSORTED LIST. ADA B,I (A) = ADDR OF LINK OF ONE TO ADD. STA F.A (NEED IT LATER) LDA A,I (A) = VALUE OF LINK OF ONE TO ADD. STA B,I IT'S GONE! LDA F.SSL ADD TO THE START OF THE SORTED LIST. STA F.A,I 1) POINT IT TO THE LIST. LDA F.A 2) MAKE IT THE NEW FIRST ITEM. INA STA F.SSL JMP OLOOP GO SCAN AGAIN. SKP * DONE SORTING. IF 'T', PRINT THE TABLE ENTRIES. * LOOP7 LDA F.CCW 'T' OPTION ? AND K8 SZA,RSS JMP XREF NO. JUST XREF. JSB EJP.F NEW PAGE. * LDA F.SSL START SCAN. STA F.A JMP LOOP9 * LOOPA CLA RESET STMT FCT FLAG. STA T1LOP LOOP4 JSB GNA.F BUMP TO NEXT ITEM. LOOP9 SZA ALL DONE ? JMP LOOPB NO. LOOK AT THIS ONE. * LDA T1LOP MAYBE. IS IT JUST END OF STMT FCT ? STA F.A (JUST IN CASE) SZA WELL ? JMP LOOPA YES. RESUME AFTER IT. JMP XREF ELSE DONE. TEST TO SEE IF XREF REQUESTED * LOOPB JSB FA.F FETCH ASSIGNS. JSB FID.F COPY (UNPACKED) SYMBOL TO (DID) * LDA F.AT PROCESS ALL FORMAL PARAMETERS. CPA DUM JMP LOOP6 LDB F.DNI,I (B) = FIRST CHAR. CPB B100 STATEMENT # CPA B2000 AND DEFINED (F.AT#2000) RSS NO. (IF STMT #, F.IU=0) JMP LOOP6 YES. LDB F.IU SZB,RSS IF F.IU = 0, SKIP ITEM. JMP LOOP4 * CPA STRAB IF F.AT=STRAB, CPB SUB AND F.IU#SUB, RSS NO. JMP LOOP4 THEN UNUSED VARIABLE. * CPA BCOMI IF LABELLED COMMON MASTER, JMP LOOP6 ALWAYS PRINT. * LDA F.AF IF F.AF=0 AND F.IU=SUB, SZA JMP LOOP6 (F.AF#0) * CPB SUB JMP LOOP4 SKIP THE ITEM. SKP * GOT A LIVE ONE. SET UP TO PRINT IT. * LOOP6 LDA F.LOP PRINT A SYMBOL TABLE LINE. INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA AT TOP OF PAGE? JMP LOOP5 NO. LDA K7 YES; PRINT HEADER LDB LABLE AND TWO BLANK LINES JSB PSL.F THEN "SYMBOL TABLE" CLA JSB SKL.F THEN A BLANK LINE LDA K31 LDB HEADR JSB PSL.F THEN HEADER CLA,INA JSB SKL.F AND TWO MORE BLANK LINES. LOOP5 JSB CLR1 CLEAR OUT LIST BUFFER * * COPY NAME TO LINE. * LDA NAME NORMAL POSITION FOR NAME. LDB T1LOP IS IT A STMT FCT FORMAL ? SZB INA YES, MOVE FURTHER RIGHT. STA LOOPC JSB NAM.F LOOPC DEF *-* * * TRANSFER ADDRESS TO LINE. SPC 1 LDB F.AF GET ADDRESS LDA F.A,I SEE IF INTRINSIC. AND B7740 F.AT,F.IU,F.NC CPA B2240 F.AT=STRAB,F.IU=SUB,F.NC=1: JMP TYP01 INTRINSIC, NO ADDR OR LOCATION. * LDA F.EM EMA ? SZA JMP EMAAD YES. GO FORMAT THAT. * LDA F.AT GET ADDRESS TYPE. CPA BCOM IF LABELLED COMMON, RSS SKIP TO DO IT JMP ATL1 ELSE JMP * INB STEP TO AND LDB B,I GET THE OFFSET ATL1 SSB CMB,INB LDA ADDR2 ADDRESS FIELD OF LINE. STA ASSLC SET LOCATION JSB ASCI5 CONVERT TO ASCII AND STORE. JMP REL01 GO DO RELOCATION INDICATOR. SKP * PROCESSING FOR EMA ADDRESSES. * EMAAD LDA F.IU CHECK IF ARRAY CPA ARR IF SO RSS SKIP JMP EMAA1 NOT ARRAY * DLD F.A,I ARRAY. THE BCOMI POINTER IN THE DIM ENTRY ADB K2 MAY HAVE BEEN GARBAGED. GET THE COPY FROM LDB B,I WORD 2 OF THE DIM ENTRY, AND STB F.AF RESET F.AF TO RIGHT VALUE EMAA1 LDA F.AT DUMMY ? CPA DUM JMP EMAFP YES. DIFFERENT ? * CPA BCOMI EMA MASTER ENTRY ? JMP USAG1 YES. NO ADDR, LOCATION OR TYPE. * LDB F.AF GET EMA ADDRESS: ADB K2 DLD B,I IN (B,A). ASL 6 SET PAGE NUMBER IN B LDA ADDR SET THE ADDRESS STA ASSLC FOR THE ADDRESS JSB ASCI4 THEN TO THE LINE LDA "P" NOW SEND THE 'P' TO INDICATE PAGE JSB PUT.F TO THE LINE LDA B40 AND A BLANK JSB PUT.F LDA F.AF GET LOWER PART AGAIN. ADA K2 LDA A,I AND B1777 ISOLATE THE PAGE OFFSET. STA B AND JSB ASCI4 SEND IT TO THE LINE JMP EMART GO SEND THE '+' * * EMA FORMAL PARAMETERS. * EMAFP CCA EMA DUMMY. SET EMA FLAG. STA EMFLG LDB F.AF GET F.RPL OF DUMMY. ADB K2 LDB B,I JMP ATL1 * B7740 OCT 7740 MASK FOR F.AT & F.IU & F.NC B2240 OCT 2240 F.AT,F.IU,F.NC FOR INTRINSICS. B2200 OCT 2200 F.AT,F.IU OF ANY EXTERNAL FUNCTION. B7200 OCT 7200 F.AT,F.IU OF COMMON MASTERS. B17K OCT 17000 B1000 OCT 1000 LABLE DEF SYTH HEADR DEF SYTH2 SKP * RELOCATION INDICATOR TO LINE * REL01 LDB "R" ASSUME PROGRAM RELOCATABLE. LDA F.AT CPA COM. IF COMMON, LDB "C" SET INDICATOR TO 'C'. CPA BCOM IF BCOM EMART LDB B53 USE "+" (RETURN FROM EMAAD) LDA F.A,I SEE IF EXTERNAL SUBR. AND B7600 F.AT & F.IU CPA B2200 F.AT=STRAB & F.IU=SUB ? RSS CPA B7200 OR F.AT=BCOMI & F.IU=SUB ? LDB "X" YES, EXTERNAL PROG OR COMMON MASTER. STB USE SAVE USE FOR LATER LDA B PUT THE CHAR IN THE LINE JSB PUT.F * * LOCATION. * LDA IU1 ITEM USAGE = STATEMENT NUMBER? LDB F.DNI,I CPB B100 JMP LOOP3 YES, SKIP TYPE AND LOCATION. * LDA LO4 ASSUME 'LOCAL' LDB USE CPB "X" IF EXTERNAL INDICATOR, LDA LO1 CHANGE TO 'EXTERNAL' LDB F.AT CPB COM. IF COMMON, LDA LO2 CHANGE TO 'COMMON' CPB DUM IF DUMMY, LDA LO3 CHANGE TO 'DUMMY'. CPB BCOM IF LABELED COMMON LDA LO5 CHANGE TO 'L COMMON' LDB LOCAT LOCATION FIELD OF LINE JSB .MVW DEF K4 NOP * * IF EMA DUMMY, ADD '(EMA)' TO LOCATION. * ISZ EMFLG EMA DUMMY ? JMP TYP02 NO. DLD LO6A YES, COPY "(EMA)" DST LBUF+30 LDA LO6A+2 STA LBUF+32 JMP TYP02 GO DO TYPE. SKP * TYPE. INTRINSICS FIRST, THEN OTHERS. * TYP01 LDA F.R UNLESS ONLY USED AS SUBROUTINE. SZA,RSS JMP USAG1 THEN NO TYPE. * LDA B,I FIRST WORD INTRINSIC DATA. SSA SPECIAL: EXEC/REIO/XLUEX ? JMP TYP02 YES. NOT GENERIC. * AND B17K # SPECIFIC FUNCTIONS SELECTED. CPA B1000 EXACTLY ONE ? JMP TYP02 YES. TELL HIM THAT TYPE. * LDA DIMG ELSE 'GENERIC' JMP TYP03 * TYP02 LDA F.AT COMMON LABEL ? CPA BCOMI JMP USAG1 YES. NO TYPE. * LDA F.IM OTHER. INDEX TABLE BY TYPE. ALF ADA DDFIM LDA A,I (A) = ADDR OF NAME. TYP03 LDB TYPE TYPE FIELD OF LINE JSB .MVW DEF K4 NOP * * USAGE TO LINE * USAG1 LDB F.IU CPB SUB RSS JMP LOOP2 NOT SUBPROGRAM * LDA IU2 ASSUME STATEMENT FUNCTION LDB F.AT CPB DUM IF DUMMY, JMP USAG2 GO CHECK SUBROUTINE/FCT. CPB BCOMI IF BCOM INFO ENTRY LDA IU8 CHANGE TO BCOM LABEL CPB STRAB IF EXTERNAL SUBROUTINE, RSS JMP LOOP3 (NO. GOT IT ALREADY) * LDA IU6 ASSUME 'INTRINSIC'. LDB F.NC IF F.NC=1, CPB B40 JMP LOOP3 THAT'S RIGHT. * USAG2 LDA IU7 ASSUME 'FUNCTION'. LDB F.R IF FUNCTION FLAG SET, SZB JMP LOOP3 THAT'S RIGHT. LEAVE TYPE. * LDA DFIM0 ELSE ZAP TYPE. LDB TYPE JSB .MVW DEF K4 NOP LDA IU3 NOW 'SUBROUTINE'. JMP LOOP3 SKP * HANDLE ARRAYS AND UNUSED VARIABLES. * LOOP2 LDA IU4 CPB VAR IF VARIABLE. JMP LOOP3 * SZB,RSS IF NOT USED, JMP LOOP8 THEN LEAVE BLANK. * LDA IU5X ARRAY. WORD CONTAINING DIMENSION COUNT. AND BM10 CLEAR OUT LAST NUMBER USED. ADA F.ND INSERT NEW DIMENSION COUNT. STA IU5X LDA IU5 ADDR OF THAT MSG. LOOP3 LDB USAGE USAGE FIELD OF LINE JSB .MVW DEF K9 NOP * * SUPPLY BCOM LABEL IF IN LABELED COMMON * LOOP8 LDA F.AT CPA BCOM IN LABELED COMMON? RSS YES SKIP JMP OL1 NO JUST OUTPUT THE LINE * LDB F.A SAVE F.A FOR TRAVERSING LIST. STB OLDFA LDB F.AF COPY NAME OF COMMON BLOCK. ADB K2 SKIP TO SLOT FOR MASTER ADDR. LDB B,I (B) = ADDR COMMON MASTER. LDA F.EM UNLESS EMA, SZA LDB F.EMA INWHICHCASE IT'S THIS ONE. STB F.A JSB NAM.F DEF LBUF+33 LDB OLDFA RESTORE F.A STB F.A SKP * OUTPUT LINE. FIRST, TRIM BLANKS. * OL1 LDA LAST START AT END. LDB BLNKS (B) = TWO BLANKS. OL2 ADA KM1 BACK UP ONE. CPB A,I IF STILL BLANK, JMP OL2 KEEP GOING. * CMA -(ADDR LAST NONBLANK WORD)-1 ADA DLBU. (FIRST)-(LAST)-1 CMA,INA (LAST)-(FIRST)+1 = LENGTH. LDB DLBU. JSB PSL.F PRINT THE LINE. JSB IFBRK CHECK FOR BREAK. DEF *+1 SSA WELL ? JMP BREAK YES. GO ABORT. * LDA F.A,I WAS THIS A STATEMENT FUNCTION ? AND B7600 CPA B1200 I.E., F.AT=REL & F.IU=SUB ? RSS YES. JMP LOOP4 NO. GO ON TO NEXT SYMBOL. * DLD F.A,I YES. (B) = EXTENSION ADDR. INB LDA B,I (A) = ADDR FIRST FORMAL. LDB F.A SAVE CURRENT F.A STB T1LOP (ALSO FLAG FOR LISTING) STA F.A SET UP TO LIST FORMALS, JMP LOOP9 AND DO IT. * ASSLC NOP ASSBF PTR ARR OCT 600 "C" OCT 103 B7600 OCT 7600 MASK FOR F.AT & F.IU B1200 OCT 1200 F.AT=REL, F.IU=SUB : STMT FCT. B53 OCT 53 "+" B1777 OCT 1777 B20 OCT 20 "R" OCT 122 "P" OCT 120 KM4 DEC -4 "X" OCT 130 USE NOP T1LOP NOP F.A OF STMT FCT IF IN FORMALS. STRAB OCT 2000 BCOM OCT 3000 BCOMI OCT 7000 K31 DEC 31 EMFLG NOP SPC 1 K9 DEC 9 BM10 OCT -10 B40 OCT 40 B2000 OCT 2000 DUM OCT 5000 SPC 1 SUB OCT 200 VAR OCT 400 COM. OCT 4000 LO1 DEF LO1A LO2 DEF LO2A LO3 DEF LO3A LO4 DEF LO4A LO5 DEF LO5A DIMG DEF IMGEN FOR 'GENERIC' DDFIM DEF *+1 USED TO INDEX THIS TABLE. DFIM0 DEF IM0 0 NONE (BLANK) DEF IM1 1 INTEGER DEF IM2 2 REAL DEF IM3 3 LOGICAL DEF IM0 4 ERROR DEF IM5 5 COMPLEX DEF IM6 6 EXTENDED DEF IM0 7 ERROR DEF IM8 8 DOUBLE INTEGER DEF IM9 9 DOUBLE LOGICAL DEF IM10 10 DOUBLE DEF IM11 11 CHARACTER DEF IM12 12 DOUBLE COMPLEX * DLBU. DEF LBUF NAME DEF LBUF+1 ADDR DBL LBUF+5 ADDR2 DBR LBUF+7 USAGE DEF LBUF+12 TYPE DEF LBUF+22 LOCAT DEF LBUF+27 LAST DEF LBUF+40 * IU1 DEF IU1A IU2 DEF IU2A IU3 DEF IU3A IU4 DEF IU4A IU5 DEF IU5A IU6 DEF IU6A IU7 DEF IU7A IU8 DEF IU8A K7 OCT 7 * * * CLEAR LIST BUFFER * SPC 1 CLR1 NOP LDA BLNKS 2 BLANKS STA LBUF START WITH BLANKS, LDA DLBU. AND PROPOGATE. LDB A INB I.E., MOVE * TO *+1. JSB .MVW DEF K39 FIRST + 39 = 40 WORDS. NOP JMP CLR1,I DONE. * K39 DEC 39 SKP * ** DATA TO OCTAL ASCII CONVERSION ** SPC 1 * CALLING SEQUENCE: LDB (DATA WORD) * LDA (ADDRESS AT START OF STORAGE) * JSB ASCI6 SPC 1 ASCI6 NOP OUTPUT 6 DIGITS STA ASSLC SET THE ADDRESS LDA KM6 GET NO. OF DIGITS TO CONVERT RBL MOVE FIRST DIGIT TO LOW B JSB NUM.F CONVERT THE NUMBER JMP ASCI6,I RETURN SPC 2 ASCI5 NOP 5 DIGITS & BLANK LDA KM5 GET NO OF DIGITS TO CONVERT BLF POSITION FIRST DIGIT JSB NUM.F CONVERT THE NUMBER JMP ASCI5,I RETURN * ASCI4 NOP ROUTINE TO CONVERT 4 OCTAL DIGITS FROM B LDA KM4 TO THE OUT PUT LINE BLF,RBL POSITION FIRST DIGIT IN RBL,RBL LEAST 3 BITS OF B JSB NUM.F CONVERT IT TO THE LINE JMP ASCI4,I RETURN. * * *********************************** * * CONVERT DIGITS TO ASCII BASE 8 * * *********************************** * * NUM.F NOP STA T1NUM SAVE THE DIGIT COUNT CPA KM6 IF 6 THEN CLA,INA,RSS USE 1 AS A MASK FOR FIRST DIGIT NUM00 LDA K7 ELSE USE 7 AND B ISOLATE THE DIGIT ADA "0" ADD 60 TO MAKE ASCII JSB PUT.F PUT IN THE BUFFER BLF,RBR POSITION THE NEXT DIGIT ISZ T1NUM DONE? JMP NUM00 NO DO NEXT DIGIT * JMP NUM.F,I YES RETURN * T1NUM NOP KM6 DEC -6 KM5 DEC -5 "0" OCT 60 * SPC 2 * * ******************************** * * PUT CHARACTER IN LIST BUFFER * * ******************************** * PUT.F NOP STB T1PUT SAVE B LDB ASSLC GET CURRENT BUFFER ADDRESS AND B177 ISOLATE THE CHARACTER CLE,ERB WORD ADDRESS TO B E=UPPER,LOWER FLAG SEZ,RSS IF UPPER CHAR ALF,SLA,ALF POSITION AND SKIP XOR B,I INCLUSION OF HIGHER CHAR. XOR B40 ADD,TAKE AWAY LOWER BLANK STA B,I SET THE WORD DOWN ISZ ASSLC STEP THE CHAR ADDRESS LDB T1PUT RESTORE B JMP PUT.F,I RETURN * T1PUT NOP B177 OCT 177 SKP * *************************** * * VARIABLES AND CONSTANTS * * *************************** SPC 1 SYTH ASC 7, SYMBOL TABLE * SYTH2 ASC 06, NAME ASC 06, ADDRESS ASC 10, USAGE ASC 05,TYPE ASC 04,LOCATION * IU1A ASC 9,STATEMENT NUMBER IU2A ASC 9,STATEMENT FUNCTION IU3A ASC 9,SUBROUTINE IU4A ASC 9,VARIABLE IU5A ASC 3,ARRAY, IU5X ASC 6, 0 DIMEN. IU6A ASC 9,INTRINSIC IU7A ASC 9,FUNCTION IU8A ASC 9,COMMON LABEL * IMGEN ASC 4,GENERIC IM0 ASC 4, (NONE) IM1 ASC 4,INTEGER IM2 ASC 4,REAL IM3 ASC 4,LOGICAL IM5 ASC 4,COMPLEX IM6 ASC 4,EXTNDED IM8 ASC 4,DBL INT IM9 ASC 4,DBL LOG IM10 ASC 4,DOUBLE IM11 ASC 4,CHAR IM12 ASC 4,DBL CPX * LO1A ASC 4,EXTERNAL LO5A ASC 1,L L FOR LABELED COMMON LO2A ASC 4,COMMON LO3A ASC 4,DUMMY LO4A ASC 4,LOCAL LO6A ASC 3,(EMA) LBUF ASC 1, BSS 39 LIST BUFFER K16 DEC 16 HED F4.3 XREF SECTION XREF JSB EJP.F FINISH OFF THE SYMBOL TABLE LDA F.CCW CHECK IF XREF AND K16 REQUIRED SZA,RSS WELL? JMP RETRN NO XREF REQUESTED GO DO NEXT MODULE * CLA XREF REQUESTED SET UP FOR IT JSB SKL.F SKIP LINE DEBUG ONLY JSB RWN.C REWIND XREF DISC FILE DEF C.SC0 JMP FERR ERROR REPORT AND EXIT SPC 1 * THE MEMORY AREA USED IN THIS SEGMENT IS IN THREE PARTS * PART 0 IS FROM THE BEGINING OIF THE SEGMENT DOWN TO 'PAS1' BELOW * PART 1 IS FROM THE END OF THIS SEGMENT (AS DEFINED BY GMS.C) * TO THE BEGINING OF THE ASSIGNMENT TABLE. PART TWO IS FROM * THE END OF THE ASSIGNMENT TABLE TO THE END OF AVAILABLE MEMORY * (THESE ARE DEFINED BY F.LO AND F.DO). * * THESE AREAS ARE FILLED WITH THE CROSS REFERENCE PAIRS GENERATED * IN PASS ONE IN CIRCULAR FASHION SO THAT WE ALWAYS HAVE THE LAST * N RECORDS IN MEMORY. THIS MEANS THAT FOR LARGE PROGRAMS WHERE * THERE IS NOT ENOUGH MEMORY TO CONTAIN ALL THE CROSS REFERENCE PAIRS * WE NEED ONLY READ THE BEGINNING OF THE FILE TO GET THE RECORDS THAT * ARE NOT IN MEMORY. * * TO DO ALL THESE WONDERS WE USE THE FOLLOWING POINTERS: * * STM0 START OF MEMORY POOL (F4.3) * ENDM0 END OF POOL ZERO ~ 'PAS1' * STMEM START OF MEMORY * ENDM1 END OF FIRST MEMORY * F.LO START OF SECOND MEMORY * ENDM2 END OF SECOND MEMORY AREA * FREC NUMBER OF LOWEST NUMBERED X-REF RECORD IN MEMORY * FRLOC THE ABOVE RECORDS ADDRESS * SPC 1 * THE CODE BELOW USES FOUR ADDRESSES: * PLIST AND ULIST ARE DEFINED AT THE * END OF THIS SEGMENT; * F.LO = END OF ASSIGNMENT TABLE + 1 AND * F.DO = END OF MEMORY. SPC 1 * IF F.DO - F.LO > ULIST - PLIST, THEN * SET PLIST _ F.LO AND ULIST _ F.DO. SPC 1 LDA SIZ0 GET SIZE OF MEMORY POOL ZERO LSR 5 ROUND DOWN TO 32 BIT CHUNCKS LSL 5 AND ADA STM0 ADD THE BASE ADDRESS STA ENDM0 SET THE END ADDRESS JSB GMS.C FIND THE END OF THIS SEGMENT STA STMEM STMEM _ LOW MAIN CCB SET UP THE END OF THIS FREE AREA ADB F.DP AS THE START OF THE ASSIGNMENT TABLE CMA,INA ADA B KEEP EVEN 32 WORD PIECES ONLY LSR 5 LSL 5 ADA STMEM ADDRESS OF WORD AFTER LAST USABLE STA ENDM1 SAVE IT CCB NOW SET UP THE OTHER AREA ADB F.DO LDA F.LO CMA,INA ADA B LSR 5 LSL 5 ADA F.LO STA ENDM2 SET IT UP * * SCAN THE SORTED SYMBOLS & CLEAR WORD (1) = COUNT WORD. * LDA F.SSL SET TO SCAN A.T. TO CLR COUNT WDS (WD 2) STA F.A RSS CLOP JSB GNA.F GET AN ENTRY SZA,RSS IF END OF LIST JMP PAS1 GO READ IN THE XREF PAIRS * INA CLEAR THE COUNT WORD. CLB STB A,I COUNT WORD JMP CLOP AND GO GET THE NEXT ENTRY *********************************************************************** *** ALL DATA & CODE REFERENCES WITHIN THIS MODULE MUST NOW BE MADE *** *** TO ADDRESSES PHYSICALLY HIGHER THAN THIS ONE. THE LOWER PART *** *** OF THIS MODULE WILL BE USED FOR DATA !!! *** *********************************************************************** * COUNT THE NUMBER OF REFERENCES FOR EACH SYMBOL * BY LOGGING EACH ONE AS THE XREF DATA IS READ. * PAS1 JSB READ READ A PAIR BUFFER TO MEMORY LDB CREC GET THE CURRENT RECORD ADDRESS PAS11 LDA B,I GET THE A.T. ADDRESS SZA,RSS END OF LIST? JMP PAS2 YES START PASS 2 * INA NO STEP THE COUNT ON THIS ENTRY ISZ A,I ADB K2 STEP B ISZ PCOUN DONE WITH THIS RECORD? JMP PAS11 NO GET NEXT ENTRY * JSB NEXRC SET ADDRESS FOR NEXT RECORD JMP PAS1 READ THE NEXT ONE SKP * ************* * * PHASE TWO * * ************* SPC 1 * SCAN THRU SORTED SYMBOLS, PRINTING XREF. * PAS2 JSB NEXRC RESERVE A BUFFER FOR PASS TWO LDA CREC SAVE ITS STA SADD ADDRESS ISZ XFLAG SET PASS TWO FLAG FOR READ ROUTINE * LDA F.SSL START SCAN. STA F.A RSS PAS22 JSB GNA.F NEXT ! SZA,RSS DONE ? JMP RETRN YES. QUIT. JMP LBL14 NO. GO PROCESS IT. SPC 1 STMEM NOP ENDM1 NOP ENDM2 NOP FREC NOP SADD NOP F.SSL NOP SPC 3 * ************************* * * ABORT CROSS REFERENCE * * ************************* SPC 1 * ************************************** * * RETURN TO FTN4 * * ************************************** SPC 1 RETRN JSB EJP.F TO TOP OF PAGE LDB K4 RETURN TO JMP F.SEG THE INIT SEGMENT FOR NEXT PGM. SPC 2 DEC 23 * NEXTP NOP K6 DEC 6 K4 DEC 4 K2 DEC 2 SKP * PRINT REFERENCES FOR SYMBOL (F.A) * LBL14 JSB RWN.C REWIND XREF FILE DEF C.SC0 JMP FERR ERROR REPORT AND EXIT * DLD F.A,I (B) = REFERENCE COUNT. CMB,INB,SZB,RSS NEGATE. ZERO ? JMP PAS22 YES. SKIP IT. STB COUNT NEGATE FOR COUNTER CLB STB REC SET RECORD COUNT TO ZERO JSB NAM.F COPY SYMBOL ASCII NAME. DEF LINE+1 CLA SKIP A LINE. JSB SKL.F * * SCAN THRU XREF DATA, OUTPUT EACH (F.A) REF. * LBL15 JSB READ GET NEXT SECTOR OF XREF PAIRS. LDA CREC GET CURRENT RECORD ADDRESS STA NEXTP AND SET IN VARABLE LBL16 LDA NEXTP,I (A)=NEXT A.T. POINTER TO CHECK CPA F.A IF IT IS THE SAME AS THE CURRENT JMP LBL19 ELEMENT, ADD LINE NO. * ISZ NEXTP POINT TO LBL17 ISZ NEXTP NEXT PAIR IN PLIST. ISZ PCOUN BUMP PAIR COUNT. JMP LBL16 COMPARE AGAINST NEXT PAIR. * LDA NEXTP IF PCOUN=0, ADJUST NEXTP, JSB NEXRC GET NEXT RECORD OF PAIRS JMP LBL15 SPC 1 LBL19 LDA NREFS CPA K10 LINE FULL? JSB PLINE YES. PRINT IT. LDA NREFS REFS ON LINE ALS,CLE *3 (E=0 FOR ASC.F) ADA NREFS ADA XRLOC START OF REFERENCES IN LINE STA RFLOC LOCATION IN LINE OF NEXT REF ISZ NREFS ISZ NEXTP POINT TO LINE NO. IN XREF PAIR LDA NEXTP,I LINE NO. IN BINARY JSB ASC.F CONVERT IT TO ASCII (E=0 HERE) STB RFLOC,I FIRST 2 DIGITS ISZ RFLOC STA RFLOC,I 2ND TWO ISZ COUNT MORE REFS? JMP LBL17 YES. * JSB PLINE PRINT LAST LINE OF XREF LIST JMP PAS22 GO GET THE NEXT SYMBOL SKP * ************** * * PRINT LINE * * ************** SPC 1 PLINE NOP LDA F.LOP INA,SZA,RSS AT BOTTOM OF PAGE? JSB EJP.F YES. FORMFEED LDA F.LOP SZA AT TOP OF PAGE? JMP PL01B NO. * LDA K11 PRINT HEADER AND TWO BLANK LINES LDB LABLX "CROSS REFERENCE LIST" JSB PSL.F OUTPUT LINE CLA JSB SKL.F SKIP A LINE LDA K11 LDB HEADX "SYMBOL REFERENCES" JSB PSL.F OUTPUT LINE CLA,INA JSB SKL.F SKIP 2 LINES PL01B LDA NREFS COMPUTE LENGTH OF PORTION OF ALS LINE BUFFER TO BE PRINTED (ONLY ADA NREFS OUT TO END OF CROSS-REF INFO.) ADA K5 LDB BLINE JSB PSL.F PRINT THE LINE CLA SET NUMBER OF REFS IN LINE STA NREFS TO 0. * LDA BLNKS BLANK OUT NAME EVERY TIME. STA LINE+1 BE PRINTED AGAIN. STA LINE+2 STA LINE+3 JMP PLINE,I SPC 1 K5 DEC 5 K10 DEC 10 BLINE DEF LINE ADDRESS OF LINE BUFFER XRLOC DEF LINE+6 RFLOC NOP COUNT NOP K32 DEC 32 K8 DEC 8 STM0 DEF F4.3 START OF MEMORY POOL 0 ENDM0 DEF PAS1 END OF POOL 0 (REFINED BY CODE) CREC DEF F4.3 INITIAL FIRST BUFFER FRLOC DEF F4.3 AND FIRST RECORD SIZ0 ABS PAS1-F4.3 MAX SIZE OF POOL 0 SKP UPADD NOP COMPUTE NEXT ADDRESS IN CIRCULAR BUFFER LDA CREC GET CURRENT ADDRESS ADA K32 ADD BLOCK SIZE CPA ENDM0 END OF BLOCK ZERO? LDA STMEM YES START BLOCK 1 CPA ENDM1 END OF FIRST POOL? LDA F.LO YES SWITH TO NEXT POOL CPA ENDM2 END OF SECOND POOL? LDA STM0 YES SET TO FIRST POOL JMP UPADD,I RETURN * * NEXRC NOP COMPUTE ADDRESS OF NEXT RECORD AND JSB UPADD KEEP TRACK OF OVERLAYS STA CREC SET NEW ADDRESS CPA STM0 OVER LAY ? ISZ OVER YES LDB OVER WERE THERE ANY OVER LAYS? SZB,RSS WELL? JMP NEXRC,I NO ALL IS WELL * LDB XFLAG PASS TWO? SZB WELL? JMP NEXRC,I YES ALL IS WELL ANY WAY * ISZ FREC STEP THE RECORD NUMBER OF THE FIRST RECORD IN JSB UPADD THE POOL AND GET ITS ADDRESS STA FRLOC SET ADDRESS IN ITS LOCATION. JMP NEXRC,I NOW ALL IS WELL SPC 2 * LINE SET-UP: SPC 1 * 2 BLANKS (LINE PRINTER ONLY) * 6 CHAR NAME (FIRST LINE FOR SYMBOL) OR 6 BLANKS (OTHER LINES) * 4 BLANKS AND 4 DIGIT REFERENCE (REPEATED UP TO 8 TIMES) SPC 1 * MAX # CHARS/LINE: 70(TTY), 72(LINE PRINTER) SPC 1 * LINE IS INITIALIZED TO 72 BLANKS SPC 1 LINE ASC 18, ASC 18, ASC 18, ASC 18, BLNKS EQU LINE NREFS NOP MUST BE 0 INITIALLY SPC 1 LABLX DEF *+1 ASC 11, CROSS-REFERENCE LIST HEADX DEF *+1 ASC 11, SYMBOL REFERENCES K11 DEC 11 SKP * **************************************** * * READ CROSS REFERENCE PAIRS FROM DISC * * **************************************** SPC 1 * ON ENTRY, THE FOLLOWING VARIABLES ARE SET UP: SPC 1 * NEXTP = NEXT PAIR LOCATION. THE 64 WORD SECTOR * IS READ INTO THIS AREA OF THE LIST OF * CROSS REFERENCE PAIRS. THE 64 WORDS * WILL TAKE UP THE AREA ADDRESSED BY * NEXTP+0 TO NEXTP+63. AT LEAST 128 WORDS MUST * REMAIN BETWEEN PLIST AND NEXTU, THE * LOCATION OF THE NEXT UNIQUE ASSIGNMENT * TABLE POINTER IN THE LIST OF THOSE POINTERS. * IF NOT, A MESSAGE IS PRINTED ELSEWHERE IN * THIS SEGMENT AND THE CROSS REF. IS ABORTED. SPC 1 * NOTE: SPC 1 * THIS ROUTINE IS USED IN BOTH PHASES OF THIS SEGMENT. * IN PHASE 1, WHEN THE LIST OF UNIQUE ASSIGNMENT * TABLE POINTERS IS BEING CONSTRUCTED (XFLAG=0), * THE SECTOR IS ALWAYS READ FROM THE DISC. IN PHASE 2, * WHEN THE CROSS REFERENCE LIST IS BEING PRINTED (XFLAG#0), * THE SECTOR IS READ ONLY IF IT IS NOT ALREADY IN CORE. * THE SECTOR IS NOT IN CORE WHEN NEXTP = OVLAY. OVLAY * IS THE ADDRESS WHERE THE SECTOR OVERLAY AREA BEGINS. SPC 1 * ON EXIT, THE FOLLOWING VARIABLES ARE SET UP: SPC 1 * PCOUN = PAIR COUNT. THIS IS THE NUMBER OF CROSS * REFERENCE PAIRS IN THE SECTOR. IT IS SET * NEGATIVE FOR LATER USE AS A COUNTER. PCOUN * ALWAYS HAS A VALUE OF -32. SPC 1 * WCOUN = WORD COUNT. THIS IS A COUNT OF THE NUMBER * OF WORDS THAT NEXTP MUST BE ADJUSTED BEFORE * THIS ROUTINE IS CALLED THE NEXT TIME. USUALLY * WCOUN IS SET TO 0. HOWEVER, WCOUN IS SET * NON-ZERO IF: SPC 1 * WCOUN = -64 IF THE SECTOR READ OVERLAYED A * PREVIOUS SECTOR. SPC 2 READ NOP JSB IFBRK CHECK FOR BREAK DEF *+1 SSA WELL? JMP BREAK * LDA XFLAG IF THIS FLAG IS 0, THE UNIQUE SZA,RSS A.T. POINTER IS BEING BUILT JMP READ1 IN PHASE 2. MUST READ SECTOR; * LDA FREC IN PASS TWO IF RECORD IS CMA,INA BELOW ONE IN ONE OF THE ADA REC BUFFERS SSA THEN JMP READ0 GO READ IT * SZA IT IS IN MEMORY JMP READ3 IF NOT FIRST ACCESS JUST GO SET IT UP * LDA FRLOC FIRST REC FROM MEM BUFFER STA CREC SET IT'S ADDRESS JMP READ3 GO DO IT * READ0 LDA SADD USE THE SAVED ADDRESS FOR PASS TWO STA CREC READS * READ1 CCB GET THE BUFFER ADDRESS ADB CREC LESS ONE STB BUFA AND SET AS THE READ ADDRESS LDA B,I GET THE WORD TO BE OVERLAYED AND STA SAV SAVE IT READ2 CLA SET TO SAVE THE AREA JSB RED.C READ A LINE DEF C.SC0 OF SCRATCH BUFA DEF * CONFIGURED ABOVE DEF K33 TOTAL SIZE IS 33 (32+FLAG) JMP FERR READ ERROR GO ABORT * SSB IF EOF JMP EOF GO SET UP * LDA BUFA,I GET THE FLAG WORD CPA KM2 IF NOT AN XREF RECORD RSS JMP READ2 GO READ ANOTHER RECORD * READ4 LDA SAV RESTOR THE SAVED WORD STA BUFA,I AND READ3 LDA KM16 A FULL SECTOR WAS READ. STA PCOUN PCOUN=-16 INDICATES 16 PAIRS ISZ REC STEP THE RECORD COUNT JMP READ,I SPC 1 EOF CLA SET EOF FLAG STA CREC,I AND GO JMP READ4 RETURN * FERR LDA K99 PASS FILE READ ERROR JMP F.ABT * BREAK LDA K96 GET BREAK ERROR JMP F.ABT AND GO ABORT * K96 DEC 96 XFLAG NOP MUST BE 0 INITIALLY. K99 DEC 99 OVER NOP MUST BE 0 INITIALLY. REC NOP PCOUN NOP KM2 DEC -2 K33 DEC 33 KM16 DEC -16 SAV BSS 1 * END F4.3 ASMB,Q,C HED FTN4X COMPILER (SEG: F4X.4) INITIALIZE THE COMPILER. NAM F4X.4,5 92834-16003 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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * ***************************************** * 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. * * 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.AT. SUBSCRIPT INFO FLAG EXT F.ABT ABORT COMPILE - FATAL ERROR. 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.EQE EQUVALENCE ERROR 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.ERX ERROR EXIT ADDRESS. EXT F.FLN FIRST LINE # OF THIS MODULE. EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.LNA ADDRESS OF CURENT LINE EXT F.LO END OF ASSIGNMEXT TABLE+1 EXT F.LSF EXPECT FIRST STATEMEXT FLAG EXT F.LSP LAST OPERATION FLAG EXT F.NXN NO INPUT FLAG EXT F.OPT OPTIONS PART OF MAIN HEADER. EXT F.PAS PASS NUMBER. 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 F.TL LENGTH OF TITLE. EXT F.TTL TITLE LINE. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CDI.F CLEAR IDI ROUTINE EXT CTL.F COPY TITLE TO PASS FILE. 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 IN1.F INIT FOR PSL.F MODULE EXT IN3.F INIT FOR WS1.F MODULE. EXT IN4.F INIT FOR FA.F MODULE EXT IN6.F INIT FOR IC.F MODULE 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 PSI.F PRINT SOURCE IMAGE. EXT SNC.F START NEXT CARD SUBROUTINE * * 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 PRM.C GET PRAMETER EXT C.SC0 SCR FILE FCB, CARD FILE & 2ND PASS FILE. EXT C.SC1 SCR FILE FCB, 1ST PASS FILE. 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$INT 1/2 WORD INTEGER OPTION EXT Z$DBL 3/4 WORD DOUBLE PRECISION OPTION EXT Z$LPP DEFAULT # LINES PER PAGE * A EQU 0 B EQU 1 K4 DEC 4 SEGMENT NUMBER SUP SKP * ************************ * * START OF COMPILATION * * ************************ SPC 1 * CLEAR LINE DESCRIPTION. DECIDE TYPE OF CALL. * F4.4 CLA,INA SET PASS 1. STA F.PAS LDA DERR1 SET ERROR RECOVERY ADDR. STA F.ERX CLA MAKE SURE WAR.F DOESN'T STA F.LNA PRINT LIST LINE IF ERROR. STA F.CC LDB F.STA WHAT KIND OF CALL ? SSB JMP NEW NEW MODULE BUT NOT FIRST ONE. (B<0) SZB JMP TRM TERMINATION. (B>0) * * GET TIME, OPEN FILES. * DLD F.IDI RESTORE REGISTERS AND JSB SUP.C CALL. DEF F.TIM ADDRESS OF TIME ARRAY NOP CLA,INA SET TITLE TO BLANKS. STA F.TL LDA BLNKS STA F.TTL * LDA PRMPT OPEN INPUT FILE. (PROMPT=']') JSB OPN.C DEF C.SAU SOURCE FCB JMP INERR * JSB OPN.C OPEN THE LIST DEVICE DEF C.LST JMP TRML * CLB OPEN THE BINARY (B=0,RELOCATABLE) JSB OPN.C DEF C.BIN JMP BERR * BERX JSB OPN.C OPEN THE CARD FILE & 2ND PASS FILE. DEF C.SC0 JMP ERROR * JSB OPN.C OPEN THE 1ST PASS FILE. DEF C.SC1 JMP ERROR * SKP * REWIND THE PASS FILES. SET # LINES / PAGE. * NEW JSB RWN.C CARD FILE & 2ND PASS FILE. DEF C.SC0 JMP ERROR JSB RWN.C 1ST PASS FILE. DEF C.SC1 JMP ERROR JSB PRM.C 4TH PARAM IS LINES/PAGE. DEF K4 SZA,RSS IF NOT GIVEN, LDA Z.LPP USE DEFAULT. ADA KM3 - 4 EXTRAS, + 1 FOR WAY USED. STA NOLIN TENTATIVE. ADA KM7 WAS IT < 10 ? CLB SSA STB NOLIN YES, USE INFINITE SIZE PAGE. * * COMPUTE BASE ADDRESS OF SYMBOL TABLE = MAX(X+C,Y) WHERE: * WHERE X = END OF LARGEST SEGMENT WHICH USES THE CARD BUFFER, AND * Y = END OF LARGEST SEGMENT WHICH DOES NOT USE IT, AND * C = LENGTH OF THE CARD BUFFER. * THIS SEGMENT IS NOT INCLUDED IN THE ABOVE. * LDA DSEGS SEGMENT TABLE POINTER. STA DFSEG JSB GMM.C GET MAIN MEMORY BOUNDS DEF K2 TWO CARD-BUFFER SEGMENTS. DEF LSE.F NAME OF LOCAL SEG. NAME FINDER STB F.DO SET TOP OF SYMBOL TABLE (END MEM) STA F.CRB X = ADDRESS OF CARD BUFFER ADA K98 X+C STA F.DP * JSB GMM.C SAME FOR NON-CARD-BUFFER ONES. DEF K4 FOUR OF THEM DEF LSE.F * LDB F.DP (B)=X+C, (A)=Y CMB,INB -(X+C). ADB A (B) = Y-(X+C) SSB,RSS IF Y IS BIGGER, STA F.DP USE IT. F.DP = BASE OF SYMBOL TABLE. * * COMPUTE ADDRESS USER PART. CHECK IT. * CMA MAKE SURE THERE IS ROOM ADA F.DO IF NEGATIVE RESULT THEN NO ROOM FOR SSA TABLE SO QUIT ON SYMBOL TABLE OVERFLOW JMP ERR3 NO ROOM. SKP * SET UP FOR CARD BUFFER. * JSB GMM.C GET SIZE THIS SEGMENT AND DEF K1 DEF LSE.F ADA K98 FOR CARD BUFFER CMA ADA F.DO SSA IF NO ROOM JMP ERR3 ABORT * LDA F.DO SET UP ADDRESS OF CARD BUFFER. ADA KM98 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 THERE'S AN EXTRA WORD ANYWAY.) LDA F.CRB NOW PLANT THE REQUIRED BLANKS ADA K2 FOR BETWEEN THE LINE NUMBER LDB BLNKS STB A,I ADA K49 DO FOR BOTH BUFFERS STB A,I * * INITIALIZATION FOR EACH MODULE. * JSB NEW.F MAIN DOES IT. DLD F.ERN+1 UPDATE CUMULATIVE ERROR TOTALS. ADA F.ERF ADB F.ERF+1 DST F.ERN+1 CLA CLEAR COUNTERS FOR NEW MODULE. STA F.ERF STA F.ERF+1 LDA F.STA FIRST MODULE ? SZA JMP NOFTN NO. DONE HERE. JMP CME YES. GO SCAN 'FTN' CARD. SKP * SEGMENT NAME FETCHER. * LSE.F NOP ISZ LSE.F IGNORE PARAM. JSB SEG.F FORM THE SEGMENT NAME. DFSEG NOP PTR TO SEGMENT #. ISZ DFSEG BUMP TO NEXT. JMP LSE.F,I EXIT. * * SEGMENT NUMBERS. * DSEGS DEF *+1 DEC 0,1 THOSE WHICH USE CARD BUFFER. DEC 2,3,5,6 & THOSE WHICH DON'T. DEC 4 FINALLY, THIS SEGMENT. * * ERROR HANDLING FOR FILES. * ERROR LDA K99 ERROR ON PASS FILE WRITE IT JMP ABT IS AN ERROR 99 * INERR JSB OPN.C ERROR ON SOURCE FILE TRY LIST DEF C.LST JMP TRMSL IF PROBLEMS SKIP ON OUT LDA K98 INPUT FILE PROBLEMS JMP ABT * 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 4 K2 DEC 2 DERR1 DEF ERR1 ERROR RECOVERY ADDR. K3 DEC 3 K5 DEC 5 KM3 DEC -3 KM7 DEC -7 RSAVE NOP NOLIN NOP NUMBER OF LINES/PAGE K98 DEC 98 KM98 DEC -98 K49 DEC 49 SKP CME CLA,CCE INITIALIZE FLAGS. STA F.ERN (ZAP THE ERROR COUNTS.) STA F.ERN+1 STA F.ERN+2 JSB INIT * * 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): * * 0 SIJ QXY EFD BCT AML * * S = USE .SMAP/.SRES INSTEAD OF .EMAP/.ERES . * I = USE 16-BIT INTEGER (VS 32-BIT) * J = USE 32-BIT INTEGER (VS 16-BIT) * 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 = DUMP THE FIRST PASS FILE & SYMBOL TABLE TO LISTING. * 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 SKP * START BY MAKING SURE THE CARD STARTS 'FTN'. * 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.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' RSS JMP ERR1 FTN4 CONTROL CARD MISSING LDA B GET NEXT TWO CHAR. ALF,ALF TO LOW A AND B377 ISOLATE CPA "N" 'N' JMP CME06 JMP ERR1 FTN CONTROL CARD MISSING * * SCAN THE 'FTN' CARD AND SET UP OPTIONS. * CME05 JSB ICH.F NEXT CHARACTER. CME06 LDB F.TC C/R ? CPB B15 JMP PCONT YES. THAT'S ALL. CPB B54 ',' ? RSS JMP ERR1 NO. ERROR IN FTN CARD JSB ICH.F INPUT CHARACTER JSB CCO.F CONVERT CONTROL OPTION. SZA,RSS FOUND ? JMP CME10 NO. IOR NLTEM YES. SET THE OPTION(S) STA NLTEM AND B30K I & J OPTIONS. CPA B30K BOTH SET NOW ? JMP ERR1 YES, ERROR. LDA NLTEM AND B3000 X & Y OPTIONS. CPA B3000 BOTH SET NOW ? JMP ERR1 YES, ERROR. LDA B THE OPTION BY ITSELF. IOR DUPS REPEATED ? CPA DUPS JMP ERR1 YES, ERROR. STA DUPS JMP CME05 GO FOR MORE. SKP * LAST RESORT, CHECK FOR DIGIT (ERR0). * CME10 LDB OPTSE NOT IN TABLE. CHECK FOR DIGIT. ADB BM61 SW.N SSB JMP ERR1 < '0' ADB KM9. SSB,RSS JMP ERR1 > '9' ADB ERR0 DIGIT; BUILD ERR ROUTINE NAME STB F.ER0 CLB ONLY ALLOW ONCE. STB SW.N JMP CME05 AGAIN. * * END OF CONTROL STATEMENT. SET CONTROL WORD. * PCONT CLA END OF CTRL STMT. STA F.NXN LDA NLTEM X OR Y SELECTED ? AND B3000 SZA JMP PCON1 YES. LDA B1000 NO. ASSUME Y. LDB Z.DBL X DEFAULT ? CPB K3 RAL YES. THEN X. PCON1 STA NEWOP LDA NLTEM I OR J SELECTED ? AND B30K SZA JMP PCON2 YES. LDA B20K NO. ASSUME I. LDB Z.INT J DEFAULT ? CPB K2 RAR YES. SET J. PCON2 IOR NEWOP COMBINE I J WITH X Y. STA NEWOP IOR NLTEM SET THE STA F.CCW CONTROL WORD SKP * IF OPTIONS ON 'RU,FTN', USE THEM. * 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 OPTNS SO BAIL OUT * JSB CCO.F CONVERT CONTROL OPTION. AND KK01 DISALLOW I,J,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 SKP * CONSTRUCT THE OPTIONS PART OF MAIN HEADER. * OPTNS LDA BLNKS SET THE FIRST WORD TO BLANKS, STA F.OPT LDA DFOPT AND USE .MVW TO PROPOGATE IT. RAL,CLE,SLA,ERA REMOVE EXACTLY ONE INDIRECT. LDA A,I RAL SET UP THE BYTE ADDR IN HEADER. STA T1OPT RAR RESTORE WORD ADDR FOR .MVW LDB A (A) = ADDR FIRST, (B) = ADDR 2ND. INB JSB .MVW DEF K5 6 WORDS ALTOGETHER. NOP LDA F.CCW SET UP COPY OF OPTIONS. STA T2OPT LDA DLOPT AND POINTER INTO (LISTING) OPTS TABLE. STA T3OPT LDA F.ER0 WAS THERE AN 'ERR0' DIGIT ? AND B377 SZA IF NOT PRESENT, CPA B60 OR '0', JMP OPT01 THEN IGNORE. * LDB A ELSE PRINT IT FIRST. JMP OPT02 * * CHECK THE NEXT OPTION (SET); GET LIST CHAR. * OPT01 ISZ T3OPT ADVANCE TO THE NEXT OPTION. ISZ T3OPT DLD T3OPT,I SEE IF CURRENT OPTION(S) ON. SZA,RSS FIRST, ARE WE DONE ? JMP NIXOP YES. QUIT. * AND T2OPT NO. HERE ARE OPTIONS IN QUESTION. CPA T3OPT,I ARE ALL SPECIFIED ONES SET ? RSS YES. JMP OPT01 NO. SKIP THIS ONE. * XOR T2OPT YES. REMOVE THOSE BITS. STA T2OPT * * INSERT (B) IN THE LISTING. * OPT02 ADB BM40 CORRECT FOR EXISTING BLANK. LDA T1OPT SET UP TO STORE. CLE,ERA (A) = ADDR, (E) = BYTE. SEZ,RSS IF UPPER BYTE, BLF,BLF MOVE THE DATA UP THERE. ADB A,I INSERT THE CHARACTER. STB A,I REPLACE WORD. ISZ T1OPT ADVANCE BYTE ADDRESS. JMP OPT01 GO TRY FOR ANOTHER. SKP DFOPT DEF F.OPT MAY HAVE INDIRECT ! T1OPT NOP BYTE ADDRESS OF OPTIONS IN HEADER. T2OPT NOP REMAINING OPTIONS FROM OPTION WORD. T3OPT NOP POINTER WITHIN OPTIONS PRINTING TABLE. BM400 OCT 177400 BM40 OCT -40 B60 OCT 60 * DLOPT DEF *-1 LIST OPTIONS TABLE. (-2) OCT 04001,121 Q,L = Q K1 OCT 00001,114 L OCT 00016,115 M,A,T = M B14 OCT 00014,101 A,T = A B10 OCT 00010,124 T OCT 00020,103 C OCT 00200,106 F OCT 00100,104 D B1000 OCT 01000,131 Y OCT 02000,130 X B10K OCT 10000,112 J B20K OCT 20000,111 I OCT 40000,123 S OCT 0 SKP * * DISMISS FTN STMT. SET UP BINARY FLAG. * NIXOP LDA DNIX SET F.EQE TO POINT TO HERE INCASE STA F.EQE OF ERROR 90 (FIRST STMT. IS A CONTINUE) CLA,CLE CLEAR E FOR IN6.F (NOT A NEW MODULE) STA F.FLN SET FLAG SO FIRST LINE # PICKED UP. JSB INIT SET UP TO CHECK FOR CONTINUED LINES JSB CTL.F PRESERVE TITLE FOR PASS 2. NIX01 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 * DNIX DEF NIX01 SKP * CONVERT CONTROL OPTIONS SUBROUTINE. * INPUT: (A) = OPTION LETTER. * OUTPUT:(A) = CORRESPONDING BIT(S). NONE-->0. * CCO.F NOP CONVERT CONTROL OPTIONS. STA OPTSE USE ORIGINAL VALUE TO END TABLE. LDB DOPTS SET UP POINTER. STB T1CME CLB,INB START WITH L=1. CCO01 CPA T1CME,I THIS ONE ? JMP CCO02 YUP. * RBL NO. TRY NEXT. ISZ T1CME JMP CCO01 * CCO02 LDA B SAVE ACTUAL OPTION. CPB K2 M ? IOR B14 YES, SET A & T. CPB K4 A ? IOR B10 YES, SET T. CPB B4000 Q ? IOR K1 YES, SET L. CPB OPTSX NOT FOUND ? CLA IF SO, RETURN A=0. JMP CCO.F,I EXIT. A=OPTIONS, B=SINGLE OPTION. * * OPTIONS TABLE. JUST THE CHARACTERS. * 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 "B" 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 OCT 112 J =10000 OCT 111 I =20000 OCT 123 S =40000 OPTSE BSS 1 MISSING = 100000 OPTSX OCT 100000 SKP 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.INT DEF Z$INT+0 1/2 WORD INTEGER DEFAULT. Z.DBL DEF Z$DBL+0 3/4 WORD DOUBLE PRECISION DEFAULT. Z.LPP DEF Z$LPP+0 DEFAULT # LINES PER PAGE. KM6 DEC -6 AD NOP COUNT NOP B377 OCT 377 NEWOP NOP B15 OCT 15 B54 OCT 54 ',' K99 DEC 99 K67 DEC 67 KM201 DEC -201 B40 OCT 40 B3000 OCT 3000 B4000 OCT 4000 B30K OCT 30000 KK01 OCT 144777 TO ZAP I,J,X,Y. BFLG OCT 40 BINARY FLAG (SET FOR BINARY) K97 DEC 97 DMAN DEF NOFT2 ERROR RETURN ON INPUT ERROR SKP * *************************** * * INITIALIZE VARIOUS SUBS * * *************************** SPC 1 * INPUT: E=1 IFF FIRST MODULE. SPC 1 INIT NOP CALL ALL THE INIT SUBS IN THE MAIN LDA NOLIN PASS THE LINE COUNT JSB IN1.F TO PSL.F ('E' PRESERVED) CLA A=0 FOR IN6.F LDB F.CRB PASS THE CARD BUFFER ADDRESS JSB IN6.F TO IC.F JSB IN3.F WS1.F JSB IN4.F FA.F JMP INIT,I RETURN * "D" OCT 104 "E" OCT 105 SPC 2 * ******************** * * CHECK FOR 'END$' * * ******************** SPC 1 NOFTN CLA,CLE STA F.FLN SET FLAG SO FIRST STMT # PICKED UP. 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 CTL.F PRESERVE TITLE FOR PASS 2. NOFT2 JSB SNC.F TEST FOR END$ CARD CLA,INA STA F.CC SET CC=1 STA F.NXN SET NO INPUT FLAG JSB ICH.F CHECK FOR 'END$'. CPA "E" 'E' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "N" 'N' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "D" 'D' ? RSS YES JMP NOFT1 NO JSB ICH.F CPA "$" '$' JMP TRM YES, 'END$', WRAP IT UP. * NOFT1 CLA STA F.EQE CLEAR THE ERROR RETURN FLAG STA F.NXN RESET NO INPUT FLAG INA STA F.CC SET CC=1 STA F.SID AND THE SCAN FLAG SKP * ************************** * * REST OF INITIALIZATION * * ************************** * * SET UP: NAM, IMPLICIT TYPES, PROG NAME, TEMPS. * PPNM 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 F.CCW 'J' OPTION ? AND B10K SZA,RSS JMP PPNM1 NO. LDA JTYP YES. MODIFY THE IMPLICIT TYPE TABLE. STA DINTY STA DINTY+1 STA DINTY+2 * PPNM1 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 SKP * ZERO OUT SOME STUFF IN MAIN. ALSO F.IDI . * 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. * * SET UP STACKS. (& A COUPLE OF FLAGS). * LDA F.DP DATA POOL START LOCATION INA 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 LDA F.DO LAST AVAILABLE MEMORY LOCATION STA F.E STA F.D STA F.S1B STA F.S1T F.S1T=F.S1B=D * * JUST A LITTLE MORE CLEANUP, THEN LOAD 4.0 . * LDA F.CRB TELL F4.0 WHERE TO MOVE CARD BUFFER: STA F.IDI FROM, LDA F.DP ADA KM98 AND TO. STA F.IDI+1 CLA,INA RESET STA F.CC THE COLUMN COUNTER CLB STB F.NXN CLEAR THE NO INPUT FLAG JMP F.SEG GO TO SEGMENT 0. SKP MFLC DEF KK32 KK32 ASC 3,FTN. DEFAULT OBJ PROG NAME INITB DEF F.AT. INIT. TO 0 AREA BEGIN ADDR. * PRNM DEF *+1 PROTO NAM RECORD K17. DEC 17,0,0,0,0,0,0,0,0,4,99,0,0,0,0,0,0 K13 DEC 13 DTYP DEF *+1 BLNKS ASC 4, BLANKS HAPPEN TO BE REAL (A-H) DINTY OCT 10020,10020,10020 THESE ARE INTEGER (I-N) ASC 6, MORE REALS (M-Z) JTYP OCT 100200 TWO BYTES OF TYPE (DBI). K15 DEC 15 K21 DEC 21 K26 DEC 26 F.CRB NOP CARD BUFFER ADDRESS "$" OCT 44 SKP * TERMINATE COMPILE. (ERROR OR END SOURCE) * FIRST, ERRORS. * ERR1 JSB PSI.F PRINT THE CONTROL LINE. CLA,INA,RSS ERR 1: ERROR IN 'FTN' DIRECTIVE. * ERR3 LDA K3 3: SYMBOL TABLE DOESN'T FIT. ABT JMP F.ABT SEND ERROR MSG; RETURNS TO 'TRM'. * * CLOSE BINARY FILE (IF ANY) * 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 RSS ERROR REPORT IT JMP NXBIN ELSE GO ON. CLA CLEAR BIN FLAG SO DON'T RE-REPORT. STA F.CCW LDB F.ERN ALREADY REPORTED IT ? LDA K97 SZB,RSS JMP ABT NO, DO SO NOW. * * SET UP THE ERROR COUNTS. * 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 F.ERN DISASTER COUNT. 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 * * END THE LIST FILE. * JSB EOF.C DEF C.LST RSS IF ERROR REPORT IT JMP TRM1 ELSE GO ON. LDA K15 REPORT TO TTY. JMP EOFER SKP * WRITE END MESSAGE WITH ERROR TOTALS. * 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 CLE SUPPRESS LEADING ZEROES. JSB ASC.F CONVERT IT CPA BLNKS IF NONE LDA "NO" USE NO RRL 8 STB ENMES+6 SET IN THE MESSAGE. STA ENMES+7 * LDA ERMX GET THE ERROR COUNT CLE,SZA,RSS IF NONE (E=0, SUPPRESS JMP EXIT2 SKIP LEADING ZEROES) JSB ASC.F ELSE CONVERT IT STB ENMES+13 SET STA ENMES+14 IN THE MESSAGE * EXIT2 LDA WAR GET THE WARNNING COUNT CLE,SZA,RSS IF NONE (E=0, SUPPRESS JMP EXIT3 SKIP LEADING ZEROES) JSB ASC.F CONVERT IT STA ENMES+20 STB ENMES+19 * EXIT3 LDA SINGL CHANGE TO SINGULAR, CLB,INB IF ANY = 1. CPB DISCT STA ENMES+12 CPB ERMX STA ENMES+18 LDA SING. CPB WAR STA ENMES+25 * JSB WRT.C SEND THE NEWS DEF C.TTY TO THE TTY DEF ENMES DEF K26 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 ERROR MATRIX. KEEP DISCT NOP THESE ERMX NOP LINES WAR NOP IN DEC 2030 DATE CODE SEQUENCE. * ERMES ASC 21,/FTN4X: ACCESS FAILED ON LIST AND SOURCE. ENMES ASC 26,$END FTN4X: NO DISASTERS, NO ERRORS, NO WARNINGS. "NO" ASC 1,NO "00" ASC 1,00 SINGL ASC 1,, SINGULAR ENDING. SING. ASC 1,. WITH DOT INSTEAD OF COMMA. T1TRM NOP SKP * CAN'T USE LIST FILE. WRITE TO TTY. * TRML LDA K15 GET COUNT FOR MESSAGE RSS SKIP DOUBLE FAILURE TRMSL LDA K21 BOTH SOURCE AND LIST FAILED TO OPEN CLB CLEAR THE STB ERMX ERROR STB WAR AND WARNING COUNTS STB TOTER EOFER STA T1TRM SET FOR CALL JSB WRT.C SEND TO THE TTY DEF C.TTY DEF ERMES DEF T1TRM NOP IGNOR ERRORS (WHAT ELSE CAN WE DO HERE?) LDA T1TRM GET THE ERROR COUNT CPA K15 SET UP THE ERROR COUNTS CLB,INB,RSS ONE ERROR LDB K2 TWO ERRORS STB DISCT SET THE DISASTOR COUNT ADB TOTER SET THE COUNTS STB TOTER JMP TRM1 NOW GO DO THE EXIT SPC 2 END F4.4 ASMB,Q,C HED FTN4X COMPILER (F4X.5:PASS 3) NAM F4X.5,5 92834-16003 REV.2030 800731 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 5 *************************************** * * THIS OVERLAY TRANSLATES THE PSEUDOCODE GENERATED BY PASS 2 INTO * RELOCATABLE BINARY, AND GENERATES THE ASSEMBLY LISTING. * * 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 EXTRY EXT F.CCW FTN OPTION WORD EXT F.CSZ COMMON SIZE EXT F.D.T ADDRESS OF '.' FUN. TABLE EXT F.DNB DEF OF NBUF (NAM RECORD) EXT F.EM EMA BIT IN A.T. EXT F.EMA F.A OF THE EMA MASTER. EXT F.EMS EMA SIZE, DOUBLE WORD. EXT F.ER0 ERR0 NAME CHANGE OPTION. EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. EXT F.IU ITEM USAGE. EXT F.MSG MSEG SIZE ON $EMA(...) EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SEG LOAD A NEW SEGMENT EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.UFM F.A OF TWPE ENTRY FOR .UFMP EXT F.#M MAX # NON-DISC CONNECTIONS. EXT F.#N MAX # DISC CONNECTIONS. EXT F.#S BUFFER MULTIPLE & DS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT EJP.F PAGE EJECT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT MPN.F MOVE PROGRAM NAME (TO NAM RECORD ECT.) EXT MVW.F MOVE WORDS. EXT NAM.F COPY SYMBOL NAME. EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * LIBRARY UTILITIES * EXT .MVW MOVE WORDS MACRO EXT IFBRK BREAK CHECK ROUTINE * * OPSYSTEM INTERFACE: * EXT RED.C READ FILE ROUTINE EXT WRT.C WRITE FILE ROUTINE EXT RWN.C REWIND FILE ROUTINE EXT C.SC0 SCRATCH FILE FCB EXT C.BIN BINARY FILE FCB * * EXTERNAL IN THIS SEGMENT. * EXT END.F END PROCESSOR. * A EQU 0 B EQU 1 SUP SPC 1 K5 DEC 5 OVERLAY # SKP * ENTRY. * F4.5 JSB END.F END PROCESSING. CLA SHOULDN'T NEED ERROR RECOVERY ADDR, STA F.ERX BUT ZAP IT JUST IN CASE. LDA F.CCW SET UP LOCAL FLAGS AND B40 ISOLATE THE BINARY FLAG STA BFLG SAVE IT LDA F.ER0 IF AN ERR0 OPTION, SZA STA ERR0 CHANGE THE NAME TO 'ERRX' LDA F.CCW NOW PUT RAR,RAR M BIT IN LOW PART OF STA CCW LOCAL WORD CLA NEWBL STA COMCO SET COUT OF CURRENT BLOCK COMMON MODULE CCA SET TO NOT IGNOR STA IGNOR ANY THING CLA SET CURRENT ADDR IN CASE NULL PROG, STA ASA FOR END PROCESSING. JSB RWN.C REWIND 2ND PASS FILE DEF C.SC0 JMP ERROR ERROR ON PASS FILE ACCESS SPC 1 LDA F.SFF BLOCK DATA ? CPA K2 JMP FBL03 YES. START IT. JMP OTNAM NO. GO SEND THE NAME RECORD * NTATI OCT 007601 IGNOR NOP COMCO NOP T1FBL NOP COMMS NOP CURRENT MASTER ADDRESS K9 DEC 9 FBCFA DEF *+2 F.A OF FAKE BLANK COMMON HEADER. DEC 0 LINK: THIS IS LAST ITEM. B7200 OCT 7200 AT=BCOMI, IU=SUB, NT=0. OCT 0 LENGTH = 0. " OF SIZE. SZB IF SIZE >= 8095 PAGES, CCA SET IT TO 8095. CLE,ERA (A) = # PAGES * 4. ARS,ARS # PAGES. IOR EMTYP ADD THE EMA TYPE BITS STA WBUF+1 SET IN WORD TWO OF THE RECORD LDA K7 7 WORD RECORD JSB .WRIT WRITE IT JSB SET SET UP TO CONTINUE THE EXT'S JMP FINAL GO PRINT SUMMARY, THEN DO DBL'S. * EMTYP OCT 140000 SKP * ****************************************** * * SHORTEN 6 CHAR. EXT NAMES TO 5 CHARS & * * * CHECK FOR DUPLICATE NAMES. * * ****************************************** SPC 1 * ENTRY: (A) = ADDR 5TH,6TH CHARS. * (T1EX) = F.A OF SYMBOL, OR -1:NAM OR -2:DOT FCT. * (T2EX) = (NEGATIVE) EXT ID IF NORMAL OR DOT FCT. * EXIT: SHORTENED IF 6 CHARS (WITH WARNING) * WARNING IF ANY DUPLICATES FOUND. * EXLNC NOP STA EXTM SAVE ADDRESS OF NAME LDB A,I GET LAST TWO CHARS. STB ERM5 SAVE LAST TWO CHAR IN MESSAGE BUF STB ERM6 SAVE LAST TWO CHAR IN MESSAGE BUF ADA KM2 COPY FIRST FOUR. DLD A,I FIRST FOUR. DST ERM1 SAVE IN BOTH PARTS. DST ERM2 LDA EXTM,I GET LAST CHAR AND B377 ISOLATE THE LAST CHAR CPA B40 IF BLANK JMP EXLNX NAME IS OK * ALF,ALF ELSE SHORTEN IT BY IOR B40 REMOVING THE 5TH CHARACTER. STA ERM6 STA EXTM,I ALSO IN RECORD. LDA ER68 AND JSB WAR.F SEND THE WARNING. LDA K14 AND THE MESSAGE LDB DERM LENGTH AND ADDRESS TO A,B JSB PSL.F PRINT IT EXLNX JSB GFA.F START SCAN FOR DUPLICATE. * EX01 JSB GNA.F GET THE NEXT ASSIGN ENTRY SZA,RSS JMP EXLNC,I END ALL OK OR REPORTED * LDA F.A,I GET THE TAG WORD AND B7600 F.AT & F.IU . CPA B2200 EXTERNAL SUBROUTINE ? RSS YES SKIP CPA B7200 OR COMMON LABEL ? RSS JMP EX01 NO TRY NEXT ENTRY * LDA F.A MUST HAVE AN INA ORDINAL (NEGATIVE) LDA A,I SSA,RSS INTRINSIC OR NOT USED ? JMP EX01 YES, PASS IT BY. * LDB F.A GET ADDRESS CPB T1EX IF SAME ADDRESS THEN JMP EX01 IT IS THE SAME SYMBOL OK * JSB NAM.F ELSE COPY THE SYMBOL. DEF ERM1 (LEAVE SHORTENED ONE ALONE) LDA ERM1 CHECK FIRST TWO. CPA ERM2 RSS JMP EX01 NO, TRY NEXT ONE. LDA ERM3 CHECK 3RD & 4TH. CPA ERM4 RSS JMP EX01 NO. LDA ERM5 IF 6TH NOT BLANK DELETE 5TH. AND B377 6TH CHAR. LDB A (SAVE IN B) LDA ERM5 5TH & 6TH CHARS. CPB B40 IF 6TH NONBLANK, RSS (BLANK. LEAVE IT) ALF,ALF MOVE 6TH CHAR TO 5TH POSITION, AND BM400 AND CHANGE 6TH POSITION TO BLANK. IOR B40 CPA ERM6 HOW ABOUT 5TH CHAR ? RSS JMP EX01 NOPE. IS O.K. * LDA T1EX CHECK IF NAM OR DOT FCT. SSA,INA IF SO ALWAYS JMP EX08 REPORT * LDA A,I IF ORDINALS LDB F.A ARE INB CPA B,I THE SAME JMP EX01 WE ALREADY REPORTED THIS ONE * EX08 LDA K91 WARNING 91. LDB T1EX UNLESS: INB,SZB,RSS PROGRAM NAME: 85, LDA K85 INB,SZB,RSS OR DOT FUNCTION: 92. LDA K92 JSB WAR.F SEND THE MESSAGE (CAN'T USE ER.F) LDA K3 LDB DERM2 SEND THE NAME JSB PSL.F TO THE LIST DEVICE TOO * LDA T1EX IF IN NAM BUFFER INA,SZA,RSS THEN JMP EX01 DO NOT CHANGE * LDA T2EX ELSE USE CALLER'S SYMBOL LDB F.A TO REPLACE INB THE CURRENT SYMBOLS STA B,I JMP EX01 TRY NEXT SYMBOL SKP * SOME MISCELLANEOUS SUBROUTINES. * CLOSE NOP FINISH & OUTPUT EXT RECORD. CCE LDA WORD RAL,ERA STA WBP1,I "EXT" RECORD DESIGNATOR CLE,ELA ADA WORD NO. OF SYMBOLS *3 ADA B3 JSB .WRIT JSB SET RE-INITIALIZE JMP CLOSE,I SPC 2 SET NOP LDA WBP2 'DEF WBUF+2' STA WLOC CLA SET WORD STA WORD JMP SET,I SKP * ******************************* * * CONVERT TO 5 DECIMAL DIGITS * * ******************************* * * CALLING SEQ: LDA * JSB AS5.F * DEF * * THE BUFFER WILL GET 5 DIGITS (LEADING ZERO SUPPRESS) & A BLANK. * AS5.F NOP LDB AS5.F GET, RESOLVE ADDR. ISZ AS5.F LDB B,I RBL,CLE,SLB,ERB JMP *-2 STB T1AS6 & SAVE. * SZA,RSS VALUE = 0 ? JMP AS601 YES. CHANGE TO '(NONE)'. * CLB,CLE START WITH FIRST 4 DIGITS. DIV K10 DIVIDE BY 10. (E=0 FOR LEADING STB T2AS6 SAVE LAST DIGIT. ZERO SUPPRESS) JSB ASC.F (E) HAS BEEN SET UP BY NOW. SWP INSERT IN BUFFER. DST T1AS6,I T1AS6 EQU *-1 ISZ T1AS6 ADVANCE TO THIRD WORD. ISZ T1AS6 LDA T2AS6 INSERT DIGIT,BLANK THERE. ALF,ALF ADA "0_" STA T1AS6,I JMP AS5.F,I DONE. * AS601 LDA DNONE ZERO, USE '(NONE)' LDB T1AS6 JSB .MVW DEF K3 NOP JMP AS5.F,I EXIT. * DNONE DEF NONE NONE ASC 3,(NONE) T2AS6 NOP LOWEST DIGIT. SKP DERM DEF *+1 ASC 1, ERM1 ASC 1, ERM3 ASC 1, ERM5 ASC 1, ASC 7, SHORTENED TO ERM2 ASC 1, ERM4 ASC 1, ERM6 ASC 1, K14 DEC 14 DERM2 DEF ERM2 KM3 DEC -3 KM4 DEC -4 KM2 DEC -2 EXTM NOP ER68 DEC 68 KM5 DEC -5 K7 DEC 7 K1 DEC 1 B100 OCT 100 B600 OCT 600 BM400 OCT 177400 B2200 OCT 2200 F.AT=STRAB, F.IU=SUB: EXT SUB. ARR EQU B600 KK20 OCT 20000 KK774 OCT 177400 BLNKS ASC 2, EXORD NOP CTR1 NOP COUNTER FOR .TBL TABLE CTR2 NOP COUNTER FOR EXT ENTRY PTEXT NOP EXT POINTER CWA NOP CURRENT WORD ADDR. IN TABLES TEMP4 NOP MARKS WHEN SOURCE REC SPLIT NREC NOP ADDR OF NEXT RECORD IN RBUF RCYC NOP PHASE OF READ INDICATOR CYCLE RIIND NOP DATA INDICATOR FOR READ RSIND NOP DATA INDICATOR STRING FOR READ WBP1 DEF WBUF+1 WBP2 DEF WBUF+2 WBP3 DEF WBUF+3 WBP5 DEF WBUF+5 WBP59 DEF WBUF+59 * "0_" ASC 1,0 SINGL EQU BLNKS * EWMSG ASC 02, ** NWAR ASC 08, NO WARNINGS ** NERR ASC 07, NO ERRORS ** ASC 06, PROGRAM: PRSIZ ASC 03,(NONE) ASC 07, COMMON: CMSIZ ASC 03,(NONE) ENDK4 DEF EWMSG SKP * PRINT SUMMARY INFO. * FINAL CLA SKIP JSB SKL.F LINE ON THE LIST LDA F.RPL OUTPUT PROGRAM SIZE IN DECIMAL. JSB AS5.F DEF PRSIZ GETCW LDA F.CSZ OUTPUT COMMON SIZE IN DECIMAL. JSB AS5.F DEF CMSIZ LDA F.ERF # OF ERRORS CLE,SZA,RSS E=0, SUPPRESS LEADING ZEROES. JMP ENDP7 NONE. * LDB SINGL IF EXACTLY ONE ERROR, CPA K1 STB NERR+5 CHANGE ENDING TO SINGULAR. JSB ASC.F MAKE ASCII, STORE IN ERBUF STB NERR STA NERR+1 ENDP7 DLD F.ERF ANY WARNINGS?? CMA,INA ALL ERRORS ARE ALSO LOGED AS WARNINGS ADA B SO BACK THEM OUT CLE,SZA,RSS WELL?? (E=0, SUPPRESS LEADING ZEROES) JMP END10 NO SKIP CONVERSION * LDB SINGL IF EXACTLY ONE WARNING, CPA K1 STB NWAR+6 CHANGE ENDING TO SINGULAR. JSB ASC.F YES CONVERT WARNNING NUMBER STB NWAR SET IN MESSAGE STA NWAR+1 END10 LDB COMCO BLOCK DATA & NOT FIRST BLOCK, SZB THEN JMP END11 DON'T PRINT IT AT ALL * LDA K36 LDB ENDK4 JSB PSL.F PRINT SIZES & NO. OF ERRORS END11 LDA CCW SET CONTROL STMT. DATA SLA IF LISTING BINARY JSB EJP.F EJECT PAGE SKP * ********************************** * * PROCESS DBL RECORDS * * ********************************** SPC 1 JSB TERM INIT DBL RECORD OUTPUT LDB DLBUF SET SLBUF LDA CCW SLA,RSS IF NOT LISTING ADB B3 NO, ALTER SLBUF TO PUT ASSY STB SLBUF CODE AT LEFT MARGIN. CLB STB TEMP4 SPC 2 * * READ INTERMEDIATE CODE * SPC 1 READ JSB IFBRK CHECK FOR BREAK DEF *+1 SSA WELL? JMP BREAK YES GO HANG IT UP JSB RED.C READ A RECORD FROM THE DEF C.SC0 2ND PASS FILE. DRBUF DEF RBUF BUFFER DEF B100 64 WORDS JMP ERROR READ ERROR GO REPORT AND EXIT * SSB IF EOF JMP END. GO SEND THE END RECORD * LDA DRBUF 'DEF RBUF' STA RLOC LDA RLOC,I EXAMINE FIRST WORD OF RECORD SZA,RSS SECTOR END? JMP READ YES, READ ANOTHER * SSA SOURCE OR XREF?? JMP SOURC YES GO HANDLE * STA CO SAVE COUNT ADA RLOC STA NREC BUFFER POSN OF NEXT RECORD JMP DPREP NO; GO TO DATA PREP ROUTN SPC 1 SOURC CPA KM2 IF XREF RECORD JMP READ IGNOR IT * RAL,CLE,ERA ELSE REMOVE THE FLAG BIT STA DRBUF,I AND RESTORE THE WORD LDA B RECORD SIZE TO A LDB DRBUF ADDRESS TO B JSB PSL.F WRITE IT JMP READ AND GO READ THE NEXT RECORD * CCW NOP CO NOP * B40 DEC 32 T2PUT NOP B3 DEC 3 K97 DEC 97 * ERROR LDA K99 READ ERROR ON PASS FILE JMP F.ABT ABORT COMPILE * BREAK LDA K96 SET BREAK ERROR JMP F.ABT AND ABORT THE COMPILE * K96 DEC 96 K99 DEC 99 WERR LDA K97 WRITE ERROR ON BINARY FILE JMP F.ABT ABORT * B7000 OCT 7000 BCOMI EQU B7000 B7600 OCT 7600 MASK OVER F.AT, F.IU B1200 OCT 1200 F.AT=REL, F.IU=SUB = STMT FCT. DUM OCT 5000 REL OCT 1000 SUB OCT 200 KK01 DEF 0,I K36 DEC 36 TRANS NOP R4ORG OCT 120261 RADIX-40 'ORG' R4BSS OCT 047645 RADIX-40 'BSS' T1LAB NOP STMT FCT FLAG FOR LAB.F SKP * *************************** * * SUPPLY LABEL SUBROUTINE * * *************************** * * LAB.F NOP SCAN ASSIGNMENT TABLE LDA BMAX SET DELTA TO LARGER VALUE. STA DELTA JSB GFA.F START SCAN FOR SYMBOL WITH THIS ADDR. LAB0B CLA CLEAR STMT FCT FLAG. STA T1LAB LAB00 JSB GNA.F GET ASSIGNMENT ENTRY LAB0A SZA,RSS IF END OF TABLE JMP LAB01 THEN TRY FUNCTION/SUBROUTINE NAME. * LDA F.A,I GET FLAG WORD. AND B7000 ISOLATE THE F.AT FIELD CPA REL MUST BE EITHER RSS REL CPA DUM OR DUM RSS IF NOT JMP LAB00 REJECT IT * JSB FA.F FETCH F.AF LDB F.A (JUST IN CASE) JSB LAB? TRY THIS ADDRESS. LDA F.A,I STMT FCT ? AND B7600 I.E., F.AT=REL & F.IU=SUB ? CPA B1200 JMP LAB03 YES. * LDA F.EM NO. EMA FORMAL ? SZA,RSS (IF NON-FORMAL, DIDN'T GET THIS FAR) JMP LAB00 NO. SKIP IT. * DLD F.A,I YES. (B) = F.A OF DIM OR BCOMI. LDA F.IU ARRAY ? CPA ARR RSS (YES) JMP LAB04 NO. (B) = F.A OF BCOMI * ADB K2 ELSE IT'S IN WORD 2 OF THE DIM ENTRY. LDB B,I (IT WAS MOVED BY END.F) LAB04 ADB K2 FINALLY, GET THE ADDR OF THE PARAM. LDA B,I LDB F.A (JUST IN CASE) JSB LAB? TRY THIS ADDR. JMP LAB00 SKIP TO NEXT. * LAB03 DLD F.A,I STMT FCT. (B) = EXTENSION ADDR. INB LDA B,I (A) = ADDR FIRST FORMAL. LDB F.A SAVE CURRENT F.A STB T1LAB STA F.A (A) = F.A = FIRST FORMAL. JMP LAB0A GO SEARCH FORMALS TOO. * LAB01 LDA T1LAB IS JUST END OF STMT FCT FORMALS ? STA F.A (JUST IN CASE) SZA WELL ? JMP LAB0B YES. RESUME AFTER STMT FCT. * LDB F.SBF NO, END. 0=MAIN, ELSE SUBROUTINE F.A LDA F.REL ENTRY POINT OF SUBPROGRAM. SZB IF NOT MAIN, JSB LAB? TRY THIS ADDR. * LDA F.UFM UNIT-FILE MAP ? SZA,RSS JMP LAB.F,I NO. EXIT. * INA YES. GET ITS ADDR, LDA A,I LDB DUFMP (ADDR OF LABEL) JSB LAB? AND TRY IT. JMP LAB.F,I TRIED THEM ALL. EXIT. * DUFMP DEF *+1,I DEF TO '.UFMP' ASC 3,.UFMP DFCBP DEF *+1,I DEF TO '.FCBP' ASC 3,.FCBP SKP * ROUTINE TO CHECK FOR MATCHING LABELS. * ENTRY: (A)=ADDR OF LABEL. * (B)=F.A OF LABEL OR DEF,I OF ASCII. * LAB? NOP CMA COMPUTE LABEL-* ADA ASA CMA SZA,RSS IS THIS SYMBOL A MATCH ? JMP LAB?2 YES. * SSA NO. IS IT BEFORE OR AFTER ? JMP LAB?,I BEFORE. IGNORE IT. * LDB DELTA AFTER. OLD MININUM. CMB,INB ADB A (CURRENT) - (OLD) SSB,RSS IS CURRENT < OLD ? JMP LAB?,I NO. IGNORE IT. * LDB MXORG YES. IS IT IN AREA ORD'D BACK OVER ? CMB,INB ADB ASA ADB A (LABEL) - (MAX ORG POINT) SSB,RSS STA DELTA NO, NEW MINIMUM TO NEXT SYMBOL. JMP LAB?,I DONE. * LAB?2 LDA LBUF+12 ALREADY GOT ONE ? CPA BLNKS RSS (NO) JMP LAB?,I YES. DON'T BOTHER WITH OTHERS. * RBL,CLE,SLB,ERB NO. SYMBOL OR JUST ASCII ? JMP LAB?4 ASCII. * JSB STOL SYMBOL. PUT IN THE BUFFER. DBL LBUF+12 JMP LAB?,I AND GO ON. * LAB?4 STB LAB?5 ASCII. COPY IT. JSB MVW.F DEF LBUF+12 LAB?5 ABS *-* DEC 3 JMP LAB?,I DONE. * DELTA NOP MINIMUM DISTANCE TO NEXT SYMBOL. BMAX OCT 77777 MXORG OCT 0 MAX ADDR FROM WHICH ANY ORG BACK DONE. SKP * BSS HANDLER WITH LABELS INCLUDED. * ENTRY: (ASA)=CURRENT ADDR. * (A) =AMOUNT TO BSS. * EXIT: MIXED LISTING LINE PRINTED. * (ASA) UPDATED. * BSS.F NOP BSS01 STA T1BSS T1BSS = AMOUNT LEFT TO DO. SZA,RSS DONE ? JMP BSS.F,I YES. EXIT. * JSB CLR1 NO. CLEAR LIST BUFFER. LDA ADRST SET UP & PRINT STARTING ADDR. STA ASSLC LDB ASA JSB ASCI5 JSB LAB.F LOOK FOR LABEL & NEXT LABEL. LDA R4BSS OUTPUT 'BSS' JSB DSQZB LDB T1BSS IS THE NEXT LABEL BEFORE END OF BSS ? CMB,INB ADB DELTA (NEXT) - (BSS) LDA T1BSS IF NOT, USE FULL BSS, SSB IF SO, LDA DELTA USE OFFSET TO NEXT LABEL. LDB A SUBTRACT FROM TOTAL. CMB,INB ADB T1BSS STB T1BSS LDB A UPDATE CURRENT ADDR. ADA ASA STA ASA JSB ASCI5 OUTPUT OCTAL BSS COUNT. LDA "B" AND "B". JSB PUT.F JSB LIST LIST THE LINE. LDA T1BSS AND GO TRY FOR MORE. JMP BSS01 * T1BSS NOP AMOUNT LEFT TO DO. SKP * ** PREPARATION FOR DATA WORKING SEGMENT ** SPC 1 DPRE0 LDB F.SFF A.T. REFERENCE IS IT A BLOCK DATA FLAG? CPB K2 WELL CLB,RSS YES SKIP TO CHECK IF CURRENT ONE JMP DPR01 NO GO FETCH THE VALUE * CPA COMMS CURRENT MASTER? CCB YES SET FLAG STB IGNOR AS NEEDED CLA ORG IS IN THE ADDON JMP DPR02 GO SET IT UP * DPR01 INA STANDARD A.T. ORG LDA A,I GET THE VALUE JMP DPR02 AND CONTINUE * DPREP ISZ RLOC LDA RLOC,I COMPUTE NEW STORAGE ADDRESS IN A ISZ RLOC PUSH THE BUFFER POINTER RAL,CLE,SLA,ERA SKIPS IF FLAG, REMOVES JMP DPRE0 IF SYMBOL TABEL REF. GO CHECK * DPR02 ADA RLOC,I ADD ON TO ADDRESS CPA ASA IF NO CHANGE JMP CYCL SKIP THE BSS/ORG * LDB RLOC IF JUST AN INB ORG CPB NREC IGNOR THE RECORD (FROM DATA STMT. ECT.) JMP PNREC * LDB ASA B CONTAINS OLD ASA STA TRANS SAVE THE NEW ADDRESS CMB,INB ADA B STA TEMP2 SAVE THE DIFFERMENCE LDA IGNOR IF IGNORING SZA,RSS THEN JMP READ GO TO NEXT RECORD * LDA CCW IF LISTING NOT NEEDED SLA,RSS THEN JMP DPR00 SKIP THIS SET UP * LDA TEMP2 ORG OR BSS ? SSA JMP DPR03 ORG. * JSB BSS.F BSS. PRINT LINE(S). JMP DPR00 AND GO FINISH UP. * DPR03 JSB CLR1 ORG. CLEAR LIST BUFFER LDA R4ORG PRINT 'ORG' JSB DSQZB LDB TRANS CONVERT LOCATION. JSB ASCI5 LDA "B" FLAG IT AS JSB PUT.F OCTAL JSB LIST SEND TO THE PRINTER LDA ASA IS THE LWA+1 BEFORE ORG CMA,INA GREATER THAN MAX SO FAR ? ADA MXORG MAX - CURRENT LDB ASA (CURRENT) SSA IF SO, STB MXORG SET NEW MAX. DPR00 LDA TRANS GET THE NEW ADDRESS STA ASA AND SET IT JSB TERM OUTPUT THE OLD RECORD CYCL CCA CPA IGNOR IGNORING THIS DATA? RSS NO SKIP JMP READ YES GO READ THE NEXT RECORD * STA RCYC SKP PNREC ISZ RLOC ADVANCE READ PTR LDA RLOC READ PTR AT START OF NEXT REC? CPA NREC JMP READ YES; GO TO BEGINNING SEGMENT ISZ RCYC NO; ANY IND BYTES LEFT? JMP RIND LDA RLOC,I NO. FETCH NEW BYTE WORD. STA RSIND LDA KM5 RELOAD BYTE COUNTER STA RCYC ISZ RLOC LDA RLOC GO TO BEGINNING ROUTINE IF PTR CPA NREC AT START OF NEXT RECORD JMP READ RIND LDA RSIND ALF,RAR STA RSIND AND K7 STA RIIND LDB WLOC SET B TO WLOC + LGTH NEXT WORD -1 CPA K7 IF OFFSET ENTRY RSS TREAT AS MR FOR NOW CPA K5 RSS CPA K6 DITTO BYTE ADDR. INB HANDLES WORD LGTH=2 CMB,INB ADB WBP0 ADB K58 SSB OUTPUT BUFFER FULL? JSB TERM YES. ISZ WLOC JSB CLR1 BLANK THE LIST BUFFER SPC 2 * ** ALTER DATA WORD AND STORE ** SPC 1 LDA CCW SET E ERA IF LIST REQUIRED CLA STA EXTN SET EXT ID TO ZERO STA DI2 SET THE NO SYMBOL FLAG STA WIIND STA CX CLEAR OFFSET STA OPCOD LDA RLOC,I READ AND STORE DATA STA WLOC,I STA OFSET STORE FOR OBJECT LISTING LDB RIIND SZB,RSS JMP R0 CONSTANT. CPB K2 JMP R2 ASCII CHAR PAIR. CPB K3 JMP R3 ABSOLUTE INSTRUCTION. CPB K6 JMP R6 BYTE DEF. AND KK01 =B100000, CALCULATE DI1 STA DI1 MREXT LDA WLOC,I GET OPCODE AND KK076 =B76000 STA CODE CPB K4 JMP R4 EXT REF. * STB WIIND 2-WORD MEM REF; SET WIIND=5 ADA DI1 STA OPCOD SAVE OPCODE & INDIRECT LDA RLOC,I GET OPERAND RELOCATION BITS AND B3 STA MR ISZ RLOC ADV READ PTR LDB RLOC,I GET OPERAND RBL,CLE,SLB,ERB =0? CLEAR FLAG JMP INDRT NEGOF STB OPADD JMP CODE0 SPC 1 INDRT LDA RLOC,I GET THE WORD ADA K8 A NEGATIVE OFFSET OF 8 IS MAX SSA IF NOW NEGATIVE JMP ASTBR THEN ASSIGNMENT TABLE REF. * LDB RLOC,I ELSE IT IS A NEG. OFFSET SO JMP NEGOF RESTORE BE AND GO SET * ASTBR STB OPADD AREF LDA B,I GET FIRST WORD OF ENTRY AND B600 ISOLATE F.IU FIELD INB LDB B,I CPA ARR IF ARRAY JMP AREF GO ANOTHER LEVEL * ISZ DI2 SET THE SYMBOL USED FLAG CPA SUB SUBROUTINE ? JMP AREF2 YES. * LDA OPADD,I NO. GET TYPE. AND B170K CPA CHAR CHARACTER ? LDB B,I YES. (B) = ADDR DESCRIPTOR. JMP CODE0 * AREF2 LDA OPADD,I SUBROUTINE. WHAT KIND ? AND B7000 F.AT FIELD. CPA STRAB F.AT=STRAB ? RSS CPA BCOMI OR BCOMI ? JMP EXT YES, EXTERNAL SUB OR COMMON LABEL. * CPA REL F.AT=REL ? (ELSE F.AT=DUM) LDB B,I YES, STMT FCT, GET ADDR FROM EXTENSION. CODE0 LDA KK051 SET QUALIFIER='R ' STA QALST,I LDA K5 TEST THE RECORD TYPE CPA RIIND IF STD MR JMP MRIN GO TEST FOR DEF * STA WIIND ELSE SET TYPE TO MR ISZ RLOC GET THE OFFSET WORD LDA RLOC,I AND SET STA CX IT FOR FUTURE REF. ADB A SET PROPER ADDRESS MRIN LDA EXTN GET EXT NO. ADA CODE TEST IF INTERNAL DEF. SZA,RSS MUST NOT BE EXT REF. JMP DF YES. IT'S A DEF. * ISZ WLOC STB WLOC,I STORE ALTERED 2ND WORD ADB DI1 SET FULL ADDRESS IN B STB OFSET SET FOR LISTING CLA CLEAR A FOR FURTHER TESTS JMP MRTST * EXT CMB,INB SET THE EXT POSITIVE LDA K5 TEST IF STD. ONE WORD EXT CPA RIIND IS ALL THAT IS NEEDED JMP EXT1 YES ONE WORD ENTRY GO DO IT * STB EXTN NO A MR WITH OFFSET IS REQUIRED RBL,RBL FORM THE INSTRUCTION ADB WLOC,I FIX THE INSTRUCTION BY ADDING ADB K3 SET 'MR' FIELD TO ABSOLUTE STB WLOC,I THE ORDINAL CLB NOW CONTINUE TO SET UP THE OFFSET JMP CODE0 * EXT1 ADB WLOC,I FIX UP THE INSTRUCTION STB WLOC,I IN THE OUTPUT BUFFER LDA CCW SET THE LISTING BIT ERA IN E LDB K4 SET THE MR TYPE JMP MREXT GO SET UP A AND DO THE MR * SPC 1 DF ADB DI1 COMPLETE ADDRESS STB WLOC,I STB OFSET FOR OBJECT LISTING LDB MR COMPUTE WIIND INB STB WIIND MRTST LDB CCW IF NOT PRINTING CLE,SLB,RSS JMP NOPRT DONE WITH IT * CPA EXTN EXTERNAL REF? JMP NOTEX NO SKIP * LDA CODE EXT REF GET CODE JMP EXTS GO PUT TOGETHER * NOTEX LDB KK041 SET QUALIFIER ='C ' CPA MR IF NOT IN COMMON RSS SKIP THE RESET OF THE QUALIFIER STB QALST,I LDA CODE JSB INV.F PUT OPCODE INTO THE LIST BUFFER SKP * ** SUPPLY OPERAND SYMBOL ** SPC 1 LDB DI2 BIF BIT 15 IS ON THEN IT IS A SYMBOL SZB,RSS FROM THE SYMBOL TABLE WELL? JMP BRCH0 NOT IN TABLE SKP FURTHER CHECKS * LDA OPADD,I READ BASE WORD OF ENTRY SLA IF CONSTANT JMP SWTCH GO USE RELATIVE ADDRESS * LDB OPADD IT IS A REAL ENTRY IS IT A TEMP? JMP TRSYM GO PUT OUT THE SYMBOL SPC 1 BRCH0 LDA MR SKIP * OPERAND LOGIC IF COMMON SZA LOCATION JMP CNVT LDA KK025 '*+' LDB ASA COMPUTE DISTANCE BETWEEN OPERAND CMB,INB AND LOAD ADDRESSES ADB OPADD SSB IF NEGATIVE ADA K2 CHANGE TO '*-' SSB MAKE DISTANCE ABSOLUTE CMB,INB STA PUT2 SAVE THE PREFIX STB A AND KM8 =B177770, DISTANCE LESS THAN 8? SZA JMP CNVT NO. * ADB "0" =B60 YES CONVERT TO A CHARACTER LDA PUT2 SEND THE PREFIX JSB PUT2 LDA B GET THE OFFSET JSB PUT.F SEND TO THE BUFFER JMP TTDI1 SPC 1 SWTCH ISZ OPADD GET THE VALUE LDB OPADD,I FROM THE SYBMOL TABLE AND B170K F.IM: IS IT CPA CHAR CHARACTER ITEM ? LDB B,I YES. (B) = ADDR. STB OPADD AND SAVE IT * CNVT LDA OPLOC (A) = BUFFER POINTER. LDB OPADD (B) = VALUE. JSB ASCI6 PUT ADDRESS INTO THE BUFFER LDA "B" FLAG AS OCTAL JSB PUT.F LDB MR MR.F ROUTINE ADDS COMMON SYMBOL LDA "C" GET "C" CPB K2 IF IN COMMON JSB PUT.F ADD THE "C" TTDI1 LDB CX GET THE OFFSET SZB,RSS IF NONE JMP ITST GO TEST FOR INDIRECT * LDA B53 "+" PUT PROPER CONECTOR SSB IN THE BUFFER ADA K2 "-" FROM "+" JSB PUT.F SEND TO THE BUFFER SSB MAKE ABSOLUTE CMB,INB JSB ASCI5 PUT OFFSET IN THE BUFFER LDA "B" NOW PUT IN JSB PUT.F THE OCTAL INDICATOR ITST LDA B54 "," LDB DI1 IF INDIRECT FLAG NOT SET SZB,RSS THEN JMP PRINT GO PRINT WHAT WE HAVE * JSB PUT.F ELSE SEND A "," LDA "I" AND A JSB PUT.F "I" JMP PRINT AND THEN GO PRINT IT * * OPLOC DBR LBUF+17 TEMP2 NOP B53 OCT 53 '+' B170K OCT 170000 F.IM MASK. CHAR OCT 130000 F.IM=CHAR "0" OCT 60 "C" OCT 103 "B" OCT 102 B54 OCT 54 ',' "I" OCT 111 KM8 DEC -8 K2 DEC 2 K3 DEC 3 K6 DEC 6 K8 DEC 8 K58 DEC 58 B377 OCT 377 KK025 ASC 1,*+ KK400 OCT 40000 CBLNK ASC 1,C CROSS REF FLAG KK041 EQU CBLNK KK051 ASC 1,R KK076 OCT 76000 MR NOP MRI AND ASCII PARAMETER CODE NOP OP CODE CX NOP COMPLEX FLAG DI1 NOP BIT 15 WORD 1 DI2 NOP BIT 15 WORD 2 OPADD NOP OPERAND ADDR / BASE ADDR OP ENTR * * ** GENERATE ASSEMBLY LISTING ** SPC 1 R0 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP REST LDA R4OCT 'OCT' JSB DSQZB LDB WLOC,I CONVERT DATA TO ASCII LDA OPLOC GET ADDRESS OF OPCODE JSB ASCI6 JMP PRINT * * ASCII DATA. * R2 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP BUFFER SETUP * LDB A STORE ASCII CHARACTER PAIR AND B377 CPA B15 TRAILING CR? ADB B23 YES. SUBSTITUTE BLANK. STB TEMP2 LDA R4ASC 'ASC ' JSB DSQZB TO THE BUFFER LDA KK03 '1,' JSB PUT2 LDA TEMP2 JSB PUT2 PUT IN THE ASCI JMP PRINT * * BYTE DEF. * R6 STB WIIND SET OUTPUT RELOCATION = 6. CLA CLEAR INDIRECTION INDICATOR. STA DI1 LDA RLOC,I COPY RELOCATION BITS. RAL,CLE,ERA (MOVE L/R BIT TO (E).) AND B3 (NOTE: OPCOD=0 STILL) STA MR STA WLOC,I ISZ RLOC ADV READ PTR LDB KK051 SET QUALIFIER = 'R'. SZA UNLESS MR#0, LDB KK041 INWHICHCASE 'C'. STB QALST,I LDB RLOC,I GET OPERAND. STB OFSET SET WORD ADDR FOR LISTING. STB OPADD ELB BYTE ADDR. ISZ WLOC STB WLOC,I SET ADDRESS FOR OUTPUT, LDA CCW IF NOT PRINTING, SLA,RSS JMP NOPRT THEN DONE. * LDA R4DBL ELSE PRINT 'DBL', SLB LDA R4DBR OR 'DBR'. JSB DSQZB JMP BRCH0 FINISH PRINTING. * R4OCT OCT 117146 RADIX-40 'OCT' R4ASC OCT 044525 RADIX-40 'ASC' R4DBL OCT 054566 RADIX-40 'DBL' R4DBR OCT 054574 RADIX-40 'DBR' KK03 ASC 1,1, '1,' B15 OCT 15 B23 OCT 23 B1777 OCT 1777 E.TBL NOP END OF .TBL + 1. ADEXT DEF EXTST BASE LOC. OF EXTST KK054 ASC 1,X EXTN NOP EXTERNAL ID # SKP R4 STB WIIND EXTERNAL REFERENCE; SET WIIND =4 SEZ,CLE,RSS IF NOT LISTING JMP NOPRT SKIP THE SET UP * EXTS LDB KK054 SET QUALIFIER ='X ' STB QALST,I JSB INV.F CONVERT AND STORE OPCODE LDA EXTN GET POSSIBLE EXT NO. SZA,RSS IF NONE THEN LDA WLOC,I PICK UP FROM THE INPUT STREAM AND B1777 =B1777 GET EXT ORDNL STA OFSET SET FOR PRINTING CMA,INA SET NEGATIVE FOR COMPARE STA EXTN LDA DI2 IS THE LDB OPADD SYMBOL ADDRESS SUPPLIED? SZA WELL JMP TRSYM YES GO MOVE IT * LDA EXTN GET THE SYMBOL NUMBER TO A LDB F.D.T SEARCH EXTERNAL TABLE FOR MATCH CONSR CPA B,I JMP FOND1 INB CPB E.TBL END OF .TBL REACHED? RSS YES. JMP CONSR JSB GFA.F START S.T. SCAN. FIXT1 JSB GNA.F NEXT ! SZA,RSS DONE ? JMP FOND2 YES. * DLD F.A,I NO. FIND EXT #. CPB EXTN JMP FOND2 YES. FOUND IT. JMP FIXT1 LOOK AGAIN. SPC 1 FOND2 LDB F.A TRSYM JSB STOL COPY STRING TO ASSY LIST BUFF DBR LBUF+17 JMP TTDI1 SPC 1 FOND1 LDA F.D.T COMPUTE LOCATION IN EXTERNAL CMA,INA SYMBOL TABLE OF ENTRY ADA B STA B ORDINAL. ADA B ADA B *3 ADA ADEXT STA B ADA B3 STA STP JSB STMV MOVE IN THE SYMBOL JMP TTDI1 GO TEST FOR INDIRECTS ETC. SKP ASSBF DBR LBUF+15 DMODT DEF MODT BASE LOC. OF MODT (MODE OF TEMP) T1PNT NOP SPC 1 R3 SEZ,RSS IF NOT PRINTING JMP NOPRT SKIP BUFFER SET UP * JSB INV.F ABSOLUTE INSTR: FIND MNEMONIC SPC 1 * ** FINISH AND PRINT ASSY LIST BUFFER ** SPC 1 PRINT LDB OFSET LDA ASSLC GET CURRENT LOCATION STA T1PNT SAVE IT LDA OBJST PRINT JSB ASCI6 OBJECT CODE TO ASCII OCTAL LDB ASA LDA ADRST STA ASSLC SET ADDRESS FOR ADDRESS JSB ASCI5 ADDRESS TO ASCII OCTAL JSB LAB.F ADD ANY LABEL LDA T1PNT RESTORE STA ASSLC THE CURRENT LOCATION JSB LIST OUTPUT LIST BUFFER LDB RIIND GET THE OFFSET IF ANY LDA EXTN IF EXTERNAL CPB K7 AND OFFSET SZA,RSS THEN SKIP TO PRINT IT JMP NOPRT NOPE SKIP THE EXTRA LINE * JSB CLR1 CLEAR THE BUFFER AND PRINT THE OFFSET LDA OBJST GET THE ADDRESS OF THE OFFSET LDB CX GET THE OFFSET JSB ASCI6 SEND IT TO THE BUFFER LDA B53 '+' JSB PUT.F SEND '+' TO THE BUFFER JSB LIST LIST IT SKP * ** POST RELOCATION BYTE ** SPC 1 NOPRT ISZ WORD ISZ ASA LDA WSIND ROTATE WSIND LEFT 1 IND ALF,RAR STORE AT RIGHT WIIND ADA WIIND STA WSIND ISZ WCYC BRANCH ONCE-IN-5 JMP PNREC LDA KM5. RESET WCYC=-5 STA WCYC LDA WSIND ROTATE WSIND LEFT 1 RAL STA STOWS,I CLA STA WSIND ISZ WLOC LDB WLOC STB STOWS JMP PNREC * OPCOD NOP OFSET NOP ASA NOP ACTUAL STORAGE ADDR. STOWS NOP STORG LOC OF NEXT WSIND WIIND NOP WCYC NOP WLOC NOP WRITE LOCATION POINTER WSIND NOP KM5. DEC -5 ADRST DBR LBUF+4 OBJST DBL LBUF+8 QALST DEF LBUF+11 ASSLC NOP SPC 1 * **************************************** * * SYMBOL FROM ASS. TBL. TO LIST BUFFER * * **************************************** * STOL NOP B IF ASS. TBL. ADDRESS ADB K2 B IS ADDRESS OF FIRST CHARS. LDA STOL,I P+1 IS ADDRESS OF WHERE TO PUT IT STA ASSLC SET IT ISZ STOL STEP TO RETURN ADDRESS LDA B,I GET THE FIRST ID WORD SSA,RSS IF NEGATIVE SKIP JMP STOL0 IT IS >0 STD. SYMBOL * AND BC4K REMOVE 4000 BIT. ALF,ALF POSITION TO GET LEAST RAR 4 DIGITS (LEFT 1+(6-#DIG)*3) STA STMV SAVE THE NUMBER. ADB KM2 GET THE ADDRESS OF THE LDA B,I IM AND GET IT ALF POSITION THE IM FIELD. AND B17 ISOLATE ADA DMODT INDEX INTO TABLE LDA A,I FETCH TEMPCELL MODE SYMBOL JSB PUT2 PUT IT IN THE BUFFER LDA KM4 GET DIGIT COUNT LDB STMV GET THE NUMBER TO B JSB NUM.F CONVERT FOUR DIGITS INTO THE BUFFER JMP STOL,I RETURN * STOL0 ADB KM2 SET UP F.A STB F.A JSB NAM.F COPY NAME TO LOCAL BUFFER. DEF STNAM LDB DFSTN (B) = ITS ADDRESS. LDA DFSTE SET END ADDRESS. STA STP JSB STMV MOVE THE SYMBOL JMP STOL,I RETURN * * STMV NOP SYMBOL MOVE B=ADDRESS,STP= STOP ADDRESS STOL1 CPB STP DONE? JMP STMV,I YES EXIT * LDA B,I GET FIRST TWO CHAR. ALF,ALF ROTATE TO AND B177 GET FIRST CHAR CPA B40 IF BLANK, JMP STMV,I QUIT, NO BLANKS ALLOWED. * JSB PUT.F PUT FIRST OUT FIRST LDA B,I GET NEXT AND B177 ISOLATE CPA B40 IF BLANK JMP STMV,I QUIT. * JSB PUT.F ELSE PUT IT OUT INB STEP B JMP STOL1 GO GET NEXT CHAR. * STP NOP B17 OCT 17 B177 OCT 177 DFSTN DEF *+1 STNAM BSS 3 DFSTE DEF * SPC 1 SKP SPC 2 * ** FINISH AND OUTPUT DBL RECORD ** SPC 1 TERM NOP LDB WORD SZB,RSS JMP TERMX EMPTY RECORD. ADB KK601 =B60100 STB WBP1,I LDA WLOC IF A NEW CPA STOWS DBL FLAG WORD IS LAST JMP NORT SKIP THE ROTATE BIT * LDB WSIND ROTIN BLF,RBR ROTATE WSIND LEFT ONE IND ISZ WCYC JMP ROTIN * RBL COMPLETE PREPARATION OF WSIND STB STOWS,I ISZ WLOC NORT LDA WBP0 COMPUTE RECORD LENGTH CMA,INA ADA WLOC JSB .WRIT OUTPUT DBL RECORD * * INITIALIZE NEXT DBL RECORD * TERMX LDA KM5. =D-5 STA WCYC LDB WBP0 'DEF WBUF' ADB K4 STB WLOC STB STOWS CLA STA WORD WORDS OF OBJECT CODE STA WSIND LDA ASA SET RECORD ORIGIN STA WBP3,I JMP TERM,I * * ************************************ * * OUTPUT RELOCATABLE BINARY RECORD * * ************************************ SPC 1 .WRIT NOP LDB BFLG DOES HE WANT A SZB,RSS BINARY?? JMP .WRIT,I NO JUST EXIT * LDB WBP0 ALF,ALF WORD CNT TO LEFT HALF STA B,I POST WC IN BUFFER ALF,ALF CMA,INA ADA B3 STA WORD COUNTER INB LDA B,I GET TYPE WORD ADB K2. ADA B,I TALLY CHECKSUM INB ISZ WORD JMP *-3 STA WBP2,I POST IN BUFFER LDA WBP0,I ALF,ALF GET WORDCOUNT STA RECLN SET IT JSB WRT.C OUTPUT RECORD DEF C.BIN WBP0 DEF WBUF DEF RECLN JMP WERR WRITE ERROR REPORT IT * JMP .WRIT,I SPC 2 RECLN NOP BFLG NOP # 0 IF BINARY TO BE PRODUCED K2. DEC 2 KK601 OCT 60100 K4 DEC 4 DLBUF DEF LBUF BASE ADDRESS OF LIST BUFFER KK120 OCT 120000 RLOC NOP SLBUF NOP ADDR OF 1ST WORD IN LIST OUTPUT WORD NOP NUMBER OF ENTRIES SPC 2 * ************************* * * FINISH DBL PROCESSING * * ************************* SPC 1 END. LDA ASA COMPUTE SIZE OF FINAL BSS. CMA,INA ADA F.RPL LDB CCW PRINTING ? SLB JSB BSS.F YES, OUTPUT BSS LINE(S). JSB TERM DUMP LAST DBL RECORD LDA CCW PRINTING ? SLA,RSS JMP END02 NO. * JSB CLR1 'END': CLEAR THE BUFFER, LDA ADRST INSERT LWA+1 ADDR, STA ASSLC LDB F.RPL JSB ASCI5 LDA R4END GET 'END', JSB DSQZB PUT IT IN BUFFER, LDA F.SBF SEE IF XFER ADDR. SZA WELL ? JMP END01 NO. GO PRINT. * LDB F.REL YES. CONVERT IT, JSB ASCI5 TO 5 OCTAL DIGITS, LDA "B" ADD "B", JSB PUT.F END01 JSB LIST AND LIST. END02 CLA SKIP A LINE JSB SKL.F ON THE LIST DEVICE LDA F.SFF IF BLOCK DATA SUB. PGM. CPA K2 THEN RSS (YES) JMP END03 NO. * LDA BLKN SEE IF SPECIAL BLANK COMMON; CPA " 57B, '.' CCA ADA BM13 IS IT A LETTER SSA,RSS ADA K7 YES, MAP 13B-44B TO 101B-132B CPA BM13 MAP 0 => 77B, '?' LDA K5 ADA B72 OTHERWISE MAP 1B-12B TO 60B-71B, '0'-'9' JSB PUT.F PRINT. (46B,47B UNUSED) JMP CONV,I RETURN SKP * MOVE TO OPCODE, PRINT 3 RADIX-40 CHARS & BLANK. * DSQZB NOP LDB ASSBF MOVE COLUMN CURSOR. STB ASSLC JSB DSQZ PRINT 3 CHARS FROM (A). LDA B40 AND B40 . JSB PUT.F JMP DSQZB,I EXIT. * B45 OCT 45 B72 OCT 72 BM13 OCT -13 K40 DEC 40 K1600 DEC 1600 * * EXIT CODE. * EXIT LDA B40 FILL WITH B40 CHAR JSB PUT.F JMP INV.F,I AND RETURN SPC 2 * MEMORY REGERENCE INSTRUCTIONS. * MRG OCT 054750 DEF (FAKED) OCT 115002 NOP (FAKED) OCT 044216 AND OCT 100624 JSB OCT 154204 XOR OCT 100262 JMP OCT 075304 IOR OCT 075554 ISZ OCT 043373 ADA OCT 043374 ADB OCT 052533 CPA OCT 052534 CPB OCT 105673 LDA OCT 105674 LDB OCT 134773 STA OCT 134774 STB SKP SRG ALF SHIFT/ROTATE GROUP. ELA ERA ALR RAR RAL ARS ALS OCT 40 CLE SLA OCT 27 ALF OCT 26 ELA OCT 25 ERA OCT 24 ALR OCT 23 RAR OCT 22 RAL OCT 21 ARS OCT 20 ALS SRGA OCT 044100 ALF OCT 060473 ELA OCT 061053 ERA OCT 044114 ALR OCT 130324 RAR OCT 130316 RAL OCT 044475 ARS OCT 044115 ALS OCT 052277 CLE OCT 134273 SLA OCT 044100 ALF OCT 060473 ELA OCT 061053 ERA OCT 044114 ALR OCT 130324 RAR OCT 130316 RAL OCT 044475 ARS OCT 044115 ALS SRGB OCT 047200 BLF OCT 060474 ELB OCT 061054 ERB OCT 047214 BLR OCT 130374 RBR OCT 130366 RBL OCT 047575 BRS OCT 047215 BLS OCT 052277 CLE OCT 134274 SLB OCT 047200 BLF OCT 060474 ELB OCT 061054 ERB OCT 047214 BLR OCT 130374 RBR OCT 130366 RBL OCT 047575 BRS OCT 047215 BLS SKP * ALTER/SKIP GROUP. * ASG CCA CLA CMA SEZ CCE OCT 2100 CLE CME SSA SLA INA SZA RSS ASGA OCT 051523 CCA OCT 052273 CLA OCT 052343 CMA OCT 133674 SEZ OCT 051527 CCE OCT 052277 CLE OCT 052347 CME OCT 134723 SSA OCT 134273 SLA OCT 075213 INA OCT 135353 SZA OCT 131645 RSS ASGB OCT 051524 CCB OCT 052274 CLB OCT 052344 CMB OCT 133674 SEZ OCT 051527 CCE OCT 052277 CLE OCT 052347 CME OCT 134724 SSB OCT 134274 SLB OCT 075214 INB OCT 135354 SZB OCT 131645 RSS SKP * MISCELLANEOUS INSTRUCTIONS. * DSG SWP OCT 135202 CLO OCT 052311 SOC OCT 134465 SOS OCT 134505 * * TWO-WORD SHIFTS. * RRR 16 OCT 131574 LSR 16 OCT 107044 ASR 16 OCT 044544 RRL 16 OCT 131566 LSL 16 OCT 107036 ASL 16 OCT 044536 * * OTHER EAU. * EIG2 OCT 100200 MPY OCT 111763 OCT 100400 DIV OCT 055230 OCT 104200 DLD OCT 055376 OCT 104400 DST OCT 056046 SPC 3 * ** MODE OF TEMP CELL TABLE ** SPC 1 MODT NOP ASC 12,I.R.L.T.C.X.A.J.M.D.S.Z. LBUF ASC 1, BSS 46 LIST BUFFER RBUF BSS 128 READ BUFFER WBUF BSS 60 WRITE BUFFER SKP * ** EXTERNAL FUNCTION SYMBOL TABLE ** SPC 1 EXTST ASC 18,.DAD .FAD .XADD .TADD .CADD .DIN 6 ASC 18,.DSB .FSB .XSUB .TSUB .CSUB .DSBR 12 ASC 18,.DMP .FMP .XMPY .TMPY .CMPY .DDE 18 ASC 18,.DDI .FDV .XDIV .TDIV .CDIV .DDIR 24 ASC 18,.DNG ..FCM ..DCM ..TCM ..CCM .DCO 30 ASC 18,.ITOI .ITOJ .JTOI .JTOJ .CTOI .CTOJ 36 ASC 18,.RTOI .RTOJ .RTOR .RTOD .RTOT .FPWR 42 ASC 18,.DTOI .DTOJ .DTOR .DTOD .DTOT .EIO. 48 ASC 18,.TTOI .TTOJ .TTOR .TTOD .TTOT .TPWR 54 ASC 18,.IIO. .JIO. .RIO. .XIO. .TIO. .FIO. 60 ASC 18,.IAY. .JAY. .RAY. .XAY. .TAY. .BIO. 66 ASC 18,.IAE. .JAE. .RAE. .XAE. .TAE. .DTA. 72 ASC 18,EXEC .ENTR .DFER .CFER .GOTO .BAD. 78 ASC 18,.EMAP .ERES .FPAU .FSTP .TAPE ERR0 84 ASC 18,.FSIU .FSOU .ENTP .ARTN .DMAP .DRES 90 ASC 18,REIO XLUEX .IOOP .IOCL .IOIN .IOCN 96 ASC 18,.ICPX .CFTD .DCPX .TCPX .TDBL .DTBL 102 ASC 18,SQRT DSQRT .SQRT CSQRT %QRT $SQRT 108 ASC 18,/SQRT SIN DSIN .SIN CSIN %IN 114 ASC 18, /SIN #SIN COS DCOS .COS 120 ASC 18,CCOS %OS /ATN2 /COS #COS TAN 126 ASC 18,DTAN .TAN %AN $TAN /TAN TANH 132 ASC 18,DTANH .TANH %ANH ATAN DATAN .ATAN 138 ASC 18,%TAN ATAN2 DATN2 .ATN2 ALOG DLOG 144 ASC 18,.LOG CLOG %LOG $LOG /LOG #LOG 150 ASC 18,ALOGT DLOGT .LOGT %LOGT $LOGT /LOGT 156 ASC 18,EXP DEXP .EXP CEXP %XP $EXP 162 ASC 18,/EXP #EXP DABS .ABS CABS %ABS 168 ASC 18,%JABS %BS .DMOD AMOD DMOD .MOD 174 ASC 18,MOD %JMOD ISIGN .JSGN SIGN DSIGN 180 ASC 18,.SIGN %IGN %JSGN IDIM .JDIM DIM 186 ASC 18,.XDIM .DDIM MIN0 .JMN0 AMIN1 DMIN1 192 ASC 18,.MIN1 AMIN0 .AMNJ MIN1 .JMN1 MAX0 198 ASC 18,.JMX0 AMAX1 DMAX1 .MAX1 AMAX0 .AMXJ 204 ASC 18,MAX1 .JMX1 AIMAG CONJG AINT DDINT 210 ASC 18,.YINT %INT IFIX .FIXD .XFXS .XFXD 216 ASC 18,.TFXS .TFXD .CINT .CFXD %FIX %FIXD 222 ASC 18,IDINT %XFXD %TFXS %TFXD FLOAT .FLTD 228 ASC 18,SNGL .NGL REAL %LOAT %FLTD .XFTS 234 ASC 18,.TFTS .XFTD .TFTD DBLE .BLE .CDBL 240 ASC 18,.CTBL CMPLX %AND %DAND .DAND %OR 246 ASC 18,%DOR .DOR IXOR %DXOR .DXOR %OT 252 ASC 18,%DNOT .DEQV .ISH .JSH %ISH %JSH 258 ASC 18,%SSW ISSW .EXIT .FFRW .FIOI .MAE. 264 ASC 18,.SMAP .SRES .LIO. .LAY. .LAE. .MAY. 270 ASC 18,.SINH %SINH .COSH %COSH .ASIN %ASIN 276 ASC 18,.ACOS %ACOS .ASNH %ASNH .ACSH %ACSH 282 ASC 18,.ATNH %ATNH .CTAN %CTAN .DSNH %DSNH 288 ASC 18,.DCSH %DCSH .DASN %DASN .DACS %DACS 294 ASC 18,.DASH .DACH %DACH .DATH %DATH 300 ASC 18,.ZADD .ZSUB .ZMPY .ZDIV ..ZCM .ZTOI 306 ASC 18,.ZTOJ .ZMPX .ZINT .ZFXD .ZCPX .IZPX 312 ASC 18,.JZPX .FZPX .DZPX .CZPX .ZFER .ZSQR 318 ASC 18,.ZSIN %ZSIN .ZCOS %ZCOS .ZTAN %ZTAN 324 ASC 18,.ZLOG %ZLOG .ZEXP %ZEXP .ZABS .ZAIM 330 ASC 18,.ZCNG .NINT %NINT .NJNT %NJNT .IDNT 336 ASC 18,%IDNT .JDNT %JDNT .ANNT %ANNT .TNNT 342 ASC 18,%TNNT DEXEC .DNRW .DSRW 348 * NO.F EQU 348 NUMBER OF ENTRIES IN ABOVE TABLE .CHK. EQU *-EXTST-NO.F-NO.F-NO.F *** MUST BE ZERO *** * ERR0 EQU EXTST+83+83+83+1 ORG * END F4.5 ASMB,Q,C HED END STATEMENT PROCESSING. NAM END.F,8 92834-16003 REV.2030 800821 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * 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) * 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 'E' BIT FROM A.T. EXT F.A ASSIGNMEXT TABLE ADDRESS (CURRENT ENTRY) EXT F.ABT ABORT COMPILE EXTRY EXT F.AF ADDRESS FIELD CURREXT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CC CHARACTER COUNT EXT F.CCW FTN OPTIONS WORD. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D0 ARRAY ELEMEXT SIZE EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.DNB DEF TO NAM RECORD. EXT F.EM EMA FLAG BIT IN A.T. EXT F.END END FLAG EXT F.ERF ERROR FLAG (# OF ER.F CALLS) EXT F.ERX GLOBAL ERROR RECOVERY ADDRESS. 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.ND NUMBER OF DIMENSIONS. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.SBF 0= MAIN, ELSE SUBROUTINE EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.SPF SPECIFICATION FLAG SET TO CURREXT STMT. LEVEL EXT F.UFM ADDR OF UNIT-FILE MAP. EXT F.#M # NON-DISC CONNECTIONS. EXT F.#N # DISC CONNECTIONS. EXT F.#S BUFFER MULTIPLE. EXT F.#B # OF BUFFER BLOCKS. SKP * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AA.F ASSIGN ADDRESS SUB. EXT AI.F ASSIGN ITEM EXT CER.F COMPILER ERROR. EXT DAD.F DOUBLE INTEGER ADD. EXT DAF.F DEFINE (F.AF) EXT DAT.F DEFINE (F.AT) EXT DIM.F DEFIND (F.IM) EXT DIU.F DEFINE (F.IU) EXT DL.F DEFINE LOCATION SUBROUTINE EXT ER.F ERROR PRINT SUBROUTINE EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FC.F FETCH CONSTANT'S VALUE TO F.IDI EXT GCD.F GET VALUE OF CONSTANT INTEGER. EXT GFA.F GET FIRST (NAMED) SYMBOL TABLE ENTRY. EXT GFC.F GET FIRST (CONSTANT) SYMBOL TABLE ENTRY. EXT GFD.F GET FIRST (DEF) SYMBOL TABLE ENTRY. EXT GNA.F GET NEXT SYMBOL TABLE EXTRY EXT IN2.F INITIALIZATION FOR OA.F EXT NAM.F COPY SYMBOL NAME. EXT NWE.F COMPUTE (B) = ITEM SIZE, FROM F.IM EXT OAI.F OUTPUT ABS. INSTRUCTION. EXT OAD.F OUTPUT ABS. DATA. EXT OC.F OUTPUT CONSTANT EXT ODD.F OUTPUT DEF TO DOT FUNCTION. EXT ODF.F OUTPUT DOT FUNCTION EXT OLR.F OUTPUT LOAD ADDRESS EXT OS.F FLUSH OA.F'S BUFFER. EXT OW.F OUTPUT WORD. EXT PDF.F PRODUCE DEF SUBROUTINE EXT PSL.F PRINT LINE ON PRINTER EXT SKL.F SKIP LINES ON LIST EXT WAR.F ERROR COMMEXT SUBROUTINE (WARNINGS) * * COMPILER LIBRARY ROUTINES: * EXT EOF.C EXT C.SC0 FCB FOR 2ND PASS FILE. * * ENTRY TO THIS MODULE. * ENT END.F * SUP A EQU 0 B EQU 1 SKP * ***************** * * END PROCESSOR * * ***************** SPC 1 END.F NOP ISZ F.END SET THE END FLAG LDA DENX9 SET THE ERROR RECOVERY ADDRESS. STA F.ERX (SHOULDN'T HAPPEN, BUT BE SAFE) JSB IN2.F RE-INITIALIZE OA.F * * DO SOME ERROR CHECKING. * CCA SET FLAG STA F.CC TO USE SHORT FORM ERROR MESSAGE LDB F.SPF GET CURRENT STMT. LEVEL ADB KM3 TEST IF MORE THAN JUST SPECS AND DATA LDA F.SFF IF BLOCK DATA SUBPROGRAM CPA K2 THEN CMB CHANGE SENSE OF TEST SSB IF PROGRAM AND NO EXECUTABLE OR BLOCK DATA WITH JMP ENDP1 THEN GO SEND ERROR * LDA F.SFF SZB,RSS IF JUST STMT. FUNCTIONS CPA K2 AND NOT BLOCK DATA JMP ENDP0 THEN * ENDP1 LDA K66 BITCH JSB WAR.F ERROR 66: SHOULD/SHOULD NOT HAVE EXEC. STMTS. SKP * IF FUNCTION, MAKE SURE IT HAS BEEN DEFINED. * ENDP0 CLA,INA JSB SKL.F SKIP TWO LINES LDA F.SBF SUBPROGRAM FLAG SET? STA F.A SZA,RSS JMP ENDP8 NO, MAIN; GENERATE STOP CALL * JSB FA.F FETCH ASSIGNS LDA F.IU LDB F.SFF IS IT A FUNCTION? SZB XOR VAR YES. LDB A LDA K46 SZB JSB WAR.F FUNCTION NAME NOT USED OR SUB NAME USED. LDA VAR IF FUNCTION, MAKE SURE LOC DEFINED. LDB F.SFF SZB JSB DIU.F JMP END01 * ENDP8 LDA F.SFF IF BLOCK DATA SUBPROGRAM CPA K2 THEN JMP ENDX3 SKIP REST OF THE END STMT. PROCESSING SKP * ************************* * * PROCESS EMA VARIABLES * * ************************* SPC 1 END01 JSB OLR.F STARTING DATA, MUST INIT RELOC. JSB GFA.F START SCAN (AGAIN). END1A JSB GNA.F GET NEXT ONE. SZA,RSS DONE ? JMP ENDP3 YES. * JSB FA.F FETCH ASSIGNS. LDA F.EM IF NOT EMA, LDB F.IU OR F.IU=SUB (E.G. EMA MASTER) SZA CPB SUB JMP END1A THEN IGNORE IT. * * EMA VARIABLE. GENERATE ZERO-DIM & N-DIM TABLES. * LDA F.AF F.A OF THE BCOMI ENTRY. STA T0STF SAVE IT, INA AND GET THE ADDRESS INFO. LDB A,I LOWER BITS OR TEMP WITH BASE ADDR. STB T8STF SAVE THAT. INA & ADVANCE TO WORD 2. LDB F.AT IF NOT FORMAL PARAM, CPB DUM JMP END1B (YES. THEN LEAVE ADDR OF .ENTR PARAM) * LDB T8STF THEN SAVE LOWER BITS IN WORD 2 FOR STB A,I THE SYMBOL TABLE LIST. END1B INA NOW COPY THE UPPER BITS. LDB A,I STB T7STF LDB F.A SAVE F.A TO CONTINUE SCAN. STB T2STF INB SET F.A TO DIM ENTRY (IF ANY) LDB B,I (ELSE HAPPENS TO BE BCOMI ENTRY) STB F.A LDA F.IU ARRAY ? CPA ARR RSS YES. JMP STF08 NO. DO ZERO-DIM CASE. * ADB K2 YES. SAVE THE OFFSET F.A, LDA B,I STA T9STF LDA F.AF SO WE CAN PUT THE BCOMI POINTER STA B,I THERE. (FOR F4.3; OTHERWISE IS LOST) LDA F.A,I GET THE REFERENCE BIT. AND K8 SZA,RSS REFERENCED WITH SUBSCRIPTS ? JMP STF08 NO. GO DO ZERO-DIM TABLE. SKP * FULL TABLE WITH BOUNDS. * LDA F.AF YES. SAVE ADDR BCOM OFFSET ENTRY. STA T0STF LDA F.CCW IF 'S' OPTION, AND B40K IOR F.DIS OR DOUBLE INTEGER SUBSCRIPT, STA T5STF THEN T5STF#0. LDA F.D0+1 SAVE # WORDS PER ELEMENT. STA T6STF LDA F.RPL DEFINE THE PROGRAM ADDR OF TABLE. JSB DAF.F LDA F.ND SAVE # OF DIM. STA T3STF RAL,CLE *2, LOWER & UPPER BOUNDS. (E=0) ADA F.A COMPUTE ADDR OF UPPER BOUND OF ADA K2 LAST DIMENSION (NOT USED) STA T1STF AND SAVE IT. LDA F.ND FIRST WORD = # DIM. CCE SINGLE INTEGER. JSB BIC.F * * LOOP THRU DIMENSIONS & OUTPUT TO TABLE. * LDA T3STF # DIM CMA,INA NEGATE & SAVE AS COUNTER. STA T4STF JMP STF02 SKIP LAST UPPER BOUND. * STF01 LDA T1STF,I UPPER BOUND. OUTPUT CONSTANT/TEMP. JSB OTV.F STF02 LDA T1STF BACK UP POINTER TO PREVIOUS UPPER BOUND. ADA KM2 STA T1STF INA AND GET F.A OF CURRENT LOWER. LDA A,I IN (A). LDB T5STF IF .EMAP/.ERES, SZB,RSS JSB OTV.F THEN OUTPUT (NEGATED) LOWER BOUND. ISZ T4STF DONE NOW ? JMP STF01 NO. LOOP. SKP * NOW THE # WORDS PER ELEMENT AND THE OFFSET. * LDA T6STF # WDS PER. CCE AS SINGLE INTEGER. JSB BIC.F LDA T2STF,I FORMAL PARAM ? AND B7000 CPA DUM JMP STF06 YES. GO USE CALCULATED VALUE. * LDA T5STF IF .EMAP/.ERES, SZA JMP STF04 (NO) * LDA T8STF THEN OUTPUT REVERSED BASE ADDR. LDB T7STF JMP STF05 OUTPUT THE VALUE. * STF04 LDB T9STF DOUBLE INT. GET VALUE OF JSB GCD.F CONSTANT OFFSET TO ELEMENT NOP (0,,0) JSB DAD.F ADD THE BASE. DEF T7STF NOP IGNORE OVERFLOW. SWP USE IN REVERSED ORDER. STF05 CLE E=0 FOR BIC.F JSB BIC.F OUTPUT OFFSET, TWO WORDS. JMP STF08 DONE WITH DIMENSIONED CASE. * STF06 LDA T7STF FORMAL. USE BASE OR (0,0). JSB OCT.F OUTPUT THAT. SKP * NOW DO TABLE FOR ZERO-DIMENSION CASE. * STF08 LDA T0STF,I CHECK THE REFERENCE BIT. AND K8 SZA,RSS JMP STF10 IF NOT REFERENCED. * LDA T0STF YES. DEFINE ITS LOCATION. STA F.A JSB DL.F CLA,CCE OUTPUT ZERO. JSB BIC.F LDA T2STF,I IS IT A FORMAL ? AND B7000 CPA DUM JMP STF09 YES. * LDB T7STF NO. (B,A) = OFFSET. LDA T8STF CLE OUTPUT AS DOUBLE INT. JSB BIC.F JMP STF10 DONE. * STF09 LDA T8STF FORMAL. OUTPUT THE TEMP. JSB OCT.F STF10 LDA T2STF RESTORE F.A, STA F.A JMP END1A & GO FOR NEXT ITEM. SPC 1 T0STF NOP F.A OF BCOMI ENTRY. T1STF NOP RUNNING BOUNDS POINTER. T2STF NOP F.A OF VARIABLE NAME ENTRY. T3STF NOP NUMBER OF DIMENSIONS. T4STF NOP COUNTER FOR BOUNDS LOOP. T5STF NOP SAVED VALUE OF F.DIS T6STF NOP SAVED VALUE OF # WDS PER ELEMENT. T7STF NOP UPPER OFFSET OR TEMP FOR (0,,0) T8STF NOP LOWER OFFSET OR TEMP FOR (0,,0) T9STF NOP SAVED F.A OF CONST OFFSET TO (0,,0) KM2 DEC -2 B7000 OCT 7000 MASK FOR F.AT DUM OCT 5000 F.AT=DUM SKP * ************************** * * OUTPUT EMA TABLE VALUE * * ************************** SPC 1 * ENTRY: (A) = F.A OF CONSTANT OR TEMP. * * IF TEMP, JUST OUTPUT IT. * IF CONSTANT, OUTPUT AS A SINGLE INTEGER * IF F.DIS=0 AND DOUBLE IF F.DIS=1. * OTV.F NOP LDB A,I CONSTANT OR TEMP ? SLB JMP OTV01 NOT NAMED. CONSTANT. * JSB OCT.F NAMED. TEMP, OUTPUT IT. JMP OTV.F,I EXIT. * OTV01 LDB A GET VALUE. JSB GCD.F NOP STB F.IDI+1 SET E=0 FOR DOUBLE, 1 FOR SINGLE. LDB F.DIS CMB,CLE,INB,SZB,RSS (E=1 IFF F.DIS=0; SKIP IF F.DIS#0) LDA F.IDI+1 (SINGLE, PUT IT IN (A).) LDB F.IDI+1 (RESTORE (B)) JSB BIC.F OUTPUT IT. JMP OTV.F,I DONE. SKP * ****************************************************** * * PROCESS NAMED A.T. ITEMS (EXCEPT EMA & CHAR TEMPS) * * ****************************************************** SPC 1 ENDP3 JSB GFA.F START SCAN. ENDP4 CLA CLEAR STA IGNOR THE IGNOR SWITCH FOR LABEL GEN. JSB GNA.F GET NEXT F.A SZA,RSS JMP ENDPA END OF ASSIGNMENT TABLE JSB FA.F FETCH ASSIGNS * * IF EMA, SKIP. * IF ARRAY, SUBROUTINE OR COMMON LABEL, IGNORE. * LDB F.IU CPB SUB IF SUB OR COMMON LABEL, JMP ENDP4 THEN DONE WITH IT. * LDA F.EM EMA ? SZA JMP ENDP4 YES. IGNORE THIS TRIP. * CPB ARR IF ARRAY, JMP ENDP4 ALREADY DEFINED * * IF STMT #, GO SEE IF DEFINED. * CPA F.IU JMP ENDP9 F.IU=0, STATEMENT # * * ASSIGN ADDRESS. * LDA F.A SPECIAL CHECK FOR CHAR TEMP. ADA K2 LDA A,I NAME. TEMP IF < 0. LDB F.IM TYPE. CPB CHAR IF F.IM=CHAR, SSA,RSS AND TEMP, RSS NO. ASSIGN ADDR. JMP ENDP4 YES. SKIP IT. * LDA F.AT IF CPA REL ALREADY DEFINED ISZ IGNOR SET SWITCH LDA F..E REFERENCED ? SZA,RSS JMP ENDPG NO. * JSB AA.F ASSIGN ADDR TO VARIABLES SKP ENDPG LDA F.AF SEE IF SPECIAL IN-LINE ADDRESS TEMP. RAL,CLE,SLA,ERA F.AF<0 ? INA,RSS YES. POINT TO BASE ADDR. JMP ENDPI NO. GO ON. * * SPECIAL IN-LINE ADDRESS TEMP DUE TO A DEF TO * AN ADDR TEMP BEING GENERATED WHILE THE LOCATION * COUNTER HUNG ON A SYMBOL (IN IMPLIED DO). * LDA A,I GET THE LOCATION COUNTER BASE. LDB F.A GET OFFSET ADB K2 FROM THE ENTRY LDB B,I AND RBL,CLE,ERB CLEAR THE SIGN ADA B PUT FINAL ADDRESS IN A JSB DAF.F DEFINE ADDRESS OF THIS SYMBOL * * IF F.IM=ADDR AND WASN'T ALREADY F.AT=REL, * DEFINE IT TO BE A TWPE CONSTANT HERE. * ENDPI LDA F.IM IF CPA ADR ADDRESS RSS SKIP JMP ENDP4 * LDA IGNOR IF ADDRESS AND ALREADY DEFINED SZA,RSS NO NOT ALREADY DEFINED JMP ENDP4 FORGET IT * LDA TWPE ELSE DEFINE AS A PGM TMP JSB DIM.F AND ISZ TWA GIVE IT LDB TWA A NAME LDA F.A ADA K2 STB A,I JMP ENDP4 SKP BCOM OCT 3000 F.AT = BCOM COM OCT 4000 F.AT = COM DENX9 DEF ENDX9 ERROR RECOVERY ADDRESS. K2 DEC 2 KM3 OCT -3 TWA OCT 122000 B40K OCT 40000 TWPE EQU B40K ADR OCT 70000 K66 DEC 66 IGNOR NOP K8 DEC 8 K46 DEC 46 REL OCT 1000 AT =1 ARR OCT 600 SUB OCT 200 VAR OCT 400 * * CHECK STATEMENT #'S. * ENDP9 JSB NAM.F MOVE THE SYMBOL IN. DEF MSG+1 LDB MSG+1 FIRST TWO CHARS. LSR 8 (B) = FIRST CHAR. CPB K64 STMT # ? RSS JMP ENDP4 NO. * LDA F.AT YES. DEFINED ? CPA REL JMP ENDP4 YES. * ISZ ER.F ELSE LOG AS AN ERROR LDA K32 NO. INVALID STMT. NO. (UNDEFINED) JSB WAR.F SEND THE MESSAGE LDA K10.. LDB ENDK3 "UNDEFINED" JSB PSL.F PRINT OUT UNDEFINED MESSAGE ISZ F.ERF F.ERF=F.ERF+1 JMP ENDP4 * K32 DEC 32 SKP * *************************** * * PROCESS CHARACTER TEMPS * * *************************** SPC 1 ENDPA JSB OLR.F OUTPUT LOAD ADDR NOW. JSB GFA.F START SCAN. ENDPB JSB GNA.F NEXT F.A SZA,RSS DONE ? JMP OVRLP YES. ONWARD... * ADA K2 NO. TEMP ? LDA A,I SSA,RSS JMP ENDPB NO. SKIP IT. * LDA F.A,I YES. CHAR ? AND B170K CPA CHAR RSS JMP ENDPB NO. SKIP IT. * * CHAR TEMP. MAY ACTUALLY BE DESCRIPTOR. * LDA F.A SAVE F.A . STA T2END DLD F.A,I (B) = EXTENSION ADDR. STB T1END SAVE IT. LDA B,I (A) = DESCRIPTOR ADDR = 0, OR ITEM,I . RAL,CLE,SLA,ERA WHICH ? (CLEAR SIGN) RSS (ITEM,I) JMP ENDPE DESCRIPTOR. GO ALLOCATE SPACE. * STA F.A ITEM. CHECK IT OUT. JSB FA.F LDA F.AT WHAT ADDRESSING MODE ? CPA DUM IF FORMAL, RSS CPA BCOM OR LABELLED COMMON, JMP ENDPE JUST LEAVE SPACE. * LDA F.AF SET BYTE ADDRESS IN DESCRIPTOR. CLE,ELA LDB T1END ADB K2 STA B,I ENDPE LDA F.RPL DEFINE THE TEMP. STA T1END,I ISZ T1END SEND LENGTH. LDA T1END,I JSB OAD.F CLA OUTPUT 'DBL ITEM' OR 'DBL 0'. LDB F.AT CPB COM SET UP MR FIELD. LDA K2 ISZ T1END AND WORD ADDR. LDB T1END,I CLE,ERB JSB OW.F OCT 140000 LDA T2END RESTORE F.A STA F.A LDA REL SET F.AT = REL. JSB DAT.F JMP ENDPB DONE WITH THIS ITEM (TEMP). * B170K OCT 170000 F.IM MASK. SKP * OUTPUT ALL NUMERIC CONSTANT, TRYING FOR OVERLAP. * * ALGORITHM: ALL ITEMS ALREADY OUTPUT ARE KEPT AT THE START OF * THE LIST, AND ALL OTHERS FOLLOW; A POINTER IS KEPT TO THE LAST * ITEM OUTPUT. THE ITEMS NOT YET OUTPUT ARE PROCESSED, BY TYPE, * (LONGEST TYPE FIRST) BY CHECKING FOR OVERLAP WITH CONSTANTS * ALREADY OUTPUT. IF A MATCH IS FOUND, THE ITEM'S ADDRESS IS SET * BUT IT IS LEFT IN THE NON-OUTPUT PART. IF NO MATCH IS FOUND, * THE ITEM IS OUTPUT AND MOVED TO JUST AFTER THE PREVIOUSLY OUTPUT * ITEM. * * START UP LOOPS. * OVRLP JSB OLR.F START NEW RELOC RECORD, JUST IN CASE. LDA DOVTY SET UP INDEX INTO TYPE TABLE. STA T1OVR JSB GFC.F (A) = F.A, DUMMY HEAD OF LIST. STA T4OVR SAVE FOR SCANS OF OUTPUT LIST. STA T2OVR SET UP AS LAST ITEM OUTPUT. OVR01 ISZ T1OVR BUMP TO NEXT TYPE. LDA T1OVR,I DONE ? SZA,RSS JMP END02 YES. * LDA T2OVR START NEW SCAN AFTER LAST ITEM OUTPUT. STA F.A OVR03 LDA F.A SAVE F.A OF LAST ENTRY (FOR DELINKING). STA T3OVR JSB GNA.F GET NEXT ENTRY. SZA,RSS DONE ? JMP OVR01 YES. * LDA A,I GET ITS TYPE. AND B170K CPA T1OVR,I RIGHT ONE ? RSS (YES) JMP OVR03 NO. SKIP IT. * JSB FA.F YES. FETCH ASSIGNS. LDA F..E USED ? SZA,RSS JMP OVR03 NO. IGNORE IT. * LDA F.AT IF ALREADY DEFINED, CPA REL JMP OVR13 THEN JUST ADD TO OUTPUT LIST. SKP * HAVE A CANDIDATE. SEARCH OUTPUT LIST FOR DUPS. * JSB NWE.F (B) = # WDS. STB T5OVR T5OVR = LENGTH. LDA F.A GET ADDR OF VALUE. ADA K2 STA T6OVR T6OVR = ADDR FIRST WORD. LDA T4OVR SET UP TO SCAN OUTPUT LIST. STA F.A OVR05 LDA F.A JUST LOOKED AT LAST ONE ? CPA T2OVR JMP OVR13 YES. DIDN'T FIND MATCH. * JSB GNA.F NO. GO ON TO NEXT. LDA A,I GET IT'S TYPE, AND B170K STA F.IM JSB NWE.F SO CAN GET IT'S LENGTH. CMB -(OLD LEN)-1 ADB T5OVR (NEW LEN)-(OLD LEN)-1 STB T7OVR - # OF POSITIONS WHICH OVERLAP. DLD F.A,I SET ADDR OF FIRST POSITION. STB T8OVR LDA F.A AND ADDR OF FIRST WORD OF OLD CONST. ADA K2 STA T9OVR * * THE OLD CONSTANT MUST BE AS LONG OR LONGER. IF * LONGER, THERE IS MORE THAN ONE WAY TO OVERLAP. * TRY THEM ALL. * OVR07 LDA T5OVR LENGTH OF NEW. CMA,INA SET UP LOOP COUNTER FOR MATCH. STA TAOVR LDA T6OVR SET UP POINTER INTO NEW CONSTANT. STA TBOVR LDA T9OVR (A) = POINTER INTO OLD CONSTANT. OVR09 LDB A,I WORD IN OLD. CPB TBOVR,I SAME AS WORD IN NEW ? RSS (YES) JMP OVR11 NO. THIS POSITION DOESN'T MATCH. * INA YES. BUMP POINTERS. ISZ TBOVR ISZ TAOVR BUMP COUNT. DONE ? JMP OVR09 NO. COMPARE ANOTHER WORD. SKP * NEW MATCHES SOME OLD. DEFINE IT. * LDA T3OVR FIRST, GET IT'S F.A STA F.A JSB GNA.F LDA REL F.AT = REL, JSB DAT.F LDA T8OVR F.AF = ADDR. JSB DAF.F JMP OVR03 GO ON TO NEXT. * * OVR11 ISZ T9OVR NO MATCH. BUMP STARTING POINT IN OLD, ISZ T8OVR AND THE CORRESPONDING ADDR, ISZ T7OVR AND COUNT POSITIONS. JMP OVR07 NOT DONE YET. TRY THIS ONE. * JMP OVR05 ALL POSITIONS TRIED. GET NEXT OLD CONSTANT. * * NO MATCH OR HAS ALREADY BEEN OUTPUT. PUT IN * OUTPUT LIST, AND OUTPUT IF NOT DONE ADREADY. * OVR13 CCB FIRST, DELINK FROM LIST. ADB T3OVR LDA B,I F.A OF NEW CONST. ADA KM1 STA F.A (NOTE! F.A IS ONE LOW AT THIS POINT) LDA A,I ITEM AFTER THIS ONE. STA B,I LINK ITEM BEFORE TO ITEM AFTER. CCB GET ITEM AFTER LAST IN OUTPUT. ADB T2OVR LDA B,I STA F.A,I LINK NEW ITEM TO REST OF LIST. ISZ F.A (RESTORE F.A TO CORRECT VALUE) LDA F.A LINK OLD END OF OUTPUT LIST TO NEW ITEM. STA B,I STA T2OVR SET NEW POINTER TO END OF OUTPUT LIST. STA F.A HAS CONSTANT ALREADY BEEN OUTPUT ? JSB FA.F LDA F.A LDB F.AT CPB REL I.E., F.AT=REL ? RSS YES. DON'T REPEAT IT. JSB OTC.F NO. OUTPUT IT. A=F.A JMP OVR03 DONE. GET NEXT ONE. * T1OVR NOP T2OVR NOP T3OVR NOP T4OVR NOP T5OVR NOP T6OVR NOP T7OVR NOP T8OVR NOP T9OVR NOP TAOVR NOP TBOVR NOP KM1 DEC -1 DOVTY DEF * TYPE TABLE, WITH ORDER TO OUTPUT CONSTANTS. OCT 140000 COMPLEX*16 OCT 120000 REAL*8 OCT 050000 COMPLEX*8 OCT 060000 REAL*6 OCT 020000 REAL*4 DBI OCT 100000 INTEGER*4 OCT 110000 LOGICAL*4 INT OCT 010000 INTEGER*2 OCT 030000 LOGICAL*2 OCT 0 (END OF TABLE) SKP * SCAN FOR ALL CONSTANTS & OUTPUT THEM. * END02 JSB GFC.F SET UP SCAN OF CONSTANTS. END03 JSB GNA.F NEXT ONE. SZA,RSS DONE ? JMP END04 YES. JSB FA.F NO. FETCH ASSIGNS. LDA F..E LDB F.AT SZA IF NOT REFERENCED OR CPB REL ALREADY DEFINED THEN JMP END03 IGNORE IT. * LDB F.IM CHARACTER ? CPB CHAR RSS (YES) JSB CER.F NO. COMPILER ERROR. * * OUTPUT CHARACTER CONSTANT. * LDA F.CSL IS LENGTH: SZA,RSS ZERO ? JMP END3D YES. DESCRIPTOR ONLY. * ADA KM21 NO. > 20 CHARS ? SSA,RSS JMP END3D YES. DATA PART ALREADY OUTPUT. * DLD F.A,I (B) = ADDR EXTENSION. ADB K2 = LOCATION FOR BYTE ADDR. LDA F.RPL PUT IT THERE. ADA K2 (DESCRIPTOR GOES FIRST) CLE,ELA STA B,I * * SET UP STRING DESCRIPTOR. * END3D DLD F.A,I PUT ADDR OF DESCRIPTOR LDA F.RPL IN EXTENSION. STA B,I INB GET LENGTH. LDA B,I JSB OAD.F OUTPUT AS CONSTANT. DLD F.A,I GET BYTE ADDR. ADB K2 LDB B,I CLE,ERB CONVERT TO WORD ADDRESS, CLA ERA AND COPY DBL/DBR BIT TO A<15>. JSB OW.F OUTPUT 'DBL' / 'DBR' . OCT 140000 R=6. * * IF SHORT, OUTPUT CONSTANT NOW. * LDA F.CSL LENGTH. ADA KM21 SHORT OR LONG ? SSA,RSS JMP END03 LONG. DONE. * LDA F.CSL SHORT. GET LENGTH AGAIN. INA ROUND UP TO WORDS. CLE,ERA CMA,INA,SZA,RSS NEGATE. ZERO WORDS ? JMP END03 YES. DESCRIPTOR ONLY. * STA T1END NO. SET UP COUNT. LDA F.A SET UP POINTER TO DATA. ADA K2 STA T2END END3C LDA T2END,I OUTPUT AS ASCII. JSB OW.F OCT 040000 ISZ T2END BUMP DATA POINTER. ISZ T1END BUMP COUNT. DONE ? JMP END3C NO. LOOP. JMP END03 YES. DONE. * T1END NOP COUNT. T2END NOP POINTER INTO ASCII DATA. KM21 DEC -21 CHAR OCT 130000 F.IM=CHAR * * SCAN FOR ALL DEF'S & OUTPUT THEM TOO. * END04 JSB GFD.F SET IT UP. END05 JSB GNA.F NEXT. SZA,RSS DONE ? JMP END06 YES. JSB FA.F NO. FETCH ASSIGNS. LDA F..E LDB F.AT SZA IF NOT REFERENCED OR CPB REL ALREADY DEFINED THEN JMP END05 IGNORE IT. JSB PDF.F OTHERWISE, OUTPUT IT. JMP END05 SKP * *************************************** * * OUTPUT THE UNIT-FILE MAP & FCB POOL * * *************************************** SPC 1 END06 LDA F.SBF IF SUBPROGRAM, LDB F.DNB OR SEGMENT, ADB K9 LDB B,I SZA,RSS CPB K5 JMP ENDX9 THEN NO UNIT-FILE MAP. * JSB OLR.F OUTPUT LOAD ADDR, AS USUAL. LDB F.RPL DEFINE ADDR OF UNIT-FILE MAP. LDA F.UFM INA STB A,I CCA FTN4X FLAG = -1. JSB OAD.F LDA F.#M 'ABS M' JSB OAD.F LDA F.#N 'ABS N' JSB OAD.F LDA F.#B 'ABS B' JSB OAD.F LDA F.#S 'ABS S' RAL,CLE,SLA,ERA CLEAR FLAG; WAS $FILES USED ? RSS YES. CLA,INA NO. S=1. JSB OAD.F * LDA F.#M ALLOCATE 4*M WORDS FOR UNIT-FILE MAP. ALS,ALS STA T1END AMOUNT SO FAR. LDA F.#S DS ? CPA B100K (FILES PRESENT BUT S=0) JMP END6A YES. * * NON-DS. * LDA F.#N NO. IF N = 0, SZA,RSS JSB OAD.F THEN DO 'DEF 0' LDB .FFIO ELSE DO 'DEF .FFIO' SZA (A=0 ON RETURN FROM OAD.F) JSB ODD.F * LDB F.#B B (NOTE: A=0, SO ASL SAFE.) INB,SZB,RSS IF -1 (FREESPACE), JMP END6B THEN JUST ALLOCATE UFMP SPACE. * LDB F.#B ELSE ALLOW FOR BUFFERS, DCB'S & FCB'S. ASL 2 4B ADB F.#N 4B+N ASL 5 32(4B+N) = 128B + 32N JMP END6B NOW ALLOCATE THAT PLUS UFMP SPACE. SKP * DS. * END6A LDA F.#N FILES ? LDB .DNRW IF NOT, .DNRW SZA LDB .DSRW IF SO, .DSRW JSB ODD.F DEF TO ONE OR OTHER. LDA F.#N N MPY K20 20N = SPACE FOR FCB'S & DCB'S. LDB A (B) = # WORDS. * * ALLOCATE (B) WORDS BUFFER SPACE & EXIT. * END6B LDA K84 (ERROR NUMBER) SSB,RSS ERROR IF ALREADY OVER 32767; ADB T1END ADD UFMP SPACE. SSB,RSS ERROR IF OVER 32767; ADB F.RPL (DO THE BSS) SSB IF TOTAL IS OVER 32767, JMP F.ABT THEN ABORT: MEM OFL. * STB F.RPL ELSE FINISH ALLOCATE, JMP ENDX9 AND QUIT. * .FFIO ABS 261 .DNRW ABS 344 .DSRW ABS 345 K84 DEC 84 K5 DEC 5 K9 DEC 9 K20 DEC 20 B100K OCT 100000 SKP * ******************************** * * ROUTINE TO OUTPUT A CONSTANT * * ******************************** * OTC.F NOP STA F.A SET THE A.T. ADDRESS JSB FA.F FETCH ASSIGNS LDA F.AT HAS IT ALREADY BEEN OUTPUT ? CPA REL RSS YES. DON'T CHANGE LOCATION. JSB DL.F NO. DEFINE IT TO BE HERE. JSB FC.F MOVE THE CONSTANT TO F.IDI FOR OUTPUT. JSB OC.F SEND IT JMP OTC.F,I RETURN SPC 2 * ************************************************* * * ROUTINE TO ESTABLISH A CONSTANT AND OUTPUT IT * * ************************************************* * * * ENTER E=0 FOR DOUBLE INT, E=1 FOR INT, A,B= VALUE * BIC.F NOP BUILD INTEGER CONSTANT DST F.IDI SET ITS VALUE LDA INT GET THE TYPE SEZ,RSS IF TO BE DOUBLE INTEGER LDA DBI GET TYPE JSB ESC.F ESTABLISH CONSTANT JSB AI.F ASSIGN IT LDA F.A AND JSB OTC.F OUTPUT IT JMP BIC.F,I RETURN A=0,E=1 SPC 2 ENDK3 DEF MSG MSG ASC 10, UNDEFINED K10.. DEC 10 K64 DEC 64 K99 DEC 99 .BAD. ABS 77 SKP * ******************************* * * OUTPUT A CONSTANT OR A TEMP * * ******************************* SPC 1 * ENTRY: (A) = F.A OF EITHER ONE. TEMP GENERATED WITH ZEROES. * OCT.F NOP LDB A,I CHECK IF NAMED. SLB,RSS JMP OCT01 IF SO, IS TEMP FOR VAR DIM. * JSB OTC.F ELSE PRODUCT CONSTANT. JMP OCT.F,I AND EXIT. * OCT01 STA F.A VAR DIM. ALLOCATE TEMP. JSB DL.F ASSIGN TEMP HERE. JSB FA.F COMPUTE F.D0 = # WORDS. LDA F.D0+1 AND SET AS COUNTER. CMA,INA STA T1OCT OCT02 CLA OUTPUT THAT MAY ZEROES. JSB OAI.F ISZ T1OCT COUNT, JMP OCT02 AND LOOP. JMP OCT.F,I ALL DONE. * T1OCT NOP COUNTER FOR LOOP. SPC 2 * UPDATE THE FOLLOWING WHEN REVISING THE COMPILER: * ENDK5 DEF CMPID CMPID DEC 21 WORDCOUNT OF FOLLOWING TEXT ASC 14, FTN4X COMPILER: HP92834 REV ASC 7,.2030 (800821) SKP * END. IF ERRORS, OUTPUT 'JSB .BAD.' . * ENDX9 LDB .BAD. LDA F.ERF # OF ERRORS IN COMPILATION SZA JSB ODF.F 'JSB .BAD.' CLA JSB SKL.F YES, SKIP A LINE. * * END OF INTERPASS PROCESSING. FIRE UP PASS 3. * ENDX3 JSB OS.F FLUSH THE CURRENT RELOC. RECORD. JSB EOF.C END FILE ON 2ND PASS FILE. DEF C.SC0 JMP PASSE ERROR SEND 99 ERROR * LDB ENDK5 PRINT THE COMPILER ID LDA B,I NOW INB JSB PSL.F CLA JSB SKL.F SKIP A LINE JMP END.F,I NOW RETURN TO THE SEGMENT FOR PASS 3. * * DISASTER: PASS FILE ERROR. * PASSE LDA K99 ERROR ON EOF JMP F.ABT ABORT THE COMPILE * END ASMB,Q,C HED FTN4X COMPILER (F4X.6:CODE GENERATOR, PASS 2) NAM F4X.6,5 92834-16003 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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * *************************************** * FORTRAN-4 COMPILER OVERLAY 6 * *************************************** * * THIS OVERLAY IS THE CODE GENERATOR. * * 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 ENTRY EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.CC COLUMN COUNT EXT F.CCW FTN OPTION WORD EXT F.D DO TABLE POINTER EXT F.ERX ERROR EXIT ADDRESS. EXT F.FLN FIRST LINE # IN THIS MODULE. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.LNA ADDRESS OF CURRENT LINE EXT F.LNL LENGTH OF CURRENT LINE EXT F.LNN LINE # OF CURRENT LINE EXT F.NC NAME CHANGE FLAG. EXT F.PAS PASS NUMBER. EXT F.PTF PERMANENT TEMP FLAG. EXT F.RES F.A OF CURRENT RESULT. EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SEG LOAD A NEW SEGMENT EXT F.T # WORDS ON STACK 1 EXT F.TL LENGTH OF TITLE LINE. EXT F.TTL LOCATION OF TITLE LINE. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT APT.F ALLOCATE 'PERMANENT' TEMP. EXT ASC.F CONVERT TO 4 ASCII DIGITS EXT CAT.F COMMON CODE FOR TEMP ALLOCATION. EXT DAT.F DEFINE (F.AT) EXT DL.F DEFINE LOCATION SUBROUTINE. EXT EJP.F PAGE EJECT. EXT ER.F ERROR PRINT SUBROUTINE. EXT FA.F FETCH ASSIGNS EXT GCD.F GET CONSTANT INTEGER, IN DBL INT FORMAT. EXT IN2.F INITIALIZE OA.F EXT ITS.F INTEGER TEST EXT NST.F TEST FOR NOT A SUBROUTINE NAME EXT OAI.F OUTPUT ABS. INSTRUCTION EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT OLR.F OUTPUT LOAD ADDR. EXT OS.F FLUSH OA.F'S BUFFER. EXT PSL.F PRINT SOURCE LINE EXT RS1.F READ WORD FROM PASS FILE 1. EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * ENT F.COC CURRENT OPCODE COUNT. ENT F.COP CURRENT OPCODE. ENT F.DFS 'DO' FINAL, STEP F.A'S. ENT F.GRX DEF TO GRD.F ENT F.LA1 PASS FILE ONE, 1ST LOOK-AHEAD. ENT F.LA2 PASS FILE ONE, 2ND LOOK-AHEAD. ENT F.RTP RESULT TYPE ENT F.S1N NEXT-TO-TOP OF STACK 1. ENT F.SRL F.A OF STMT FCT HIDDEN PARAM. ENT F.TPX TYPE OF EXPRESSION BEING PROCESSED. * ENT ATC.F ALLOCATE TEMP CELL. ENT ATM.F CONDITIONALLY ALLOCATE TEMP (TWO OPNDS). ENT DEF.F PRODUCE A DEF TO (B). ENT F1T.F FREE TEMP IF TOS. ENT F2T.F FREE TEMPS IF TOS OR NEXT-TO-TOP. ENT ITN.F INITIALIZE TEMP NAMES. ENT RD.F PASS FILE ONE READ WITH LOOK-AHEAD. ENT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITH & LOG & REL OP CODE GEN.) * EXT ADD.F ADD. EXT AND.F AND. EXT CO.F COMMUTE TOP TWO OPERANDS. EXT CTS.F CONVERT TOP OF STACK. EXT DIV.F DIVIDE. EXT EQV.F .EQV. EXT .EQ.F .EQ. EXT EXP.F EXPONENTIATION. EXT .GE.F .GE. EXT .GT.F .GT. EXT .LE.F .LE. EXT .LT.F .LT. EXT MP1.F MAP TOS IF EMA. EXT MP2.F MAP TOP TWO STACK ITEMS IF EMA. EXT MPY.F MULTIPLICATION. EXT NEG.F UNARY MINUS. EXT NOT.F .NOT. EXT .NE.F .NE. EXT .OR.F .OR. EXT SUB.F SUBTRACTION. EXT XOR.F .XOR. .NEQV. .EOR. * * ENTRY POINTS IN KWC.F (KEYWORD STMT CODE GEN) * EXT AGT.F ASSIGNED GOTO. EXT AIF.F ARITHMETIC IF. EXT ASP.F ASSIGN STATEMENT. EXT CAD.F ASCII DATA OUTPUT (FORMAT & DATA STMTS) EXT CGT.F COMPUTED GOTO. EXT DO.F DO. EXT DTA.F DATA STATEMENT. EXT DOT.F END OF DO LOOP. EXT EBR.F ENDFILE/BACKSPACE/REWIND (SAVE CODE). EXT EIF.F ENDIF. EXT ELS.F ELSE. EXT GTO.F GOTO. EXT IDO.F IMPLIED DO. EXT ILA.F ORDERING OF IMPLIED DO. EXT IOA.F I/O WHOLE ARRAY. EXT IOE.F I/O STATEMENT END (EXCEPT R/W). EXT IOK.F I/O STATEMENT KEYWORD. EXT IOL.F I/O LIST ITEM. EXT IOS.F I/O STATEMENT START. EXT LIF.F LOGICAL IF. EXT NR.F IMPLIED DO 'RECORD'. EXT PTM.F PROGRAM TERMINATION. (END) EXT RTN.F RETURN. EXT RWE.F READ/WRITE END. EXT STP.F PAUSE & STOP. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT CAR.F CLEAR ALL REGISTER DATA, INCL MAP STATUS. EXT FT.F FIND TYPE. EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT LD.F LOAD. EXT MIM.F MAP ITEM MODE. EXT PO1.F POP ONE ITEM OFF STACK. EXT PU1.F PUSH ONE ITEM ONTO STACK. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SMT.F SAVE MAPPED DATA. (FREE MAPS) EXT ST.F STORE. EXT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F * EXT EA?.F SKIP IF (F.A) IS IN EMA. EXT FPE.F FORM PROGRAM ENTRANCE CODE. EXT SAL.F SUBROUTINE OR ARRAY REF, LEFT PAREN. EXT SAR.F SUBROUTINE OR ARRAY REF, RIGHT PAREN. * * COMPILER LIBRARY ROUTINES USED. * EXT WRT.C WRITE FILE ROUTINE. EXT C.SC0 2ND PASS FILE FCB. * * OTHER LIB. UTILITIES * EXT .MVW MOVE WORDS MACRO EXT IFBRK BREAK TEST. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 1 DEC 6 OVERLAY NUMBER SKP * *------------------* * * START HERE * * *------------------* * F4.6 ISZ F.PAS SET PASS NUMBER. JSB CAR.F INITIALIZE REGISTERS. LDA F.D INITIALIZE THE STACK. STA F.S1B JSB VS1.F LDA DP2ER SET UP ERROR EXIT ADDRESS. STA F.ERX CCA RESET LINE #. (BUMPED BEFORE USED) ADA F.FLN STA F.LNN JSB IN2.F INITIALIZE OA.F JSB RD.F INITIALIZE RD.F : JSB RD.F TWO WORDS OF LOOK-AHEAD. * * MAIN LOOP. READ PASS FILE. * RDPSF JSB RD.F NEXT ! CPA KM1 END ? JMP EXIT YES. GO FINISH UP. RAL,CLE,SLA,ERA CHECK & CLEAR SIGN. JMP RDPS2 OPERAND. * STA FULOP OPERATOR & COUNT. SAVE. AND B377 EXTRACT OPERATOR & SAVE. RDPS1 STA F.COP XOR FULOP EXTRACT COUNT & SAVE. ALF,ALF STA F.COC CLA ZERO THE COUNT OF WORDS USED. STA F.RSC (RECOVERY SKIP COUNT) * LDA F.COP CHECK OUT THE OPCODE: CMA,SSA,INA,SZA IF NEGATIVE OR ZERO, RSS (NO) HLT 12 PUNT. * ADA TBLSZ NO. (A) = (MAX) - (ACTUAL) SSA IN RANGE ? HLT 12 NO. PUNT. * LDA F.COP GET ROUTINE ADDR. ADA OPTBL LDA A,I LDB F.COP ENTER WITH (B) = OPCODE. JSB A,I PROCESS OPERATOR. JMP RDPSF NEXT. * RDPS2 JSB PU1.F OPERAND. JUST STUFF ON STACK. JMP RDPSF SKP * ERROR CLEANUP. * F.P2E LDA F.RSC FIRST, SKIP REST OF OPERATOR. CMA,INA (ERRORS ONLY OCCUR ON OPERATORS) ADA F.COC F.COC-F.RSC = AMOUNT TO SKIP. F.P2A CMA,SSA,INA,SZA IS THERE ANY ? RSS YES. JMP F.P2C NO. (F.RSC>F.COC FOR 'IF' SHORT-CIRCUIT) * STA F.COC YES. SKIP IT. F.P2B JSB RD.F ISZ F.COC JMP F.P2B * F.P2C JSB RD.F LOOK FOR NEW STATEMENT. CPA KM1 END ? JMP EXIT YES, NO BREAK. * SSA OPEREAND ? JMP F.P2C YES, IGNORE. * STA FULOP SAVE. AND B377 EXTRACT OPERATOR & SAVE. STA F.COP XOR FULOP EXTRACT COUNT & SAVE. ALF,ALF STA F.COC CLA ZERO THE COUNT OF WORDS USED. STA F.RSC (RECOVERY SKIP COUNT) LDA F.COP CHECK OUT THE OPCODE: CPA K28 28 ? JMP P2C1 YES. GO ECHO LINE. * CPA K29 29 ? JMP P2C2 YES. GO COUNT LINE. * CPA K46 START-OF-STATEMENT ? JMP RDPS1 YES. DONE WITH CLEANUP. * XOR FULOP NO. SKIP JUNK AFTER THIS OPERATOR. ALF,ALF JMP F.P2A (A) = AMOUNT TO SKIP. * P2C1 JSB LST.F ECHO SKIPPED LINE. JMP F.P2C CONTINUE SKIPPING. * P2C2 JSB LNL.F COUNT SKIPPED LINE. JMP F.P2C CONTINUE SKIPPING. * * EXIT PASS 2. FLUSH CROSS-REF BUFFER, LOAD SEGMENT 5. * EXIT JSB CRPFL FLUSH. JSB OS.F ALSO FLUSH OA.F BUFFER LDB K5 LOAD SEG 5. JMP F.SEG SKP DP2ER DEF F.P2E PASS 2 ERROR EXIT ADDRESS. FULOP NOP COUNT & OPERATOR. F.COC NOP COUNT. (RIGHT JUSTIFIED) F.COP NOP OPERATOR. F.RSC NOP # WORDS USED FROM CURRENT OPERATOR. F.GRX DEF GRD.F ACCESS: F.GRD => F.GRX => GRD.F OPTBL DEF TABLE-1 ADDR OPERATOR JUMP TABLE. K5 DEC 5 K28 DEC 28 K29 DEC 29 K46 DEC 46 SPC 2 * ******************************* * * NOTE START OF NEW STATEMENT * * ******************************* SPC 1 SNS.F NOP JMP SNS.F,I NOTHING TO DO FOR NOW. SPC 2 * *********************************** * * INITIALIZE TEMP CELL BASE NAMES * * *********************************** * ITN.F NOP * LDA DLINT JUST ZERO THEM OUT. LDB DLIN1 BY USING .MVW AND CONSTANT ZERO. JSB .MVW DEF K12 NOP JMP ITN.F,I DONE. SPC 2 * ***************** * * SEGMENT START * * ***************** SPC 1 SSS.F NOP LDA F.RPL SAVE F.RPL, STA T1SSS CLA WHILE WE ORG TO THE START, STA F.RPL JSB OLR.F JSB OAI.F AND OUTPUT 'NOP' TO KEEP LOADR HAPPY. LDA T1SSS THEN ORG BACK. STA F.RPL JSB OLR.F JMP SSS.F,I * T1SSS NOP SKP * ****************** * * INITIALIZATION * * ****************** * * PARAM IS TYPE OF INPUT EXPRESSION: * * = 0, STATEMENT FUNCTION. * =-1, SUBROUTINE CALL STATEMENT. * =-2, DO INITIAL PARAMETER. * =-3, LOGICAL UNIT #. * =-4, DO STATEMENT TERMINAL OR STEP-SIZE PARAMETER. * =-5, COMPUTED GO TO INDEX EXPRESSION. * =-6, ASSIGNMENT STATEMENT. * =-7, IF EXPRESSION. * =-8, INPUT I/O LIST ELEMENT OR L-VALUED KEYWORD. * =-9, OUTPUT I/O LIST ELEMENT OR R-VALUED KEYWORD. * INIT NOP JSB RD.F (A) = TYPE. STA T1INI SAVE FOR THE INHIBIT BIT, AND B377 AND SET UP F.TPX = NEGATIVE TYPE. CMA,INA STA F.TPX CPA KM5 COMPUTED GOTO ? (INHIBIT BIT = 0) JMP INIT1 YES, DON'T CLOBBER STACK. LDA F.D INITIALIZE STACK 1 (OPERAND STA F.S1B STACK ) BOUNDS TO LAST WORD STA F.S1T OF DO TABLE OR LAST WORD OF STA F.S1N DATA POOL. CLA STA F.T NO. OF WORDS ON STACK 1 INIT1 JSB CAR.F CLEAR ALL REGISTER STATUS. LDA T1INI INITIALIZE TEMPS ? ALF,ALF SLA,RSS (BIT 8 INHIBITS IT) JSB ITN.F YES. INITIALIZE TEMP CELLS. * * ENTRY SECTION * LDA F.A SAVE F.A OF POSSIBLE STATEMENT STA T1EE FUNCTION NAME LDB F.TPX IF STATEMENT FUNCTION, LDA F.SRL AND HIDDEN PARAMETER, SZB,RSS WELL ? SZA,RSS RSS (NO) JSB PU1.F YES. PUSH THAT PARAM ONTO STACK. JMP INIT,I INITIALIZATION DONE. * * COUNTERS FOR RE-USABLE TEMP CELLS. * DLINT DEF T.INT-1 USED TO ZERO OUT THE T.INT ARRAY. DLIN1 DEF T.INT DEC 0 THIS WORD MUST EXACTLY PRECEDE THE BSS!! T.INT BSS 12 ROOM FOR TYPES THRU TYPE 12 (COMPLEX*16) T1INI NOP FOR ORIGINAL PARAM WORD. SKP * ************************** * * EXPRESSION TERMINATION * * ************************** * * GET EXIT ADDRESS & EXT FLAG. IF NO EXT CHECK, EXIT. * TERM NOP LDB F.TPX CHECK TYPE OF INPUT EXPRESSION. ADB DTERM FIND EXIT ADDRESS. LDB B,I RBL,CLE,SLB,ERB CHECK IF EXTERNAL NAME ? JMP B,I NO. EXIT NOW. * * ELSE MAKE SURE NOT AN EXTERNAL NAME. * STB T4EE (SAVE EXIT ADDRESS) LDB F.S1T,I RESULT IS IN REGISTERS? SZB,RSS JMP EE70 YES. STB F.A NO - IF RESULT IS AN JSB FA.F EXTERNAL NAME, FLAG AS JSB NST.F ERROR 25. OTHERWISE CONTINUE. EE70 JMP T4EE,I EXIT. * DEF EE71 -9: OUTPUT LIST. CHECK. DEF EE71 -8: INPUT LIST. CHECK. DEF EE71 -7: IF. CHECK. DEF EE73,I -6: ASSIGNMENT. DEF EE71 -5: COMPUTED GOTO. CHECK. DEF EE63 -4: DO STEP/TERM. CHECK. DEF EE72 -3: UNIT #. CHECK. DEF EE60,I -2: DO INITIAL. DEF EE73,I -1: SUBR CALL. DEF EE67 0: STMT FCT. CHECK. DTERM DEF *-1 ADDRESS TYPE 0. * * END OF UNIT # - DITTO, AND MAKE SURE INTEGER. * EE72 JSB GT1.F F.IM = TYPE. JSB ITS.F ERROR IF NOT INTEGER. LDA INT ALSO, CONVERT INT*4 TO INT*2. JSB CTS.F (ON TOP OF STACK) EE71 JMP TERM,I * * I/O LIST ELEMENT. PROCESS IT ELSEWHERE. * EE73 JSB CAR.F VOID REGISTERS & MAPS, JUST IN CASE. JMP TERM,I EXIT. SKP * 'DO' INITIAL VALUE. CLEAR FLAG. * EE60 CLA CLEAR THE 'FINAL' & 'STEP' F.A'S. STA F.DFS STA F.DFS+1 LDA F.RTP SAVE THE 'DO' INDEX TYPE. STA F.DIT JMP EE73 VOID REG & EXIT. SPC 2 * DO STEP/TERM. CONVERT TO INDEX VAR TYPE. * EE63 LDA F.DIT CONVERT TO INDEX VAR TYPE. JSB CTS.F CONVERT TOS IF NEEDED. JSB MP1.F AND MAP IT IN, IF EMA. * LDB F.S1T,I (B) = RESULT. SZB IN REGISTER ? CPB K1 RSS YES. LOAD IF ADDR, STORE IN TEMP. JMP EE64A NO. (B) = F.A OF RESULT. * JSB SCG.F LOAD TO REG. LDA F.DIT ALLOCATE PERMANENT TEMP FOR IT. JSB APT.F (A) = F.A OF TEMP. STA T3EE SAVE THAT. LDB F.S1T,I STORE IN TEMP. JSB ST.F LDB T3EE RETURN F.A OF THE TEMP. EE64A LDA F.DFS SEE IF 'FINAL' OR 'STEP'. SZA WHICH ? STB F.DFS+1 'STEP'. SAVE IN F.DFS+1. SZA,RSS STB F.DFS 'FINAL'. SAVE IN F.DFS. JSB PO1.F POP OFF STACK. LDB F.DFS+1 STEP F.A OR ZERO. JSB GCD.F CHECK IF CONSTANT. JMP EE73 NO. * SZA,RSS YES. ZERO ? SZB JMP EE73 NO. O.K. * LDA K23 YES. WARNING 23. JSB WAR.F JMP EE73 NOW WAIT FOR STEP OR END. * F.DFS DEC 0,0 'DO' FINAL, STEP F.A'S. F.DIT NOP 'DO' INDEX VARIABLE TYPE. K23 DEC 23 SKP * STMT FCT. SAVE RESULT, MAKE TEMPS PERMANENT. * EE67 LDB T1EE IS IT REGISTER OR MEM RESULT ? JSB FT.F (A) = TYPE. JSB MIM.F MAP IT. SSB REG OR MEM ? JMP EE67A MEM. ALREADY STORED IT. * LDB T1EE REGISTER. CONVERT IF NEEDED. JSB FT.F JSB CTS.F LDB F.S1T,I (B) = TOS. JSB LD.F LOAD RESULT. * EE67A DLD T1EE,I (B) = EXTENSION ADDR. LDB B,I (B) = ENTRY POINT ADDR. LDA JMPII OUTPUT 'JMP ENTRY,I' JSB OMR.F JMP EE73 DONE. (VOID REG) SPC 1 KM5 DEC -5 KM1 DEC -1 K1 DEC 1 K12 DEC 12 INT OCT 010000 JMPII OCT 126000 T1EE NOP T3EE NOP T4EE NOP F.SRL NOP F.A OF (STMT FCT) HIDDEN PARAM. F.RTP NOP RESULT TYPE. F.S1N NOP NEXT TO TOP STACK LOCN F.TPX NOP TYPE OF INPUT EXPR. SPC 2 * ************************** * * SIMPLE SUBROUTINE CALL * * ************************** SPC 1 SSC.F NOP JSB SAL.F MARK THE SUBROUTINE NAME, JSB SAR.F AND GENERATE THE CALL. JMP SSC.F,I DONE! SKP * ******************** * * ASSIGN OPERATION * = * ******************** SPC 1 AO.F NOP LDB F.S1N,I GET RESULT TYPE. JSB FT.F JSB CTS.F CONVERT OPERAND IF NEEDED. LDA F.S1N,I IF DESTINATION CPA F.S1T,I =SOURCE, (MAYBE CONVERT USED TAS.F) JMP AO02 THEN SKIP IT. * JSB MP2.F MAP EITHER IF IN EMA. JSB SCG.F LOAD SOURCE VARIABLE LDA F.S1N,I A.T. POINTER OF STORING VAR. LDB F.S1T,I A.T. POINTER OF LOADING VAR. JSB ST.F AO02 JSB PO1.F POP OPERANDS OFF STACK, JSB PO1.F BUT DON'T PUSH ANYTHING ONTO IT. JMP AO.F,I EXIT. * T1AO NOP F.A OF RHS WHILE RESOLVING EMA ARRAY. SPC 2 * *************************** * * INVERSE ASSIGN OPERATOR * * *************************** SPC 1 IAO.F NOP CCB GET THE ARRAY F.A ADB F.S1B LDB B,I RBL,CLE,ERB WIPE OFF THE ARRAY MARK BIT. JSB FT.F GET ITS TYPE, JSB CTS.F AND CONVERT RHS TO THAT. JSB MP1.F ALSO MAP RHS, IF NOT DONE YET. JSB SMT.F SAVE CURRENT MAPPED DATA, JSB SBR.F AND REGISTERS. JSB PO1.F POP RHS OFF STACK, STA T1AO AND SAVE, WHILE WE JSB SAR.F FINALLY RESOLVE THE ADDRESS. LDA T1AO NOW PUT THE VALUE BACK, JSB PU1.F AND JSB AO.F PERFORM AN ORDINARY ASSIGN. JMP IAO.F,I DONE. SKP * ******************************************** * * LOOK AHEAD FOR ASSIGNMENT TO AVOID TEMP * * ******************************************** * * TAS.F TRIES TO OPTIMIZE OUT CALLS TO .DFER & .CFER BY LOOKING * AHEAD FROM OPERATIONS WITH DBL/RE8/CPX RESULTS. IF (F.RTP) IS * DBL/RE8/CPX, THEN (F.RES) WILL BE SET TO THE RESULT F.A . * * MUST HAVE: 1) CURRENT OP IS = (CONVERSION). * OR 2) NEXT OP IS = (NORMAL OPERATION). * OR 3) NEXT OP IS (UNARY -), THEN =. * AND: THE NEXT OPERAND IS OF TYPE (F.RTP) * AND IS NOT IN EMA. * * ENTRY: (F.RTP) = RESULT TYPE OF CURRENT OPERATION. * (B) = POINTER TO NEXT OPERAND (ON STACK). * EXIT: (F.RES) = F.A TO USE FOR DEF TO RESULT. (DBL/RE8/CPX ONLY) * TAS.F NOP STB T1TAS SAVE THE OPERAND POINTER LDA F.RTP REGISTER RESULT ? JSB MIM.F SSB,RSS (IF SO, B>=0) JMP TAS.F,I NO. IGNORE CALL. * LDA F.COP YES. IS CURRENT OPERATOR ASSIGNMENT ? CPA EQOPC (MUST BE CONVERSION) JMP TAS02 YES. * LDA F.LA1 NO. IS NEXT OPERATOR ASSIGNMENT ? CPA EQOPC JMP TAS02 YES. GO CHECK TYPE. * CPA NGOPC HOW ABOUT NEGATION ? RSS JMP TAS01 NO. ASSIGN TEMP. * LDA F.LA2 YES. THEN ASSIGNMENT ? CPA EQOPC JMP TAS03 YES. O.K. UNLESS REGISTER. * TAS01 LDA F.RTP NO. ALLOCATE TEMP. JSB ATC.F STA F.RES SET FOR RESULT TO BE THERE. JMP TAS.F,I THAT'S ALL. * TAS03 LDB T1TAS,I NEGATE THEN ASSIGN. REGISTER ? SZB (WE CAN'T HANDLE THAT) CPB K1 JMP TAS01 YES. GO WITH TEMP. * LDA B,I ALSO CAN'T DO ADDR TEMPS. AND B170K CPA ADDR JMP TAS01 * TAS02 LDB T1TAS,I GET F.A OF NEXT OPERAND. JSB FT.F CHECK ITS TYPE CPA F.RTP SAME AS RESULT ? RSS YES. IT WORKS (IF NOT EMA). JMP TAS01 NO. ALLOCATE TEMP. * LDA T1TAS,I ALL O.K. UNLESS EMA. STA F.A JSB EA?.F HOW ABOUT IT ? RSS (NO. O.K.) JMP TAS01 EMA. IT ISN'T MAPPED YET. * STA F.RES WORKS. SET RESULT TO BYPASS TEMP. JMP TAS.F,I DONE. SKP T1TAS NOP EQOPC EQU K1 = OPERATOR #. K4 DEC 4 NGOPC EQU K4 UNARY MINUS OPERATOR #. ADDR OCT 70000 F.IM=ADDR B170K OCT 170000 F.IM MASK SPC 2 * **************************************** * * 2 OPERAND LOOK AHEAD FOR ASSIGNMENT * * **************************************** * * THIS ROUTINE CALL TAS FOR 2 OPERANDS * ENTRY: (F.RTP) = RESULT TYPE. *  EXACTLY TWO STACK ENTRIES FOR CURRENT OPERATION. * ATM.F NOP CONDITIONAL TEMP (NONE IF = NEXT) LDB F.S1N GET ADDRESS OF THE NEXT OPERAND INB TO B JSB TAS.F CALL TAS TO TEST IT AND ALLOCATE JMP ATM.F,I RETURN SKP * **************** * * GENERATE DEF * * **************** SPC 1 DEF.F NOP OPERAND ASSUMED NOT TO BE IN REG CLA JSB SOA.F OUTPUT THE DEF JMP DEF.F,I SPC 2 * ************************ * * ALLOCATE A TEMP CELL * * ************************ SPC 1 ATC.F NOP LDB F.TPX ARE WE IN A STATEMENT FUNCTION ??? SZB,RSS JMP ATC01 YES. GO USE A PERMANENT ONE. * LDB F.PTF IS THE PERMANENT TEMP FLAG SET ? SZB JMP ATC01 YES. USE PERMAMENT ONE. * STA F.IM NO. (A)=F.IM OF TEMP CELL NEEDED ALF MAKE F.IM A SMALL INTEGER ADA DLINT (A)_ ADDRESS OF TEMP CELL NUMBER. ISZ A,I BUMP TO THE NEXT TEMP. LDA A,I FETCH THE TEMP NUMBER. (TRANSIENT TEMP) JSB CAT.F DO IT. JMP ATC.F,I DONE. * ATC01 JSB APT.F STMT FCT. MAKE IT PERMANENT. JMP ATC.F,I DONE. B377 OCT 377 K2 DEC 2 SKP * ***************************** * * FREE TEMP IF TOP-OF-STACK * * ***************************** SPC 1 * F1T.F CHECKS THE ITEM AT F.S1T, THE TOP OF THE OPERAND STACK. * IF IT IS A TEMP, AND IS THE MOST RECENTLY ALLOCATED OF ITS * TYPE, IT IS FREED, I.E. THE TEMP COUNTER FOR THAT TYPE IS * DECREMENTED, SO THE NEXT TEMP ALLOCATED OF THAT TYPE WILL BE * THIS TEMP AGAIN. * F1T.F NOP JMP F1T.F,I *** DOESN'T WORK !!! *** LDA F.S1T,I TOS. SZA IF REGISTER, CPA K1 JMP F1T.F,I THEN NOT TEMP. * LDB A,I 1ST WORD: LSB = F.NT ADA K2 LDA A,I 3RD WORD: NAME. RAL,CLE,SLA,ERA SIGN BIT OF NAME SET ? (CLEAR IT) SLB AND NAMED ? (F.NT=0) JMP F1T.F,I NO. NOT TEMP. * CLB TEMP. SEPERATE TYPE & NUMBER. RRL 5 (B) = TYPE IN LSB. (NAME<14:11>) ALF,ALF RE-ALIGN NUMBER. (NAME<10:0>) ALF,RAR (A) = NUMBER. ADB DLINT ADDR OF COUNTER, THIS TYPE. CPA B,I IS THIS TEMP MOST RECENTLY ISSUED ? CCA,RSS (YES) JMP F1T.F,I NO. CAN'T FREE ANY OTHER. * ADA B,I YES. FREE IT, STA B,I BY DECREMENTING COUNTER. JMP F1T.F,I EXIT. SPC 2 * ********************************** * * FREE 2 TEMPS FROM TOP OF STACK * * ********************************** SPC 1 * F2T.F WORKS LIKE F1T.F, BUT WILL EITHER OR BOTH OF THE TOP * 2 ITEMS ON THE OPERAND STACK. THREE CALLS TO F1T.F ARE NEEDED * BECAUSE IF BOTH ITEMS ARE TEMPS OF THE SAME TYPE, AND NEXT-TO-TOP * IS THE MOST RECENT AND TOP IS NEXT MOST RECENT, WE CAN'T FREE TOP * UNTIL WE'VE FREED NEXT-TO-TOP. LIKEWISE IF DONE IN REVERSE ORDER. * F2T.F NOP JMP F2T.F,I *** DOESN'T WORK !!! *** JSB F1T.F TRY TO FREE TOS. JSB CO.F SWAP. JSB F1T.F TRY TO FREE NEXT-TO-TOP. JSB CO.F SWAP BACK. JSB F1T.F TRY TOS AGAIN, JUST IN CASE. JMP F2T.F,I EXIT. SKP * ****************** * * PASS FILE READ * * ****************** SPC 1 RD.F NOP JSB RS1.F READ AHEAD A WORD. LDB F.LA2 JUST ROLL UP THE QUEUE: STA F.LA2 NEW WORD GOES ON BOTTOM. LDA F.LA1 TOP GOES TO (A). STB F.LA1 BOTTOM GOES TO TOP. ISZ F.RSC BUMP RECOVERY SKIP COUNT. JMP RD.F,I EXIT. * F.LA1 NOP LOOK-AHEAD 1. F.LA2 NOP LOOK-AHEAD 2. SPC 2 * ********************** * * DEFINE STATEMENT # * * ********************** SPC 1 DSN.F NOP JSB RD.F GET THE #. STA F.A SAVE IT. JSB FA.F FETCH ASSIGNS. LDB F.NC FORMAT ? CPB B140 (I.E., NC=3) JMP DSN.F,I YES. LEAVE F.AF ALONE. JSB DL.F NO. SET F.AF = F.RPL JMP DSN.F,I & EXIT. * K3 DEC 3 B140 OCT 140 SKP * ************* * * LIST LINE * * ************* SPC 1 LST.F NOP JSB IFBRK BREAK ? DEF *+1 CLE,SSA (E=0 FOR ASC.F) JMP BREAK YES. QUIT. * ISZ F.LNN BUMP LINE # FOR WAR.F LDA F.LNN CONVERT TO ASCII. JSB ASC.F (E=0, SUPPRESS LEADING ZEROES) SWP STB T1LST SAVE '34' RRR 8 MAKE '4123' AND B377 THEN '-123' IOR B20K SO FIRST COLUMN IS BLANK. DST LINOL LDA T1LST NOW '34' AND B377 MAKE '-4' IOR B20K ALF,ALF THEN '4-' STA LINOL+2 SO FINALLY IS '-1234-' LDA F.COC (A) = LENGTH IN WORDS. STA F.LNL SAVE FOR WAR.F CMA,INA SET COUNTER. STA T1LST CMA,INA RESTORE. ADA K3 ACCOUNT FOR LINE #. STA T3LST FOR WRT.C LDA DLBUF SET POINTER. STA F.LNA FOR WAR.F AND STA T2LST US. * * COPY THE LINE TO OUR BUFFER. * LST01 JSB RD.F STA T2LST,I ISZ T2LST BUMP BUFFER ADDR. ISZ T1LST MORE ? JMP LST01 YUP. * * IF 'M' OPTION & NOT COMMENT, WRITE TO PASS FILE. * LDA F.CCW LOOK FOR 'M' OPTION. RAR (IN BIT 1) CCE,SLA,RSS (E=1) JMP LST02 NO. LDA LINOL YES. SET SIGN 1ST WD AS FLAG TO PASS 3. RAL,ERA (E=1) STA LINOL LDA LBUFF IS FIRST CHAR 'C' ? AND KK02 CPA "C" JMP LST02 YES, IGNORE IT. JSB OS.F NO. FLUSH CODE TO HERE JSB WRT.C WRITE THE LINE TO THE PASS FILE. DEF C.SC0 DLNOL DEF LINOL DEF T3LST JMP PASER IF PASS FILE ERROR. * * IF 'L' OPTION, LIST IT NOW. * LST02 LDA F.CCW LOOK FOR 'L' OPTION. SLA,RSS JMP LST.F,I NO. ALF HOW ABOUT 'Q' ? SSA,RSS JMP LST03 NO. * LDA DLNOL YES. REFORMAT WITH ADDRESS. LDB DLNL2 FIRST, MOVE LINE # BACK 6 CHARS. JSB .MVW DEF K3 NOP LDB F.RPL (B) = LOAD ADDRESS. CLA CONVERT. AFTER EACH LINE, (B,A) = RRR 12 00000000 00000111 22233344 45550000 BLF,RBL 00000000 11100000 22233344 45550000 RRL 6 00111000 00222333 44455500 00000000 ALF,ALF 00111000 00222333 00000000 44455500 ALF,RAR 00111000 00222333 00000444 55500000 RRR 3 00000111 00000222 33300000 44455500 BLF,RBL 11100000 22200000 33300000 44455500 LSR 5 00000111 00000222 00000333 00000444 ADB "00" DIGITS 1 & 2. ADA "00" DIGITS 3 & 4. STB LINOL STA LINOL+1 LDA F.RPL NOW DO LAST DIGIT & BLANK. AND K7 IOR "B0" BLANK,DIGIT ALF,ALF DIGIT,BLANK. STA LINOL+2 LDB DLNL2 (B) = ADDRESS. LDA T3LST (A) = OLD LENGTH. ADA K3 ACCOUNT FOR ADDRESS. JMP LST04 GO LIST & EXIT. LST03 LDB DLNOL WRITE ORDINARY LINE TO LISTING. LDA T3LST LST04 JSB PSL.F WRITE. JMP LST.F,I EXIT. SKP T1LST NOP T2LST NOP T3LST NOP KK02 OCT 177400 K7 DEC 7 B20K OCT 20000 BLANK IN UPPER BYTE. "C" BYT 103,0 "00" ASC 1,00 "B0" ASC 1, 0 DLNL2 DEF LINL2 ADDR LINE # IF 'Q' DLBUF DEF LBUFF ADDR ACTUAL SOURCE. LINL2 ASC 3,-1234- LINE # & BLANKS IF 'Q'. LINOL ASC 3,-1234- (LINE#,BLKS) OR (ADDR) *IN LBUFF BSS 40 *SEQUENCE. SPC 2 * ************************** * * PRINT COMPILER COMMENT * * ************************** SPC 1 * PRINTS A COMPILER COMMENT (E.G., EXTENDED ERROR INFO). * PCC.F NOP LDA F.COC SET UP COUNT. CMA,INA,SZA,RSS NEGATE. IF ZERO, JMP PCC.F,I IGNORE. * STA T1PCC LDA DLBUF SET UP BUFFER ADDR. STA T2PCC PCC01 JSB RD.F COPY FROM FILE TO BUFFER. STA T2PCC,I ISZ T2PCC ADVANCE BUFFER PTR. ISZ T1PCC BUMP COUNT. DONE ? JMP PCC01 NO. * LDB DLBUF WRITE LINE. LDA F.COC JSB PSL.F JMP PCC.F,I DONE. * T1PCC NOP COUNTER FOR COPY. T2PCC NOP BUFFER POINTER FOR COPY. SKP * ************************ * * COUNT UNPRINTED LINE * * ************************ SPC 1 LNL.F NOP JSB IFBRK BREAK ? DEF *+1 SSA JMP BREAK YES. QUIT. * ISZ F.LNN BUMP LINE #. CLA ZAP OTHER STUFF. STA F.CC JMP LNL.F,I EXIT. SPC 2 * ******************* * * TITLE DIRECTIVE * * ******************* SPC 1 TTL.F NOP LDA F.COC SET UP THE LENGTH. STA F.TL CMA,INA,SZA,RSS NEGATE FOR LOOP COUNTER. ZERO ? JMP TTL.F,I YES. JUST CLEARING IT, DONE. * STA T1TTL NO. T1TTL = COUNTER. LDA DFTTL SET UP POINTER. RAL,CLE,SLA,ERA REMOVE AT MOST ONE INDIRECT. LDA A,I STA T2TTL T2TTL = POINTER. TTL01 JSB RD.F GET A WORD, STA T2TTL,I PUT IT AWAY, ISZ T2TTL BUMP POINTER, ISZ T1TTL AND LOOP. JMP TTL01 JMP TTL.F,I DONE. * T1TTL NOP LOOP COUNTER. T2TTL NOP TITLE BUFFER POINTER. DFTTL DEF F.TTL TITLE BUFFER ADDR (MAY BE INDIRECT) SKP * ********* * * BREAK * * ********* SPC 1 BREAK LDA K96 DISASTER 96. JMP F.ABT * K96 DEC 96 SPC 2 * ******************* * * PASS FILE ERROR * * ******************* SPC 1 PASER LDA K99 DISASTR 99. JMP F.ABT SPC 1 K99 DEC 99 SPC 2 * ****************** * * DELAYED ERRORS * * ****************** SPC 1 ERR.F NOP JSB RD.F CLASS. STA ER.F LDA F.LNN SAVE LINE #. STA T1ERR JSB RD.F LINE #. STA F.LNN JSB RD.F COLUMN. STA F.CC JSB RD.F ERROR NUMBER. JSB WAR.F ISSUE IT. LDA T1ERR RESTORE LINE #. STA F.LNN CLA CLEAR COLUMN NUMBER. STA F.CC JMP ERR.F,I EXIT. * T1ERR NOP SKP * ************************* * * CROSS REFERENCE PAIRS * * ************************* SPC 1 * THIS BUFFER IS USED TO WRITE CROSS REFERENCE PAIRS TO THE * INTERMEDIATE CODE STRING. THE RECORD GOES OUT WITH A FIRST * WORD = -2 TO DISTINGUISH IT FROM SOURCE ('M') OR CODE. * SEE CRP.F FOR FORMAT OF PAIRS. * * THERE ARE 16 PAIRS PER RECORD EXCEPT (POSSIBLY) THE LAST ONE. * THE WORD FOLLOWING THE LAST PAIR IS 0, USUALLY IN WORD 34. * THE RECORD IS FLUSHED BY "CRPFL". SPC 1 CRF.F NOP JSB RD.F A.T. PTR STA LWORD,I OUTPUT IT. ISZ LWORD BUMP POINTER TO BUFFER ISZ NWRDS BUMP COUNTER JSB RD.F LINE #. STA LWORD,I OUTPUT IT. ISZ LWORD BUMP BUFFER POINTER ISZ NWRDS BUMP WORD COUNT. FULL? JMP CRF.F,I NOT YET. JSB CRPFL YES. FLUSH IT. JMP CRF.F,I NOW DONE. * CRPFL NOP FLUSH CROSS-REF PAIR BUFFER. LDB DEFCR EMPTY ? CPB LWORD JMP CRPFL,I YES. DON'T BOTHER. CLA STA LWORD,I FLAG END OF BUFFER JSB WRT.C WRITE THE RECORD DEF C.SC0 ON THE SCRATCH FILE DEF CRBUF-1 INCLULDE THE FLAG WORD DEF K34 34 WORDS JMP PASER ERROR ON PASS FILE LDA KM32 REINITIALIZE NUMBER OF WORDS STA NWRDS LDA DEFCR REINTIALIZE STARTING ADDRESS OF PAIRS STA LWORD JMP CRPFL,I * DEFCR DEF CRBUF CROSS REFERENCE BUFFER LWORD DEF CRBUF NWRDS DEC -32 KM32 DEC -32 K34 DEC 34 KM2 DEC -2 DON'T DELETE ! MUST PRECEDE CRBUF! CRBUF BSS 33 SKP * OPERATOR JUMP TABLE. SPC 1 TABLE DEF AO.F 1 = DEF ADD.F 2 + DEF SUB.F 3 - DEF NEG.F 4 UNARY - DEF MPY.F 5 * DEF DIV.F 6 / DEF EXP.F 7 ** DEF .OR.F 8 .OR. DEF AND.F 9 .AND. DEF NOT.F 10 .NOT. DEF .LT.F 11 .LT. DEF .LE.F 12 .LE. DEF .EQ.F 13 .EQ. DEF .NE.F 14 .NE. DEF .GE.F 15 .GE. DEF .GT.F 16 .GT. DEF EQV.F 17 .EQV. DEF XOR.F 18 .XOR. DEF IAO.F 19 INVERSE ASSIGN. DEF PTM.F 20 'END' (& RETURN IN MAIN) DEF RTN.F 21 'RETURN' DEF EBR.F 22 ENDFILE/BACKSPACE/REWIND (SAVE CODE). DEF STP.F 23 'STOP' DEF STP.F 24 'PAUSE' DEF ERR.F 25 ERRORS DELAYED FROM PASS 1. DEF SAL.F 26 START SUBROUTINE REF DEF SAL.F 27 START ARRAY REF DEF LST.F 28 LINE TO BE LISTED. DEF LNL.F 29 NEW LINE, NO LIST. DEF CRF.F 30 CROSS-REFERENCE PAIR. DEF FPE.F 31 PROGRAM ENTRY DEF INIT 32 START OF EXPRESSION DEF SSC.F 33 SIMPLE CALL DEF SAR.F 34 SUBROUTINE OR ARRAY DEF TERM 35 END OF EXPRESSION DEF ASP.F 36 'ASSIGN' DEF DSN.F 37 DEFINE STATEMENT #. DEF CAD.F 38 COPY ASCII DATA. (FORMAT & HOLLERITH) DEF AIF.F 39 'IF' (ARITHMETIC) DEF LIF.F 40 'IF' (LOGICAL) DEF GTO.F 41 'GOTO' (SIMPLE) DEF AGT.F 42 'GOTO' (ASSIGNED) DEF CGT.F 43 'GOTO' (COMPUTED) DEF DO.F 44 'DO' DEF DOT.F 45 'DO' END. DEF SNS.F 46 START NEW STATEMENT. DEF RWE.F 47 'READ','WRITE' END. DEF IDO.F 48 IMPLIED DO. DEF NR.F 49 NEW IMPLIED DO RECORD. DEF ILA.F 50 ORDERING OF IMPLIED DO. DEF DTA.F 51 'DATA' ITEM DEFINITION. DEF 0 52 (UNUSED) DEF 0 53 (UNUSED) DEF ELS.F 54 'ELSE' DEF EIF.F 55 'ENDIF' DEF PCC.F 56 PRINT COMPILER COMMENT. DEF EJP.F 57 $PAGE DEF TTL.F 58 $TITLE DEF MP1.F 59 EMA CALL-BY-REFERENCE. DEF MP1.F 60 EMA CALL-BY-VALUE. DEF SSS.F 61 STUPID SEGMENT START WORD. DEF IOA.F 62 I/O WHOLE ARRAY. DEF IOL.F 63 I/O LIST ITEM. DEF IOS.F 64 I/O STATEMENT START. DEF IOK.F 65 I/O STATEMENT KEYWORD. DEF IOE.F 66 I/O STATEMENT END (EXCEPT R/W) * TBLSZ ABS *-TABLE # OF ENTRIES IN THE TABLE. * END F4.6 ASMB,Q,C HED CONSTANT CHECKING AND FOLDING. NAM FLD.F,8 92834-16003 REV.2030 800320 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * PGMR: B.G. * *************************************** * ENT CF2.F CHECK/FOLD BINARY OPERATIONS (+-*/**). ENT CF1.F CHECK/FOLD UNARY OPS (UNARY-, CONV) * EXT F.A ASSIGNMENT TABLE ADDRESS (CURRENT ENTRY). EXT F.DID ADDRESS OF F.IDI EXT F.IDI INPUT ARRAY. EXT F.RES RESULT F.A EXT F.S1T TOP OF STACK 1. EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT AI.F ASSIGN ITEM. EXT CFC.F CHECK FOR CONSTANT. EXT EIC.F EXTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT. EXT FT.F FIND TYPE OF OPERAND IN (B). EXT MIM.F MAP (A)=F.IM TO SENSIBLE ORDER. EXT P2P.F POP 2 OPERANDS, PUSH ONE. * EXT .MVW * A EQU 0 B EQU 1 SUP * * THESE ROUTINES WERE STOLEN DIRECTLY FROM THE HFPP DIAGNOSTIC * (WRITTEN BY CRAIG CHATTERTON) ON 790820. SPC 2 * GLOBAL CONSTANTS & VARIABLES. * DFC1 DEF F.C1+0 DFC2 DEF F.C2+0 K1 DEC 1 K2 DEC 2 K3 DEC 3 K4 DEC 4 K5 DEC 5 K15 DEC 15 K64 DEC 64 K127 DEC 127 POSMX DEC 32767 * KM1 DEC -1 KM4 DEC -4 KM15 DEC -15 KM16 DEC -16 * UPBYT OCT 177400 LWBYT OCT 377 * SIGN BSS 1 TMP BSS 1 TMP2 BSS 1 * F.C1 BSS 5 F.C2 BSS 5 * ACC DEF ACC3 ACC3 BSS 5 SKP * ******************************** * * CHECK/FOLD BINARY OPERATIONS * * ******************************** SPC 1 * ENTRY: (F.S1N,I) = 1ST OPERAND. * (F.S1T,I) = 2ND OPERAND. * (A) = OPERATOR #: 0=+, 1=-, 2=*, 3=/, -1=NONE. * 4=COMPARE: RTN (A)=1ST WD DIFF. * * EXIT: RETURN POINT DEPENDS ON WHICH OPERAND(S) WERE CONSTANT: * (P+1) BOTH. IF +-*/, FOLDING COMPLETE. A,B=CODES. * (P+2) SECOND OPND CONST, (B) = CODE. * (P+3) FIRST OPND CONST, (A) = CODE. * (P+4) NEITHER OPND CONST. * CF2.F NOP STA OPNUM SAVE OPERATOR #. LDB F.S1N,I CHECK FIRST OPERAND. LDA DFC1 IF CONST, PUT IN F.C1 JSB CKUNP CHECK, UNPACK. (SETS TTYPE) ISZ CF2.F NOT CONST, BUMP RETURN. STB T1CF2 USE (B) EITHER WAY. LDB F.S1T,I CHECK 2ND OPERAND. LDA DFC2 IF CONST, PUT IN F.C2 JSB CKUNP (SETS TTYPE) JMP CF2.4 NOT CONST. GO EXIT. * LDA T1CF2 CONST. WAS FIRST CONST ? CPA B100K JMP CF2.F,I NO. NO FOLDING. * LDA OPNUM EXCEPTION: ** SSA JMP CF2.5 YES, NO FOLDING. * CPA K4 ALSO COMPARE: JMP CF2.9 GO SUBTRACT & RETURN 1ST WORD. * LDA TTYPE MAP TYPE IN CASE INT/DBI. JSB MIM.F LDB OPNUM OPERATION. SZA,RSS INTEGER ? JMP CF2.6 YES, ALL SPECIAL CASES. * CPA K1 DOUBLE INT ? JMP CF2.7 YES. ADD & SUBTRACT ARE SPECIAL. * CF2.1 ADB DFCTS PICK ROUTINE. LDB B,I JSB B,I DO IT. JSB PACK RE-PACK, ENTER IN A.T. CF2.2 LDA F.A SET UP F.A OF RESULT. STA F.RES JSB P2P.F POP OPNDS, PUSH RESULT. JMP CF2.F,I DONE. IF FOLD, A&B GARBAGE. SKP CF2.4 ISZ CF2.F 2ND NOT CONST, ADJUST RETURN. ISZ CF2.F CF2.5 LDA T1CF2 RESTORE (A) = 1ST CONST VALUE. JMP CF2.F,I NON-FOLD EXIT. * * SPECIAL PROCESSING FOR INTEGER OPERATIONS. * CF2.6 LDA F.S1T,I INTEGER. GET 2ND OPND. ADA K2 STA T1CF2 JUST SAVE ADDR. LDA F.S1N,I GET 1ST OPND. ADA K2 LDA A,I 1ST OPND. ADB DCF2I SELECT OP. LDB B,I JMP B,I DCF2I DEF *+1 DEF CF2IA ADD DEF CF2IS SUB DEF CF2IM MPY DEF CF2ID DIV * CF2IA ADA T1CF2,I ADD. JMP CF2IP CF2IS CMA SUB. ADA T1CF2,I CMA JMP CF2IP CF2IM MPY T1CF2,I MPY. JMP CF2IP CF2ID LDB A ASR 16 DIV T1CF2,I DIV. CF2IP JSB EIC.F SET UP INT CONST. JMP CF2.2 SKP * SPECIAL PROCESSING: DOUBLE INT ADD/SUB. * CF2.7 SZB DOUBLE INT. ONLY: CPB K1 ADD/SUB. ERB,SLB YES. (E=FLAG, SKIP) JMP CF2.1 NO. NORMAL. * LDA F.S1T,I GET 2ND OPND. ADA K2 DLD A,I SEZ,RSS ADD OR SUB ? JMP CF2.8 ADD. LEAVE IT. * CMA SUB. NEGATE 2ND. CMB,INB,SZB,RSS INA CF2.8 DST F.C2 SAVE 2ND. LDA F.S1N,I GET 1ST. ADA K2 DLD A,I CLE ADD. ADB F.C2+1 SEZ INA ADA F.C2 DST F.IDI SET UP NEW CONST. LDA TTYPE TYPE = DBI. JSB ESC.F JSB AI.F JMP CF2.2 GO FINISH UP. * CF2.9 JSB SUBOP COMPARE. SUBTRACT: OPND1-OPND2. LDA F.C1 RETURN 1ST WORD OF RESULT. JMP CF2.F,I DONE. * T1CF2 NOP OPNUM NOP OPERATOR #. TTYPE NOP RESULT TYPE. KK01 OCT 100002 OPND=DBI, RESLT=REA. SPC 2 DFCTS DEF *+1 ROUTINE ADDRESSES FOR FOLDING. DEF ADDOP DEF SUBOP DEF MPYOP DEF DIVOP SKP * ************************************ * * CHECK/FOLD NEGATION & CONVERSION * * ************************************ SPC 1 * ENTRY: (A) = RESULT TYPE (CONVERSION ONLY). * (B) = ADDR OF OPERAND ON STACK. * (E) = OPERATION: 1=NEGATE, 0=CONVERT. * * EXIT: RETURN TO (P+1) IF CONSTANT. STACK UPDATED. * (P+2) IF NOT CONSTANT. * CF1.F NOP STB T0CF1 SAVE STACK POINTER. CCB SAVE OPERATION: ERB -1: NEGATE 0: CONVERT. STB T2CF1 STA T1CF1 SAVE RESULT TYPE. (CONV ONLY) LDA DFC1 UNPACK TO F.C1 IF CONSTANT. LDB T0CF1,I JSB CKUNP TRY IT. (SET TTYPE) RSS NOT CONSTANT. BUMP RTN & EXIT. JMP CF1.0 CONST. * CF1.3 ISZ CF1.F BUMP RTN, JMP CF1.F,I EXIT. * CF1.0 ISZ T2CF1 WHICH OPERATION ? JMP CF1.1 CONVERSION. * LDA TTYPE NEGATION. DON'T OFL ON MAX NEG INT. CPA INT FOR INT, ADB K17 IT'S -2**15 CPA DBI FOR DBI, ADB K33 IT'S -2**31 SZB,RSS IS IT ONE OF THOSE ? (ALSO FLT ZERO) JMP CF1.F,I YES. NO OPERATION, DONE. * LDB DFC1 NEGATE. JSB COM5 JMP CF1.2 GO REPACK & REPLACE TOS. * CF1.1 LDA F.C1+1 SPECIAL CASE: AND UPBYT IF OPND = DBI LDB T1CF1 & RESLT = REA BLF,BLF ADB TTYPE (15:12=OPND TYPE, 7:4=RESULT TYPE) CPB KK01 THEN TRUNCATE STA F.C1+1 DON'T ROUND. LDA T1CF1 IS RESULT CPA CPX COMPLEX ? RSS CPA ZPX JMP CF1.3 YES. DON'T DO IT. * STA TTYPE NO. SET IT UP FOR PACKING. CF1.2 JSB PACK RE-PACK CONSTANT. LDA F.A REPLACE STACK FRAME. STA T0CF1,I STA F.RES ALSO SET UP F.RES, JUST IN CASE. JMP CF1.F,I ALL DONE ! SKP T0CF1 NOP STACK POINTER. T1CF1 NOP TYPE(S). T2CF1 NOP OPERATION: -1=NEGATE, 0=CONVERT. INT OCT 010000 DBI OCT 100000 CPX OCT 050000 ZPX OCT 140000 K17 DEC 17 K33 DEC 33 T1PAC NOP SPC 2 * ******************************* * * RE-PACK RESULT & MAKE CONST * * ******************************* SPC 1 PACK NOP JSB EXPCK HANDLE OFL/UFL. LDA TTYPE FIX UP F.IM JSB MIM.F MAP TO 0,4. (CAN'T BE CPX) SZA INT CPA K1 OR DBI ? JMP PACK1 YES. GO USE FIXOP. * STA T1PAC NO. REA/DBL/RE8, ROUND. JSB RND5 JSB EXPCK CHECK FOR UNDERFLOW/OVERFLOW. LDA T1PAC & PACK. JSB PAK5 JMP PACK2 * PACK1 JSB FIXOP INT/DBI, FIX IT. PACK2 LDA DFC1 COPY TO F.IDI LDB F.DID JSB .MVW DEF K4 NOP LDA TTYPE FORM A.T. ENTRY. JSB ESC.F JSB AI.F JMP PACK,I DONE. SKP * ************************************* * * CHECK FOR CONST, UNPACK / ANALYZE * * ************************************* SPC 1 * ENTRY: (B) = F.A OF OPERAND. * (A) = ADDR TO UNPACK TO. * * EXIT: NOT CONSTANT: RETURN TO (P+1) WITH (B)=100000. * CONSTANT, RETURN TO (P+2) WITH: * (B) = VALUE: IF ZERO, ZERO. * IF +- POWER OF 2 IN [.5,2**31], THEN * SIGN * (2+LOG2(X)) * OTHERWISE +32767 . * CKUNP NOP STA T1CKU SAVE ADDR F.C1/F.C2 STB F.A SAVE F.A OF OPND. JSB FT.F FIND TYPE STA TTYPE AND SAVE IT. LDB F.A RESTORE F.A JSB CFC.F CHECK FOR CONSTANT. JMP CKU06 NO, GO SET B=100000 & EXIT. * LDA B COPY CONSTANT. FROM HERE... LDB T1CKU TO THERE. (ORIGINAL (A)) JSB .MVW COPY IT. DEF K4 NOP LDA TTYPE GET THE TYPE. CPA CPX IF COMPLEX, RSS CPA ZPX OR DOUBLE COMPLEX, JMP CKU06 DENY THAT IT'S CONSTANT. * JSB MIM.F MAP TO [0,5]. SEZ ARITHMETIC ? JMP CKU99 NO. ERROR. * ISZ CKUNP OTHERWISE ADMIT IT. LDB T1CKU ADDR OF DATA. SZA INT OR CPA K1 DBI ? JMP CKU01 YES. GO FLOAT. * JSB UNPK5 NO. UNPACK FLOATING. JMP CKU02 * CKU01 JSB FLTOP INT/DBI, FLOAT TO 5-WORD. SKP * IT'S UNPACKED, NOW ANALYZE IT. * CKU02 LDB T1CKU,I FIRST WORD. SZB,RSS ZERO ? JMP CKUNP,I YES. RETURN B=0. * CPB B100K PROBABLE NEG. POWER OF 2 ? JMP CKU03 YES. * CPB B40K PROBABLE POS. POWER OF 2 ? RSS YES. JMP CKU05 NO. NOT A POWER OF 2 AT ALL. * CKU03 ISZ T1CKU 1ST WORD IS O.K., MAKE SURE LDA T1CKU,I THAT 2ND = 3RD = 4TH = 0. ISZ T1CKU IOR T1CKU,I .OR. 3RD ISZ T1CKU IOR T1CKU,I .OR. 4TH SZA WELL ? JMP CKU05 NO. NOT POWER OF 2. * ISZ T1CKU POWER OF 2. GET THE EXPONENT. LDA T1CKU,I SSB IF NEGATIVE POWER OF 2, INA ADJUST EXP. (A)=1+LOG2(X) NOW. SSA X < 0.5 ? JMP CKU05 YES. TOO SMALL. * ADA KM33 X > 2**31 ? SSA,RSS JMP CKU05 YES. TOO BIG. * ADA K34 (A) = 2+LOG2(X). SSB NEGATIVE NUMBER ? CMA,INA YES. NEGATE (A), TOO. LDB A COPY STATUS TO B. JMP CKUNP,I EXIT, (B) = STATUS. * CKU05 LDB POSMX UNKNOWN, RETURN (B)=32767. JMP CKUNP,I DONE. * CKU06 LDB B100K B=100000, FLAG FOR NOT CONSTANT. JMP CKUNP,I EXIT. * CKU99 LDA K57 NON-ARITHMETIC, ERROR. JSB ER.F * T1CKU NOP KM33 DEC -33 K34 DEC 34 K57 DEC 57 B100K OCT 100000 B40K OCT 040000 SKP * *************************** * * NEGATE: ((B)) = - ((B)) * * *************************** SPC 1 COM5 NOP STB TMP SAVE RSLT ADDR ADB K3 X0=-X0 LDA B,I CMA,CLE,INA STA B,I CMB,INB X1=X1'+COUT(X0) CMB LDA B,I CMA,SEZ,CLE INA STA B,I CMB,INB X2=X2'+COUT(X0) CMB LDA B,I CMA,SEZ,CLE INA STA B,I LDA TMP,I X3=X3'+COUT(X2) CMA,SEZ,RSS IF NO CIN, DONE JMP TNRM * SSA,INA ELSE INC, & CHECK FOR OVFLW JMP TNRM IF XIN WAS +, CHECK FOR NORM. OUTPUT * SSA,RSS WAS NEG. POS NOW ? JMP TNRM YES. O.K. * RAR NO, WAS -1, SHIFT RIGHT & BUMP EXP LDB TMP ADB K4 B=EXP ADDR ISZ B,I NOP IN CASE THE TUKEY TRIES TO SKIP TNRM STA TMP,I SAVE FIRST WD. LDB TMP RESTORE TMP ADDR JSB NORM5 NORMALIZE, JUST IN CASE. JMP COM5,I SKP * ******************************************** * * RIGHT CIRCULAR SHIFT (E)_((B)) ONE BIT * * ******************************************** SPC 1 ER4 NOP STB TMP2 SAVE OPND ADDR. LDA KM4 LOOP 4 TIMES. STA TMP ER01 LDA B,I SHIFT. ERA STA B,I INB ISZ TMP DONE ? JMP ER01 NO, KEEP GOING. * LDB TMP2 YES, RESTORE (B) & EXIT. JMP ER4,I SPC 2 * ******************************************* * * LEFT CIRCULAR SHIFT (E),((B)) ONE BIT * * ******************************************* SPC 1 EL4 NOP STB TMP SAVE ADDR 1ST WORD AS STOPPING POINT. ADB K4 (B) = ADDR 5TH WORD. EL01 CMB,INB BACK UP TO PREVIOUS WORD, DON'T SET (E). CMB LDA B,I SHIFT. ELA STA B,I CPB TMP JUST DID FIRST WORD ? JMP EL4,I YES, EXIT. JMP EL01 NO, KEEP GOING. SPC 2 * *********************************** * * LOGICAL LEFT SHIFT (B) ONE WORD * * *********************************** SPC 1 EL4W NOP STB TMP SAVE OPND ADDR. INB 2ND => 1ST. LDA B,I STA TMP,I ISZ TMP INB DLD B,I 3RD => 2ND. STA TMP,I ISZ TMP LDA B 4TH => 3RD, CLB 0 => 4TH. DST TMP,I LDB TMP RESTORE (B) ADB KM2 JMP EL4W,I SKP * ************************************* * * LOGICAL LEFT SHIFT (B) ONE NIBBLE * * ************************************* SPC 1 EL4N NOP STB TMP SAVE ADDR OF OPND. DLD B,I 1ST WORD. RRL 4 STA TMP,I ISZ TMP DLD TMP,I 2ND WORD. RRL 4 STA TMP,I ISZ TMP DLD TMP,I 3RD & 4TH WORDS. AND B7777 RRL 4 DST TMP,I LDB TMP RESTORE (B). ADB KM2 JMP EL4N,I DONE. * B7777 OCT 7777 SKP * ********************************************** * * ARITHMETIC RIGHT SHIFT ((B)),(E) ONE BIT * * ********************************************** SPC 1 AR4 NOP LDA B,I JUST COPY SIGN TO (E) ELA JSB ER4 AND DO CIRCULAR SHIFT. JMP AR4,I SPC 2 * ********************************************** * * ARITHMETIC RIGHT SHIFT ((B)) BY (A) BITS * * * (RETURN E=1 IFF BITS SHIFTED OUT) * * ********************************************** SPC 1 AR4N NOP CMA,INA,SZA,RSS NEGATE COUNT. ZERO ? JMP AR4N2 YES. GO CLEAR (E) & EXIT. * STA AR4NC SET -COUNT. CLA CLEAR STICKY BIT. STA AR4NS AR4N1 JSB AR4 DO A SHIFT. SEZ BIT LOST ? ISZ AR4NS YES. NOTE. ISZ AR4NC MORE ? JMP AR4N1 YES. LOOP. * LDA AR4NS BITS LOST ? AR4N2 CLE,SZA (IF NOT, E=0) CCE YES, E=1. JMP AR4N,I EXIT. * AR4NC NOP - COUNT AR4NS NOP SUM OF STICKY BITS. SKP * ******************** * * NORMALIZE ((B)) * * ******************** SPC 1 NORM5 NOP CLA INITIALIZE COUNTER. STA T1NRM LDA B,I SAVE FIRST WORD OF OPND. STA T2NRM * * FIRST, BY WORDS. * NRM5A LDA B,I (NEW) FIRST WORD. SZA IF ZERO, CPA KM1 OR -1, RSS THEN SHIFT. JMP NRM5C ELSE HIGH BIT IS IN THIS WORD. * LDA T1NRM ADD 16 TO COUNT. CPA K64 ALREADY SHIFTED 4 TIMES ? JMP NRM5B YES. RESULT = 0. * ADA K16 NO. COUNT THIS ONE. STA T1NRM JSB EL4W SHIFT. LDA B,I SIGN WRONG NOW ? XOR T2NRM SSA,RSS JMP NRM5A NO, IS O.K., KEEP SHIFTING. * LDA T2NRM OVER-SHIFTED. COMPENSATE. ELA SET (E)=CORRECT SIGN. JSB ER4 SHIFT IT BACK. CCA CORRECT SHIFT COUNT. ADA T1NRM STA T1NRM JMP NRM5Z GO CORRECT EXPONENT. * NRM5B STO ZERO. SET OVFLW,E EBP=0 CLA ADB K4 STA B,I ADB KM4 CCE JMP NORM5,I SKP * THEN BY NIBBLES. * NRM5C LDA B,I NEED (ANOTHER) NIBBLE SHIFT ? AND B174K (A)=TOP NIBBLE. SZA CPA B174K RSS YES. JMP NRM5D NO. GO DO BIT SHIFTS. * JSB EL4N SHIFT, LDA T1NRM AND FIX UP COUNT. ADA K4 STA T1NRM JMP NRM5C TRY AGAIN. * * FINALLY, BIT SHIFTS. * NRM5D LDA B,I NEED A BIT SHIFT ? ELA CHECK MOST SIG. BITS FOR NORMALIZATION CMA,SEZ,SSA,RSS JMP NRM5Z IF BITS=01, NORMALIZED SEZ,CLE,SSA JMP NRM5Z OR IF BITS=10 JSB EL4 IF NOT NORM. SHIFT LEFT & TEST AGAIN ISZ T1NRM ALSO COUNT IT. JMP NRM5D * * ADJUST EXPONENT. * NRM5Z ADB K4 RSLT EXP= OPND EXP-#SHIFTS LDA T1NRM # SHIFTS. CMA,INA ADA B,I STA B,I ADB KM4 RESTORE (B). JMP NORM5,I * T1NRM NOP T2NRM NOP K16 DEC 16 KM2 DEC -2 B174K OCT 174000 SKP * **************************************** * * MANTISSA ADD: ((A)) = ((A)) + ((B)) * * **************************************** SPC 1 SUMOP NOP STB TMP SAVE 2ND OPND ADDR. * ADB K3 LOW MANT ADDR 2ND OPND LDB B,I SEZ,CLE IF CIN, INC WORD INB ADA K3 LOW MANT ADDR 1ST OPND / RESULT ADB A,I ADD IN 1ST OPND STB A,I & REPLACE. * LDB TMP GET 3RD WD 2ND OPND. ADB K2 LDB B,I CMA,SEZ,CLE,INA PROPOGATE ANY PREVIOUS CARRY AND START INB DECREMENTING (A) WITHOUT SETTING (E). CMA FINISH SAFE DECREMENT OF (A). ADB A,I ADD TO 3RD WD 1ST OPND. STB A,I LDB TMP 2ND WORD, JUST LIKE 3RD. INB LDB B,I CMA,SEZ,CLE,INA INB CMA ADB A,I STB A,I * CLO LDB TMP,I HIGH MANT CMA,SEZ,CLE,INA IF CIN INC INB CMA (A) IS NOW ADDR 1ST OPND. SOC IF OVFLW, MUST DO SPECIAL ADD JMP SPAD ADB A,I B = UPPERS + CARRY SUM01 STB A,I LDB A (B) = RESULT ADDR. JMP SUMOP,I THATS ALL FOLKS * SPAD ADB A,I (1ST UPPER + CARRY = 40000B) + 2ND UPPER SSB,RSS IF A>0, THEN 2ND UPPER < 0, CLEAR OVFLW CLO JMP SUM01 GO HOME SKP * **************************** * * ADD: F.C1 = F.C1 + F.C2 * * **************************** SPC 1 ADDOP NOP LDA F.C1 IF FIRST OPND = 0, CLE,SZA,RSS JMP ADD02 RESULT EXP = 2ND EXP. * LDA F.C2 IF 2ND OPND = 0, SZA,RSS JMP ADD03 RESULT EXP = 1ST EXP. * LDA F.C2+4 FORM (1ST EXP) - (2ND EXP) CMA,INA ADA F.C1+4 SSA,RSS IF +, COMPL & TEST (1ST >= 2ND) JMP XGTY * ADA K64 A=64-DIFF (1ST < 2ND) LDB F.C2+4 RESULT EXP = 2ND EXP STB F.C1+4 LDB DFC1 (B) = ADDR 1ST OP. SSA IF<0,SWAMP-- 1ST=0 JMP SET0 JMP SHIFT ELSE SHIFT Y RIGHT * XGTY CMA,INA FORM 64 - DIFF ADA K64 LDB DFC2 (B) = ADDR OPND2 SSA IF <0, SWAMP-- 2ND=0 JMP SET0 * SHIFT ADA NEG65 A= =#SHIFTS-1 CMA COMPL CNT JSB AR4N SHIFT IT SEZ,RSS CHECK FOR STICKY BIT JMP ADD03 NO. DONE. * ADB K3 YES. OPND(0)=IOR(OPND(0),1) CLA,INA IOR B,I STA B,I JMP ADD03 * SET0 CLA CLEAR OPND STA B,I INB STA B,I INB STA B,I CLE,INB STA B,I JMP ADD03 SKP ADD02 LDA F.C2+4 (1ST OPND = 0) STA F.C1+4 ADD03 CLE NO CIN LDA DFC1 DO THE ADD LDB DFC2 JSB SUMOP SOC IF OVFLW, ADJUST RSLT JSB MOVFW JSB NORM5 JMP ADDOP,I * NEG65 DEC -65 SPC 2 * ********************************* * * SUBTRACT: F.C1 = F.C1 - F.C2 * * ********************************* SPC 1 SUBOP NOP LDB DFC2 NEGATE F.C2 JSB COM5 JSB ADDOP THEN ADD. JMP SUBOP,I SPC 2 * * ADJUST ((B)) AFTER OVERFLOW * SPC 1 MOVFW NOP STB T1MOF SAVE OPND ADDR JSB ER4 SHIFT OPND BACK ONE BIT LDA B,I A=OPND(3) ADB K3 B=OPND(0) ADDR SEZ,CLE,RSS IF LSB=1, CHECK FOR SIGN OF OPND JMP EXPUP SSA,RSS IF A<0, SET LSB OF OPND=1 JMP EXPUP CLA,INA IOR B,I STA B,I EXPUP INB B=EXP ADDR ISZ B,I EXP =EXP + 1 JMP *+1 IT COULD SKIP LDB T1MOF RESTORE OPND ADDR JMP MOVFW,I NOW GET OUT OF THIS HOLE * T1MOF NOP SKP * ********************************* * * MULTIPLY: F.C1 = F.C1 * F.C2 * * ********************************* SPC 1 MPYOP NOP JSB MDENT CLEAR ACCUMULATORS, COMPUTE SIGN. LDA NEG63 63 BITS TO WORRY ABOUT. STA MPCNT LDB DFC1 SHIFT MULTIPLICAND RIGHT TO AVOID OVERFLOW. JSB AR4 MPY01 LDB ACC SHIFT RUNNING SUM RIGHT. JSB AR4 LDB DFC2 PICK OFF THE NEXT MULTIPLIER BIT. JSB AR4 LDA ACC SET UP TO ADD IN MULTIPLICAND. LDB DFC1 SEZ,CLE MULTIPLIER BIT SET ? (E=0 FOR SUMOP) JSB SUMOP YES, DO IT. ISZ MPCNT COUNT. DONE ? JMP MPY01 NO, GO ON. * LDA ACC COPY RESULT MANTISSA. LDB DFC1 JSB .MVW DEF K4 NOP LDA F.C1+4 FORM RESULT EXPONENT. ADA F.C2+4 STA F.C1+4 LDB DFC1 NORM RESULT LDA SIGN IF SIGN ODD, RSLT=-RSLT CLE,SSA JSB COM5 * JSB NORM5 * JMP MPYOP,I DRIVE HER HOME, BOYS * MPCNT BSS 1 NEG63 DEC -63 SKP * ******************************* * * DIVIDE: F.C1 = F.C1 / F.C2 * * ******************************* SPC 1 DIVOP NOP LDA F.C2 2ND OPND ZERO ? SZA,RSS JMP EXIT0 YES, RSLT EXP=TOO LARGE --OVFLW * LDA F.C1 1ST OPND ZERO ? SZA,RSS JMP DIVOP,I YES, RESULT = 0 = 1ST OPND * JSB MDENT TAKE ABS, COMPUTE SIGN. LDA DFC2 SET UP NEGATED 2ND OPND LDB YCOM JSB .MVW DEF K5 NOP LDB YCOM JSB COM5 LDA YCOME SEE IF 2ND OPND IS 1: CPA F.C2+4 I.E., SAME EXP IF + OR - ? RSS YES. NOT -1, NORMAL. JMP TSTR -1, SPECIAL CASE (YCOM NOT ALIGNED). * LDA NEG62 SET LOOP COUNT STA DVCNT DIVLP LDA F.C1 (A) HAS SIGN OF 1ST OPND. LDB DFC2 DECIDE WHETHER TO ADD OR SUB. CLE,SSA,RSS WELL ? (E=0 FOR SUMOP) LDB YCOM SUB. LDA DFC1 DO X=X+Y OR X=X-Y JSB SUMOP CLE NO SHIFT IN JSB EL4 X=X*2 CME Q0=-SIGN OF X DIVSH LDB ACC LEFT SHIFT RESULT. JSB EL4 Q=Q*2 * ISZ DVCNT DONE ? RSS JMP DVASB YES. * LDA F.C1 NO. IF 2 HIGH BITS SAME, KEEP SHIFTING. RAL,SLA IF NEG, COMPLEMENT. CMA CLE,SSA NOW TEST 2ND BIT: (E=0) JMP DIVLP IF SET, NORMALIZED, DONE SHIFTING. * LDB DFC1 UNNORMALIZED. SHIFT DIVIDEND. JSB EL4 JMP DIVSH SHIFT RESULT USING SIGN(DIVIDEND) SKP DVASB LDB ACC DONE, BUT Q NEEDS ONE MORE SHIFT CCE FORCE LSB=1 FOR PROPER NEGATE ROUNDING. JSB EL4 * LDA ACC F.C1=ACC LDB DFC1 JSB .MVW DEF K4 NOP TSTR LDA F.C2+4 COMPUTE RESULT EXPONENT. CMA,INA ADA F.C1+4 INA STA F.C1+4 LDB DFC1 JSB NORM5 NORMALIZE RESULT LDA SIGN IF SIGN ODD, NEGATE. CLE,SSA JSB COM5 JMP DIVOP,I IS IT SOUP YET? * EXIT0 LDB LWBYT STORE ILLEGAL EXP IN RESULT EXP STB F.C1+4 STB F.C1 MAKE MANTISSA NON-ZERO SO NORM5 WORKS. LDB DFC1 RETURN (B)=ADDR RESULT. JMP DIVOP,I THAT SHOULD DO IT FOR NOW! * NEG62 DEC -62 DVCNT BSS 1 YCOM DEF *+1 BSS 4 YCOME BSS 1 SPC 2 * COMMON ENTRY CODE FOR MPYOP, DIVOP. * MDENT NOP LDA F.C1 COMPUTE RESULT SIGN. XOR F.C2 STA SIGN LDB DFC1 TAKE ABS(F.C1) LDA B,I SSA JSB COM5 LDB DFC2 TAKE ABS(F.C2) LDA B,I SSA JSB COM5 CLA,CLE CLEAR ACCUMULATOR & (E). STA ACC3 STA ACC3+1 STA ACC3+2 STA ACC3+3 STA ACC3+4 JMP MDENT,I EXIT. SKP * *************************** * * ROUND F.C1 TO (A) WORDS * * *************************** SPC 1 RND5 NOP STA WRDAJ CMA GET INDEX TO RNDING WORD ADA RNDBF LDB A 2ND OP TO SUMOP. LDA F.C1 (A) HAS SIGN OF OPND ELA E=CIN=1 IF OPND >=0 IE ADD 200B CME LDA DFC1 ADD ROUND WORD. JSB SUMOP SOC JSB MOVFW HANDLE OVERFLOW. CLA CLEAR MANTISSA WORDS AFTER ROUND WORD. LDB WRDAJ CPB K2 2-WORD ? STA F.C1+2 YES, CLEAR 3RD. RBR,SLB,RBL 4-WORD ? STA F.C1+3 NO, CLEAR 4TH. ADB KM1 MASK OFF LOWER 8 BITS OF LOW WORD ADB DFC1 LDA B,I AND UPBYT STA B,I LDB DFC1 JSB NORM5 MAY HAVE TO NORMALIZE. JMP RND5,I * WRDAJ BSS 1 * RNDBF DEF RNDBE OCT 0 OCT 0 OCT 0 OCT 177 OCT 177777 RNDBE OCT 177777 POINTS TO LAST WORD OF BUFFER SKP * ********************************** * * PACK F.C1 TO (A)-WORD FLOATING * * ********************************** SPC 1 PAK5 NOP CCB COMPUTE ADDR LAST WORD. ADB DFC1 ADB A LDA B,I CLEAR LOW BITS. AND UPBYT STA B,I LDA F.C1+4 FORMAT THE EXPONENT. RAL SIGN TO LSB, AND LWBYT 8 BITS ONLY. IOR B,I MERGE. STA B,I JMP PAK5,I EXIT. SPC 2 * ****************************************** * * UNPACK ((B)) IN PLACE, (A)-WD FLOATING * * ****************************************** SPC 1 UNPK5 NOP STB TMP ADB KM1 B=LOW MANT ADDR ADB A STB TMP2 LDA B,I A=LOW OPND WORD AND LWBYT FORM EXPONENT HALF SLA,RAR MOVE SIGN TO BIT 15, EXTEND IF NECESSARY IOR NEGXP LDB TMP STORE EXP IN 5TH WORD ADB K4 STA B,I LDA TMP2,I TRUNCATE LOW MANT TO UPPER BYTE. AND UPBYT STA TMP2,I CLA CLEAR EXTRA WDS. ((B))=EXPONENT. UNP01 ADB KM1 BACK UP FROM EXPONENT. CPB TMP2 AT LAST MANTISSA WORD ? JMP UNP02 YES. DONE. * STA B,I NO. CLEAR WORD IN BETWEEN. JMP UNP01 TRY AGAIN. * UNP02 LDB TMP RETURN (B) = OPERAND ADDR. JMP UNPK5,I SET THE CHUTE AND LET IT FLY * NEGXP OCT 177600 SKP * ************************************* * * CHECK F.C1 FOR UNDERFLOW/OVERFLOW * * ************************************* SPC 1 EXPCK NOP LDA F.C1+4 EXPONENT. SSA,RSS IF EXP>0,A=-EXP-1 CMA ADA PS128 CLO SSA,RSS IF EXP IN RANGE GO HOME JMP EXPCK,I STO OVERFLOW FLAG LDA F.C1+4 CHECK SIGN OF EXP SSA IF <0, UNDERFLOW JMP UNFLW LDA K127 ELSE SET TO MAX + STA F.C1+4 SET EXP. LDA POSMX SET 1ST WD TO 077777B STA F.C1 CCA SET NEXT 2 WORDS TO 177777B STA F.C1+1 STA F.C1+2 LDA UPBYT 4TH WORD= UPPER 8 BITS ONLY STA F.C1+3 JMP EXPCK,I * UNFLW CLA STA F.C1 SET ALL ZEROES. STA F.C1+1 STA F.C1+2 STA F.C1+3 STA F.C1+4 JMP EXPCK,I SET SAILS FOR THE INDIES PS128 DEC 128 SKP * ****************************************** * * FIX F.C1 TO INTEGER, A=0/1 FOR SNG DBL * * ****************************************** SPC 1 FIXOP NOP STA INTWD SAVE SINGLE-DOUBLE FLAG SZA IF DOUBLE, A=16-- #SHIFTS=15+16*INTWD-EXP LDA KM16 A<=-#SHIFTS ADA KM15 ADA F.C1+4 ADD EXP. (A) = - # SHIFTS. CLO CLEAR OVERFLOW FOR RETURN (SET LATER) SZA,RSS IF CNT=0,CHECK FOR ROUND JMP FXTRD (A=0 HERE, NO STICKY BIT) SSA,RSS IF CNT>0, OVERFLOW JMP FIXOV GO TEST * CMA,INA NEGATE COUNT LDB DFC1 JSB AR4N SHIFT CNT TIMES CLA FORM STICKY BIT. ELA * FXTRD LDB F.C1 IF #>=0, RETURN. SSB,RSS ELSE CHECK FOR ROUND JMP FIXOP,I * LDB INTWD 'OR' TOGETHER ALL BITS SZB,RSS AFTER END OF INTEGER. IOR F.C1+1 (ONLY FOR SINGLE INT) IOR F.C1+2 IOR F.C1+3 SZA,RSS ANY BITS SET ? JMP FIXOP,I NO, RETURN * LDB DFC1 YES, BUMP THE INTEGER. ADB INTWD GET LSW OF RESULT ISZ B,I IF NOT=0, DONE-- RETURN JMP FIXOP,I CPB DFC1 IF SINGLE INTEGER, RETURN JMP FIXOP,I ISZ DFC1,I ELSE ROUND UPPER WORD NOP IT COULD SKIP! JMP FIXOP,I FIXOV LDA POSMX A=32767=OVERFLOW # CCB B=-1, IN CASE DOUBLE INTEGER. DST F.C1 PUT IN RESULT STO OVERFLOW RETURN JMP FIXOP,I * INTWD BSS 1 SKP * ****************************************** * * CONVERT ((B)) FROM INTEGER TO INTERNAL * * * (A) = 0/1 FOR SNG/DBL INT * * ****************************************** SPC 1 FLTOP NOP INB ADVANCE TO 2ND WORD. CLE,ERA (A)=0, (E)=SNG/DBL FLAG. SEZ,RSS IF SINGLE INT, STA B,I DO 2ND WORD. INB STA B,I 3RD INB STA B,I 4TH INB ELA,ALF SNG:0 DBL:16 ADA K15 SNG:15 DBL:31 STA B,I SET EXPONENT VALUE. ADB KM4 NORMALIZE. JSB NORM5 JMP FLTOP,I EXIT. * END ASMB,Q,C HED REGISTER AND TYPE MANAGEMENT. NAM RTM.F,8 92834-16003 REV.2030 800416 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * 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) * 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.AF ADDRESS FIELD OF CURRENT A.T. ENTRY. EXT F.AT ADDRESS TYPE OF CURRENT A.T. ENTRY. EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.OFE DATA POOL OVERFLOW ENTRY. EXT F.RES F.A OF CURRENT RESULT. EXT F.S1B BOTTOM OF STACK 1. EXT F.S1T TOP OF STACK 1. EXT F.S2T TOP OF STACK 2. EXT F.T # WORDS ON STACK 1. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT CFC.F CHECK FOR CONSTANT. EXT DAF.F DEFINE (F.AF) EXT DIM.F DEFINE (F.IM) EXT EDO.F ESTABLISH DATA WITH OFFSET. EXT EIC.F ESTABLICH INTEGER CONSTANT. EXT FA.F FETCH ASSIGNS EXT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT SOA.F SET F.A=(B) AND OUTPUT (A). * * ENTRY POINTS IN F4.6 * EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT ATC.F ALLOCATE TEMP CELL. EXT DEF.F PRODUCE A DEF TO (B). * * ENTRY POINTS IN AOP.F * EXT ADD.F ADD. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * ENT F.ACA STACK ADDR OF (A) REGISTER. ENT F.ACB STACK ADDR OF (B) REGISTER. ENT F.ACM STACK ADDR OF CURRENTLY MAPPED ITEM. * ENT ABB.F SET UP A/B BIT FROM F.RES TO A<11>. ENT AOR.F ALLOCATE ONE REGISTER. ENT CAR.F CLEAR REG DATA & MAP STATUS. ENT CBR.F CLEAR REGISTER DATA FOR BOTH REGISTERS. ENT CRD.F CLEAR REGISTER DATA (ONE REGISTER). ENT FT.F FIND TYPE. ENT GRD.F GET REGISTER DATA. ENT GT1.F GET TYPE OF TOP-OF-STACK. ENT GT2.F GET TYPE OF TWO TOP OPERANDS. ENT LD.F LOAD. ENT LDA.F LOAD INTO (A). ENT LDB.F LOAD INTO (B). ENT LDF.F LOAD FIRST WORD. (EITHER REGISTER). ENT LDO.F LOAD WITH OFFSET. ENT MIM.F MAP ITEM MODE. ENT P1P.F POP ONE STACK ITEM, PUSH RESULT. ENT P2P.F POP TWO STACK ITEMS, PUSH RESULT. ENT PO1.F POP ONE STACK ITEM. ENT PU1.F PUSH ONE STACK ITEM. ENT SBR.F STORE BOTH REGISTERS. ENT SCG.F START CODE GENERATION. (LOAD TOS). ENT SMT.F SAVE MAPPED DATA IN TEMP (FREE MAPS). ENT SRD.F STORE REGISTER DATA. ENT SRS.F STORE REGISTER DATA, SHORT FORM. ENT SRT.F STORE REGISTER INTO TEMP. ENT ST.F STORE. ENT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F * EXT EA?.F SKIP IF F.A IS IN EMA. EXT MAP.F MAP (F.A). * * MISCELLANEOUS LIBRARY. * EXT .MVW MOVE WORDS. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SPC 2 * ****************** * * SET UP A/B BIT * * ****************** SPC 1 ABB.F NOP LDA F.RES JUST F.RES, ALF,ALF LEFT SHIFTED 11. ALF,RAR JMP ABB.F,I DONE. SKP * ************************************ * * MAP DATA & FREE MAPS (FOR LOADS) * * ************************************ SPC 1 * ENTRY: (B) = F.A TO BE MAPPED. * EXIT: (B) = F.RES = MAPPED F.A * MAPS SET FREE IF ITEM WAS OR IS MAPPED. * MFM.F NOP STB F.A CHECK IT OUT. STB F.RES SET F.RES IN CASE NOT MAPPED. LDA F.ACM IF THIS IS THE MAPPED ITEM, CPB A,I SZA,RSS (THERE MUST BE ONE) RSS (NO) JMP MFM01 THEN FREE THE MAPS & EXIT. * JSB EA?.F NO. IS IT IN EMA ? JMP MFM.F,I NO. DONE. * JSB MAP.F YES, MAP IT. MFM01 CLA NOW FREE UP THE MAPS. STA F.ACM JMP MFM.F,I DONE. (B) = F.A AGAIN. SPC 2 * ************************** * * LOAD FIRST WORD OF (B) * * ************************** SPC 1 LDF.F NOP JSB MFM.F MAP & FREE MAPS. STB T1LDF SAVE F.A SZB IN REGISTER ? CPB K1 JMP LDF01 YES. * JSB AOR.F NO. ALLOCATE ONE OR OTHER. JSB SRT.F AND FREE IT UP. DEF F.RES JSB ABB.F NOW LOAD 1ST WD. ADA LDAI LDB T1LDF JSB SOA.F JMP LDF03 GO SET REGISTER STATUS. * LDF01 JSB GRD.F CHANGE TO INTEGER. DEF T1LDF LDA INT JSB SRD.F DEF T1LDF LDB T1LDF LOAD FIRST WORD. JSB LD.F LDF03 LDA INT SET RESULT. JSB SRS.F DEF F.RES JMP LDF.F,I EXIT. * T1LDF NOP F.A OF ITEM TO LOAD. SKP * ***************** * * GENERATE LOAD * * ***************** SPC 1 * INITIALIZE, MAP IN IF EMA, CHECK IF IN REGISTER. * LD.F NOP (B) = A.T. POINTER TO LOADING VAR. JSB MFM.F MAP & FREE MAPS. (SETS F.A & F.RES) STB T0LD SAVE IT BRS REGISTER ? SZB JMP LD02 NO. * * IF DATA IN REG, DONE. * JSB GRD.F YES. GET INFO. DEF T0LD STA F.RTP F.RTP = F.IM OF ITEM. SOS ADDR ? JMP LD.F,I NO. DATA IN REG, DONE. * * ADDR IN REG. DEPENDS ON DATA TYPE. * LDB T0LD YES. (B) = 0/1. CPA INT IF INTEGER JMP LD005 GO DO LDA CPA LOG SAME IF LOG JMP LD005 CPA REA IF REAL ARRAY JMP LD004 GO DO DLD CPA DBI SAME FOR DOUBLE INTEGER. JMP LD004 CPA LO4 SAME FOR DOUBLE LOGICAL. JMP LD004 * LD003 LDA F.RTP NOT LOADABLE. ALLOCATE TEMP, JSB ATC.F LDB T0LD AND COPY IT THERE, JSB ST.F TO MAKE SURE MAPS ARE FREE NOW. JMP LD.F,I EXIT. * * LOAD 2-WORD DATUM FROM ADDR IN REG. * LD004 LDA T0LD STORE OTHER REGISTER, WHICHEVER. CMA,INA INA STA T2LD JSB SRT.F DEF T2LD LDA .DLD DO 'DLD' JSB OAI.F (RTN A=0,E=1) ERA A=100000 IOR T0LD A,I / B,I JSB OAI.F THE DEF. JMP LD06 GO SET F.RES & REG STATUS. SKP * LOAD ONE-WORD DATUM FROM ADDR IN REG. * LD005 LDB T0LD IN (A) ? SZB,RSS JMP LD007 YES. GO DO 'LDA 0,I' * LDA F.ACA IN (B). IS (A) FREE ? SSA JMP LD008 YES. GO DO 'LDA 1,I' * LDA LDB1I NO. DO 'LDB 1,I' (B=1, F.RES) JMP LD009 * LD008 JSB CBR.F 'LDA 1,I', CLEAR BOTH REG (TO GET B) LD007 LDA LDA0I SET UP LDA 0/1,I ADA T0LD CLB F.RES=0. LD009 STB F.RES JSB OAI.F JMP LD05 GO SET REGISTER STATUS. * * LOAD FROM MEMORY. DEPENDS ON DATA TYPE. * LD02 JSB GIM.F (A) = F.IM STA F.RTP SAVE IN F.RTP CPA INT IF INTEGER, JMP LD03 OUTPUT LDA / LDB CPA LOG IF LOGICAL, JMP LD03 OUTPUT SAME. CPA REA IF REAL, JMP LD04 OUTPUT DLD R CPA DBI DITTO DOUBLE INTEGER. JMP LD04 CPA LO4 AND DOUBLE LOGICAL. JMP LD04 JMP LD003 NOT LOADABLE, COPY TO TEMP. * * LOAD ONE WORD FROM MEM. ** ALLOCATE REGISTER ** * LD03 JSB AOR.F ALLOCATE EITHER ONE. JSB SRT.F FREE UP THE REGISTER. DEF F.RES LDB T0LD RESTORE F.A STB F.A JSB CFC.F CONSTANT ? JMP LD07 NO. * CLB YES. (B) = OPCODE TO FORM IT, IF ANY. SZA,RSS ZERO ? LDB CLAI YES. 'CLA' CPA KM1 -1 ? LDB CCAI YES. 'CCA' CPA K1 +1 ? LDB CLAII YES. 'CLA,INA' SZB,RSS ANY FOUND ? JMP LD07 NO. * LDA B (A) = INST. JSB ORI.F OUTPUT IT WITH A/B BIT. JMP LD05 GO FINISH UP. * LD07 JSB ABB.F FORM LDA / LDB ADA LDAI JSB OA.F LOAD THE WORD. JMP LD05 GO SET UP REGISTER INFO. * * LOAD TWO-WORD DATUM FROM MEMORY. * LD04 JSB SBR.F FREE UP BOTH REGISTERS. LDA .DLD JSB OAI.F OUTPUT 'DLD' LDB T0LD JSB DEF.F OUTPUT DEF R * * SET RESULT ADDR AND REGISTER STATUS. * LD06 CLA FOR (A) OR (A,B) STA F.RES LD05 LDA F.RTP F.IM JSB SRS.F STORE REG DATA. DEF F.RES JMP LD.F,I EXIT. SPC 1 T0LD BSS 1 T2LD BSS 1 .DLD OCT 104200 DOUBLE LOAD LDAI OCT 62000 CCAI CCA KM8 DEC -8 KM1 DEC -1 K0 DEC 0 K1 DEC 1 SKP * ************************* * * START CODE GENERATION * * ************************* SPC 1 * I.E., LOAD TOP-OF-STACK IF LOADABLE. * SCG.F NOP LDB F.S1T,I JSB FT.F GET TYPE, JSB MIM.F AND ANALYZE. SSB LOADABLE ? JMP SCG.F,I NO. * LDB F.S1T,I YES. LOAD IT. JSB LD.F JSB P1P.F REPLACE TOS WITH REGISTER. JMP SCG.F,I SPC 2 * ************************** * * LOAD INTO (A) OR (A,B) * * ************************** SPC 1 LDA.F NOP JSB MFM.F MAP & FREE MAPS. CLAI CLA SET F.RES=0. STA F.RES SZB,RSS IS IT ALREADY IN (A) ? JMP LDA01 YES, IT'S O.K. * STB T1LDA NO. (REMEMBER F.A) JSB SRT.F STORE (A) TO GUARANTEE DEF K0 THAT THE LOAD WILL BE INTO IT. LDB T1LDA (RESTORE F.A) CPB K1 DATA/ADDR IN (B) ? RSS YES. JMP LDA01 NO. JUST GO LOAD. * JSB GRD.F YES. IF DATA, STILL NOT THERE. DEF K1 CLB,INB (IN CASE ADDR) SOS IF ADDR, WILL WORK. JMP LDA02 ELSE DATA. GO DO 'LDA B'. * LDA01 JSB LD.F JUST LOAD. WILL GO INTO (A). JMP LDA.F,I * LDA02 STA T1LDA (SAVE ITS F.IM) LDA LDA1 DO 'LDA B' JSB OAI.F ISSUE. JSB CBR.F VOID (B) (A TOO) LDA T1LDA SET UP A-REG DATA: TYPE, JSB SRS.F DO IT. DEF K0 JMP LDA.F,I DONE. * T1LDA NOP LDA1 LDA B SKP * ***************** * * LOAD INTO (B) * * ***************** SPC 1 * ENTRY: (B) = F.A OR REG # OF DATA TO LOAD. * EXIT: (F.RES) = 1 TO INDICATE (B). * LDB.F NOP JSB MFM.F MAP & FREE MAPS. CLA,INA SET F.RES=1. STA F.RES SZB,RSS DATA/ADDRESS IN (A) ? JMP LDB01 YES. * CPB K1 IN (B) ? JMP LDB00 YES. LEAVE IT ALONE FOR NOW. * STB T1LDB (PRESERVE (B)) JSB SRT.F NO. STORE CURRENT CONTENTS. DEF K1 LDB T1LDB (RESTORE (B)) LDB00 LDA F.ACA NOT IN (A). SAVE STATUS STA T1LDB OF (A) AND SET IT 'IN-USE'. CLA STA F.ACA JSB LD.F NOW LD.F FORCED TO USE (B). LDA T1LDB RESTORE STATUS OF (A). STA F.ACA JMP LDB.F,I DONE. * LDB01 JSB SRT.F DATA/ADDRESS IN (A). FREE UP (B). DEF K1 JSB GRD.F WHICH ? DEF K0 (O=1 IFF ADDRESS) STA T1LDB (SAVE F.IM OF DATA) LDA LDB0 DO 'LDB A' SOC UNLESS ADDRESS, LDA LDB0I THEN MAKE IT 'LDB A,I' JSB OAI.F ISSUE INSTRUCTION. JSB CBR.F VOID (A). (B, TOO) LDA T1LDB SET UP B-REG INFO: TYPE, JSB SRS.F DO IT. DEF K1 JMP LDB.F,I DONE. * T1LDB NOP LDB0 LDB A SKP * ******************** * * LOAD WITH OFFSET * * ******************** SPC 1 * WILL SET UP ACCESS TO AN ITEM WHICH IS OFFSET FROM ANOTHER * ITEM. MAIN USE IS TO CONVERT DBI=>INT AND CPX=>REA. * * ENTRY: (A)=OFFSET. * (B)=F.A OF ITEM (MAY BE REG #). * (F.RTP)=RESULT TYPE. * * EXIT: (F.RES)=RESULT F.A OR REG #. IF WAS REG ON STACK, RESULT * IS REGISTER WITH SAME STACK ADDR, BUT STACK ISN'T UPDATED. * LDO.F NOP STA T1LDO T1LDO=OFFSET, LDA F.RTP STA T3LDO T3LDO=RESULT TYPE. STB F.A MAP IN IF EMA. JSB MAP.F STB T2LDO T2LDO=F.A JSB GRD.F DATA/ADDRESS IN REGISTER ? DEF T2LDO STB T4LDO IF SO, T4LDO = STACK ADDR, IF ANY. SSB WELL ? JMP LDO04 NO. * SOS YES. WHICH ? JMP LDO03 DATA. * * ADDRESS IN REGISTER, JUST ADD OFFSET. * LDO01 ERA ADDRESS. REMEMBER IF EMA. STA T5LDO LDA INT CHANGE TYPE TO INT, JSB SRS.F DEF T2LDO LDA T2LDO PUSH IT ONTO STACK, JSB PU1.F LDA T1LDO FORM OFFSET, JSB EIC.F JSB PU1.F PUT THAT ON STACK, AND JSB ADD.F ADD 'EM UP. (SETS F.RES) JSB PO1.F POP RESULT OFF STACK. STO CHANGE BACK TO ADDR, LDA T5LDO AND RESTORE EMA STATUS. ELA LDO02 LDA T3LDO SET TYPE, LDB T4LDO AND STACK ADDR. SSB BUT IF WASN'T IN REGISTER BEFORE, CLB THEN DON'T VOID NOW. JSB SRD.F (E & O ALREADY SET UP) DEF F.RES JMP LDO.F,I THAT'S IT. SKP * DATA IN REGISTERS, JUST ADJUST REGISTER #. * LDO03 JSB CRD.F FIRST, ZAP THE OLD REGISTER DATA. DEF T2LDO LDA T2LDO NOW ADJUST REG #. ADA T1LDO STA F.RES CLO DATA (NOT ADDR), CLE NOT EMA. JMP LDO02 GO SET TYPE & STACK ADDR. * * IN MEMORY. IF POSSIBLE, USE DATA W/OFFSET. * LDO04 LDA T2LDO,I ALREADY DATA W/OFFSET ? LDB T1LDO (IN CASE NOT) AND B601 I.E., F.IU=ARR & F.NT=1 ? CPA B601 RSS YES. JMP LDO05 NO. * LDA T2LDO GET F.A OF MASTER, VALUE OF OFFSET. INA DLD A,I (A)=MASTER, (B)=OFFSET. STA T2LDO REPLACE MASTER, ADB T1LDO AND ADD OFFSET IN. STB T1LDO * LDO05 SZB,RSS OFFSET ZERO ? JMP LDO06 THEN CAN ALWAYS DO IT. * LDA T2LDO IN MEM. FORMAL ? STA F.A JSB FA.F / LDA F.AT I.E., F.AT=DUM ? CPA DUM JMP LDO07 YES. CAN'T USE DATA WITH OFFSET. * LDA F.IM ADDR TEMP ? CPA ADDR JMP LDO07 YES. LIKEWISE. * LDO06 LDA F.RTP USE DATA WITH OFFSET. STA F.IM SET UP F.IM=TYPE, LDA T1LDO OFFSET, LDB T2LDO FROM ITEM. JSB EDO.F ESTABLISH DATA WITH OFFSET. LDA F.A SET UP F.RES & EXIT. STA F.RES JMP LDO.F,I SKP * FORMAL PARAM OR ADDR TEMP. EITHER LOAD IT & ADJUST * REG #, OR LOAD ITS ADDRESS AND BUMP THAT. * LDO07 LDA F.IM GET ITEM'S TYPE. CPA ADDR IF ADDRESS, LDA F.AF IT'S IN ITS F.AF JSB MIM.F SSB (CAN'T BE 1-WORD) 2 WORDS ? JMP LDO08 NO. MUST FUDGE ADDRESS. * LDA F.ACB IF 2-WORD ITEM IN (A,B), CPA K1 THEN HAVE TO STORE BOTH WORDS, SO BOTH JMP LDO09 REG WILL BE FREE, SO LOAD WHOLE ITEM. * AND F.ACA NO. ARE BOTH ALREADY FREE ? SSA (IFF BOTH F.AC* < 0) JMP LDO09 YES. LOAD WHOLE NUMBER. * LDO08 JSB AOR.F ALLOCATE A REGISTER FOR THE ADDRESS. JSB ABB.F SET UP A/B, ADA LDAII WITH LOAD INDIRECT, LDB T2LDO WHICH CANCELS ITEM'S INDIRECT. JSB SOA.F ISSUE IT. LDA T2LDO WAS ITEM MAPPED ADDRESS ? LDB F.ACM I.E., CPA B,I ITEM MATCHES STACK POSITION F.ACM, CCE,SZB,RSS AND F.ACM#0 ? (E=1, IN CASE EMA) CLE NO. SET NON-EMA REGISTER STATUS. LDA F.RES SET T2LDO=F.RES, STA T2LDO SO CAN USE REG OFFSET CODE ABOVE. JMP LDO01 GO DO IT. * * 2-WORD FORMAL OR ADDR TEMP & APPROPRIATE TO LOAD. * LDO09 LDB T2LDO THEN LOAD IT. JSB LD.F LDA F.RES SET UP T2LDO, STA T2LDO JMP LDO03 SO CAN USE NORMAL REG DATA CODE. * T1LDO NOP OFFSET. T2LDO NOP F.A OR REG # OF ITEM. T3LDO NOP RESULT TYPE. T4LDO NOP STACK ADDR IF REG. T5LDO NOP SAVED EMA (E) REGISTER STATUS. B601 OCT 601 MASK F.IU,F.NT & F.IU=ARR,F.NT=1. DUM OCT 5000 F.AT=DUM LDAII OCT 162000 OPCODE FOR LDA ,I SKP * ****************** * * GENERATE STORE * * ****************** SPC 1 ST.F NOP ASSUME F.IM OF SOURE, DEST SAME. CPA B STORE INTO SELF ? JMP ST.F,I YES. IGNORE. * STA T0ST SAVE A.T. PTR TO DESTINATION. STB F.A MAP IN THE SOURCE, IF NEED BE. JSB EA?.F CAREFUL! DON'T CALL MAP.F IF NOT RSS IN EMA: IT MAY HAVE CALLED US. JSB MAP.F (RESULT IN A,B BOTH) STB T1ST SAVE A.T. PTR TO SOURCE. LDB T0ST JSB FT.F GET F.IM OF DESTINATION. * CPA INT IF INTEGER, RSS CPA LOG OR LOGICAL, JMP ST01 USE STA/STB. * CPA DBI IF DOUBLE INTEGER, RSS CPA REA REAL, RSS CPA LO4 OR DOUBLE LOGICAL, JMP ST03 USE DST. * LDA ST.F ELSE DBL/RE8/CPX/ZPX. SAVE ENTRY PT, STA T2ST AS WE MAY BE CALLED RECURSIVELY. LDA T1ST STACK UP THE F.A'S, FOR TWO REASONS: JSB PU1.F TO SURVIVE A RECURSIVE CALL, LDA T0ST AND TO BE UPDATED IF THEY ARE JSB PU1.F REGISTERS, SINCE: JSB SBR.F WE MUST STORE BEFORE DFER/CFER. JSB PO1.F RESTORE RESULT F.A, STA T0ST LDB A AND RE-FETCH TYPE. JSB FT.F LDB .CFER IF RE8 OR CPX, USE .CFER CPA DBL IF DBL, LDB .DFER USE .DFER CPA ZPX IF ZPX, LDB .ZFER USE .ZFER JSB ODF.F GENERATE JSB .ROUTINE LDB T0ST NOW SEND DEF'S TO F.A'S. JSB DEF.F RESULT ADDR, JSB PO1.F LDB A JSB DEF.F SOURCE ADDR. LDA T0ST (A) = F.A OF DEST. JMP T2ST,I DONE. * * USE 'DST' FOR REAL & DOUBLE INTEGER. * ST03 LDA .DST GENERATE 'DST' JSB OAI.F LDB T0ST GENERATE DEF DESTINATION. JSB DEF.F JMP ST02 SKP * USE STA/STB FOR INTEGER, LOGICAL & DOUBLE LOGICAL. * ST01 LDA T1ST SET UP STA / STB ALF,ALF ALF,RAR ADA STAI LDB T0ST (B)=F.A OF DEST. SZB IF DEST IS REGISTER, CPB K1 IOR B100K THEN SET INDIRECT BIT: MUST BE ADDR. JSB SOA.F OUTPUT 'STA' OR 'STB' * * IF REGISTER STORED, FREE IT UP. * IF ADDRESS IN REGISTER USED, FREE IT UP TOO. * ST02 JSB GRD.F GET REG DATA. (IF NOT REG, B=-1) DEF T1ST FOR SOURCE. LDA T0ST IF ON STACK, REPLACE BY DEST F.A SSB,RSS (IF NOT IN USE, NO STORE) STA B,I (IF NOT ON STACK, B=0, NOP) JSB CRD.F NOTE THAT REG IS EMPTY NOW. DEF T1ST (IF NOT REG, NOP) JSB CRD.F NOW THE DESTINATION, WHICH IS A REGISTER DEF T0ST ONLY IF THE DESTINATION ADDR WAS IN IT. LDA T0ST RETURN (A)=F.A OF DEST. JMP ST.F,I EXIT. SPC 2 .DST OCT 104400 'DLD' .CFER ABS 75 .DFER ABS 74 .ZFER ABS 316 STAI OCT 72000 T0ST NOP DESTINATION F.A T1ST NOP SOURCE F.A T2ST NOP ENTRY POINT SAVED OVER RECURSIVE CALL. T1GST NOP T2GST NOP INT OCT 010000 REA OCT 020000 LOG OCT 030000 CPX OCT 050000 ZPX OCT 140000 DBL OCT 060000 B100K OCT 100000 DBI EQU B100K LO4 OCT 110000 RE8 OCT 120000 SKP * ************************** * * GENERATE STORE IN TEMP * * ************************** SPC 1 * ENTRY: (B) = F.A OR REGISTER NUMBER. * GST.F NOP FOR STORING A AND A-B INTO TEMPS STB T1GST SAVE F.A JSB GRD.F GET REG DATA. (O.K. IF NOT REG) DEF T1GST STB T2GST SAVE PLACE TO PUT NEW STACK ITEM. SOS ADDR ? JMP GST05 NO. * LDB T1GST YES. STORE IN ADDR TEMP. JSB GSA.F LDA F.A (A) = F.A OF TEMP. JMP GST04 GO FINISH UP. * GST05 JSB ATC.F DATA. ALLOCATE TEMP CELL LDB T1GST IN CASE OF DBL/CPX/ZPX FROM EMA JSB ST.F STORE INT, LOG OR REAL GST04 STA T2GST,I SET NEW A.T. POINTER IN STACK JSB CRD.F NOTE THAT REG IS EMPTY NOW. DEF T1GST JMP GST.F,I RETURN SPC 2 * ***************************** * * STORE MAPPED DATA IN TEMP * * ***************************** SPC 1 SMT.F NOP LDB F.ACM ANYTHING IN MAPS ? SZB,RSS JMP SMT.F,I NO. * STB T2SMT YES. SAVE THE STACK ADDR. LDB B,I (B) = ITS F.A JSB FT.F GET ITS TYPE, JSB ATC.F ALLOCATE TEMP FOR IT, STA T1SMT SAVE TEMP'S F.A LDA F.IM IS IT LOADABLE ? JSB MIM.F LDA B (THE ANSWER IS IN (A)) LDB F.ACM,I IN CASE NOT, STB F.RES SET UP F.RES HERE. SSA,RSS WELL ? JSB LD.F LOADABLE. LOAD IT. LDB F.RES STORE SOURCE. LDA T1SMT F.A OF TEMP = STORE DEST. STA T2SMT,I REPLACE STACK FRAME. JSB ST.F STORE THE ITEM IN THE TEMP. CLA CLEAR OUT THE MAP POINTER. STA F.ACM JMP SMT.F,I DONE. * T1SMT NOP F.A OF TEMP. T2SMT NOP STACK ADDR OF MAPPED DATA. SKP * ******************************************* * * ALLOCATE ADDRESS TEMP AND STORE INTO IT * * ******************************************* SPC 1 * ENTRY: (B) = REG #. * GSA.F NOP ROUTINE TO ALLOCATE AN ADDRESS TEMP AND STB T1GSA STORE INTO IT. (SAVE REG #) JSB GRD.F GET TYPE OF DATA. DEF T1GSA STA T2GSA T2GSA = F.IM DATA. LDA ADDR ALLOCATE TEMP. JSB ATC.F LDA INT TEMPORARILY MAKE F.IM OF TEMP. INT JSB DIM.F LDA F.A STORE REGISTER CONTAINING LDB T1GSA ADDRESS IN TEMP CELL. JSB ST.F (ST.F USES DESTINATION TYPE) LDA ADDR JSB DIM.F CHANGE ITS F.IM BACK TO ADDRESS. LDA T2GSA INSERT F.IM OF ITEM BEING ADDRESSED JSB DAF.F INTO AF OF TEMP CELL A.T. ENTRY. JMP GSA.F,I RETURN F.IM OF DATA IN (A). * T1GSA NOP T2GSA NOP T1SER NOP ADDR OCT 070000 SKP * ************************ * * REGISTER INFORMATION * * ************************ SPC 1 * THE A & B REGISTER INFORMATION IS ACCESSED BY THE FOLLOWING * ROUTINES, WHICH USE THE FOLLOWING CONVENTIONS: * * (A) = F.IM OF DATA. * (B) = -1 IF REGISTER FREE. * 0 IF IN USE BUT NOT ON STACK. * +1 IF 2ND WORD OF 2-WORD DATUM (B ONLY) * +2 IF 1ST WORD OF REVERSED DBL INT (B ONLY) * >2 IF ADDR OF ITEM ON STACK. * (O) = ADDRESS FLAG. REGISTER CONTAINS ADDRESS OF DATA. * (E) = EMA ADDRESS FLAG. DATA MUST BE COPIED BEFORE ANY * MAP CHANGES. IF E=1, MUST HAVE O=1. SPC 1 DFAF DEF F.AFA * KEEP THE FOLLOWING IN ORDER * * * F.AFA NOP (A) ADDRESS FLAG. * F.EFA NOP EMA FLAG. * F.IMA NOP ITEM MODE. * F.ACA NOP STACK ADDR. * F.AFB NOP (B) ADDRESS FLAG. * F.EFB NOP EMA FLAG. * F.IMB NOP ITEM MODE. * F.ACB NOP STACK ADDR. * * F.ACM NOP STACK ADDRESS OF MAPPED EMA ITEM. SPC 1 * ********************* * * GET REGISTER DATA * * ********************* SPC 1 GRD.F NOP LDA GRD.F,I GET REG #. ISZ GRD.F LDA0I LDA A,I CCB (B=-1) SZA REGISTER ? CPA K1 ALS,SLA,ALS YES. GET DATA. (A*4 & SKIP) JMP GRD.F,I NO. RETURN STATUS: FREE. * ADA DFAF FORM ADDR DATA. LDB0I LDB A,I SET (O) CLO ADB BMAX (OVERFLOWS IF B=1) INA SET (E) LDB A,I ERB INA SET (A) & (B) DLD A,I JMP GRD.F,I EXIT. * BMAX OCT 77777 SKP * *********************** * * STORE REGISTER DATA * * *********************** SPC 1 SRD.F NOP STA T1SRD+2 SET UP 4-WORD BLOCK. STB T1SRD+3 CLA ELA STA T1SRD+1 ERA A=0, E RESTORED. SOC INA STA T1SRD SEZ,SZA IF E=O=1, EMA ADDRESS, SSB AND REGISTER IS BEING SET IN-USE, RSS (NO) STB F.ACM THEN SET UP EMA STACK POINTER. LDB SRD.F,I GET REG #. ISZ SRD.F LDB1I LDB B,I SZB REGISTER ? CPB K1 RSS JMP SRD.F,I NO. DONE. * BLS,BLS FORM ADDR OF REG DATA. ADB DFAF LDA DT1SR SOURCE FOR COPY. JSB .MVW COPY DATA. DEF K4 NOP SKP * RESET STATUS OF B-REGISTER. (AS PART OF A-REG) * LDA F.ACB WAS B-REG ASSOCIATED WITH (A) ? CCB CPA K1 AS PART OF TWO-WORD NUMBER ? STB F.ACB YES. CPA K2 AS PART OF REVERSED DOUBLE INTEGER ? STB F.ACB YES. LDA F.ACA IS A-REG IN USE NOW ? LDB F.AFA AND DATA, NOT ADDR ? SSA,RSS (SKIP IF NOT IN USE) SZB (IN USE. SKIP IF DATA) JMP SRD.F,I NO. LEAVE (B) ALONE. * LDA F.IMA YES. 2-WORD VALUE ? CLB,INB CPA DBI DOUBLE INTEGER, STB F.ACB CPA REA REAL, STB F.ACB CPA LO4 DOUBLE LOGICAL. STB F.ACB IF ANY, SET NEW (B) STATUS. JMP SRD.F,I EXIT. * T1SRD BSS 4 DT1SR DEF T1SRD K2 DEC 2 K4 DEC 4 SPC 2 * ***************************** * * CLEAR ALL REGIGISTER DATA * * ***************************** SPC 1 CAR.F NOP JSB CBR.F FIRST, A & B REGISTERS. CLA THEN ANY EMA INFO. STA F.ACM JMP CAR.F,I THAT'S IT. SKP * *********************** * * CLEAR REGISTER DATA * * *********************** SPC 1 CRD.F NOP LDA CRD.F CONVERT TO SRD.F CALL. STA SRD.F CCB WITH B=-1, NOT IN USE. JMP SRD.F+1 SPC 2 * ************************ * * CLEAR BOTH REGISTERS * * ************************ SPC 1 CBR.F NOP JSB CRD.F JUST ONE AT A TIME. DEF K0 JSB CRD.F DEF K1 JMP CBR.F,I SPC 2 * **************************** * * STORE REGISTER INTO TEMP * * **************************** SPC 1 SRT.F NOP LDA SRT.F,I GET REG #. ISZ SRT.F STA T1SRT T1SRT = ADDR OF REG #. JSB GRD.F GET DESCRIPTION. DEF T1SRT,I SSB ANYTHING THERE ? JMP SRT.F,I NO. (OR NOT REG.) * CPB K2 IS IT (B) & MPY EXTENSION ? JMP SRT.F,I YES, DON'T SAVE IT. * CPB K1 IS IT LOWER PART OF (A,B) ITEM ? CLB,RSS YES, SAVE BOTH OF THEM. LDB T1SRT,I NO, SAVE WHATEVER CALLER SAID. JSB GST.F JMP SRT.F,I EXIT. * T1SRT NOP SKP * ********************************* * * STORE BOTH REGISTERS IN TEMPS * * ********************************* SPC 1 SBR.F NOP JSB SRT.F DEF K0 JSB SRT.F DEF K1 JMP SBR.F,I SPC 2 * *********************************** * * STORE REGISTER DATA, SHORT FORM * * *********************************** SPC 1 * SAME AS SRD.F, EXCEPT SETS B,E,O TO ZERO. * SRS.F NOP LDB SRS.F COPY OUR ENTRY. STB SRD.F CLB,CLE B=0, E=0. CLO O=0. JMP SRD.F+1 NOW FAKE THE SRD.F CALL. SPC 2 * ************************* * * ALLOCATE ONE REGISTER * * ************************* SPC 1 * EXIT: (A)=(F.RES)=REG#, * AOR.F NOP LDA F.ACA CHECK REG USAGE. LDB F.ACB B-REG IS FREE IF SZB F.ACB # 0 ADB KM8 AND F.ACB < 8 SSB WELL ? (SKIP IF (B) IN USE) SSA A-REG FREE ? CLA,RSS (A) FREE OR (B) IN USE, USE (A). CLAII CLA,INA OTHERWISE, USE (B). STA F.RES F.RES = REGISTER #. JMP AOR.F,I EXIT. SKP * *************** * * POP STACK 1 * * *************** SPC 1 PO1.F NOP TO UNSTACK AND DISCARD OPERANDS. LDA F.S1T IF REGISTER POPPED, CLB CLEAR ITS STACK POINTER(S). CPA F.ACA STB F.ACA CPA F.ACB STB F.ACB CPA F.ACM STB F.ACM LDA F.S1T,I (A) = OLD TOS. LDB F.T INB JUST ONE. STB F.T FROM STACK TO T. ADB F.S1B STB F.S1T NEW PTR TO TOP OPERAND ON STK1. INB STB F.S1N NEW PTR TO NEXT-TO-TOP OPERAND. JMP PO1.F,I SPC 2 * **************************************** * * POP ONE OR TWO OPERANDS, PUSH RESULT * * **************************************** SPC 1 P1P.F NOP POP 1. JSB PO1.F POP IT. LDA F.RES PUSH RESULT. JSB PU1.F JMP P1P.F,I SPC 1 P2P.F NOP POP 2. JSB PO1.F POP ONE AND JSB P1P.F LET P1P DO THE OTHERS. JMP P2P.F,I SKP * **************** * * PUSH STACK 1 * * **************** SPC 1 * STACK 1 IS THE OPERAND STACK. IT IS IN HIGH CORE, JUST BELOW THE * DO TABLE, AND GROWS TOWARD LOW CORE. THIS ROUTINE IS ENTERED WITH * (A) = WORD TO BE STACKED, GENERALLY AN (F.A) BUT (F.A,I) FOR AN * ARRAY OR SUBROUTINE WITH LIST FOLLOWING. 0/1 MEANS A/B REGISTERS. SPC 1 * (B) IS NOT DESTROYED BY THIS SUBROUTINE SPC 1 PU1.F NOP PUSH STACK 1 TO STACK OPERANDS. STB T0PU1 SAVE B REGISTER. CCB ADB F.T STB F.T T=T-1 ADB F.S1B STB F.S1T NEW PTR TO TOP OPERAND ON STK1. CPB F.S2T IF 2 TOP POINTERS THE SAME, JMP F.OFE DATA POOL OVERFLOW * INB SET NEXT-TO-TOP. STB F.S1N STA F.S1T,I STORE DATA. ARS REGISTER ? SZA JMP PU101 NO. * JSB GRD.F YES. SAVE STACK ADDR. DEF F.S1T,I LDB F.S1T CHANGE STACK POINTER. SEZ IF ADDRESS IN EMA, STB F.ACM SET UP MAPPED DATA STACK ADDR. JSB SRD.F DEF F.S1T,I PU101 LDB T0PU1 RESTORE (B), EXIT. JMP PU1.F,I SPC 1 T0PU1 NOP SPC 2 * **************** * * VOID STACK 1 * * **************** SPC 1 VS1.F NOP LDA F.S1T SET F.S1T = F.S1B, STA F.S1B CLA AND F.T = 0. STA F.T JMP VS1.F,I DONE. SKP * *************************** * * MAP & ANALYZE ITEM MODE * * *************************** SPC 1 * ENTRY: (A) = F.IM TO BE ANALYZED. * EXIT: (A) = MAPPED ITEM MODE: * 0=INT 1=DBI 2=REA 3=DBL 4=RE8 * 5=CPX 6=ZPX -1=OTHER * (B) = LENGTH INFO: * 0: 1 WORD 1: 2 WORDS -1: LONGER * (E) = NUMERIC DATA FLAG * 0: NUMERIC 1: LOGICAL, CHARACTER OR MISC. SPC 1 MIM.F NOP ALF PUT BITS IN LOW PART OF WORD. ADA DMIMT INDEX INTO TABLE. LDB A,I PICK APART TABLE ENTRY: CLA,CLE <15:8> => B (SIGN EXTENDED) ASR 8 <7> => E ELA,ARS <6:0> => A (SIGN EXTENDED) ARS,ARS ARS,ARS ARS,ARS ARS,ARS JMP MIM.F,I DONE ! * DMIMT DEF *+1 MIM TABLE: SEE ABOVE FOR DESCRIPTION. BYT -1,-1 UNDEF OR STMT # BYT 0,0 INTEGER*2 BYT 1,2 REAL*4 BYT 0,-1 LOGICAL*2 BYT -1,-1 TWPE BYT -1,5 COMPLEX*8 BYT -1,3 DOUBLE PRECISION*6 BYT -1,-1 ADDRESS BYT 1,1 INTEGER*4 BYT 1,-1 LOGICAL*4 BYT -1,4 DOUBLE PRECISION*8 BYT -1,-1 CHARACTER BYT -1,6 COMPLEX*16 SKP * ********************************* * * GET TYPES OF TOP TWO OPERANDS * * ********************************* SPC 1 GT2.F NOP GET F.IM OF TWO TOP OPERANDS LDB F.S1N,I JSB FT.F GET F.IM OF NEXT TO TOP OPERAND STA T1GT2 SAVE IT. JSB GT1.F GET F.IM OF TOP OPERAND. LDB T1GT2 (B)=TYPE(F.S1N), (A)=TYPE(F.S1T). JMP GT2.F,I * T1GT2 NOP SPC 2 * *************************** * * GET TYPE OF TOP OPERAND * * *************************** SPC 1 GT1.F NOP LDB F.S1T,I JSB FT.F GET F.IM OF TOP OPERAND STA F.RTP AND SAVE IT IN F.RTP JMP GT1.F,I SPC 2 * ************* * * FIND TYPE * * ************* SPC 1 FT.F NOP ENTERED WITH (B) = A.T. PTR. STB F.A JSB GRD.F IF IN REG, GET TYPE. DEF F.A STA F.IM (IN CASE YES.) SSB IF WASN'T REGISTER, JSB GIM.F GET FROM A.T. JMP FT.F,I EXIT. SPC 2 * ***************** * * GET ITEM MODE * * ***************** SPC 1 GIM.F NOP IF F.IM=ADDR FOR F.A, CHANGE IT. JSB FA.F FETCH ASSIGNS LDB F.IM (B) _ F.IM OF F.A CPB ADDR IF F.IM=ADDRESS, STA F.IM SET F.IM=AF F.A LDA F.IM MAKE SURE UPDATED F.IM IS IN (A) JMP GIM.F,I * END ASMB,Q,C HED ARITHMETIC & LOGICAL OPERATIONS CODE GENERATOR. NAM AOP.F,8 92834-16003 REV.2030 800818 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * 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) * 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.IDI INPUT ARRAY. EXT F.S1T TOP OF STACK 1 * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CF1.F CHECK FOLDING ON UNARY OPERATIONS. EXT CF2.F CHECK FOLDING ON BINARY OPERATIONS. EXT CFC.F CHECK FOR CONSTANT. EXT CDI.F CLEAR IDI ROUTINE EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT OZ.F OUTPUT MEM REF TO *+N. EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * EXT F.ACB STACK ADDRESS FOR B-REG. EXT F.ACA STACK ADDRESS FOR A-REG. EXT F.COP CURRENT OPCODE. EXT F.LA1 1ST LOOK-AHEAD, 1ST PASS FILE. EXT F.LA2 2ND LOOK-AHEAD, 1ST PASS FILE. EXT F.RES RESULT F.A EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT ATC.F ALLOCATE TEMP CELL. EXT ATM.F CONDITIONALLY ALLOCATE TEMP (TWO OPNDS). EXT DEF.F PRODUCE A DEF TO (B). EXT F1T.F FREE TEMP IF TOS. EXT F2T.F FREE TEMP IF TOS OR NEXT-TO-TOP. EXT GDF.F GENERATE DOT FUNCTION CALL. EXT RD.F PASS FILE READ WITH LOOK-AHEAD. EXT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITHMETIC AND LOGICAL OPERATORS.) * ENT ADD.F ADD. ENT AND.F AND. ENT CON.F CONVERSION. ENT CO.F COMMUTE TOP TWO OPERANDS. ENT CTS.F CONVERT TOP OF STACK. ENT DIV.F DIVIDE. ENT EQV.F .EQV. ENT .EQ.F .EQ. ENT EXP.F EXPONENTIATION. ENT .GE.F .GE. ENT .GT.F .GT. ENT .LE.F .LE. ENT .LT.F .LT. ENT MP1.F MAP TOS IF EMA. ENT MP2.F MAP TOP TWO STACK ITEMS IF EMA. ENT MPY.F MULTIPLICATION. ENT .NE.F .NE. ENT NEG.F UNARY MINUS. ENT NOT.F .NOT. ENT .OR.F .OR. ENT SUB.F SUBTRACTION. ENT XOR.F .XOR. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT F.ACM STACK ADDR OF CURRENTLY MAPPED ITEM. * EXT ABB.F SET UP A/B BIT. EXT CAR.F CLEAR REGISTER DATA, INCLUDING MAPS. EXT CBR.F CLEAR REGISTER DATA FOR BOTH REGISTERS. EXT CRD.F CLEAR REGISTER DATA (ONE REGISTER). EXT FT.F FIND TYPE. EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT GT2.F GET TYPE OF TWO TOP OPERANDS. EXT LD.F LOAD. EXT LDA.F LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT LDF.F LOAD FIRST WORD. (EITHER REGISTER). EXT LDO.F LOAD WITH OFFSET. EXT MIM.F MAP ITEM MODE. EXT P1P.F POP ONE STACK ITEM, PUSH RESULT. EXT P2P.F POP TWO STACK ITEMS, PUSH RESULT. EXT PO1.F POP ONE STACK ITEM. EXT PU1.F PUSH ONE STACK ITEM. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SRD.F STORE REGISTER DATA. EXT SRS.F STORE REGISTER DATA, SHORT FORM. EXT SRT.F STORE REGISTER INTO TEMP. * * ENTRY POINTS IN SAM.F * EXT MAP.F MAP IN EMA ITEM. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * ********************************************* * * COMMUTE TO PUT REGISTER OR CONSTANT FIRST * * ********************************************* SPC 1 * * ENTRY: (F.S1N,I) = 1ST OPND, (F.S1T,I) = 2ND OPND. * (A) # 0: 1ST OPND WILL BE LOADED TO (A). * = 0: DON'T CARE. * (E) = 0: IF CONSTANT & MEM, CONSTANT FIRST. * = 1: DON'T COMMUTE JUST FOR CONSTANT. * EXIT: E=0 IF NO COMMUTE DONE, 1 IF COMMUTED. * CCO.F NOP LDB F.S1N,I IF OPND1 ADDR/DATA IN (A), SZB,RSS SZA,RSS AND WE WILL LOAD INTO (A), ALS,SLA,ERA (NO. SKIP & COPY (E) TO SIGN OF (A).) JMP CCO02 THEN LEAVE AS IS. (IN CASE ADDR). * STA T1CCO NO. SAVE (E). JSB GRD.F GET INFO ON 1ST OPND. DEF F.S1N,I SSB,RSS IS IT REGISTER ? (B>=0) JMP CCO00 YES. GO SEE IF DATA/ADDR. * LDB F.S1T,I NO. IS 2ND CONSTANT ? LDA T1CCO ALSO, DOES IT MATTER ? SSA,RSS SKIP IF IGNORING CONSTANTS. JSB CFC.F SKIP IF CONSTANT. CCB,RSS NO. GO SEE IF 2ND IS REG. (B=-1) JMP CCO01 YES. COMMUTE. JMP CCO03 NO. * CCO00 SOS DATA (O=0) ? JMP CCO02 YES. DON'T COMMUTE. * CCO03 STB T1CCO NOW B>=0 IFF 1ST OPND IS ADDR. JSB GRD.F GET INFO ON 2ND OPND. DEF F.S1T,I SSB REGISTER ? JMP CCO02 NO. DON'T COMMUTE. * SOS DATA ? JMP CCO01 YES. COMMUTE. * LDA T1CCO ADDR. IS OPND1 ADDR TOO ? SSA,RSS JMP CCO02 YES. BOTH ARE, DON'T COMMUTE. * CCO01 JSB CO.F THEN COMMUTE. CCE,RSS AND SET E=1 TO SAY WE DID IT. CCO02 CLE E=0 SAYS WE DIDN'T. JMP CCO.F,I EXIT. * T1CCO NOP SKP * ******************** * * COMMUTE OPERANDS * * ******************** SPC 1 CO.F NOP CALLED WHEN COMM. IS REQUIRED. LDA F.S1T,I (A)_TOP OPERAND ON STACK 1. LDB F.S1N,I (B)_ NEXT-TO-TOP OPERAND ON STACK STB F.S1T,I TOP OPERAND _ (B) STA F.S1N,I NEXT-TO-TOP OPERAND _ (A) * LDA F.S1T UPDATE REGISTER INFO ON STACK: SZB,RSS STA F.ACA F.S1T=A CPB K1 STA F.ACB F.S1T=B LDA F.S1N LDB A,I SZB,RSS STA F.ACA F.S1N=A CPB K1 STA F.ACB F.S1N=B * LDB F.S1T (B)=F.S1T, (A)=F.S1N CPB F.ACM F.ACM = F.S1T ? JMP CO01 YES. (CAN'T DO BOTH) * CPA F.ACM NO. F.ACM = F.S1N ? STB F.ACM YES. CHANGE TO F.S1T JMP CO.F,I DONE. * CO01 STA F.ACM F.ACM=F.S1T, CHANGE TO F.S1N JMP CO.F,I DONE. SKP * ******* * * ADD * * ******* SPC 1 ADD.F NOP ADD TWO TOP OPERANDS. JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. JSB F2T.F FREE TEMPS. CLA TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP ADD.F,I FOLDED. ALL DONE HERE. JMP ADD02 2ND CONST ONLY. JMP ADD01 1ST CONST ONLY. (COMMUTE.) * ADD00 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. CLA,CLE PUT REGISTER FIRST, OR CONSTANT. JSB CCO.F (A=0, USES EITHER REGISTER.) LDA F.RTP MAP TYPE. JSB MIM.F ADA DADDT GET DOT FUNCTION INFO. LDA A,I LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP ADD.F,I * ADD01 STA T1ADD 1ST CONST: SAVE CONST DESCRIPTION. JSB CO.F & COMMUTE. LDB T1ADD (B)=CONST DESCR. ADD02 SZB CONST=0 ? JMP ADD03 NO. * JSB PO1.F YES. JUST THROW IT AWAY. LDA F.S1T,I AND SET F.RES RIGHT. STA F.RES JMP ADD.F,I ALL DONE. * ADD03 LDA F.RTP OTHERWISE CAN ONLY HELP: CPA INT INTEGER JMP ADD04 * CPA DBI AND DOUBLE INTEGER. RSS JMP ADD00 REA/DBL/RE8/CPX, NOTHING SPECIAL. * CLA DOUBLE INTEGER: CPB K2 FOR X+1, LDA .DIN USE .DIN CPB KM2 FOR X+(-1), LDA .DDE USE .DDE SZA,RSS ONE OF ABOVE ? JMP ADD00 NO. ORDINARY. * STA T1ADD YES. SAVE INC/DEC. JSB PO1.F POP THE CONSTANT. LDB F.S1T,I LOAD THE ITEM. JSB LD.F LDB T1ADD DO THE INC/DEC. JSB ODF.F JMP ADD4A GO REPLACE TOS & EXIT. * ADD04 CPB K2 INTEGER, ONLY HELP IS X+1 RSS JMP ADD00 NO. ORDINARY. * JSB PO1.F YES. POP THE CONSTANT. LDB F.S1T,I LOAD THE ITEM. JSB LD.F LDA INAI 'INA' JSB ORI.F OUTPUT INA/INB. ADD4A JSB P1P.F REPLACE TOS WITH REGISTER. JMP ADD.F,I ALL DONE. * * INTEGER ADD. * ADD05 LDB F.S1N,I LOAD 1ST OP JSB LD.F LDB F.S1T,I ADD SECOND. JSB ABB.F SET UP ADA/ADB ADA ADAI JSB SOA.F OUTPUT ADA/ADB LDA F.S1T,I IF ADD TO ITSELF, CPA F.S1N,I JMP ADD06 DON'T FREE RESULT REGISTER ! * JSB CRD.F IF 2ND OPND IS IN REG, DEF F.S1T,I THEN FREE IT. ADD06 JSB P2P.F SET STACK RIGHT. JMP ADD.F,I * .DIN ABS 005 OFFSET FOR .DIN .DDE ABS 017 OFFSET FOR .DDE INAI INA ADAI OCT 42000 T1ADD NOP D.REG EQU 040000B BIT 14: REGISTERS PRESERVED. D.OPM EQU 020000B BIT 13: 1ST OPERAND IN MEMORY. D.RTN EQU 010000B BIT 12: USE RETURN ADDRESS. D.ER0 EQU 004000B BIT 11: ADD 'JSB ERR0' AFTER. * DADDT DEF *+1 ADD DOT FUNCTION TABLE. DEF ADD05,I INT, SPECIAL CASE. ABS 000+D.REG DBI, .DAD ABS 001+D.REG REA, .FAD ABS 002+D.OPM DBL, .XADD ABS 003+D.REG+D.OPM RE8, .TADD ABS 004+D.OPM CPX, .CADD ABS 300+D.REG+D.OPM ZPX, .ZADD SKP * ************ * * SUBTRACT * * ************ SPC 1 SUB.F NOP JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. JSB F2T.F FREE TEMPS. CLA,INA TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP SUB.F,I FOLDED. ALL DONE HERE. JMP SUB06 2ND CONSTANT ONLY. JMP SUB03 1ST CONSTANT ONLY. * SUB01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. LDA F.RTP MAP TYPE. JSB MIM.F ADA DSUBT GET DOT FUNCTION INFO. LDA A,I LDB F.S1T,I IF DOUBLE INTEGER AND 2ND OPND CPA .DSB IS IN (A,B), SZB JMP SUB02 (NO) * JSB CO.F THEN COMMUTE & USE REVERSE SUBTRACT. LDA .DSBR JMP SUB10 GO GENERATE CODE. * SUB02 CPA .FSB FLOATING, SZB AND IN (A,B) ? JMP SUB10 NO. * JSB GRD.F YES. ADDR OR DATA ? DEF K0 LDA .FSB (RESTORE DOT FUNCTION) SOC WELL ? JMP SUB10 ADDR. CAN STORE THAT. * JSB NEG.F DATA. BETTER TO NEGATE & ADD. JSB ADD.F JMP SUB.F,I DONE. * SUB10 LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP SUB.F,I EXIT. SKP * 1ST OPND CONSTANT. * SUB03 CPA KM2 (-1) - X ? JMP SUB04 YES. * SZA 0-X ? JMP SUB01 NO. * JSB CO.F YES. DELETE ZERO: SWAP, JSB PO1.F POP IT. JSB NEG.F NEGATE X. JMP SUB.F,I DONE. * SUB04 LDA F.RTP (-1) - X CPA INT CAN HELP INTEGER JMP SUB05 * CPA DBI AND DOUBLE INTEGER. RSS JMP SUB01 BUT NOTHING ELSE. * SUB05 JSB CO.F FOR INT/DBI, JUST 1'S COMPLEMENT. JSB PO1.F REMOVE (-1). JSB SCG.F LOAD X. LDA CMAI DO 'CMA' OR 'CMB'. JSB ORI.F LDA CMBI DO 'CMB' LDB F.RTP ONLY IF DBL INT. CPB DBI JSB OAI.F JSB P1P.F REPLACE X WITH (A) OR (A,B). JMP SUB.F,I DONE. * * SECOND OPERAND CONSTANT. * SUB06 SZB X-0 ? JMP SUB07 NO. * JSB PO1.F YES. JUST REMOVE IT. LDA F.S1T,I AND SET F.RES RIGHT. STA F.RES JMP SUB.F,I DONE. * SUB07 LDA F.RTP INTEGER OR DOUBLE INT ? CPA INT JMP SUB08 * CPA DBI RSS JMP SUB01 NO, NO HELP. * SUB08 JSB NEG.F YES. NEGATE 2ND OPND. JSB ADD.F & ADD. JMP SUB.F,I DONE. SKP * INTEGER SUBTRACT. * SUB09 JSB GRD.F IS 2ND OPND IN REGISTER ? DEF F.S1T,I SSB,RSS SOC (AND DATA, NOT ADDR) RSS NO. JMP SUB08 YES. GO DO 'CM*,IN*' & 'AD*'. * JSB GRD.F IS 1ST OPND IN REGISTER ? DEF F.S1N,I SSB,RSS SOC (AND DATA, NOT ADDR) JMP SUB08 NO. DITTO. * LDA CMAI YES. DO 'CM*', LDB F.S1N,I (FOR ORI.F, SET UP F.RES NOW) STB F.RES JSB ORI.F JSB ADD.F 'AD* X', LDA CMAI JSB ORI.F AND 'CM*' JMP SUB.F,I DONE. * DSUBT DEF *+1 SUBTRACT DOT-FUNCTION TABLE. DEF SUB09,I INT, SPECIAL CASE. .DSB ABS 006+D.REG DBI, .DSB .FSB ABS 007+D.REG REA, .FSB ABS 008+D.OPM DBL, .XSUB ABS 009+D.REG+D.OPM RE8, .TSUB ABS 010+D.OPM CPX, .CSUB ABS 301+D.REG+D.OPM ZPX, .ZSUB * .DSBR ABS 011+D.REG DOUBLE INTEGER REVERSED SUB * DBI OCT 100000 KM2 DEC -2 SKP * ********** * * NEGATE * * ********** SPC 1 NEG.F NOP GEN. CODE FOR UNARY MINUS. JSB MP1.F MAP IT IN IF IN EMA. JSB GT1.F GET ITEM TYPE. JSB MIM.F ANALYZE TYPE. SEZ,CCE NUMERIC DATA ? (E=1) JMP CON09 NO. ERROR. * LDB F.S1T STACK ADDR. JSB CF1.F IF CONSTANT, FOLD. JMP NEG.F,I YES. ALL DONE! * * IF DBL/RE8/CPX AND NOT IN-PLACE, SUBTRACT FROM ZERO. * LDA F.RTP NOT CONST. REGISTER OPERATION ? JSB MIM.F SSB,RSS JMP NEG02 YES. LET GDF.F SORT IT OUT. * LDA F.A IF NOT, SEE IF IT IS A TEMP CELL SZA (DON'T TEST REGISTERS) CPA K1 JMP NEG03 (REGISTER - USE SUBTRACT) * ADA K2 IS IT A TEMP ? LDA A,I SSAI SSA IF TEMP CELL, JMP NEG04 GENERATE JSB TO ..DCM/..TCM/..CCM/..ZCM * NEG03 LDB F.S1N GET POINTER TO NEXT OPERAND JSB TAS.F ALLOCATE DBL OR CPX TEMP CELL.IF NEEDED LDA F.RES IS IT JUST A NEGATE IN PLACE ? CPA F.S1T,I JMP NEG04 YES, DO THAT. * JSB CDI.F NO. IT'S FASTER & SMALLER TO DO A SUBTRACT LDA F.RTP FROM ZERO THAN TO COPY & NEGATE. JSB ESC.F JSB AI.F ENTER THE CONSTANT. LDA F.A PUSH ONTO STACK JSB PU1.F JSB CO.F & MAKE IT THE FIRST OPERAND. LDA F.RTP GET THE SUBTRACT INFO. JSB MIM.F ADA DSUBT FROM THE SUB.F TABLE. LDA A,I FLAGS & ORDINAL FOR PROPER CALL. LDB K2 2 OPERANDS. JSB GDF.F ISSUE SUBTRACT. JSB PU1.F PUSH RESULT ON STACK. JMP NEG.F,I DONE ! SKP * IN-PLACE OR IN REGISTERS. USE GDF.F . * NEG02 JSB F1T.F REGISTERS. FREE TEMP. NEG04 LDA F.S1T,I SET (F.RES) = (TOS) IN CASE IN-PLACE. STA F.RES LDA F.RTP GET THE FLAG ORDINAL WORD. JSB MIM.F ADA DNEGT FROM THE TABLE. LDA A,I INB,SZB DBL,RE8,CPX LOOK LIKE ZERO-OPERAND. CLB,INB DBI,REA LOOK LIKE ONE-OPERAND. JSB GDF.F (INT IS SPECIAL CASE.) LDA F.RTP HERE WE HAVE A PROBLEM BECAUSE THE JSB MIM.F ZERO-OPERAND FLAVOR OF THE GDF.F CALL SSB DIDN'T GET ITS RESULT/OPERAND POPPED, BUT NEG00 JSB PO1.F THE ONE-OPERAND ONE DID. FIX THAT HERE. LDA F.RES IN ANY EVENT, PUSH THE RESULT. JSB PU1.F JMP NEG.F,I DONE. SPC 1 DNEGT DEF *+1 NEGATION DOT-FUNCTION TABLE. DEF NEG01,I INT, SPECIAL CASE. ABS 024+D.REG DBI, .DNG ABS 025+D.REG REA, ..FCM ABS 026+D.OPM DBL, ..DCM ABS 027+D.REG+D.OPM RE8, ..TCM ABS 028+D.OPM CPX, ..CCM ABS 304+D.REG+D.OPM ZPX, ..ZCM * K1 DEC 1 K2 DEC 2 SPC 1 NEG01 JSB SCG.F LOAD INTEGER, SET RESULT = 0/1. LDA NEGI JSB ORI.F OUTPUT CM*,IN* FOR INTEGER NEG. JMP NEG00 * NEGI CMA,INA SKP * ************ * * MULTIPLY * * ************ SPC 1 MPY.F NOP JSB MAT.F MATCH TYPES. JSB MP2.F MAP IF IN EMA. JSB F2T.F FREE TEMPS. LDA K2 TRY TO FOLD: A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP MPY.F,I BOTH CONSTANTS, DONE. JMP MPY03 2ND CONSTANT. JMP MPY02 1ST CONSTANT. * MPY01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDA F.RTP MAP TYPE. JSB MIM.F ADA DMPYT GET DOT FUNCTION INFO. LDA A,I LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP MPY.F,I DONE. * * ONE OPERAND CONSTANT. SPECIAL CASES. * MPY02 STA T1MPY FIRST ONE. COMMUTE. JSB CO.F LDB T1MPY MPY03 SZB,RSS X * 0 ? JMP MPY05 CPB K2 * 1 ? JMP MPY06 CPB KM2 * (-1) ? JMP MPY07 CPB K3 * 2 ? JMP MPY08 * LDA F.RTP ONLY CASES LEFT: CPA INT INTEGER TIMES SSB POSITIVE POWER OF 2. JMP MPY01 NO. * CPB BMAX POWER OF 2 AT ALL ? JMP MPY01 NO. * STB T1MPY YES. SAVE 2+LOG2(C). JSB PO1.F REMOVE C. LDA T1MPY X * 4 ? CPA K4 JMP MPY04 YES. SKP LDB F.S1T,I NO. OTHER POWER OF 2, LOAD X INTO (A). JSB LDA.F JSB SRT.F SHIFT DESTROYS (B), SO SAVE IT. DEF K1 LDA T1MPY FORM POWER OF 2. ADA KM2 ADA LSLI FORM 'LSL K' JSB OAI.F JSB P1P.F SET STACK RIGHT. JMP MPY.F,I DONE. * MPY04 JSB SCG.F X * 4, LOAD INTO EITHER REG. LDA MPY.4 FORM '*LR,R*L' JSB ORI.F JMP MPY.F,I (OTHER REG INTACT.) * MPY05 JSB CO.F X*0. RESULT=0. JSB CRD.F IF X WAS IN A REGISTER, FREE IT. DEF F.S1T,I * MPY06 JSB PO1.F X*1. JUST DISCARD THE 1. (OR 0) LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP MPY.F,I * MPY07 JSB PO1.F X*(-1). DISCARD IT, JSB NEG.F NEGATE. JMP MPY.F,I * MPY08 JSB MY2.F COMMON WITH DIVIDE BY 0.5 . JMP MPY.F,I * MY2.F NOP JSB PO1.F X*2. CHANGE TO X+X. LDA F.S1T,I DUPLICATE X. STA F.RES SET UP (F.RES) IN CASE MEM. LDA F.RTP NO. REGISTER DATA ? JSB MIM.F SSB,RSS JSB SCG.F YES. LOAD IT NOW (SET F.RES). LDA F.RES (IF WE DON'T, DUP STCK ENTRY NOT UPDATED) JSB PU1.F PUSH DUPLICATE ENTRY ONTO STACK. JSB ADD.F & ADD. JMP MY2.F,I DONE. * INT OCT 010000 F.IM=INT BMAX OCT 77777 K3 DEC 3 K4 DEC 4 SKP * INTEGER MULTIPLY. * MPY09 LDB F.S1N,I LOAD 1ST OPND INTO (A). JSB LDA.F (MIGHT BE IN (B), SO DO FIRST) LDA F.S1T,I IS 2ND OPND IN (B) ? CPA K1 JMP MPY10 YES. LEAVE IT. * JSB SRT.F NO. SAVE (B). DEF K1 MPY10 LDA .MPY ISSUE 'MPY' JSB OAI.F LDB F.S1T,I ISSUE 'DEF 2ND OPND' JSB DEF.F CLA SET RESULT TO BE (A), STA F.RES LDA INT OF TYPE INT. (THE B-REG STUFF STA F.RTP ABOVE GARBAGED IT.) JSB P2P.F FIX UP STACK. LDA K2 SET UP (B) REG TO BE STA F.ACB EXTENSION OF (A). JMP MPY.F,I DONE. SPC 2 T1MPY NOP LSLI LSL 16 PROTOTYPE 'LSL' FOR INT MPY. MPY.4 ALR,RAL MODEL FOR INTEGER MPY BY 4. * DMPYT DEF *+1 DEF MPY09,I INT, SPECIAL CASE. ABS 012+D.REG DBI, .DMP ABS 013+D.REG REA, .FMP ABS 014+D.OPM DBL, .XMPY ABS 015+D.OPM+D.REG RE8, .TMPY ABS 016+D.OPM CPX, .CMPY ABS 302+D.REG+D.OPM ZPX, .ZMPY SKP * *********** * * DIVIDE * * *********** SPC 1 DIV.F NOP JSB MAT.F MATCH TYPES. JSB MP2.F JSB F2T.F FREE TEMPS. LDA K3 TRY TO FOLD. A=OP#, LDB F.RTP B=TYPE, JSB CF2.F TRY IT. JMP DIV.F,I TWO CONSTANTS. DONE. JMP DIV04 2ND IS CONSTANT. JMP DIV02 1ST IS CONSTANT. * DIV01 JSB ATM.F IF NON-REGISTER, DETERMINE RESULT ADDR. LDA F.RTP DETERMINE DOT FUNCTION ADDR. JSB MIM.F ADA DDIVT LDA A,I DOT FUNCTION DESCRIPTION. LDB F.S1T,I IF DOUBLE INTEGER AND 2ND OPND CPA .DDI IS IN (A,B), SZB JMP DIV1A (NO) * JSB CO.F THEN COMMUTE & USE REVERSE DIVIDE. LDA .DDIR DIV1A LDB K2 2 OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP DIV.F,I EXIT. * DIV02 SZA 0/X ? JMP DIV03 NO. * JSB CRD.F YES. IF X WAS IN A REGISTER, FREE IT. DEF F.S1T,I JSB PO1.F RESULT=0. LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP DIV.F,I * DIV03 LDA F.RTP NO. INTEGER ? CPA INT RSS JMP DIV01 NO. NO HELP. SKP * FOR (CONST)/X, CAN DO SIGN EXTENSION NOW. * JSB SBR.F YES, SAVE A & B. LDB F.S1N,I LOAD DIVIDEND INTO (A). JSB LDA.F LDA F.S1N,I GET SIGN OF CONSTANT. ADA K2 LDB A,I (B)=CONST. LDA CLBI IF +, DO 'CLB'. SSB LDA CCBI ELSE DO 'CCB'. JSB OAI.F JSB CO.F FIX UP STATUS: JSB P1P.F SET STACK & REG DATA RIGHT. JSB CO.F LDA K2 SET (B) STATUS TO INDICATE STA F.ACB THAT (B,A) IS A DBL INT. JMP DIV01 NOW LET IT TAKE ITS COURSE. * * 2ND OPND IS CONSTANT. * DIV04 SZB X/0 ? JMP DIV05 NO. * LDA K14 YES. WARNING. JSB WAR.F JMP DIV01 DON'T BOTHER TRYING TO OPTIMIZE IT. * DIV05 CPB K1 X/0.5 ? JMP DIV06 YES. * CPB K2 X/1.0 ? JMP DIV07 YES. * CPB KM2 X/(-1) ? JMP DIV10 YES. * CPB K3 X/2.0 ? RSS (YES) JMP DIV01 NO, NOTHING SPECIAL. * LDA F.RTP YES. INTEGER*2 ? CPA INT RSS (YES) JMP DIV01 NO. CAN'T HELP. * JSB PO1.F YES. CHANGE TO SHIFT. POP THE 2, JSB SCG.F LOAD INTO EITHER REGISTER, LDA SSAI AND DO: 'SSI', JSB ORI.F LDA INAI 'INA' JSB ORI.F LDA ARSI 'ARS' JSB ORI.F JMP DIV.F,I THEN DONE. * DIV10 JSB PO1.F X/(-1). JUST NEGATE. DISCARD THE -1, JSB NEG.F & NEGATE. JMP DIV.F,I DONE. * DIV06 JSB MY2.F USE X*2. JMP DIV.F,I DONE. * DIV07 JSB PO1.F X/1, NOP. LDA F.S1T,I SET F.RES RIGHT. STA F.RES JMP DIV.F,I * K14 DEC 14 CCBI CCB SKP * INTEGER DIVIDE. * DIV08 LDA F.S1N,I IF 1ST OPND IN (A), LDB F.ACB AND (B,A) = DBL INT, CPB K2 SZA RSS NO. JMP DIV09 THEN CAN SKIP THE LOAD & EXTEND. * LDB F.S1N,I NO. LOAD 1ST OPND INTO (B). JSB LDB.F JSB SRT.F FREE UP (A). DEF K0 LDA ASRI DO 'ASR 16' JSB OAI.F DIV09 LDA DIVI DO 'DIV' JSB OAI.F LDB F.S1T,I DO 'DEF 2ND OPND' JSB DEF.F CLA SET RESULT IN (A). STA F.RES JSB CBR.F NOTHING IN (B) ANYMORE, LDA F.RTP BUT HAVE TO SET UP (A). JSB SRS.F DEF K0 JSB P2P.F JMP DIV.F,I DONE. * DDIVT DEF *+1 DOT FUNCTION TABLE FOR DIVIDE. DEF DIV08,I INT, SPECIAL CASE. .DDI ABS 018+D.REG DBI, .DDI ABS 019+D.REG REA, .FDV ABS 020+D.OPM DBL, .XDIV ABS 021+D.OPM+D.REG RE8, .TDIV ABS 022+D.OPM CPX, .CDIV ABS 303+D.REG+D.OPM ZPX, .ZDIV * .DDIR ABS 023+D.REG DBI, .DDIR (REVERSED) DIVI OCT 100400 SKP * ****************** * * EXPONENTIATION * * ****************** SPC 1 * DETERMINE FINAL TYPE, CHECK CONSTANTS. * EXP.F NOP JSB MP2.F MAP OPERAND(S) IN IF IN EMA. JSB F2T.F FREE TEMPS. JSB GT2.F GET TYPES. STA T2EXP SAVE EXPONENT TYPE. STB T1EXP SAVE BASE TYPE. CPA CPX IS EXPONENT COMPLEX ? RSS CPA ZPX OR DOUBLE COMPLEX ? JMP EXP99 YES, ERROR. * JSB MIM.F MAP EXPONENT TYPE. SEZ ARITHMETIC ? JMP EXP99 NO, ERROR. * STA T3EXP YES. SAVE IT. LDA T1EXP MAP BASE TYPE. JSB MIM.F SEZ ARITHMETIC ? JMP EXP99 NO, ERROR. * STA T4EXP SAVE MAPPED BASE TYPE. CMA,INA WHICH IS HIGHER TYPE ? ADA T3EXP LDB T1EXP (ASSUME BASE) SSA,RSS WELL ? LDB T2EXP EXPONENT. USE INSTEAD. STB F.RTP SET UP RESULT TYPE. LDA T4EXP RESTORE BASE TYPE. MPY K5 COMPUTE TABLE ADDR: 5 EXP TYPES. ADA T3EXP OFFSET = 5*(BASE TYPE)+(EXP TYPE) ADA DEXPT PLUS BASE. LDA A,I (A) = DOT FUNCTION WORD. SZA,RSS LEGAL COMBINATION ? JMP EXP99 NO, ERROR. * STA T3EXP YES. SAVE IT. CCA CHECK OUT CONSTANTS, BUT DON'T FOLD. JSB CF2.F JMP EXP02 BOTH CONSTANT. JMP EXP04 SECOND ONLY. JMP EXP09 FIRST ONLY. * * CAN'T USE CONSTANTS, ISSUE NORMAL CODE. * EXP01 JSB ATM.F NEITHER. ALLOCATE TEMP IF REQ'D. LDA T3EXP GENERATE THE CODE. LDB K2 TWO OPERANDS. EXP00 JSB GDF.F LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP EXP.F,I DONE. SKP * FIRST CONSTANT. 1**X = 1. * EXP09 CPA K2 1**X ? JMP EXP03 YES. RESULT=1. JMP EXP01 NO. NO HELP. * * BOTH CONSTANTS. CHECK 1**C THEN SECOND. * EXP02 CPA K2 1**C ? RSS YES, RESULT = 1. JMP EXP04 NO. * EXP03 JSB CRD.F FOR CASE 1**X, DEF F.S1T,I IF X WAS IN REGISTER, FREE IT. JSB PO1.F JUST DISCARD CONSTANT OR X. LDB F.S1T AND CONVERT TO FINAL TYPE. JSB CON.F JMP EXP.F,I AND EXIT. * * SECOND CONSTANT. CHECK -1,0,0.5,1,2 . * EXP04 SZB,RSS X**0 ? JMP EXP01 YES, MAY BE ERROR, USE NORMAL. * CPB K2 X**1 ? JMP EXP03 YES. RESULT=X. * CPB KM2 X**-1 ? JMP EXP06 YES. * CPB K3 X**2 ? JMP EXP07 YES. * CPB K1 X**0.5 ? (CAN'T BE INT IF SO) JMP EXP08 YES. USE SQRT. * * TRY TO USE .FPWR OR .TPWR * LDA T1EXP IS BASE: CLBI CLB CPA REA REAL ? LDB .FPWR CPA RE8 DOUBLE ? LDB .TPWR SZB,RSS JMP EXP01 NO. NO HELP. * STB T4EXP YES. TRY TO USE .FPWR OR .TPWR . LDB F.S1T,I GET FIRST WORD OF CONSTANT. MUST BE +. ADB K2 LDA B,I SSA WELL ? JMP EXP01 NEGATIVE. NO HELP. * LDA T2EXP WHAT TYPE IS EXPONENT ? CPA INT INTEGER ? JMP EXP05 YES. ALWAYS O.K. * CPA DBI DOUBLE INTEGER ? RSS YES. JMP EXP01 NO. NO HELP. * DLD B,I CHECK THAT DOUBLE INT IS SMALL ENUF. SWP ASL 16 SOC WELL ? JMP EXP01 NO. HARD WAY. * LDA B YES. FORM SINGLE INT CONSTANT. JSB EIC.F JSB PO1.F REPLACE WITH SHORT CONSTANT. LDA F.A JSB PU1.F EXP05 JSB CO.F PUT THE EXPONENT FIRST. LDA T4EXP GET DOT FUNCTION INFO BACK. STA T3EXP USE IT INSTEAD OF OTHER. JMP EXP01 GO USE NORMAL CALL. * * X**(-1) = 1/X. * EXP06 JSB PO1.F POP (-1) OFF STACK. CLA,INA FORM A +1. JSB EIC.F JSB PU1.F PUSH ON STACK, JSB CO.F COMMUTE: HAVE +1,X. LDB F.S1T CONVERT X TO FINAL TYPE. JSB CON.F JSB DIV.F DIVIDE. JMP EXP.F,I DONE. * * X**2 = X*X. * EXP07 JSB PO1.F X**2, DO AS X*X. LDB F.S1T CONVERT X IF REQ'D. JSB CON.F LDA F.S1T,I DUPLICATE X. STA F.RES LDB F.S1T,I CONSTANT ? JSB CFC.F RSS JMP EXP10 YES. DON'T LOAD !!! * LDA T1EXP NO. REGISTER DATA ? JSB MIM.F SSB,RSS JSB SCG.F YES. LOAD IT NOW (SET F.RES). EXP10 LDA F.RES (OTHERWISE, DUP STCK ENTRY NOT UPDATED.) JSB PU1.F PUSH IT. JSB MPY.F DO X*X. JMP EXP.F,I DONE. SKP * X**0.5 = SQRT(X). * EXP08 JSB PO1.F X**0.5 . DISCARD 0.5 LDB F.S1T CONVERT TO FINAL TYPE IF NECESSARY. JSB CON.F LDA F.RTP MAP TYPE. JSB MIM.F ADA DSQT PICK SQRT,DSQRT,.SQRT LDA A,I DOT FUNCION WORD. CLB,INB ONE ARGUMENT. JMP EXP00 GO DO IT & FIX STACK. * EXP99 LDA K45 ILLEGAL EXPONENTIATION. JSB ER.F * T1EXP NOP T2EXP NOP T3EXP NOP T4EXP NOP K5 DEC 5 K45 DEC 45 REA OCT 020000 F.IM=REA RE8 OCT 120000 F.IM=RE8 SKP DEXPT DEF *+1 EXPONENTIATION DOT FUNCIONS. ABS 030+D.OPM+D.ER0 .ITOI ABS 031+D.OPM+D.ER0 .ITOJ NOP (INT**REA ILLEGAL) NOP (INT**DBL ILLEGAL) NOP (INT**RE8 ILLEGAL) * ABS 032+D.OPM+D.ER0 .JTOI ABS 033+D.OPM+D.ER0 .JTOJ NOP (DBI**REA ILLEGAL) NOP (DBI**DBL ILLEGAL) NOP (DBI**RE8 ILLEGAL) * ABS 036+D.OPM+D.ER0 .RTOI ABS 037+D.OPM+D.ER0 .RTOJ ABS 038+D.OPM+D.ER0 .RTOR ABS 039+D.OPM+D.ER0 .RTOD ABS 040+D.OPM+D.ER0 .RTOT * ABS 042+D.OPM+D.ER0 .DTOI ABS 043+D.OPM+D.ER0 .DTOJ ABS 044+D.OPM+D.ER0 .DTOR ABS 045+D.OPM+D.ER0 .DTOD ABS 046+D.OPM+D.ER0 .DTOT * ABS 048+D.OPM+D.ER0 .TTOI ABS 049+D.OPM+D.ER0 .TTOJ ABS 050+D.OPM+D.ER0 .TTOR ABS 051+D.OPM+D.ER0 .TTOD ABS 052+D.OPM+D.ER0 .TTOT * ABS 034+D.OPM+D.ER0 .CTOI ABS 035+D.OPM+D.ER0 .CTOJ NOP (CPX**REA ILLEGAL) NOP (CPX**DBL ILLEGAL) NOP (CPX**RE8 ILLEGAL) * ABS 305+D.OPM+D.ER0 .ZTOI ABS 306+D.OPM+D.ER0 .ZTOJ NOP (ZPX**REA ILLEGAL) NOP (ZPX**DBL ILLEGAL) NOP (ZPX**RE8 ILLEGAL) * .FPWR ABS 041 .TPWR ABS 053 * DSQT DEF *-1 SQUARE ROOT DOT FUNCTION TABLE. ABS 102+D.REG+D.ER0 SQRT ABS 103+D.OPM+D.RTN+D.ER0 DSQRT ABS 104+D.OPM+D.RTN+D.ER0 .SQRT SKP * *************************** * * CHECK FOR TWO CONSTANTS * * *************************** SPC 1 * INPUT: TOP 2 VALUE ON STACK 1 TO BE CHECKED. * OUTPUT: RTN TO P+1: NEITHER IS CONSTANT. * P+2: FIRST (TOP) ONLY. (DFCN1=ADDR) * P+3: SECOND ONLY. (DFCN2=ADDR) * P+4: BOTH ARE CONSTANTS. (DFCN1,DFCN2) * IF THE SECOND ONE IS CONSTANT, ITS ADDRESS IS RETURNED IN (B) * AND ITS FIRST WORD IN (A). SPC 1 C2C.F NOP LDB F.S1T,I CHECK FIRST OPERAND. JSB CFC.F RSS NOT CONSTANT. ISZ C2C.F CONSTANT. BUMP RTN BY ONE. STB DFCN1 SAVE ADDR. LDB F.S1N,I CHECK SECOND OPERAND. JSB CFC.F JMP C2C.F,I NOT CONSTANT. ISZ C2C.F CONSTANT. BUMP RTN BY TWO. ISZ C2C.F STB DFCN2 SAVE ADDR. JMP C2C.F,I EXIT. * DFCN1 NOP DFCN2 NOP SKP * *************************************** * * .AND. .OR. .EQV. .NEQV. .XOR. .EOR. * * *************************************** SPC 1 AND.F NOP JSB AND00 AND: 0 * .OR.F NOP JSB AND00 OR: 1 * XOR.F NOP ALSO .NEQV. & .EOR. JSB AND00 XOR: 2 (ALSO .NEQV. & .EOR.) * EQV.F NOP JSB AND00 EQV: 3 * AND00 NOP COMMON ENTRY. LDA AND00 TRAPSE BACK THRU CALL. ADA KM2 (A)=ADDR OF CALLER'S ENTRY. LDB A,I (B)=RETURN ADDR, STB AND.F SAVE IT. CMA FORM (ADDR ENTRY) - (ADDR AND.F) ADA DFAND CMA ARSI ARS /2 = OPERATOR ORDINAL. STA T1AND T1AND = OP #. * JSB MP2.F MAP ITEM(S) IF IN EMA. JSB GT2.F GET TYPES. CPB LOG 1ST=LOG ? JMP AND02 YES. * CPB LO4 1ST=LO4 ? JMP AND02 YES. * CPB INT 1ST=INT ? JMP AND01 YES. * CPB DBI 1ST=DBI ? JMP AND04 YES. JMP AND99 NO. IMPROPER TYPE, ERROR 56. * * 1ST OPND IS INTEGER. * AND01 CPA DBI 2ND=DBI ? JMP AND05 YES. CONVERT 1ST TO DBI. * CPA INT 2ND=INT ? JMP AND03 YES. INT.OP.INT, SAME AS LOGICAL. JMP AND99 NO. ERROR. * * 1ST OPERAND IS LOG OR LO4, 2ND MUST BE TOO. * AND02 CPA LOG 2ND=LOG ? RSS YES. CPA LO4 OR LO4 ? RSS YES. JMP AND99 NO. MIXED, ERROR. SKP AND03 JSB F2T.F FREE TEMPS. CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDB F.S1N,I LOAD FIRST OPND INTO (A). JSB LDA.F (ONLY ONE WORD, EVEN IF LO4) LDA DANDI INDEX INTO INSTRUCION TABLE: ADA T1AND LDA A,I (A)=OPCODE: AND/IOR/XOR/XOR LDB F.S1T,I DO THE OPERATION. JSB SOA.F LDB T1AND IF IT WAS .EQV. , LDA CMAI DO 'CMA' CPB K3 WELL ? JSB OAI.F YES. LDA F.S1T,I WE WANT TO FREE 2ND OPND IF REGISTER, CPA F.S1N,I BUT NOT IF IT IS SAME AS FIRST OPND. JMP AND3A SAME. LEAVE RESULT INTACT. * JSB CRD.F DIFFERENT. FREE 2ND OPND (IF REGISTER) DEF F.S1T,I AND3A JSB P2P.F POP OPNDS, PUSH RESULT. JMP AND.F,I EXIT. * * DOUBLE INTEGER MASKING OPERATIONS. * AND04 CPA INT 1ST=DBI. 2ND=INT, RSS CPA DBI OR DBI ? RSS YES. O.K. JMP AND99 NO. MISMATCH. * AND05 JSB MAT.F CLOSE ENUF. CONVERT IF MUST. JSB F2T.F FREE TEMPS. JSB F2T.F IF THAT CREATED ANOTHER TEMP, FREE IT. LDA DBI SET TYPE. STA F.RTP CLA,CLE,INA PUT REGISTER FIRST (PREF A) OR CONSTANT. JSB CCO.F LDA DDAND INDEX INTO FUNCTION TABLE. ADA T1AND LDA A,I (A)=DOT FUNCTION #: .DAND/.DOR/.DXOR/.DEQV LDB K2 TWO OPERANDS. JSB GDF.F GENERATE CODE. LDA F.RES PUSH RESULT ON STACK. JSB PU1.F JMP AND.F,I DONE. * AND99 LDA K56 ILLEGAL TYPE COMBINATION, ERROR 56. JSB ER.F * K56 DEC 56 LO4 OCT 110000 T1AND NOP OPERATOR: AND=0, OR=1, XOR=2, EQV=3. DFAND DEF AND.F FOR COMPUTING ABOVE. * DANDI DEF *+1 KEEP IN ORDER * OCT 012000 AND * OCT 032000 IOR * OCT 022000 XOR * OCT 022000 (FOR .EQV.) * * DDAND DEF *+1 KEEP IN ORDER * ABS 244+D.REG .DAND * ABS 247+D.REG .DOR * ABS 250+D.REG .DXOR * ABS 253+D.REG .DEQV * SKP * ******* * * NOT * * ******* SPC 1 NOT.F NOP JSB MP1.F MAP ITEM IF IN EMA. JSB F1T.F FREE TEMP. JSB GT1.F TYPE ? LDB F.S1T,I (B=F.A OF OPND) CPA DBI DOUBLE INTEGER ? JMP NOT01 YES. GO DO CMA & CMB. * CPA INT INTEGER ? RSS YES, CMA. CPA LOG LOGICAL ? RSS YES, CMA. CPA LO4 DOUBLE LOGICAL ? RSS YES, CMA (FIRST WORD ONLY). JMP AND99 NO, ILLEGAL TYPE. * LDA F.LA1 YES. TWO .NOT.'S IN A ROW ? CPA F.COP JMP NOT02 YES. THEY CANCEL. * JSB LDA.F NO. COMPLEMENT FIRST WORD ONLY. LDA CMAI OUTPUT CMA/CMB. JSB ORI.F COMPLEMENT. JSB P1P.F FIX UP STACK. JMP NOT.F,I DONE. * NOT01 LDA F.LA1 DBL INT. TWO NOT'S IN A ROW ? CPA F.COP JMP NOT02 YES. THEY CANCEL. * JSB LD.F LOAD WHOLE DOUBLE INTEGER. LDA CMAI OUTPUT 'CMA' JSB OAI.F LDA CMBI AND 'CMB' JSB OAI.F JSB P1P.F FIX UP STACK. JMP NOT.F,I DONE. * NOT02 JSB RD.F TWO .NOT.'S; JUST SKIP SECOND ONE. JMP NOT.F,I * O.NOT DEC 10 OPCODE FOR .NOT. SKP * **************************** * * CHANGE RESULT TO LOGICAL * * **************************** SPC 1 SLR.F NOP JSB GRD.F ASSUME IT'S IN A REGISTER. DEF F.RES LDA LOG CHANGE TYPE. JSB SRD.F DEF F.RES JMP SLR.F,I DONE. SPC 2 * SUBROUTINE TO REVERSE ORDER OF RELATIONAL OPERATION. * RRO.F NOP LDA F.COP CURRENT OPERATION. ADA DRLT1 INDEX INTO TABLE. LDA A,I GET OPCODE & OTHER STUFF. AND B37 PICK OUT OPCODE BITS. STA F.COP SET UP NEW OPCODE. JMP RRO.F,I DONE. SPC 2 * SUBROUTINE TO NEGATE RELATIONAL OPERATION. * NRO.F NOP LDA F.COP CURRENT OPERATION. ADA DRLT1 INDEX INTO TABLE. LDA A,I NEW OPCODE & JUNK. ALF,ALF RIGHT-JUSTIFY NEW OPCODE. RAL,RAL AND B37 ISOLATE IT. STA F.COP SET UP NEW OPCODE. JMP NRO.F,I DONE. SKP * ********************************* * * .LT. .LE. .EQ. .NE. .GE. .GT. * * ********************************* SPC 1 .LT.F BSS 0 .LE.F BSS 0 .EQ.F BSS 0 .NE.F BSS 0 .GE.F BSS 0 .GT.F BSS 0 REL.F NOP * * FIRST ACCOUNT FOR NEGATION (E.G. PREPROCESSORS). * REL03 LDA F.LA1 IS NEXT OPERATION .NOT. ? CPA O.NOT RSS (YES) JMP REL04 NO. * JSB RD.F YES. DISCARD THE .NOT. JSB NRO.F NEGATE SENSE OF THE OPERATOR. JMP REL03 TRY FOR MORE. * REL04 JSB MP2.F MAP ITEM(S) IF IN EMA. REL05 LDA K4 OPERATION = 4, COMPARE. JSB CF2.F EITHER CONSTANTS ? JMP REL40 BOTH. JMP REL10 SECOND. RSS FIRST. JMP REL11 NEITHER. * JSB CO.F FIRST. MAKE IT SECOND. JSB RRO.F AND REVERSE OPERATOR. JMP REL05 GO TRY AGAIN. * REL10 SZB,RSS SECOND CONSTANT. ZERO ? JMP REL12 YES. SPECIAL-CASE. * CPB KM2 -1 ? RSS (YES) JMP REL11 NO. NOT A SPECIAL CASE. * JSB GT2.F YES. IS IT: CPB INT INT*2, RSS CPB DBI OR INT*4 ? RSS JMP REL11 NO. NO HELP. * LDA F.COP YES. IS OPERATOR: CPA OP.GT .GT. RSS CPA OP.LE OR .LE. ? CCB,RSS (B=-1) JMP REL11 NO. NO HELP. * ADA B YES. .GT.-1 => .GE.0 STA F.COP AND .LE.-1 => .LT.0 JMP REL12 NOW TREAT CONSTANT AS ZERO. * * MATCH OPERAND TYPES, PROCESS BY TYPE. * REL11 JSB MAT.F FIRST, MAKE SURE MATCHING TYPES. JSB F2T.F FREE TEMPS. LDA F.RTP INTEGER ? CPA INT JMP REL14 YES. * CPA DBI DOUBLE INTEGER ? JMP REL30 YES. * LDB F.COP A LITTLE CHECKING BEFORE WE GO ON... CPB OP.EQ IS IT .EQ. ? RSS CPB OP.NE OR .NE. ? JMP REL15 YES. * CPA CPX NO. THEN COMPLEX ILLEGAL. RSS CPA ZPX ALSO DOUBLE COMPLEX. JMP CON10 JMP REL50 ELSE CARRY ON... * REL15 CPA REA YES, .EQ. OR .NE., REAL ? JMP REL30 YES. GO USE .DCO AS IF DOUBLE INT. JMP REL50 NO. NORMAL SUBTRACT. SKP * INTEGER COMPARE. * REL14 LDA F.COP WHICH TEST ? CPA OP.EQ .EQ. ? RSS CPA OP.NE OR .NE. ? JMP REL02 YES. GO USE 'CPA'. * CPA OP.LE IF .LE., JSB CO.F COMMUTE. CPA OP.GT IF .GT., JSB CO.F COMMUTE. LDA CLOI ISSUE 'CLO' JSB OAI.F LDB F.S1T,I IS 2ND OPND CONSTANT ? JSB CFC.F WELL ? RSS NO. (SKIP THE SENSE REVERSAL LATER) CPA B100K YES. BUT IS IT MAX NEG ? CCA,RSS YES. CAN'T DO THAT ONE. CLA NO. (A=0 REVERSES SENSE) STA T2REL SAVE FLAG. SZA WHICH IS IT ? JMP REL00 NON-CONST. * JSB SUB.F CONST. DO NORMAL SUBTRACT. JMP REL01 & WILL REVERSE SENSE TOO. * * 2ND OPND NOT CONST: CLO / LDA <1ST> / CMA / ADA <2ND> / SOS / CMA * * 2ND CONST, NOT -32768: CLO / LDA -<2ND> / ADA <1ST> / SOC / CMA * REL00 JSB CO.F NOT CONST. WANT TO COMPL 1ST OPND, SO CCA PUT 1ST OPND ON TOP, CREATE (-1), JSB EIC.F JSB PU1.F AND PUT ON STACK. JSB CO.F MAKE IT (-1),(1ST OPND) JSB SUB.F THIS IS A ROUNDABOUT WAY OF 1'S COMPL. JSB ADD.F HAVE (2ND OPND)-(1ST OPND)-1 REL01 LDA SOSI OVERFLOW CHECK. LDB F.COP WILL REVERSE SENSE IF CPB OP.GE .GE. XOR B100 CPB OP.LE OR .LE. XOR B100 ISZ T2REL NORMAL SUBTRACT REVERSES SENSE TOO. XOR B100 JSB OAI.F THERE IT GOES... LDA CMAI 'CMA' CHANGES (2ND)-(1ST)-1 INTO JSB ORI.F (1ST)-(2ND) (IF NO OFL) JSB SLR.F CHANGE RESULT TYPE TO LOGICAL. JSB P1P.F FIX UP STACK. JMP REL.F,I DONE. SKP * INTEGER .EQ. & .NE. * REL02 CLA,CLE .EQ. & .NE. COMMUTE IF HELPS. JSB CCO.F A=0: EITHER REG. E=1: CONSTANTS TOO. LDB F.S1N,I LOAD FIRST ONE. JSB LD.F JSB ABB.F FORM A/B BIT. ADA CPAI ISSUE CPA/CPB. LDB F.S1T,I TO SECOND OPND. JSB SOA.F JSB CRD.F FREE UP REGISTER CONTAINING 2ND OPND DEF F.S1T,I (MAY ALSO FREE 1ST, THAT'S O.K.) JSB PO1.F POP OPERANDS. JSB PO1.F JSB LLI.F SET UP LOGICAL IF INFO. LDA DRLT4 GET TABLE FOR CODE GEN. JMP REL90 DO IT. * * COMPARE TO ZERO. TAILORED SEQUENCES. * REL12 JSB F2T.F FREE TEMPS. JSB GT2.F (B) = TYPE OF NEXT-TO-TOP (TOP=ZERO). LDA F.COP (A) = OPERATION. CPB CPX IF COMPLEX, RSS CPB ZPX OR DOUBLE COMPLEX, RSS (YES) JMP REL06 NO. * CPA OP.EQ YES. THEN MUST BE .EQ. RSS CPA OP.NE OR .NE. JMP REL13 (YES) JMP CON10 ALL OTHERS ILLEGAL. * REL06 CPB DBI ALSO, IF DBI... RSS JMP REL13 (NO) * CPA OP.LT .LT. IS EASY (SIGN TEST) JMP REL13 * CPA OP.GE AND .GE. (SIGN TEST) JMP REL13 * CPA OP.LE BUT NOT .LE. JMP REL11 * CPA OP.GT OR .GT. JMP REL11 * LDB F.S1N,I FOR DOUBLE INT .EQ., .NE. JSB LD.F ZERO, MUST CHECK OUT LDA IORBI BOTH WORDS; DO 'IOR B' JSB OAI.F (A=0) STA F.S1N,I NOTE THAT THE LOAD WAS DONE. * REL13 JSB LLI.F SET UP 'LOGICAL IF' INFO. JSB PO1.F POP THE ZERO OFF THE STACK. REL16 LDB F.S1T,I GET TYPE AGAIN. JSB GT1.F LDB K2 (B=2) CPA ZPX IF DOUBLE COMPLEX, BLS,SLB (YES. B=4) CPA CPX OR COMPLEX, RSS (YES) JMP REL07 NO. NO PROBLEM. * STB T3REL THEN LOAD UP FIRST WORD OF SECOND PART. LDA F.S1T,I IF ADDRESS IN REGISTER, SZA CPA K1 RSS (YES) JMP REL18 NO. * JSB SRT.F THEN SAVE IT: SINCE ADDRESS WILL BE USED DEF F.S1T,I TWICE, AND NO ONE ELSE KNOWS THAT. REL18 LDB INT CALL LOADED RESULT INTEGER. STB F.RTP LDA T3REL OFFSET TO SECOND PART. LDB F.S1T,I JSB LDO.F LOAD ITEM+2 OR ITEM+4. LDB F.RES MAKE SURE IT'S IN (A). JSB LDA.F LDA IORI 'OR' IN THE FIRST WORD OF FIRST PART. LDB F.S1T,I JSB SOA.F JMP REL09 * REL07 LDB F.S1T,I LOAD FIRST WORD OF ITEM. JSB LDF.F REL09 JSB PO1.F NOW POP THAT OFF STACK. LDA DRLT2 GET TABLE ADDR FOR COMPARE TO ZERO. JMP REL90 GO GENERATE CODE FOR IT. SKP * DOUBLE INTEGER COMPARE. * REL30 JSB LLI.F LOOK AHEAD FOR LOGICAL IF. LDB T1REL 0=VALUE, 1=IF & NO GOTO, 2=IF & GOTO. ADB KM2 >=0 IFF LOG IF & GOTO. LDA F.COP TRY TO GET THE BEST COMBINATION HERE: CPA OP.GE IF .GE., CMBI CMB COMMUTE IFF LOG IF & GOTO. CPA OP.GT IF .GT., CMB DITTO. SSB,RSS IS BEST CODE SEQUENCE FROM COMMUTING ? JMP REL31 NO. * JSB CO.F YES. COMMUTE, JSB RRO.F AND REVERSE OPERATOR. REL31 CLA,CCE A=0: EITHER REG. E=1: IGNORE CONSTANTS. JSB CCO.F ON OTHER HAND, IF ALREADY IN REGISTERS, SEZ THEN THAT IS MORE IMPORTANT. JSB RRO.F YUP. WE COMMUTE, HAVE TO REVERSE TOO. LDA .DCO NOW ISSUE THE .DCO CODE. LDB K2 TWO OPERANDS. JSB GDF.F ALL AUTOMATIC! LDA DRLT5 GET TABLE ADDR FOR STUFF THAT FOLLOWS. JMP REL90 AND GO ISSUE CODE. * * BOTH CONSTANTS, FOLD IT. * REL40 LDB F.COP INDEX TABLE OF VALUES. ADB DRLT1 GET WORD WHICH HAS 3-BIT LOG VALUES: LDB B,I 3/IF<, 3/IF>, 3/IF= SSA,RSS >=0 ? RBL YES, SKIP '<'. SZA,RSS =0 ? RBL YES, SKIP '>'. LDA B FORM LOGICAL CONSTANT. AND B100K STA F.IDI SET UP A.T. ENTRY. LDA LOG JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A SET IT UP AS RESULT. STA F.RES JSB P2P.F FIX UP STACK. JMP REL.F,I DONE. SKP * REA/DBL/RE8/CPX/ZPX COMPARE USING SUBTRACT. * REL50 JSB LLI.F FIGURE OUT IF LOGICAL IF FOLLOWS. LDA F.COP COMMUTE IF: CPA OP.LE .LE. RSS CPA OP.GT OR .GT. RSS JMP REL53 NEITHER. DON'T COMMUTE. * JSB CO.F YES. COMMUTE TO GENERATE BETTER CODE. JSB RRO.F REVERSE THE OP TOO. REL53 LDB F.RTP ON THE OTHER HAND, FOR REALS, CPB REA (IS IT REAL*4 ?) CLA,CCE,RSS A=0, E=-1 FOR CCO.F JMP REL54 NOT REAL. * JSB CCO.F BETTER TO HAVE REGISTER FIRST. SEZ DID THAT FORCE A COMMUTE ? JSB RRO.F YES, HAVE TO REVERSE OP THEN. REL54 JSB SUB.F ALL SET. SUBTRACT. JMP REL16 NOW TREAT AS COMPARE TO ZERO. * * SUBR TO LOOK AHEAD FOR LOGICAL IF. * SET UP: T1REL: 0=VALUE, 1=LOGIF, 2=LOGIF & GOTO. * T2REL: IF LOG IF, JUMP TARGET. * LLI.F NOP CLA ASSUME VALUE. STA T1REL LDA K35 IS NEXT OPCODE THE END-OF-EXPRESSION ? CPA F.LA1 (IF NOT, 2ND CPA FAILS TOO.) LDA F.LA2 YES. IS OPERATOR AFTER NEXT LOGICAL IF ? CPA OPLIF RSS (YES) JMP LLI.F,I NO. * ISZ T1REL ADVANCE TO SECOND CODE SEQUENCE. JSB RD.F DISCARD END-OF-EXPRESSION. JSB RD.F DISCARD LOGICAL IF. JSB RD.F DISCARD SEQUENCE INFO. JSB RD.F GET F.A OF TWPE ENTRY. STA T2REL SAVE IT. DLD A,I GET ITS F.AF . CMB,SSB WHICH TYPE ? JMP LLI.F,I NORMAL. * STB T2REL GOTO. SET UP ITS F.A ISZ T1REL AND ADVANCE POINTER. JMP LLI.F,I DONE. SKP * GENERATE CODE BY TABLE. * REL90 LDB F.COP INDEX BY OPCODE: BLS *2 ADB F.COP *3. THREE CASES. ADA B START OF THREE-WORD BLOCK. LDB T1REL LOGICAL IF CHARACTERIZATION. ADA B ADDR OF CODE SEQUENCE DESCRIPTION. LDA A,I THE DESCRIPTION. STA T1REL SAVE FOR AWHILE. SZB VALUE OR LOGICAL IF ? JMP REL92 LOGICAL IF. NO VALUE HERE. * JSB SLR.F VALUE. SET IT UP. LDA F.RES ON STACK, TOO. JSB PU1.F JMP REL93 GO ISSUE CODE. * REL92 JSB CAR.F IF LOGICAL IF, ZAP REGISTER DATA. * * GENERATE UP TO FOUR INSTRUCTIONS ACCORDING TO THE * THE OPERATION AND WHETHER IT IS THE LAST ONE IN * A LOGICAL IF AND IF THE IF IS FOLLOWED BY 'GOTO'. * REL93 LDA T1REL EXTRACT NEXT VALUE. ALF LDB A (SAVE COPY) AND BM20 (A) = WORD WITH CODE ZAPPED. STA T1REL TO MAKE SURE WE STOP AFTER 4. XOR B HERE'S THE CODE ITSELF. ADA DRLT3 GET THE OPCODE OR PROCESSOR ADDR. LDA A,I RAL,CLE,SLA,ERA WHICH IS IT ? (CLEAR SIGN) JMP 0,I PROCESSOR. USE IT. * LDB F.RES INSTRUCTION. ADD THE A/B BIT. BLF,BLF BLF,RBR SZA UNLESS NOP. ADA B JSB OAI.F ISSUE INSTRUCTION. JMP REL93 NEXT. * REL94 LDB T2REL JMP. ISSUE IT. LDA JMPI JSB SOA.F JMP REL93 NEXT. * REL95 LDA JMPI JMP *+3. LDB K3 JSB OZ.F JMP REL93 NEXT. * REL96 JMP REL.F,I DONE. * REL97 LDA JMPI RSS: JMP *+2 LDB K2 JSB OZ.F JMP REL93 SKP * TABLE DEFINING OPCODE MAPPING FOR ABOVE. * DRLT3 DEF *+1 DEF REL96,I 00B: END. DEF REL97,I 01B: RSS. (JMP *+2) CLA 02B: CLA. CLA,RSS 03B: CLA,RSS. CCA 04B: CCA. CCA,RSS 05B: CCA,RSS. CMAI CMA 06B: CMA. SSA 07B: SSA. SSA,RSS 10B: SSA,RSS. SZA 11B: SZA. SZA,RSS 12B: SZA,RSS. DEF REL94,I 13B: JMP DEF REL95,I 14B: JMP *+3 CMA,SSA,INA,SZA 15B: CMA,SSA,INA,SZA (SKIP IF <= 0) NOP 16B: NOP SPC 2 LOG OCT 030000 CPX OCT 050000 ZPX OCT 140000 B37 OCT 37 B100 OCT 100 B100K OCT 100000 BM20 OCT 177760 T1REL NOP T2REL NOP T3REL NOP 2/4 FOR CPX/ZPX COMPARE. OP.LT DEC 11 OP.LE DEC 12 OP.EQ DEC 13 OP.NE DEC 14 OP.GE DEC 15 OP.GT DEC 16 OPLIF BYT 2,50 LOGICAL IF OPCODE. K35 DEC 35 END-OF-EXPRESSION OPCODE. SOSI SOS JMPI OCT 26000 CPAI OCT 52000 IORI OCT 32000 IORBI IOR B .DCO ABS 029+D.REG * DRLT1 DEF *+1-11 REVERSALS: NEGATIONS: FOLDING: TRUE IF: OCT 101720 LT=>GT LT=>GE < OCT 122017 LE=>GE LE=>GT < = OCT 021615 EQ=>EQ EQ=>NE = OCT 141516 NE=>NE NE=>EQ < > OCT 061314 GE=>LE GE=>LT > = OCT 041413 GT=>LT GT=>LE > SKP * TABLE FOR COMPARE TO ZERO. * DRLT2 DEF *+1-11-11-11 BYT 0,0 .LT., VALUE: NOTHING. BYT 213,0 IF: SSA,RSS/JMP BYT 173,0 IF,GOTO: SSA/JMP BYT 244,0 .LE., VALUE: SZA,RSS/CCA BYT 333,0 IF: CMA,SSA,INA,SZA/JMP BYT 321,260 IF,GOTO: CMA,SSA,INA,SZA/RSS/JMP BYT 223,100 .EQ., VALUE: SZA/CLA,RSS/CCA BYT 233,0 IF: SZA/JMP BYT 253,0 IF,GOTO: SZA,RSS/JMP BYT 224,0 .NE., VALUE: SZA/CCA BYT 253,0 IF: SZA,RSS/JMP BYT 233,0 IF,GOTO: SZA/JMP BYT 140,0 .GE., VALUE: CMA BYT 173,0 IF: SSA/JMP BYT 213,0 IF,GOTO: SSA,RSS/JMP BYT 226,0 .GT., VALUE: SZA/CMA BYT 321,260 IF: CMA,SSA,INA,SZA/RSS/JMP BYT 333,0 IF,GOTO: CMA,SSA,INA,SZA/JMP * * INTEGER*2 .EQ. AND .NE. * DRLT4 DEF *+1-13-13-13 BYT 122 .EQ., VALUE: CCA,RSS/CLA BYT 33,0 IF: RSS/JMP BYT 260,0 IF,GOTO: JMP BYT 64,0 .NE., VALUE: CLA,RSS/CCA BYT 260,0 IF: JMP BYT 33,0 IF,GOTO: RSS/JMP * * TABLE FOR DOUBLE INTEGER COMPARE. * DRLT5 DEF *+1-11-11-11 BYT 25,40 .LT., VALUE: RSS/CCA,RSS/CLA BYT 261,260 IF: JMP/RSS/JMP BYT 33,0 IF,GOTO: RSS/JMP/--- BYT 345,40 .LE., VALUE: NOP/CCA,RSS/CLA BYT 301,260 IF: JMP*+3/RSS/JMP BYT 273,0 IF,GOTO: JMP/JMP/--- BYT 316,64 .EQ., VALUE: JMP*+3/NOP/CLA,RSS/CCA BYT 313,260 IF: JMP*+3/JMP/JMP BYT 276,0 IF,GOTO: JMP/NOP/--- BYT 316,122 .NE., VALUE: JMP*+3/NOP/CCA,RSS/CLA BYT 276,0 IF: JMP/NOP/--- BYT 313,260 IF,GOTO: JMP*+3/JMP/JMP BYT 23,100 .GE., VALUE: RSS/CLA,RSS/CCA BYT 33,0 IF: RSS/JMP/--- BYT 261,260 IF,GOTO: JMP/RSS/JMP BYT 343,100 .GT., VALUE: NOP/CLA,RSS/CCA BYT 273,0 IF: JMP/JMP/--- BYT 301,260 IF,GOTO: JMP*+3/RSS/JMP SKP * ***************************** * * MAP TOP OPERAND IF IN EMA * * ***************************** SPC 1 * NOTE: THIS ROUTINE ALSO CALLED FOR EMA CALL-BY-VALUE * PROCESSING; IT MAY BE CALLED EVEN IF TOS IS A SUB/FCT * NAME WITH SIGN BIT, OR A TWPE ENTRY. * MP1.F NOP LDA F.S1T,I CHECK IT OUT. SSA,RSS IF SUB/FCT ENTRY, CPA K1 OR ALREADY IN (B), JMP MP1.F,I THEN NOT IN EMA. * STA F.A ELSE TRY TO MAP IT. JSB MAP.F STB F.S1T,I UPDATE STACK REGARDLESS. CPB K1 WAS IT MAPPED ? RSS (YES) JMP MP1.F,I NO. DONE. * LDA F.S1T YES: STA F.ACB UPDATE B-REG STACK ADDR, STA F.ACM AND MAP STACK ADDR. JMP MP1.F,I SPC 2 * ********************************** * * MAP TOP TWO OPERANDS IF IN EMA * * ********************************** SPC 1 MP2.F NOP JSB MP1.F FIRST DO TOP OPERAND. LDA F.S1N,I THEN NEXT-TO-TOP. CPA K1 IF ALREADY IN (B), JMP MP2.F,I THEN NOT IN EMA. * STA F.A ELSE TRY TO MAP IT. JSB MAP.F STB F.S1N,I UPDATE STACK REGARDLESS. CPB K1 WAS IT MAPPED ? RSS (YES) JMP MP2.F,I NO. DONE. * LDA F.S1N YES: STA F.ACB UPDATE B-REG STACK INFO. STA F.ACM AND MAP STACK INFO. JMP MP2.F,I SKP * *********************** * * MATCH OPERAND TYPES * * *********************** SPC 1 MAT.F NOP JSB GT2.F GET TYPES OF TWO TOP OPERANDS STB T0MAT SAVE TYPE OF (F.S1N). JSB MIM.F ANALYZE F.RTP. SEZ LOGICAL ? JMP CON10 YES, ERROR. * CMA,INA WILL SUBTRACT FROM OTHER. STA T1MAT SAVE. LDA T0MAT ANALYZE OTHER TYPE. JSB MIM.F SEZ LOGICAL ? JMP CON10 YES, ERROR. * ADA T1MAT ORDINAL(F.S1N TYPE) - ORDINAL(F.RTP) SZA,RSS TYPES SAME ? JMP MAT.F,I YES. DONE. * SSA WHICH IS PREFERRED ? JMP MAT01 (F.RTP). SET THAT UP. * LDA T0MAT OTHER. CHANGE F.RTP, STA F.RTP LDB F.S1T AND CONVERT TOS. JMP MAT02 * MAT01 LDB F.S1N NEXT-TO-TOP OPERAND TO BE CONV. MAT02 JSB CON.F GENERATE CONVERSION CODE JMP MAT.F,I SPC 1 T0MAT NOP T1MAT NOP SKP * **************************** * * GENERATE CONVERSION CODE * * **************************** SPC 1 CON.F NOP STB T2CON (B)=POINT. TO STK ENT CONT ELEM. LDB B,I IF ITEM IS IN (B), CPB K1 JMP CON12 THEN SKIP THE EMA TEST. * STB F.A ELSE TRY TO MAP IT IN. JSB MAP.F STB T2CON,I UPDATE STACK. LDA T2CON IF THE ITEM WAS MAPPED, CPB K1 STA F.ACM UPDATE THE STACK POINTER FOR MAPS. * CON12 LDB T2CON,I GET ITS TYPE. JSB FT.F CPA F.RTP SAME AS RESULT TYPE ? JMP CON.F,I YES. IGNORE CALL. * STA T0CON T0CON = SOURCE TYPE. JSB MIM.F MAP THAT. SEZ NON-NUMERIC ? JMP CON08 YES. SPECIAL. * STA T1CON NO. SAVE MAPPED VALUE. LDA F.RTP MAP RESULT TYPE. JSB MIM.F SEZ LOGICAL ? JMP CON09 YES. SPECIAL. * .MPY MPY K7 NO. COMPUTE ADDR CONVERSION TABLE. ADA DCONT (A) = BASE OF SET OF SEVEN. ADA T1CON (A) = ADDR OF TABLE ENTRY. STA T1CON SAVE. LDA F.RTP FOR CF1.F : RESULT TYPE. LDB T2CON STACK ADDR. JSB CF1.F IF CONSTANT, CONVERT IT. (E=0) JMP CON.F,I SUCCESSFUL. ALL DONE. * CLA SET F.RES=0 IN CASE NOT ASSIGNMENT. STA F.RES LDA F.RTP IS RESULT IN A REGISTER ? JSB MIM.F SSB,RSS JMP CON05 YES. NO TEMPS. * LDB F.S1N STACK ADDR NEXT OPND (INCASE ASSGN). LDA F.COP IS IT ASSIGNMENT ? CPA EQOPC (ONLY ONE SAFE TO BYPASS TEMP ON) JMP CON11 YES. GO TRY LOOK-AHEAD. * LDA F.RTP NO. ASSIGN TEMP NOW. JSB ATC.F STA F.RES JMP CON05 * CON11 JSB TAS.F ALLOCATE DBL/RE8/CPX/ZPX TEMP IF NEEDED. CON05 LDA T1CON,I GO TO SPECIAL CASES NOW BECAUSE RAL,CLE,SLA,ERA STACK ACTIVITY WILL DESTROY JMP A,I STATUS OF (B) AS EXTENSION OF (A). * LDA T2CON,I PUSH DUPLICATE ENTRY ONTO STACK FOR GDF.F JSB PU1.F JSB F1T.F FREE TEMP. LDA T1CON,I SET UP DOT FUNCTION GENERATION. CLB,INB ONE OPERAND. CON01 JSB GDF.F ISSUE CONVERSION CODE. (POPS STACK) CON02 JSB GRD.F IF RESULT IS IN (A), DEF F.RES LDB T2CON SET UP STACK POINTER. JSB SRD.F DEF F.RES LDA F.RES OVERWRITE STACK FRAME WITH RESULT. STA T2CON,I JMP CON.F,I ALL DONE. SKP * SPECIAL CASES: DBI => INT, CPX => REA, ZPX => RE8. * JUST OFFSETS. * CON03 CLA,INA,RSS DBI => INT, OFFSET=1, CON04 CLA CPX/ZPX => REA/RE8, OFFSET=0. LDB T2CON,I FROM THIS ITEM. JSB LDO.F (F.RTP ALREADY SET UP) JMP CON02 AND FIX UP STACK. * * SPECIAL CASE: INT => DBI * CON06 LDB T2CON,I LOAD IT INTO (B). LDA F.ACB UNLESS... CPA K2 (B) IS THE EXTENSION OF (A) SZB AND WE ARE CONVERTING (A). RSS (NO) JMP CON6A YES. JUST SWAP. * JSB LDB.F NO. LOAD (B). JSB SRT.F AND FREE (A). DEF K0 LDA ASRI ISSUE 'ASR 16' JSB OAI.F CON6A LDA SWPI AND 'RRR 16' = SWAP. JSB OAI.F LDA DBI SET UP REGISTER DATA. LDB T2CON DOUBLE INT, STACK ADDR. CLOI CLO DATA. CLE JSB SRD.F DEF K0 IN (A,B). CLA SET RESULT IN STACK. STA T2CON,I LDB DBI RESTORE RESULT TYPE. STB F.RTP JMP CON.F,I DONE. * * SPECIAL CASE: REA => CPX, RE8 => ZPX. * CON07 LDA T2CON,I PUSH DUPLICATE ENTRY ON STACK. JSB PU1.F JSB CDI.F FORM A ZERO. LDB F.RTP MAKE IT SINGLE OR DOUBLE. LDA REA CPB ZPX LDA RE8 JSB ESC.F JSB AI.F LDA F.A PUSH ONTO STACK. JSB PU1.F LDA .CMPX DOT FUNCTION INFO FOR 'CMPLX' LDB F.RTP CPB ZPX LDA .ZMPX OR '.ZMPX' LDB K2 TWO OPERANDS. JMP CON01 JUST USE GDF.F NORMALLY. SKP * LOGICAL OPERAND(S). * CON08 BSS 0 CON09 LDA T0CON LOGICAL & LOGICAL STILL O.K. CPA LOG 1ST=LOG ? RSS CPA LO4 OR DBL LOG ? RSS JMP CON10 NO. ERROR. * LDA F.RTP 2ND=LOG ? CPA LOG RSS CPA LO4 OR DBL LOG ? RSS JMP CON10 NO. ERROR. * LDA LOG YES. SET RESULT TYPE = SINGLE LOGICAL. STA F.RTP JMP CON.F,I DONE! * CON10 LDA K57 OTHERWISE ERROR. JSB ER.F * T0CON NOP T1CON NOP T2CON NOP SKP * CONVERSION DOT FUNCTION TABLE. * DCONT DEF * (INT => INT DELETED) * DEF CON03,I DBI => INT ABS 212+D.REG IFIX ABS 214+D.OPM .XFXS (.DINT) ABS 216+D.OPM .TFXS (.TINT) ABS 218+D.OPM .CINT ABS 308+D.OPM .ZINT * DEF CON06,I INT => DBI K0 NOP ABS 213+D.REG .FIXD ABS 215+D.OPM .XFXD ABS 217+D.OPM .TFXD ABS 219+D.OPM .CFXD ABS 309+D.OPM .ZFXD * ABS 226+D.REG FLOAT ABS 227+D.REG .FLTD NOP ABS 228+D.OPM+D.RTN SNGL ABS 229+D.OPM+D.RTN .NGL DEF CON04,I CPX => REA ABS 229+D.OPM+D.RTN .SNGL (IGNORE 2ND PART) * ABS 233+D.REG .XFTS ABS 235+D.REG .XFTD ABS 237+D.OPM+D.RTN DBLE NOP ABS 100+D.OPM .TDBL ABS 239+D.OPM .CDBL ABS 100+D.OPM .TDBL (IGNORE 2ND PART) * ABS 234+D.REG .TFTS (.ITBL) ABS 236+D.REG .TFTD ABS 238+D.OPM+D.RTN .BLE ABS 101+D.OPM .DTBL NOP ABS 240+D.OPM .CTBL DEF CON04,I ZPX => RE8 * ABS 096+D.REG .ICPX ABS 097+D.REG .CFTD DEF CON07,I REA => CPX ABS 098+D.OPM .DCPX ABS 099+D.OPM .TCPX NOP ABS 310+D.OPM .ZCPX * ABS 311+D.REG .IZPX ABS 312+D.REG .JZPX ABS 313+D.REG .FZPX ABS 314+D.OPM .DZPX DEF CON07,I RE8 => ZPX ABS 315+D.OPM .CZPX * .CMPX ABS 241+D.OPM+D.RTN CMPLX .ZMPX ABS 307+D.OPM+D.RTN .ZMPX ASRI ASR 16 SWPI SWP * EQOPC EQU K1 K7 DEC 7 K57 DEC 57 SKP * ************************ * * CONVERT TOP-OF-STACK * * ************************ * * ENTRY: (A) = RESULT TYPE. * EXIT: F.RTP=RESULT TYPE, TOS CONVERTED. SPC 1 CTS.F NOP STA F.RTP F.RTP = RESULT TYPE. LDB F.S1T (B) = STACK ADDR. JSB CON.F DO IT. JMP CTS.F,I DONE. * END ASMB,Q,C HED SUBROUTINE AND ARRAY REFERENCE CODE GENERATION. NAM SAM.F,8 92834-16003 REV.2030 800731 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * 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) * 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.AF ADDRESS FIELD CURRENT F.A EXT F.AT ADDRESS TYPE OF CURRENT F.A EXT F.AT. FLAG FOR BUILDING DIM/BCOMI ENTRIES. EXT F.CCW FTN OPTIONS WORD. EXT F.D0 ARRAY ELEMENT SIZE. EXT F.DIS DOUBLE INTEGER SUBSCRIPT FLAG. EXT F.EM EMA FLAG BIT IN A.T. EXT F.FES TWPE FOR FIRST EXECUTABLE. EXT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). 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.LUB ADDR OF LOWER-UPPER BOUNDS TABLE. EXT F.NC MISC A.T. DATA (INTRINSICS FLAG) EXT F.ND NUMBER OF DIMENSIONS EXT F.PCT F.A OF TEMP FOR 'PCOUNT'. EXT F.PTY PROGRAM TYPE. EXT F.R MISC BIT IN A.T. EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SBF 0=MAIN, ELSE SUB/FCT F.A EXT F.SFF SUBROUTINE/FUNCTION FLAG. EXT F.SRL F.A OF HIDDEN PARAM IN STMT FCT DEF. EXT F.UFM F.A OF .UFMP . * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT. EXT DAF.F DEFINE (F.AF). EXT DAT.F DEFINE (F.AT). EXT EDO.F ESTABLISH DATA WITH OFFSET. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT ESD.F ESTABLISH DEF SUBROUTINE EXT FA.F FETCH ASSIGNS EXT FC.F FETCH VALUE OF CONSTANT. EXT GCD.F GET CONSTANT DIMENSION VALUE SUB. EXT OA.F OUTPUT MEM REF WITH F.A EXT OAD.F OUTPUT ABS. DATA EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODD.F OUTPUT DEF TO DOT FUNCTION. EXT ODF.F OUTPUT DOT FUNCTION EXT OLR.F OUTPUT LOAD ADDRESS EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT ORI.F OUTPUT ABS INSTRUCTION, S. REGISTER INSTRUCTION. EXT OZ.F OUTPUT ZREL (OP *+N) EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F WARNING PRINT SUBROUTINE. * * ENTRY POINTS IN F4.6 * EXT F.COP CURRENT OP CODE. EXT F.LA1 1ST LOOK-AHEAD WORD FIRST PASS FILE. EXT F.PTF PERMANENT TEMP FLAG. EXT F.RES RESULT F.A EXT F.RTP RESULT TYPE EXT F.S1N NEXT-TO-TOP OF STACK 1. EXT F.TPX TYPE OF EXPRESSION BEING PROCESSED. * EXT APT.F ALLOCATE 'PERMANENT' TEMP. EXT DEF.F PRODUCE A DEF TO (B). EXT ITN.F INITIALIZE TEMP NAMES. EXT RD.F PASS FILE READ FOR PASS 2. EXT TAS.F CONDITIONALLY ALLOCATE TEMP. (LOOK-AHEAD) * * ENTRY POINTS IN AOP.F (ARITH/LOG/REL OP CODE GEN.) * EXT ADD.F ADD. EXT AND.F .AND. EXT CO.F COMMUTE TOP TWO OPERANDS. EXT CON.F CONVERSION. EXT CTS.F CONVERT TOP OF STACK. EXT MPY.F MULTIPLICATION. EXT NEG.F NEGATION. EXT NOT.F .NOT. EXT .OR.F .OR. EXT XOR.F .XOR. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT F.ACB B-REGISTER STACK ADDR. * EXT ABB.F SET UP A/B BIT. EXT AOR.F ALLOCATE ONE REGISTER. EXT CBR.F CLEAR REGISTER DATA, BOTH REGISTERS. EXT CRD.F CLEAR REGISTER DATA (ONE REGISTER). EXT FT.F FIND TYPE OF (B). EXT LD.F LOAD INTO EITHER REGISTER. EXT LDA.F LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT GRD.F GET REGISTER DATA. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT MIM.F MAP ITEM MODE. EXT P1P.F POP ONE ITEM OFF STACK, PUSH RESULT. EXT PO1.F POP ONE ITEM OFF STACK. EXT PU1.F PUSH ONE ITEM ONTO STACK. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION. (LOAD TOS). EXT SMT.F STORE MAPPED DATA (FREE MAPS). EXT SRD.F STORE REGISTER DATA. EXT SRS.F STORE REGISTER DATA, SHORT FORM. EXT SRT.F STORE REGISTER INTO TEMP. EXT VS1.F VOID STACK 1. * * ENTRY POINTS IN SAM.F * ENT EA?.F SKIP IF F.A IS IN EMA. ENT FPE.F FORM PROGRAM ENTRANCE CODE. ENT GDF.F GENERATE DOT FUNCTION CALL. ENT MAP.F MAP-IN IF IN EMA. ENT SAL.F SUBROUTINE OR ARRAY, LEFT PAREN. ENT SAR.F SUBROUTINE OR ARRAY, RIGHT PAREN. * * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * **************************** * FORM PROGRAM ENTRANCE CODE * * **************************** * FPE.F NOP JSB OLR.F PUT OUT LOAD ADDRESS JSB VS1.F VOID STACK 1. LDA F.RPL SAVE THE ADDRESS OF STA T2FPE THE FIRST PRAM (FOR .ENTR) JSB RD.F GET SUB ROUTINE F.A STA F.A AND SET IT SZA IF ENTRY FOR BLOCK DATA OR MAIN, JMP FPE13 (NO) * LDB F.SFF WHICH IS IT ? (A=0) CPB K2 JMP FPE20 BLOCK DATA. NO ENTRY POINT. * JSB OAI.F MAIN. ISSUE 'NOP' IN CASE CALLED AS SUBR. LDA T2FPE SET THE TRANSFER ADDRESS. STA F.REL LDA F.PTY SEGMENT ? CPA K5 JMP FPE20 YES. DONE. * LDB .FIOI NO. 'JSB .FIOI' JSB ODF.F LDA TWPE SET UP TWPE ENTRY FOR .UFMP JSB ESC.F JSB AI.F LDB F.A SAVE ITS F.A, STB F.UFM JSB DEF.F AND DO 'DEF .UFMP' JMP FPE20 DONE. * * PUT OUT NOP'S & .ENTR CALL; DEFINE FORMALS TOO. THE FUNCTION * ITSELF IS LEFT UNDEFINED, AND WILL BE DEFINED LATER BY SUBTRACTING * ONE (TWO IF NON-REGISTER DATA) FROM THE ADDRESS OF THE FIRST * FORMAL. THIS ALLOWS THE FORMALS TO STAY LINKED TO THE FUNCTION * (FUNCTION F.AF POINTS TO FIRST FORMAL, FORMALS POINT USING LINK * WORDS) SO THAT TYPE CHECKING MAY BE DONE ON STMT FCT ARGUMENTS. * FPE13 STA T0FPE T0FPE = F.A OF SUBR/FCT. JSB FA.F COMPUTE F.D0 = # WDS IN RESULT. LDA F.A IF F.A=F.SBF (PROCESSING PGM ENTRY) LDB F.SFF AND F.SFF=0 (SUBROUTINE) CPA F.SBF WELL ? SZB RSS (NO, FUNCTION) JMP FPE00 YES. SUBROUTINE, NO HIDDEN PARAM. * CLA FUNCTION. (A=0) STA F.SRL SET F.SRL=0 IN CASE RESULT IN REG. LDB F.D0+1 GET SIZE OF RESULT. ADB KM3 IS IT < 3 ? SSB WELL ? JMP FPE00 YES. RESULT IN REGISTER(S). * JSB OAI.F NO. USE EXTRA DUMMY. (A=0) CCAI CCA SET (A)=F.RPL OF THE EXTRA DUMMY. ADA F.RPL LDA F.IM ALLOCATE TEMP AS RESULT. JSB APT.F LDA DUM SET F.AT=DUM JSB DAT.F LDA T2FPE SET F.AF=ADDR JSB DAF.F LDA F.A F.SRL=F.A OF TEMP. STA F.SRL LDB T0FPE RESTORE ASSIGNS OF FUNCTION. STB F.A CPB F.SBF IS THIS THE MAIN ENTRY ? STA F.FRF YES. SET RESULT F.A (DEFAULT=0). JSB FA.F SKP * OUTPUT NOP'S, DEFINE FORMALS, AND STACK * THEM UP FOR NEXT LOOP, SINCE LINKS GONE. * FPE00 LDA F.AF SET UP TO SCAN FORMALS. LDB T0FPE STATEMENT FUNCTION ? CPB F.SBF JMP FPE01 NO. F.AF HAS FORMALS LIST ADDR. * .DLD DLD T0FPE,I YES. FORMALS LIST IS IN 2-WORD EXTENSION, INB GET LINK, 2ND WORD. LDA B,I FPE01 SZA,RSS DONE ? JMP FPE02 YES. * STA F.A NO. SET AS CURRENT FORMAL. JSB PU1.F AND STACK IT. JSB FA.F AND GET ITS F.AF STA T1FPE TO SET AS THE NEXT ONE. LDA F.RPL DEFINE ADDR CURRENT FORMAL. USE DAF.F JSB DAF.F TO PUT ARRAY ADDRESSES IN 'DIM' ENTRY. CLA OUTPUT 'NOP' JSB OAI.F LDA T1FPE (A)=ADDR NEXT FORMAL; JMP FPE01 GO ON. * * 'NOP' / 'JSB .ENTR' / 'DEF PARAMS' * FPE02 LDA F.RPL SAVE LOCATION OF ENTRY STA T1FPE FIRST, FOR ENTRY CODE. LDB T0FPE STATEMENT FUNCTION ? CPB F.SBF JMP FPE03 NO. ENTRY FOR PROGRAM UNIT. * INB YES. GET THE EXTENSION ADDR, LDB B,I STA B,I AND PUT ENTRY PT IN 1ST WORD. JMP FPE14 * FPE03 STA F.REL PROG UNIT ENTRY. REMEMBER. FPE14 CLA OUTPUT 'NOP' FOR ENTRY. JSB OAI.F LDB F.PCT WAS 'PCOUNT' USED, LDA T0FPE AND THIS IS MAIN ENTRY (NOT STMT FCT) ? CPA F.SBF IF PROG ENTRY, SZB,RSS AND PCOUNT, JMP FPE16 (NO) * LDA LDAI THEN 'LDA ENTRY' LDB T1FPE JSB OMR.F LDA STAI 'STA ' LDB F.PCT JSB SOA.F FPE16 LDA F.S1T WAS PARAM LIST EMPTY ? CPA F.S1B RSS JMP FPE07 NO. * LDA LDAII YES. JUST DO: LDB T1FPE 'LDA ENTRY,I' JSB OMR.F LDA STAI 'STA ENTRY' LDB T1FPE JSB OMR.F JMP FPE20 NO LIST TO PROCESS. * FPE07 LDB .ENTP IF 'PCOUNT' CODE, MUST ALLOW FOR TWO LDA T1FPE WORDS BETWEEN ENTRY & .ENTP, ELSE INA USE .ENTR . CPA F.RPL LDB .ENTR JSB ODF.F 'JSB .ENTR/.ENTP' LDB T2FPE OUTPUT 'DEF PARAMS' JSB OMR.F SKP * LOOP THRU DUMMIES: * 1) IF EMA, COPY ITS ADDR. * 2) IF VARIABLE DIMENSIONS, COPY LOWER BOUND AND * COMPUTE & SAVE DIMENSION SIZE. * 3) IF NON-EMA VAR DIM, OR EMA AND DOUBLE INTEGER * SUBSCRIPTS USED, COMPUTE & SAVE ADDRESS OF * ELEMENT (0,...,0). * LDA F.S1B START OF LOOP. STA T1FPE T1FPE = PTR INTO STACK 1. LDA F.S1T SAVE F.S1T FOR CUTTING STACK. STA T6FPE FPE04 LDA T6FPE CUT STACK BACK DOWN. STA F.S1T JSB CBR.F DISCARD REGISTER INFO. LDA T1FPE DONE ? CPA F.S1T JMP FPE20 YES. * ADA KM1 NO. ADVANCE TO NEXT. STA T1FPE LDA A,I SET UP F.A STA F.A JSB FA.F FETCH ASSIGNS. LDA F.EM IN EMA ? STA T5FPE (SET TENTATIVE .EMAP FLAG) STA T7FPE (SET EMA FLAG) SZA,RSS JMP FPE05 NO. * * IN EMA. BUILD & LINK IN A FAKE BCOMI ENTRY. * LDA F.AF SAVE REL ADDR OF PARAM. STA T2FPE LDA BCOMI SET F.AT. = BCOMI FOR AI.F STA F.AT. JSB AI.F CREATE THE BCOMI ENTRY. (F.EM SET) LDA F.A SAVE F.A OF BCOMI ENTRY. STA T4FPE LDB T1FPE,I LINK INTO THE PARAM. STB F.A JSB DAF.F LDA .DLD DO 'DLD PARAM,I' JSB OAI.F (A=0,E=1) LDB T2FPE (ADDR PARAM) LDA T4FPE SAVE IT IN WORD 2 OF BCOMI. ADA K2 STB A,I LDA KK01 DO THE DEF. JSB OMR.F LDA .DST START THE DST JSB OAI.F LDA DBI CREATE TEMP FOR REVERSED ADDR. JSB APT.F LDA T4FPE PUT ITS F.A IN BCOMI WORD 1. INA STB A,I JSB DEF.F FINISH: 'DST TEMP' LDA T1FPE,I RESTORE ITEM ASSIGNS. STA F.A JSB FA.F LDA F.IU ARRAY ? CPA ARR CLB,RSS (B=0) JMP FPE04 NO. ALL DONE. * LDA F.CCW YES. 'S' OPTION SET, OR AND B40K IOR F.DIS DOUBLE INTEGER SUBSCRIPTS ? SZA STB T5FPE YES. CLEAR .EMAP FLAG. LDA .DST DO FIRST PART OF DST. JSB OAI.F LDA DBI GET THE TEMP FOR IT. JSB APT.F LDA T4FPE PUT ITS F.A IN WORD 3 OF BCOMI. ADA K3 STB A,I JSB DEF.F AND FINISH 'DST TEMP' LDA T1FPE,I RESTORE ASSIGNS. STA F.A JSB FA.F JMP FPE06 GO DO MORE ARRAY PROCESSING. * FPE05 LDA F.IU NON-EMA. ARRAY ? CPA ARR RSS YES. KEEP GOING. JMP FPE04 NO. ALL DONE WITH THIS ONE. SKP * ARRAY: * FIGURE OUT DIMENSION TYPE, INT/DBI. * FPE06 JSB CBR.F FIRST, ZAP REGISTER DATA. JSB ITN.F AND INITIALIZE TEMP NAMES. LDA INT ASSUME SINGLE INTEGER FOR SUBS. LDB F.DIS IS THAT IT ? SZB LDA DBI NO. DOUBLE INT SUBS. STA T4FPE REMEMBER THAT. * * NEGATE, SAVE LOWER BOUND. * COMPUTE (UPPER)-(LOWER)+1 * LDA F.A VAR DIM. PUSH THE ARRAY NAME ONTO STACK. IOR KK01 WITH SIGN. JSB PU1.F LDA F.ND SET UP LOOP THRU DIMS. CMA,INA STA T2FPE T2FPE = COUNTER. LDA F.LUB STA T3FPE T3FPE = BOUNDS TABLE POINTER. FPE08 LDA T3FPE,I LOWER BOUND. STA F.A FETCH ITS ASSIGNS. JSB FA.F LDB F.EM IN EMA ? LDA K48 SZB JSB ER.F YES. ERROR. * LDA T3FPE,I PUT LOWER BOUND ON STACK. JSB PU1.F LDA T4FPE CONVERT IF NECESSARY, JSB CTS.F JSB NEG.F AND NEGATE. LDB F.S1T,I CONSTANT ? JSB CFC.F RSS (NO, REGISTER SINCE WE NEGATED IT) JMP FPE09 YES. * LDA T5FPE (IF USING .EMAP, MAKE THE TEMP SZA PERMANENT 'CAUSE IT'S IN THE ISZ F.PTF .EMAP TABLE) JSB SRT.F NO, REG. SAVE NEGATED LOWER BOUND. DEF F.S1T,I DLD T3FPE,I NOW WANT TO SEE IF SHOULD REMEMBER JSB FT.F THAT IS IN REG TOO. WHAT TYPE IS UPPER ? CPA T4FPE IF CORRECT ONE, JMP FPE10 THEN CAN REMEMBER. * DLD T3FPE,I BUT ALSO, JSB CFC.F IF UPPER IS CONSTANT, CONV DOESN'T NEED REG. JMP FPE09 (NO. WILL USE TEMP INSTEAD) * FPE10 LDA T4FPE NOW RESTORE REGISTER STATUS. JSB SRS.F DEF K0 MUST HAVE BEEN (A). * CLA,RSS STACK: TEMP / REGISTER. FPE09 LDA F.S1T,I ELSE: CONSTANT/CONSTANT. JSB PU1.F (ONE FOR LATER, ONE FOR NOW) LDA F.S1N,I COPY THE TEMP OR CONSTANT F.A STA T3FPE,I INTO LOWER BOUND SLOT. ISZ T3FPE & ADVANCE TO UPPER BOUND. SKP * UPPER BOUND PART. * LDA T3FPE,I CHECK UPPER BOUND FOR EMA. STA F.A JSB FA.F LDB F.EM LDA K48 SZB WELL ? JSB ER.F YES. ERROR 48. * LDA T3FPE,I PUT UPPER BOUND ON STACK. JSB PU1.F LDA T4FPE CONVERT IF REQ'D. JSB CTS.F LDB F.S1T,I IS UPPER CONSTANT ? JSB CFC.F RSS JMP FPE12 YES. WILL INCREMENT UPPER. * LDB F.S1N,I NO. IS LOWER IN REG ? SZB,RSS JMP FPE11 YES. INCREMENT THAT. * JSB CFC.F NO. IS LOWER CONSTANT ? JMP FPE12 NO, LOWER IN MEM. INCR UPPER. * FPE11 JSB CO.F COMMUTE IF ADVANTAGEOUS. FPE12 CLA,INA ADD ONE TO WHATEVER IS ON TOP. JSB EIC.F JSB PU1.F JSB ADD.F JSB ADD.F ADD THE OTHER. LDB F.S1T,I IF RESULT IS NOT CONSTANT, JSB CFC.F JSB SCG.F LOAD IT. MUST MAKE LOCAL COPY. ISZ F.PTF (ALLOCATE PERMANENT TEMP) JSB SRT.F NOW PUT IN TEMP. DEF F.S1T,I JSB PO1.F POP THE RESULT, AND STA T3FPE,I REMEMBER IT INSTEAD OF UPPER BOUND. ISZ T3FPE ISZ T2FPE DONE WITH ALL DIMENSIONS, THIS FORMAL ? JMP FPE08 NO. JUST KEEP TRUCKIN' SKP * DONE WITH ALL DIMENSIONS OF THIS FORMAL. * COMPUTE THE ADDRESS OF ELEMENT (0,...,0). * LDA T5FPE UNLESS USING .EMAP, SZA JMP FPE04 INWHICHCASE THAT'S ALL WE DO. * JSB SAR.F YES. COMPUTE ADDR OF (0,...,0) LDA T7FPE DOING .SRES OR .DRES STUFF ? SZA JMP FPE15 YES. GO PUT IN TABLE. * JSB SCG.F LOAD CORRECTION. JSB ABB.F FORM A/B BIT. ADA ADAII ISSUE 'ADA PARAM' WITHOUT THE LDB T1FPE,I INDIRECT BIT. JSB SOA.F ISZ F.PTF (USE 'PERMANENT' TEMP) JSB SRT.F STORE THAT. (IT'S AN INTEGER) DEF F.S1T,I JSB PO1.F POP THE TEMP OFF, LDB T1FPE,I AND INSERT IN THE 'DIM' ENTRY. INB LDB B,I ADB K2 STA B,I JMP FPE04 ON TO THE NEXT FORMAL... * FPE15 LDA .DST PUT THE RESOLVED .DMAP ADDRESS JSB OAI.F IN THE .DMAP TABLE. LDA T1FPE,I STA F.A GET THE BCOMI ADDR. JSB FA.F LDA F.AF HERE IT IS. ADA K3 NEED WORD 3. LDB A,I (B) = F.A OF TEMP. JSB DEF.F FINISH DST WITH DEF TO TEMP. JMP FPE04 ALL DONE! SKP * IF STATEMENT FUNCTION(S), JUMP AROUND. * FPE20 LDA T0FPE DOING ENTRY FOR PROGRAM UNIT ? LDB F.FES AND THERE WERE STATEMENT FUNCTIONS ? CPA F.SBF SSB PROGRAM. STMT FCT ? JMP FPE22 NOT PROG OR NO STMT FCT. * LDA JMPI ISSUE JUMP AROUND. JSB SOA.F * FPE22 LDB T0FPE IF PROGRAM NAME, STB F.A SZB JSB FA.F THEN RESTORE ASSIGNS. JSB VS1.F VOID STACK 1. JMP FPE.F,I EXIT. * .ENTR ABS 73 .TBL OFFSET OF .ENTR .ENTP ABS 86 .ENTP JSBI OCT 16000 ADAII OCT 142000 LDAII OCT 162000 LDAI OCT 062000 STAI OCT 072000 B40K OCT 040000 TWPE EQU B40K F.IM = TWPE. BCOMI OCT 7000 F.AT = BCOMI T0FPE NOP F.A OF SUB/FCT. T1FPE NOP STACK PTR FOR SCANNING LIST. T2FPE NOP COUNTER OF # DIMENSIONS. T3FPE NOP BOUNDS TABLE POINTER. T4FPE NOP INT DBI AS REQUIRED DIMENSION TYPE. T5FPE NOP .EMAP USAGE FLAG. T6FPE NOP SAVED VALUE OF F.S1T T7FPE NOP EMA FLAG. KK01 OCT 100000 DBI EQU KK01 KM3 DEC -3 K3 DEC 3 K5 DEC 5 K31 DEC 31 OPCODE FOR PROGRAM ENTRY. K48 DEC 48 .FIOI ABS 262 SKP * ******************************************** * * SUBROUTINE OR ARRAY CALL GENERATION CODE * * ******************************************** SPC 1 * FIRST, FLAG THE NAME SO WE CAN COUNT PARAMS. * SAL.F NOP LDA F.S1T,I JUST SET SIGN. IOR KK01 STA F.S1T,I JMP SAL.F,I DONE ! * * AT END, PROCESS PARAMS & GENERATE CODE. * SAR.F NOP CLB,INB STB PNUM AT LEAST THE SUBPROG NAME ON STACK CLB NO ALTERNATE RETURNS YET. STB ANAR LDB F.S1T SUAR0 LDA B,I (A) = STACK CONTENTS SSA IF (A) <0, JMP SUAR1 NAME OF SUBPROG ON STACK FOUND. * SZA IF REGISTER, CPA K1 JMP SUAR5 THEN NOT STMT #. * LDA A,I ELSE CHECK IT: FIRST WORD A.T. ENTRY. AND KK04 F.IM & F.IU & F.NT SZA,RSS STMT # ? (F.IM=0, F.IU=0, F.NT=0) JMP SUAR6 YES. * LDA B,I NO. GET F.IM & F.AT . LDA A,I AND B177K CPA TWSTR IF F.IM=TWPE & F.AT=STR-ABS, JMP SUAR6 THEN MUST BE DO STATEMENT LABEL. * SUAR5 ISZ PNUM NOT STMT #. COUNT THE NORMAL PARAMETER. JMP SUAR7 * SUAR6 ISZ ANAR STMT #. COUNT THE ALTERNATE RETURN. SUAR7 INB ADVANCE IN STACK. JMP SUAR0 CONTINUE SCANNING PARAMS. * SUAR1 STB S1LOC REMEMBER STACK POS OF SUB/ARR NAME. STB S2LOC REMEMBER HOW MUCH TO POP LATER. ELA,CLE,ERA WIPE OFF SIGN BIT. STA B,I REPLACE ON STACK. STA F.A SET F.A TO POINT TO NAME JSB FA.F FETCH ASSIGNS FOR SUB OR ARR. LDA F.IU CPA ARR NAME IS ARRAY? JMP SUAR2 YES. * JSB JTS.F NO, GEN. CALL TO SUBPROG. RSS SUAR2 JSB AEA.F GEN. ARRAY ELEMENT ADDR CALC. * SUAR3 LDA F.S1T POP OPERANDS. THERE YET ? CPA S2LOC JMP SUAR4 YES. JSB PO1.F NO. KEEP GOING. JMP SUAR3 SUAR4 JSB P1P.F POP SUB NAME, PUSH RESULT. JMP SAR.F,I RETURN SPC 1 S2LOC NOP ADDR SUBR NAME ON STACK. PNUM NOP NUMBER OF PARAMETER TO SUB OR ARRAY. ANAR NOP ACTUAL NUMBER OF ALTERNATE RETURNS. B177K OCT 177000 MASK FOR F.IM & F.AT TWSTR OCT 042000 F.IM=TWPE & F.AT=STR-ABS. SPC 2 * ********************** * * JUMP TO SUBPROGRAM * * ********************** SPC 1 JTS.F NOP LDA F.NC INTRINSIC ? CPA B40 RSS (YES) JMP JTS05 NO. * LDB S1LOC,I (A)=F.A OF SUB. GET DOT ORDINAL. INB LDB B,I ADDR OF INTRINSICS TABLE. LDA B,I FIRST WORD OF IT. SSA,RSS IS IT A SPECIAL ? JMP JTS20 NO. GO DO NORMAL INTRINSIC. * AND B777 YES. GET DOT ORDINAL, STA T1JTS AND SAVE. JSB SBR.F SAVE REGISTERS BUT NOT MAPS. LDB T1JTS (B) = DOT FUNCTION ORDINAL, JSB ODF.F ISSUE IT. JMP JTS09 * JTS05 JSB SMT.F SAVE MAPPED DATA FIRST, JSB SBR.F THEN OTHER REGISTERS. LDA JSBI LDB S1LOC,I JSB SOA.F OUTPUT JSB TO SUBPROG NAME * * DECIDE WHETHER SUBROUTINE OR FUNCTION REF. * JTS09 LDA S1LOC,I FIRST, RESTORE ASSIGNS. STA F.A JSB FA.F LDA F.IM AND SAVE F.IM OF SUBPROG NAME STA T0JTS LDB F.TPX (B) = TYPE OF INPUT EXPRESSION. LDA S1LOC (A) = NAME ADDR ON STACK 1. INA IF NOTHING STACKED BELOW IT, CPA F.S1B INB,SZB AND WER'E PROCESSING SUBROUTINE CALL, CCB NO. (B)=-1 AS FUNCTION FLAG. * * CHECK FOR STATEMENT FCT. IF SO, CAN'T BE SUBR. * LDA F.AT CPA REL WELL ? JMP JTS04 YES. GO CHECK. * SZB NO. FUNCTION OR SUBROUTINE ? JMP JTS03 FUNCTION. JMP JTS01 SUBROUTINE. * JTS04 SZB,RSS STMT FCT. CALLED AS SUBROUTINE ? JMP JTS58 YES. ERROR. SKP * CHECK TYPE & NUMBER OF STMT FCT ARGS. * LDA S1LOC,I (A) = F.A OF STMT FCT. DLD A,I (B) = ADDR OF STMT FCT A.T. EXTENSION. DLD B,I (B) = F.A OF FIRST FORMAL. LDA S1LOC (A) = INITIAL STACK POINTER. JMP JTS10 START IN MIDDLE. * JTS08 LDA T1JTS,I GET F.IU OF ACTUAL. LDA A,I AND B600 CPA SUB JUST CAN'T BE SUBROUTINE. JMP JTS60 THAT'S TOO BAD... * LDB T1JTS,I GET F.IM OF ACTUAL. JSB FT.F (IN CASE ADDR TEMP) STA T3JTS SAVE THAT, LDA T2JTS,I AND GET F.IM OF FORMAL. AND B170K CPA T3JTS SAME ? RSS YES. JMP JTS13 NO. ERROR. * CCB MOVE ON. GET LINK TO NEXT FORMAL. ADB T2JTS LDB B,I (B) = F.A NEXT FORMAL. LDA T1JTS JTS10 CPA F.S1T OUT OF ACTUALS ? JMP JTS11 YES. * ADA KM1 NO. MOVE ON TO NEXT. STA T1JTS SZB,RSS OUT OF FORMALS ? JMP JTS59 YES. TOO MANY ACTUALS. * STB T2JTS NO. SET UP F.A OF THIS ONE. JMP JTS08 GO COMPARE THEM. * JTS11 SZB,RSS OUT OF ACTUALS. HOW 'BOUT FORMALS ? JMP JTS03 YUP. MATCHES. * JTS13 LDA K60 WARNING 60: ARGUMENT MODE ERROR. JSB WAR.F ISSUE THE WARNING. SKP * FUNCTION. SEE IF RESULT IN MEM. * JTS03 LDA ANAR BUT FIRST, MAKE SURE LDB F.NC THAT THERE ARE NOT ALTERNATE CPB B40 RETURN, EXCEPT FOR INTRINSICS. JMP JTS31 NAMELY EXEC, REIO & XLUEX. * SZA NOT ONE OF THEM. MUST NOT HAVE JMP JTS58 ALTERNATE RETURNS. * JTS31 LDA T0JTS ANALYZE RESULT TYPE. STA F.RTP (FOR TAS.F) JSB MIM.F SSB,RSS REGISTER DATA ? JMP JTS02 YES. NO HIDDEN PARAMETER. * CLA CALLS TO DBL OR CPX FUNCTIONS LDB PNUM INB JSB OZ.F OUTPUT DEF *+N+2 LDB S1LOC GET LOCATION OF NEXT OPERAND INB JSB TAS.F ALLOCATE DBL OR CPX RESULT TEMP IF NEEDED LDB F.RES OUTPUT DEF TO RESULT. JSB DEF.F JMP JTS07 DO DO THE DEF'S. * JTS01 LDA F.NC SUBROUTINE. IF SPECIAL INTRINSIC, CPA B40 THEN CAN BE FUNCTION TOO. JMP JTS02 * LDB F.R ELSE MUST BE STRICTLY USED AS SUB. LDA K58 SZB JSB WAR.F THEN WARNING FOR USING AS SUBROUTINE. * JTS02 CLA REGISTER DATA OR SUBROUTINE. STA F.RES SET RESULT = (A) / (A,B) LDB PNUM JSB OZ.F OUTPUT DEF *+N+1 * * PRODUCE THE DEFS TO THE ACTUAL PARAMETERS. * JTS07 LDB S1LOC OUTPUT ARGUMENT DEFS CPB F.S1T ALREADY DONE LAST ONE ? JMP JTS18 YES. DONE. * ADB KM1 STB S1LOC POINTS TO NEXT ARG IN STACK LDB B,I SEE IF STATEMENT #. LDA B,I AND KK04 F.IM & F.IU & F.NT SZA,RSS IF ALL ZERO, JMP JTS07 THEN STATEMENT #: SKIP. * LDA B,I DITTO FOR END-OF-LOOP TWPE ENTRIES. AND B177K CPA TWSTR JMP JTS07 * LDA B,I SEE IF IT'S AN INTRINSIC. AND B7740 F.AT, F.IU, F.NC CPA B2240 F.AT=STRAB, F.IU=SUB, F.NC=1. JMP JTS16 YES. SPECIAL. * JSB DEF.F NO. ORDINARY DEF. JMP JTS07 * JTS16 INB INTRINSIC. GET TABLE ADDR. LDB B,I (B)=FWA INTRINSIC TABLE. LDA B,I A<8:0> = DOT FUNCTION ORDINAL. AND B777 ISOLATE IT, SWP PUT IN (B) FOR ODD.F, JSB ODD.F AND OUTPUT DEF TO DOT FUNCTION. JMP JTS07 * JTS18 LDA T0JTS STA F.RTP F.RTP = TYPE OF FUNTION RESULT JSB SRS.F SET UP REGISTER RESULT, IF ANY. DEF F.RES LDA ANAR ANY ALTERNATE RETURNS ? SZA,RSS JMP JTS.F,I NO. DONE. SKP * HANDLE SUBROUTINE ALTERNATE RETURNS. * LDA S2LOC,I SEE IF SPECIAL INTRINSIC. LDA A,I AND B140 STA T3JTS T3JTS=0 IF NOT SPECIAL. LDB ANAR (B=# ALT RTNS) CPA B40 RSS (YES) JMP JTS44 NO. GO SEE IF LONG OR SHORT FORM. * LDA K12 (ERROR NUMBER) CPB K1 SPECIAL. EXACTLY ONE ALTERNATE RTN ? RSS (YES) JSB WAR.F NO. ERROR. * LDA JMPI SET UP T3JTS TO USE 'JMP'S. JMP JTS45 * JTS44 ADB KM3 NOT SPECIAL. MORE THAN TWO ALT RTNS ? SSB JMP JTS41 NO. SKIP HEADER CODE. * LDB .ARTN YES. ISSUE: JSB ODF.F 'JSB .ARTN' LDB ANAR INB & 'DEF *+N+1' CLA JSB OZ.F JTS45 STA T3JTS SET UP T3JTS TO DO 'DEF'S. * JTS41 LDA S2LOC SET UP LOOP THRU PARAMS. STA S1LOC CLA INITIALIZE RETURN NUMBER. STA T2JTS JTS42 LDB S1LOC DONE LAST ONE ? CPB F.S1T JMP JTS.F,I YES. DONE. * ADB KM1 NO. ADVANCE TO NEXT. STB S1LOC LDB B,I SEE IF STMT #. LDA B,I AND KK04 F.IM & F.IU & F.NT SZA,RSS IF ALL ZERO, STMT #. JMP JTS46 YES. DO IT. * LDA B,I NO. IF F.IM=TWPE & F.AT=STR-ABS, AND B177K CPA TWSTR RSS THEN DO STMT LABEL, STILL STMT #. JMP JTS42 ELSE NOT STMT #. * JTS46 LDB ANAR WHICH TYPE ARE WE DOING ? ADB KM3 LDA T3JTS SSB IF LONG FORM: MANY RETURN, SZA OR SPECIAL INTRINSIC, JMP JTS43 THEN DO 'DEF' OR 'JMP'. * ISZ T2JTS SHORT FORM. BUMP COUNTER. LDA T2JTS AND FORM CONSTANT FROM IT. JSB EIC.F LDA CPAI DO 'CPA COUNTER' JSB OA.F TO SEE IF IT'S THE RIGHT VALUE. LDA JMPI NOW DO 'JMP STMT#' JTS43 LDB S1LOC,I JSB SOA.F DEF OR JMP. JMP JTS42 GO FOR MORE. * K12 DEC 12 KK04 OCT 170601 MASK FOR F.IM & F.IU & F.NT .ARTN ABS 87 CPAI OCT 52000 JMPI OCT 26000 SKP * INTRINSIC FUNCTION. VERIFY FCT CALL, ARG COUNT. * JTS20 STB T0JTS SAVE ADDR OF INTRINSIC TABLE. LDA F.TPX IN SUBR CALL IF F.TPX=-1. LDB S1LOC AND NOTHING ELSE STACKED UP. INB CPB F.S1B INA,SZA WELL ? JMP JTS22 NO, FUNCTION REF, O.K. * JTS58 LDA K58 INTRINCIC USED AS SUBROUTINE. JSB ER.F JTS59 LDA K59 INCORRECT # OF ARGS. JSB ER.F JTS60 LDA K60 INCORRECT TYPE. JSB ER.F * JTS22 LDA T0JTS,I GET EXPECTED PARAM COUNT. ALF,RAR AND K7 (A)=EXPECTED COUNT. INA COMPARE TO PNUM, WHICH IS COUNT+1. CPA PNUM WELL ? JMP JTS23 MATCHES. * CCB NO. BUT IF PNUM > 1, ADB PNUM (SO COUNT > 0), CPA K4 AND VARIABLE NUMBER ALLOWED, SZB,RSS THEN ALLOW IT ANYWAY. JMP JTS59 ELSE ERROR. * * SCAN LIST TO SEE DETERMINE TYPE. ALLOW * MIXED INTEGER*2 AND INTEGER*4. * JTS23 CPA K1 ZERO-ARGUMENT INTRINSIC ? JMP JTS25 YES. * LDB F.S1T,I NO. GET F.IM OF LAST PARAM. JSB FT.F STA T1JTS SAVE THAT. CLA T2JTS = MIXED MODE FLAG. STA T2JTS LDB F.S1T T3JTS = STACK ADDR. STB T3JTS JTS24 LDA T3JTS,I F.A OF CURRENT ITEM. SZA REGISTER ? CPA K1 JMP JTS32 YES. DATA. * LDA A,I NO. CHECK OUT THE USAGE. AND B600 (A)=F.IU CPA SUB IS IT A SUBROUTINE ? JMP JTS60 YES. CAN'T DO THAT. * JTS32 ISZ T3JTS ON TO THE NEXT ITEM. LDB T3JTS CPB S1LOC IS THAT ALL ? JMP JTS25 (YES.) * LDB B,I (B)=F.A OF NEW ITEM, JSB FT.F GET ITS TYPE. CPA T1JTS SAME ? JMP JTS24 YES. GO ON. * ALF NO. MAYBE STILL O.K.; COMBINE IOR T1JTS WITH TYPE SO FAR, AND CPA KK02 SEE IF: INT/DBI ? RSS YES. CPA KK03 OR: DBI/INT ? RSS YES. JMP JTS60 NO. MIXED TYPES. ERROR. * ISZ T2JTS MIXED INT/DBI, SET THE FLAG. JMP JTS24 AND GO ON. * * IF MIXED INT/DBI, CONVERT ALL TO DBI. * JTS25 LDA T2JTS WELL ? SZA,RSS JMP JTS27 ALL SAME. * LDA T0JTS,I MIXED. CHECK FOR EXCEPTION: AND B777 (A)=FORMAL PARAM VERSION. CPA %ISH ISHFT (INT*2) RSS CPA %JSH ISHFT (INT*4) JMP JTS27 IF EITHER, LEAVE IT MIXED. * LDA DBI NEITHER. ELSE SET RESULT TO DOUBLE INTEGER. STA F.RTP ALSO FOR CON.F STA T1JTS LDB F.S1T ENTER WITH (B)=STACK ADDR. JTS26 STB T2JTS CONVERT ONE TO DBI IF NOT ALREADY. JSB CON.F LDB T2JTS BUMP TO NEXT ONE. INB CPB S1LOC AT FCT NAME ? RSS YES, DONE. JMP JTS26 NO. GO ON. * * SEARCH INTRINSICS TABLE FOR FUNCTION * WITH MATCHING ARGUMENT TYPE. * JTS27 LDA T0JTS,I GET NUMBER OF ENTRIES. LSR 9 AND B17 CMA,INA SET UP COUNT. STA T2JTS JTS28 ISZ T0JTS ON TO NEXT ENTRY. LDA T0JTS,I TYPE WORD. ALF,ALF ALIGN, AND B170K AND EXTRACT ARG TYPE. CPA T1JTS RIGHT ONE ? JMP JTS29 YES. * ISZ T0JTS NO. SKIP IT, ISZ T2JTS AND BUMP COUNT. JMP JTS28 MORE TO CHECK. JMP JTS60 DIDN'T FIND IT, ERROR. * * GOT IT. CALL THE FUNCTION. * JTS29 LDB T0JTS,I FIRST, EXTRACT RESULT TYPE. RRR 4 AND B170K STA F.RTP JSB MIM.F REGISTER OR MEMORY RESULT ? SSB,RSS JMP JTS30 REGISTER. * LDB S1LOC MEMORY. TRY TO SHORT-CIRCUIT INB A DFER OR CFER. B=STK ADDR NXT OPND, JSB TAS.F USE TAS.F TO LOOK AHEAD, SET F.RES . JTS30 ISZ T0JTS GET THE DOT FUNCTION WORD. LDA T0JTS,I CCB SET (B) TO NUMBER OF PARAMS. ADB PNUM JSB GDF.F GENERATE THE CALL. JMP JTS.F,I CALLER MUST CLEAN UP STACK. SPC 2 T0JTS NOP T1JTS NOP T2JTS NOP T3JTS NOP B7000 OCT 7000 F.AT MASK. REL OCT 1000 F.AT=REL. B7740 OCT 7740 F.AT, F.IU, F.NC MASK. B2240 OCT 2240 F.AT=STRAB, F.IU=SUB, F.NC=1. B170K OCT 170000 F.IM MASK. B40 OCT 40 F.NC=1, INTRINSIC. KK02 OCT 010010 INT & DBI. KK03 OCT 100001 DBI & INT. B17 OCT 17 KM2 DEC -2 KM1 DEC -1 K1 DEC 1 K2 DEC 2 K7 DEC 7 K58 DEC 58 K59 DEC 59 K60 DEC 60 %ISH DEC 256 %JSH DEC 257 SKP * ************************************************ * * ROUTINE TO GEN .EMAP CALL FOR SIMPLE VARABLE * * ************************************************ * * ENTRY: F.A = A.T. PTR IN QUESTION. * EXIT: (A)=(B)=F.A=F.RES = (MAPPED) A.T. PTR * MAP.F NOP LDA F.A SET DEFAULT STA F.RES RESULT I.E. IT IS NOT IN EMA STA T1MAP ALSO SAVE IN CASE MAPPING. JSB EA?.F IS IT IN EA?.F JMP MAP00 NO EXIT * JSB SMT.F YES. SAVE ANYTHING CURRENTLY MAPPED. LDA T1MAP RESTORE F.A STA F.A JSB FA.F & ASSIGNS. CLB,INB STB PNUM SET NUMBER OF VARIABLES FOR AEA.F CLB SET NO. OF DIMS. STB F.ND SET NUMBER OF DIMENSIONS JSB AEA.F AEA DOES THE REST MAP00 LDA F.RES LOAD RESULT TO (A) LDB A AND (B), STA F.A AND SET F.A JMP MAP.F,I RETURN (RESULT IS IN REG) AND PTR. IN A * T1MAP NOP TO SAVE F.A OVER SMT.F CALL. SPC 2 * ***************************************************** * * ROUTINE TO TEST IF F.A POINTS AT AND EMA VARIABLE * * ***************************************************** * * SKIPS IF (F.A) IN EMA. (A) PRESERVED. (B) SET TO F.A * EA?.F NOP LDB F.A IF IN REGISTER, SZB CPB K1 JMP EA?.F,I THEN NOT IN EMA. * STA T1EA? JSB FA.F FETCH ASSIGNS LDA F.EM I.E., IS F.EM SET ? SZA ISZ EA?.F YES STEP THE RETURN TO INDICAT EMA LDA T1EA? (A) = ORIGINAL VALUE. LDB F.A (B) = F.A JMP EA?.F,I RETURN P+1 NOT EMA, P+2 EMA * T1EA? NOP SKP * ************************* * * ARRAY ELEMENT ADDRESS * * ************************* SPC 1 K25 DEC 25 K38 DEC 38 SUB OCT 200 F.IU=1 (SUBROUTINE) SPC 1 * INITIALIZE: T1AEA = F.A OF ARRAY. * T3AEA = ADDR F.A OF LAST U.B. + 1 * T6AEA = F.IM OF ARRAY. * T7AEA = # WDS PER ELEMENT. * TBAEA = DBL INT SUBSCR FLAG. * VERIFY # SUBS. * AEA.F NOP LDA F.IM T6AEA = ARRAY F.IM STA T6AEA LDA F.A T1AEA = ARRAY F.A STA T1AEA LDA F.DIS TBAEA = ARRAY F.DIS STA TBAEA LDA F.LUB ADDR OF BOUNDS TABLE. ADA F.ND + # SUBS, TWICE. ADA F.ND STA T2AEA T2AEA=T3AEA = LWA+1 BOUNDS TABLE. STA T3AEA LDB F.D0+1 WDS / ELEMENT. LDA F.ND ZERO-DIM ? SZA,RSS CCB YES, SET TO -1 STB T7AEA T7AEA = # WDS / ELEMENT. LDB F.ND # DIMENSIONS. CMB -(#DIM)-1 ADB PNUM +(#SUBS)+1 LDA K38 SZB #SUBS = #DIM ? JSB ER.F ERR: # SUBS .NE. # DIMENSIONS * * IF ZERO DIM, MUST BE EMA. * CPB F.ND F.ND=0 ? (B=0) JMP AEA20 YES. * * SET UP BACKWARD LOOP THRU SUBSCRIPTS TO: * 1) CONVERT SUBSCRIPTS TO INTEGER/DBL INT. * 2) CHECK IF ALL ARE = LOWER BOUND. * STB T8AEA CLEAR 'FIRST ELEMENT' FLAG. LDA INT SET UP TYPE TO CONVERT TO. LDB F.DIS DOUBLE INTEGER SUBSCRIPTING ? SZB LDA DBI YES. CONVERT TO DBI, ELSE TO INT. STA T9AEA T9AEA = SUBSCRIPT TYPE TO USE. LDB F.S1T T4AEA = SUBSCRIPT POINTER. STB T4AEA SKP * CONVERT TO INTEGER. * AEA15 LDB B,I F.A OF SUBSCRIPT. SZB IF SUBSCRIPT IS IN REGISTERS, CPB K1 JMP AEA17 GO CHECK TYPE. STB F.A OTHERWISE MAKE SURE IT IS JSB FA.F NOT A SUBPROGRAM NAME. LDA K25 LDB F.IU CPB SUB JSB ER.F AEA17 LDA T9AEA IF REQ'D, CONVERT TO INT/DBI. STA F.RTP LDB T4AEA LOCATION OF CONVERSION SOURCE JSB CON.F CONVERT IT TO INTEGER (IF NOT ALREADY). * * IF SUBS. # L.B., CLEAR 'FIRST ELEMENT' FLAG. * LDB T3AEA BACK UP TO CURRENT LOWER BOUND. ADB KM2 STB T3AEA LDB B,I LOWER BOUND F.A JSB GCD.F IS IT CONSTANT ? JMP AEA18 NO. NOT FIRST ELEMENT. * CMAI CMA YES. IT WAS NEGATED; RESTORE IT. CMB,INB,SZB,RSS INA .DST DST T0AEA SAVE IT FOR NOW. LDB T4AEA,I SUBSCRIPT F.A JSB GCD.F IS IT CONSTANT ? JMP AEA18 NO. THEN NOT FIRST ELEMENT. * CPA T0AEA IS IT THE SAME ? RSS JMP AEA18 NO. * CPB T0AEA+1 RSS YES. LEAVE FLAG ALONE. AEA18 ISZ T8AEA TEST FAILS. NOT FIRST ELEMENT. * * END LOOP. * ISZ T4AEA NEXT SUBSCRIPT. LDB T4AEA CPB S1LOC DONE ? RSS YES. JMP AEA15 NO, CONTINUE. SKP * IF ALL SUBSCRIPTS = L.B., TREAT AS SIMPLE. * LDA T8AEA IS FLAG STILL SET ? LDB F.COP AND NOT IN PREAMBLE ? SZA,RSS CPB K31 PREAMBLE: F.COP=31. JMP AEA05 NO. * LDA T1AEA YES. TREAT AS SIMPLE. LDB T6AEA (A)=F.A, (B)=F.IM JMP AEA28 * * IF EMA, DONE VIA SUBROUTINE/MICROCODE. * AEA05 LDA T1AEA RESTORE F.A, STA F.A JSB EA?.F AND SEE IF EMA. RSS NO. GO ON. JMP AEA20 YES. PROCESS EMA. * * LOOP THRU DIMENSIONS TO * COMPUTE CULULATIVE PRODUCTS OF DIMENSIONS. * LDA DTBAE T9AEA = CUMULATIVE DIMENSION POINTER. STA T9AEA AEA06 ISZ T3AEA SKIP LOWER BOUND. LDB T3AEA,I F.A OF DIMENSION SIZE (WAS U.B.) ISZ T3AEA JSB CFC.F CONSTANT ? CLA (NO, SET PRODUCT = 0) MPY T9AEA,I MULTIPLY BY OLD PRODUCT. ISZ T9AEA SET NEW CUM. PROD. STA T9AEA,I * * END LOOP. * LDB T3AEA SEE IF WE'RE DONE. CPB T2AEA I.E., BACK TO END OF DIMENSIONS. RSS YUP. JMP AEA06 NO, CONTINUE. * * INITIALIZE SUBSCRIPT COMPUTATION LOOP. * LDA F.S1T T4AEA = SUBSCRIPT PTR. STA T4AEA ISZ T3AEA T3AEA = DIM SIZE PTR. (LWA+2 HERE) CLA,INA MULTIPLIER = 1. STA T8AEA CLA OFFSET = 0. STA TAAEA JSB EIC.F VALUE = 0. JSB PU1.F ISZ PNUM REMEMBER TO POP LATER. SKP * TOP OF REVERSE LOOP. BACK UP POINTERS. * AEA09 LDA T3AEA T3AEA = DIM PTR. ADA KM2 STA T3AEA CCA T9AEA = CUMULATIVE PRODUCT PTR. ADA T9AEA STA T9AEA * * MULTIPLY BY DIMENSION (EXCEPT 1ST LOOP) * LDA T4AEA 1ST LOOP ? CPA F.S1N JMP AEA14 YES, SKIP IT. LDB T3AEA,I NO. CONSTANT ? JSB CFC.F JMP AEA13 NO. MPY T8AEA YES. UPDATE MULTIPLIER. STA T8AEA JMP AEA14 AEA13 JSB MVM.F NOT CONST: MULT VALUE BY MULTIPLIER, LDA T3AEA,I THEN BY DIMENSION. JSB PU1.F JSB MPY.F * * IF SUBSCRIPT & PREV. DIM CONSTANT, PRE-COMPUTE. * AEA14 LDB T4AEA,I SUB CONST ? JSB CFC.F JMP AEA12 NO. * LDB T9AEA,I ALL PREV. DIM CONSTANT ? SZB,RSS (IF SO, PRODUCT IS NON-ZERO) JMP AEA12 NO. SOME VAR DIM SOMEWHERE. * MPY B YES. * CUMULATIVE PRODUCT. ADA TAAEA ADD TO OFFSET. STA TAAEA JMP AEA16 DONE HERE. * * ADD SUBSCRIPT. END LOOP. * AEA12 JSB MVM.F FIRST, MULT VALUE BY MULTIPLIER. LDA T4AEA,I THEN ADD SUBSCRIPT. JSB PU1.F JSB ADD.F AEA16 ISZ T4AEA TO PREVIOUS SUBSCRIPT. LDA T9AEA IF JUST DID FIRST SUBSCRIPT, CPA DTBAE RSS DONE. JMP AEA09 ELSE LOOP. SKP * MULTIPLY OFFSET*NW, VALUE*NW*MULTIPLIER. * LDA TAAEA OFFSET. MPY T7AEA STA TAAEA LDA T8AEA MULTIPLIER. MPY T7AEA *NW JSB EIC.F *VALUE. JSB PU1.F JSB MPY.F * * COMPUTE ADDRESS FOR NON-FORMALS. * LDB T1AEA SET UP F.A, STB F.A JSB FA.F AND FETCH ASSIGNS. LDA F.AT FORMAL PARAMETER ? CPA DUM JMP AEA30 YES. DIFFERENT. * CCB GET THE LOWER BOUND CORRECTION: ADB F.LUB IN WORD BEFORE FIRST LOWER BOUND. LDB B,I HERE'S THE F.A ADB K2 INDEX TO THE VALUE, LDA B,I AND GET IT. STA T0AEA SAVE LOWER-BOUND CORRECTION. LDB F.S1T,I SUBSCRIPT VALUE CONSTANT ? JSB CFC.F JMP AEA29 NO. * ADA TAAEA YES. ADD OFFSET. ADA T0AEA ADD LOWER-BOUND CORRECTION. LDB T1AEA ESTABLISH DATA WITH OFFSET ENTRY TO JSB EDO.F (ADDR) + (VALUE+OFFSET+CORRECTION) LDA F.A F.A OF ITEM. LDB T6AEA F.IM OF ITEM. JMP AEA28 CLEAN UP. * AEA29 LDA TAAEA ESTABLISH DEF TO (ADDR+OFFSET+CORRECTION) ADA T0AEA LOWER-BOUND-CORRECTION. LDB T1AEA JSB ESD.F LDA F.A ADD VALUE. JMP AEA31 SKP * COMPUTE ADDRESS FOR FORMAL PARAMETER. * AEA30 LDA TAAEA ADD OFFSET TO VALUE. JSB EIC.F JSB PU1.F JSB ADD.F LDA T1AEA GET ADDR F.A OF INA (ADDR + LOWER_BOUND_CORRECTION) LDA A,I (A)=F.A OF DIM. ADA K2 ADDR IN DIM ENTRY FOR THE F.A LDA A,I F.A OF THE DEF. SZA,RSS IS IT PROLOGUE CODE ? JMP AEA.F,I YES, COMPUTING THE DEF, NOT USING. * AEA31 STA T0AEA SAVE F.A OF DEF. JSB SCG.F LOAD VALUE. JSB ABB.F SET UP A/B BIT. ADA ADAI ADA/ADB LDB T0AEA ADD DEF. JSB SOA.F LDB F.RES RESULT IS AN ADDR IN (A) OR (B). JMP AEA24 SPC 1 ADAI OCT 42000 DUM OCT 5000 * S1LOC NOP .EMAP ABS 78 EMA ARRAY ELEMENT ADDRESS CALCULATER .ERES ABS 79 AS ABOVE BUT WITHOUT MAPPING. .DMAP ABS 88 DOUBLE INTEGER VERSIONS. .DRES ABS 89 .SMAP ABS 264 .SRES ABS 265 .ERR0 ABS 83 SKP * EMA. * AEA20 JSB SMT.F SINCE WIPING OUT MAPS, SAVE MAPPED DATA. JSB SBR.F AND REGISTERS, FOR THAT MATTER. LDA T7AEA IF ZERO-DIMENSION, SSA (I.E., T7AEA<0) JSB EAC.F AND CALL-BY-REFERENCE, RSS (NO) JMP AEA25 THEN USE ADDRESS DIRECTLY. * LDA TBAEA NO. SINGLE OR DOUBLE INTEGER SUBSCRIPTS ? SZA JMP AEA21 DOUBLE. GO USE .DMAP/.DRES * LDA F.CCW SINGLE. 'S' OPTION SET ? RAL SSA,RSS JMP AEA35 NO. USE .EMAP/.ERES * LDB .SRES YES. USE .SMAP/.SRES JSB EAC.F LDB .SMAP JMP AEA32 OUTPUT JSB & GO ON. * AEA21 LDB .DRES DOUBLE. ASSUME .DRES JSB EAC.F IF CALL-BY-VALUE, LDB .DMAP USE .DMAP AEA32 JSB ODF.F ISSUE THE CALL, JMP AEA26 AND SKIP THE GARBAGE PARAMETERS. * AEA35 LDB .ERES SINGLE. ASSUME .ERES JSB EAC.F IF CALL-BY-VALUE, LDB .EMAP USE .EMAP JSB ODF.F SEND DOT FUNCTION CALL LDB PNUM COMPUTE THE DEF ERR RETURN ADDRESS ADB K2 *+NDIM+3 JSB OZ.F SEND IT LDA BMAX OUTPUT 77777B INSTEAD OF DEF TO EMA MASTER. JSB OAD.F AEA26 DLD T1AEA,I (B) = F.A OF THE DIM ENTRY (IF THERE) AND B600 GET F.IU CPA ARR ARRAY ? RSS JMP AEA36 NO. THEN (B) = F.A OF BCOMI ENTRY. * LDA T7AEA YES. USED AS ARRAY OR SIMPLE ITEM ? SSA,RSS JMP AEA36 ARRAY. USE (B) = F.A OF DIM ENTRY. * DLD B,I SIMPLE ITEM. INDEX TO THE BCOMI ENTRY. AEA36 JSB DEF.F LDA T7AEA GET ZERO-DIM FLAG. SSA IF ZERO-DIM CASE, JMP AEA23 GO SEND THE ERR0. * LDB F.S1T SET UP TO SEND STB T4AEA THE DEFS TO THE INDEXES AEA22 LDB T4AEA THE DEF'S TO THE INDEXES CPB S1LOC END OF LIST? JMP AEA23 YES GO WRAP IT UP * ISZ T4AEA SET IT FOR NEXT TIME LDB B,I GET THE A.T. POINTER JSB DEF.F SEND A DEF JMP AEA22 TRY AGAIN * AEA23 LDB .ERR0 NOW SEND A JSB ERR0 LDA F.CCW UNLESS 'S' OPTION, RAL,ELA (E=1 IFF 'S') LDA TBAEA OR DOUBLE INTEGER SUBSCRIPTS. SEZ,SZA,RSS WELL ? JSB ODF.F .EMAP/.ERES, ISSUE IT. (ERROR RETURN) CLB,INB SET FOR RESULT TO BE IN B-REG. JSB EAC.F CALL-BY-REF ? JMP AEA33 NO, SET UP AS ADDR & EXIT. * LDA DBI SET UP A-REG AS DOUBLE INTEGER. JSB SRS.F DEF K0 CLA F.RES=A. JMP AEA27 * AEA25 LDB T1AEA A.T. PTR INB GET DIM OR BCOM PTR LDB B,I LDA T1AEA,I CHECK IF ARRAY. AND B600 CPA ARR IF SO, INB,RSS SKIP THE DIM ENTRY RSS TO GET TO THE LDB B,I BCOM ENTRY. INB LOAD EMA OFFSET. LDA B,I A = LSB. STA F.A IN CASE FORMAL. STA F.IDI IN CASE NOT. LDA T1AEA,I CHECK FOR THAT. AND B7000 CPA DUM WELL ? JMP AEA34 YES. USE THE TEMP. * ADB K2 LDB B,I B = MSB. STB F.IDI+1 SET CONSTANT VALUE. LDA DBI SET UP DOUBLE INT JSB ESC.F JSB AI.F ENTER IN TABLE. AEA34 LDA F.A GET A.T. PTR FOR CONSTANT OR TEMP. AEA27 LDB DBI 2-WORD ADDRESS, CALL IT DOUBLE INT. AEA28 STA F.RES NOTE LOCATION OF IT. STB F.RTP JMP AEA.F,I RETURN. * AEA24 CLE,RSS NON-EMA ADDR. AEA33 CCE EMA ADDR. STB T0AEA REG #. STB F.RES LDA T6AEA F.IM CLB NO STACK. STO ADDR IN REG. JSB SRD.F SET UP REG INFO. DEF T0AEA JMP AEA.F,I EXIT. * SPC 1 T0AEA BSS 2 T1AEA NOP T2AEA NOP T3AEA NOP T4AEA NOP T6AEA NOP T7AEA NOP T8AEA NOP T9AEA NOP TAAEA NOP TBAEA NOP SAVED VALUE OF F.DIS INT OCT 10000 F.IM=1 INTEGER B600 OCT 600 F.IU MASK ARR EQU B600 F.IU=ARRAY K0 DEC 0 BMAX OCT 77777 VALUE TO FAKE OUT .EMAP DTBAE DEF *+1 ADDR OF CUMULATIVE PRODUCT TABLE. DEC 1 THE TABLE. BSS 3 (LAST WORD COMPUTED BUT NOT USED) SPC 2 MVM.F NOP MULTIPLY VALUE BY MULTIPLIER. LDA T8AEA MULTIPLIER. JSB EIC.F FORM CONSTANT. JSB PU1.F JSB MPY.F MULTIPLY. CLA,INA RESET MULTIPLIER. STA T8AEA JMP MVM.F,I EXIT. * * SKIP IF CURRENT USE IS CALL-BY-REFERENCE. * EAC.F NOP STB T1EAC SAVE (B). LDA F.COP IF DOING PROGRAM ENTRY, CPA K31 JMP EAC04 THEN BY REFERENCE. * LDB T7AEA IF EXPLICIT SUBSCRIPTS, SSB,RSS LDA F.LA1 THEN MUST LOOK AHEAD. CPA K59 DOES IT HAVE CALL-BY-REF FORM ? RSS (YES) JMP EAC05 NO. BY VALUE. * LDB F.S1T SEARCH FOR THE SUBROUTINE NAME. EAC01 INB NEXT ITEM. (CAN'T BE ON TOP) LDA B,I SSA,RSS MARKED ? JMP EAC01 NO. NOT THERE YET. * RAL,CLE,ERA YES. CLEAR THE SIGN BIT. LDA A,I FIRST WORD TABLE ENTRY. STA T2EAC (SAVE FOR LATER) AND B600 SUBROUTINE ? CPA SUB RSS YES. GOT IT. JMP EAC01 NO. KEEP LOOKING. * LDA T2EAC YES. GET F.NC AND B140 CPA B40 INTRINSIC ? JMP EAC05 YES. BY VALUE. * LDA T2EAC NO. GET F.AT AND B7000 CPA REL F.AT=REL (STMT FCT) ? RSS YES. BY VALUE. (ELSE BY REF) EAC04 ISZ EAC.F BY REFERENCE. BUMP RETURN. EAC05 LDB T1EAC RESTORE (B). JMP EAC.F,I EXIT. * T1EAC NOP SAVED (B). T2EAC NOP 1ST WD OF ENTRY. B140 OCT 140 MASK FOR F.NC (INTRINSICS FLAGS) SKP * ****************************** * * GENERATE DOT FUNCTION CALL * * ****************************** SPC 1 * ENTRY: OPERAND(S) ON STACK, LAST OPERAND IS TOP-OF-STACK. * (A) = DOT FUNCTION INFORMATION: * BIT 15: CALL SPECIAL HANDLER, ADDR IN 14:0. * IF < 1000B, JUMP TABLE ORDINAL. * 14: REGISTERS PRESERVED BY FUNCTION. * 13: OPERAND(S) ALWAYS IN MEMORY. * 12: USE RETURN ADDRESS. * 11: ISSUE 'JSB ERR0' AFTER CALL. * 10: RESERVED. * 9: RESERVED. * 8-0: DOT FUNCTION ORDINAL, [0,511] . * * (B) = NUMBER OF OPERANDS. * * (F.RTP) = RESULT TYPE. * * (F.RES) = F.A OF RESULT, IF IN MEMORY. * * EXIT: (A) = (F.RES) = F.A OF RESULT. * REGISTER DATA UPDATED AS REQUIRED. * OPERANDS POPPED FROM STACK, BUT RESULT NOT PUSHED * BACK (IN CASE EXPLICIT FUNCTION CALL). * * NOTE: GDF.F ASSUMES THAT THE DOT FUNCTION CALLED DOES NOT * ALTER THE STATE OF THE MAPS. IF GDF.F IS TO BE USED * TO CALL SOMETHING WHICH DOES ALTER THE MAPS, THE * ROUTINE SMT.F SHOULD BE CALLED FIRST. SPC 1 * ENTRY. CHECK FOR SPECIAL CASE. * GDF.F NOP STA T1GDF SAVE DOT INFO. RAL,CLE,SLA,ERA SIGN SET ? (CLEAR IT) JMP GDF30 YES. SPECIAL CASE. * * * GET RESULT INFO. DEFAULT = REG. * STB T2GDF SAVE OPND COUNT. LDA F.RTP DETERMINE IF RESULT FITS IN REG. STA T7GDF (ALSO SAVE TYPE) JSB MIM.F (B): -1,NOT REG. 0,(A). 1,(A,B). STB T4GDF T4GDF = RESULT REGISTER INFO. CLA (A)=0, RESULT F.A IF IN REG. SSB,RSS RESULT IN REGISTER(S) ? JMP GDF09 YES. * JSB GRD.F NO. ADDRESS IN REGISTER ? DEF F.RES LDA B (A)=STACK ADDR OR NEGATIVE. XOR KK01 IF ADDR IN REG, (A)=INDIRECT TO STACK. SSA,RSS WELL ? LDA F.RES NO. (A)=ACTUAL F.A LDB T4GDF RESTORE (B). GDF09 STA T5GDF SAVE RESULT F.A SKP * STORE REGISTERS ONLY IF WE HAVE TO. * LDA T1GDF DOES THE FUNCTION UNDERSTAND REGISTERS ? RAL (BIT 14) SSA JMP GDF10 YES. ANALYZE RESULT REGISTERS, TOO. * JSB SBR.F NO. JUST STORE REGISTERS. (EMA: ADDR ONLY) JMP GDF15 THAT WAS EASY ! * GDF10 SSB RESULT IN REGISTERS ? JMP GDF15 NO. DON'T HAVE TO STORE AT ALL. * LDA F.S1T YES. MAKE ROOM FOR RESULT, BUT DON'T STORE ADA T2GDF OPERANDS IN REGISTERS. STA T3GDF SET UP TO SCAN OPERANDS. LDABI LDA B ACCUMULATE DATA IN (A). (FOR IOR) GDF11 LDB T3GDF DONE ? CPB F.S1T JMP GDF12 YES. * ADB KM1 NO. GO ON TO NEXT. STB T3GDF LDB B,I OPERAND. SZB,RSS IN (A) ? IOR K4 YES, FLAG SO ISN'T SAVED. CPB K1 IN (B) ? IOR K2 DITTO. (MAY DO TWICE! A+A) JMP GDF11 * GDF12 STA T3GDF SAVE FLAGS. RAR,RAR SAVE (A) ? SLA I.E., NO OPERAND IN (A) ? JMP GDF13 NO. OPERAND IN (A), LEAVE IT. * JSB SRT.F YES. SAVE (A). DEF K0 GDF13 CLA,INA IS B-REG PART OF (A,B) DATA ? CPA F.ACB WELL ? JMP GDF15 YES. DON'T HAVE TO SAVE THEN. * LDA T3GDF FLAGS. SLA,RSS IS (B) PART OF RESULT ? JMP GDF15 NO. DON'T SAVE. * RAR,SLA YES. IS IT AN OPERAND ? JMP GDF15 YES. DON'T SAVE. * JSB SRT.F SAVE (B). DEF K1 SKP * LOAD (FIRST) OPERAND IF REQUIRED. * GDF15 LDA T1GDF SHOULD WE ? RAL,RAL (BIT 13) SSA JMP GDF16 NO, USE DEF(S). * CCA YES. GET IT. ADA T2GDF ADA F.S1T LDB A,I (B) = F.A OF OPERAND. JSB LDA.F ALWAYS PASS IN (A) OR (A,B). * * ISSUE JSB AND OPTIONAL RETURN ADDR. * GDF16 LDA T1GDF ISSUE THE JSB. AND B777 ORDINAL: BITS 8:0. LDB A JSB ODF.F LDA T1GDF RETURN ADDRESS ? ALF,RAR (BIT 12) SSA,RSS JMP GDF17 NO. * LDB T2GDF YES. (B) SET UP FOR 'DEF *+N' INB DEF *+N+1 LDA T4GDF RESULT IN REGISTERS ? SSA (-1=N0, 0=A, 1=A,B) INB NO. DEF *+N+2 CLA A=0, DEF. JSB OZ.F RETURN ADDR. * * ISSUE DEF'S TO RESULT AND OPERANDS. * GDF17 LDB T5GDF SET UP RESULT ADDRESS. RBL,CLE,SLB,ERB (IF ON STACK, MAY HAVE BEEN STORED LDB B,I IN A TEMP, SO WANT UPDATED F.A) STB T5GDF & SAVE IT. LDA T4GDF RESULT IN REGISTERS ? SSA JSB DEF.F NO, ISSUE DEF TO RESULT. * LDA F.S1T SET UP LOOP THRU OPERANDS. ADA T2GDF (POINTS JUST BEFORE 1ST OPND) LDB T1GDF 1ST OPERAND IN REGISTER(S) ? RBL,RBL (BIT 13) SSB,RSS WELL ? ADA KM1 YES. SKIP IT. STA T3GDF SET UP LOOP. GDF19 LDA T3GDF DONE ? CPA F.S1T JMP GDF20 YES. * ADA KM1 NO. GO ON TO NEXT OPERAND. STA T3GDF LDB A,I ISSUE DEF TO IT. JSB DEF.F JMP GDF19 & LOOP. * * ISSUE OPTIONAL 'JSB ERR0'. * GDF20 LDA T1GDF IS OPTION SET ? ALF (BIT 11) LDB .ERR0 (ORDINAL OF ERR0) SSAI SSA WELL ? JSB ODF.F YES. DO IT. * * SET UP (F.RES) & (F.RTP). * LDA T5GDF JUST COPY RESULT ADDR. STA F.RES LDA T7GDF ALSO RESTORE RESULT TYPE. STA F.RTP * * POP OPERANDS & INVALIDATE ANY REGISTERS FOUND. * LDA T2GDF OPERAND COUNT. CMA,INA,SZA,RSS ANY ? JMP GDF22 NO. GO SET UP REG. * STA T3GDF ELSE T3GDF = -(COUNT) GDF21 JSB CRD.F IF OPERAND IN REGISTER, ZAP IT. DEF F.S1T,I JSB PO1.F POP OPERAND, ISZ T3GDF COUNT JMP GDF21 & LOOP. * * IF RESULT IN REGISTER(S), SET THAT UP. * GDF22 LDA T4GDF CAREFUL! MAY HAVE RESULT ADDRESS IN SSA REGISTER FOR DBL/RE8/CPX. JMP GDF23 SO IF ONE OF THOSE, DON'T CALL SRS.F * LDA F.RTP (A) = TYPE OF RESULT. JSB SRS.F REGISTER RESULT, UPDATE REG INFO. DEF F.RES GDF23 LDA F.RES RETURN (A) = RESULT F.A JMP GDF.F,I EXIT. SKP * BIT 15 SET, JUMP TO SPECIAL HANDLER. * GDF30 STA T1GDF (A) = LOW 15. AND B777 ARE THEY < 1000B ? CPA T1GDF RSS JMP T1GDF,I NO. IT'S AN ADDRESS, JUMP THERE. * LDB GDF.F (SAVE RTN ADDR, SO WE CAN MAKE A STB T6GDF RECURSIVE CALL TO GDF.F IF NEED BE) ADA DIITB INLINE INTRINSIC, INDEX LDA A,I INTO THE TABLE. JSB A,I PRODUCE CODE FOR THE OPERATOR. JSB PO1.F POP RESULT OFF STACK, GDF34 STA F.RES F.RES=RESULT. LDB A FIND TYPE. JSB FT.F STA F.RTP F.RTP=TYPE. JMP T6GDF,I EXIT USING SAVED ENTRY POINT. * B777 OCT 777 K4 DEC 4 DIITB DEF IITBL ADDR OF INLINE INTRINSICS TABLE. T1GDF NOP FLAGS & ORDINAL. T2GDF NOP # OPERANDS. T3GDF NOP POINTER/COUNTER. T4GDF NOP RESULT REGISTER FLAG. T5GDF NOP RESULT F.A T6GDF NOP SAVED ENTRY, FOR RECURSIVE CALLS. T7GDF NOP SAVED F.RTP * * INLINE INTRINSICS TABLE. * IITBL BSS 0 DEF CNVRT CONVERT TO RESULT TYPE. DEF ABS 1 DEF ABS 2 DEF ABS 3 DEF ISHFT 4 DEF AND.F IAND 5 DEF .OR.F IOR 6 DEF XOR.F IXOR 7 DEF NOT.F NOT 8 DEF NOT.F DNOT 9 DEF PCNT PCOUNT 10 * * ALL CONVERSIONS. * CNVRT NOP LDA F.RTP RESULT TYPE. JSB CTS.F CONVERT. JMP CNVRT,I SKP * INLINE ABSOLUTE VALUE, INT/DBI/REA. * ABS NOP LDB F.S1T,I CONSTANT ? JSB CFC.F JMP ABS01 NO. * SSA,RSS YES. POSITIVE OR NEGATIVE ? JMP ABS,I POSITIVE. JUST IDENTITY. JMP ABS02 NEGATIVE. NEGATE. (INT & DBI BOTH) * ABS01 LDB F.S1T,I NOT CONSTANT. LOAD IT. JSB LD.F JSB P1P.F MAKE STACK RIGHT FOR NEG.F JSB ABB.F FORM A/B BIT, ADA SSAI TO PICK SSA/SSB. JSB OAI.F OUTPUT TEST, ABS02 JSB NEG.F AND NEGATION. JMP ABS,I GO CLEAN UP. * * PCOUNT(). * PCNT NOP LDA F.RTP SAVE RESULT TYPE. STA T1GDF LDA F.SBF MAIN ? SZA JMP PCNT1 NO. * JSB EIC.F YES. FORM INT ZERO. STA F.RES HERE IT IS. JMP PCNT2 GO STACK & EXIT. * PCNT1 JSB AOR.F SUBPROG. ALLOCATE REGISTER. JSB ABB.F GET A/B BIT. IOR LDAI 'LDA TEMP' LDB F.PCT JSB SOA.F LDA CMAI 'CMA' JSB ORI.F JSB ABB.F A/B BIT. IOR ADAII 'ADA TEMP,I' LDB F.PCT JSB SOA.F LDA INT SET UP REGISTER AS INTEGER. JSB SRS.F DEF F.RES PCNT2 LDA F.RES STACK UP THE RESULT. JSB PU1.F LDA T1GDF SET UP F.RTP & CONVERT JSB CTS.F TO DBL INT IF NEED BE. JMP PCNT,I DONE. SKP * SHIFT FUNCTION. IF VARIABLE COUNT, CALL LIBRARY. * ISHFT NOP LDB F.S1T,I SHIFT COUNT CONSTANT ? JSB CFC.F RSS NO. JMP SHFT1 YES. * LDB F.S1N,I LIBRARY. GET DATA TYPE. JSB FT.F JSB CTS.F CONVERT SHIFT TO MATCH. LDB F.RTP SELECT: LDA .ISH .ISH FOR INT*2, CPB DBI LDA .JSH .JSH FOR INT*4 LDB K2 TWO PARAMETERS. JSB GDF.F RE-ENTER TO ISSUE CODE. JMP T6GDF,I EXIT. * * CONSTANT SHIFT COUNT. TEST FOR LARGE OR ZERO. * SHFT1 JSB PO1.F GET VALUE. LDBAI LDB A JSB GCD.F AS A DOUBLE INTEGER. HLT 12 (MUST BE CONST) SWP TEST FOR VERY LARGE. ASL 16 SOC JMP SHFT2 YES. VALUE = 0. (O=1) * STB T1GDF SAVE VALUE. JSB GT1.F GET TYPE OF DATA. LDB T1GDF RESTORE VALUE TO TEST. SSB MUST TEST ABS VALUE, CMB,INB SINCE 2'S COMP IS ASYMMETRIC. ASL 10 CHECK FOR [-31,+31]. LDA F.IM IF SINGLE INTEGER, CPA INT ADB B FURTHER LIMIT TO [-15,+15]. SHFT2 CLA (A,B)=0 IN CASE LARGE SHIFT. CLBI CLB SOC WELL ? JMP SHFT4 TOO BIG, RESULT = 0. * LDB T1GDF REASONABLE SHIFT. ZERO ? SZB,RSS JMP ISHFT,I YES. RESULT = DATA. * SSB,RSS TAKE -ABS OF SHIFT COUNT. CMB,INB STB T2GDF LDB F.S1T,I IS DATA CONSTANT ? JSB CFC.F JMP SHFT6 NO. SKP * BOTH SHIFT & DATA CONSTANT. FOLD. * LDA F.S1T,I GET VALUE. STA F.A JSB FC.F IN (F.IDI) OR (F.IDI,F.IDI+1) LDA T1GDF SET (E) ELA TO SIGN OF SHIFT COUNT. LDB F.IDI CONSTANT TO (B,A), OR (B) WITH A=0. LDA F.IDI+1 SHFT3 SEZ IF NEGATIVE, LSR 1 RIGHT SHIFT. SEZ,RSS IF POSITIVE, LSL 1 LEFT SHIFT. ISZ T2GDF COUNT JMP SHFT3 & LOOP. * * CONSTANT RESULT, SET IT UP. * SHFT4 STB F.IDI VALUE. STA F.IDI+1 JSB GT1.F SET UP F.RTP JSB PO1.F DISCARD OLD DATA. LDA F.RTP TYPE. JSB ESC.F JSB AI.F ENTER IN A.T. LDA F.A RESULT. JMP GDF34 * * SHIFT CONSTANT. CHECK DATA TYPE. * SHFT6 JSB GT1.F WHAT IS IT ? CPA DBI JMP SHFT9 DOUBLE INTEGER. * CLAI CLA SINGLE. CHECK SPECIAL CASES: LDB T1GDF CPB K1 LEFT 1 ? LDA CLELA CLE,ELA CPB K2 LEFT 2 ? LDA ALRRL ALR,RAL INB,SZB,RSS RIGHT 1 ? LDA CLERA CLE,ERA SZA,RSS ANY OF THE ABOVE ? JMP SHFT7 NO. NOT A SPECIAL CASE. * STA T1GDF YES. USE IT. JSB SCG.F LOAD DATA IN EITHER REG. LDA T1GDF ISSUE INSTRUCTION, JSB ORI.F MODIFIED BY REGISTER NUBMER. JMP ISHFT,I EXIT. * CLELA CLE,ELA ALRRL ALR,RAL CLERA CLE,ERA SKP * NORMAL SINGLE INTEGER. * SHFT7 SSB RIGHT OR LEFT ? JMP SHFT8 RIGHT. * LDB F.S1T,I LEFT: JSB LDA.F LDA X JSB SRT.F SAVE (B) DEF K1 LDA LSL00 LSL COUNT ADA T1GDF JMP SHF8A GO FINISH. * SHFT8 LDB F.S1T,I RIGHT: JSB LDB.F LDB X JSB SRT.F SAVE (A) DEF K0 LDA T1GDF LSR COUNT CMA,INA ADA LSR00 SHF8A JSB OAI.F JSB PO1.F DISCARD ORIGINAL DATA. JMP T6GDF,I DONE. SPC 2 R.REG EQU 040000B REGISTER BIT IN GDF.F CALL. .ISH ABS R.REG+254 FUNCTION INFO FOR SINGLE INT SHIFT. .JSH ABS R.REG+255 FOR DOUBLE INT. LSL00 LSL 16 LSR00 LSR 16 RRL00 RRL 16 RRR00 RRR 16 ANDI OCT 12000 K16 DEC 16 KM16 DEC -16 SPC 2 * SUBROUTINE TO PERFORM: 'AND =D 2**(16-COUNT)-1' * WHICH CLEARS THE UNUSED BITS IN DOUBLE INTEGER * SHIFTS OF 1-15 BITS. * SHM.F NOP LDA K16 FORM 16 - COUNT. ADA T2GDF ADA LSL00 LSL 16-COUNT. STA SHM01 WILL EXECUTE. CLA,INA 1. SHM01 ABS *-* LSL 16-COUNT: 2**(16-COUNT) ADA KM1 -1 JSB EIC.F MAKE THE CONSTANT. LDA ANDI 'AND' JSB OA.F JMP SHM.F,I EXIT. SKP * DOUBLE INTEGER DATA. IN-LINE. * SHFT9 JSB SCG.F LOAD INTO (A,B). LDB T1GDF TEST COUNT ? ASL 11 O=1 IFF 16-31 BITS, LEFT OR RIGHT. SSB WHICH ? JMP SHF11 RIGHT. * SOC LEFT. 1-15 OR 16-31 ? JMP SHF10 16-31. * JSB SHM.F 1-15 LEFT. CLEAR BITS SHIFTED OFF. LDA RRL00 RRL COUNT. ADA T1GDF JSB OAI.F JMP ISHFT,I EXIT. * SHF10 LDA LDABI 16-31 LEFT. JSB OAI.F 'LDA B' LDA T1GDF ADA KM16 ADA LSL00 'LSL COUNT-16' CPA LSL00 RSS (UNLESS COUNT = 16) JSB OAI.F LDA CLBI JSB OAI.F 'CLB' JMP ISHFT,I DONE. * SHF11 SOC RIGHT. 1-15 OR 16-31 ? JMP SHF12 16-31. * LDA T1GDF RIGHT 1-15. CMA,INA ADA RRR00 RRR COUNT. JSB OAI.F JSB SHM.F CLEAR BITS SHIFTED IN. JMP ISHFT,I * SHF12 LDA LDBAI RIGHT 16-31. JSB OAI.F 'LDB A' LDA T1GDF CMA,INA ADA KM16 ADA LSR00 'LSR COUNT-16' CPA LSR00 RSS (UNLESS COUNT = 16) JSB OAI.F LDA CLAI JSB OAI.F 'CLA' JMP ISHFT,I DONE. * END ASMB,Q,C HED CODE GENERATION FOR KEYWORD STATEMENTS. NAM KWC.F,8 92834-16003 REV.2030 800821 * *************************************************************** * (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-18003 * * RELOC: PART OF 92834-16003 * * 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) * 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.AF ADDRESS FIELD CURRENT F.A EXT F.AT ADDRESS TYPE OF CURREXT F.A EXT F.C OFFSET FOR CODE GEN. EXT F.CSL CHARACTER STRING LENGTH. EXT F.D0 ARRAY ELEMENT SIZE. EXT F.D DO TABLE POINTER. EXT F.DO LWA+1 DO TABLE. EXT F.DID ADDRESS OF F.IDI EXT F.EM EMA FLAG BIT IN A.T. ENTRY. EXT F.FRF FUNCTION RESULT F.A (NON-STMT FCT). EXT F.IDI INPUT ARRAY NON-NUMERIC EXT F.IM CURREXT ITEM MODE (REAL, COMPLEX,ECT.) EXT F.IU CURRENT ITEM USAGE. EXT F.L # ITEMS ON STACK 2 ?? EXT F.LO END OF A.T. + 1 EXT F.LUB ADDR OF LOWER/UPPER BOUNDS TABLE. EXT F.NAR NUMBER OF ALTERNATE RETURNS. EXT F.NC NAME CHANGE FLAG. EXT F.ND NUMBER OF DIMENSIONS EXT F.NIT NO-INLINE-TEMPS FLAG. EXT F.OFE DATA POOL OVERFLOW ENTRY. EXT F.REL SUB. PROG. RETURN LOCATION EXT F.RPL PROGRAM LOCATION COUNTER EXT F.S1B BOTTOM OF STACK 1 EXT F.S1T TOP OF STACK 1 EXT F.SBF 0=MAIN, ELSE F.A OF SUBPROGRAM. EXT F.SFF SUBROUTINE/FUNCTION FLAG 0/1 EXT F.T # WORDS ON STACK 1 EXT F.VDM VARIABLE DIMENSIONS FLAG. * * EXT'S WITH A TRAILING '.F' ARE SUBROUTINES * EXT AI.F ASSIGN ITEM EXT CFC.F CHECK FOR CONSTANT. EXT DAT.F DEFINE (F.AT) EXT DL.F DEFINE LOCATION SUBROUTINE. EXT EIC.F ESTABLISH INTEGER CONSTANT. EXT ER.F ERROR PRINT SUBROUTINE. EXT ESC.F ESTABLISH CONSTANT SUBROUTINE EXT ESD.F ESTABLISH DEF SUBROUTINE EXT FA.F FETCH ASSIGNS EXT NWI.F SET F.D0 TO # WORDS IN ARRAY. EXT OA.F OUTPUT ASSIGNMEXT TABLE OPERAND EXT OAD.F OUTPUT ABS. DATA EXT OAI.F OUTPUT ABS. INSTRUCTION EXT ODF.F OUTPUT DOT FUNCTION EXT OID.F OUTPUT INSTRUCTION, DOT-OPERAND. EXT OLR.F OUTPUT LOAD ADDRESS EXT OMR.F OUTPUT MEMORY REF. INSTRUCTION EXT ORI.F OUTPUT ABS. REGISTER INSTRUCTION. EXT OW.F OUTPUT WORD EXT OZ.F OUTPUT ZREL (OP *+N) EXT PDF.F PRODUCE DEF EXT SOA.F STORE AND OUTPUT (OA.F) EXT WAR.F ERROR COMMENT SUBROUTINE (WARNINGS) * * ENTRY POINTS IN F4.6 * EXT F.COC CURRENT OPCODE COUNT. EXT F.COP CURRENT OPCODE. EXT F.DFS 'DO' FINAL & STEP F.A'S. EXT F.RES RESULT F.A . EXT F.S1N NEXT-TO-TOP OF STACK 1. * EXT APT.F ALLOCATE PERMANENT TEMP. EXT ATC.F ALLOCATE TEMP CELL. EXT DEF.F GENERATE DEF TO (B). EXT ITN.F INITIALIZE TEMP CELL COUNTERS. EXT MAP.F MAP F.A IN FROM EMA IF NEED BE. EXT RD.F PASS FILE ONE READ WITH LOOK-AHEAD. * * ENTRY POINTS IN AOP.F (ARITH & LOG & REL OP CODE GEN.) * EXT ADD.F ADD. EXT CTS.F CONVERT TOP OF STACK. EXT MP1.F MAP TOS IF NEED BE. EXT MPY.F MPY. EXT NEG.F NEGATE. * * ENTRY POINTS IN KWC.F (KEYWORD STMT CODE GEN) * ENT AGT.F ASSIGNED GOTO. ENT AIF.F ARITHMETIC IF. ENT ASP.F ASSIGN STATEMENT. ENT CAD.F ASCII DATA OUTPUT (FORMAT & DATA STMTS) ENT CGT.F COMPUTED GOTO. ENT DO.F DO. ENT DTA.F DATA STATEMENT. ENT DOT.F END OF DO LOOP. ENT EBR.F ENDFILE/BACKSPACE/REWIND (SAVE CODE). ENT EIF.F ENDIF. ENT ELS.F ELSE. ENT GTO.F GOTO. ENT IDO.F IMPLIED DO. ENT ILA.F ORDERING OF IMPLIED DO. ENT IOA.F I/O WHOLE ARRAY. ENT IOE.F I/O STATEMENT END. ENT IOK.F I/O STATEMENT KEYWORD. ENT IOL.F I/O LIST ITEM. ENT IOS.F I/O STATEMENT START. ENT LIF.F LOGICAL IF. ENT NR.F IMPLIED DO 'RECORD'. ENT PTM.F PROGRAM TERMINATION. (END) ENT RTN.F RETURN. ENT RWE.F READ/WRITE END. ENT STP.F PAUSE & STOP. * * ENTRY POINTS IN RTM.F (REGISTER & TYPE MGMT.) * EXT ABB.F SET UP A/B BIT. EXT CAR.F CLEAR ALL REGISTER DATA, INCL EMA INFO. EXT FT.F FIND TYPE. EXT GT1.F GET TYPE OF TOP-OF-STACK. EXT GRD.F GET REGISTER DATA. EXT LD.F LOAD. EXT LDA.F LOAD INTO (A). EXT LDB.F LOAD INTO (B). EXT LDF.F LOAD FIRST WORD OF DATA. EXT MIM.F MAP ITEM MODE. EXT PO1.F POP ONE STACK ITEM. EXT PU1.F PUSH ONE STACK ITEM. EXT SBR.F STORE BOTH REGISTERS. EXT SCG.F START CODE GENERATION (LOAD TOS). EXT SMT.F STORE MAPPED DATA IN TEMP. EXT SRD.F SET REGISTER DATA. EXT SRS.F SET REGISTER DATA (SHORT FORM). EXT SRT.F STORE REGISTER IN TEMP. EXT ST.F STORE. * * ENTRY POINTS IN SAM.F (SUB & ARRAY MGR) * EXT EA?.F EMA CHECK. * * ENTRY POINTS IN LIBRARIES. * EXT .MVW MOVE WORDS INSTRUCTION. * A EQU 0 A-REGISTER B EQU 1 B-REGISTER SUP SKP * ***************** * * PUSH DO STACK * * ***************** SPC 1 PUD.F NOP (A) = DATA TO PUSH. LDB F.T ANYTHING ON STACK 1 ? SZB JMP F.OFE YES. SOMEONE BLEW IT!!! CCB NO. MAKE ROOM. ADB F.D STB F.D STB F.S1B RESET LOCATION OF STACK 1. STB F.S1T STA B,I SAVE DATA. CMB,INB CHECK FOR COLLISION. ADB F.LO ADB F.L (STACK 2 MAY BE OBSOLETE ?) SSB JMP PUD.F,I NO. ALL DONE. JMP F.OFE YES. COMPLAIN. SPC 2 * **************** * * POP DO STACK * * **************** SPC 1 POD.F NOP RETURNS (A) = OLD TOS. LDA F.D IF STACK UNDERFLOW, CPA F.DO JMP POD01 JUST RETURN ZERO. * LDA F.D,I ISZ F.D JMP POD.F,I * POD01 CLA STACK UNDERFLOW. BE QUIET ABOUT IT, JMP POD.F,I IT PROBABLY STEMS FROM SOURCE ERROR. SKP * ************** * * ASCII DATA * * ************** SPC 1 CAD.F NOP LDA F.RPL SAVE OLD F.RPL STA T1CAD JSB RD.F GET F.RPL OF DATA. STA F.RPL ORG THERE. JSB OLR.F CCA SET UP LOOP COUNT ADA F.COC (WITHOUT F.RPL WORD) CMA,INA,SZA,RSS NEGATE. ZERO ? JMP CAD02 YES. DONE. STA T2CAD NO. COUNTER. * CAD01 JSB RD.F GET ONE. JSB OW.F OUTPUT IT. B40K OCT 40000 ISZ T2CAD COUNT & LOOP. JMP CAD01 * CAD02 LDA T1CAD RESTORE POSITION. STA F.RPL JSB OLR.F JMP CAD.F,I EXIT. * T1CAD NOP T2CAD NOP SPC 2 * ********************** * * DEFINE STATEMENT # * * ********************** SPC 1 DSN.F NOP JSB RD.F GET THE #. STA F.A SAVE IT. JSB FA.F FETCH ASSIGNS. LDA REL ALREADY DEFINED ? CPA F.AT JMP DSN01 YES. JSB DAT.F NO. DEFINE IT. F.AT=REL. LDB F.NC FORMAT ? CPB B140 (I.E., NC=3) JMP DSN.F,I YES. LEAVE F.AF ALONE. JSB DL.F NO. SET F.AF = F.RPL JMP DSN.F,I & EXIT. DSN01 LDA K27 DOUBLY DEFINED. FIRST DEF HOLDS. JSB WAR.F JMP DSN.F,I EXIT. * B140 OCT 140 SKP * **************** * * PAUSE & STOP * * **************** SPC 1 STP.F NOP JSB RD.F (A) = F.A OF OCTAL CONSTANT. LDB A GO DO LOAD. JSB LD.F LDA F.COP (A)=23 FOR STOP, 24 FOR PAUSE. LDB .PAUS OFFSET FOR PAUSE. SLA WHICH ? LDB .STOP STOP. GET OFFSET. JSB ODF.F OUTPUT 'JSB .PAUS' OR 'JSB .STOP' JSB CAR.F ZAP REGISTER DATA. JMP STP.F,I EXIT. SPC 2 * ******************************************** * * SAVE CODE FOR ENDFILE, BACKSPACE, REWIND * * ******************************************** SPC 1 EBR.F NOP JSB RD.F READ CODE: -1/0/+1. STA T1EBR AND SAVE IT. JMP EBR.F,I EXIT. * T1EBR NOP XMIT CODE FROM EBR.F TO IOEB1. K27 DEC 27 .PAUS ABS 80 .STOP ABS 81 SKP * *********************** * * PROGRAM TERMINATION * * *********************** SPC 1 PTM.F NOP LDB F.SFF BLOCK DATA ? CPB K2 JMP PTM.F,I YES. NO CODE. * LDA CLAI 'CLA' JSB OAI.F LDB .EXIT 'JSB .EXIT' JSB ODF.F JMP PTM.F,I EXIT. SPC 2 * ********** * * RETURN * * ********** SPC 1 RTN.F NOP LDB F.SFF SUBROUTINE OR FUNCTION ? SZB,RSS JMP RTN01 SUBROUTINE. GO LOAD RTN #. * LDA JMPI FUNCTION. IF NOT FIRST RETURN, CPB K1 (I.E., F.SFF#1) RSS JMP RTN04 THEN JUST JMP TO FIRST RETURN (F.SFF) * LDA F.RPL ELSE NOTE LOCATION OF THIS CODE, STA F.SFF LDA F.FRF (A)=FINAL RESULT DESTINATION. LDB F.SBF (B)=RESULT SOURCE. SZARS SZA,RSS IN (A,B) OR HIDDEN DUMMY ? JMP RTN02 (A,B). JUST LOAD. * JSB ST.F MEMORY. DO DFER/CFER. JMP RTN03 * RTN01 LDB F.S1T,I SUBROUTINE. GET RETURN VALUE. JSB CFC.F CONSTANT ? CLA,INA IF NOT, USE 1 FOR ERROR CHECKING. CMA,SSA,INA,RSS IS RETURN VALUE NEGATIVE CONSTANT ? JMP RTN1A YES. WARN HIM. * ADA F.NAR (MAX VALUE) - (ACTUAL VALUE) SSA,RSS TOO BIG ? JMP RTN1B NO. * RTN1A LDA K12 YES. WARNING. JSB WAR.F * RTN1B LDB F.S1T,I (B) = F.A OF ALT RTN NUMBER. RTN02 JSB LDA.F REGISTER RESULT, LOAD. RTN03 LDA JMPII DO 'JMP ENTRY,I' LDB F.REL ENTRY LOCATION. RTN04 JSB OMR.F ISSUE CODE. JSB CAR.F ZAP REGISTER DATA. JMP RTN.F,I EXIT. * JMPI OCT 26000 JMPII OCT 126000 K12 DEC 12 SKP * ********** * * ASSIGN * * ********** SPC 1 ASP.F NOP JSB CAR.F CLEAR REGISTER DATA, JUST IN CASE. JSB RD.F GET STMT # F.A. LDB A SET UP DEF. CLAI CLA JSB ESD.F LDA F.A SAVE F.A FOR LATER. STA T1ASP JSB RD.F GET VARIABLE F.A. STA F.A MAP IT IN IF IN EMA. JSB MAP.F (MAY USE (B), BUT (A) FREE) STA T2ASP SAVE FOR THE STORE. LDA LDAI LOAD THE DEF. LDB T1ASP JSB SOA.F LDA STAI STORE IN VARIABLE. LDB T2ASP JSB SOA.F JSB CAR.F ZAP REGISTER DATA. JMP ASP.F,I EXIT. * T1ASP NOP T2ASP NOP SKP * ******************** * * 2-WAY & 3-WAY IF * * ******************** SPC 1 * COPY STATEMENT #'S. * AIF.F NOP JSB MP1.F MAP RESULT IN, JUST TO BE SAFE. JSB RD.F FIRST, COPY SEQUENCE #. CMA IS COMPLEMENTED IN F.AF OF STMT #'S. STA T0AIF JSB RD.F COPY FIRST STMT #. STA T1AIF JSB RD.F COPY 2ND STMT #. STA T2AIF LDB F.COC 2-WAY OR 3-WAY ? CPB K3 JMP AIF01 2-WAY. * JSB RD.F 3-WAY. COPY 3RD STMT #. STA T3AIF JMP AIF02 GO CHECK TYPE. * AIF01 STA T3AIF 2-WAY. SET 3RD = 2ND. JSB GT1.F CHECK FOR LOGICAL. CPA LOG IF SO, RSS CPA LO4 OR DOUBLE LOGICAL, JMP AIF03 THEN TYPE IS O.K. * AIF02 JSB GT1.F 3-WAY OR 2-WAY, NOT LOGICAL. JSB MIM.F MUST BE NUMERIC TYPE. (I.E. E=0) LDB F.IM BUT NOT COMPLEX. LDA K61 OTHERWISE, WARNING 61. SEZ,RSS WELL ? (SKIP IF NON-NUMERIC) CPB CPX RSS CPB ZPX JSB WAR.F ONE OR OTHER, WARNING. * * CHECK FOR REDUNDANCY, DOUBLE INTEGER. * AIF03 LDA T3AIF 2=3 ? CPA T2AIF IF SO, THEN JUST SIGN TEST. JMP AIF14 YES. EASY FOR DOUBLE INTEGER TOO. * LDB F.IM DOUBLE INTEGER ? CPB DBI JMP AIF20 YES. HARDER. * LDB F.S1T,I NO. ONLY NEED FIRST WORD THEN. JSB LDF.F LDB T1AIF 1=2 ? CPB T2AIF JMP AIF06 YES. DO THAT. * CPB T3AIF 1=3 ? JMP AIF05 YES: SZA / JMP3 / JMP2 SKP * NO REDUNDANCY: SSA / JMP1 / SZA / JMP3 / JMP2 * JSB JNS.F 1=NEXT ? JMP AIF11 YES. * LDA SSAI 'SSA' JSB ORI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F AIF05 LDB T3AIF 3RD = NEXT ? JSB JNS.F JMP AIF08 YES. * LDA SZAI NO. 'SZA' JMP AIF07 * AIF06 LDA KK03 1=2, DO 'CMA,SSA,INA,SZA' AIF07 JSB ORI.F LDA JMPI 'JMP 3' LDB T3AIF JSB SOA.F JMP AIF09 GO DO 'JMP 2' * AIF08 LDA SZARS 3=NEXT. 'SZA,RSS' JSB ORI.F AIF09 LDB T2AIF 'JMP 2' AIF9A JSB JNS.F IS THAT THE NEXT STATEMENT ? JMP AIF12 YES. DON'T DO IT. * AIF10 LDA JMPI YES. JUMP. JSB SOA.F AIF12 JSB CAR.F ZAP REGISTER DATA. JMP AIF.F,I DONE. * * 1=NEXT, 2#3: SZA,RSS / JMP2 / SSA,RSS / JMP3 * AIF11 LDA SZARS 'SZA,RSS' JSB ORI.F LDA JMPI 'JMP 2' LDB T2AIF JSB SOA.F LDA SSARS 'SSA,RSS' JSB ORI.F LDB T3AIF 'JMP 3' JMP AIF10 SKP * 2=3: SSA / JMP1 / JMP 2=3 * AIF14 CPA T1AIF 1=2=3 ? JMP AIF09 YES. GO THERE. * LDB F.S1T,I NO. LOAD UP FIRST WORD. JSB LDF.F LDB T1AIF IS 1=NEXT ? JSB JNS.F (SAME TRICK AS ABOVE) JMP AIF15 YES. * LDA SSAI NO. 'SSA' JSB ORI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F JMP AIF09 DO OPTIONAL 'JMP 2' * AIF15 LDA SSARS 1=NEXT. 'SSA,RSS' JSB ORI.F JMP AIF09 THEN OPTIONAL 'JMP 2' * * DOUBLE INTEGER. * AIF20 JSB SCG.F LOAD BOTH WORDS OF DOUBLE INTEGER. LDB T1AIF 1=3 ? CPB T3AIF JMP AIF24 YES: SZA,RSS / SZB / JMP 1=3 / JMP 2 * LDB T2AIF NO. 2=NEXT ? JSB JNS.F JMP AIF22 YES. * * USING .DCO * LDB .DCO 'JSB .DCO' JSB ODF.F CLA SET UP DOUBLE INTEGER ZERO. STA F.IDI STA F.IDI+1 LDA DBI JSB ESC.F JSB AI.F CLA 'DEF =J0' JSB OA.F LDA JMPI 'JMP 2' LDB T2AIF JSB SOA.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F LDB T3AIF 'JMP 3' JMP AIF9A BUT NOT IF IT'S TO NEXT STMT. SKP * DOUBLE INTEGER SKIPPING ON A & B. * AIF22 LDA SSAI 2=NEXT. 'SSA' JSB OAI.F LDA JMPI 'JMP 1' LDB T1AIF JSB SOA.F AIF24 LDA SZBRS 1=3. 'SZB,RSS' JSB OAI.F LDA SZAI 'SZA' (NOTE: F.RES=0 HERE FOR ORI.F) JMP AIF07 AND 'JMP 3' AND OPTIONAL 'JMP 2'. SPC 2 T0AIF NOP T1AIF NOP T2AIF NOP T3AIF NOP KK03 CMA,SSA,INA,SZA SKIP IF <= 0. K61 DEC 61 SSAI SSA SPC 2 * ************************************* * * TEST IF JUMP IS TO NEXT STATEMENT * * ************************************* SPC 1 * ENTRY: (B) = F.A OF JUMP TARGET (STMT #). * T0AIF = COMPLEMENT OF CURRENT SEQUENCE #. * EXIT: (B) PRESERVED. * (A) DESTROYED. * SKIP IF NOT NEXT STATEMENT. SPC 1 JNS.F NOP LDA B GET F.AF OF STMT #. INA LDA A,I CPA T0AIF SAME AS COMPL SEQ # ? RSS YES. GOT ONE. ISZ JNS.F NO. PROBABLY MUST JUMP THERE. JMP JNS.F,I EXIT. SKP * ************** * * LOGICAL IF * * ************** SPC 1 LIF.F NOP JSB MP1.F MAP IT IN, JUST TO BE SAFE. JSB GT1.F GET RESULT TYPE. LDB A IS IT LOGICAL ? LDA K62 CPB LOG RSS CPB LO4 OR DOUBLE LOGICAL ? RSSI RSS JSB WAR.F NO, WARNING. JSB RD.F GET SEQ #. INA BUMP IT TO MATCH TRUE BRANCH SEQ #. CMA SET UP FOR JNS.F TO USE. STA T0AIF JSB RD.F GET F.A OF TWPE ENTRY. STA T1AIF SAVE IT. LDB F.S1T,I LOAD FIRST WORD OF DATA. JSB LDF.F DLD T1AIF,I (B) = F.AF OF TWPE ENTRY. LDA SSARS ('SSA,RSS' IN CASE NOT GOTO) CMB,SSB (IF WAS < 0, IS NOW F.A OF GOTO TARGET) JMP LIF01 NO. VANILLA. JSB JNS.F YES. SEE IF TARGET IS NEXT LINE. JMP LIF02 YES. NO CODE. STB T1AIF NO. SET IT AS JUMP TARGET. LDA SSAI AND ISSUE 'SSA' FIRST. LIF01 JSB ORI.F SKIP. LDA JMPI AND JUMP. LDB T1AIF JSB SOA.F LIF02 JSB CAR.F ZAP REGISTER DATA. JMP LIF.F,I EXIT. * LOG OCT 030000 LO4 OCT 110000 SKP * ******** * * ELSE * * ******** SPC 1 ELS.F NOP JSB RD.F ENDIF TARGET: JUMP THERE. RAL,CLE,ERA (CLEAR SIGN) LDB A LDA JMPI JSB SOA.F JSB RD.F ELSE TARGET: DEFINE IT. RAL,CLE,ERA (CLEAR SIGN) STA F.A JSB DL.F JMP ELS.F,I DONE. SPC 2 * ********* * * ENDIF * * ********* SPC 1 EIF.F NOP JSB RD.F ENDIF TARGET: DEFINE IT. RAL,CLE,ERA STA F.A SZA (MISSING IF NO 'ELSE') JSB DL.F JSB RD.F ELSE TARGET: DEFINE IT. RAL,CLE,ERA STA F.A SZA (MISSING IF 'ELSE' PART) JSB DL.F JMP EIF.F,I EXIT. SKP * **************** * * DO STATEMENT * * **************** SPC 1 DO.F NOP JSB RD.F (F.D+3) = F.A OF INDEX. JSB PUD.F LDA F.RPL (F.D+2) = F.RPL JSB PUD.F LDA F.DFS (F.D+1) = FINAL. JSB PUD.F LDA F.DFS+1 (F.D) = STEP SIZE. JSB PUD.F JMP DO.F,I THAT'S ALL, FOLKS. SPC 2 * ****************** * * DO TERMINATION * * ****************** SPC 1 * JUST SET UP THINGS FROM DO STACK. * DOT.F NOP JSB RD.F T1DO = F.A OF INDEX. STA T1DO JSB RD.F F.A OF TWPE FOR LOOP END. INA SAVE ADDR OF ITS F.AF STA T0DO JSB RD.F 0 IF OUTER, ELSE F.A OF STMT #. LDB F.RPL OUTER LOOPS GET START OF INDEX CODE. DLD A,I IF (A)=F.A, (B)=F.AF; IF (A)=0, NOP. STB T0DO,I DEFINE THE TWPE ENTRY. JSB POD.F F.DFS+1 = STEP SIZE. STA F.DFS+1 JSB POD.F F.DFS = FINAL VALUE. STA F.DFS JSB POD.F T0DO = JUMP TARGET. STA T0DO JSB POD.F GET F.A OF INDEX FROM STACK. CPA T1DO CHECK AGAINST PASS FILE. RSS O.K. JMP DOT01 WRONG. ERROR. * JSB DT.F USE COMMON CODE. JMP DOT.F,I DONE. * DOT01 LDA F.DO PROBLEM ON DO STACK. MUST BE DUE TO STA F.D PREVIOUS ERROR. JUST EXIT QUIETLY, JMP DOT.F,I WITH DO STACK CUT BACK. SPC 2 * ************************** * * IMPLIED DO TERMINATION * * ************************** SPC 1 * JUST SET UP T0DO & T1DO, OTHERS ARE O.K. * IDO.F NOP JSB RD.F T1DO = F.A OF INDEX. STA T1DO JSB RD.F T0DO = JUMP TARGET. STA T0DO JSB DT.F USE COMMON CODE. JMP IDO.F,I DONE. SPC 2 K62 DEC 62 T0DO NOP T1DO NOP SKP * ************************* * * COMMON DO TERMINATION * * ************************* SPC 1 * FIRST, INCREMENT THE INDEX BY THE STEP. * DT.F NOP JSB CAR.F START WITH NO REGISTERS. LDA F.DFS+1 (A) = STEP SIZE. SZAI SZA DEFAULT ? JMP DT00 NO. * CLA,INA YES. SET UP CONSTANT 1. JSB EIC.F STA F.DFS+1 DT00 JSB PU1.F TOS=INDEX, NEXT=INCR. LDB T1DO GET PRECISION. JSB FT.F CPA DBI DOUBLE ? (INDEX, INCR HAVE SAME TYPE) JMP DT04 YES. DIFFERENT EMA HANDLING. * LDA T1DO SINGLE. PROCEED WITH THE ADD; JSB PU1.F IF THE INDEX HAS TO BE MAPPED IN, JSB ADD.F (B) STAYS INTACT SINCE ADD DONE IN (A). JSB SCG.F (JUST IN CASE ZERO INCR) LDA T1DO SEE IF IT HAD TO BE MAPPED. STA F.A JSB EA?.F JMP DT10 NO. NORMAL. * LDA INT YES. SET UP (B) AS ADDRESS, AGAIN. CLB,CLE BUT DON'T BOTHER WITH EMA. STO JSB SRD.F DEF K1 CLB,INB,RSS NOW USE (B) FOR THE STORE. DT10 LDB T1DO FINALLY, STORE INDEX BACK. LDA STAI JSB SOA.F * * DETERMINE: STEP SIZE: +CONST, VAR, -CONST. * FINAL: CONST, VAR. * LDB F.DFS+1 STEP SIZE. JSB CFC.F CONSTANT ? CLAR CLA,RSS NO. SET T1DO=0. IOR K1 YES. MAKE SURE NON-ZERO. STA T1DO T1DO=0 IF VAR, ELSE HAS SIGN OF CONST. LDB F.DFS (A) = FINAL VALUE. JSB CFC.F CONSTANT ? JMP DT01 NO. SKP * FINAL VALUE IS CONSTANT: NEGATE IT. * LDB T1DO CHECK STEP SIZE. NEGI CMA,INA NORMALLY, JUST NEGATE. CMB,SSB,INB,SZB STEP=+CONST ? ADA KM1 YES. NEGATE & DECREMENT. JSB EIC.F MAKE THE CONSTANT. LDB A GO ADD TO INDEX. CLA CLEAR FINAL=CONST FLAG. JMP DT02 * * FINAL VALUE IS VARIABLE: NEGATE INDEX. * DT01 LDB T1DO CHECK STEP SIZE. LDA NEGI FOR STEP=VAR OR +CONST, NEGATE. SSB BUT FOR -CONST, LDA CMAI NEGATE & DECREMENT. JSB OAI.F LDB F.DFS ADD FINAL VALUE. CCAI CCA SET FINAL=CONST FLAG. DT02 STA F.DFS * * ADD. IF STEP=VAR, DO 'XOR STEP'. * LDA ADAI JSB SOA.F LDA T1DO WELL ? SZA JMP DT03 NO. LDA XORI YES. LDB F.DFS+1 JSB SOA.F * * ISSUE THE SKIP. DO 'CPA STEP' IF STEP=VAR. * DT03 LDA SSAI DEFAULT IS 'SSA'. LDB T1DO STEP=+CON ? CMB,SSB,INB,SZB XOR K1 YES, CHANGE TO 'SSA,RSS' ISZ F.DFS FINAL=CONST ? XOR K1 YES, CHANGE TO OTHER. JSB OAI.F ISSUE SKIP. * LDA T1DO STEP=VAR ? SZA JMP DT08 NO. LDA CPAI YES. DO 'CPA STEP' LDB F.DFS+1 JSB SOA.F JMP DT08 SKP * DOUBLE INTEGER INDEX. * DT04 LDA T1DO IF EMA, MAP IT IN NOW. STA F.A JSB MAP.F JSB PU1.F PUT THE F.A ON THE STACK, JSB SBR.F AND IF EMA, SAVE THE ADDRESS. LDB F.S1T,I NOW COPY THE TOS ENTRY, STB T1DO WHICH IS F.A OF INDEX OR ADDR TEMP. JSB ADD.F ADD INCREMENT, JSB SCG.F AND MAKE SURE LOADED, EVEN IF INCR=0. LDB T1DO NOW MUST FIX UP ADDR TEMP IF EMA. LDA B,I SEE WHICH: AND B170K GET F.IM OF THE ITEM. CPA ADDR IF ADDR TEMP, RSS (YES) JMP DT09 NO. LEAVE ALONE. * LDA DBI YES. RESTORE THE TYPE OF THE TEMP, INB STA B,I SINCE WE ARE RE-USING AFTER A DEF. DT09 CLB STORE BACK. SINCE THE EMA ADDRESS LDA T1DO IS IN AN ADDR TEMP, NO OTHER TRICKS JSB ST.F REQUIRED TO RE-USE IT HERE. * * THEN USE .DCO . * LDB .DCO DO 'JSB .DCO' JSB ODF.F CLA AND 'DEF FINAL' LDB F.DFS JSB SOA.F LDB T0DO ALWAYS LOOP ON '='. LDA JMPI JSB OMR.F LDB F.DFS+1 IS STEP CONSTANT ? JSB CFC.F JMP DT06 NO. * SSA,RSS YES. + OR - ? JMP DT08 +, JUST ONE MORE JUMP TO TOP. * LDA RSSI -. 'RSS' FIRST. JMP DT07 * DT06 LDA CLAR VARIABLE. 'CLA,RSS' JSB OAI.F LDA CCAI THEN 'CCA' JSB OAI.F LDA XORI THEN 'XOR STEP' LDB F.DFS+1 JSB SOA.F LDA SSARS AND FINALLY, 'SSA,RSS'. DT07 JSB OAI.F * * ISSUE JUMP TO TOP OF LOOP. EXIT. * DT08 LDB T0DO (B) = SAVED F.RPL. LDA JMPI JSB OMR.F JSB CAR.F ZAP REGISTER DATA. JMP DT.F,I DONE. * CPAI OCT 52000 XORI OCT 22000 ADAI OCT 42000 LDAI OCT 62000 STAI OCT 72000 .DCO ABS 29 B170K OCT 170000 MASK FOR F.IM ADDR OCT 70000 F.IM=ADDR KM1 DEC -1 K3 DEC 3 SKP * *************** * * SIMPLE GOTO * * *************** SPC 1 GTO.F NOP JSB RD.F (A) = SEQ # OF GOTO. CMAI CMA SET UP T0AIF FOR JNS.F TEST. STA T0AIF JSB RD.F (A) = F.A OF TARGET STMT #. LDB A IS IT NEXT STATEMENT ? JSB JNS.F JMP GTO.F,I YES, NO CODE. LDA JMPI ISSUE JUMP. JSB SOA.F JMP GTO.F,I EXIT. SPC 2 * ***************** * * ASSIGNED GOTO * * ***************** SPC 1 AGT.F NOP JSB RD.F GET VARIABLE F.A STA F.A JSB RD.F GET # ITEMS IN LIST. ADA F.T JUST THROW AWAY. STA F.T ADA F.S1B STA F.S1T INA STA F.S1N JSB FA.F FETCH ASSIGNS ON VAR. JSB MAP.F MAP IN IF EMA. STB F.RES SAVE IN CASE LOAD NOT DONE. LDA F.AT IF DUMMY OR CPA DUM RSS CPB K1 IN EMA, THEN JSB LD.F LOAD. F.RES = RESULT F.A LDA JMPII NOW ISSUE THE JUMP. LDB F.RES THRU THIS LOCATION. JSB SOA.F JSB CAR.F ZAP REGISTER DATA. JMP AGT.F,I DONE. * DUM OCT 5000 SKP * ***************** * * COMPUTED GOTO * * ***************** SPC 1 * DECIDE BETWEEN IN-LINE & .GOTO * CGT.F NOP JSB MP1.F MAP INDEX IN, JUST IN CASE. JSB RD.F GET SEQUENCE COUNTER. CMA SET UP FOR JNS.F STA T0AIF JSB RD.F GET LENGTH OF BRANCH LIST. STA T3GTO SAVE FOR EXIT. CMA,INA SAVE AS COUNTER. STA T2GTO LDB T3GTO SET UP PTR INTO STACK 1. ADB F.S1T (IT RUNS BACKWARDS) STB T1GTO (NOTE: STACK 1 ONLY MOVES AT 'DO') LDA INT CONVERT INDEX TO INTEGER. JSB CTS.F JSB PO1.F (A) = F.A OF INDEX. STA F.A SAVE IT. LDB A BRS REGISTER IFF B=0. LDA T2GTO - (# STMT NUMBERS) ADA K2 ONE OR TWO ITEMS ? SSARS SSA,RSS JMP CGT01 YES. GENERATE IN-LINE CODE. KK04 INA,SZA,RSS THREE AND VALUE IN REG ? SZB JMP CGT03 NO. USE '.GOTO' * * IN-LINE: * CMA,SSA,INA,SZA / (N-1)*(INA,SZA,RSS/JMP K) / JMP N. * CGT01 CPA K1 ONLY ONE STMT # ? (IT WORKS) JMP CGT06 YES. JUST JUMP. ISZ T2GTO (ONLY OUTPUT N-1 JUMPS NOW.) LDB F.A LOAD IF NOT ALREADY IN REG. JSB LD.F LDA KK03 'CMA,SSA,INA,SZA' (OR B) JSB ORI.F I.E., NEGATE & SKIP IF > 0. CGT02 LDA KK04 'INA,SZA,RSS' (OR B) JSB ORI.F LDB T1GTO,I 'JMP STMT' LDA JMPI JSB SOA.F CCB MOVE STACK PTR. ADB T1GTO STB T1GTO ISZ T2GTO LOOP THRU ALL. JMP CGT02 JMP CGT06 LAST JUMP, POP STACK & EXIT. * * USING '.GOTO' * CGT03 JSB SBR.F SAVE REGISTERS. LDB .GOTO OUTPUT 'JSB .GOTO' JSB ODF.F LDB T3GTO N = # STMTS. ADB K2 # STMTS + 2. JSB OZ.F OUTPUT 'DEF *+N+2' CLA OUTPUT 'DEF INDEX' LDB F.A (NOTE: THE (A) REGISTER IS NOT STORED, JSB SOA.F SO .GOTO MUST HANDLE 'DEF 0' RIGHT.) CGT05 LDB T1GTO,I OUTPUT THE DEFS. CLA JSB ESD.F JSB PDF.F CCB MOVE STACK PTR. ADB T1GTO STB T1GTO ISZ T2GTO LOOP THRU ALL. JMP CGT05 JMP CGT07 GO POP STACK & EXIT. * * OUTPUT LAST JUMP, POP STACK & EXIT. * CGT06 LDB T1GTO,I F.A OF IT. JSB JNS.F NEXT LINE ? JMP CGT07 YES. SKIP IT. LDA JMPI NO. DO JUMP. JSB SOA.F CGT07 LDA T3GTO CUT STACK BACK. ADA F.T STA F.T ADA F.S1B STA F.S1B INA STA F.S1N JSB CAR.F ZAP REGISTER DATA. JMP CGT.F,I DONE. SPC 1 T1GTO NOP T2GTO NOP T3GTO NOP .GOTO ABS 76 SKP * *********************** * * START I/O STATEMENT * * *********************** SPC 1 IOS.F NOP JSB RD.F GET STATEMENT TYPE. STA T1IOS CLA CLEAR OUT KEYWORD VALUE TABLE. STA KWVT LDA DKWVT INA LDB A INB JSB .MVW DEF K33 28 KEYWORDS, 6 MISC VALUES. NOP (TOTAL = 34, 33 ADDITIONAL) JSB ITN.F INITIALIZE TEMPS. (INHIBITED IN EXPR) JMP IOS.F,I THAT'S ALL FOR NOW. * T1IOS NOP I/O STATEMENT TYPE. SKP * *************** * * I/O KEYWORD * * *************** SPC 1 IOK.F NOP JSB RD.F GET KEYWORD # AND WHOLE ITEM FLAG. STA T1IOK SAVE. CLA,INA IS VALUE ON STACK ? CPA F.COC JMP IOK01 YES. DO THAT. * JSB RD.F NO. GET F.A OF VALUE. SZA,RSS IS IT '*' FORMAT ? JMP IOK03 YES. SKIP EMA CHECK TOO. * JSB PU1.F NO. PUT IT ON STACK. IOK01 LDA F.S1T,I IS ITEM IN EMA ? STA F.A (FOR EA?.F) JSB EA?.F EMA ? (A) PRESERVED. JMP IOK02 NO. * LDB T1IOS YES. READ/WRITE ? SZB CPB K1 RSS JMP IOK09 NO. ERROR. * LDB T1IOK YES. UNIT # ? RBL,CLE,ERB CPB K.UNT JMP IOK04 YES. O.K. FOR BACKWARDS COMPAT. * IOK09 LDA K48 OTHERWISE, JSB ER.F ERROR. * IOK04 JSB PO1.F EMA UNIT #, MAP IT. JSB MAP.F MAKE SURE THAT F.ACM IS UPDATED. JSB PU1.F * IOK02 JSB SMT.F FREE UP THE MAPS. (DATA TO TEMPS) JSB SBR.F SAVE BOTH REGISTERS. JSB PO1.F POP THE ITEM OFF THE STACK. (TO (A)). STA T2IOK SAVE THE ITEM F.A, AND LDA A,I SEE IF CHAR TEMP. AND KK05 F.IM & F.IU & F.NT CPA KK06 F.IM=CHAR, F.IU=VAR, F.NT=0 ? RSS (YES) JMP IOK05 NO. NOT CHAR TEMP. * LDA T2IOK YES. CHAR TEMP OR VAR. WHICH ? ADA K2 LDA A,I SSA,RSS JMP IOK05 VAR. LEAVE IT. * DLD T2IOK,I TEMP. (B) = EXTENSION ADDR. LDB B,I (B) = ADDR DESCRIPTOR / ITEM,I RBL,CLE,SLB,ERB IS IT SPECIAL ITEM,I ENTRY ? RSS (YES) JMP IOK05 NO. LEAVE IT. * LDA T1IOK YES. IS IT FORMAT ? RAL,CLE,ERA CPA K.FMT RSS (YES) JMP IOK08 NO. ORDINARY. * LDA B,I FORMAT. SEE IF ARRAY OR VAR. AND B600 CPA VAR IF VAR, RSS (YES) JMP IOK08 NO: THEN NORMAL FAKED STRING. * STB T3IOK THEN ASSIGN'ED FORMAT VARIABLE. DLD T2IOK,I (B)=ADDR DESCRIPTOR. INB SET LENGTH TO MAX. LDA BMAX STA B,I LDA LDAI SET UP LOAD. LDB T3IOK JMP IOK10 GO LOAD THE ADDRESS & FORMAT IT. * IOK08 LDA B,I GET ADDRESS TYPE OF ITEM. IOR B10 (MARK THE ITEM USED) STA B,I AND B7000 CPA BCOM IF LABELLED COMMON, JMP IOK06 CPA DUM OR FORMAL, RSS THEN SPECIAL PROCESSING. JMP IOK05 ELSE LEAVE IT. * LDA LDAII FORMAL. DO 'LDA ITEM', STB T3IOK (SAVE F.A OF FORMAL) IOK10 JSB SOA.F LOAD ITS ADDRESS. LDA CLELA SHIFT. JSB OAI.F LDB T2IOK STORE IN DESCRIPTOR. CLA,INA (SET OFFSET = 1 TO GET STA F.C TO 2ND WD OR DESCRIPTOR) LDA STAI JSB SOA.F LDA T3IOK RESTORE F.A TO DUMMY. STA F.A JSB FA.F FETCH ASSIGNS. LDA F.IU IF ARRAY, LDB F.VDM WITH VARIABLE DIMENSIONS, CPA ARR SZBRS SZB,RSS JMP IOK05 NO. DONE WITH DUMMY. * JSB CVA.F YES. CALCULATE ARRAY SIZE. JSB SCG.F MAKE SURE IT'S IN A REGISTER. LDA CLELA SHIFT TO GET # CHARS. JSB ORI.F JSB ABB.F GET A/B BIT. IOR STAI SET STA/STB. LDB T2IOK STORE LENGTH IN 1ST WD. JSB SOA.F JMP IOK05 DONE. * IOK06 CLA LABELLED COMMON. SET UP DEF. JSB ESD.F LDA LDAI AND LOAD IT. JSB OA.F LDA CLELA 'CLE,ELA' JSB OAI.F TO MAKE BYTE ADDR. LDB T2IOK STORE IN DESCRIPTOR. CLA,INA (IN 2ND WORD) STA F.C LDA STAI JSB SOA.F IOK05 LDA T2IOK (A) = ITEM F.A (AGAIN). IOK03 LDB T1IOK WHOLE ITEM BIT & KEYWORD ORDINAL. RBL,CLE,ERB COPY BIT TO (E) & CLEAR. RAL,ERA PUT WHOLE ITEM BIT ON ITEM. ADB DKWVT ADDR IN TABLE. STA B,I PUT KEYWORD VALUE IN TABLE. JMP IOK.F,I DONE. * T1IOK NOP WHOLE ITEM BIT & KEYWORD ORDINAL. T2IOK NOP SAVED F.A OF ITEM. T3IOK NOP SAVED F.A OF DUMMIED CHAR ITEM. KK05 OCT 170601 F.IM & F.IU & F.NT KK06 OCT 130400 F.IM=CHAR, F.IU=VAR, F.NT=0. LDAII OCT 162000 B600 OCT 600 F.IU MASK. ARR EQU B600 F.IU=ARR. VAR OCT 400 F.IU=VAR. CLELA CLE,ELA B7000 OCT 7000 F.AT MASK. BMAX OCT 77777 MAX POS INT. SKP * ********************* * * I/O STATEMENT END * * ********************* SPC 1 * DEFAULT 'IOSTAT' IF NECESSARY. * IOE.F NOP LDA V.IOS IS IOSTAT PRESENT ? SZA JMP IOE02 YES. * LDA F.IOT IOSTAT TEMP EXISTS ? SZA JMP IOE01 YES. * LDA INT NO. CREATE ONE. JSB APT.F STA F.IOT AND SAVE FOR NEXT TIME. IOE01 LDA F.IOT SET IOSTAT TO THE TEMP. STA V.IOS * * START BY SCANNING APPROPRIATE TEMPLATE AND: * 1) CHECKING TYPES, CONVERTING IF REQ'D. * 2) COUNTING # OF PARAMS TO BE ISSUED. * 3) ACCUMULATING BIT VECTOR. * IOE02 LDA DSTTP ADDR OF TABLE OF POINTERS. ADA T1IOS ORDINAL OF STMT. LDA A,I ADDR OF TEMPLATE. STA T1IOE WILL RE-USE THIS ONE. STA T2IOE THIS ONE FOR LOOPING. CLA ZERO OUT COUNT & BIT VECTOR. STA T3IOE STA T4IOE STA T6IOE AND SPECIAL NEXTREC INFO. STA T7IOE AND SPECIAL MAXREC INFO.. * IOE04 LDA T2IOE,I NEXT TEMPLATE WORD. SZA,RSS DONE ? JMP IOE20 YES. * AND B77 KEYWORD ORDINAL. ADA DKWVT GET VALUE F.A STA T5IOE (SAVE ITS ADDR) LDA A,I CMA,CLE,INA E=1 IFF DOESN'T EXIST. DLD T2IOE,I LDA B (A) = 2ND WORD. LDB T2IOE,I BLF,BLF B<15> = BIT 7 OF DESCRIPTION. SEZ,RSS EXISTS ? JMP IOE06 YES. * SSB BIT 7: 0=DEFAULT, 1=LEAVE OUT. JMP IOE18 LEAVE OUT. DON'T COUNT EITHER. * CPA B100K SPECIAL CASE: IF VALUE = 100000B, JMP IOE05 THEN SET UP TO GENERATE 'NOP' LATER. * STA F.IDI ELSE SET UP VALUE. LDA K2 SET F.CSL=2, JUST IN CASE. STA F.CSL LDA T2IOE,I GET TYPE. AND B170K JSB ESC.F SET UP CONSTANT. JSB AI.F LDA F.A (A) = CONSTANT F.A IOE05 STA T5IOE,I INSERT IN TABLE. JMP IOE17 SKIP OTHER CHECKS. * IOE06 SSB,RSS EXISTS. BIT VECTOR ? JMP IOE07 NO. * IOR T4IOE YES. ADD NEW BIT. STA T4IOE * IOE07 LDB T5IOE,I F.A OF VALUE. RBL,CLE,ERB (CLEAR SIGN) JSB FT.F LDB A (B) = ACTUAL TYPE. LDA T2IOE,I GET EXPECTED TYPE. AND B170K SZA IF ANY TYPE O.K., (ZBUF) CPA B OR RIGHT TYPE, JMP IOE17 THEN DONE. * CPA INT INTEGER*2 EXPECTED, JMP IOE11 CPA DBI INTEGER*4, JMP IOE13 CPA LOG LOGICAL*2, JMP IOE15 * IOE16 LDA K26 WARNING 26: INT EXPECTED. JSB WAR.F JMP IOE17 * IOE15 CPB LO4 SHOULD BE LOGICAL*2, JMP IOE17 LOGICAL*4 IS O.K. AS IS. JMP IOE16 ELSE WARNING. * IOE11 CPB DBI SHOULD BE INT*2, IS IT INT*4 ? RSS JMP IOE16 NO. WARNING. * LDA T2IOE,I YES. O.K.; CONVERT NOW OR LATER ? ALF,ALF (TEST BIT 8) SLA IF 0, DO IT NOW. JMP IOE17 ELSE LATER. * IOE12 LDA T5IOE,I CONVERT DBI <==> INT. RAL,CLE,ERA (CLEAR SIGN) JSB PU1.F LDA T2IOE,I GET EXPECTED TYPE. AND B170K JSB CTS.F CONVERT. JSB SBR.F JSB PO1.F STA T5IOE,I JMP IOE17 NOW IT'S O.K. * IOE13 CPB INT SHOULD BE INT*4, IS IT INT*2 ? RSS JMP IOE16 NO. WARNING. * LDA T2IOE,I CHECK IF VALUE/RESULT. ALF,ALF (BIT 8) SLA,RSS 0=VALUE, 1=RESULT. JMP IOE12 VALUE. CONVERT AHEAD OF TIME. * LDB T5IOE,I RESULT: NEXTREC OR MAXREC IN INQUIRE. RBL,CLE,ERB (CLEAR SIGN) LDA T2IOE,I GET KEYWORD ORDINAL. AND B77 THESE ARE SPECIAL CASES WHERE A TEMP CPA K.NXR IS REQUIRED BECAUSE THE RESULT INQUIRE STB T6IOE (NEXTREC) STORES IS BIGGER THAN THE CPA K.MXR VARIABLE SPECIFIED FOR IT. STB T7IOE (MAXREC) LDA DBI ALLOCATE DBI TEMP FOR NOW. JSB ATC.F STA T5IOE,I AND PUT THE RESULT THERE. * IOE17 ISZ T3IOE COUNT THE PARAM. IOE18 ISZ T2IOE ADVANCE IN TABLE. ISZ T2IOE JMP IOE04 GO PROCESS NEXT ENTRY. * T1IOE NOP ADDR OF TEMPLATE TABLE, THIS STMT. T2IOE NOP POINTER INTO TEMPLATE TABLE. T3IOE NOP PARAM COUNT. T4IOE NOP BIT VECTOR.. T5IOE NOP ADDR OF CURRENT KEYWORD VALUE F.A T6IOE NOP SAVED 'NEXTREC' F.A WHEN INT*2 USED. T7IOE NOP SAVED 'MAXREC' F.A WHEN INT*2 USED. F.IOT DEC 0 F.A OF IOSTAT TEMP. K26 DEC 26 K33 DEC 33 K48 DEC 48 B77 OCT 77 .IOOP ABS 92 .IOCL ABS 93 .IOIN ABS 94 .IOCN ABS 95 .EXIT ABS 260 LDBI OCT 66000 SKP * SET UP VALUE OF BIT VECTOR. * IOE20 LDA V.BVT BIT VECTOR USED ? SZA,RSS (IF SO, DEFAULT=0 SET UP) JMP IOE22 NO. * LDA T4IOE YES. SET IT UP. JSB EIC.F STA V.BVT * * EXECUTE STATEMENT-SPECIFIC CODE. * IOE22 LDA T1IOS STATEMENT TYPE. ADA DSJT1 JUST USE JUMP TABLE. LDA A,I JMP A,I * DSJT1 DEF *+1 DEF IOER1 READ DEF IOER1 WRITE DEF IOEO1 OPEN DEF IOEC1 CLOSE DEF IOEI1 INQUIRE DEF IOEB1 BACKSPACE/ENDFILE/REWIND. * IOEB1 LDA T1EBR -1/0/+1 CODE. JSB EIC.F FORM CONSTANT, LDB A (B) = ITS F.A, JSB LDA.F THEN CCA/CLA/CLA,INA LDB .IOCN BACKSPACE ENDFILE REWIND: .IOCN RSS * IOEO1 LDB .IOOP OPEN: .IOOP RSS * IOEC1 LDB .IOCL CLOSE: .IOCL RSS * IOEI1 LDB .IOIN INQUIRE: .IOIN JSB ODF.F 'JSB XXXXX' LDB T3IOE (A=0) INB # PARAMS + 1 JSB OZ.F 'DEF *+N+1' JMP IOE30 PRODUCE THE PARAMS. SKP * START OF READ OR WRITE. * IOER1 LDB V.RCL IS 'RECL' SUPPLIED ? SZB,RSS JMP IOER3 NO. NORMAL READ/WRITE. * JSB CFC.F YES. ENCODE/DECODE. CONSTANT ? JMP IOER5 NO. GO COPY TO STRING DESCR. * LDB V.SDS YES. INSERT INTO A.T. ENTRY INB FOR STRING DESCRIPTOR. LDB B,I ADDR OF EXTENSION. INB STA B,I 2ND WD OF EXTENSION = LENGTH. JMP IOER6 * IOER5 LDA LDAI COPY LENGTH TO STRING DESCRIPTOR. JSB SOA.F 'LDA LENGTH' LDA STAI LDB V.SDS JSB SOA.F 'STA DESCRIPTOR' * IOER6 LDA B40K SET ALEN = # RECORDS = 16384. JSB EIC.F STA V.ALN JMP IOER4 SKIP UNIT # LOAD. * IOER3 LDA V.UNT UNIT # SUPPLIED ? RAL,CLE,ERA (REMOVE SIGN BIT) SZA JMP IOER2 YES. GO LOAD IT. * LDA T1IOS NO. GET READ/WRITE FLAG. LDB .FSIU PICK A DOT FUNCTION ORDINAL. SZA READ=0, .FSIU LDB .FSOU PRINT=1, .FSOU LDA LDAI LOAD IT INTO (A). JSB OID.F JMP IOER4 DONE WITH STD-UNIT. SKIP OTHER. * IOER2 JSB PU1.F EXPLICIT UNIT #. CONVERT TO INT*2. LDA INT JSB CTS.F JSB PO1.F LDB A JSB LDA.F * * LOAD THE BIT VECTOR INTO (B). SEE IF FORMATTED. * IOER4 LDB V.FMT BUT FIRST, SET CHAR FORMAT BIT. RBL,CLE,ERB CHECK TO SEE IF FORMAT IS TYPE CHAR. SZB,RSS IF NO FORMAT, JMP IOER7 THEN NOT CHAR. * STB F.A GET ASSIGNS. JSB FA.F LDB F.IM (B) = FORMAT TYPE. CPB CHAR CHAR ? JMP IOER8 YES. * LDA F.IU NO. VARIABLE ? CPA VAR RSS (YES) JMP IOER7 NO. ARRAY OR STATEMENT #. * LDA F.AT YES. FORMAL PARAM ? CPA DUM RSS (YES) JMP IOER7 NO. CAN USE INDIRECT. * LDB F.A YES. ASSIGN'D FMT IN FORMAL PARAM. JSB LDB.F LOAD INTO (B), JSB GRD.F CHANGE TO AN ADDRESS, DEF K1 STO JSB SRD.F DEF K1 JSB SRT.F AND SAVE IN TEMP. DEF K1 LDA F.A NOW REPLACE THE FORMAT F.A STA V.FMT WITH THAT OF THE TEMP (WILL BE INLINE). * IOER7 CLA,CCE,RSS NOT CHAR. (A,E)=1. IOER8 CLA,CCE,INA CHAR. (A,E)=3. ELA (A) = 3 OR 1. XOR T1IOS BIT 0 = 1 FOR READ, 0 FOR WRITE. IOR T4IOE ADD REST OF BIT VECTOR. JSB EIC.F FORM CONSTANT, LDA LDBI AND LOAD IT JSB OA.F INTO (B). CLA (SET UP T1NR=0) STA T1NR LDA F.RPL (SET UP T2NR=F.RPL) STA T2NR * LDB V.FMT FORMAT INDICATOR. SZB,RSS BINARY ? (NO FORMAT) JMP RWS03 YES. * * FORMATTED. * RBL,CLE,ERB (CLEAR SIGN) SZB,RSS LIST-DIRECTED ? JMP RWS01 YES. * STB F.A NO. SAVE FORMAT F.A FOR LATER. LDB .EIO. 'JSB .EIO.' JSB ODF.F JSB FA.F FETCH ASSIGNS FOR FORMAT. LDA F.IM IF TYPE INTEGER (AS OPPOSED TO CPA INT CHARACTER, ADDRESS OR STMT #) RSS CPA DBI CLA,CCE,RSS (A=0, E=1) JMP IOER9 (NO) * LDB F.IU AND SIMPLE VARIABLE, CPB VAR ERA,SLA THEN A=100000: DEF VAR,I IOER9 CLA ELSE A=0: DEF ARR/FMT/CHAR DES/* JSB OA.F JMP RWS02 * RWS01 LDB .FIO. 'JSB .FIO.' JSB ODF.F JMP RWS02 * * BINARY. * RWS03 LDB .BIO. ISSUE 'JSB .BIO.' JSB ODF.F RWS02 LDA TWPE FORM TWPE ENTRY FOR 'DEF END' JSB ESC.F JSB AI.F LDA F.A REMEMBER IT. STA T1RWS JMP IOE30 AND GO ISSUE REST OF PARAMS. * CHAR OCT 130000 F.IM = CHAR. .FSIU DEC 84 DOT ORDINAL OF STANDARD INPUT. .FSOU DEC 85 DOT ORDINAL OF STANDARD OUTPUT. SKP * OUTPUT DEF'S TO PARAMS. * IOE30 JSB CAR.F FIRST, VOID ANY REGISTERS. LDA T1IOE SET UP LOOP. STA T2IOE IOE32 LDA T2IOE,I TABLE ENTRY. SZA,RSS DONE ? JMP IOE34 YES. * AND B77 NO. GET ORDINAL. ADA DKWVT INDEX INTO TABLE, LDB A,I AND GET F.A OF VALUE. CPB B100K IF SPECIAL CASE, JMP IOE33 GO DO 'NOP' * ISZ F.NIT (INHIBIT INLINE TEMPS IN I/O PARAMS) RBL,CLE,ERB (CLEAR SIGN) SZB IF VALUE PRESENT, JSB DEF.F 'DEF VALUE' JMP IOE35 GO LOOP. * IOE33 CLA GENERATE 'NOP'. JSB OAI.F IOE35 ISZ T2IOE LOOP. ISZ T2IOE JMP IOE32 * * DO ANY POST-CONVERSIONS REQUIRED. * IOE34 LDA T1IOS IF READ OR WRITE, SZA CPA K1 JMP IOE37 DO 'DEF END' INSTEAD. * JSB IOEP ELSE DO POST-CONV & END/ERR. JSB CAR.F FORGET ANY REGISTERS, JMP IOE.F,I AND EXIT. * IOE37 LDB T1RWS READ/WRITE. JSB DEF.F GENERATE 'DEF END-OF-LIST' JSB CAR.F JUST FOR GOOD MEASURE. JMP IOE.F,I DONE. SPC 4 IOEP NOP LDA T1IOE SET UP LOOP. STA T2IOE IOEP1 LDA T2IOE,I GET NEXT TABLE ENTRY. SZA,RSS DONE ? JMP IOEP6 YES. GO DO END & ERR. * ALF,ALF NO. IS IT RESULT ? SLA,RSS (BIT 8 SET ?) JMP IOEP3 NO. NO ACTION NEEDED. * LDA T2IOE,I YES, RESULT. GET INFO BACK. AND B77 KEYWORD ORDINAL. ADA DKWVT STA T5IOE SAVE TABLE ADDR. LDB A,I VALUE F.A RBL,CLE,ERB (CLEAR SIGN) SZB,RSS IF NO VALUE, JMP IOEP3 THEN FORGET IT. * JSB FT.F VALUE TYPE. LDB A LDA T2IOE,I GET EXPECTED TYPE. AND B170K CPA B SAME ? JMP IOEP4 YES. MAY STILL BE NEXTREC. * CPA INT EXPECTED = INT*2 ? JMP IOEP2 YES. ACTUAL MUST BE INT*4. JMP IOEP3 NO. MUST BE CHAR OR LOG, O.K. * IOEP4 LDA T2IOE,I TYPE SAME. IS IT NEXTREC/MAXREC, AND B77 (KEYWORD ORDINAL) CLB AND POST-CONVERSION REQUIRED ? CPA K.NXR NEXTREC, LDB T6IOE CPA K.MXR OR MAXREC ? LDB T7IOE SZB,RSS WELL ? JMP IOEP3 NO. THEN REALLY SAME. * LDA T5IOE,I YES. GET F.A OF THE TEMP USED. STB T5IOE (AND REMEMBER F.A OF REAL RESULT) RAL,CLE,ERA (CLEAR SIGN) JSB PU1.F CONVERT TO INT. LDA INT JSB CTS.F JSB SCG.F LOAD; MAY STILL BE IN MEM. LDB F.S1T,I STORE INTO INT*2 VAR. LDA T5IOE JSB ST.F JSB PO1.F JMP IOEP3 DONE. * IOEP2 LDB T5IOE,I LOAD RESULT FROM FIRST WORD. RBL,CLE,ERB (CLEAR SIGN) LDA LDBI MUST LOAD EXPLICITLY. JSB SOA.F LDA INT SET B-REG RESULT. JSB SRS.F DEF K1 CLA,INA PUSH ON STACK, SO CAN JSB PU1.F CONVERT TO INT*4. LDA DBI JSB CTS.F LDB F.S1T,I STORE IT BACK. LDA T5IOE,I RAL,CLE,ERA (CLEAR SIGN) JSB ST.F IOEP3 ISZ T2IOE ADVANCE IN TABLE. ISZ T2IOE JMP IOEP1 * * DO END= AND ERR=. * IOEP6 LDA V.IOS IOSTAT F.A RAL,CLE,ERA (CLEAR SIGN) LDB V.END IF END= OR ERR= SUPPLIED, ADB V.ERR SZB,RSS CPA F.IOT OR IOSTAT NOT SUPPLIED, RSS THEN MUST CHECK IT. JMP IOEP,I ELSE LET USER FIGURE IT OUT. * JSB PU1.F NO. LOAD IOSTAT. LDA INT CHEAP WAY TO GET ONLY SECOND WORD. JSB CTS.F LDB F.S1T,I LOAD INTO (A). JSB LDA.F JSB PO1.F (NOTE: REG # IS IN F.RTP) LDA T1IOS READ ? SZA JMP IOEP8 NO. THEN NO END=. * LDA V.END YES. IF END= AND ERR= SAME, CPA V.ERR JMP IOEP8 THEN END= COVERED BY ERR=. * LDA SSAI ELSE DO 'SSA' JSB ORI.F LDB V.END WHERE ? SZB JMP IOEP7 END= PRESENT. * LDB .EXIT END= NOT PRESENT, JSB ODF.F 'JSB .EXIT' JMP IOEP8 * IOEP7 RBL,CLE,ERB END= THERE, (CLEAR SIGN) LDA JMPI JSB SOA.F ISSUE JUMP TO STATEMENT #. * IOEP8 LDA SZAI CHECK FOR ERROR: JSB ORI.F 'SZA' LDB V.ERR AS ABOVE, BUT USING ERR=. SZB JMP IOEP9 * LDB .EXIT JSB ODF.F JMP IOEP,I * IOEP9 RBL,CLE,ERB LDA JMPI JSB SOA.F JMP IOEP,I SKP * KEYWORD VALUE TABLE. * * EACH ENTRY CONTAINS THE F.A OF THE VALUE OF THE KEYWORD. * IF ZERO, VALUE NOT PROVIDED. * IF SIGN BIT SET, WHOLE ITEM TO BE USED (E.G. ARRAY) * SPECIAL CASE: 100000B IS FORMAT '*'. * DKWVT DEF * DEF ZEROTH VALUE. KWVT BSS 34 ROOM FOR 32 VALUES. V.END EQU DKWVT+1 END= VALUE. V.ERR EQU DKWVT+2 ERR= V.FMT EQU DKWVT+3 FMT= V.RCL EQU DKWVT+10 RECL= V.UNT EQU DKWVT+11 UNIT= V.IOS EQU DKWVT+19 IOSTAT= V.BVT EQU DKWVT+30 BIT VECTOR. V.SDS EQU DKWVT+33 INTERNAL FILE STRING DESCRIPTOR. V.ALN EQU DKWVT+34 INTERNAL FILE # RECORDS. K.FMT EQU K3 K.UNT DEC 11 K.MXR DEC 24 K.NXR DEC 25 SPC 2 * TABLES DESCRIBING THE PARAMETERS USED FOR VARIOUS I/O * STATEMENTS. EACH ENTRY HAS ONE OR TWO WORDS: * * BITS 15:12 PARAMETER TYPE. * 8 0=DATA, 1=RESULT. * 7 (IFF BIT 6) 0: 2ND WD HAS DEFAULT VALUE. (100000: NOP) * 1: 2ND WD HAS BIT VECTOR BIT. * 6 1=OPTIONAL, 0=REQUIRED. * 5:0 KEYWORD ORDINAL. * * LIST IS TERMINATED BY A ZERO WORD. * RDWRT EQU * READ/WRITE. OCT 130741 SDES: CHAR, OPTNL, RESULT, #33. OCT 14 OCT 010342 ALEN: INT*2, OPTNL, RESULT, #34. OCT 14 OCT 100304 REC: INT*4, OPTNL, DATA, #4. OCT 20 OCT 010723 IOSTAT: INT*2, OPTNL, RESULT, #19. OCT 40 OCT 000314 ZBUF: ANY, OPTNL, DATA, #12. OCT 300 OCT 010315 ZLEN: INT*2, OPTNL, DATA, #13. OCT 300 OCT 010337 SEC: INT*2, OPTNL, DATA, #31. OCT 1400 OCT 010340 TER: INT*2, OPTNL, DATA, #32. OCT 1400 OCT 0 SKP OPEN EQU * OPEN OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 NO DEFAULT. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 NO DEFAULT. OCT 130106 FILE: CHAR, OPTNL, DATA, #6. OCT 100000 DEFAULT = NOP. OCT 130105 USE: CHAR, OPTNL, DATA, #5. ASC 1,EX DEFAULT = 'EX' OCT 130126 STATUS: CHAR, OPTNL, DATA, #22. ASC 1,UN DEFAULT = 'UN' OCT 130121 ACCESS: CHAR, OPTNL, DATA, #17. ASC 1,SE DEFAULT = 'SE' OCT 130107 FORM: CHAR, OPTNL, DATA, #7. OCT 100000 DEFAULT = NOP OCT 010112 RECL: INT*2, OPTNL, DATA, #10. OCT 100000 DEFAULT = 128 OCT 130116 BLANK: CHAR, OPTNL, DATA, #14. ASC 1,NU DEFAULT = 'NU' OCT 010111 NODE: INT*2, OPTNL, DATA, #9. DEC -1 DEFAULT = -1. OCT 010127 BUFSIZ: INT*2, OPTNL, DATA, #23. OCT 100000 DEFAULT = NOP OCT 010130 MAXREC: INT*2, OPTNL, DATA, #24. OCT 100000 DEFAULT = NOP OCT 0 * CLOSE EQU * CLOSE. OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 NO DEFAULT. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 NO DEFAULT. OCT 130126 STATUS: CHAR, OPTNL, DATA, #22. ASC 1,KE DEFAULT = 'KE' OCT 0 * BSENR EQU * BACKSPACE/ENDFILE/REWIND. OCT 010013 UNIT: INT*2, REQ'D, DATA, #11. DEC 0 OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 OCT 0 SKP INQUI EQU * INQUIRE. OCT 010113 UNIT: INT*2, OPTNL, DATA, #11. OCT 100000 DEFAULT: NOP. OCT 010423 IOSTAT: INT*2, REQ'D, RESULT, #19. DEC 0 OCT 130106 FILE: CHAR, OPTNL, DATA, #6. OCT 100000 DEFAULT: NOP. OCT 100430 MAXREC: INT*4, OPTNL, RESULT, #24. OCT 100000 DEFAULT: NOP. OCT 010136 BIT VECTOR. REQ'D, DATA, #30. DEC 0 OCT 030717 EXIST: LOG*2, OPTNL, RESULT, #15. K1 OCT 1 OCT 030725 OPENED: LOG*2, OPTNL, RESULT, #21. K2 OCT 2 OCT 010724 NUMBER: INT*2, OPTNL, RESULT, #20. OCT 4 OCT 030720 NAMED: LOG*2, OPTNL, RESULT, #16. B10 OCT 10 OCT 130710 NAME: CHAR, OPTNL, RESULT, #8. OCT 20 OCT 130705 USE: CHAR, OPTNL, RESULT, #5. OCT 40 OCT 130721 ACCESS: CHAR, OPTNL, RESULT, #17. OCT 100 OCT 130733 SEQ.: CHAR, OPTNL, RESULT, #27. OCT 200 OCT 130722 DIRECT: CHAR, OPTNL, RESULT, #18. OCT 400 OCT 130707 FORM: CHAR, OPTNL, RESULT, #7. B1000 OCT 1000 OCT 130732 FORMTD: CHAR, OPTNL, RESULT, #26. OCT 2000 OCT 130734 UNFMTD: CHAR, OPTNL, RESULT, #28. OCT 4000 OCT 010712 RECL: INT*2, OPTNL, RESULT, #10. B10K OCT 10000 OCT 100731 NXTREC: INT*4, OPTNL, RESULT, #25. OCT 20000 OCT 130716 BLANK: CHAR, OPTNL, RESULT, #14. OCT 40000 OCT 010711 NODE: INT*2, OPTNL, RESULT, #9. B100K OCT 100000 OCT 0 SPC 2 REL EQU B1000 F.AT=REL INT EQU B10K F.IM=INT TWPE EQU B40K F.IM=TWPE DBI EQU B100K F.IM=DBI SKP * TABLE TO ACCESS THE ABOVE TABLES BY STATEMENT ORDINAL. * DSTTP DEF *+1 DEF TO STATEMENT TEMPLATE TABLE POINTERS. DEF RDWRT 0 READ. DEF RDWRT 1 WRITE. DEF OPEN 2 OPEN. DEF CLOSE 3 CLOSE. DEF INQUI 4 INQUIRE. DEF BSENR 5 BACKSPACE/ENDFILE/REWIND. SKP * ****************** * * READ/WRITE END * * ****************** SPC 1 * IF OUTPUT, ISSUE 'JSB .DTA.' * RWE.F NOP LDA T1IOS FLAG. LDB .DTA. SZA WHICH ? JSB ODF.F WRITE, DO IT. * * DEFINE EXIT ADDRESS FOR FORMATTED; DO CONV, END/ERR. * LDA T1RWS F.A OF TWPE. INA ADDRESS TO STORE F.RPL . LDB F.RPL DO IT. STB A,I JSB IOEP CONVERSIONS, END=, ERR=. JSB CAR.F ZAP REGISTER DATA. JMP RWE.F,I DONE. SKP * ****************************** * * NEW 'RECORD' IN IMPLIED DO * * ****************************** SPC 1 * COMPUTE LENGTH OF PREVIOUS RECORD. * NR.F NOP LDA T2NR F.RPL AT START OF RECORD. CMA,INA ADA F.RPL LENGTH OF RECORD. STA T1NR,I STORE IN TWPE ENTRY FOR LAST RECORD. * * SET T2NR=F.RPL . IF FIRST REC, SET T1ILA=F.RPL . * LDA F.RPL STA T2NR LDB T1NR IS IT THE FIRST TIME ? SZB,RSS STA T1ILA YES, REMEMBER. * * SAVE F.A OF TWPE FOR NEW RECORD. * JSB RD.F STA T1NR REMEMBER WHERE TO SAVE ITS LENGTH. ISZ T1NR I.E., IN SECOND WORD OF TWPE. CLB,CCE ORG TO IT. RAL,ERA JSB OW.F OCT 20000 JMP NR.F,I DONE. SKP * ******************************************* * * SET LOAD ADDRESS OF IMPLIED DO 'RECORD' * * ******************************************* SPC 1 ILA.F NOP JSB RD.F (A) = F.A OF RECORD TO DEFINE. INA ADDRESS TO PUT LOAD ADDRESS. LDB A,I SAVE ITS LENGTH. STB T2ILA LDB T1ILA REPLACE IT WITH LOAD ADDRESS. STB A,I ADB T2ILA UPDATE LOAD ADDRESS. STB T1ILA JMP ILA.F,I EXIT. SPC 2 T1RWS NOP F.A OF TWPE FOR LIST END, ELSE -1. * T1NR NOP F.A+1 OF TWPE ENTRY OF NEW RECORD. T2NR NOP F.RPL AT START OF CURRENT RECORD. * T1ILA NOP TRUE LOAD ADDRESS AT END CURRENT RECORD. T2ILA NOP LENGTH NEW RECORD. * .EIO. ABS 47 .FIO. ABS 59 .BIO. ABS 65 .DTA. ABS 71 SPC 2 * ****************************** * * I/O LIST ELEMENT PROCESSOR * * ****************************** SPC 1 * SEE IF IN REGISTERS OR ARRAY NAME. * IOL.F NOP LDA F.S1T,I F.A OF RESULT. SZA IN REGISTER(S) ? CPA K1 JMP IOL01 YES. * STA F.A SET F.A TO ITEM. JSB MP1.F MAP IF IN EMA JSB GT1.F RESTORE F.IM CLA,INA DID IT GET MAPPED ? CPA F.S1T,I (IF SO, IN (B)) JMP IOL03 YES. ADDRESS IN REGISTERS. JMP IOL04 NO. NON-EMA VARIABLE OR CONSTANT. SKP * DATA OR ADDRESS IN REGISTERS. STORE IT. * IOL01 JSB GRD.F GET REG INFO. DEF F.S1T,I SOC ADDRESS ? JMP IOL02 YES. * LDB F.S1T,I NO. DATA. JSB SBR.F STORE IT. LDA F.A (A) = F.A OF DATA. JMP IOL04 * IOL02 STA F.IM SET TYPE OF ARRAY ELEMENT. LDA F.S1T,I REG #. IOL03 ALF,ALF STORE ADDRESS IN (A) OR (B). ALF,RAR (FORMS THE A/B BIT) ADA STAI LDB K2 STA/B *+2 JSB OZ.F (A=0). STA F.A SET F.A TO GENERATE NOP. * * MAKE COMPLEX INTO ARRAY. OUTPUT OTHERS. * IOL04 LDB F.IM TYPE ? CPB CPX IF COMPLEX, JMP IOL08 USE AS ARRAY, LENGTH=2. CPB ZPX DITTO, DOUBLE COMPLEX. JMP IOL07 * JSB MTR.F GET ORDINAL OF ROUTINE. DEF .IIO.-1 JSB ODF.F 'JSB ROUTINE' JSB OA.F OUTPUT DEF TO ELEMENT. JMP IOL05 DONE. EXIT. * * COMPLEX ELEMENT. DO AS REAL ARRAY. * IOL07 LDB .TAY (FOR DOUBLE COMPLEX, .TAY) RSS IOL08 LDB .RAY OUTPUT 'JSB .RAY.' JSB ODF.F JSB OA.F AND 'DEF ITEM' LDA K2 AND JSB OAD.F 'DEC 2' IOL05 JSB CAR.F ZAP REGISTER DATA. JMP IOL.F,I DONE. SPC 2 * .IIO. DEC 54,56,266 INT,REA,LOG K0 DEC 00 (TWPE) DEC 56,57 CPX,DBL DEC 00 (ADDR) DEC 55,266,58 DBI,LO4,RE8 CPX OCT 050000 ZPX OCT 140000 SKP * ************** * * ARRAY NAME * * ************** SPC 1 IOA.F NOP LDA F.S1T,I SET UP ASSIGNS. STA F.A JSB FA.F LDA F.VDM ANY VARIABLE DIMENSIONS ? SZA JMP IOA07 YES, GENERATE ARRAY SIZE CALC. CODE * CLA,INA STA F.D0+1 F.D0=1 (1ST WORD SHOULD BE ZERO) LDA F.IM CPA CPX F.IM=CPX? RSS CPA ZPX OR ZPX ? ISZ F.D0+1 YES, F.D0=2 JSB NWI.F F.D0=F.D0*(PRODUCT OF DIMENSIONS) DLD F.D0 SAVE ARRAY ELEMENT COUNT. DST T1IOA CCA (A)=-1 TO FLAG CONSTANT SIZE. JMP IOA10 * * VARIABLE ARRAY SIZE; GENERATE SIZE CALC. CODE. * IOA07 JSB CVA.F COMPUTE ARRAY SIZE, LEAVE ON STACK. LDA F.S1N,I RESTORE F.A & ASSIGNS FOR ARRAY. STA F.A JSB FA.F LDA F.S1T,I (A) = F.A OF SIZE. * * OUTPUT DOT FUNCTION. * IOA10 STA T3IOA F.A OF LENGTH. -1 IF CONST. LDB F.EM EMA ? SZB JMP IOA14 YES. * JSB MTR.F NO. GET ORDINAL OF ROUTINE. DEF .IAY.-1 STB T2IOA SAVE THE '.' FUNCTION OFFSET LDA T3IOA F.A OF LENGTH. SZA LENGTH IN (A) ? JMP IOA11 NO. * LDA STAI YES. DO 'STA *+3' LDB K3 JSB OZ.F (A=0) STA T1IOA+1 NOW SET UP TO OCT 0 IS GENERATED. CCA I.E., MAKE IT LOOK LIKE CONSTANT 0. STA T3IOA (STILL ON STACK, BUT WHO CARES ?) * IOA11 LDB T2IOA OUTPUT 'JSB .IAY.' ETC. JSB ODF.F JSB OA.F OUTPUT 'DEF ITEM' OR NOP. LDB T3IOA (B) = F.A OR -1 SSB,RSS SIZE CONSTANT ? JMP IOA13 NO. * LDA T1IOA+1 YES. (A) = SIZE, JSB OAD.F PUT IT INLINE. JMP IOL19 DONE. * IOA13 LDA B100K SIZE IN TEMP, JSB SOA.F INDIRECT SIZE (FORMAL PARAM) JMP IOL19 DONE. * .IAY. DEC 60 INT .RAY DEC 62,267 REA,LOG DEC 0 (TWPE) DEC 62,63 CPX,DBL DEC 0 (ADDR) DEC 61,269 DBI,LO4 .TAY DEC 64 RE8 DEC 0,64 CHAR,ZPX * .IAE. DEC 66,68,268 INT,REA,LOG DEC 0 (TWPE) DEC 68,69 CPX,DBL DEC 0 (ADDR) DEC 67,264,70 DBI,LO4,RE8 DEC 0,70 CHAR,ZPX SKP * OUTPUT ENTIRE EMA ARRAY. * IOA14 SSA SIZE CONSTANT ? JMP IOA15 YES. * JSB NEG.F NO. MUST NEGATE. (FORCES LOAD) LDA .SWP AND SWAP. JSB OAI.F 'SWP' JSB SRT.F NOW PUT IT IN TEMP. DEF K0 JSB PO1.F AND REMEMBER WHERE. STA T3IOA * IOA15 LDA F.S1T,I RESTORE ASSIGNS. STA F.A JSB FA.F JSB MTR.F GET ORDINAL OF ROUTINE. DEF .IAE.-1 JSB ODF.F OUTPUT THE JSB. DLD F.AF,I (B) = LOWER WORD OR F.A OF TEMP. LDA F.AT FORMAL PARAM ? CPA DUM JMP IOA16 YES. F.A OF TEMP. * LDA F.AF NO. GET UPPER WORD. ADA K3 LDA A,I .SWP SWP SET UP IN REVERSED ORDER. JSB DTR.F DEF TO THAT. JMP IOA17 ON TO LENGTH. * IOA16 JSB DEF.F FORMAL. GEN DEF TO TEMP, REVERSED ADDR. * IOA17 LDB T3IOA NOW DO LENGTH. IS IT A CONSTANT ? SSB JMP IOA18 YES. GO GENERATE IT. * JSB DEF.F NO. GENERATE DEF TO TEMP. JMP IOL19 AND DONE. * IOA18 LDB T1IOA GENERATE CONSTANT & DEF TO IT. LDA T1IOA+1 (IN REVERSED ORDER) CMB NEGATED. CMA,INA,SZA,RSS INB JSB DTR.F IOL19 JSB CAR.F ZAP REGISTER DATA. JMP IOA.F,I DONE. * T1IOA DEC 0,0 # WORDS IN ARRAY. T2IOA NOP OFFSET OF DOT FUNCTION. T3IOA NOP F.A OF DUMMY LENGTH, ELSE 0. SKP * ROUTINE TO CALCULATE VARIABLE ARRAY SIZE. * CVA.F NOP LDB F.ND GET # DIMS CMB,INB NEGATE. STB T1CVA & SAVE. LDA F.LUB ADDR BOUNDS TABLE. INA POINT IT TO FIRST DIM SIZE. STA T2CVA SET POINTER. LDA A,I GET F.A OF FIRST DIM SIZE, JSB PU1.F AND STACK IT. LDB F.EM IF EMA ARRAY, LDA DBI SZB JSB CTS.F ALL COMPUTATION IN DOUBLE INTEGER. JMP CVA02 START THE LOOP. * CVA01 ISZ T2CVA ADVANCE TO NEXT DIMENSION. ISZ T2CVA LDA T2CVA,I PUSH DIMENSION SIZE ON STACK. JSB PU1.F JSB MPY.F MULTIPLY INTO RUNNING PRODUCT. CVA02 ISZ T1CVA ANY MORE ? JMP CVA01 YES. DO THEM. * LDA F.IM COMPLEX ? CPA CPX RSS CPA ZPX RSS YES. JMP CVA.F,I NO. DONE. LDA K2 YES. DOUBLE IT. JSB EIC.F SET UP INTEGER 2, JSB PU1.F PUSH ON STACK, JSB MPY.F AND MULTIPLY. JMP CVA.F,I EXIT. * T1CVA NOP T2CVA NOP SKP * ROUTINE TO MAP TYPE TO ROUTINE ORDINAL. * MTR.F NOP LDB F.IM ITEM TYPE. LDA V.FMT SPECIAL TEST: IF FORMATTED, RAL,CLE,ERA (CLEAR SIGN) SZA,RSS JMP MTR01 LIST-DIRECTED/BINARY: LEAVE IT. * CPB LOG THEN PASS LOGICAL*2 LDB INT AS INTEGER*2, CPB LO4 AND LOGICAL*4 LDB DBI AS INTEGER*4. MTR01 BLF MOVE TYPE TO LOW 4 BITS. ADB MTR.F,I ADD TABLE BASE. ISZ MTR.F LDB B,I GET TABLE ENTRY. JMP MTR.F,I EXIT. SPC 2 * ROUTINE TO FORM DBL INT CONST & OUTPUT DEF TO IT. * DTR.F NOP DST F.IDI FORM IT. LDA DBI JSB ESC.F JSB AI.F ENTER IN SYMBOL TABLE. CLA OUTPUT DEF TO IT. JSB OA.F JMP DTR.F,I DONE. SKP * ************************ * * DATA STATEMENT ITEMS * * ************************ SPC 1 * GET THE ITEM F.A, THE OFFSET & THE REPEAT. * ORG TO THE START OF THE DATA. * DTA.F NOP JSB RD.F COPY F.A & FETCH ASSIGNS. STA F.A SZA (UNLESS NONE: PROGM RELATIVE) JSB FA.F JSB RD.F AND OFFSET. STA T0DTA JSB RD.F AND REPEAT. CLB USE ASCII BIT: RAL,CLE,SLA,ERA IF CLEAR, USE R=0, LDB B40K ELSE USE R=2. STB T4DTA IN OW.F CALL. CMA,CCE,INA (NEGATE FOR LOOP) (E=1) STA T1DTA LDA F.RPL SAVE CURRENT POSITION. LDB T0DTA (B) = OFFSET. STA T0DTA LDA F.A PROGRAM RELATIVE ? SZA,RSS JMP DTA03 YES. (B) = ADDRESS. * LDA F.AT LABELLED COMMON ? (BLOCKDATA) CPA BCOM JMP DTA01 YES. HARDER. * ADB F.AF (B) = ADDRESS. DTA03 STB F.RPL ORG THERE. JSB OLR.F JMP DTA02 * DTA01 LDA F.AF BCOM. (A) = F.A OF OFFSET ENTRY. INA ADD THE BCOM OFFSET TO THE ARRAY OFFSET. ADB A,I CCE,INA GET F.A OF THE MASTER ENTRY. LDA A,I RAL,ERA ADD SIGN. JSB OW.F ISSUE THE ORG. OCT 20000 DTA02 LDA F.COC SET UP THE DATA WORD COUNT. CMA,INA ADA K3 THREE HEADER WORDS. STA T2DTA - # DATA WORDS. * * COPY THE DATA TO THE F.IDI BUFFER. * LDA F.DID COPY TO F.IDI STA T3DTA DTA05 JSB RD.F ONE AT A TIME. STA T3DTA,I ISZ T3DTA ISZ T2DTA COUNT 'EM JMP DTA05 SKP * OUTPUT THE BUFFER (REPEAT COUNT) TIMES. * DTA04 LDA F.COC SET UP COUNT (AGAIN) CMA,INA ADA K3 (3 HEADER WORDS) STA T2DTA LDA F.DID AND POINTER. STA T3DTA DTA06 LDA T3DTA,I OUTPUT ANOTHER WORD. JSB OW.F T4DTA ABS *-* R=0 (OCTAL) OR R=2 (ASCII) ISZ T3DTA BUMP POINTER, ISZ T2DTA AND COUNTER. JMP DTA06 IF MORE THIS ITEM. * ISZ T1DTA BUMP REPEAT COUNTER. JMP DTA04 IF MORE TIMES. * LDA T0DTA RESTORE F.RPL STA F.RPL JSB OLR.F JMP DTA.F,I EXIT. * T0DTA NOP OFFSET SAVED F.RPL T1DTA NOP - REPEAT COUNT LEFT. T2DTA NOP BUFFER COUNTER. T3DTA NOP BUFFER POINTER. BCOM OCT 3000 F.AT=BCOM * END