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