File PASS2.PA (PAL assembler source file)

Directory of image this file is from
This file as a plain text file

/3  OS/8 FORTRAN  (PASS TWO)
/
/ VERSION 4A  PT 16-MAY-77
/
/	OS/8 FORTRAN COMPILER - PASS 2
/
/		BY: HANK MAURER
/		UPDATED BY: R. LARY + M. HURLEY
/
/
/COPYRIGHT  (C)  1974,1975 BY DIGITAL EQUIPMENT CORPORATION
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
/CORPORATION.  DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/FOR ANY ERRORS THAT MAY APPEAR IN THIS DOCUMENT.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
/
/DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
/OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
/DIGITAL.
/
/
/
VERSON=4

/SEE F4.PA FOR LIST OF MAINTENANCE RELEASE CHANGES -S.R. /ALSO, ADDED SAFETY CDF 0 TO BUMP ROUTINE TO FIX BUG /MASSAGED LINK IN THAT AREA TO GET ROOM /ALSO, / FIXED BUG RE DN ERROR PRINTING WRONG LINE NUMBER / / /CHANGES FOR OS/8 V3D AND OS/78 BY P.T. /.PATCH LEVEL FOR PASS2 IS IN LOCATION 327 IFNDEF OVERLY <OVERLY=0> IFNZRO OVERLY <NOPUNCH> *2 /V3C TEM, 1 /V3C LINENO, 1 /LINE NUMBER VERS, -VERSON /VERSION NUMBER ERRPTR, 5001 /POINTER TO THE ERROR LIST FILDEV, 0 /THIS IS THE FILE DESCRIPTOR FILBLK, 0 /FOR RALF X10, COMREG-1 /INTER PASS COM REGION X11, 0 X12, 0 X13, 0 X14, 0 X15, 0 X16, 0 X17, 0 /AUTO INDEX REGISTERS ENTRY, 0 /THINGS USED BY SYMBOL /TABLE FIDDLER OENTRY, 0 BUCKET, 0 TYPE, 0 TEMP, 0 /GENERAL TEMPS TEMP2, 0 ARG1, 0 /ARGS AND TYPES BASE1, 0 TYPE1, 0 ARG2, 0 BASE2, 0 TYPE2, 0 TMPCNT, 1 /TEMP COUNT TMPMAX, 0 /MAX TEMP COUNT LITNUM, 0 /LITERAL DISPLACEMENT TMPBLK=2 OUBUF=4400 COMREG=4600 STACK1=4700 OVRLAY=5000 NPOVLY=700 XRBUFR=6600 STACK=7000 /STACK-5 CAN'T BE 0 INBUF=7200 NPPAS3=1600 ARG, 0 /TEMP FOR CODE AC, 0 /AC FOR MULTIPLY ROUTINE XR, 0 /XR CHAR FOR OADDR MQ, 0 /MQ FOR MULTIPLY ROUTINE XRNUM, 0 /TEMP USED IN XR STUFF WHATAC, 0 /POINTER TO VAR WHATBS, 0 /JUST STORED FREEXR, 0 /NUMBER OF FREE /INDEX REG DIMPTR, 0 /POINTER TO DIM INFO /AFTER GETSS NARGS, 0 /ARG COUNT FOR SS VAR /COMPILE GLABEL, 1 /GENERATED LABEL COUNTER STKLVL, STACK /STACK LEVEL (CHANGED /BY DO) COMMA, 254 /, PLUS, 253 /+ IFLABL, 0 /HOLDS LABEL FOR LOG IF DOTEMP, 7000 /DO LOOP TEMP COUNTER BINARY, 0 /BINARY IO=1, FORMATTED=0 INPUT, 0 /INPUT=1 OUTPUT=0 FOR IO STMTS PROGNM, 0 /POINTER TO PROG/FUNC NAME FUNCTN, 0 /0=MAIN, 1=FUNC, -2=SUBR ARGLST, 0 /POINTER TO ARG LIST DATASW, 0 /=1 IF THIS IS A DATA STMT GCTEMP, 0 /TEMP USED BY GENCAL EXTLIT, 0 /EXTERNAL LITERALS LIST ELCNT, 0 /AND COUNT IOLOOP, 0 /IO LOOP SWITCH ARGIO, 0 /ARG IO SWITCH F1LNAM, 0617;2224;2216;2415 /FILE NAME FORTRN.TM DEVH, 7607 /DEVICE HANDLER ADDRESS ACSWIT, 0 /IS NON ZERO IF CALLING AN ARG IOSTMT, 0 /SET 1 IF IN IO STMT /(FOR IMPLIED LOOPS) FMODE, 1 /1 IF IN F OR D MODE (0 IF E) ASFSWT, 0 /1 IF ASF PROLOG, -1 IF /ASF END, 0 OTHER JSRLBL, 0 /LABEL NUMBER FOR CALLS TO ARGS DPUSED, 0 /=1 IF DP HARDWARE USED QM4, -4 Q260, 260 QTTYOU, TTYOUT QERMSG, ERMSG QNEXT, NEXT QNEXTM, NEXT-2 QUCODE, UCODE QCODE, CODE QINWOR, INWORD QONUMB, ONUMBR QSAVEA, SAVEAC Q6M3, Q5, 5 QGENCO, GENCOD QM6, -6 QOPCOD, OPCOD QOPCDE, OPCODE QOADDR, OADDR Q17, 17 QTTYMS, TTYMSG QXRTBL, XRTABL QCHKXR, CHEKXR QGENSF, GENSTF QGENSE, GENSTE QOSNUM, OSNUM QCRLF, CRLF QOTAB, OTAB QOUTSY, OUTSYM QGARG, GARG Q20, 20 Q40, 40 QOUTNA, OUTNAM QLITRL, LITRL Q200, 200 Q255, 255 Q3, 3 QOLABE, OLABEL QGETSS, GETSS Q256, 256 QSAVAC, SAVACT QSKPIR, SKPIRL QGENCA, GENCAL QLOADA, LOADA QMUL12, MUL12 QGARGS, GARGS QOINS, OINS QOCHAR, OCHAR QNUMBR, NUMBRO QXRBUF, XRBUFR QTTYP2, TTYP2C QTTCRL, TTCRLF QM63, -63 Q7605, 7605 RELCD, 0 QLABEL, NLABEL P0F1, 5274 /101-2605 P0F2, VERROR
/ OUTPUT UTILTIY ROUTINES PAGE OCNT, CRLF, 0 /OUTPUT CR LF TAD (215 JMS I QOCHAR TAD (212 JMS I QOCHAR TAD (200 KRS TAD (-203 SNA CLA KSF /CHECK FOR ^C JMP I CRLF JMP I (7605 NCHAR, OSNUM, 0 /PRINT STMT NUMBER IAC /SKIP POINTER WORD DCA NAMPTR TAD (6211 /ALWAYS IN FIELD 1 DCA NAMCDF TAD OSNUM /SAVE ENTRY POINT DCA OUTNAM TAD (243 /GET FIRST CHAR (ALWAYS #) JMP L6201 /GO PRINT NAME TTCHAR, OUTSYM, 0 /PRINT OPCODE DCA NAMPTR /SAVE POINTER TO STUFF TAD L6201 /ALWAYS FIELD 0 DCA NAMCDF TAD OUTSYM /SAVE ENTRY DCA OUTNAM JMP NAMCDF /PRINT REST ONUMT, OUTNAM, 0 /OUTPUT NAME DCA NAMPTR /SAVE ADDRESS OF NAME RDF /GET FIELD OF NAME TAD L6201 DCA NAMCDF /SAVE AS CDF TAD I NAMPTR /GET FIRST CHAR (ALREADY ASCII) ISZ NAMPTR /SKIP OVER TYPE AND DIM PTR ISZ NAMPTR L6201, CDF JMS I QOCHAR /OUTPUT CHAR ISZ NAMPTR NAMCDF, 0 TAD I NAMPTR /GET NEXT TWO CHARS CDF SNA /IS NAME DONE ? JMP I OUTNAM /YES DCA NCHAR /SAVE TWO CHARS TAD NCHAR RTR /GET UPPER CHAR RTR RTR TAD (240 AND (77 TAD (240 JMS I QOCHAR /OUTPUT IT TAD NCHAR /NOW DO LOWER AND (77 SNA JMP I OUTNAM /NAME DONE TAD (240 AND (77 TAD (240 JMP L6201+1 /GO AND OUTPUT IT ONUMBR, 0 /OUTPUT OCTAL NUMBER DCA ONUMT /SAVE TEMPORARILY TAD QM4 /4 DIGITS DCA OCNT OLOOP, TAD ONUMT CLL RTL RAL DCA ONUMT TAD ONUMT RAL AND (7 TAD Q260 JMS I QOCHAR ISZ OCNT JMP OLOOP JMP I ONUMBR TTYP2C, 0 /PRINT 2 CHARS ON THE TTY DCA TTCHAR TAD TTCHAR RTR RTR RTR JMS CONVRT TAD TTCHAR JMS CONVRT JMP I TTYP2C NAMPTR, CONVRT, 6401 /CONVERT TO ASCII AND (77 SZA TAD (240 AND (77 TAD (240 JMS I QTTYOUT JMP I CONVRT TTCRLF, 0 TAD (215 JMS I QTTYOUT TAD (212 JMS I QTTYOUT JMP I TTCRLF TTYMSG, 0 /PRINT 2 CHAR ERROR MESSAGE CDF TAD I TTYMSG ISZ TTYMSG /PRINT ERROR MESSAGE JMS I QERMSG FATAL, JMP I QNEXT /FATAL ERROR MESSAGE TAD I FATAL JMS I QERMSG JMP I Q7605 /RETURN TO PS8 DP2C1, TEXT '.+2,1' NEG, JMS I QUCODE /NEGATE CODE NEGTBL-1 JMP I QNEXT PAGE
/ OPCODE JUMP TABLE TAD TEMP2 SKP /CODE ALREADY READ NEXT, JMS I QINWORD /GET NEXT INPUT WORD TAD (XPUSH /INDEX INTO JUMP TABLE DCA TEMP2 CDF 10 TAD I TEMP2 CDF 0 DCA TEMP2 /GET JUMP ADDRESS JMP I TEMP2 /GO THERE
/OPTIMIZING RELATIONAL CODE FOR OS/8 F4 /COMPLIMENTS OF R.L. LE, STL RTL /2 LT, TAD QM4 /GENERATE -4 FOR LT, -2 FOR LE JMP GE+1 /GO TO COMMON RELATIONAL CODE GT, STL RTL GE, IAC /GENERATE 1 FOR GE, 3 FOR GT DCA RELCD /ALL THIS FUNNY STUFF IS BECAUSE SOME JMS I QCODE /OF THE RELATIONAL SKELETONS OPTIMIZE BY LETABL-6;5 /PERFORMING THE RELATIONAL ON THE NEGATIVE TAD RELCD /OF THE FAC - WHEN THIS HAPPENS SPECIAL SPA /CODE IN THE SKELETON DOES AN "ISZ RELCD", CIA /CHANGING ABS(RELCD) TO ITS OPPOSITE RELATIONAL JMP RELGEN /E.G. GE(1) TO LE(2), LE(-2) TO GE(-1) EQ, CLA IAC /SINCE EQ AND NE ARE SIGN-INDEPENDENT, NE, DCA RELCD /WE DON'T NEED THAT KLUDGE BUT FOR COMPATIBILITY JMS I QCODE /WITH RTPS THE OS/8 FORTRAN SYSTEM FUNCTION EQTABL-6;5 /"#CEQ" WORKS THE WRONG WAY - IT PRODUCES CLA IAC /A 1.0 IF THE COMPLEX AC WAS (0.,0.) AND RELCD /AND A 0.0 OTHERWISE - SO WE HAVE TO REVERSE SZA CLA /THE SENSE OF COMPLEX .EQ. AND .NE. RELATIONS. RELGM1, TAD Q5 RELGEN, DCA RELCD /STORE "FINAL" RELCD JMS I QINWORD /GENTLY PROBE AHEAD IN THE INPUT DCA TEMP2 TAD TEMP2 TAD (XPUSH-XLOGIF SNA CLA /IF THIS WAS THE TOP RELATION OF A LOGICAL IF, JMP LIFOPT /WE'RE IN A POSITION TO OPTIMIZE TAD RELCD /OTHERWISE OUTPUT A CALL TO THE CLL RAL /ROUTINE CORRESPONDING TO THE RELATIONAL TAD (LTRNE DCA .+3 CLA IAC JMS I (OJSR /GENERATE A JSA #XX 0 JMP I QNEXTM2 /PROCESS THE WHATCHIMACALLIT LIFOPT, TAD TYPE1 /SEE IF WE SHOULD GENERATE A "STARTF" FIRST AND Q17 /ONLY WORRY ABOUT D.P. TAD QM4 /SINCE THE ROUTINE #CEQ DOES A STARTF DCA FMODE /FMODE=0 ONLY IF ARGS WERE D.P. JMS I QGENSF /GENERATE STARTF IF NECESSARY JMP I .+1 LIFBGN+1 /GO TO LOGICAL IF PROCESSOR EQV, JMS I QCODE /.EQV. LOGICAL OPERATOR EQVTBL-6;0 JMP RELGM1
/ PASS TWO OUTPUT ROUTINE OCHAR, 0 /OUTPUT A CHAR TO THE /RALF INPUT FILE AND (377 DCA OUTEMP /SAVE CHAR ISZ OUJUMP /BUMP THREE WAY SWITCH OUJUMP, JMP . JMP CHAR1 JMP CHAR2 TAD OUTEMP /HIGH FOUR BITS GO INTO CLL RTL /THE HIGH ORDER BITS OF THE RTL /FIRST WORD OF THE TWO WORD PAIR AND (7400 /SEE NOTE * BELOW TAD I OUPOLD /COMBINE WITH OTHER BITS DCA I OUPOLD TAD OUTEMP /THE OTHER FOUR BITS OF THIS CHAR CLL RTR /GO INTO THE HIGH ORDER FOUR RTR /BITS OF THE SECOND /WORD OF THE PAIR RAR AND (7400 TAD I OUPTR DCA I OUPTR TAD OUJMP /RESET 3 WAY BRANCH DCA OUJUMP ISZ OUPTR /BUMP BUFFER POINTER ISZ OUWDCT /AND DOUBLE WORD COUNTER JMP I OCHAR /BUFFER NOT FULL JMS OUDUMP /DUMP IT JMP I OCHAR CHAR2, TAD OUPTR /SAVE FIRST WORD POINTER DCA OUPOLD ISZ OUPTR /GO TO SECOND WORD CHAR1, TAD OUTEMP /STORE CHAR 1 OR 2 DCA I OUPTR JMP I OCHAR OUTEMP, OUDUMP, 0 /BUMP THE DUFFER TAD OSIZE /ANY ROOM LEFT ? SNA JMP OUERR IAC DCA OSIZE /YES, ITS OK JMS I DEVH /WRITE 4200 /CONTROL WORD OUBUF /BUFFER POINTER OBLOCK, 0 /BLOCK NUMBER JMP OUERR /ERROR ISZ OBLOCK /INCREMENT BLOCK NUMBER ISZ FILSIZ /AND FILE SIZE TAD OBLOCK-1 /SET BUFFER POINTER DCA OUPTR TAD (-200 /SET DOUBLE WORD COUNT DCA OUWDCT JMP I OUDUMP OUERR, JMS I (FATAL /FATAL OUTPUT ERROR 1706 / * THE PONY EXPRESS STARTED IN 1860 AND ONLY RAN / FOR 19 MONTHS WHILE LOSING $200,000. OUPOLD, 0 OUPTR, OUBUF OUJMP, JMP OUJUMP OUWDCT, -200 OSIZE, 0 DD1, TEXT '1' PAGE
/ READ FROM FORTRN.TM INWORD, 0 /READ A WORD FROM INPUT FILE ISZ INBCNT /ANYTHING LEFT IN BUFFER ? JMP NOREAD /YES ISZ INRCNT /ANYTHING LEFT IN FILE? SKP JMP I (END /NO, END OF PROG JMS I DEVH /READ NEXT BLOCK X200, 0200 INBUF INBLOK, 0 JMP INERR /INPUT ERROR ISZ INBLOK /BUMP BLOCK NUMBER TAD (-400 /RESET COUNTER DCA INBCNT TAD INBLOK-1 /RESET POINTER DCA INBPTR NOREAD, TAD I INBPTR /GET WORD FROM BUFFER ISZ INBPTR /BUMP BUFFER POINTER JMP I INWORD INERR, JMS I (FATAL /FATAL INPUT ERROR 1105 INBCNT, -1 /FORCE READ FIRST TIME INBPTR, 0 INRCNT, 0
/ CODE UTILITIES GETSS, 0 /GET POINTER TO DIM INFO CDF 10 IAC DCA DIMPTR /ADDR OF TYPE WORD TAD I DIMPTR ISZ DIMPTR /MOVE TO DIM/EQUIV POINTER AND X200 /EQUIV INFO ? SNA CLA JMP .+3 /NONE TAD I DIMPTR /SKIP EQUIV INFO DCA DIMPTR TAD I DIMPTR /ADDRESS OF DIM INFO JMP I GETSS NUMBRO, 0 /OUTPUT 15 BIT OCTAL NUMBER TAD AC /IS HIGH DIGIT 0 ? SNA JMP .+3 /YES, PRINT 4 DIGITS ONLY TAD Q260 /MAKE IT ASCII JMS I QOCHAR /PUT IT TAD MQ /NOW LOW FOUR DIGITS JMS I QONUMBR JMP I NUMBRO UCODE, 0 /GEN CODE FOR UNARY OPERATORS JMS I QSAVEAC /SAVE AC IF NEEDED JMS GARG JMP OTERR /OPERATOR/TYPE ERROR TAD ARG1 /IS ARG IN AC ? SNA CLA TAD Q5 /YES, USE SECOND HALF OF TABLE TAD TYPE1 TAD I UCODE /PLUS TABLE ADDRESS DCA USKEL CDF 10 TAD I USKEL /ADDR OF SKELETON SNA JMP OTERR /0 MEANS BAD /OPERATOR/TYPE COMBO DCA USKEL /SAVE SKELETON ADDR JMS I QGENCOD /GO DO THE CODE USKEL, 0 DCA I X16 /RESULT IN AC ISZ X16 /BUMP STACK POINTER ISZ X16 /TYPE IS ALREADY THERE ISZ UCODE /FIX RET ADDR JMP I UCODE GARG, 0 /GET ONE ARG CLL CMA RTL /BACK UP ONE ENTRY TAD X16 DCA X16 TAD X16 /USABLE POINTER DCA X15 TAD I X15 /GET OPERAND DCA ARG1 TAD I X15 DCA TYPE1 TAD I X15 DCA BASE1 TAD TYPE1 /CHECK TYPE TAD QM6 SMA CLA JMP I GARG /TAKE ERROR EXIT ISZ ARG2 /MAKE SURE ARG2 ISN'T ZERO JMS I (MPTRA1 /MOVE THE POINTER IF /THERE IS ONE ISZ GARG JMP I GARG TTYOUT, 0 /OUTPUT TO THE TTY TLS TSF JMP .-1 CLA KSF JMP I TTYOUT /NO KEYBOARD FLAG KRB AND (177 /ACCEPT PARITY ASCII TAD (-3 /^C ? SNA JMP I Q7605 /YES, BACK TO PS8 TAD (3-17 /^O ? SZA CLA JMP I TTYOUT /NO, RETURN DCA TTYOUT+1 /KILL OUTPUT STUFF DCA TTYOUT+2 DCA TTYOUT+3 JMP I TTYOUT /RETURN
LTRNE, TEXT '#NE' TEXT '#GE' TEXT '#LE' TEXT '#GT' TEXT '#LT' TEXT '#EQ' PAGE
/ SOME TEXT P2, TEXT '+2' XVAL, TEXT '#VAL' DP4, TEXT '.+4' FADD, TEXT 'FADD' FLDA, TEXT 'FLDA' FSUB, TEXT 'FSUB'
/ SAVE AC ROUTINES SAVACT, 0 /SAVE TOP OF STACK IF /NECESSARY TAD SAVACT /SAVE RETURN ADDR DCA SAVEAC CLL CMA RAL JMP SAVEAC+2 /BACK UP ONLY ONE ENTRY SAVEAC, 0 /STORE AC IF NEEDED TAD (-5 /LOOK AT STACK TWO DOWN TAD X16 DCA SATEMP TAD I SATEMP /IF 0, RESULT WAS LEFT IN AC SZA CLA JMP I SAVEAC /NO, NO STORE NEEDED TAD TMPCNT /STORE TEMP NUMBER DCA I SATEMP ISZ SATEMP /MOVE TO TYPE WORD TAD I SATEMP /GET TYPE JMS SAVE /GO DO ACTUAL STORE JMP I SAVEAC SAVE, 0 /SAVE AC DCA ACSTOR /THIS IS THE TYPE TAD ACSTOR /IS IT COMPLEX OR DOUBLE? TAD QM4 SNA JMP NOC /ITS DOUBLE IAC SZA CLA JMP NOCORD /NO JMS I QGENCOD /STARTE; FLDA #CAC SEGCAC-1 NOC, JMS ACSTOR /%FSTA #TMP+XXXX JMS TMPBMP /THIS USE TWO TEMPS JMP I SAVE NOCORD, JMS ACSTOR /%FSTA #TMP+XXXX JMP I SAVE
SATEMP, ACSTOR, 0 /GENERATES FSTA TEMP+XXXX JMS I QOPCOD /OUTPUT %FSTA %TEMP+XXXX FSTA JMS I QOADDR TMPCNT /TMPCNT CONTAINS THE /ARG NUMBER JMS TMPBMP /BUMP TEMPORARY NUMBER JMP I ACSTOR TMPBMP, 0 /ROUTINE TO BUMP TEMPORARIES TAD TMPCNT /BIGGER THAN MAX? CIA CLL TAD TMPMAX SZL CLA JMP .+3 /GO BUMP TEMP CNT TAD TMPCNT /NEW TEMP MAX DCA TMPMAX ISZ TMPCNT /INCR TEMP COUNT JMP I TMPBMP
/ PUSH ARG ONTO STACK PUSH, JMS SAVEAC /GO SAVE AC IF NEEDED JMS I QINWORD /GET ADDR OF NEW VAR DCA TEMP /SAVE IT TAD TEMP /PUSH IT DCA I X16 ISZ TEMP /GO TO TYPE CDF 10 TAD I TEMP /GET TYPE CDF AND Q17 /PUSH TYPE DCA I X16 /ONTO STACK CKPDL, DCA I X16 /ZERO BASE WORD TAD X16 /IS STACK FULL ? CIA CLL TAD (STACK+177 SZL CLA JMP I QNEXT /NO, OK TAD STKLVL /RESET STACK LEVEL DCA X16 JMS I QTTYMSG /PRINT MESSAGE 2004 DPUSH, JMS I QINWORD /GET THE VAR NAME PTR DCA I X16 /PUSH IT JMS I QINWORD /NOW GET THE DISPLACEMENT JMP CKPDL-1 /GO CHECK FOR OVERFLOW STARTF, TEXT 'STARTF'
/ ARITHMETIC IF ARTHIF, JMS I QUCODE /GET ARG INTO AC AIFTBL-1 JMS I QGENSF /DO ALL TRANSFERS IN FMODE TAD (JLT /FIRST OPCODE DCA AJUMP AIFLUP, JMS I QINWORD /GET NEXT INPUT DCA TEMP2 /SAVE IT IN CASE ITS NOT LABEL TAD TEMP2 CLL TAD (XPUSH-XLAST /IS IT A LABEL ? SNL CLA JMP I QNEXTM2 /NO, PROCEED JMS I QOPCDE AJUMP, 0 /OUTPUT CORRECT JUMP TAD TEMP2 CDF 10 JMS I QOSNUM /NOW THE LABEL JMS I QCRLF ISZ AJUMP /MOVE TO NEXT OPCODE ISZ AJUMP JMP AIFLUP DOT, TEXT '.' DP8, TEXT '.+10' PAGE
/ PICK UP TOP TWO ARGS GARGS, 0 /GET TOP 2 ARGS FROM STACK TAD X16 TAD QM6 /BACK TWO OPERANDS DCA X15 TAD X15 DCA X16 /AND OFFICIALLY POP THE STACK TAD I X15 /GET FIRST ARG DCA ARG1 TAD I X15 /AND TYPE DCA TYPE1 TAD I X15 DCA BASE1 /AND FIRST BASE (IN /CASE OF SS) TAD I X15 /NOW SECOND ARG DCA ARG2 TAD I X15 DCA TYPE2 TAD I X15 DCA BASE2 TAD TYPE1 /TYPES MUST BE LT 6 TAD QM6 SMA CLA JMP I GARGS /RETURN BAD TAD TYPE2 TAD QM6 SPA CLA ISZ GARGS /FIX RETURN JMS MPTRA1 /GET ARG1 POINTER IF NEEDED TAD ARG2 /IS ARG2 A POINTER TAD (-61 SZA CLA JMP I GARGS /NO, RETURN TAD ARG1 /IS ARG1 IN THE AC ? SZA CLA JMP .+5 /NO TAD TMPCNT /YES, STORE THE AC DCA ARG1 TAD TYPE1 /GET TYPE JMS I (SAVE TAD BASE2 /MOVE POINTER FROM TEMP /TO BASE+3 DCA ARG2 JMS I QGENCOD MPTR3-1 TAD (62 /ARG IS NOW POINTED TO /BY BASE+3 DCA ARG2 JMP I GARGS MPTRA1, 0 /MOVE ARG1 POINTER TO BASE TAD ARG1 TAD (-61 SZA CLA JMP I MPTRA1 TAD ARG2 SZA CLA JMP .+5 TAD TMPCNT DCA ARG2 TAD TYPE2 /GET THE TYPE JMS I (SAVE TAD BASE1 DCA ARG1 JMS I QGENCOD MPTR0-1 TAD (61 DCA ARG1 /SET ARG1 TO IND0 JMP I MPTRA1
/ BINARY OPERATORS CODE, 0 /GENERATE CODE FOR /BINARY OPERATORS JMS GARGS /GET OPERANDS JMP OTERR /BAD TYPE OPERATOR COMBO TAD TYPE1 /INDEX INTO TYPE CHECK TABLE CLL RTL TAD TYPE1 TAD TYPE2 CLL RAL TAD (TYPMIX-14 /POINTER TO CORRECT ENTRY DCA SKEL CDF 10 TAD I SKEL /RESULTING TYPE SNA JMP TYPERR /THIS MIX IS ILLEGAL DCA TYPE1 /SAVE RESULT TYPE ISZ SKEL /GET INDEX INTO /SKELETON TABLE TAD I SKEL CDF TAD I CODE /PLUS BASE GIVES ADDR /OF M,AC CASE DCA SKEL CDF 10 TAD I SKEL /IS THIS TYPE OPER /COMBO LEGAL ? SNA CLA JMP OTERR /NO ISZ CODE /POINTS TO RESULTING TYPE TAD ARG2 SZA CLA ISZ SKEL /SECOND ARG IS IN MEMORY TAD ARG1 SNA CLA /SKIP ON M,M CASE ISZ SKEL /MOVE TO AC,M CASE TAD I SKEL /PICK UP POINTER TO SKELETON DCA SKEL JMS I QGENCOD /GO DO THE CODE SKEL, 0 DCA I X16 /RESULT IS IN THE AC TAD I CODE SNA /IS TYPE SAME AS ARGS ? TAD TYPE1 /YES DCA I X16 /STORE IT DCA I X16 /ZERO BASE WORD TAD I CODE /IS TYPE SAME AS ARGS ? SZA DCA FMODE /NO, WE'RE NOW IN FMODE JMP I CODE TYPERR, JMS BUMP /PUT FALSE VALUE ONTO STACK JMS I QTTYMSG /OUTPUT ERROR 1524 OTERR, JMS BUMP /PUT FALSE VALUE ONTO STACK JMS I QTTYMSG 1724 XDPP6, TEXT '#DPT+6' XFIX, TEXT '#FIX' PAGE
/ CODE GENERATOR (FROM SKELETONS) GENCOD, 0 /CODE GENERATOR ROUTINE CDF TAD X14 DCA TEMP14 /FIX COMPLEX FUNCTION BUG TAD I GENCOD /GET SKELETON ADDRESS ISZ GENCOD MPOPUP, DCA X14 /HERE ON MACRO END DCA MRETN CODLUP, CDF 10 /STUFF IS IN FIELD 1 TAD I X14 /GET OPCODE CDF SNA JMP ENDM /IS IT END OF A MACRO ? SPA JMP MACRO /ITS A MACRO REFERENCE DCA .+2 /SAVE OPCODE JMS I QOPCOD /OUTPUT IT 0 CDF 10 TAD I X14 /ADDRESS ? CDF SNA JMP NOADDR /NO OPERAND FOR THIS INSTR SPA JMP DOADDR /ADDRESS IS AN OPERAND DCA TEMP JMS I QOTAB /ADDRESS IS A SPECIFIC TAD TEMP JMS I QOUTSYM NOADDR, JMS I QCRLF JMP CODLUP /DO NEXT LINE DOADDR, IAC /IS IT ARG1 ? SZA CLA JMP ITSA2 /NO, ITS ARG2 JMS I QOADDR /OUTPUT ARG1 ADDRESS FIELD ARG1 JMP CODLUP ITSA2, JMS I QOADDR /OUTPUT ARG2 ADDRESS ARG2 /FIELD JMP CODLUP MACRO, TAD Q5 /CODES BETWEEN -1 AND -5 ARE SPECIAL SPA JMP .+4 /NOT ONE OF THEM TAD (JMP MJTBL DCA .+1 HLT /GO TO PROPER ROUTINE DCA MSTART /SAVE START OF MACRO TAD X14 /SAVE RETURN ADDRESS DCA MRETN TAD MSTART /GO DO MACRO DCA X14 JMP CODLUP
ENDM, TAD MRETN /WAS THIS A MACRO ? SZA JMP MPOPUP /YES - GET OUT OF IT TAD TEMP14 DCA X14 /RESTORE X14 FOR FUNCAL JMP I GENCOD /AND EXIT LOADA1, JMS I (LOADA /GENERATE LOAD ARG1 /IF NECESSARY JMP CODLUP LOADA2, JMS I (LOADA /GENERATE LOAD ARG2 /IF NECESSARY JMP CODLUP DOSTE, JMS I QGENSE /STARTE IF IN F MODE JMP CODLUP SGNNEG, ISZ RELCD /CHANGE SIGN OF RELATIONAL OPERATOR JMP CODLUP MSTART=TEMP MRETN, 0 /MACRO RETURN ADDRESS TEMP14, 0 MJTBL, JMP SGNNEG /-5 - NEGATE RELATIONAL SIGN JMP LOADA2 /-4 - LOAD ARG 2 JMP LOADA1 /-3 - LOAD ARG 1 JMP DOSTE /-2 - START E MODE JMS I QGENSF /-1 - START F MODE JMP CODLUP XSET, TEXT 'SETX' ZEROC1, TEXT '0,1'
/ GOTO'S AND ASSIGN CGOTO, JMS GTSTUF /LOOK AT INDEX JMS I QGENCOD /OUTPUT COMPUTED GOTO CODE CGTCOD-1 JMS I QINWORD /GET COUNT CIA DCA TEMP2 CGTLUP, JMS JAGEN ISZ TEMP2 JMP CGTLUP JMP I QNEXT GOTO, JMS I QGENSF /ALL TRANSFERS IN F MODE JMS JAGEN JMP I QNEXT JAGEN, 0 JMS I QOPCDE /OUTPUT JA'S JA JMS I QINWORD /GET THE LABEL CDF 10 JMS I QOSNUM /OUTPUT IT AS THE ADDRESS JMS I QCRLF JMP I JAGEN GTSTUF, 0 JMS I QGARG /GET THE ARG JMP GTTYPE CLL CMA RTL /CHECK THE TYPE TAD TYPE1 SMA CLA JMP GTTYPE /NOT INTEGER OR REAL TAD ARG1 /IS IT IN THE AC ? SNA CLA JMP I GTSTUF /YES ALREADY JMS I QGENCOD GI-1 /LOAD THE INDEX JMP I GTSTUF GTTYPE, JMS I QTTYMSG /GOTO TYPE ERROR 0726 JAC, TEXT 'JAC' FSTA, TEXT 'FSTA' FNEG, TEXT 'FNEG' PAGE
/ ADDRESS FIELD OUTPUT OADDR, 0 /OUTPUT ADDRESS FIELD TAD I OADDR /GET ADDRESS OF PARAMETERS DCA ARG ISZ OADDR TAD I ARG /GET VALUE OF ARG CLL TAD (-52 /IS IT A TEMP REFNCE SNL JMP TMPREF /YES, 1-51 TAD (52-61 /IS IT AN ARRAY REFERENCE ? SZL JMP SSREF /YES, 52-60 IS XR1-XR7 SNA JMP IND0 /INDIRECT THROUGH 0 TAD (61-7000 /CHECK FOR DO TEMP SZL JMP DOTMP TAD (7000-62 SNA JMP IND3 /INDIRECT THROUGH 3 TAD (63 DCA TEMP CDF 10 TAD I TEMP /IS THIS AN ARG ? AND Q20 CDF SZA CLA JMP INDARG /YES, REF IT INDIRECTLY JMS I QOTAB CDF 10 TAD I TEMP /LOOK AT TYPE WORD AND (50 /IS IT LIT OR STMT NO.? SNA JMP OUTA /NO, JUST OUTPUT ADDRESS AND Q40 SNA CLA JMP OUTSN /OUTPUT STMT NUMBER JMP OUTLIT /OUTPUT LITERAL OUTA, TAD PROGNM /IS THIS THE FUNCTION NAME ? CIA TAD TEMP SNA CLA JMP FUNNAM /YES, REFERENCE #VAL INSTEAD OUTA2, CLA CMA /SIMPLE LOCAL VARIABLE REFNCE TAD TEMP /ADDRESS OF VAR JMS I QOUTNAM /INTO ADDR FIELD JMS I QCRLF JMP I OADDR /END OF ADDRESS OUTLIT, ISZ TEMP /MOVE TO LITERAL NUMBER TAD I TEMP DCA TEMP /DISPLACEMENT FROM %LITRL CDF TAD QLITRL /OUTPUT #LIT+ JMS I QOUTSYM TAD TEMP /DISPLACEMENT JMS I QONUMBR JMP OADRET-1 FUNNAM, TAD (XVAL /#VAL JMS I QOUTSYM JMP OADRET-1 SSREF, TAD (270 /MAKE IT AN ASCII DIGIT DCA XR ISZ ARG /POINT TO THE BASE WORD TAD I ARG /GET THE ADDR OF THE BASE DCA ARG CDF 10 TAD ARG IAC /GO TO TYPE OF BASE VAR DCA TEMP2 TAD I TEMP2 /IS IT AN ARG TO THE SUBR ? AND Q20 SNA CLA JMP NOTARG /NO, NO INDIRECT STUFF CDF JMS SIT TAD ARG /VAR NAME CDF 10 JMS I QOUTNAM TAD COMMA JMS I QOCHAR TAD XR /XR NUMBER JMS I QOCHAR JMS I QCRLF OADRET, JMP I OADDR IND3, TAD (XBASP3-XBASE /INDIRECT THRU #BASE+3 IND0, TAD (XBASE /INDIRECT THRU #BASE DCA TEMP JMS SIT TAD TEMP JMP FUNNAM+1 OUTSN, CLA CMA /OUTPUT STMT NUMBER TAD TEMP JMS I QOSNUM /OUTPUT THE NUMBER TAD (P2 /+2 (HACK FOR FORMAT) JMP FUNNAM+1 INDARG, JMS SIT /INDIRECT INDICATOR CDF 10 JMP OUTA2 /OUTPUT ARG NAME SIT, 0 TAD (245 /% (INDIRECT) JMS I QOCHAR JMS I QOTAB JMP I SIT CEQ, TEXT '#CEQ' XBAC1P, TEXT '#BASE,1+' XUE, TEXT '#UE' PAGE
/ ADDRESS FIELD OUTPUT NOTARG, TAD I TEMP2 /GET TYPE WORD DCA TEMP /SAVE IT TAD TEMP ISZ TEMP2 AND Q200 /EQUIVALENCED ? SNA CLA JMP .+3 TAD I TEMP2 /SKIP EQUIV INFO BLOCK DCA TEMP2 CLL CML RTL TAD I TEMP2 /ADDRESS OF MAGIC NUMBER DCA TEMP2 TAD I TEMP2 /MAGIC NUMBER ITSELF DCA TEMP2 CDF JMS I QOTAB /TAB TAD ARG /OUTPUT VARIABLE MINUS CONST JMS VMC TAD COMMA JMS I QOCHAR TAD XR /N JMS I QOCHAR JMS I QCRLF /END OF LINE JMP OADRET DOTMP, DCA TEMP /ADDRESS RELATIVE TO %DOTMP JMS I QOTAB TAD (DOTMPN /OUTPUT #DOTMP JMS I QOUTSYM JMP PLUSN /GO OUTPUT +XXXX TMPREF, CLA TAD I ARG /BUMP TEMPS BACK CORRECTLY (?) DCA TMPCNT JMS I QOTAB /TAB CLA CMA TAD I ARG /GET NUMBER DCA TEMP /INTO TEMP IFNZRO TMPBLK-2 <XXXXXX> CLL STA RAL /V3C -2 (-TMPBLK) /V3C LINK SET TAD TEMP /V3C (SAVES A LITERAL) SNL /V3C DCA TEMP /YES, SAVE ALTERED DISPLACEMENT SNL CLA /V3C TAD (TEMPN2-TEMPN /USE %TEMPX TAD (TEMPN /USE %TEMP JMS I QOUTSYM PLUSN, TAD PLUS /PLUS CONSTANT JMS I QOCHAR TAD TEMP /DISPLACEMENT TIMES THREE CLL RAL TAD TEMP JMS I QONUMBR /OUT IT JMS I QCRLF JMP OADRET
/ UTILITIES VMC, 0 /OUTPUT VARIABLE MINUS CONST CDF 10 JMS I QOUTNAM /PUT VAR NAME TAD Q255 /- JMS I QOCHAR TAD TEMP /THIS CONTAINS THE TYPE JMS SKPIRL /SKIP ON I,R OR L TAD Q3 /USE SIX WORDS PER ENTRY TAD Q3 /REAL, INTEGER, OR /LOGICAL 3 WORDS DCA MQ TAD TEMP2 JMS MUL12 /DO MULTIPLY JMS I QNUMBRO /OUTPUT 15 BIT NUMBER JMP I VMC SC, SKPIRL, 0 /SKIP ON TYPE I R OR L AND Q17 /ISOLATE TYPE CODE TAD QM4 /IS IT DOUBLE ? SZA IAC /NO, IS IT COMPLEX ? SZA CLA ISZ SKPIRL /NEITHER, SKIP JMP I SKPIRL /RETURN MUL12, 0 /12 BIT MULTIPLY DCA OPRND TAD (-15 DCA SC JMP STMUL M12LUP, TAD AC SNL JMP .+3 CLL TAD OPRND RAR STMUL, DCA AC TAD MQ RAR DCA MQ ISZ SC JMP M12LUP JMP I MUL12 OPRND, BUMP, 0 /PUT FALSE ENTRY ONTO STACK CDF 0 /V3C IMPORTANT PROTECTION DCA I X16 ISZ X16 ISZ X16 /THIS PREVENTS UNDER /FLOWING THE STACK JMP I BUMP /AFTER SOME ERRORS EXTERN, TEXT 'EXTERN' CADD, TEXT '#CAD' CNEG, TEXT '#CNG' CMUL, TEXT '#CML' JLE, TEXT 'JLE' ORG, TEXT 'ORG' STARTE, TEXT 'STARTE' XDPTMP, TEXT '#DPT' PAGE
/ RANDOM CODE GENERATORS ERROR, JMS I QINWORD /GET ERROR CODE JMS I QERMSG /PRINT IT JMP I QNEXT EOSTMT, TAD DATASW /WAS THIS A DATA STMT ? SNA CLA JMP OPTMYZ /NO DCA DATASW /KILL SWITCH JMS I QOPCDE ORG /ORIGIN BACK TO THE PROGRAM TAD GLABEL JMS I QOLABEL JMS I QCRLF ISZ GLABEL /BUMP LABEL GENERATOR OPTMYZ, CLA /CHANGED TO CLA IAC IF /O JMS I QXRTBL /CLEAR TABLE OR RESET FLAGS ISZ LINENO /BUMP LINE NUM TAD LINENO /DISPLAY IN MQ 7421 /FOR COOLNESS CLA /FOR NON-EAE FOLKS TAD STKLVL /RESET STACK LEVEL DCA X16 JMS IFEND /LOOK FOR END OF LOGICAL IF JMS I (ASFEND /END OF A.S.F. DEFINITION ? DEBUG, JMP I QNEXT /OVERLAYED IF NO /N SWITCH JMS I QOPCDE /OUTPUT LDX NNNN,0 LDX TAD LINENO /THIS IS THE CURRENT ISN JMS I QONUMBR TAD COMMA JMS I QOCHAR TAD Q260 JMS I QOCHAR JMS I QCRLF JMP I QNEXT IFEND, 0 /OUTPUT IF END LABEL IF TAD IFLABL /WAS THIS END OF LOG IF SNA JMP I IFEND /OUTPUT DEBUG STUFF JMS I QLABEL /OUPTUT THE LABEL JMS I QGENSF /ALL LOGICAL IFS MUST /END IN FMODE DCA WHATAC /CAN'T DEPEND ON /AC HERE JMS I QXRTBL /OR XR'S EITHER DCA IFLABL /KILL THE SWITCH JMP I IFEND OPCOD, 0 /TAB OPCODE DCA WHATAC /AC HAS JUST BEEN /MODIFIED JMS I QOTAB TAD I OPCOD ISZ OPCOD JMS I QOUTSYM JMP I OPCOD DIV, JMS I QSAVACT /IF SECOND OPERAND IN AC, SAVE IT JMS I QCODE /DIVIDE DIVTBL-6;0 CLA CMA /WERE BOTH VARS INTEGER? TAD TYPE1 SZA CLA JMP I QNEXT /NO JMS I QGENCOD A0FN-1 /ALN 0;FNORM JMP I QNEXT LIFBGN, DCA RELCD /ENTER HERE IF LAST OPCODE NOT A RELATIONAL JMS I QGARG /ENTER HERE FROM RELATIONAL OPTIMIZER JMP NOTLOG TAD TYPE1 /MUST BE LOGICAL TAD (-5 SZA CLA JMP NOTLOG TAD ARG1 /IS IT IN AC ? SNA CLA JMP .+3 JMS I QGENCOD GI-1 JMS I QINWORD /IS IT IF(...)GOTO XX ? DCA TEMP2 TAD TEMP2 TAD (XPUSH-XGOTO SNA CLA JMP IFGOTO /YES, TREAT AS SPECIAL CASE TAD GLABEL /SET IF LABEL DCA IFLABL TAD RELCD CIA TAD Q5 /GENERATE THE OPPOSITE JUMP JMS RELJMP /AROUND THE TARGET OF THE IF TAD GLABEL JMS I QOLABEL ISZ GLABEL /INCREMENT LABEL GENERATOR JMS I QCRLF JMP I QNEXTM2 IFGOTO, TAD RELCD JMS RELJMP /GENERATE TRUE RELATIONAL JUMP IF "IF()GOTO" JMS I QINWORD /GET THE LABEL CDF 10 JMS I QOSNUM JMS I QCRLF JMP I QNEXT NOTLOG, JMS I QTTYMSG 1411 RELJMP, 0 CLL RAL TAD (JNE DCA .+2 JMS I QOPCDE 0 JMP I RELJMP FMUL, TEXT 'FMUL' FDIV, TEXT 'FDIV' CAC, TEXT '#CAC' LITRL, TEXT '#LIT+' TEMPN, TEXT '#TMP' PAGE
/ DO LOOP COMPILER DOBEGN, JMS I QSAVACT /FOR EXPR IN LOOP PARAMS TAD X16 /SET NEW STACK LEVEL DCA STKLVL JMS I QGARGS /GET LIMIT AND STEP JMP DPERR /ERROR IN DO PARMS JMS DOPARM /DO PARAMETER STUF FOR LIMIT ARG1 JMS DOPARM ARG2 /AND THEN FOR STEP TAD ARG1 /REPLACE ALTERRED STACK /ENTRIES DCA I X16 ISZ X16 /REST OF ARG1 OK TAD GLABEL /SAVE LOOP LABEL DCA I X16 TAD ARG2 DCA I X16 ISZ X16 ISZ X16 JMS I QCRLF /CRLF BEFORE LABL TAD GLABEL JMS I QLABEL /OUPTUT LOOP LABEL ISZ GLABEL /INCR LABEL GENERATOR DCA WHATAC /FORGET AC AND JMS I QXRTBL /XR'S AT DO BEGIN JMP I QNEXT DOSTOR, JMS I QGARGS /LOOK AT INDEX AND JMP DPERR /INITIAL VALUE CLL CMA RTL /MUST BE INTEGER OR TAD TYPE1 /REAL (L=1 AC=-3) SZL CLA /SKIP IF >2 CLL CMA RTL /L=1 AC=-3 TAD TYPE2 SZL CLA /L=0 IS BAD JMP I (STORE+2 /DO STORE IF OK DPERR, JMS I QTTYMSG /ERROR IN LIMITS 0420 /DP DOFINI, JMS I QXRTBL /DON'T OPTIMIZE XR USAGE /IN SUCCESSIVE IMPLIED DO LOOPS TAD IOSTMT /INSIDE IO STMT ? SNA CLA JMS IFEND /IF NOT, END IF FIRST JMS I QINWORD /GET THE INDEX DCA ARG1 TAD ARG1 /GET THE TYPE WORD ADR IAC DCA TYPE1 CDF 10 TAD I TYPE1 CDF AND Q17 DCA TYPE1 /TYPE OF INDEX VAR TAD QM6 TAD STKLVL /BACK UP THE STACK DCA X16 TAD X16 /RESET THE STACK LEVEL DCA STKLVL TAD I X16 /GET THE FINAL VALUE DCA DOARG ISZ X16 TAD I X16 /GET THE LOOP LABEL DCA DARG TAD I X16 /GET THE STEP DCA ARG2 TAD I X16 /WHICH DO FIN CODE ? CLL CML RAL TAD TYPE1 TAD QM6 SNA CLA TAD (DOFIN1-DOFIN0 /INDEX=I, STEP=R TAD (DOFIN0-1 /ALL OTHER CASES DCA .+2 JMS I QGENCOD /DO FINISH CODE 0 JMS I QOPCOD /SUBTRACT UPPER LIMIT FSUB JMS I QOADDR DOARG JMS I QOPCDE /NOW THE JLT %%LOOP JLE TAD DARG /OUTPUT LABEL JMS I QOLABEL JMS I QCRLF TAD STKLVL /FIX X16 INCASE MULTIPLE DO ENDER DCA X16 JMP I QNEXT DOARG, DOPARM, 0 /SUBR FOR DO PARAMETERS TAD I DOPARM ISZ DOPARM /GET THE PARM POINTER DCA DARG CLL CML RTL /GET ADDR OF TYPE WORD TAD DARG DCA TYPE CLL CMA RTL /CHECK TYPE TAD I TYPE SMA CLA JMP DPERR /NOT I OR R TAD I DARG SNA JMP STRTMP /ARG ALREADY IN AC TAD QM63 /IS IT ARRAY REF? SPA CLA JMP SVLIMT /YES, SAVE LIMIT TAD I DARG /REGET SYM ADDR DCA X10 /ADR OF TYPE WORD CDF 10 TAD I X10 /MAYBE ITS A LIT? CDF AND Q40 SZA CLA JMP I DOPARM /YES, ITS LITERAL /WE'RE ALWAYS IN F MODE HERE /SINCE THE LAST THING /WAS A DO STORE SVLIMT, JMS I QOPCOD /OTHERWISE LOAD IT FLDA JMS I QOADDR DARG, 0 STRTMP, TAD DOTEMP /SET ARG TO NEXT DO TEMP DCA I DARG JMS I QOPCOD /GENERATE STORE FSTA ISZ DOTEMP /BUMP DO TEMP TAD DARG DCA .+2 JMS I QOADDR /DO TEMP ADDRESS FIELD 0 JMP I DOPARM PAGE
/ SUBSCRIPT REFERENCE COMPILER ARGS, JMS I QINWORD /COMPILE ARGUMENT LIST CMA DCA NARGS /NUMBER OF ARGS TAD NARGS /GET ADDRESS OF SUBSCRIPTED VAR CLL RAL TAD NARGS /ENTRY ON THE STACK TAD X16 DCA X15 TAD X15 /SAVE POINTER TO START /OF THIS ENTRY DCA X14 /FOR POSSIBLE FUTURE USE ISZ NARGS /NOW ITS THE 2'S COMPLEMENT NOP TAD I X15 /FETCH SS VARIABLE DCA BASE1 TAD I X15 /ITS TYPE DCA TYPE1 TAD BASE1 /STORE BASE WORD DCA I X15 TAD BASE1 /GET ADDR OF TYPE WORD IAC DCA TEMP CDF 10 /GET TYPE WORD CLL CML RTR /TEST DIM BIT AND I TEMP SNA CLA JMP TRYCAL /SOME KIND OF CALL TAD BASE1 /NOW GET ADDRESS OF DIM INFO JMS I QGETSS DCA ARG1 /RETURNS WITH FIELD SET TAD I ARG1 /CORRECT NUMBER OF DIMENSIONS? TAD NARGS CDF SZA CLA JMP DIMERR /NO ISZ ARG1 /SKIP TOTAL SIZE ISZ ARG1 /SKIP MAGIC NUMBER ISZ ARG1 /AND ASSOCIATED LITERAL DCA XRNUM /START WITH XR 1 TAD (-10 /SEVEN XRS DCA XRCNT /COUNT FOR SEARCH DCA FREEXR /ZERO FREE XR INDICATOR XRCHEK, CDF ISZ XRCNT /ANY MORE XR EXPRS TO TEST ? SKP /YES, GO CHECK THEM JMP COMPSS /NO, MUST COMPILE /XR ERPRESSION ISZ XRNUM /BUMP XR NUMBER TAD XRNUM CLL RTL /TIMES 16 CLL RTL TAD (XRBUFR-1 /PLUS BASE (-1) DCA X13 TAD I X13 /LOOK AT THE SPA /INDICATOR JMP .+3 /-1=USED BY THIS STMT SZA CLA /IF ZERO GO TO /MTXR (EVENTUALLY) TAD FREEXR /ANY FREE BEFORE THIS ONE ? SZA CLA JMP NOTMT /YES, ALREADY FOUND ONE TAD XRNUM /THIS WILL BE DCA FREEXR /THE XR WE USE JMP XRCHEK /GO LOOK AT NEXT NOTMT, TAD X13 /SAVE FLAG ADDRESS DCA XRFLAG /IN CASE WE NEED IT LATER TAD I X13 /POINTER TO THE DIM INFO DCA TEMP2 CDF 10 TAD I TEMP2 /SAME NUMBER OF DIMS ? TAD NARGS SZA CLA JMP XRCHEK /NO, THIS XR WONT DO TAD NARGS /SET COUNTER DCA DCNT TAD ARG1 /POINTER TO DIM FACTORS DCA X12 ISZ TEMP2 /SKIP THREE WORDS ISZ TEMP2 ISZ TEMP2 DCHEK, ISZ DCNT /ANY MORE ? SKP JMP SSCHEK /DIMS OK, CHECK SS ISZ TEMP2 /GET TO NEXT DIM TAD I TEMP2 /ARE THEY EQUAL ? CIA TAD I X12 SZA CLA JMP XRCHEK /NO, GO TRY NEXT ONE JMP DCHEK SSCHEK, TAD NARGS /COUNT AGAIN CDF DCA DCNT CLL CMA RAL /-2 TAD X16 /ADDR OF START OF TOP /SS ON STACK JMP .+3 SSC2, CLL CMA RTL /-3 TAD XTMP /BACK UP TO NEXT LOWER SS DCA XTMP /LINK IS ALWAYS ZERO HERE TAD I XTMP /GET NEXT SS (WORKING /RIGHT TO LEFT) TAD (-61 /IS IT A VAR OR LITERAL? SNL CLA JMP XRCHEK /WE'RE JUST /LOOKING FOR AN EMPTY TAD I XTMP /RE GET SS POINTER CIA TAD I X13 /ARE THEY THE SAME ? SZA CLA JMP XRCHEK /NO ISZ DCNT JMP SSC2 /KEEP CHECKING TAD XRNUM /THEY MATCH, STICK IN /THE XR NUMBER TAD (51 DCA I X14 CLL CML RTL TAD X14 /PURGE SS FROM STACK DCA X16 CLA CMA /SET FLAG TO /'USED BY THIS STMT' DCA I XRFLAG JMP I QNEXT DCNT, 0 XRFLAG, 0 XTMP, 0 PAGE
/ SUBSCRIPT REFERENCE COMPILER COMPSS, TAD FREEXR /GET XR EXPR AREA CLL RTL /BY MULTIPLYING /THE NUMBER CLL RTL /BY 16 TAD (XRBUFR /AND ADDING THE /BASE ADDRESS DCA XREPTR /THIS IS IT CLA CMA /SET USED BY THIS /STMT FLAG DCA I XREPTR ISZ XREPTR CLL CMA RTL /STORE THE DIB POINTER TAD ARG1 DCA I XREPTR TAD NARGS /GET ADDR OF POINTER TO LAST CMA /DIMENSION FACTOR TAD ARG1 DCA ARG1 /SINCE WE USE THEM IN /REVERSE ORDER JMS I QSAVEAC /STORE AC IF NEEDED /FOLLOWING INSTRUCTION REMOVED FOR OPTOMIZATION / JMS I QGENSF /ALL SUBSCRIPTS AR I OR R TAD (FLDA /LOAD FIRST SS SKP CSSLUP, TAD (FADD /ADD ALL SUBSEQUENT ONES DCA OPC CLL CMA RTL /BACK UP STACK BY ONE ENTRY TAD X16 DCA X16 TAD X16 /GET A WORKING POINTER DCA X15 TAD I X15 /GET THE NEXT SUBSCRIPT DCA ARG2 CLL CMA RAL /MUST BE INTEGER TAD I X15 SMA CLA JMP DIMERR TAD I X15 DCA BASE2 TAD ARG2 /STORE THE SS INTO THE /XR EXPR ISZ XREPTR /INCREMENT FIRST DCA I XREPTR TAD ARG2 /IS ARG2 THE AC (ONLY /POSSIBLE IF SNA CLA /ITS THE RIGHTMOST /SUBSCRIPT) JMP NLODSS /YES, DON'T LOAD IT JMS I QOPCOD /OUTPUT LOAD OR ADD OPC, 0 /THIS LOCATION TELLS /THE STORY JMS I QOADDR /FOLLOWED BY THE OPERAND ARG2 /POINTED TO BY ARG2 NLODSS, ISZ NARGS /ANY MORE SUBSCRIPTS ? JMP MORESS /YES, GO COMPILE THEM TAD FREEXR /ANY FREE INDEX REG? SZA CLA JMP ASGNXR /YES, GO USE IT TAD (61 /ITS A SPECIAL POINTER ENTRY DCA I X14 ISZ X14 TAD TMPCNT /SAVE TEMP NUMBER DCA I X14 /BEFORE WE BLOW X14 JMS I (GENPTR /GENERATE POINTER TO THE ARG JMS I QGENCOD /BACK TO FMODE SF-1 JMS I (ACSTOR /GENERATE STORE AC JMP I QNEXT DIMERR, JMS I QTTYMSG /SS NOT OF CORRECT NUMBER 2323 XRCNT, 0 TRYCAL, TAD ASFSWT /ASF DEFINITION SMA SZA CLA JMP DEFASF /YES, GO OUTPUT PROLOG TAD I TEMP /IS IT A FUNCTION OR AN ARG? CDF AND (1420 SNA JMP DIMERR /NO, SOME KIND OF ERROR AND Q20 DCA ACSWIT /SAVE THE AC SWITCH JMP FUNCAL /STANDARD FUNCTION CALL MORESS, JMS I QGENSF /MUST USE SINGLE PRECISION FOR MULTIPLY JMS I QOPCOD /MULTIPLY BY DIM FACTOR FMUL CDF 10 TAD I ARG1 /PICK UP FACTOR ADDRESS CDF DCA ARG2 CLA CMA TAD ARG1 /MOVE BACK ONE DCA ARG1 JMS I QOADDR /OUTPUT MULTIPLY ADDRESS ARG2 JMP CSSLUP /LOOP ON NEXT SS ASGNXR, JMS I QOPCDE /OUTPUT ATX N ATX TAD FREEXR /GET NUMBER OF FREE XR TAD Q260 JMS I QOCHAR JMS I QCRLF TAD FREEXR TAD (51 /COMPUTE PROPER NUMBER DCA I X14 /PUT IT INTO TOP OF STACK JMP I QNEXT XREPTR, 0
/ RANDOM TEXT OTAB, 0 TAD (211 JMS I QOCHAR JMP I OTAB FCLA, TEXT 'FCLA' STARTD, TEXT 'STARTD' TEMPN2, TEXT '#TMPX' CSUB, TEXT '#CSB' CDIV, TEXT '#CDV' PAGE
/ GENERAL CALL GENERATOR GENCAL, 0 /GENERATE A CALL; ALL ARGS ON STACK /X15 POINTS TO START OF STACK INFO /NARGS IS NEG NUMBER OF ARGS /FUNCTION NAME IS FIRST ON STACK TAD I GENCAL /GET FUN NAME SWITCH DCA FNSWIT TAD X15 /NEW STACK VALUE DCA X16 TAD X15 /WORKING POINTER DCA ARG2 TAD NARGS /WORKING COUNTER SNA JMP OUTJSR /NO ARGS, PUT JSR DCA TYPE2 CHKPTR, ISZ ARG2 /MOVE TO NUMBER TAD ARG2 IAC /ADDR OF TYPE WORD DCA BASE2 TAD I BASE2 /GET TYPE DCA TYPE1 /TYPE OF ARG FOR GENPTR ISZ BASE2 /POINT TO BASE WORD TAD I BASE2 DCA BASE1 /FOR GENPTR TAD I ARG2 /GET ARG NUMBER CLL TAD (-52 /IS IT INDEXED ? SNL JMP NOTINX /NO, ITS A TEMP TAD (52-61 /IS IT INDIRECT ? SZL JMP INXR /NO, ITS IN AN XR SNA JMP INTMP /POINTER IN A TEMP TAD (62 /GET TO TYPE WORD DCA GCTEMP CDF 10 TAD I GCTEMP /IS IT AN ARG CDF AND (1020 /ARG OR EXTERNAL ? SNA JMP NOTINX+1 /NEITHER AND Q20 SZA CLA JMP ARGARG /ARG SQUARED JMP EXTARG /EXTERNAL ARG NOTINX, CLA ISZ ARG2 /BUMP POINTER ISZ ARG2 ISZ TYPE2 /INCR COUNT JMP CHKPTR OUTJSR, TAD JSRLBL /DOES IT GET A LABEL ? SNA JMP .+3 /NO JMS I QLABEL /OUPTUT THE LABEL+COMMA DCA JSRLBL /KILL SWITCH TAD X16 /ADDR OF POINTER TO FUN NAME DCA TEMP FNSWIT, 0 /REAARANGED** JMP I (IOFUN /IO FUNCTION CALL JMS I QOPCDE /OUTPUT THE JSR JSR TAD I TEMP /NOW THE SUBR NAME CDF 10 JMS I QOUTNAM JMS I QCRLF TAD NARGS /ANY ARGS ? SNA CLA JMP I GENCAL /NO, END OF CALL JMS I QOPCDE /JUMP AROUND THE ARGS JA TAD Q256 JMS I QOCHAR /. TAD PLUS JMS I QOCHAR /+ CLL CLA CMA RAL /-2 TAD NARGS /-N-2 CLL CMA RAL /2*N+2 JMS I QONUMBR IOONLY, JMS I QCRLF TAD X16 /WORKING POINTER DCA X15 PTRLST, TAD I X15 /GET NEXT ARG SZA JMP SARG /SIMPLE ARG CLL CML RTL TAD X15 /ADDR OF GENERATED /LABEL NUMBER DCA TEMP TAD I TEMP /OUTPUT #GXXXX (THE /GENERATED LABEL) JMS I QLABEL /OUPTUT THE LABEL JMS I QGENCOD JADP2-1 /GENERATE A DUMMY JA JMP BARGLP SARG, DCA ARG2 /STORE THE ARG NUMBER JMS I QOPCOD /OUTPUT JA ARG JA JMS I QOADDR /NOW ADDRESS FIELD ARG2 BARGLP, ISZ X15 /BUMP POINTER ISZ X15 ISZ NARGS /BUMP COUNT JMP PTRLST JMP I GENCAL INTMP, TAD I BASE2 /GET TEMP NUMBER DCA ARG1 /THAT PTR IS STORED IN JMS I QGENCOD /PICK UP POINTER LDASTD-1 STRPTR, JMS I QOPCDE /NOW STORE THE POINTER FSTA TAD GLABEL /OUTPUT THE LABEL JMS I QOLABEL JMS I QCRLF TAD GLABEL /SAVE THE LABEL NUMBER DCA I BASE2 DCA I ARG2 /ZERO ARG NUMBER ISZ GLABEL /INCREMENT LABEL NUMBER JMS I QGENCOD /BACK TO F MODE SF-1 JMP NOTINX /CONTINUE LOOP NLABEL, 0 JMS I QOLABEL TAD COMMA JMS I QOCHAR JMP I NLABEL PAGE
/ GENERATE SUBROUTINE CALL FUNCAL, JMS I QSAVEAC /SAVE NEXT TO LAST IF NEEDED JMS I QSAVACT /SAVE LAST IF NEEDED JMS I QGENSF /ALL CALLS DONE IN F MODE DCA I X14 /RESULT RETURNED IN AC TAD ACSWIT /IS THE SUBR AN ARG ? SNA CLA JMP MAKCAL /NO, ITS EASIER JMS I QOPCOD /GET THE JSR TO THE SUBR FLDA JMS I QOADDR BASE1 /BY GETTING THE VALUE /OF THE ARG JMS I QGENCOD /STARTD SD-1 JMS I QOPCDE /STORE IT AHEAD FSTA TAD GLABEL /INTO THE JSR ISZ GLABEL DCA JSRLBL /SET THE SWITCH TAD JSRLBL JMS I QOLABEL JMS I QCRLF JMS I QGENCOD /STARTF SF-1 MAKCAL, ISZ BASE1 /MOVE TO TYPE WORD CDF 10 TAD I BASE1 /GET TYPE OF FUNCTION CDF JMS I QSKPIRL /WHAT MODE WILL WE LEAVE IN? DCA FMODE /PROBABLY E JMS I QGENCAL /GO GENERATE THE CALL SKP 0 /THIS IS A FREE LOCATION JMP I QNEXT ARGARG, JMS I QOPCDE /%FLDA FLDA TAD I ARG2 /POINTER CDF 10 JMS I QOUTNAM JMS I QCRLF JMS I QGENCOD /%SD SD-1 CDF 10 CLL CML RTR /IS IT AN ARRAY ? AND I GCTEMP CDF SNA CLA JMP STRPTR /GO STORE THE POINTER TAD I ARG2 /GET THE LITERAL NUMBER JMS I QGETSS TAD Q3 DCA GCTEMP TAD I GCTEMP DCA OLABEL /SAVE IT CDF JMS I QOPCDE /%FADD LITERAL FADD TAD QLITRL JMS I QOUTSYM TAD OLABEL /XXXX JMS I QONUMBR JMS I QCRLF JMP STRPTR /GO STORE THE POINTER INXR, TAD (270 /MAKE AN ASCII CHAR DCA XR JMS I QOPCDE /XTA XTA TAD XR JMS I QOCHAR /N JMS I QCRLF TAD BASE1 /FIND ADDR OF MAGIC /NUMBER LITERAL JMS I QGETSS CDF TAD Q3 DCA ARG1 JMS I (GENPTR /GENERATE THE POINTER JMP STRPTR /GO STORE THE POINTER EXTARG, TAD I ARG2 /MAKE AN ENTRY IN THE EXT CDF 10 /LITERAL LIST DCA I X17 TAD DOTEMP /USE DO TEMPS FOR THIS DCA I X17 CDF TAD DOTEMP /SINCE OADDR CAN HANDLE THEM DCA I ARG2 ISZ DOTEMP /BUMP COUNT ISZ ELCNT /ALSO EXT LIT COUNT JMP NOTINX /BACK TO PROCESSING ARGS
/ UTILITY ROUTINES OLABEL, 0 /OUTPUT #GXXXX FOR GEN'D LABELS DCA TEMP TAD (243 JMS I QOCHAR TAD (307 JMS I QOCHAR TAD TEMP JMS I QONUMBR JMP I OLABEL OPCODE, 0 /TAD OPCODE TAB DCA WHATAC /THIS INSTRUCTION ZAPS AC JMS I QOTAB TAD I OPCODE ISZ OPCODE JMS I QOUTSYM JMS I QOTAB JMP I OPCODE M1C2, TEXT '-1,2' GENSTE, 0 /GENERATE STARTE IF IN /F MODE TAD FMODE /LOOK AT THE SWITCH SNA CLA JMP I GENSTE /ALREADY IN E MODE DCA FMODE /CLEAR THE SWITCH JMS I QOPCOD /GENERATE THE STARTE STARTE JMS I QCRLF /CAN'T USE GENCOD FOR THAT JMP I GENSTE D0, TEXT '0' DOTMPN, TEXT '#DOTMP' PAGE
/ OPCODES AND OTHER TEXT XBASE, TEXT '#BASE' XBASP3, TEXT '#BASE+3' DP3C0, TEXT '.+3,0' JXN, TEXT 'JXN' ALN, TEXT 'ALN' ATX, TEXT 'ATX' XTA, TEXT 'XTA' LDX, TEXT 'LDX' XREW, TEXT '#REW' XENDF, TEXT '#ENDF' XBAK, TEXT '#BAK' XEXIT, TEXT '#EXIT' XRTN, TEXT '#RTN'
JNE, TEXT 'JNE' TEXT 'JGE' TEXT 'JLE' TEXT 'JGT' JLT, TEXT 'JLT' /MUST BE IN THIS ORDER!! TEXT 'JEQ' JA, TEXT 'JA' JSR, TEXT 'JSR' JSA, TEXT 'JSA' /MUST BE IN THIS ORDER! TRAP3, TEXT 'TRAP3'
/ POINTER GENERATOR GENPTR, 0 /GENERATE A POINTER JMS I QOPCOD /MULTIPLY BY 3. OR 6. FMUL TAD TYPE1 /D OR C ? JMS I QSKPIRL /SKIP ON I, R, OR L TAD Q6M3 TAD (THREE DCA TEMP /POINTER TO CORRECT LITERAL JMS I QOADDR TEMP JMS I QGENCOD /ALN 0; STARTD A0SD-1 JMS I QOPCDE /FADD THE BASE LITERAL FADD ISZ BASE1 /GET ADDR OF TYPE WORD CDF 10 TAD I BASE1 /GET TYPE WORD AND Q20 SNA CLA JMP NIARG /NOT AN ARG CMA TAD BASE1 JMS I QOUTNAM /IF AN ARG, THE LITERAL /IS THE ARG JMP OSF NIARG, CDF TAD QLITRL /OTHERWISE ITS IN THE /LITERAL BLOCK JMS I QOUTSYM CDF 10 TAD I ARG1 /LITERAL NUMBER CDF JMS I QONUMBR OSF, JMS I QCRLF JMP I GENPTR
/ MORE RANDOM CODE GENERATORS STOP, JMS I QGENCOD /CALL EXIT STPCOD-1 JMP I QNEXT FORMAT, JMS I QINWORD /NUMBER OF WORDS OF TEXT CMA DCA TEMP JMS I QOPCDE /JA AROUND THE STUFF JA TAD Q256 JMS I QOCHAR /. TAD PLUS JMS I QOCHAR CLL CMA RAL /.+2+NWORDS TAD TEMP CMA JMP .+3 FMTLUP, JMS I QOTAB /TA JMS I QINWORD /GET NEXT WORD JMS I QONUMBR /OUTPUT IT JMS I QCRLF ISZ TEMP JMP FMTLUP JMP I QNEXT DFRTTM, 0 /ROUTINE TO DELETE "SYS:FORTRN.TM" CLA IAC CIF 10 JMS I Q200 4 FTRNTM 0 NOP JMP I DFRTTM EQUDOT, TEXT '=.' XPAUSE, TEXT '#PAUSE' PAGE
/REWIND, ENDFILE, BACKSPACE REWIND, TAD (XREW-XENDF ENDFIL, TAD (XENDF-XBAK BAKSPC, TAD (XBAK DCA REBSUB JMS I QUCODE AIFTBL-1 /GET UNIT INTO FAC JMS I QGENSF /FORCE F MODE CLA STL RTL JMS I (OJSR REBSUB, 0 JMP I QNEXT
/ DATA STATEMENT STUFF DATAST, TAD X16 /SAVE STACK DCA DSTACK TAD DATASW /MULTIPLE DATA STMT ? SZA CLA JMP FIXDAT-2 /YES, DON'T OUTPUT LABEL ISZ DATASW /SET DATA SWITCH JMS I QOTAB /DEFINE ORIGIN SYMBOL TAD GLABEL JMS I QOLABEL TAD (EQUDOT /#GXXXX=. JMS I QOUTSYM JMS I QCRLF CLA CMA /SET VAR TO NONE LEFT DCA NUMELM FIXDAT, TAD QXRBUFR /USE XR BUFFER FOR DATA BUFFER DCA DATPTR CMA DCA RCOUNT /SET REPETITION COUNT TO 1 JMP I QNEXT DREPTC, JMS I QINWORD /GET REPETITION COUNT CIA DCA RCOUNT JMP I QNEXT DATELM, JMS I QINWORD /GET SIZE OF ELEMENT CIA DCA TEMP JMS I QINWORD /GET ELEMENT DCA I DATPTR ISZ DATPTR /INTO DATA BUFFER ISZ TEMP JMP .-4 JMP I QNEXT ENDELM, TAD QXRBUFR /SETUP POINTER DCA TEMP MORELM, ISZ NUMELM /ANY MORE FOR THIS VAR? JMP SAMVAR /YES TAD DSTACK /CHECK FOR MISMATCH CIA TAD X16 SNA CLA JMP DLERR /OOOPS ISZ DSTACK /GET TO NEXT VAR JMS I QOPCDE /%ORG VAR ORG TAD I DSTACK /GET VAR DCA TEMP2 TAD TEMP2 ISZ DSTACK /MOVE TO THE DISPLACEMENT CDF 10 /OUTPUT VAR JMS I QOUTNAM CMA DCA NUMELM /ASSUME UNDIMENSIONED CDF 10 ISZ TEMP2 /MOVE TO TYPE WORD TAD I TEMP2 /GET TYPE JMS I QSKPIRL /SKIP ON I R L CLL CMA RTL /YES TAD (-3 DCA ELMSIZ /NUMBER OF WORDS PER ELEMENT CLL CML RTR AND I TEMP2 CDF SNA CLA JMP GOTSIZ /NOT DIMENSIONED CLA IAC /IF DISP = 7777 , WHOLE ARRAY TAD I DSTACK /LOOK AT DISPLACEMENT SZA CLA JMP GOTSIZ+1 /ONLY ONE ELEMENT OF THE ARRAY CMA TAD TEMP2 /GET TOTAL SIZE JMS I QGETSS IAC DCA TEMP2 TAD I TEMP2 CIA /THIS IS THE NUMBER OF ELEMENTS DCA NUMELM CDF GOTSIZ, DCA I DSTACK /ZERO DISPLACEMENT TAD PLUS /OUTPUT +XXXX JMS I QOCHAR TAD ELMSIZ /MULTIPLY DISP BY 3 OR 6 CIA DCA MQ TAD I DSTACK /GET DISP JMS I QMUL12 JMS I QNUMBRO /OUTPUT THE ORG ALTERATION JMS I QCRLF ISZ DSTACK /MOVE TO NEXT ENTRY SAMVAR, TAD ELMSIZ /GET SET TO PICK UP AN ELEMENT DCA NARGS JMS I QOTAB JMP .+3 /SKIP ; FIRST TIME ELMLUP, TAD (273 /SEMICOLON JMS I QOCHAR TAD I TEMP /GET A WORD FROM THE BUFFER ISZ TEMP JMS I QONUMBR ISZ NARGS /ONE DATA LIST ELEMENT MUST FILL JMP ELMLUP /ONE VARIABLE LIST ELEMENT JMS I QCRLF /I.E. ONE ARRAY ELEMENT TAD DATPTR /IS THIS DATA ELEMENT EXHAUSTED? CIA CLL TAD TEMP SNL CLA JMP MORELM /MORE LEFT ISZ RCOUNT /REPEAT ? JMP ENDELM /YES JMP FIXDAT /NO, BACK FOR MORE DATA DLERR, JMS I QTTYMSG /DATA LIST ERROR 0414 ELMSIZ=ARG1 NUMELM=TYPE1 DSTACK=BASE1 DATPTR=ARG2 RCOUNT=TYPE2 PAGE
/ END STATEMENT PROCESSING END, TAD FUNCTN /WHAT WAS IT ? SZA CLA JMP .+3 /SUBR, RETURN TAD (STPCOD-1 /MAIN PROG, CALL EXIT DCA .+2 JMS I QGENCOD RTNCOD-1 TAD DOTEMP /ANY DO TEMPS ? TAD M7000 SPA SNA JMP .+3 /NO JMS OTMPS /OUTPUT THEM XDOTMP, DOTMPN CLA TAD TMPMAX /ANY EXTRA TEMPS ? TAD (-TMPBLK SPA SNA JMP .+4 IAC /OUTPUT THEM + 1 JMS OTMPS TEMPN2 CLA TAD ELCNT /ANY EXTERNAL LITERALS? SNA JMP END2 /NO CIA DCA ELCNT TAD EXTLIT /PICK UP THE POINTER DCA X17 ELLOOP, CDF 10 TAD I X17 /GET SYMBOL NAME DCA TEMP TAD I X17 /AND DO TEMP NUMBER CDF TAD (-7000 /MINUS BASE DCA TEMP2 JMS I QOPCDE /ORIGIN ORG TAD XDOTMP /OUTPUT #DOTMP JMS I QOUTSYM TAD PLUS /+ JMS I QOCHAR TAD TEMP2 /DISP CLL CML RAL /*2+1 TAD TEMP2 /*3+1 JMS I QONUMBR JMS I QCRLF JMS I QOPCDE /NOW OUTPUT JSR NAME JSR TAD TEMP CDF 10 JMS I QOUTNAM JMS I QCRLF ISZ ELCNT JMP ELLOOP END2, TAD (232 /^Z JMS I QOCHAR JMS I (OUDUMP /DUMP BUFFER CIF 10 JMS I (7700 /GET USR 10 CIF 10 CLA IAC JMS I Q200 /CLOSE OUTPUT FILE 4 F1LNAM FILSIZ, 0 JMP OUERR /BADDDDIE TAD FILSIZ /FIX INPUT LIST CLL RTL RTL JMP FINAL ERMSG, 0 /PRINT ERROR MESSAGE ON THE TTY DCA TEMP /SAVE THE CODE TAD QM4 /BACK UP THE ERROR TAD ERRPTR /POINTER DCA X10 CDF 10 DCA I X10 /ZERO END OF LIST TAD TEMP /NOW STICK IN THE CODE DCA I X10 TAD X10 /SAVE THE NEW POINTER DCA ERRPTR TAD LINENO /NOW THE LINE NUMBER DCA I X10 CDF TAD TEMP /PRINT ERROR CODE JMS I QTTYP2C JMS I QTTYP2C /NOW SOME SPACES TAD QTTYOUT /FUDGE THE OUTPUT /ROUTINE POINTER DCA QOCHAR /SO THAT ONUMBR GOES TO /THE TTY TAD LINENO /PRINT THE LINE NUMBER JMS I QONUMBR TAD (OCHAR /FIXUP OUTPUT POINTER DCA QOCHAR JMS I QTTCRLF JMS I QGENCOD /TRAP IF ERROR EXECUTED ERCODE-1 JMP I ERMSG M7000, OTMPS, -7000 /OUTPUT TEMP BLOCK DCA TEMP /SAVE SIZE TAD I OTMPS ISZ OTMPS JMS I QOUTSYM /OUTPUT NAME TAD COMMA JMS I QOCHAR JMS I QOPCDE /ORG ORG TAD Q256 /. JMS I QOCHAR TAD PLUS JMS I QOCHAR TAD TEMP CLL RAL TAD TEMP /SIZE TIMES THREE JMS I QONUMBR JMS I QCRLF JMP I OTMPS PAGE
/ CHAIN TO RALF / PASS2O VERSION 4A PT 16-MAY-77 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T. /FIXED THE Q OPTION /PATCH LEVEL IS IN LOCATION 26131 IFZERO OVERLY < /ANOTHER SCORE FOR PAL8 *OVRLAY NOPUNCH> IFNZRO OVERLY < /TO TAKE THE LEAD FIELD 2 ENPUNCH *OVRLAY> /LATE IN THE FINAL QUARTER GORALF, TAD FILDEV /GET SIZE AND DEVICE WORD DCA I (7617 /PUT IT AWAY ISZ (7617 /BUMP POINTER TAD FILBLK /GET ORIGIN OF FIE DCA I (7617 /STORE IT ISZ (7617 DCA I (7617 /ZERO END OF LIST TAD I RALFSV CDF 0 SPA CLA /WAS /A SPECIFIED? JMP I (7605 /YES - GET OUT CLA IAC CHNLKP, CIF 10 JMS I Q200 2 /LOOKUP RALF.SV RALFNM RALFSV, 7643 JMP I (7605 TAD (6 /** DCA CHNLKP+2 JMP CHNLKP RALFNM, 2201;1406;0000;2326 /RALF.SV PASS3N, 2001;2323;6300;2326 /PASS3.SV ADD, JMS I QCODE /GENERATE CODE FOR ADD ADDTBL-6;0 JMP I QNEXT
/ EXP OPERATOR ETYPE, 0 EXP, JMS I QSAVACT /SAVE AC IF ITS SECOND ARG JMS I QGARGS /GET THE TWO ARGS JMP I (OTERR /TYPE/OPERATOR ERROR TAD TYPE1 /GET PLACE IN TABLE CLL RTL TAD TYPE1 /TYPE1 TIMES TEN TAD TYPE2 /** CLL RAL TAD (EXPTBL-15 /POINTER TO ENTRY MINUS ONE DCA X10 CDF 10 TAD I X10 /GET RESULTING TYPE SNA JMP I (OTERR /BAD IF THIS WORD IS ZERO DCA ETYPE /SAVE THE TYPE TAD I X10 /GET THE SUBR NAME CDF DCA I (ESUBR+2 /PUT IT INTO ITS PLACE TAD TYPE1 /GET INTO CORRECT MODE JMS SETMOD TAD ARG1 /IS ARG 1 ALREADY IN THE AC SNA CLA JMP .+5 /YES, SKIP THE LOAD JMS I QOPCOD /OTHERWISE LOAD IT FLDA JMS I QOADDR ARG1 JMS I QOINS /FSTA #BASE FSTA;XBASE TAD TYPE2 /SET MODE FOR ARG 2 JMS SETMOD JMS I QOPCOD /NOW LOAD IT FLDA JMS I QOADDR ARG2 JMS I QOINS /EXTERN FOR THE SUBR EXTERN;ESUBR JMS I QOINS /JSA TO THE SUBR JSA;ESUBR DCA I X16 /RESULT IS THE AC TAD ETYPE /WITH THIS AS THE TYPE DCA I X16 DCA I X16 TAD ETYPE /SET FMODE CORRECTLY JMS I QSKPIRL SKP CLA IAC /RETURNED IN F MODE DCA FMODE JMP I QNEXT SETMOD, /SET MODE TO CORRESPOND /TO THE ARG VOVER, VERSON /VERSION NUMBER FOR OVERLAY JMS I QSKPIRL /SKIP IF WE WANT F MODE JMP .+3 /SET TO E MODE JMS I QGENSF /SET TO F MODE JMP I SETMOD JMS I QGENSE JMP I SETMOD FINAL, CIA IAC DCA FILDEV /SAVE RALF INPUT SPEC CMA DCA I X7746 /DON'T SAVE CORE ARROUND CHAIN JMS I (DFRTTM /DELETE FORTRN.TM CDF 10 TAD I Q7605 /IS THERE A LISTING FILE? SNA CLA JMP GORALF /NO, JUST CHAIN TO RALF CIF 10 CDF CLA IAC JMS I Q200 /FIND PASS 3 2 PASS3N PAS3SV, 0 JMP I Q7605 TAD PAS3SV-1 /MOVE BLOCK TO CHAIN COMMAND IAC /SKIP OVER CORE CONTROL BLOCK DCA X7746 JMS I DEVH /READ IN PASS 3 NPPAS3 SPASS3, 400 X7746, 7746 JMP I Q7605 JMP I SPASS3 /GO DO PASS 3 PAGE
/ I/O OPEN AND CLOSE STRTIO, 0 /ROUTINE FOR STARTING IO STMT ISZ IOSTMT /SET IOSTMT SWITCH /(INCASE OF IMPLIED LOOPS) JMS I QSAVEAC /SAVE AC JMS I QSAVACT /IF NECESSARY TAD I STRTIO /GET NUMBER OF ARGS DCA NARGS /SAVE IT ISZ STRTIO /MOVE TOHE NME TAD NARGS /BACKUP STACK BY THIS MUCH TAD NARGS /THREE OR SIX TAD NARGS TAD X16 DCA X15 TAD X15 DCA TEMP /FUNCTION NAME GOES HERE JMS I QOPCDE /EXTERN FOR SUBR EXTERN TAD I STRTIO /GET SUBROUTINE NAME JMS I QOUTSYM /OUTPUT IT JMS I QCRLF TAD I STRTIO /PUT NAME DCA I TEMP /ONTO STACK JMS I QGENSF /ALL CALLS IN F MODE JMS I QGENCAL /GENERATE THE CALL NOP JMP I QNEXT /NOTHING FOR R CLOSE FMTRD1, IAC /START FORMATTED READ DCA INPUT /SET INPUT = 1 DCA BINARY /AND BINARY = 0 JMS STRTIO /GO MAKE THE CALL -2;XREADO FMTWR1, DCA INPUT /SET SWITCHES DCA BINARY JMS STRTIO -2;XWRITO BINRD1, CLA IAC DCA BINARY CLA IAC DCA INPUT JMS STRTIO -1;XRUO BINWR1, DCA INPUT CLA IAC DCA BINARY JMS STRTIO -1;XWUO WCLOSE, CLA STL RTL /TRAP3 HERE TOO** JMS OJSR /OUTPUT TRAP3 #WUC XWUC DCA IOSTMT /KILL IO SWITCH JMP I QNEXT OJSR, 0 /OUTPUT EXTERN THEN JSR OR TRAP3 CLL RAL /AC ON ENTRY IS 0 (JSR), 1 (JSA) OR 2 (TRAP3). TAD (JSR DCA OJSROP JMS I QOPCDE /FIRST EXTERN EXTERN TAD I OJSR JMS I QOUTSYM JMS I QCRLF JMS I QOPCDE /THEN JSR OJSROP, 0 TAD I OJSR ISZ OJSR JMS I QOUTSYM JMS I QCRLF JMP I OJSR XWUC, TEXT '#RENDO' /** XREADO, TEXT '#READO' XWRITO, TEXT '#WRITO' XRUO, TEXT '#RUO' XWUO, TEXT '#WUO' RDRTNE, TEXT /#RSVO/ RDDRTN, TEXT /#RFDV/ FTRNTM, 0617;2224;2216;2415 /FORTRN.TM
DNA, JMS I QCODE /AND CODE ANDTBL-6;0 JMP I QNEXT PURGE, JMS I QGARG /LOOK AT THE TOP OF STACK JMP I (IOTYPE /BAD TYPE TAD ARG1 /IT MUST BE A SCALAR REFNCE CLL TAD QM63 SNL CLA JMP I (IOTYPE /BAD TYPE JMP I QNEXT PAUZE, JMS I QUCODE /GET ARG INTO FAC AIFTBL-1 JMS I QGENCOD /OUTPUT JSR PAZCOD-1 JMP I QNEXT PAGE
/DIRECT ACCESS I/O DARD1, CLA IAC /SET SWITCHES DCA INPUT CLA IAC DCA BINARY /SAME AS UNFORMATTED JMS I (STRTIO /GENERATE CALL -2;XRDAO DAWR1, DCA INPUT /SAME AS UNFORMATTED WRITE OPEN CLA IAC DCA BINARY JMS I (STRTIO /CALL -2;XWDAO DEFFIL, TAD XDFARG /FAKE A CALL DCA I (STRTIO /TO SKIP THE ISZ IOSTMT JMP I (STRTIO+2 XDFARG, .+1 -4;XDEF XDEF, TEXT '#DEF' XRDAO, TEXT '#RDAO' XWDAO, TEXT '#WDAO'
/ RANDOM UNFITTING STUFF RETURN, JMS I QGENCOD /JA #RTN RTNCOD-1 JMP I QNEXT GENSTF, 0 /GENERATE STARTF IF IN E MODE TAD FMODE /LOOK AT THE SWITCH SZA CLA JMP I GENSTF /ALREADY THERE ISZ FMODE /SET SWITCH JMS I QOPCOD /OUTPUT STARTF STARTF JMS I QCRLF JMP I GENSTF /RETURN NOT, JMS I QUCODE /.NOT. NOTTBL-1 JMP I (RELGM1 SUB, JMS I QCODE /SUBTRACT SUBTBL-6;0 JMP I QNEXT MUL, JMS I QCODE /MULTIPLY MULTBL-6;0 JMP I QNEXT ASFDEF, CLA IAC /SET SWITCH FOR ASF PROLOG DCA ASFSWT JMP I QNEXT OINS, 0 /OUTPUT TAB OPCODE TAB /ADDRESS CRLF DCA WHATAC /ZAPS AC JMS I QOTAB TAD I OINS /GET OPCODE ISZ OINS JMS I QOUTSYM JMS I QOTAB TAD I OINS /GET ADDRESS SZA JMS I QOUTSYM JMS I QCRLF /END LINE ISZ OINS JMP I OINS
/ CODE GENERATOR FOR STORE STORE, JMS I QGARGS /GET ARGS FOR STORE JMP I (OTERR TAD ARG1 /KILL ANY XR /EXPRS. INVOLVING JMS I QCHKXR /THE VARIABLE BEING STORED TAD ARG2 /IS SECOND ARG IN AC ? SNA CLA TAD Q5 /YES, ADD 5 TO TYPE2 TAD TYPE2 DCA TYPE2 TAD TYPE1 /TYPE1 TIMES TEN CLL RTL TAD TYPE1 CLL RAL TAD TYPE2 /PLUS TYPE2 TAD (STRTBL-13 /PLUS TABLE BASE DCA SSKEL /GIVES ENTRY ADDRESS CDF 10 TAD I SSKEL /POINTER TO SKELETON DCA SSKEL JMS I QGENCOD /GENERATE CODE SSKEL, 0 TAD ASFSWT /IS THIS END OF ASF ? SZA CLA JMP I QNEXT /YES, DON'T DO A STORE TAD TYPE1 /MODE IS THE SAME JMS I QSKPIRL /AS THE VARIABLE STORED IN SKP CLA IAC DCA FMODE JMS I QOPCOD /OUTPUT STORE FSTA JMS I QOADDR /ADDRESS FIELD ARG1 TAD ARG1 /REMEMBER THE AC CIA DCA WHATAC /(REMEMBER THE TAD BASE1 /ALAMO ?) CIA /(WOULD YOU DCA WHATBS /BELIEVE THE MAINE ???) ISZ ARG1 /GO TO TYPE WORD CDF 10 CLL /IF ARG1 IS TAD ARG1 /A SS'D REFNCE TAD QM63 /DON'T SZL CLA /BOTHER CHECKING TAD I ARG1 /LOOK AT SOME BITS CDF AND (3400 /DIM,EXT, OR ASF ? SNA CLA JMP I QNEXT JMS I QTTYMSG /ATTEMPT TO STORE IN 1720 /EXTERNAL OR ASF FLDAP, TEXT 'FLDA%' PAGE
/ARITHEMTIC STATEMENT FUNCTIONS (BLAH!) DEFASF, CDF /A.S.F. PROLOG TAD FMODE /SAVE CPU MODE DCA ASFMOD /SINCE WE JUMP ARROUND TAD X14 /SET STACK POINTER TAD (3 /SO THAT ASF NAME STAYS DCA X16 CLA CMA /SET ASF SWITCH DCA ASFSWT TAD TMPMAX /USE UNIQUE TEMPS IAC DCA TMPCNT /FOR ALL ASF'S JMS I QXRTBL /AND FORGET XR'S JMS I QOPCDE /JA AROUND JA TAD GLABEL /SAVE ARROUND LABEL DCA ASFSKP ISZ GLABEL /BUMP LABEL GENERATOR TAD ASFSKP /PUT LABEL AS ADDRESS OF JA JMS I QOLABEL JMS I QCRLF TAD GLABEL /FUNCTIONS XR'S O HERE JMS I QLABEL /OUPTUT THE LABEL JMS I QOINS /#GXXXX, ORG .+10 ORG;DP8 TAD BASE1 /NOW OUTPUT FUNCTION NAME CDF 10 JMS I QOUTNAM TAD COMMA /AS TAG JMS I QOCHAR /OF START OF FUNCTION JMS I QOPCDE /SETX XSET TAD GLABEL /TO THE GENERATED LABEL ISZ GLABEL JMS I QOLABEL JMS I QCRLF JMS I QOINS /LDX 0,1 LDX;ZEROC1 JMS I QGENCOD /STARTD SD-1 /JUST LIKE A SUBROUTINE /ISN'T IT ? JMS I QOINS /FLDA #BASE FLDA;XBASE /GET RETURN JUMP JMS I QOPCDE /STORE IT AHEAD FSTA TAD GLABEL /USING GENERATED LABEL JMS I QOLABEL JMS I QCRLF ASFARG, JMS I QOINS /FLDA% #BASE,1+ FLDAP;XBAC1P /GET ARG POINTER JMS I QOINS /FSTA #BASE+3 FSTA;XBASP3 /SAVE IT TAD I X15 /GET PARAMETER DCA ARG2 TAD I X15 DCA TYPE2 ISZ X15 TAD TYPE2 /IS IT SINGLE OR DOUBLE? JMS I QSKPIRL JMP ASFASE /DOUBLE JMS I QGENCOD /STARTF SF-1 CLA IAC ARGSV, DCA FMODE /SET FMODE APPROPRIATELY JMS I QOINS /FLDA% #BASE+3 FLDAP;XBASP3 /GET THE VALUE JMS I QOPCOD FSTA /AND SAVE IT JMS I QOADDR ARG2 ISZ NARGS /ANY MORE ARGS ? SKP JMP I QNEXT /NO, END OF ASF PROLOG JMS I QGENCOD /STARTD SD-1 JMP ASFARG /NEXT ARG ASFASE, JMS I QGENCOD /STARTE SE-1 JMP ARGSV ASFEND, 0 /HANDLE END OF A.S.F. TAD ASFSWT /IS THIS END OF ASF ? SNA CLA JMP PTCH /V3C NO DCA ASFSWT /CLEAR SWITCH JMS I QOINS /RESET XR'S XSET;ZXR TAD GLABEL /OUTPUT SPACE FOR RETURN ADDR ISZ GLABEL JMS I QLABEL /OUPTUT THE LABEL JMS I QOINS /ORG .+2 ORG;DOTP2 TAD ASFSKP /OUTPUT SKIP ARROUND LABEL JMS I QLABEL /OUPTUT THE LABEL JMS I QCRLF TAD ASFMOD /RESET MODE SWITCH DCA FMODE TAD TMPMAX /UNIQUE TEMPS IAC DCA TEM /V3C MUST BE USED JMS I QXRTBL /AND XR'S LOST PTCH, TAD TEM /V3C DCA TMPCNT /V3C JMP I ASFEND /RETURN ASFMOD, 0 ASFSKP, 0 IOFUN, JMS I QOPCDE /CALLED BY TRAP3,NOT JSR** TRAP3 TAD I TEMP JMS I QOUTSYM /OUTPUT THE IO FUNCTION NAME JMP I (IOONLY /DO SOME OTHER STUFF ESUBR, TEXT '#EXPXX' /THIS WILL BE THE CORRECT NAME PAGE
/ I/O LIST ELEMENT IOLMNT, JMS I QGARG /GET THE ARG JMP IOTYPE /TYPE ERROR DCA IOLOOP /CLEAR LOOP SWITCH CLL STA RTL /-3 TAD TYPE1 DCA TYPE1 /TYPE1 = 0 IF COMPLEX, 1 IF D.P. TAD ARG1 /ADDR OF TYPE WD CLL IAC DCA ARG2 TAD ARG1 /LOOK AT ARG TAD QM63 SNL CLA JMP NOLOOP /NOT ARRAY OUTPUT CDF 10 CLL CML RTR /IS IT DIMENSIONED ? AND I ARG2 CDF SNA CLA JMP NOLOOP /NO, NO LOOP ISZ IOLOOP /SET SWITCH TAD ARG1 /GET TO SS JMS I QGETSS IAC /TOTAL SIZE WORD DCA BASE1 TAD I ARG2 /IS THIS ARRAY AN ARG ? AND Q20 DCA ARGIO /SET SWITCH TAD I BASE1 /IS IT VARIABLY DIMENSIONED ? SNA JMP I (VDAIO /YES, MUST COMPUTE SIZE DCA BASE2 /SAVE SIZE CDF JMS I QOPCDE /PUT SIZE IN XR 1 LDX TAD Q255 JMS I QOCHAR /- TAD BASE2 JMS I QONUMBR TAD COMMA JMS I QOCHAR TAD (261 JMS I QOCHAR JMS I QCRLF TAD ARGIO /IS IT AN ARG ? SZA CLA JMP I (ARGIOA /YES OLLABL, TAD GLABEL /OUTPUT LABEL JMS I QOLABEL DCA I (XRBUFR+20 /KILL XR1 ENTRY TAD COMMA JMS I QOCHAR NOLOOP, TAD INPUT /INPUT OR OUTPUT ? SNA CLA JMP OUTV /OUTPUT JMS FIXCAL /SET PTR FOR OJSR** JMS I (DUMSUB /NOW THE STORE FSTA TAD ARG1 /KILL ASSOCIATED JMS I QCHKXR /XR EXPRESSIONS CDSFLP, TAD TYPE1 /IS IT C OR D ? CLL RAR SZA CLA JMP ENDLUP /NO, NO STARTE JMS I QGENCOD SF-1 ENDLUP, TAD IOLOOP /IS THERE A LOOP ? SNA CLA JMP I QNEXT /NO, DO NEXT LIST ELEMENT JMS I QOPCDE /YES, OUTPUT JXN JXN TAD GLABEL ISZ GLABEL /OUTPUT LABEL JMS I QLABEL /OUPTUT THE LABEL TAD (261 JMS I QOCHAR TAD PLUS /OUTPUT PLUS (FOR /INCREMENT DUMMY) JMS I QOCHAR JMS I QCRLF JMP I QNEXT /DO NEXT LIST ELEMENT OUTV, TAD TYPE1 /D OR C ? CLL RAR SZA CLA JMP .+3 /NO, NO STARTF NECCESSARY JMS I QGENCOD SE-1 JMS I (DUMSUB /OUTPUT FLDA FLDA JMS FIXCAL JMP CDSFLP /THEN STARTF AND JXN IF ANY FIXCAL, 6401 TAD TYPE1 /IF VARIABLE IS COMPLEX, CIA /OR IF VARIABLE IS DOUBLE AND SZA /I/O IS BINARY, TAD BINARY /GENERATE A JSR #RFDV SNA CLA /ELSE GENERATE A TRAP3 #RSVO JMP BINDIO CLA STL RTL /SET PTR JMS I (OJSR /NOW GO DO IT RDRTNE /HERE'S THE NAME JMP I FIXCAL BINDIO, JMS I (OJSR RDDRTN JMP I FIXCAL IOTYPE, JMS I QTTYMSG /IO TYPE ERROR 1124 DEFLBL, JMS I QCRLF /CRLF BEFORE LABL JMS I QGENSF /ENTER F MODE BEFORE ALL LABELS JMS I QINWORD /GET THE LABEL CDF 10 JMS I QOSNUM /OUTPUT IT TAD COMMA JMS I QOCHAR JMS I QXRTBL /KILL XR TABLE DCA WHATAC /AND AC AT LABEL JMP I QNEXT PAGE
/ I/O LIST ELEMENT VDAIO, CLL CMA RAL /GET ADDR OF NUMBER OF DIMS TAD BASE1 DCA X10 TAD I X10 /GET DIM COUNT CIA DCA NARGS ISZ X10 /SKIP SIZE ISZ X10 /AND MAGIC NUMBER ISZ X10 /AND LITERAL NUMBER TAD (FLDA /LOAD FIRST DIM SKP GSIZLP, TAD (FMUL /MULTIPLY THE REST DCA OPCIO CDF 10 TAD I X10 /GET THE NEXT DIMENSION DCA TYPE2 CDF JMS I QOPCOD /OUTPUT OPCODE OPCIO, 0 JMS I QOADDR /NOW THE DIMENSION TYPE2 ISZ NARGS JMP GSIZLP /KEEP GOING JMS I QOPCOD /NEGATE THE FAC FNEG JMS I QCRLF JMS I QGENCOD /PUT THE COUNT INTO XR1 ATX1-1 ARGIOA, JMS I QGENCOD /PUT -1 INTO XR 2 LXM1C2-1 JMS I QOPCDE /LOAD THE ARG POINTER - FLDA /CONST DCA I (XRBUFR+40 /KILL XR 2 ENTRY TAD ARG1 CDF 10 JMS I QOUTNAM JMS I QCRLF JMS I QOPCDE /NOW ADD THE MAGIC NUMBER FADD TAD QLITRL /OUTPUT #LIT+XXXX JMS I QOUTSYM CDF 10 ISZ BASE1 ISZ BASE1 TAD I BASE1 CDF JMS I QONUMBR JMS I QCRLF JMS I QOPCDE FSTA /NOW STORE IN #BASE+3 TAD (XBASP3 JMS I QOUTSYM JMS I QCRLF JMS I QGENCOD /STARTF SF-1 JMP I (OLLABL /NOW THE INSIDE OF THE LOOP DUMSUB, 0 /OUTPUT FLDA OR FSTA /WITH SE IF NEEDED TAD I DUMSUB /GET THE OPCODE DCA LDASTA ISZ DUMSUB TAD TYPE1 /MUST WE SE ? CLL RAR /TYPE1 IS 0 IF C, 1 IF D SNA CLA TAD Q3 /MULTIPLIER IS 6 TAD Q3 /OR 3 DCA MQ JMS I QOPCOD /FLDA OR FSTA LDASTA, 0 TAD IOLOOP /IS IT A LOOP ? SNA CLA JMP EZVAR /NO TAD ARGIO /IS IT AN ARG ? SZA CLA JMP IBASP3 /YES, INDIRECT THROUGH #BASE+3 JMS I QOTAB TAD ARG1 CDF 10 /OUTPUT NAME JMS I QOUTNAM TAD (255 /- JMS I QOCHAR TAD BASE2 /NEGATIVE OF SIZE CIA JMS I QMUL12 /TIMES 6 OR 3 JMS I QNUMBRO TAD COMMA /COMMA SEVEN JMS I QOCHAR TAD (261 JMS I QOCHAR JMS I QCRLF JMP I DUMSUB /RETURN EZVAR, JMS I QOADDR /ITS A SCALAR ARG1 JMP I DUMSUB IBASP3, TAD (245 /INDIRECT THROUGH #BASE+3 JMS I QOCHAR JMS I QOTAB TAD (XBPC2P /FLDA% #BASE+3,2+ JMS I QOUTSYM JMS I QCRLF JMP I DUMSUB XBPC2P, TEXT '#BASE+3,2+' OR, JMS I QCODE ORTABL-6;0 JMP I (RELGEN XOR, JMS I QCODE EQVTBL-6;0 JMP I (RELGEN DOTP2, TEXT '.+2' ZXR, TEXT '#XR' PAGE
/ ASSIGNED GOTO AND ASSIGN AGOTO, JMS GTSTUF /LOOK AT THE ASSIGNED VAR JMS I QGENCOD /GENERATE A JAC AGTCOD-1 JMP I QNEXT ASSIGN, JMS I QGARG /GET THE ASSIGN VAR JMP GTTYPE CLL CMA RTL /MUST BE I OR R TAD TYPE1 SMA CLA JMP GTTYPE /GOTO TYPE ERROR JMS I QGENCOD /GENERATE THE ASSIGN CODE ASNCOD-1 JMS I (JAGEN JMS I QGENCOD /NOW STORE IT ASTOR-1 JMP I QNEXT
/ OPTIMIZER SUBROUTINES CHEKXR, 0 /KILL XR EXPRS CIA /ASSOCIATED WITH THIS VAR DCA KILVAR /SINCE IT HAS /JUST BEEN CHANGED TAD (-7 /LOOK AT XR 1 THRU 7 DCA TEMP /COUNT TAD (XRBUFR+20 /POINTER DCA TEMP2 KILLUP, TAD I TEMP2 /GET NEXT XR /EXPR. INDICATOR SNA CLA JMP EOKL /NOTHING HERE TAD TEMP2 /GET POINTER DCA X13 /INTO AN XR TAD I X13 /GET ADDR OF DIB DCA DIMPTR /SAVE IT CDF 10 /FIELD OF SYMBOL TABLE TAD I DIMPTR /GET NUMBER OF /DIMENSIONS CMA /COMPLIMENTED DCA NARGS /SAVE IT CDF /BACK TO FIELD OF XRBUFR CHKKIL, ISZ NARGS /CHECK 1 LESS /THAN THE NUMBER SKP /OF DIMENSIONS JMP EOKL TAD I X13 /LOOK AT NEXT /ELEMENT OF EXPR TAD KILVAR /IS IT THE VAR /JUST CHANGED ? SNA CLA DCA I TEMP2 /YES, KILL THIS EXPRESSION JMP CHKKIL /LOOP EOKL, TAD TEMP2 /DO NEXT XR TAD Q20 DCA TEMP2 /BUMP POINTER BY 16 ISZ TEMP JMP KILLUP JMP I CHEKXR /RETURN KILVAR, XRTABL, 0 /CLEAR OR RESET /XR TABLE FLAGS DCA TYPE /0=CLEAR 1=RESET TAD (-7 /DO XR1 THRU 7 DCA TEMP /COUNT TAD (XRBUFR+20 /POINTER DCA TEMP2 XRTLUP, TAD I TEMP2 /GET INDICATOR SNA CLA JMP .+3 /DON'T CHANGE IF ZERO TAD TYPE /OTHERWISE SET TO DCA I TEMP2 /'USED BY /PREVIOUS STMT' TAD TEMP2 /GET TO NEXT ONE TAD Q20 DCA TEMP2 /BUMPING BY 16 ISZ TEMP JMP XRTLUP /LOOP JMP I XRTABL /DONE LOADA, 0 /GENERATE AN FLDA TAD I LOADA /IF NECESSARY DCA LODARG /GET ARG POINTER ISZ LOADA /BUMP RETURN TAD I LODARG /DOES AC MATCH ? TAD WHATAC SZA CLA JMP DOLOAD /NO, MUST LOAD TAD LODARG /GET ADDRESS IAC /OF BASE DCA ARG /IN CASE SS'D TAD I ARG /DOES BASE MATCH? TAD WHATBS SNA CLA JMP I LOADA /OK, DON'T LOAD DOLOAD, JMS I QOPCOD /GENERATE FLDA FLDA JMS I QOADDR /ADDRESS LODARG, 0 JMP I LOADA PAGE
/ INTER PASS EQUATES BLNKCN=21 ALIST=23 INTLST=60 FPLIST=56 DPLIST=57 CMPLST=61 HOLIST=55 SNLIST=62 ONEI=63 THREE=70 SIX=75 TRUE=102
/ START PASS 2 (INTER PASS COMMUNICATION) IFNZRO OVERLY < FIELD 0 NOPUNCH *OVRLAY> IFZERO OVERLY < FIELD 0 ENPUNCH *OVRLAY> START2, JMP I Q7605 /RETURN BUT DON'T SAVE CORE TAD I X10 /PICK UP NEXT FROM PASS 1 DCA X17 TAD X17 /SAVE POINTER TO /EXTERNAL LITERALS DCA EXTLIT TAD I X10 /PASS ONE STACK LEVEL DCA X11 TAD I X10 /TEMP FILE START DCA INBLOK TAD I X10 /AND SIZE CMA DCA INRCNT TAD I X10 /START OF PASS2O.SV DCA PASS2O TAD I X10 /START OF OUTPUT FILE DCA FILBLK /SAVE IT FOR CHAINING TO RALF TAD FILBLK DCA OBLOCK TAD I X10 DCA OSIZE /ALSO MAX SIZE TAD I X10 /PICK UP PROG NAME DCA PROGNM TAD I X10 DCA ARGLST /AND ARG LIST ADDR TAD I X10 /AND /FUNCTION/SUBROUTINE/MAIN SWITCH DCA FUNCTN TAD I X10 /GET DP HARDWARE SWITCH DCA DPUSED TAD I X10 /CHECK FOR CROSSED VERSIONS TAD VERS SZA CLA JMP VERROR /VERSION ERROR STA STL /V3C DCLOOP, TAD X11 /V3C THIS ADD CLEARS THE LINK DCA X11 /V3C TAD X11 TAD (-STACK1 SNL CLA JMP PSN /GO DO STMT NUMBERS TAD I X11 /GET DO LOOP ENDING STMT NUMBER IAC DCA X10 CDF 10 TAD (0416 /DN DO END MISSING JMS NPRNT /GO PRINT THE MESSAGE /AND THE NUMBER CDF CLL CMA RTL JMP DCLOOP /V3C BACK UP 2 PSN, TAD (SNLIST /PROCESS STMT NUMBERS CDF 10 SNCLUP, DCA ENTRY /SAVE NEW ENTRY ADDR TAD I ENTRY /GET ADDR OF NEXT ENTRY SNA JMP SNDONE /NO MORE STMT NUMBERS IAC DCA TEMP /ADDR OF TYPE WORD TAD I TEMP /WAS STMT NUMBER DEFINED? SPA CLA JMP SNDEFN /YES TAD TEMP DCA X10 TAD (2523 /PRINT US MESSAGE JMS NPRNT SNDEFN, TAD (0110 /SET TYPE WORD DCA I TEMP TAD I ENTRY /PROCEED JMP SNCLUP SNDONE, CDF FIXELP, JMS I (TYPRTN NEGSLV /FIX UP NEGATIVE EQUIVALENCE OFFSETS CLL CML RTL /CHECK FOR BLOCK DATA TAD FUNCTN /(FUNCTN=-2) SNA CLA JMP BDSTUF /IT IS JMS I (TYPRTN /DO IMPLICIT TYPING IMPLCT JMS I (TYPRTN /REMOVE SUB ARGS FROM LIST SUBARG JMS I (TYPRTN /EXTERNALS EXTRNL JMP I (PROLG1 /MORE PROLOG BDSTUF, TAD I (BDSWIT /SET UP SWITCH DCA I (PROLG2 TAD (END2 /ALTER END CODE CDF 10 DCA I (XEND CDF 0 DCA NODBUG /NO ISN'S JMP I (HOLDUN /DO SOME STUFF SUBARG, 0 /REMOVE ARGS FROM ST TAD I TYPE AND Q20 /CHECK ARG BIT SNA CLA JMP I SUBARG JMS UNHOOK JMP TFUDGE UNHOOK, 0 TAD I ENTRY DCA I OENTRY TAD BUCKET DCA I ENTRY JMP I UNHOOK VERROR, TAD (2605 /PRINT VE (VERSION ERROR) JMS I QTTYP2C JMS I QTTCRLF JMP I Q7605 PAGE
/ GENERATE ARGUMENT STORAGE PROLG1, JMS I (INS2 / %JA #ST JA;XST JMS I (INS /#XR, %ORG .+10 XXR;ORG;DP8 JMS I QOPCDE / %TEXT #NAMEXX# TEXTX TAD PLUS JMS I QOCHAR CDF 10 TAD PROGNM JMS I QOUTNAM JMS I (FILL /FILL WITH BLANKS TAD PLUS JMS I QOCHAR ISZ PROGNM JMS I QCRLF JMS I (INS /#RET, %SETX #XR XRET;SETX;XXR JMS I (INS2 / %SETB #BASE SETB;XBASE JMS I (INS2 / %JA .+3 JA XDP3, DP3 JMS I (INS /#BASE, %ORG .+6 XBASE;ORG;DP6 TAD ARGLST /ANY ARGS ? SNA JMP NOARGS /NO, SKIP THIS STUFF DCA X10 /SAVE POINTER TO ARG LIST CDF 10 /HOW MANY ? TAD I ARGLST CIA DCA NARGS /THIS MANY DCA TEMP2 /ARRAY ARG COUNTER ARGLP1, JMS PLSUB1 /OUTPUT DEFS FOR ARRAY /ARGS FIRST SNA CLA /SINCE THEY MUST BE /INDIRECTABLY JMP NOARAY /REFERENCABLE ISZ TEMP2 NOARAY, ISZ NARGS JMP ARGLP1 /PROCESS ENTIRE ARG LIST CDF 10 TAD I ARGLST /GO THRU ARGS AGAIN CIA CLL DCA NARGS TAD ARGLST DCA X10 TAD TEMP2 /HOW MANY ARRAY ARGS ? TAD QM6 SNA JMP NISA /NO INDIRECT LOCS LEFT /FOR SCALARS DCA TEMP2 SZL CLA JMP TOOMNY /TOO MANY ARRAY ARGS (>6) ARGLP2, JMS PLSUB1 /NOW OUTPUT AS MANY INDIRECT SZA CLA /SCALAR ARGS AS POSSIBLE JMP NOSCLR /TO REDUCE THE PROLOG ISZ TEMP2 /ROOM FOR ANY MORE SKP JMP NISA2 /NO, THE REST MUST MOVE VALUES NOSCLR, ISZ NARGS /LOOP SOME MORE JMP ARGLP2 JMS I (PLSUB2 /OUTPUT SOME TRACEBACK STUFF JMP I (MORE /GENERATE SCALAR, /LITERAL AND TEMP STORAGE NISA2, JMS I (PLSUB2 JMP NDLP3 /OUTPUT TRACEBACK /STUFF,THEN REST NISA, JMS I (PLSUB2 /GET PAST THE TRACEBACK STUFF ARGLP3, TAD XM3 /GENERATE ORG .+6 FOR D OR C DCA XNOP JMS PLSUB1 /OUTPUT REMAINING /SCALAR ARG SPACE SZA CLA JMP NDLP3 CDF 10 TAD I TEMP /TURN OFF SUBARG BIT AND (7757 /(THATS THE /SECOND TIME I FIXED THIS) DCA I TEMP NDLP3, ISZ NARGS JMP ARGLP3 CDF JMP I (MORE /GENERATE SCALAR, /LITERAL AND TEMP STORAGE NOARGS, JMS I (PLSUB2 /NO ARGS, OUTPUT TRACEBACK STUFF JMP I (MORE /GENERATE SCALAR, /LITERAL AND TEMP STORAGE PLSUB1, 0 CDF TAD I PLSUB1 /GET THE SKIP DCA PLSKIP ISZ PLSUB1 CDF 10 TAD I X10 /GET THE NEXT ARG IAC DCA TEMP /TYP WORD ADDR CLL CML RTR /2000=DIM BIT AND I TEMP PLSKIP, 0 /ARRAYS OR SCALARS ? JMP I PLSUB1 ISZ PLSUB1 CLA CMA TAD TEMP /DEFINE THIS VAR JMS I QOUTNAM TAD COMMA JMS I QOCHAR CDF 10 TAD I TEMP /LOOK AT THE TYPE CDF JMS I QSKPIRL /SKIP IF NOT C OR D XNOP, NOP /THIS IS CHANGED LATER (MAYBE) TAD XDP3 /.+3 OR .+6 DCA .+3 JMS I (INS2 /ORG FOR THE VALUE ORG;0 JMP I PLSUB1 TOOMNY, TAD P0F1 /TOO MANY ARRAY ARGS JMP I P0F2 XM3, CLL CML RTL PAGE
/ SCALARS, LITERALS & TEMPS HOLLIT, MORE, JMS I (TYPRTN /OUTPUT SCALARS SCALAR TAD (TEMPS /OUTPUT FIRST FIVE TEMPS JMS I (OUTVAR TAD (LITRL2 JMS I QOUTSYM TAD COMMA /OUTPUT %LITRL, JMS I QOCHAR JMS I (DOLIST INTLST O141, 0141;-3 /OUTPUT INTEGER LITERALS JMS I (DOLIST FPLIST 0142;-3 /OUTPUT FP LITERALS JMS I (DOLIST DPLIST 0144;-6 /DOUBLE LITERALS JMS I (DOLIST CMPLST 0143;-6 /COMPLEX LITERALS JMS I (TYPRTN /OUTPUT DIMENSION FACTORS DFLIT JMS I (ADFLIT /OUTPUT ARG DIM FACTOR LITERALS TAD (HOLIST /OUTPUT HOLLERITH LITERALS DCA ENTRY HOLLUP, CDF 10 TAD I ENTRY SNA JMP HOLDUN DCA ENTRY /SAVE NEW ENTYR TAD ENTRY DCA X10 TAD O141 /SET TYPE INFO DCA I X10 TAD LITNUM DCA I X10 /SAVE LIT DISP CLL CMA RTL /SET UP COUNTER DCA HOLLIT /BY THREES HOLOOP, CDF 10 /OUTPUT LITERAL AS OCTALS TAD I X10 CDF SNA JMP HOFILL /FILL OUT REST DCA ARG TAD ARG AND (77 /IS THIS LAST WORD? SZA CLA JMP .+4 /NO TAD ARG /YES, STICK IN TAD Q40 /BLANK JMP HOFILL+1 /AND OUTPUT IT TAD ARG /OUTPUT CHAR PAIR JMS ONUM ISZ HOLLIT JMP HOLOOP JMP HOLOOP-2 HOFILL, TAD (4040 /FILL WITH BLANKS JMS ONUM ISZ HOLLIT JMP HOFILL JMP HOLLUP /DO NEXT HOLLERITH LITERAL HOLDUN, CDF JMS I (TYPRTN /DO ARRAYS ARRAYS JMS I (TYPRTN /REMOVE COMMON VARS FROM S.T. COMVAR JMS I QOTAB TAD (XLBLE /#LBL=. JMS I QOUTSYM JMS I QCRLF CDF 10 /LOOK AT THE BLANK COMMON LIST TAD I (ONEI+2 /MAKE TRUE=INTEGER ONE DCA I (TRUE+2 TAD I (BLNKCN+1 CDF SNA JMP NOBC /NO BLANK COMMON DCA TYPE /POINTER TO VARIABLE LIST JMS I QOPCOD COMMON JMS I QCRLF CDF 10 BCLOOP, TAD TYPE /PROCESS THIS HUNK OF /BLANK COMMON DCA X10 TAD I X10 SNA JMP NXTBC /EMPTY HUNK CIA /SIZE OF HUNK DCA TEMP TAD I X10 /OUTPUT HUNK JMS I (OUTVAR CDF 10 ISZ TEMP JMP .-4 NXTBC, TAD I TYPE /ADDR OF NEXT HUNK SNA JMP NOBC /THAT WAS THE LAST HUNK DCA TYPE JMP BCLOOP /DO NEXT HUNK NOBC, CDF JMS I (TYPRTN /DO NAMED COMMONS COMNAM JMS I (TYPRTN /NOW EQUIVALENCES EQUIVS JMS INS2 ORG;XLBL /%ORG #LBL JMP I (PROLG2 /COMPLETE PROLOG PAGE
/ ARGUMENT PICKUP GENERATOR PROLG2, TAD FUNCTN /SECOND PART OF PROLOG SZA CLA JMP DORETN /NOT A MAIN PROG JMS I (INS /#ST, BASE #BASE XST;BASE;XBASE JMS I (INS2 / SETB #BASE SETB;XBASE JMS I (INS2 / SETX #XR SETX;XXR BDSWIT, JMP I (FINIST /GO GET OVERLAY DORETN, JMS I (INS /#RTN, BASE #BASE XRTN;BASE;XBASE TAD ARGLST /ANY ARGS ? SNA JMP JAGOBK /NO DCA X10 /POINTER TO THE LIST CDF 10 TAD I ARGLST /NUMBER OF ARGS CIA DCA NARGS DCA TEMP2 /ZERO ARG COUNTER CDF TAD NARGS /WILL WE RESTORE ANY ? TAD (6 SMA CLA JMP JAGOBK /NO JMS I (INS2 / FLDA #ARGS FLDA;XARGS JMS I (INS2 / FSTA #BASE FSTA;XBASE RSLOOP, CDF 10 TAD I X10 /GET NEXT ARG IAC DCA TEMP /ADDR OF TYPE WORD ISZ TEMP2 /INCR COUNT TAD I TEMP /IS IT A VALUE TRANSMISSION ? AND Q20 CDF SZA CLA JMP NOREST /NO, DON'T RESTORE IT JMS I QOPCDE / %LDX XXXX,1 LDX TAD TEMP2 JMS I QONUMBR TAD (C1 JMS I QOUTSYM JMS I QCRLF JMS I QGENCOD /STARTD SD-1 JMS I (INS2 /GET POINTER TO ARG FLDAI;XBASC1 JMS I (INS2 /AND SAVE IN #BASE+3 FSTA;XBASP3 JMS STFORE /INTO CORRECT MODE JMS I QOPCDE /FLDA VAR FLDA CMA TAD TEMP CDF 10 JMS I QOUTNAM JMS I QCRLF JMS I (INS2 / FSTA% #BASE+3 FSTAI;XBASP3 NOREST, ISZ NARGS JMP RSLOOP JMS I QGENCOD /MAKE SURE WE'RE IN F MODE QSFM1, SF-1 JAGOBK, TAD FUNCTN /WHAT WAS THIS ? SPA CLA JMP NOFVAL /NOT A FUNCTION CDF 10 /GET TYPE TAD I PROGNM AND Q17 TAD (FVAL-1 /PLUS TABLE ADDRESS DCA GVSKEL /GIVES POINTER TO /SKELETON ADDRESS TAD I GVSKEL /GET SKELETON ADDRESS DCA GVSKEL JMS I QGENCOD /PICK UP FUNCTION VALUE GVSKEL, 0 NOFVAL, JMS I (INS2 / JA #GOBAK JA;XGOBAK JMS I (INS /#ST, %STARTD XST;STARTD;0 JMS I QOTAB TAD (210 / %FLDA' 10 JMS I QONUMBR JMS I QCRLF JMS I (INS2 / %FSTA #GOBAK,0 FSTA;XGOBC0 JMP I (MORPLG STFORE, 0 /START F OR E CDF 10 TAD I TEMP /GET TYPE CDF JMS I QSKPIRL /SKIP ON I R OR L TAD (SE-SF /SE TAD QSFM1 /SF DCA .+2 JMS I QGENCOD 0 JMP I STFORE /DON'T FORGET TO /RETURN DUMMY XARGS, TEXT '#ARGS' PAGE
/ ENTRY AND EXIT CODE MORPLG, JMS I QOTAB TAD Q200 / FLDA' 0 JMS I QONUMBR JMS I QCRLF JMS I (INS2 / %SETX #XR SETX;XXR JMS I (INS2 / %SETB #BASE SETB;XBASE TAD ARGLST /ANY ARGS ? SNA JMP I (ENDPLG /NO, JUST STARTF DCA ARG /SAVE POINTER TO THEM JMS I (INS2 / %LDX 0,1 LDX;ZC1 JMS I (INS2 / %FSTA #BASE FSTA;XBASE JMS I (INS2 / %FSTA #ARGS FSTA;XARGS CDF 10 TAD I ARGLST /NUMBER OF ARGS CIA DCA NARGS GALOOP, CDF JMS I (INS2 / %FLDA I #BASE,1+ FLDAI;XBAC1P DCA TYPE /CLEAR THE SD SWITCH CDF 10 ISZ ARG /GET TO NEXT ARG TAD I ARG /LOOK AT ITS TYPE WORD IAC DCA TEMP CLL CML RTR AND I TEMP /WAS IT DIMENSIONED ? SNA CLA JMP I (TSTABT /NO, SEE IF ITS VALUE CMA TAD TEMP /GET ADDR OF DIM INFO JMS I QGETSS IAC /ADDR OF SIZE DCA TEMP2 TAD I TEMP2 ISZ TEMP2 ISZ TEMP2 SNA CLA JMP OUFSTA+1 /IT HAS A VARIABLE DIMENSION TAD I TEMP2 /GET MAGIC NUMBER LIT DISP DCA TEMP2 CDF JMS I QOPCDE / %FSUB #LIT+XXXX FSUB TAD QLITRL JMS I QOUTSYM TAD TEMP2 JMS I QONUMBR JMS I QCRLF CDF 10 OUFSTA, DCA I ARG /IT ISN'T VARIABLY DIMENSIONED CDF JMS I QOPCDE / %FSTA ARGN FSTA CDF 10 CMA TAD TEMP JMS I QOUTNAM JMS I QCRLF ISZ NARGS SKP JMP I (ENDPLG /END OF PROLOG TAD TYPE /DID WE LEAVE D MODE SNA CLA JMP GALOOP /NO JMS I QGENCOD /YES, OUTPUT AN %SD SD-1 JMP GALOOP FINIST, CDF 10 TAD FUNCTN /WAS THIS A FUNCTION ? SPA SNA CLA JMP .+4 /NO, SKIP THIS TAD I PROGNM /YES, TURN OFF EXT BIT AND (6777 /ALLOWING STORING IN FUN NAME DCA I PROGNM TAD (2200 /CHECK /N /Q AND I (7644 CDF SNA CLA NODBUG, DCA I (DEBUG /IF NOT SET, PUT ISN'S CDF 10 /INTO CODE TAD I (7644 /IS /Q SET ? CDF AND (0200 SZA CLA ISZ I (OPTMYZ /MAKE A CLA IAC FROM A CLA GFNAME, CDF 10 TAD I FNAME /MOVE FILE NAME CDF DCA I NAMEF /INTO PAGE ISZ FNAME ISZ NAMEF ISZ NFCNT JMP GFNAME JMP I (RDOVLY /GO WHERE ? /CALIFORNIA OF COURSE!!!! FNAME, 7601 NAMEF, F1LNAM NFCNT, -4 ONUM, 0 ISZ LITNUM /BUMP LITERAL COUNTER DCA ARG JMS I QOTAB TAD ARG JMS I QONUMBR JMS I QCRLF JMP I ONUM PAGE
/ ENTRY AND EXIT CODE TSTABT, TAD I TEMP /VALUE TRANSMISSION ? AND Q20 SZA CLA JMP I (OUFSTA /NO CDF JMS I (INS2 / %FSTA #BASE+3 FSTA;XBASP3 JMS I (STFORE /ENTER CORRECT MODE JMS I (INS2 / %FLDA% #BASE+3 FLDAI;XBASP3 ISZ TYPE /SET SWITCH JMP I (OUFSTA-1 ENDPLG, JMS I QGENCOD /%SF SF-1 TAD ARGLST /ANY VARIABLY /DIMENSIONED ARRAYS ? SNA JMP I (FINIST /NO ARGS AT ALL DCA X10 CDF 10 TAD I ARGLST /NUMBER OF ARGS CIA DCA NSARGS VDIMLP, CDF 10 TAD I X10 /GET NEXT ARG SNA JMP NDVDIM /NOT A VARIABLY /DIMENSIONED ARRAY DCA VDTEMP TAD VDTEMP /GET ADDR OF DIMENSION INFO JMS I QGETSS DCA VDTMP2 TAD I VDTMP2 /NUMBER OF DIMENSIONS CIA DCA NARGS ISZ VDTMP2 /MOVE TO MAGIC NUMBER LITERAL ISZ VDTMP2 ISZ VDTMP2 TAD I VDTMP2 /GET IT CDF DCA MNL /SAVE MAGIC NUMBER LITERAL TAD (FLDA /JUST LOAD FIRST DIM DCA MNOPC TAD NARGS /GET ADDRESS CIA /OF THE LAST TAD VDTMP2 /DIMENSION DCA VDTMP2 /FOR THE SIZE GETTER JMP CMPMN3 /SKIP MULTIPLY FIRST TIME CMPMN1, TAD (FMUL /NEXT TIME USE A MULTIPLY DCA MNOPC JMS I QOPCOD /NEXT SUBSCRIPT (ALWAYS (1.0) FADD JMS I QOADDR /NOW ADDRESS (ONEI CMPMN3, ISZ NARGS /ANY MORE SS ? JMP CMPMN2 /YES ISZ VDTEMP /GET TO TYPE CDF 10 TAD I VDTEMP CDF JMS I QSKPIRL /SKIP ON I R L TAD Q6M3 /YES TAD (THREE JMS LDAMUL /3.02 JMS I (INS2 /ALN 0 ALN;D0 JMS I QOPCDE FSTA TAD QLITRL /SAVE IN THE MAGIC /NUMBER LITERAL JMS I QOUTSYM CLA CMA TAD MNL JMS I QONUMBR JMS I QCRLF JMS I (INS2 /FNEG FNEG;0 JMS I (INS2 /ENTER D MODE STARTD;0 JMS I QOPCDE FADDM /NOW MODIFY THE POINTER CMA TAD VDTEMP CDF 10 JMS I QOUTNAM JMS I QCRLF JMS I (INS2 /RETURN TO F MODE STARTF;0 NDVDIM, ISZ NSARGS /ANY MORE ARGS TO CHECK? JMP VDIMLP /YES CDF JMP I (FINIST CMPMN2, CLA CMA /BACK UP THE POINTER TAD VDTMP2 /BY ONE DCA VDTMP2 CDF 10 TAD I VDTMP2 /GET IT CDF JMS LDAMUL /3.02 JMP CMPMN1 /LOOP VDTEMP, 0 VDTMP2, 0 NSARGS, 0 MNL, 0 DP12, TEXT '.+14' LDAMUL, 0 /3.02 DCA MNADR JMS I QOPCOD MNOPC, 0 JMS I QOADDR MNADR JMP I LDAMUL MNADR, 0 PAGE / RANDOM PROLOG STUFF ARRAYS, 0 /OUTPUT ARRAYS TAD I TYPE AND (6220 /IS IT AN ARRAY SNA JMP I ARRAYS AND (4220 /NOT COMMON, EQUIV OR ARG SZA CLA JMP I ARRAYS JMS I (UNHOOK /REMOVE FROM BUCKET TAD ENTRY /OUTPUT VARIABLE JMS I (OUTVAR JMP TFUDGE-1 FILL, 0 /FILL SUB NAME WITH BLANKS CLL CML RTL TAD PROGNM /PROGNM+2 CIA /-PROGNM-2 TAD I XNAMP /1,2,3 TAD QM4 /-3,-2,-1 DCA TEMP JMP .+5 TAD (240 /TWO BLANKS FOR EACH WORD JMS I QOCHAR TAD (240 JMS I QOCHAR ISZ TEMP /MORE ? JMP .-5 /YES JMP I FILL XNAMP, NAMPTR NPRNT, 0 JMS I QTTYP2C JMS I QTTYP2C TAD I X10 /NOW NUMBER JMS I QTTYP2C TAD I X10 JMS I QTTYP2C TAD I X10 JMS I QTTYP2C JMS I QTTCRLF JMP I NPRNT
/ROUTINE TO FIX UP NEGATIVE EQUIVALENCE OFFSETS NEGSLV, 0 TAD I TYPE AND Q200 SNA CLA /IS VARIABLE A SLAVE? JMP I NEGSLV /NO TAD TYPE DCA X10 TAD I X10 /GET POINTER TO EQUIV BLOCK DCA X10 CLA IAC TAD I X10 /GET POINTER TO MASTER DCA OLDM /TYPE WORD TAD I X10 /OFFSET FROM MASTER CMA STL TAD I X10 /SUBTRACT FROM SLAVE OFFSET DCA SFUDGE /SAVE IN CASE WE NEED IT TAD I OLDM /IF MASTER IS IN COMMON FORGET THE NEXT TEST: SZL SPA CLA /IF MASTER OFFSET < SLAVE OFFSET THEN JMP I NEGSLV /SLAVE WILL ORIGIN BEFORE MASTER - TAD I TYPE /THEREFORE THE SLAVE MUST BECOME THE MASTER AND (7577 /UNSLAVE THE SLAVE DCA I TYPE ISZ TYPE TAD I TYPE DCA TYPE1 /TYPE1 POINTS TO EQUIV BLOCK CLA IAC TAD TYPE1 DCA X10 /USE AUTO-XR TO CLEAR OFFSETS TAD ENTRY DCA NEWM TAD I OLDM /GET OLD MASTER'S TYPE WD TAD Q200 DCA I OLDM /MAKE IT A SLAVE ISZ OLDM TAD I TYPE1 /GET POINTER TO SLAVE DIMENSION BLOCK DCA I TYPE /PUT IT IN SYMTAB AS BEFITTING A NEW MASTER TAD I OLDM /GET OLD MASTERS DIM PTR DCA I TYPE1 /PUT IT IN EQUIV BLOCK AS BEFITTING A NEW SLAVE TAD TYPE1 /NOW ASSOCIATE THE EQUIV BLOCK DCA I OLDM /WITH THE NEW SLAVE DCA I X10 /AND MAKE BOTH OFFSETS 0 DCA I X10 /("FIXSLV" WILL ADJUST IT - NOTE THE "MASTER" CDF 0 /WD OF THE BLOCK STILL POINTS TO THE OLD MASTER) JMS I (TYPRTN /** RECURSIVE CALL ** - ACTUALLY WE DON'T CARE FIXSLV /SINCE WE AREN'T RETURNING ANYWAY JMP I (FIXELP /TRY AGAIN FROM SCRATCH
/ROUTINE TO ADJUST ALL SLAVES OF THE OLD MASTER /TO BE SLAVES OF THE NEW MASTER FIXSLV, 0 /THROUGHOUT TAD I TYPE AND Q200 SNA CLA /IS IT A SLAVE? JMP I FIXSLV /NO ISZ TYPE CLA IAC TAD I TYPE DCA TYPE /TYPE NOW POINTS TO THE EQUIV BLOCK CLA IAC TAD I TYPE /GET PTR TO THIS SLAVES MASTER (+1) CMA TAD OLDM /COMPARE MASTERS SZA CLA JMP I FIXSLV /NOT UNDER SAME MASTER - LEAVE TAD NEWM DCA I TYPE /"MEET THE NEW BOSS..... ISZ TYPE / SAME AS THE OLD BOSS...." TAD I TYPE / (THE WHO) TAD SFUDGE /ADD IN THE DIFFERENCE BETWEEN OLD AND NEW IAC /MASTERS TO THE MASTER OFFSET DCA I TYPE JMP I FIXSLV /THE SLAVE IS NOW -- A SLAVE! OLDM, 0 NEWM, 0 SFUDGE, 0 PAGE
/ ENTRY AND EXIT CODE PLSUB2, 0 /DUMB SUBR FOR PROLOG CDF JMS INS2 / %ORG #BASE+30 ORG;XBAP30 JMS INS2 / %FNOP FNOP;0 JMS INS2 / %JA #RET JA;XRET JMS INS2 / FNOP FNOP;0 JMS INS /#GOBAK,ORG .+2 XGOBAK;DBLZRO;0 /**TO INSURE IT'S 0 TAD DPUSED /WAS DOUBLE PRECISSION USED ? SNA CLA JMP NDPUSD /NO, NO NEED FOR TEMP JMS INS XDPTMP;ORG;DP12 /#DPT, ORG .+12 JMS INS2 DPCHK;0 NDPUSD, TAD FUNCTN /FUNCTION OR SUBR ? SNA JMP I PLSUB2 /ITS #MAIN, NO #VAL OR #ARGS SPA CLA JMP .+5 /ITS A SUBROUTINE, NO #VAL JMS INS /#VAL, %ORG .+6 XVAL;ORG;DP6 JMS INS /#ARGS, %ORG .+3 XARGS;ORG;DP3 JMP I PLSUB2 INS2, 0 / %OPCOD ADDR TAD INS2 /COMMONIZE RETURNS DCA INS JMP INS3 INS, 0 /TAG, %OPCOD ADDR TAD I INS /GET TAG FIELD ISZ INS JMS I QOUTSYM /OUTPUT IT TAD COMMA JMS I QOCHAR INS3, JMS I QOTAB TAD I INS /GET OPCODE ISZ INS JMS I QOUTSYM TAD I INS /GET ADDR SNA CLA JMP .+4 /NO ADDRESS JMS I QOTAB TAD I INS JMS I QOUTSYM ISZ INS JMS I QCRLF JMP I INS SECT, TEXT 'SECT' XRET, TEXT '#RET' XXR, TEXT '#XR' XGOBAK, TEXT '#GOBAK' XST, TEXT '#ST' XGOBC0, TEXT '#GOBAK,0' XBAP30, TEXT '#BASE+30' FNOP, TEXT 'FNOP' SETX, TEXT 'SETX' SETB, TEXT 'SETB' TEXTX, TEXT 'TEXT' XBASC1, TEXT '#BASE,1' DP3, TEXT '.+3' DP6, TEXT '.+6' ZC1, TEXT '0,1' FLDAI, TEXT 'FLDA%' FSTAI, TEXT 'FSTA%' XLBLE, TEXT '#LBL=.' C1, TEXT ',1' XLBL, TEXT '#LBL' /STACK-5 CAN'T BE 0 DBLZRO, TEXT '0;0' PAGE
/ SYMBOL TABLE PROCESSING ROUTINES IMPLCT, 0 /DO IMPLICIT TYPING TAD I TYPE AND O100 /WAS IT EXPLICITLY TYPED SZA CLA JMP I IMPLCT /YES TAD BUCKET /IS IT INTEGER ? TAD M317 CLL TAD M006 SNL CLA ISZ I TYPE /TYPE IT REAL ISZ I TYPE /TYP IT INTEGER JMP I IMPLCT O100, DFLIT, 100 /GENERATE FACTORS FOR CALLS CLL CML RTR /DIMENSIONED ? AND I TYPE SNA CLA JMP I DFLIT /NO TAD I TYPE DCA TEMP /SET PROPER WDS/ENTRY FOR VMC TAD ENTRY /GET ADDR OF MAGIC NUMBER JMS I QGETSS TAD (2 DCA TYPE TAD I ENTRY /SAVE LINK DCA DFTEMP TAD BUCKET /FIX NAME DCA I ENTRY TAD I TYPE /GET MAGIC NUMBER DCA TEMP2 ISZ TYPE CDF JMS I (ONUM /OUTPUT A ZERO WORD JMS I QOPCDE JA TAD ENTRY /OUTPUT VAR MINUS CONST JMS I (VMC JMS I QCRLF /END LITERAL CDF 10 TAD LITNUM /SAVE NUMBER IN DIM INFO DCA I TYPE ISZ LITNUM /THEN BY 2 MORE ISZ LITNUM TAD DFTEMP /RESTORE ENTRY DCA I ENTRY JMP I DFLIT M006, DFTEMP, EXTRNL, 6 /DO EXTERNALS TAD I TYPE AND O1000 /IS IT EXT ? SNA CLA JMP I EXTRNL JMS I (UNHOOK /REMOVE THIS SYMBOL TAD PROGNM /IS IT THE PROG NAME ? CIA TAD ENTRY SZA CLA JMP .+5 /NO, OUTPUT EXTERN TAD FUNCTN /IS IT A MAIN PROG ? SNA CLA JMP TFUDGE-1 /YES, NO SECT TAD (SECT-EXTERN /NOT MAIN, OUTPUT SECT TAD XTRN DCA M317 CDF JMS I QOPCDE M317, -317 TAD ENTRY /NOW VAR NAME CDF 10 JMS I QOUTNAM JMS I QCRLF JMP TFUDGE-1 O1000, EQUIVS, 1000 /OUTPUT EQUIVALENCES TAD I TYPE AND Q200 /IS THIS A SLAVE ? SNA CLA JMP I EQUIVS /NO JMS I (UNHOOK /UNHOOK THE ENTRY TAD I TYPE /SAVE THE TYPE WORD DCA TYPE1 ISZ TYPE /POINT TO EQUIVALENCE BLOCK TAD I TYPE DCA X10 CDF JMS I QOPCDE /OUTPUT ORG ORG CDF 10 TAD I X10 /MASTER NAME DCA X11 /SAVE IT TAD X11 JMS I QOUTNAM /OUTPUT IT TAD PLUS /+ JMS I QOCHAR CDF 10 TAD I X11 /MASTER SS JMS SUBRX TAD Q255 /MINUS JMS I QOCHAR CDF 10 TAD TYPE1 /SLAVE SS JMS SUBRX JMS I QCRLF /EOL CDF 10 TAD ENTRY /NOW OUTPUT SLAVE JMS I (OUTVAR JMP TFUDGE-1 XTRN, SUBRX, EXTERN JMS I QSKPIRL /SIZE OF THING TAD Q3 TAD Q3 /TIMES 3 OR 6 DCA MQ TAD I X10 CDF JMS I QMUL12 /MAKE THE PRODUCT JMS I QNUMBRO /OUT WITH IT JMP I SUBRX DPCHK, TEXT 'DPCHK' FADDM, TEXT 'FADDM' PAGE
/ SYMBOL TABLE PROCESSING ROUTINES BASE, TEXT 'BASE' OUTVAR, 0 /ALLOCATE STORAGE FOR A VARIABLE DCA VARADR RDF /GET FIELD OF VAR TAD X6201 DCA OVFLD1 TAD OVFLD1 DCA OVFLD2 TAD VARADR /OUTPUT NAME, JMS I QOUTNAM TAD COMMA JMS I QOCHAR JMS I QOPCDE /OUTPUT ORG ORG ISZ VARADR /POINT TO TYPE WROD OVFLD1, 0 TAD I VARADR /GET TYPE X6201, CDF JMS I QSKPIRL TAD Q3 /PER ENTRY TAD Q3 /INTEGER, REAL, AND /LOGICAL 3WORDS DCA MQ DCA AC OVFLD2, 0 CLL CML RTR /CHECK DIM BIT AND I VARADR SNA CLA JMP PLSDOT /NOT DIMENSIONED TAD I VARADR /LOOK AT TYPE ISZ VARADR /MOVE TO EQ DIM POINTER AND Q200 /EQUIVALENCED ? SNA CLA JMP .+3 /NO TAD I VARADR /YES, SKIP EQUIV INFO DCA VARADR TAD I VARADR /ADDRESS OF DIM INFO IAC DCA VARADR /ADDRESS OF SIZE TAD I VARADR /GET TOTAL SIZE CDF JMS I QMUL12 PLSDOT, CDF TAD Q256 JMS I QOCHAR TAD PLUS JMS I QOCHAR JMS I QNUMBRO JMS I QCRLF JMP I OUTVAR SCALAR, 0 /OUTPUT SCALARS TAD I TYPE /IS IT A SCALAR ? AND (7630 /COM, DIM, EXT, ASF, /EQV, ARG, COMMONNAME SZA CLA JMP I SCALAR /NO JMS I (UNHOOK /DELETE THIS FROM THE LIST TAD ENTRY /OUTPUT THIS VARIABLE JMS OUTVAR JMP TFUDGE-1 VARADR, DOLIST, 0 /PROCESS A LITERAL LIST TAD I DOLIST /GET LIST START DCA ENTRY ISZ DOLIST TAD I DOLIST DCA TYPE /GET TYPE BITS ISZ DOLIST TAD I DOLIST ISZ DOLIST DCA LSIZE /GET LITERAL SIZE CDF 10 DLLOOP, TAD I ENTRY /GET NEXT ENTRY SNA JMP DLRETN /NO MORE DCA ENTRY TAD ENTRY DCA X10 /ADDRESS OF TYPE WORD TAD TYPE /PUT IN TYPE DCA I X10 TAD X10 /SAVE THIS ADDR DCA X11 TAD LSIZE /SIZE OF LITERAL DCA TEMP LITLUP, CDF JMS I QOTAB CDF 10 TAD I X10 CDF JMS I QONUMBR JMS I QCRLF ISZ TEMP JMP LITLUP CDF 10 TAD LITNUM /SAVE LITERAL NUMBER DCA I X11 TAD LSIZE /INCREMENT LITERAL NUMBER CIA TAD LITNUM DCA LITNUM JMP DLLOOP DLRETN, CDF JMP I DOLIST TEMPS, 243;2000;TMPSIZ;2415;2000 TMPSIZ, 1;TMPBLK+1 LSIZE, COMVAR, 0 /REMOVE COMMON VARS FROM ST TAD I TYPE AND (4400 /ALSO ASF NAMES SNA CLA JMP I COMVAR JMS I (UNHOOK JMP TFUDGE-1 LITRL2, TEXT '#LIT' COMMON, TEXT 'COMMON' PAGE
/ SYMBOL TABLE PROCESSING ROUTINES TYPRTN, 0 /PROCESS ENTIRE SYMBOL TABLE TAD I TYPRTN /GET ROUTINE ADDRESS DCA ROUTNE ISZ TYPRTN TAD O301 /START WITH 'A' DCA BUCKET TAD M32 /BUCKET COUNT DCA BCNT TYPLP2, TAD BUCKET /GET START OF NEXT LIST TAD ALM301 TYPLUP, DCA OENTRY /SAVE OLD ENTRY ADDRESS CDF 10 TFUDGE, TAD I OENTRY /GET ADDR OF NEXT ENTRY SNA JMP EOL /0 MEANS END OF LIST DCA ENTRY IAC TAD ENTRY /ADDR OF TYPE WORD DCA TYPE JMS I ROUTNE /CALL ROUTINE TAD I OENTRY /CONTINUE DOWN THE LIST JMP TYPLUP EOL, ISZ BUCKET /DO NEXT LETTER ISZ BCNT JMP TYPLP2 CDF JMP I TYPRTN /END OF PASS BCNT=ARG1 COMNAM, 0 /OUTPUT A COMMON BLOCK TAD I TYPE /IS THIS A COMMON BLOCK NAME TAD M111 SZA CLA JMP I COMNAM /NO CDF JMS I QOPCDE COMMON CDF 10 JMS I (UNHOOK /REMOVE THE COMMON /BLOCK FROM S.T. TAD ENTRY JMS I QOUTNAM /OUTPUT NAME JMS I QCRLF ISZ TYPE /GET TO COMMON STUFF POINTER CNLOOP, CDF 10 TAD I TYPE /GET ADDR OF NEXT HUNK /OF COMMON SNA JMP TFUDGE /END OF IT DCA TYPE TAD TYPE /GET A WORKING POINTER DCA X10 TAD I X10 /GET COUNT SNA JMP CNLOOP /NONE IN THIS HUNK CIA DCA TEMP2 TAD I X10 /GET VARIABLE ADDRESS JMS I (OUTVAR /OUTPUT IT CDF 10 ISZ TEMP2 JMP .-4 /DO NEXT ONE FROM THIS HUNK JMP CNLOOP /DO NEXT HUNK O301, 301 M32, -32 ALM301, ALIST-301 M111, -111 ROUTNE, ADFLIT, 0 /OUTPUT ARG DF LITS TAD ARGLST /ANY ARGS SNA JMP I ADFLIT DCA X10 CDF 10 TAD I ARGLST /NUMBER OF ARGS CIA DCA NARGS ADFLUP, CDF 10 TAD I X10 /GET ARG ADDR IAC DCA TEMP /TYPE WORD ADDR TAD I TEMP /GET TYPE INFO DCA TEMP2 CLL CML RTR AND I TEMP /DIMENSIONED ? SNA CLA JMP NDADFL /NO ISZ TEMP /ADDR OF DIM INFO CLL CML RTL TAD I TEMP /ADDR OF MAGIC NUMBER DCA TEMP TAD I TEMP /MAGIC NUMBER DCA MQ /PREPARE TO MULTIPLY ISZ TEMP /ADDR OF LITERAL GOES HERE TAD LITNUM /STICK IN THE ADDRESS IAC DCA I TEMP CDF JMS I (ONUM /OUTPUT A ZERO TAD TEMP2 /LOOK AT TYPE JMS I QSKPIRL /SKIP ON I R L TAD (3 /DOUBLE OR COMPLEX TAD (3 JMS I QMUL12 TAD AC /OUTPUT 2 WORD LITERAL JMS I (ONUM TAD MQ JMS I (ONUM NDADFL, ISZ NARGS JMP ADFLUP JMP I ADFLIT RDOVLY, JMS I (7607 /READ IN OVERLAY NPOVLY OVRLAY PASS2O, 0 JMP I (INERR TAD I (VOVER /CHECK VERSION OF OVERLAY TAD VERS SZA CLA JMP I (VERROR /ERROR, MIXED VERSIONS JMP I (EOSTMT /START PASS2 PROPER PAGE
FIELD 1 *5000 0 /THIS IS THE START OF /THE ERROR MESSAGE LIST /WHICH WORKS BACKWARDS
/OS/8 F4 COMPILER CODE SKELETONS MAC=-6 NEGSGN=-5 FLDAA2=-4 FLDAA1=-3 ENTERE=-2 ENTERF=-1 CGTCOD, ATX;DD1;STARTD;0;FLDA;DP2C1;STARTF;0 AGTCOD, JAC;0;0 ASNCOD, ENTERF;FLDA;DP3C0;JA;DP4;0 ERCODE, EXTERN;XUE;TRAP3;XUE;0 A0FN, EXTERN;XFIX;JSA;XFIX;0 A0SD, ALN;D0 SD, STARTD;0;0 SE, STARTE;0;0 SF, STARTF;0;0 MPTR0, ENTERF;FLDAA1;FSTA;XBASE;0 MPTR3, ENTERF;FLDAA2;FSTA;XBASP3;0 JADP2, JA;DOT;0 DOFIN0, ENTERF;FLDAA1;FADD;-2 ASTOR, FSTA;-1;0 DOFIN1, ENTERF;FLDAA1;FADD;-2;MAC+A0FN;FSTA;-1;0 LDASTD, FLDAA1;STARTD;0;0 /CHALK UP ONE FOR PAL8 ATX1, ATX;DD1;0 LXM1C2, LDX;M1C2;STARTD;0;0 FVAL, FVI-1;FVI-1;FVC-1;FVD-1;FVI-1 FVI, FLDA;XVAL;0 FVC, STARTE;0;FLDA;XVAL;MAC+PCAC;0 FVD, STARTE;0;FLDA;XVAL;0 RTNCOD, RTNX+MAC;JA;XRTN;0 PAZCOD, ENTERF;EXTERN;XPAUSE;JSR;XPAUSE;0 STPCOD, RTNX+MAC;EXTERN;XEXIT;JSR;XEXIT;0 GIRL1, ENTERF;FLDAA1;ENTERE;0 GIRL2, ENTERF;FLDAA2;ENTERE;0 SEGCAC, GCAC, ENTERE;EXTERN;CAC;FLDA;CAC;0 PCAC, EXTERN;CAC;FSTA;CAC;0 GC1C2, ENTERE;FLDAA1;EXTERN;CAC;FSTA;CAC;FLDAA2;0 GC1, ENTERE;FLDAA1;0 GC2, ENTERE;FLDAA2;0 JSACEQ, EXTERN;CEQ;JSA;CEQ;NEGSGN;0 JSACNG, EXTERN;CNEG;JSA;CNEG;0 JSACAD, EXTERN;CADD;JSA;CADD;0 JSACSB, EXTERN;CSUB;JSA;CSUB;0 JSACML, EXTERN;CMUL;JSA;CMUL;0 JSACDV, EXTERN;CDIV;JSA;CDIV;0
/ ADD, SUBTRACT, MULTIPLY, AND DIVIDE SKELETONS ADDTBL, AS-1;AS+2;AS+4 AX-1;AX+2;AX+5 AS-1;AD-1;AS+4 ASC-1;ASC+2;ASC+3 ASD-1;ASD+7;ASD+10 ACS-1;ACS+4;ACS+6 ADS-1;ADS+3;ADS+7 0 FNEG;0 AS, FADD;-1;0 ENTERF;FLDAA1 FADD;-2;0 JSACNG+MAC AX, GC1+MAC;JSACAD+MAC;0 GC1C2+MAC;JSACAD+MAC;0 GC2+MAC;JSACAD+MAC;0 AD, ENTERE;FLDAA1;FADD;-2;0 JSACNG+MAC ASC, GIRL1+MAC;JSACAD+MAC;0 GIRL1+MAC ENTERE;PCAC+MAC;GC2+MAC;JSACAD+MAC;0 FNEG;0 ASD, FSTA;XDPTMP;ENTERF;FLDAA1;ENTERE;FADD;XDPTMP;0 GIRL1+MAC ENTERE;FADD;-2;0 JSACNG+MAC ACS, ENTERE;PCAC+MAC;GC1+MAC;JSACAD+MAC;0 GC1+MAC;PCAC+MAC GIRL2+MAC;JSACAD+MAC;0 FNEG;0 ADS, ENTERE;FADD;-1;0 GIRL2+MAC;FADD;-1;0 FSTA;XDPTMP;GIRL2+MAC;FADD;XDPTMP;0 SUBTBL, AS-3;SS-1;SS+1 AX-2;SX-1;SX+2 AS-3;SDBL-1;SS+1 ASC-2;SSX-1;SSX ASD-3;SSD-1;SSD ACS-2;SCS-1;SCS+1 ADS-3;SDS-1;SDS5-1 0 SS, ENTERF;FLDAA1 FSUB;-2;0 SX, GC1C2+MAC;JSACSB+MAC;0 GC2+MAC;JSACSB+MAC;0 SDBL, ENTERE;FLDAA1;FSUB;-2;0 SSX, GIRL1+MAC ENTERE;PCAC+MAC;GC2+MAC;JSACSB+MAC;0 SSD, GIRL1+MAC ENTERE;FSUB;-2;0 SCS, GC1+MAC;PCAC+MAC GIRL2+MAC;JSACSB+MAC;0 SDS, GIRL2+MAC;FNEG;0;FADD;-1;0 SDS5, FSTA;XDPTMP;GIRL2+MAC;FNEG;0;FADD;XDPTMP;0 MULTBL, M1-1;M1+3-1;M1+5-1 M4-1;M4+3-1;M4+6-1 M1-1;M7-1;M7+2-1 M8-1;M8+3-1;M8+4-1 M11-1;M11+6-1;M11+7-1 M14-1;M14+5-1;M14+7-1 M18+1-1;M18-1;M18+5-1 0 M1, FMUL;-1;0 ENTERF;FLDAA1 FMUL;-2;0 M4, GC1+MAC;JSACML+MAC;0 GC1C2+MAC;JSACML+MAC;0 GC2+MAC;JSACML+MAC;0 M7, ENTERE;FLDAA1;FMUL;-2;0 M8, GIRL1+MAC;JSACML+MAC;0 GIRL1+MAC ENTERE;PCAC+MAC;GC2+MAC;JSACML+MAC;0 M11, FSTA;XDPTMP;GIRL1+MAC;FMUL;XDPTMP;0 GIRL1+MAC ENTERE;FMUL;-2;0 M14, ENTERE;PCAC+MAC;GC1+MAC;JSACML+MAC;0 GC1+MAC;PCAC+MAC GIRL2+MAC;JSACML+MAC;0 M18, GIRL2+MAC ENTERE;FMUL;-1;0 FSTA;XDPTMP;GIRL2+MAC;FMUL;XDPTMP;0 DIVTBL, 1;D2-1;D2+2-1 1;D5-1;D5+3-1 1;D7-1;D7+2-1 1;D9-1;D10-1 1;D12-1;D13-1 1;D14-1;D15-1 1;D16-1;D17-1 0 D2, ENTERF;FLDAA1 FDIV;-2;0 D5, GC1C2+MAC;JSACDV+MAC;0 GC2+MAC;JSACDV+MAC;0 D7, ENTERE;FLDAA1;FDIV;-2;0 D9, GIRL1+MAC D10, ENTERE;PCAC+MAC;GC2+MAC;JSACDV+MAC;0 D12, GIRL1+MAC D13, ENTERE;FDIV;-2;0 D14, GC1+MAC;PCAC+MAC D15, GIRL2+MAC;JSACDV+MAC;0 D16, GIRL2+MAC;FSTA;XDPTMP;FLDAA1;FDIV;XDPTMP;0 D17, FSTA;XDPP6;GIRL2+MAC;FSTA;XDPTMP;FLDA;XDPP6;FDIV;XDPTMP;0
/ RELATIONALS AND LOGICALS SKELETON TABLES EQTABL, EQ1-1;EQ2-1;EQ3-1 EQ4-1;EQ5-1;EQ6-1 EQ1-1;EQ7-1;EQ3-1 EQ8-1;EQ9-1;EQ10-1 EQ11-1;EQ12-1;EQ13-1 EQ14-1;EQ15-1;EQ16-1 EQ17-1;EQ18-1;EQ19-1 EQ1-1;EQ2-1;EQ3-1 EQ1, FSUB;-1;0 EQ2, ENTERF;FLDAA1 EQ3, FSUB;-2;0 EQ4, GC1+MAC;JSACEQ+MAC;0 EQ5, GC1C2+MAC;JSACEQ+MAC;0 EQ6, GC2+MAC;JSACEQ+MAC;0 EQ7, ENTERE;MAC+EQ2+1;0 EQ8, GIRL1+MAC;JSACEQ+MAC;0 EQ9, GIRL1+MAC EQ10, ENTERE;PCAC+MAC;GC2+MAC;JSACEQ+MAC;0 EQ11, MAC+ASD-2;0 EQ12, GIRL1+MAC EQ13, MAC+SSD+1;0 EQ15, GIRL2+MAC EQ14, ENTERE;PCAC+MAC;GC1+MAC;JSACEQ+MAC;0 EQ16, GIRL2+MAC;JSACEQ+MAC;0 EQ18, GIRL2+MAC EQ17, MAC+ADS-2;0 EQ19, MAC+SDS5;0
LETABL, LE1-1;LE2-1;LE3-1 0;0;0 LE1-1;LE4-1;LE3-1 0;0;0 LE11-1;LE12-1;LE13-1 0;0;0 LE17-1;LE18-1;LE19-1 0 LE1, FSUB;-1;NEGSGN;0 LE2, ENTERF;FLDAA1 LE3, FSUB;-2;0 LE4, ENTERE;MAC+LE2+1;0 LE11, MAC+ASD-2;0 LE12, GIRL1+MAC LE13, MAC+SSD+1;0 LE18, GIRL2+MAC LE17, MAC+ADS-2;0 LE19, MAC+SDS5;0
ANDTBL, 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 M1-1;M1+3-1;M1+5-1 ORTABL, 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 AS-1;AS+2;AS+4
EQVTBL, 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 0;0;0 EQ1-1;EQ2-1;EQ3-1
/CONVERSION-FOR-STORE-OPERATOR SKELETONS STRTBL, SIIM-1;SIRM-1;SICM-1;SIDM-1;SIIM-1 SIIA-1;SIRA-1;SICA-1;SIDA-1;SIIA-1 SIIM-1;SIIM-1;SRCM-1;SRDM-1;SIIM-1 SIIA-1;SIIA-1;SRCA-1;SRDA-1;SIIA-1 SCIM-1;SCIM-1;SCCM-1;SCDM-1;SCIM-1 SCIA-1;SCIA-1;SCCA-1;SCDA-1;SCIA-1 SDIM-1;SDIM-1;SDCM-1;SDDM-1;SDIM-1 SDIA-1;SDIA-1;SDCA-1;SDDA-1;SDIA-1 SLIM-1;SLIM-1;SLCM-1;SLDM-1;SIIM-1 SLIA-1;SLIA-1;SLCA-1;SLDA-1;SIIA-1 SIIM, ENTERF;FLDAA2 SIIA, 0 SIRM, ENTERF;FLDAA2 SIRA, A0FN+MAC;0 SICM, GC2+MAC;PCAC+MAC SICA, ENTERF;GCAC+1+MAC;A0FN+MAC;0 SRCM, GC2+MAC;PCAC+MAC SRCA, ENTERF;GCAC+1+MAC;0 SCCM=GC2 SCIM, ENTERF;FLDAA2 SCIA, ENTERE;0 SCCA=GCAC SLIM, ENTERF;FLDAA2 SLIA, JSA;LTRNE;0 SLCM, GC2+MAC;ENTERF;SLIA+MAC;0 SLCA, ENTERF;GCAC+1+MAC;SLIA+MAC;0 SIDM, ENTERE;FLDAA2 SIDA, ENTERF;SIRA+MAC;0 SRDM, ENTERE;FLDAA2 SRDA, ENTERF;0 SCDM, ENTERE;FLDAA2 SCDA, FSTA;TEMPN;ENTERF;FLDA;TEMPN;ENTERE;0 SDIM, ENTERF;FLDAA2 SDIA, ENTERE;0 SDCM, ENTERE;FLDAA2;PCAC+MAC SDCA, ENTERF;GCAC+1+MAC;ENTERE;0 SDDM, ENTERE;FLDAA2 SDDA, 0 SLDM, ENTERE;FLDAA2 SLDA, JSA;LTRNE;0
/ UNARY MINUS AND .NOT. SKELETONS NEGTBL, NIM-1;NIM-1;NCM-1;NDM-1;0 NIA-1;NIA-1;NCA-1;NIA-1;0 NIM, ENTERF;FLDAA1 NIA, FNEG;0;0 NCM, GC1+MAC;PCAC+MAC;JSACNG+MAC;0 NCA=JSACNG NDM, ENTERE;NIM+1+MAC;0 NOTTBL, 0;0;0;0;NOTM-1 0;0;0;0;NOTA-1 NOTM, ENTERF;FLDAA1 NOTA, 0
/ ARITHMETIC IF SKELETONS AIFTBL, GI-1;GI-1;GC-1;GD-1;GI-1 /V3C GI+1;GI+1;GC+1;GD+1;GI+1 /V3C GI, ENTERF;FLDAA1;0 GC, GC1+MAC;0 GD, ENTERE;FLDAA1;0
/OPERATOR DISPATCH TABLE XPUSH, PUSH ADD SUB MUL DIV EXP NOT NEG GE GT LE LT DNA OR EQ NE XOR EQV PAUZE DPUSH BINRD1 FMTRD1 WCLOSE /** DARD1 BINWR1 FMTWR1 WCLOSE DAWR1 DEFFIL ASFDEF ARGS EOSTMT ERROR RETURN REWIND STORE XEND, END DEFLBL DOFINI ARTHIF XLOGIF, LIFBGN DOBEGN ENDFIL STOP ASSIGN BAKSPC FORMAT XGOTO, GOTO CGOTO AGOTO IOLMNT DATELM DREPTC DATAST ENDELM PURGE XLAST, DOSTOR
/ EXPONENTIATION TABLE (NOT A STANDARD SKELETON TABLE) EXPTBL, 1;1111;2;1122;3;1103;4;1104;0;0 /I**D=D 2;1111;2;1122;3;1103;4;1104;0;0 /R**D=D 3;0311;3;0322;3;0303;0;0;0;0 4;0411;4;0422;0;0;4;0404;0;0 0;0;0;0;0;0;0;0;0
/ TYPE MIXING TABLE TYPMIX, 1;6;2;6;3;17;4;22;0;0 2;6;2;6;3;17;4;22;0;0 3;25;3;25;3;11;0;0;0;0 4;30;4;30;0;0;4;14;0;0 0;0;0;0;0;0;0;0;5;33 RTNX, ENTERF;EXTERN;LTRNE;0 $



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search