projects / pdp8.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
A large commit.
[pdp8.git] / sw / os8 / v3d / sources / fortran / all / f4.pa
1 /4 OS/8 FORTRAN (PASS ONE)
2 /
3 / VERSION 4A PT 16-MAY-77
4 /
5 / OS/8 FORTRAN COMPILER - PASS 1
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/CHANGES FOR MAINTENANCE RELEASE (S.R.):
40
41 /1. BUMPED VERSION NUMBER TO 304
42 /2. INCLUDED PATCH SEQ #4 (OCT DSN) FOR SF ERROR FIX
43 /3. INCLUDED PATCH SEQ #6 (TEMP VARS IN ASF)
44 /4. FIXED PROBLEM IN DATA STATEMENT
45 /5. STOPPED HALT AFTER OT ERROR BY CONVERTING LOGICAL
46 / VARS TO INTEGER IN ARITHMETIC IF STATEMENT
47 /6. FIXED BUG RE /A AND .RA EXTENSION
48
49 /LAST MINUTE CHANGES:
50
51 /7. ALLOWED PARITY INPUT
52 /8. IGNORE NULLS ON INPUT
53 /9. FIXED BUG RE IGNORING LAST LINE IF IN ERROR
54 / OR IN FACT IGNORING ANY LAST LINE IF NO END STATEMENT
55 /10. ALLOW MULTIPLE INPUT FILES
56 /
57 /
58 /CHANGES FOR OS/8 V3D AND OS/78 BY P.T.
59 / .PATCH LEVEL NOW CONTAINED IN LOCATION 1130
60 \f *7
61 LINENO, 1 /2.01/ LINE NUMBER
62 X10, 0 /AUTO INDEX REGISTERS
63 X11, 0
64 X12, 0
65 NEXT, FREE-1 /FREE SPACE POINTER
66 STACK, STACKS-1 /STACK POINTER
67 CHRPTR, 0 /INPUT BUFFER POINTER
68 X16, 0
69 X17, 0
70 STKLVL, STACKS-1 /STACK BASE LEVEL
71 BUCKET, 0 /FIRST CHAR OF NAME
72 WORD1, 0 /SIX WORD LITERAL BUFFER
73 WORD2, 0
74 WORD3, 0
75 WORD4, 0
76 WORD5, 0
77 WORD6, 0
78 ACO, 0 /FLOATING AC OVERFLOW WORD
79 OP1, 0 /SEVEN WORD OPERAND FOR "NUMBER"
80 OP2, 0
81 OP3, 0
82 OP4, 0
83 OP5, 0
84 OP6, 0
85 OPO, 0
86 CHAR, 0 /ICHAR PUTS CHARACTER HERE
87 NOCODE, 0 /IS 1 IF CODE GENERATION OFF
88 NCHARS, 0 /SIZE OF INPUT LINE
89 NUMELM, 0 /NUMBER OF VARS IN TYPED LIST
90 TEMP, 0
91 TEMP2, 0
92 DECPT, 0 /SET 1 IF NUMBER CONTAINED .
93 ESWIT, 0 /1 FOR E 0 FOR D
94 NDIGIT, 0 /NUMBER OF DIGITS TO RIGHT OF .
95 HCHAR, HCOUNT /HOLLERITH GETTER ROUTINE
96 SNUM, 0 /POINTER TO ST ENTRY FOR STMT NUMBER
97 IFSWIT, 0 /=1 IF INSIDE LOGICAL IF
98 EXPON, 0 /HOLDS EXPONENT FOR CONVERSION
99 TMPFIL, 0617;2224;2216;2415 /PASS1 OUTPUT FILE
100 0;0;0;0 /PASS2 OUTPUT FILE
101 DOEND, 0 /SET 1 IF THIS STMT WAS A IF,
102 /GOTO, RETURN, PAUSE, OR STOP
103 THSNUM, 0 /CURRENT STATEMENT NUMBER
104 DIMNUM, 0 /LINEARIZED SS FOR EQ
105 DPRDCT, 0 /HOLDS DIMENSION PRODUCT
106 EQTEMP, 0 /TEMP FOR EQUIVALENCE
107 MQ, 0 /MQ FOR 12 BIT MULTIPLY
108 MASTER, 0 /POINTER TO MASTER IN EQUIV GROUP
109 MNUM, 0 /LINEARIZED SS FOR MASTER
110 NSLAVE, 0 /NUMBER OF SLAVES IN GROUP
111 PASS2O, 0 /START OF PASS 2 OVERLAY SECTION
112 OUFILE, 0 /START OF PASS1 OUTPUT FILE
113 DSERES, 0 /MAGIC NUMBER
114 PROGNM, MAIN /POINTER TO PROG NAME
115 ARGLST, 0 /POINTER TO ARG LIST
116 FUNCTN, 0 /0=MAIN, 1=FUNCTION, -2=SUBROUTINE
117 SETBIT, 0 /TEMPS FOR DECLARATION SCANNER
118 BADBIT, 0
119 DOINDX, 0 /POINTER TO DO INDEX FOR DO LOOPS
120 TLTEMP, 0 /TEMP FOR TYPE ROUTINE
121 OWTEMP, 0 /TEMP FOR OUTWRD
122 CNT72, -102 /72 COLUMN COUNTER
123 DPUSED, 0 /=1 IF DOUBLE HARDWARE USED
124 VERS, VERSON /VERSION NUMBER
125 M211, -211
126 P211, 211
127 P240, 240
128 IXLNP5, LINE+5 /**
129 IXLINE, LINE
130 IXLINM, LINE-1
131 STMJMP, 0 /FOR DEFINE FILE
132 \f/ OPCODES AND EQUS
133 MAXHOL=100 /MAXIMUM HOLLERITH LITERAL
134 COMREG=4600 /INTER-PASS COMMUNICATION REGION
135 STACKS=4700 /STACK AREA
136 NAME1=6200 /NAME AND HOLLERITH BUFFER (WAS 6400)**
137 LINE=6300 /LINE BUFFER (WAS 6500)**
138 INBUF=6600 /INPUT BUFFER (FIELD 1)
139 OUBUF=7200 /OUTPUT BUFFER (DITTO)
140 INDEVH=7200 /INPUT DEVICE HANDLER (WAS 7400)**
141 PAUSOP=22
142 DPUSH=PAUSOP+1
143 BINRD1=DPUSH+1 /OPCODE DEFINITIONS
144 FMTRD1=BINRD1+1
145 RCLOSE=FMTRD1+1
146 DARD1=RCLOSE+1
147 BINWR1=DARD1+1
148 FMTWR1=BINWR1+1
149 WCLOSE=FMTWR1+1
150 DAWR1=WCLOSE+1
151 DEFFIL=DAWR1+1
152 ASFDEF=DEFFIL+1
153 ARGSOP=ASFDEF+1
154 EOLCOD=ARGSOP+1
155 ERRCOD=EOLCOD+1
156 RETOPR=ERRCOD+1
157 REWOPR=RETOPR+1
158 STOROP=REWOPR+1
159 ENDOPR=STOROP+1
160 DEFLBL=ENDOPR+1
161 DOFINI=DEFLBL+1
162 ARTHIF=DOFINI+1
163 LIFBGN=ARTHIF+1
164 DOBEGN=LIFBGN+1
165 ENDFOP=DOBEGN+1
166 STOPOP=ENDFOP+1
167 ASNOPR=STOPOP+1
168 BAKOPR=ASNOPR+1
169 FMTOPR=BAKOPR+1
170 GO2OPR=FMTOPR+1
171 CGO2OP=GO2OPR+1
172 AGO2OP=CGO2OP+1
173 IOLMNT=AGO2OP+1
174 DATELM=IOLMNT+1
175 DREPTC=DATELM+1
176 DATAST=DREPTC+1
177 ENDELM=DATAST+1
178 PRGSTK=ENDELM+1
179 DOSTOR=PRGSTK+1
180 / ASSEMBLE STATEMENT
181 PAGE
182 RDLOOP, CIF 10 /FOR OS/8 2 PG HANDLERS**
183 JMS I [ICHAR /GET CHAR FROM INPUT FILE
184 JMP ENDLIN /END LINE OR CR
185 TAD M211 /CHECK FOR TAB**
186 SNA
187 TAD (240-211 /CONVERT TO BLANK
188 TAD P211 /**
189 DCA I CHRPTR /SAVE CHAR
190 ISZ CNT72 /PAST COLUMN 72 ?
191 SKP
192 JMP SKPLIN /SKIP 73 TO 80
193 TAD CHRPTR
194 CIA CLL
195 TAD (LINE+670
196 SZL CLA /TEST FOR TOO MANY CONTINUATIONS
197 JMP RDLOOP
198 JMS I [ERMSG /LINE TOO LONG
199 1424
200 SKPCOM, TAD X16 /RESTORE CHRPTR
201 DCA CHRPTR
202 SKPLIN, CIF 10 /**
203 JMS I [ICHAR /SKIP REST OF LINE
204 JMP ENDLIN
205 CLA
206 JMP SKPLIN
207 ENDLIN, TAD CHRPTR /SAVE CHAR POSITION
208 DCA X16
209 TAD CHRPTR
210 DCA X10 /SAVE POSITION FOR COMMENT CHECK
211 TAD (-102 /SET COLUMN COUNT
212 DCA CNT72
213 TAD M6
214 DCA NCHARS
215 GET6, CIF 10 /**
216 JMS I [ICHAR /GET FIRST 6 CHARS
217 JMP SHORTL /IGNORE SHORT LINES
218 TAD M211 /IS CHAR A TAB ? **
219 SZA CLA
220 JMP NOTAB /NO
221 TAD P240 /TREAT FIRST TAB AS SIX BLANKS
222 DCA I CHRPTR
223 ISZ NCHARS
224 JMP .-3
225 TAD P240 /FAKE CONTINUATION CHECK
226 DCA CHAR
227 JMP CCHECK /GO TO COMMENT CHECK
228 SHORTL, TAD X16 /RESET CHAR POINTER
229 DCA CHRPTR /TO IGNORE SHORT LINES
230 JMP ENDLIN
231 NOTAB, TAD CHAR
232 DCA I CHRPTR
233 ISZ NCHARS
234 JMP GET6 /LOOP
235 CCHECK, TAD I X10 /IS IT A COMMENT ?
236 TAD (-303
237 SNA CLA
238 JMP SKPCOM /COMMENT, SKIP REST
239 NOCMNT, TAD CHAR /WAS SIXTH CHAR A BLANK ?
240 TAD MMM240
241 SNA CLA
242 JMP GOTLIN /YES, NO MORE CONTINUATIONS
243 CCARD, TAD X16 /IGNORE THESE SIX CHARACTERS
244 DCA CHRPTR
245 JMP RDLOOP /CONTINUE WITH THIS LINE
246 GOTLIN, TAD CHRPTR /COMPUTE -NCHARS-1
247 CIA
248 TAD (LINE+4
249 DCA NCHARS
250 TAD [LINE-1 /RESET CHAR POINTER
251 DCA CHRPTR
252 JMS I [CKCTLC /CHECK FOR CONTROL C
253 LINE1, DCA THSNUM /ZERO CURRENT STMT NUMBER
254 CLL CML RAR /SET LABEL DEFINE BIT
255 JMS I [STMNUM /GO LOOK FOR LABEL
256 JMP COMPIL /NONE THERE
257 TAD SNUM /SAVE STATEMENT NUMBER
258 DCA THSNUM
259 TAD (DEFLBL /OUTPUT DEFINITION FOR THIS LABEL
260 JMS I [OUTWRD
261 TAD SNUM
262 JMS I [OUTWRD /FOLLOWED BY THE LABEL ADDRESS
263 COMPIL, JMS I [SAVECP
264 ISZ LINENO /2.01/ PUT LINE NUMBER
265 TAD LINENO /2.01/ INTO MQ
266 7421 /2.01/
267 CLA IAC
268 DCA NOCODE /SET NOCODE SWITCH
269 JMS I [ERMSG /SET UP DEFAULT ERROR MESSAGE
270 1513
271 JMS I [LEXPR /IS IT ARITHMETIC ?
272 JMP NOTAR /NO
273 JMS I [GETC /LOOK FOR =
274 JMP NOTAR /NOT ARITHMETIC
275 TAD MMM275 /=
276 SNA CLA
277 JMS I [EXPR /SCAN LEFT PART
278 JMP NOTAR
279 JMS I [ERMSG /SET MESSAGE TO ILLEGAL OPERATOR
280 1720
281 ISZ NCHARS /SHOULD BE NOTHING LEFT
282 JMP NOTAR /IF THERE IS, ITS NOT ARITHMETIC
283 ITSAR, JMS I [RESTCP /RESTORE TO START OF LINE
284 DCA NOCODE /ALLON CODE
285 JMS I [LEXPR /GET LEFT SIDE
286 M6, -6 /V3C MUST BE HERE
287 JMS I [GETC /SKIP =
288 MMM240, -240 /SHOULD NEVER GET HERE
289 CLA
290 JMS I [EXPR /GET RIGHT SIDE
291 MMM275, -275 /SHOULD NEVER GET HERE
292 TAD (STOROP /OUTPUT STORE
293 JMS I [OUTWRD
294 JMP I [NEXTST /DO NEXT LINE
295 NOTAR, JMS I [RESTCP /RESTART LINE
296 DCA NOCODE
297 JMS I [SAVECP /RESAVE CHAR POSITION
298 TAD (CMDLST-1
299 DCA X10
300 JMP I (CMDLUP /GO SEARCH FOR KEYWORD
301 \f/ KEYWORD SEARCH
302 PAGE
303 CMDLUP, CDF 10 /TABLE IN FIELD ONE
304 TAD I X10 /GET NEXT 2 CHARS OF KEYWORD
305 SZA
306 JMP CMDLP2 /NOT DONE YET
307 CLL CMA RAL /REMOVE CHAR POS FROM STACK
308 TAD STACK
309 DCA STACK
310 TAD I X10 /GET ROUTINE ADDRESS
311 CDF
312 DCA STMJMP
313 JMP I STMJMP /JUMP TO THE ROUTINE
314 CMDLP2, DCA TEMP /SAVE THE TWO CHARS
315 CDF
316 JMS I [GET2C /GET TWO CHARS FROM THE INPUT
317 JMP .+4 /NOT ENOUGH CHARS, CAN'T BE THIS ONE
318 TAD TEMP /COMPARE
319 SNA CLA
320 JMP CMDLUP /MATCHES, KEEP GOING
321 JMS I [RESTCP /RESTORE CHAR POS
322 ISZ STACK
323 ISZ STACK /AND SAVE IT AGAIN
324 CDF 10
325 TAD I X10 /FIND END OF THIS COMMAND
326 SZA CLA
327 JMP .-2
328 ISZ X10 /SKIP ROUTINE ADDRESS
329 TAD I X10 /IS THE LIST EXHAUSTED ?
330 SZA
331 JMP CMDLP2 /NO, GO AGAIN
332 BADCMD, JMS I [ERMSG /TREAT AS BAD ARITHMETIC STMT
333 ERCODE, 0
334 \f/ END OF STMT PROC
335 NEXTLN,
336 NEXTST,
337 DOENDR, TAD STKLVL /RESET STACK POINTER
338 DCA STACK
339 JMS I [POP /LOOK FOR DO END
340 CIA
341 TAD THSNUM /DOES THIS LINE END A DO LOOP ?
342 SZA CLA
343 JMP NODOND /NO, REPLACE STACK AND COMPILE STMT
344 TAD (DOFINI
345 JMS I [OUTWRD /OUTPUT DO END COMMAND
346 JMS I [POP /GET INDEX VARIABLE
347 JMS I [OUTWRD
348 TAD STACK /RESET STACK BASE LEVEL
349 DCA STKLVL
350 TAD DOEND /WAS THIS A LEGAL ENDING STMT ?
351 SZA CLA
352 JMS I [ERMSG
353 0504 /DO END ERROR
354 DCA DOEND /KILL SWITCH
355 JMP DOENDR
356 NODOND, ISZ STACK /REPLACE STACK ENTRY
357 DCA DOEND /KILL SWITCH
358 TAD (EOLCOD /OUTPUT EOL CODE
359 JMS I [OUTWRD
360 DCA ERCODE /RESET ERROR CODE
361 DCA IFSWIT /KILL IF SWITCH
362 TAD (-6 /MOVE FIRST 6 CHARS
363 DCA NCHARS
364 TAD [LINE-1 /INTO START OF BUFFER
365 DCA CHRPTR
366 TAD I X16
367 DCA I CHRPTR
368 ISZ NCHARS
369 JMP .-3
370 JMP I (RDLOOP
371 \f/ GOTO'S
372 GOTO, ISZ DOEND /DO END ILLEGAL
373 JMS I [STMNUM /IS IT A SIMPLE GOTO ?
374 JMP CMPGO2 /NO, SEE IF ITS A COMPUTED ONE
375 TAD (GO2OPR /OUTPUT GOTO OPERATOR
376 JMS I [OUTWRD
377 TAD SNUM /FOLLOWED BY STMT NUMBER
378 JMS I [OUTWRD
379 JMP I [NEXTST
380 CMPGO2, JMS I [GETC /LOOK FOR (
381 JMP BADGO2 /BAD GOTO
382 TAD (-250
383 SZA CLA
384 JMP ASNGO2 /NOT ( , MAYBE ITS AN ASSIGNED GOTO
385 TAD STACK /SAVE STACK POSITION
386 DCA X12
387 DCA TEMP /ZERO BRANCH COUNTER
388 GO2LUP, JMS I [STMNUM /GET NEXT STMT NUMBER
389 JMP BADGO2 /MUST BE THERE
390 TAD SNUM
391 JMS I [PUSH /SAVE IT TEMPORARILY
392 ISZ TEMP /BUMP BRANCH COUNT
393 JMS I [COMARP /LOOK FOR COMMA OR RIGHT PAREN
394 JMP BADGO2 /NEITHER
395 JMP GO2LUP /COMMA, GO GET NEXT LABEL
396 JMS I [GETC /SKIP NEXT CHAR (ITS A COMMA)
397 JMP BADGO2
398 CLA
399 TAD TEMP /SAVE COUNT
400 JMS I [PUSH /ON STACK
401 JMS I [EXPR /COMPILE INDEX EXPR
402 JMP I [NEXTST
403 TAD (CGO2OP /OUTPUT COMPUTED GOTO OPERATOR
404 JMS I [OUTWRD
405 JMS I [POP /GET COUNT
406 CIA
407 DCA TEMP /SAVE COMPLEMENT
408 TAD TEMP
409 CIA
410 JMS I [OUTWRD /OUTPUT COUNT
411 TAD X12 /RESTORE STACK POINTER
412 DCA STACK
413 TAD I X12 /MOVE STMT NUMBERS TO OUTPUT
414 JMS I [OUTWRD
415 ISZ TEMP
416 JMP .-3
417 JMP I [NEXTST
418 ASNGO2, JMS I [BACK1 /PUT BACK NON (
419 JMS I [LEXPR /GET ASSIGN VAR
420 JMP BADGO2
421 TAD (AGO2OP /OUTPUT GOTO OPERATOR
422 JMS I [OUTWRD
423 JMP I [NEXTST
424 BADGO2, JMS I [ERMSG
425 0724
426 JMP I [NEXTST
427 \f/ I/O STATEMENTS
428 PAGE
429 RDWR, 0 /SUBR FOR IO STATEMENTS
430 JMS I [CHECKC /LOOK FOR (
431 M250, -250
432 JMP BADRD
433 JMS I [EXPR /COMPILE UNIT
434 JMP I [BADCMD
435 JMS I [COMARP
436 JMP DAQUOT /LOOK FOR ' (DIRECT ACCESS I/O)
437 JMP RDFMT /,
438 TAD (BINRD1 /FORMATLESS READ/WRITE
439 IOSTRT, TAD I RDWR /ADD ADJUSTOR
440 JMS I [OUTWRD /OUTPUT BINARY READ
441 IOLIST, JMS I [PUSH /MARK STACK
442 JMS I [GETC /IS IT AN IMPLIED DO ?
443 JMP ENDIOL /NO, END OF LIST
444 TAD M250
445 SZA CLA
446 JMP TRYIOE /NO, LOOK FOR IO ELEMENT
447 JMS I [SAVECP /SAVE CHAR POS AT START OF IDO
448 DCA IDOPAR /ZERO PAREN COUNTER
449 FINDND, JMS I [GETNAM /GET A NAME IF THERE IS ONE
450 XPURGE, PRGSTK /DON'T WORRY ITS A NOP
451 JMS I [GETC /GET A CHAR
452 JMP ENDIOL
453 TAD M251 /IS IT A ) ?
454 SNA
455 JMP RPIOL /YES
456 IAC /IS IT ( ?
457 SNA
458 JMP LPIOL /YES
459 TAD (250-275 /IS IT = ?
460 SZA CLA
461 JMP FINDND /NONE OF THESE
462 TAD IDOPAR /IS PAREN COUNT 0 ?
463 SZA CLA
464 JMP FINDND /NO, ITS FROM AN INNER LOOP
465 JMS I [LOOKUP /THIS ELEMENT IS THE DO INDEX
466 DCA DOINDX
467 JMS I (DOSTUF /COMPILE THE LOOP
468 JMP BADIOL /ERROR IN DO PARMS
469 JMS I [CHECKC /MUST HAVE )
470 -251
471 JMP BADIOL
472 TAD CHRPTR /SAVE CHAR POSITION
473 DCA TEMP
474 TAD NCHARS
475 DCA TEMP2
476 JMS I [RESTCP /RESTORE TO START OF IMPLIED LOOP
477 TAD TEMP2 /NOW SAVE POS AFTER LOOP
478 JMS I [PUSH
479 TAD TEMP
480 JMS I [PUSH
481 TAD DOINDX /AND DO INDEX
482 JMP IOLIST
483 LPIOL, ISZ IDOPAR /( INCREASES COUNT
484 JMP FINDND
485 RPIOL, CMA /) DECREASES COUNT
486 TAD IDOPAR
487 SMA
488 JMP FINDND-1
489 CLA
490 BADIOL,
491 BADRD, JMS I [ERMSG /BAD IO STMT
492 2227
493 JMP I [NEXTST
494 TRYIOE, JMS I [BACK1 /PUT BACK NON (
495 JMS I [LEXPR /GET IOLIST ELEMENT
496 JMP BADRD /NOT THERE, ERROR
497 JMS I [GETC /LOOK FOR A COMMA
498 JMP .+4 /EOL
499 TAD (-254
500 SZA
501 JMP NOTIOL /NOT AN ELEMENT
502 TAD (IOLMNT /OUTPUT OPCODE
503 JMS I [OUTWRD
504 JMP IOLIST+1
505 NOTIOL, TAD (254-275 /IS IT AN = (END OF IDO)
506 SZA CLA
507 JMP BADIOL /NO, BAD
508 JMS I [POP /GET STUFF FROM THE STACK
509 SNA
510 JMP BADIOL /ZERO IS BAD
511 DCA DOINDX /THIS IS THE INDEX
512 JMS I [RESTCP /GET THE CHAR POSITION
513 TAD XPURGE /OUTPUT PURGE OPERATOR
514 JMS I [OUTWRD /BECAUSE AN EXTRA IS ON THE STK
515 TAD (DOFINI /END LOOP
516 JMS I [OUTWRD
517 TAD DOINDX
518 JMS I [OUTWRD
519 JMS I [GETC /END OF LIST ?
520 JMP ENDIOL
521 TAD (-254
522 SZA CLA
523 JMP BADIOL /MUST BE A COMMA
524 JMP IOLIST+1
525 IDOPAR, 0
526 ENDIOL, JMS I [POP /IS THE MARK THERE ?
527 SZA CLA
528 JMP BADRD /NO, ERROR
529 TAD I RDWR
530 TAD (RCLOSE /END OF IO OPERATION
531 JMS I [OUTWRD
532 JMP I [NEXTST
533 RDFMT, JMS I [STMNUM /LOOK FOR FMT LINE NUMBER
534 JMP RTFMT
535 JMS I [OUTWRD /OUTPUT PUSH COMMAND
536 TAD SNUM /OUTPUT STMT NUMBER OF FORMAT
537 JMS I [OUTWRD
538 RDLIST, TAD (FMTRD1 /START OF FORMATTED READ
539 TAD I RDWR /ADD ADJUSTOR
540 JMS I [OUTWRD
541 JMS I [CHECKC /LOOK FOR )
542 M251, -251
543 JMP BADRD
544 JMP IOLIST /GO GET IO LIST
545 RTFMT, JMS I [LEXPR /GET R.T. FORMAT
546 JMP BADRD
547 JMP RDLIST /GET LIST
548 \f/DIRECT ACCESS I/O
549 PAGE
550 DAQUOT, JMS I [BACK1
551 JMS I [CHECKC /LOOK FOR '
552 -247
553 JMP BADRD /SYNTAX IS NO GOOD
554 JMS I [EXPR /GET RECORD NUMBER EXPR
555 JMP BADRD
556 JMS I [CHECKC /LOOK FOR )
557 -251
558 JMP BADRD
559 TAD (DARD1 /DIRECT ACCESS OPEN
560 JMP IOSTRT
561 FIND, JMP I [NEXTST /COOL ISN'T IT ?
562 DFINFL, JMS I [EXPR /COMPILE UNIT
563 JMP BADDEF /BAD DEFINE STMT
564 DCA STMJMP /PERMIT VARIABLE FOR LOG UNIT
565 JMS I [CHECKC /(
566 -250
567 JMP BADDEF
568 JMS I [EXPR /NUMBER OF RECORDS
569 JMP BADDEF
570 JMS I [CHECKC /,
571 -254
572 JMP BADDEF
573 JMS I [EXPR /RECORD SIZE
574 JMP BADDEF
575 JMS I [CHECKC /,
576 -254
577 JMP BADDEF
578 JMS I [CHECKC /U
579 -325
580 JMP BADDEF
581 JMS I [CHECKC /,
582 MCOMA, -254
583 JMP BADDEF
584 JMS I [GETNAM /GET INDEX VARIABLE
585 JMP BADDEF
586 JMS I [OUTWRD
587 JMS I [LOOKUP
588 JMS I [OUTWRD /OUTPUT INDEX VAR
589 TAD (DEFFIL /OUTPUT DEFINE OPERATOR
590 JMS I [OUTWRD
591 JMS I [CHECKC /)
592 -251
593 JMP BADDEF
594 JMS I [GETC /ANOTHER DEFINE ?
595 JMP I [NEXTST
596 TAD MCOMA /, ?
597 SNA CLA
598 JMP DFINFL /YES, ANOTHER FILE
599 BADDEF, JMS I [ERMSG /BAD DEFINE FILE STMT
600 0406
601 JMP I [NEXTST
602 RESTCP, 0 /RESTORE CHAR POSITION FROM STACK
603 JMS I [POP
604 DCA CHRPTR
605 JMS I [POP
606 DCA NCHARS
607 JMP I RESTCP
608 INTEGE, JMS I [CHECKC /INTEGER STMT
609 -322
610 JMP I [BADCMD
611 JMS I [TYPLST
612 0101
613 0100
614 NOP
615 JMP I [NEXTST
616 PAUZE, JMS I [CHECKC /LOOK FOR E
617 -305
618 JMP I [BADCMD
619 JMS I [GETC /ANY EXPR ?
620 JMP NOARGP /MAKE IT PAUSE 1
621 JMS I [BACK1 /PUT IT BACK
622 JMS I [EXPR /GET PAUSE NUMBER
623 XPAUZ, PAUSOP
624 OPAUZ, TAD XPAUZ /OUTPUT PAUSE OPERATOR
625 JMS I [OUTWRD
626 JMP I [NEXTST
627 NOARGP, JMS I [OUTWRD /PUSH 1.0
628 TAD [ONE
629 JMS I [OUTWRD
630 JMP OPAUZ /GO PUT OPERATOR
631 READ, JMS I (RDWR /COMPILE READ STMT
632 0
633 WRITE, JMS I [CHECKC /LOOK FOR E
634 -305
635 JMP I [BADCMD
636 JMS I (RDWR /COMPILE WRITE
637 BINWR1-BINRD1
638 CKCTLC, 6401 /CHECK FOR CONTROL C
639 TAD (7600
640 KRS
641 TAD (-7603 /^C
642 SNA CLA
643 KSF
644 JMP I CKCTLC
645 JMP I (7600
646
647 XOCTAL, DCA WORD1 /**
648 DCA WORD2
649 DCA WORD3 /STATEMENT NUM LEFT THERE**
650 DCA WORD5
651 DCA WORD6
652 XCTAL1, DCA WORD4
653 JMS I [DIGIT /GET NEXT DIGIT
654 JMP ENDOXT /NO DIGITS LEFT
655 AND [7 /THROW AWAY SOME BITS
656 DCA TEMP
657 JMS I (AL1 /MOVE WORD LEFT THREE
658 JMS I (AL1
659 JMS I (AL1
660 TAD WORD4 /ADD DIGIT TO WORD4
661 TAD TEMP
662 JMP XCTAL1 /LOOP
663 ENDOXT, TAD WORD2 /PUT WORDS INTO THE LEFT PLACE
664 DCA WORD1
665 TAD WORD3
666 DCA WORD2
667 TAD WORD4
668 DCA WORD3
669 JMP DATAFP /GO STUFF IT AWAY
670 \f/ DIMENSION, COMMON, REAL
671 PAGE
672 DIMENS, JMS I [IFCHEK
673 JMS I [CHECKC /CHECK FOR "N"
674 -316
675 JMP I [BADCMD /NO GOOD
676 JMS I [TYPLST /PROCESS LIST
677 0000 /DIMENSION IS THE SIMPLEST CASE
678 0000
679 NOP /ERROR RETURN
680 JMP I [NEXTST
681 REAL, JMS I [IFCHEK /CHECK FOR INSIDE IF
682 JMS I [TYPLST /PROCESS LIST
683 0102 /TYPE-REAL
684 0100
685 NOP
686 JMP I [NEXTST
687 COMPLE, JMS I [CHECKC /CHECK FOR "X"
688 -330
689 JMP I [BADCMD
690 JMS I [IFCHEK
691 JMS I [TYPLST /PROCESS COMPLEX LIST
692 0103
693 0100
694 NOP
695 CLA IAC /SET DP SWITCH
696 DCA DPUSED
697 JMP I [NEXTST
698 COMMON, JMS I [IFCHEK /BAD INSIDE LOGICAL IF
699 JMS I [GETC /CHECK FOR SLASH
700 JMP I [BADCMD
701 TAD M257
702 SZA CLA
703 JMP BLANKC /MUST BE BLANK COMMON
704 JMS I [GETNAM /GET NAME OF COMMON
705 JMP DBLSLS /MIGHT BE //
706 JMS I [CHECKC /LOOK FOR /
707 M257, -257
708 JMP BADCOM
709 JMS I [LOOKUP /LOOKUP COMMON NAME
710 IAC
711 DCA COMNAM /SAVE ADDR OF TYPE WORD
712 CDF 10
713 TAD I COMNAM /LOOK AT TYPE
714 SZA
715 TAD (-111 /MUST BE COMMON OR UNDEF.
716 SZA CLA
717 JMP BADCOM
718 TAD (111 /SET CORRECT BITS
719 DCA I COMNAM
720 CDF
721 DOCOMN, JMS I [TYPLST /HANDLE LIST
722 4000
723 5460
724 JMP I [NEXTST
725 TAD X12
726 DCA STACK /RESET STACK
727 CDF 10
728 ISZ COMNAM /POINTER TO COMMON INFO
729 DCA I NEXT /ZERO NEXT PTR WORD
730 TAD I COMNAM /LOOK FOR END OF LIST
731 SNA
732 JMP EOCL /THIS IS IT
733 DCA COMNAM /PROCEED DOWN LIST
734 JMP .-4
735 EOCL, TAD NEXT /HOOK IN NEXT PART
736 DCA I COMNAM
737 TAD NUMELM
738 DCA I NEXT /NUMBER IN THIS PART
739 TAD NUMELM
740 CIA
741 DCA NUMELM
742 CDF
743 TAD I X12 /MOVE VARIABLE PTRS
744 CDF 10
745 DCA I NEXT
746 ISZ NUMELM
747 JMP .-5
748 CDF
749 JMS I [GETC /ANOTHER BLOCK ?
750 JMP I [NEXTST /NO
751 JMP COMMON+3 /MAYBE
752 DBLSLS, JMS I [CHECKC /LOOK FOR SECOND SLASH
753 -257
754 JMP BADCOM
755 SKP
756 BLANKC, JMS I [BACK1 /PUT BACK NON SLASH
757 TAD (BLNKCN /USE BLANK COMMON
758 DCA COMNAM
759 JMP DOCOMN
760 BADCOM, JMS I [ERMSG /ERROR IN COMMON STMT
761 0317
762 JMP I [NEXTST
763 COMNAM, 0
764 \f/ EXTERNAL, FORMAT, BACKSPACE
765 EXTERN, JMS I [TYPLST /PROCESS LIST
766 1000
767 6660
768 NOP
769 JMP I [NEXTST
770 FORMAT, TAD (FMTOPR /OUTPUT FORMAT OPERATOR
771 JMS I [OUTWRD
772 TAD NCHARS /GET NUMBER OF WORDS
773 CIA
774 CLL RAR /NWORDS=(NCHARS+1)/2
775 FMTLUP, JMS I [OUTWRD /OUTPUT IT
776 JMS I [GETCWB /GET THE CHARS
777 JMP I [NEXTST /NO MORE
778 AND [77
779 CLL RTL /SHIFT LEFT 6
780 RTL
781 RTL
782 DCA TEMP
783 JMS I [GETCWB /GET OTHER HALF
784 NOP /IGNORE END OF LINE
785 AND [77
786 TAD TEMP /PUT THEM TOGETHER
787 JMP FMTLUP /LOOP
788 /NOTE : THE ENTIRE FORMAT INCLUDING PARENTHESIS ()
789 / IS PASSED TO THE CODE
790 BACKSP, JMS I [CHECKC /CHECK FOR "E"
791 -305
792 JMP I [BADCMD
793 JMS I [EXPR /COMPILE UNIT EXPR
794 JMP I [BADCMD
795 TAD (BAKOPR /OUTPUT BACKSPACE OPERATOR
796 JMS I [OUTWRD
797 JMP I [NEXTST
798 \f/ OUTPUT ROUTINE
799 PAGE
800 OUPTR, OUBUF
801 OCOUNT, -401
802 OUTWRD, 0 /OUTPUT ROUTINE
803 DCA OWTEMP /SAVE WORD
804 TAD NOCODE
805 SZA CLA
806 JMP I OUTWRD /COOL IT IF NOCODE
807 ISZ OCOUNT /TEST FOR BUFFER FULL
808 JMP NOWRIT /STILL SOME ROOM
809 JMS OUDUMP /DUMP THE BUFFER
810 TAD OUBLOK-1 /RESET BUFFER PARAMETERS
811 DCA OUPTR
812 TAD (-400
813 DCA OCOUNT
814 NOWRIT, TAD OWTEMP /PUT WORD
815 CDF 10
816 DCA I OUPTR /INTO BUFFER
817 CDF
818 ISZ OUPTR /MOVE POINTER
819 JMP I OUTWRD
820 OULEN, 0 /NUMBER OF BLOCKS LEFT IN HOLE
821 OUDUMP, 0 /DUMP OUT BUFFER
822 TAD OULEN /ANY ROOM LEFT ?
823 SNA
824 JMP OUERR
825 IAC
826 DCA OULEN
827 JMS I (7607 /CALL SYSTEM HANDLER
828 4210
829 OUBUF
830 OUBLOK, 0
831 JMP OUERR
832 ISZ OUBLOK /INCREMENT BLOCK NUMBER
833 ISZ FILSIZ /ALSO SIZE OF FILE
834 JMP I OUDUMP
835 OUERR, JMS I [MESSAG /ERROR IN WRITING OR OPENING FILE
836 317
837 306
838 \f/ END PASS ONE
839 XEND, JMS I [CHECKC /LOOK FOR "D"
840 -304
841 JMP I [BADCMD
842 JMS I [GETC /END MUST BE ALL
843 JMP ENDX
844 L7700, SMA CLA /NEVER SKIPS
845 JMP I [BADCMD
846 ENDX, CDF 0
847 TAD (ENDOPR /OUTPUT END OF FILE
848 JMS I [OUTWRD
849 JMS OUDUMP /DUMP BUFFER
850 CIF 10
851 JMS I L7700 /LOCK MONITOR IN
852 10
853 CIF 10
854 CLA IAC
855 JMS I L200 /CLOSE TEMP FILE
856 4
857 TMPFIL
858 FILSIZ, 0
859 JMP OUERR
860 CIF 10
861 CLA IAC
862 JMS I L200 /OPEN PASS 2 OUTPUT FILE
863 L3, 3
864 OBLK, TMPFIL+4 /STARTING BLOCK
865 0 /SIZE
866 JMP OUERR /ERROR
867 TAD (COMREG-1 /SAVE IMPORTANT STUFF
868 DCA X10
869 TAD NEXT /ADDR OF FREE SPACE
870 DCA I X10
871 TAD STKLVL /STACK LEVEL
872 DCA I X10
873 TAD OUFILE /START OF PASS1 OUTPUT FILE
874 DCA I X10
875 TAD FILSIZ /ALSO THE SIZE
876 DCA I X10
877 TAD PASS2O /START OF PASS2 OVERLAY
878 DCA I X10
879 TAD OBLK /START OF PASS2 OUTPUT FILE
880 DCA I X10
881 TAD OBLK+1 /AND MAX SIZE
882 DCA I X10
883 TAD PROGNM /POINTER TO PROG NAME
884 DCA I X10
885 TAD ARGLST /AND ARG LIST
886 DCA I X10
887 TAD FUNCTN /AND PROG SWITCH
888 DCA I X10
889 TAD DPUSED /STORE THE DP SWITCH
890 DCA I X10
891 TAD VERS /AND THE VERSION NUMBER
892 DCA I X10
893 CIF 10
894 JMS I L200 /CHAIN TO PASS TWO
895 6
896 PASS2B, 0 /FILLED BY ONCE ONLY CODE FOR PASS 1
897 RETURN, TAD (RETOPR /OUTPUT RETURN CODE
898 JMS I [OUTWRD
899 ISZ DOEND /DO END ILLEGAL HERE
900 JMP I [NEXTST
901 COMARP, 0 /LOOK FOR COMMA OR RIGHT PAREN
902 JMS I [GETC
903 JMP I COMARP
904 TAD [-254 /COMMA ?
905 SNA
906 JMP .+5
907 TAD L3 /RIGHT PAREN ?
908 SZA CLA
909 JMP I COMARP
910 ISZ COMARP
911 ISZ COMARP /COMMA INCR ONCE
912 JMP I COMARP
913 LOGICA, JMS I [CHECKC /LOOK FOR L
914 -314
915 JMP I [BADCMD /NO GOOD
916 JMS I [TYPLST /PROCESS LIST
917 0105
918 0100
919 L200, 0200 /NOP
920 JMP I [NEXTST
921 \f/ EQUIVALENCE (UGH!)
922 PAGE
923 EQUIV, JMS I [IFCHEK /BAD WITH IF
924 JMS I [CHECKC /LOOK FOR "E"
925 -305
926 JMP I [BADCMD
927 EQVLUP, JMS I [CHECKC /LOOK FOR (
928 -250
929 JMP BADEQU
930 TAD STACK /SAVE STACK POS
931 DCA X17
932 DCA NSLAVE /NUMBER OF SLAVES = 0
933 JMS I [GETSS /GET THE MASTER
934 JMP BADEQU
935 SVMSTR, CDF 10 /1.03/ CHECK FOR ALREADY EQUIVALENCED
936 TAD I TEMP2 /1.03/
937 CDF /1.03/
938 AND (200 /1.03/ (AS A SLAVE)
939 SZA CLA /1.03/
940 JMP DOFUNY /3.01/BACK UP TO ITS MASTER
941 TAD TEMP2 /SAVE THE MASTER TYPE ADDRESS
942 DCA MASTER
943 DCA SFUDGE /3.01/CLEAR OFFSET FUDGE
944 TAD DIMNUM /SAVE THE MASTER SUBSCRIPT
945 DCA MNUM
946 GETSLV, JMS I [COMARP /LOOK FOR , OR )
947 JMP BADEQU
948 JMP DOSLAV /,
949 TAD NSLAVE /COMPLEMENT THE NUMBER OF SLAVES
950 SNA
951 JMP ENDGRP /NO SLAVES
952 CIA
953 DCA NSLAVE
954 TAD X17 /RESTACK THE STORE
955 DCA STACK
956 EQLOOP, TAD I X17 /GET NEXT SUBSCRIPT NUMBER
957 DCA TEMP
958 TAD I X17 /AND NEXT TYPE WORD ADDRESS
959 DCA TEMP2
960 CDF 10
961 TAD I TEMP2 /LOOK AT TYPE WORD
962 TAD (200 /SET EQUIVALENCE BIT
963 DCA I TEMP2
964 ISZ TEMP2 /MOVE TO EQUIVALENCE/DIMENSION PTR
965 TAD I TEMP2 /PROPAGATE DIMENSION POINTER
966 DCA I NEXT /TO EQUIVALENCE INFO BLOCK
967 TAD NEXT /NOW STORE EQ INFO BLK ADDRESS
968 DCA I TEMP2 /INTO EQ-DIM POINTER WORD
969 CLA CMA
970 TAD MASTER /STORE S.T. ADDR OF MASTER
971 DCA I NEXT /INTO THE EQUIVALENCE BLOCK
972 TAD MNUM /OUTPUT NUMBERS
973 DCA I NEXT
974 TAD TEMP
975 DCA I NEXT
976 CDF
977 ISZ NSLAVE /ANY MORE SLAVES ?
978 JMP EQLOOP /YES, EQUIVALENCE NOT YET ATTAINED
979 ENDGRP, JMS I [GETC /FINI, ALL VARIABLES ARE CREATED
980 JMP I [NEXTST /EQUIVALENCED
981 TAD (-254 /IS NEXT CHAR A COMMA ?
982 SNA CLA
983 JMP EQVLUP /IF YES, DO NEXT GROUP
984 BADEQU, JMS I [ERMSG /SYNTAX ERROR IN EQUIVALENCE
985 2123
986 JMP I [NEXTST
987 EQUCOM, JMS I [ERMSG /MULTIPLE LEVELS OF EQUIVALENCE OR
988 2114 /MORE THAN ONE COMMON VARIABLE
989 JMP I [NEXTST
990 DOSLAV, ISZ NSLAVE /ANOTHER SLAVE VARIABLE
991 JMS I [GETSS /GET THE GOODS
992 JMP BADEQU
993 CDF 10
994 TAD I TEMP2 /LOOK AT THE TYPE
995 SMA CLA
996 JMP SVSLAV /IT ISN'T IN COMMON
997 TAD I MASTER /LOOK AT THE MASTERS TYPE
998 SPA CLA
999 JMP EQUCOM /MASTER IS IN COMMON TOO .. BAD
1000 CDF
1001 TAD MNUM /SAVE THE MAGIC NUMBER
1002 JMS I [PUSH
1003 TAD MASTER
1004 JMS I [PUSH /AND THE S.T. ADDRESS
1005 JMP SVMSTR /NOW GO MAKE THE NEW ONE MASTER
1006 SVSLAV, TAD I TEMP2 /1.03/ PREVIOUSLY EQUIVALENCED ?
1007 AND (200 /1.03/
1008 SZA CLA /1.03/
1009 JMP EQUCOM /1.03/ YES, ERROR
1010 TAD DIMNUM /SAVE THE NEW SLAVE
1011 TAD SFUDGE /3.01/ADD OFFSET FUDGE
1012 CDF
1013 JMS I [PUSH
1014 TAD TEMP2
1015 JMS I [PUSH
1016 JMP GETSLV /AND GO GET THE NEXT SLAVE
1017
1018 SFUDGE, 0
1019 \f/ROUTINE TO HANDLE TRIVIAL CASES OF EQUIVALENCE CHAINING
1020 /THIS WHOLE PAGE IS 3.01
1021
1022 DOFUNY, CLA IAC
1023 TAD TEMP2
1024 DCA MASTER /GET POINTER TO EQUIVALENCE BLOCK
1025 CDF 10
1026 TAD I MASTER
1027 DCA X12
1028 CLA IAC
1029 TAD I X12 /GET ADDRESS OF "REAL" MASTER'S
1030 DCA MASTER /TYPE WORD
1031 TAD I X12
1032 TAD DIMNUM
1033 DCA MNUM /OFFSETS ARE ADDITIVE
1034 TAD I X12
1035 DCA SFUDGE /SAVE OTHER HALF OF OFFSET TO ADD
1036 CDF /TO SLAVES
1037 JMP GETSLV / (PRAY)
1038 PAGE
1039 \f/ EQUIVALENCE (UGH!)
1040 O1420, 1420 /1.03/ MUST BE FIRST ON PAGE
1041 GETSS, 0 /GET THE LINEARIZED SUBSCRIPT
1042 DCA DIMNUM
1043 JMS I [GETNAM /GET THE VARIABLE
1044 JMP I GETSS
1045 JMS I [LOOKUP
1046 IAC /ADDRESS OF TYPE WORD
1047 DCA TEMP2
1048 CDF 10
1049 TAD I TEMP2
1050 CDF
1051 O200, AND O1420 /1.03/ EXT, STMTFUN, SUBARG ?
1052 SZA CLA
1053 JMP I GETSS
1054 TAD STACK
1055 DCA X12 /SAVE STACK POSITION
1056 DCA TEMP /ZERO NUMBER OF DIMENSIONS
1057 TAD TEMP2
1058 IAC
1059 DCA EQTEMP /ADDRESS OF EQ-DIM POINTER
1060 JMS I [GETC
1061 JMP I GETSS
1062 TAD (-250 /LOOK FOR (
1063 SNA CLA
1064 JMP DIMGET-1 /OK
1065 JMS I [BACK1
1066 JMP RGETSS
1067 DCA DIMNUM /DATA CALLS GETSS WITH AC = 7777
1068 DIMGET, JMS I (SMLNUM /GET A SUBSCRIPT
1069 CLA CMA
1070 TAD EXPON /SS-1
1071 JMS I [PUSH /SAVE SS
1072 ISZ TEMP /BUMP COUNT OF SS
1073 JMS I [COMARP /LOOK FOR , OR )
1074 JMP I GETSS
1075 JMP DIMGET /,
1076 CLA IAC /)
1077 DCA DPRDCT /SET DIMENSION PRODUCT TO 1
1078 TAD X12 /RESTORE STACK POSITION
1079 DCA STACK
1080 TAD TEMP /COMPLEMENT NUMBER OF SS
1081 CIA
1082 DCA TEMP
1083 CDF 10
1084 CLL CML RTR /2000
1085 AND I TEMP2 /HAS VARIABLE BEEN DIMENSIONED ?
1086 SNA CLA
1087 JMP I GETSS /NO, THATS BAD
1088 TAD I EQTEMP /GET ADDRESS OF DIMENSION BLOCK
1089 DCA EQTEMP
1090 TAD I EQTEMP /IS NUMBER OF DIMENSIONS
1091 TAD TEMP /EQUAL TO NUMBER OF SUBSCRIPTS ?
1092 SZA CLA
1093 JMP TRY1SS /1.03/ SEE IF ITS ONE SUBSCRIPT
1094 CLA CLL IAC /+1 V3C
1095 TAD I EQTEMP /+ NUMBER OF DIMENSIONS
1096 TAD EQTEMP /+ ADDRESS OF COUNT WORD
1097 DCA EQTEMP /GIVES ADDRESS OF NEXT TO LAST DIMENSION
1098 LINEAR, CDF
1099 TAD I X12 /GET NEXT SS - 1
1100 DCA MQ
1101 TAD DPRDCT /MULTIPLY BY THE DIMENSION PRODUCT
1102 JMS MUL12 /WHERE D.P. = 1,D1,D1D2,D1D2D3,...
1103 TAD DIMNUM /ACCUMULATE THE SUM
1104 DCA DIMNUM
1105 CDF 10
1106 TAD I EQTEMP /ADDR OF LITERAL
1107 IAC
1108 DCA X11 /WORKING POINTER TO VALUE
1109 TAD I X11 /GET DIMENSION INTO FAC
1110 DCA WORD1
1111 TAD I X11
1112 DCA WORD2
1113 TAD I X11
1114 DCA WORD3
1115 CDF
1116 JMS I [FIXNUM /GO FIX IT
1117 DCA MQ
1118 TAD DPRDCT /OF THE D.P. SERIES (ABOVE)
1119 JMS MUL12
1120 DCA DPRDCT
1121 CLA IAC /V3C BUMP POSITION POINTER
1122 TAD EQTEMP
1123 DCA EQTEMP
1124 ISZ TEMP /ANY MORE SS ?
1125 JMP LINEAR /YES
1126 RGETSS, ISZ GETSS
1127 JMP I GETSS
1128 TRY1SS, CLA IAC /1.03/
1129 TAD TEMP /1.03/ ONLY ONE SS ?
1130 SZA CLA /1.03/
1131 JMP I GETSS /1.03/ MORE, THATS NO GOOD
1132 CDF /1.03/
1133 TAD I X12 /1.03/ GET THE SUBSCRIPT
1134 DCA DIMNUM /1.03/ AND RETURN IT
1135 JMP RGETSS /1.03/
1136 MUL12, 0 /12 BIT UNSIGNED MULTIPLY
1137 DCA OP2 /SAVE OPERAND
1138 TAD (-15 /SET SHIFT COUNT
1139 DCA SC
1140 JMP STMUL
1141 M12LUP, TAD AC
1142 SNL
1143 JMP .+3
1144 CLL
1145 TAD OP2
1146 RAR
1147 STMUL, DCA AC
1148 TAD MQ
1149 RAR
1150 DCA MQ
1151 ISZ SC
1152 JMP M12LUP
1153 TAD MQ /RETURN VALUE
1154 JMP I MUL12
1155 AC=OP3
1156 SC=OP4
1157 \f/ IF STATEMENTS
1158 PAGE
1159 IF, JMS I [EXPR /COMPILE CONDITION EXPRESSION
1160 JMP I [BADCMD
1161 JMS I [STMNUM /IS IT ARITHMETIC IF ?
1162 JMP LOGIF
1163 TAD (ARTHIF /START IF COMMAND
1164 JMS I [OUTWRD
1165 CLL CMA RTL
1166 DCA TEMP
1167 ISZ DOEND /DO END ILLEGAL HERE
1168 JMP IFLABL /GET IF LABELS
1169 IFLOOP, JMS I [CHECKC /LOOK FOR ,
1170 -254
1171 JMP I [NEXTST
1172 JMS I [STMNUM /GET NEXT STMT NUMBER
1173 JMP BADIF
1174 IFLABL, TAD SNUM /OUTPUT LABEL
1175 JMS I [OUTWRD
1176 ISZ TEMP
1177 JMP IFLOOP
1178 JMP I [NEXTST
1179 LOGIF, JMS IFCHEK /IF()IF()... NOT LEGAL
1180 ISZ IFSWIT /CLEAR IF SWITCH
1181 TAD (LIFBGN /START LOGICAL IF
1182 JMS I [OUTWRD
1183 JMP I (COMPIL /COMPILE THE STATEMENT
1184 DOSWT,
1185 IFCHEK, 0 /CHECK IF SWITCH
1186 TAD IFSWIT
1187 SNA CLA
1188 JMP I IFCHEK
1189 BADIF, JMS I [ERMSG
1190 1111
1191 JMP I [NEXTST
1192 \f/ CALL STMT
1193 CALL, JMS I [SAVECP /SAVE CHAR POS
1194 JMS I [GETNAM /GET SUBROUTINE NAME
1195 JMP BADCAL /NO NAME HERE IS BAD
1196 JMS I [LOOKUP /GET ADDRESS OF TYPE WORD
1197 IAC
1198 DCA TEMP
1199 CDF 10
1200 TAD I TEMP /LOOK AT TYPE
1201 AND (6640 /ANYTHING BUT EXT OR ARG ?
1202 SZA CLA
1203 JMP BADCAL /YES, BAD
1204 TAD I TEMP /SET EXT BIT
1205 AND (137 /LEAVE TYPE AND ARG BITS
1206 TAD (1000
1207 DCA I TEMP
1208 CDF
1209 JMS I [RESTCP /RESTORE CHAR POS
1210 CLA IAC /SIGNAL THAT THIS IS A CALL
1211 JMS I [LEXPR /COMPILE IT
1212 XSTORE, DOSTOR /DON'T WORRY VIRGINIA, ITS A NOP
1213 TAD OWTEMP /WHAT WAS THE LAST THING OUT ?
1214 CLL
1215 TAD (-63 /IF LESS THAN 63
1216 SNL CLA
1217 JMP I [NEXTST /IT WAS AN ARG COUNT
1218 TAD [ARGSOP /OTHERWISE IT WAS AN ARG LESS CALL
1219 JMS I [OUTWRD /SO TELL PASS 2 ABOUT IT
1220 JMS I [OUTWRD
1221 JMP I [NEXTST
1222 BADCAL, JMS I [ERMSG
1223 2316
1224 JMP I [NEXTST
1225 \f/ DO DAH, DO DAH
1226 DO, JMS I [IFCHEK /IF(...)DO IS ILLEGAL
1227 JMS I [STMNUM /LOOK FOR ENDING STMT NUMBER
1228 JMP I [BADCMD
1229 JMS I [GETNAM /LOOKUP INDEX VARIABLE
1230 JMP I [BADCMD
1231 JMS I [LOOKUP
1232 DCA DOINDX
1233 JMS I [CHECKC /LOOK FOR =
1234 -275
1235 JMP I [BADCMD
1236 ISZ DOEND /CAN'T END DO LOOP ON A DO
1237 JMS DOSTUF /GET DO PARAMETERS
1238 JMP BADDO
1239 TAD DOINDX /PUSH DO INDEX
1240 JMS I [PUSH
1241 TAD SNUM /PUSH ENDING STMT NUMBER
1242 JMS I [PUSH
1243 TAD STACK
1244 DCA STKLVL /SAVE NEW STACK BASE
1245 JMP I [NEXTST
1246
1247 DOSTUF, 0 /SUBR FOR DO LOOP STUFF
1248 JMS I [OUTWRD /OUTPUT DO INDEX
1249 TAD DOINDX
1250 JMS I [OUTWRD
1251 JMS I [EXPR /GET EXPR FOR INITIAL VALUE
1252 JMP I DOSTUF
1253 TAD XSTORE /YES
1254 JMS I [OUTWRD
1255 JMS I [CHECKC /LOOK FOR COMMA
1256 N254, -254
1257 JMP I DOSTUF
1258 JMS I [EXPR /GET EXPR FOR FINAL VALUE
1259 JMP I DOSTUF
1260 JMS I [GETC /LOOK FOR A COMMA
1261 JMP STEP1 /USE STEP OF 1
1262 TAD N254
1263 SZA CLA
1264 JMP STEP1-1
1265 JMS I [EXPR /GET EXPR FOR STEP
1266 JMP I DOSTUF
1267 DORET, ISZ DOSTUF
1268 TAD (DOBEGN /DO BEGIN OPERATOR
1269 JMS I [OUTWRD
1270 JMP I DOSTUF
1271 JMS I [BACK1 /PUT BACK NON , (OFFICER BELOW LT.)
1272 STEP1, JMS I [OUTWRD /OUTPUT A PUSH 1.0
1273 TAD (ONE
1274 JMS I [OUTWRD
1275 JMP DORET /FINISH DO STUFF
1276 BADDO, JMS I [ERMSG /BAD DO COMMAND
1277 0417
1278 JMP I [NEXTST
1279 BDERR, JMS I [ERMSG /ILLEGAL IN BLOCK DATA
1280 0223
1281 JMP I [NEXTST
1282 \f/ TYPE STATEMENT SUBROUTINE
1283 PAGE
1284 TYPLST, 0 /HANDLE LIST FOR TYPE DELL
1285 TAD STACK
1286 DCA X12 /SAVE STACK POINTER
1287 DCA NUMELM
1288 TAD I TYPLST /GET SET BITS
1289 DCA SETBIT
1290 ISZ TYPLST
1291 TAD I TYPLST /AND ILLEGAL BITS
1292 DCA BADBIT
1293 ISZ TYPLST
1294 LSTLUP, JMS I [GETNAM /GET VARIABLE
1295 JMP BADLST
1296 JMS I [LOOKUP /S.T. SEARCH
1297 DCA TLTEMP /SAVE VAR ADDRESS
1298 TAD TLTEMP /PUT IT ON THE STACK
1299 ISZ TLTEMP /NOW POINT TO TYPE WORD
1300 JMS I [PUSH /INCREMENT NUMBER
1301 ISZ NUMELM /INCREMENT NUMBER
1302 CDF 10
1303 TAD I TLTEMP /COMPARE TYPES
1304 AND BADBIT /CHECK FOR ILLEGAL BITS
1305 SZA CLA
1306 JMP TYPAGN /ATTEMPT TO RE-TYPE
1307 TAD SETBIT /GET SET BITS
1308 CMA /GENERATE MASK
1309 AND I TLTEMP
1310 TAD SETBIT /DO THE SET
1311 DCA I TLTEMP /BUT NOT DIMENSION BIT
1312 CDF
1313 GETDIM, JMS I [GETC
1314 JMP EOL
1315 TAD (-250 /LOOK FOR (
1316 SZA
1317 JMP NOTDIM /NOT DIMENSIONED
1318 CLA IAC /INITIALIZE MAGIC NUMBER
1319 DCA DSERES
1320 CLA IAC
1321 DCA DPRDCT /AND DIMENSION PRODUCT
1322 TAD STACK
1323 DCA X17 /SAVE STACK POINTER
1324 DCA TEMP2 /DIMENSION COUNT=0
1325 JMP I (DIMLUP /GET DIMENSIONS
1326 PUTDIM, TAD X17
1327 DCA STACK /RESTORE STACK
1328 CDF 10
1329 TAD (3400 /DIM, EXT, SF ?
1330 AND I TLTEMP
1331 SZA CLA
1332 JMP DIMAGN /ATTEMPT TP RE-DIMENSION
1333 CLL CML RTR
1334 TAD I TLTEMP /SET DIMENSION BIT
1335 DCA I TLTEMP
1336 ISZ TLTEMP
1337 TAD TEMP2 /NUMBER OF DIMS.
1338 DCA I NEXT
1339 TAD I TLTEMP /GET EQUIVALENCE POINTER
1340 SZA
1341 DCA TLTEMP
1342 TAD NEXT /STORE POINTER TO
1343 DCA I TLTEMP /DIMENSION INFORMATION
1344 TAD DPRDCT /SAVE DIM PRODUCT
1345 DCA I NEXT
1346 TAD DSERES /AND MAGIC NUMBER
1347 DCA I NEXT
1348 DCA I NEXT /ZERO MAGIC LITERAL POINTER
1349 TAD TEMP2
1350 CIA
1351 DCA TEMP2 /LEAVE LAST DIM
1352 CDF
1353 MOVDIM, TAD I X17 /1.03/ GET THE DIMENSION
1354 CDF 10 /1.03/
1355 DCA I NEXT /1.03/ INTO THE DIMENSION INFO BLOCK
1356 CDF /1.03/
1357 ISZ TEMP2 /1.03/
1358 JMP MOVDIM /1.03/
1359 NEXTEL, JMS I [GETC /LOOK FOR ,
1360 JMP TLRETN
1361 TAD (-254
1362 SNA CLA
1363 JMP LSTLUP /OK, GET NEXT MEMBER
1364 ENDLST, JMS I [BACK1
1365 ISZ TYPLST
1366 JMP I TYPLST
1367 BADDIM, JMS I [ERMSG /DIMENSION ERROR
1368 0204
1369 JMP I TYPLST
1370 BADLST, JMS I [ERMSG /ERROR IN LIST
1371 2404
1372 JMP I TYPLST
1373 TYPAGN, JMS I [ERMSG
1374 2224 /RE-TYPE
1375 JMP GETDIM
1376 DIMAGN, JMS I [ERMSG /ATTEMPT TO RE DIMENSION
1377 2204
1378 JMP NEXTEL
1379 NOTDIM, TAD (250-254 /IS IT A COMMA?
1380 SZA CLA
1381 JMP ENDLST
1382 JMP LSTLUP /GET NEXT ELEMENT
1383 EOL,
1384 TLRETN, ISZ TYPLST
1385 JMP I TYPLST /TAKE OK EXIT
1386 ENDFIL, JMS I [CHECKC /LOOK FOR "E"
1387 -305
1388 JMP I [BADCMD
1389 JMS I [EXPR /COMPILE UNIT
1390 JMP I [BADCMD
1391 TAD (ENDFOP /OUTPUT ENDFILE OPERATOR
1392 JMS I [OUTWRD
1393 JMP I [NEXTST
1394 DOUBLE, JMS I [CHECKC /LOOK FOR N
1395 -316
1396 JMP I [BADCMD
1397
1398 JMS I [IFCHEK /NOT ON AN IF
1399 JMS I [TYPLST /PROCESS LIST
1400 0104
1401 0100
1402 NOP
1403 CLA IAC /SET THE DP SWITCH
1404 DCA DPUSED
1405 JMP I [NEXTST
1406 \f/ SYMBOL TABLE LOOKERUPPER
1407 PAGE
1408 LOOKUP, 0 /SYMBOL TABLE LOOKUP FOR VARIABLE ENTRY
1409 TAD NOCODE /IS THIS IN NOCODE MODE ?
1410 SZA CLA
1411 JMP I LOOKUP /YES, DO NOTHING
1412 TAD BUCKET
1413 TAD (ALIST-1 /GET START OF CORRECT BUCKET
1414 CDF 10
1415 LOOK, DCA OLDN3 /SAVE ADDR OF PREVIOUS ENTRY
1416 TAD I OLDN3 /GET ADDR OF NEXT ENTRY
1417 SNA
1418 JMP HOOKIN /NO NEXT ENTRY, ATTACH NEW ENTRY
1419 TAD (2 /SKIP OVER TYPE AND DIM POINTER
1420 DCA X10
1421 TAD (NAME1
1422 DCA PNAME /SETUP POINTER TO NAME
1423 CDF
1424 CHKNAM, TAD I PNAME /GET WORD NAME
1425 CIA CLL
1426 CDF 10
1427 TAD I X10 /COMPARE WITH THIS ENTRY
1428 SZA CLA
1429 JMP NOTSAM /DIFFERENT
1430 CDF
1431 TAD I PNAME
1432 AND [77 /WAS THIS THE END OF NAME?
1433 ISZ PNAME
1434 SZA CLA
1435 JMP CHKNAM /NO, KEEP COMPARING
1436 CDF 10
1437 RLOOKU, TAD I OLDN3 /GET ADDR OF START OF ENTRY
1438 CDF /AND RETURN IT IN THE AC
1439 JMP I LOOKUP /RETURN ADDR OF SYMBOL
1440 NOTSAM, SZL
1441 JMP HOOKIN /NEW SYMBOL <CURRENT ONE
1442 TAD I OLDN3
1443 JMP LOOK /CONTINUE SEARCH
1444 HOOKIN, TAD I OLDN3 /HOOK NEW ENTRY INTO LIST
1445 DCA I NEXT
1446 TAD NEXT
1447 DCA I OLDN3
1448 DCA I NEXT /ZERO TYPE WORD
1449 DCA I NEXT /ZERO EQUIVALENCE/DIMENSION POINTER
1450 TAD (NAME1 /PREPARE TO STICK IN THE NAME
1451 DCA PNAME
1452 CDF
1453 ENTERN, TAD I PNAME /MOVE NAME INTO S.T.
1454 CDF 10
1455 DCA I NEXT
1456 CDF
1457 TAD I PNAME
1458 ISZ PNAME /END OF NAME?
1459 AND [77
1460 SZA CLA
1461 JMP ENTERN /NO, KEEP GOING
1462 CDF 10
1463 STCHEK, TAD NEXT /CHECK FOR S.T. OVERFLOW
1464 CIA CLL
1465 TAD (4740 /5000 STARTS PASS2 SKELETON TABLES
1466 SZL CLA
1467 JMP RLOOKU
1468 CDF
1469 JMS I [ERMSG /S.T. FULL
1470 2324
1471 JMP I (ENDX /TREAT AS END OF INPUT
1472 OLDN3, 0 /ADDR OF PREVIOUS ENTRY
1473 N3SIZE, 0 /SIZE OF ENTRY
1474 LTEMP,
1475 PNAME, /POINTER TO NAME BUFFER
1476 LUKUP2, 0 /LOOKUP FOR FIXED LENGTH SYMBOLS
1477 TAD I LUKUP2 /GET THE BUCKET START
1478 DCA OLDN3 /SAVE IT AS THE PREVIOUS ENTRY
1479 ISZ LUKUP2
1480 TAD I LUKUP2 /GET THE ENTRY SIZE
1481 ISZ LUKUP2
1482 DCA N3SIZE
1483 TAD LUKUP2 /SAVE RETURN ADDR
1484 DCA LOOKUP
1485 TAD NOCODE /IS CODE GENERATION OFF ?
1486 SZA CLA
1487 JMP I LOOKUP /YES, JUST RETURN
1488 CDF 10
1489 LOOK2, TAD I OLDN3 /GET ADDR OF NEXT ENTRY
1490 SNA
1491 JMP HOKIN2 /IF 0 ITS END OF LIST
1492 IAC
1493 DCA X10 /START OF VALUE INFO
1494 TAD (WORD1-1 /SETUP POINTER TO PROTOTYPE
1495 DCA X11
1496 TAD N3SIZE /AND TEMP OF ENTRY SIZE
1497 DCA LTEMP
1498 CHKVAL, CDF
1499 TAD I X11
1500 CIA CLL /COMPARE THIS WORD OF THE VALUE
1501 CDF 10
1502 TAD I X10
1503 SZA CLA
1504 JMP NOTSM2 /NOT THIS ONE
1505 ISZ LTEMP /INCR SIZE COUNT
1506 JMP CHKVAL /MORE STUFF
1507 JMP RLOOKU /RETURN WITH THE GOODS
1508 NOTSM2, SZL
1509 JMP HOKIN2 /NEW SYMBOL < CURRENT ONE
1510 TAD I OLDN3 /CONTINUE SEARCH
1511 DCA OLDN3
1512 JMP LOOK2
1513 HOKIN2, TAD I OLDN3 /HOOK NEW ENTRY INTO LIST
1514 DCA I NEXT
1515 TAD NEXT
1516 DCA I OLDN3
1517 TAD (WORD1-1 /PREPARE TO STICK IN THE VALUE
1518 DCA X11
1519 DCA I NEXT /ZERO TYPE WORD
1520 CDF
1521 ENTERV, TAD I X11 /MOVE VALUE INTO S.T.
1522 CDF 10
1523 DCA I NEXT
1524 ISZ N3SIZE /INCR SIZE COUNT
1525 JMP ENTERV-1
1526 JMP STCHEK /STORE TYPE AND CHECK FOR OVERFLOW
1527 STOP, TAD (STOPOP /OUTPUT STOP OPERATOR
1528 JMS I [OUTWRD
1529 ISZ DOEND /DO ILLEGAL ON STOP
1530 JMP I [NEXTST
1531 \f/ EXPRESSION ANALYZER
1532 PAGE
1533 EXPR, 0 /POLISHIZE EXPRESSION
1534 TAD EXPR
1535 JMS I [PUSH /SAVE RETURN ADDR
1536 JMS I [PUSH /MARK STACK
1537 UNOPR, JMS I [GETC /LOOK FOR UNARY OPERATOR
1538 JMP MISARG /THERE HAS TO BE AN OPERAND
1539 TAD (-253 /UNARY+(NOP)
1540 SNA
1541 JMP UNOPR
1542 TAD (253-255 /UNARY-
1543 SNA
1544 JMP UMINUS
1545 TAD (255-256 /.NOT.
1546 SZA CLA
1547 JMP OPRAND
1548 DCA BUCKET /FOR CKNOT
1549 JMS I (TRUFAL /.TRUE. OR .FALSE. ?
1550 JMP CKNOT /NEITHER, IS IT >.NOT.
1551 JMP .+3 /.TRUE.
1552 TAD (NOTOPR /FALSE=.NOT.TRUE
1553 JMS I [PUSH
1554 JMS I [OUTWRD
1555 TAD (TRUE
1556 JMS I [OUTWRD
1557 JMP I (NOSS
1558 CKNOT, TAD BUCKET
1559 TAD (-16
1560 SZA CLA
1561 JMP OPRAND /MIGHT BE LITERAL .XXXXXX
1562 TAD (NOTOPR /PUSH .NOT. OPERATOR
1563 JMS I [PUSH
1564 JMP UNOPR
1565 UMINUS, TAD (UMOPR /PUSH UNARY MINUS
1566 JMS I [PUSH
1567 JMP UNOPR
1568 OPRAND, JMS I [BACK1 /PUT BACK NON UNARY OPERATOR
1569 JMS I [GETNAM /LOOK FOR VARIABLE REFERENCE
1570 JMP NOTVAR /NOPE.
1571 JMS I [LOOKUP /SYMBOL TABLE SEARCH
1572 JMP I [OPR8R /GO OUTPUT PUSH-VAR
1573 NOTVAR, JMS I [NUMBER /LOOK FOR A LITERAL
1574 JMP NOTNUM /NO KIND OF NUMBER
1575 JMP HOLCHK /INTEGER
1576 JMP DPLIT /DOUBLE PRECISION
1577 FPLIT, JMS I [LUKUP2 /FLOATING, ENTER INTO TABLE
1578 FPLIST
1579 -3
1580 JMP I [OPR8RL /PUSH VARIABLE, NO SUBSCRIPTS
1581 DPLIT, JMS I [LUKUP2 /DOUBLE-PREC., ENTER IN TABLE
1582 DPLIST
1583 -6
1584 JMP I [OPR8RL
1585 HOLCHK, JMS I [GETC /IS THIS HOLLERITH?
1586 JMP .+5
1587 TAD (-310
1588 SNA CLA
1589 JMP I (HFIELD /YES
1590 JMS I [BACK1
1591 JMS I [LUKUP2 /FIND THE ENTRY
1592 INTLST
1593 -3
1594 JMP I [OPR8RL
1595 NOTNUM, JMS I [GETC /LOOK FOR COMPLEX LITERAL
1596 JMP MISARG /MISSING OPERAND
1597 TAD (-250 /OPEN PAREN?
1598 SZA
1599 JMP QUOTE /GO LOOK FOR A STRING
1600 JMS I [SAVECP /SAVE CHAR POSITION
1601 JMS I [NUMBER /GET REAL PART
1602 JMP I (NCMPLX /NO NUMBER
1603 SKP /INTEGER-OK
1604 JMP I (NCMPLX /DOUBLE-NOT LEGAL FOR COMPLEX
1605 JMS I [CHECKC /LOOK FOR ,
1606 -254
1607 JMP I (NCMPLX /NO, CAN'T BE COMPLEX LIT.
1608 TAD WORD1 /SAVE REAL PART
1609 DCA TEMP
1610 TAD WORD2
1611 DCA TEMP2
1612 TAD WORD3
1613 DCA CHAR
1614 JMS I [NUMBER /GET IMAGINARY PART
1615 JMP BADCL /NOT THERE, BAD
1616 SKP /I
1617 JMP BADCL /D-BAD
1618 JMS I [CHECKC /LOOK FOR )
1619 -251
1620 JMP BADCL /NO ) BAD
1621 TAD WORD1 /PUT IMAGINARY PART
1622 DCA WORD4
1623 TAD WORD2 /INTO SECOND AHLF
1624 DCA WORD5
1625 TAD WORD3 /OF COMPLEX LITERAL
1626 DCA WORD6
1627 TAD TEMP /NOW RESTORE REAL PART
1628 DCA WORD1
1629 TAD TEMP2
1630 DCA WORD2
1631 TAD CHAR
1632 DCA WORD3
1633 CLL CMA RAL /REMOVE CHAR POS FROM STACK
1634 TAD STACK /SINCE OTHERWISE IT GOES OUT
1635 DCA STACK /AS CODE
1636 JMS I [LUKUP2 /WHICH WE WILL NOW SEARCH
1637 CMPLST /USE COMPLEX LIST
1638 -6
1639 JMP I [OPR8RL
1640 BADCL, JMS I [ERMSG /BAD COMPLEX LITERAL
1641 0314
1642 JMP I [BADEXP
1643 MISARG, JMS I [ERMSG /MISSING OPERAND
1644 1517
1645 JMP I [BADEXP
1646 \f/ EXPRESSION ANALYZER
1647 PAGE
1648 HQUOTE, 0 /SUBR FOR QUOTE STRINGS
1649 JMS I [GETCWB /GET CHAR
1650 JMP BADH
1651 TAD [-247 /IS IT '
1652 SZA
1653 JMP NOTQ2 /NO
1654 JMS I [GETCWB
1655 JMP LUHOL
1656 TAD [-247 /LOOK FOR ''
1657 SNA CLA
1658 JMP NOTQ2 /REPLACE '' BY '
1659 JMS I [BACK1 /ITS END OF STRING
1660 JMP LUHOL
1661 NOTQ2, TAD [247 /RESTORE CHAR
1662 AND [77
1663 JMP I HQUOTE
1664 HFIELD, JMS I [FIXNUM /INTEGERIZE NUMBER
1665 SNA
1666 JMP BADH /ZERO IS BAD
1667 CMA CLL
1668 DCA TEMP
1669 TAD (HCOUNT /SET SUBR POINTER
1670 DOHOL, DCA HCHAR
1671 TAD (-MAXHOL /SET COUNTER FOR MAX
1672 DCA HOLCTR
1673 TAD (NAME1 /SET UP NAME POINTER
1674 DCA TEMP2
1675 PAKHOL, DCA I TEMP2 /PACK HOLLERITH STRING
1676 JMS I HCHAR
1677 CLL RTL
1678 RTL
1679 RTL
1680 DCA I TEMP2
1681 JMS I HCHAR
1682 TAD I TEMP2
1683 DCA I TEMP2
1684 ISZ TEMP2
1685 ISZ HOLCTR /CHECK FOR TOO MANY
1686 JMP PAKHOL
1687 BADH, JMS I [ERMSG /BAD OR TOO BIG HOLLERITH FIELD
1688 1017
1689 JMP I [BADEXP
1690 LUHOL, TAD (33 /LOOK UP THIS LITERAL
1691 DCA BUCKET
1692 JMS I [LOOKUP
1693 JMP I [OPR8RL
1694 HCOUNT, 0
1695 ISZ TEMP /CHECK COUNT
1696 SKP
1697 JMP LUHOL /EXPIRED
1698 JMS I [GETCWB /GET CHAR
1699 JMP BADH
1700 AND [77 /6-BIT IZE IT
1701 JMP I HCOUNT
1702 HOLCTR, 0 /COUNTER FOR HOLLERITH FIELDS
1703 NCMPLX, JMS I [RESTCP /NOT COMPLEX LITERAL
1704 JMS I [EXPR /MUST BE SUB EXPRESSION
1705 JMP BADEXP
1706 JMS I [GETC /LOOK FOR )
1707 JMP PARMM
1708 TAD (-251
1709 SNA CLA
1710 JMP I (NOSS /NO SUBSCRIPT LEGAL AFTER SUB EXPR
1711 PARMM, JMS I [ERMSG /MISSING )
1712 1515
1713 BADEXP, JMS I [POP /BAD EXPRESSION,
1714 SZA CLA
1715 JMP BADEXP /LOOK FOR STACK MARKER
1716 JMS I [POP
1717 DCA TEMP /RETURN ADDR.
1718 JMP I TEMP
1719 JMS I [BACK1 /PUT BACK TEMINAL CHAR
1720 ENDEXP, JMS I [POP /GET NEXT THING FROM STACK
1721 SNA
1722 JMP EXPDUN /IF ZERO, FINISH
1723 IAC /GET ADDR OF OPERATION NUMBER
1724 DCA TEMP
1725 TAD I TEMP /GET OPERATOR VALUE
1726 JMS I [OUTWRD /OUTPUT OPERATOR XXXXXX
1727 JMP ENDEXP /LOOP
1728 EXPDUN, JMS I [POP /GET RETURN ADDR
1729 IAC
1730 DCA TEMP
1731 JMP I TEMP
1732 LETTER, 0 /GET A LETTER
1733 JMS I [GETC
1734 JMP I LETTER
1735 TAD (-301
1736 SPA
1737 JMP NLETR
1738 TAD (301-333
1739 SMA
1740 JMP NLETR
1741 TAD (33
1742 ISZ LETTER
1743 JMP I LETTER
1744 NLETR, JMS I [BACK1
1745 JMP I LETTER
1746 QUOTE, TAD (250-247 /IS IT '
1747 SZA
1748 JMP MISARG /NO, OPERAND IS MISSING
1749 TAD (HQUOTE /SET SUBR POINTER
1750 JMP DOHOL
1751 CHECKC, 0 /CHECK FOR A SINGLE CHAR
1752 TAD I CHECKC /GET THE CHAR
1753 DCA CCTEMP
1754 ISZ CHECKC /SKIP PAST THE CHAR
1755 JMS I [GETC /GET CHAR FROM INPUT
1756 JMP I CHECKC /DIDN'T MAKE IT
1757 TAD CCTEMP /IS THIS IT ?
1758 SNA CLA
1759 ISZ CHECKC /YES
1760 JMP I CHECKC
1761 CCTEMP, 0
1762 \f/ EXPRESSION ANALYZER
1763 PAGE
1764 BADFSS, JMS I [ERMSG
1765 2323
1766 JMP I [BADEXP
1767 OPR8R, DCA TEMP
1768 JMS I [OUTWRD /PUSH
1769 TAD TEMP
1770 JMS I [OUTWRD /OUTPUT OPERAND PTR
1771 JMS I [GETC
1772 JMP I [ENDEXP
1773 TAD (-250 /IS IT S.S. OR FUNCTION
1774 SZA
1775 JMP NOTFSS
1776 TAD STMJMP
1777 TAD (-DFINFL
1778 SNA CLA /FOR D.F.,PERMIT VARPARENS
1779 JMP NOTFSS
1780 ISZ TEMP /LOOK AT TYPE
1781 CDF 10
1782 TAD (3420 /DIM, EXT, SF, OR ARG ?
1783 AND I TEMP
1784 SZA CLA
1785 JMP NOTFUN /NOT A FUNCTION REFERENCE
1786 TAD I TEMP
1787 TAD (1000 /SET EXT BIT
1788 DCA I TEMP
1789 NOTFUN, CDF
1790 SKP
1791 JMS I [POP /PUT COUNT INTO AC
1792 SSFUN, IAC /INCREMENT ARG COUNT
1793 JMS I [PUSH /SAVE IT ON THE STACK
1794 JMS I [EXPR /GET ARG (OR S.S.)
1795 JMP I [BADEXP
1796 JMS I [COMARP /LOOK FOR , OR )
1797 JMP BADFSS /NEITHER
1798 JMP SSFUN-1 /, GET NEXT ARG (SUBSCRIPT?)
1799 TAD (ARGSOP /YES, OUTPUT ARGLIST OPER
1800 JMS I [OUTWRD
1801 JMS I [POP /AND THE COUNT
1802 JMS I [OUTWRD
1803 NOSS, JMS I [GETC /GET NEXT CHAR
1804 JMP I [ENDEXP
1805 TAD (-253 /PREPARE IT
1806 JMP NOTFSS+1
1807 OPR8RL, DCA TEMP /SAVE ADDR OF LITERAL
1808 JMS I [OUTWRD
1809 TAD TEMP
1810 JMS I [OUTWRD
1811 JMP NOSS
1812 \f/ TYPLST PART TWO
1813 DIMLUP, JMS I [NUMBER /GET DIMENSION
1814 JMP VARDIM /MAYBE ITS VAR DIM ?
1815 JMP .+3 /OK, INTEGER
1816 JMP BADDIM
1817 JMP BADDIM /DP AND FP ARE BAD
1818 JMS I [FIXNUM /FIX IT FOR SOME STUFF
1819 DCA MQ
1820 TAD DPRDCT /GET NEW DIMENSION PRODUCT
1821 JMS I [MUL12
1822 DCA DPRDCT
1823 ISZ TEMP2 /INCREMENT DIM COUNT
1824 TAD WORD2 /IF WORD2 OR AC NON ZERO
1825 TAD AC /DIM IS TOO BIG
1826 SZA CLA /1.03/
1827 JMP BADDIM /1.03/
1828 JMS I (ANORM /1.03/ RENORMALIZE THE NUMBER
1829 JMS I [LUKUP2 /1.03/ ENTER IT INTO LITERAL LIST
1830 INTLST /1.03/
1831 -3 /1.03/
1832 PSHDIM, JMS I [PUSH /1.03/ AND SAVE ON THE STACK
1833 JMS I [COMARP /LOOK FOR , OR )
1834 JMP BADDIM
1835 SKP /COMMA MEANS ANOTHER DIM FOLLOWS
1836 JMP PUTDIM /) MEANS END OF DIMS
1837 TAD DSERES /FORM NEXT VALUE OF MAGIC NUMBER
1838 TAD DPRDCT
1839 DCA DSERES
1840 JMP DIMLUP /NOW LOOP FOR NEXT DIM
1841 VDTEMP, 0
1842 VARDIM, CDF 10 /IS ARRAY AN ARG ?
1843 TAD I TLTEMP
1844 CDF
1845 AND (20
1846 SNA CLA
1847 JMP BADDIM /NO, BAD DIMENSION
1848 JMS I [GETNAM /OK, GET DIMENSION
1849 JMP BADDIM
1850 JMS I [LOOKUP
1851 IAC
1852 DCA VDTEMP /ADDR OF TYPE WORD
1853 CDF 10 /IS THA VARIABLE AN ARG ?
1854 TAD I VDTEMP
1855 AND (20
1856 CDF
1857 SNA CLA
1858 JMP BADDIM /NO, THATS BAD
1859 DCA DPRDCT /3.02 ZERO DIM PRODUCT
1860 ISZ TEMP2 /INCREMENT DIM COUNT
1861 CMA /1.03/
1862 TAD VDTEMP /1.03/ SAVE DIMENSION VARIABLE
1863 JMP PSHDIM /3.02 SAVE DIM ON STACK
1864 MESSAG, 0 /PRINT PASS1 IMMEDIATE ERROR
1865 TAD I MESSAG /GET CHAR ONE
1866 ISZ MESSAG
1867 JMS I (TTYOUT
1868 TAD I MESSAG /GET CHAR TWO
1869 JMS I (TTYOUT
1870 TAD (215 /CR
1871 JMS I (TTYOUT
1872 TAD (212 /LF
1873 JMS I (TTYOUT
1874 JMP I (7605 /EXIT TO MONITOR
1875 \f/ EXPRESSION ANALYZER REVISITED
1876 PAGE
1877 NOTFSS, TAD (250-253 /IS IT +
1878 SZA
1879 JMP .+3
1880 TAD (ADDOPR /YES
1881 JMP GOTOPR
1882 TAD (253-255 /IS IT -
1883 SZA
1884 JMP .+3
1885 TAD (SUBOPR /YES
1886 JMP GOTOPR
1887 TAD (255-252 /IS IT *
1888 SZA
1889 JMP NOTMUL /NO
1890 JMS I [GETC
1891 JMP NOTEXP
1892 TAD (-252 /IS IT **
1893 SZA CLA
1894 JMP .+3
1895 TAD (EXPOPR /YES
1896 JMP GOTOPR
1897 JMS I [BACK1
1898 NOTEXP, TAD (MULOPR /IT WAS *
1899 JMP GOTOPR
1900 NOTMUL, TAD (252-257 /IS IT /
1901 SZA
1902 JMP .+3
1903 TAD (DIVOPR /YES
1904 JMP GOTOPR
1905 IAC /IS IT .
1906 SZA CLA
1907 JMP I (ENDEXP-1 /NO, END OF EXPR
1908 JMS CKEOPR /LOOK FOR EXTENDED OPERATOR
1909 JMP BADOPR /NONE THERE
1910 JMS I [CHECKC /CHECK FOR CLOSING .
1911 -256
1912 JMP BADOPR /NOT THERE
1913 CDF 10 /3.01/
1914 TAD I X10 /GET OPERATOR POINTER
1915 CDF
1916 JMP GOTOPR
1917 CKEOPR, 0 /CHECK FOR EXTENDED OPERATOR
1918 JMS I [GETNAM /GET NAME
1919 JMP I CKEOPR /NONE
1920 TAD (OPRLST-1 /PTR TO LIST
1921 DCA X10
1922 OPRLUP, CDF 10 /3.01/
1923 TAD I X10 /COMPARE FIRST CHAR
1924 CDF 0
1925 SNA
1926 JMP I CKEOPR /END OF LIST
1927 TAD BUCKET
1928 SZA CLA
1929 JMP NOTHIS /NOT THIS ONE
1930 CDF 10 /3.01/
1931 TAD I X10
1932 CDF
1933 TAD I (NAME1 /COMPARE 2ND AND 3RD
1934 SZA CLA
1935 JMP NOTHIS+1 /NOT THIS ONE
1936 ISZ CKEOPR /BUMP RETURN
1937 JMP I CKEOPR
1938 NOTHIS, ISZ X10 /BUMP LIST PTR
1939 ISZ X10 /AGAIN
1940 JMP OPRLUP /KEEP GOING
1941 BADOPR, JMS I [ERMSG /NOT LEGAL EXT. OPER.
1942 1720
1943 JMP I [BADEXP
1944 GOTOPR, DCA NEWOP /SAVE NEWEST OPER.
1945 JMS I [POP /GET STACK TOP
1946 SNA
1947 JMP PUSH2 /EMPTY
1948 DCA OLDOP
1949 TAD I OLDOP /COMPARE PREC.
1950 CIA
1951 TAD I NEWOP /NEW-OLD
1952 SPA SNA CLA
1953 JMP OUTOLD /OLD>NEW
1954 TAD OLDOP
1955 PUSH2, JMS I [PUSH /OLD < NEW
1956 TAD NEWOP /GO PUSH BOTH
1957 JMS I [PUSH
1958 JMP I (UNOPR /GO LOOK FOR NEXT OPERAND
1959 OUTOLD, ISZ OLDOP /OUTPUT OPERATOR
1960 TAD I OLDOP
1961 JMS I [OUTWRD
1962 JMP GOTOPR+1 /TRY NEXT STACK ELEMENT
1963 NEWOP=WORD1
1964 OLDOP=WORD2
1965 \f/ UTILITIES
1966 GETCWB, 0 /GET A CHARACTER (PRESERVE BLANKS)
1967 ISZ NCHARS
1968 JMP .+4
1969 CLA CMA
1970 DCA NCHARS /RESET NCHARS
1971 JMP I GETCWB
1972 ISZ GETCWB
1973 TAD I CHRPTR /GET THE CHAR
1974 JMP I GETCWB
1975 SAVECP, 0 /SAVE CHAR POSITION
1976 TAD NCHARS
1977 JMS I [PUSH
1978 TAD CHRPTR
1979 JMS I [PUSH
1980 JMP I SAVECP
1981 FIXNUM, 0 /FIX FAC (I'M MOVING IT AGAIN)
1982 TAD WORD1 /IS IT FIXED ?
1983 TAD (-27
1984 SNA
1985 JMP RETFN /YES, EXPONENT IS 23
1986 SMA CLA
1987 JMP I FIXNUM /BAD IF EXP IS >23
1988 JMS I (AR1 /RIGHT SHIFT ONE
1989 JMP FIXNUM+1 /TEST AGAIN
1990 RETFN, TAD WORD3 /RETURN LOWEST 12 BITS
1991 JMP I FIXNUM
1992 \f/ UTILITIES
1993 PAGE
1994 GETC, 0 /GET A CHARACTER (IGNORING BLANKS)
1995 ISZ NCHARS
1996 JMP .+4
1997 CLA CMA
1998 DCA NCHARS
1999 JMP I GETC
2000 TAD I CHRPTR
2001 TAD (-240 /IS IT A BLANK
2002 SNA
2003 JMP GETC+1 /YES IGNORE IT
2004 TAD (240 /FIX CHAR
2005 ISZ GETC
2006 JMP I GETC
2007 ERMSG, 0 /ERROR MESSAGE HANDLER
2008 CDF
2009 TAD NOCODE /IS CODE GENERATION ON ?
2010 SZA CLA
2011 JMP NOTOUT /NO
2012 TAD (ERRCOD /ERROR CODE TO OUTPUT FILE
2013 JMS I [OUTWRD
2014 TAD I ERMSG
2015 ISZ ERMSG
2016 JMS I [OUTWRD
2017 JMP I ERMSG /RETURN
2018 NOTOUT, TAD I ERMSG /SAVE THE ERROR CODE
2019 ISZ ERMSG
2020 DCA ERCODE
2021 JMP I ERMSG
2022 POP, 0 /PUT TOP OF STACK INTO AC
2023 TAD STACK
2024 DCA ERMSG
2025 CLA CMA
2026 TAD STACK
2027 DCA STACK /DECREMENT STACK POINTER
2028 TAD I ERMSG
2029 JMP I POP
2030 TRUFAL, 0 /CHECK FOR LOGICAL LITERALS
2031 JMS I [GETNAM
2032 JMP I TRUFAL
2033 JMS I [CHECKC /LOOK FOR TERMINAL .
2034 -256
2035 JMP I TRUFAL
2036 TAD BUCKET /LOOK AT FIRST CHAR
2037 TAD (-24
2038 SNA
2039 JMP .+5 /ITS "T"
2040 TAD (24-6
2041 SZA CLA
2042 JMP I TRUFAL /ITS NEITHER
2043 ISZ TRUFAL /ITS "F"
2044 ISZ TRUFAL
2045 JMP I TRUFAL
2046 \f/ LEFT HALF EXPRESSION ANALYZER
2047 LEXPR, 0 /GET LEFT HAND EXPRESSION
2048 DCA LETEMP /SAVE CALL SWITCH
2049 JMS I [GETNAM /LOOK FOR VAR NAME
2050 JMP MSNGOP /MUST BE THERE
2051 JMS I [OUTWRD /OUTPUT A ZERO (PUSH)
2052 JMS I [LOOKUP /SEEK OUT ENTRY FOR THIS VAR
2053 DCA TEMP
2054 TAD TEMP
2055 JMS I [OUTWRD
2056 JMS I [GETC /LOOK FOR DIMENSIONS
2057 JMP LEXPOK /NO (
2058 TAD (-250
2059 SZA CLA
2060 JMP LEXPOK-1 /NO (
2061 ISZ TEMP /LOOK AT TYPE
2062 CDF 10
2063 CLL CML RTR /DIMENSIONED ?
2064 AND I TEMP
2065 TAD LETEMP /OR A CALL ?
2066 TAD NOCODE /OR CODE OFF ?
2067 SZA CLA
2068 JMP NOTSF /YES, NOT AN ARITHMETIC S.F.
2069 TAD I TEMP
2070 AND (1420 /EXT, SF, OR ARG ?
2071 SNA CLA /V3C
2072 TAD [-M6 /SEE IF CALLED FROM SPECIAL PLACE
2073 TAD LEXPR /V3C COMPARE WITH ENTRY PT
2074 SZA CLA
2075 JMP ASFERR /THIS IS BAD IF SO
2076 TAD I TEMP
2077 TAD (400
2078 DCA I TEMP /SET A.S.F. BIT
2079 CDF
2080 TAD (ASFDEF /DEFINE ASF
2081 JMS I [OUTWRD
2082 NOTSF, CDF
2083 SKP
2084 JMS I [POP /ARG COUNT TO AC
2085 SSLOOP, IAC /INCREMENT SS COUNT
2086 JMS I [PUSH /SAVE ON THE STACK
2087 JMS I [EXPR /COMPILE SUBSCRIPT
2088 JMP FSSBAD+2 /ERROR WITHIN SS
2089 JMS I [COMARP /LOOK FOR , OR )
2090 JMP FSSBAD /NEITHER (THERE WAS A BUG HERE)
2091 JMP SSLOOP-1 /, GET NEXT ARG/SS
2092 TAD (ARGSOP /OUTPUT SS OPERATOR
2093 JMS I [OUTWRD
2094 JMS I [POP /THEN COUNT
2095 JMS I [OUTWRD
2096 SKP
2097 JMS I [BACK1 /PUT BACK A CHARACTER
2098 LEXPOK, ISZ LEXPR
2099 JMP I LEXPR /RETURN
2100 MSNGOP, JMS I [ERMSG /MISSING OPERAND
2101 1517
2102 JMP I LEXPR
2103 FSSBAD, JMS I [ERMSG /MISSING COMMA OR CLOSE PARENTHESIS
2104 2323
2105 JMS I [POP /GET ARG COUNT OFF STACK
2106 CLA
2107 JMP I LEXPR
2108 ASFERR, JMS I [ERMSG /BAD ARITHMETIC STMT FUNCTION
2109 2306
2110 JMP NOTSF /DO THE REST OF THE ASF DEF
2111 LETEMP, 0
2112 \f/UTILITIES
2113 PAGE
2114 G2CTMP,
2115 PUSH, 0 /PUT AC ONTO STACK
2116 DCA I STACK /STORE
2117 TAD (STACKS+100 /CHECK FOR STACK OVERFLOW
2118 CIA CLL
2119 TAD STACK
2120 SNL CLA
2121 JMP I PUSH /OK, RETURN
2122 DCA NOCODE /SET CODE GENERATION ON
2123 JMS I [ERMSG
2124 2004
2125 JMP I [NEXTST
2126 GET2C, 0 /GET 2 SIX BIT CHARS INTO ONE WPRD
2127 JMS I [GETC /GET FIRST CHAR
2128 JMP I GET2C
2129 AND [77
2130 CLL RTL
2131 RTL
2132 RTL
2133 DCA G2CTMP
2134 JMS I [GETC /GET SECOND CHAR
2135 JMP I GET2C
2136 ISZ GET2C /FIX RETURN ADDR
2137 AND [77
2138 TAD G2CTMP
2139 JMP I GET2C
2140 STMNUM, 0 /PICK UP STATEMENT NUMBER
2141 DCA WORD4 /SAVE DEFINED BIT (IF ANY)
2142 DCA WORD2 /ZERO SOME STUFF
2143 DCA WORD3
2144 JMS DIGIT /GET A DIGIT
2145 JMP I STMNUM /NONE THERE, NO STMT NUMBER
2146 TAD (-60 /IS IT A LEADING 0 ?
2147 SNA
2148 JMP .-4 /YES, IGNORE IT
2149 TAD (60
2150 CLL RTL
2151 RTL
2152 RTL
2153 DCA WORD1
2154 JMS DIGIT /GET SECOND DIGIT
2155 JMP ENDNUM /END OF NUMBER
2156 TAD WORD1
2157 DCA WORD1 /COMBINE FIRST AND SECOND
2158 JMS DIGIT
2159 JMP ENDNUM
2160 CLL RTL
2161 RTL
2162 RTL
2163 DCA WORD2
2164 JMS DIGIT
2165 JMP ENDNUM /COMBINE THIRD AND FOURTH
2166 TAD WORD2
2167 DCA WORD2
2168 JMS DIGIT /GET FIFTH DIGIT
2169 JMP ENDNUM
2170 CLL RTL
2171 RTL
2172 RTL
2173 DCA WORD3
2174 ENDNUM, JMS I [LUKUP2 /LOOK UP IN S.T.
2175 SNLIST /STMT NUMBER LIST
2176 -3
2177 ISZ STMNUM
2178 DCA SNUM /SAVE S.T. ADDRESS OF LABEL
2179 CDF 10 /SET TYPE WORD
2180 TAD SNUM /GET ADDR OF TYPE
2181 IAC
2182 DCA SNTEMP
2183 TAD I SNTEMP /GET TYPE WORD
2184 CLL
2185 TAD WORD4 /PUT IN THE DEFINITION BIT
2186 SNL
2187 DCA I SNTEMP /RESTORE IT IF NOT MULTIPLE DEFN
2188 CDF
2189 SNL CLA
2190 JMP I STMNUM
2191 JMS I [ERMSG
2192 1514
2193 JMP I STMNUM
2194 SNTEMP,
2195 DIGIT, 0 /GET A DIGIT
2196 JMS I [GETC /GET A CHAR
2197 JMP I DIGIT
2198 TAD (-272 /IS IT > 271 (9)
2199 SMA
2200 JMP NODIGT /YES, ITS GREATER
2201 TAD (272-260 /IS IT < 260 (0)
2202 SPA
2203 JMP NODIGT /YES, ITS LESS
2204 TAD (60
2205 ISZ DIGIT
2206 JMP I DIGIT /TAKE SUCCESSFUL RETURN
2207 NODIGT, JMS I [BACK1 /RESTORE NON DIGIT
2208 JMP I DIGIT
2209 ASSIGN, JMS I [STMNUM /GET STMT NUMBER
2210 JMP BADASN
2211 JMS I [GET2C /LOOK FOR "TO"
2212 JMP BADASN
2213 TAD (-2417
2214 SNA CLA
2215 JMS I [LEXPR /GET ASSIGN VARIABLE
2216 JMP BADASN
2217 TAD (ASNOPR /OUTPUT ASSIGN OPERATOR
2218 JMS I [OUTWRD
2219 TAD SNUM /NOW STMT NUMBER
2220 JMS I [OUTWRD
2221 JMP I [NEXTST
2222 BADASN, JMS I [ERMSG
2223 0123
2224 JMP I [NEXTST
2225 TTYOUT, 0 /TTY OUTPUT ROUTINE
2226 TLS
2227 TSF
2228 JMP .-1
2229 CLA
2230 JMP I TTYOUT
2231 \f/ PRECEDENCE TABLE
2232 PAGE
2233 ADDOPR, 100
2234 1
2235 SUBOPR, 100
2236 2
2237 MULOPR, 200
2238 3
2239 DIVOPR, 200
2240 4
2241 EXPOPR, 500
2242 5
2243 NOTOPR, 30
2244 6
2245 UMOPR, 400
2246 7
2247 EQOPR, 40
2248 16
2249 NEOPR, 40
2250 17
2251 GEOPR, 40
2252 10
2253 GTOPR, 40
2254 11
2255 LEOPR, 40
2256 12
2257 LTOPR, 40
2258 13
2259 ANDOPR, 20
2260 14
2261 OROPR, 10
2262 15
2263 XOROPR, 7
2264 20
2265 EQVOPR, 7
2266 21
2267 \f/ UTILITY ROUTINES
2268 BACK1, 0 /BACK UP ONE CHAR
2269 CLA CMA
2270 TAD NCHARS
2271 DCA NCHARS
2272 CLA CMA
2273 TAD CHRPTR
2274 DCA CHRPTR
2275 JMP I BACK1
2276 OADD, 0 /ADD OPERAND TO FAC
2277 CLL
2278 TAD OPO
2279 TAD ACO
2280 DCA ACO
2281 RAL
2282 TAD OP6
2283 TAD WORD6
2284 DCA WORD6
2285 RAL
2286 TAD OP5
2287 TAD WORD5
2288 DCA WORD5
2289 RAL
2290 TAD OP4
2291 TAD WORD4
2292 DCA WORD4
2293 RAL
2294 TAD OP3
2295 TAD WORD3
2296 DCA WORD3
2297 RAL
2298 TAD OP2
2299 TAD WORD2
2300 DCA WORD2
2301 JMP I OADD
2302 \f/ FLOATING POINT DIVIDE ROUTINE
2303 PAGE
2304 FPDIV, 0
2305 JMS I DAR1 /UNNORMALIZE AC BY ONE
2306 TAD OP1 /COMPUTE FINAL EXPONENT
2307 CIA
2308 TAD WORD1
2309 DCA OP1 /AND SAVE IT
2310 TAD DM74 /SET ITERATION COUNTER
2311 DCA DITCNT
2312 TAD WORD2
2313 RAL /INITIALIZE LINK
2314 FPDVLP, CLA RAR /COMPARE SIGNS
2315 TAD OP2
2316 SPA CLA
2317 JMP .+3
2318 TAD OPMAC /NEGATE OPERAND
2319 JMS I DFNEG
2320 JMS I DOADD /ADD OPERAND AND FAC
2321 TAD D6 /RIGHT SHIFT QUOTIENT
2322 RAL /PRESERVING ADD OVERFLOW BIT
2323 DCA D6
2324 TAD D5
2325 RAL
2326 DCA D5
2327 TAD D4
2328 RAL
2329 DCA D4
2330 TAD D3
2331 RAL
2332 DCA D3
2333 TAD D2
2334 RAL
2335 DCA D2
2336 JMS I DAL1 /LEFT SHIFT FAC ONE
2337 ISZ DITCNT /TEST ITERATION COUNT
2338 JMP FPDVLP
2339 TAD OP1 /PUT QUOTIENT INTO FAC
2340 DCA WORD1
2341 TAD D2
2342 DCA WORD2
2343 TAD D3
2344 DCA WORD3
2345 TAD D4
2346 DCA WORD4
2347 TAD D5
2348 DCA WORD5
2349 TAD D6
2350 DCA WORD6
2351 DCA ACO
2352 JMS I DNORM /NORMALIZE
2353 JMP I FPDIV
2354 D2, 0
2355 D3, 0
2356 D4, 0
2357 D5, 0
2358 D6, 0
2359 DITCNT, 0
2360 DAR1, AR1
2361 DAL1, AL1
2362 DM74, -74
2363 OPMAC, OPO-ACO
2364 DFNEG, NEGFAC
2365 DOADD, OADD
2366 DNORM, ANORM
2367 *STACKS-1
2368 -1 /TO PREVENT SPURIOUS DO ENDS
2369 \f/ NUMERIC CONVERSION ROUTINE
2370 PAGE
2371 NUMBER, 0 /GENERAL NUMBER CONVERSION ROUTINE
2372 DCA ESWIT /ZERO E/D SWITCH
2373 DCA DECPT /ZERO DECIMAL POINT SWITCH
2374 DCA WORD1 /ZERO FAC
2375 DCA WORD2
2376 DCA WORD3
2377 DCA WORD4
2378 DCA WORD5
2379 DCA WORD6
2380 DCA ACO
2381 DCA SIGN /CLEAR SIGN SWITCH
2382 JMS I [GETC /GET A CHAR
2383 JMP I NUMBER /NO CHAR IS NO NUMBER
2384 JMS CHKSGN /CHECK FOR SIGN
2385 SIGN, 0 /THIS SWITCH GETS SET
2386 DCA NDIGIT /ZERO DIGIT COUNT
2387 CONVLP, JMS I [DIGIT /GET A DIGIT
2388 JMP TRYDEC /IS THERE A DECIMAL POINT ?
2389 AND [17
2390 DCA NXTDGT /SAVE THE DIGIT
2391 ISZ NDIGIT /INCR NUMBER OF DIGITS
2392 TAD WORD2 /PREPARE TO MULT BY 10
2393 DCA OP2
2394 TAD WORD3
2395 DCA OP3
2396 TAD WORD4
2397 DCA OP4
2398 TAD WORD5
2399 DCA OP5
2400 TAD WORD6
2401 DCA OP6
2402 TAD ACO
2403 DCA OPO
2404 JMS I (AL1 /DOUBLE FAC
2405 JMS I (AL1 /DOUBLE AGAIN
2406 JMS I (OADD /TIMES FIVE
2407 JMS I (AL1 /ONE MORE DOUBLING IS TIMES 10
2408 DCA OP2
2409 DCA OP3 /PUT NEWEST DIGIT INTO OPERAND
2410 DCA OP4
2411 DCA OP5
2412 DCA OP6
2413 TAD NXTDGT
2414 DCA OPO
2415 JMS I (OADD /ADD IN NEWEST DIGIT
2416 JMP CONVLP
2417 TRYDEC, TAD DECPT /DECIMAL ALREADY ?
2418 SZA CLA
2419 JMP TRYE2 /YES, LOOK FOR EXPONENT
2420 JMS I [GETC /LOOK FOR .
2421 JMP DIGTST /SEE IF THERE WAS ANYTHING
2422 TAD (-256
2423 SZA
2424 JMP TRYE1 /TRY FOR E
2425 JMS I [SAVECP /SAVE CHAR POS
2426 JMS I (CKEOPR /CHECK FOR SPECIAL CASE OF LIT.RE.
2427 JMP NOLDRE /NOT LIT.RE.
2428 JMS I [RESTCP
2429 JMS I [BACK1 /PUT BACK . IT BELONGS TO RELATIONAL
2430 DIGTST, TAD NDIGIT /ANY DIGITS ?
2431 SNA CLA
2432 JMP I NUMBER /NO, NO NUMBER
2433 JMP INTEGR /TAKE INTEGER EXIT
2434 NOLDRE, ISZ DECPT /SET DECIMAL POINT SW
2435 JMS I [RESTCP /RESTORE CHAR POS
2436 JMP CONVLP-1 /LOOP FOR OTHER DIGITS
2437 TRYE1, JMS I [BACK1 /PUT BACK NON .
2438 TAD NDIGIT /ANY DIGITS YET ?
2439 SNA CLA
2440 JMP I NUMBER /NO, NO NUMBER
2441 JMS EORD /LOOK OR E OR D
2442 JMP INTEGR
2443 TRYE2, JMS EORD /LOOK FOR E OR D
2444 FPNUM, ISZ NUMBER
2445 ISZ NUMBER
2446 DCA EXPON /ZERO EXPONENT
2447 JMS I (DODEC /HANDLE DIGITS RIGHT OF .
2448 JMP DOSIGN-1 /GO DO SIGN
2449 INTEGR, TAD (107 /PUT IN EXPONNT
2450 DCA WORD1
2451 JMS I (ANORM /NORMALIZE
2452 ISZ NUMBER /BUMP RETURN
2453 DOSIGN, TAD SIGN /CHECK THE SIGN
2454 SZA CLA
2455 JMS I (NEGFAC /NEGATE IF NEGATIVE
2456 JMP I NUMBER /RETURN
2457 CHKSGN, 0 /CHECK FOR SIGN
2458 TAD (-255 /IS IT - ?
2459 SNA
2460 ISZ I CHKSGN /YES, SET SWITCH
2461 SZA
2462 TAD (255-253 /IS IT + ?
2463 SZA CLA
2464 JMS I [BACK1 /RETURN CHAR OTHERWISE
2465 JMP I CHKSGN
2466 EORD, 0 /LOOK FOR E OR D
2467 JMS I [GETC /LOOK FOR E OR D
2468 JMP I EORD
2469 TAD (-304
2470 CLL RAR
2471 SZA CLA /E OR D?
2472 JMP NOEORD /NO
2473 SZL
2474 ISZ ESWIT /SET SWITCH IF E
2475 SNL
2476 ISZ DPUSED /SET D.P. SWITCH IF D
2477 JMP I (GETEXP /OK, GET EXPONENT
2478 NOEORD, JMS I [BACK1 /PUT IT BACK CAUSE ITS NOT OURS
2479 JMP I EORD
2480 NXTDGT, 0
2481 REWIND, JMS I [EXPR /COMPILE UNIT
2482 JMP I [NEXTST
2483 TAD (REWOPR /OUTPUT REWIND OPERATOR
2484 JMS I [OUTWRD
2485 JMP I [NEXTST
2486 \f/ NUMERIC CONVERSION ROUTINE
2487 PAGE
2488 SMLNUM, 0 /INPUT A NUMBER <= 4095
2489 EXPLUP, DCA EXPON /ZERO THE EXPONENT
2490 JMS I [DIGIT /GET THE NEXT DIGIT
2491 JMP I SMLNUM /NUMBER DONE
2492 AND [17
2493 DCA OPO /SAVE THE DIGIT
2494 TAD EXPON /MULT BY 10
2495 CLL RAL
2496 CLL RAL
2497 TAD EXPON
2498 CLL RAL
2499 TAD OPO /ADD IN DIGIT
2500 JMP EXPLUP /STORE BACK INTO EXPONENT
2501 GETEXP, DCA ESIGN /ZERO EXPONENT SIGN SWITCH
2502 JMS I [GETC /GET A CHAR
2503 JMP I (FPNUM+1
2504 JMS I (CHKSGN /IS IT A SIGN
2505 FPRTNE,
2506 ESIGN, 0 /THIS IS THE SWITCH TO SET
2507 JMS SMLNUM /GO GET THE EXPONENT
2508 FIXEXP, TAD ESIGN /CHECK EXPONENT SIGN
2509 SNA CLA
2510 JMP .+4
2511 TAD EXPON /COMPLEMENT EXPONENT
2512 CIA
2513 DCA EXPON
2514 JMS DODEC /GO HANLE EXPONENT
2515 CLL CML RTL /BUMP RETURN BY TWO (DP) OR 3 (FP)
2516 TAD ESWIT /DEPENDING ON E/D SWITCH
2517 TAD I [NUMBER
2518 DCA I [NUMBER
2519 JMP I (DOSIGN /CHECK THE SIGN
2520 DODEC, 0
2521 TAD DO107 /NORMALIZE THE NUMBER
2522 DCA WORD1
2523 JMS I (ANORM
2524 TAD DECPT /WAS THERE A DECIMAL POINT ?
2525 SZA CLA
2526 TAD NDIGIT /HOW MANY DIGITS TO THE RIGHT ?
2527 CIA
2528 TAD EXPON /SUBTRACT THAT NUMBER FROM EXP
2529 SMA
2530 JMP POSEXP /EXPONENT IS POSITIVE
2531 CIA
2532 DCA EXPON /ONLY NEED ABS VALUE
2533 TAD (FPDIV /DO DIVIDES
2534 JMP .+3
2535 POSEXP, DCA EXPON
2536 TAD (FPMUL /DO MULTIPLIES
2537 DCA FPRTNE /MULTIPLY/DIVIDE ROUTINE
2538 TAD (PETABL-1 /POWERS OF TEN TABLE
2539 DCA X17
2540 EXPMUL, TAD EXPON /LOOK AT THE EXPONENT
2541 SNA
2542 JMP I DODEC /IF 0 ITS THRU
2543 CLL RAR
2544 DCA EXPON /PUT LOWEST BIT INTO LINK
2545 SNL
2546 JMP SKPEXP /THIS ONE DOESN'T COUNT
2547 CDF 10 /3.01/
2548 TAD I X17 /MOVE FACTOR INTO OPERAND
2549 DCA OP1
2550 TAD I X17
2551 DCA OP2
2552 TAD I X17
2553 DCA OP3
2554 TAD I X17
2555 DCA OP4
2556 TAD I X17
2557 DCA OP5
2558 TAD I X17
2559 DCA OP6
2560 DCA OPO
2561 CDF
2562 JMS I FPRTNE /MULTIPLY OR DIVIDE BY THIS FACTOR
2563 JMP EXPMUL /CHECK NEXT BIT
2564 SKPEXP, TAD X17 /SKIP OVER THIS FACTOR
2565 TAD (6
2566 JMP EXPMUL-1
2567 AR1, 0 /SHIFT FAC RIGHT ONE
2568 TAD WORD2
2569 CLL RAR
2570 DCA WORD2
2571 TAD WORD3
2572 RAR
2573 DCA WORD3
2574 TAD WORD4
2575 RAR
2576 DCA WORD4
2577 TAD WORD5
2578 RAR
2579 DCA WORD5
2580 TAD WORD6
2581 RAR
2582 DCA WORD6
2583 TAD ACO
2584 RAR
2585 DCA ACO
2586 ISZ WORD1
2587 DO107, 107
2588 JMP I AR1
2589
2590 AL1, 0 /SHIFT FAC LEFT ONE
2591 TAD ACO
2592 CLL RAL
2593 DCA ACO
2594 TAD WORD6
2595 RAL
2596 DCA WORD6
2597 TAD WORD5
2598 RAL
2599 DCA WORD5
2600 TAD WORD4
2601 RAL
2602 DCA WORD4
2603 TAD WORD3
2604 RAL
2605 DCA WORD3
2606 TAD WORD2
2607 RAL
2608 DCA WORD2
2609 JMP I AL1
2610 \f/ NUMERIC CONVERSION ROUTINE
2611 PAGE
2612 FPMUL, 0 /FLOATING MULTIPLY ROUTINE
2613 TAD WORD1 /COMPUTE NEW EXPONENT
2614 TAD OP1
2615 DCA OP1
2616 TAD WORD2 /SAVE AC MANTISSA
2617 DCA TW2
2618 TAD WORD3
2619 DCA TW3
2620 TAD WORD4
2621 DCA TW4
2622 TAD WORD5
2623 DCA TW5
2624 TAD WORD6
2625 DCA TW6
2626 TAD (-74 /SET ITERATION COUNTER
2627 DCA ITRCNT
2628 DCA WORD2 /ZERO FAC MANTISSA
2629 DCA WORD3
2630 DCA WORD4
2631 DCA WORD5
2632 DCA WORD6
2633 DCA ACO
2634 MULLUP, JMS I (AR1 /SHIFT FAC RIGHT ONE
2635 TAD TW2 /SHIFT MULTIPLIER RIGHT
2636 CLL RAR
2637 DCA TW2
2638 TAD TW3
2639 RAR
2640 DCA TW3
2641 TAD TW4
2642 RAR
2643 DCA TW4
2644 TAD TW5
2645 RAR
2646 DCA TW5
2647 TAD TW6
2648 RAR
2649 DCA TW6
2650 SZL
2651 JMS I (OADD /ADD IF LINK IS ONE
2652 ISZ ITRCNT /BUMP COUNT
2653 JMP MULLUP /LOOP
2654 TAD OP1 /PUT IN CORRECT EXPONENT
2655 DCA WORD1
2656 JMS I (ANORM /NORMALIZE THE RESULT
2657 JMP I FPMUL
2658 TW2, 0
2659 TW3, 0
2660 TW4, 0
2661 TW5, 0
2662 TW6, 0
2663 ANORM, 0 /NORMALIZE FAC
2664 TAD WORD2 /IS MANTISSA 0 ?
2665 SNA
2666 TAD WORD3
2667 SNA
2668 TAD WORD4
2669 SNA
2670 TAD WORD5
2671 SNA
2672 TAD WORD6
2673 SNA
2674 TAD ACO
2675 SNA CLA
2676 JMP ZEXP /YES, ZERO EXPONENT
2677 NORMLP, CLA CLL CML RTR /IS HIGH ORDER MANTISSA = 6000
2678 TAD WORD2
2679 SZA
2680 JMP NO6000 /NO, SKIP THIS STUFF
2681 TAD WORD3 /YES, IS THE REST 0 ?
2682 SNA
2683 TAD WORD4
2684 SNA
2685 TAD WORD5
2686 SNA
2687 TAD WORD6
2688 SNA
2689 TAD ACO
2690 SZA CLA /SKIP IF 600000 ... 0000
2691 NO6000, SPA CLA
2692 JMP I ANORM /NORM IS DONE WHEN BITS DIFFER
2693 JMS I (AL1 /SHIFT LEFT ONE
2694 CLA CMA /DECREMENT EXPONENT
2695 TAD WORD1
2696 DCA WORD1
2697 JMP NORMLP /LOOP
2698 ZEXP, DCA WORD1
2699 JMP I ANORM
2700 NEGFAC, 0 /NEGATE FAC
2701 TAD (ACO /GET POINTER TO OPERAND
2702 DCA NFPTR
2703 TAD (-6 /SIX WORD NEGATE
2704 DCA NFCNT
2705 CLL
2706 NFLOOP, RAL
2707 TAD I NFPTR /GET NEXT WORD
2708 CLL CML CIA
2709 DCA I NFPTR /RESTORE AFTER COMPLEMENTING
2710 CML CLA CMA /LINK GETS COMPLEMENTED ONCE HERE
2711 TAD NFPTR /AND ONCE AGAIN HERE
2712 DCA NFPTR /RESTORE DECREMENTED POINTER
2713 ISZ NFCNT
2714 JMP NFLOOP
2715 JMP I NEGFAC
2716 NFPTR, 0
2717 NFCNT, 0
2718 ITRCNT,
2719 DHLRTH, 0 /HOLLERITH IN DATA SUBR
2720 ISZ TEMP
2721 SKP
2722 JMP I DHLRTH
2723 ISZ DHLRTH
2724 JMS I [GETCWB
2725 JMP DHOLER
2726 JMP I DHLRTH
2727 \f/ VARIABLE SCANNER
2728 PAGE
2729 GETNAM, 0 /GET VARIABLE NAME
2730 JMS LETTER /FIRST CHAR MUST BE ALPHABETIC
2731 JMP I GETNAM /NO VARIABLE
2732 DCA BUCKET /FIRST ONE IS THE BUCKET
2733 TAD (NAME1
2734 DCA NPTR /POINTER TO NAME BUFFER
2735 CLL CMA RTL /SIX CHARS MAX (3 WORDS)
2736 DCA NCNT
2737 PAKLUP, JMS LETTER /GET A LETTER
2738 SKP
2739 JMP .+3 /WE GOT IT
2740 JMS I [DIGIT /NO LETTER, IS IT A DIGIT ?
2741 JMP NDONE /NO, NAMES OVER
2742 CLL RTL
2743 RTL
2744 RTL /MOVE CHAR TO A HIGHER PLACE
2745 DCA I NPTR /STORE IT
2746 ISZ NCNT /BUMP COUNTER
2747 JMP MORNAM /MORE TO COME
2748 SKP
2749 NDONE, DCA I NPTR /ZERO NEXT WORD
2750 ISZ GETNAM /FIX RETURN ADDR
2751 JMP I GETNAM
2752 MORNAM, JMS LETTER /GET NEXT CHAR
2753 SKP
2754 JMP .+3 /ITS A LETTER
2755 JMS I [DIGIT
2756 JMP NDONE+1 /NO GOOD, NAMES OVER
2757 TAD I NPTR
2758 DCA I NPTR /COMBINE TWO CHARS
2759 ISZ NPTR
2760 JMP PAKLUP
2761 NPTR, 0
2762 NCNT=OADD
2763 \f/ DATA STATEMENT
2764 DATA, JMS I [IFCHEK /IF(..)DATA ????
2765 TAD (DATAST /START DATA STATEMENT
2766 JMS I [OUTWRD
2767 DATLUP, CLA CMA /SET DIMNUM = -1 IF NO SUBSCRIPTS
2768 JMS I [GETSS /GET LIST ELEMENT
2769 JMP DATAER
2770 TAD (DPUSH /OUTPUT DPUSH OPERATOR
2771 JMS I [OUTWRD
2772 CMA
2773 TAD TEMP2 /FOLLOWED BY POINTER
2774 JMS I [OUTWRD
2775 TAD DIMNUM /FOLLOWED BY NUMBER
2776 JMS I [OUTWRD
2777 CDF 10
2778 TAD I TEMP2 /LOOK AT TYE TYPE
2779 AND (20 /IS IT AN ARG ?
2780 CDF
2781 SZA CLA
2782 JMP DATAER /YES, THATS BAD
2783 JMS I [GETC /, ?
2784 JMP DATAER
2785 TAD (-254
2786 SNA
2787 JMP DATLUP /LOOK FOR MORE
2788 TAD (254-257 // ?
2789 SZA CLA
2790 JMP DATAER
2791 JMP DLOOP2 /GO LOOK FOR ELEMENT
2792 DATA3, TAD (WORD1-1
2793 DCA X10 /POINTER TO THE GOODS
2794 TAD I X10 /THEN STUFF
2795 JMS I [OUTWRD
2796 ISZ TEMP
2797 JMP .-3
2798 NXTDE, TAD (ENDELM /OUTPUT END OF ELEMENT
2799 JMS I [OUTWRD
2800 JMS I [GETC /LOOK FOR COMMA
2801 JMP DATAER
2802 TAD (-254
2803 SNA
2804 JMP DLOOP2 /YES, GET MORE DATA
2805 TAD (254-257 /SLASH ?
2806 SZA CLA
2807 JMP DATAER /NO, ERROR
2808 JMS I [GETC /ANOTHER DATA GROUP ?
2809 JMP I [NEXTST /NO
2810 TAD (-254 /COMMA ?
2811 SNA CLA
2812 JMP DATA+1 /START A NEW DATA STMT
2813 DATAER, JMS I [ERMSG
2814 0401 /OK WHEN THIS IS AN AND
2815 JMP I [NEXTST
2816 DHOLER, JMS I [ERMSG
2817 0410 /HOLLERITH DATA ERROR
2818 JMP I [NEXTST
2819 DQUOTE, 0 /GET CHAR FOR QUOTED DATA
2820 JMS I [GETCWB
2821 JMP DHOLER
2822 TAD [-247
2823 SZA
2824 JMP DNOTQ2
2825 JMS I [GETCWB
2826 JMP I DQUOTE
2827 TAD [-247
2828 SNA CLA
2829 JMP DNOTQ2 /REPLACE '' BY '
2830 JMS I [BACK1
2831 JMP I DQUOTE
2832 DNOTQ2, TAD [247 /FIX CHAR
2833 ISZ DQUOTE
2834 JMP I DQUOTE
2835 OUT3WD, 0 /2.02/ OUTPUT 3 WORDS
2836 TAD [DATELM /2.02/ OUTPUT ELEMENT HEAD
2837 JMS I [OUTWRD /2.02/
2838 TAD (3 /2.02/ AND SIZE
2839 JMS I [OUTWRD /2.02/
2840 TAD WORD1 /2.02/ NOW THREE WORDS
2841 JMS I [OUTWRD /2.02/
2842 TAD WORD2 /2.02/
2843 JMS I [OUTWRD /2.02/
2844 TAD WORD3 /2.02/
2845 JMS I [OUTWRD /2.02/
2846 JMP I OUT3WD /2.02/
2847 \f/ DATA STATEMENT
2848 PAGE
2849 DLOOP2, JMS I [GETC
2850 JMP DATAER
2851 TAD (-250 /IS CHAR ( ?
2852 SZA
2853 JMP NOCMPD /NO, NOT COMPLEX DATA
2854 JMS I [NUMBER /GET REAL PART
2855 JMP DATAER
2856 SKP
2857 JMP DATAER /DP IS NG WITH COMPLEX
2858 JMS OUT3WD /2.02/ OUTPUT 3 WORDS
2859 JMS I [CHECKC /LOOK FOR COMMA
2860 -254
2861 JMP DATAER /BAD IF NOT THERE
2862 JMS I [NUMBER /GET IMAGINARY PART
2863 JMP DATAER
2864 SKP
2865 JMP DATAER
2866 JMS I [CHECKC /LOOK FOR )
2867 -251
2868 JMP DATAER /NOT THERE
2869 JMP DATAFP /GO MOVE IMAGINARY PART
2870 NOCMPD, IAC /IS IT QUOTED STRING ?
2871 SZA
2872 JMP NQUOTD /NO
2873 TAD (DQUOTE /GET SUBR ADDRESS
2874 JMP HOLDAT /GO HANDLE IT
2875 NQUOTD, TAD (247-317 /IS IT AN O (OCTAL)
2876 SNA
2877 JMP I (XOCTAL /YES
2878 TAD (317-256 /IS IT .
2879 SNA CLA
2880 JMS I (TRUFAL /CHECK FOR TRUE OR FALSE
2881 JMP NOTF /NO TRUE-FALSE, TRY NUMBER
2882 CLL CML RTR /2000
2883 DCA WORD2
2884 TAD WORD2
2885 SZA CLA
2886 IAC
2887 DCA WORD1 /TRUE=1.0 FALSE=0.0
2888 DCA WORD3
2889 JMP DATAFP /GO PUT IT
2890 NOTF, JMS I [BACK1 /PUT BACK CHAR
2891 JMS I [NUMBER /TRY FOR A NUMBER
2892 JMP DATAER /ELEMENT MISSING
2893 JMP TRYHOS /IF INTEGER, TRY FOR H OR *
2894 TAD (-3
2895 DATAFP, TAD (-3 /FP DATA
2896 DCA TEMP /SIZE OF ITEM
2897 TAD [DATELM /DATA ELEMENT SIGNAL
2898 JMS I [OUTWRD
2899 TAD TEMP /THEN SIZE
2900 CIA /ALWAYS POSITIVE
2901 JMS I [OUTWRD
2902 JMP DATA3 /GO OUTPUT THE DATA
2903 TRYHOS, JMS I [GETC /LOOK FOR H
2904 JMP DATAER
2905 TAD (-310
2906 SZA
2907 JMP TRYSTR /NOT H, MAYBE ITS *
2908 JMS I [FIXNUM /INTEGERIZE IT
2909 SNA
2910 JMP DHOLER /HOLLERITH DATA ERROR
2911 CMA
2912 DCA TEMP /SAVE COUNT
2913 TAD (DHLRTH /GET SUBR POINTER
2914 HOLDAT, DCA HCHAR
2915 CLL CMA RTL /2.02/ COUNT
2916 DCA TEMP2 /2.02/ BY THREES
2917 TAD (WORD1-1 /2.02/
2918 DCA X10 /2.02/ POINTER
2919 HDLOOP, JMS I HCHAR /GET A CHAR
2920 JMP EOHD /2.02/
2921 AND [77 /6 BITIZE IT
2922 CLL RTL
2923 RTL
2924 RTL /UPPER-PART-OF-WORDIZE
2925 DCA WORD3 /2.02/ STORAGIZE IT
2926 JMS I HCHAR /GET ANOTHER
2927 JMP LASTHD /LAST HALF WORD MUST GO OUT
2928 AND [77
2929 TAD WORD3 /2.02/ COMBINIZE THE TWO HALVES
2930 DCA I X10 /2.02/ STORE IT
2931 ISZ TEMP2 /2.02/ THREE AT A TIME
2932 JMP HDLOOP /2.02/
2933 JMS OUT3WD /2.02/ OUTPUT THREE
2934 JMP HOLDAT+1 /2.02/ GO DO NEXT THREE WDS
2935 EOHD, CLL CML RTL /2.02/ ANY CHARS IN THIS SET ?
2936 TAD TEMP2 /2.02/
2937 SPA CLA /2.02/
2938 JMP NXTDE /2.02/ NO, DO NEXT ELEMENT
2939 JMP .+4 /2.02/ YES, FILL IT OUT
2940 LASTHD, TAD WORD3 /2.02/ FILL OUT LOWER CHAR
2941 TAD (40 /2.02/ WITH A BLANK
2942 DCA I X10 /2.02/
2943 TAD (4040 /2.02/ THEN FILL REST
2944 DCA I X10 /2.02/ WITH BLANKS
2945 TAD (4040 /2.02/
2946 DCA I X10 /2.02/
2947 JMP DATAFP /2.02/ GO OUTPUT IT
2948 TRYSTR, TAD (310-252 /*
2949 SNA CLA
2950 JMP .+3
2951 JMS I [BACK1 /PUT BACK THAT CHAR
2952 JMP DATAFP /ITS JUST AN INTEGER
2953 TAD (DREPTC /REPETITION COUNT
2954 JMS I [OUTWRD
2955 JMS I [FIXNUM
2956 JMS I [OUTWRD /OUTPUT COUNT
2957 JMP DLOOP2 /LOOP
2958 \f/ INITIALIZE READ IN
2959 *6400
2960 INITLN, TAD IX7772 /READ FIRST SIX CHARS
2961 DCA TEMP
2962 TAD IXLINM
2963 DCA CHRPTR
2964 INITLP, CIF 10
2965 JMS I [ICHAR /READ A CHAR
2966 JMP INITLN
2967 TAD IXM211 /TAB ?
2968 SZA CLA
2969 JMP NIXTAB /NO THIS ONE
2970 TAD IX0240
2971 DCA I CHRPTR
2972 ISZ TEMP
2973 JMP .-3
2974 JMP CHKCOM /DO COMMENT CHECK
2975 NIXTAB, TAD CHAR
2976 DCA I CHRPTR /STORE THE CHAR
2977 ISZ TEMP
2978 JMP INITLP
2979 CHKCOM, TAD I IXLINE /COMMENT ?
2980 TAD IXM303
2981 SNA CLA
2982 JMP IGNORE /IGNORE IT
2983 TAD I IXLNP5 /CONTINUATION ?
2984 TAD IXM240
2985 SZA CLA
2986 JMP IGNORE
2987 TAD IX7700 /FIX CALL
2988 CDF 10 /SEE WHAT HAPPENS WHEN YOU MOVE A ROUTINE**
2989 DCA I IXINCL
2990 CDF /**
2991 CIF 10
2992 JMS I IX200 /REMOVE MONITOR
2993 11
2994 CDF 10 /FIX FIELD ONE STUFF
2995 TAD I MOV1
2996 DCA I MOV2
2997 ISZ MOV1
2998 ISZ MOV2
2999 ISZ MOVCNT
3000 JMP .-5
3001 CDF
3002 JMP I IXRDFS /LOOK FOR PROG HEADER
3003 MOV1, 2020
3004 MOV2, 20
3005 MOVCNT, -160
3006 IGNORE, CIF 10 /**
3007 JMS I [ICHAR /SKIP TILL CARRIAGE RETURN
3008 JMP INITLN
3009 CLA
3010 JMP IGNORE
3011 IXRDFS, RDFRST
3012 IXINCL, INCALL
3013 IXM240, -240
3014 IXM303, -303
3015 IX0240, 0240
3016 IX200, 200
3017 IX7600, 7600
3018 IX7772, 7772
3019 IXM211, -211
3020 IX7700, 7700 /V3C
3021 \f/ SEARCH FOR PROGRAM HEADER
3022 PAGE
3023 RDFRST, CIF 10 /**
3024 JMS I [ICHAR /THIS IS A DUPLICATE OF THE CODE
3025 JMP ENDLNF /AT LABEL 'RDLOOP' , ONLY THE
3026 TAD (-211
3027 SNA
3028 TAD (240-211
3029 TAD (211
3030 DCA I CHRPTR /NAMES HAVE BEEN CHANGED TO
3031 ISZ CNT72
3032 SKP
3033 JMP SKPFL2
3034 TAD CHRPTR /PROTECT THE ASSEMBLY
3035 CIA CLL /(IT GETS THE FIRST LINE
3036 TAD (LINE+270 /WHICH MAY BE SUBROUTINE OR
3037 /FUNCTION. 1ST LINE SHORTER THAN REST BEC OF BUFFER OVERWRITES**
3038 SZL CLA /OR SOMETHING ELSE, IN WHICH CASE
3039 JMP RDFRST /ITS THE MAIN PROGRAM)
3040 JMS I [ERMSG /LINE TOO LONG
3041 1424
3042 JMP SKPFL /SKIP REST
3043 SKPFL2, CIF 10 /**
3044 JMS I [ICHAR
3045 JMP ENDLNF
3046 CLA
3047 JMP SKPFL2
3048 SKPCMF, TAD X16 /BY ORDER OF THE EMPEROR
3049 DCA CHRPTR /MARIO DE NOBILI
3050 ENDLNF, TAD CHRPTR
3051 DCA X16
3052 TAD CHRPTR
3053 DCA X10
3054 TAD (-102
3055 DCA CNT72
3056 TAD (-6
3057 DCA NCHARS
3058 GET6F, CIF 10 /**
3059 JMS I [ICHAR
3060 JMP SKPCMF
3061 TAD (-211
3062 SZA CLA
3063 JMP NOTABF
3064 TAD (240
3065 DCA I CHRPTR
3066 ISZ NCHARS
3067 JMP .-3
3068 TAD (240
3069 DCA CHAR
3070 JMP CCHEKF
3071 NOTABF, TAD CHAR
3072 DCA I CHRPTR
3073 ISZ NCHARS
3074 JMP GET6F
3075 CCHEKF, TAD I X10
3076 TAD (-303
3077 SZA CLA
3078 JMP NOCMTF
3079 SKPFL, CIF 10 /**
3080 JMS I [ICHAR
3081 JMP SKPCMF
3082 CLA
3083 JMP SKPFL
3084 NOCMTF, TAD CHAR
3085 TAD (-240
3086 SNA CLA
3087 JMP GOTFST
3088 CCARDF, TAD X16
3089 DCA CHRPTR
3090 JMP RDFRST
3091 GOTFST, TAD CHRPTR
3092 CIA
3093 TAD (LINE+4
3094 DCA NCHARS
3095 TAD [LINE-1
3096 DCA CHRPTR
3097 JMS I [SAVECP
3098 TAD (HDRLST-1
3099 DCA X10 /PREPARE TO SEARCH THE LIST
3100 CLOOP1, CDF 10 /(FNC NAMES UP IN FLD 1)**
3101 TAD I X10 /OF LEGAL HEADER LINES
3102 CDF
3103 SZA /CODE IS AS UNDER 'CMDLUP'
3104 JMP CLOOP2
3105 CLA CMA RAL
3106 TAD STACK
3107 DCA STACK
3108 CDF 10 /**
3109 TAD I X10
3110 CDF
3111 DCA TEMP
3112 JMP I TEMP
3113 CLOOP2, DCA TEMP
3114 JMS I [GET2C
3115 JMP BADCMF
3116 CIA
3117 TAD TEMP
3118 SNA CLA
3119 JMP CLOOP1
3120 SEARCH, CDF 10 /**
3121 TAD I X10
3122 CDF
3123 SZA CLA
3124 JMP SEARCH
3125 ISZ X10
3126 JMS I [RESTCP
3127 ISZ STACK
3128 ISZ STACK
3129 CDF 10 /**
3130 TAD I X10
3131 CDF
3132 SZA
3133 JMP CLOOP2
3134 BADCMF, JMS I [RESTCP /NOT A FUNCTION OR SUBROUTINE
3135 JMP I (LINE1 /SO GO TO MAIN PART OF COMPILER
3136 BADDIE, JMS I [MESSAG /SOMETHING MISSING FROM SYS
3137 323 /S
3138 331 /Y
3139 \f/ ANALYZE PROGRAM HEADER
3140 PAGE
3141 SUBRTN, CLA CMA /SET TO -1 FOR SUBR
3142 JMP XXXFUN+1
3143 REAFUN, TAD (102 /SET TYPE TO REAL
3144 DCA TYPE
3145 JMP XXXFUN
3146 LOGFUN, IAC /SET TYPE OF FUN
3147 DBLFUN, IAC /WITH DOUBLEMINT GUM !
3148 CMPFUN, IAC
3149 IAC
3150 INTFUN, TAD (101
3151 DCA TYPE
3152 JMS I [CHECKC /LOOK FOR 'N'
3153 -316
3154 JMP BADBGN
3155 XXXFUN, CLA IAC
3156 DCA FUNCTN /SET SWITCH
3157 CDF 10 /1.05/ KILL ENTRY FOR 'MAIN'
3158 DCA I (ALIST+14 /1.05/ BUT DO IT BEFORE THE M BUCKET
3159 CDF /1.05/ CONTAINS ANYTHING USEFULL
3160 JMS I [GETNAM /GET FUNC/SUBR NAME
3161 JMP BADBGN
3162 JMS I [LOOKUP /PUT INTO SYMBOL TABLE
3163 DCA PROGNM
3164 TAD PROGNM /SET UP TYPE
3165 IAC
3166 DCA TEMP
3167 TAD STACK
3168 DCA X12 /SAVE POINTER
3169 DCA TEMP2 /ZERO ARG COUNTER
3170 CDF 10
3171 TAD TYPE /PUT IN THE TYPE BITS
3172 TAD (1000
3173 DCA I TEMP
3174 CDF
3175 JMS I [CHECKC /LOOK OFR (
3176 -250
3177 JMP ISITFN /IS IT A FUNCTION ?
3178 ARGLUP, JMS I [GETNAM /GET THE ARG
3179 JMP BADBGN
3180 JMS I [LOOKUP
3181 IAC
3182 DCA TEMP /ADDR OF TYPE WORD
3183 CDF 10
3184 TAD I TEMP
3185 SZA CLA
3186 JMP BADBGN /ALREADY AN ARG
3187 TAD (20
3188 DCA I TEMP
3189 CDF
3190 CMA
3191 TAD TEMP /OUTPUT ADDR OF ARG
3192 JMS I [PUSH
3193 ISZ TEMP2 /KEEP COUNT
3194 JMS I [COMARP /LOOK FOR , OR )
3195 JMP BADBGN /NEITHER
3196 JMP ARGLUP /,
3197 TAD TEMP2 /) HOW MANY ARGS ?
3198 CDF 10
3199 DCA I NEXT /INTO ARG LIST
3200 TAD TEMP2
3201 CIA
3202 DCA TEMP2
3203 TAD NEXT /SAVE ADDR OF ARG LIST
3204 DCA ARGLST
3205 CDF
3206 TAD X12 /RESTORE THE STACK
3207 DCA STACK
3208 MOVARG, TAD I X12 /PUT ARGS INTO ARG LIST
3209 CDF 10
3210 DCA I NEXT
3211 CDF
3212 ISZ TEMP2
3213 JMP MOVARG
3214 JMP I [NEXTST /DO NEXT LINE
3215 TYPE=WORD6
3216 ISITFN, TAD FUNCTN /IS IT A FUNCTION
3217 SPA SNA CLA /WITH NO ARGS ?
3218 JMP I [NEXTST /NO, WE'RE OK
3219 BADBGN, JMS I [ERMSG
3220 2010
3221 JMP I [NEXTST
3222 BDATA, JMS I [CHECKC /LOOK FOR A
3223 -301
3224 JMP BADBGN
3225 CLL CMA RAL /SET FUNCTION SWITCH
3226 DCA FUNCTN /2.02/ STORE IT DUMMY!!
3227 TAD (BDLIST-1 /POINTER TO LIST OF PATCHES
3228 DCA X10
3229 BDLOOP, CDF 10
3230 TAD I X10 /GET PATCH LOCATION
3231 CDF
3232 SNA
3233 JMP I [NEXTST /NO MORE PATCHES
3234 DCA TEMP /SAVE PATCH ADDRESS
3235 TAD BADJMP /GET ERROR JUMP
3236 DCA I TEMP /STORE IT
3237 JMP BDLOOP /LOOP
3238 BADJMP, JMP I [BDERR
3239 \f/ INITIAL SYMBOL TABLE
3240 FIELD 1
3241 *2020
3242 NOPUNC
3243 *20
3244 ENPUNC
3245 0
3246 BLNKCN, 111;0 /BLANK COMMON SLOT
3247 ALIST, 0;0;0;0;0;0;0;0;0;0;0;0;MAIN;0;0;0;0;0;0;0;0;0;0;0;0;0
3248 HOLIST, 0
3249 FPLIST, 0
3250 DPLIST, 0
3251 INTLST, ONE
3252 CMPLST, 0
3253 SNLIST, 0
3254 ONE, THREE;0;1;2000;0
3255 THREE, SIX;0;2;3000;0
3256 SIX, 0;0;3;3000;0
3257 TRUE, 0;0145;0
3258 MAIN, 0;1000;0;0111;1600
3259 FREE, 0
3260 \f/ BLOCK DATA PATCH LIST
3261 BDLIST, IF /BLOCK DATA PATCH LIST
3262 DOUBLE
3263 DO
3264 GOTO
3265 CALL
3266 READ
3267 REWIND
3268 ENDFIL
3269 FORMAT
3270 WRITE
3271 BACKSP
3272 ASSIGN
3273 STOP
3274 PAUZE
3275 DFINFL
3276 FIND
3277 ITSAR
3278 0
3279 \f/ INITIALIZATION
3280 *2200
3281 START, SKP /NON-CHAINED ENTRY POINT
3282 JMP .+5 /CCL ENTRY
3283 CIF CDF 10 /START HERE
3284 JMS I (200 /COMMAND DECODE
3285 5
3286 0624 /DEFAULT EXT IS .FT
3287 TAD I L7600 /IS AN OUTPUT FILE GIVEN ?
3288 SNA CLA
3289 JMP MYFILE /NO, USE FORTRN.TM
3290 MOVOFN, TAD I OFNAME /MOVE NAME INTO PAGE 0
3291 CDF
3292 DCA I NAMEOF
3293 CDF 10
3294 ISZ NAMEOF
3295 ISZ OFNAME
3296 ISZ OFNSIZ
3297 JMP MOVOFN
3298 EXTEST, TAD I (7604 /SET DEFAULT EXTENSIONS
3299 SZA
3300 JMP EXTSET
3301 TAD I (7643
3302 SPA
3303 JMP GETRA /A WAS SET.USE RA
3304 AND L41 /CHECK FOR L+G
3305 SNA CLA
3306 TAD (0610 /USE RL
3307 TAD (1404 /USE LD
3308 EXTSET, DCA I (7604
3309 TAD I (7604
3310 CDF 0
3311 DCA I NAMF
3312 CDF 10
3313 TAD I (7611
3314 SNA
3315 TAD (1423 /.LS FOR LISTING
3316 DCA I (7611
3317 TAD I (7616
3318 SNA
3319 TAD (1520 /.MP FOR LOAD MAP
3320 DCA I (7616
3321 EFILE, CLA IAC /OPEN PASS1 OUTPUT FILE
3322 JMS I (200
3323 3
3324 OBLOK, TMPFL2
3325 OSIZE, 0
3326 JMP OBAD /BADDIE
3327 CDF
3328 TAD OBLOK /SAVE STARTING BLOCK
3329 DCA OUBLOK
3330 TAD OBLOK
3331 DCA I (OUFILE
3332 TAD OSIZE
3333 DCA OULEN
3334 CDF 10
3335 CLA IAC
3336 JMS I (200 /GET PASS2
3337 2
3338 SPASS2, PASS2N
3339 0
3340 JMP OBAD
3341 CLA IAC
3342 JMS I (200
3343 2
3344 SP2O, PAS2ON /GET PASS2 OVERLAY
3345 0
3346 JMP OBAD
3347 CDF /SAVE PASS2 AND PASS2O BLOCKS
3348 TAD SPASS2
3349 DCA PASS2B
3350 TAD SP2O /SKIP FIRST BLOCK
3351 IAC /ITS THE CORE TABLE
3352 DCA I (PASS2O
3353 CIF
3354 JMP INITLN /GO START COMPILE
3355 MYFILE, CDF /PUT DEFAULT INTO 17600
3356 TAD I NAMOF
3357 DCA I NAMEOF
3358 TAD I NAMOF /ALSO INTO PAGE 0
3359 CDF 10
3360 DCA I OFNAME
3361 ISZ NAMOF
3362 ISZ NAMEOF
3363 ISZ OFNAME
3364 ISZ OFNSIZ
3365 JMP MYFILE
3366 CLA IAC /SET DEV TO SYS
3367 DCA I L7600
3368 JMP EXTEST /GO OPEN FILE
3369 OBAD, CIF CDF
3370 JMP BADDIE
3371 OFNAME, 7601 /IGNORE DEVICE (ALWAYS USE SYS)
3372 NAMEOF, TMPFIL+4
3373 NAMOF, TMPFIL
3374 OFNSIZ, -3
3375 TMPFL2, 0617;2224;2216;2415 /FORTRN.TM
3376 PASS2N, 2001;2323;6200;2326 /PASS2.SV
3377 PAS2ON, 2001;2323;6217;2326 /PASS2O.SV
3378 NAMF, TMPFIL+7
3379 L7600,
3380 GETRA, 7600 /CLA
3381 TAD (2201 /V3C USE RA
3382 JMP EXTSET
3383 L41, 41
3384 \f PAGE
3385 / PROGRAM HEADER LIST
3386 HDRLST, TEXT 'INTEGERFUNCTIO'
3387 INTFUN
3388 TEXT 'REALFUNCTION'
3389 REAFUN
3390 TEXT 'COMPLEXFUNCTIO'
3391 CMPFUN
3392 TEXT 'DOUBLEPRECISIONFUNCTIO'
3393 DBLFUN
3394 TEXT 'LOGICALFUNCTIO'
3395 LOGFUN
3396 TEXT 'FUNCTION'
3397 XXXFUN
3398 TEXT 'SUBROUTINE'
3399 SUBRTN
3400 TEXT 'BLOCKDAT'
3401 BDATA
3402 0
3403 \f/ PS-8 FILE INPUT ROUTINES
3404 /NEED TWO PAGES BEC. MOVING ICHAR OUT OF FIELD 1 REQUIRES
3405 /ALOT OF FIELD DIDDLING.
3406 *5400
3407 MORCHR, TAD (214 /FIX CHAR
3408 CDF 0 /**
3409 DCA I QCHAR
3410 CDF 10
3411 TAD I (ICHAR
3412 IAC /UPDATE ADDR
3413 DCA TCHAR
3414 CIF CDF 0
3415 TAD I QCHAR /RETURN VALUE IN AC
3416 JMP I TCHAR
3417 TCHAR, 0
3418 QCHAR, CHAR
3419 / EXTENDED OPERATOR LIST
3420 OPRLST, -01;-1604;ANDOPR
3421 -17;-2200;OROPR
3422 -05;-2100;EQOPR
3423 -16;-0500;NEOPR
3424 -07;-0500;GEOPR
3425 -07;-2400;GTOPR
3426 -14;-0500;LEOPR
3427 -14;-2400;LTOPR
3428 -30;-1722;XOROPR
3429 -05;-2126;EQVOPR
3430 0
3431 / EXPONENT TABLE
3432 PETABL, 0004;2400;0000 /1E1
3433 0000;0000;0000
3434 0007;3100;0000 /1E2
3435 0000;0000;0000
3436 0016;2342;0000 /1E4
3437 0000;0000;0000
3438 0033;2765;7020 /1E8
3439 0000;0000;0000
3440 0066;2160;6744 /1E16
3441 6770;1000;0
3442 0153;2356;1326 /1E32
3443 6501;2670;2655
3444 0325;3023;6017 /1E64
3445 5117;7747;6466
3446 0652;2235;6443 /1E128
3447 7114;0164;6145
3448 1523;2523;7565 /1E256
3449 7734;7374;7357
3450 3245;3430;6320 /1E512
3451 2565;1407;2176
3452 ENDSTM, 211;"E;"N;"D;215;211;215;232 /V3C
3453 /FAKE END STATEMENT USED IF PROGRAM HAS NONE
3454 \f PAGE
3455 \f/MAIN PART OF OS/8 INPUT ROUTINES
3456
3457 ICHAR, 0 /READ CHAR FROM INPUT FILE
3458 CDF 10
3459 ISZ INJMP /BUMP THREE WAY UNPACK SWITCH
3460 ISZ INCHCT
3461 INJMPP, JMP INJMP
3462 / CDF **
3463 TAD INEOF /DID LAST READ YEILD END OF FILE ?
3464 SNA CLA
3465 JMP INGBUF /NO, DO ANOTHER READ
3466 GETNEW, JMS INNEWF /OPEN A NEW INPUT FILE
3467 JMP ENDIN /END OF INPUT
3468 INGBUF, TAD INCTR /BUMP RECORD COUNTER
3469 CLL IAC
3470 SNL
3471 DCA INCTR /RESTORE IF IT HASN'T OVERFLOWED
3472 SZL
3473 ISZ INEOF /SET END OF FILE SWITCH
3474 CDF 10 /**
3475 CIF 0 /**
3476 JMS I INHNDL /DO THE READ
3477 0210 /ONE BLOCK TO FIELD 1
3478 INBUFP, INBUF
3479 INREC, 0
3480 JMP INERR /HANDLER ERROR
3481 INBREC, ISZ INREC /BUMP RECORD NUMBER
3482 TAD INBUFP /RESET BUFFER POINTER
3483 SVIBPT, DCA INPTR /V3C
3484 TAD (-601 /SET CHAR COUNT
3485 DCA INCHCT
3486 TAD INJMPP /RESET THREE WAY JUMP SWITCH
3487 DCA INJMP
3488 JMP ICHAR+1 /GO AGAIN
3489 INERR, ISZ INEOF /EITHER EOF OR BADDIE
3490 SMA CLA
3491 JMP INBREC /END OF FILE, DO NEXT FILE
3492 JMP TERR /INPUT ERROR, GIVE I F AND EXIT
3493 ENDIN, TAD (ENDSTM /V3C IF NO END STATEMENT, FORCE ONE
3494 JMP SVIBPT
3495
3496 /ENDIN, TAD INCALL /END OF INPUT IS USR IN CORE ?
3497 / TAD (-200
3498 / CIF 0 /**
3499 / SZA CLA
3500 / JMP I (ENDX /NO, ITS END OF PROG
3501 TERR, JMS I (MESSAG /YES, BAD INPUT. WAS SQ.BRCK**
3502 311
3503 306
3504 INJMP, HLT /3 WAY CHAR UNPACK BRANCH
3505 JMP ICHAR1
3506 JMP ICHAR2
3507 ICHAR3, TAD INJMPP /RESET JUMP SWITCH
3508 DCA INJMP
3509 TAD I INPTR
3510 AND (7400 /COMBINE THE HIGH ORDER BITS
3511 CLL RTR /OF THE TWO WORDS
3512 RTR
3513 TAD INTMP /TO FORM THE THIRD CHAR
3514 RTR
3515 RTR
3516 ISZ INPTR /BUMP WORD POINTER
3517 JMP ICHAR1+1 /DO SOME COMMON STUFF
3518 ICHAR2, TAD I INPTR /SAVE THE HIGH ORDER BITS
3519 AND (7400
3520 DCA INTMP /FOR THE THIRD CHAR
3521 ISZ INPTR /GO TO THE SECOND WORD
3522 ICHAR1, TAD I INPTR /GET THE LOW 8 BITS
3523 / CDF
3524 AND (177 /AND I MEAN ONLY 8 !!
3525 SNA /V3C YOU WERE WRONG - YOU MEANT ONLY 7
3526 JMP ICHAR+1
3527 TAD (-32 /IS IT ^Z (END OF FILE)
3528 SNA
3529 JMP GETNEW /YES, LOOK FOR THE NEXT FILE
3530 TAD (232-212
3531 SNA
3532 JMP ICHAR+1 /IGNORE LINE FEEDS
3533 TAD (212-215
3534 SNA
3535 JMP ICHARN /RETURN ON CARRIAGE RETURN **
3536 IAC
3537 SNA
3538 JMP ICHAR+1 /IGNORE FORM FEEDS
3539 JMP I (MORCHR /**
3540 ICHARN, CIF CDF 0
3541 JMP I ICHAR
3542 INTMP, 0
3543 INFPTR, 7617 /POINTER TO INPUT FILE LIST
3544 INEOF, 1
3545 INCHCT,
3546 INNEWF, -1 /FETCH HANDLER FOR NEXT FILE
3547 CDF 0 /**
3548 TAD (INDEVH+1 /THIS IS WHERE IT GOES **
3549 DCA INHNDL
3550 CDF 10
3551 TAD I INFPTR /GET NEXT INPUT FILE INFO
3552 SNA
3553 JMP I INNEWF /NO MORE FILES
3554 CDF 10 /WAS CIF 10**
3555 JMS I INCALL /CALL MONITOR
3556 1 /FETCH HANDLER
3557 INHNDL, 0 /ENTRY ADDR GOES HERE
3558 JMP INERR+3 /THIS CAN'T HAPPEN HERE
3559 TAD I INFPTR /GET LENGTH
3560 AND (7760
3561 SZA /A ZERO HERE MEANS >=256 BLOCKS
3562 TAD (17 /PUT IN SOME MORE BITS
3563 CLL CML RTR
3564 RTR
3565 DCA INCTR /STORE LENGTH OF FILE
3566 ISZ INFPTR
3567 TAD I INFPTR /GET STARTING RECORD NUMBER
3568 DCA INREC
3569 ISZ INFPTR
3570 DCA INEOF /CLEAR EOF FLAG
3571 ISZ INNEWF
3572 JMP I INNEWF
3573 INCTR, 0
3574 INCALL, 200 /CHANGED TO 7700 AFTER FIRST TIME
3575 INPTR, 0
3576 PAGE
3577 \f/ KEYWORD LIST
3578 CMDLST, -1106;0;IF /IF
3579 -0417
3580 -2502
3581 -1405
3582 -2022
3583 -0503
3584 -1123
3585 -1117;0;DOUBLE /DOUBLE PRECISION
3586 -0417;0;DO /DO
3587 -0717
3588 -2417;0;GOTO /GOTO
3589 -0317
3590 -1515
3591 -1716;0;COMMON /COMMON
3592 -0317
3593 -1520
3594 -1405;0;COMPLE /COMPLEX
3595 -0317
3596 -1624
3597 -1116
3598 -2505;0;NEXTST /CONTINUE
3599 -0301
3600 -1414;0;CALL /CALL
3601 -2205
3602 -0114;0;REAL /REAL
3603 -2205
3604 -0104;0;READ /READ
3605 -2205
3606 -2711
3607 -1604;0;REWIND /REWIND
3608 -2205
3609 -2425
3610 -2216;0;RETURN /RETURN
3611 -0516
3612 -0406
3613 -1114;0;ENDFIL /ENDFILE
3614 -0516;0;XEND /END
3615 -0411
3616 -1505
3617 -1623
3618 -1117;0;DIMENS /DIMENSION
3619 -0401
3620 -2401;0;DATA /DATA
3621 -0617
3622 -2215
3623 -0124;0;FORMAT /FORMAT
3624 -2722
3625 -1124;0;WRITE /WRITE
3626 -0521
3627 -2511
3628 -2601
3629 -1405
3630 -1603;0;EQUIV /EQUIVALENCE
3631 -0405
3632 -0611
3633 -1605
3634 -0611
3635 -1405;0;DFINFL /DEFINEFILE
3636 -1116
3637 -2405
3638 -0705;0;INTEGE /INTEGER
3639 -1417
3640 -0711
3641 -0301;0;LOGICA /LOGICAL
3642 -0530
3643 -2405
3644 -2216
3645 -0114;0;EXTERN /EXTERNAL
3646 -0201
3647 -0313
3648 -2320
3649 -0103;0;BACKSP /BACKSPACE
3650 -0123
3651 -2311
3652 -0716;0;ASSIGN /ASSIGN
3653 -2001
3654 -2523;0;PAUZE /PAUSE
3655 -2324
3656 -1720;0;STOP /STOP
3657 -0611
3658 -1604;0;FIND /FIND
3659 0 /END OF LIST
3660 $
3661 \f
My complete PDP-8 universe