--- /dev/null
+/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
+\f/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
+\f/ 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
+\f/ 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
+\f/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
+\f/ 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
+\f/ 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
+\f/ 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
+\fLTRNE, TEXT '#NE'
+ TEXT '#GE'
+ TEXT '#LE'
+ TEXT '#GT'
+ TEXT '#LT'
+ TEXT '#EQ'
+ PAGE
+\f/ SOME TEXT
+
+P2, TEXT '+2'
+XVAL, TEXT '#VAL'
+DP4, TEXT '.+4'
+FADD, TEXT 'FADD'
+FLDA, TEXT 'FLDA'
+FSUB, TEXT 'FSUB'
+\f/ 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
+\fSATEMP,
+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
+\f/ 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'
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\fENDM, 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'
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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'
+\fJNE, 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'
+\f/ 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
+\f/ 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
+\f/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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\fDNA, 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
+\f/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'
+\f/ 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
+\f/ 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
+\f/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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/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
+\f/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
+\f/ 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
+\f/ 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
+\f/ 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
+\f/ 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
+\f FIELD 1
+ *5000
+ 0 /THIS IS THE START OF
+ /THE ERROR MESSAGE LIST
+ /WHICH WORKS BACKWARDS
+\f/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
+\f/ 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
+\f/ 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
+\fLETABL, 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
+\fANDTBL, 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
+\fEQVTBL, 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
+\f/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
+\f/ 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
+\f/ 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
+\f/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
+\f/ 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
+\f/ 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
+ $
+\f
projects / pdp8.git / blobdiff