Commit | Line | Data |
---|---|---|
7af5ad59 PH |
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 |