1 /3 OS/8 FORTRAN (PASS TWO)
3 / VERSION 4A PT 16-MAY-77
5 / OS/8 FORTRAN COMPILER - PASS 2
8 / UPDATED BY: R. LARY + M. HURLEY
11 /COPYRIGHT (C) 1974,1975 BY DIGITAL EQUIPMENT CORPORATION
22 /THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
23 /AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
24 /CORPORATION. DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
25 /FOR ANY ERRORS THAT MAY APPEAR IN THIS DOCUMENT.
27 /THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
28 /UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
29 /(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
30 /SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
32 /DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
33 /OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
39 \f/SEE F4.PA FOR LIST OF MAINTENANCE RELEASE CHANGES -S.R.
40 /ALSO, ADDED SAFETY CDF 0 TO BUMP ROUTINE TO FIX BUG
41 /MASSAGED LINK IN THAT AREA TO GET ROOM
43 / FIXED BUG RE DN ERROR PRINTING WRONG LINE NUMBER
46 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
47 /.PATCH LEVEL FOR PASS2 IS IN LOCATION 327
49 IFNDEF OVERLY <OVERLY=0>
50 IFNZRO OVERLY <NOPUNCH>
53 LINENO, 1 /LINE NUMBER
54 VERS, -VERSON /VERSION NUMBER
55 ERRPTR, 5001 /POINTER TO THE ERROR LIST
56 FILDEV, 0 /THIS IS THE FILE DESCRIPTOR
58 X10, COMREG-1 /INTER PASS COM REGION
65 X17, 0 /AUTO INDEX REGISTERS
66 ENTRY, 0 /THINGS USED BY SYMBOL
71 TEMP, 0 /GENERAL TEMPS
73 ARG1, 0 /ARGS AND TYPES
80 TMPMAX, 0 /MAX TEMP COUNT
81 LITNUM, 0 /LITERAL DISPLACEMENT
89 STACK=7000 /STACK-5 CAN'T BE 0
93 AC, 0 /AC FOR MULTIPLY ROUTINE
94 XR, 0 /XR CHAR FOR OADDR
95 MQ, 0 /MQ FOR MULTIPLY ROUTINE
96 XRNUM, 0 /TEMP USED IN XR STUFF
97 WHATAC, 0 /POINTER TO VAR
98 WHATBS, 0 /JUST STORED
99 FREEXR, 0 /NUMBER OF FREE
101 DIMPTR, 0 /POINTER TO DIM INFO
103 NARGS, 0 /ARG COUNT FOR SS VAR
105 GLABEL, 1 /GENERATED LABEL COUNTER
106 STKLVL, STACK /STACK LEVEL (CHANGED
110 IFLABL, 0 /HOLDS LABEL FOR LOG IF
111 DOTEMP, 7000 /DO LOOP TEMP COUNTER
112 BINARY, 0 /BINARY IO=1, FORMATTED=0
113 INPUT, 0 /INPUT=1 OUTPUT=0 FOR IO STMTS
114 PROGNM, 0 /POINTER TO PROG/FUNC NAME
115 FUNCTN, 0 /0=MAIN, 1=FUNC, -2=SUBR
116 ARGLST, 0 /POINTER TO ARG LIST
117 DATASW, 0 /=1 IF THIS IS A DATA STMT
118 GCTEMP, 0 /TEMP USED BY GENCAL
119 EXTLIT, 0 /EXTERNAL LITERALS LIST
121 IOLOOP, 0 /IO LOOP SWITCH
122 ARGIO, 0 /ARG IO SWITCH
123 F1LNAM, 0617;2224;2216;2415 /FILE NAME FORTRN.TM
124 DEVH, 7607 /DEVICE HANDLER ADDRESS
125 ACSWIT, 0 /IS NON ZERO IF CALLING AN ARG
126 IOSTMT, 0 /SET 1 IF IN IO STMT
128 FMODE, 1 /1 IF IN F OR D MODE (0 IF E)
129 ASFSWT, 0 /1 IF ASF PROLOG, -1 IF
131 JSRLBL, 0 /LABEL NUMBER FOR CALLS TO ARGS
132 DPUSED, 0 /=1 IF DP HARDWARE USED
190 \f/ OUTPUT UTILTIY ROUTINES
193 CRLF, 0 /OUTPUT CR LF
206 OSNUM, 0 /PRINT STMT NUMBER
207 IAC /SKIP POINTER WORD
209 TAD (6211 /ALWAYS IN FIELD 1
211 TAD OSNUM /SAVE ENTRY POINT
213 TAD (243 /GET FIRST CHAR (ALWAYS #)
214 JMP L6201 /GO PRINT NAME
216 OUTSYM, 0 /PRINT OPCODE
217 DCA NAMPTR /SAVE POINTER TO STUFF
218 TAD L6201 /ALWAYS FIELD 0
220 TAD OUTSYM /SAVE ENTRY
222 JMP NAMCDF /PRINT REST
224 OUTNAM, 0 /OUTPUT NAME
225 DCA NAMPTR /SAVE ADDRESS OF NAME
226 RDF /GET FIELD OF NAME
228 DCA NAMCDF /SAVE AS CDF
229 TAD I NAMPTR /GET FIRST CHAR (ALREADY ASCII)
230 ISZ NAMPTR /SKIP OVER TYPE AND DIM PTR
233 JMS I QOCHAR /OUTPUT CHAR
236 TAD I NAMPTR /GET NEXT TWO CHARS
240 DCA NCHAR /SAVE TWO CHARS
248 JMS I QOCHAR /OUTPUT IT
249 TAD NCHAR /NOW DO LOWER
252 JMP I OUTNAM /NAME DONE
256 JMP L6201+1 /GO AND OUTPUT IT
257 ONUMBR, 0 /OUTPUT OCTAL NUMBER
258 DCA ONUMT /SAVE TEMPORARILY
273 TTYP2C, 0 /PRINT 2 CHARS ON THE TTY
284 CONVRT, 6401 /CONVERT TO ASCII
298 TTYMSG, 0 /PRINT 2 CHAR ERROR MESSAGE
301 ISZ TTYMSG /PRINT ERROR MESSAGE
303 FATAL, JMP I QNEXT /FATAL ERROR MESSAGE
306 JMP I Q7605 /RETURN TO PS8
308 NEG, JMS I QUCODE /NEGATE CODE
312 \f/ OPCODE JUMP TABLE
315 SKP /CODE ALREADY READ
316 NEXT, JMS I QINWORD /GET NEXT INPUT WORD
317 TAD (XPUSH /INDEX INTO JUMP TABLE
322 DCA TEMP2 /GET JUMP ADDRESS
323 JMP I TEMP2 /GO THERE
324 \f/OPTIMIZING RELATIONAL CODE FOR OS/8 F4
328 LT, TAD QM4 /GENERATE -4 FOR LT, -2 FOR LE
329 JMP GE+1 /GO TO COMMON RELATIONAL CODE
331 GE, IAC /GENERATE 1 FOR GE, 3 FOR GT
332 DCA RELCD /ALL THIS FUNNY STUFF IS BECAUSE SOME
333 JMS I QCODE /OF THE RELATIONAL SKELETONS OPTIMIZE BY
334 LETABL-6;5 /PERFORMING THE RELATIONAL ON THE NEGATIVE
335 TAD RELCD /OF THE FAC - WHEN THIS HAPPENS SPECIAL
336 SPA /CODE IN THE SKELETON DOES AN "ISZ RELCD",
337 CIA /CHANGING ABS(RELCD) TO ITS OPPOSITE RELATIONAL
338 JMP RELGEN /E.G. GE(1) TO LE(2), LE(-2) TO GE(-1)
340 EQ, CLA IAC /SINCE EQ AND NE ARE SIGN-INDEPENDENT,
341 NE, DCA RELCD /WE DON'T NEED THAT KLUDGE BUT FOR COMPATIBILITY
342 JMS I QCODE /WITH RTPS THE OS/8 FORTRAN SYSTEM FUNCTION
343 EQTABL-6;5 /"#CEQ" WORKS THE WRONG WAY - IT PRODUCES
344 CLA IAC /A 1.0 IF THE COMPLEX AC WAS (0.,0.)
345 AND RELCD /AND A 0.0 OTHERWISE - SO WE HAVE TO REVERSE
346 SZA CLA /THE SENSE OF COMPLEX .EQ. AND .NE. RELATIONS.
348 RELGEN, DCA RELCD /STORE "FINAL" RELCD
349 JMS I QINWORD /GENTLY PROBE AHEAD IN THE INPUT
353 SNA CLA /IF THIS WAS THE TOP RELATION OF A LOGICAL IF,
354 JMP LIFOPT /WE'RE IN A POSITION TO OPTIMIZE
355 TAD RELCD /OTHERWISE OUTPUT A CALL TO THE
356 CLL RAL /ROUTINE CORRESPONDING TO THE RELATIONAL
360 JMS I (OJSR /GENERATE A JSA #XX
362 JMP I QNEXTM2 /PROCESS THE WHATCHIMACALLIT
364 LIFOPT, TAD TYPE1 /SEE IF WE SHOULD GENERATE A "STARTF" FIRST
365 AND Q17 /ONLY WORRY ABOUT D.P.
366 TAD QM4 /SINCE THE ROUTINE #CEQ DOES A STARTF
367 DCA FMODE /FMODE=0 ONLY IF ARGS WERE D.P.
368 JMS I QGENSF /GENERATE STARTF IF NECESSARY
370 LIFBGN+1 /GO TO LOGICAL IF PROCESSOR
372 EQV, JMS I QCODE /.EQV. LOGICAL OPERATOR
375 \f/ PASS TWO OUTPUT ROUTINE
376 OCHAR, 0 /OUTPUT A CHAR TO THE
379 DCA OUTEMP /SAVE CHAR
380 ISZ OUJUMP /BUMP THREE WAY SWITCH
384 TAD OUTEMP /HIGH FOUR BITS GO INTO
385 CLL RTL /THE HIGH ORDER BITS OF THE
386 RTL /FIRST WORD OF THE TWO WORD PAIR
387 AND (7400 /SEE NOTE * BELOW
388 TAD I OUPOLD /COMBINE WITH OTHER BITS
390 TAD OUTEMP /THE OTHER FOUR BITS OF THIS CHAR
391 CLL RTR /GO INTO THE HIGH ORDER FOUR
392 RTR /BITS OF THE SECOND
398 TAD OUJMP /RESET 3 WAY BRANCH
400 ISZ OUPTR /BUMP BUFFER POINTER
401 ISZ OUWDCT /AND DOUBLE WORD COUNTER
402 JMP I OCHAR /BUFFER NOT FULL
405 CHAR2, TAD OUPTR /SAVE FIRST WORD POINTER
407 ISZ OUPTR /GO TO SECOND WORD
408 CHAR1, TAD OUTEMP /STORE CHAR 1 OR 2
412 OUDUMP, 0 /BUMP THE DUFFER
413 TAD OSIZE /ANY ROOM LEFT ?
417 DCA OSIZE /YES, ITS OK
420 OUBUF /BUFFER POINTER
421 OBLOCK, 0 /BLOCK NUMBER
423 ISZ OBLOCK /INCREMENT BLOCK NUMBER
424 ISZ FILSIZ /AND FILE SIZE
425 TAD OBLOCK-1 /SET BUFFER POINTER
427 TAD (-200 /SET DOUBLE WORD COUNT
430 OUERR, JMS I (FATAL /FATAL OUTPUT ERROR
432 / * THE PONY EXPRESS STARTED IN 1860 AND ONLY RAN
433 / FOR 19 MONTHS WHILE LOSING $200,000.
441 \f/ READ FROM FORTRN.TM
443 INWORD, 0 /READ A WORD FROM INPUT FILE
444 ISZ INBCNT /ANYTHING LEFT IN BUFFER ?
446 ISZ INRCNT /ANYTHING LEFT IN FILE?
448 JMP I (END /NO, END OF PROG
449 JMS I DEVH /READ NEXT BLOCK
453 JMP INERR /INPUT ERROR
454 ISZ INBLOK /BUMP BLOCK NUMBER
455 TAD (-400 /RESET COUNTER
457 TAD INBLOK-1 /RESET POINTER
459 NOREAD, TAD I INBPTR /GET WORD FROM BUFFER
460 ISZ INBPTR /BUMP BUFFER POINTER
462 INERR, JMS I (FATAL /FATAL INPUT ERROR
464 INBCNT, -1 /FORCE READ FIRST TIME
468 GETSS, 0 /GET POINTER TO DIM INFO
471 DCA DIMPTR /ADDR OF TYPE WORD
473 ISZ DIMPTR /MOVE TO DIM/EQUIV POINTER
474 AND X200 /EQUIV INFO ?
477 TAD I DIMPTR /SKIP EQUIV INFO
479 TAD I DIMPTR /ADDRESS OF DIM INFO
481 NUMBRO, 0 /OUTPUT 15 BIT OCTAL NUMBER
482 TAD AC /IS HIGH DIGIT 0 ?
484 JMP .+3 /YES, PRINT 4 DIGITS ONLY
485 TAD Q260 /MAKE IT ASCII
487 TAD MQ /NOW LOW FOUR DIGITS
490 UCODE, 0 /GEN CODE FOR UNARY OPERATORS
491 JMS I QSAVEAC /SAVE AC IF NEEDED
493 JMP OTERR /OPERATOR/TYPE ERROR
494 TAD ARG1 /IS ARG IN AC ?
496 TAD Q5 /YES, USE SECOND HALF OF TABLE
498 TAD I UCODE /PLUS TABLE ADDRESS
501 TAD I USKEL /ADDR OF SKELETON
503 JMP OTERR /0 MEANS BAD
505 DCA USKEL /SAVE SKELETON ADDR
506 JMS I QGENCOD /GO DO THE CODE
508 DCA I X16 /RESULT IN AC
509 ISZ X16 /BUMP STACK POINTER
510 ISZ X16 /TYPE IS ALREADY THERE
511 ISZ UCODE /FIX RET ADDR
514 CLL CMA RTL /BACK UP ONE ENTRY
517 TAD X16 /USABLE POINTER
519 TAD I X15 /GET OPERAND
525 TAD TYPE1 /CHECK TYPE
528 JMP I GARG /TAKE ERROR EXIT
529 ISZ ARG2 /MAKE SURE ARG2 ISN'T ZERO
530 JMS I (MPTRA1 /MOVE THE POINTER IF
535 TTYOUT, 0 /OUTPUT TO THE TTY
541 JMP I TTYOUT /NO KEYBOARD FLAG
543 AND (177 /ACCEPT PARITY ASCII
546 JMP I Q7605 /YES, BACK TO PS8
549 JMP I TTYOUT /NO, RETURN
550 DCA TTYOUT+1 /KILL OUTPUT STUFF
570 SAVACT, 0 /SAVE TOP OF STACK IF
572 TAD SAVACT /SAVE RETURN ADDR
575 JMP SAVEAC+2 /BACK UP ONLY ONE ENTRY
576 SAVEAC, 0 /STORE AC IF NEEDED
577 TAD (-5 /LOOK AT STACK TWO DOWN
580 TAD I SATEMP /IF 0, RESULT WAS LEFT IN AC
582 JMP I SAVEAC /NO, NO STORE NEEDED
583 TAD TMPCNT /STORE TEMP NUMBER
585 ISZ SATEMP /MOVE TO TYPE WORD
586 TAD I SATEMP /GET TYPE
587 JMS SAVE /GO DO ACTUAL STORE
590 DCA ACSTOR /THIS IS THE TYPE
591 TAD ACSTOR /IS IT COMPLEX OR DOUBLE?
598 JMS I QGENCOD /STARTE; FLDA #CAC
600 NOC, JMS ACSTOR /%FSTA #TMP+XXXX
601 JMS TMPBMP /THIS USE TWO TEMPS
603 NOCORD, JMS ACSTOR /%FSTA #TMP+XXXX
606 ACSTOR, 0 /GENERATES FSTA TEMP+XXXX
607 JMS I QOPCOD /OUTPUT %FSTA %TEMP+XXXX
610 TMPCNT /TMPCNT CONTAINS THE
612 JMS TMPBMP /BUMP TEMPORARY NUMBER
615 TMPBMP, 0 /ROUTINE TO BUMP TEMPORARIES
616 TAD TMPCNT /BIGGER THAN MAX?
620 JMP .+3 /GO BUMP TEMP CNT
621 TAD TMPCNT /NEW TEMP MAX
623 ISZ TMPCNT /INCR TEMP COUNT
625 \f/ PUSH ARG ONTO STACK
626 PUSH, JMS SAVEAC /GO SAVE AC IF NEEDED
627 JMS I QINWORD /GET ADDR OF NEW VAR
636 DCA I X16 /ONTO STACK
637 CKPDL, DCA I X16 /ZERO BASE WORD
638 TAD X16 /IS STACK FULL ?
643 TAD STKLVL /RESET STACK LEVEL
645 JMS I QTTYMSG /PRINT MESSAGE
647 DPUSH, JMS I QINWORD /GET THE VAR NAME PTR
649 JMS I QINWORD /NOW GET THE DISPLACEMENT
650 JMP CKPDL-1 /GO CHECK FOR OVERFLOW
651 STARTF, TEXT 'STARTF'
653 ARTHIF, JMS I QUCODE /GET ARG INTO AC
655 JMS I QGENSF /DO ALL TRANSFERS IN FMODE
656 TAD (JLT /FIRST OPCODE
658 AIFLUP, JMS I QINWORD /GET NEXT INPUT
659 DCA TEMP2 /SAVE IT IN CASE ITS NOT LABEL
662 TAD (XPUSH-XLAST /IS IT A LABEL ?
664 JMP I QNEXTM2 /NO, PROCEED
666 AJUMP, 0 /OUTPUT CORRECT JUMP
669 JMS I QOSNUM /NOW THE LABEL
671 ISZ AJUMP /MOVE TO NEXT OPCODE
677 \f/ PICK UP TOP TWO ARGS
679 GARGS, 0 /GET TOP 2 ARGS FROM STACK
681 TAD QM6 /BACK TWO OPERANDS
684 DCA X16 /AND OFFICIALLY POP THE STACK
685 TAD I X15 /GET FIRST ARG
690 DCA BASE1 /AND FIRST BASE (IN
692 TAD I X15 /NOW SECOND ARG
698 TAD TYPE1 /TYPES MUST BE LT 6
701 JMP I GARGS /RETURN BAD
705 ISZ GARGS /FIX RETURN
706 JMS MPTRA1 /GET ARG1 POINTER IF NEEDED
707 TAD ARG2 /IS ARG2 A POINTER
710 JMP I GARGS /NO, RETURN
711 TAD ARG1 /IS ARG1 IN THE AC ?
714 TAD TMPCNT /YES, STORE THE AC
718 TAD BASE2 /MOVE POINTER FROM TEMP
723 TAD (62 /ARG IS NOW POINTED TO
727 MPTRA1, 0 /MOVE ARG1 POINTER TO BASE
737 TAD TYPE2 /GET THE TYPE
744 DCA ARG1 /SET ARG1 TO IND0
747 CODE, 0 /GENERATE CODE FOR
749 JMS GARGS /GET OPERANDS
750 JMP OTERR /BAD TYPE OPERATOR COMBO
751 TAD TYPE1 /INDEX INTO TYPE CHECK TABLE
756 TAD (TYPMIX-14 /POINTER TO CORRECT ENTRY
759 TAD I SKEL /RESULTING TYPE
761 JMP TYPERR /THIS MIX IS ILLEGAL
762 DCA TYPE1 /SAVE RESULT TYPE
763 ISZ SKEL /GET INDEX INTO
767 TAD I CODE /PLUS BASE GIVES ADDR
771 TAD I SKEL /IS THIS TYPE OPER
775 ISZ CODE /POINTS TO RESULTING TYPE
778 ISZ SKEL /SECOND ARG IS IN MEMORY
780 SNA CLA /SKIP ON M,M CASE
781 ISZ SKEL /MOVE TO AC,M CASE
782 TAD I SKEL /PICK UP POINTER TO SKELETON
784 JMS I QGENCOD /GO DO THE CODE
786 DCA I X16 /RESULT IS IN THE AC
788 SNA /IS TYPE SAME AS ARGS ?
791 DCA I X16 /ZERO BASE WORD
792 TAD I CODE /IS TYPE SAME AS ARGS ?
794 DCA FMODE /NO, WE'RE NOW IN FMODE
796 TYPERR, JMS BUMP /PUT FALSE VALUE ONTO STACK
797 JMS I QTTYMSG /OUTPUT ERROR
799 OTERR, JMS BUMP /PUT FALSE VALUE ONTO STACK
805 \f/ CODE GENERATOR (FROM SKELETONS)
807 GENCOD, 0 /CODE GENERATOR ROUTINE
810 DCA TEMP14 /FIX COMPLEX FUNCTION BUG
811 TAD I GENCOD /GET SKELETON ADDRESS
813 MPOPUP, DCA X14 /HERE ON MACRO END
815 CODLUP, CDF 10 /STUFF IS IN FIELD 1
816 TAD I X14 /GET OPCODE
819 JMP ENDM /IS IT END OF A MACRO ?
821 JMP MACRO /ITS A MACRO REFERENCE
823 JMS I QOPCOD /OUTPUT IT
829 JMP NOADDR /NO OPERAND FOR THIS INSTR
831 JMP DOADDR /ADDRESS IS AN OPERAND
833 JMS I QOTAB /ADDRESS IS A SPECIFIC
837 JMP CODLUP /DO NEXT LINE
838 DOADDR, IAC /IS IT ARG1 ?
840 JMP ITSA2 /NO, ITS ARG2
841 JMS I QOADDR /OUTPUT ARG1 ADDRESS FIELD
844 ITSA2, JMS I QOADDR /OUTPUT ARG2 ADDRESS
847 MACRO, TAD Q5 /CODES BETWEEN -1 AND -5 ARE SPECIAL
849 JMP .+4 /NOT ONE OF THEM
852 HLT /GO TO PROPER ROUTINE
853 DCA MSTART /SAVE START OF MACRO
854 TAD X14 /SAVE RETURN ADDRESS
856 TAD MSTART /GO DO MACRO
859 \fENDM, TAD MRETN /WAS THIS A MACRO ?
861 JMP MPOPUP /YES - GET OUT OF IT
863 DCA X14 /RESTORE X14 FOR FUNCAL
864 JMP I GENCOD /AND EXIT
866 LOADA1, JMS I (LOADA /GENERATE LOAD
869 LOADA2, JMS I (LOADA /GENERATE LOAD
872 DOSTE, JMS I QGENSE /STARTE IF IN F MODE
874 SGNNEG, ISZ RELCD /CHANGE SIGN OF RELATIONAL OPERATOR
877 MRETN, 0 /MACRO RETURN ADDRESS
880 MJTBL, JMP SGNNEG /-5 - NEGATE RELATIONAL SIGN
881 JMP LOADA2 /-4 - LOAD ARG 2
882 JMP LOADA1 /-3 - LOAD ARG 1
883 JMP DOSTE /-2 - START E MODE
884 JMS I QGENSF /-1 - START F MODE
889 \f/ GOTO'S AND ASSIGN
890 CGOTO, JMS GTSTUF /LOOK AT INDEX
891 JMS I QGENCOD /OUTPUT COMPUTED GOTO CODE
893 JMS I QINWORD /GET COUNT
900 GOTO, JMS I QGENSF /ALL TRANSFERS IN F MODE
905 JMS I QOPCDE /OUTPUT JA'S
907 JMS I QINWORD /GET THE LABEL
909 JMS I QOSNUM /OUTPUT IT AS THE ADDRESS
914 JMS I QGARG /GET THE ARG
916 CLL CMA RTL /CHECK THE TYPE
919 JMP GTTYPE /NOT INTEGER OR REAL
920 TAD ARG1 /IS IT IN THE AC ?
922 JMP I GTSTUF /YES ALREADY
926 GTTYPE, JMS I QTTYMSG /GOTO TYPE ERROR
932 \f/ ADDRESS FIELD OUTPUT
933 OADDR, 0 /OUTPUT ADDRESS FIELD
934 TAD I OADDR /GET ADDRESS OF PARAMETERS
937 TAD I ARG /GET VALUE OF ARG
939 TAD (-52 /IS IT A TEMP REFNCE
941 JMP TMPREF /YES, 1-51
942 TAD (52-61 /IS IT AN ARRAY REFERENCE ?
944 JMP SSREF /YES, 52-60 IS XR1-XR7
946 JMP IND0 /INDIRECT THROUGH 0
947 TAD (61-7000 /CHECK FOR DO TEMP
952 JMP IND3 /INDIRECT THROUGH 3
956 TAD I TEMP /IS THIS AN ARG ?
960 JMP INDARG /YES, REF IT INDIRECTLY
963 TAD I TEMP /LOOK AT TYPE WORD
964 AND (50 /IS IT LIT OR STMT NO.?
966 JMP OUTA /NO, JUST OUTPUT ADDRESS
969 JMP OUTSN /OUTPUT STMT NUMBER
970 JMP OUTLIT /OUTPUT LITERAL
971 OUTA, TAD PROGNM /IS THIS THE FUNCTION NAME ?
975 JMP FUNNAM /YES, REFERENCE #VAL INSTEAD
976 OUTA2, CLA CMA /SIMPLE LOCAL VARIABLE REFNCE
977 TAD TEMP /ADDRESS OF VAR
978 JMS I QOUTNAM /INTO ADDR FIELD
980 JMP I OADDR /END OF ADDRESS
981 OUTLIT, ISZ TEMP /MOVE TO LITERAL NUMBER
983 DCA TEMP /DISPLACEMENT FROM %LITRL
985 TAD QLITRL /OUTPUT #LIT+
987 TAD TEMP /DISPLACEMENT
990 FUNNAM, TAD (XVAL /#VAL
993 SSREF, TAD (270 /MAKE IT AN ASCII DIGIT
995 ISZ ARG /POINT TO THE BASE WORD
996 TAD I ARG /GET THE ADDR OF THE BASE
1000 IAC /GO TO TYPE OF BASE VAR
1002 TAD I TEMP2 /IS IT AN ARG TO THE SUBR ?
1005 JMP NOTARG /NO, NO INDIRECT STUFF
1017 IND3, TAD (XBASP3-XBASE /INDIRECT THRU #BASE+3
1018 IND0, TAD (XBASE /INDIRECT THRU #BASE
1023 OUTSN, CLA CMA /OUTPUT STMT NUMBER
1025 JMS I QOSNUM /OUTPUT THE NUMBER
1026 TAD (P2 /+2 (HACK FOR FORMAT)
1028 INDARG, JMS SIT /INDIRECT INDICATOR
1030 JMP OUTA2 /OUTPUT ARG NAME
1032 TAD (245 /% (INDIRECT)
1037 XBAC1P, TEXT '#BASE,1+'
1040 \f/ ADDRESS FIELD OUTPUT
1042 NOTARG, TAD I TEMP2 /GET TYPE WORD
1046 AND Q200 /EQUIVALENCED ?
1049 TAD I TEMP2 /SKIP EQUIV INFO BLOCK
1052 TAD I TEMP2 /ADDRESS OF MAGIC NUMBER
1054 TAD I TEMP2 /MAGIC NUMBER ITSELF
1058 TAD ARG /OUTPUT VARIABLE MINUS CONST
1064 JMS I QCRLF /END OF LINE
1066 DOTMP, DCA TEMP /ADDRESS RELATIVE TO %DOTMP
1068 TAD (DOTMPN /OUTPUT #DOTMP
1070 JMP PLUSN /GO OUTPUT +XXXX
1072 TAD I ARG /BUMP TEMPS BACK CORRECTLY (?)
1076 TAD I ARG /GET NUMBER
1078 IFNZRO TMPBLK-2 <XXXXXX>
1079 CLL STA RAL /V3C -2 (-TMPBLK)
1081 TAD TEMP /V3C (SAVES A LITERAL)
1083 DCA TEMP /YES, SAVE ALTERED DISPLACEMENT
1085 TAD (TEMPN2-TEMPN /USE %TEMPX
1086 TAD (TEMPN /USE %TEMP
1088 PLUSN, TAD PLUS /PLUS CONSTANT
1090 TAD TEMP /DISPLACEMENT TIMES THREE
1093 JMS I QONUMBR /OUT IT
1097 VMC, 0 /OUTPUT VARIABLE MINUS CONST
1099 JMS I QOUTNAM /PUT VAR NAME
1102 TAD TEMP /THIS CONTAINS THE TYPE
1103 JMS SKPIRL /SKIP ON I,R OR L
1104 TAD Q3 /USE SIX WORDS PER ENTRY
1105 TAD Q3 /REAL, INTEGER, OR
1109 JMS MUL12 /DO MULTIPLY
1110 JMS I QNUMBRO /OUTPUT 15 BIT NUMBER
1113 SKPIRL, 0 /SKIP ON TYPE I R OR L
1114 AND Q17 /ISOLATE TYPE CODE
1115 TAD QM4 /IS IT DOUBLE ?
1117 IAC /NO, IS IT COMPLEX ?
1119 ISZ SKPIRL /NEITHER, SKIP
1120 JMP I SKPIRL /RETURN
1121 MUL12, 0 /12 BIT MULTIPLY
1140 BUMP, 0 /PUT FALSE ENTRY ONTO STACK
1141 CDF 0 /V3C IMPORTANT PROTECTION
1144 ISZ X16 /THIS PREVENTS UNDER
1146 JMP I BUMP /AFTER SOME ERRORS
1147 EXTERN, TEXT 'EXTERN'
1153 STARTE, TEXT 'STARTE'
1156 \f/ RANDOM CODE GENERATORS
1158 ERROR, JMS I QINWORD /GET ERROR CODE
1159 JMS I QERMSG /PRINT IT
1161 EOSTMT, TAD DATASW /WAS THIS A DATA STMT ?
1164 DCA DATASW /KILL SWITCH
1166 ORG /ORIGIN BACK TO THE PROGRAM
1170 ISZ GLABEL /BUMP LABEL GENERATOR
1171 OPTMYZ, CLA /CHANGED TO CLA IAC IF /O
1172 JMS I QXRTBL /CLEAR TABLE OR RESET FLAGS
1173 ISZ LINENO /BUMP LINE NUM
1174 TAD LINENO /DISPLAY IN MQ
1176 CLA /FOR NON-EAE FOLKS
1177 TAD STKLVL /RESET STACK LEVEL
1179 JMS IFEND /LOOK FOR END OF LOGICAL IF
1180 JMS I (ASFEND /END OF A.S.F. DEFINITION ?
1181 DEBUG, JMP I QNEXT /OVERLAYED IF NO /N SWITCH
1182 JMS I QOPCDE /OUTPUT LDX NNNN,0
1184 TAD LINENO /THIS IS THE CURRENT ISN
1192 IFEND, 0 /OUTPUT IF END LABEL IF
1193 TAD IFLABL /WAS THIS END OF LOG IF
1195 JMP I IFEND /OUTPUT DEBUG STUFF
1196 JMS I QLABEL /OUPTUT THE LABEL
1197 JMS I QGENSF /ALL LOGICAL IFS MUST
1199 DCA WHATAC /CAN'T DEPEND ON
1201 JMS I QXRTBL /OR XR'S EITHER
1202 DCA IFLABL /KILL THE SWITCH
1204 OPCOD, 0 /TAB OPCODE
1205 DCA WHATAC /AC HAS JUST BEEN
1212 DIV, JMS I QSAVACT /IF SECOND OPERAND IN AC, SAVE IT
1215 CLA CMA /WERE BOTH VARS INTEGER?
1222 LIFBGN, DCA RELCD /ENTER HERE IF LAST OPCODE NOT A RELATIONAL
1223 JMS I QGARG /ENTER HERE FROM RELATIONAL OPTIMIZER
1225 TAD TYPE1 /MUST BE LOGICAL
1229 TAD ARG1 /IS IT IN AC ?
1234 JMS I QINWORD /IS IT IF(...)GOTO XX ?
1239 JMP IFGOTO /YES, TREAT AS SPECIAL CASE
1240 TAD GLABEL /SET IF LABEL
1244 TAD Q5 /GENERATE THE OPPOSITE JUMP
1245 JMS RELJMP /AROUND THE TARGET OF THE IF
1248 ISZ GLABEL /INCREMENT LABEL GENERATOR
1252 JMS RELJMP /GENERATE TRUE RELATIONAL JUMP IF "IF()GOTO"
1253 JMS I QINWORD /GET THE LABEL
1258 NOTLOG, JMS I QTTYMSG
1275 \f/ DO LOOP COMPILER
1277 DOBEGN, JMS I QSAVACT /FOR EXPR IN LOOP PARAMS
1278 TAD X16 /SET NEW STACK LEVEL
1280 JMS I QGARGS /GET LIMIT AND STEP
1281 JMP DPERR /ERROR IN DO PARMS
1282 JMS DOPARM /DO PARAMETER STUF FOR LIMIT
1285 ARG2 /AND THEN FOR STEP
1286 TAD ARG1 /REPLACE ALTERRED STACK
1289 ISZ X16 /REST OF ARG1 OK
1290 TAD GLABEL /SAVE LOOP LABEL
1296 JMS I QCRLF /CRLF BEFORE LABL
1298 JMS I QLABEL /OUPTUT LOOP LABEL
1299 ISZ GLABEL /INCR LABEL GENERATOR
1300 DCA WHATAC /FORGET AC AND
1301 JMS I QXRTBL /XR'S AT DO BEGIN
1303 DOSTOR, JMS I QGARGS /LOOK AT INDEX AND
1304 JMP DPERR /INITIAL VALUE
1305 CLL CMA RTL /MUST BE INTEGER OR
1306 TAD TYPE1 /REAL (L=1 AC=-3)
1308 CLL CMA RTL /L=1 AC=-3
1311 JMP I (STORE+2 /DO STORE IF OK
1312 DPERR, JMS I QTTYMSG /ERROR IN LIMITS
1314 DOFINI, JMS I QXRTBL /DON'T OPTIMIZE XR USAGE
1315 /IN SUCCESSIVE IMPLIED DO LOOPS
1316 TAD IOSTMT /INSIDE IO STMT ?
1318 JMS IFEND /IF NOT, END IF FIRST
1319 JMS I QINWORD /GET THE INDEX
1321 TAD ARG1 /GET THE TYPE WORD ADR
1328 DCA TYPE1 /TYPE OF INDEX VAR
1330 TAD STKLVL /BACK UP THE STACK
1332 TAD X16 /RESET THE STACK LEVEL
1334 TAD I X16 /GET THE FINAL VALUE
1337 TAD I X16 /GET THE LOOP LABEL
1339 TAD I X16 /GET THE STEP
1341 TAD I X16 /WHICH DO FIN CODE ?
1346 TAD (DOFIN1-DOFIN0 /INDEX=I, STEP=R
1347 TAD (DOFIN0-1 /ALL OTHER CASES
1349 JMS I QGENCOD /DO FINISH CODE
1351 JMS I QOPCOD /SUBTRACT UPPER LIMIT
1355 JMS I QOPCDE /NOW THE JLT %%LOOP
1357 TAD DARG /OUTPUT LABEL
1360 TAD STKLVL /FIX X16 INCASE MULTIPLE DO ENDER
1364 DOPARM, 0 /SUBR FOR DO PARAMETERS
1366 ISZ DOPARM /GET THE PARM POINTER
1368 CLL CML RTL /GET ADDR OF TYPE WORD
1371 CLL CMA RTL /CHECK TYPE
1374 JMP DPERR /NOT I OR R
1377 JMP STRTMP /ARG ALREADY IN AC
1378 TAD QM63 /IS IT ARRAY REF?
1380 JMP SVLIMT /YES, SAVE LIMIT
1381 TAD I DARG /REGET SYM ADDR
1382 DCA X10 /ADR OF TYPE WORD
1384 TAD I X10 /MAYBE ITS A LIT?
1388 JMP I DOPARM /YES, ITS LITERAL
1389 /WE'RE ALWAYS IN F MODE HERE
1390 /SINCE THE LAST THING
1392 SVLIMT, JMS I QOPCOD /OTHERWISE LOAD IT
1396 STRTMP, TAD DOTEMP /SET ARG TO NEXT DO TEMP
1398 JMS I QOPCOD /GENERATE STORE
1400 ISZ DOTEMP /BUMP DO TEMP
1403 JMS I QOADDR /DO TEMP ADDRESS FIELD
1407 \f/ SUBSCRIPT REFERENCE COMPILER
1409 ARGS, JMS I QINWORD /COMPILE ARGUMENT LIST
1411 DCA NARGS /NUMBER OF ARGS
1412 TAD NARGS /GET ADDRESS OF SUBSCRIPTED VAR
1414 TAD NARGS /ENTRY ON THE STACK
1417 TAD X15 /SAVE POINTER TO START
1419 DCA X14 /FOR POSSIBLE FUTURE USE
1420 ISZ NARGS /NOW ITS THE 2'S COMPLEMENT
1422 TAD I X15 /FETCH SS VARIABLE
1426 TAD BASE1 /STORE BASE WORD
1428 TAD BASE1 /GET ADDR OF TYPE WORD
1431 CDF 10 /GET TYPE WORD
1432 CLL CML RTR /TEST DIM BIT
1435 JMP TRYCAL /SOME KIND OF CALL
1436 TAD BASE1 /NOW GET ADDRESS OF DIM INFO
1438 DCA ARG1 /RETURNS WITH FIELD SET
1439 TAD I ARG1 /CORRECT NUMBER OF DIMENSIONS?
1444 ISZ ARG1 /SKIP TOTAL SIZE
1445 ISZ ARG1 /SKIP MAGIC NUMBER
1446 ISZ ARG1 /AND ASSOCIATED LITERAL
1447 DCA XRNUM /START WITH XR 1
1449 DCA XRCNT /COUNT FOR SEARCH
1450 DCA FREEXR /ZERO FREE XR INDICATOR
1452 ISZ XRCNT /ANY MORE XR EXPRS TO TEST ?
1453 SKP /YES, GO CHECK THEM
1454 JMP COMPSS /NO, MUST COMPILE
1456 ISZ XRNUM /BUMP XR NUMBER
1460 TAD (XRBUFR-1 /PLUS BASE (-1)
1462 TAD I X13 /LOOK AT THE
1464 JMP .+3 /-1=USED BY THIS STMT
1465 SZA CLA /IF ZERO GO TO
1467 TAD FREEXR /ANY FREE BEFORE THIS ONE ?
1469 JMP NOTMT /YES, ALREADY FOUND ONE
1470 TAD XRNUM /THIS WILL BE
1471 DCA FREEXR /THE XR WE USE
1472 JMP XRCHEK /GO LOOK AT NEXT
1473 NOTMT, TAD X13 /SAVE FLAG ADDRESS
1474 DCA XRFLAG /IN CASE WE NEED IT LATER
1475 TAD I X13 /POINTER TO THE DIM INFO
1478 TAD I TEMP2 /SAME NUMBER OF DIMS ?
1481 JMP XRCHEK /NO, THIS XR WONT DO
1482 TAD NARGS /SET COUNTER
1484 TAD ARG1 /POINTER TO DIM FACTORS
1486 ISZ TEMP2 /SKIP THREE WORDS
1489 DCHEK, ISZ DCNT /ANY MORE ?
1491 JMP SSCHEK /DIMS OK, CHECK SS
1492 ISZ TEMP2 /GET TO NEXT DIM
1493 TAD I TEMP2 /ARE THEY EQUAL ?
1497 JMP XRCHEK /NO, GO TRY NEXT ONE
1499 SSCHEK, TAD NARGS /COUNT AGAIN
1503 TAD X16 /ADDR OF START OF TOP
1506 SSC2, CLL CMA RTL /-3
1507 TAD XTMP /BACK UP TO NEXT LOWER SS
1508 DCA XTMP /LINK IS ALWAYS ZERO HERE
1509 TAD I XTMP /GET NEXT SS (WORKING
1511 TAD (-61 /IS IT A VAR OR LITERAL?
1513 JMP XRCHEK /WE'RE JUST
1514 /LOOKING FOR AN EMPTY
1515 TAD I XTMP /RE GET SS POINTER
1517 TAD I X13 /ARE THEY THE SAME ?
1521 JMP SSC2 /KEEP CHECKING
1522 TAD XRNUM /THEY MATCH, STICK IN
1527 TAD X14 /PURGE SS FROM STACK
1529 CLA CMA /SET FLAG TO
1530 /'USED BY THIS STMT'
1537 \f/ SUBSCRIPT REFERENCE COMPILER
1539 COMPSS, TAD FREEXR /GET XR EXPR AREA
1540 CLL RTL /BY MULTIPLYING
1543 TAD (XRBUFR /AND ADDING THE
1545 DCA XREPTR /THIS IS IT
1546 CLA CMA /SET USED BY THIS
1550 CLL CMA RTL /STORE THE DIB POINTER
1553 TAD NARGS /GET ADDR OF POINTER TO LAST
1554 CMA /DIMENSION FACTOR
1556 DCA ARG1 /SINCE WE USE THEM IN
1558 JMS I QSAVEAC /STORE AC IF NEEDED
1559 /FOLLOWING INSTRUCTION REMOVED FOR OPTOMIZATION
1560 / JMS I QGENSF /ALL SUBSCRIPTS AR I OR R
1561 TAD (FLDA /LOAD FIRST SS
1563 CSSLUP, TAD (FADD /ADD ALL SUBSEQUENT ONES
1565 CLL CMA RTL /BACK UP STACK BY ONE ENTRY
1568 TAD X16 /GET A WORKING POINTER
1570 TAD I X15 /GET THE NEXT SUBSCRIPT
1572 CLL CMA RAL /MUST BE INTEGER
1578 TAD ARG2 /STORE THE SS INTO THE
1580 ISZ XREPTR /INCREMENT FIRST
1582 TAD ARG2 /IS ARG2 THE AC (ONLY
1584 SNA CLA /ITS THE RIGHTMOST
1586 JMP NLODSS /YES, DON'T LOAD IT
1587 JMS I QOPCOD /OUTPUT LOAD OR ADD
1588 OPC, 0 /THIS LOCATION TELLS
1590 JMS I QOADDR /FOLLOWED BY THE OPERAND
1591 ARG2 /POINTED TO BY ARG2
1592 NLODSS, ISZ NARGS /ANY MORE SUBSCRIPTS ?
1593 JMP MORESS /YES, GO COMPILE THEM
1594 TAD FREEXR /ANY FREE INDEX REG?
1596 JMP ASGNXR /YES, GO USE IT
1597 TAD (61 /ITS A SPECIAL POINTER ENTRY
1600 TAD TMPCNT /SAVE TEMP NUMBER
1601 DCA I X14 /BEFORE WE BLOW X14
1602 JMS I (GENPTR /GENERATE POINTER TO THE ARG
1603 JMS I QGENCOD /BACK TO FMODE
1605 JMS I (ACSTOR /GENERATE STORE AC
1607 DIMERR, JMS I QTTYMSG /SS NOT OF CORRECT NUMBER
1610 TRYCAL, TAD ASFSWT /ASF DEFINITION
1612 JMP DEFASF /YES, GO OUTPUT PROLOG
1613 TAD I TEMP /IS IT A FUNCTION OR AN ARG?
1617 JMP DIMERR /NO, SOME KIND OF ERROR
1619 DCA ACSWIT /SAVE THE AC SWITCH
1620 JMP FUNCAL /STANDARD FUNCTION CALL
1621 MORESS, JMS I QGENSF /MUST USE SINGLE PRECISION FOR MULTIPLY
1622 JMS I QOPCOD /MULTIPLY BY DIM FACTOR
1625 TAD I ARG1 /PICK UP FACTOR ADDRESS
1629 TAD ARG1 /MOVE BACK ONE
1631 JMS I QOADDR /OUTPUT MULTIPLY ADDRESS
1633 JMP CSSLUP /LOOP ON NEXT SS
1634 ASGNXR, JMS I QOPCDE /OUTPUT ATX N
1636 TAD FREEXR /GET NUMBER OF FREE XR
1641 TAD (51 /COMPUTE PROPER NUMBER
1642 DCA I X14 /PUT IT INTO TOP OF STACK
1651 STARTD, TEXT 'STARTD'
1652 TEMPN2, TEXT '#TMPX'
1656 \f/ GENERAL CALL GENERATOR
1658 GENCAL, 0 /GENERATE A CALL; ALL ARGS ON STACK
1659 /X15 POINTS TO START OF STACK INFO
1660 /NARGS IS NEG NUMBER OF ARGS
1661 /FUNCTION NAME IS FIRST ON STACK
1662 TAD I GENCAL /GET FUN NAME SWITCH
1664 TAD X15 /NEW STACK VALUE
1666 TAD X15 /WORKING POINTER
1668 TAD NARGS /WORKING COUNTER
1670 JMP OUTJSR /NO ARGS, PUT JSR
1672 CHKPTR, ISZ ARG2 /MOVE TO NUMBER
1674 IAC /ADDR OF TYPE WORD
1676 TAD I BASE2 /GET TYPE
1677 DCA TYPE1 /TYPE OF ARG FOR GENPTR
1678 ISZ BASE2 /POINT TO BASE WORD
1680 DCA BASE1 /FOR GENPTR
1681 TAD I ARG2 /GET ARG NUMBER
1683 TAD (-52 /IS IT INDEXED ?
1685 JMP NOTINX /NO, ITS A TEMP
1686 TAD (52-61 /IS IT INDIRECT ?
1688 JMP INXR /NO, ITS IN AN XR
1690 JMP INTMP /POINTER IN A TEMP
1691 TAD (62 /GET TO TYPE WORD
1694 TAD I GCTEMP /IS IT AN ARG
1696 AND (1020 /ARG OR EXTERNAL ?
1698 JMP NOTINX+1 /NEITHER
1701 JMP ARGARG /ARG SQUARED
1702 JMP EXTARG /EXTERNAL ARG
1704 ISZ ARG2 /BUMP POINTER
1706 ISZ TYPE2 /INCR COUNT
1708 OUTJSR, TAD JSRLBL /DOES IT GET A LABEL ?
1711 JMS I QLABEL /OUPTUT THE LABEL+COMMA
1712 DCA JSRLBL /KILL SWITCH
1713 TAD X16 /ADDR OF POINTER TO FUN NAME
1715 FNSWIT, 0 /REAARANGED**
1716 JMP I (IOFUN /IO FUNCTION CALL
1717 JMS I QOPCDE /OUTPUT THE JSR
1719 TAD I TEMP /NOW THE SUBR NAME
1723 TAD NARGS /ANY ARGS ?
1725 JMP I GENCAL /NO, END OF CALL
1726 JMS I QOPCDE /JUMP AROUND THE ARGS
1737 TAD X16 /WORKING POINTER
1739 PTRLST, TAD I X15 /GET NEXT ARG
1741 JMP SARG /SIMPLE ARG
1743 TAD X15 /ADDR OF GENERATED
1746 TAD I TEMP /OUTPUT #GXXXX (THE
1748 JMS I QLABEL /OUPTUT THE LABEL
1750 JADP2-1 /GENERATE A DUMMY JA
1752 SARG, DCA ARG2 /STORE THE ARG NUMBER
1753 JMS I QOPCOD /OUTPUT JA ARG
1755 JMS I QOADDR /NOW ADDRESS FIELD
1757 BARGLP, ISZ X15 /BUMP POINTER
1759 ISZ NARGS /BUMP COUNT
1762 INTMP, TAD I BASE2 /GET TEMP NUMBER
1763 DCA ARG1 /THAT PTR IS STORED IN
1764 JMS I QGENCOD /PICK UP POINTER
1766 STRPTR, JMS I QOPCDE /NOW STORE THE POINTER
1768 TAD GLABEL /OUTPUT THE LABEL
1771 TAD GLABEL /SAVE THE LABEL NUMBER
1773 DCA I ARG2 /ZERO ARG NUMBER
1774 ISZ GLABEL /INCREMENT LABEL NUMBER
1775 JMS I QGENCOD /BACK TO F MODE
1777 JMP NOTINX /CONTINUE LOOP
1784 \f/ GENERATE SUBROUTINE CALL
1786 FUNCAL, JMS I QSAVEAC /SAVE NEXT TO LAST IF NEEDED
1787 JMS I QSAVACT /SAVE LAST IF NEEDED
1788 JMS I QGENSF /ALL CALLS DONE IN F MODE
1789 DCA I X14 /RESULT RETURNED IN AC
1790 TAD ACSWIT /IS THE SUBR AN ARG ?
1792 JMP MAKCAL /NO, ITS EASIER
1793 JMS I QOPCOD /GET THE JSR TO THE SUBR
1796 BASE1 /BY GETTING THE VALUE
1798 JMS I QGENCOD /STARTD
1800 JMS I QOPCDE /STORE IT AHEAD
1802 TAD GLABEL /INTO THE JSR
1804 DCA JSRLBL /SET THE SWITCH
1808 JMS I QGENCOD /STARTF
1810 MAKCAL, ISZ BASE1 /MOVE TO TYPE WORD
1812 TAD I BASE1 /GET TYPE OF FUNCTION
1814 JMS I QSKPIRL /WHAT MODE WILL WE LEAVE IN?
1815 DCA FMODE /PROBABLY E
1816 JMS I QGENCAL /GO GENERATE THE CALL
1818 0 /THIS IS A FREE LOCATION
1820 ARGARG, JMS I QOPCDE /%FLDA
1829 CLL CML RTR /IS IT AN ARRAY ?
1833 JMP STRPTR /GO STORE THE POINTER
1834 TAD I ARG2 /GET THE LITERAL NUMBER
1841 JMS I QOPCDE /%FADD LITERAL
1848 JMP STRPTR /GO STORE THE POINTER
1849 INXR, TAD (270 /MAKE AN ASCII CHAR
1856 TAD BASE1 /FIND ADDR OF MAGIC
1862 JMS I (GENPTR /GENERATE THE POINTER
1863 JMP STRPTR /GO STORE THE POINTER
1864 EXTARG, TAD I ARG2 /MAKE AN ENTRY IN THE EXT
1865 CDF 10 /LITERAL LIST
1867 TAD DOTEMP /USE DO TEMPS FOR THIS
1870 TAD DOTEMP /SINCE OADDR CAN HANDLE THEM
1872 ISZ DOTEMP /BUMP COUNT
1873 ISZ ELCNT /ALSO EXT LIT COUNT
1874 JMP NOTINX /BACK TO PROCESSING ARGS
1875 \f/ UTILITY ROUTINES
1876 OLABEL, 0 /OUTPUT #GXXXX FOR GEN'D LABELS
1885 OPCODE, 0 /TAD OPCODE TAB
1886 DCA WHATAC /THIS INSTRUCTION ZAPS AC
1894 GENSTE, 0 /GENERATE STARTE IF IN
1896 TAD FMODE /LOOK AT THE SWITCH
1898 JMP I GENSTE /ALREADY IN E MODE
1899 DCA FMODE /CLEAR THE SWITCH
1900 JMS I QOPCOD /GENERATE THE STARTE
1902 JMS I QCRLF /CAN'T USE GENCOD FOR THAT
1905 DOTMPN, TEXT '#DOTMP'
1907 \f/ OPCODES AND OTHER TEXT
1910 XBASP3, TEXT '#BASE+3'
1926 JLT, TEXT 'JLT' /MUST BE IN THIS ORDER!!
1931 JSA, TEXT 'JSA' /MUST BE IN THIS ORDER!
1933 \f/ POINTER GENERATOR
1934 GENPTR, 0 /GENERATE A POINTER
1935 JMS I QOPCOD /MULTIPLY BY 3. OR 6.
1938 JMS I QSKPIRL /SKIP ON I, R, OR L
1941 DCA TEMP /POINTER TO CORRECT LITERAL
1944 JMS I QGENCOD /ALN 0; STARTD
1946 JMS I QOPCDE /FADD THE BASE LITERAL
1948 ISZ BASE1 /GET ADDR OF TYPE WORD
1950 TAD I BASE1 /GET TYPE WORD
1953 JMP NIARG /NOT AN ARG
1956 JMS I QOUTNAM /IF AN ARG, THE LITERAL
1960 TAD QLITRL /OTHERWISE ITS IN THE
1964 TAD I ARG1 /LITERAL NUMBER
1969 \f/ MORE RANDOM CODE GENERATORS
1970 STOP, JMS I QGENCOD /CALL EXIT
1973 FORMAT, JMS I QINWORD /NUMBER OF WORDS OF TEXT
1976 JMS I QOPCDE /JA AROUND THE STUFF
1982 CLL CMA RAL /.+2+NWORDS
1986 FMTLUP, JMS I QOTAB /TA
1987 JMS I QINWORD /GET NEXT WORD
1988 JMS I QONUMBR /OUTPUT IT
1994 DFRTTM, 0 /ROUTINE TO DELETE "SYS:FORTRN.TM"
2005 XPAUSE, TEXT '#PAUSE'
2007 \f/REWIND, ENDFILE, BACKSPACE
2009 REWIND, TAD (XREW-XENDF
2010 ENDFIL, TAD (XENDF-XBAK
2014 AIFTBL-1 /GET UNIT INTO FAC
2015 JMS I QGENSF /FORCE F MODE
2020 \f/ DATA STATEMENT STUFF
2021 DATAST, TAD X16 /SAVE STACK
2023 TAD DATASW /MULTIPLE DATA STMT ?
2025 JMP FIXDAT-2 /YES, DON'T OUTPUT LABEL
2026 ISZ DATASW /SET DATA SWITCH
2027 JMS I QOTAB /DEFINE ORIGIN SYMBOL
2030 TAD (EQUDOT /#GXXXX=.
2033 CLA CMA /SET VAR TO NONE LEFT
2035 FIXDAT, TAD QXRBUFR /USE XR BUFFER FOR DATA BUFFER
2038 DCA RCOUNT /SET REPETITION COUNT TO 1
2040 DREPTC, JMS I QINWORD /GET REPETITION COUNT
2044 DATELM, JMS I QINWORD /GET SIZE OF ELEMENT
2047 JMS I QINWORD /GET ELEMENT
2049 ISZ DATPTR /INTO DATA BUFFER
2053 ENDELM, TAD QXRBUFR /SETUP POINTER
2055 MORELM, ISZ NUMELM /ANY MORE FOR THIS VAR?
2057 TAD DSTACK /CHECK FOR MISMATCH
2062 ISZ DSTACK /GET TO NEXT VAR
2063 JMS I QOPCDE /%ORG VAR
2065 TAD I DSTACK /GET VAR
2068 ISZ DSTACK /MOVE TO THE DISPLACEMENT
2072 DCA NUMELM /ASSUME UNDIMENSIONED
2074 ISZ TEMP2 /MOVE TO TYPE WORD
2075 TAD I TEMP2 /GET TYPE
2076 JMS I QSKPIRL /SKIP ON I R L
2079 DCA ELMSIZ /NUMBER OF WORDS PER ELEMENT
2084 JMP GOTSIZ /NOT DIMENSIONED
2085 CLA IAC /IF DISP = 7777 , WHOLE ARRAY
2086 TAD I DSTACK /LOOK AT DISPLACEMENT
2088 JMP GOTSIZ+1 /ONLY ONE ELEMENT OF THE ARRAY
2090 TAD TEMP2 /GET TOTAL SIZE
2095 CIA /THIS IS THE NUMBER OF ELEMENTS
2098 GOTSIZ, DCA I DSTACK /ZERO DISPLACEMENT
2099 TAD PLUS /OUTPUT +XXXX
2101 TAD ELMSIZ /MULTIPLY DISP BY 3 OR 6
2104 TAD I DSTACK /GET DISP
2106 JMS I QNUMBRO /OUTPUT THE ORG ALTERATION
2108 ISZ DSTACK /MOVE TO NEXT ENTRY
2109 SAMVAR, TAD ELMSIZ /GET SET TO PICK UP AN ELEMENT
2112 JMP .+3 /SKIP ; FIRST TIME
2113 ELMLUP, TAD (273 /SEMICOLON
2115 TAD I TEMP /GET A WORD FROM THE BUFFER
2118 ISZ NARGS /ONE DATA LIST ELEMENT MUST FILL
2119 JMP ELMLUP /ONE VARIABLE LIST ELEMENT
2120 JMS I QCRLF /I.E. ONE ARRAY ELEMENT
2121 TAD DATPTR /IS THIS DATA ELEMENT EXHAUSTED?
2125 JMP MORELM /MORE LEFT
2126 ISZ RCOUNT /REPEAT ?
2128 JMP FIXDAT /NO, BACK FOR MORE DATA
2129 DLERR, JMS I QTTYMSG /DATA LIST ERROR
2137 \f/ END STATEMENT PROCESSING
2139 END, TAD FUNCTN /WHAT WAS IT ?
2141 JMP .+3 /SUBR, RETURN
2142 TAD (STPCOD-1 /MAIN PROG, CALL EXIT
2146 TAD DOTEMP /ANY DO TEMPS ?
2150 JMS OTMPS /OUTPUT THEM
2153 TAD TMPMAX /ANY EXTRA TEMPS ?
2157 IAC /OUTPUT THEM + 1
2161 TAD ELCNT /ANY EXTERNAL LITERALS?
2166 TAD EXTLIT /PICK UP THE POINTER
2169 TAD I X17 /GET SYMBOL NAME
2171 TAD I X17 /AND DO TEMP NUMBER
2173 TAD (-7000 /MINUS BASE
2175 JMS I QOPCDE /ORIGIN
2177 TAD XDOTMP /OUTPUT #DOTMP
2186 JMS I QOPCDE /NOW OUTPUT JSR NAME
2196 JMS I (OUDUMP /DUMP BUFFER
2198 JMS I (7700 /GET USR
2202 JMS I Q200 /CLOSE OUTPUT FILE
2207 TAD FILSIZ /FIX INPUT LIST
2211 ERMSG, 0 /PRINT ERROR MESSAGE ON THE TTY
2212 DCA TEMP /SAVE THE CODE
2213 TAD QM4 /BACK UP THE ERROR
2217 DCA I X10 /ZERO END OF LIST
2218 TAD TEMP /NOW STICK IN THE CODE
2220 TAD X10 /SAVE THE NEW POINTER
2222 TAD LINENO /NOW THE LINE NUMBER
2225 TAD TEMP /PRINT ERROR CODE
2227 JMS I QTTYP2C /NOW SOME SPACES
2228 TAD QTTYOUT /FUDGE THE OUTPUT
2230 DCA QOCHAR /SO THAT ONUMBR GOES TO
2232 TAD LINENO /PRINT THE LINE NUMBER
2234 TAD (OCHAR /FIXUP OUTPUT POINTER
2237 JMS I QGENCOD /TRAP IF ERROR EXECUTED
2241 OTMPS, -7000 /OUTPUT TEMP BLOCK
2245 JMS I QOUTSYM /OUTPUT NAME
2256 TAD TEMP /SIZE TIMES THREE
2262 / PASS2O VERSION 4A PT 16-MAY-77
2263 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
2265 /PATCH LEVEL IS IN LOCATION 26131
2266 IFZERO OVERLY < /ANOTHER SCORE FOR PAL8
2269 IFNZRO OVERLY < /TO TAKE THE LEAD
2272 *OVRLAY> /LATE IN THE FINAL QUARTER
2273 GORALF, TAD FILDEV /GET SIZE AND DEVICE WORD
2274 DCA I (7617 /PUT IT AWAY
2275 ISZ (7617 /BUMP POINTER
2276 TAD FILBLK /GET ORIGIN OF FIE
2277 DCA I (7617 /STORE IT
2279 DCA I (7617 /ZERO END OF LIST
2282 SPA CLA /WAS /A SPECIFIED?
2283 JMP I (7605 /YES - GET OUT
2294 RALFNM, 2201;1406;0000;2326 /RALF.SV
2295 PASS3N, 2001;2323;6300;2326 /PASS3.SV
2297 ADD, JMS I QCODE /GENERATE CODE FOR ADD
2302 EXP, JMS I QSAVACT /SAVE AC IF ITS SECOND ARG
2303 JMS I QGARGS /GET THE TWO ARGS
2304 JMP I (OTERR /TYPE/OPERATOR ERROR
2305 TAD TYPE1 /GET PLACE IN TABLE
2307 TAD TYPE1 /TYPE1 TIMES TEN
2310 TAD (EXPTBL-15 /POINTER TO ENTRY MINUS ONE
2313 TAD I X10 /GET RESULTING TYPE
2315 JMP I (OTERR /BAD IF THIS WORD IS ZERO
2316 DCA ETYPE /SAVE THE TYPE
2317 TAD I X10 /GET THE SUBR NAME
2319 DCA I (ESUBR+2 /PUT IT INTO ITS PLACE
2320 TAD TYPE1 /GET INTO CORRECT MODE
2322 TAD ARG1 /IS ARG 1 ALREADY IN THE AC
2324 JMP .+5 /YES, SKIP THE LOAD
2325 JMS I QOPCOD /OTHERWISE LOAD IT
2329 JMS I QOINS /FSTA #BASE
2331 TAD TYPE2 /SET MODE FOR ARG 2
2333 JMS I QOPCOD /NOW LOAD IT
2337 JMS I QOINS /EXTERN FOR THE SUBR
2339 JMS I QOINS /JSA TO THE SUBR
2341 DCA I X16 /RESULT IS THE AC
2342 TAD ETYPE /WITH THIS AS THE TYPE
2345 TAD ETYPE /SET FMODE CORRECTLY
2348 CLA IAC /RETURNED IN F MODE
2351 SETMOD, /SET MODE TO CORRESPOND
2353 VOVER, VERSON /VERSION NUMBER FOR OVERLAY
2354 JMS I QSKPIRL /SKIP IF WE WANT F MODE
2355 JMP .+3 /SET TO E MODE
2356 JMS I QGENSF /SET TO F MODE
2362 DCA FILDEV /SAVE RALF INPUT SPEC
2364 DCA I X7746 /DON'T SAVE CORE ARROUND CHAIN
2365 JMS I (DFRTTM /DELETE FORTRN.TM
2367 TAD I Q7605 /IS THERE A LISTING FILE?
2369 JMP GORALF /NO, JUST CHAIN TO RALF
2373 JMS I Q200 /FIND PASS 3
2378 TAD PAS3SV-1 /MOVE BLOCK TO CHAIN COMMAND
2379 IAC /SKIP OVER CORE CONTROL BLOCK
2381 JMS I DEVH /READ IN PASS 3
2386 JMP I SPASS3 /GO DO PASS 3
2388 \f/ I/O OPEN AND CLOSE
2390 STRTIO, 0 /ROUTINE FOR STARTING IO STMT
2391 ISZ IOSTMT /SET IOSTMT SWITCH
2392 /(INCASE OF IMPLIED LOOPS)
2393 JMS I QSAVEAC /SAVE AC
2394 JMS I QSAVACT /IF NECESSARY
2395 TAD I STRTIO /GET NUMBER OF ARGS
2397 ISZ STRTIO /MOVE TOHE NME
2398 TAD NARGS /BACKUP STACK BY THIS MUCH
2399 TAD NARGS /THREE OR SIX
2404 DCA TEMP /FUNCTION NAME GOES HERE
2405 JMS I QOPCDE /EXTERN FOR SUBR
2407 TAD I STRTIO /GET SUBROUTINE NAME
2408 JMS I QOUTSYM /OUTPUT IT
2410 TAD I STRTIO /PUT NAME
2411 DCA I TEMP /ONTO STACK
2412 JMS I QGENSF /ALL CALLS IN F MODE
2413 JMS I QGENCAL /GENERATE THE CALL
2415 JMP I QNEXT /NOTHING FOR R CLOSE
2416 FMTRD1, IAC /START FORMATTED READ
2417 DCA INPUT /SET INPUT = 1
2418 DCA BINARY /AND BINARY = 0
2419 JMS STRTIO /GO MAKE THE CALL
2421 FMTWR1, DCA INPUT /SET SWITCHES
2436 WCLOSE, CLA STL RTL /TRAP3 HERE TOO**
2437 JMS OJSR /OUTPUT TRAP3 #WUC
2439 DCA IOSTMT /KILL IO SWITCH
2441 OJSR, 0 /OUTPUT EXTERN THEN JSR OR TRAP3
2442 CLL RAL /AC ON ENTRY IS 0 (JSR), 1 (JSA) OR 2 (TRAP3).
2445 JMS I QOPCDE /FIRST EXTERN
2450 JMS I QOPCDE /THEN JSR
2458 XWUC, TEXT '#RENDO' /**
2459 XREADO, TEXT '#READO'
2460 XWRITO, TEXT '#WRITO'
2463 RDRTNE, TEXT /#RSVO/
2464 RDDRTN, TEXT /#RFDV/
2465 FTRNTM, 0617;2224;2216;2415 /FORTRN.TM
2466 \fDNA, JMS I QCODE /AND CODE
2469 PURGE, JMS I QGARG /LOOK AT THE TOP OF STACK
2470 JMP I (IOTYPE /BAD TYPE
2471 TAD ARG1 /IT MUST BE A SCALAR REFNCE
2475 JMP I (IOTYPE /BAD TYPE
2477 PAUZE, JMS I QUCODE /GET ARG INTO FAC
2479 JMS I QGENCOD /OUTPUT JSR
2483 \f/DIRECT ACCESS I/O
2485 DARD1, CLA IAC /SET SWITCHES
2488 DCA BINARY /SAME AS UNFORMATTED
2489 JMS I (STRTIO /GENERATE CALL
2491 DAWR1, DCA INPUT /SAME AS UNFORMATTED WRITE OPEN
2496 DEFFIL, TAD XDFARG /FAKE A CALL
2497 DCA I (STRTIO /TO SKIP THE ISZ IOSTMT
2504 \f/ RANDOM UNFITTING STUFF
2505 RETURN, JMS I QGENCOD /JA #RTN
2508 GENSTF, 0 /GENERATE STARTF IF IN E MODE
2509 TAD FMODE /LOOK AT THE SWITCH
2511 JMP I GENSTF /ALREADY THERE
2512 ISZ FMODE /SET SWITCH
2513 JMS I QOPCOD /OUTPUT STARTF
2516 JMP I GENSTF /RETURN
2517 NOT, JMS I QUCODE /.NOT.
2520 SUB, JMS I QCODE /SUBTRACT
2523 MUL, JMS I QCODE /MULTIPLY
2526 ASFDEF, CLA IAC /SET SWITCH FOR ASF PROLOG
2529 OINS, 0 /OUTPUT TAB OPCODE TAB
2533 TAD I OINS /GET OPCODE
2537 TAD I OINS /GET ADDRESS
2540 JMS I QCRLF /END LINE
2543 \f/ CODE GENERATOR FOR STORE
2544 STORE, JMS I QGARGS /GET ARGS FOR STORE
2546 TAD ARG1 /KILL ANY XR
2548 JMS I QCHKXR /THE VARIABLE BEING STORED
2549 TAD ARG2 /IS SECOND ARG IN AC ?
2551 TAD Q5 /YES, ADD 5 TO TYPE2
2554 TAD TYPE1 /TYPE1 TIMES TEN
2558 TAD TYPE2 /PLUS TYPE2
2559 TAD (STRTBL-13 /PLUS TABLE BASE
2560 DCA SSKEL /GIVES ENTRY ADDRESS
2562 TAD I SSKEL /POINTER TO SKELETON
2564 JMS I QGENCOD /GENERATE CODE
2566 TAD ASFSWT /IS THIS END OF ASF ?
2568 JMP I QNEXT /YES, DON'T DO A STORE
2569 TAD TYPE1 /MODE IS THE SAME
2570 JMS I QSKPIRL /AS THE VARIABLE STORED IN
2574 JMS I QOPCOD /OUTPUT STORE
2576 JMS I QOADDR /ADDRESS FIELD
2578 TAD ARG1 /REMEMBER THE AC
2580 DCA WHATAC /(REMEMBER THE
2583 DCA WHATBS /BELIEVE THE MAINE ???)
2584 ISZ ARG1 /GO TO TYPE WORD
2587 TAD ARG1 /A SS'D REFNCE
2589 SZL CLA /BOTHER CHECKING
2590 TAD I ARG1 /LOOK AT SOME BITS
2592 AND (3400 /DIM,EXT, OR ASF ?
2595 JMS I QTTYMSG /ATTEMPT TO STORE IN
2596 1720 /EXTERNAL OR ASF
2599 \f/ARITHEMTIC STATEMENT FUNCTIONS (BLAH!)
2601 DEFASF, CDF /A.S.F. PROLOG
2602 TAD FMODE /SAVE CPU MODE
2603 DCA ASFMOD /SINCE WE JUMP ARROUND
2604 TAD X14 /SET STACK POINTER
2605 TAD (3 /SO THAT ASF NAME STAYS
2607 CLA CMA /SET ASF SWITCH
2609 TAD TMPMAX /USE UNIQUE TEMPS
2611 DCA TMPCNT /FOR ALL ASF'S
2612 JMS I QXRTBL /AND FORGET XR'S
2613 JMS I QOPCDE /JA AROUND
2615 TAD GLABEL /SAVE ARROUND LABEL
2617 ISZ GLABEL /BUMP LABEL GENERATOR
2618 TAD ASFSKP /PUT LABEL AS ADDRESS OF JA
2621 TAD GLABEL /FUNCTIONS XR'S O HERE
2622 JMS I QLABEL /OUPTUT THE LABEL
2623 JMS I QOINS /#GXXXX, ORG .+10
2625 TAD BASE1 /NOW OUTPUT FUNCTION NAME
2629 JMS I QOCHAR /OF START OF FUNCTION
2632 TAD GLABEL /TO THE GENERATED LABEL
2636 JMS I QOINS /LDX 0,1
2638 JMS I QGENCOD /STARTD
2639 SD-1 /JUST LIKE A SUBROUTINE
2641 JMS I QOINS /FLDA #BASE
2642 FLDA;XBASE /GET RETURN JUMP
2643 JMS I QOPCDE /STORE IT AHEAD
2645 TAD GLABEL /USING GENERATED LABEL
2648 ASFARG, JMS I QOINS /FLDA% #BASE,1+
2649 FLDAP;XBAC1P /GET ARG POINTER
2650 JMS I QOINS /FSTA #BASE+3
2651 FSTA;XBASP3 /SAVE IT
2652 TAD I X15 /GET PARAMETER
2657 TAD TYPE2 /IS IT SINGLE OR DOUBLE?
2660 JMS I QGENCOD /STARTF
2663 ARGSV, DCA FMODE /SET FMODE APPROPRIATELY
2664 JMS I QOINS /FLDA% #BASE+3
2665 FLDAP;XBASP3 /GET THE VALUE
2670 ISZ NARGS /ANY MORE ARGS ?
2672 JMP I QNEXT /NO, END OF ASF PROLOG
2673 JMS I QGENCOD /STARTD
2675 JMP ASFARG /NEXT ARG
2676 ASFASE, JMS I QGENCOD /STARTE
2679 ASFEND, 0 /HANDLE END OF A.S.F.
2680 TAD ASFSWT /IS THIS END OF ASF ?
2683 DCA ASFSWT /CLEAR SWITCH
2684 JMS I QOINS /RESET XR'S
2686 TAD GLABEL /OUTPUT SPACE FOR RETURN ADDR
2688 JMS I QLABEL /OUPTUT THE LABEL
2689 JMS I QOINS /ORG .+2
2691 TAD ASFSKP /OUTPUT SKIP ARROUND LABEL
2692 JMS I QLABEL /OUPTUT THE LABEL
2694 TAD ASFMOD /RESET MODE SWITCH
2696 TAD TMPMAX /UNIQUE TEMPS
2698 DCA TEM /V3C MUST BE USED
2699 JMS I QXRTBL /AND XR'S LOST
2702 JMP I ASFEND /RETURN
2705 IOFUN, JMS I QOPCDE /CALLED BY TRAP3,NOT JSR**
2708 JMS I QOUTSYM /OUTPUT THE IO FUNCTION NAME
2709 JMP I (IOONLY /DO SOME OTHER STUFF
2710 ESUBR, TEXT '#EXPXX' /THIS WILL BE THE CORRECT NAME
2712 \f/ I/O LIST ELEMENT
2714 IOLMNT, JMS I QGARG /GET THE ARG
2715 JMP IOTYPE /TYPE ERROR
2716 DCA IOLOOP /CLEAR LOOP SWITCH
2719 DCA TYPE1 /TYPE1 = 0 IF COMPLEX, 1 IF D.P.
2720 TAD ARG1 /ADDR OF TYPE WD
2723 TAD ARG1 /LOOK AT ARG
2726 JMP NOLOOP /NOT ARRAY OUTPUT
2728 CLL CML RTR /IS IT DIMENSIONED ?
2732 JMP NOLOOP /NO, NO LOOP
2733 ISZ IOLOOP /SET SWITCH
2736 IAC /TOTAL SIZE WORD
2738 TAD I ARG2 /IS THIS ARRAY AN ARG ?
2740 DCA ARGIO /SET SWITCH
2741 TAD I BASE1 /IS IT VARIABLY DIMENSIONED ?
2743 JMP I (VDAIO /YES, MUST COMPUTE SIZE
2744 DCA BASE2 /SAVE SIZE
2746 JMS I QOPCDE /PUT SIZE IN XR 1
2757 TAD ARGIO /IS IT AN ARG ?
2760 OLLABL, TAD GLABEL /OUTPUT LABEL
2762 DCA I (XRBUFR+20 /KILL XR1 ENTRY
2765 NOLOOP, TAD INPUT /INPUT OR OUTPUT ?
2768 JMS FIXCAL /SET PTR FOR OJSR**
2769 JMS I (DUMSUB /NOW THE STORE
2771 TAD ARG1 /KILL ASSOCIATED
2772 JMS I QCHKXR /XR EXPRESSIONS
2773 CDSFLP, TAD TYPE1 /IS IT C OR D ?
2776 JMP ENDLUP /NO, NO STARTE
2779 ENDLUP, TAD IOLOOP /IS THERE A LOOP ?
2781 JMP I QNEXT /NO, DO NEXT LIST ELEMENT
2782 JMS I QOPCDE /YES, OUTPUT JXN
2785 ISZ GLABEL /OUTPUT LABEL
2786 JMS I QLABEL /OUPTUT THE LABEL
2789 TAD PLUS /OUTPUT PLUS (FOR
2793 JMP I QNEXT /DO NEXT LIST ELEMENT
2794 OUTV, TAD TYPE1 /D OR C ?
2797 JMP .+3 /NO, NO STARTF NECCESSARY
2800 JMS I (DUMSUB /OUTPUT FLDA
2803 JMP CDSFLP /THEN STARTF AND JXN IF ANY
2805 TAD TYPE1 /IF VARIABLE IS COMPLEX,
2806 CIA /OR IF VARIABLE IS DOUBLE AND
2808 TAD BINARY /GENERATE A JSR #RFDV
2809 SNA CLA /ELSE GENERATE A TRAP3 #RSVO
2811 CLA STL RTL /SET PTR
2812 JMS I (OJSR /NOW GO DO IT
2813 RDRTNE /HERE'S THE NAME
2819 IOTYPE, JMS I QTTYMSG /IO TYPE ERROR
2821 DEFLBL, JMS I QCRLF /CRLF BEFORE LABL
2822 JMS I QGENSF /ENTER F MODE BEFORE ALL LABELS
2823 JMS I QINWORD /GET THE LABEL
2825 JMS I QOSNUM /OUTPUT IT
2828 JMS I QXRTBL /KILL XR TABLE
2829 DCA WHATAC /AND AC AT LABEL
2832 \f/ I/O LIST ELEMENT
2834 VDAIO, CLL CMA RAL /GET ADDR OF NUMBER OF DIMS
2837 TAD I X10 /GET DIM COUNT
2841 ISZ X10 /AND MAGIC NUMBER
2842 ISZ X10 /AND LITERAL NUMBER
2843 TAD (FLDA /LOAD FIRST DIM
2845 GSIZLP, TAD (FMUL /MULTIPLY THE REST
2848 TAD I X10 /GET THE NEXT DIMENSION
2851 JMS I QOPCOD /OUTPUT OPCODE
2853 JMS I QOADDR /NOW THE DIMENSION
2856 JMP GSIZLP /KEEP GOING
2857 JMS I QOPCOD /NEGATE THE FAC
2860 JMS I QGENCOD /PUT THE COUNT INTO XR1
2862 ARGIOA, JMS I QGENCOD /PUT -1 INTO XR 2
2864 JMS I QOPCDE /LOAD THE ARG POINTER -
2866 DCA I (XRBUFR+40 /KILL XR 2 ENTRY
2871 JMS I QOPCDE /NOW ADD THE MAGIC NUMBER
2873 TAD QLITRL /OUTPUT #LIT+XXXX
2883 FSTA /NOW STORE IN #BASE+3
2887 JMS I QGENCOD /STARTF
2889 JMP I (OLLABL /NOW THE INSIDE OF THE LOOP
2890 DUMSUB, 0 /OUTPUT FLDA OR FSTA
2892 TAD I DUMSUB /GET THE OPCODE
2895 TAD TYPE1 /MUST WE SE ?
2896 CLL RAR /TYPE1 IS 0 IF C, 1 IF D
2898 TAD Q3 /MULTIPLIER IS 6
2901 JMS I QOPCOD /FLDA OR FSTA
2903 TAD IOLOOP /IS IT A LOOP ?
2906 TAD ARGIO /IS IT AN ARG ?
2908 JMP IBASP3 /YES, INDIRECT THROUGH #BASE+3
2915 TAD BASE2 /NEGATIVE OF SIZE
2917 JMS I QMUL12 /TIMES 6 OR 3
2919 TAD COMMA /COMMA SEVEN
2924 JMP I DUMSUB /RETURN
2925 EZVAR, JMS I QOADDR /ITS A SCALAR
2928 IBASP3, TAD (245 /INDIRECT THROUGH #BASE+3
2931 TAD (XBPC2P /FLDA% #BASE+3,2+
2935 XBPC2P, TEXT '#BASE+3,2+'
2945 \f/ ASSIGNED GOTO AND ASSIGN
2947 AGOTO, JMS GTSTUF /LOOK AT THE ASSIGNED VAR
2948 JMS I QGENCOD /GENERATE A JAC
2951 ASSIGN, JMS I QGARG /GET THE ASSIGN VAR
2953 CLL CMA RTL /MUST BE I OR R
2956 JMP GTTYPE /GOTO TYPE ERROR
2957 JMS I QGENCOD /GENERATE THE ASSIGN CODE
2960 JMS I QGENCOD /NOW STORE IT
2963 \f/ OPTIMIZER SUBROUTINES
2964 CHEKXR, 0 /KILL XR EXPRS
2965 CIA /ASSOCIATED WITH THIS VAR
2966 DCA KILVAR /SINCE IT HAS
2968 TAD (-7 /LOOK AT XR 1 THRU 7
2970 TAD (XRBUFR+20 /POINTER
2972 KILLUP, TAD I TEMP2 /GET NEXT XR
2975 JMP EOKL /NOTHING HERE
2976 TAD TEMP2 /GET POINTER
2978 TAD I X13 /GET ADDR OF DIB
2980 CDF 10 /FIELD OF SYMBOL TABLE
2981 TAD I DIMPTR /GET NUMBER OF
2985 CDF /BACK TO FIELD OF XRBUFR
2986 CHKKIL, ISZ NARGS /CHECK 1 LESS
2990 TAD I X13 /LOOK AT NEXT
2992 TAD KILVAR /IS IT THE VAR
2995 DCA I TEMP2 /YES, KILL THIS EXPRESSION
2997 EOKL, TAD TEMP2 /DO NEXT XR
2999 DCA TEMP2 /BUMP POINTER BY 16
3002 JMP I CHEKXR /RETURN
3004 XRTABL, 0 /CLEAR OR RESET
3006 DCA TYPE /0=CLEAR 1=RESET
3007 TAD (-7 /DO XR1 THRU 7
3009 TAD (XRBUFR+20 /POINTER
3011 XRTLUP, TAD I TEMP2 /GET INDICATOR
3013 JMP .+3 /DON'T CHANGE IF ZERO
3014 TAD TYPE /OTHERWISE SET TO
3015 DCA I TEMP2 /'USED BY
3017 TAD TEMP2 /GET TO NEXT ONE
3019 DCA TEMP2 /BUMPING BY 16
3023 LOADA, 0 /GENERATE AN FLDA
3024 TAD I LOADA /IF NECESSARY
3025 DCA LODARG /GET ARG POINTER
3026 ISZ LOADA /BUMP RETURN
3027 TAD I LODARG /DOES AC MATCH ?
3030 JMP DOLOAD /NO, MUST LOAD
3031 TAD LODARG /GET ADDRESS
3033 DCA ARG /IN CASE SS'D
3034 TAD I ARG /DOES BASE MATCH?
3037 JMP I LOADA /OK, DON'T LOAD
3038 DOLOAD, JMS I QOPCOD /GENERATE FLDA
3040 JMS I QOADDR /ADDRESS
3044 \f/ INTER PASS EQUATES
3057 \f/ START PASS 2 (INTER PASS COMMUNICATION)
3066 START2, JMP I Q7605 /RETURN BUT DON'T SAVE CORE
3067 TAD I X10 /PICK UP NEXT FROM PASS 1
3069 TAD X17 /SAVE POINTER TO
3072 TAD I X10 /PASS ONE STACK LEVEL
3074 TAD I X10 /TEMP FILE START
3079 TAD I X10 /START OF PASS2O.SV
3081 TAD I X10 /START OF OUTPUT FILE
3082 DCA FILBLK /SAVE IT FOR CHAINING TO RALF
3086 DCA OSIZE /ALSO MAX SIZE
3087 TAD I X10 /PICK UP PROG NAME
3090 DCA ARGLST /AND ARG LIST ADDR
3092 /FUNCTION/SUBROUTINE/MAIN SWITCH
3094 TAD I X10 /GET DP HARDWARE SWITCH
3096 TAD I X10 /CHECK FOR CROSSED VERSIONS
3099 JMP VERROR /VERSION ERROR
3101 DCLOOP, TAD X11 /V3C THIS ADD CLEARS THE LINK
3106 JMP PSN /GO DO STMT NUMBERS
3107 TAD I X11 /GET DO LOOP ENDING STMT NUMBER
3111 TAD (0416 /DN DO END MISSING
3112 JMS NPRNT /GO PRINT THE MESSAGE
3116 JMP DCLOOP /V3C BACK UP 2
3117 PSN, TAD (SNLIST /PROCESS STMT NUMBERS
3119 SNCLUP, DCA ENTRY /SAVE NEW ENTRY ADDR
3120 TAD I ENTRY /GET ADDR OF NEXT ENTRY
3122 JMP SNDONE /NO MORE STMT NUMBERS
3124 DCA TEMP /ADDR OF TYPE WORD
3125 TAD I TEMP /WAS STMT NUMBER DEFINED?
3130 TAD (2523 /PRINT US MESSAGE
3132 SNDEFN, TAD (0110 /SET TYPE WORD
3134 TAD I ENTRY /PROCEED
3137 FIXELP, JMS I (TYPRTN
3138 NEGSLV /FIX UP NEGATIVE EQUIVALENCE OFFSETS
3139 CLL CML RTL /CHECK FOR BLOCK DATA
3140 TAD FUNCTN /(FUNCTN=-2)
3143 JMS I (TYPRTN /DO IMPLICIT TYPING
3145 JMS I (TYPRTN /REMOVE SUB ARGS FROM LIST
3147 JMS I (TYPRTN /EXTERNALS
3149 JMP I (PROLG1 /MORE PROLOG
3150 BDSTUF, TAD I (BDSWIT /SET UP SWITCH
3152 TAD (END2 /ALTER END CODE
3156 DCA NODBUG /NO ISN'S
3157 JMP I (HOLDUN /DO SOME STUFF
3158 SUBARG, 0 /REMOVE ARGS FROM ST
3160 AND Q20 /CHECK ARG BIT
3173 VERROR, TAD (2605 /PRINT VE (VERSION ERROR)
3178 \f/ GENERATE ARGUMENT STORAGE
3180 PROLG1, JMS I (INS2 / %JA #ST
3182 JMS I (INS /#XR, %ORG .+10
3184 JMS I QOPCDE / %TEXT #NAMEXX#
3191 JMS I (FILL /FILL WITH BLANKS
3196 JMS I (INS /#RET, %SETX #XR
3198 JMS I (INS2 / %SETB #BASE
3200 JMS I (INS2 / %JA .+3
3203 JMS I (INS /#BASE, %ORG .+6
3205 TAD ARGLST /ANY ARGS ?
3207 JMP NOARGS /NO, SKIP THIS STUFF
3208 DCA X10 /SAVE POINTER TO ARG LIST
3212 DCA NARGS /THIS MANY
3213 DCA TEMP2 /ARRAY ARG COUNTER
3214 ARGLP1, JMS PLSUB1 /OUTPUT DEFS FOR ARRAY
3216 SNA CLA /SINCE THEY MUST BE
3218 JMP NOARAY /REFERENCABLE
3221 JMP ARGLP1 /PROCESS ENTIRE ARG LIST
3223 TAD I ARGLST /GO THRU ARGS AGAIN
3228 TAD TEMP2 /HOW MANY ARRAY ARGS ?
3231 JMP NISA /NO INDIRECT LOCS LEFT
3235 JMP TOOMNY /TOO MANY ARRAY ARGS (>6)
3236 ARGLP2, JMS PLSUB1 /NOW OUTPUT AS MANY INDIRECT
3237 SZA CLA /SCALAR ARGS AS POSSIBLE
3238 JMP NOSCLR /TO REDUCE THE PROLOG
3239 ISZ TEMP2 /ROOM FOR ANY MORE
3241 JMP NISA2 /NO, THE REST MUST MOVE VALUES
3242 NOSCLR, ISZ NARGS /LOOP SOME MORE
3244 JMS I (PLSUB2 /OUTPUT SOME TRACEBACK STUFF
3245 JMP I (MORE /GENERATE SCALAR,
3246 /LITERAL AND TEMP STORAGE
3247 NISA2, JMS I (PLSUB2
3248 JMP NDLP3 /OUTPUT TRACEBACK
3250 NISA, JMS I (PLSUB2 /GET PAST THE TRACEBACK STUFF
3251 ARGLP3, TAD XM3 /GENERATE ORG .+6 FOR D OR C
3253 JMS PLSUB1 /OUTPUT REMAINING
3258 TAD I TEMP /TURN OFF SUBARG BIT
3259 AND (7757 /(THATS THE
3260 /SECOND TIME I FIXED THIS)
3266 JMP I (MORE /GENERATE SCALAR,
3267 /LITERAL AND TEMP STORAGE
3269 NOARGS, JMS I (PLSUB2 /NO ARGS, OUTPUT TRACEBACK STUFF
3270 JMP I (MORE /GENERATE SCALAR,
3271 /LITERAL AND TEMP STORAGE
3274 TAD I PLSUB1 /GET THE SKIP
3278 TAD I X10 /GET THE NEXT ARG
3280 DCA TEMP /TYP WORD ADDR
3281 CLL CML RTR /2000=DIM BIT
3283 PLSKIP, 0 /ARRAYS OR SCALARS ?
3287 TAD TEMP /DEFINE THIS VAR
3292 TAD I TEMP /LOOK AT THE TYPE
3294 JMS I QSKPIRL /SKIP IF NOT C OR D
3295 XNOP, NOP /THIS IS CHANGED LATER (MAYBE)
3296 TAD XDP3 /.+3 OR .+6
3298 JMS I (INS2 /ORG FOR THE VALUE
3301 TOOMNY, TAD P0F1 /TOO MANY ARRAY ARGS
3305 \f/ SCALARS, LITERALS & TEMPS
3308 MORE, JMS I (TYPRTN /OUTPUT SCALARS
3310 TAD (TEMPS /OUTPUT FIRST FIVE TEMPS
3314 TAD COMMA /OUTPUT %LITRL,
3318 O141, 0141;-3 /OUTPUT INTEGER LITERALS
3321 0142;-3 /OUTPUT FP LITERALS
3324 0144;-6 /DOUBLE LITERALS
3327 0143;-6 /COMPLEX LITERALS
3328 JMS I (TYPRTN /OUTPUT DIMENSION FACTORS
3330 JMS I (ADFLIT /OUTPUT ARG DIM FACTOR LITERALS
3331 TAD (HOLIST /OUTPUT HOLLERITH LITERALS
3337 DCA ENTRY /SAVE NEW ENTYR
3340 TAD O141 /SET TYPE INFO
3343 DCA I X10 /SAVE LIT DISP
3344 CLL CMA RTL /SET UP COUNTER
3345 DCA HOLLIT /BY THREES
3346 HOLOOP, CDF 10 /OUTPUT LITERAL AS OCTALS
3350 JMP HOFILL /FILL OUT REST
3353 AND (77 /IS THIS LAST WORD?
3356 TAD ARG /YES, STICK IN
3358 JMP HOFILL+1 /AND OUTPUT IT
3359 TAD ARG /OUTPUT CHAR PAIR
3364 HOFILL, TAD (4040 /FILL WITH BLANKS
3368 JMP HOLLUP /DO NEXT HOLLERITH LITERAL
3370 JMS I (TYPRTN /DO ARRAYS
3372 JMS I (TYPRTN /REMOVE COMMON VARS FROM S.T.
3378 CDF 10 /LOOK AT THE BLANK COMMON LIST
3379 TAD I (ONEI+2 /MAKE TRUE=INTEGER ONE
3384 JMP NOBC /NO BLANK COMMON
3385 DCA TYPE /POINTER TO VARIABLE LIST
3390 BCLOOP, TAD TYPE /PROCESS THIS HUNK OF
3395 JMP NXTBC /EMPTY HUNK
3398 TAD I X10 /OUTPUT HUNK
3403 NXTBC, TAD I TYPE /ADDR OF NEXT HUNK
3405 JMP NOBC /THAT WAS THE LAST HUNK
3407 JMP BCLOOP /DO NEXT HUNK
3409 JMS I (TYPRTN /DO NAMED COMMONS
3411 JMS I (TYPRTN /NOW EQUIVALENCES
3415 JMP I (PROLG2 /COMPLETE PROLOG
3417 \f/ ARGUMENT PICKUP GENERATOR
3419 PROLG2, TAD FUNCTN /SECOND PART OF PROLOG
3421 JMP DORETN /NOT A MAIN PROG
3422 JMS I (INS /#ST, BASE #BASE
3424 JMS I (INS2 / SETB #BASE
3426 JMS I (INS2 / SETX #XR
3428 BDSWIT, JMP I (FINIST /GO GET OVERLAY
3429 DORETN, JMS I (INS /#RTN, BASE #BASE
3431 TAD ARGLST /ANY ARGS ?
3434 DCA X10 /POINTER TO THE LIST
3436 TAD I ARGLST /NUMBER OF ARGS
3439 DCA TEMP2 /ZERO ARG COUNTER
3441 TAD NARGS /WILL WE RESTORE ANY ?
3445 JMS I (INS2 / FLDA #ARGS
3447 JMS I (INS2 / FSTA #BASE
3450 TAD I X10 /GET NEXT ARG
3452 DCA TEMP /ADDR OF TYPE WORD
3453 ISZ TEMP2 /INCR COUNT
3454 TAD I TEMP /IS IT A VALUE TRANSMISSION ?
3458 JMP NOREST /NO, DON'T RESTORE IT
3459 JMS I QOPCDE / %LDX XXXX,1
3466 JMS I QGENCOD /STARTD
3468 JMS I (INS2 /GET POINTER TO ARG
3470 JMS I (INS2 /AND SAVE IN #BASE+3
3472 JMS STFORE /INTO CORRECT MODE
3473 JMS I QOPCDE /FLDA VAR
3480 JMS I (INS2 / FSTA% #BASE+3
3484 JMS I QGENCOD /MAKE SURE WE'RE IN F MODE
3486 JAGOBK, TAD FUNCTN /WHAT WAS THIS ?
3488 JMP NOFVAL /NOT A FUNCTION
3492 TAD (FVAL-1 /PLUS TABLE ADDRESS
3493 DCA GVSKEL /GIVES POINTER TO
3495 TAD I GVSKEL /GET SKELETON ADDRESS
3497 JMS I QGENCOD /PICK UP FUNCTION VALUE
3499 NOFVAL, JMS I (INS2 / JA #GOBAK
3501 JMS I (INS /#ST, %STARTD
3504 TAD (210 / %FLDA' 10
3507 JMS I (INS2 / %FSTA #GOBAK,0
3511 STFORE, 0 /START F OR E
3513 TAD I TEMP /GET TYPE
3515 JMS I QSKPIRL /SKIP ON I R OR L
3521 JMP I STFORE /DON'T FORGET TO
3525 \f/ ENTRY AND EXIT CODE
3531 JMS I (INS2 / %SETX #XR
3533 JMS I (INS2 / %SETB #BASE
3535 TAD ARGLST /ANY ARGS ?
3537 JMP I (ENDPLG /NO, JUST STARTF
3538 DCA ARG /SAVE POINTER TO THEM
3539 JMS I (INS2 / %LDX 0,1
3541 JMS I (INS2 / %FSTA #BASE
3543 JMS I (INS2 / %FSTA #ARGS
3546 TAD I ARGLST /NUMBER OF ARGS
3550 JMS I (INS2 / %FLDA I #BASE,1+
3552 DCA TYPE /CLEAR THE SD SWITCH
3554 ISZ ARG /GET TO NEXT ARG
3555 TAD I ARG /LOOK AT ITS TYPE WORD
3559 AND I TEMP /WAS IT DIMENSIONED ?
3561 JMP I (TSTABT /NO, SEE IF ITS VALUE
3563 TAD TEMP /GET ADDR OF DIM INFO
3571 JMP OUFSTA+1 /IT HAS A VARIABLE DIMENSION
3572 TAD I TEMP2 /GET MAGIC NUMBER LIT DISP
3575 JMS I QOPCDE / %FSUB #LIT+XXXX
3583 OUFSTA, DCA I ARG /IT ISN'T VARIABLY DIMENSIONED
3585 JMS I QOPCDE / %FSTA ARGN
3594 JMP I (ENDPLG /END OF PROLOG
3595 TAD TYPE /DID WE LEAVE D MODE
3598 JMS I QGENCOD /YES, OUTPUT AN %SD
3602 TAD FUNCTN /WAS THIS A FUNCTION ?
3604 JMP .+4 /NO, SKIP THIS
3605 TAD I PROGNM /YES, TURN OFF EXT BIT
3606 AND (6777 /ALLOWING STORING IN FUN NAME
3608 TAD (2200 /CHECK /N /Q
3612 NODBUG, DCA I (DEBUG /IF NOT SET, PUT ISN'S
3614 TAD I (7644 /IS /Q SET ?
3618 ISZ I (OPTMYZ /MAKE A CLA IAC FROM A CLA
3620 TAD I FNAME /MOVE FILE NAME
3622 DCA I NAMEF /INTO PAGE
3627 JMP I (RDOVLY /GO WHERE ?
3628 /CALIFORNIA OF COURSE!!!!
3634 ISZ LITNUM /BUMP LITERAL COUNTER
3642 \f/ ENTRY AND EXIT CODE
3644 TSTABT, TAD I TEMP /VALUE TRANSMISSION ?
3649 JMS I (INS2 / %FSTA #BASE+3
3651 JMS I (STFORE /ENTER CORRECT MODE
3652 JMS I (INS2 / %FLDA% #BASE+3
3654 ISZ TYPE /SET SWITCH
3656 ENDPLG, JMS I QGENCOD /%SF
3658 TAD ARGLST /ANY VARIABLY
3659 /DIMENSIONED ARRAYS ?
3661 JMP I (FINIST /NO ARGS AT ALL
3664 TAD I ARGLST /NUMBER OF ARGS
3668 TAD I X10 /GET NEXT ARG
3670 JMP NDVDIM /NOT A VARIABLY
3673 TAD VDTEMP /GET ADDR OF DIMENSION INFO
3676 TAD I VDTMP2 /NUMBER OF DIMENSIONS
3679 ISZ VDTMP2 /MOVE TO MAGIC NUMBER LITERAL
3682 TAD I VDTMP2 /GET IT
3684 DCA MNL /SAVE MAGIC NUMBER LITERAL
3685 TAD (FLDA /JUST LOAD FIRST DIM
3687 TAD NARGS /GET ADDRESS
3689 TAD VDTMP2 /DIMENSION
3690 DCA VDTMP2 /FOR THE SIZE GETTER
3691 JMP CMPMN3 /SKIP MULTIPLY FIRST TIME
3692 CMPMN1, TAD (FMUL /NEXT TIME USE A MULTIPLY
3694 JMS I QOPCOD /NEXT SUBSCRIPT (ALWAYS (1.0)
3696 JMS I QOADDR /NOW ADDRESS
3698 CMPMN3, ISZ NARGS /ANY MORE SS ?
3700 ISZ VDTEMP /GET TO TYPE
3704 JMS I QSKPIRL /SKIP ON I R L
3712 TAD QLITRL /SAVE IN THE MAGIC
3721 JMS I (INS2 /ENTER D MODE
3724 FADDM /NOW MODIFY THE POINTER
3730 JMS I (INS2 /RETURN TO F MODE
3732 NDVDIM, ISZ NSARGS /ANY MORE ARGS TO CHECK?
3736 CMPMN2, CLA CMA /BACK UP THE POINTER
3740 TAD I VDTMP2 /GET IT
3758 / RANDOM PROLOG STUFF
3760 ARRAYS, 0 /OUTPUT ARRAYS
3762 AND (6220 /IS IT AN ARRAY
3765 AND (4220 /NOT COMMON, EQUIV OR ARG
3768 JMS I (UNHOOK /REMOVE FROM BUCKET
3769 TAD ENTRY /OUTPUT VARIABLE
3772 FILL, 0 /FILL SUB NAME WITH BLANKS
3774 TAD PROGNM /PROGNM+2
3780 TAD (240 /TWO BLANKS FOR EACH WORD
3791 TAD I X10 /NOW NUMBER
3799 \f/ROUTINE TO FIX UP NEGATIVE EQUIVALENCE OFFSETS
3804 SNA CLA /IS VARIABLE A SLAVE?
3808 TAD I X10 /GET POINTER TO EQUIV BLOCK
3811 TAD I X10 /GET POINTER TO MASTER
3813 TAD I X10 /OFFSET FROM MASTER
3815 TAD I X10 /SUBTRACT FROM SLAVE OFFSET
3816 DCA SFUDGE /SAVE IN CASE WE NEED IT
3817 TAD I OLDM /IF MASTER IS IN COMMON FORGET THE NEXT TEST:
3818 SZL SPA CLA /IF MASTER OFFSET < SLAVE OFFSET THEN
3819 JMP I NEGSLV /SLAVE WILL ORIGIN BEFORE MASTER -
3820 TAD I TYPE /THEREFORE THE SLAVE MUST BECOME THE MASTER
3821 AND (7577 /UNSLAVE THE SLAVE
3825 DCA TYPE1 /TYPE1 POINTS TO EQUIV BLOCK
3828 DCA X10 /USE AUTO-XR TO CLEAR OFFSETS
3831 TAD I OLDM /GET OLD MASTER'S TYPE WD
3833 DCA I OLDM /MAKE IT A SLAVE
3835 TAD I TYPE1 /GET POINTER TO SLAVE DIMENSION BLOCK
3836 DCA I TYPE /PUT IT IN SYMTAB AS BEFITTING A NEW MASTER
3837 TAD I OLDM /GET OLD MASTERS DIM PTR
3838 DCA I TYPE1 /PUT IT IN EQUIV BLOCK AS BEFITTING A NEW SLAVE
3839 TAD TYPE1 /NOW ASSOCIATE THE EQUIV BLOCK
3840 DCA I OLDM /WITH THE NEW SLAVE
3841 DCA I X10 /AND MAKE BOTH OFFSETS 0
3842 DCA I X10 /("FIXSLV" WILL ADJUST IT - NOTE THE "MASTER"
3843 CDF 0 /WD OF THE BLOCK STILL POINTS TO THE OLD MASTER)
3844 JMS I (TYPRTN /** RECURSIVE CALL ** - ACTUALLY WE DON'T CARE
3845 FIXSLV /SINCE WE AREN'T RETURNING ANYWAY
3846 JMP I (FIXELP /TRY AGAIN FROM SCRATCH
3847 \f/ROUTINE TO ADJUST ALL SLAVES OF THE OLD MASTER
3848 /TO BE SLAVES OF THE NEW MASTER
3850 FIXSLV, 0 /THROUGHOUT
3853 SNA CLA /IS IT A SLAVE?
3858 DCA TYPE /TYPE NOW POINTS TO THE EQUIV BLOCK
3860 TAD I TYPE /GET PTR TO THIS SLAVES MASTER (+1)
3862 TAD OLDM /COMPARE MASTERS
3864 JMP I FIXSLV /NOT UNDER SAME MASTER - LEAVE
3866 DCA I TYPE /"MEET THE NEW BOSS.....
3867 ISZ TYPE / SAME AS THE OLD BOSS...."
3868 TAD I TYPE / (THE WHO)
3870 TAD SFUDGE /ADD IN THE DIFFERENCE BETWEEN OLD AND NEW
3871 IAC /MASTERS TO THE MASTER OFFSET
3873 JMP I FIXSLV /THE SLAVE IS NOW -- A SLAVE!
3879 \f/ ENTRY AND EXIT CODE
3881 PLSUB2, 0 /DUMB SUBR FOR PROLOG
3883 JMS INS2 / %ORG #BASE+30
3891 JMS INS /#GOBAK,ORG .+2
3892 XGOBAK;DBLZRO;0 /**TO INSURE IT'S 0
3893 TAD DPUSED /WAS DOUBLE PRECISSION USED ?
3895 JMP NDPUSD /NO, NO NEED FOR TEMP
3897 XDPTMP;ORG;DP12 /#DPT, ORG .+12
3900 NDPUSD, TAD FUNCTN /FUNCTION OR SUBR ?
3902 JMP I PLSUB2 /ITS #MAIN, NO #VAL OR #ARGS
3904 JMP .+5 /ITS A SUBROUTINE, NO #VAL
3905 JMS INS /#VAL, %ORG .+6
3907 JMS INS /#ARGS, %ORG .+3
3910 INS2, 0 / %OPCOD ADDR
3911 TAD INS2 /COMMONIZE RETURNS
3914 INS, 0 /TAG, %OPCOD ADDR
3915 TAD I INS /GET TAG FIELD
3917 JMS I QOUTSYM /OUTPUT IT
3921 TAD I INS /GET OPCODE
3936 XGOBAK, TEXT '#GOBAK'
3938 XGOBC0, TEXT '#GOBAK,0'
3939 XBAP30, TEXT '#BASE+30'
3944 XBASC1, TEXT '#BASE,1'
3950 XLBLE, TEXT '#LBL=.'
3952 XLBL, TEXT '#LBL' /STACK-5 CAN'T BE 0
3955 \f/ SYMBOL TABLE PROCESSING ROUTINES
3957 IMPLCT, 0 /DO IMPLICIT TYPING
3959 AND O100 /WAS IT EXPLICITLY TYPED
3962 TAD BUCKET /IS IT INTEGER ?
3967 ISZ I TYPE /TYPE IT REAL
3968 ISZ I TYPE /TYP IT INTEGER
3971 DFLIT, 100 /GENERATE FACTORS FOR CALLS
3972 CLL CML RTR /DIMENSIONED ?
3977 DCA TEMP /SET PROPER WDS/ENTRY FOR VMC
3978 TAD ENTRY /GET ADDR OF MAGIC NUMBER
3982 TAD I ENTRY /SAVE LINK
3984 TAD BUCKET /FIX NAME
3986 TAD I TYPE /GET MAGIC NUMBER
3990 JMS I (ONUM /OUTPUT A ZERO WORD
3993 TAD ENTRY /OUTPUT VAR MINUS CONST
3995 JMS I QCRLF /END LITERAL
3997 TAD LITNUM /SAVE NUMBER IN DIM INFO
3999 ISZ LITNUM /THEN BY 2 MORE
4001 TAD DFTEMP /RESTORE ENTRY
4006 EXTRNL, 6 /DO EXTERNALS
4008 AND O1000 /IS IT EXT ?
4011 JMS I (UNHOOK /REMOVE THIS SYMBOL
4012 TAD PROGNM /IS IT THE PROG NAME ?
4016 JMP .+5 /NO, OUTPUT EXTERN
4017 TAD FUNCTN /IS IT A MAIN PROG ?
4019 JMP TFUDGE-1 /YES, NO SECT
4020 TAD (SECT-EXTERN /NOT MAIN, OUTPUT SECT
4026 TAD ENTRY /NOW VAR NAME
4032 EQUIVS, 1000 /OUTPUT EQUIVALENCES
4034 AND Q200 /IS THIS A SLAVE ?
4037 JMS I (UNHOOK /UNHOOK THE ENTRY
4038 TAD I TYPE /SAVE THE TYPE WORD
4040 ISZ TYPE /POINT TO EQUIVALENCE BLOCK
4044 JMS I QOPCDE /OUTPUT ORG
4047 TAD I X10 /MASTER NAME
4050 JMS I QOUTNAM /OUTPUT IT
4054 TAD I X11 /MASTER SS
4063 TAD ENTRY /NOW OUTPUT SLAVE
4068 JMS I QSKPIRL /SIZE OF THING
4070 TAD Q3 /TIMES 3 OR 6
4074 JMS I QMUL12 /MAKE THE PRODUCT
4075 JMS I QNUMBRO /OUT WITH IT
4080 \f/ SYMBOL TABLE PROCESSING ROUTINES
4083 OUTVAR, 0 /ALLOCATE STORAGE FOR A VARIABLE
4085 RDF /GET FIELD OF VAR
4090 TAD VARADR /OUTPUT NAME,
4094 JMS I QOPCDE /OUTPUT ORG
4096 ISZ VARADR /POINT TO TYPE WROD
4098 TAD I VARADR /GET TYPE
4102 TAD Q3 /INTEGER, REAL, AND
4107 CLL CML RTR /CHECK DIM BIT
4110 JMP PLSDOT /NOT DIMENSIONED
4111 TAD I VARADR /LOOK AT TYPE
4112 ISZ VARADR /MOVE TO EQ DIM POINTER
4113 AND Q200 /EQUIVALENCED ?
4116 TAD I VARADR /YES, SKIP EQUIV INFO
4118 TAD I VARADR /ADDRESS OF DIM INFO
4120 DCA VARADR /ADDRESS OF SIZE
4121 TAD I VARADR /GET TOTAL SIZE
4132 SCALAR, 0 /OUTPUT SCALARS
4133 TAD I TYPE /IS IT A SCALAR ?
4134 AND (7630 /COM, DIM, EXT, ASF,
4135 /EQV, ARG, COMMONNAME
4138 JMS I (UNHOOK /DELETE THIS FROM THE LIST
4139 TAD ENTRY /OUTPUT THIS VARIABLE
4143 DOLIST, 0 /PROCESS A LITERAL LIST
4144 TAD I DOLIST /GET LIST START
4148 DCA TYPE /GET TYPE BITS
4152 DCA LSIZE /GET LITERAL SIZE
4154 DLLOOP, TAD I ENTRY /GET NEXT ENTRY
4159 DCA X10 /ADDRESS OF TYPE WORD
4160 TAD TYPE /PUT IN TYPE
4162 TAD X10 /SAVE THIS ADDR
4164 TAD LSIZE /SIZE OF LITERAL
4176 TAD LITNUM /SAVE LITERAL NUMBER
4178 TAD LSIZE /INCREMENT LITERAL NUMBER
4185 TEMPS, 243;2000;TMPSIZ;2415;2000
4188 COMVAR, 0 /REMOVE COMMON VARS FROM ST
4190 AND (4400 /ALSO ASF NAMES
4196 COMMON, TEXT 'COMMON'
4198 \f/ SYMBOL TABLE PROCESSING ROUTINES
4200 TYPRTN, 0 /PROCESS ENTIRE SYMBOL TABLE
4201 TAD I TYPRTN /GET ROUTINE ADDRESS
4204 TAD O301 /START WITH 'A'
4206 TAD M32 /BUCKET COUNT
4208 TYPLP2, TAD BUCKET /GET START OF NEXT LIST
4210 TYPLUP, DCA OENTRY /SAVE OLD ENTRY ADDRESS
4212 TFUDGE, TAD I OENTRY /GET ADDR OF NEXT ENTRY
4214 JMP EOL /0 MEANS END OF LIST
4217 TAD ENTRY /ADDR OF TYPE WORD
4219 JMS I ROUTNE /CALL ROUTINE
4220 TAD I OENTRY /CONTINUE DOWN THE LIST
4222 EOL, ISZ BUCKET /DO NEXT LETTER
4226 JMP I TYPRTN /END OF PASS
4228 COMNAM, 0 /OUTPUT A COMMON BLOCK
4229 TAD I TYPE /IS THIS A COMMON BLOCK NAME
4237 JMS I (UNHOOK /REMOVE THE COMMON
4240 JMS I QOUTNAM /OUTPUT NAME
4242 ISZ TYPE /GET TO COMMON STUFF POINTER
4244 TAD I TYPE /GET ADDR OF NEXT HUNK
4247 JMP TFUDGE /END OF IT
4249 TAD TYPE /GET A WORKING POINTER
4251 TAD I X10 /GET COUNT
4253 JMP CNLOOP /NONE IN THIS HUNK
4256 TAD I X10 /GET VARIABLE ADDRESS
4257 JMS I (OUTVAR /OUTPUT IT
4260 JMP .-4 /DO NEXT ONE FROM THIS HUNK
4261 JMP CNLOOP /DO NEXT HUNK
4267 ADFLIT, 0 /OUTPUT ARG DF LITS
4268 TAD ARGLST /ANY ARGS
4273 TAD I ARGLST /NUMBER OF ARGS
4277 TAD I X10 /GET ARG ADDR
4279 DCA TEMP /TYPE WORD ADDR
4280 TAD I TEMP /GET TYPE INFO
4283 AND I TEMP /DIMENSIONED ?
4286 ISZ TEMP /ADDR OF DIM INFO
4288 TAD I TEMP /ADDR OF MAGIC NUMBER
4290 TAD I TEMP /MAGIC NUMBER
4291 DCA MQ /PREPARE TO MULTIPLY
4292 ISZ TEMP /ADDR OF LITERAL GOES HERE
4293 TAD LITNUM /STICK IN THE ADDRESS
4297 JMS I (ONUM /OUTPUT A ZERO
4298 TAD TEMP2 /LOOK AT TYPE
4299 JMS I QSKPIRL /SKIP ON I R L
4300 TAD (3 /DOUBLE OR COMPLEX
4303 TAD AC /OUTPUT 2 WORD LITERAL
4310 RDOVLY, JMS I (7607 /READ IN OVERLAY
4315 TAD I (VOVER /CHECK VERSION OF OVERLAY
4318 JMP I (VERROR /ERROR, MIXED VERSIONS
4319 JMP I (EOSTMT /START PASS2 PROPER
4323 0 /THIS IS THE START OF
4324 /THE ERROR MESSAGE LIST
4325 /WHICH WORKS BACKWARDS
4326 \f/OS/8 F4 COMPILER CODE SKELETONS
4334 CGTCOD, ATX;DD1;STARTD;0;FLDA;DP2C1;STARTF;0
4336 ASNCOD, ENTERF;FLDA;DP3C0;JA;DP4;0
4337 ERCODE, EXTERN;XUE;TRAP3;XUE;0
4338 A0FN, EXTERN;XFIX;JSA;XFIX;0
4343 MPTR0, ENTERF;FLDAA1;FSTA;XBASE;0
4344 MPTR3, ENTERF;FLDAA2;FSTA;XBASP3;0
4346 DOFIN0, ENTERF;FLDAA1;FADD;-2
4348 DOFIN1, ENTERF;FLDAA1;FADD;-2;MAC+A0FN;FSTA;-1;0
4349 LDASTD, FLDAA1;STARTD;0;0
4350 /CHALK UP ONE FOR PAL8
4352 LXM1C2, LDX;M1C2;STARTD;0;0
4353 FVAL, FVI-1;FVI-1;FVC-1;FVD-1;FVI-1
4355 FVC, STARTE;0;FLDA;XVAL;MAC+PCAC;0
4356 FVD, STARTE;0;FLDA;XVAL;0
4357 RTNCOD, RTNX+MAC;JA;XRTN;0
4358 PAZCOD, ENTERF;EXTERN;XPAUSE;JSR;XPAUSE;0
4359 STPCOD, RTNX+MAC;EXTERN;XEXIT;JSR;XEXIT;0
4360 GIRL1, ENTERF;FLDAA1;ENTERE;0
4361 GIRL2, ENTERF;FLDAA2;ENTERE;0
4363 GCAC, ENTERE;EXTERN;CAC;FLDA;CAC;0
4364 PCAC, EXTERN;CAC;FSTA;CAC;0
4365 GC1C2, ENTERE;FLDAA1;EXTERN;CAC;FSTA;CAC;FLDAA2;0
4366 GC1, ENTERE;FLDAA1;0
4367 GC2, ENTERE;FLDAA2;0
4368 JSACEQ, EXTERN;CEQ;JSA;CEQ;NEGSGN;0
4369 JSACNG, EXTERN;CNEG;JSA;CNEG;0
4370 JSACAD, EXTERN;CADD;JSA;CADD;0
4371 JSACSB, EXTERN;CSUB;JSA;CSUB;0
4372 JSACML, EXTERN;CMUL;JSA;CMUL;0
4373 JSACDV, EXTERN;CDIV;JSA;CDIV;0
4374 \f/ ADD, SUBTRACT, MULTIPLY, AND DIVIDE SKELETONS
4375 ADDTBL, AS-1;AS+2;AS+4
4388 AX, GC1+MAC;JSACAD+MAC;0
4389 GC1C2+MAC;JSACAD+MAC;0
4390 GC2+MAC;JSACAD+MAC;0
4391 AD, ENTERE;FLDAA1;FADD;-2;0
4393 ASC, GIRL1+MAC;JSACAD+MAC;0
4395 ENTERE;PCAC+MAC;GC2+MAC;JSACAD+MAC;0
4397 ASD, FSTA;XDPTMP;ENTERF;FLDAA1;ENTERE;FADD;XDPTMP;0
4401 ACS, ENTERE;PCAC+MAC;GC1+MAC;JSACAD+MAC;0
4403 GIRL2+MAC;JSACAD+MAC;0
4405 ADS, ENTERE;FADD;-1;0
4407 FSTA;XDPTMP;GIRL2+MAC;FADD;XDPTMP;0
4408 SUBTBL, AS-3;SS-1;SS+1
4418 SX, GC1C2+MAC;JSACSB+MAC;0
4419 GC2+MAC;JSACSB+MAC;0
4420 SDBL, ENTERE;FLDAA1;FSUB;-2;0
4422 ENTERE;PCAC+MAC;GC2+MAC;JSACSB+MAC;0
4425 SCS, GC1+MAC;PCAC+MAC
4426 GIRL2+MAC;JSACSB+MAC;0
4427 SDS, GIRL2+MAC;FNEG;0;FADD;-1;0
4428 SDS5, FSTA;XDPTMP;GIRL2+MAC;FNEG;0;FADD;XDPTMP;0
4429 MULTBL, M1-1;M1+3-1;M1+5-1
4433 M11-1;M11+6-1;M11+7-1
4434 M14-1;M14+5-1;M14+7-1
4435 M18+1-1;M18-1;M18+5-1
4440 M4, GC1+MAC;JSACML+MAC;0
4441 GC1C2+MAC;JSACML+MAC;0
4442 GC2+MAC;JSACML+MAC;0
4443 M7, ENTERE;FLDAA1;FMUL;-2;0
4444 M8, GIRL1+MAC;JSACML+MAC;0
4446 ENTERE;PCAC+MAC;GC2+MAC;JSACML+MAC;0
4447 M11, FSTA;XDPTMP;GIRL1+MAC;FMUL;XDPTMP;0
4450 M14, ENTERE;PCAC+MAC;GC1+MAC;JSACML+MAC;0
4452 GIRL2+MAC;JSACML+MAC;0
4455 FSTA;XDPTMP;GIRL2+MAC;FMUL;XDPTMP;0
4456 DIVTBL, 1;D2-1;D2+2-1
4466 D5, GC1C2+MAC;JSACDV+MAC;0
4467 GC2+MAC;JSACDV+MAC;0
4468 D7, ENTERE;FLDAA1;FDIV;-2;0
4470 D10, ENTERE;PCAC+MAC;GC2+MAC;JSACDV+MAC;0
4472 D13, ENTERE;FDIV;-2;0
4473 D14, GC1+MAC;PCAC+MAC
4474 D15, GIRL2+MAC;JSACDV+MAC;0
4475 D16, GIRL2+MAC;FSTA;XDPTMP;FLDAA1;FDIV;XDPTMP;0
4476 D17, FSTA;XDPP6;GIRL2+MAC;FSTA;XDPTMP;FLDA;XDPP6;FDIV;XDPTMP;0
4477 \f/ RELATIONALS AND LOGICALS SKELETON TABLES
4478 EQTABL, EQ1-1;EQ2-1;EQ3-1
4482 EQ11-1;EQ12-1;EQ13-1
4483 EQ14-1;EQ15-1;EQ16-1
4484 EQ17-1;EQ18-1;EQ19-1
4489 EQ4, GC1+MAC;JSACEQ+MAC;0
4490 EQ5, GC1C2+MAC;JSACEQ+MAC;0
4491 EQ6, GC2+MAC;JSACEQ+MAC;0
4492 EQ7, ENTERE;MAC+EQ2+1;0
4493 EQ8, GIRL1+MAC;JSACEQ+MAC;0
4495 EQ10, ENTERE;PCAC+MAC;GC2+MAC;JSACEQ+MAC;0
4500 EQ14, ENTERE;PCAC+MAC;GC1+MAC;JSACEQ+MAC;0
4501 EQ16, GIRL2+MAC;JSACEQ+MAC;0
4505 \fLETABL, LE1-1;LE2-1;LE3-1
4509 LE11-1;LE12-1;LE13-1
4511 LE17-1;LE18-1;LE19-1
4513 LE1, FSUB;-1;NEGSGN;0
4516 LE4, ENTERE;MAC+LE2+1;0
4547 \f/CONVERSION-FOR-STORE-OPERATOR SKELETONS
4548 STRTBL, SIIM-1;SIRM-1;SICM-1;SIDM-1;SIIM-1
4549 SIIA-1;SIRA-1;SICA-1;SIDA-1;SIIA-1
4550 SIIM-1;SIIM-1;SRCM-1;SRDM-1;SIIM-1
4551 SIIA-1;SIIA-1;SRCA-1;SRDA-1;SIIA-1
4552 SCIM-1;SCIM-1;SCCM-1;SCDM-1;SCIM-1
4553 SCIA-1;SCIA-1;SCCA-1;SCDA-1;SCIA-1
4554 SDIM-1;SDIM-1;SDCM-1;SDDM-1;SDIM-1
4555 SDIA-1;SDIA-1;SDCA-1;SDDA-1;SDIA-1
4556 SLIM-1;SLIM-1;SLCM-1;SLDM-1;SIIM-1
4557 SLIA-1;SLIA-1;SLCA-1;SLDA-1;SIIA-1
4562 SICM, GC2+MAC;PCAC+MAC
4563 SICA, ENTERF;GCAC+1+MAC;A0FN+MAC;0
4564 SRCM, GC2+MAC;PCAC+MAC
4565 SRCA, ENTERF;GCAC+1+MAC;0
4572 SLCM, GC2+MAC;ENTERF;SLIA+MAC;0
4573 SLCA, ENTERF;GCAC+1+MAC;SLIA+MAC;0
4575 SIDA, ENTERF;SIRA+MAC;0
4579 SCDA, FSTA;TEMPN;ENTERF;FLDA;TEMPN;ENTERE;0
4582 SDCM, ENTERE;FLDAA2;PCAC+MAC
4583 SDCA, ENTERF;GCAC+1+MAC;ENTERE;0
4588 \f/ UNARY MINUS AND .NOT. SKELETONS
4589 NEGTBL, NIM-1;NIM-1;NCM-1;NDM-1;0
4590 NIA-1;NIA-1;NCA-1;NIA-1;0
4593 NCM, GC1+MAC;PCAC+MAC;JSACNG+MAC;0
4595 NDM, ENTERE;NIM+1+MAC;0
4596 NOTTBL, 0;0;0;0;NOTM-1
4600 \f/ ARITHMETIC IF SKELETONS
4601 AIFTBL, GI-1;GI-1;GC-1;GD-1;GI-1 /V3C
4602 GI+1;GI+1;GC+1;GD+1;GI+1 /V3C
4606 \f/OPERATOR DISPATCH TABLE
4665 \f/ EXPONENTIATION TABLE (NOT A STANDARD SKELETON TABLE)
4666 EXPTBL, 1;1111;2;1122;3;1103;4;1104;0;0 /I**D=D
4667 2;1111;2;1122;3;1103;4;1104;0;0 /R**D=D
4668 3;0311;3;0322;3;0303;0;0;0;0
4669 4;0411;4;0422;0;0;4;0404;0;0
4671 \f/ TYPE MIXING TABLE
4672 TYPMIX, 1;6;2;6;3;17;4;22;0;0
4673 2;6;2;6;3;17;4;22;0;0
4674 3;25;3;25;3;11;0;0;0;0
4675 4;30;4;30;0;0;4;14;0;0
4676 0;0;0;0;0;0;0;0;5;33
4677 RTNX, ENTERF;EXTERN;LTRNE;0