projects / pdp8.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
A large commit.
[pdp8.git] / sw / os8 / v3d / sources / fortran / all / pass2.pa
1 /3 OS/8 FORTRAN (PASS TWO)
2 /
3 / VERSION 4A PT 16-MAY-77
4 /
5 / OS/8 FORTRAN COMPILER - PASS 2
6 /
7 / BY: HANK MAURER
8 / UPDATED BY: R. LARY + M. HURLEY
9 /
10 /
11 /COPYRIGHT (C) 1974,1975 BY DIGITAL EQUIPMENT CORPORATION
12 /
13 /
14 /
15 /
16 /
17 /
18 /
19 /
20 /
21 /
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.
26 /
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.
31 /
32 /DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
33 /OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
34 /DIGITAL.
35 /
36 /
37 /
38 VERSON=4
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
42 /ALSO,
43 / FIXED BUG RE DN ERROR PRINTING WRONG LINE NUMBER
44 /
45 /
46 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
47 /.PATCH LEVEL FOR PASS2 IS IN LOCATION 327
48
49 IFNDEF OVERLY <OVERLY=0>
50 IFNZRO OVERLY <NOPUNCH>
51 *2 /V3C
52 TEM, 1 /V3C
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
57 FILBLK, 0 /FOR RALF
58 X10, COMREG-1 /INTER PASS COM REGION
59 X11, 0
60 X12, 0
61 X13, 0
62 X14, 0
63 X15, 0
64 X16, 0
65 X17, 0 /AUTO INDEX REGISTERS
66 ENTRY, 0 /THINGS USED BY SYMBOL
67 /TABLE FIDDLER
68 OENTRY, 0
69 BUCKET, 0
70 TYPE, 0
71 TEMP, 0 /GENERAL TEMPS
72 TEMP2, 0
73 ARG1, 0 /ARGS AND TYPES
74 BASE1, 0
75 TYPE1, 0
76 ARG2, 0
77 BASE2, 0
78 TYPE2, 0
79 TMPCNT, 1 /TEMP COUNT
80 TMPMAX, 0 /MAX TEMP COUNT
81 LITNUM, 0 /LITERAL DISPLACEMENT
82 TMPBLK=2
83 OUBUF=4400
84 COMREG=4600
85 STACK1=4700
86 OVRLAY=5000
87 NPOVLY=700
88 XRBUFR=6600
89 STACK=7000 /STACK-5 CAN'T BE 0
90 INBUF=7200
91 NPPAS3=1600
92 ARG, 0 /TEMP FOR CODE
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
100 /INDEX REG
101 DIMPTR, 0 /POINTER TO DIM INFO
102 /AFTER GETSS
103 NARGS, 0 /ARG COUNT FOR SS VAR
104 /COMPILE
105 GLABEL, 1 /GENERATED LABEL COUNTER
106 STKLVL, STACK /STACK LEVEL (CHANGED
107 /BY DO)
108 COMMA, 254 /,
109 PLUS, 253 /+
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
120 ELCNT, 0 /AND COUNT
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
127 /(FOR IMPLIED LOOPS)
128 FMODE, 1 /1 IF IN F OR D MODE (0 IF E)
129 ASFSWT, 0 /1 IF ASF PROLOG, -1 IF
130 /ASF END, 0 OTHER
131 JSRLBL, 0 /LABEL NUMBER FOR CALLS TO ARGS
132 DPUSED, 0 /=1 IF DP HARDWARE USED
133 QM4, -4
134 Q260, 260
135 QTTYOU, TTYOUT
136 QERMSG, ERMSG
137 QNEXT, NEXT
138 QNEXTM, NEXT-2
139 QUCODE, UCODE
140 QCODE, CODE
141 QINWOR, INWORD
142 QONUMB, ONUMBR
143 QSAVEA, SAVEAC
144 Q6M3,
145 Q5, 5
146 QGENCO, GENCOD
147 QM6, -6
148 QOPCOD, OPCOD
149 QOPCDE, OPCODE
150 QOADDR, OADDR
151 Q17, 17
152 QTTYMS, TTYMSG
153 QXRTBL, XRTABL
154 QCHKXR, CHEKXR
155 QGENSF, GENSTF
156 QGENSE, GENSTE
157 QOSNUM, OSNUM
158 QCRLF, CRLF
159 QOTAB, OTAB
160 QOUTSY, OUTSYM
161 QGARG, GARG
162 Q20, 20
163 Q40, 40
164 QOUTNA, OUTNAM
165 QLITRL, LITRL
166 Q200, 200
167 Q255, 255
168 Q3, 3
169 QOLABE, OLABEL
170 QGETSS, GETSS
171 Q256, 256
172 QSAVAC, SAVACT
173 QSKPIR, SKPIRL
174 QGENCA, GENCAL
175 QLOADA, LOADA
176 QMUL12, MUL12
177 QGARGS, GARGS
178 QOINS, OINS
179 QOCHAR, OCHAR
180 QNUMBR, NUMBRO
181 QXRBUF, XRBUFR
182 QTTYP2, TTYP2C
183 QTTCRL, TTCRLF
184 QM63, -63
185 Q7605, 7605
186 RELCD, 0
187 QLABEL, NLABEL
188 P0F1, 5274 /101-2605
189 P0F2, VERROR
190 \f/ OUTPUT UTILTIY ROUTINES
191 PAGE
192 OCNT,
193 CRLF, 0 /OUTPUT CR LF
194 TAD (215
195 JMS I QOCHAR
196 TAD (212
197 JMS I QOCHAR
198 TAD (200
199 KRS
200 TAD (-203
201 SNA CLA
202 KSF /CHECK FOR ^C
203 JMP I CRLF
204 JMP I (7605
205 NCHAR,
206 OSNUM, 0 /PRINT STMT NUMBER
207 IAC /SKIP POINTER WORD
208 DCA NAMPTR
209 TAD (6211 /ALWAYS IN FIELD 1
210 DCA NAMCDF
211 TAD OSNUM /SAVE ENTRY POINT
212 DCA OUTNAM
213 TAD (243 /GET FIRST CHAR (ALWAYS #)
214 JMP L6201 /GO PRINT NAME
215 TTCHAR,
216 OUTSYM, 0 /PRINT OPCODE
217 DCA NAMPTR /SAVE POINTER TO STUFF
218 TAD L6201 /ALWAYS FIELD 0
219 DCA NAMCDF
220 TAD OUTSYM /SAVE ENTRY
221 DCA OUTNAM
222 JMP NAMCDF /PRINT REST
223 ONUMT,
224 OUTNAM, 0 /OUTPUT NAME
225 DCA NAMPTR /SAVE ADDRESS OF NAME
226 RDF /GET FIELD OF NAME
227 TAD L6201
228 DCA NAMCDF /SAVE AS CDF
229 TAD I NAMPTR /GET FIRST CHAR (ALREADY ASCII)
230 ISZ NAMPTR /SKIP OVER TYPE AND DIM PTR
231 ISZ NAMPTR
232 L6201, CDF
233 JMS I QOCHAR /OUTPUT CHAR
234 ISZ NAMPTR
235 NAMCDF, 0
236 TAD I NAMPTR /GET NEXT TWO CHARS
237 CDF
238 SNA /IS NAME DONE ?
239 JMP I OUTNAM /YES
240 DCA NCHAR /SAVE TWO CHARS
241 TAD NCHAR
242 RTR /GET UPPER CHAR
243 RTR
244 RTR
245 TAD (240
246 AND (77
247 TAD (240
248 JMS I QOCHAR /OUTPUT IT
249 TAD NCHAR /NOW DO LOWER
250 AND (77
251 SNA
252 JMP I OUTNAM /NAME DONE
253 TAD (240
254 AND (77
255 TAD (240
256 JMP L6201+1 /GO AND OUTPUT IT
257 ONUMBR, 0 /OUTPUT OCTAL NUMBER
258 DCA ONUMT /SAVE TEMPORARILY
259 TAD QM4 /4 DIGITS
260 DCA OCNT
261 OLOOP, TAD ONUMT
262 CLL RTL
263 RAL
264 DCA ONUMT
265 TAD ONUMT
266 RAL
267 AND (7
268 TAD Q260
269 JMS I QOCHAR
270 ISZ OCNT
271 JMP OLOOP
272 JMP I ONUMBR
273 TTYP2C, 0 /PRINT 2 CHARS ON THE TTY
274 DCA TTCHAR
275 TAD TTCHAR
276 RTR
277 RTR
278 RTR
279 JMS CONVRT
280 TAD TTCHAR
281 JMS CONVRT
282 JMP I TTYP2C
283 NAMPTR,
284 CONVRT, 6401 /CONVERT TO ASCII
285 AND (77
286 SZA
287 TAD (240
288 AND (77
289 TAD (240
290 JMS I QTTYOUT
291 JMP I CONVRT
292 TTCRLF, 0
293 TAD (215
294 JMS I QTTYOUT
295 TAD (212
296 JMS I QTTYOUT
297 JMP I TTCRLF
298 TTYMSG, 0 /PRINT 2 CHAR ERROR MESSAGE
299 CDF
300 TAD I TTYMSG
301 ISZ TTYMSG /PRINT ERROR MESSAGE
302 JMS I QERMSG
303 FATAL, JMP I QNEXT /FATAL ERROR MESSAGE
304 TAD I FATAL
305 JMS I QERMSG
306 JMP I Q7605 /RETURN TO PS8
307 DP2C1, TEXT '.+2,1'
308 NEG, JMS I QUCODE /NEGATE CODE
309 NEGTBL-1
310 JMP I QNEXT
311 PAGE
312 \f/ OPCODE JUMP TABLE
313
314 TAD TEMP2
315 SKP /CODE ALREADY READ
316 NEXT, JMS I QINWORD /GET NEXT INPUT WORD
317 TAD (XPUSH /INDEX INTO JUMP TABLE
318 DCA TEMP2
319 CDF 10
320 TAD I TEMP2
321 CDF 0
322 DCA TEMP2 /GET JUMP ADDRESS
323 JMP I TEMP2 /GO THERE
324 \f/OPTIMIZING RELATIONAL CODE FOR OS/8 F4
325 /COMPLIMENTS OF R.L.
326
327 LE, STL RTL /2
328 LT, TAD QM4 /GENERATE -4 FOR LT, -2 FOR LE
329 JMP GE+1 /GO TO COMMON RELATIONAL CODE
330 GT, STL RTL
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)
339
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.
347 RELGM1, TAD Q5
348 RELGEN, DCA RELCD /STORE "FINAL" RELCD
349 JMS I QINWORD /GENTLY PROBE AHEAD IN THE INPUT
350 DCA TEMP2
351 TAD TEMP2
352 TAD (XPUSH-XLOGIF
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
357 TAD (LTRNE
358 DCA .+3
359 CLA IAC
360 JMS I (OJSR /GENERATE A JSA #XX
361 0
362 JMP I QNEXTM2 /PROCESS THE WHATCHIMACALLIT
363
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
369 JMP I .+1
370 LIFBGN+1 /GO TO LOGICAL IF PROCESSOR
371
372 EQV, JMS I QCODE /.EQV. LOGICAL OPERATOR
373 EQVTBL-6;0
374 JMP RELGM1
375 \f/ PASS TWO OUTPUT ROUTINE
376 OCHAR, 0 /OUTPUT A CHAR TO THE
377 /RALF INPUT FILE
378 AND (377
379 DCA OUTEMP /SAVE CHAR
380 ISZ OUJUMP /BUMP THREE WAY SWITCH
381 OUJUMP, JMP .
382 JMP CHAR1
383 JMP CHAR2
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
389 DCA I OUPOLD
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
393 /WORD OF THE PAIR
394 RAR
395 AND (7400
396 TAD I OUPTR
397 DCA I OUPTR
398 TAD OUJMP /RESET 3 WAY BRANCH
399 DCA OUJUMP
400 ISZ OUPTR /BUMP BUFFER POINTER
401 ISZ OUWDCT /AND DOUBLE WORD COUNTER
402 JMP I OCHAR /BUFFER NOT FULL
403 JMS OUDUMP /DUMP IT
404 JMP I OCHAR
405 CHAR2, TAD OUPTR /SAVE FIRST WORD POINTER
406 DCA OUPOLD
407 ISZ OUPTR /GO TO SECOND WORD
408 CHAR1, TAD OUTEMP /STORE CHAR 1 OR 2
409 DCA I OUPTR
410 JMP I OCHAR
411 OUTEMP,
412 OUDUMP, 0 /BUMP THE DUFFER
413 TAD OSIZE /ANY ROOM LEFT ?
414 SNA
415 JMP OUERR
416 IAC
417 DCA OSIZE /YES, ITS OK
418 JMS I DEVH /WRITE
419 4200 /CONTROL WORD
420 OUBUF /BUFFER POINTER
421 OBLOCK, 0 /BLOCK NUMBER
422 JMP OUERR /ERROR
423 ISZ OBLOCK /INCREMENT BLOCK NUMBER
424 ISZ FILSIZ /AND FILE SIZE
425 TAD OBLOCK-1 /SET BUFFER POINTER
426 DCA OUPTR
427 TAD (-200 /SET DOUBLE WORD COUNT
428 DCA OUWDCT
429 JMP I OUDUMP
430 OUERR, JMS I (FATAL /FATAL OUTPUT ERROR
431 1706
432 / * THE PONY EXPRESS STARTED IN 1860 AND ONLY RAN
433 / FOR 19 MONTHS WHILE LOSING $200,000.
434 OUPOLD, 0
435 OUPTR, OUBUF
436 OUJMP, JMP OUJUMP
437 OUWDCT, -200
438 OSIZE, 0
439 DD1, TEXT '1'
440 PAGE
441 \f/ READ FROM FORTRN.TM
442
443 INWORD, 0 /READ A WORD FROM INPUT FILE
444 ISZ INBCNT /ANYTHING LEFT IN BUFFER ?
445 JMP NOREAD /YES
446 ISZ INRCNT /ANYTHING LEFT IN FILE?
447 SKP
448 JMP I (END /NO, END OF PROG
449 JMS I DEVH /READ NEXT BLOCK
450 X200, 0200
451 INBUF
452 INBLOK, 0
453 JMP INERR /INPUT ERROR
454 ISZ INBLOK /BUMP BLOCK NUMBER
455 TAD (-400 /RESET COUNTER
456 DCA INBCNT
457 TAD INBLOK-1 /RESET POINTER
458 DCA INBPTR
459 NOREAD, TAD I INBPTR /GET WORD FROM BUFFER
460 ISZ INBPTR /BUMP BUFFER POINTER
461 JMP I INWORD
462 INERR, JMS I (FATAL /FATAL INPUT ERROR
463 1105
464 INBCNT, -1 /FORCE READ FIRST TIME
465 INBPTR, 0
466 INRCNT, 0
467 \f/ CODE UTILITIES
468 GETSS, 0 /GET POINTER TO DIM INFO
469 CDF 10
470 IAC
471 DCA DIMPTR /ADDR OF TYPE WORD
472 TAD I DIMPTR
473 ISZ DIMPTR /MOVE TO DIM/EQUIV POINTER
474 AND X200 /EQUIV INFO ?
475 SNA CLA
476 JMP .+3 /NONE
477 TAD I DIMPTR /SKIP EQUIV INFO
478 DCA DIMPTR
479 TAD I DIMPTR /ADDRESS OF DIM INFO
480 JMP I GETSS
481 NUMBRO, 0 /OUTPUT 15 BIT OCTAL NUMBER
482 TAD AC /IS HIGH DIGIT 0 ?
483 SNA
484 JMP .+3 /YES, PRINT 4 DIGITS ONLY
485 TAD Q260 /MAKE IT ASCII
486 JMS I QOCHAR /PUT IT
487 TAD MQ /NOW LOW FOUR DIGITS
488 JMS I QONUMBR
489 JMP I NUMBRO
490 UCODE, 0 /GEN CODE FOR UNARY OPERATORS
491 JMS I QSAVEAC /SAVE AC IF NEEDED
492 JMS GARG
493 JMP OTERR /OPERATOR/TYPE ERROR
494 TAD ARG1 /IS ARG IN AC ?
495 SNA CLA
496 TAD Q5 /YES, USE SECOND HALF OF TABLE
497 TAD TYPE1
498 TAD I UCODE /PLUS TABLE ADDRESS
499 DCA USKEL
500 CDF 10
501 TAD I USKEL /ADDR OF SKELETON
502 SNA
503 JMP OTERR /0 MEANS BAD
504 /OPERATOR/TYPE COMBO
505 DCA USKEL /SAVE SKELETON ADDR
506 JMS I QGENCOD /GO DO THE CODE
507 USKEL, 0
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
512 JMP I UCODE
513 GARG, 0 /GET ONE ARG
514 CLL CMA RTL /BACK UP ONE ENTRY
515 TAD X16
516 DCA X16
517 TAD X16 /USABLE POINTER
518 DCA X15
519 TAD I X15 /GET OPERAND
520 DCA ARG1
521 TAD I X15
522 DCA TYPE1
523 TAD I X15
524 DCA BASE1
525 TAD TYPE1 /CHECK TYPE
526 TAD QM6
527 SMA CLA
528 JMP I GARG /TAKE ERROR EXIT
529 ISZ ARG2 /MAKE SURE ARG2 ISN'T ZERO
530 JMS I (MPTRA1 /MOVE THE POINTER IF
531 /THERE IS ONE
532 ISZ GARG
533 JMP I GARG
534
535 TTYOUT, 0 /OUTPUT TO THE TTY
536 TLS
537 TSF
538 JMP .-1
539 CLA
540 KSF
541 JMP I TTYOUT /NO KEYBOARD FLAG
542 KRB
543 AND (177 /ACCEPT PARITY ASCII
544 TAD (-3 /^C ?
545 SNA
546 JMP I Q7605 /YES, BACK TO PS8
547 TAD (3-17 /^O ?
548 SZA CLA
549 JMP I TTYOUT /NO, RETURN
550 DCA TTYOUT+1 /KILL OUTPUT STUFF
551 DCA TTYOUT+2
552 DCA TTYOUT+3
553 JMP I TTYOUT /RETURN
554 \fLTRNE, TEXT '#NE'
555 TEXT '#GE'
556 TEXT '#LE'
557 TEXT '#GT'
558 TEXT '#LT'
559 TEXT '#EQ'
560 PAGE
561 \f/ SOME TEXT
562
563 P2, TEXT '+2'
564 XVAL, TEXT '#VAL'
565 DP4, TEXT '.+4'
566 FADD, TEXT 'FADD'
567 FLDA, TEXT 'FLDA'
568 FSUB, TEXT 'FSUB'
569 \f/ SAVE AC ROUTINES
570 SAVACT, 0 /SAVE TOP OF STACK IF
571 /NECESSARY
572 TAD SAVACT /SAVE RETURN ADDR
573 DCA SAVEAC
574 CLL CMA RAL
575 JMP SAVEAC+2 /BACK UP ONLY ONE ENTRY
576 SAVEAC, 0 /STORE AC IF NEEDED
577 TAD (-5 /LOOK AT STACK TWO DOWN
578 TAD X16
579 DCA SATEMP
580 TAD I SATEMP /IF 0, RESULT WAS LEFT IN AC
581 SZA CLA
582 JMP I SAVEAC /NO, NO STORE NEEDED
583 TAD TMPCNT /STORE TEMP NUMBER
584 DCA I SATEMP
585 ISZ SATEMP /MOVE TO TYPE WORD
586 TAD I SATEMP /GET TYPE
587 JMS SAVE /GO DO ACTUAL STORE
588 JMP I SAVEAC
589 SAVE, 0 /SAVE AC
590 DCA ACSTOR /THIS IS THE TYPE
591 TAD ACSTOR /IS IT COMPLEX OR DOUBLE?
592 TAD QM4
593 SNA
594 JMP NOC /ITS DOUBLE
595 IAC
596 SZA CLA
597 JMP NOCORD /NO
598 JMS I QGENCOD /STARTE; FLDA #CAC
599 SEGCAC-1
600 NOC, JMS ACSTOR /%FSTA #TMP+XXXX
601 JMS TMPBMP /THIS USE TWO TEMPS
602 JMP I SAVE
603 NOCORD, JMS ACSTOR /%FSTA #TMP+XXXX
604 JMP I SAVE
605 \fSATEMP,
606 ACSTOR, 0 /GENERATES FSTA TEMP+XXXX
607 JMS I QOPCOD /OUTPUT %FSTA %TEMP+XXXX
608 FSTA
609 JMS I QOADDR
610 TMPCNT /TMPCNT CONTAINS THE
611 /ARG NUMBER
612 JMS TMPBMP /BUMP TEMPORARY NUMBER
613 JMP I ACSTOR
614
615 TMPBMP, 0 /ROUTINE TO BUMP TEMPORARIES
616 TAD TMPCNT /BIGGER THAN MAX?
617 CIA CLL
618 TAD TMPMAX
619 SZL CLA
620 JMP .+3 /GO BUMP TEMP CNT
621 TAD TMPCNT /NEW TEMP MAX
622 DCA TMPMAX
623 ISZ TMPCNT /INCR TEMP COUNT
624 JMP I TMPBMP
625 \f/ PUSH ARG ONTO STACK
626 PUSH, JMS SAVEAC /GO SAVE AC IF NEEDED
627 JMS I QINWORD /GET ADDR OF NEW VAR
628 DCA TEMP /SAVE IT
629 TAD TEMP /PUSH IT
630 DCA I X16
631 ISZ TEMP /GO TO TYPE
632 CDF 10
633 TAD I TEMP /GET TYPE
634 CDF
635 AND Q17 /PUSH TYPE
636 DCA I X16 /ONTO STACK
637 CKPDL, DCA I X16 /ZERO BASE WORD
638 TAD X16 /IS STACK FULL ?
639 CIA CLL
640 TAD (STACK+177
641 SZL CLA
642 JMP I QNEXT /NO, OK
643 TAD STKLVL /RESET STACK LEVEL
644 DCA X16
645 JMS I QTTYMSG /PRINT MESSAGE
646 2004
647 DPUSH, JMS I QINWORD /GET THE VAR NAME PTR
648 DCA I X16 /PUSH IT
649 JMS I QINWORD /NOW GET THE DISPLACEMENT
650 JMP CKPDL-1 /GO CHECK FOR OVERFLOW
651 STARTF, TEXT 'STARTF'
652 \f/ ARITHMETIC IF
653 ARTHIF, JMS I QUCODE /GET ARG INTO AC
654 AIFTBL-1
655 JMS I QGENSF /DO ALL TRANSFERS IN FMODE
656 TAD (JLT /FIRST OPCODE
657 DCA AJUMP
658 AIFLUP, JMS I QINWORD /GET NEXT INPUT
659 DCA TEMP2 /SAVE IT IN CASE ITS NOT LABEL
660 TAD TEMP2
661 CLL
662 TAD (XPUSH-XLAST /IS IT A LABEL ?
663 SNL CLA
664 JMP I QNEXTM2 /NO, PROCEED
665 JMS I QOPCDE
666 AJUMP, 0 /OUTPUT CORRECT JUMP
667 TAD TEMP2
668 CDF 10
669 JMS I QOSNUM /NOW THE LABEL
670 JMS I QCRLF
671 ISZ AJUMP /MOVE TO NEXT OPCODE
672 ISZ AJUMP
673 JMP AIFLUP
674 DOT, TEXT '.'
675 DP8, TEXT '.+10'
676 PAGE
677 \f/ PICK UP TOP TWO ARGS
678
679 GARGS, 0 /GET TOP 2 ARGS FROM STACK
680 TAD X16
681 TAD QM6 /BACK TWO OPERANDS
682 DCA X15
683 TAD X15
684 DCA X16 /AND OFFICIALLY POP THE STACK
685 TAD I X15 /GET FIRST ARG
686 DCA ARG1
687 TAD I X15 /AND TYPE
688 DCA TYPE1
689 TAD I X15
690 DCA BASE1 /AND FIRST BASE (IN
691 /CASE OF SS)
692 TAD I X15 /NOW SECOND ARG
693 DCA ARG2
694 TAD I X15
695 DCA TYPE2
696 TAD I X15
697 DCA BASE2
698 TAD TYPE1 /TYPES MUST BE LT 6
699 TAD QM6
700 SMA CLA
701 JMP I GARGS /RETURN BAD
702 TAD TYPE2
703 TAD QM6
704 SPA CLA
705 ISZ GARGS /FIX RETURN
706 JMS MPTRA1 /GET ARG1 POINTER IF NEEDED
707 TAD ARG2 /IS ARG2 A POINTER
708 TAD (-61
709 SZA CLA
710 JMP I GARGS /NO, RETURN
711 TAD ARG1 /IS ARG1 IN THE AC ?
712 SZA CLA
713 JMP .+5 /NO
714 TAD TMPCNT /YES, STORE THE AC
715 DCA ARG1
716 TAD TYPE1 /GET TYPE
717 JMS I (SAVE
718 TAD BASE2 /MOVE POINTER FROM TEMP
719 /TO BASE+3
720 DCA ARG2
721 JMS I QGENCOD
722 MPTR3-1
723 TAD (62 /ARG IS NOW POINTED TO
724 /BY BASE+3
725 DCA ARG2
726 JMP I GARGS
727 MPTRA1, 0 /MOVE ARG1 POINTER TO BASE
728 TAD ARG1
729 TAD (-61
730 SZA CLA
731 JMP I MPTRA1
732 TAD ARG2
733 SZA CLA
734 JMP .+5
735 TAD TMPCNT
736 DCA ARG2
737 TAD TYPE2 /GET THE TYPE
738 JMS I (SAVE
739 TAD BASE1
740 DCA ARG1
741 JMS I QGENCOD
742 MPTR0-1
743 TAD (61
744 DCA ARG1 /SET ARG1 TO IND0
745 JMP I MPTRA1
746 \f/ BINARY OPERATORS
747 CODE, 0 /GENERATE CODE FOR
748 /BINARY OPERATORS
749 JMS GARGS /GET OPERANDS
750 JMP OTERR /BAD TYPE OPERATOR COMBO
751 TAD TYPE1 /INDEX INTO TYPE CHECK TABLE
752 CLL RTL
753 TAD TYPE1
754 TAD TYPE2
755 CLL RAL
756 TAD (TYPMIX-14 /POINTER TO CORRECT ENTRY
757 DCA SKEL
758 CDF 10
759 TAD I SKEL /RESULTING TYPE
760 SNA
761 JMP TYPERR /THIS MIX IS ILLEGAL
762 DCA TYPE1 /SAVE RESULT TYPE
763 ISZ SKEL /GET INDEX INTO
764 /SKELETON TABLE
765 TAD I SKEL
766 CDF
767 TAD I CODE /PLUS BASE GIVES ADDR
768 /OF M,AC CASE
769 DCA SKEL
770 CDF 10
771 TAD I SKEL /IS THIS TYPE OPER
772 /COMBO LEGAL ?
773 SNA CLA
774 JMP OTERR /NO
775 ISZ CODE /POINTS TO RESULTING TYPE
776 TAD ARG2
777 SZA CLA
778 ISZ SKEL /SECOND ARG IS IN MEMORY
779 TAD ARG1
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
783 DCA SKEL
784 JMS I QGENCOD /GO DO THE CODE
785 SKEL, 0
786 DCA I X16 /RESULT IS IN THE AC
787 TAD I CODE
788 SNA /IS TYPE SAME AS ARGS ?
789 TAD TYPE1 /YES
790 DCA I X16 /STORE IT
791 DCA I X16 /ZERO BASE WORD
792 TAD I CODE /IS TYPE SAME AS ARGS ?
793 SZA
794 DCA FMODE /NO, WE'RE NOW IN FMODE
795 JMP I CODE
796 TYPERR, JMS BUMP /PUT FALSE VALUE ONTO STACK
797 JMS I QTTYMSG /OUTPUT ERROR
798 1524
799 OTERR, JMS BUMP /PUT FALSE VALUE ONTO STACK
800 JMS I QTTYMSG
801 1724
802 XDPP6, TEXT '#DPT+6'
803 XFIX, TEXT '#FIX'
804 PAGE
805 \f/ CODE GENERATOR (FROM SKELETONS)
806
807 GENCOD, 0 /CODE GENERATOR ROUTINE
808 CDF
809 TAD X14
810 DCA TEMP14 /FIX COMPLEX FUNCTION BUG
811 TAD I GENCOD /GET SKELETON ADDRESS
812 ISZ GENCOD
813 MPOPUP, DCA X14 /HERE ON MACRO END
814 DCA MRETN
815 CODLUP, CDF 10 /STUFF IS IN FIELD 1
816 TAD I X14 /GET OPCODE
817 CDF
818 SNA
819 JMP ENDM /IS IT END OF A MACRO ?
820 SPA
821 JMP MACRO /ITS A MACRO REFERENCE
822 DCA .+2 /SAVE OPCODE
823 JMS I QOPCOD /OUTPUT IT
824 0
825 CDF 10
826 TAD I X14 /ADDRESS ?
827 CDF
828 SNA
829 JMP NOADDR /NO OPERAND FOR THIS INSTR
830 SPA
831 JMP DOADDR /ADDRESS IS AN OPERAND
832 DCA TEMP
833 JMS I QOTAB /ADDRESS IS A SPECIFIC
834 TAD TEMP
835 JMS I QOUTSYM
836 NOADDR, JMS I QCRLF
837 JMP CODLUP /DO NEXT LINE
838 DOADDR, IAC /IS IT ARG1 ?
839 SZA CLA
840 JMP ITSA2 /NO, ITS ARG2
841 JMS I QOADDR /OUTPUT ARG1 ADDRESS FIELD
842 ARG1
843 JMP CODLUP
844 ITSA2, JMS I QOADDR /OUTPUT ARG2 ADDRESS
845 ARG2 /FIELD
846 JMP CODLUP
847 MACRO, TAD Q5 /CODES BETWEEN -1 AND -5 ARE SPECIAL
848 SPA
849 JMP .+4 /NOT ONE OF THEM
850 TAD (JMP MJTBL
851 DCA .+1
852 HLT /GO TO PROPER ROUTINE
853 DCA MSTART /SAVE START OF MACRO
854 TAD X14 /SAVE RETURN ADDRESS
855 DCA MRETN
856 TAD MSTART /GO DO MACRO
857 DCA X14
858 JMP CODLUP
859 \fENDM, TAD MRETN /WAS THIS A MACRO ?
860 SZA
861 JMP MPOPUP /YES - GET OUT OF IT
862 TAD TEMP14
863 DCA X14 /RESTORE X14 FOR FUNCAL
864 JMP I GENCOD /AND EXIT
865
866 LOADA1, JMS I (LOADA /GENERATE LOAD
867 ARG1 /IF NECESSARY
868 JMP CODLUP
869 LOADA2, JMS I (LOADA /GENERATE LOAD
870 ARG2 /IF NECESSARY
871 JMP CODLUP
872 DOSTE, JMS I QGENSE /STARTE IF IN F MODE
873 JMP CODLUP
874 SGNNEG, ISZ RELCD /CHANGE SIGN OF RELATIONAL OPERATOR
875 JMP CODLUP
876 MSTART=TEMP
877 MRETN, 0 /MACRO RETURN ADDRESS
878 TEMP14, 0
879
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
885 JMP CODLUP
886
887 XSET, TEXT 'SETX'
888 ZEROC1, TEXT '0,1'
889 \f/ GOTO'S AND ASSIGN
890 CGOTO, JMS GTSTUF /LOOK AT INDEX
891 JMS I QGENCOD /OUTPUT COMPUTED GOTO CODE
892 CGTCOD-1
893 JMS I QINWORD /GET COUNT
894 CIA
895 DCA TEMP2
896 CGTLUP, JMS JAGEN
897 ISZ TEMP2
898 JMP CGTLUP
899 JMP I QNEXT
900 GOTO, JMS I QGENSF /ALL TRANSFERS IN F MODE
901 JMS JAGEN
902 JMP I QNEXT
903
904 JAGEN, 0
905 JMS I QOPCDE /OUTPUT JA'S
906 JA
907 JMS I QINWORD /GET THE LABEL
908 CDF 10
909 JMS I QOSNUM /OUTPUT IT AS THE ADDRESS
910 JMS I QCRLF
911 JMP I JAGEN
912
913 GTSTUF, 0
914 JMS I QGARG /GET THE ARG
915 JMP GTTYPE
916 CLL CMA RTL /CHECK THE TYPE
917 TAD TYPE1
918 SMA CLA
919 JMP GTTYPE /NOT INTEGER OR REAL
920 TAD ARG1 /IS IT IN THE AC ?
921 SNA CLA
922 JMP I GTSTUF /YES ALREADY
923 JMS I QGENCOD
924 GI-1 /LOAD THE INDEX
925 JMP I GTSTUF
926 GTTYPE, JMS I QTTYMSG /GOTO TYPE ERROR
927 0726
928 JAC, TEXT 'JAC'
929 FSTA, TEXT 'FSTA'
930 FNEG, TEXT 'FNEG'
931 PAGE
932 \f/ ADDRESS FIELD OUTPUT
933 OADDR, 0 /OUTPUT ADDRESS FIELD
934 TAD I OADDR /GET ADDRESS OF PARAMETERS
935 DCA ARG
936 ISZ OADDR
937 TAD I ARG /GET VALUE OF ARG
938 CLL
939 TAD (-52 /IS IT A TEMP REFNCE
940 SNL
941 JMP TMPREF /YES, 1-51
942 TAD (52-61 /IS IT AN ARRAY REFERENCE ?
943 SZL
944 JMP SSREF /YES, 52-60 IS XR1-XR7
945 SNA
946 JMP IND0 /INDIRECT THROUGH 0
947 TAD (61-7000 /CHECK FOR DO TEMP
948 SZL
949 JMP DOTMP
950 TAD (7000-62
951 SNA
952 JMP IND3 /INDIRECT THROUGH 3
953 TAD (63
954 DCA TEMP
955 CDF 10
956 TAD I TEMP /IS THIS AN ARG ?
957 AND Q20
958 CDF
959 SZA CLA
960 JMP INDARG /YES, REF IT INDIRECTLY
961 JMS I QOTAB
962 CDF 10
963 TAD I TEMP /LOOK AT TYPE WORD
964 AND (50 /IS IT LIT OR STMT NO.?
965 SNA
966 JMP OUTA /NO, JUST OUTPUT ADDRESS
967 AND Q40
968 SNA CLA
969 JMP OUTSN /OUTPUT STMT NUMBER
970 JMP OUTLIT /OUTPUT LITERAL
971 OUTA, TAD PROGNM /IS THIS THE FUNCTION NAME ?
972 CIA
973 TAD TEMP
974 SNA CLA
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
979 JMS I QCRLF
980 JMP I OADDR /END OF ADDRESS
981 OUTLIT, ISZ TEMP /MOVE TO LITERAL NUMBER
982 TAD I TEMP
983 DCA TEMP /DISPLACEMENT FROM %LITRL
984 CDF
985 TAD QLITRL /OUTPUT #LIT+
986 JMS I QOUTSYM
987 TAD TEMP /DISPLACEMENT
988 JMS I QONUMBR
989 JMP OADRET-1
990 FUNNAM, TAD (XVAL /#VAL
991 JMS I QOUTSYM
992 JMP OADRET-1
993 SSREF, TAD (270 /MAKE IT AN ASCII DIGIT
994 DCA XR
995 ISZ ARG /POINT TO THE BASE WORD
996 TAD I ARG /GET THE ADDR OF THE BASE
997 DCA ARG
998 CDF 10
999 TAD ARG
1000 IAC /GO TO TYPE OF BASE VAR
1001 DCA TEMP2
1002 TAD I TEMP2 /IS IT AN ARG TO THE SUBR ?
1003 AND Q20
1004 SNA CLA
1005 JMP NOTARG /NO, NO INDIRECT STUFF
1006 CDF
1007 JMS SIT
1008 TAD ARG /VAR NAME
1009 CDF 10
1010 JMS I QOUTNAM
1011 TAD COMMA
1012 JMS I QOCHAR
1013 TAD XR /XR NUMBER
1014 JMS I QOCHAR
1015 JMS I QCRLF
1016 OADRET, JMP I OADDR
1017 IND3, TAD (XBASP3-XBASE /INDIRECT THRU #BASE+3
1018 IND0, TAD (XBASE /INDIRECT THRU #BASE
1019 DCA TEMP
1020 JMS SIT
1021 TAD TEMP
1022 JMP FUNNAM+1
1023 OUTSN, CLA CMA /OUTPUT STMT NUMBER
1024 TAD TEMP
1025 JMS I QOSNUM /OUTPUT THE NUMBER
1026 TAD (P2 /+2 (HACK FOR FORMAT)
1027 JMP FUNNAM+1
1028 INDARG, JMS SIT /INDIRECT INDICATOR
1029 CDF 10
1030 JMP OUTA2 /OUTPUT ARG NAME
1031 SIT, 0
1032 TAD (245 /% (INDIRECT)
1033 JMS I QOCHAR
1034 JMS I QOTAB
1035 JMP I SIT
1036 CEQ, TEXT '#CEQ'
1037 XBAC1P, TEXT '#BASE,1+'
1038 XUE, TEXT '#UE'
1039 PAGE
1040 \f/ ADDRESS FIELD OUTPUT
1041
1042 NOTARG, TAD I TEMP2 /GET TYPE WORD
1043 DCA TEMP /SAVE IT
1044 TAD TEMP
1045 ISZ TEMP2
1046 AND Q200 /EQUIVALENCED ?
1047 SNA CLA
1048 JMP .+3
1049 TAD I TEMP2 /SKIP EQUIV INFO BLOCK
1050 DCA TEMP2
1051 CLL CML RTL
1052 TAD I TEMP2 /ADDRESS OF MAGIC NUMBER
1053 DCA TEMP2
1054 TAD I TEMP2 /MAGIC NUMBER ITSELF
1055 DCA TEMP2
1056 CDF
1057 JMS I QOTAB /TAB
1058 TAD ARG /OUTPUT VARIABLE MINUS CONST
1059 JMS VMC
1060 TAD COMMA
1061 JMS I QOCHAR
1062 TAD XR /N
1063 JMS I QOCHAR
1064 JMS I QCRLF /END OF LINE
1065 JMP OADRET
1066 DOTMP, DCA TEMP /ADDRESS RELATIVE TO %DOTMP
1067 JMS I QOTAB
1068 TAD (DOTMPN /OUTPUT #DOTMP
1069 JMS I QOUTSYM
1070 JMP PLUSN /GO OUTPUT +XXXX
1071 TMPREF, CLA
1072 TAD I ARG /BUMP TEMPS BACK CORRECTLY (?)
1073 DCA TMPCNT
1074 JMS I QOTAB /TAB
1075 CLA CMA
1076 TAD I ARG /GET NUMBER
1077 DCA TEMP /INTO TEMP
1078 IFNZRO TMPBLK-2 <XXXXXX>
1079 CLL STA RAL /V3C -2 (-TMPBLK)
1080 /V3C LINK SET
1081 TAD TEMP /V3C (SAVES A LITERAL)
1082 SNL /V3C
1083 DCA TEMP /YES, SAVE ALTERED DISPLACEMENT
1084 SNL CLA /V3C
1085 TAD (TEMPN2-TEMPN /USE %TEMPX
1086 TAD (TEMPN /USE %TEMP
1087 JMS I QOUTSYM
1088 PLUSN, TAD PLUS /PLUS CONSTANT
1089 JMS I QOCHAR
1090 TAD TEMP /DISPLACEMENT TIMES THREE
1091 CLL RAL
1092 TAD TEMP
1093 JMS I QONUMBR /OUT IT
1094 JMS I QCRLF
1095 JMP OADRET
1096 \f/ UTILITIES
1097 VMC, 0 /OUTPUT VARIABLE MINUS CONST
1098 CDF 10
1099 JMS I QOUTNAM /PUT VAR NAME
1100 TAD Q255 /-
1101 JMS I QOCHAR
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
1106 /LOGICAL 3 WORDS
1107 DCA MQ
1108 TAD TEMP2
1109 JMS MUL12 /DO MULTIPLY
1110 JMS I QNUMBRO /OUTPUT 15 BIT NUMBER
1111 JMP I VMC
1112 SC,
1113 SKPIRL, 0 /SKIP ON TYPE I R OR L
1114 AND Q17 /ISOLATE TYPE CODE
1115 TAD QM4 /IS IT DOUBLE ?
1116 SZA
1117 IAC /NO, IS IT COMPLEX ?
1118 SZA CLA
1119 ISZ SKPIRL /NEITHER, SKIP
1120 JMP I SKPIRL /RETURN
1121 MUL12, 0 /12 BIT MULTIPLY
1122 DCA OPRND
1123 TAD (-15
1124 DCA SC
1125 JMP STMUL
1126 M12LUP, TAD AC
1127 SNL
1128 JMP .+3
1129 CLL
1130 TAD OPRND
1131 RAR
1132 STMUL, DCA AC
1133 TAD MQ
1134 RAR
1135 DCA MQ
1136 ISZ SC
1137 JMP M12LUP
1138 JMP I MUL12
1139 OPRND,
1140 BUMP, 0 /PUT FALSE ENTRY ONTO STACK
1141 CDF 0 /V3C IMPORTANT PROTECTION
1142 DCA I X16
1143 ISZ X16
1144 ISZ X16 /THIS PREVENTS UNDER
1145 /FLOWING THE STACK
1146 JMP I BUMP /AFTER SOME ERRORS
1147 EXTERN, TEXT 'EXTERN'
1148 CADD, TEXT '#CAD'
1149 CNEG, TEXT '#CNG'
1150 CMUL, TEXT '#CML'
1151 JLE, TEXT 'JLE'
1152 ORG, TEXT 'ORG'
1153 STARTE, TEXT 'STARTE'
1154 XDPTMP, TEXT '#DPT'
1155 PAGE
1156 \f/ RANDOM CODE GENERATORS
1157
1158 ERROR, JMS I QINWORD /GET ERROR CODE
1159 JMS I QERMSG /PRINT IT
1160 JMP I QNEXT
1161 EOSTMT, TAD DATASW /WAS THIS A DATA STMT ?
1162 SNA CLA
1163 JMP OPTMYZ /NO
1164 DCA DATASW /KILL SWITCH
1165 JMS I QOPCDE
1166 ORG /ORIGIN BACK TO THE PROGRAM
1167 TAD GLABEL
1168 JMS I QOLABEL
1169 JMS I QCRLF
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
1175 7421 /FOR COOLNESS
1176 CLA /FOR NON-EAE FOLKS
1177 TAD STKLVL /RESET STACK LEVEL
1178 DCA X16
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
1183 LDX
1184 TAD LINENO /THIS IS THE CURRENT ISN
1185 JMS I QONUMBR
1186 TAD COMMA
1187 JMS I QOCHAR
1188 TAD Q260
1189 JMS I QOCHAR
1190 JMS I QCRLF
1191 JMP I QNEXT
1192 IFEND, 0 /OUTPUT IF END LABEL IF
1193 TAD IFLABL /WAS THIS END OF LOG IF
1194 SNA
1195 JMP I IFEND /OUTPUT DEBUG STUFF
1196 JMS I QLABEL /OUPTUT THE LABEL
1197 JMS I QGENSF /ALL LOGICAL IFS MUST
1198 /END IN FMODE
1199 DCA WHATAC /CAN'T DEPEND ON
1200 /AC HERE
1201 JMS I QXRTBL /OR XR'S EITHER
1202 DCA IFLABL /KILL THE SWITCH
1203 JMP I IFEND
1204 OPCOD, 0 /TAB OPCODE
1205 DCA WHATAC /AC HAS JUST BEEN
1206 /MODIFIED
1207 JMS I QOTAB
1208 TAD I OPCOD
1209 ISZ OPCOD
1210 JMS I QOUTSYM
1211 JMP I OPCOD
1212 DIV, JMS I QSAVACT /IF SECOND OPERAND IN AC, SAVE IT
1213 JMS I QCODE /DIVIDE
1214 DIVTBL-6;0
1215 CLA CMA /WERE BOTH VARS INTEGER?
1216 TAD TYPE1
1217 SZA CLA
1218 JMP I QNEXT /NO
1219 JMS I QGENCOD
1220 A0FN-1 /ALN 0;FNORM
1221 JMP I QNEXT
1222 LIFBGN, DCA RELCD /ENTER HERE IF LAST OPCODE NOT A RELATIONAL
1223 JMS I QGARG /ENTER HERE FROM RELATIONAL OPTIMIZER
1224 JMP NOTLOG
1225 TAD TYPE1 /MUST BE LOGICAL
1226 TAD (-5
1227 SZA CLA
1228 JMP NOTLOG
1229 TAD ARG1 /IS IT IN AC ?
1230 SNA CLA
1231 JMP .+3
1232 JMS I QGENCOD
1233 GI-1
1234 JMS I QINWORD /IS IT IF(...)GOTO XX ?
1235 DCA TEMP2
1236 TAD TEMP2
1237 TAD (XPUSH-XGOTO
1238 SNA CLA
1239 JMP IFGOTO /YES, TREAT AS SPECIAL CASE
1240 TAD GLABEL /SET IF LABEL
1241 DCA IFLABL
1242 TAD RELCD
1243 CIA
1244 TAD Q5 /GENERATE THE OPPOSITE JUMP
1245 JMS RELJMP /AROUND THE TARGET OF THE IF
1246 TAD GLABEL
1247 JMS I QOLABEL
1248 ISZ GLABEL /INCREMENT LABEL GENERATOR
1249 JMS I QCRLF
1250 JMP I QNEXTM2
1251 IFGOTO, TAD RELCD
1252 JMS RELJMP /GENERATE TRUE RELATIONAL JUMP IF "IF()GOTO"
1253 JMS I QINWORD /GET THE LABEL
1254 CDF 10
1255 JMS I QOSNUM
1256 JMS I QCRLF
1257 JMP I QNEXT
1258 NOTLOG, JMS I QTTYMSG
1259 1411
1260
1261 RELJMP, 0
1262 CLL RAL
1263 TAD (JNE
1264 DCA .+2
1265 JMS I QOPCDE
1266 0
1267 JMP I RELJMP
1268
1269 FMUL, TEXT 'FMUL'
1270 FDIV, TEXT 'FDIV'
1271 CAC, TEXT '#CAC'
1272 LITRL, TEXT '#LIT+'
1273 TEMPN, TEXT '#TMP'
1274 PAGE
1275 \f/ DO LOOP COMPILER
1276
1277 DOBEGN, JMS I QSAVACT /FOR EXPR IN LOOP PARAMS
1278 TAD X16 /SET NEW STACK LEVEL
1279 DCA STKLVL
1280 JMS I QGARGS /GET LIMIT AND STEP
1281 JMP DPERR /ERROR IN DO PARMS
1282 JMS DOPARM /DO PARAMETER STUF FOR LIMIT
1283 ARG1
1284 JMS DOPARM
1285 ARG2 /AND THEN FOR STEP
1286 TAD ARG1 /REPLACE ALTERRED STACK
1287 /ENTRIES
1288 DCA I X16
1289 ISZ X16 /REST OF ARG1 OK
1290 TAD GLABEL /SAVE LOOP LABEL
1291 DCA I X16
1292 TAD ARG2
1293 DCA I X16
1294 ISZ X16
1295 ISZ X16
1296 JMS I QCRLF /CRLF BEFORE LABL
1297 TAD GLABEL
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
1302 JMP I QNEXT
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)
1307 SZL CLA /SKIP IF >2
1308 CLL CMA RTL /L=1 AC=-3
1309 TAD TYPE2
1310 SZL CLA /L=0 IS BAD
1311 JMP I (STORE+2 /DO STORE IF OK
1312 DPERR, JMS I QTTYMSG /ERROR IN LIMITS
1313 0420 /DP
1314 DOFINI, JMS I QXRTBL /DON'T OPTIMIZE XR USAGE
1315 /IN SUCCESSIVE IMPLIED DO LOOPS
1316 TAD IOSTMT /INSIDE IO STMT ?
1317 SNA CLA
1318 JMS IFEND /IF NOT, END IF FIRST
1319 JMS I QINWORD /GET THE INDEX
1320 DCA ARG1
1321 TAD ARG1 /GET THE TYPE WORD ADR
1322 IAC
1323 DCA TYPE1
1324 CDF 10
1325 TAD I TYPE1
1326 CDF
1327 AND Q17
1328 DCA TYPE1 /TYPE OF INDEX VAR
1329 TAD QM6
1330 TAD STKLVL /BACK UP THE STACK
1331 DCA X16
1332 TAD X16 /RESET THE STACK LEVEL
1333 DCA STKLVL
1334 TAD I X16 /GET THE FINAL VALUE
1335 DCA DOARG
1336 ISZ X16
1337 TAD I X16 /GET THE LOOP LABEL
1338 DCA DARG
1339 TAD I X16 /GET THE STEP
1340 DCA ARG2
1341 TAD I X16 /WHICH DO FIN CODE ?
1342 CLL CML RAL
1343 TAD TYPE1
1344 TAD QM6
1345 SNA CLA
1346 TAD (DOFIN1-DOFIN0 /INDEX=I, STEP=R
1347 TAD (DOFIN0-1 /ALL OTHER CASES
1348 DCA .+2
1349 JMS I QGENCOD /DO FINISH CODE
1350 0
1351 JMS I QOPCOD /SUBTRACT UPPER LIMIT
1352 FSUB
1353 JMS I QOADDR
1354 DOARG
1355 JMS I QOPCDE /NOW THE JLT %%LOOP
1356 JLE
1357 TAD DARG /OUTPUT LABEL
1358 JMS I QOLABEL
1359 JMS I QCRLF
1360 TAD STKLVL /FIX X16 INCASE MULTIPLE DO ENDER
1361 DCA X16
1362 JMP I QNEXT
1363 DOARG,
1364 DOPARM, 0 /SUBR FOR DO PARAMETERS
1365 TAD I DOPARM
1366 ISZ DOPARM /GET THE PARM POINTER
1367 DCA DARG
1368 CLL CML RTL /GET ADDR OF TYPE WORD
1369 TAD DARG
1370 DCA TYPE
1371 CLL CMA RTL /CHECK TYPE
1372 TAD I TYPE
1373 SMA CLA
1374 JMP DPERR /NOT I OR R
1375 TAD I DARG
1376 SNA
1377 JMP STRTMP /ARG ALREADY IN AC
1378 TAD QM63 /IS IT ARRAY REF?
1379 SPA CLA
1380 JMP SVLIMT /YES, SAVE LIMIT
1381 TAD I DARG /REGET SYM ADDR
1382 DCA X10 /ADR OF TYPE WORD
1383 CDF 10
1384 TAD I X10 /MAYBE ITS A LIT?
1385 CDF
1386 AND Q40
1387 SZA CLA
1388 JMP I DOPARM /YES, ITS LITERAL
1389 /WE'RE ALWAYS IN F MODE HERE
1390 /SINCE THE LAST THING
1391 /WAS A DO STORE
1392 SVLIMT, JMS I QOPCOD /OTHERWISE LOAD IT
1393 FLDA
1394 JMS I QOADDR
1395 DARG, 0
1396 STRTMP, TAD DOTEMP /SET ARG TO NEXT DO TEMP
1397 DCA I DARG
1398 JMS I QOPCOD /GENERATE STORE
1399 FSTA
1400 ISZ DOTEMP /BUMP DO TEMP
1401 TAD DARG
1402 DCA .+2
1403 JMS I QOADDR /DO TEMP ADDRESS FIELD
1404 0
1405 JMP I DOPARM
1406 PAGE
1407 \f/ SUBSCRIPT REFERENCE COMPILER
1408
1409 ARGS, JMS I QINWORD /COMPILE ARGUMENT LIST
1410 CMA
1411 DCA NARGS /NUMBER OF ARGS
1412 TAD NARGS /GET ADDRESS OF SUBSCRIPTED VAR
1413 CLL RAL
1414 TAD NARGS /ENTRY ON THE STACK
1415 TAD X16
1416 DCA X15
1417 TAD X15 /SAVE POINTER TO START
1418 /OF THIS ENTRY
1419 DCA X14 /FOR POSSIBLE FUTURE USE
1420 ISZ NARGS /NOW ITS THE 2'S COMPLEMENT
1421 NOP
1422 TAD I X15 /FETCH SS VARIABLE
1423 DCA BASE1
1424 TAD I X15 /ITS TYPE
1425 DCA TYPE1
1426 TAD BASE1 /STORE BASE WORD
1427 DCA I X15
1428 TAD BASE1 /GET ADDR OF TYPE WORD
1429 IAC
1430 DCA TEMP
1431 CDF 10 /GET TYPE WORD
1432 CLL CML RTR /TEST DIM BIT
1433 AND I TEMP
1434 SNA CLA
1435 JMP TRYCAL /SOME KIND OF CALL
1436 TAD BASE1 /NOW GET ADDRESS OF DIM INFO
1437 JMS I QGETSS
1438 DCA ARG1 /RETURNS WITH FIELD SET
1439 TAD I ARG1 /CORRECT NUMBER OF DIMENSIONS?
1440 TAD NARGS
1441 CDF
1442 SZA CLA
1443 JMP DIMERR /NO
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
1448 TAD (-10 /SEVEN XRS
1449 DCA XRCNT /COUNT FOR SEARCH
1450 DCA FREEXR /ZERO FREE XR INDICATOR
1451 XRCHEK, CDF
1452 ISZ XRCNT /ANY MORE XR EXPRS TO TEST ?
1453 SKP /YES, GO CHECK THEM
1454 JMP COMPSS /NO, MUST COMPILE
1455 /XR ERPRESSION
1456 ISZ XRNUM /BUMP XR NUMBER
1457 TAD XRNUM
1458 CLL RTL /TIMES 16
1459 CLL RTL
1460 TAD (XRBUFR-1 /PLUS BASE (-1)
1461 DCA X13
1462 TAD I X13 /LOOK AT THE
1463 SPA /INDICATOR
1464 JMP .+3 /-1=USED BY THIS STMT
1465 SZA CLA /IF ZERO GO TO
1466 /MTXR (EVENTUALLY)
1467 TAD FREEXR /ANY FREE BEFORE THIS ONE ?
1468 SZA CLA
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
1476 DCA TEMP2
1477 CDF 10
1478 TAD I TEMP2 /SAME NUMBER OF DIMS ?
1479 TAD NARGS
1480 SZA CLA
1481 JMP XRCHEK /NO, THIS XR WONT DO
1482 TAD NARGS /SET COUNTER
1483 DCA DCNT
1484 TAD ARG1 /POINTER TO DIM FACTORS
1485 DCA X12
1486 ISZ TEMP2 /SKIP THREE WORDS
1487 ISZ TEMP2
1488 ISZ TEMP2
1489 DCHEK, ISZ DCNT /ANY MORE ?
1490 SKP
1491 JMP SSCHEK /DIMS OK, CHECK SS
1492 ISZ TEMP2 /GET TO NEXT DIM
1493 TAD I TEMP2 /ARE THEY EQUAL ?
1494 CIA
1495 TAD I X12
1496 SZA CLA
1497 JMP XRCHEK /NO, GO TRY NEXT ONE
1498 JMP DCHEK
1499 SSCHEK, TAD NARGS /COUNT AGAIN
1500 CDF
1501 DCA DCNT
1502 CLL CMA RAL /-2
1503 TAD X16 /ADDR OF START OF TOP
1504 /SS ON STACK
1505 JMP .+3
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
1510 /RIGHT TO LEFT)
1511 TAD (-61 /IS IT A VAR OR LITERAL?
1512 SNL CLA
1513 JMP XRCHEK /WE'RE JUST
1514 /LOOKING FOR AN EMPTY
1515 TAD I XTMP /RE GET SS POINTER
1516 CIA
1517 TAD I X13 /ARE THEY THE SAME ?
1518 SZA CLA
1519 JMP XRCHEK /NO
1520 ISZ DCNT
1521 JMP SSC2 /KEEP CHECKING
1522 TAD XRNUM /THEY MATCH, STICK IN
1523 /THE XR NUMBER
1524 TAD (51
1525 DCA I X14
1526 CLL CML RTL
1527 TAD X14 /PURGE SS FROM STACK
1528 DCA X16
1529 CLA CMA /SET FLAG TO
1530 /'USED BY THIS STMT'
1531 DCA I XRFLAG
1532 JMP I QNEXT
1533 DCNT, 0
1534 XRFLAG, 0
1535 XTMP, 0
1536 PAGE
1537 \f/ SUBSCRIPT REFERENCE COMPILER
1538
1539 COMPSS, TAD FREEXR /GET XR EXPR AREA
1540 CLL RTL /BY MULTIPLYING
1541 /THE NUMBER
1542 CLL RTL /BY 16
1543 TAD (XRBUFR /AND ADDING THE
1544 /BASE ADDRESS
1545 DCA XREPTR /THIS IS IT
1546 CLA CMA /SET USED BY THIS
1547 /STMT FLAG
1548 DCA I XREPTR
1549 ISZ XREPTR
1550 CLL CMA RTL /STORE THE DIB POINTER
1551 TAD ARG1
1552 DCA I XREPTR
1553 TAD NARGS /GET ADDR OF POINTER TO LAST
1554 CMA /DIMENSION FACTOR
1555 TAD ARG1
1556 DCA ARG1 /SINCE WE USE THEM IN
1557 /REVERSE ORDER
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
1562 SKP
1563 CSSLUP, TAD (FADD /ADD ALL SUBSEQUENT ONES
1564 DCA OPC
1565 CLL CMA RTL /BACK UP STACK BY ONE ENTRY
1566 TAD X16
1567 DCA X16
1568 TAD X16 /GET A WORKING POINTER
1569 DCA X15
1570 TAD I X15 /GET THE NEXT SUBSCRIPT
1571 DCA ARG2
1572 CLL CMA RAL /MUST BE INTEGER
1573 TAD I X15
1574 SMA CLA
1575 JMP DIMERR
1576 TAD I X15
1577 DCA BASE2
1578 TAD ARG2 /STORE THE SS INTO THE
1579 /XR EXPR
1580 ISZ XREPTR /INCREMENT FIRST
1581 DCA I XREPTR
1582 TAD ARG2 /IS ARG2 THE AC (ONLY
1583 /POSSIBLE IF
1584 SNA CLA /ITS THE RIGHTMOST
1585 /SUBSCRIPT)
1586 JMP NLODSS /YES, DON'T LOAD IT
1587 JMS I QOPCOD /OUTPUT LOAD OR ADD
1588 OPC, 0 /THIS LOCATION TELLS
1589 /THE STORY
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?
1595 SZA CLA
1596 JMP ASGNXR /YES, GO USE IT
1597 TAD (61 /ITS A SPECIAL POINTER ENTRY
1598 DCA I X14
1599 ISZ X14
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
1604 SF-1
1605 JMS I (ACSTOR /GENERATE STORE AC
1606 JMP I QNEXT
1607 DIMERR, JMS I QTTYMSG /SS NOT OF CORRECT NUMBER
1608 2323
1609 XRCNT, 0
1610 TRYCAL, TAD ASFSWT /ASF DEFINITION
1611 SMA SZA CLA
1612 JMP DEFASF /YES, GO OUTPUT PROLOG
1613 TAD I TEMP /IS IT A FUNCTION OR AN ARG?
1614 CDF
1615 AND (1420
1616 SNA
1617 JMP DIMERR /NO, SOME KIND OF ERROR
1618 AND Q20
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
1623 FMUL
1624 CDF 10
1625 TAD I ARG1 /PICK UP FACTOR ADDRESS
1626 CDF
1627 DCA ARG2
1628 CLA CMA
1629 TAD ARG1 /MOVE BACK ONE
1630 DCA ARG1
1631 JMS I QOADDR /OUTPUT MULTIPLY ADDRESS
1632 ARG2
1633 JMP CSSLUP /LOOP ON NEXT SS
1634 ASGNXR, JMS I QOPCDE /OUTPUT ATX N
1635 ATX
1636 TAD FREEXR /GET NUMBER OF FREE XR
1637 TAD Q260
1638 JMS I QOCHAR
1639 JMS I QCRLF
1640 TAD FREEXR
1641 TAD (51 /COMPUTE PROPER NUMBER
1642 DCA I X14 /PUT IT INTO TOP OF STACK
1643 JMP I QNEXT
1644 XREPTR, 0
1645 \f/ RANDOM TEXT
1646 OTAB, 0
1647 TAD (211
1648 JMS I QOCHAR
1649 JMP I OTAB
1650 FCLA, TEXT 'FCLA'
1651 STARTD, TEXT 'STARTD'
1652 TEMPN2, TEXT '#TMPX'
1653 CSUB, TEXT '#CSB'
1654 CDIV, TEXT '#CDV'
1655 PAGE
1656 \f/ GENERAL CALL GENERATOR
1657
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
1663 DCA FNSWIT
1664 TAD X15 /NEW STACK VALUE
1665 DCA X16
1666 TAD X15 /WORKING POINTER
1667 DCA ARG2
1668 TAD NARGS /WORKING COUNTER
1669 SNA
1670 JMP OUTJSR /NO ARGS, PUT JSR
1671 DCA TYPE2
1672 CHKPTR, ISZ ARG2 /MOVE TO NUMBER
1673 TAD ARG2
1674 IAC /ADDR OF TYPE WORD
1675 DCA BASE2
1676 TAD I BASE2 /GET TYPE
1677 DCA TYPE1 /TYPE OF ARG FOR GENPTR
1678 ISZ BASE2 /POINT TO BASE WORD
1679 TAD I BASE2
1680 DCA BASE1 /FOR GENPTR
1681 TAD I ARG2 /GET ARG NUMBER
1682 CLL
1683 TAD (-52 /IS IT INDEXED ?
1684 SNL
1685 JMP NOTINX /NO, ITS A TEMP
1686 TAD (52-61 /IS IT INDIRECT ?
1687 SZL
1688 JMP INXR /NO, ITS IN AN XR
1689 SNA
1690 JMP INTMP /POINTER IN A TEMP
1691 TAD (62 /GET TO TYPE WORD
1692 DCA GCTEMP
1693 CDF 10
1694 TAD I GCTEMP /IS IT AN ARG
1695 CDF
1696 AND (1020 /ARG OR EXTERNAL ?
1697 SNA
1698 JMP NOTINX+1 /NEITHER
1699 AND Q20
1700 SZA CLA
1701 JMP ARGARG /ARG SQUARED
1702 JMP EXTARG /EXTERNAL ARG
1703 NOTINX, CLA
1704 ISZ ARG2 /BUMP POINTER
1705 ISZ ARG2
1706 ISZ TYPE2 /INCR COUNT
1707 JMP CHKPTR
1708 OUTJSR, TAD JSRLBL /DOES IT GET A LABEL ?
1709 SNA
1710 JMP .+3 /NO
1711 JMS I QLABEL /OUPTUT THE LABEL+COMMA
1712 DCA JSRLBL /KILL SWITCH
1713 TAD X16 /ADDR OF POINTER TO FUN NAME
1714 DCA TEMP
1715 FNSWIT, 0 /REAARANGED**
1716 JMP I (IOFUN /IO FUNCTION CALL
1717 JMS I QOPCDE /OUTPUT THE JSR
1718 JSR
1719 TAD I TEMP /NOW THE SUBR NAME
1720 CDF 10
1721 JMS I QOUTNAM
1722 JMS I QCRLF
1723 TAD NARGS /ANY ARGS ?
1724 SNA CLA
1725 JMP I GENCAL /NO, END OF CALL
1726 JMS I QOPCDE /JUMP AROUND THE ARGS
1727 JA
1728 TAD Q256
1729 JMS I QOCHAR /.
1730 TAD PLUS
1731 JMS I QOCHAR /+
1732 CLL CLA CMA RAL /-2
1733 TAD NARGS /-N-2
1734 CLL CMA RAL /2*N+2
1735 JMS I QONUMBR
1736 IOONLY, JMS I QCRLF
1737 TAD X16 /WORKING POINTER
1738 DCA X15
1739 PTRLST, TAD I X15 /GET NEXT ARG
1740 SZA
1741 JMP SARG /SIMPLE ARG
1742 CLL CML RTL
1743 TAD X15 /ADDR OF GENERATED
1744 /LABEL NUMBER
1745 DCA TEMP
1746 TAD I TEMP /OUTPUT #GXXXX (THE
1747 /GENERATED LABEL)
1748 JMS I QLABEL /OUPTUT THE LABEL
1749 JMS I QGENCOD
1750 JADP2-1 /GENERATE A DUMMY JA
1751 JMP BARGLP
1752 SARG, DCA ARG2 /STORE THE ARG NUMBER
1753 JMS I QOPCOD /OUTPUT JA ARG
1754 JA
1755 JMS I QOADDR /NOW ADDRESS FIELD
1756 ARG2
1757 BARGLP, ISZ X15 /BUMP POINTER
1758 ISZ X15
1759 ISZ NARGS /BUMP COUNT
1760 JMP PTRLST
1761 JMP I GENCAL
1762 INTMP, TAD I BASE2 /GET TEMP NUMBER
1763 DCA ARG1 /THAT PTR IS STORED IN
1764 JMS I QGENCOD /PICK UP POINTER
1765 LDASTD-1
1766 STRPTR, JMS I QOPCDE /NOW STORE THE POINTER
1767 FSTA
1768 TAD GLABEL /OUTPUT THE LABEL
1769 JMS I QOLABEL
1770 JMS I QCRLF
1771 TAD GLABEL /SAVE THE LABEL NUMBER
1772 DCA I BASE2
1773 DCA I ARG2 /ZERO ARG NUMBER
1774 ISZ GLABEL /INCREMENT LABEL NUMBER
1775 JMS I QGENCOD /BACK TO F MODE
1776 SF-1
1777 JMP NOTINX /CONTINUE LOOP
1778 NLABEL, 0
1779 JMS I QOLABEL
1780 TAD COMMA
1781 JMS I QOCHAR
1782 JMP I NLABEL
1783 PAGE
1784 \f/ GENERATE SUBROUTINE CALL
1785
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 ?
1791 SNA CLA
1792 JMP MAKCAL /NO, ITS EASIER
1793 JMS I QOPCOD /GET THE JSR TO THE SUBR
1794 FLDA
1795 JMS I QOADDR
1796 BASE1 /BY GETTING THE VALUE
1797 /OF THE ARG
1798 JMS I QGENCOD /STARTD
1799 SD-1
1800 JMS I QOPCDE /STORE IT AHEAD
1801 FSTA
1802 TAD GLABEL /INTO THE JSR
1803 ISZ GLABEL
1804 DCA JSRLBL /SET THE SWITCH
1805 TAD JSRLBL
1806 JMS I QOLABEL
1807 JMS I QCRLF
1808 JMS I QGENCOD /STARTF
1809 SF-1
1810 MAKCAL, ISZ BASE1 /MOVE TO TYPE WORD
1811 CDF 10
1812 TAD I BASE1 /GET TYPE OF FUNCTION
1813 CDF
1814 JMS I QSKPIRL /WHAT MODE WILL WE LEAVE IN?
1815 DCA FMODE /PROBABLY E
1816 JMS I QGENCAL /GO GENERATE THE CALL
1817 SKP
1818 0 /THIS IS A FREE LOCATION
1819 JMP I QNEXT
1820 ARGARG, JMS I QOPCDE /%FLDA
1821 FLDA
1822 TAD I ARG2 /POINTER
1823 CDF 10
1824 JMS I QOUTNAM
1825 JMS I QCRLF
1826 JMS I QGENCOD /%SD
1827 SD-1
1828 CDF 10
1829 CLL CML RTR /IS IT AN ARRAY ?
1830 AND I GCTEMP
1831 CDF
1832 SNA CLA
1833 JMP STRPTR /GO STORE THE POINTER
1834 TAD I ARG2 /GET THE LITERAL NUMBER
1835 JMS I QGETSS
1836 TAD Q3
1837 DCA GCTEMP
1838 TAD I GCTEMP
1839 DCA OLABEL /SAVE IT
1840 CDF
1841 JMS I QOPCDE /%FADD LITERAL
1842 FADD
1843 TAD QLITRL
1844 JMS I QOUTSYM
1845 TAD OLABEL /XXXX
1846 JMS I QONUMBR
1847 JMS I QCRLF
1848 JMP STRPTR /GO STORE THE POINTER
1849 INXR, TAD (270 /MAKE AN ASCII CHAR
1850 DCA XR
1851 JMS I QOPCDE /XTA
1852 XTA
1853 TAD XR
1854 JMS I QOCHAR /N
1855 JMS I QCRLF
1856 TAD BASE1 /FIND ADDR OF MAGIC
1857 /NUMBER LITERAL
1858 JMS I QGETSS
1859 CDF
1860 TAD Q3
1861 DCA ARG1
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
1866 DCA I X17
1867 TAD DOTEMP /USE DO TEMPS FOR THIS
1868 DCA I X17
1869 CDF
1870 TAD DOTEMP /SINCE OADDR CAN HANDLE THEM
1871 DCA I ARG2
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
1877 DCA TEMP
1878 TAD (243
1879 JMS I QOCHAR
1880 TAD (307
1881 JMS I QOCHAR
1882 TAD TEMP
1883 JMS I QONUMBR
1884 JMP I OLABEL
1885 OPCODE, 0 /TAD OPCODE TAB
1886 DCA WHATAC /THIS INSTRUCTION ZAPS AC
1887 JMS I QOTAB
1888 TAD I OPCODE
1889 ISZ OPCODE
1890 JMS I QOUTSYM
1891 JMS I QOTAB
1892 JMP I OPCODE
1893 M1C2, TEXT '-1,2'
1894 GENSTE, 0 /GENERATE STARTE IF IN
1895 /F MODE
1896 TAD FMODE /LOOK AT THE SWITCH
1897 SNA CLA
1898 JMP I GENSTE /ALREADY IN E MODE
1899 DCA FMODE /CLEAR THE SWITCH
1900 JMS I QOPCOD /GENERATE THE STARTE
1901 STARTE
1902 JMS I QCRLF /CAN'T USE GENCOD FOR THAT
1903 JMP I GENSTE
1904 D0, TEXT '0'
1905 DOTMPN, TEXT '#DOTMP'
1906 PAGE
1907 \f/ OPCODES AND OTHER TEXT
1908
1909 XBASE, TEXT '#BASE'
1910 XBASP3, TEXT '#BASE+3'
1911 DP3C0, TEXT '.+3,0'
1912 JXN, TEXT 'JXN'
1913 ALN, TEXT 'ALN'
1914 ATX, TEXT 'ATX'
1915 XTA, TEXT 'XTA'
1916 LDX, TEXT 'LDX'
1917 XREW, TEXT '#REW'
1918 XENDF, TEXT '#ENDF'
1919 XBAK, TEXT '#BAK'
1920 XEXIT, TEXT '#EXIT'
1921 XRTN, TEXT '#RTN'
1922 \fJNE, TEXT 'JNE'
1923 TEXT 'JGE'
1924 TEXT 'JLE'
1925 TEXT 'JGT'
1926 JLT, TEXT 'JLT' /MUST BE IN THIS ORDER!!
1927 TEXT 'JEQ'
1928 JA, TEXT 'JA'
1929
1930 JSR, TEXT 'JSR'
1931 JSA, TEXT 'JSA' /MUST BE IN THIS ORDER!
1932 TRAP3, TEXT 'TRAP3'
1933 \f/ POINTER GENERATOR
1934 GENPTR, 0 /GENERATE A POINTER
1935 JMS I QOPCOD /MULTIPLY BY 3. OR 6.
1936 FMUL
1937 TAD TYPE1 /D OR C ?
1938 JMS I QSKPIRL /SKIP ON I, R, OR L
1939 TAD Q6M3
1940 TAD (THREE
1941 DCA TEMP /POINTER TO CORRECT LITERAL
1942 JMS I QOADDR
1943 TEMP
1944 JMS I QGENCOD /ALN 0; STARTD
1945 A0SD-1
1946 JMS I QOPCDE /FADD THE BASE LITERAL
1947 FADD
1948 ISZ BASE1 /GET ADDR OF TYPE WORD
1949 CDF 10
1950 TAD I BASE1 /GET TYPE WORD
1951 AND Q20
1952 SNA CLA
1953 JMP NIARG /NOT AN ARG
1954 CMA
1955 TAD BASE1
1956 JMS I QOUTNAM /IF AN ARG, THE LITERAL
1957 /IS THE ARG
1958 JMP OSF
1959 NIARG, CDF
1960 TAD QLITRL /OTHERWISE ITS IN THE
1961 /LITERAL BLOCK
1962 JMS I QOUTSYM
1963 CDF 10
1964 TAD I ARG1 /LITERAL NUMBER
1965 CDF
1966 JMS I QONUMBR
1967 OSF, JMS I QCRLF
1968 JMP I GENPTR
1969 \f/ MORE RANDOM CODE GENERATORS
1970 STOP, JMS I QGENCOD /CALL EXIT
1971 STPCOD-1
1972 JMP I QNEXT
1973 FORMAT, JMS I QINWORD /NUMBER OF WORDS OF TEXT
1974 CMA
1975 DCA TEMP
1976 JMS I QOPCDE /JA AROUND THE STUFF
1977 JA
1978 TAD Q256
1979 JMS I QOCHAR /.
1980 TAD PLUS
1981 JMS I QOCHAR
1982 CLL CMA RAL /.+2+NWORDS
1983 TAD TEMP
1984 CMA
1985 JMP .+3
1986 FMTLUP, JMS I QOTAB /TA
1987 JMS I QINWORD /GET NEXT WORD
1988 JMS I QONUMBR /OUTPUT IT
1989 JMS I QCRLF
1990 ISZ TEMP
1991 JMP FMTLUP
1992 JMP I QNEXT
1993
1994 DFRTTM, 0 /ROUTINE TO DELETE "SYS:FORTRN.TM"
1995 CLA IAC
1996 CIF 10
1997 JMS I Q200
1998 4
1999 FTRNTM
2000 0
2001 NOP
2002 JMP I DFRTTM
2003
2004 EQUDOT, TEXT '=.'
2005 XPAUSE, TEXT '#PAUSE'
2006 PAGE
2007 \f/REWIND, ENDFILE, BACKSPACE
2008
2009 REWIND, TAD (XREW-XENDF
2010 ENDFIL, TAD (XENDF-XBAK
2011 BAKSPC, TAD (XBAK
2012 DCA REBSUB
2013 JMS I QUCODE
2014 AIFTBL-1 /GET UNIT INTO FAC
2015 JMS I QGENSF /FORCE F MODE
2016 CLA STL RTL
2017 JMS I (OJSR
2018 REBSUB, 0
2019 JMP I QNEXT
2020 \f/ DATA STATEMENT STUFF
2021 DATAST, TAD X16 /SAVE STACK
2022 DCA DSTACK
2023 TAD DATASW /MULTIPLE DATA STMT ?
2024 SZA CLA
2025 JMP FIXDAT-2 /YES, DON'T OUTPUT LABEL
2026 ISZ DATASW /SET DATA SWITCH
2027 JMS I QOTAB /DEFINE ORIGIN SYMBOL
2028 TAD GLABEL
2029 JMS I QOLABEL
2030 TAD (EQUDOT /#GXXXX=.
2031 JMS I QOUTSYM
2032 JMS I QCRLF
2033 CLA CMA /SET VAR TO NONE LEFT
2034 DCA NUMELM
2035 FIXDAT, TAD QXRBUFR /USE XR BUFFER FOR DATA BUFFER
2036 DCA DATPTR
2037 CMA
2038 DCA RCOUNT /SET REPETITION COUNT TO 1
2039 JMP I QNEXT
2040 DREPTC, JMS I QINWORD /GET REPETITION COUNT
2041 CIA
2042 DCA RCOUNT
2043 JMP I QNEXT
2044 DATELM, JMS I QINWORD /GET SIZE OF ELEMENT
2045 CIA
2046 DCA TEMP
2047 JMS I QINWORD /GET ELEMENT
2048 DCA I DATPTR
2049 ISZ DATPTR /INTO DATA BUFFER
2050 ISZ TEMP
2051 JMP .-4
2052 JMP I QNEXT
2053 ENDELM, TAD QXRBUFR /SETUP POINTER
2054 DCA TEMP
2055 MORELM, ISZ NUMELM /ANY MORE FOR THIS VAR?
2056 JMP SAMVAR /YES
2057 TAD DSTACK /CHECK FOR MISMATCH
2058 CIA
2059 TAD X16
2060 SNA CLA
2061 JMP DLERR /OOOPS
2062 ISZ DSTACK /GET TO NEXT VAR
2063 JMS I QOPCDE /%ORG VAR
2064 ORG
2065 TAD I DSTACK /GET VAR
2066 DCA TEMP2
2067 TAD TEMP2
2068 ISZ DSTACK /MOVE TO THE DISPLACEMENT
2069 CDF 10 /OUTPUT VAR
2070 JMS I QOUTNAM
2071 CMA
2072 DCA NUMELM /ASSUME UNDIMENSIONED
2073 CDF 10
2074 ISZ TEMP2 /MOVE TO TYPE WORD
2075 TAD I TEMP2 /GET TYPE
2076 JMS I QSKPIRL /SKIP ON I R L
2077 CLL CMA RTL /YES
2078 TAD (-3
2079 DCA ELMSIZ /NUMBER OF WORDS PER ELEMENT
2080 CLL CML RTR
2081 AND I TEMP2
2082 CDF
2083 SNA CLA
2084 JMP GOTSIZ /NOT DIMENSIONED
2085 CLA IAC /IF DISP = 7777 , WHOLE ARRAY
2086 TAD I DSTACK /LOOK AT DISPLACEMENT
2087 SZA CLA
2088 JMP GOTSIZ+1 /ONLY ONE ELEMENT OF THE ARRAY
2089 CMA
2090 TAD TEMP2 /GET TOTAL SIZE
2091 JMS I QGETSS
2092 IAC
2093 DCA TEMP2
2094 TAD I TEMP2
2095 CIA /THIS IS THE NUMBER OF ELEMENTS
2096 DCA NUMELM
2097 CDF
2098 GOTSIZ, DCA I DSTACK /ZERO DISPLACEMENT
2099 TAD PLUS /OUTPUT +XXXX
2100 JMS I QOCHAR
2101 TAD ELMSIZ /MULTIPLY DISP BY 3 OR 6
2102 CIA
2103 DCA MQ
2104 TAD I DSTACK /GET DISP
2105 JMS I QMUL12
2106 JMS I QNUMBRO /OUTPUT THE ORG ALTERATION
2107 JMS I QCRLF
2108 ISZ DSTACK /MOVE TO NEXT ENTRY
2109 SAMVAR, TAD ELMSIZ /GET SET TO PICK UP AN ELEMENT
2110 DCA NARGS
2111 JMS I QOTAB
2112 JMP .+3 /SKIP ; FIRST TIME
2113 ELMLUP, TAD (273 /SEMICOLON
2114 JMS I QOCHAR
2115 TAD I TEMP /GET A WORD FROM THE BUFFER
2116 ISZ TEMP
2117 JMS I QONUMBR
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?
2122 CIA CLL
2123 TAD TEMP
2124 SNL CLA
2125 JMP MORELM /MORE LEFT
2126 ISZ RCOUNT /REPEAT ?
2127 JMP ENDELM /YES
2128 JMP FIXDAT /NO, BACK FOR MORE DATA
2129 DLERR, JMS I QTTYMSG /DATA LIST ERROR
2130 0414
2131 ELMSIZ=ARG1
2132 NUMELM=TYPE1
2133 DSTACK=BASE1
2134 DATPTR=ARG2
2135 RCOUNT=TYPE2
2136 PAGE
2137 \f/ END STATEMENT PROCESSING
2138
2139 END, TAD FUNCTN /WHAT WAS IT ?
2140 SZA CLA
2141 JMP .+3 /SUBR, RETURN
2142 TAD (STPCOD-1 /MAIN PROG, CALL EXIT
2143 DCA .+2
2144 JMS I QGENCOD
2145 RTNCOD-1
2146 TAD DOTEMP /ANY DO TEMPS ?
2147 TAD M7000
2148 SPA SNA
2149 JMP .+3 /NO
2150 JMS OTMPS /OUTPUT THEM
2151 XDOTMP, DOTMPN
2152 CLA
2153 TAD TMPMAX /ANY EXTRA TEMPS ?
2154 TAD (-TMPBLK
2155 SPA SNA
2156 JMP .+4
2157 IAC /OUTPUT THEM + 1
2158 JMS OTMPS
2159 TEMPN2
2160 CLA
2161 TAD ELCNT /ANY EXTERNAL LITERALS?
2162 SNA
2163 JMP END2 /NO
2164 CIA
2165 DCA ELCNT
2166 TAD EXTLIT /PICK UP THE POINTER
2167 DCA X17
2168 ELLOOP, CDF 10
2169 TAD I X17 /GET SYMBOL NAME
2170 DCA TEMP
2171 TAD I X17 /AND DO TEMP NUMBER
2172 CDF
2173 TAD (-7000 /MINUS BASE
2174 DCA TEMP2
2175 JMS I QOPCDE /ORIGIN
2176 ORG
2177 TAD XDOTMP /OUTPUT #DOTMP
2178 JMS I QOUTSYM
2179 TAD PLUS /+
2180 JMS I QOCHAR
2181 TAD TEMP2 /DISP
2182 CLL CML RAL /*2+1
2183 TAD TEMP2 /*3+1
2184 JMS I QONUMBR
2185 JMS I QCRLF
2186 JMS I QOPCDE /NOW OUTPUT JSR NAME
2187 JSR
2188 TAD TEMP
2189 CDF 10
2190 JMS I QOUTNAM
2191 JMS I QCRLF
2192 ISZ ELCNT
2193 JMP ELLOOP
2194 END2, TAD (232 /^Z
2195 JMS I QOCHAR
2196 JMS I (OUDUMP /DUMP BUFFER
2197 CIF 10
2198 JMS I (7700 /GET USR
2199 10
2200 CIF 10
2201 CLA IAC
2202 JMS I Q200 /CLOSE OUTPUT FILE
2203 4
2204 F1LNAM
2205 FILSIZ, 0
2206 JMP OUERR /BADDDDIE
2207 TAD FILSIZ /FIX INPUT LIST
2208 CLL RTL
2209 RTL
2210 JMP FINAL
2211 ERMSG, 0 /PRINT ERROR MESSAGE ON THE TTY
2212 DCA TEMP /SAVE THE CODE
2213 TAD QM4 /BACK UP THE ERROR
2214 TAD ERRPTR /POINTER
2215 DCA X10
2216 CDF 10
2217 DCA I X10 /ZERO END OF LIST
2218 TAD TEMP /NOW STICK IN THE CODE
2219 DCA I X10
2220 TAD X10 /SAVE THE NEW POINTER
2221 DCA ERRPTR
2222 TAD LINENO /NOW THE LINE NUMBER
2223 DCA I X10
2224 CDF
2225 TAD TEMP /PRINT ERROR CODE
2226 JMS I QTTYP2C
2227 JMS I QTTYP2C /NOW SOME SPACES
2228 TAD QTTYOUT /FUDGE THE OUTPUT
2229 /ROUTINE POINTER
2230 DCA QOCHAR /SO THAT ONUMBR GOES TO
2231 /THE TTY
2232 TAD LINENO /PRINT THE LINE NUMBER
2233 JMS I QONUMBR
2234 TAD (OCHAR /FIXUP OUTPUT POINTER
2235 DCA QOCHAR
2236 JMS I QTTCRLF
2237 JMS I QGENCOD /TRAP IF ERROR EXECUTED
2238 ERCODE-1
2239 JMP I ERMSG
2240 M7000,
2241 OTMPS, -7000 /OUTPUT TEMP BLOCK
2242 DCA TEMP /SAVE SIZE
2243 TAD I OTMPS
2244 ISZ OTMPS
2245 JMS I QOUTSYM /OUTPUT NAME
2246 TAD COMMA
2247 JMS I QOCHAR
2248 JMS I QOPCDE /ORG
2249 ORG
2250 TAD Q256 /.
2251 JMS I QOCHAR
2252 TAD PLUS
2253 JMS I QOCHAR
2254 TAD TEMP
2255 CLL RAL
2256 TAD TEMP /SIZE TIMES THREE
2257 JMS I QONUMBR
2258 JMS I QCRLF
2259 JMP I OTMPS
2260 PAGE
2261 \f/ CHAIN TO RALF
2262 / PASS2O VERSION 4A PT 16-MAY-77
2263 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
2264 /FIXED THE Q OPTION
2265 /PATCH LEVEL IS IN LOCATION 26131
2266 IFZERO OVERLY < /ANOTHER SCORE FOR PAL8
2267 *OVRLAY
2268 NOPUNCH>
2269 IFNZRO OVERLY < /TO TAKE THE LEAD
2270 FIELD 2
2271 ENPUNCH
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
2278 ISZ (7617
2279 DCA I (7617 /ZERO END OF LIST
2280 TAD I RALFSV
2281 CDF 0
2282 SPA CLA /WAS /A SPECIFIED?
2283 JMP I (7605 /YES - GET OUT
2284 CLA IAC
2285 CHNLKP, CIF 10
2286 JMS I Q200
2287 2 /LOOKUP RALF.SV
2288 RALFNM
2289 RALFSV, 7643
2290 JMP I (7605
2291 TAD (6 /**
2292 DCA CHNLKP+2
2293 JMP CHNLKP
2294 RALFNM, 2201;1406;0000;2326 /RALF.SV
2295 PASS3N, 2001;2323;6300;2326 /PASS3.SV
2296
2297 ADD, JMS I QCODE /GENERATE CODE FOR ADD
2298 ADDTBL-6;0
2299 JMP I QNEXT
2300 \f/ EXP OPERATOR
2301 ETYPE, 0
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
2306 CLL RTL
2307 TAD TYPE1 /TYPE1 TIMES TEN
2308 TAD TYPE2 /**
2309 CLL RAL
2310 TAD (EXPTBL-15 /POINTER TO ENTRY MINUS ONE
2311 DCA X10
2312 CDF 10
2313 TAD I X10 /GET RESULTING TYPE
2314 SNA
2315 JMP I (OTERR /BAD IF THIS WORD IS ZERO
2316 DCA ETYPE /SAVE THE TYPE
2317 TAD I X10 /GET THE SUBR NAME
2318 CDF
2319 DCA I (ESUBR+2 /PUT IT INTO ITS PLACE
2320 TAD TYPE1 /GET INTO CORRECT MODE
2321 JMS SETMOD
2322 TAD ARG1 /IS ARG 1 ALREADY IN THE AC
2323 SNA CLA
2324 JMP .+5 /YES, SKIP THE LOAD
2325 JMS I QOPCOD /OTHERWISE LOAD IT
2326 FLDA
2327 JMS I QOADDR
2328 ARG1
2329 JMS I QOINS /FSTA #BASE
2330 FSTA;XBASE
2331 TAD TYPE2 /SET MODE FOR ARG 2
2332 JMS SETMOD
2333 JMS I QOPCOD /NOW LOAD IT
2334 FLDA
2335 JMS I QOADDR
2336 ARG2
2337 JMS I QOINS /EXTERN FOR THE SUBR
2338 EXTERN;ESUBR
2339 JMS I QOINS /JSA TO THE SUBR
2340 JSA;ESUBR
2341 DCA I X16 /RESULT IS THE AC
2342 TAD ETYPE /WITH THIS AS THE TYPE
2343 DCA I X16
2344 DCA I X16
2345 TAD ETYPE /SET FMODE CORRECTLY
2346 JMS I QSKPIRL
2347 SKP
2348 CLA IAC /RETURNED IN F MODE
2349 DCA FMODE
2350 JMP I QNEXT
2351 SETMOD, /SET MODE TO CORRESPOND
2352 /TO THE ARG
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
2357 JMP I SETMOD
2358 JMS I QGENSE
2359 JMP I SETMOD
2360 FINAL, CIA
2361 IAC
2362 DCA FILDEV /SAVE RALF INPUT SPEC
2363 CMA
2364 DCA I X7746 /DON'T SAVE CORE ARROUND CHAIN
2365 JMS I (DFRTTM /DELETE FORTRN.TM
2366 CDF 10
2367 TAD I Q7605 /IS THERE A LISTING FILE?
2368 SNA CLA
2369 JMP GORALF /NO, JUST CHAIN TO RALF
2370 CIF 10
2371 CDF
2372 CLA IAC
2373 JMS I Q200 /FIND PASS 3
2374 2
2375 PASS3N
2376 PAS3SV, 0
2377 JMP I Q7605
2378 TAD PAS3SV-1 /MOVE BLOCK TO CHAIN COMMAND
2379 IAC /SKIP OVER CORE CONTROL BLOCK
2380 DCA X7746
2381 JMS I DEVH /READ IN PASS 3
2382 NPPAS3
2383 SPASS3, 400
2384 X7746, 7746
2385 JMP I Q7605
2386 JMP I SPASS3 /GO DO PASS 3
2387 PAGE
2388 \f/ I/O OPEN AND CLOSE
2389
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
2396 DCA NARGS /SAVE IT
2397 ISZ STRTIO /MOVE TOHE NME
2398 TAD NARGS /BACKUP STACK BY THIS MUCH
2399 TAD NARGS /THREE OR SIX
2400 TAD NARGS
2401 TAD X16
2402 DCA X15
2403 TAD X15
2404 DCA TEMP /FUNCTION NAME GOES HERE
2405 JMS I QOPCDE /EXTERN FOR SUBR
2406 EXTERN
2407 TAD I STRTIO /GET SUBROUTINE NAME
2408 JMS I QOUTSYM /OUTPUT IT
2409 JMS I QCRLF
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
2414 NOP
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
2420 -2;XREADO
2421 FMTWR1, DCA INPUT /SET SWITCHES
2422 DCA BINARY
2423 JMS STRTIO
2424 -2;XWRITO
2425 BINRD1, CLA IAC
2426 DCA BINARY
2427 CLA IAC
2428 DCA INPUT
2429 JMS STRTIO
2430 -1;XRUO
2431 BINWR1, DCA INPUT
2432 CLA IAC
2433 DCA BINARY
2434 JMS STRTIO
2435 -1;XWUO
2436 WCLOSE, CLA STL RTL /TRAP3 HERE TOO**
2437 JMS OJSR /OUTPUT TRAP3 #WUC
2438 XWUC
2439 DCA IOSTMT /KILL IO SWITCH
2440 JMP I QNEXT
2441 OJSR, 0 /OUTPUT EXTERN THEN JSR OR TRAP3
2442 CLL RAL /AC ON ENTRY IS 0 (JSR), 1 (JSA) OR 2 (TRAP3).
2443 TAD (JSR
2444 DCA OJSROP
2445 JMS I QOPCDE /FIRST EXTERN
2446 EXTERN
2447 TAD I OJSR
2448 JMS I QOUTSYM
2449 JMS I QCRLF
2450 JMS I QOPCDE /THEN JSR
2451 OJSROP, 0
2452 TAD I OJSR
2453 ISZ OJSR
2454 JMS I QOUTSYM
2455 JMS I QCRLF
2456 JMP I OJSR
2457
2458 XWUC, TEXT '#RENDO' /**
2459 XREADO, TEXT '#READO'
2460 XWRITO, TEXT '#WRITO'
2461 XRUO, TEXT '#RUO'
2462 XWUO, TEXT '#WUO'
2463 RDRTNE, TEXT /#RSVO/
2464 RDDRTN, TEXT /#RFDV/
2465 FTRNTM, 0617;2224;2216;2415 /FORTRN.TM
2466 \fDNA, JMS I QCODE /AND CODE
2467 ANDTBL-6;0
2468 JMP I QNEXT
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
2472 CLL
2473 TAD QM63
2474 SNL CLA
2475 JMP I (IOTYPE /BAD TYPE
2476 JMP I QNEXT
2477 PAUZE, JMS I QUCODE /GET ARG INTO FAC
2478 AIFTBL-1
2479 JMS I QGENCOD /OUTPUT JSR
2480 PAZCOD-1
2481 JMP I QNEXT
2482 PAGE
2483 \f/DIRECT ACCESS I/O
2484
2485 DARD1, CLA IAC /SET SWITCHES
2486 DCA INPUT
2487 CLA IAC
2488 DCA BINARY /SAME AS UNFORMATTED
2489 JMS I (STRTIO /GENERATE CALL
2490 -2;XRDAO
2491 DAWR1, DCA INPUT /SAME AS UNFORMATTED WRITE OPEN
2492 CLA IAC
2493 DCA BINARY
2494 JMS I (STRTIO /CALL
2495 -2;XWDAO
2496 DEFFIL, TAD XDFARG /FAKE A CALL
2497 DCA I (STRTIO /TO SKIP THE ISZ IOSTMT
2498 JMP I (STRTIO+2
2499 XDFARG, .+1
2500 -4;XDEF
2501 XDEF, TEXT '#DEF'
2502 XRDAO, TEXT '#RDAO'
2503 XWDAO, TEXT '#WDAO'
2504 \f/ RANDOM UNFITTING STUFF
2505 RETURN, JMS I QGENCOD /JA #RTN
2506 RTNCOD-1
2507 JMP I QNEXT
2508 GENSTF, 0 /GENERATE STARTF IF IN E MODE
2509 TAD FMODE /LOOK AT THE SWITCH
2510 SZA CLA
2511 JMP I GENSTF /ALREADY THERE
2512 ISZ FMODE /SET SWITCH
2513 JMS I QOPCOD /OUTPUT STARTF
2514 STARTF
2515 JMS I QCRLF
2516 JMP I GENSTF /RETURN
2517 NOT, JMS I QUCODE /.NOT.
2518 NOTTBL-1
2519 JMP I (RELGM1
2520 SUB, JMS I QCODE /SUBTRACT
2521 SUBTBL-6;0
2522 JMP I QNEXT
2523 MUL, JMS I QCODE /MULTIPLY
2524 MULTBL-6;0
2525 JMP I QNEXT
2526 ASFDEF, CLA IAC /SET SWITCH FOR ASF PROLOG
2527 DCA ASFSWT
2528 JMP I QNEXT
2529 OINS, 0 /OUTPUT TAB OPCODE TAB
2530 /ADDRESS CRLF
2531 DCA WHATAC /ZAPS AC
2532 JMS I QOTAB
2533 TAD I OINS /GET OPCODE
2534 ISZ OINS
2535 JMS I QOUTSYM
2536 JMS I QOTAB
2537 TAD I OINS /GET ADDRESS
2538 SZA
2539 JMS I QOUTSYM
2540 JMS I QCRLF /END LINE
2541 ISZ OINS
2542 JMP I OINS
2543 \f/ CODE GENERATOR FOR STORE
2544 STORE, JMS I QGARGS /GET ARGS FOR STORE
2545 JMP I (OTERR
2546 TAD ARG1 /KILL ANY XR
2547 /EXPRS. INVOLVING
2548 JMS I QCHKXR /THE VARIABLE BEING STORED
2549 TAD ARG2 /IS SECOND ARG IN AC ?
2550 SNA CLA
2551 TAD Q5 /YES, ADD 5 TO TYPE2
2552 TAD TYPE2
2553 DCA TYPE2
2554 TAD TYPE1 /TYPE1 TIMES TEN
2555 CLL RTL
2556 TAD TYPE1
2557 CLL RAL
2558 TAD TYPE2 /PLUS TYPE2
2559 TAD (STRTBL-13 /PLUS TABLE BASE
2560 DCA SSKEL /GIVES ENTRY ADDRESS
2561 CDF 10
2562 TAD I SSKEL /POINTER TO SKELETON
2563 DCA SSKEL
2564 JMS I QGENCOD /GENERATE CODE
2565 SSKEL, 0
2566 TAD ASFSWT /IS THIS END OF ASF ?
2567 SZA CLA
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
2571 SKP
2572 CLA IAC
2573 DCA FMODE
2574 JMS I QOPCOD /OUTPUT STORE
2575 FSTA
2576 JMS I QOADDR /ADDRESS FIELD
2577 ARG1
2578 TAD ARG1 /REMEMBER THE AC
2579 CIA
2580 DCA WHATAC /(REMEMBER THE
2581 TAD BASE1 /ALAMO ?)
2582 CIA /(WOULD YOU
2583 DCA WHATBS /BELIEVE THE MAINE ???)
2584 ISZ ARG1 /GO TO TYPE WORD
2585 CDF 10
2586 CLL /IF ARG1 IS
2587 TAD ARG1 /A SS'D REFNCE
2588 TAD QM63 /DON'T
2589 SZL CLA /BOTHER CHECKING
2590 TAD I ARG1 /LOOK AT SOME BITS
2591 CDF
2592 AND (3400 /DIM,EXT, OR ASF ?
2593 SNA CLA
2594 JMP I QNEXT
2595 JMS I QTTYMSG /ATTEMPT TO STORE IN
2596 1720 /EXTERNAL OR ASF
2597 FLDAP, TEXT 'FLDA%'
2598 PAGE
2599 \f/ARITHEMTIC STATEMENT FUNCTIONS (BLAH!)
2600
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
2606 DCA X16
2607 CLA CMA /SET ASF SWITCH
2608 DCA ASFSWT
2609 TAD TMPMAX /USE UNIQUE TEMPS
2610 IAC
2611 DCA TMPCNT /FOR ALL ASF'S
2612 JMS I QXRTBL /AND FORGET XR'S
2613 JMS I QOPCDE /JA AROUND
2614 JA
2615 TAD GLABEL /SAVE ARROUND LABEL
2616 DCA ASFSKP
2617 ISZ GLABEL /BUMP LABEL GENERATOR
2618 TAD ASFSKP /PUT LABEL AS ADDRESS OF JA
2619 JMS I QOLABEL
2620 JMS I QCRLF
2621 TAD GLABEL /FUNCTIONS XR'S O HERE
2622 JMS I QLABEL /OUPTUT THE LABEL
2623 JMS I QOINS /#GXXXX, ORG .+10
2624 ORG;DP8
2625 TAD BASE1 /NOW OUTPUT FUNCTION NAME
2626 CDF 10
2627 JMS I QOUTNAM
2628 TAD COMMA /AS TAG
2629 JMS I QOCHAR /OF START OF FUNCTION
2630 JMS I QOPCDE /SETX
2631 XSET
2632 TAD GLABEL /TO THE GENERATED LABEL
2633 ISZ GLABEL
2634 JMS I QOLABEL
2635 JMS I QCRLF
2636 JMS I QOINS /LDX 0,1
2637 LDX;ZEROC1
2638 JMS I QGENCOD /STARTD
2639 SD-1 /JUST LIKE A SUBROUTINE
2640 /ISN'T IT ?
2641 JMS I QOINS /FLDA #BASE
2642 FLDA;XBASE /GET RETURN JUMP
2643 JMS I QOPCDE /STORE IT AHEAD
2644 FSTA
2645 TAD GLABEL /USING GENERATED LABEL
2646 JMS I QOLABEL
2647 JMS I QCRLF
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
2653 DCA ARG2
2654 TAD I X15
2655 DCA TYPE2
2656 ISZ X15
2657 TAD TYPE2 /IS IT SINGLE OR DOUBLE?
2658 JMS I QSKPIRL
2659 JMP ASFASE /DOUBLE
2660 JMS I QGENCOD /STARTF
2661 SF-1
2662 CLA IAC
2663 ARGSV, DCA FMODE /SET FMODE APPROPRIATELY
2664 JMS I QOINS /FLDA% #BASE+3
2665 FLDAP;XBASP3 /GET THE VALUE
2666 JMS I QOPCOD
2667 FSTA /AND SAVE IT
2668 JMS I QOADDR
2669 ARG2
2670 ISZ NARGS /ANY MORE ARGS ?
2671 SKP
2672 JMP I QNEXT /NO, END OF ASF PROLOG
2673 JMS I QGENCOD /STARTD
2674 SD-1
2675 JMP ASFARG /NEXT ARG
2676 ASFASE, JMS I QGENCOD /STARTE
2677 SE-1
2678 JMP ARGSV
2679 ASFEND, 0 /HANDLE END OF A.S.F.
2680 TAD ASFSWT /IS THIS END OF ASF ?
2681 SNA CLA
2682 JMP PTCH /V3C NO
2683 DCA ASFSWT /CLEAR SWITCH
2684 JMS I QOINS /RESET XR'S
2685 XSET;ZXR
2686 TAD GLABEL /OUTPUT SPACE FOR RETURN ADDR
2687 ISZ GLABEL
2688 JMS I QLABEL /OUPTUT THE LABEL
2689 JMS I QOINS /ORG .+2
2690 ORG;DOTP2
2691 TAD ASFSKP /OUTPUT SKIP ARROUND LABEL
2692 JMS I QLABEL /OUPTUT THE LABEL
2693 JMS I QCRLF
2694 TAD ASFMOD /RESET MODE SWITCH
2695 DCA FMODE
2696 TAD TMPMAX /UNIQUE TEMPS
2697 IAC
2698 DCA TEM /V3C MUST BE USED
2699 JMS I QXRTBL /AND XR'S LOST
2700 PTCH, TAD TEM /V3C
2701 DCA TMPCNT /V3C
2702 JMP I ASFEND /RETURN
2703 ASFMOD, 0
2704 ASFSKP, 0
2705 IOFUN, JMS I QOPCDE /CALLED BY TRAP3,NOT JSR**
2706 TRAP3
2707 TAD I TEMP
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
2711 PAGE
2712 \f/ I/O LIST ELEMENT
2713
2714 IOLMNT, JMS I QGARG /GET THE ARG
2715 JMP IOTYPE /TYPE ERROR
2716 DCA IOLOOP /CLEAR LOOP SWITCH
2717 CLL STA RTL /-3
2718 TAD TYPE1
2719 DCA TYPE1 /TYPE1 = 0 IF COMPLEX, 1 IF D.P.
2720 TAD ARG1 /ADDR OF TYPE WD
2721 CLL IAC
2722 DCA ARG2
2723 TAD ARG1 /LOOK AT ARG
2724 TAD QM63
2725 SNL CLA
2726 JMP NOLOOP /NOT ARRAY OUTPUT
2727 CDF 10
2728 CLL CML RTR /IS IT DIMENSIONED ?
2729 AND I ARG2
2730 CDF
2731 SNA CLA
2732 JMP NOLOOP /NO, NO LOOP
2733 ISZ IOLOOP /SET SWITCH
2734 TAD ARG1 /GET TO SS
2735 JMS I QGETSS
2736 IAC /TOTAL SIZE WORD
2737 DCA BASE1
2738 TAD I ARG2 /IS THIS ARRAY AN ARG ?
2739 AND Q20
2740 DCA ARGIO /SET SWITCH
2741 TAD I BASE1 /IS IT VARIABLY DIMENSIONED ?
2742 SNA
2743 JMP I (VDAIO /YES, MUST COMPUTE SIZE
2744 DCA BASE2 /SAVE SIZE
2745 CDF
2746 JMS I QOPCDE /PUT SIZE IN XR 1
2747 LDX
2748 TAD Q255
2749 JMS I QOCHAR /-
2750 TAD BASE2
2751 JMS I QONUMBR
2752 TAD COMMA
2753 JMS I QOCHAR
2754 TAD (261
2755 JMS I QOCHAR
2756 JMS I QCRLF
2757 TAD ARGIO /IS IT AN ARG ?
2758 SZA CLA
2759 JMP I (ARGIOA /YES
2760 OLLABL, TAD GLABEL /OUTPUT LABEL
2761 JMS I QOLABEL
2762 DCA I (XRBUFR+20 /KILL XR1 ENTRY
2763 TAD COMMA
2764 JMS I QOCHAR
2765 NOLOOP, TAD INPUT /INPUT OR OUTPUT ?
2766 SNA CLA
2767 JMP OUTV /OUTPUT
2768 JMS FIXCAL /SET PTR FOR OJSR**
2769 JMS I (DUMSUB /NOW THE STORE
2770 FSTA
2771 TAD ARG1 /KILL ASSOCIATED
2772 JMS I QCHKXR /XR EXPRESSIONS
2773 CDSFLP, TAD TYPE1 /IS IT C OR D ?
2774 CLL RAR
2775 SZA CLA
2776 JMP ENDLUP /NO, NO STARTE
2777 JMS I QGENCOD
2778 SF-1
2779 ENDLUP, TAD IOLOOP /IS THERE A LOOP ?
2780 SNA CLA
2781 JMP I QNEXT /NO, DO NEXT LIST ELEMENT
2782 JMS I QOPCDE /YES, OUTPUT JXN
2783 JXN
2784 TAD GLABEL
2785 ISZ GLABEL /OUTPUT LABEL
2786 JMS I QLABEL /OUPTUT THE LABEL
2787 TAD (261
2788 JMS I QOCHAR
2789 TAD PLUS /OUTPUT PLUS (FOR
2790 /INCREMENT DUMMY)
2791 JMS I QOCHAR
2792 JMS I QCRLF
2793 JMP I QNEXT /DO NEXT LIST ELEMENT
2794 OUTV, TAD TYPE1 /D OR C ?
2795 CLL RAR
2796 SZA CLA
2797 JMP .+3 /NO, NO STARTF NECCESSARY
2798 JMS I QGENCOD
2799 SE-1
2800 JMS I (DUMSUB /OUTPUT FLDA
2801 FLDA
2802 JMS FIXCAL
2803 JMP CDSFLP /THEN STARTF AND JXN IF ANY
2804 FIXCAL, 6401
2805 TAD TYPE1 /IF VARIABLE IS COMPLEX,
2806 CIA /OR IF VARIABLE IS DOUBLE AND
2807 SZA /I/O IS BINARY,
2808 TAD BINARY /GENERATE A JSR #RFDV
2809 SNA CLA /ELSE GENERATE A TRAP3 #RSVO
2810 JMP BINDIO
2811 CLA STL RTL /SET PTR
2812 JMS I (OJSR /NOW GO DO IT
2813 RDRTNE /HERE'S THE NAME
2814 JMP I FIXCAL
2815 BINDIO, JMS I (OJSR
2816 RDDRTN
2817 JMP I FIXCAL
2818
2819 IOTYPE, JMS I QTTYMSG /IO TYPE ERROR
2820 1124
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
2824 CDF 10
2825 JMS I QOSNUM /OUTPUT IT
2826 TAD COMMA
2827 JMS I QOCHAR
2828 JMS I QXRTBL /KILL XR TABLE
2829 DCA WHATAC /AND AC AT LABEL
2830 JMP I QNEXT
2831 PAGE
2832 \f/ I/O LIST ELEMENT
2833
2834 VDAIO, CLL CMA RAL /GET ADDR OF NUMBER OF DIMS
2835 TAD BASE1
2836 DCA X10
2837 TAD I X10 /GET DIM COUNT
2838 CIA
2839 DCA NARGS
2840 ISZ X10 /SKIP SIZE
2841 ISZ X10 /AND MAGIC NUMBER
2842 ISZ X10 /AND LITERAL NUMBER
2843 TAD (FLDA /LOAD FIRST DIM
2844 SKP
2845 GSIZLP, TAD (FMUL /MULTIPLY THE REST
2846 DCA OPCIO
2847 CDF 10
2848 TAD I X10 /GET THE NEXT DIMENSION
2849 DCA TYPE2
2850 CDF
2851 JMS I QOPCOD /OUTPUT OPCODE
2852 OPCIO, 0
2853 JMS I QOADDR /NOW THE DIMENSION
2854 TYPE2
2855 ISZ NARGS
2856 JMP GSIZLP /KEEP GOING
2857 JMS I QOPCOD /NEGATE THE FAC
2858 FNEG
2859 JMS I QCRLF
2860 JMS I QGENCOD /PUT THE COUNT INTO XR1
2861 ATX1-1
2862 ARGIOA, JMS I QGENCOD /PUT -1 INTO XR 2
2863 LXM1C2-1
2864 JMS I QOPCDE /LOAD THE ARG POINTER -
2865 FLDA /CONST
2866 DCA I (XRBUFR+40 /KILL XR 2 ENTRY
2867 TAD ARG1
2868 CDF 10
2869 JMS I QOUTNAM
2870 JMS I QCRLF
2871 JMS I QOPCDE /NOW ADD THE MAGIC NUMBER
2872 FADD
2873 TAD QLITRL /OUTPUT #LIT+XXXX
2874 JMS I QOUTSYM
2875 CDF 10
2876 ISZ BASE1
2877 ISZ BASE1
2878 TAD I BASE1
2879 CDF
2880 JMS I QONUMBR
2881 JMS I QCRLF
2882 JMS I QOPCDE
2883 FSTA /NOW STORE IN #BASE+3
2884 TAD (XBASP3
2885 JMS I QOUTSYM
2886 JMS I QCRLF
2887 JMS I QGENCOD /STARTF
2888 SF-1
2889 JMP I (OLLABL /NOW THE INSIDE OF THE LOOP
2890 DUMSUB, 0 /OUTPUT FLDA OR FSTA
2891 /WITH SE IF NEEDED
2892 TAD I DUMSUB /GET THE OPCODE
2893 DCA LDASTA
2894 ISZ DUMSUB
2895 TAD TYPE1 /MUST WE SE ?
2896 CLL RAR /TYPE1 IS 0 IF C, 1 IF D
2897 SNA CLA
2898 TAD Q3 /MULTIPLIER IS 6
2899 TAD Q3 /OR 3
2900 DCA MQ
2901 JMS I QOPCOD /FLDA OR FSTA
2902 LDASTA, 0
2903 TAD IOLOOP /IS IT A LOOP ?
2904 SNA CLA
2905 JMP EZVAR /NO
2906 TAD ARGIO /IS IT AN ARG ?
2907 SZA CLA
2908 JMP IBASP3 /YES, INDIRECT THROUGH #BASE+3
2909 JMS I QOTAB
2910 TAD ARG1
2911 CDF 10 /OUTPUT NAME
2912 JMS I QOUTNAM
2913 TAD (255 /-
2914 JMS I QOCHAR
2915 TAD BASE2 /NEGATIVE OF SIZE
2916 CIA
2917 JMS I QMUL12 /TIMES 6 OR 3
2918 JMS I QNUMBRO
2919 TAD COMMA /COMMA SEVEN
2920 JMS I QOCHAR
2921 TAD (261
2922 JMS I QOCHAR
2923 JMS I QCRLF
2924 JMP I DUMSUB /RETURN
2925 EZVAR, JMS I QOADDR /ITS A SCALAR
2926 ARG1
2927 JMP I DUMSUB
2928 IBASP3, TAD (245 /INDIRECT THROUGH #BASE+3
2929 JMS I QOCHAR
2930 JMS I QOTAB
2931 TAD (XBPC2P /FLDA% #BASE+3,2+
2932 JMS I QOUTSYM
2933 JMS I QCRLF
2934 JMP I DUMSUB
2935 XBPC2P, TEXT '#BASE+3,2+'
2936 OR, JMS I QCODE
2937 ORTABL-6;0
2938 JMP I (RELGEN
2939 XOR, JMS I QCODE
2940 EQVTBL-6;0
2941 JMP I (RELGEN
2942 DOTP2, TEXT '.+2'
2943 ZXR, TEXT '#XR'
2944 PAGE
2945 \f/ ASSIGNED GOTO AND ASSIGN
2946
2947 AGOTO, JMS GTSTUF /LOOK AT THE ASSIGNED VAR
2948 JMS I QGENCOD /GENERATE A JAC
2949 AGTCOD-1
2950 JMP I QNEXT
2951 ASSIGN, JMS I QGARG /GET THE ASSIGN VAR
2952 JMP GTTYPE
2953 CLL CMA RTL /MUST BE I OR R
2954 TAD TYPE1
2955 SMA CLA
2956 JMP GTTYPE /GOTO TYPE ERROR
2957 JMS I QGENCOD /GENERATE THE ASSIGN CODE
2958 ASNCOD-1
2959 JMS I (JAGEN
2960 JMS I QGENCOD /NOW STORE IT
2961 ASTOR-1
2962 JMP I QNEXT
2963 \f/ OPTIMIZER SUBROUTINES
2964 CHEKXR, 0 /KILL XR EXPRS
2965 CIA /ASSOCIATED WITH THIS VAR
2966 DCA KILVAR /SINCE IT HAS
2967 /JUST BEEN CHANGED
2968 TAD (-7 /LOOK AT XR 1 THRU 7
2969 DCA TEMP /COUNT
2970 TAD (XRBUFR+20 /POINTER
2971 DCA TEMP2
2972 KILLUP, TAD I TEMP2 /GET NEXT XR
2973 /EXPR. INDICATOR
2974 SNA CLA
2975 JMP EOKL /NOTHING HERE
2976 TAD TEMP2 /GET POINTER
2977 DCA X13 /INTO AN XR
2978 TAD I X13 /GET ADDR OF DIB
2979 DCA DIMPTR /SAVE IT
2980 CDF 10 /FIELD OF SYMBOL TABLE
2981 TAD I DIMPTR /GET NUMBER OF
2982 /DIMENSIONS
2983 CMA /COMPLIMENTED
2984 DCA NARGS /SAVE IT
2985 CDF /BACK TO FIELD OF XRBUFR
2986 CHKKIL, ISZ NARGS /CHECK 1 LESS
2987 /THAN THE NUMBER
2988 SKP /OF DIMENSIONS
2989 JMP EOKL
2990 TAD I X13 /LOOK AT NEXT
2991 /ELEMENT OF EXPR
2992 TAD KILVAR /IS IT THE VAR
2993 /JUST CHANGED ?
2994 SNA CLA
2995 DCA I TEMP2 /YES, KILL THIS EXPRESSION
2996 JMP CHKKIL /LOOP
2997 EOKL, TAD TEMP2 /DO NEXT XR
2998 TAD Q20
2999 DCA TEMP2 /BUMP POINTER BY 16
3000 ISZ TEMP
3001 JMP KILLUP
3002 JMP I CHEKXR /RETURN
3003 KILVAR,
3004 XRTABL, 0 /CLEAR OR RESET
3005 /XR TABLE FLAGS
3006 DCA TYPE /0=CLEAR 1=RESET
3007 TAD (-7 /DO XR1 THRU 7
3008 DCA TEMP /COUNT
3009 TAD (XRBUFR+20 /POINTER
3010 DCA TEMP2
3011 XRTLUP, TAD I TEMP2 /GET INDICATOR
3012 SNA CLA
3013 JMP .+3 /DON'T CHANGE IF ZERO
3014 TAD TYPE /OTHERWISE SET TO
3015 DCA I TEMP2 /'USED BY
3016 /PREVIOUS STMT'
3017 TAD TEMP2 /GET TO NEXT ONE
3018 TAD Q20
3019 DCA TEMP2 /BUMPING BY 16
3020 ISZ TEMP
3021 JMP XRTLUP /LOOP
3022 JMP I XRTABL /DONE
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 ?
3028 TAD WHATAC
3029 SZA CLA
3030 JMP DOLOAD /NO, MUST LOAD
3031 TAD LODARG /GET ADDRESS
3032 IAC /OF BASE
3033 DCA ARG /IN CASE SS'D
3034 TAD I ARG /DOES BASE MATCH?
3035 TAD WHATBS
3036 SNA CLA
3037 JMP I LOADA /OK, DON'T LOAD
3038 DOLOAD, JMS I QOPCOD /GENERATE FLDA
3039 FLDA
3040 JMS I QOADDR /ADDRESS
3041 LODARG, 0
3042 JMP I LOADA
3043 PAGE
3044 \f/ INTER PASS EQUATES
3045 BLNKCN=21
3046 ALIST=23
3047 INTLST=60
3048 FPLIST=56
3049 DPLIST=57
3050 CMPLST=61
3051 HOLIST=55
3052 SNLIST=62
3053 ONEI=63
3054 THREE=70
3055 SIX=75
3056 TRUE=102
3057 \f/ START PASS 2 (INTER PASS COMMUNICATION)
3058 IFNZRO OVERLY <
3059 FIELD 0
3060 NOPUNCH
3061 *OVRLAY>
3062 IFZERO OVERLY <
3063 FIELD 0
3064 ENPUNCH
3065 *OVRLAY>
3066 START2, JMP I Q7605 /RETURN BUT DON'T SAVE CORE
3067 TAD I X10 /PICK UP NEXT FROM PASS 1
3068 DCA X17
3069 TAD X17 /SAVE POINTER TO
3070 /EXTERNAL LITERALS
3071 DCA EXTLIT
3072 TAD I X10 /PASS ONE STACK LEVEL
3073 DCA X11
3074 TAD I X10 /TEMP FILE START
3075 DCA INBLOK
3076 TAD I X10 /AND SIZE
3077 CMA
3078 DCA INRCNT
3079 TAD I X10 /START OF PASS2O.SV
3080 DCA PASS2O
3081 TAD I X10 /START OF OUTPUT FILE
3082 DCA FILBLK /SAVE IT FOR CHAINING TO RALF
3083 TAD FILBLK
3084 DCA OBLOCK
3085 TAD I X10
3086 DCA OSIZE /ALSO MAX SIZE
3087 TAD I X10 /PICK UP PROG NAME
3088 DCA PROGNM
3089 TAD I X10
3090 DCA ARGLST /AND ARG LIST ADDR
3091 TAD I X10 /AND
3092 /FUNCTION/SUBROUTINE/MAIN SWITCH
3093 DCA FUNCTN
3094 TAD I X10 /GET DP HARDWARE SWITCH
3095 DCA DPUSED
3096 TAD I X10 /CHECK FOR CROSSED VERSIONS
3097 TAD VERS
3098 SZA CLA
3099 JMP VERROR /VERSION ERROR
3100 STA STL /V3C
3101 DCLOOP, TAD X11 /V3C THIS ADD CLEARS THE LINK
3102 DCA X11 /V3C
3103 TAD X11
3104 TAD (-STACK1
3105 SNL CLA
3106 JMP PSN /GO DO STMT NUMBERS
3107 TAD I X11 /GET DO LOOP ENDING STMT NUMBER
3108 IAC
3109 DCA X10
3110 CDF 10
3111 TAD (0416 /DN DO END MISSING
3112 JMS NPRNT /GO PRINT THE MESSAGE
3113 /AND THE NUMBER
3114 CDF
3115 CLL CMA RTL
3116 JMP DCLOOP /V3C BACK UP 2
3117 PSN, TAD (SNLIST /PROCESS STMT NUMBERS
3118 CDF 10
3119 SNCLUP, DCA ENTRY /SAVE NEW ENTRY ADDR
3120 TAD I ENTRY /GET ADDR OF NEXT ENTRY
3121 SNA
3122 JMP SNDONE /NO MORE STMT NUMBERS
3123 IAC
3124 DCA TEMP /ADDR OF TYPE WORD
3125 TAD I TEMP /WAS STMT NUMBER DEFINED?
3126 SPA CLA
3127 JMP SNDEFN /YES
3128 TAD TEMP
3129 DCA X10
3130 TAD (2523 /PRINT US MESSAGE
3131 JMS NPRNT
3132 SNDEFN, TAD (0110 /SET TYPE WORD
3133 DCA I TEMP
3134 TAD I ENTRY /PROCEED
3135 JMP SNCLUP
3136 SNDONE, CDF
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)
3141 SNA CLA
3142 JMP BDSTUF /IT IS
3143 JMS I (TYPRTN /DO IMPLICIT TYPING
3144 IMPLCT
3145 JMS I (TYPRTN /REMOVE SUB ARGS FROM LIST
3146 SUBARG
3147 JMS I (TYPRTN /EXTERNALS
3148 EXTRNL
3149 JMP I (PROLG1 /MORE PROLOG
3150 BDSTUF, TAD I (BDSWIT /SET UP SWITCH
3151 DCA I (PROLG2
3152 TAD (END2 /ALTER END CODE
3153 CDF 10
3154 DCA I (XEND
3155 CDF 0
3156 DCA NODBUG /NO ISN'S
3157 JMP I (HOLDUN /DO SOME STUFF
3158 SUBARG, 0 /REMOVE ARGS FROM ST
3159 TAD I TYPE
3160 AND Q20 /CHECK ARG BIT
3161 SNA CLA
3162 JMP I SUBARG
3163 JMS UNHOOK
3164 JMP TFUDGE
3165
3166 UNHOOK, 0
3167 TAD I ENTRY
3168 DCA I OENTRY
3169 TAD BUCKET
3170 DCA I ENTRY
3171 JMP I UNHOOK
3172
3173 VERROR, TAD (2605 /PRINT VE (VERSION ERROR)
3174 JMS I QTTYP2C
3175 JMS I QTTCRLF
3176 JMP I Q7605
3177 PAGE
3178 \f/ GENERATE ARGUMENT STORAGE
3179
3180 PROLG1, JMS I (INS2 / %JA #ST
3181 JA;XST
3182 JMS I (INS /#XR, %ORG .+10
3183 XXR;ORG;DP8
3184 JMS I QOPCDE / %TEXT #NAMEXX#
3185 TEXTX
3186 TAD PLUS
3187 JMS I QOCHAR
3188 CDF 10
3189 TAD PROGNM
3190 JMS I QOUTNAM
3191 JMS I (FILL /FILL WITH BLANKS
3192 TAD PLUS
3193 JMS I QOCHAR
3194 ISZ PROGNM
3195 JMS I QCRLF
3196 JMS I (INS /#RET, %SETX #XR
3197 XRET;SETX;XXR
3198 JMS I (INS2 / %SETB #BASE
3199 SETB;XBASE
3200 JMS I (INS2 / %JA .+3
3201 JA
3202 XDP3, DP3
3203 JMS I (INS /#BASE, %ORG .+6
3204 XBASE;ORG;DP6
3205 TAD ARGLST /ANY ARGS ?
3206 SNA
3207 JMP NOARGS /NO, SKIP THIS STUFF
3208 DCA X10 /SAVE POINTER TO ARG LIST
3209 CDF 10 /HOW MANY ?
3210 TAD I ARGLST
3211 CIA
3212 DCA NARGS /THIS MANY
3213 DCA TEMP2 /ARRAY ARG COUNTER
3214 ARGLP1, JMS PLSUB1 /OUTPUT DEFS FOR ARRAY
3215 /ARGS FIRST
3216 SNA CLA /SINCE THEY MUST BE
3217 /INDIRECTABLY
3218 JMP NOARAY /REFERENCABLE
3219 ISZ TEMP2
3220 NOARAY, ISZ NARGS
3221 JMP ARGLP1 /PROCESS ENTIRE ARG LIST
3222 CDF 10
3223 TAD I ARGLST /GO THRU ARGS AGAIN
3224 CIA CLL
3225 DCA NARGS
3226 TAD ARGLST
3227 DCA X10
3228 TAD TEMP2 /HOW MANY ARRAY ARGS ?
3229 TAD QM6
3230 SNA
3231 JMP NISA /NO INDIRECT LOCS LEFT
3232 /FOR SCALARS
3233 DCA TEMP2
3234 SZL CLA
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
3240 SKP
3241 JMP NISA2 /NO, THE REST MUST MOVE VALUES
3242 NOSCLR, ISZ NARGS /LOOP SOME MORE
3243 JMP ARGLP2
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
3249 /STUFF,THEN REST
3250 NISA, JMS I (PLSUB2 /GET PAST THE TRACEBACK STUFF
3251 ARGLP3, TAD XM3 /GENERATE ORG .+6 FOR D OR C
3252 DCA XNOP
3253 JMS PLSUB1 /OUTPUT REMAINING
3254 /SCALAR ARG SPACE
3255 SZA CLA
3256 JMP NDLP3
3257 CDF 10
3258 TAD I TEMP /TURN OFF SUBARG BIT
3259 AND (7757 /(THATS THE
3260 /SECOND TIME I FIXED THIS)
3261
3262 DCA I TEMP
3263 NDLP3, ISZ NARGS
3264 JMP ARGLP3
3265 CDF
3266 JMP I (MORE /GENERATE SCALAR,
3267 /LITERAL AND TEMP STORAGE
3268
3269 NOARGS, JMS I (PLSUB2 /NO ARGS, OUTPUT TRACEBACK STUFF
3270 JMP I (MORE /GENERATE SCALAR,
3271 /LITERAL AND TEMP STORAGE
3272 PLSUB1, 0
3273 CDF
3274 TAD I PLSUB1 /GET THE SKIP
3275 DCA PLSKIP
3276 ISZ PLSUB1
3277 CDF 10
3278 TAD I X10 /GET THE NEXT ARG
3279 IAC
3280 DCA TEMP /TYP WORD ADDR
3281 CLL CML RTR /2000=DIM BIT
3282 AND I TEMP
3283 PLSKIP, 0 /ARRAYS OR SCALARS ?
3284 JMP I PLSUB1
3285 ISZ PLSUB1
3286 CLA CMA
3287 TAD TEMP /DEFINE THIS VAR
3288 JMS I QOUTNAM
3289 TAD COMMA
3290 JMS I QOCHAR
3291 CDF 10
3292 TAD I TEMP /LOOK AT THE TYPE
3293 CDF
3294 JMS I QSKPIRL /SKIP IF NOT C OR D
3295 XNOP, NOP /THIS IS CHANGED LATER (MAYBE)
3296 TAD XDP3 /.+3 OR .+6
3297 DCA .+3
3298 JMS I (INS2 /ORG FOR THE VALUE
3299 ORG;0
3300 JMP I PLSUB1
3301 TOOMNY, TAD P0F1 /TOO MANY ARRAY ARGS
3302 JMP I P0F2
3303 XM3, CLL CML RTL
3304 PAGE
3305 \f/ SCALARS, LITERALS & TEMPS
3306
3307 HOLLIT,
3308 MORE, JMS I (TYPRTN /OUTPUT SCALARS
3309 SCALAR
3310 TAD (TEMPS /OUTPUT FIRST FIVE TEMPS
3311 JMS I (OUTVAR
3312 TAD (LITRL2
3313 JMS I QOUTSYM
3314 TAD COMMA /OUTPUT %LITRL,
3315 JMS I QOCHAR
3316 JMS I (DOLIST
3317 INTLST
3318 O141, 0141;-3 /OUTPUT INTEGER LITERALS
3319 JMS I (DOLIST
3320 FPLIST
3321 0142;-3 /OUTPUT FP LITERALS
3322 JMS I (DOLIST
3323 DPLIST
3324 0144;-6 /DOUBLE LITERALS
3325 JMS I (DOLIST
3326 CMPLST
3327 0143;-6 /COMPLEX LITERALS
3328 JMS I (TYPRTN /OUTPUT DIMENSION FACTORS
3329 DFLIT
3330 JMS I (ADFLIT /OUTPUT ARG DIM FACTOR LITERALS
3331 TAD (HOLIST /OUTPUT HOLLERITH LITERALS
3332 DCA ENTRY
3333 HOLLUP, CDF 10
3334 TAD I ENTRY
3335 SNA
3336 JMP HOLDUN
3337 DCA ENTRY /SAVE NEW ENTYR
3338 TAD ENTRY
3339 DCA X10
3340 TAD O141 /SET TYPE INFO
3341 DCA I X10
3342 TAD LITNUM
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
3347 TAD I X10
3348 CDF
3349 SNA
3350 JMP HOFILL /FILL OUT REST
3351 DCA ARG
3352 TAD ARG
3353 AND (77 /IS THIS LAST WORD?
3354 SZA CLA
3355 JMP .+4 /NO
3356 TAD ARG /YES, STICK IN
3357 TAD Q40 /BLANK
3358 JMP HOFILL+1 /AND OUTPUT IT
3359 TAD ARG /OUTPUT CHAR PAIR
3360 JMS ONUM
3361 ISZ HOLLIT
3362 JMP HOLOOP
3363 JMP HOLOOP-2
3364 HOFILL, TAD (4040 /FILL WITH BLANKS
3365 JMS ONUM
3366 ISZ HOLLIT
3367 JMP HOFILL
3368 JMP HOLLUP /DO NEXT HOLLERITH LITERAL
3369 HOLDUN, CDF
3370 JMS I (TYPRTN /DO ARRAYS
3371 ARRAYS
3372 JMS I (TYPRTN /REMOVE COMMON VARS FROM S.T.
3373 COMVAR
3374 JMS I QOTAB
3375 TAD (XLBLE /#LBL=.
3376 JMS I QOUTSYM
3377 JMS I QCRLF
3378 CDF 10 /LOOK AT THE BLANK COMMON LIST
3379 TAD I (ONEI+2 /MAKE TRUE=INTEGER ONE
3380 DCA I (TRUE+2
3381 TAD I (BLNKCN+1
3382 CDF
3383 SNA
3384 JMP NOBC /NO BLANK COMMON
3385 DCA TYPE /POINTER TO VARIABLE LIST
3386 JMS I QOPCOD
3387 COMMON
3388 JMS I QCRLF
3389 CDF 10
3390 BCLOOP, TAD TYPE /PROCESS THIS HUNK OF
3391 /BLANK COMMON
3392 DCA X10
3393 TAD I X10
3394 SNA
3395 JMP NXTBC /EMPTY HUNK
3396 CIA /SIZE OF HUNK
3397 DCA TEMP
3398 TAD I X10 /OUTPUT HUNK
3399 JMS I (OUTVAR
3400 CDF 10
3401 ISZ TEMP
3402 JMP .-4
3403 NXTBC, TAD I TYPE /ADDR OF NEXT HUNK
3404 SNA
3405 JMP NOBC /THAT WAS THE LAST HUNK
3406 DCA TYPE
3407 JMP BCLOOP /DO NEXT HUNK
3408 NOBC, CDF
3409 JMS I (TYPRTN /DO NAMED COMMONS
3410 COMNAM
3411 JMS I (TYPRTN /NOW EQUIVALENCES
3412 EQUIVS
3413 JMS INS2
3414 ORG;XLBL /%ORG #LBL
3415 JMP I (PROLG2 /COMPLETE PROLOG
3416 PAGE
3417 \f/ ARGUMENT PICKUP GENERATOR
3418
3419 PROLG2, TAD FUNCTN /SECOND PART OF PROLOG
3420 SZA CLA
3421 JMP DORETN /NOT A MAIN PROG
3422 JMS I (INS /#ST, BASE #BASE
3423 XST;BASE;XBASE
3424 JMS I (INS2 / SETB #BASE
3425 SETB;XBASE
3426 JMS I (INS2 / SETX #XR
3427 SETX;XXR
3428 BDSWIT, JMP I (FINIST /GO GET OVERLAY
3429 DORETN, JMS I (INS /#RTN, BASE #BASE
3430 XRTN;BASE;XBASE
3431 TAD ARGLST /ANY ARGS ?
3432 SNA
3433 JMP JAGOBK /NO
3434 DCA X10 /POINTER TO THE LIST
3435 CDF 10
3436 TAD I ARGLST /NUMBER OF ARGS
3437 CIA
3438 DCA NARGS
3439 DCA TEMP2 /ZERO ARG COUNTER
3440 CDF
3441 TAD NARGS /WILL WE RESTORE ANY ?
3442 TAD (6
3443 SMA CLA
3444 JMP JAGOBK /NO
3445 JMS I (INS2 / FLDA #ARGS
3446 FLDA;XARGS
3447 JMS I (INS2 / FSTA #BASE
3448 FSTA;XBASE
3449 RSLOOP, CDF 10
3450 TAD I X10 /GET NEXT ARG
3451 IAC
3452 DCA TEMP /ADDR OF TYPE WORD
3453 ISZ TEMP2 /INCR COUNT
3454 TAD I TEMP /IS IT A VALUE TRANSMISSION ?
3455 AND Q20
3456 CDF
3457 SZA CLA
3458 JMP NOREST /NO, DON'T RESTORE IT
3459 JMS I QOPCDE / %LDX XXXX,1
3460 LDX
3461 TAD TEMP2
3462 JMS I QONUMBR
3463 TAD (C1
3464 JMS I QOUTSYM
3465 JMS I QCRLF
3466 JMS I QGENCOD /STARTD
3467 SD-1
3468 JMS I (INS2 /GET POINTER TO ARG
3469 FLDAI;XBASC1
3470 JMS I (INS2 /AND SAVE IN #BASE+3
3471 FSTA;XBASP3
3472 JMS STFORE /INTO CORRECT MODE
3473 JMS I QOPCDE /FLDA VAR
3474 FLDA
3475 CMA
3476 TAD TEMP
3477 CDF 10
3478 JMS I QOUTNAM
3479 JMS I QCRLF
3480 JMS I (INS2 / FSTA% #BASE+3
3481 FSTAI;XBASP3
3482 NOREST, ISZ NARGS
3483 JMP RSLOOP
3484 JMS I QGENCOD /MAKE SURE WE'RE IN F MODE
3485 QSFM1, SF-1
3486 JAGOBK, TAD FUNCTN /WHAT WAS THIS ?
3487 SPA CLA
3488 JMP NOFVAL /NOT A FUNCTION
3489 CDF 10 /GET TYPE
3490 TAD I PROGNM
3491 AND Q17
3492 TAD (FVAL-1 /PLUS TABLE ADDRESS
3493 DCA GVSKEL /GIVES POINTER TO
3494 /SKELETON ADDRESS
3495 TAD I GVSKEL /GET SKELETON ADDRESS
3496 DCA GVSKEL
3497 JMS I QGENCOD /PICK UP FUNCTION VALUE
3498 GVSKEL, 0
3499 NOFVAL, JMS I (INS2 / JA #GOBAK
3500 JA;XGOBAK
3501 JMS I (INS /#ST, %STARTD
3502 XST;STARTD;0
3503 JMS I QOTAB
3504 TAD (210 / %FLDA' 10
3505 JMS I QONUMBR
3506 JMS I QCRLF
3507 JMS I (INS2 / %FSTA #GOBAK,0
3508 FSTA;XGOBC0
3509 JMP I (MORPLG
3510
3511 STFORE, 0 /START F OR E
3512 CDF 10
3513 TAD I TEMP /GET TYPE
3514 CDF
3515 JMS I QSKPIRL /SKIP ON I R OR L
3516 TAD (SE-SF /SE
3517 TAD QSFM1 /SF
3518 DCA .+2
3519 JMS I QGENCOD
3520 0
3521 JMP I STFORE /DON'T FORGET TO
3522 /RETURN DUMMY
3523 XARGS, TEXT '#ARGS'
3524 PAGE
3525 \f/ ENTRY AND EXIT CODE
3526
3527 MORPLG, JMS I QOTAB
3528 TAD Q200 / FLDA' 0
3529 JMS I QONUMBR
3530 JMS I QCRLF
3531 JMS I (INS2 / %SETX #XR
3532 SETX;XXR
3533 JMS I (INS2 / %SETB #BASE
3534 SETB;XBASE
3535 TAD ARGLST /ANY ARGS ?
3536 SNA
3537 JMP I (ENDPLG /NO, JUST STARTF
3538 DCA ARG /SAVE POINTER TO THEM
3539 JMS I (INS2 / %LDX 0,1
3540 LDX;ZC1
3541 JMS I (INS2 / %FSTA #BASE
3542 FSTA;XBASE
3543 JMS I (INS2 / %FSTA #ARGS
3544 FSTA;XARGS
3545 CDF 10
3546 TAD I ARGLST /NUMBER OF ARGS
3547 CIA
3548 DCA NARGS
3549 GALOOP, CDF
3550 JMS I (INS2 / %FLDA I #BASE,1+
3551 FLDAI;XBAC1P
3552 DCA TYPE /CLEAR THE SD SWITCH
3553 CDF 10
3554 ISZ ARG /GET TO NEXT ARG
3555 TAD I ARG /LOOK AT ITS TYPE WORD
3556 IAC
3557 DCA TEMP
3558 CLL CML RTR
3559 AND I TEMP /WAS IT DIMENSIONED ?
3560 SNA CLA
3561 JMP I (TSTABT /NO, SEE IF ITS VALUE
3562 CMA
3563 TAD TEMP /GET ADDR OF DIM INFO
3564 JMS I QGETSS
3565 IAC /ADDR OF SIZE
3566 DCA TEMP2
3567 TAD I TEMP2
3568 ISZ TEMP2
3569 ISZ TEMP2
3570 SNA CLA
3571 JMP OUFSTA+1 /IT HAS A VARIABLE DIMENSION
3572 TAD I TEMP2 /GET MAGIC NUMBER LIT DISP
3573 DCA TEMP2
3574 CDF
3575 JMS I QOPCDE / %FSUB #LIT+XXXX
3576 FSUB
3577 TAD QLITRL
3578 JMS I QOUTSYM
3579 TAD TEMP2
3580 JMS I QONUMBR
3581 JMS I QCRLF
3582 CDF 10
3583 OUFSTA, DCA I ARG /IT ISN'T VARIABLY DIMENSIONED
3584 CDF
3585 JMS I QOPCDE / %FSTA ARGN
3586 FSTA
3587 CDF 10
3588 CMA
3589 TAD TEMP
3590 JMS I QOUTNAM
3591 JMS I QCRLF
3592 ISZ NARGS
3593 SKP
3594 JMP I (ENDPLG /END OF PROLOG
3595 TAD TYPE /DID WE LEAVE D MODE
3596 SNA CLA
3597 JMP GALOOP /NO
3598 JMS I QGENCOD /YES, OUTPUT AN %SD
3599 SD-1
3600 JMP GALOOP
3601 FINIST, CDF 10
3602 TAD FUNCTN /WAS THIS A FUNCTION ?
3603 SPA SNA CLA
3604 JMP .+4 /NO, SKIP THIS
3605 TAD I PROGNM /YES, TURN OFF EXT BIT
3606 AND (6777 /ALLOWING STORING IN FUN NAME
3607 DCA I PROGNM
3608 TAD (2200 /CHECK /N /Q
3609 AND I (7644
3610 CDF
3611 SNA CLA
3612 NODBUG, DCA I (DEBUG /IF NOT SET, PUT ISN'S
3613 CDF 10 /INTO CODE
3614 TAD I (7644 /IS /Q SET ?
3615 CDF
3616 AND (0200
3617 SZA CLA
3618 ISZ I (OPTMYZ /MAKE A CLA IAC FROM A CLA
3619 GFNAME, CDF 10
3620 TAD I FNAME /MOVE FILE NAME
3621 CDF
3622 DCA I NAMEF /INTO PAGE
3623 ISZ FNAME
3624 ISZ NAMEF
3625 ISZ NFCNT
3626 JMP GFNAME
3627 JMP I (RDOVLY /GO WHERE ?
3628 /CALIFORNIA OF COURSE!!!!
3629 FNAME, 7601
3630 NAMEF, F1LNAM
3631 NFCNT, -4
3632
3633 ONUM, 0
3634 ISZ LITNUM /BUMP LITERAL COUNTER
3635 DCA ARG
3636 JMS I QOTAB
3637 TAD ARG
3638 JMS I QONUMBR
3639 JMS I QCRLF
3640 JMP I ONUM
3641 PAGE
3642 \f/ ENTRY AND EXIT CODE
3643
3644 TSTABT, TAD I TEMP /VALUE TRANSMISSION ?
3645 AND Q20
3646 SZA CLA
3647 JMP I (OUFSTA /NO
3648 CDF
3649 JMS I (INS2 / %FSTA #BASE+3
3650 FSTA;XBASP3
3651 JMS I (STFORE /ENTER CORRECT MODE
3652 JMS I (INS2 / %FLDA% #BASE+3
3653 FLDAI;XBASP3
3654 ISZ TYPE /SET SWITCH
3655 JMP I (OUFSTA-1
3656 ENDPLG, JMS I QGENCOD /%SF
3657 SF-1
3658 TAD ARGLST /ANY VARIABLY
3659 /DIMENSIONED ARRAYS ?
3660 SNA
3661 JMP I (FINIST /NO ARGS AT ALL
3662 DCA X10
3663 CDF 10
3664 TAD I ARGLST /NUMBER OF ARGS
3665 CIA
3666 DCA NSARGS
3667 VDIMLP, CDF 10
3668 TAD I X10 /GET NEXT ARG
3669 SNA
3670 JMP NDVDIM /NOT A VARIABLY
3671 /DIMENSIONED ARRAY
3672 DCA VDTEMP
3673 TAD VDTEMP /GET ADDR OF DIMENSION INFO
3674 JMS I QGETSS
3675 DCA VDTMP2
3676 TAD I VDTMP2 /NUMBER OF DIMENSIONS
3677 CIA
3678 DCA NARGS
3679 ISZ VDTMP2 /MOVE TO MAGIC NUMBER LITERAL
3680 ISZ VDTMP2
3681 ISZ VDTMP2
3682 TAD I VDTMP2 /GET IT
3683 CDF
3684 DCA MNL /SAVE MAGIC NUMBER LITERAL
3685 TAD (FLDA /JUST LOAD FIRST DIM
3686 DCA MNOPC
3687 TAD NARGS /GET ADDRESS
3688 CIA /OF THE LAST
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
3693 DCA MNOPC
3694 JMS I QOPCOD /NEXT SUBSCRIPT (ALWAYS (1.0)
3695 FADD
3696 JMS I QOADDR /NOW ADDRESS
3697 (ONEI
3698 CMPMN3, ISZ NARGS /ANY MORE SS ?
3699 JMP CMPMN2 /YES
3700 ISZ VDTEMP /GET TO TYPE
3701 CDF 10
3702 TAD I VDTEMP
3703 CDF
3704 JMS I QSKPIRL /SKIP ON I R L
3705 TAD Q6M3 /YES
3706 TAD (THREE
3707 JMS LDAMUL /3.02
3708 JMS I (INS2 /ALN 0
3709 ALN;D0
3710 JMS I QOPCDE
3711 FSTA
3712 TAD QLITRL /SAVE IN THE MAGIC
3713 /NUMBER LITERAL
3714 JMS I QOUTSYM
3715 CLA CMA
3716 TAD MNL
3717 JMS I QONUMBR
3718 JMS I QCRLF
3719 JMS I (INS2 /FNEG
3720 FNEG;0
3721 JMS I (INS2 /ENTER D MODE
3722 STARTD;0
3723 JMS I QOPCDE
3724 FADDM /NOW MODIFY THE POINTER
3725 CMA
3726 TAD VDTEMP
3727 CDF 10
3728 JMS I QOUTNAM
3729 JMS I QCRLF
3730 JMS I (INS2 /RETURN TO F MODE
3731 STARTF;0
3732 NDVDIM, ISZ NSARGS /ANY MORE ARGS TO CHECK?
3733 JMP VDIMLP /YES
3734 CDF
3735 JMP I (FINIST
3736 CMPMN2, CLA CMA /BACK UP THE POINTER
3737 TAD VDTMP2 /BY ONE
3738 DCA VDTMP2
3739 CDF 10
3740 TAD I VDTMP2 /GET IT
3741 CDF
3742 JMS LDAMUL /3.02
3743 JMP CMPMN1 /LOOP
3744 VDTEMP, 0
3745 VDTMP2, 0
3746 NSARGS, 0
3747 MNL, 0
3748 DP12, TEXT '.+14'
3749 LDAMUL, 0 /3.02
3750 DCA MNADR
3751 JMS I QOPCOD
3752 MNOPC, 0
3753 JMS I QOADDR
3754 MNADR
3755 JMP I LDAMUL
3756 MNADR, 0
3757 PAGE
3758 / RANDOM PROLOG STUFF
3759
3760 ARRAYS, 0 /OUTPUT ARRAYS
3761 TAD I TYPE
3762 AND (6220 /IS IT AN ARRAY
3763 SNA
3764 JMP I ARRAYS
3765 AND (4220 /NOT COMMON, EQUIV OR ARG
3766 SZA CLA
3767 JMP I ARRAYS
3768 JMS I (UNHOOK /REMOVE FROM BUCKET
3769 TAD ENTRY /OUTPUT VARIABLE
3770 JMS I (OUTVAR
3771 JMP TFUDGE-1
3772 FILL, 0 /FILL SUB NAME WITH BLANKS
3773 CLL CML RTL
3774 TAD PROGNM /PROGNM+2
3775 CIA /-PROGNM-2
3776 TAD I XNAMP /1,2,3
3777 TAD QM4 /-3,-2,-1
3778 DCA TEMP
3779 JMP .+5
3780 TAD (240 /TWO BLANKS FOR EACH WORD
3781 JMS I QOCHAR
3782 TAD (240
3783 JMS I QOCHAR
3784 ISZ TEMP /MORE ?
3785 JMP .-5 /YES
3786 JMP I FILL
3787 XNAMP, NAMPTR
3788 NPRNT, 0
3789 JMS I QTTYP2C
3790 JMS I QTTYP2C
3791 TAD I X10 /NOW NUMBER
3792 JMS I QTTYP2C
3793 TAD I X10
3794 JMS I QTTYP2C
3795 TAD I X10
3796 JMS I QTTYP2C
3797 JMS I QTTCRLF
3798 JMP I NPRNT
3799 \f/ROUTINE TO FIX UP NEGATIVE EQUIVALENCE OFFSETS
3800
3801 NEGSLV, 0
3802 TAD I TYPE
3803 AND Q200
3804 SNA CLA /IS VARIABLE A SLAVE?
3805 JMP I NEGSLV /NO
3806 TAD TYPE
3807 DCA X10
3808 TAD I X10 /GET POINTER TO EQUIV BLOCK
3809 DCA X10
3810 CLA IAC
3811 TAD I X10 /GET POINTER TO MASTER
3812 DCA OLDM /TYPE WORD
3813 TAD I X10 /OFFSET FROM MASTER
3814 CMA STL
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
3822 DCA I TYPE
3823 ISZ TYPE
3824 TAD I TYPE
3825 DCA TYPE1 /TYPE1 POINTS TO EQUIV BLOCK
3826 CLA IAC
3827 TAD TYPE1
3828 DCA X10 /USE AUTO-XR TO CLEAR OFFSETS
3829 TAD ENTRY
3830 DCA NEWM
3831 TAD I OLDM /GET OLD MASTER'S TYPE WD
3832 TAD Q200
3833 DCA I OLDM /MAKE IT A SLAVE
3834 ISZ OLDM
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
3849
3850 FIXSLV, 0 /THROUGHOUT
3851 TAD I TYPE
3852 AND Q200
3853 SNA CLA /IS IT A SLAVE?
3854 JMP I FIXSLV /NO
3855 ISZ TYPE
3856 CLA IAC
3857 TAD I TYPE
3858 DCA TYPE /TYPE NOW POINTS TO THE EQUIV BLOCK
3859 CLA IAC
3860 TAD I TYPE /GET PTR TO THIS SLAVES MASTER (+1)
3861 CMA
3862 TAD OLDM /COMPARE MASTERS
3863 SZA CLA
3864 JMP I FIXSLV /NOT UNDER SAME MASTER - LEAVE
3865 TAD NEWM
3866 DCA I TYPE /"MEET THE NEW BOSS.....
3867 ISZ TYPE / SAME AS THE OLD BOSS...."
3868 TAD I TYPE / (THE WHO)
3869
3870 TAD SFUDGE /ADD IN THE DIFFERENCE BETWEEN OLD AND NEW
3871 IAC /MASTERS TO THE MASTER OFFSET
3872 DCA I TYPE
3873 JMP I FIXSLV /THE SLAVE IS NOW -- A SLAVE!
3874
3875 OLDM, 0
3876 NEWM, 0
3877 SFUDGE, 0
3878 PAGE
3879 \f/ ENTRY AND EXIT CODE
3880
3881 PLSUB2, 0 /DUMB SUBR FOR PROLOG
3882 CDF
3883 JMS INS2 / %ORG #BASE+30
3884 ORG;XBAP30
3885 JMS INS2 / %FNOP
3886 FNOP;0
3887 JMS INS2 / %JA #RET
3888 JA;XRET
3889 JMS INS2 / FNOP
3890 FNOP;0
3891 JMS INS /#GOBAK,ORG .+2
3892 XGOBAK;DBLZRO;0 /**TO INSURE IT'S 0
3893 TAD DPUSED /WAS DOUBLE PRECISSION USED ?
3894 SNA CLA
3895 JMP NDPUSD /NO, NO NEED FOR TEMP
3896 JMS INS
3897 XDPTMP;ORG;DP12 /#DPT, ORG .+12
3898 JMS INS2
3899 DPCHK;0
3900 NDPUSD, TAD FUNCTN /FUNCTION OR SUBR ?
3901 SNA
3902 JMP I PLSUB2 /ITS #MAIN, NO #VAL OR #ARGS
3903 SPA CLA
3904 JMP .+5 /ITS A SUBROUTINE, NO #VAL
3905 JMS INS /#VAL, %ORG .+6
3906 XVAL;ORG;DP6
3907 JMS INS /#ARGS, %ORG .+3
3908 XARGS;ORG;DP3
3909 JMP I PLSUB2
3910 INS2, 0 / %OPCOD ADDR
3911 TAD INS2 /COMMONIZE RETURNS
3912 DCA INS
3913 JMP INS3
3914 INS, 0 /TAG, %OPCOD ADDR
3915 TAD I INS /GET TAG FIELD
3916 ISZ INS
3917 JMS I QOUTSYM /OUTPUT IT
3918 TAD COMMA
3919 JMS I QOCHAR
3920 INS3, JMS I QOTAB
3921 TAD I INS /GET OPCODE
3922 ISZ INS
3923 JMS I QOUTSYM
3924 TAD I INS /GET ADDR
3925 SNA CLA
3926 JMP .+4 /NO ADDRESS
3927 JMS I QOTAB
3928 TAD I INS
3929 JMS I QOUTSYM
3930 ISZ INS
3931 JMS I QCRLF
3932 JMP I INS
3933 SECT, TEXT 'SECT'
3934 XRET, TEXT '#RET'
3935 XXR, TEXT '#XR'
3936 XGOBAK, TEXT '#GOBAK'
3937 XST, TEXT '#ST'
3938 XGOBC0, TEXT '#GOBAK,0'
3939 XBAP30, TEXT '#BASE+30'
3940 FNOP, TEXT 'FNOP'
3941 SETX, TEXT 'SETX'
3942 SETB, TEXT 'SETB'
3943 TEXTX, TEXT 'TEXT'
3944 XBASC1, TEXT '#BASE,1'
3945 DP3, TEXT '.+3'
3946 DP6, TEXT '.+6'
3947 ZC1, TEXT '0,1'
3948 FLDAI, TEXT 'FLDA%'
3949 FSTAI, TEXT 'FSTA%'
3950 XLBLE, TEXT '#LBL=.'
3951 C1, TEXT ',1'
3952 XLBL, TEXT '#LBL' /STACK-5 CAN'T BE 0
3953 DBLZRO, TEXT '0;0'
3954 PAGE
3955 \f/ SYMBOL TABLE PROCESSING ROUTINES
3956
3957 IMPLCT, 0 /DO IMPLICIT TYPING
3958 TAD I TYPE
3959 AND O100 /WAS IT EXPLICITLY TYPED
3960 SZA CLA
3961 JMP I IMPLCT /YES
3962 TAD BUCKET /IS IT INTEGER ?
3963 TAD M317
3964 CLL
3965 TAD M006
3966 SNL CLA
3967 ISZ I TYPE /TYPE IT REAL
3968 ISZ I TYPE /TYP IT INTEGER
3969 JMP I IMPLCT
3970 O100,
3971 DFLIT, 100 /GENERATE FACTORS FOR CALLS
3972 CLL CML RTR /DIMENSIONED ?
3973 AND I TYPE
3974 SNA CLA
3975 JMP I DFLIT /NO
3976 TAD I TYPE
3977 DCA TEMP /SET PROPER WDS/ENTRY FOR VMC
3978 TAD ENTRY /GET ADDR OF MAGIC NUMBER
3979 JMS I QGETSS
3980 TAD (2
3981 DCA TYPE
3982 TAD I ENTRY /SAVE LINK
3983 DCA DFTEMP
3984 TAD BUCKET /FIX NAME
3985 DCA I ENTRY
3986 TAD I TYPE /GET MAGIC NUMBER
3987 DCA TEMP2
3988 ISZ TYPE
3989 CDF
3990 JMS I (ONUM /OUTPUT A ZERO WORD
3991 JMS I QOPCDE
3992 JA
3993 TAD ENTRY /OUTPUT VAR MINUS CONST
3994 JMS I (VMC
3995 JMS I QCRLF /END LITERAL
3996 CDF 10
3997 TAD LITNUM /SAVE NUMBER IN DIM INFO
3998 DCA I TYPE
3999 ISZ LITNUM /THEN BY 2 MORE
4000 ISZ LITNUM
4001 TAD DFTEMP /RESTORE ENTRY
4002 DCA I ENTRY
4003 JMP I DFLIT
4004 M006,
4005 DFTEMP,
4006 EXTRNL, 6 /DO EXTERNALS
4007 TAD I TYPE
4008 AND O1000 /IS IT EXT ?
4009 SNA CLA
4010 JMP I EXTRNL
4011 JMS I (UNHOOK /REMOVE THIS SYMBOL
4012 TAD PROGNM /IS IT THE PROG NAME ?
4013 CIA
4014 TAD ENTRY
4015 SZA CLA
4016 JMP .+5 /NO, OUTPUT EXTERN
4017 TAD FUNCTN /IS IT A MAIN PROG ?
4018 SNA CLA
4019 JMP TFUDGE-1 /YES, NO SECT
4020 TAD (SECT-EXTERN /NOT MAIN, OUTPUT SECT
4021 TAD XTRN
4022 DCA M317
4023 CDF
4024 JMS I QOPCDE
4025 M317, -317
4026 TAD ENTRY /NOW VAR NAME
4027 CDF 10
4028 JMS I QOUTNAM
4029 JMS I QCRLF
4030 JMP TFUDGE-1
4031 O1000,
4032 EQUIVS, 1000 /OUTPUT EQUIVALENCES
4033 TAD I TYPE
4034 AND Q200 /IS THIS A SLAVE ?
4035 SNA CLA
4036 JMP I EQUIVS /NO
4037 JMS I (UNHOOK /UNHOOK THE ENTRY
4038 TAD I TYPE /SAVE THE TYPE WORD
4039 DCA TYPE1
4040 ISZ TYPE /POINT TO EQUIVALENCE BLOCK
4041 TAD I TYPE
4042 DCA X10
4043 CDF
4044 JMS I QOPCDE /OUTPUT ORG
4045 ORG
4046 CDF 10
4047 TAD I X10 /MASTER NAME
4048 DCA X11 /SAVE IT
4049 TAD X11
4050 JMS I QOUTNAM /OUTPUT IT
4051 TAD PLUS /+
4052 JMS I QOCHAR
4053 CDF 10
4054 TAD I X11 /MASTER SS
4055 JMS SUBRX
4056 TAD Q255 /MINUS
4057 JMS I QOCHAR
4058 CDF 10
4059 TAD TYPE1 /SLAVE SS
4060 JMS SUBRX
4061 JMS I QCRLF /EOL
4062 CDF 10
4063 TAD ENTRY /NOW OUTPUT SLAVE
4064 JMS I (OUTVAR
4065 JMP TFUDGE-1
4066 XTRN,
4067 SUBRX, EXTERN
4068 JMS I QSKPIRL /SIZE OF THING
4069 TAD Q3
4070 TAD Q3 /TIMES 3 OR 6
4071 DCA MQ
4072 TAD I X10
4073 CDF
4074 JMS I QMUL12 /MAKE THE PRODUCT
4075 JMS I QNUMBRO /OUT WITH IT
4076 JMP I SUBRX
4077 DPCHK, TEXT 'DPCHK'
4078 FADDM, TEXT 'FADDM'
4079 PAGE
4080 \f/ SYMBOL TABLE PROCESSING ROUTINES
4081
4082 BASE, TEXT 'BASE'
4083 OUTVAR, 0 /ALLOCATE STORAGE FOR A VARIABLE
4084 DCA VARADR
4085 RDF /GET FIELD OF VAR
4086 TAD X6201
4087 DCA OVFLD1
4088 TAD OVFLD1
4089 DCA OVFLD2
4090 TAD VARADR /OUTPUT NAME,
4091 JMS I QOUTNAM
4092 TAD COMMA
4093 JMS I QOCHAR
4094 JMS I QOPCDE /OUTPUT ORG
4095 ORG
4096 ISZ VARADR /POINT TO TYPE WROD
4097 OVFLD1, 0
4098 TAD I VARADR /GET TYPE
4099 X6201, CDF
4100 JMS I QSKPIRL
4101 TAD Q3 /PER ENTRY
4102 TAD Q3 /INTEGER, REAL, AND
4103 /LOGICAL 3WORDS
4104 DCA MQ
4105 DCA AC
4106 OVFLD2, 0
4107 CLL CML RTR /CHECK DIM BIT
4108 AND I VARADR
4109 SNA CLA
4110 JMP PLSDOT /NOT DIMENSIONED
4111 TAD I VARADR /LOOK AT TYPE
4112 ISZ VARADR /MOVE TO EQ DIM POINTER
4113 AND Q200 /EQUIVALENCED ?
4114 SNA CLA
4115 JMP .+3 /NO
4116 TAD I VARADR /YES, SKIP EQUIV INFO
4117 DCA VARADR
4118 TAD I VARADR /ADDRESS OF DIM INFO
4119 IAC
4120 DCA VARADR /ADDRESS OF SIZE
4121 TAD I VARADR /GET TOTAL SIZE
4122 CDF
4123 JMS I QMUL12
4124 PLSDOT, CDF
4125 TAD Q256
4126 JMS I QOCHAR
4127 TAD PLUS
4128 JMS I QOCHAR
4129 JMS I QNUMBRO
4130 JMS I QCRLF
4131 JMP I OUTVAR
4132 SCALAR, 0 /OUTPUT SCALARS
4133 TAD I TYPE /IS IT A SCALAR ?
4134 AND (7630 /COM, DIM, EXT, ASF,
4135 /EQV, ARG, COMMONNAME
4136 SZA CLA
4137 JMP I SCALAR /NO
4138 JMS I (UNHOOK /DELETE THIS FROM THE LIST
4139 TAD ENTRY /OUTPUT THIS VARIABLE
4140 JMS OUTVAR
4141 JMP TFUDGE-1
4142 VARADR,
4143 DOLIST, 0 /PROCESS A LITERAL LIST
4144 TAD I DOLIST /GET LIST START
4145 DCA ENTRY
4146 ISZ DOLIST
4147 TAD I DOLIST
4148 DCA TYPE /GET TYPE BITS
4149 ISZ DOLIST
4150 TAD I DOLIST
4151 ISZ DOLIST
4152 DCA LSIZE /GET LITERAL SIZE
4153 CDF 10
4154 DLLOOP, TAD I ENTRY /GET NEXT ENTRY
4155 SNA
4156 JMP DLRETN /NO MORE
4157 DCA ENTRY
4158 TAD ENTRY
4159 DCA X10 /ADDRESS OF TYPE WORD
4160 TAD TYPE /PUT IN TYPE
4161 DCA I X10
4162 TAD X10 /SAVE THIS ADDR
4163 DCA X11
4164 TAD LSIZE /SIZE OF LITERAL
4165 DCA TEMP
4166 LITLUP, CDF
4167 JMS I QOTAB
4168 CDF 10
4169 TAD I X10
4170 CDF
4171 JMS I QONUMBR
4172 JMS I QCRLF
4173 ISZ TEMP
4174 JMP LITLUP
4175 CDF 10
4176 TAD LITNUM /SAVE LITERAL NUMBER
4177 DCA I X11
4178 TAD LSIZE /INCREMENT LITERAL NUMBER
4179 CIA
4180 TAD LITNUM
4181 DCA LITNUM
4182 JMP DLLOOP
4183 DLRETN, CDF
4184 JMP I DOLIST
4185 TEMPS, 243;2000;TMPSIZ;2415;2000
4186 TMPSIZ, 1;TMPBLK+1
4187 LSIZE,
4188 COMVAR, 0 /REMOVE COMMON VARS FROM ST
4189 TAD I TYPE
4190 AND (4400 /ALSO ASF NAMES
4191 SNA CLA
4192 JMP I COMVAR
4193 JMS I (UNHOOK
4194 JMP TFUDGE-1
4195 LITRL2, TEXT '#LIT'
4196 COMMON, TEXT 'COMMON'
4197 PAGE
4198 \f/ SYMBOL TABLE PROCESSING ROUTINES
4199
4200 TYPRTN, 0 /PROCESS ENTIRE SYMBOL TABLE
4201 TAD I TYPRTN /GET ROUTINE ADDRESS
4202 DCA ROUTNE
4203 ISZ TYPRTN
4204 TAD O301 /START WITH 'A'
4205 DCA BUCKET
4206 TAD M32 /BUCKET COUNT
4207 DCA BCNT
4208 TYPLP2, TAD BUCKET /GET START OF NEXT LIST
4209 TAD ALM301
4210 TYPLUP, DCA OENTRY /SAVE OLD ENTRY ADDRESS
4211 CDF 10
4212 TFUDGE, TAD I OENTRY /GET ADDR OF NEXT ENTRY
4213 SNA
4214 JMP EOL /0 MEANS END OF LIST
4215 DCA ENTRY
4216 IAC
4217 TAD ENTRY /ADDR OF TYPE WORD
4218 DCA TYPE
4219 JMS I ROUTNE /CALL ROUTINE
4220 TAD I OENTRY /CONTINUE DOWN THE LIST
4221 JMP TYPLUP
4222 EOL, ISZ BUCKET /DO NEXT LETTER
4223 ISZ BCNT
4224 JMP TYPLP2
4225 CDF
4226 JMP I TYPRTN /END OF PASS
4227 BCNT=ARG1
4228 COMNAM, 0 /OUTPUT A COMMON BLOCK
4229 TAD I TYPE /IS THIS A COMMON BLOCK NAME
4230 TAD M111
4231 SZA CLA
4232 JMP I COMNAM /NO
4233 CDF
4234 JMS I QOPCDE
4235 COMMON
4236 CDF 10
4237 JMS I (UNHOOK /REMOVE THE COMMON
4238 /BLOCK FROM S.T.
4239 TAD ENTRY
4240 JMS I QOUTNAM /OUTPUT NAME
4241 JMS I QCRLF
4242 ISZ TYPE /GET TO COMMON STUFF POINTER
4243 CNLOOP, CDF 10
4244 TAD I TYPE /GET ADDR OF NEXT HUNK
4245 /OF COMMON
4246 SNA
4247 JMP TFUDGE /END OF IT
4248 DCA TYPE
4249 TAD TYPE /GET A WORKING POINTER
4250 DCA X10
4251 TAD I X10 /GET COUNT
4252 SNA
4253 JMP CNLOOP /NONE IN THIS HUNK
4254 CIA
4255 DCA TEMP2
4256 TAD I X10 /GET VARIABLE ADDRESS
4257 JMS I (OUTVAR /OUTPUT IT
4258 CDF 10
4259 ISZ TEMP2
4260 JMP .-4 /DO NEXT ONE FROM THIS HUNK
4261 JMP CNLOOP /DO NEXT HUNK
4262 O301, 301
4263 M32, -32
4264 ALM301, ALIST-301
4265 M111, -111
4266 ROUTNE,
4267 ADFLIT, 0 /OUTPUT ARG DF LITS
4268 TAD ARGLST /ANY ARGS
4269 SNA
4270 JMP I ADFLIT
4271 DCA X10
4272 CDF 10
4273 TAD I ARGLST /NUMBER OF ARGS
4274 CIA
4275 DCA NARGS
4276 ADFLUP, CDF 10
4277 TAD I X10 /GET ARG ADDR
4278 IAC
4279 DCA TEMP /TYPE WORD ADDR
4280 TAD I TEMP /GET TYPE INFO
4281 DCA TEMP2
4282 CLL CML RTR
4283 AND I TEMP /DIMENSIONED ?
4284 SNA CLA
4285 JMP NDADFL /NO
4286 ISZ TEMP /ADDR OF DIM INFO
4287 CLL CML RTL
4288 TAD I TEMP /ADDR OF MAGIC NUMBER
4289 DCA TEMP
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
4294 IAC
4295 DCA I TEMP
4296 CDF
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
4301 TAD (3
4302 JMS I QMUL12
4303 TAD AC /OUTPUT 2 WORD LITERAL
4304 JMS I (ONUM
4305 TAD MQ
4306 JMS I (ONUM
4307 NDADFL, ISZ NARGS
4308 JMP ADFLUP
4309 JMP I ADFLIT
4310 RDOVLY, JMS I (7607 /READ IN OVERLAY
4311 NPOVLY
4312 OVRLAY
4313 PASS2O, 0
4314 JMP I (INERR
4315 TAD I (VOVER /CHECK VERSION OF OVERLAY
4316 TAD VERS
4317 SZA CLA
4318 JMP I (VERROR /ERROR, MIXED VERSIONS
4319 JMP I (EOSTMT /START PASS2 PROPER
4320 PAGE
4321 \f FIELD 1
4322 *5000
4323 0 /THIS IS THE START OF
4324 /THE ERROR MESSAGE LIST
4325 /WHICH WORKS BACKWARDS
4326 \f/OS/8 F4 COMPILER CODE SKELETONS
4327
4328 MAC=-6
4329 NEGSGN=-5
4330 FLDAA2=-4
4331 FLDAA1=-3
4332 ENTERE=-2
4333 ENTERF=-1
4334 CGTCOD, ATX;DD1;STARTD;0;FLDA;DP2C1;STARTF;0
4335 AGTCOD, JAC;0;0
4336 ASNCOD, ENTERF;FLDA;DP3C0;JA;DP4;0
4337 ERCODE, EXTERN;XUE;TRAP3;XUE;0
4338 A0FN, EXTERN;XFIX;JSA;XFIX;0
4339 A0SD, ALN;D0
4340 SD, STARTD;0;0
4341 SE, STARTE;0;0
4342 SF, STARTF;0;0
4343 MPTR0, ENTERF;FLDAA1;FSTA;XBASE;0
4344 MPTR3, ENTERF;FLDAA2;FSTA;XBASP3;0
4345 JADP2, JA;DOT;0
4346 DOFIN0, ENTERF;FLDAA1;FADD;-2
4347 ASTOR, FSTA;-1;0
4348 DOFIN1, ENTERF;FLDAA1;FADD;-2;MAC+A0FN;FSTA;-1;0
4349 LDASTD, FLDAA1;STARTD;0;0
4350 /CHALK UP ONE FOR PAL8
4351 ATX1, ATX;DD1;0
4352 LXM1C2, LDX;M1C2;STARTD;0;0
4353 FVAL, FVI-1;FVI-1;FVC-1;FVD-1;FVI-1
4354 FVI, FLDA;XVAL;0
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
4362 SEGCAC,
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
4376 AX-1;AX+2;AX+5
4377 AS-1;AD-1;AS+4
4378 ASC-1;ASC+2;ASC+3
4379 ASD-1;ASD+7;ASD+10
4380 ACS-1;ACS+4;ACS+6
4381 ADS-1;ADS+3;ADS+7
4382 0
4383 FNEG;0
4384 AS, FADD;-1;0
4385 ENTERF;FLDAA1
4386 FADD;-2;0
4387 JSACNG+MAC
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
4392 JSACNG+MAC
4393 ASC, GIRL1+MAC;JSACAD+MAC;0
4394 GIRL1+MAC
4395 ENTERE;PCAC+MAC;GC2+MAC;JSACAD+MAC;0
4396 FNEG;0
4397 ASD, FSTA;XDPTMP;ENTERF;FLDAA1;ENTERE;FADD;XDPTMP;0
4398 GIRL1+MAC
4399 ENTERE;FADD;-2;0
4400 JSACNG+MAC
4401 ACS, ENTERE;PCAC+MAC;GC1+MAC;JSACAD+MAC;0
4402 GC1+MAC;PCAC+MAC
4403 GIRL2+MAC;JSACAD+MAC;0
4404 FNEG;0
4405 ADS, ENTERE;FADD;-1;0
4406 GIRL2+MAC;FADD;-1;0
4407 FSTA;XDPTMP;GIRL2+MAC;FADD;XDPTMP;0
4408 SUBTBL, AS-3;SS-1;SS+1
4409 AX-2;SX-1;SX+2
4410 AS-3;SDBL-1;SS+1
4411 ASC-2;SSX-1;SSX
4412 ASD-3;SSD-1;SSD
4413 ACS-2;SCS-1;SCS+1
4414 ADS-3;SDS-1;SDS5-1
4415 0
4416 SS, ENTERF;FLDAA1
4417 FSUB;-2;0
4418 SX, GC1C2+MAC;JSACSB+MAC;0
4419 GC2+MAC;JSACSB+MAC;0
4420 SDBL, ENTERE;FLDAA1;FSUB;-2;0
4421 SSX, GIRL1+MAC
4422 ENTERE;PCAC+MAC;GC2+MAC;JSACSB+MAC;0
4423 SSD, GIRL1+MAC
4424 ENTERE;FSUB;-2;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
4430 M4-1;M4+3-1;M4+6-1
4431 M1-1;M7-1;M7+2-1
4432 M8-1;M8+3-1;M8+4-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
4436 0
4437 M1, FMUL;-1;0
4438 ENTERF;FLDAA1
4439 FMUL;-2;0
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
4445 GIRL1+MAC
4446 ENTERE;PCAC+MAC;GC2+MAC;JSACML+MAC;0
4447 M11, FSTA;XDPTMP;GIRL1+MAC;FMUL;XDPTMP;0
4448 GIRL1+MAC
4449 ENTERE;FMUL;-2;0
4450 M14, ENTERE;PCAC+MAC;GC1+MAC;JSACML+MAC;0
4451 GC1+MAC;PCAC+MAC
4452 GIRL2+MAC;JSACML+MAC;0
4453 M18, GIRL2+MAC
4454 ENTERE;FMUL;-1;0
4455 FSTA;XDPTMP;GIRL2+MAC;FMUL;XDPTMP;0
4456 DIVTBL, 1;D2-1;D2+2-1
4457 1;D5-1;D5+3-1
4458 1;D7-1;D7+2-1
4459 1;D9-1;D10-1
4460 1;D12-1;D13-1
4461 1;D14-1;D15-1
4462 1;D16-1;D17-1
4463 0
4464 D2, ENTERF;FLDAA1
4465 FDIV;-2;0
4466 D5, GC1C2+MAC;JSACDV+MAC;0
4467 GC2+MAC;JSACDV+MAC;0
4468 D7, ENTERE;FLDAA1;FDIV;-2;0
4469 D9, GIRL1+MAC
4470 D10, ENTERE;PCAC+MAC;GC2+MAC;JSACDV+MAC;0
4471 D12, GIRL1+MAC
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
4479 EQ4-1;EQ5-1;EQ6-1
4480 EQ1-1;EQ7-1;EQ3-1
4481 EQ8-1;EQ9-1;EQ10-1
4482 EQ11-1;EQ12-1;EQ13-1
4483 EQ14-1;EQ15-1;EQ16-1
4484 EQ17-1;EQ18-1;EQ19-1
4485 EQ1-1;EQ2-1;EQ3-1
4486 EQ1, FSUB;-1;0
4487 EQ2, ENTERF;FLDAA1
4488 EQ3, FSUB;-2;0
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
4494 EQ9, GIRL1+MAC
4495 EQ10, ENTERE;PCAC+MAC;GC2+MAC;JSACEQ+MAC;0
4496 EQ11, MAC+ASD-2;0
4497 EQ12, GIRL1+MAC
4498 EQ13, MAC+SSD+1;0
4499 EQ15, GIRL2+MAC
4500 EQ14, ENTERE;PCAC+MAC;GC1+MAC;JSACEQ+MAC;0
4501 EQ16, GIRL2+MAC;JSACEQ+MAC;0
4502 EQ18, GIRL2+MAC
4503 EQ17, MAC+ADS-2;0
4504 EQ19, MAC+SDS5;0
4505 \fLETABL, LE1-1;LE2-1;LE3-1
4506 0;0;0
4507 LE1-1;LE4-1;LE3-1
4508 0;0;0
4509 LE11-1;LE12-1;LE13-1
4510 0;0;0
4511 LE17-1;LE18-1;LE19-1
4512 0
4513 LE1, FSUB;-1;NEGSGN;0
4514 LE2, ENTERF;FLDAA1
4515 LE3, FSUB;-2;0
4516 LE4, ENTERE;MAC+LE2+1;0
4517 LE11, MAC+ASD-2;0
4518 LE12, GIRL1+MAC
4519 LE13, MAC+SSD+1;0
4520 LE18, GIRL2+MAC
4521 LE17, MAC+ADS-2;0
4522 LE19, MAC+SDS5;0
4523 \fANDTBL, 0;0;0
4524 0;0;0
4525 0;0;0
4526 0;0;0
4527 0;0;0
4528 0;0;0
4529 0;0;0
4530 M1-1;M1+3-1;M1+5-1
4531 ORTABL, 0;0;0
4532 0;0;0
4533 0;0;0
4534 0;0;0
4535 0;0;0
4536 0;0;0
4537 0;0;0
4538 AS-1;AS+2;AS+4
4539 \fEQVTBL, 0;0;0
4540 0;0;0
4541 0;0;0
4542 0;0;0
4543 0;0;0
4544 0;0;0
4545 0;0;0
4546 EQ1-1;EQ2-1;EQ3-1
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
4558 SIIM, ENTERF;FLDAA2
4559 SIIA, 0
4560 SIRM, ENTERF;FLDAA2
4561 SIRA, A0FN+MAC;0
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
4566 SCCM=GC2
4567 SCIM, ENTERF;FLDAA2
4568 SCIA, ENTERE;0
4569 SCCA=GCAC
4570 SLIM, ENTERF;FLDAA2
4571 SLIA, JSA;LTRNE;0
4572 SLCM, GC2+MAC;ENTERF;SLIA+MAC;0
4573 SLCA, ENTERF;GCAC+1+MAC;SLIA+MAC;0
4574 SIDM, ENTERE;FLDAA2
4575 SIDA, ENTERF;SIRA+MAC;0
4576 SRDM, ENTERE;FLDAA2
4577 SRDA, ENTERF;0
4578 SCDM, ENTERE;FLDAA2
4579 SCDA, FSTA;TEMPN;ENTERF;FLDA;TEMPN;ENTERE;0
4580 SDIM, ENTERF;FLDAA2
4581 SDIA, ENTERE;0
4582 SDCM, ENTERE;FLDAA2;PCAC+MAC
4583 SDCA, ENTERF;GCAC+1+MAC;ENTERE;0
4584 SDDM, ENTERE;FLDAA2
4585 SDDA, 0
4586 SLDM, ENTERE;FLDAA2
4587 SLDA, JSA;LTRNE;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
4591 NIM, ENTERF;FLDAA1
4592 NIA, FNEG;0;0
4593 NCM, GC1+MAC;PCAC+MAC;JSACNG+MAC;0
4594 NCA=JSACNG
4595 NDM, ENTERE;NIM+1+MAC;0
4596 NOTTBL, 0;0;0;0;NOTM-1
4597 0;0;0;0;NOTA-1
4598 NOTM, ENTERF;FLDAA1
4599 NOTA, 0
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
4603 GI, ENTERF;FLDAA1;0
4604 GC, GC1+MAC;0
4605 GD, ENTERE;FLDAA1;0
4606 \f/OPERATOR DISPATCH TABLE
4607
4608 XPUSH, PUSH
4609 ADD
4610 SUB
4611 MUL
4612 DIV
4613 EXP
4614 NOT
4615 NEG
4616 GE
4617 GT
4618 LE
4619 LT
4620 DNA
4621 OR
4622 EQ
4623 NE
4624 XOR
4625 EQV
4626 PAUZE
4627 DPUSH
4628 BINRD1
4629 FMTRD1
4630 WCLOSE /**
4631 DARD1
4632 BINWR1
4633 FMTWR1
4634 WCLOSE
4635 DAWR1
4636 DEFFIL
4637 ASFDEF
4638 ARGS
4639 EOSTMT
4640 ERROR
4641 RETURN
4642 REWIND
4643 STORE
4644 XEND, END
4645 DEFLBL
4646 DOFINI
4647 ARTHIF
4648 XLOGIF, LIFBGN
4649 DOBEGN
4650 ENDFIL
4651 STOP
4652 ASSIGN
4653 BAKSPC
4654 FORMAT
4655 XGOTO, GOTO
4656 CGOTO
4657 AGOTO
4658 IOLMNT
4659 DATELM
4660 DREPTC
4661 DATAST
4662 ENDELM
4663 PURGE
4664 XLAST, DOSTOR
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
4670 0;0;0;0;0;0;0;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
4678 $
4679 \f
My complete PDP-8 universe