projects / pdp8.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
A large commit.
[pdp8.git] / sw / os8 / v3d / sources / extensions / dectapes / dectape1 / brts.pa
CommitLineData
81e70d48
PH		 1/OS8 BASIC RUNTIME SYSTEM, V5A
2/
3/
4/
5/
6/
7/
8/
9/
10/
11/
12/
13/COPYRIGHT (C) 1972, 1973, 1974, 1975
14/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
15/
16/
17/
18/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
19/SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
20/SION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE, OR ANT OTHER
21/COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
22/TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
23/AGREES TO THESE LICENSE TERMS. TITLE TO AND OWNERSHIP OF THE
24/SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
25/
26/
27/THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
28/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
29/EQUIPMRNT COROPATION.
30/
31/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
32/SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
33/
34/
35/
36/
37/
38/
39\f/AUGUST 19, 1972
40/
41/R.G. BEAN, 1972
42/SHAWN SPILMAN, 1973
43/ J.K.,1975
44/JR 21-APR-77 ADDED EXTENDED DATE CODE, CLEANED UP LISTING
45/JR 26-APR-77 TIGHTENED UP STRING ROUTINES
46/JR 28-APR-77 ADD SOURCE FIX FOR SEVERAL KNOWN BUGS
47/JR 4-MAY-77 REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY
48/
49/
50 VERSON= 5 /VERSION OF BRTS
51 /VERSION LOCATED AT TAG "VERLOC" AND VERLOC+1
52 /VERLOC = 260+VERSON
53 /VERLOC+1 = 300+SUBVER (01 = A)
54 SUBVER= 01 /SUBVERSION OF BRTS
55 SUBVAF= 01 /SUBVERSION OF BASIC.AF OVERLAY
56 SUBVSF= 01 /SUBVERSION OF BASIC.SF OVERLAY
57 SUBVFF= 01 /SUBVERSION OF BASIC.FF OVERLAY
58 /FIRST WORD OF EACH OVERLAY CONTAINS
59 /60+VERSON IN LEFT HALF AND SUBVERSION OF OVERLAY
60 /IN RIGHT HALF.
61 MDATE= 7666 /CONTAINS OS/8 DATE IN FIELD 1
62 BIPCCL= 7777 /CONTAINS YEAR EXTENSION BITS
63 SCOPWD= 7726 /WORD CONTAINING SCOPE FLAG IN 200 BIT
64 EDBLK= 7604 /CONTAINS BLOCK NUMBER OF EDITOR
65 WIDTH= 120 /WIDTH OF PRINTER
66 COLWID= 16 /WIDTH OF ONE PRINT COLUMN
67 SACLIM= 120 /DEFINE WIDTH OF STRING ACCUMULATOR
68 OVERLAY=3400 /ADDRESS OF START OF 5 PAGE OVERLAY BUFFER
69
70
71
72/ASSEMBLY INSTRUCTIONS
73/ .R PAL8
74/ *BRTS<BRTS.PA/W
75/ .R ABSLDR
76/ *BRTS$ (THEN SAVE AS SHOWN BELOW)
77/
78
79/WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE
80/CORE LAYOUT IS AS FOLLOWS:
81/
82/BRTS IS AT 0-6777
83/OVERLAY BASIC.AF IS AT 3400-4577
84/OVERLAY BASIC.SF IA AT 12000-13177
85/OVERLAY BASIC.FF IS AT 13400-14577
86/
87/TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC,
88/ASSEMBLE THIS SOURCE IN A 12K OR MORE MACHINE,THEN
89/PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS
90/
91/.R ABSLDR
92/*BRTS$
93/.SAVE SYS:BRTS 0-6777
94/
95/.SAVE SYS:BASIC.AF 3400-4577
96/
97/.SAVE SYS:BASIC.SF 12000-13177
98/
99/.SAVE SYS:BASIC.FF 13400-14577
100/
101/THE BASIC RUN-TIME SYSTEM IS CONDITIONALIZED TO TAKE ADVANTAGE
102/OF THE PDP-8/E KE8/E EAE OPTION.
103/NORMALLY,THE SYSTEM IS ASSEMBLED SUCH THAT IT WILL RUN ON ANY
104/PDP-8 OR PDP-12. TO TAKE ADVANTAGE OF THE ADDITIONAL HARDWARE,SET
105/THE SWITCH EAE=1 IF THE SYSTEM INCLUDES A KE8/E EAE.
106/YOU MAY DO THIS BY CONCATENATING TTY: ONTO BRTS.PA AS FOLLOWS
107/.PAL EABRTS<TTY:,SYS:BRTS.PA/W
108/EAE=1
109/^Z
110/^Z
111/. BINARY IS CREATED...
112/NOW EABRTS IS LOADED INSTEAD OF BRTS
113/TO GET A LISTING, USE THE /J SWITCH TO INHIBIT THE FPP CODE YOU
114/ARE NOT USING (EAE ON A NON EAE ASSEMBLY FOR EXAMPLE)
115
116/EAE=0 /USE STANDARD FLOATING POINT PACKAGE
117/EAE=1 /USE EAE FLOATING POINT PACKAGE
118/
119/V4 FIXES
120/.EAE ADD FOR NUMS <.00001 TO 0
121/.FILE INPUT FROM TTY
122/.OUTPUT OF NUMS > 80,000
123/.STRING FETCH WHEN COUNT IS IN ONE FLD &
124/ TEXT IS IN THE NEXT
125\f AC4000= CLA STL RAR
126 AC2000= CLA STL RTR
127 AC0002= CLA STL RTL
128 AC7775= CLL STA RTL
129 AC7776= CLL STA RAL
130 AC3777= CLL STA RAR
131 AC5777= CLL STA RTR
132
133 IFNDEF EAE <EAE=0>
134
135 /PAGE 0 LOCATIONS
136
137 *6
138USECON, 0 /USE CONSTANT GENERATED BY "USE" STATEMENT
139FSTOP1, FSTOPI /POINTER TO RTS EXIT ROUTINE USED
140 /BY ^C HOOKS IN SYSTEM HANDLER.
141 /IF THIS IS MOVED, BLOAD MUST BE ALTERED
142
143 *10
144SACXR, 15 /INDEX REGISTER FOR STRING ROUTINES
145XR1, VCHECK
146XR2, 0
147XR3, 0
148XR4, 4 /INDEX REGISTERS
149XR5, 0
150DATAXR, 0 /POINTER FOR IN-CORE DATA LIST
151SPINNR, 2713 /AT RUNTIME,THIS LOCATION IS SPUN FOR RND SEED
152
153 *20
154
155/COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY
156/A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR
157/TO THE BRTS LOAD
158
159CDFIO, 6211 /* CDF FOR I/O TABLE AND SYMBOL TABLES
160SCSTRT, 0 /* POINTER TO START OF SCALAR SYMBOL TABLE
161ARSTRT, 0 /* POINTER TO START OF ARRAY SYMBOL TABLE-1
162STSTRT, 0 /* POINTER TO START OF STRING SYMBOL TABLE-1
163SASTRT, 0 /* POINTER TO START OF STRING ARRAY TABLE-1
164CDFPS, 0 /* CDF FOR START OF PSEUDO-CODE
165PSSTRT, 0 /* POINTER TO START OF PSEUDO CODE-1
166DLSTOP, 0 /* POINTER TO TOP OF DATA LIST
167DLSTRT, 0 /* POINTER TO BOTTOM OF INCORE DATA LIST-1
168PSFLAG, 0 /* OS/8 SWAPPING FLAGS WORD
169 /BIT 0 SET IF OS/8 SAVED IN N7400 INSTEAD OF N7600 (TD8E)
170 /BIT 1 SET IF ROM TD8E HANDLER NOT NEEDING CDF CHANGES
171 /BIT 11 SET IF 17600 IS IN 17600. BIT 11 TOGGLED BY
172 /PSWAP ROUTINE
173
174\f/SYSTEM REGISTERS
175
176SACLEN, 0 /LENGTH OF STRING IN SAC
177S1, 0 /SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!)
178S2, 0 /SUBSCRIPT 2 (MUST BE PRECEEDED BY S1!)
179DMAP, 0 /MAP OF DRIVER PAGES
180BMAP, 0 /MAP OF FILE BUFFERS
181
182 *37
183/FLOATING POINT PACKAGE LOCATIONS. THE FOLLOWING 21 LOCATIONS ARE USED
184/FOR VARIOUS PURPOSES BY THE FLOATING POINT PACKAGE. THOSE WITH DOUBLE
185/LABELS ARE USED BY BRTS AS TEMPORARIES WHEN NOT CALLING THE PACKAGE.
186/THE SECOND TAG IS THE ONE USED BY THE FLOATING POINT PACKAGE,THE FIRST
187/IS USED BY BRTS.
188
189FF, 0 /SPECIAL MODE FLIP-FLOP
190TEMP1,
191AC0, 0
192AC1, 0
193TEMP3,
194AC2, 0
195TM,
196TEMP4, 6201
197ACX, 0 /FAC-EXPONENT
198ACH, 0 /FAC-HIGH ORDER MANTISSA
199ACL, 0 /FAC-MANTISSA LOW
200TEMP5,
201OPX, 0
202TEMP6,
203OPH, 0
204TEMP7,
205OPL, 0
206DSWIT, 0 /SWITCH USED BY INPUT ROUTINE
207CHAR, 215 /TERMINATOR OF LAST INPUT
208TEMP10, 0 /LOC NEEDED BY FPP
209
210 DECEXP= TEMP10
211
212 /SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE
213
214MODESW, 0 /0 FOR ARTHIMETIC MODE,1 FOR STRING MODE
215INSAV, 0 /CURRENT PSEUDO-INSTRUCTION BEING EXECUTED
216LINEHI, 0 /HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED
217LINELO, 0 /LOW ORDER BITS OF CURRENT LINE NUMBER
218STRMAX, 0 /MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING
219STRCNT, 0 /- # OF CHARACTERS IN CURRENT STRING
220STRPTR, 0 /POINTER TO SIZE WORD OF CURRENT OPERAND STRING
221TEMP2, 0
222
223\f/I/O TABLE POINTER AREA-THIS BLOCK HOLDS POINTERS TO THE I/O TABLE
224/ENTRY FOR THE CURRENT FILE.THE POINTERS ARE CHANGED EVERY TIME AN
225/SFN IS EXECUTED. A TAD I OFF ONE OF THE POINTERS WILL GET THE INFORMATION
226/NOTED IN THE COMMENT FOR THE CURRENT I/O DEVICE
227/THIS BLOCK IS INITIALIZED FOR TTY
228
229 IOTSIZ= 15 /CURRENT SIZE OF IO TABLE
230
231 /THE FORMAT OF THE HEADER WORD IS AS FOLLOWS
232 /BITS USAGE
233 /0-3 OS/8 DEVICE NUMBER
234 /4-5 3 FOR 2 CHARACTER UNPACKING COUNT
235 /6 SET IF BUFFER HAS BEEN MODIFIED AND NEEDS TO BE WRITTEN
236 /7 SET IF NOT FILE STRUCTURED DEVICE
237 /8 SET IF HANDLER IS 2 PAGES LONG
238 /9 SET IF VARIABLE LENGTH (OUTPUT) FILE
239 /10 SET IF EOF
240 /11 SET IF ASCII FILE, CLEAR IF NUMERIC IMAGE FILE
241
242
243ENTNO, 0 /ENTRY NUMBER NOW IN AREA
244IOTHDR, TTYF /HEADER WORD
245IOTBUF, TTYF+1 /BUFFER ADDRESS
246IOTBLK, TTYF+2 /CURRENT BLOCK IN BUFFER
247IOTPTR, TTYF+3 /READ\WRITE POINTER
248IOTHND, TTYF+4 /HANDLER ENTRY POINT
249IOTLOC, TTYF+5 /FILE STARTING BLOCK #
250IOTLEN, TTYF+6 /ACTUAL FILE LENGTH
251IOTMAX, TTYF+7 / DEVICE / (FILE MAXIMUM LENGTH)
252IOTPOS, TTYF+10 / NAME / (POSITION OF PRINT HEAD)
253IOTFIL, TTYF+11 /
254/ TTYF+12 / FILE
255/ TTYF+13 / NAME
256/ TTYF+14 / .EX
257
258IOTDEV= IOTMAX
259\f *200
260
261 /FETCH NEXT PSEUDO WORD
262
263PWFECH, JMP START1 /START ONCE ONLY CODE IN TTY BUFFER
264 ISZ INTPC /BUMP PSEUDO-CODE PROGRAM COUNTER
265 JMP CDFPSU /NO-SKIP;JUST GET NEXT PSEUDO-CODE WORD
266 TAD CDFPSU /SKIP MEANS WE HAVE TO INCREMENT PS-CODE FIELD
267 TAD [10
268 DCA CDFPSU
269CDFPSU, VCHECK /SET DF TO FIELD OF PSEUDO-CODE
270 TAD I INTPC /GET NEXT WORD OF CODE
271 CDF 0 /SET DATA FIELD BACK TO INTERPRETER FIELD
272 JMP I PWFECH /RETURN
273O7770, 7770
274
275SSMODE, IAC /SET INTERPRETER TO STRING MODE
276AMODE, DCA MODESW /SET INTERPRETER TO ARITH MODE
277 /FALL BACK INTO I-LOOP
278
279 /BRTS I-LOOP
280
281ILOOP, CLA CLL /FLUSH
282 DCA FF /PUT FPP IN SI MODE
283 JMS PWFECH /GET NEXT PSEUDO-INSTRUCTION
284 DCA INSAV /SAVE FOR LATER
285 JMS I [XPRINT /CALL TO TTY DRIVER
286 NOP
287 TAD INSAV
288 AND [7400 /STRIP TO OPCODE BITS
289 CLL RTL
290 RTL
291 RAL /OPCODE NOW IN BITS 8-11
292 TAD O7770 /SUBTRACT 10
293 SMA /IS OPCODE <10?
294 JMP SCASE /CALL TO INSTRUCTION COMMON TO SMODE AND AMODE
295 DCA TEMP1 /YES-SAVE THE OFFSET
296 TAD MODESW /WHICH MODE?
297 SZA CLA
298 JMP SMODE /STRING MODE
299 TAD TEMP1 /ARITHMETIC MODE-GET OFFSET
300 TAD JMSI /MAKE JMS TO FP PACKAGE ROUTINE
301 DCA .+2 /PUT IN LINE
302 JMS ARGPRE /SET UP ARGUMENT FROM SYMBOL TABLE
303ILOOPF, . /JMS TO THE FLOATING POINT PACKAGE ROUTINE
304 NOP /FPP SOMETIMES RETURNS TO CALL+2
305 JMP ILOOP /DONE
306
307SCASE, TAD JMPI /JUST DISPATCH TO ROUTINE CALLED FOR
308 DCA .+1
309 . /JUMP TO APPROPRIATE ROUTINE
310
311JMSI, JMS I SEP1 /JMS USED FOR CALLS TO FPP BY AMODE INST
312JMPI, JMP I SEP1 /JMP USED TO CALL ROUTINES COMMON TO AMODE AND SMODE
313\f /JUMP TABLE FOR AMODE INSTRUCTIONS
314
315 FFADD /FAC_C(A)+FAC OPCODE 0
316 FFSUB /FAC_FAC-C(A) OPCODE 1
317 FFMPY /FAC_FAC*C(A) OPCODE 2
318 FFDIV /FAC_FAC/C(A) OPCODE 3
319 FFGET /FAC_C(A) OPCODE 4
320 FFPUT /C(A)_FAC OPCODE 5
321 FFSUB1 /FAC_C(A)-FAC OPCODE 6
322 FFDIV1 /FAC_C(A)/FAC OPCODE 7
323/ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE
324SEP1, LS1I /S1_C(A) OPCODE 10
325 LS2I /S2_C(A) OPCODE 11
326 FJOCI /IF TRUE,PC_C(PC,PC+1) OPCODE 12
327 JEOFI /IF EOF,PC_C(PC,PC+1) OPCODE 13
328 LINEI /LINE NUMBER OPCODE 14
329 ARRAYI /ARRAY INST OPCODE 15
330 ILOOP /NOP OPCODE 16
331 OPERI /OPERATE INST OPCODE 17
332
333
334SMODE, TAD TEMP1 /INST OFFSET
335 TAD JMSSI /BUILD JMP OFF STRING TABLE
336 DCA SDIS /PUT IN LINE
337 CLL /STRING SCALAR TABLE
338 JMS I STFINL /SET UP ARGUMENT ADDRESS
339SDIS, . /CALL STRING ROUTINE REQUESTED
340
341
342/JUMP TABLE FOR SMODE INSTRUCTIONS
343/ A "/*" IN THE COMMENT MEANS THAT THAT OPCODE IS NOT USED,SO WE
344/USE THE SLOT FOR REGULAR STORAGE
345
346 SCON1 /SAC_SAC&C(A$)
347 SCOMP /IF SAC .NE. C(A$),PC_PC+2
348 SREAD /C(A$)_DEVICE
349INTPC, . /* INTERPRETER PC
350 SLOAD /SAC_C(A$)
351 SSTORE /C(A$)_SAC
352STFINL, STFIND /* LINK TO STRING FINDING ROUTINE
353JMSSI, JMP I .+1 /* DISPATCH JUMP FOR SMODE INSTRUCTIONS
354\f/ARGPRE-ROUTINE TO TRANSLATE OPERAND FIELD INTO 12 BIT POINTER
355/INTO SCALAR TABLE FOR USE IN FPP CALLS.
356
357ARGPRE, 0
358 TAD INSAV /GET INSTRUCTION
359 AND [377 /STRIP TO OPERAND FIELD
360 DCA TEMP1 /SAVE
361 TAD TEMP1
362 CLL RAL /*2
363 TAD TEMP1 /PTR*3
364 TAD SCSTRT /MAKE 12 BIT ADDR
365SCALDF, 1000 /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER)
366 JMP I ARGPRE /RETURN
367
368/ROUTINE TO ZERO FAC
369
370FACCLR, -4
371L7600, 7600 /CLA
372 DCA ACX /ZERO EXPONENT
373 DCA ACL /ZERO LOW MANTISSA
374 DCA ACH /ZERO HIGH MANTISSA
375 JMP I FACCLR
376
377 /STRING ACCUMULATOR USED BY STRING OPCODES AND FUNCTIONS
378 /CONTAINS ONE 6BIT CHAR PER WORD
379
380START1,
381SAC, OSR
382 SZA CLA
383 NOP /A HLT PLACED HERE WILL ALLOW YOU TO STOP
384 /MACHINE BEFORE RUNTIME SYSTEM STARTS BY
385 /SETTING SWITCH REGISTER
386 TLS /SET TTY FLAG
387 ISZ SPINNR /SPIN RANDOM NUMBER SEED
388 NOP /WHILE WAITING FOR INITIALIZING TLS
389 TSF /FLAG UP YET?
390 JMP .-3 /NO
391 TAD CDFIO
392 DCA I PS1L /SET UP CDFS IN PSWAP
393 TAD CDFIO
394 DCA I PS2L
395 JMS I PFUDSC /SWAP 17600 IN IF NOT ALREADY IN AND SAVE SCOPE FLAG
396 JMS I CDFPSU
397 TAD SCALDF /SET PROG NOT RESTARTABLE BIT
398 DCA I L7746 /TELL USR TO SAVE 1000-1777
399 TAD PINFO /POINTER TO INFO TABLE IN 17600
400 DCA XR1
401 TAD POVTAB /POINTER TO BLOCK TABLE IN OVERLAY DRIVER
402 DCA XR2
403 TAD FACCLR /WE HAVE TO GET 4 BLOCK NUMBERS
404 DCA TEMP1
405OVML, CDF 10
406 TAD I XR1 /GET BLOCK NUMBER FOR THIS OVERLAY FROM INFO AREA
407 CDF
408 DCA I XR2 /PUT IN TABLE IN OVERLAY DRIVER
409 ISZ TEMP1 /DONE?
410 JMP OVML /NO
411 JMS I [PSWAP /SWAP 17600 BACK TO HIGH CORE NOW
412 JMP I .+1
413 START3 /CONTINUE THE INITIALIZING CODE IN INTERMEDIATE BUFFER
414L7746, 7746
415PINFO, 7607
416POVTAB, ARITHA-1
417PS1L, P1CDF
418PS2L, P1CDF1
419PFUDSC, FUDSC
420
421 PAGE
422
423FUDSC, 0
424 TAD PSFLAG /TEST WHERE 17600 IS LOCATED
425 SMA CLA
426 TAD [200 /IF NOT TD8E USE 7600
427 TAD [7400 /IF TD8E USE 7400
428 DCA I PHICORE /STORE FOR SWAPPER
429 CLA IAC
430 AND PSFLAG
431 SNA CLA /SKP IF PAGE 17600 IS ALREADY IN
432 JMS I [PSWAP /ELSE BRING IT IN
433 CDF 10
434 TAD I PSCOPW
435 CDF
436 AND [200 /GET SCOPE BIT FROM RES MONITOR
437 DCA I PSCOPF
438 TAD I PHEIGHT
439 DCA I PHCTR /NOW INITIALIZE THE SCREEN HEIGHT COUNTER
440 JMP I FUDSC /RETURN
441PHEIGHT,HEIGHT
442PHCTR, HCTR
443PSCOPW, SCOPWD
444PSCOPF, SCOPFG
445PHICOR, HICORE
446\f *SAC+SACLIM+1 /ORIGIN PAST SAC+ONE GUARD CHAR
447
448 /JUMP ON CONDITION
449
450FJOCI, TAD INSAV /GET JUMP INSTRUCTION
451 AND [17 /MASK OFF JUMP CONDITION
452 SNA /IS IT GOSUB?
453 JMP I (GOSUB /YES-PUSH PC ON STACK THEN JUMP
454 TAD FSTOPI /BASE TAD FOR BUILD OF TAD INSTRUCTION
455 DCA .+1 /PUT IN LINE
456 . /GET PROPER SKIP
457 DCA .+2 /PUT IN LINE
458 TAD ACH /GET HIGH ORDER FAC
459 . /SKIP INSTRUCTION
460 JMP SUCJMP /CONDITION TRUE-JUMP
461JFAIL, JMS I [PWFECH /CONDITION FALSE-DON'T JUMP,BUT BUMP PC
462 JMP I [ILOOP /DONE
463
464/JUMP ON END OF FILE
465
466JEOFI, JMS I [IDLE /SEE IF FILE OPEN
467 TAD I IOTHDR /1ST WORD OF I/O TABLE ENTRY
468 CLL RTR /GET EOF BIT IN LINK
469 SNL CLA /EOF?
470 JMP JFAIL /NO-DON'T JUMP
471 /YES, FALL INTO JUMP ROUTINE
472
473SUCJMP, JMS I [PWFECH /GET WORD FOLLOWING JUMP INS.
474 DCA I INTPCL /STORE AS NEW PC
475 TAD INSAV /GET JUMP INSTRUCTION
476 AND [340 /MASK OFF DESTINATION FIELD
477 CLL RTR /SLIDE OVER
478 TAD CDFINL /MAKE A CDF INSTRUCTION
479 DCA I [CDFPSU /AND SET NEW PC INSTRUCTION FIELD
480 JMP I [ILOOP /NEXT INSTUCTION
481
482K7554, 7554 /MUST PRECEDE SKIP TABLE
483
484/SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS
485
486K7600, 7600 /UNCONDITIONAL (CLA)
487 SMA CLA /JPA
488 SZA CLA /JNA
489 SMA SZA CLA /JPA JNA
490 SPA CLA /JMA
491 SNA CLA /JZA
492 SPA SNA CLA /JMA JZA
493 JMP I JFORL /FORLOOP JUMP ROUTINE
494
495JFORL, JFOR
496INTPCL, INTPC
497 0000;0 /MARK BEGINNING OF GOSUB STACK
498GSTCK, 6000;0
499 6000;0
500 6000;0
501 6000;0
502 6000;0
503 6000;0
504 6000;0
505 6000;0
506 6000;0
507 0 /MARK THE END OF THE GOSUB STACK
508\f/CALL TO DEVICE DRIVER FOR FILE I/O. ASSUMES ARGS HAVE BEEN SET UP
509
510DRCALL, 0
511 DCA DRARG1 /FUNCTION WORD INTO DRIVER CALL
512CDFINL, CDF /DF TO CURRENT FIELD
513 TAD I IOTBUF /GET BUFFER ADDRE FROM I/O TABLE ENTRY
514 DCA DRARG2 /PUT IN DRIVER CALL
515 TAD I IOTBLK /GET BLOCK NUMBER FROM I/O TABLE
516 DCA DRARG3 /PUT IN DRIVER CALL
517 TAD I IOTHND /GET DRIVER ENTRY
518 DCA DRIVER /SAVE
519 JMS I DRIVER /CALL DRIVER
520DRARG1, 0 /FUNCTION CONTROL WORD
521DRARG2, 0 /BUFFER ADDRESS
522DRARG3, 0 /BLOCK #
523 SMA CLA /DEVICE ERROR-IS IT FATAL?
524 JMP I DRCALL /ALLS WELL
525DE, JMS I [ERROR /FATAL
526DRIVER, 0
527
528/CALL TO INTERPRETER EXITING ROUTINE
529
530FSTOPN, JMS I [XPRINT /ON NORMAL EXITS,WE MUST EMPTY RING BUFFER
531 JMP .-1 /FIRST
532FSTOPI, TAD K7554
533 DCA INSAV /FAKE A CALL TO BASIC.FF FUNCTION 6
534 JMP I .+1 /CALL OVERLAY
535 FUNC5I
536
537/USE FUNCTION-TAKES WORD FOLLOWING CALL AND STUFFS IT IN USECON FOR
538/USE A BUFFER POINTER FOR USER SUBROUTINE
539
540USE, JMS I [PWFECH /GET NEXT WORD FROM PSEUDO-CODE STREAM
541 DCA USECON /STORE IN PAGE 0 SLOT
542 JMP I [ILOOP /RETURN
543
544 PAGE
545\f/ARRAY INSTRUCTIONS
546/ARRAY INSTRUCTIONS WORK BY FINDING THE ADDRESS OF THE ARGUMENT FROM THE ARRAY SYMBOL
547/TABLE,THEN CALLING THE APPROPRIATE FLOATING POIN PACKAGE ROUTINE.
548
549ARRAYI, TAD MODESW /WHICH MODE?
550 SZA CLA
551 JMP SARRAY /SMODE
552 TAD INSAV /GET ARRAY INSTRUCTION
553 AND K0037 /MASK OFF ARRAY OPERAND
554 CLL RTL /MULTIPLY BY 4 (ENTRY LENGTH)
555 TAD ARSTRT /MAKE POINTER INTO ARRAY TABLE
556 DCA XR1 /POINTS TO ARRAY FOR THIS OPERATION
557ATABDF, . /CHANGE DF TO ARRAY TABLE FIELD (SET BY START)
558 TAD I XR1 /GET POINTER TO FIRST ARRAY ELEMENT
559 DCA TEMP2 /SAVE FOR LATER
560 TAD I XR1 /GET DF FOR VARIABLE
561 DCA ADFC /PUT IN LINE AT END OF ROUTINE
562 TAD I XR1 /GET ARRAY DIMENSION 1
563 DCA TEMP3 /SAVE
564 TAD S1 /GET SUBSCRIPT 1
565 CLL CMA /SET UP 12 BIT COMPARE
566 TAD TEMP3 /DIMENSION 1 +1
567 SNL CLA /S1 TOO BIG?
568SU, JMS I [ERROR /YES-SUBSCRIPT OUT OF BOUNDS ERROR
569 DCA TEMP6 /CLEAR TEMPORARY
570 TAD I XR1 /GET DIMENSION 2
571 SNA /IS SECOND DIMENSION 0?(ARRAY UNIDIMENSIONAL)
572 JMP ADCALC /YES-DON'T CHECK S2 FOR OUT OF BOUNDS
573 DCA ARJMP /SAVE DIM2+1
574 TAD S2 /GET SUBSCRIPT 2
575 CLL CMA /SAVE 12 BIT COMPARE
576 TAD ARJMP
577 SNL CLA /S2 BIGGER THAN DIM2?
578 JMP SU /YES
579 TAD S2 /MULTIPLY DIM1+1 BY S2
580 JMS I [MPY /12 BY 12 MULTIPLY ROUTINE
581ADCALC, CLL
582 TAD S1 /LORD OF S1+(DIM1+1)*S2
583 DCA TEMP5 /SAVE
584 RAL /CARRY TO BIT 11
585 TAD TEMP6 /HORD OF S1+(DIM1+1)*S2
586 DCA TEMP6 /SAVE
587 TAD TEMP5 /LORD OF S1+(DIM1+1)*S2
588 CLL RAL /*2
589 DCA TEMP7 /LORD OF [S1+(DIM1+1)*S2]*2
590 TAD TEMP6 /HORD OF S1+(DIM1+1)*S2
591 RAL /*2
592 DCA TEMP3 /HORD OF [S1+(DIM1+1)*S2]*2
593 CLL
594 TAD TEMP5 /LORD OF S1+(DIM1+1)
595 TAD TEMP7 /LORD OF [S1+(DIM1+1)*S2]
596 DCA TEMP7 /LORD OF 3*[S1+(DIM1+1)*S2]
597 RAL /CARRY TO BIT 11
598 TAD TEMP6 /HORD OF [S1+(DIM1+1)*S2)*2
599 TAD TEMP3 /HORD OF S1+(DIM1+1)*S2
600 DCA TEMP6 /HORD OF 3*[S1+(DIM1+1)*S2]
601 CLL
602 TAD TEMP7 /INDEX TO ELEMENT
603 TAD TEMP2 /AC POINTS TO CORRECT ARRAY ELEMENT
604 DCA XR1 /SAVE POINTER
605 RAL /CARRY TO BIT 11
606 TAD TEMP6 /COMBINE TO MAKE TOTAL # OF FIELD OVERLAPS
607 CLL RTL
608 RAL /SLIDE OVERLAPS TO FIELD BITS (6-8)
609 TAD ADFC /ADD ANY CHANGE IN DATA FIELD TO CDF
610 DCA ADFC /PUT ABSOLUTE CDF IN LINE
611 TAD INSAV /GET ARRAY INSTRUCTION AGAIN
612 AND [340 /MASK OFF ARRAY OPCODE
613 CLL RTR
614 RTR
615 RAR /SLIDE TO BITS 9-11
616 TAD JMPI2 /AND USE AS INDEX INTO JUMP TABLE
617 DCA ARJMP /PUT JUMP IN LINE OF CODE
618 IAC
619 DCA FF /PUT FPP IN "SPECIAL MODE"
620ADFC, . /CHANGE DF TO DF OF ARRAY ELEMNT
621 TAD XR1 /AC POINTS TO ARRAY ELEMENT
622ARJMP, . /PERFORM THE REQUIRED OPERATION
623 NOP /FPP SOMETIMES RETURNS TO CALL+2
624 JMP I [ILOOP /DONE
625
626/ARRAY JUMP TABLE
627
628AJT, FFSUB1 /FAC=A(S1,S2)-FAC OPCODE 0
629 FFADD /FAC=FAC+A(S1,S2) OPCODE 1
630 FFSUB /FAC=FAC-A(S1,S2) OPCODE 2
631 FFMPY /FAC=FAC*A(S1,S2) OPCODE 3
632 FFDIV /FAC=FAC/A(S1,S2) OPCODE 4
633 FFGET /FAC=C(A(S1,S2) OPCODE 5
634FPUTLL, FFPUT /C(A(S1,S2)=FAC OPCODE 6
635 FFDIV1 /FAC=A(S1,S2)/FAC OPCODE 7
636\f /STRING ARRAY DISPATCH
637
638SARRAY, TAD INSAV /GET INSTRUCTION
639 AND [340 /ISOLATE ARRAY OPCODE
640 CLL RTR
641 RTR /AND SLIDE IT OVER FOR AN OFFSET
642 RAR
643 TAD JMPISA /BUILD A JUMP TO STRING INSTRCUTION
644 DCA SAD /AND PUT IN LINE
645 STL /TELL SFIND TO USE ARRAY TABLE
646 JMS I STFILK /SET UP ARGUMENT ADDRESS
647SAD, . /EXECUTE INSTRCUTION
648
649/STRING ARRAY JUMP TABLE
650/USED WHEN ARRAYI CALLED IN SMODE
651/ A "/*" IN THE COMMENT MEANS THAT OPCODE IS UNDEFINED AND THE SLOT
652/IN THE TABLES IS USED FOR NORMAL STORAGE
653
654JMPISA, JMP I .+1 /DISPATCH JUMP FOR STRING ARRAY INSTRUCTIONS
655
656 SCON1 /SAC_SAC&C(A$(S1))
657 SCOMP /SKIP IF SAC=C(A$(S1))
658 SREAD /A$(S1)_DEVICE
659K0037, 37 /*
660STFILK, STFIND /* LINK TO STRING FINDING ROUTINE
661 SLOAD /SAC_C(A$(S1))
662 SSTORE /C(A$(S1))_SAC
663JMPI2, JMS I AJT /* DISPATCH JUMP FOR ARRAY INST
664\f/ROUTINE TO PUT ONE WORD IN FILE BUFFER IN FIELD 1
665
666BCPUT, 0
667 DCA TEMP6 /SAVE AC
668 JMS I [IDLE /CHECK IF FILE OPEN
669 TAD I IOTPTR /GET READ/WRITE POINTER
670 DCA TEMP7 /SAVE
671 TAD ENTNO /GET FILE #
672 SZA CLA /IF TTY,BUFFER FIELD IS 0
673 CDF 10
674 TAD TEMP6 /GET WORD TO STORE AGAIN
675 DCA I TEMP7 /STORE IT IN BUFFER
676CDF0, CDF
677 TAD I IOTHDR /HEADER WORD
678 AND (7737 /TURN OFF BLOCK WRITTEN BIT
679 TAD (40 /TURN IT ON AGAIN
680 DCA I IOTHDR
681 JMP I BCPUT /RETURN
682
683 PAGE
684\f/TELETYPE DRIVING ROUTINE
685/2 ENTRY POINTS-XPUTCH PUTS A CHARCTER IN THE RING BUFFER
686/ XPRINT TYPES A CHARACTER IF POSSIBLE
687/ AND RETURNS TO CALL+1 IF THERE
688/ ARE MORE CHARCTERS IN THE BUFFER,CALL+2
689/ IF THE BUFFER IS EMPTY
690/THE IDEA IS THE PLACE CALLS TO XPRINT AT VARIOUS POINTS IN THE INTER-
691/PRETER AND THUS KEEP THE TTY BUSY WITHOUT WASTING THE TIME WAITING FOR
692/THE TTY FLAG. THE SUCCESS OF THIS SCHEME DEPENDS HEAVILY ON THE NUMBER
693/AND PLACEMENT OF THE CALLS TO XPRINT.
694
695XPUTCH, 0
696 DCA CHRSAV /SAVE THE CHARACTER
697XPUT1, ISZ SPINNR /SPIN RANDOM # SEED
698 JMS XPRINT /START A CHAR IF POSSIBLE
699 NOP
700 TAD BCNT /GET THE NUMBER OF AVAILABLE SLOTS
701 SNA CLA /ARE THERE ANY?
702 JMP XPUT1 /NO-TRY TO RPINT 1 AND FREE UP A SPACE
703PUTCHR, TAD CHRSAV /GET CHARACTER AGAIN
704 DCA I BUFIN /PUT CHARACTER IN RING BUFFER
705 ISZ BUFIN /BUMP BUFEER POINTER OF INPUT
706 CLA CLL CMA /-1 IN AC
707 TAD BCNT /DECREMENT AVAILABLE SLOT COUNT
708 DCA BCNT
709 TAD BUFIN /GET BUFFER INPUT POINTER
710 TAD MBEND /SUBTRACT ADDR OF END OF BUFFER
711 SPA SNA CLA /PAST EDN OF BUFFER?
712 JMP I XPUTCH /NO-RETURN
713 TAD BSTRTA /YES-RESET INPUT POINTER TO BEGINNING OF BUFFER
714 DCA BUFIN
715 JMP I XPUTCH /RETURN
716
717BUFIN, BSTRT /POINTER TO NEXT SLOT FOR BUFFER INPUT
718BUFOUT, BSTRT /POINTER TO NEXT CHARACTER TO BE PRINTED
719BSTRTA, BSTRT /ADDR OF START OF TTY BUFFER
720BCNT, 30 /# OF AVAILABLE SLOTS IN BUFFER (40 INITIALLY)
721CHRSAV=TEMP1
722MBEND, -BEND /-ADDR OF END OF RING BUFFER
723MCTRLC, -3
724M50, -30
725MXON, -21+3
726MXOFF, -23+21
727XFLAG, 0
728
729
730XPRINT, 0
731 KSF /IS KEYBOARD FLAG UP?
732 JMP NOCC /NO-NO CHANCE FOR A CTRL/C
733 KRB /YES-GET THE CHAR IN KEYBOARD BUFFER
734 AND [177 /GET RID OF PARAITY
735 TAD MCTRLC /IS IT CTRL/C
736 SNA
737 JMP I FSTOP1 /YES-ABORT TO EDITOR
738 TAD MXON
739 SZA
740 JMP .+3
741 DCA XFLAG
742 JMP NOCC+3
743 TAD MXOFF
744 SZA CLA
745 JMP NOCC
746 ISZ XFLAG
747 JMP XPRINT+1
748NOCC, TAD XFLAG
749 SZA CLA
750 JMP XPRINT+1
751 TAD BCNT /# OF AVAILABLE SLOTS IN BUFFER
752 TAD M50 /IS BUFFER EMPTY?
753 SNA CLA
754 JMP RECP2 /YES-RETURN TO CALL+2
755 TSF /NO-TTY FLAG UP YET?
756 JMP I XPRINT /NO-GO ABOUT YOUR BUSINESS
757 TAD I BUFOUT /GET NEXT CHARACTER
758/*****************************************************************:
759/N.B. BECAUSE OF THE ABOVE INSTRUCTION,THE DF MUST BE SET TO THE
760/INTERPRETER FIELD WHENEVER XPRINT IS CALLED. WATCH YOUR HOOK PLACEMENT!
761/****************************************************************:
762 JMS I (PCH /TYPE THE CHAR
763 ISZ BUFOUT /BUMP BUFFER OUTPUT POINTER
764 TAD BUFOUT /GET OUTPUT POINTER
765 TAD MBEND /SUBTRACT END OF BUFFER
766 SPA SNA CLA /IS OUTPUT POINTER PAST END?
767 JMP BOUTRS /NO-FREE UP A SPOT
768 TAD BSTRTA /YES-RESET POINTER TO BEGINNING
769 DCA BUFOUT
770BOUTRS, ISZ BCNT /INCREMENT # OF FREE SLOTS (WE JUST PRINTED ONE)
771 JMP I XPRINT /RETURN
772
773RECP2, ISZ XPRINT /BUMP RETURN
774 JMP I XPRINT /RETURN TO CALL+2 FOR EMPTY BUFFER
775
776
777/TELETYPE RING BUFFER
778
779BSTRT, "B /START OF BUFFER
780 "R
781 "T
782 "S
783 "
784 "V
785VERLOC, 260+VERSON
786 300+SUBVER
787 0215
788 0212
789VEREND, 0212
790VCHECK, 0
791 CDF 10
792 TAD I N7644
793 CDF 0
794 AND XR4
795 SNA CLA
796 JMP I VCHECK
797 TAD XR1
798 DCA BUFIN
799 TAD SACXR
800 DCA BCNT
801 JMP I VCHECK
802BEND,
803N7644, 7644
804
805\f /LINE NUMBERS
806
807LINEI, TAD INSAV /GET INSTRUCTION
808 DCA LINEHI /SAVE
809 JMS I [PWFECH /GET WORD FOLLOWING LINE # INST
810 DCA LINELO /SAVE AS LOW ORDER LINE #
811TRHOOK, JMP I [ILOOP /RETURN TO I-LOOP
812 TAD KC240 /IF TRACE IS ON,FAKE CALL
813 DCA INSAV /TO FUNC2,#12
814 JMP I .+1
815 FUNC2I /DISPATCH TO TRACE FUNCTION
816
817/INTERMEDIATE TTY BUFFER
818/USED TO BUFFER OUTPUT FROM FPP BEFORE WE PUT IT
819/IN BASIC FORMAT FOR TRANSPORTATION TO THE TTY RING
820/BUFFER
821
822KC240, 240 /STOPPER TO MARK BEGINNING OF BUFFER
823INTERB,
824START3, TAD CDFPS /CDF FOR PSEUDO-CODE
825 DCA I [CDFPSU /PUT IN-LINE TO ILOOP
826 TAD PSSTRT /START OF PSEUDO-CODE
827 DCA I INTPCK /PUT INTO PC
828 JMS I [FACCLR /ZERO FAC
829 TAD CDFIO /CDF FOR SYMBOL TABLE FIELD
830 DCA I STDFL /PUT IN LINE FOR STRING FUNCTIONS
831FPPTM5, TAD CDFIO /CDF FOR SYMBOL TABLES
832 DCA I ATABDL /PUT IN LINE FOR ARRAY CALCULATIONS
833 TAD CDFIO /CDF FOR SCALAR TABLE
834FPPTM4, DCA I SCALDL /PUT IN LINE FOR ARGPRE
835 TAD CDFIO
836 DCA I DLCDFL /DATA FIELD FOR DATA LIST
837FPPTM3, TAD DLSTRT
838 DCA DATAXR /DO A RESTORE IN INCORE DATA LIST
839 JMP I .+1 /CONTINUE INITAILIZATION CODE IN TTY INPUT BUFFER
840FPPTM2, START4
841ATABDL, ATABDF
842STDFL, STDF
843FPPTM1, /FLOATING POINT TEMPORARY
844INTPCK, INTPC
845DLCDFL, DLCDF
846SCALDL, SCALDF
847
848 PAGE
849\f /VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE)
850
851HEIGHT, 0 /NEGATIVE SCREEN HEIGHT
852DELAY, 0 /NEGATIVE DELAY VALUE
853 IFNZRO HEIGHT-1200 <__FIX SET COMMAND__>
854HCTR, 0 /HEIGHT COUNTER INITIALIZED BY SET
855DCTR, 0 /DELAY COUNTER INITIALIZED BY SET
856
857 /LOW LEVEL ROUTINE TO TYPE A CHAR
858
859PCH, 0
860 TSF /WAIT FOR PREV CHAR
861 JMP .-1
862 TLS /TYPE THE CURRENT ONE
863 AND [177 /MASK TO 7BIT
864 TAD (-15 /TEST IF LINE FEED WILL BE SENT NEXT
865 SZA CLA
866 JMP I PCH /RETURN IF NOT
867 ISZ HCTR /TEST SCREEN HEIGHT IF LF
868 JMP I PCH /RETURN IF NOT AT BOTTOM OF SCREEN
869 TAD HEIGHT
870 DCA HCTR /RESET HEIGHT COUNTER NOW
871 TAD DELAY
872 SNA /TEST FOR ZERO DELAY
873 JMP I PCH /RETURN IF SO
874 DCA DCTR /ELSE SET DELAY COUNTER
875DLOOP, ISZ PSWAP /NOW EXEC INNER LOOP 4096 TIMES (USUALLY)
876 JMP .-1
877 KSF /TEST IF KEY STRUCK
878 SKP
879 JMP I PCH /RETURN AT ONCE IF YES
880 ISZ DCTR /TEST DELAY TIMER
881 JMP DLOOP /REITERATE
882 JMP I PCH /NOW ALLOW PRINTING TO CONTINUE
883
884 /OPERATE CLASS INSTRUCTIONS
885
886OPERI, TAD INSAV /GET OPERATE INSTRUCTION
887 AND [17 /MASK OFF OPERATE OPCODE
888 TAD JMPI3 /BUILD JUMP OFF OPERATE JUMPTABLE
889 DCA .+1 /STORE THE JUMP IN LINE
890 . /DISPATCH TO PROPER OPERATE ROUTINE
891
892JMPI3, JMP I .+1 /JUMP TO OPERATE ROUTINE CALLED FOR
893
894 /OPERATE JUMP TABLE
895
896 FUNC3I /CALL RESIDENT FUNCTION OPCODE 0
897 SPFUNC /SPECIAL FUNCTIONS OPCODE 1
898 SFN /SET FILE NUMBER OPCODE 2
899 FNEGI /NEGATE FAC OPCODE 3
900 RETRNI /GOSUB RETURN OPCODE 4
901 RESTOR /RESTORE DEVICE OPCODE 5
902 LSUB1I /LOAD S1 FROM FAC OPCODE 6
903 LSUB2I /LOAD S2 FROM FAC OPCODE 7
904MSPACE, 20 /THIS OPCODE NOT DEFINED,SO WE PUT A CONST HERE
905 READI /READ DEVICE OPCODE 11
906 WRITEI /WRITE DEVICE OPCODE 12
907 SWRITE /STRING WRITE OPCODE 13
908 FUNC5I /CALL FILE FUNCTION OPCODE 14
909 FUNC4I /CALL USER FUNCTION OPCODE 15
910 FUNC1I /CALL FUNCTIONS 1 OPCODE 16
911 FUNC2I /CALL FUNCTIONS 2 OPCODE 17
912\f/ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE)
913/WHERE N IS THE HIGH CORE FIELD
914
915PSWAP, 0
916 TAD KK7600 /POINTER TO 17600 AND COUNTER
917 DCA TEMP1
918 TAD PSFLAG /GET SWAPPING FLAGS
919 RAR
920 CML RAL /TOGGLE THE INPLACE BIT
921 DCA PSFLAG /STORE IT BACK
922 TAD HICORE /PICK UP ADDR OF HIGH CORE
923 DCA TEMP2 /POINTER TO HIGH CORE
924P1CDF, HLT /DF TO HI CORE
925 TAD I TEMP2 /GET WORD FROM HI CORE
926 DCA TEMP4 /SAVE IT
927P2CDF, CDF 10
928 TAD I TEMP1 /GET WORD FROM 17600
929P1CDF1, HLT /DF TO HI CORE AGAIN
930 DCA I TEMP2 /PUT 17600 WORD IN HI CORE
931P2CDF1, CDF 10
932 TAD TEMP4 /GET SAVED HI CORE WORD
933 DCA I TEMP1 /AND PUT IN 17600
934 ISZ TEMP2 /BUMP HI CORE POINTER
935KK7600, 7600 /CLA
936 ISZ TEMP1 /BUMP 17600 POINTER AND CHECK FOR DONE
937 JMP P1CDF /NO DONE-MOVE NEXT WORD
938 CDF
939 JMP I PSWAP /DONE-RETURN
940HICORE, 0 /POINTS TO LOCATION OF 17600 SAVE AREA
941
942 IFNZRO EAE <
943
944 /TEMPORARY INCLUSION FOR FFOUT
945
946 /ADD OP TO FAC
947
948OADD, 0
949 CLL
950 TAD AC2
951 TAD AC1
952 DCA AC1 /ADD GUARD BITS
953 RAL
954 TAD OPL
955 TAD ACL
956 DCA ACL /ADD LOW ORDER BITS
957 RAL
958 TAD OPH
959 TAD ACH
960 DCA ACH /ADD HIGH ORDER BITS
961 JMP I OADD
962
963 /SHIFT FAC LEFT 1 BIT
964
965AL1, 0
966 TAD AC1
967 CLL RAL
968 DCA AC1
969 TAD ACL
970 RAL
971 DCA ACL
972 TAD ACH
973 RAL
974 DCA ACH
975 JMP I AL1
976 >
977 PAGE
978\f /LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY
979
980LSUB2I, ISZ DCASUB
981 JMP LSUB1I
982LS2I, ISZ DCASUB
983LS1I, JMS I [FACSAV /PRESERVE FAC
984 JMS I ARGPRL /GET ARG POINTER INTO AC
985 JMS I [FFGET /LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN)
986LSUB1I, JMS I [FACSAV /SAVE THE FAC
987 JMS I [UNSFIX /GET INT(FAC)
988DCASUB, DCA S1 /SET RESULT AS SUBSCRIPT 1
989 JMS I [FACRES /RESTORE FAC
990 TAD DCAS1
991 DCA DCASUB /FUDGE INSTR BACK
992 JMP I [ILOOP /NEXT INSTRCUTION
993DCAS1, DCA S1
994ARGPRL, ARGPRE
995
996/JMP DISPATCH FOR FUNC1 CALLS
997
998JMSI4, JMS I .+1 /CALL FOR CANNED FUNCTION SET 1
999
1000/JUMP TABLE FOR FUNCTION CALL 1
1001
1002 ATAN /FUNCTION BITS= 0
1003 COS / 1
1004 EXPON1 / 2
1005 EXPON / 3
1006 INT / 4
1007 LOG / 5
1008 SGN / 6
1009 SIN / 7
1010 RND / 10
1011 FROOT / 11
1012
1013/JUMP FOR FUNC2 DISPATCH
1014
1015JMSI5, JMP I .+1 /JMP OFF THE SET 2 TABLE
1016
1017/JUMP TABLE FOR FUNCTION SET 2
1018
1019 ASC /FUNCTION BITS= 0
1020 CHR / 1
1021 DATE / 2
1022 LEN / 3
1023 POS / 4
1024 SEG / 5
1025 STR / 6
1026 VAL / 7
1027 ERRORR / 10
1028/ERRORR MUST BE FUNCTION #10,ELSE "ERROPC" MUST CHANGE
1029 TRACE / 11
1030 TPRINT / 12
1031/TPRINT MUST BE #12 OR TRHOOK+1 MUST CHANGE
1032
1033/DISPATCH FOR FUNC5 CALLS
1034
1035JMPFIL, JMP I .+1 /CALL FORR FILE MANIPULATING FUNCTIONS
1036
1037/JUMP TABLE FOR FILE FUNCTIONS
1038
1039 CHAIN /FUNCTION BITS= 0
1040 CLOSE / 1
1041 OPENAF / 2
1042 OPENAV / 3
1043 OPENNF / 4
1044 OPENNV / 5
1045 FSTOP /INT. EXIT 6
1046
1047/ERROR CALL FOR USER FUNCTIONS-USER FUNCTION SHOULD "JMS I (IA"
1048
1049IA, JMS I [ERROR
1050\f /FUNCTION OVERLAY DRIVER
1051
1052FUNC4I, JMS I [XPRINT /PURGE TTY RING BUFFER
1053 JMP .-1 /BEFORE CALLING USER FUNCTION
1054 IAC /LOOK FOR OVERLAY FLAG=3
1055FUNC5I, IAC /LOOK FOR OVERLAY FLAG=2
1056FUNC2I, IAC /LOOK FOR OVERLAY FLAG=1
1057FUNC1I, DCA TEMP1 /LOOK FOR OVERLAY FLAG=0
1058 CDF /DF TO THIS FIELD
1059 TAD TEMP1 /GET OVERLAY # AGAIN
1060 CIA /NEGATE
1061 TAD OVRLAY /COMPARE AGAINST OVERLAY FLAG
1062 SNA CLA /IS THE ONE WE WANT ALREADY RESIDENT?
1063 JMP OVDNE /YES-JUST JUMP TO FUNCTION
1064 TAD TEMP1 /NO-GET NUMBER OF OVERALY DESIRED
1065 TAD OATADI /USE AS OFFSET TO BUILD STARTING BLOCK TAD
1066 DCA TEMP2 /POINTS TO PROPER STARING BLOCK #
1067 TAD I TEMP2 /GET STARTING BLOCK FOR THIS OVERLAY
1068 DCA OVADD /PUT IN DRIVER CALL
1069 JMS I L7607 /CALL SYSTEM HANDLER
1070 0500 /OVERLAY 3400-4600
1071 3400
1072OVADD, . /STARTING BLOCK # OF OVERLAY
1073OE, JMS I [ERROR /I/O ERROR
1074 TAD TEMP1
1075 DCA OVRLAY /CHANGE RESIDENT FLAG
1076OVDNE, TAD [SAC-1 /ENTER STRING FUNCTIONS WITH SACXR SET UP
1077 DCA SACXR
1078 TAD TEMP1 /FUNCTION #
1079 TAD JMSTAD /BUILD A TAD OF THE PROPER DISPATCH JMS
1080 DCA .+2 /PUT IN LINE
1081 JMS I [FBITGT /GET # OF FUNCTION DESIRED
1082 . /BUILD JUMP OFF JUMP TABLE
1083FUJUMP, DCA .+1 /PUT JUMP IN LINE
1084 . /GO TO DESIRED FUNCTION
1085 JMP I [ILOOP /DONE
1086
1087OATADI, ARITHA
1088L7607, 7607
1089OVRLAY, 0 /# OF CURRENTLY RESIDENT OVERLAY
1090 /0=ARITHMETIC,1=STRING,2=FILE,3=USER
1091
1092/OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS
1093/INITIALIZED BY LOADER
1094
1095ARITHA, . /STARTING BLOCK OF ARITHMETIC OVERLAY
1096STRNGA, . /STARTING BLOCK OF STRING OVERLAY
1097FILEFA, . /STARTING BLOCK OF FILE OVERLAY
1098USRA, . /STARTING BLOCK OF USER FUNCTIONS
1099
1100JMSTAD, TAD I TADTAB
1101
1102TADTAB, JMSI4
1103 JMSI5
1104 JMPFIL
1105 JMSUSR
1106
1107\f/CALL FOR RESIDENT FUNCTION
1108
1109FUNC3I, JMS I [FBITGT /ISOLATE FUNCTION #
1110 TAD JMSI7 /MAKE A JUMP OFF JUMP TABLE
1111 JMP FUJUMP /PUT THE JUMP IN LINE AND EXECUTE IT
1112
1113JMSI7, JMP I .+1
1114
1115/JUMP TABLE FOR RESIDENT FUNCTIONS
1116
1117 XABSVL /FUNCTION BITS= 0
1118 COMMA / 1
1119 CRFUNC / 2
1120 ILOOPF / 3
1121 TAB / 4
1122 PNT / 5
1123 USE / 6
1124
1125
1126 *1557 /****N.B.****
1127 /THIS TABLE CANNOT BE MOVED!!!!
1128
1129/JUMP DISPATCH FOR USER ROUTINES
1130JMSUSR, JMS I .+1
1131
1132/JUMP TABLE FOR USER FUNCTIONS
1133 ILOOPF /USER FUNCTION 1
1134 ILOOPF / 2
1135 ILOOPF / 3
1136 ILOOPF / 4
1137 ILOOPF / 5
1138 ILOOPF / 6
1139 ILOOPF / 7
1140 ILOOPF / 8
1141 ILOOPF / 9
1142 ILOOPF / 10
1143 ILOOPF / 11
1144 ILOOPF / 12
1145 ILOOPF / 13
1146 ILOOPF / 14
1147 ILOOPF / 15
1148 ILOOPF / 16
1149
1150 PAGE
1151\f/SPECIAL FUNCTIONS
1152
1153SPFUNC, JMS I [FBITGT /ISOLATE FUNCTION BITS
1154 TAD JMPI6 /MAKE A JUMP OFF SPECIAL FUNCTION TABLE
1155 DCA .+1 /PUT IN LINE
1156 .
1157
1158JMPI6, JMP I .+1 /JUMP TO SPECIAL FUNCTION ROUTINE
1159
1160/SPECIAL FUNCTION JUMP TABLE
1161
1162 SETF /SET FSWITCH 0
1163 FRANDM /RANDOMIZE 1
1164 FSTOPN /LEAVE INTERPRETER 2
1165 SRLIST /STRING READ FROM DATA LIST 3
1166 CSFN /SET FILE # TO TTY 4
1167 RDLIST /READ DATA LIST 5
1168 AMODE /SWITCH TO A MODE 6
1169 SSMODE /SWITCH TO S MODE 7
1170\f/SUBROUTINE UNSFIX-UNSIGNED INTEGER FIX ROUTINE. FIXS A POSITIVE 12 BIT
1171/NUMBER OUT OF FAC MANTISSA AND LEAVES RESULT IN AC.RESULT IS AN UNSIGNED,
1172/12 BIT INTEGER
1173
1174UNSFIX, 0
1175 CDF 0
1176 TAD ACL /LOW MANTISSA
1177 CLL RAL /HI BIT OF LO MANTISSA TO LINK
1178 CLA
1179 TAD ACH /HIGH MANTISSA
1180 SPA /IS NUMBER POSITIVE?
1181FM, JMS I [ERROR /NO-BOO!!!
1182 RAL /SHIFT THE SIGN BIT OUT AND THE MANTISSA OVER,
1183 DCA ACH /MAKING 12 BITS OF MANTISSA AND BINARY POINT BEFORE BIT 0
1184 TAD ACX /GET EXPONENT
1185 SPA SNA CLA /IS X>1?
1186 JMP I UNSFIX /NO-FIX IT TO 0
1187 TAD ACX /YES-GET EXPONENT
1188 TAD [-14 /SET BINARY POINT AT 12
1189 SNA /DONE ALREADY?
1190 JMP UNSOUT /YES
1191 SMA /NO-IS # TOO BIG?
1192FO, JMS I [ERROR /YES
1193 DCA ACX /NO-STORE COUNT
1194 TAD ACH /HI MANTISSA
1195UNSLP, CLL RAR /SCALE RIGHT
1196 ISZ ACX /DONE?
1197 JMP UNSLP /NO
1198 JMP I UNSFIX /YES-RETURN
1199
1200UNSOUT, TAD ACH /ANSWER IN AC
1201 JMP I UNSFIX
1202
1203/RESTORE ROUTINE
1204
1205RESTOR, TAD ENTNO /GET CURRENT FILE #
1206 SNA CLA /IS IT 0?
1207 JMP RESDLS /YES-RESTORE DATA LIST
1208 JMS I (WRBLK /NO-WRITE CURRENT BUFFER
1209 STA /-1
1210 TAD I IOTLOC /STARTING BLOCK-1
1211 DCA I IOTBLK /SET CURRENT BLOCK #
1212 TAD I IOTBUF /GET BUFFER ADDRESS
1213 DCA I IOTPTR /USE IT TO RESET READ\WRITE POINTER
1214 TAD I IOTHDR /GET HEADER WORD
1215 AND (7435 /CLEAR EOF BIT,BUFFER WRITTEN BIT,AND CHAR #
1216 DCA I IOTHDR
1217 JMS I [NEXREC /READ FIRST BLOCK INTO BUFFER
1218 JMP I [ILOOP /DONE
1219RESDLS, TAD DLSTRT /ADDRESS OF START OF INCORE DATA LIST
1220 DCA DATAXR /USE IT TO RESET DATA LIST POINTER
1221 JMP I [ILOOP /THATS ALL!
1222\f/SUBROUTINE STFIND-WHEN CALLED,IF LINK=1 STRING ARRAY TABLE IS
1223/USED,IF LINK=0 STRING SYMBOL TABLE IS USED. RETURNS WITH AC SET
1224/TO CDF OF OPERAND STRING,STRPTR POINTING TO THE FIRST WORD
1225/IN THE STRING, AND THE MAX LENGTH OF THE STRING IS IN STRMAX. ALSO,
1226/THE ACTUAL LENGTH OF THE STRING IS IN STRCNT
1227
1228STFIND, 0
1229 SZL /IS THIS AN ARRAY INST?
1230 JMP SAFIND /YES-POINTER IS INTO ARRAY TABLE
1231 TAD INSAV /GET INST AGAIN
1232 AND [377 /ISOLATE OPERAND POINTER
1233 DCA TEMP1 /NO-SAVE OPERAND POINTER
1234 TAD TEMP1 /N
1235 CLL RAL /2N
1236 TAD TEMP1 /3N (3 WORDS/ENTRY)
1237 TAD STSTRT /ADD BASE ADR OF STRING TABLE
1238STCOM, DCA XR2 /POINTER TO THIS ENTRY IN STRING TABLE
1239STDF, . /DF TO THAT OF SYMBOL TABLES (SET BY START)
1240 TAD I XR2 /GET POINTER TO STRING
1241 DCA STRPTR
1242 TAD I XR2 /GET CDF FOR OPERAND STRING
1243 DCA STRCDF /SAVE
1244 TAD I XR2 /GET -(MAX LENGTH OF STRING)
1245 DCA STRMAX /SAVE
1246 SNL /ARRAY ELEMENT?
1247 JMP STRCDF /NO-SKIP THIS SUBSCRIPT CALCULATION
1248 TAD S1 /GET SUBSCRIPT
1249 CLL CMA /SET UP 12 BIT COMPARE
1250 TAD I XR2 /GET DIMENSION
1251 SNL CLA /IS S1>DIMENSION?
1252 JMP I (SU /YES
1253 TAD STRMAX /NO-GET ELEMENT LENGTH
1254 CIA /MAKE POSITIVE
1255 CLL IAC /ROUND OFF TO NEAREST MULTIPLE OF 2
1256 CLL RAR / DIVIDE BY TWO (COUNT/2=WORD COUNT)
1257 CLL IAC /ADD A WORD FOR HEADER
1258 DCA TEMP3 /# OF WORDS IN EACH ARRAY ELEMENT
1259 TAD S1 /GET SUBSCRIPT
1260 JMS I [MPY /S1*ELEMENT LENGTH (ASSUMES LINK UNCHANGED ON RETURN)
1261 TAD STRPTR /ARRAY OFFSET+POINTER TO A(0)
1262 DCA STRPTR /FINAL STRING POINTER
1263 RAL /CARRY TO BIT 11
1264 TAD TEMP6 /ADD TO ACCUMLATED OVERLAPS FROM MULTIPLY
1265 CLL RTL
1266 RAL /PUT OVERLAP # INTO BITS 6-8
1267 TAD STRCDF /ADD TO CDF IF NECESSARY
1268 DCA STRCDF /SAVE AGAIN
1269STRCDF, 0 /DF TO STRING FIELD
1270 TAD I STRPTR
1271 CDF
1272 DCA STRCNT /STORE -(CURRENT LENGTH OF STRING)
1273 TAD STRCDF /CDF TO OPERAND IN AC
1274 DCA I (SSTEX /SETUP STRING STORE EXIT DF HERE
1275 JMS I (BYTSET /ENTER FUNCTIONS WITH BYTE POINTERS SETUP
1276 JMP I STFIND /RETURN
1277
1278SAFIND, TAD INSAV /GET INST
1279 AND (37 /ISOLATE OPERAND POINTER
1280 CLL RTL /4N (4 WORDS/ENTRY)
1281 TAD SASTRT /USE STRING ARRAY TABLE
1282 STL /SET LINK FOR ARRAY INST
1283 JMP STCOM /RETURN TO SUBROUTINE MAINLINE
1284
1285 /PNT(X)
1286 /SEND 7BIT CHAR TO THE CURRENT FILE
1287
1288PNT, JMS I [UNSFIX /FIX X
1289 AND [177 /STRIP TO 7 ASCII BITS
1290 TAD [200 /FORCE CHANNEL 8
1291 JMS I [PUTCH /PUT IN FILE BUFFER
1292 JMP I [ILOOP /DONE
1293
1294 PAGE
1295\f/ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER
1296/AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER
1297
1298SFN, JMS I [UNSFIX /FIX FAC TO GET FILE #
1299CSFN, DCA ENTNO /IF ENTRY IS HERE,FILE #=0 (TTY)
1300 TAD ENTNO
1301 STL
1302 TAD (-4 /IS RESULT A LEGAL FILE #?
1303 SNL SZA CLA
1304FN, JMS I [ERROR /NO-ERROR
1305 TAD ENTNO /PICK UP FILE NUMBER
1306 CLL RTL
1307 RTL
1308 CIA
1309 TAD ENTNO
1310 CIA /MULTIPLY BY SIZE OF IOTABLE
1311 IFNZRO IOTSIZ-15 <__ASSEMBLY ERROR__>
1312 TAD (TTYF /ADD TO BASE
1313 DCA XR1 /STORE IN TEMP
1314 TAD (IOTHDR-1 /NOW POINT AT PAGE 0 AREA
1315 DCA XR2
1316 TAD (-IOTSIZ+3 /SETUP ALL BUT LAST 3
1317 DCA TEMP2
1318 TAD XR1
1319 DCA I XR2
1320 ISZ XR1
1321 ISZ TEMP2
1322 JMP .-4 /SET UP THE POINTERS NOW
1323 JMP I [ILOOP /--RETURN--
1324\f /GOSUB
1325
1326GOSUB, TAD I GSP
1327 SMA CLA
1328GS, JMS I [ERROR /ERROR IF STACK OVERFLOW
1329 TAD I [CDFPSU /ELSE GET CDF INSTR
1330 DCA I GSP
1331 ISZ GSP
1332 TAD I (INTPC
1333 DCA I GSP /STORE INT PC
1334 ISZ GSP
1335 JMP I (SUCJMP /EXEC AS NORMAL GOTO NOW
1336
1337 /GOSUB RETURN
1338
1339RETRNI, STA
1340 TAD GSP
1341 DCA GSP /POP STACK
1342 TAD I GSP /GET PC
1343 DCA I (INTPC
1344 STA
1345 TAD GSP /POP STACK
1346 DCA GSP
1347 TAD I GSP
1348 SMA
1349GR, JMS I [ERROR /FATAL ERROR IF NO RETURN
1350 DCA I [CDFPSU
1351 JMP I (JFAIL /BUMP PC PAST ADDR WORD AND CONTINUE
1352
1353GSP, GSTCK /GOSUB STACK POINTER
1354
1355 /FOR-LOOP JUMP ROUTINE
1356 /ENTER WITH AC = HORD
1357
1358JFOR, SNA /IS FAC=0?
1359 JMP I (JFAIL /YES-DO NOT JUMP
1360 TAD FSWITC /ADD FSWITCH
1361 SPA CLA /ARE SIGN BIT=FSWITCH?
1362 JMP I (JFAIL /NO-DO NOT JUMP
1363 JMP I (SUCJMP /YES-DO JUMP
1364
1365/ROUTINE TO INITIALIZE FSWITCH
1366
1367SETF, AC4000
1368 AND ACH /ISOLATE SIGN OF MANTISSA
1369 DCA FSWITC /STORE IN FSWITCH
1370 JMP I [ILOOP /DONE
1371FSWITC, 0
1372\f/ROUTINE TO RESET CHARACTER NUMBER TO 1
1373
1374CNOCLR, 0
1375 TAD I IOTHDR
1376 AND [7477 /SET CHAR BITS TO 0
1377 DCA I IOTHDR
1378 JMP I CNOCLR /RETURN
1379
1380 /ROUTINE TO ZERO THE CURRENT I/O BUFFER
1381
1382BLZERO, 0
1383 STA
1384 TAD I IOTBUF
1385 DCA XR1 /POINT INTO THE BUFFER
1386 TAD [7400
1387 DCA CNOBML /SET COUNT TO 400 WORDS
1388 TAD (232 /INSERT A ^Z IN THE BUFFER FIRST
1389 CDF 10
1390 DCA I XR1
1391 ISZ CNOBML
1392 JMP .-2 /LOOP FOR THE REST
1393 CDF
1394 JMP I BLZERO /--RETURN--
1395
1396 /BUMP 3 FOR 2 CHAR NUMBER FOR CURRENT FILE
1397
1398CNOBML, 0
1399 TAD I IOTHDR /HEADER WORD
1400 TAD [100 /ADD 1 TO THE COUNT BITS
1401 DCA I IOTHDR
1402 JMP I CNOBML /DONE
1403\f /STRING COMPARE
1404 /COMPARE SAC WITH MEMORY, BLANK EXTENDING THE
1405 /SHORTER STRING ON THE RIGHT
1406
1407SCOMP, DCA MODESW /SET INTERPRETER TO ARITH MODE NOW
1408 JMS I [FACCLR /TENTATIVELY ASSUME EQUAL (FAC = 0)
1409SCOMLP, TAD STRCNT /IS THE MEMORY STRING EMPTY NOW?
1410 SNA CLA
1411 TAD L40 /PAD WITH SPACE IF YES
1412 SNA
1413 JMS I (LDB /LOAD NEXT BYTE IF NOT
1414 DCA TEMP2
1415 TAD SACLEN /NOW IS THE SAC EMPTY
1416 SNA CLA
1417 TAD L40 /YES, PAD IT
1418 SNA
1419 TAD I SACXR /NO GET IT
1420 CLL CIA /COMPARE TO MEMORY
1421 TAD TEMP2
1422 SZA CLA
1423 JMP SNEQ /JMP IF NOT EQUAL, L=SENSE OF COMPARE
1424 TAD STRCNT /IS MEMORY STRING DONE
1425 SZA CLA
1426 ISZ STRCNT /NO, BUMP COUNT
1427L40, 40 /EFFECTIVE NOP
1428 TAD SACLEN /IS THE SAC EMPTY
1429 SZA CLA
1430 ISZ SACLEN /NO BUMP COUNT
1431 TAD SACLEN /GET SAC REMAINDER (SKP IF IS JUST ZERO)
1432 TAD STRCNT /ADD ARG REMAINDER
1433 SZA CLA
1434 JMP SCOMLP /LOOP IF BOTH NOT EMPTY
1435 JMP I [ILOOP /OTHERWISE EQUAL
1436SNEQ, STA RAR
1437 DCA ACH /STORE SIGN BIT
1438 JMP I [ILOOP /--RETURN--
1439
1440 PAGE
1441\f /STRING DATA LIST READ, STRING LOAD AND STRING CONCATENATE
1442
1443SRLIST, JMS I (DLREAD /FIRST READ NEG BYTE COUNT
1444 DCA STRCNT /STORE IT
1445 STL /SET LINK MEANS USE PHONY DATA LIST BYTE LOAD
1446 SKP /SKP INTO STRING LOAD ROUTINE
1447SLOAD, CLL /CLEAR LINK TO USE NORMAL LOAD BYTE ROUTINE
1448 DCA SACLEN /CLEAR SAC LENGTH COUNTER
1449 SZL
1450 TAD (DRGCH-LDB /USE PHONY LOAD BYTE
1451SCON1, TAD (LDB /USE REAL LDB FOR CONCATENATE
1452 DCA SCLDB
1453 TAD STRCNT
1454 SNA CLA
1455 JMP I [ILOOP /NOTHING TO DO IF NULL STRING
1456 TAD SACLEN /COMPUTE OFFSET INTO SAC
1457 CIA
1458 TAD [SAC-1
1459 DCA SACXR /TO STORE AFTER END OF PREV STRING
1460SEGCOM, JMS I SCLDB /GET A BYTE
1461 DCA I SACXR /STORE IT
1462 STA
1463 TAD SACLEN /NOW BUMP SIZE OF SAC
1464 DCA SACLEN
1465 TAD SACLEN /CHECK IF ROOM LEFT
1466 TAD (SACLIM
1467 SPA CLA
1468SC, JMS I [ERROR /FATAL ERROR IF SAC OVERFLOW
1469 ISZ STRCNT
1470 JMP SEGCOM /ITERATE IF MORE
1471 JMP I [ILOOP /--RETURN--
1472
1473SCLDB, 0
1474
1475 /ROUTINE TO GET A BYTE FROM THE DATA LIST
1476
1477DRGCH, 0
1478 TAD SACLEN /TEST FOR EVEN OR ODD
1479 CLL RAR
1480 SZL CLA
1481 JMP CHR2 /SECOND CHAR
1482 JMS I (DLREAD /FIRST CHAR, READ ANOTHER WORD
1483 DCA DRCHR
1484 TAD DRCHR
1485 CLL RTR
1486 RTR
1487 RTR /SHIFT RIGHT
1488 SKP
1489CHR2, TAD DRCHR /GET SECOND CHAR
1490 AND [77 /MASK TO 6BIT
1491 JMP I DRGCH /RETURN
1492
1493DRCHR, 0
1494\f
1495/ROUTINE TO SET EOF BIT IN I/O ENTRY
1496EOFSET, TAD I IOTHDR /HEADER
1497 CLL RTR /EOF BIT TO LINK
1498 STL RTL /SET LINK
1499 /PUT LINK IN EOF BIT
1500 DCA I IOTHDR /STORE IN I/O TABLE ENTRY
1501 JMP I [ILOOP /EOF BIT SET-ABORT TO ILOOP
1502
1503/SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS
1504/OF TEMP3 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN TEMP6
1505/AND THE LOW RESULT IN THE AC
1506
1507MPY, 0
1508 DCA TEMP10
1509 DCA TEMP6
1510 TAD [-14
1511 DCA TEMP5
1512MP12LP, TAD TEMP3
1513 RAR
1514 DCA TEMP3
1515 TAD TEMP6
1516 SNL
1517 JMP .+3 /12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2
1518 CLL
1519 TAD TEMP10
1520 RAR
1521 DCA TEMP6
1522 ISZ TEMP5
1523 JMP MP12LP
1524 TAD TEMP3 /LORD OF (DIM1+1)*S2 IN AC
1525 RAR /HORD OF (DIM1+1)*S2 IN TEMP6
1526 JMP I MPY /RETURN
1527
1528 /ROUTINE TO CHECK IF FILE IDLE
1529
1530IDLE, 0
1531 TAD I IOTHND /GET HANDLER ENTRY
1532 SNA CLA /IS IT EMPTY?
1533FI, JMS I [ERROR /YES-USER TRIED TO DO SOMETHING TO AN UNOPEN FILE
1534 JMP I IDLE /NO-RETURN
1535\f/ROUTINE TO READ NEXT WORD IN DATALIST INTO AC
1536
1537DLREAD, 0
1538 TAD DATAXR /DATA LIST POINTER
1539 CLL CMA /SET UP 12 BIT COMPARE
1540 TAD DLSTOP /ADDR OF END OF DATA LIST
1541 SNL CLA /POINTER AT END OF LIST?
1542DA, JMS I [ERROR /YES
1543DLCDF, . /NO-DF TO DATA LIST
1544 TAD I DATAXR /FETCH WORD FROM DATA LIST
1545 CDF
1546 JMP I DLREAD /DONE
1547
1548 /RANDOMIZE STATEMENT
1549
1550FRANDM, TAD SPINNR /USE SPINNR FOR NEW SEED FOR RND(X)
1551 STL RAL /MAKE SURE SEED IS ODD
1552 DCA RSEED
1553 JMP I [ILOOP /DONE
1554RSEED, 2713
1555
1556/SUBROUTINE CR,LF
1557
1558CRLFR, 0
1559 TAD [215
1560 JMS I [PUTCH
1561 TAD (212
1562 JMS I [PUTCH /PRINT A CR,AND LF
1563 DCA I IOTPOS /ZERO NUMBER OF CHARS PRINTED SO FAR
1564 JMP I CRLFR
1565
1566/SUBROUTINE FOTYPE
1567/RETURNS TO CALL+1 IF FILE FIXED LENGTH,CALL+2 IF VARIABLE
1568
1569FOTYPE, 0
1570 TAD I IOTHDR /GET HEADER
1571 AND (4 /ISOLATE TYPE BIT
1572 SZA CLA /IS IT FIXED LENGTH?
1573 ISZ FOTYPE /NO-BUMP RETURN
1574 JMP I FOTYPE /RETURN
1575
1576 /ABS(X) FUNCTION
1577
1578XABSVL, JMS ABSVAL /NEGATE FAC IF NEGATIVE
1579 JMP I [ILOOP /--RETURN--
1580
1581 /SUBROUTINE TO TAKE ABS VALUE OF FAC
1582
1583ABSVAL, 0
1584 TAD ACH
1585 SPA CLA /IS FAC<0?
1586 JMS I [FFNEG /YES-NEGATE IT
1587 JMP I ABSVAL /RETURN
1588
1589/ROUTINE TO RESTORE THE FAC FROM FP TEMP
1590
1591FACRES, 0
1592 JMS I [FFGET /GET FAC
1593 INTERB
1594 JMP I FACRES /RETURN
1595
1596 PAGE
1597\f /STRING STORE
1598
1599SSTORE, TAD SACLEN
1600 SNA
1601 JMP I (SSTEX /EXIT IF NULL STRING IN SAC
1602 DCA TEMP1 /SET COUNT
1603 TAD SACLEN /SEE IF WILL FIT
1604 CIA
1605 TAD STRMAX
1606 SMA SZA CLA /SKP IF LEN.LE.MAX LEN
1607SL, JMS I [ERROR /ERROR IF TARGET STRING TOO SMALL
1608 TAD I SACXR /PICK UP SAC BYTE
1609 JMS I (DPB /STORE IT
1610 ISZ TEMP1
1611 JMP .-3
1612 JMP I (SSTEX /--RETURN--
1613
1614 /STRING READ FROM FILE TO MEMORY
1615
1616SREAD, JMS I [GETCH /GET CHAR FROM FILE
1617 TAD CHAR
1618 TAD [-215 /IS IS CR?
1619 SNA
1620 JMP I (SSTEX /YES, EXIT
1621 TAD (3 /IS IT LF?
1622 SNA CLA
1623 JMP SREAD /YES, IGNORE IT
1624 TAD I (BYTCNT /SEE IF THIS CHAR WILL FIT
1625 TAD STRMAX
1626 SMA CLA
1627 JMP ST /NO, SOFT ERROR
1628 TAD CHAR /YES, STORE IT
1629 JMS I (DPB
1630 JMP SREAD
1631ST, JMS I [ERROR
1632 TAD [215 /FAKE OUT INPUT ROUTINE
1633 DCA CHAR
1634 JMP I (SSTEX /SET STRING SIZE AND EXIT
1635\f /STRING WRITE FROM SAC TO DEVICE
1636
1637SWRITE, DCA COMMAS
1638 TAD SACLEN /SEE IF NULL STRING
1639 SNA
1640 JMP I [ILOOP /RETURN IF SO
1641 CIA
1642 TAD I IOTPOS /ADD TO NUMBER OF CHARS PRINTED SO FAR
1643 TAD (-WIDTH
1644 SMA SZA CLA /SKP IF LE WIDTH OF LINE
1645 JMS I [CRLFR /ELSE RESET CARRAIGE
1646 TAD SACLEN
1647 DCA STRCNT /SET LOOP COUNTER
1648 TAD [SAC-1
1649 DCA SACXR /POINT AT SAC
1650SWRLP, TAD I SACXR
1651 TAD (240
1652 AND [77
1653 TAD (240 /CONVERT TO 8BIT
1654 JMS I (PUTCH
1655 ISZ STRCNT
1656 JMP SWRLP /ITERATE IF MORE
1657 JMP I [ILOOP /--RETURN--
1658
1659\f/COMMA FUNCTION (KNOWN ONLY TO COMPILER FOR FORMATTING PRINT
1660/STATEMENTS)
1661
1662COMMA, JMS I [FTYPE /SKP IF FILE IS ASCII
1663 JMP I [ILOOP /NO-COMMA FUNCTION IS A NOP
1664 TAD COMMAS /GET COMMA SWITCH
1665 SNA CLA /WAS LAST THING PRINTED A COMMA?
1666 JMP .+3 /NO-WE ARE OK
1667 TAD (" /YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION
1668 JMS I [PUTCH
1669 IAC
1670 DCA COMMAS /SET COMMA SWITCH
1671 TAD (-4
1672 DCA TEMP2
1673 TAD I IOTPOS /GET NUMBER OF CHARS PRINTED SO FAR
1674COMLOP, TAD (-COLWID
1675 SPA /PAST THIS ONE?
1676 JMP SLOVER /YES-SLIDE PRINT HEAD TO START OF NEXT
1677 SNA /EXACTLY ON A COLUMN?
1678 JMP I [ILOOP /YES-DONE
1679 ISZ TEMP2 /ALL MARKERS CHECKED YET?
1680 JMP COMLOP /NO-DO NEXT
1681 CLA /FALL INTO CR ROUTINE TO RESET COL TO 0
1682
1683/CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING
1684/PRINT STATEMENTS)
1685
1686CRFUNC, TAD I IOTHDR
1687 CLL RTR
1688 SNL CLA /SKP IF EOF IS SET
1689 JMS I [FTYPE /SKP IF FILE IS ASCII
1690 JMP I [ILOOP /WE DON'T WANT TO OUTPUT CLFR
1691 JMS I [CRLFR /DO AS WE ARE TOLD
1692 JMP I [ILOOP /NEXT INST
1693
1694 /TAB FUNCTION
1695
1696TAB, JMS I [UNSFIX /FIX X TO INTEGER
1697 CIA /NEGATE
1698 TAD I IOTPOS /COMPARE DESIRED COLUMN TO REAL COLUMN
1699 IAC /BUMP BY 1 (WORD 7=COL #-1)
1700 SMA /IS X>=CURRENT COLUMN?
1701 JMP I [ILOOP /YES-THEN DO NOTHING
1702 /FALL INTO SPACE OUT ROUTINE
1703
1704SLOVER, DCA COLCNT /-# OF COLUMNS TO NEXT MARKER
1705 JMS I [FTYPE /IS FILE NUMERIC?
1706 JMP I [ILOOP /YES-THIS IS A NOP
1707 TAD (" /GET SPACE
1708 JMS I [PUTCH /PRINT IT
1709 ISZ COLCNT /THERE YET?
1710 JMP .-3 /NO-TYPE ANOTHER SPACE
1711 JMP I [ILOOP /YES-DONE
1712
1713COMMAS, 1 /SET TO 1 IF LAST PRINT WAS A COMMA MOVE
1714COLCNT, 0
1715
1716/ROUTINE TO CALL ERROR ROUTINE BY FAKING A FUNC2 CALL TO FUNCTION #10
1717
1718ERROR, 0
1719 CLA CLL IAC /ENTRY AC RANDOM
1720 AND PSFLAG /TEST IF OS/8 17600 RESIDENT
1721 SZA CLA /SKP IF NOT
1722 JMS I [PSWAP /ELSE FORCE IT OUT (THESE ERRORS ARE FATAL)
1723 TAD (7607
1724 DCA INSAV /FAKE A FUNC CALL TO FUNC2 #10
1725 JMP I (FUNC2I
1726XERRRET,JMP I ERROR /RETURN TO CALLER IF NON FATAL ERROR
1727
1728 /FLOATING NEGATE
1729
1730FNEGI, JMS I [FFNEG /CALL NEGATE ROUTINE
1731 JMP I [ILOOP /RETURN TO ILOOP
1732
1733NUMBUF, ZBLOCK 6 /6 DIGIT BUFFER USED BY FFOUT
1734
1735 PAGE
1736\f /INCREMENT AND LOAD 6BIT BYTE FROM MEMORY
1737
1738LDB, 0
1739 JMS BUMP /INCREMENT POINTER AND SET DF
1740 TAD I BYTPTR /PICK UP BYTE
1741 CDF
1742 ISZ BYTSWT /TEST HALFWORD SWITCH
1743 JMP .+4
1744 CLL RTR
1745 RTR
1746 RTR
1747 AND [77 /MASK TO 6BIT
1748 JMP I LDB /RETURN WITH CHAR IN AC
1749
1750 /INCREMENT AND DEPOSIT BYTE IN MEMORY
1751
1752DPB, 0
1753 AND [77 /MASK TO 6BIT NOW
1754 DCA BYTE
1755 JMS BUMP /INCREMENT POINTER AND SET DF
1756 TAD [77 /GET MASK
1757 ISZ BYTSWT /SKP IF PTR BUMPED
1758 CMA CML /ELSE PRESERVE LEFT HALF
1759 AND I BYTPTR /ZERO OUT TARGET BYTE
1760 DCA I BYTPTR
1761 TAD BYTE /GET BYTE
1762 SZL
1763 JMP .+4 /JMP IF NO SHIFT
1764 CLL RTL
1765 RTL
1766 RTL
1767 TAD I BYTPTR
1768 DCA I BYTPTR /STORE BYTE
1769 CDF
1770 ISZ BYTCNT /TALLY NUMBER OF BYTES STORED
1771 JMP I DPB /--RETURN--
1772
1773 /BUMP BYTE POINTER
1774
1775BUMP, 0
1776 TAD BYTSWT /BUMP LOW ORDER BIT
1777 CLL CMA
1778 DCA BYTSWT
1779 ISZ BYTSWT /SKP IF NO CARRY
1780 ISZ BYTPTR /ELSE BUMP WORD PTR
1781 JMP BYTCDF /JMP OUT IF FIELD NOT CROSSED
1782 TAD [10
1783 TAD BYTCDF
1784 DCA BYTCDF /PROPAGATE CARRY INTO CDF INSTR
1785BYTCDF, 0 /GETS SET BY BYTSET TO TARGET FIELD
1786 JMP I BUMP /RETURN WITH A CLEAR LINK
1787
1788 /BYTE LOAD/STORE INITIALIZE ROUTINE
1789
1790BYTSET, 0
1791 TAD SSTEX /GET FIELD OF STRING
1792 DCA BYTCDF /STORE INLINE
1793 TAD STRPTR /NOW GET ADDR OF COUNT WORD
1794 DCA BYTPTR /STORE
1795 IAC
1796 DCA BYTSWT /SET LOW ORDER BIT TO CARRY NEXT TIME
1797 DCA BYTCNT /CLEAR DEPOSITED BYTE COUNT
1798 TAD [SAC-1
1799 DCA SACXR /ALWAYS RETURN WITH SAC POINTER SET UP
1800 JMP I BYTSET /--RETURN--
1801
1802 /STRING STORE EXIT ROUTINE
1803
1804SSTEX, 0 /GETS SET BY STFIND TO DF OF STRING
1805 TAD BYTCNT /ENTER WITH POSITIVE LENGTH IN COUNT
1806 CIA
1807 DCA I STRPTR /STORE IN STRING
1808 JMP I [ILOOP /--RETURN-- (ILOOP RESETS DF)
1809
1810BYTCNT, 0
1811BYTPTR, 0
1812BYTSWT, 0
1813BYTE, 0
1814\f/SUBROUTINE BUFCHK-CHECKS THE POSITION OF THE BUFFER POINTER FOR
1815/THE DEVICE WHOSE I/O TABLE ENTRY IS IN WORKING AREA. RETURNS TO CALL+1
1816/IF THE POINTER IS AT THE END AND CHAR NUMBER IS 1 (LAST
1817/AVAILABLE CHAR 3 HAS BEEN USED),CALL+2 IF THE POINTER IS AT THE
1818/END BUT THE CHAR # IS NOT 1 (THERE IS 1 CHAR 3 LEFT), CALL+3
1819/IF THERE IS 1 WORD LEFT IN BUFFER,CALL+4 IF MORE THAN 1 LEFT.
1820
1821BUFCHK, 0
1822 TAD ENTNO /GET DEVICE #
1823 SNA CLA /IS IT TTY?
1824 TAD (62-400 /YES-CHECK FOR A BUFFER 60 WORDS LONG
1825 TAD [400 /NO-CHECK FOR A BUFFER 400 WORDS LONG
1826 TAD I IOTBUF /ADD LENGTH TO BUFFER ADDRESS
1827 CIA /-ADDR OF END OF BUFFER
1828 TAD I IOTPTR /CHECK AGAINST CURRENT POINTER
1829 SNA /IS POINTER AT END OF BUFFER?
1830 JMP EBC /AT END-CHECK THE CHAR #
1831 ISZ BUFCHK
1832 ISZ BUFCHK /NO-BUMP RETURN
1833 IAC
1834 SNA CLA /WAS POINTER AT LAST WORD?
1835 JMP I BUFCHK /YES-RETURN TO CALL+3
1836 ISZ BUFCHK /NO
1837 JMP I BUFCHK /RETURN TO CALL+4
1838
1839EBC, JMS I [CHARNO /GET CHAR #
1840 JMP I BUFCHK /IT WAS 1-RETURN TO CALL+1
1841 NOP /IT WAS 3-RETURN TO CALL+2
1842 ISZ BUFCHK /IT WAS 2-RETURN TO CALL+2
1843 JMP I BUFCHK
1844\f
1845/SUBROUTINE PACKCH-PACKS ASCII CHARS,3 FOR 2, INTO BUFFER FOR THE
1846/DEVICE IN WORK AREA. CALL WITH THE CHARACTER IN THE AC
1847
1848PACKCH, 0
1849 DCA TEMP1 /SAVE
1850 JMS I [CHARNO /DETERMINE CHARACTER NUMBER
1851 SKP /1
1852 JMP CHAR3P /3
1853 TAD TEMP1 /1 OR 2-GET CHAR AGAIN
1854 JMS I [WRITFL /STORE IN BUFFER
1855 JMS I (CNOBML /BUMP CHARACTER NUMBER
1856 JMP I PACKCH /DONE
1857
1858CHAR3P, AC7776
1859 TAD I IOTPTR /BACK BUFFER POINTER UP TO POINT TO CHAR 1
1860 DCA I IOTPTR
1861 TAD TEMP1 /CHAR
1862 CLL RTL
1863 RTL /SLIDE LEFT HALF INTO BITS 0-3
1864 DCA TEMP1 /SAVE
1865 TAD TEMP1
1866 JMS COMBNE /ISOLATE LEFT HALF,COMBINE WITH CHAR1,AND PUT IN FILE
1867 TAD TEMP1 /CHAR AGAIN
1868 CLL RTL
1869 RTL /SLIDE RIGHT HALF INTO BITS 0-3
1870 JMS COMBNE /ISOLATE RIGHT HALF,COMBINE WITH CHAR 2,AND PUT IN FILE
1871 JMS I [CNOCLR /CLEAR THE CHARACTER NUMBER (RESET IT TO 1)
1872 JMP I PACKCH /DONE
1873
1874COMBNE, 0
1875 AND [7400 /ISOLATE HALF IN QUESTION
1876 DCA TEMP2 /SAVE
1877 JMS I (BCGET /GET A WORD FROM FILE BUFFER IN FIELD 1
1878 AND [377 /FLUSH ANY SLUSH IN BITS 0-3
1879 TAD TEMP2 /COMBINE
1880 JMS I [WRITFL /PUT IN BUFFER
1881 JMP I COMBNE /RETURN
1882
1883 PAGE
1884\f/ROUTINE TO READ WORD FROM FILE BUFFER AND BUMP POINTER
1885
1886READFL, 0
1887 JMS I (FOTYPE /IS FILE VARIABLE LENGTH
1888 SKP
1889VR, JMS I [ERROR /YES-IT IS AN ERROR TO TRY AND READ IT
1890 TAD I IOTHDR /CHECK IF MORE THERE
1891 CLL RTR /EOF BIT TO LINK
1892 SNL CLA /EOF?
1893 JMP .+3 /NO-CONTINUE
1894RE, JMS I [ERROR /YES-ATTEMPT TO READ BEYOND EOF
1895 JMP I [ILOOP /NOT FATAL-RETURN TO I LOOP
1896 JMS BCGET /GET WORD FROM FILE BUFFER
1897 ISZ I IOTPTR /BUMP POINTER
1898 JMP I READFL /DONE
1899
1900/ROUTINE TO WRITE AC IN FILE BUFFER AND INCREMENT POINTER
1901
1902WRITFL, 0
1903 JMS I (BCPUT /STORE AC IN FILE BUFFER
1904 ISZ I IOTPTR /BUMP POINTER
1905 TAD I IOTHDR /GET FILE HEADER WORD
1906 CLL RTR /EOF BIT TO LINK
1907 SNL CLA /WAS FILE PAST END?
1908 JMP I WRITFL /NO-RETURN
1909WE, JMS I [ERROR /YES-ATTEMPT TO WRITE PAST END OF FILE
1910 JMP I [ILOOP /NON-FATAL RETURN TO ILOOP
1911
1912/ROUTINE TO GET ONE WORD FROM FILE BUFFER IN FIELD 1
1913
1914BCGET, 0
1915 JMS I [IDLE /CHECK IF FILE OPEN
1916 TAD I IOTPTR /GET READ WRITE POINTER
1917 DCA WRITFL /SAVE
1918 TAD ENTNO /GET FILE #
1919 SZA CLA /IF TTY,BUFFER FIELD IS 0
1920 CDF 10 /DF TO BUFFER FIELD
1921 TAD I WRITFL /GET WORD FROM BUFFER
1922 CDF
1923 JMP I BCGET /RETURN
1924\f/SUBROUTINE UNPACK-UNPACKS ASCII, 3 FOR 2 ,FROM THE FILE IN THE I/O
1925/WORKING AREA. RETURNS WITH THE CHAR IN CHAR.
1926
1927UNPACK, 0
1928 JMS I [CHARNO /GET CHAR #
1929 SKP /1
1930 JMP CHAR3U /3
1931 JMS I (CNOBML /BUMP CHAR NUMBER
1932 JMS READFL /GET CHAR AGAIN
1933U123C, AND [177 /STRIP OFF 7 BITS
1934 SNA
1935 JMP UNPACK+1 /ZERO
1936 TAD [200
1937 DCA CHAR /SAVE
1938 TAD CHAR
1939 TAD (-232 /IS IT CTRL/Z?
1940 SNA CLA
1941 JMP I [EOFSET /YES-SET EOF BIT
1942 JMP I UNPACK /RETURN
1943
1944CHAR3U, JMS I [CNOCLR /RESET CHAR # TO 1
1945 AC7776
1946 TAD I IOTPTR
1947 DCA I IOTPTR /BACK BUFFER POINTER UP 2
1948 JMS READFL /GET LEFT HALF OF CHAR
1949 AND [7400
1950 DCA XR5 /SAVE
1951 JMS READFL /GET NEXT WORD WITH RIGHT HALF
1952 AND [7400 /ISOLATE RIGHT HALF
1953 CLL RTR
1954 RTR /SLIDE RIGHT HALF OVER
1955 TAD XR5 /COMBINE WITH LEFT HALF
1956 CLL RTR
1957 RTR /MOVE TO BITS 4-11
1958 JMP U123C /REJOIN MAINLINE
1959\f/READ FUNCTION-GETS NUMBERS INTO VARIABLES
1960
1961READI, JMS I [FTYPE /SKP IF FILE IS ASCII
1962 JMP RIMAGE /READ NUMERIC IMAGE
1963 JMS I (FFIN /READ ASCII INTO NUMBER
1964 JMP I [ILOOP /--RETURN--
1965RIMAGE, JMS I [BUFCHK /YES-CHECK BUFFER POINTER
1966 NOP /PAST END-NEXT RECORD
1967 NOP /AT END-NEXT RECORD
1968 JMS I [NEXREC /ONLY 1 WORD LEFT-IT IS UNUSED IN NUMERIC FMT
1969 JMS READFL /GET WORD FROM FILE
1970 DCA ACX /STORE AS EXPONENT
1971 JMS READFL /GET WORD FROM FILE
1972 DCA ACH /STORE AS HIGH MANTISSA
1973 JMS READFL /GET WORD FROM FILE
1974 DCA ACL /STORE AS LOW MANTISSA
1975 JMP I [ILOOP /DONE
1976
1977/ROUTINE TO FETCH ASCII CHARACTERS FROM FILE BUFFER
1978
1979GETCH, 0
1980 JMS I [FTYPE /IS FILE ASCII?
1981SR, JMS I [ERROR /NO-ERROR
1982 TAD ENTNO
1983 SZA CLA
1984 JMP NTTY
1985 TAD TCHAR
1986 TAD [-215
1987 SNA CLA
1988 JMS I [DRCALL
1989NTTY, JMS I [BUFCHK /NO-CHECK STATUS OF BUFFER
1990 JMS I [NEXREC /LAST CHAR READ-NEXT RECORD
1991 NOP /CHAR 3 NOT USED YET
1992TCHAR, 215 /NOP: CHAR 2 AND 3 LEFT
1993 JMS UNPACK /UNPACK CHAR FROM BUFFER
1994 TAD ENTNO
1995 SZA CLA
1996 JMP I GETCH /RETURN
1997 TAD CHAR
1998 DCA TCHAR
1999 JMP I GETCH
2000
2001/SUBROUTINE CHARNO-RETURNS TO CALL+1 IF CHAR #=1,CALL+2 IF 3,CALL+3
2002/IF 2
2003
2004CHARNO, 0
2005 TAD I IOTHDR /HEADER
2006 AND (300 /ISOLATE CHAR #
2007 CLL RTL
2008 RTL /CHAR # TO BITS 0,1
2009 SMA SZA /IS IT 2?
2010 ISZ CHARNO /YES-BUMP RETURN
2011 SZA CLA /IS IT 2 OR 3?
2012 ISZ CHARNO /YES-BUMP RETURN
2013 JMP I CHARNO /RETURN
2014
2015 PAGE
2016\f/WRITE FUNCTION-PUTS NUMBERS IN FILE BUFFERS
2017
2018WRITEI, JMS I [FTYPE /SKP IF FILE IS ASCII
2019 JMP WIMAGE /ELSE DO IMAGE WRITE
2020 JMS I (FFOUT /CONVERT INTERNAL TO ASCII
2021 TAD XR1
2022 CIA
2023 TAD (INTERB-1 /CALCULATE NUMBER OF CHARS STORED IN BUFFER
2024 DCA TEMP10 /SAVE
2025 TAD (INTERB-1
2026 DCA SACXR /NOW POINT SACXR INTO BUFFER
2027 TAD TEMP10 /GET COUNT OF CHARS TO BE PRINTED
2028 CIA
2029 TAD I IOTPOS /ADD TO PRINT HEAD POSITION
2030 TAD (-WIDTH /COMPARE AGAINST "72"
2031 SMA SZA CLA /WILL THE NUMBER FIT ON THIS LINE?
2032 JMS I [CRLFR /NO-ISSUE A CR,LF
2033CPLOOP, TAD I SACXR /GET CHAR FROM INTERMEDIATE BUFFER
2034 JMS PUTCH /PUT ON DEVICE
2035 ISZ TEMP10 /BUMP COUNTER
2036 JMP CPLOOP /NEXT
2037 TAD O240
2038 JMS PUTCH /SEND OUT A SPACE AFTER NUMBER
2039 JMP WDONE /TAKE COMMON EXIT
2040WIMAGE, JMS I [BUFCHK /FILE IS NUMERIC-CHECK BUFFER STATUS
2041O240, 240 /PAST END-NEW RECORD (AND INST SERVES AS NOP)
2042O210, 0210 /AT END-NEW RECORD (AND SERVES AS NOP)
2043 JMS I [NEXREC /ONE WORD LEFT-DON'T USE IT
2044 TAD ACX /EXPONENT
2045 JMS I [WRITFL /WRITE IN BUFFER
2046 TAD ACH /HIGH MANTISSA
2047 JMS I [WRITFL /WRITE IN BUFFER
2048 TAD ACL /LOW MANTISSA
2049 JMS I [WRITFL /WRITE IN BUFFER
2050WDONE, DCA I (COMMAS /CLEAR COMMA SWITCH
2051 JMP I [ILOOP /WRITE IS DONE
2052\f/ROUTINE TO PUT ASCII CHARS IN FILE BUFFER. IGNORES RUBOUTS.
2053
2054PUTCH, 0
2055 DCA TEMP1 /SAVE CHAR
2056 TAD TEMP1 /GET CHAR AGAIN
2057 TAD (-377
2058 SNA CLA /IS IT A RUBOUT?
2059 JMP I PUTCH /YES-RETURN
2060 JMS I [FTYPE /IS FILE NUMERIC?
2061SW, JMS I [ERROR /YES-ERROR
2062 ISZ I IOTPOS /BUMP COULMN NUMBER
2063 TAD ENTNO /GET ENTRY #
2064 SNA CLA /IS IT TTY?
2065 JMP TOUT /YES-JUST PUT CHARS IN RING BUFFER
2066 JMS I [BUFCHK /NO-IS BUFFER FULL?
2067 JMS I [NEXREC /YES-NEXT RECORD
2068O40, 40 /THERE IS A CHAR 3 LEFT (AND IS A NOP)
2069O20, 20 /THERE IS A CHAR 2 AND 3 LEFT (AND IS A NOP)
2070 TAD TEMP1 /GET CHAR AGAIN
2071 JMS I [PACKCH /PUT IN BUFFER
2072 JMP I PUTCH /RETURN
2073
2074TOUT, TAD TEMP1 /GET CHAR
2075 JMS I [XPUTCH /PUTCH CHAR IN OUTPUT BUFFER FOR TTY
2076 JMP I PUTCH /RETURN
2077\f/SUBROUTINE NEXREC-WRITES THIS BUFFER IN FILE,THEN READS IN NEXT BUFFER
2078/IF POSSIBLE,ELSE SETS EOF BIT. IF DEVICE IS READ OR WRITE ONLY
2079/IT JUST READS OR WRITES A BLOCK,WHICHEVER IS APPROPRIATE
2080
2081NEXREC, 0
2082 TAD I IOTHDR /GET HEADER
2083 AND O20 /GET READ/WRITE ONLY BIT
2084 SNA CLA /IS IT ON?
2085 JMP FILSTR /NO-DEVICE IS FILE STRUCTURED
2086 JMS I (FOTYPE /YES-IS IT INPUT OR OUTPUT FILE?
2087 JMP RONLY
2088 JMS WRBLK
2089RWONC, ISZ I IOTBLK
2090 JMS BLINIT /INIT FILE TABLE ENTRIES
2091 JMP I NEXREC /DONE
2092
2093RONLY, JMS BLREAD
2094 JMP RWONC
2095
2096FILSTR, JMS WRBLK /WRITE THE CURRENT BLOCK IF IT HAS BEEN CHANGED
2097 JMS BLINIT /INIT FILE TABLE ENTRIES
2098 ISZ I IOTBLK /BUMP BLOCK #
2099 TAD I IOTLOC /STARTING BLOCK
2100 CIA /NEGATE
2101 TAD I IOTBLK /SUBTRACT FROM CURRENT BLOCK FOR FILE LENGTH
2102 CLL CMA /SET UP CURRENT FILE LENGTH FOR 12 BIT COMPARE
2103 TAD I IOTLEN /COMPARE TO ACTUAL LENGTH
2104 SNL CLA /IS IT > CURRENT LENGTH?
2105 JMP LASTB /YES-EXTEND THE FILE IF IT IS OUTPUT
2106 JMS BLREAD /READ IN THE NEXT RECORD
2107 JMP I NEXREC /RETURN
2108
2109
2110LASTB, JMS I (FOTYPE /IS FILE FIXED LENGTH?
2111 JMP I [EOFSET /YES-SET EOF FLAG
2112 TAD I IOTLEN /NO-GET ACTUAL LENGTH
2113 CLL CMA
2114 TAD I IOTMAX /MAXIMUM LENGTH
2115 SNL CLA /IS ACTUAL LENGTH >= MAXIMUM LENGTH?
2116 JMP I [EOFSET /YES-SET EOF BITS
2117 ISZ I IOTLEN /NO-BUMP ACTUAL LENGTH
2118 JMP I NEXREC /RETURN WITHOUT READING NEXT RECORD
2119\f/ROUTINE TO READ 2 PAGES FROM DEVICE
2120
2121BLREAD, 0
2122 JMS I (BLZERO
2123 TAD O210 /"READ 2 PAGES"
2124 JMS I [DRCALL /HANDLER CALL
2125 JMP I BLREAD
2126
2127/ROUTINE TO WRITE 2 PAGES ONTO DEVICE
2128
2129WRBLK, 0
2130 TAD I IOTHDR /GET FILE HEADER
2131 AND O40 /GET FILE WRITTEN BIT
2132 SNA CLA /HAS THIS BLOCK BEEN CHANGED?
2133 JMP I WRBLK /NO-RETURN
2134 TAD (4210 /"WRITE 2 PAGES"
2135 JMS I [DRCALL /CALL TO DEVICE HANDLER
2136 JMS I (BLZERO
2137 JMP I WRBLK
2138
2139/ROUTINE TO INITIALIZE I/O TABLE ENTRIES AFTER READ OR WRITE
2140
2141BLINIT, 0
2142 TAD I IOTBUF
2143 DCA I IOTPTR /INIT READ/WRITE POINTER
2144 TAD I IOTHDR
2145 AND (7437 /SET CHAR # TO 1 AND CLEAR BLOCK WRITTEN BIT
2146 DCA I IOTHDR
2147 JMP I BLINIT
2148
2149/ROUTINE TO SAVE THE FAC IN FP TEMP
2150
2151FACSAV, 0
2152 JMS I [FFPUT /STORE FAC
2153 INTERB /USE INTERMEDIATE BUFFER FOR TEMP STORAGE
2154 JMP I FACSAV /RETURN
2155
2156 PAGE
2157\f
2158
2159
2160
2161
2162
2163/////////////////////////////////////////////////////////////
2164/////////////////////////////////////////////////////////////
2165//////////// OVERLAY BUFFER 3400-4600 ////////////////////
2166//////////// CONTAINS FUNCTION OVERLAYS ////////////////////
2167//////////// AT RUN TIME ////////////////////
2168/////////////////////////////////////////////////////////////
2169/////////////////////////////////////////////////////////////
2170
2171
2172\f/////////////////////////////////////////////////////////////
2173/////////////////////////////////////////////////////////////
2174////////////// OVERLAY 1-ARITHMETIC FUNCTIONS ///////////////
2175/////////////////////////////////////////////////////////////
2176/////////////////////////////////////////////////////////////
2177
2178 *OVERLAY
2179
2180
2181
2182/INTEGER FUNCTION
2183/RANGE=ALL X
2184
2185INT, VERSON^100+SUBVAF+6000 /INITIALLY CONTAINS VERSION OF ARITH OVERLAY
2186 JMS I [FFPUT /SAVE X
2187 FPPTM1
2188 TAD ACX /GET EXPONENT
2189 SMA SZA CLA /IS EXP<0?
2190 JMP INSC /NO-GO ON
2191 TAD ACH /YES
2192 SPA CLA /IS X<0?
2193 JMP M1R /YES-INT=-1
2194 JMS I [FACCLR /YES-RETURN A 0
2195 JMP I INT
2196INSC, TAD ACH /GET HI MANTISSA
2197 SMA CLA /IS IT <0?
2198 JMP INTPOS /NO-USE FAC AS IS
2199 JMS I [FFNEG /YES-NEGATE FAC (MAKE IT POS)
2200 IAC /AND SET FLAG
2201INTPOS, DCA TEMP3 /FLAG FOR NEGATIVE
2202 DCA TEMP5 /ZERO LORD MASK
2203 CLL CML RAR
2204 DCA TEMP4 /INITIALIZE HORD MASK TO 4000
2205 TAD ACX
2206 CIA /- COUNT
2207 DCA TEMP2
2208MASKL, TAD TEMP4
2209 CLL CML RAR /ROTATE 1'S THROUGH 3 WORD MASK
2210 DCA TEMP4 /
2211 TAD TEMP5 /UNTIL THERE IS A COUNT OF ZERO
2212 RAR
2213 DCA TEMP5
2214 ISZ TEMP2 /DONE?
2215 JMP MASKL /NO
2216 TAD ACH /YES-MASK HORD
2217 AND TEMP4
2218 DCA ACH
2219 TAD ACL /MASK LORD
2220 AND TEMP5
2221 DCA ACL
2222 TAD TEMP3 /NEG FLAG
2223 SNA CLA /WAS ORIGINAL NUMER <0?
2224 JMP I INT /NO-DONE
2225 JMS I [FFPUT /SAVE INT(X)
2226 FPPTM2
2227 JMS I (FFADD /-INT(X)+(X)
2228 FPPTM1
2229 TAD ACH /SAVE HORD
2230 DCA TEMP3
2231 JMS I [FACCLR /FLUSH FAC
2232 TAD TEMP3 /WAS INT(X)=X?
2233 SNA CLA
2234 JMP JUSNEG /YES-JUST NEGATE INT(X)
2235 JMS I (FFADD /NO-ADD 1
2236 ONE
2237JUSNEG, JMS I (FFADD /GET INT(X)
2238 FPPTM2
2239JNEG, JMS I [FFNEG /AND NEGATE (INT(5.3)=-6)
2240 JMP I INT /DONE
2241
2242M1R, JMS I [FFGET /LOAD FAC WITH 1
2243 ONE
2244 JMP JNEG /JUST NEGATE AND RETURN
2245
2246ONE, 1
2247 2000
2248 0
2249
2250\f/EXPONENTIATION FUNCTION
2251/IF B=0,A^B=1
2252/IF A=0 AND B>0,A^B=0
2253/IF A=0 AND B<0,DIVIDE BY ZERO ERROR MESSAGE RESULTS AND A^B=0
2254/IF B=INTEGER > 0, A^B=A*A*A*.......*A
2255/IF B=INTEGER < 0, A^B=1/A*A*A*.......*A
2256/IF B=REAL AND A>0, A^B=EXP(B*LOG(A))
2257/IF B=REAL AND A<0, A FATAL ERROR RESULTS
2258
2259EXPON, 0
2260 JMS I [FFPUT /SAVE A
2261 FPPTM5
2262 JMS I [FFPUT /SET UP RUNNING PRODUCT IN CASE OF
2263 FPPTM4 /MULTIPLIES
2264 TAD ACH /HI ORDER OF A
2265 DCA EXPON /SAVE IT
2266 DCA INSAV /POINTER TO B IN SYMBOL TABLE
2267 JMS I ARGPLL /FIND B
2268 JMS I [FFGET /GET B
2269ARGPLL, ARGPRE /LOC SKIPPED BY FPP,SO WE USE IT FOR CONSTANT
2270 CDF
2271 TAD ACH /HI ORDER OF B
2272 SNA /IS B=0?
2273 JMP I (RETRN1 /YES A^B=1
2274 SMA CLA /IS B<0?
2275 JMP .+4 /NO
2276 TAD EXPON /YES-GET HI ORDER A
2277 SNA CLA /IS A=0?
2278 JMP I (DV /YES-DIVIDE BY ZERO ERROR
2279 TAD EXPON /B>0. IS A=0?
2280 SNA CLA
2281 JMP RET0 /YES A^B=0
2282 JMS I [FFPUT /SAVE B
2283 FPPTM3
2284 JMS INT /GET INT(B)
2285 JMS I (MULLIM /TEST EXPONENT OF RESULT TO LIMIT LARGE MULTIPLY LOOPS
2286 JMS I (FFSUB /INT(B)-B
2287 FPPTM3
2288 TAD ACH /IS INT(B)-B=0?
2289 SZA CLA
2290 JMP I (USELOG /NO-USE LOGS
2291 JMS I [FFGET /NO-USE REPETITIVE MULTIPLY
2292 FPPTM3 /GET B AGAIN
2293 TAD ACH
2294 DCA EXPON /SAVE SIGN OF B
2295 JMS I (ABSVAL /!B!
2296 JMS I [FFPUT /USE ABS(B) AS MULTIPLY COUNT
2297 FPPTM3
2298EMLOOP, JMS I [FFGET /GET B
2299 FPPTM3
2300 JMS I (FFSUB /B-1
2301 ONE
2302 JMS I [FFPUT /SAVE NEW COUNT
2303 FPPTM3
2304 TAD ACH
2305 SNA CLA /IS COUNT ZERO YET
2306 JMP I (EMDONE /YES-MULTIPLIES ARE DONE
2307 JMS I [FFGET /NO-GET RUNNING PRODUCT
2308 FPPTM4
2309 JMS I (FFMPY /MULTIPLY BY A
2310 FPPTM5
2311 JMS I [FFPUT /SAVE NEW RUNNING PRODUCT
2312 FPPTM4
2313 JMP EMLOOP
2314
2315RET0, JMS I [FACCLR /RETURN WITH 0 IN FAC
2316 JMP I [ILOOP
2317
2318 PAGE
2319\fEMDONE, JMS I [FFGET /GET RUNNING PRODUCT
2320 FPPTM4
2321 TAD I EXPONK /GET SIGN OF B
2322 SMA CLA /WAS IT -?
2323 JMP I [ILOOP /NO-A^B=A*A*A*...*A
2324 JMS I FIDVP /YES-INVERT
2325 ONE
2326 JMP I [ILOOP /A^B=1/A:A*A*...*A
2327
2328RETRN1, JMS I [FFGET
2329 ONE /SET FAC TO 1
2330 JMP I [ILOOP
2331
2332USELOG, TAD I EXPONK /SIGN OF A
2333 SPA CLA /A<0?
2334EM, JMS I [ERROR /YES-PRINT A MESSAGE
2335 JMS I [FFGET /LOAD A
2336 FPPTM5
2337 JMS I FFLOGL /LOG(A)
2338 JMS I FMPYLV /B*LOG(A)
2339 FPPTM3
2340 JMS I FFEXPL /EXP(B*LOG(A))
2341 JMP I [ILOOP /DONE
2342
2343
2344FFEXPL, EXPON1
2345FFLOGL, LOG
2346FMPYLV, FFMPY
2347EXPONK, EXPON
2348FIDVP, FFDIV1
2349
2350/SGN FUNCTION
2351
2352SGN, 0
2353 TAD ACH /GET HIGH MANTISSA
2354 SNA /IS X=ZERO?
2355 JMP I [ILOOP /YES-THEN LEAVE IT ALONE
2356 SPA CLA /IS X>0?
2357 JMP .+3 /NO
2358 IAC /YES-SET FAC=1
2359 SKP
2360 CMA /NO-SET FAC=-1
2361 DCA ACX /SET UP FLOAT
2362 JMS I [FFLOAT /FLOAT VALUE OF SGN FUNCTION
2363 JMP I [ILOOP /DONE
2364\f IFZERO EAE <
2365/FLOATING SQUARE ROOT
2366/USES A HARDWARE TYPE ALGORITHM FOR BINARY SQUARE ROOTS
2367/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES-P 409
2368/
2369FROOT, 0
2370 CLA CLL CML RTR /SET RESULT TO 2000;0000
2371 DCA AN1
2372 DCA AN2
2373 CDF /DF TO PACKAGE FIELD
2374 TAD KM22 /SET COUNTER FOR DEVELOPING 22 BITS OF RESULT
2375 DCA AC2 /ALREADY HAVE 1
2376 TAD ACH
2377 SNA
2378 JMP I FROOT /ZERO FAC-NORMALIZED!-RETN. SAME
2379 SPA CLA
2380 JMS I [FFNEG /TAKE ROOT OF ABSOL VALUE
2381 TAD ACX /GET EXPONENT OF FAC
2382 SPA /IF NEGATIVE-MUST PROPAGATE SIGN
2383 CML
2384 RAR /DIVIDE EXP. BY 2
2385 DCA ACX /STORE IT BACK
2386 SZL /INCREMENT EXP. IF ORIGINAL EXP
2387 ISZ ACX /WAS ODD
2388 NOP
2389 SNL /DO A PRE-SHIFT FOR EVEN EXPONENTS
2390 JMS I AL1K /SO FIRST BIT PAIR IS 10 NOT 01
2391 CLA CLL CMA RAL /SET COUNTER FOR DETECTING A
2392 DCA ZCNT /ZERO REMAINDER
2393 CLA CLL CML RTR /SET UP POSITION OF TRIAL BIT
2394 RTR /FOR FIRST PASS THRU LOOP
2395 DCA OPH
2396 DCA OPL
2397 TAD K6000 /GET A FAST FIRST BIT-WE KNOW
2398 TAD ACH /THIS WILL WORK SINCE # IS NORMALIZED
2399 DCA ACH /IF # IS A POWER OF TWO, AND A PERFECT
2400 TAD ACH /SQUARE-WE ARE DONE HERE!
2401 SNA /WELL IS IT?
2402 TAD ACL /COULD BE-CHECK LOW ORDER
2403 SNA CLA
2404 JMP DONE /WHOOPPEE-WE WIN BIG.
2405 JMP LOP01 /NOPE-LOOP DON'T SHIFT FIRST TIME
2406SLOOP, TAD OPH /SHIFT TRIAL BIT 1 PLACE
2407 CLL RAR /TO THE RIGHT
2408 DCA OPH /AND STORE BACK
2409 TAD OPL
2410 RAR
2411 DCA OPL
2412 JMS I AL1K /SHIFT FAC LEFT 1 PLACE
2413LOP01, TAD OPL /ADD TRIAL BIT TO`ANSWER
2414 TAD AN2 /SO FAR
2415 CLL CMA IAC /NEGATE IT
2416 TAD ACL /AND ADD TO FAC (REMAINDER SO FAR)
2417 SNA /IS RESULT ZERO?
2418 ISZ ZCNT /YES-INCREMENT COUNTER
2419 DCA TM /STORE RESULT IN TEMPORARY
2420\f CML RAL /ADD CARRY TO HIGH ORDER FOR SUBTRACT
2421 TAD OPH /ADD TRIAL BIT
2422 TAD AN1 /ADD RESULT SO FAR (HI ORDER)
2423 CLL CMA IAC /AND SUBTRACT FROM HI ORDER FAC
2424 TAD ACH
2425 SNL /RESULT NEGATIVE?
2426 JMP GON /YES-NEXT RESULT BIT IS 0
2427 SZA /NO-IS HI ORDER RESULT=0?
2428 JMP LOP02 /NO-GO ON
2429 ISZ ZCNT /YES-WAS LOW ORDER =0?
2430 JMP .+3 /NO-GO ON
2431 CMA /YES-REM.=0-SET COUNTER SO
2432 DCA AC2 /LOOKS LIKE WE'RE DONE
2433LOP02, DCA ACH /STORE HIGH ORDER REM. IN FAC
2434 TAD TM /STORE LO ORDER REM. IN FAC
2435 DCA ACL
2436 TAD OPL /TRIAL BIT SHIFTED LEFT 1 IS
2437 CLL RAL /RESULT BIT-ADD IT TO ROOT DEVELOPED
2438 TAD AN2 /SO FAR
2439 DCA AN2
2440 TAD OPH
2441 RAL
2442 TAD AN1
2443 DCA AN1
2444GON, CLA CLL CMA RAL /RESET COUNTER FOR ZERO REM.
2445 DCA ZCNT
2446 ISZ AC2 /DONE ALL 23 RESULT BITS?
2447 JMP SLOOP /NO-GO ON
2448DONE, TAD AN1 /YES-STORE ANSWER IN FAC
2449 DCA ACH /ITS NORMALIZED ALREADY
2450 TAD AN2
2451 DCA ACL
2452 JMP I FROOT /AND RETURN
2453
2454K6000, 6000
2455ZCNT, 0
2456AL1K, AL1
2457AN1, 0
2458AN2, 0
2459KM22, -26
2460
2461 PAGE
2462 >
2463\f IFNZRO EAE <
2464/
2465/FLOATING SQUARE ROOT
2466/USES MODIFIED HARDWARE ALGORITHM FOR BINARY SQUARE ROOTS
2467/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES; P-409
2468 *SGN+14
2469FROOT, 0
2470 CLA CLL CML RTR /SET RESLT TO 2000,0000
2471 DCA OPL
2472 DCA OPH
2473 SWAB /MODE B OF EAE-ALSO DOES MQL
2474 CDF
2475 DCA RBCNT /CLR. SHIFT COUNTER
2476 TAD KM22
2477 DCA AC2 /SET COUNTER FOR 23 BITS OF RESULT
2478 TAD ACX /GET EXPONENT OF FAC
2479 ASR /DIVIDE BY 2
2480 1
2481 DCA ACX /STORE IT BACK
2482 DPSZ /INCREMENT EXP. IF ORIG. EXP
2483 ISZ ACX /WAS ODD
2484 NOP
2485 MQA /DETERMINE WHETHER TO DO A
2486 CLL RAL /PRE-SHIFT FOR EVEN EXPONENTS.
2487 CML RAL
2488 DCA RKNT /STORE BIT-0 OR 1 SHIFT CNT
2489 CLL CML RTR /SET UP FIRST TRIAL BIT
2490 RTR
2491 DCA AC1
2492 DCA AC0 /STORE AWAY
2493 DCA ACNT /ZERO COUNTER
2494 DLD /GET THE FAC
2495 ACH
2496 SWP /GET IN RIGHT ORDER
2497 SNA /IS IT ZERO? (HI ORD=0)
2498 JMP I FROOT /YES-ROOT = 0
2499 SPA /NEGATIVE?
2500 DCM /YES-TAKE ABSOL. VALUE
2501 SHL /SHIFT # 1 BIT IF EXP WAS EVEN
2502RKNT, 0 /SO FIRST BIT PAIR IS 10 NOT 01
2503 TAD K6000 /SUBTRACT 2000-KNOW FIRST BIT
2504 DPSZ /IS 1(NORMALIZED)-DONE??
2505 JMP LOP1 /NO-WE MUST LOOP
2506 JMP DONE /YES-AN EASY ONE!!!
2507LOOP, DLD /GET THE FAC
2508 ACH
2509 SHL /SHIFT FAC APPROPRIATELY
2510 1
2511LOP1, DST /MUST STOR BACK IN CASE RESLT
2512 ACH /BIT IS 0
2513 DLD /GET TRIAL BIT
2514 AC0
2515
2516 ASR /SHIFT THE BIT APPROPRIATELY
2517ACNT, 0
2518 ISZ ACNT /SHIFT 1 MORE NEXT TIME
2519 DAD /ADD IN RESULT SO FAR
2520 OPH
2521 DCM /NEGATE IT
2522 ISZ RBCNT /BUMP COUNTER FOR RESLT BIT
2523 DAD /DO THE SUBTRACT
2524 ACH
2525 SNL /RESULT NEGATIVE?
2526 JMP GON /YES-NEXT RESULT BIT = 0
2527
2528 DPSZ /NO-DID WE GET A ZERO REMAINDER?
2529 JMP NOTZRO /NOPE
2530ZREM, CMA /YES-SET SO LOOKS LIKE WE'RE DONE
2531 DCA AC2
2532NOTZRO, DST /GOOD SUBTR.-MODIFY FAC
2533 ACH /ITS NOT CHANGED BY BAD SUBTRACT
2534 CAM /CLEAR EVERYTHING
2535 RTR
2536 ASR /SHIFT RESLT BIT TO RIGHT PLACE
2537RBCNT, 0
2538 DAD /ADD IT TO THE RESULT SO FAR
2539 OPH /WE APPEND IT TO RIGHT OF LAST
2540 DST /BIT
2541 OPH /STORE IT BACK
2542GON, ISZ AC2 /DONE 23 BITS?
2543 JMP LOOP /NO-GO ON
2544DONE, DLD /YES-GET RESULT-ITS NORMALIZED
2545 OPH
2546 DCA ACH /STORE HIGH ORDER BACK
2547 SWP
2548 DCA ACL /STORE LOW ORDER BACK
2549 JMP I FROOT /RETURN
2550KM22, -26
2551K6000, 6000
2552
2553 PAGE
2554 >
2555\f/23-BIT EXTENDED FUNCTIONS
2556
2557/1-31-72 R BEAN
2558
2559/******SINE******
2560
2561SIN, 0
2562 JMS NHNDLE /IF X<0,NEGATE X AND SET NFLAG
2563 JMS I (FFMPY /X*2/PI
2564 TOVPI
2565 JMS FRACT /SAVE X IN TEMP1,THE INTEGER PART OF X IN NUM,AND GET FRACTIONAL PART IN FAC
2566 TAD NUM /GET INTEGER PART OF (2/PI)*X
2567 AND (3 /ISOLATE BITS 10,11
2568 TAD JMPISN
2569 DCA .+1 /MAKE JUMP TO ARGUMENT REDUCING ROUTINE
2570 JMP . /AND ADJUST ARG ACCORDING TO QUADRANT OF X
2571JMPISN, JMP I .+1
2572 POLYSN /X IN QUAD1,SIN(X)=SIN(X)
2573 QUAD2 /X IN QUAD2,SIN(X)=SIN(1-X)
2574 QUAD3 /X IN QUAD3,SIN(X)=SIN(-X)
2575 QUAD4 /X IN QUAD4,SIN(X)=SIN(X-1)
2576
2577QUAD2, JMS I (FFSUB1 /1-X
2578 ONE
2579 JMP POLYSN /CALCULATE SIN(1-X)
2580QUAD3, JMS I [FFNEG /-X
2581 JMP POLYSN /CALCULATE SIN(-X)
2582QUAD4, JMS I (FFSUB /X-1
2583 ONE
2584POLYSN, JMS I [FFPUT /SAVE X
2585 FPPTM1
2586 JMS I (FFSQ /U=X**2
2587 JMS I [FFPUT /SAVE U
2588 FPPTM2
2589 JMS I (FFMPY /A7*U
2590 SINA7
2591 JMS I (FFADD /A5+A7*U
2592 SINA5
2593 JMS I (FFMPY /A5*U+A7*U**2
2594 FPPTM2
2595 JMS I (FFADD /A3+A5(U)+A7(U**2)
2596 SINA3
2597 JMS I (FFMPY /A3(U)+A5(U**2)+A7(U**3)
2598 FPPTM2
2599 JMS I (FFADD /A1+A3(U)+A5(U**2)+A7(U**3)
2600 SINA1
2601 JMS I (FFMPY /A1(X)+A3(X**3)+A5(X**5)+A7(X**7)
2602 FPPTM1
2603 JMS NCHK /IF NFLAG IS SET,SET SIN(X)=-SIN(X)
2604 JMP I SIN /FAC=SIN(X)
2605
2606
2607/******COSINE******
2608/USES SIN ROUTINE TO CALCULATE COS(X)
2609
2610COS, 0
2611 JMS I (FFADD /COS(X)=SIN(PI/2+X)
2612 PIOV2
2613 JMS SIN
2614 JMP I COS /RETURN
2615\f/ROUTINE TO SEPERATE THE INTEGER AND FRACTIONAL PARTS OF FAC
2616/ORIGINAL FAC IS SAVED IN TEMP1,THE INTEGER PORTION OF FAC IS
2617/SAVED AT NUM,AND THE FRACTIONAL FORTION OF THE FAC IS LEFT IN THE FAC
2618
2619FRACT, 0
2620 JMS I [FFPUT /SAVE X
2621 FPPTM1
2622 JMS I (FFIX /INTEGER PORTION OF X
2623 TAD ACX
2624 DCA NUM /SAVE FIXED FORTION OF X
2625 JMS I [FFLOAT /FAC=FLOAT(FIX(X))
2626 JMS I (FFSUB1 /FAC=X-INT(X)=FRACTION (X)
2627 FPPTM1
2628 JMP I FRACT /RETURN
2629
2630/ROUTINE TO CHECK IF FAC<0; IF IT IS,FAC IS NEGATED AND NFLAG IS
2631/SET TO 1
2632
2633NHNDLE, 0
2634 TAD ACH /FETCH HIGH ORDER MANTISSA
2635 SMA CLA /IS IT <0?
2636 JMP NFLGST /NO-CLEAR NFLAG
2637 JMS I [FFNEG /YES-NEGATE FAC
2638 IAC /AND SET NFLAG
2639NFLGST, DCA NFLAG
2640 JMP I NHNDLE
2641
2642/ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0
2643
2644NCHK, 0 /LOC ALSO USED FOR TEMP STORAGE
2645 TAD NFLAG
2646 SZA CLA /IS NFLAG=0?
2647 JMS I [FFNEG /NO-NEGATE FAC
2648 JMP I NCHK /YES-RETURN
2649
2650 NUM=NCHK
2651\f/******EXPONENTIAL******
2652
2653EXPON1, 0 /LOC USED FOR TEMP STORAGE BY SIN,ARCTAN
2654 JMS I (FFMPY /Y=XLOG2(E)
2655 LOG2E
2656 JMS FRACT /GET FRACTIONAL PART OF Y
2657 JMS I (FFMPY /(FRACTION(Y))*(LN2/2)
2658 LN2OV2
2659 JMS I [FFPUT /SAVE Y
2660 FPPTM1
2661 JMS I (FFSQ /Y**2
2662 JMS I (FFADD /B1+Y**2
2663 EXPB1
2664 JMS I (FFDIV1 /A1/(B1+Y**2)
2665 EXPA1
2666 JMS I (FFADD /A0+A1/(B1+Y**2)
2667 EXPA0
2668 JMS I (FFSUB /A0-Y+A1/(B1+Y**2)
2669 FPPTM1
2670 JMS I [FFPUT /SAVE
2671 FPPTM2
2672 JMS I [FFGET /GET Y
2673 FPPTM1
2674 ISZ ACX /MULT. BY 2=2Y
2675 NOP
2676 JMS I (FFDIV /2Y/(A0-Y+A1/(B1+Y**2))
2677 FPPTM2
2678 JMS I (FFADD /1+2Y/(AO-Y+A1/(B1+Y**2))
2679 ONE
2680 JMS I (FFSQ /[1+2Y/(A0-Y+A1/(B1+Y**2))]**2=EXP(Y)
2681 TAD NUM
2682 TAD ACX /EXP(X)=(2**N)(EXPY)
2683 DCA ACX
2684 JMP I EXPON1 /FAC=EXPON(X)
2685
2686 NFLAG=EXPON1
2687
2688/CONSTANT THAT WOULDN'T FIT ELSEWHERE
2689TOVPI, 0 /.6366198
2690 2427
2691 6302
2692
2693MULLIM, 0
2694 TAD ACX /CHECK IF NUMBER OF MULTIPLIES IS TOO LARGE
2695 SPA
2696 CLA /RETURN IF EXPONENT IS NEGATIVE (WE'LL USE LOGS)
2697 TAD (-4 /ONLY A ROUGH ROUGH LIMIT ON THE EXPONENT
2698 SPA SNA CLA /SKP IF NUMBER GT 15 APPROX
2699 JMP I MULLIM /NO, CONTINUE
2700 JMP I (USELOG /YES, USE LOG INSTEAD
2701
2702 PAGE
2703\f/******ARC TANGENT******
2704
2705ATAN, 0
2706 JMS I NHNDLL /IF X<0,SET NFLAG AND NEGATE
2707 JMS I [FFPUT /SAVE X
2708 FPPTM1
2709 JMS I FSUBM /X-1
2710 ONE
2711 TAD ACH /GET HI MANTISSA
2712 SPA CLA /WAS X>1?
2713 JMP ARGPOL /NO-CLEAR GT1FLG
2714 JMS I [FFGET /YES-ATAN(X)=PI/2-ATAN(1/X)
2715 ONE
2716 JMS I FDIVM /1/X
2717 FPPTM1
2718 JMS I [FFPUT
2719 FPPTM1
2720 IAC /SET GT1FLG
2721ARGPOL, DCA GT1FLG
2722 JMS I [FFGET /GET X OR 1/X
2723 FPPTM1
2724 JMS I FSQRM /Y**2
2725 JMS I [FFPUT /SAVE
2726 FPPTM2
2727 JMS I FADDM /Y**2+B3
2728 ATANB3
2729 JMS I FDIV1M /A3/(Y**2+B3)
2730 ATANA3
2731 JMS I FADDM /B2+A3/(Y**2+B3)
2732 ATANB2
2733 JMS I FADDM /Y**2+B2+A3/(Y**2+B3)
2734 FPPTM2
2735 JMS I FDIV1M /A2/(Y**2+B2+A3/(Y**2+B3))
2736 ATANA2
2737 JMS I FADDM /B1+A2/(Y**2+B2+A3/(Y**2+B3))
2738 ATANB1
2739 JMS I FADDM /Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))
2740 FPPTM2
2741 JMS I FDIV1M /A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
2742 ATANA1
2743 JMS I FADDM /B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
2744 ATANB0
2745 JMS I FMPYM /ATAN(Y)=X*(B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))))
2746 FPPTM1
2747 TAD GT1FLG /WAS X>1?
2748 SNA CLA
2749 JMP NGT /NO-TEST IF X<0?
2750 JMS I FSUB1M /ATAN(X)=PI/2-ATAN(1/X)
2751 PIOV2
2752NGT, JMS I NCHKL /IF NFLAG SET,NEGATE FAC
2753 JMP I ATAN /FAC=ATAN(X)
2754NHNDLL, NHNDLE
2755NCHKL, NCHK
2756\f/******NAPERIAN LOGARITHM******
2757
2758 GTFLG=ATAN
2759
2760LOG, 0
2761 TAD ACH
2762 SPA SNA /X<0 OR X=0?
2763 JMP I ARTRAP /YES-TAKE ILLEGAL ARGUMENT TRAP
2764 CLL RTL
2765 SNA /NO-HORD=2000?
2766 TAD ACX /YES-EXP=1?
2767 CMA IAC
2768 IAC
2769 SNA
2770 TAD ACL /YES-LORD=0?
2771 SZA CLA
2772 JMP POLYNL /NO-ARG IS LEGAL AND NOT 1
2773 DCA ACX
2774 DCA ACL
2775LTRPRT, DCA ACH
2776 JMP I LOG /YES-LOG(1)=0
2777POLYNL, TAD ACX
2778 DCA GTFLG /SAVE EXPONENT FOR LATER
2779 DCA ACX /ISOLATE MANTISSA IN FAC
2780 JMS I [FFPUT /SAVE F
2781 FPPTM1
2782 JMS I FADDM /F+SQR(.5)
2783 SQRP5
2784 JMS I [FFPUT /SAVE
2785 FPPTM2
2786 JMS I [FFGET
2787 FPPTM1
2788 JMS I FSUBM /F-SQR(.5)
2789 SQRP5
2790 JMS I FDIVM /Z=F+SQR(.5)/F-SQR(.5)
2791 FPPTM2
2792 JMS I [FFPUT
2793 FPPTM1
2794 JMS I FSQRM /Z**2
2795 JMS I [FFPUT
2796 FPPTM2
2797 JMS I FMPYM /C5(Z**2)
2798 LOGC5
2799 JMS I FADDM /C3+C5(Z**2)
2800 LOGC3
2801 JMS I FMPYM /C3(Z**2)+C5(Z**4)
2802 FPPTM2
2803 JMS I FADDM /C1+C3(Z**2)+C5(Z**4)
2804 LOGC1
2805 JMS I FMPYM /C1(Z)+C3(Z**3)+C5(Z**5)
2806 FPPTM1
2807 JMS I FSUBM /C1(Z)+C3(Z**3)+C5(Z**5)-1/2=LOG2(F)
2808 ONEHAF
2809 JMS I [FFPUT /SAVE LOG2(F)
2810 FPPTM2
2811 TAD GTFLG /I
2812 DCA ACX /SET UP FLOAT
2813 JMS I [FFLOAT
2814 JMS I FADDM /I+LOG2(F)
2815 FPPTM2
2816 JMS I FMPYM /[I+LOG2(F)]*LOGE(2)=LOGE(X)
2817 LN2
2818 JMP I LOG /FAC=LN(X)
2819
2820 GT1FLG=LOG
2821FMPYM, FFMPY
2822FADDM, FFADD
2823FDIVM, FFDIV
2824FDIV1M, FFDIV1
2825FSUBM, FFSUB
2826FSUB1M, FFSUB1
2827FSQRM, FFSQ
2828ARTRAP, LM
2829/CONSTANTS USED BY VARIOUS FUNCTIONS
2830
2831SINA1, 1 /1.5707949
2832 3110
2833 3747
2834SINA3, 0 /-.64592098
2835 5325
2836 1167
2837SINA5, 7775 /.07948766
2838 2426
2839 2466
2840SINA7, 7771 /-.004362476
2841 5610
2842 3164
2843PIOV2, 1 /1.5707963
2844 3110
2845 3756
2846LOG2E, 1 /1.442695
2847 2705
2848 2434
2849LN2OV2, 7777 /.34657359
2850 2613
2851 4415
2852EXPB1, 6 /60.090191
2853 3602
2854 7054
2855EXPA1, 12 /-601.80427
2856 5514
2857 3104
2858EXPA0, 4 /12.015017
2859 3001
2860 7301
2861ATANB0, 7776 /.17465544
2862 2626
2863 6157
2864ATANA1, 2 /3.7092563
2865 3553
2866 1071
2867ATANB1, 3 /6.762139
2868 3303
2869 670
2870ATANA2, 3 /-7.10676
2871 4344
2872 5267
2873ATANB2, 2 /3.3163354
2874 3241
2875 7554
2876ATANA3, 7777 /-.26476862
2877 5703
2878 4040
2879ATANB3, 1 /1.44863154
2880 2713
2881 3140
2882SQRP5, 0 /.7071068
2883 2650
2884 1170
2885LOGC1, 2 /2.8853913
2886 2705
2887 2440
2888LOGC3, 0 /.9614706
2889 3661
2890 566
2891LOGC5, 0 /.59897865
2892 2312
2893 5525
2894ONEHAF, 0 /.5
2895 2000
2896 0
2897LN2, 0 /.6931472
2898 2613
2899 4415
2900\f *4500
2901
2902 /******FIX******
2903/ROUTINE TO FIX ANY FLOATING NUMBER IN FAC BETWEEN -2047 AND +2047 TO
2904/A TWELVE BIT INTEGER AND LEAVE RESULT IN EXP (LOC 44)
2905
2906FFIX, 0
2907 CLA
2908 TAD ACX /FETCH EXPONENT
2909 SZA SMA /IS NUMBER <1?
2910 JMP .+3 /NO-CONTINUE ON
2911FTRPRT, CLA
2912 JMP FIXDNE+1 /YES-FIX IT TO ZERO
2913 TAD (-13 /SET BINARY POINT AT 11
2914 SNA /PLACES TO RIGHT OF CURRENT POINT?
2915 JMP FIXDNE /NO-NUMBER IS ALREADY FIXED THEN.
2916 SMA /YES-IS NUMBER TOO LARGE TO FIX?
2917 JMP I (FO /YES-TAKE OVERFLOW TRAP
2918 DCA ACX /NO-SET SCALE COUNT
2919FIXLP, CLL /0 IN LINK
2920 TAD ACH /GET HIGH MANTISSA
2921 SPA /IS IT <0?
2922 CML /YES-PUT A 1 IN LINK
2923 RAR /SCALE RIGHT
2924 DCA ACH /SAVE
2925 ISZ ACX /DONE YET?
2926 JMP FIXLP /NO
2927FIXDNE, TAD ACH /YES-ANSWER IN AC
2928 DCA ACX /RETURN WITH ANSWER IN 44
2929 JMP I FFIX /RETURN
2930
2931/******FLOAT******
2932/ROUTINE TO FLOAT ANY INTEGER IN EXP (LOC 44) INTO FAC
2933
2934FFLOAT, 0
2935 TAD ACX
2936 DCA ACH /PUT NUMBER IN HI MANTISSA
2937 DCA ACL /CLEAR LOW MANTISSA
2938 TAD (13 /11(10) INTO EXPONENT
2939 DCA ACX
2940 JMS I [FFNOR /NORMALIZE
2941 JMP I FFLOAT /RETURN
2942\f/RANDOM NUMBER GENERATOR
2943
2944RND, 0
2945 TAD I (RSEED /GET SEED
2946 DCA TEMP3 /PUT IN MULTIPLY OPERAND
2947 TAD (73
2948 JMS I [MPY /MULTIPLY SEED BY 73
2949 DCA I (RSEED /USE LOW ORDER 12 BITS AS NEW SEED
2950 TAD I (RSEED /LOW ORDER OF PRODUCT ALSO SERVES
2951 CLL RAR /AS RANDOM NUMBER
2952 DCA ACH /SET SIGN TO 0 AND STORE AS HORD
2953 DCA ACX
2954 RAR
2955 DCA ACL /USE 12 BITS AS MANTISSA
2956 DCA AC1 /CLEAR FPP OVERFLOW
2957 JMS I [FFNOR /AND NORMALIZE
2958 JMP I [ILOOP /DONE
2959
2960 PAGE
2961\f /FLOATING POINT OUTPUT ROUTINE
2962 /CONVERT INTERNAL NUMBER TO ASCII
2963 /EXIT WITH CHAR STRING IN 'INTERB'
2964 /XR1 = POINTER TO LAST CHAR STORED
2965
2966FFOUT, 0
2967 TAD (INTERB-1
2968 DCA XR1 /SET POINTER TO ASCII BUFFER
2969 TAD ACH /SEE IF FAC NEGATIVE
2970 SMA CLA
2971 JMP OKPOS /JMP IF POSITIVE
2972 JMS I [FFNEG /TAKE ABS VALUE IF NEGATIVE
2973 TAD ("- /PRINT MINUS SIGN
2974 SKP
2975OKPOS, TAD (240 /PRINT SPACE IF POSITIVE
2976 DCA I XR1
2977 TAD ACH /SEE IF NUMBER IS ZERO
2978 SNA CLA
2979 JMP ZERXIT /SPECIAL CASE IF SO
2980 JMS I (CVTNUM /CALL ROUTINE TO UNPACK TO BASE 10
2981 TAD (NUMBUF-1
2982 DCA XR2 /POINT XR2 AT DIGIT BUFFER
2983 TAD (5 /TEST FORMAT TO USE
2984 TAD DECEXP
2985 CLL
2986 TAD (-4
2987 SNL
2988 JMP SMLFMT /JMP IF .0NNNNNN TO .0000NNNNNN
2989 TAD (-7
2990 SZL CLA
2991 JMP REGFMT /JMP IF .NNNNNN TO NNNNNN
2992 /OTHERWISE USE E FORMAT N.NNNNNE+NNN OR N.NNNNNE-NNN
2993 TAD I XR2 /GET DIGIT TO LEFT OF POINT
2994 JMS PUTD /PUT IT OUT
2995 TAD (".
2996 DCA I XR1 /NOW SEND OUT DECIMAL POINT
2997 TAD (-5
2998 DCA AC2 /DO 5 MORE DIGITS
2999 TAD I XR2 /PICK UP DIGIT
3000 JMS PUTD /CONVERT TO ASCII AND STORE
3001 ISZ AC2
3002 JMP .-3 /LOOP FOR MORE
3003 TAD ("E /PRINT E
3004 DCA I XR1
3005/ CLL
3006 TAD DECEXP /TAKE ABS(DECEXP)
3007 SPA
3008 CML CIA
3009 DCA DECEXP
3010 RTL /CONVERT "+" TO "-" IF NEGATIVE
3011 TAD ("+
3012 DCA I XR1
3013 JMS IDIV /PRINT 3 DIGITS OF EXPONENT NOW
3014 -144
3015 JMS IDIV
3016 -12
3017 TAD DECEXP
3018 JMS PUTD
3019 JMP I FFOUT /ALL DONE --RETURN--
3020\f /HANDLE .0NNNNNN TO .0000NNNNNN
3021
3022SMLFMT, DCA AC0 /STORE NUMBER OF LEADING ZEROES
3023 TAD (". /PUT OUT DECIMAL POINT
3024 DCA I XR1
3025 JMS PUTD /SEND A 0
3026 ISZ AC0
3027 JMP .-2 /LOOP FOR LEADING 0'S
3028
3029 /GENERAL NON E FORMAT .NNNNNN TO NNNNNN
3030
3031REGFMT, TAD (-7
3032 DCA AC1 /INIT COUNT OF NONZERO DIGITS
3033 TAD (NUMBUF+6
3034 DCA AC2 /POINT AT END OF DIGIT BUFFER
3035SHRINK, STA /DECREMENT DIGIT POINTER
3036 TAD AC2
3037 DCA AC2
3038 ISZ AC1 /REDUCE SIGNIFICANT DIGIT COUNT
3039 TAD DECEXP
3040 IAC
3041 TAD AC1
3042 SMA CLA
3043 JMP PRTLP /JMP OUT IF NOT TO RIGHT OF DECIMAL POINT
3044 TAD I AC2 /ELSE LOOK AT DIGIT
3045 SNA CLA
3046 JMP SHRINK /DISCARD IT IF ZERO
3047PRTLP, STA
3048 TAD DECEXP
3049 DCA DECEXP /SEE IF DIGIT TO BE PRINTED FOLLOWS DP
3050 AC0002
3051 TAD DECEXP
3052 SZA CLA
3053 JMP NODP /NO
3054 TAD (". /YES, PRINT DP
3055 DCA I XR1
3056NODP, TAD I XR2 /PICK UP DECIMAL DIGIT
3057 JMS PUTD /PUT OUT
3058 ISZ AC1
3059 JMP PRTLP /JMP IF MORE DIGITS TO PRINT
3060 JMP I FFOUT /--RETURN--
3061
3062ZERXIT, JMS PUTD
3063 JMP I FFOUT /--RETURN--
3064
3065 /DIVIDE DECEXP BY -DIVISOR IN CALL+1
3066
3067IDIV, 0
3068 DCA AC1 /CLEAR QUOTIENT
3069IDIVLP, TAD DECEXP
3070 TAD I IDIV
3071 SPA
3072 JMP IDVOUT /JMP OUT IF LESS THAN DIVISOR
3073 DCA DECEXP /ELSE UPDATE IT
3074 ISZ AC1 /TALLY QUOTIENT
3075 JMP IDIVLP /ITERATE
3076IDVOUT, CLA
3077 TAD AC1 /GET QUOT AS NEXT DIGIT
3078 JMS PUTD /PUT OUT
3079 ISZ IDIV
3080 JMP I IDIV
3081
3082 /CONVERT NUMBER IN AC TO ASCII DIGIT
3083 /MUST NOT TOUCH THE LINK
3084
3085PUTD, 0
3086 TAD ("0 /ADD IN 0
3087 DCA I XR1 /STORE IN BUFFER
3088 JMP I PUTD
3089
3090 PAGE
3091\f /CONVERT NUMBER IN FAC TO FORMAT N.NNNNNE NNN
3092 /DECIMAL EXPONENT RETURNED AS SIGNED NUMBER IN DECEXP
3093 /6 DIGITS STORED IN NUMBUF AS BINARY 0-9
3094 /FIRST REDUCES MANTISSA TO FORM 0DD DDF FFF FFF...
3095 /BY SUCCESSIVE MULTIPLIES OR DIVIDES BY 10. FOLLOWED BY
3096 /RENORMALIZATIONS UNTIL INTIGER BITS
3097 /DDDD ARE LT 10.
3098 /DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10.
3099
3100CVTNUM, 0
3101 DCA AC1 /CLEAR OVERFLOW WORD
3102 SKP /SKP IN AND CLEAR DECIMAL EXPONENT
3103ADJDEC, TAD DECEXP
3104 DCA DECEXP /STORE UPDATED DECIMAL EXPONENT
3105NORML, TAD ACH /SEE IF FRACTION IS NORMALIZED
3106 RAL
3107 SPA CLA
3108 JMP NORMED /JMP IF YES
3109 JMS I (AL1 /SHIFT AC LEFT 1 BIT
3110 STA
3111 TAD ACX /COMPENSATE BINARY EXPONENT
3112 DCA ACX
3113 JMP NORML /TRY AGAIN
3114NORMED, TAD ACX /RANGE CHECK BINARY EXPONENT NOW
3115 SMA SZA
3116 JMP DIVCHK /JMP IF NUMBER GE 1
3117 TAD O4
3118 DCA ACX /INCREASE BINARY EXP TOWARDS ZERO
3119 JMS AR1 /SHIFT 4 BITS RIGHT
3120 JMS AR1 /MAX RELATIVE ERROR WILL BE LT 15*2^-34 PER MULTIPLY
3121 JMS AR1
3122 JMS AR1
3123 JMS MPY10 /NOW MULTIPLY BY 10.
3124 STA /DECREASE DECIMAL EXPONENT
3125 JMP ADJDEC /RENORMALIZE AND TRY AGAIN
3126
3127DIVCHK, TAD (-5 /SEE IF EXP GT 4
3128 SPA
3129 JMP INRANG /JMP IF NOT, NUMBER MAY BE IN RANGE
3130DIVGO, CLA CLL
3131 TAD (-40 /SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE)
3132 DCA AC2 /(THE LEN ELEKMAN TECHNIQUE)
3133 /MAX RELATIVE ERROR WILL BE LT 9*2^-34. PER DIVIDE
3134DVLOOP, TAD ACH /SEE IF GE 10.
3135 TAD (5400
3136 SMA
3137 DCA ACH /UPDATE IF YES
3138 CML STA RAL
3139 DCA AC0 /SAVE LOW ORDER BIT
3140 JMS I (AL1 /SHIFT MANTISSA NOW
3141 ISZ AC0 /STORE BIT NOW
3142 ISZ AC1
3143 ISZ AC2 /BUMP COUNT
3144 JMP DVLOOP /ITERATE
3145 TAD ACH /NOW ZERO OUT REMAINDER
3146 AND [377
3147 DCA ACH
3148 IAC /NOW INCREASE DECIMAL EXPONENT
3149 JMP ADJDEC
3150
3151INRANG, DCA AC2 /SET SHIFT COUNTER
3152 SKP
3153 JMS AR1 /SHIFT FAC RIGHT
3154 ISZ AC2
3155 JMP .-2 /LEAVE EFFECTIVE BINARY POINT RIGHT OF ACH BIT 4
3156 TAD ACH /ACH = 0DD DDF FFF FFF (D=DECIMAL DIGIT BITS)
3157 TAD (5400 /SEE IF DDDD GE 10
3158 SMA CLA
3159 JMP DIVGO /DIVIDE AGAIN (NORMALIZATION WILL WORK)
3160 CLL
3161 TAD AC1 /NOW ROUND BY ADDING 0.000005
3162 TAD (4761
3163 DCA AC1
3164 IAC /ADD 24761 TO LOW BITS
3165 RAL
3166 TAD ACL
3167 DCA ACL
3168 SZL
3169 ISZ ACH
3170 TAD ACH
3171 TAD (5400 /SEE IF CARRY INTO 9.XXX...
3172 SZA CLA
3173 JMP CVT10 /JMP IF NO
3174 TAD [200 /ELSE SET TO 1.00000
3175 DCA ACH
3176 DCA ACL
3177 DCA AC1
3178 ISZ DECEXP /AND BUMP DECIMAL EXPONENT
3179O4, 4 /EFFECTIVE NOP
3180
3181 /NOW CONVERT TO DECIMAL DIGITS
3182
3183CVT10, TAD (-6 /DO 6 DIGITS
3184 DCA AC0
3185 TAD (NUMBUF-1
3186 DCA XR3
3187 JMP CVTGO /FIRST DIGIT IS ALREADY IN
3188CVTLP, TAD ACH /ZERO OUT PREV DIGIT
3189 AND [177
3190 DCA ACH
3191 JMS MPY10 /MULTIPLY BY 10.
3192CVTGO, TAD ACH /GET DIGIT FROM 0DD DDF FFF FFF
3193 RTL
3194 RTL
3195 RTL
3196 AND [17
3197 DCA I XR3 /STORE IT
3198 ISZ AC0
3199 JMP CVTLP /LOOP IF MORE
3200 JMP I CVTNUM /--RETURN--
3201
3202 /MULTIPLY ACH,,ACL,,AC1 BY 10.
3203
3204MPY10, 0
3205 TAD ACH
3206 DCA OPH /COPY AC TO OP
3207 TAD ACL
3208 DCA OPL
3209 TAD AC1
3210 DCA AC2
3211 JMS I (AL1 /N*2
3212 JMS I (AL1 /N*4
3213 JMS I (OADD /N*5
3214 JMS I (AL1 /N*10.
3215 JMP I MPY10
3216
3217 /SHIFT FAC RIGHT 1 BIT
3218
3219AR1, 0
3220 TAD ACH
3221 CLL RAR
3222 DCA ACH
3223 TAD ACL
3224 RAR
3225 DCA ACL
3226 TAD AC1
3227 RAR
3228 DCA AC1
3229 JMP I AR1 /DONE
3230
3231 PAGE
3232\f IFZERO EAE <
3233
3234/FLOATING POINT INPUT ROUTINE
3235
3236FFIN, 0
3237 CLA CMA
3238 DCA I FDVPT /INITIALIZE PERIOD SWITCH TO -1
3239 CMA /SET SIGN SWITCH TO -1
3240 DCA SIGNF
3241 CDF /DF TO PACKAGE FIELD
3242 DCA DSWIT /ZERO CONVERSION SWITCH
3243DECONV, DCA ACX /ZERO OUT THE FAC!
3244 DCA ACL
3245P200, 200
3246 DCA ACH
3247DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT.
3248DECON, JMS GCHR /GET A CHAR.FROM TTY.
3249 JMP FFIN1 /TERMINATOR-
3250 ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH
3251 ISZ DNUMBR /BUMP # OF DIGITS-# IS STORED IN
3252 JMS I FMPYLL /"FMPY TEN"
3253 TEN
3254 JMS I [FFPUT /"FPUT I TM3PT"
3255 FPPTM1
3256 JMS I [FFGET /"FGET TP"
3257 TP
3258 JMS I [FFNOR /"FNOR"
3259 JMS I FADDLL /"FADD I TM3PT"
3260 FPPTM1
3261 JMP DECON /GO ON
3262FFIN1, ISZ I FDVPT /HAVE WE HAD A PERIOD YET?
3263 JMP FIGO2 /YES-GO ON
3264 ISZ TP1 /NO-IS THIS A PERIOD?
3265 ISZ TP1
3266 SKP CLA
3267 JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT.
3268 /AND GO CONVERT REST
3269 DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF
3270 /DIGITS AFTER DECIMAL POINT.
3271FIGO2, ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?)
3272 JMS I FFNEGP /YES-NEGATE IT
3273 CLA CMA /RESET SIGN SWITCH FOR EXP.
3274 DCA SIGNF
3275 TAD CHAR /NO-WAS THE TERMINATOR AN 'E'?
3276 TAD KME
3277 SNA CLA
3278GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT
3279 JMP EDON /END OF EXPONENT
3280 TAD TM /GOT DIG. OF EXP-STORED IN TP1
3281 CLL RTL /MULT. ACCUMULATED EXP BY 10
3282 TAD TM
3283 CLL RAL
3284 TAD TP1 /ADD DIGIT
3285 JMP GETE /CONTINUE
3286\fEDON, TAD TM /GET EXPONENT
3287 ISZ SIGNF /WAS EXPONENT NEGATIVE?
3288 CMA IAC /YES-NEGATE IT
3289 CMA IAC /AND CALC. DNUMBR - EXPON.
3290 TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN
3291 CLL CMA IAC
3292 SPA /RESULT POSITIVE?
3293 CLL CMA CML IAC /NO-MAKE POS. AND SET LINK
3294 CMA /NEGATE FOR COUNTER
3295 DCA DNUMBR /AND STORE
3296 RAL /LINK=1-DIV;=0-MUL. # BY TEN
3297 TAD MDV /FORM CORRECT INSTRUCTION
3298 DCA SIGNF /AND STORE FOR EXECUTION
3299FCNT, ISZ DNUMBR /DONE ALL OPERATIONS?
3300 JMP SIGNF /NO
3301 JMP I FFIN /YES-RETURN
3302SIGNF, 0 /NO- MUL OR DIV. MANTISSA
3303 TEN /BY TEN
3304 JMP FCNT /GO ON
3305FFNEGP, FFNEG
3306DNUMBR, 0
3307KME, -305
3308MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER
3309FMPYLL, FFMPY
3310FDVPT, FFDIV /!!!!!!!!!!!!!!!!!
3311FADDLL, FFADD
3312
3313KK12, 12
3314TP, 13
3315TP1, 0
3316 0
3317TEN, 4
3318 2400
3319 0
3320\f/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
3321/OR A TERMINATOR.
3322/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
3323/THIS ROUTINE MUST NOT MODIFY THE MQ!!
3324GCHR, 0
3325 DCA TM /STORE ACCUMULATED EXPONENT (MAYBE)
3326 JMS INPUT /GET A CHAR FROM TTY.
3327 TAD CHAR /PICK IT UP
3328 TAD PLUS /WAS IT PLUS SIGN?
3329 SNA
3330 JMP DECON1 /YES-GET ANOTHER CHAR.
3331 TAD MINUS /NO WAS IT MINUS SIGN?
3332 SZA CLA
3333 JMP .+3
3334 DCA SIGNF /YES-FLIP SWITCH
3335DECON1, JMS INPUT /GET A CHAR.
3336 TAD CHAR
3337 TAD K7506 /SEE IF ITS A DIGIT
3338 CLL
3339 TAD KK12
3340 DCA TP1 /STORE FOR LATER
3341 SZL /DIGIT?
3342 ISZ GCHR /YES-RETN. TO CALL+2
3343 JMP I GCHR /NO-RETN. TO CALL+1
3344K7506, 7506
3345/
3346/INPUT ROUTINE-IGNORES LEADING SPACES
3347/
3348INPUT, 0
3349 JMS I IGETCH /USE OUR ROUTINE TO GET CHAR
3350 TAD DSWIT /GET TERMINATOR
3351 SZA CLA /VALID INPUT YET?
3352 JMP IOUT /YES-CONTINUE
3353 TAD CHAR /NO-GET CHAR
3354 TAD M240 /COMPARE AGAINST SPACE
3355 SZA /SKP IF SPACE
3356 TAD (240-212 /COMPARE TO LF
3357 SNA CLA /IS IT A SPACE OR LF?
3358 JMP INPUT+1 /YES-IGNORE IT
3359IOUT, JMP I INPUT /RETURN
3360IGETCH, GETCH /POINTER TO GET CHAR ROUTINE
3361 /ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL)
3362M240, -240
3363PLUS, -253
3364MINUS, 253-255
3365/
3366/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
3367/
3368PATCHF, 0
3369 SZA /IS AC EMPTY
3370 JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
3371 TAD FF /YES-GET SPECIAL MODE FLIP-FLOP
3372 SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0
3373RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND
3374 JMP I PATCHF /RETURN
3375\f PAGE
3376/
3377/INVERSE FLOATING SUBTRACT-USES FLOATING ADD
3378/!!FSW1!!-THIS IS OP-FAC
3379/
3380FFSUB1, 0
3381 JMS I [PATCHF /WHICH MODE?
3382 TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP.
3383 JMS I ARGETL /GO PICK UP OPERAND
3384 CDF
3385 JMS I FFNEGA /NEGATE FAC
3386 TAD FFSUB1 /AND GO ADD
3387 JMP I SUB0P
3388FFNEGA, FFNEG
3389SUB0P, SUB0
3390/
3391/INVERSE FLOATING DIVIDE
3392/FSWITCH=1
3393/THIS IS OP/FAC
3394/
3395FFDIV1, 0
3396 JMS I [PATCHF /WHICH MODE OF CALL?
3397 TAD I FFDIV1 /CALLED BY USER-GET ADDR.
3398 JMS I ARGETL /PICK UP OPERAND
3399 TAD ACL /SWAP THE FAC AND OPERAND
3400 DCA OPL /THERE IS A POINTER TO OPL
3401 TAD I AC2 /IN AC2 LEFT FROM ARGET SUBR.
3402 DCA ACL
3403 TAD ACX /MIGHT AS WELL SUBTRACT THE
3404 CLL CMA IAC /EXPONENTS HERE (SAVES A WORD)
3405 TAD OPX /THEN ZERO OPX SO WILL NOT
3406 DCA ACX /MESS UP WHEN ITS DONE AGAIN
3407 DCA OPX /LATER (SEE DIV. ROUTINE)
3408 TAD ACH
3409 DCA AC2 /NOW SWAP HIGH ORDER MANTISSAS
3410 TAD OPH
3411 DCA ACH
3412 TAD AC2
3413 DCA OPH
3414 CDF /DF TO PACKAGE FIELD
3415 TAD FFDIV1 /NOW KLUDGE UP A SUBROUTINE LINKAGE
3416 DCA I FFDP
3417 TAD KFD1
3418 DCA I MDSETP
3419 JMP I MD1P /GO SET UP AND DIVIDE
3420
3421MD1P, MD1
3422ARGETL, ARGET
3423MDSETP, MDSET
3424FFDP, FFDIV
3425KFD1, FFD1
3426\f/MDSET-SETS UP SIGNS FOR MULTIPLY AND DIVIDE
3427/ALSO SHIFTS OPERAND ONE BIT TO THE LEFT.
3428/EXIT WITH EXPONENT OF OPERAND IN AC FOR EXPONENT
3429/CALCULATION-CALLED WITH ADDRESS OF OPERAND IN AC AND
3430/DATA FIELD SET PROPERLY FOR OPERAND.
3431/
3432MDSET, 0
3433 JMS I ARGETK /GET ARGUMENT
3434MD1, CDF /DF TO PACKAGE FIELD
3435 CLA CLL CMA RAL /SET SIGN CHECK TO -2
3436 DCA TM
3437 TAD OPH /IS OPERAND NEGATIVE?
3438 SMA CLA
3439 JMP .+3 /NO
3440 JMS I OPNEGP /YES-NEGATE IT
3441 ISZ TM /BUMP SIGN CHECK
3442 TAD OPL /AND SHIFT OPERAND LEFT ONE BIT
3443 CLL RAL
3444 DCA OPL
3445 TAD OPH
3446 RAL
3447 DCA OPH
3448 DCA AC1 /CLR. OVERFLOW WORF OF FAC
3449 TAD ACH /IS FAC NEGATIVE
3450 SMA CLA
3451 JMP LEV /NO-GO ON
3452 JMS I FFNEGK /YES-NEGATE IT
3453 ISZ TM /BUMP SIGN CHECK
3454 NOP /MAY SKIP
3455LEV, TAD OPX /EXIT WITH OPERAND EXPONENT IN AC
3456 JMP I MDSET
3457
3458FFNEGK, FFNEG
3459OPNEGP, OPNEG
3460ARGETK, ARGET
3461
3462/
3463/CONTINUATION OF FLOATING DIVIDE ROUTINE
3464/
3465FD1, TAD AC2 /NEGATE HI ORDER PRODUCT
3466 CLL CMA IAC
3467 TAD ACH /COMPARE WITH REMAINDER OF FIRST DIV.
3468 SNL /WELL?
3469 JMP I DVOPSP /GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
3470 CLL /OK-DO (REM-(Q*OPL))/OPH
3471 DCA ACH /FIRST STORE ADJUSTED PRODUCT
3472 JMS I DV24P /DIVIDE BY OPH (HI ORDER OPERAND)
3473DVL1, TAD AC1 /GET QUOT. OF FIRST DIV.
3474 SMA /IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT
3475 JMP FD /NO-ITS NORMALIZED-DONE
3476 CLL
3477 ISZ ACL
3478 SKP
3479 IAC
3480 RAR
3481 DCA ACH /STORE IN FAC
3482 TAD ACL /P@ LOW ORDER RIGHT
3483 RAR
3484 DCA ACL /STORE BACK
3485 ISZ ACX /BUMP EXPONENT
3486 NOP
3487 TAD ACH
3488 JMP DVL1+1
3489FD, DCA ACH /STORE HIGH ORDER RESULT
3490 JMP I FDDONP /GO LEAVE DIVIDE
3491
3492FDDONP, FDDON /END OF FLTG. DIV. ROUTINE
3493DV24P, DV24 /ROUTINE TO DO A 24X12BIT DIVIDE
3494DVOPSP, DVOPS /ROUTINE TO ADJUST QUOT OF FIRST DIV.
3495/
3496/CONTINUATION OF ROUTINE TO ADJUST QUOT. OF FIRST DIV.
3497/DBAD1 IS ONLY EXECUTED ON DIVIDE OVERFLOW-OTHERWISE THE
3498/ROUTINE STARTS AT DVOP2
3499/
3500DBAD1, DCA ACX /DIVIDE OVERFLO-ZERO ALL
3501DVOP2, SNA /IS IT ZERO?
3502 DCA ACL /YES-MAKE WHOLE THING ZERO
3503 DCA ACH
3504 JMS I DV24P /DIVIDE EXTENDED REM. BY HI DIVISOR
3505 TAD ACL /NEGATE THE RESULT
3506 CLL CMA IAC
3507 DCA ACL
3508 SNL /IF QUOT. IS NON-ZERO, SUBTRACT
3509 CMA /ONE FROM HIGH ORDER QUOT.
3510 JMP DVL1 /GO TO IT
3511
3512 PAGE
3513\f/FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
3514FFMPY, 0
3515 JMS I [PATCHF /WHICH MODE OF CALL?
3516 TAD I FFMPY /CALLED BY USER-GET OPERAND ADDR.
3517 JMS I MDSETK /SET UP FOR MPY-OPX IN AC ON RETN.
3518 TAD ACX /DO EXPONENT ADDITION
3519 DCA ACX /STORE FINAL EXPONENT
3520 DCA DV24 /ZERO TEM STORAGE FOR MPY ROUTINE
3521 DCA AC2
3522 TAD ACH /IS FAC=0?
3523 SNA CLA
3524 DCA ACX /YES-ZERO EXPONENT
3525 JMS MP24 /NO-MULTIPLY FAC BY LOW ORDER OPR.
3526 TAD OPH /NOW MULTIPLY FAC BY HI ORDER MULTIPLIER
3527 DCA OPL
3528 JMS MP24
3529 TAD AC2 /STORE RESULT BACK IN FAC
3530RTZRO, DCA ACL /LOW ORDER
3531 TAD DV24 /HIGH ORDER
3532 DCA ACH
3533 TAD ACH /DO WE NEED TO NORMALIZE?
3534 RAL
3535 SMA CLA
3536 JMP SHLFT /YES-DO IT FAST
3537MDONE, DCA AC1 /NO-ZERO OVERFLOW WD(DO I NEED THIS???)
3538 ISZ FFMPY /BUMP RETURN POINTER
3539 ISZ TM /SHOULD RESULT BE NEGATIVE?
3540 JMP I FFMPY /NOPE-RETN.
3541 JMS I FFNEGR /YES-NEGATE IT
3542 JMP I FFMPY /RETURN
3543SHLFT, CMA /SUBTRACT 1 FROM EXP.
3544 TAD ACX
3545 DCA ACX
3546 JMS I AL1PTR /SHIFT FAC LEFT 1 BIT
3547 JMP MDONE+1 /DONE.
3548AL1PTR, AL1
3549/
3550/24 BIT BY 12 BIT MULTIPLY. MULTIPLIER IS IN OPL
3551/MULTIPLICAND IS IN ACH AND ACL
3552/RESULT LEFT IN DV24,AC2, AND AC1
3553MP24, 0
3554 TAD KKM12 /SET UP 12 BIT COUNTER
3555 DCA OPX
3556 TAD OPL /IS MULTIPLIER=0?
3557 SZA
3558 JMP MPLP1 /NO-GO ON
3559 DCA AC1 /YES-INSURE RESULT=0
3560 JMP I MP24 /RETURN
3561MPLP, TAD OPL /SHIFT A BIT OUT OF LOW ORDER
3562MPLP1, RAR /OF MULTIPLIER AND INTO LINK
3563 DCA OPL
3564 SNL /WAS IT A 1?
3565 JMP MPLP2 /NO-0-JUST SHIFT PARTIAL PRODUCT
3566\f CLL /YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
3567 TAD AC2
3568 TAD ACL /LOW ORDER
3569 DCA AC2
3570 RAL /PROPAGATE CARRY
3571 TAD ACH /HI ORDER
3572MPLP2, TAD DV24
3573 RAR /NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
3574 DCA DV24
3575 TAD AC2
3576 RAR
3577 DCA AC2
3578 RAR /1 BIT OF OVERFLOW TO AC1
3579 DCA AC1
3580 ISZ OPX /DONE ALL 12 MULTIPLIER BITS?
3581 JMP MPLP /NO-GO ON
3582 JMP I MP24 /YES-RETURN
3583/
3584/PART OF DIVIDE ROUTINE-FFDIV MUST BE AT LOC. 6722
3585MP12L, DCA OPL /STORE BACK MULTIPLIET
3586 TAD AC2 /GET PRODUCT SO FAR
3587 SNL /WAS MULTIPLIER BIT A 1?
3588 JMP .+3 /NO-JUST SHIFT THE PARTIAL PRODUCT
3589 CLL /YES-CLEAR LINK AND ADD MULTIPLICAND
3590 TAD ACL /TO PARTIAL PRODUCT
3591 RAR /SHIFT PARTIAL PRODUCT-THIS IS HI ORDER
3592 DCA AC2 /RESULT-STORE BACK
3593DVLP1, TAD OPL /SHIFT A BIT OUT OF MULTIPLIER
3594 RAR /AND A BIT OR RESLT. INTO IT (LO ORD. PROD.)
3595 ISZ FFMPY /DONE ALL BITS?
3596 JMP MP12L /NO-LOOP BACK
3597 CLL CMA IAC /YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
3598 DCA ACL /NEGATE AND STORE
3599 CML RAL /PROPAGATE CARRY
3600 JMP I FD1P /GO ON
3601FD1P, FD1 /POINTER TO REST OF DIVIDE ROUTINE
3602/
3603/FLOATING DIVIDE ROUTINE
3604/USES THE METHOD OF TRIAL DIVISION BY HI ORDER
3605FFDIV, 0 /(USED AS A TEM. BY I/O ROUTINES)
3606 JMS I [PATCHF /WHICH MODE OF CALL?
3607 TAD I FFDIV /CALLED BY USER-GET ARG. ADDR.
3608 JMS I MDSETK /GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
3609FFD1, CMA IAC /NEGATE EXP. OF OPERAND
3610 TAD ACX /ADD EXP OF FAC
3611 DCA ACX /STORE AS FINAL EXPONENT
3612 TAD OPH /NEGATE HI ORDER OP. FOR USE
3613 CLL CMA IAC /AS DIVISOR
3614 DCA OPH
3615 JMS DV24 /CALL DIV.--(ACH+ACL)/OPH
3616 TAD ACL /SAVE QUOT. FOR LATER
3617 DCA AC1
3618 TAD KM13 /SET COUNTER FOR 12 BIT MULTIPLY
3619 DCA FFMPY /TO MULTIPLY QUOT. OF DIV. BY
3620 JMP DVLP1 /LOW ORDER OF OPERAND (OPL)
3621\f/
3622/END OF FLOATING DIVIDE-FUDGE SOME
3623/STUFF THEN JUMP INTO MULTIPLY
3624/
3625FDDON, TAD FFDIV /STORE RETN. ADDR. IN MULT ROUTINE
3626 DCA FFMPY
3627 JMP MDONE /GO CLEAN UP
3628/
3629/DIVIDE ROUTINE--24 BITS IN ACH,ACL ARE DIVIDED BY 12 BITS
3630/IN OPH. OPH IS ASSUMED NEGATIVE AND .GT. ACH IN ABSOLUTE VALUE
3631/ELSE-DIVIDE OVERFLOW--WE RETURN NORMALLY WITH QUOTIENT
3632/IN ACL AND REM. IN ACH. (AC2=0 ON RETN.)
3633/
3634DV24, 0
3635 TAD ACH /CHECK THAT DIVISOR IS .GT. DIVIDEND
3636 TAD OPH /DIVISOR IN OPH (NEGATIVE)
3637 SZL CLA /IS IT?
3638 JMP I DVOVR /NO-DIVIDE OVERFLOW
3639 TAD KM13 /YES-SET UP 12 BIT LOOP
3640 DCA AC2
3641 JMP DV1 /GO BEGIN DIVIDE
3642DV2, TAD ACH /CONTINUE SHIFT OF FAC LEFT
3643 RAL
3644 DCA ACH /RESTORE HI ORDER
3645 TAD ACH /NOW SUBTRACT DIVISOR FROM HI ORDER
3646 TAD OPH /DIVIDEND
3647 SZL /GOOD SUBTRACT?
3648 DCA ACH /YES-RESTORE HI DIVIDEND
3649 CLA /NO-DON'T RESTORE--OPH.GT.ACH
3650DV1, TAD ACL /SHIFT FAC LEFT 1 BIT-ALSO SHIFT
3651 RAL /1 BIT OF QUOT. INTO LOW ORD OF ACL
3652 DCA ACL
3653 ISZ AC2 /DONE 12 BITS OF QUOT?
3654 JMP DV2 /NO-GO ON
3655 JMP I DV24 /YES-RETN W/AC2=0
3656FFNEGR, FFNEG
3657MDSETK, MDSET
3658KKM12, -14
3659KM13, -15
3660DVOVR, DV
3661
3662 PAGE
3663\f/
3664/FLOATING ADD
3665/
3666FFADD, 0
3667 JMS I [PATCHF /WHICH MODE FO CALL?
3668 TAD I FFADD /CALLED BY USER-GET ADDR. OF OPR.
3669 JMS I ARGETP /PICK UP OPERAND
3670FAD1, CDF /DF TO PACKAGE FIELD
3671 TAD OPH /IS OPERAND = 0
3672 SNA CLA
3673 JMP DONA /YES-DONE
3674 TAD ACH /NO-IS FAC=0?
3675 SNA CLA
3676 JMP DOADD /YES-DO ADD
3677 TAD ACX /NO-DO EXPONENT CALCULATION
3678 CLL CMA IAC
3679 TAD OPX
3680 SMA SZA /WHICH EXP. GREATER?
3681 JMP FACR /OPERANDS-SHIFT FAC
3682 CMA IAC /FAC'S-SHIFT OPERAND=DIFFRNCE+1
3683 JMS OPSR
3684 JMS ACSR /SHIFT FAC ONE PLACE RIGHT
3685DOADD, TAD OPX /SET EXPONENT OF RESULT
3686 DCA ACX
3687 JMS OADD /DO THE ADDITION
3688 JMS I FNORP /NORMALIZE RESULT
3689DONA, ISZ FFADD /BUMP RETURN
3690 JMP I FFADD /RETURN
3691FACR, JMS ACSR /SHIFT FAC = DIFF.+1
3692 JMS OPSR /SHIFT OPR. 1 PLACE
3693 JMP DOADD /DO ADDITION
3694/
3695/OPERAND SHIFT RIGHT-ENTER WITH POSITIVE COUNT-1
3696/IN AC
3697OPSR, 0
3698 CMA /- (COUNT+1) TO SHIFT COUNTER
3699 DCA AC0
3700LOP2, TAD OPH /GET SIGN BIT
3701 RAL /TO LINK
3702 CLA
3703 TAD OPH /GET HI MANTISSA
3704 RAR /SHIFT IT RIGHT, PROPAGATING SIGN
3705 DCA OPH /STORE BACK
3706 TAD OPL
3707 RAR
3708 DCA OPL /STORE LO ORDER BACK
3709 RAR /SAVE 1 BIT OF OVERFLOW
3710 DCA AC2 /IN AC2
3711 ISZ OPX /INCREMENT EXPONENT
3712NOP2, NOP
3713 ISZ AC0 /DONE ALL SHIFTS?
3714 JMP LOP2 /NO-LOOP
3715 JMP I OPSR /YES-RETN.
3716\f/
3717/SHIFT FAC LEFT 1 BIT
3718/
3719AL1, 0
3720 TAD AC1 /GET OVERFLOW BIT
3721 CLL RAL /SHIFT LEFT
3722 DCA AC1 /STORE BACK
3723 TAD ACL /GET LOW ORDER MANTISSA
3724 RAL /SHIFT LEFT
3725 DCA ACL /STORE BACK
3726 TAD ACH /GET HI ORDER
3727 RAL
3728 DCA ACH /STORE BACK
3729 JMP I AL1 /RETN.
3730/
3731/SHIFT FAC RIGHT-ENTER WITH COUNT-1 IN AC (POSITIVE)
3732/
3733ACSR, 0
3734 CMA /AC CONTAINS COUNT-1
3735 DCA AC0 /STORE COUNT
3736LOP1, TAD ACH /GET SIGN BIT OF MANTISSA
3737 RAL /SET UP SIGN PROPAGATION
3738 CLA
3739 TAD ACH /GET HIGH ORDER MANTISSA
3740 RAR /SHIFT RIGHT`1, PROPAGATING SIGN
3741 DCA ACH /STORE BACK
3742 TAD ACL /GET LOW ORDER
3743 RAR /SHIFT IT
3744 DCA ACL /STORE BACK
3745 RAR
3746 DCA AC1 /SAVE 1 BIT OF OVERFLOW
3747 ISZ ACX /INCREMENT EXPONENT
3748NOP1, NOP
3749 ISZ AC0 /DONE?
3750 JMP LOP1 /NO-LOOP
3751 JMP I ACSR /YES-RETN-AC=L=0
3752/
3753/DIVIDE OVERFLOW-ZERO ACX,ACH,ACL
3754/
3755DBAD, CLA CLL /NECESSARY SO WE DON'T GET OVRFLO AGAIN
3756 JMP I DBAD1P /GO ZERO ALL
3757/
3758/FLOATING SUBTRACT
3759/
3760FFSUB, 0
3761 JMS I [PATCHF /WHICH MODE OF CALL?
3762 TAD I FFSUB /CALLED BY USER-GET ADDR. OF OP
3763 JMS I ARGETP /PICK UO THE OP.
3764 JMS OPNEG /NEGATE OPERAND
3765 TAD FFSUB /JMP INTO FLTG. ADD
3766SUB0, DCA FFADD /AFTER SETTING UP RETURN
3767 JMP FAD1
3768ARGETP, ARGET
3769\f *6135
3770/
3771/FLOATING NEGATE
3772/
3773FFNEG, 0 /(USED AS A TEM. BY OUTPUT ROUTINE)
3774 TAD ACL /GET LOW ORDER FAC
3775 CLL CMA IAC /NEGATE IT
3776 DCA ACL /STORE BACK
3777 CML RAL /ADJUST OVERFLOW BIT AND
3778 TAD ACH /PROPAGATE CARRY-GET HI ORD
3779 CLL CMA IAC /NEGATE IT
3780 DCA ACH /STORE BACK
3781 JMP I FFNEG
3782/
3783/NEGATE OPERAND
3784/
3785OPNEG, 0
3786 TAD OPL /GET LOW ORDER
3787 CLL CMA IAC /NEGATE AND STORE BACK
3788 DCA OPL
3789 CML RAL /PROPAGATE CARRY
3790 TAD OPH /GET HI ORDER
3791 CLL CMA IAC /NEGATE AND STORE BACK
3792 DCA OPH
3793 JMP I OPNEG
3794/
3795/ADD OPERAND TO FAC
3796/
3797OADD, 0
3798 CLL
3799 TAD AC2 /ADD OVERFLOW WORDS
3800 TAD AC1
3801 DCA AC1
3802 RAL /ROTATE CARRY
3803 TAD OPL /ADD LOW ORDER MANTISSAS
3804 TAD ACL
3805 DCA ACL
3806 RAL
3807 TAD OPH /ADD HI ORDER MANTISSAS
3808 TAD ACH
3809 DCA ACH
3810 JMP I OADD /RETN.
3811DBAD1P, DBAD1
3812FNORP, FFNOR
3813 >
3814\f IFNZRO EAE <
3815/EAE FLOATING POINT PACKAGE
3816/FOR PDP8/E WITH KE8-E EAE
3817/
3818/W.J. CLOGHER
3819/
3820/DEFINITIONS OF EAE INSTRUCTIONS
3821 SWP= 7521
3822 CAM= 7621
3823 MQA= 7501
3824 MQL= 7421
3825 SGT= 6006
3826 SWAB= 7431
3827 SWBA= 7447
3828 SCA= 7441
3829 MUY= 7405
3830 DVI= 7407
3831 NMI= 7411
3832 SHL= 7413
3833 ASR= 7415
3834 LSR= 7417
3835 ACS= 7403
3836 SAM= 7457
3837 DAD= 7443
3838 DLD= 7663
3839 DST= 7445
3840 DPIC= 7573
3841 DCM= 7575
3842 DPSZ= 7451
3843 /
3844 TM= TEMP4
3845 \f/
3846/FLOATING POINT INPUT ROUTINE
3847/
3848 PAGE
3849FFIN, 0
3850 CLA CMA
3851 DCA PRSW /INITIALIZE PERIOD SWITCH TO -1
3852 CMA /SET SIGN SWITCH TO -1
3853 DCA SIGNF
3854 CDF /CHANGE TO DF OF PACKAGE
3855 DCA DSWIT /ZERO CONVERSION SWITCH
3856DECONV, DCA ACX /ZERO OUT THE FAC!
3857 DCA ACL
3858 DCA ACH
3859DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT.
3860DECON, JMS GCHR /GET A CHAR.FROM TTY.
3861 JMP FFIN1 /TERMINATOR-
3862 ISZ DSWIT /DIGIT-BUMP CONVERSION SWITCH
3863 ISZ DNUMBR /BUMP # OF DIGITS
3864 DCA TP1 /STORE IT IN FORM EASILY FLOATIBLE
3865 JMS I FMPYLL /MULTIPLY # BY 10
3866 TEN
3867 JMS I [FFPUT /STORE IT AWAY
3868 FPPTM1
3869 JMS I [FFGET /GET NEW DIGIT
3870 TP
3871 JMS I [FFNOR /FLOAT IT
3872 JMS I FADDLL /ADD IT TO THE ACCUMULATED #
3873 FPPTM1
3874 JMP DECON /GO ON
3875FFIN1, ISZ PRSW /HAVE WE HAD A PERIOD YET?
3876 JMP FIGO2 /YES-GO ON
3877 TAD K2 /NO-IS THIS A PERIOD?
3878 SNA CLA
3879 JMP DECNV /YES-ZERO DIG. COUNT AFTER DEC. PT.
3880 /AND GO CONVERT REST
3881 DCA DNUMBR /NO-TERMINATOR-ZERO COUNT OF
3882 /DIGITS AFTER DECIMAL POINT.
3883FIGO2, CLA MQL /0 TO MQ FOR LATER MULTIPLY
3884 ISZ SIGNF /IS # NEGATIVE?(DID WE GET - SIGN?)
3885 JMS I FFNEGP /YES-NEGATE IT
3886 SWAB
3887 CMA /RESET SIGN SWITCH FOR EXP.
3888 DCA SIGNF
3889 TAD CHAR /NO-WAS THE TERMINATOR AN 'E'?
3890 TAD KME
3891 SNA CLA
3892GETE, JMS GCHR /YES-GET A CHAR. OF EXPONENT
3893 JMP EDON /END OF EXPONENT
3894 MUY /GOT DIGIT OF EXP-MULT ACCUMULATED
3895 K12 /EXPONENT BY TEN AND ADD DIGIT
3896 JMP GETE /CONTINUE
3897\fEDON, ISZ SIGNF /WAS EXPONENT NEGATIVE?
3898 DCM /YES-NEGATE IT
3899 CLA CLL /CLEAR AC AND LINK
3900 TAD DNUMBR /GET # TIMES TO DIV MANTISSA BY TEN
3901 SAM /SUBTRACT FROM EXPONENT
3902 CLL
3903 SPA /RESULT POSITIVE?
3904 CLL CMA CML IAC /NO-MAKE POS. AND SET LINK
3905 CMA /NEGATE FOR COUNTER
3906 DCA DNUMBR /AND STORE
3907 RAL /LINK=1-DIV;=0-MUL. # BY TEN
3908 TAD MDV /FORM CORRECT INSTRUCTION
3909 DCA FINST /AND STORE FOR EXECUTION
3910FCNT, ISZ DNUMBR /DONE ALL OPERATIONS?
3911 JMP FINST /NO
3912 JMP I FFIN /YES-RETURN
3913FINST, 0 /NO- MUL OR DIV. MANTISSA
3914 TEN /BY TEN
3915 JMP FCNT /GO ON
3916FFNEGP, FFNEG
3917PRSW, 0
3918DNUMBR, 0
3919SIGNF, 0
3920K2, 2
3921KME, -305
3922MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER
3923FMPYLL, FFMPY
3924 FFDIV /!!!!!!!!!!!!!!!!!
3925FADDLL, FFADD
3926
3927K12, 12
3928TP, 13
3929TP1, 0
3930 0
3931TEN, 4
3932 2400
3933 0
3934\f/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
3935/OR A TERMINATOR.
3936/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
3937/THIS ROUTINE MUST NOT MODIFY THE MQ!!
3938GCHR, 0
3939 JMS INPUT /GET A CHAR FROM TTY.
3940 TAD CHAR /PICK IT UP
3941 TAD PLUS /WAS IT PLUS SIGN?
3942 SNA
3943 JMP DECON1 /YES-GET ANOTHER CHAR.
3944 TAD MINUS /NO WAS IT MINUS SIGN?
3945 SZA CLA
3946 JMP .+3
3947 DCA SIGNF /YES-FLIP SWITCH
3948DECON1, JMS INPUT /GET A CHAR.
3949 TAD CHAR
3950 TAD K7506 /SEE IF ITS A DIGIT
3951 CLL
3952 TAD K12
3953 SZL /DIGIT?
3954 ISZ GCHR /YES-RETN. TO CALL+2
3955 JMP I GCHR /NO-RETN. TO CALL+1
3956K7506, 7506
3957PLUS, -253
3958MINUS, 253-255
3959/
3960/
3961/INPUT ROUTINE-IGNORES LEADING SPACES
3962/
3963INPUT, 0
3964 JMS I IGETCH /USE OUR ROUTINE TO GET CHAR
3965 TAD DSWIT /GET TERMINATOR
3966 SZA CLA /VALID INPUT YET?
3967 JMP IOUT /YES-CONTINUE
3968 TAD CHAR /NO-GET CHAR
3969 TAD M240 /COMPARE AGAINST SPACE
3970 SZA
3971 TAD (240-212 /IS IT AN LF?
3972 SNA CLA /IS IT A SPACE OR LF?
3973 JMP INPUT+1 /YES-IGNORE IT
3974IOUT, JMP I INPUT /RETURN
3975M240, -240
3976IGETCH, GETCH /ALTERED BY VAL FUNCITON TO PICK FROM SAC
3977/
3978/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
3979/
3980PATCHF, 0
3981 SZA /IS AC EMPTY
3982 JMP RTN2 /NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
3983 TAD FF /YES-GET SPECIAL MODE FLIP-FLOP
3984 SZA CLA /IF ON,THE ZERO AC MEANS ADDRESS OF 0
3985RTN2, ISZ PATCHF /USE AC AS ADDRESS OF OPERAND
3986 JMP I PATCHF /RETURN
3987/
3988\f PAGE
3989/
3990/FLOATING SUBTRACT-USES FLOATING ADD
3991/FSW1!!
3992FFSUB1, 0
3993 JMS I [PATCHF /WHICH MODE?
3994 TAD I FFSUB1 /CALLED BY USER-GET ADDR. OF OP
3995 JMS I ARGETL /PICK UP ARGUMENT
3996 CDF
3997 JMS I FFNEGA /NEGATE FAC!
3998 TAD FFSUB1
3999 JMP I SUB0P
4000FFNEGA, FFNEG
4001SUB0P, SUB0
4002
4003
4004/
4005/FLOATING DIVIDE
4006/FSWITCH=1
4007/THIS IS OP/FAC
4008/
4009FFDIV1, 0
4010 JMS I [PATCHF /WHICH MODE OF CALL?
4011 TAD I FFDIV1 /CALLED BY USER-GET ADDR.
4012 JMS I ARGETL /(INTERP.)-GET OPRND.-ADDR. IN AC
4013 CDF /CDF TO FIELD OF PACKAGE
4014 TAD ACH /SWAP FAC AND OPRND-OPH IN MQ!
4015 DCA OPH /STORE ACH IN OPH
4016 TAD ACX /GET EXP OF FAC
4017 SWP /OPH TO AC, ACX TO MQ
4018 DCA ACH /STORE OPH IN ACH
4019 TAD OPX /STORE OPX IN ACX
4020 DCA ACX
4021 TAD OPL /OPL TO MQ, ACX TO AC
4022 SWP
4023 DCA OPX /STORE ACX IN OPX
4024 TAD ACL
4025 DCA OPL /STORE ACL IN OPL
4026 TAD OPH /OPH TO MQ FOR LATER
4027 SWP
4028 DCA ACL /STORE OPL IN ACL
4029 TAD FFDIV1 /SET UP SO WE RETN TO
4030 DCA I FFDP /NORMAL DIVIDE ROUTINE
4031 TAD FD1
4032 DCA I MDSETP
4033 JMP I MD1P /GO ARRANGE OPERANDS
4034
4035MD1P, MD1
4036ARGETL, ARGET
4037MDSETP, MDSET
4038FFDP, FFDIV
4039FD1, FFD1
4040
4041\f
4042/PATCH TO EAE ADD ROUTINE
4043
4044ADDPCH, 0
4045 TAD AC1
4046 TAD RB4000
4047 DPSZ
4048 JMP ADDP1
4049 CLL CML RTR
4050 ISZ ACX
4051 NOP
4052ADDP1, TAD RB4000
4053 JMP I ADDPCH
4054RB4000, 4000
4055
4056
4057/
4058PTCHAD, CDF
4059 TAD OPH
4060 SNA CLA /OPERAND ZERO
4061 JMP I JADON /YES
4062 TAD ACH /FAC ZERO
4063 SZA CLA
4064 JMP I JFAD1 /NO
4065 TAD OPX
4066 DCA ACX
4067 TAD OPH
4068 DCA ACH
4069 TAD OPL
4070 DCA ACL
4071 JMP I JADON
4072JADON, ADON
4073JFAD1, FAD1
4074\f/
4075/FLOATING MULTIPLY--DOES 4 SINGLE MULTIPLIES WITH EAE
4076/THIS USES THE FACT THAT IF AC IS NON-ZERO WHEN YOU DO
4077/A MUY INSTR, THE AC IS ADDED TO RESULT OF THE MULTIPLY.
4078/(IN THE LOW ORDER, NATCHERLY)
4079 PAGE
4080FFMPY, 0
4081 JMS I [PATCHF /WHICH MODE?
4082 TAD I FFMPY /CALLED BY USER-GET ADDRESS
4083 JMS MDSET /SET UP FOR MULT
4084 CLA MUY /MULTIPLY-LOW ORDER FAC STILL IN MQ
4085 OPH /THIS IS PRODUCT OF LOW ORDERS
4086 MQL /ZAP LOW ORDER RESULT-INSIGNIFICANT
4087 TAD ACH /GET LOW ORDER(!) OF FAC
4088 SWP MUY /TO MQ-HIGH ORD. RESLT OF LAST MPY
4089 OPL /TO AC-WILL BE ADDED TO RESLT-THIS
4090 DST /IS PRODUCT-LOW ORD FAC,HI ORD OP
4091 AC0 /STORE RESULT
4092 DLD /HIGH ORDER FAC TO MQ, OPX TO AC
4093 ACL
4094 TAD ACX /ADD FAC EXPONENT-GET SUM OF EXPS.
4095 DCA ACX /STORE RESULT
4096 MUY /MUL. HIGH ORDER FAC BY LOW ORD OP.
4097 OPH /HIGH ORDER FAC WAS IN MQ
4098 DAD /ADD IN RESULT OF SECOND MULTIPLY
4099 AC0
4100 DCA ACH /STORE HIGH ORDER RESULT
4101 TAD ACL /GET HIGH ORDER FAC
4102 SWP /SEND IT TO MQ AND LOW ORD. RESULT
4103 DCA AC0 /OF ADD TO AC-STORE IT
4104 RAL /ROTATE CARRY TO AC
4105 DCA ACL /STORE AWAY
4106 MUY /NOW DO PRODUCT OF HIGH ORDERS
4107 OPL /FAC HIGH IN MQ, OP HIGH IN OPL
4108 DAD /ADD IN THE ACCUMULATED #
4109 ACH
4110 SNA /ZERO?
4111 JMP RTZRO /YES-GO ZERO EXPONENT
4112 NMI /NO-NORMALIZE (1 SHIFT AT MOST!)
4113 DCA ACH /STORE HIGH ORDER RESULT
4114 CLA SCA /GET STEP CNTR-DID WE NEED A SHIFT?
4115 SNA CLA
4116 JMP SNCK /NO-JUST CHECK SIGN
4117 CLA CMA /YES-MUST DECREASE EXP. BY 1
4118 TAD ACX
4119RTZRO, DCA ACX /STORE BACK
4120\f
4121 TAD AC0
4122 SPA CLA /IS HIGH ORDER OF OVERFLO WD. 1?
4123 DPIC /YES-ADD 1 TO LOW ORDER-STILL IN MQ
4124SNCK, ISZ MSIGN /RESULT NEGATIVE?
4125 JMP MPOS /NO-GO ON
4126 TAD ACH /YES-GET HIGH ORDER BACK
4127 DCM /LOW ORDER STILL IN MQ-NEGATE
4128 DCA ACH /STORE HIGH ORDER BACK
4129MPOS, SWP /LOW ORDER TO AC
4130 DCA ACL /STORE AWAY
4131 ISZ FFMPY /BUMP RETURN
4132 JMP I FFMPY /RETIRN
4133MSIGN, 0
4134ARGETK, ARGET
4135DVOFL, DV
4136
4137/
4138/ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE
4139/
4140MDSET, 0
4141 JMS I ARGETK /GET OPERAND (ADDR. IN AC)
4142 CDF /CHANGE TO DATA FIELD OF PACKAGE
4143MD1, CLA CLL CMA RAL /MAKE A MINUS TWO
4144 DCA MSIGN /AND STORE IN MSIGN.
4145 TAD OPL /GET LOW ORDER MANTISSA OF OP.
4146 SWP /GET INTO RIGHT ORDER ( OPH IN MQ)
4147 SMA /NEGATIVE?
4148 JMP .+3 /NO
4149 DCM /YES-NEGATE IT
4150 ISZ MSIGN /BUMP SIGN COUNTER
4151 SHL /SHIFT OPRND LEFT 1 TO AVOID OVRFLO
4152 1
4153 DST /STORE BACK-OPH CONTAINS LOW ORDER
4154 OPH / OPL CONTAINS HIGH ORDER
4155 DLD /GET THE MANTISSA OF THE FAC
4156 ACH
4157 SWP /MAKE IT CORRECT ORDER
4158 SMA /NEGATIVE?
4159 JMP FPOS /NO
4160 DCM /YES-NEGATE IT
4161 ISZ MSIGN /BUMP SIGN COUNTER (MAY SKIP)
4162 NOP
4163FPOS, DST /STORE BACK-ACH CONTAINS LOW ORDER
4164 ACH / ACL CONTAINS HIGH ORDER
4165 JMP I MDSET /RETURN
4166\f
4167
4168
4169/
4170/FLOATING DIVIDE
4171/
4172 *5722
4173FFDIV, 0
4174 JMS I [PATCHF /WHICH MODE?
4175 TAD I FFDIV /CALLED BY USER-GET ARG. ADDRESS
4176 JMS MDSET /GET ARG. AND SET UP SIGNS
4177FFD1, DVI /DIVIDE-ACH AND ACL IN AC,MQ
4178 OPL /THIS IS HI (!) ORDER DIVISOR
4179 DST /QUOT TO AC0,REM TO AC1
4180 AC0
4181 SZL CLA /DIVIDE ERROR?
4182 JMP I DVOFL /YES-HANDLE IT
4183 TAD OPX /DO EXPONENT CALCULATION
4184 CMA IAC /EXP. OF FAC - EXP. OF OP
4185 TAD ACX
4186 DCA ACX
4187 DPSZ /IS QUOT = 0?
4188 SKP /NO-GO ON
4189 DCA ACX /YES-ZERO EXPONENT
4190DVLP, MUY /NO-THIS IS Q*OPL*2**-12
4191 OPH
4192 DCM /NEGATE IT
4193 TAD AC1 /SEE IF GREATER THAN REMAINDER
4194 SNL
4195 JMP I DVOPSP /YES-ADJUST FIRST DIVIDE
4196 DVI /NO-DO Q*OPL*2**-12/OPH
4197 OPL
4198 SZL CLA /DIV ERROR?
4199 JMP I DVOFL /YES
4200DVLP1, TAD AC0 /NO-GET QUOT OF FIRST DIV.
4201 SMA /NEGATIVE?
4202 JMP .+5 /NO-REMEMBER-QUOT OF 2ND DIV. IN MQ
4203 LSR /YES-MUST SHIFT IT RIGHT 1
4204 1
4205 ISZ ACX /ADJUST EXPONENT
4206 NOP
4207 ISZ MSIGN /SHOULD SIGN BE MINUS?
4208 SKP /NO
4209 DCM /YES-DO IT
4210DBAD1, DCA ACH /STORE IT BACK
4211 SWP
4212 DCA ACL
4213 ISZ FFDIV
4214 JMP I FFDIV /BUMP RETN. AND RETN.
4215
4216DVOPSP, DVOPS
4217DBAD, CAM
4218 DCA ACX /ZERO EXPONENT
4219 JMP DBAD1 /GO ZERO MANTISSA
4220\f/FLOATING ADDITION-IN ORDER NOT TO LOSE BITS, WE DO NOT
4221/SHIFT BOTH NUMBERS RIGHT 1 BIT BEFORE ADD-ONLY SHIFTS DONE
4222/ARE TO ALIGN EXPONENTS.
4223/
4224 PAGE
4225FFADD, 0
4226 JMS I [PATCHF /WHICH MODE OF CALLING
4227 TAD I FFADD /CALLED DIRECTLY BY USER
4228 JMS I ARGETP /PICK UP ARGUMENTS
4229 JMP I PATCHK /CHECK FOR ADDITION BY ZERO
4230FAD1, TAD OPX /PICK UP EXPONENT OF OPERAND
4231 MQL /SEND IT TO MQ FOR SUBTRACT
4232 TAD ACX /GET EXPONENT OF FAC
4233 SAM /SUBTRACT-RESULT IN AC
4234 SPA /NEGATIVE RESULT?
4235 CMA IAC /YES-MAKE IT POSITIVE
4236 DCA CNT /STORE IT AS A SHIFT COUNT
4237 TAD CNT /COUNT TOO BIG?(CAN'T BE ALIGNED)
4238 TAD M27
4239 SPA SNA CLA
4240 CMA /NO-OK
4241 DCA AC0 /YES-MAKE IT A LOAD OF LARGEST #
4242 DLD /GET ADDRESSES TO SEE WHO'S SHIFTED
4243 ADDRS
4244 SGT /WHICH EXP GREATER(GT FLG SET
4245 /BY SUBTR. OF EXPS.)
4246 SWP /OPERAND'S-SHIFT THE FAC
4247 DCA SHFBG /STORE ADDRESS OF WHO GETS SHIFTED
4248 SWP /GET ADDRESS OF OTHER (0 TO MQ)
4249 DCA DADR /THIS ONE JUST GETS ADDED
4250 SGT /WHICH EXPONENT WAS GREATER?
4251 JMP .+3 /FAC'S - DO NOTHING
4252 TAD OPX /OPERAND'S-PUT FINAL EXP. IN ACX
4253 DCA ACX
4254 DLD /GET THE LARGER # TO AC,MQ
4255DADR, 0
4256 SWP /PUT IN THE RIGHT ORDER
4257 ISZ AC0 /COULD EXPONENTS BE ALIGNED?
4258 JMP LOD /NO-JUST LEAVE LARGER IN AC,MQ
4259 DST /YES-STORE THIS TEMPORARILY
4260 AC0 /(IF ONLY FAC STORAGE WAS REVERSED)
4261 DLD /GET THE SMALLER #
4262SHFBG, 0
4263 SWP /PUT IT IN RIGHT ORDER
4264 ASR /DO THE ALIGNMENT SHIFT
4265CNT, 0
4266\f DAD /ADD THE LARGER #
4267 AC0
4268 DST /STORE RESULT
4269 AC0
4270 SZL /OVERFLOW?(L NOT = SIGN BIT)
4271 CMA /NOTE-WE DIDN'T SHIFT BOTH RIGHT 1
4272 SMA CLA
4273 JMP NOOV /NOPE
4274 CLA CLL CML RAR /MAYBE-SEE IF 2 #S HAD SAME SIGN
4275 AND ACH
4276 TAD OPH
4277 SMA CLA /SIGNS ALIKE?
4278 JMP OVRFLO /YES-OVERFLOW
4279NOOV, JMS I ADDPCL /JUMP TO PATCH FOR THIS ROUTINE
4280LOD, NMI /NORMALIZE (LOW ORDER STILL IN MQ)
4281 DCA ACH /STORE FINAL RESULT
4282 SWP /GET AND STORE LOW ORDER
4283 DCA ACL
4284 SCA /GET SHIFT COUNTER(# OF NMI SHIFTS)
4285 CMA IAC /NEGATE IT
4286 TAD ACX /AND ADJUST FINAL EXPONENT
4287 DCA ACX
4288ADON, ISZ FFADD /BUMP RETURN PAST ADDRESS
4289 JMP I FFADD /RETURN
4290OVRFLO, TAD AC1 /OVERFLOW-GET HIGH ORDER RESLT BACK
4291 ASR /SHIFT IT RIGHT 1
4292 1
4293 TAD KK4000 /REVERSE SIGN BIT
4294 DCA ACH /AND STORE
4295 SWP
4296 DCA ACL /STORE LOW ORDER
4297 ISZ ACX /BUMP EXPONENT
4298 NOP
4299 JMP ADON /DONE
4300KK4000, 4000
4301M27, -27
4302ADDRS, OPH
4303 ACH
4304ARGETP, ARGET
4305/FLOATING SUBTRACT-USES FLOATING ADD
4306/FSW0!!
4307FFSUB, 0
4308 JMS I [PATCHF /WHICH MODE?
4309 TAD I FFSUB /CALLED BY USER-GET ADDRESS OF OP.
4310 JMS I ARGETP
4311 CDF
4312 TAD OPL /OPH IS IN MQ!
4313 SWP /PUT IT IN RIGHT ORDER
4314 DCM /NEGATE IT
4315 DCA OPH /STORE BACK
4316 MQA
4317 DCA OPL
4318 TAD FFSUB /GO TO ADD
4319SUB0, DCA FFADD
4320 JMP FAD1-1
4321\f/
4322/FLOATING NEGATE--NEGATE FLOATING AC
4323/
4324FFNEG, 0
4325 SWAB /MUST BE MODE B
4326 DLD /GET MANTISSA
4327 ACH
4328 SWP /CORRECT ORDER PLEASE!
4329 DCM /NEGATE IT
4330 DCA ACH /RESTORE
4331 SWP /SEND 0 TO MQ
4332 DCA ACL
4333 JMP I FFNEG
4334
4335
4336/
4337/CONTINUATION OF DIVIDE ROUTINE
4338/WE ARE ADJUSTING THE RESULT OF THE
4339/FIRST DIVIDE.
4340/
4341DVOPS, CMA IAC
4342 DCA AC1 /ADJUST REMAINDER
4343 TAD OPL /WATCH FOR OVERFLOW
4344 CLL CMA IAC
4345 TAD AC1
4346 SNL
4347 JMP DVOP1 /DON'T ADJUST QUOT.
4348 DCA AC1
4349 CMA
4350 TAD AC0
4351 DCA AC0 /REDUCE QUOT BY 1
4352DVOP1, CLA CLL
4353 TAD AC1 /GET REMAINDER
4354 SNA /ZERO?
4355 CAM /YES-ZERO EVERYTHING
4356 DVI /NO
4357 OPL
4358 SZL CLA /DIV. OVERFLOW?
4359 JMP I DVOVR /YES
4360 DCM /NO-ADJUST HI QUOT (MAYBE)
4361 JMP I DVLP1P /GO BACK
4362DVLP1P, DVLP1
4363DVOVR, DV
4364ADDPCL, ADDPCH
4365PATCHK, PTCHAD
4366 >
4367\f PAGE
4368/ARGUMENT PICK UP ROUTINE-ENTER WITH DATA FIELD SET TO EITHER
4369/FLTG. DATA FIELD OR FLTG. INSTR. FIELD.
4370/ADDRESS OF OPERAND IS IN THE AC ON ENTRY.
4371/ON RETURN, THE`AC IS CLEAR
4372/
4373ARGET, 0
4374 DCA AC2 /STORE ADDRESS OF OPERAND
4375 TAD I AC2 /PICK UP EXPONENT
4376 DCA OPX
4377 JMS ISZAC2 /MOVE POINTER TO HORD,WATCH FOR FIELD OVERLAP
4378 TAD I AC2 /PICK IT UP
4379 IFZERO EAE <
4380 NOP
4381 NOP
4382 >
4383
4384 IFNZRO EAE <
4385 SWAB /OPH INTO MQ BECAUSE EAE ROUTINES
4386 MQA /EXPECT TO FIND IT THERE
4387 >
4388 DCA OPH /STORE
4389 JMS ISZAC2 /MOVE POINTER TO LORD,WATCHING FOR OVERLAP
4390 TAD I AC2 /PICK IT UP
4391 DCA OPL /STORE IT
4392 JMP I ARGET /RETURN
4393\f IFZERO EAE <
4394/
4395/ROUTINE TO NORMALIZE THE FAC
4396/
4397FFNOR, 0
4398 TAD ACH /GET THE HI ORDER MANTISSA
4399 SNA /ZERO?
4400 TAD ACL /YES-HOW ABOUT LOW?
4401 SNA
4402 TAD AC1 /LOW=0, IS OVRFLO BIT ON?
4403 SNA CLA
4404 JMP ZEXP /#=0-ZERO EXPONENT
4405NORMLP, AC2000 /NOT 0-MAKE A 2000 IN AC
4406 TAD ACH /ADD HI ORDER MANTISSA
4407 SZA /HI ORDER = 6000
4408 JMP .+3 /NO-CHECK LEFT MOST DIGIT
4409 TAD ACL /YES-6000 OK IF LOW=0
4410 SZA CLA
4411 SPA CLA /2,3,4,5,ARE LEGAL LEFT MOST DIGS.
4412 JMP FFNORR /FOR NORMALIZED #-(+2000=4,5,6,7)
4413 JMP FNLP /JUMP SO FFGET AND PUT ARE ORGED RIGHT
4414
4415FFNORR, DCA AC1 /DONE W/NORMALIZE-CLEAR AC1
4416 JMP I FFNOR /RETURN
4417AL1P, AL1
4418 >
4419 IFNZRO EAE <
4420
4421/
4422/ROUTINE TO NORMALIZE THE FAC
4423/
4424 *6215
4425FFNOR, 0
4426 CDF /CHANGE D.F. TO FIELD OF PACKAGE
4427 SWAB /FORCE MODE B
4428 DLD /PICK UP MANTISSA
4429 ACH
4430 SWP /PUT IT IN CORRECT ORDER
4431 NMI /NORMALIZE IT
4432 SNA /IS THE # ZERO?
4433 DCA ACX /YES-INSURE ZERO EXPONENT
4434 DCA ACH /STORE HIGH ORDER BACK
4435 SWP /STORE LOW ORDER BACK
4436 DCA ACL
4437 CLA SCA /STEP COUNTER TO AC
4438 CMA IAC /NEGATE IT
4439 TAD ACX /AND ADJUST EXPONENT
4440 DCA ACX
4441 JMP I FFNOR /RETURN
4442 >
4443\f/FLOATING GET
4444
4445 *6241
4446FFGET, 0
4447 JMS I [PATCHF /WHICH MODE OF CALL
4448 TAD I FFGET /CALLED BY USER-GET ADDR. OF OP
4449 JMS ARGET /PICK UP OPERAND
4450 TAD OPX
4451 DCA ACX /LOAD THE OPERAND INTO FAC
4452 TAD OPL
4453 DCA ACL
4454 TAD OPH
4455 DCA ACH
4456 ISZ FFGET
4457 CDF
4458 JMP I FFGET /RETN. TO CALL +2
4459/
4460/FLOATING PUT
4461/
4462FFPUT, 0
4463 JMS I [PATCHF /WHICH MODE OF CALL?
4464 TAD I FFPUT /CALLED BY USER-GET OPR. ADDR
4465 DCA FFGET /STORE IN A TEMP
4466 TAD ACX /GET FAC AND STORE IT
4467 DCA I FFGET /AT SPECIFIED ADDRESS
4468 JMS ISZFGT /BUMP POINTER,WATCHING FOR FIELD OVERLAP
4469 TAD ACH
4470 DCA I FFGET
4471 JMS ISZFGT
4472 TAD ACL
4473 DCA I FFGET
4474 ISZ FFPUT /BUMP RETN.
4475 CDF
4476 JMP I FFPUT /RETN. TO CALL+2
4477
4478/ROUTINES TO BUMP ARGET AND FPUT POINTERS AND INCREMENT THE
4479/DATA FIELD IF THE POINTER CROSSES A FIELD BOUNDARY
4480
4481ISZFGT, 0
4482 ISZ FFGET /BUMP POINTER
4483 JMP I ISZFGT /NO SKIP MEANS JUST RETURN
4484 SKP /SKIP MEANS WE HAVE TO INCREMENT DATA FIELD
4485NEWCDF, DCA ISZFGT /THIS INST EXECUTED ONLY BY ISZAC2
4486 RDF /GET THE DATA FIELD
4487 TAD CDF10 /BUMP BY 1 AND MAKE A CDF
4488 DCA .+1 /PUT IN LINE
4489 .
4490 JMP I ISZFGT /RETURN
4491
4492CDF10, CDF 10
4493
4494ISZAC2, 0
4495 ISZ AC2 /BUMP POINTER
4496 JMP I ISZAC2 /NOTHING HAPPENED
4497 TAD ISZAC2 /NEED NEW DF. GET RETURN ADDR
4498 JMP NEWCDF /AND BUMP DF
4499\f IFZERO EAE <
4500/
4501/ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
4502/REMAINDER OF THE FIRST`DIVIDE IS LESS THAN QUOT*OPL
4503/USED BY FLTG. DIVIDE ROUTINE
4504/
4505DVOPS, CMA IAC /NEGATE AND STORE REVISED REMAINDER
4506 DCA ACH
4507 CLL
4508 TAD OPH
4509 TAD ACH /WATCH FOR OVERFLOW
4510 SNL
4511 JMP DVOP1 /OVERFLOW-DON'T ADJUST QUOT. OF 1ST DIV.
4512 DCA ACH /NO OVERFLOW-STORE NEW REM.
4513 CMA /SUBTRACT 1 FROM QUOT OF
4514 TAD AC1 /FIRST DIVIDE
4515 DCA AC1
4516DVOP1, CLA CLL
4517 TAD ACH /GET HI ORD OF REMAINDER
4518 JMP I DVOP2P /GO ON
4519DVOP2P, DVOP2
4520
4521FNLP, CLL CML CMA /-1
4522 TAD ACX /SUBTR. 1 FROM EXPONENT
4523 DCA ACX
4524 JMS I AL1P /SHIFT FAC LEFT 1
4525 JMP NORMLP /GO BACK AND SEE IF NORMALIZED
4526ZEXP, DCA ACX
4527 JMP FFNORR
4528 >
4529\f/
4530/FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF
4531/
4532 *6347
4533A,
4534FFSQ, 0
4535 JMS I TMPY /CALL MULTIPLY TO MULTIPLY
4536 ACX /FAC BY ITSELF
4537 JMP I FFSQ /DONE
4538TMPY, FFMPY
4539/
4540/ ERROR TRAPS
4541O0, JMS I [ERROR /OVERFLOW
4542DV, JMS I [ERROR /DIVISION ERROR
4543 JMS I [FACCLR /RETURN 0 IN FAC
4544 JMP I [ILOOP
4545LM, JMS I [ERROR /ILLEGAL ARGUMENT
4546
4547 PAGE
4548
4549\f *OVERLAY+3000
4550
4551
4552/TELETYPE "DRIVER"-WHEN CALLED,GRABS CHARACTERS FROM THE
4553/TELETYPE UNTIL A CR IS SENT OR THE BUFFER IS FULL. ASSUMES TTY ENTRY
4554/IS IN I/O WORK AREA.
4555
4556TTYDRI, 0
4557 JMP LFLUSH+1
4558IO, JMS I [ERROR
4559LFLUSH, JMS I [CRLFR /PRINT A CR,LF
4560 TAD K277 /PRINT A ? SIGNIFYING WAIT FOR INPUT
4561 JMS I [XPUTCH
4562 TAD I IOTBUF /BUFFER ADDRESS
4563 DCA I IOTPTR /INITIALIZE POINTER TO START OF BUFFER
4564 JMS I [CNOCLR /INITIALIZE CHAR # TO 1
4565TTYIN, JMS I [XPRINT /EMPTY TTY BUFFER BEFORE AWAITING INPUT
4566 JMP .-1
4567 TAD I (HEIGHT /ALWAYS RESET SCREEN HIEGHT ON INPUT
4568 DCA I (HCTR
4569 TAD K5252 /DESIGN INTO AC
4570KSFA, KSF /CHAR READY?
4571 JMP SPIN /NO-DIDDLE WHILE WE WAIT
4572 CLA CLL /FLUSH SPINNER OUT OF AC
4573 TAD [200 /FORCE PARITY BIT
4574 KRS /GET CHAR
4575 DCA CHAR /SAVE
4576 TAD CHAR
4577 JMS I [XPUTCH /ECHO IT
4578 KCC /CLEAR KEYBOARD FLAG AND SET READER RUN
4579 TAD CHAR
4580 TAD MCTRLU /IS IT CTRL/U?
4581 SNA CLA
4582 JMP LFLUSH /YES-START AGAIN
4583 TAD CHAR /NO
4584 TAD CRUBOT /IS IT RUBOUT?
4585 SNA
4586 JMP BACKUP /YES-BACK UP BUFFER POINTER
4587 TAD MCR /NO-IS IT CR?
4588 SNA CLA
4589 JMP CR /YES-DONE
4590 TAD CHAR
4591 JMS I [PACKCH /PACK CHAR IN BUFFER
4592 JMS I [BUFCHK /BUFFER FULL?
4593 JMP IO /YES-ERROR
4594 NOP /NO-CHAR 3 LEFT
4595 NOP /NO-2 AND 3 LEFT
4596 JMP TTYIN /NO-NEXT CHAR
4597MCTRLU, -225
4598MCR, 377-215
4599CRUBOT, -377
4600K5252, 5252
4601K277, 277
4602
4603BACKUP, TAD I IOTPTR /BUFFER POINTER
4604 CIA /NEGATE
4605 TAD I IOTBUF /COMPARE AGAINST START OF BUFFER
4606 SNA CLA /BUFFER EMPTY?
4607 JMP TTYIN /YES-THERE IS NOTHING TO RUBOUT
4608 TAD SCOPFG /TEST IF CONSOLE IS A SCOPE
4609 SNA CLA
4610 JMP NOSCOP /JMP IF NOT
4611 TAD (10
4612 JMS I [XPUTCH /PRINT BS,SP,BS TO RUBOUT IF SCOPE
4613 TAD (40
4614 JMS I [XPUTCH
4615 TAD (10
4616 SKP
4617NOSCOP, TAD K334
4618 JMS I [XPUTCH /ECHO "\"
4619 JMS I [CHARNO /GET CHAR # OF NEXT CHAR (LAST #+1)
4620 JMP C1B /1
4621 JMP C3B /3
4622 JMS I [CNOCLR /IT WAS 2-MAKE IT 1
4623PBACK, CLA CMA /-1
4624 TAD I IOTPTR /BACK UP BUFFER POINTER
4625 DCA I IOTPTR
4626 JMP TTYIN /NEXT CHAR
4627K334, 334
4628
4629C1B, TAD I IOTHDR
4630 AND [7477
4631 TAD [200 /IT WAS 1-MAKE IT 3
4632 DCA I IOTHDR
4633 JMP TTYIN /NO NEED TO BACK UP POINTER
4634
4635C3B, TAD I IOTHDR
4636 AND [7477
4637 TAD [100 /IT WAS 3,MAKE IT 2
4638 DCA I IOTHDR
4639 JMP PBACK /BACK UP POINTER
4640
4641
4642CR, JMS I [CRLFR /ECHO A CR,LF
4643 TAD K4
4644 TAD TTYDRI /BUMP DRIVE RETURN TO NORMAL
4645 DCA TTYDRI
4646 TAD CHAR
4647 JMS I [PACKCH /PACK CHAR IN BUFFER
4648 TAD I IOTBUF
4649 DCA I IOTPTR /INITAILZE BUFFER POINTERS
4650 JMS I [CNOCLR
4651 JMP I TTYDRI /RETURN
4652K4, 4
4653
4654
4655SPIN, ISZ SPINNR /SPIN RANDOM # SEED
4656 SKP
4657 CMA CML RAL /MARCH TO THE LEFT
4658 JMP KSFA /CHECK FOR CHAR YET
4659SCOPFG, 0 /GETS SET TO SCOPE FLAG BY STARTUP CODE
4660\f/SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC
4661
4662FBITGT, 0
4663 TAD INSAV
4664 CLL RTR
4665 RTR /PUT FUNCTION BITS IN BITS 8-11
4666 AND [17 /MASK THEM OFF
4667 JMP I FBITGT /RETURN
4668
4669/DATA LIST READ (NUMERIC)
4670
4671RDLIST, JMS I (DLREAD /FETCH WORD FROM LIST
4672 DCA ACX /STORE AS EXPONENT
4673 JMS I (DLREAD
4674 DCA ACH /HIGH MANTISSA
4675 JMS I (DLREAD
4676 DCA ACL /LOW MANTISSA
4677 JMP I [ILOOP
4678
4679/SUBROUTINE FTYPE-RETURNS TO CALL+1 IF FILE NUMERIC,CALL+2 IF ASCII
4680
4681FTYPE, 0
4682 TAD I IOTHDR /GET HEADER
4683 CLL RAR /TYPE TO LINK
4684 SZL CLA /IS IT NUMERIC?
4685 ISZ FTYPE /NO-BUMP RETURN
4686 JMP I FTYPE /RETURN
4687
4688 PAGE
4689\f/LAST PAGE OF BRTS-CONTAINS SAC,I/O TABLE, AND SOME MISCELLANEOUS CODE
4690
4691/TELETYPE INPUT BUFFER (74. CHARACTERS LONG)
4692/THIS BUFFER CONTAINS ONCE ONLY START CODE WHEN LOADED
4693
4694TTYBUF,
4695START4, TAD CDFPS /DF FOR BOTTOM OF PSEUDO-CODE
4696 TAD MCDF1 /COMPARE TO A CDF 10
4697 SZA CLA /DO THEY MATCH?
4698 JMP I [ILOOP /NO-ALL BUFFERS ARE FREE-START INTERPRETER
4699 TAD PSSTRT
4700 CLL CMA
4701 TAD [400
4702 SNL CLA /IS START OF PSEUDO-CODE BELOW 400
4703 JMP CHKB2 /NO-CHECK FOR 1000
4704 TAD [17 /YES-SET ALL BUFFERS BUSY
4705 JMP BAS
4706CHKB2, TAD PSSTRT
4707 CLL CMA
4708 TAD C1000
4709 SNL CLA /IS START OF PSEUDO-CODE BELOW 1000
4710 JMP CHKB3 /NO-CHECK 1400
4711 TAD C16 /YES-ONLY BUFFER 1 IS AVAILABLE
4712 JMP BAS
4713CHKB3, TAD PSSTRT
4714 CLL CMA
4715 TAD C1400
4716 SNL CLA /IS START OF CODE BELOW 1400?
4717 JMP CHKB4 /YES-CHECK 2000
4718 TAD C14 /YES-ONLY BUFFER 1 AND 2 AVAILABLE
4719 JMP BAS
4720CHKB4, TAD PSSTRT
4721 CLL CMA
4722 TAD K2000
4723 SNL CLA /IS CODE START BELOW 2000?
4724 JMP I [ILOOP /NO-START INTERPRETER-ALL BUFFER FREE
4725 TAD [10 /YES-BUFFERS 1,2, AND 3 AVAILABLE
4726BAS, DCA BMAP
4727 JMP I [ILOOP /START INTERPRETER
4728 0
4729MCDF1, -6211
4730K2000, 2000
4731C14, 14
4732C16, 16
4733C1000, 1000
4734C1400, 1400
4735 ZBLOCK 10
4736TTYEND, 0
4737\f *OVERLAY+3277
4738
4739////////////////////////////////////////////////////////////////
4740/////// I/O TABLE 5 13-WORD ENTRIES ////////////////////////////
4741////////////////////////////////////////////////////////////////
4742
4743TTYF, 1 /TELETYPE ENTRY-FILE IS ASCII
4744 TTYBUF /BUFFER ADDRESS
4745 0 /CURRENT BLOCK IN BUFFER
4746 TTYBUF /READ WRITE POINTER
4747 TTYDRI /HANDLER ENTRY
4748 ZBLOCK 10
4749FILE1, ZBLOCK 15 /FILE #1
4750FILE2, ZBLOCK 15 /FILE #2
4751FILE3, ZBLOCK 15 /FILE #3
4752FILE4, ZBLOCK 15 /FILE #4
4753
4754 PAGE
4755\f /CROSS FIELD LITERAL EQUATES
4756
4757 PGETCH= [GETCH
4758 PILOOP= [ILOOP
4759 PPUTCH= [PUTCH
4760 PSACM1= [SAC-1
4761 PXPUTCH= [XPUTCH
4762 PXPRINT= [XPRINT
4763 PFFNOR= [FFNOR
4764 PFFGET= [FFGET
4765 PFFPUT= [FFPUT
4766 PUNSFIX= [UNSFIX
4767 PERROR= [ERROR
4768 PFACCLR= [FACCLR
4769 PIDLE= [IDLE
4770 PPSWAP= [PSWAP
4771 PFTYPE= [FTYPE
4772 USR= [200
4773 O200= [200
4774 O400= [400
4775 O100= [100
4776 O10= [10
4777 O17= [17
4778 O7400= [7400
4779 O77= [77
4780 O215= [215
4781 O7700= [7700
4782 M215= [-215
4783\f/////////////////////////////////////////////////////////////
4784/////////////////////////////////////////////////////////////
4785////////////// OVERLAY 2- STRING FUNCTIONS /////////////////
4786/////////////////////////////////////////////////////////////
4787/////////////////////////////////////////////////////////////
4788
4789 FIELD 1
4790 *2000
4791 RELOC OVERLAY
4792
4793 /VERSION NUMBER WORD FOR STRING OVERLAY
4794
4795 VERSON^100+SUBVSF+6000
4796
4797/CHR$ FUNCTION
4798/RETURNS 1 6BIT CHAR STRING FOR THE VALUE OF X
4799
4800CHR, JMS I PUNSFIX /FIX X TO 12 BIT INTEGER
4801 AND O77 /MASK TO 6BIT
4802 DCA I (SAC /AND PUT INTO SAC
4803 CMA
4804 DCA SACLEN /SET SAC LENGTH TO 1
4805 JMP I (SSMODE /SET TO SMODE AND RETURN
4806
4807/ASC FUNCTION
4808/RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC
4809
4810ASC, TAD I (SAC /GET FIRST CHAR OF STRING
4811 JMP FLOATS /FLOAT RESULT INTO FAC AND RETURN
4812
4813/LEN FUNCTION
4814/RETURNS LENGTH OF SAC IN FAC
4815
4816LEN, TAD SACLEN /LENGTH OF STRING IN SAC
4817 CIA /MAKE POSITIVE
4818
4819/ROUTINE TO FLOAT FAC AND RETURN
4820
4821FLOATS, DCA ACH /NUMBER TO BE FLOATED IN HORD
4822 DCA ACL /CLEAR LORD
4823 DCA TEMP2 /CLEAR FPP OVERFLOW
4824 TAD (13 /SET EXP TO 11
4825 DCA ACX
4826 JMS I PFFNOR /NORMALIZE
4827 JMP I PILOOP /RETURN
4828\f
4829
4830
4831/STR$ FUNCTION
4832/RETURNS ASCII STRING FOR NUMBER IN FAC
4833
4834STR, JMS I (FFOUT /GET NUMBER INTO INTERMEDIATE BUFFER FIRST
4835 TAD XR1
4836 CIA
4837 TAD (INTERB-1
4838 DCA SACLEN
4839 TAD SACLEN /NOW SAVE COUNTER
4840 DCA TEMP2
4841 TAD (INTERB-1
4842 DCA XR1 /POINT AT BUFFER
4843STRLUP, TAD I XR1 /GET A CHAR
4844 AND O77 /MASK TO 6BIT
4845 TAD (-40 /CROCK TO DELETE BLANKS
4846 SZA
4847 JMP .+3
4848 ISZ SACLEN /IGNORE THE BLANK
4849 JMP .+3
4850 TAD (40
4851 DCA I SACXR /STORE IN SAC
4852 ISZ TEMP2
4853 JMP STRLUP /LOOP FOR MORE
4854 JMP I (SSMODE /DONE-RETURN IN SMODE
4855\f
4856/VAL FUNCTION
4857/RETURNS NUMBER IN FAC FOR STRING IN SAC
4858
4859VAL, TAD SACLEN
4860 DCA VALCNT /COUNT OF CHARS TO INPUT
4861 TAD (VALGET /ADDR OF PHONY INPUT ROUTINE
4862 DCA I (IGETCH /PUT IN INPUT ROUTINE IN PLACE OF KRB
4863 JMS I (FFIN /CALL FPP INPUT ROUTINE
4864 TAD PGETCH /NOW RESTORE REAL INPUT ADDR
4865 DCA I (IGETCH /RESTORE IN INPUT ROUTINE
4866 JMP I PILOOP /DONE
4867
4868VALGET, 0
4869 TAD VALCNT /TEST NUMBER OF CHARS LEFT
4870 SNA CLA
4871 JMP EOVAL /NONE
4872 ISZ VALCNT /ELSE BUMP
4873 NOP
4874 TAD I SACXR /GET A BYTE
4875 TAD (240
4876 AND O77
4877 TAD (240 /CONVERT TO 8BIT
4878 SKP
4879EOVAL, TAD O215
4880 DCA CHAR
4881 JMP I VALGET /RETURN WITH CHAR IN 'CHAR'
4882
4883VALCNT, 0
4884
4885 PAGE
4886\f/ DATE FUNCTION
4887/ RETURNS STRING OF THE FORM "MM/DD/YY" IN SAC IF DATE IS PRESENT
4888/ RETURNS NULL STRING OTHERWISE
4889
4890
4891DATE, TAD CDFIO /COPY CDF TO FIELD 17600 IN LINE
4892 DCA .+1
4893YEAREX, 0
4894 TAD PSFLAG /GET TD8E BIT TO LINK
4895 CLL RAL
4896 SNL CLA
4897 TAD I (MDATE /IF ZERO LOOK AT MDATE IN N7600
4898 SZL
4899 TAD I (MDATE-200 /ELSE LOOK AT N7400
4900 DCA DATEWD /STORE (DATE IS NOT A CLOSED SUBROUTINE)
4901 CDF /DATE IS IN THE FORM MMM MDD DDD YYY
4902 TAD DATEWD /PICK UP DATE
4903 SZA CLA
4904 TAD (-10 /RETURN 8. BYTES IF NOT NULL DATE
4905 DCA SACLEN /SET SAC LENGTH
4906 TAD I (BIPCCL /NOW GET YEAR EXTENSION
4907 AND (600 /IT'S IN THE 600 BITS
4908 CLL RTR
4909 RTR /SHIFT INTO PLACE
4910 DCA YEAREX /HOLD YEAR EXTENSION
4911 TAD DATEWD /NOW ISOLATE MONTH
4912 AND O7400
4913 CLL RTL
4914 RTL
4915 RAL
4916 JMS PUTN /PUT "MM/" INTO THE SAC
4917 TAD DATEWD /NOW GET DAY OF MONTH
4918 AND (370
4919 CLL RTR
4920 RAR
4921 JMS PUTN /PUT "DD/" IN SAC
4922 TAD DATEWD /FINALLY GET YEAR
4923 AND (7
4924 TAD YEAREX /ADD TO EXTENSION BITS
4925 TAD (106 /ADD 70. FOR BASE YEAR
4926 JMS PUTN /PUT OUT "YY/" (EXTRA SLASH WILL BE IGNORED)
4927 JMP I (SSMODE /RETURN IN STRING MODE
4928
4929PUTN, 0
4930 ISZ NHIGH /BUMP HIGH ORDER DIGIT
4931 TAD (-12 /-10.
4932 SMA
4933 JMP .-3 /LOOP IF NOT REDUCED YET
4934 TAD (12+60 /CONVERT TO DECIMAL DIGIT
4935 DCA NLOW /HOLD MOMENTARILY
4936 TAD NHIGH /NOW GET HI ORDER DIGIT
4937 TAD (57 /MAKE 6BIT
4938 DCA I SACXR
4939 TAD NLOW /SEND OUT LOW DIGIT
4940 DCA I SACXR
4941 TAD (57
4942 DCA I SACXR /SEND OUT "/"
4943 DCA NHIGH /CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!)
4944 JMP I PUTN
4945NHIGH, 0
4946NLOW, 0
4947DATEWD, 0
4948\f/TRACE FUNCTION PRINTER. WHEN TRACE IS ENABLED,THIS ROUTINE
4949/PRINTS THE LINE # EACH TIME IT IS STORED
4950
4951TPRINT, JMS I (LMAKE /MAKE LINE # INTO FIVE DIGITS
4952 TAD ("%
4953 JMS I PXPUTCH /PRINT "%"
4954 TAD ("
4955 JMS I PXPUTCH /PRINT A SPACE
4956 TAD (DIG1-1 /ADDR OF FIRST DIGIT-1
4957 DCA XR5 /IN XR5
4958IGS, TAD I XR5 /GET DIGIT OF LINE NUMBER
4959 DCA TCHR /SAVE IT
4960 TAD (-"0
4961 TAD TCHR /COMPARE IT TO 0
4962 SNA CLA /IS IT A 0?
4963 JMP IGS /YES-IGNORE LEADING ZEROES
4964PREST, TAD TCHR /NO-GET CHAR AGAIN
4965 TAD M215
4966 SNA CLA /IS IT A CR?
4967 JMP TDONE /YES-LINE NUMBER IS PRINTED
4968 TAD TCHR /NO-GET CHAR A THIRD TIME
4969 JMS I PXPUTCH /TYPE IT
4970 TAD I XR5 /GET NEXT CHAR
4971 DCA TCHR
4972 JMP PREST /AND LOOP
4973TDONE, TAD ("
4974 JMS I PXPUTCH /FOLLOW LINE # WITH A SPACE
4975 TAD ("%
4976 JMS I PXPUTCH /TYPE ANOTHER "%"
4977 TAD (215
4978 JMS I PXPUTCH /TYPE,CR,LF
4979 TAD (212
4980 JMS I PXPUTCH
4981 JMS I PXPRINT /EMPTY RING BUFFER OF TRACE NUMBER
4982 JMP .-1
4983 JMP I PILOOP /DONE
4984TCHR, 0
4985
4986 PAGE
4987\f/TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF
4988
4989TRACE, TAD ACH /GET HI MANTISSA OF ARG
4990 SNA CLA /SKP TO TURN TRACE ON
4991 TAD TRREST /ELSE RESTORE TRACE BYPASS INSTR IN LINE NUMBER ROUTINE
4992 DCA I HOOKL /BY NOP ING INSTRUCTION AT TRHOOK
4993TRREST, JMP I PILOOP
4994
4995HOOKL, TRHOOK
4996
4997/ERROR ROUTINE
4998
4999ERRORR, JMS I PXPRINT /PURGE TTY RING BUFFER
5000 JMP .-1 /BEFORE PRINTING ERROR
5001 TAD ETABA /ADDR OF ERROR TABLE
5002 DCA XR4 /POINTS INTO ERROR TABLE
5003FERRLP, TAD I XR4 /GET 2 CHAR ERROR CODE
5004 DCA TEMP1 /SAVE
5005 TAD TEMP1
5006 CLL RTR
5007 RTR
5008 RTR
5009 AND O77 /STRIP TO 6 BIT
5010 TAD K0300 /MAKE 8 BIT (LETTERS ONLY ALLOWED)
5011 DCA ESTRNG /PUT IN MESSAGE
5012 TAD TEMP1 /2 CHAR CODE AGAIN
5013 AND O77 /SECOND CHAR
5014 TAD K0300 /MAKE LETTER
5015 DCA ESTRNG+1 /PUT IN MESSAGE
5016 TAD I XR4 /GET ERROR CODE +1
5017 TAD I PERROR /COMPARE AGAINST RETURN ADDR
5018 SZA CLA /MATCH?
5019 JMP FERRLP /NO-TRY NEXT ONE
5020 JMS LMAKE /MAKE THE LINE # INTO DECIMAL DIGITS
5021 TAD ESTRA /ADDR OF MESSAGE
5022 DCA XR5
5023ETLOP, TAD I XR5 /GET MESSAGE CHAR
5024 SPA /DONE? (MESSAGE ENDNS WITH - NUMBER
5025 JMP FATCHK /YES-DETERMINE ERROR TYPE
5026 JMS I PXPUTCH /NO-PUT CHAR IN RING BUFFER
5027 JMP ETLOP
5028
5029FATCHK, CLA
5030 TAD MFATAL /-ADDR OF FATAL ERRORS
5031 TAD XR4 /ADDR OF THIS ERROR
5032 SMA CLA /FATAL ERROR?
5033 JMP I ERRETN /NO-NEXT INST
5034 JMP I STOPI /YES-TERMINATE RUN
5035
5036ERRETN, XERRRET
5037STOPI, FSTOPN
5038
5039MAKED, 0
5040 AND O17 /ISOLATE BCD DIGIT
5041 TAD K260 /MAKE ASCII DIGIT
5042 JMP I MAKED
5043
5044K260, 260
5045K0300, 300
5046\f/SUBROUTINE LMAKE-MAKES THE CURRENT LINE NUMBER INTO FIVE DIGITS
5047/STARTING AT DIG1
5048
5049LMAKE, 0
5050 TAD LINEHI /YES:GET HI LINE #
5051 JMS MAKED /GET DIGIT 2
5052 DCA DIG2 /PUT IN MESSAGE
5053 TAD LINEHI
5054 CLL RTR
5055 RTR
5056 JMS MAKED /GET DIGIT 1
5057 DCA DIG1 /AND PUT IN MESSAGE
5058 TAD LINELO /DOGOTS 3,4, AND 5
5059 JMS MAKED /GET DIGIT 5
5060 DCA DIG5
5061 TAD LINELO
5062 CLL RTR
5063 RTR
5064 JMS MAKED /GET DIGIT 4
5065 DCA DIG4 /AND PUT IN MESSAGE
5066 TAD LINELO
5067 CLL RAL
5068 RTL
5069 RTL
5070 JMS MAKED /GET DIGIT 3
5071 DCA DIG3 /MESSAGE NOW COMPLETE
5072 JMP I LMAKE
5073\f/ERROR MESSAGE
5074
5075EMESS, 215
5076 212
5077ESTRNG, 0000
5078 0000
5079 "
5080 "A
5081 "T
5082 "
5083 "L
5084 "I
5085 "N
5086 "E
5087 "
5088DIG1, 0
5089DIG2, 0
5090DIG3, 0
5091DIG4, 0
5092DIG5, 0
5093 215
5094 212
5095ESTRA, EMESS-1 /MINUS NUMBER TO END ABOVE MESSAGE
5096\f/ERROR TABLE\r/ENTRY FORMAT- 2 CHAR 6-BIT ERROR CODE (LETTERS ONLY)
5097/ -(ADDR OF CALL)-1
5098
5099ETABA, ETAB-1
5100MFATAL, -EFATAL
5101ETAB, 0602 /FB
5102 -FB-1 /ATTEMPT TO OPEN AN ALREADY OPEN FILE
5103 0722 /GR
5104 -GR-1 /RETURN WITHOUT A GOSUB
5105 2622 /VR
5106 -VR-1 /ATTEMPT TO READ VARIABLE LENGTH FILE
5107 2325 /SU
5108 -SU-1 /SUBSCRIPT ERROR
5109 0405 /DE
5110 -DE-1 /DEVICE DRIVER ERROR
5111 1705 /OE
5112 -OE-1 /DRIVER ERROR WHILE OVERLAYING
5113 0615 /FM
5114 -FM-1 /ATTEMPT TO FIX MINUS NUMBER
5115 0617 /FO
5116 -FO-1 /ATTEMPT TO FIX NUMBER >4095
5117 0616 /FN
5118 -FN-1 /ILLEGAL FILE #
5119 2303 /SC
5120 -SC-1 /ATTEMPT TO OVERFLOW SAC ON CONCATENATE
5121 0611 /FI
5122 -FI-1 /ATTEMPT TO CLOSE OR USE UNOPENED FILE
5123 0401 /DA
5124 -DA-1 /ATTEMPT TO READ PAST END OF DATA LIST
5125 0723 /GS
5126 -GS-1 /TOO MANY NESTED GOSUBS
5127 2322 /SR
5128 -SR-1 /ATTEMPT TO READ STRING FROM NUMERIC FILE
5129 2327 /SW
5130 -SW-1 /ATTEMPT TO WRITE STRING INTO NUMERIC FILE
5131 2001 /PA
5132 -PA-1 /ILLEGAL ARG IN POS
5133 0603 /FC
5134 -FC-1 /OS/8 ERROR WHILE CLOSING TENTATIVE FILE
5135 0311 /CI
5136 -CI-1 /INQUIRE FAILURE IN CHAIN
5137 0314 /CL
5138 -CL-1 /LOOKUP FAILURE IN CHAIN
5139 1116 /IN
5140 -IN-1 /INQUIRE FAILURE IN OPEN
5141 0417 /DO
5142 -DO-1 /NO MORE ROOM FOR DRIVERS
5143 0605 /FE
5144 -FE-1 /FETCH ERROR IN OPEN
5145 0217 /BO
5146 -BO-1 /NO MORE FILE BUFFERS AVAILABLE
5147 0516 /EN
5148 -EN-1 /ENTER ERROR IN OPEN
5149 1106 /IF
5150 -IF-1 /ILLEGAL DEV:FILENAME SPECIFICATION
5151 2314 /SL
5152 -SL-1 /STRING TOO LONG OR UNDEFINED
5153 1726 /OV
5154 -O0-1 /NUMERIC OR INPUT OVERFLOW
5155 1415 /LM
5156 -LM-1 /ATTEMPT TO TAKE LOG OF NEG # OR 0
5157 0515 /EM
5158 -EM-1 /ATTEMPT TO EXPONENTIATE A NEG NUMBER TO A REAL ROWER
5159 1101 /IA
5160 -IA-1 /ILLEGAL ARGUMENT IN USER FUNCTION
5161 0330 /CX
5162 -CX-1 /ILLEGAL FILENAME EXTENSION IN A CHAIN STATEMENT
5163/***********************************************************
5164EFATAL, /ERRORS BEFORE THIS LABEL ARE FATAL
5165/*******************************************************
5166 2205 /RE
5167 -RE-1 /ATTEMPT TO READ PAST EOF
5168 2705 /WE
5169 -WE-1 /ATTEMPT TO WRITE PAST EOF
5170 0426 /DV
5171 -DV-1 /ATTEMPT TO DIVIDE BY 0
5172 2324 /ST
5173 -ST-1 /STRING TRUNCATION ON INPUT
5174 1117 /IO
5175 -IO-1 /TTY INPUT BUFFER OVERFLOW
5176\f T= .
5177 *ETAB
5178 *T
5179/SEG$ FUNCTION
5180/RETURNS SEGMENT OF X$ BETWEEN Y AND Z
5181/IF Y<=0,THEN Y TAKEN AS 1
5182/IF Y>LEN(X$),NULL STRING RETURNED
5183/IF Z<=0,NULL STRING RETURNED
5184/IF Z>LEN(X$),Z IS SET=LEN(X$)
5185/IF Z<Y,NULL STRING IS RETURNED
5186
5187SEG, CLA IAC
5188 DCA MODESW /RETURN IN STRING MODE
5189 TAD ACH /IS Y>0?
5190 SMA SZA CLA
5191 JMS I PUNSFIX /FIX IF POSITIVE
5192 SNA
5193 IAC /SET Y TO 1 IF Y.LE.0
5194 DCA YARG
5195 TAD SACLEN /COMPARE YARG TO SACLEN
5196 CIA
5197 STL CIA
5198 TAD YARG
5199 SNL SZA CLA /SKP IF YARG.LOS.LEN(X$)
5200 JMP NULLST /NO-RETURN THE NULL STRING
5201 DCA INSAV /FAKE POINTER TO SCALAR #0
5202 JMS I ARGPLK /GET ADDR OF Z
5203 JMS I PFFGET /LOAD Z INTO FAC
5204ARGPLK, ARGPRE /LOC SKIPPED BY FPP SO WE PUT CONST HERE
5205 TAD ACH /HI MANTISSA OF Z
5206 SPA SNA CLA /IS Z<0?
5207 JMP NULLST /YES-RETURN THE NULL STRING
5208 JMS I PUNSFIX /NO-FIX Z
5209 STL
5210 TAD SACLEN /CALC Z-LEN(SAC)
5211 SNL /SKP IF Z.LO.LEN(SAC)
5212 CLA /ELSE TAKE LEN(SAC)
5213 CMA
5214 TAD SACLEN
5215 TAD YARG /NUMBER OF BYTES TO USE
5216 SMA
5217 JMP NULLST /NONE, RETURN NULL STRING
5218 DCA STRCNT
5219 TAD YARG /INDEX INTO STRING FOR SOURCE BYTES
5220 TAD (SAC-2
5221 DCA XR2 /SET SOURCE XR
5222 TAD STRCNT
5223 DCA SACLEN /SET NEW LENGTH OF SAC NOW
5224 TAD I XR2 /NOW MOVE THE BYTES
5225 DCA I SACXR
5226 ISZ STRCNT
5227 JMP .-3
5228 JMP I PILOOP /--RETURN--
5229NULLST, CLA CLL
5230 DCA SACLEN /ZERO SAC
5231 JMP I PILOOP /--RETURN--
5232YARG, 0
5233
5234 PAGE
5235\f /POS FUNCTION
5236 /RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z
5237
5238POS, CLA CLL
5239 DCA INSAV /FAKE AS STRING CALL TO STRING 0
5240 JMS I (STFIND /FIND Y$
5241 TAD STRCNT /# OF CHARS IN Y$
5242 SNA CLA /IS Y$ THE NULL STRING?
5243 JMP ONERET /YES-RETURN 1 AS POSITION
5244 TAD SACLEN /NO-# OF CHARS IN X$
5245 SNA CLA /IS X$ THE NULL STRING?
5246 JMP ZRORET /YES-RETURN 0
5247 TAD ACH /NO-GET HORD OF Z
5248 SPA SNA CLA /IS Z GT 0?
5249PA, JMS I PERROR /NO-ILLEGAL ARGUMENT
5250 JMS I PUNSFIX /FIX Z
5251 DCA POSITN /USE IT AS POSITION TO START SEARCH
5252 TAD POSITN
5253 STL
5254 TAD SACLEN /COMPARE POSITION TO MAXIMUM LENGTH OF STRING
5255 SNL SZA CLA
5256 JMP PA /Z IS PAST END OF STRING-ERROR
5257POSSET, TAD STRCNT
5258 CMA
5259 TAD POSITN /GET POSITION NOW CHECKING+SIZE IF Y$
5260 TAD SACLEN /COMPARE AGAINST LENGTH OF STRING
5261 SMA SZA CLA /ANY MORE TO COME?
5262 JMP ZRORET /NO-SEARCH FAILS
5263 JMS I (BYTSET /SETUP BYTE LOAD ROUTINE
5264 TAD POSITN /SEARCH START POSITION IN X$
5265 TAD (SAC-2 /ADD TO BASE OF SAC
5266 DCA SACXR
5267 TAD STRCNT /# OF CHARS IN Y$
5268 DCA TEMP3 /COUNTER
5269SRCLP, JMS I (LDB
5270 CIA
5271 TAD I SACXR /COMPARE CHARS
5272 SNA CLA /DO THEY MATCH?
5273 JMP SCONTU /YES-CONTINUE MATCH TO NEXT CHAR IN X$ AND Y$
5274 ISZ POSITN /BUMP POSITION TO BE CHECKED
5275 JMP POSSET /ITERATE
5276
5277SCONTU, ISZ TEMP3 /MORE CHARS IN Y$?
5278 JMP SRCLP /YES, ITERATE
5279 TAD POSITN /NO FOUND A MATCH
5280 JMP I (FLOATS
5281ZRORET, JMS I PFACCLR /SEARCH FAILS-RETURN 0
5282 JMP I PILOOP
5283
5284ONERET, CLA IAC
5285 JMP I (FLOATS /RETURN 1
5286POSITN, 0
5287
5288 PAGE
5289\f RELOC
5290
5291//////////////////////////////////////////////////
5292//////////////////////////////////////////////////
5293///////// OVERLAY 3-FILE MANIPULATING ////////////
5294///////// FUNCTIONS ////////////
5295//////////////////////////////////////////////////
5296//////////////////////////////////////////////////
5297
5298 *3400
5299
5300 /FILE CLOSING ROUTINE
5301
5302 VERSON^100+SUBVFF+6000 /VERSION WORD FOR FILES OVERLAY
5303
5304ANDPTR, ANDLST
5305ANDLST, 7776 /MASKS FOR CLEARING BUFFER AND HANDLER STATUS BITS
5306 7775
5307 7773
5308 7767
5309
5310CLOSE, TAD ENTNO /GET FILE #
5311 SNA CLA /IS IT TTY?
5312 JMP I PILOOP /YES-DON'T DO ANYTHING
5313 JMS I PIDLE /SEE IF FILE OPEN
5314 JMS I PFTYPE /IS FILE NUMERIC?
5315 JMP NOCZ /YES-DON'T OUTPUT ^Z
5316 JMS I (FOTYPE /NO-IS FILE VARIABLE LENGTH?
5317 JMP NOCZ /NO-DON'T OUTPUT ^Z
5318 TAD (232 /YES
5319 JMS I PPUTCH /WRITE A ^Z IN FILE
5320NOCZ, JMS I (WRBLK /WRITE LAST BLOCK IF IT HAS CHANGED
5321 JMS I PPSWAP /RESTORE 17600
5322 JMS I (FOTYPE /IS FILE FIXED LENGTH?
5323 JMP CLOSED /YES-NO NEED TO CLOSE THE FILE
5324 TAD I IOTLEN /NO-GET FILE LENGTH
5325 DCA CLENG /PUT IN CLOSE CALL
5326 TAD IOTFIL
5327 DCA FNAP /POINTER TO FILE NAME
5328 TAD I IOTHDR
5329 CLL RTL
5330 RTL
5331 RAL /GET DEVICE NUMBER INTO BITS 8-11
5332 AND O17 /ISOLATE IT
5333 CIF 10
5334 JMS I O7700 /CALL USR
5335 4 /CLOSE
5336FNAP, . /POINTER TO FILE NAME
5337CLENG, .
5338FC, JMS I PERROR /FILE CLOSING ERROR
5339CLOSED, TAD I IOTBUF /GET BUFFER ADDRESS
5340 CLL RTL
5341 RTL /BUFFER NUMBER INTO AC
5342 RAL /BITS 10,11
5343 AND (3 /STRIP
5344 TAD ANDPTR /USE AS INDEX INTO MASKS
5345 DCA TEMP1
5346 TAD BMAP /BUFFER STATUS MAP
5347 AND I TEMP1 /CLEAR THE BIT FOR THIS BUFFER
5348 DCA BMAP
5349\f TAD I IOTHDR /HEADER WORD
5350 AND O7400 /STRIP HEADER TO DEVICE # ONLY
5351 DCA I IOTHDR
5352 TAD MM4 /-4
5353 DCA TEMP3 /USE AS COUNTER
5354CHECKL, TAD TEMP3 /GET 3 OF FILE TO CHECK
5355 TAD (W0PTR /MAKE POINTER TO PROPER W0 HEADER
5356 DCA TEMP1 /SAVE POINTER
5357 TAD TEMP3 /-# OF FILE WERE CHECKING
5358 TAD ENTNO /COMPARE TO CURRENT NUMBER
5359 SNA CLA /IS IT THIS ONE?
5360 JMP PSTCHK /YES-DON'T CHECK DRIVER
5361 TAD I TEMP1 /GET HEADER WORD FOR THE FILE OF INTEREST
5362 AND O7400 /ISOLATE DEVICE #
5363 CIA /NEGATE
5364 TAD I IOTHDR /COMPARE TO CURRENT DEVICE #
5365 SNA CLA /SAME DEVICE?
5366 JMP CRETN /YES-LEAVE DRIVER IN CORE
5367PSTCHK, ISZ TEMP3 /ALL 4 CHECKED?
5368 JMP CHECKL /NO-CHECK THE NEXT 1
5369 TAD I IOTHDR
5370 AND O10 /GET HANDLER LENGTH BIT
5371 SZA CLA /TWO PAGES?
5372 JMP TPREL /YES-FREE BOTH PAGES
5373 TAD I IOTHND /THIS IS THE ONLY FILE USING HANDLER THEN
5374 CLL RTL
5375 RTL /SLIDE BITS 4,5 OF HANDLER PAGE TO AC BITS 10,11
5376 RAL
5377 AND (3 /ISOLATE HANDLER BUFFER NUMBER
5378 TAD ANDPTR /MAKE POINTER TO PROPER AND MASK
5379RELCOM, DCA TEMP1
5380 TAD DMAP /DRIVER PAGE MAP
5381 AND I TEMP1 /CLEAR HANDLER PAGE BIT
5382 DCA DMAP
5383CRETN, DCA I IOTHND /SET FILE AS IDLE
5384 JMS I PPSWAP /GET RID OF 17600 AGAIN
5385 JMP I PILOOP /DONE
5386
5387TPREL, TAD I IOTHND /ONLY FILE USING HANDLER
5388 CLL RTL
5389 RTL /ISOLATE HANDLER BUFFER NUMBER
5390 RAL
5391 AND (3
5392 TAD (ANDLS2 /USE AS INDEX TO AND MASK
5393 JMP RELCOM
5394
5395W0PTR, FILE1
5396 FILE2 /FILE TABLE ENTRIES
5397 FILE3
5398 FILE4
5399
5400MM4,
5401ANDLS2, 7774
5402 7701
5403
5404/CODE TO READ IN COMPILER AND START IT
5405/THIS CODE GETS MOVED TO FIELD 1 AND EXECUTED FROM
5406/LOC 2001-2013 IN FIELD 1
5407
5408CREAD, CDF 10
5409 CIF 0
5410 4613 /"JMS I L7607K"
5411 3700 /31 PAGES
5412 0 /0-7577
5413CBLK, 7617 /STARTING BLOCK OF COMPILER
5414 HLT /SYSTEM ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
5415 CIF 0
5416 5612 /"JMP I .+1"-START THE COMPILER
5417 7001 /STARTING ADDR OF COMPILER
5418K7607K, 7607
5419 /LESS THAN THE DESIRED VALUE
5420
5421EXTCHK, 0 /SKIP RETURN IF CURRENT
5422 AC0002
5423 IAC
5424 TAD IOTFIL /IS .SV
5425 DCA EXTEMP /JUST A TEMP
5426 TAD I EXTEMP /GET EXTENSION
5427 TAD (-2326
5428 SNA CLA /IS IT .SV?
5429 ISZ EXTCHK /YES: SKIP
5430 JMP I EXTCHK
5431EXTEMP, 0
5432
5433 PAGE
5434\f/CHAIN FUNCTION
5435/SETS UP COMMAND DECODER AREA,THEN CHAINS TO BCOMP.SV
5436
5437CHAIN, JMS I PXPRINT /EMPTY TTY RING BUFFER
5438 JMP .-1
5439 JMS I PPSWAP /RESTORE PG 17600
5440 JMS I DNA2 /GET FILE NAME IN NAME AREA FROM CURRENT FILE
5441 CIF 10
5442 JMS I O7700 /CALL USR
5443 10 /LOCK IN CORE
5444 TAD I IOTDEV
5445 DCA DNA1 /FIRST TWO CHARS OF DEV NAME
5446 TAD I IOTDEV+1 /LAST TWO CHARS
5447 DCA DNA2
5448 CIF 10
5449 JMS I USR
5450 12 /INQUIRE
5451DNA1, 0 /DEVICE NAME
5452DNA2, NAMEG
5453CDIN, 0
5454CI, JMS I PERROR /ERROR
5455 TAD CDIN /GET ENTRY POINT OF DRIVER FOR CHAIN FILE
5456 SZA CLA /IS IT IN CORE?
5457 JMP DISIN /YES-NO NEED TO FETCH IT
5458 TAD DNA2 /NO-DEVICE # INTO AC
5459 CIF 10
5460 JMS I USR
5461 1 /FETCH HANDLER
5462 7001 /INTO PAGE 7000
5463 JMP CI /MAKE IT LOOK LIKE INQUIRE ERROR
5464DISIN, TAD IOTFIL
5465 DCA STB /POINTER TO FILE NAME
5466 TAD DNA2 /GET DEVICE #
5467 CIF 10
5468 JMS I USR
5469 2 /LOOKUP
5470STB, 0 /POINTER TO FILE NAME
5471FLN, 0
5472CL, JMS I PERROR /LOOKUP ERROR
5473 TAD STB /GET STARTING BLOCK
5474 CDF 10
5475 DCA I (7620 /STARTING BLOCK IN CD AREA
5476 TAD FLN /FILE LENGTH
5477 CLL RTL
5478 RTL
5479 AND (7760 /PUT IN BITS 0-7
5480 TAD DNA2 /COMBINE WITH DEVICE #
5481 DCA I (7617 /PUT IN CD AREA
5482 TAD O100 /SET R SWITCH
5483 DCA I (7644
5484 TAD I (7605 /STARTING BLOCK OF COMPILER
5485 SNA /(IS THIS A CORE IMAGE?
5486 JMP CICHAIN /YES: HANDLE SOMEWHAT DIFFERENTLY
5487 CDF
5488 DCA I (CBLK /INTO COMPILER READ CODE
5489 CDF
5490 JMS I (EXTCHK /SKP IF EXTENSION .SV
5491 SKP
5492 JMP CX /ERROR IF IT IS
5493 JMS I (PSWAP2 /NOW EXEC DESTRUCTIVE EXIT CODE
5494 CDF 10
5495 JMP I (CSMOVE /MOVE THE COMPILER READ TO FIELD 1 AND EXECUTE IT
5496
5497CICHAIN,CDF
5498 JMS I (EXTCHK /SKP IF EXTENSION IS .SV
5499CX, JMS I PERROR /ERROR IF NOT
5500 JMS I (PSWAP2 /NOW EXEC ONCE ONLY CLEAN UP ROUTINE
5501 TAD STB
5502 DCA CHNSTB
5503 CIF 10 /NOW DO A RESET AND DELETE TENTATIVE FILES
5504 JMS I USR
5505 13 /RESET
5506 CIF 10 /FLAG TENTATIVE FILE CLEANUP
5507 JMS I USR
5508 6
5509CHNSTB, HLT
5510\f /FILE LOOKUP
5511
5512FLOOK, AC0002
5513 JMS I (ENTLOK /LOOKUP
5514 DCA I IOTLEN /ACTUAL LENGTH
5515 TAD I IOTLEN
5516 DCA I IOTMAX /ALSO EQUALS MAXIMUM LENGTH
5517CLEANP, DCA I IOTPOS /ZERO COLUMN POINTER
5518 CMA /-1
5519 TAD I IOTLOC /STARTING BLOCK-1
5520 DCA I IOTBLK /CURRENT BLOCK #=STARTING BLOCK-1
5521 TAD I IOTBUF
5522 DCA I IOTPTR /READ/WRITE POINTER AT BEGINNING OF BUFFER
5523 CIF 10
5524 JMS I USR /CALL TO USR
5525 11 /USROUT
5526 JMS I PPSWAP /GET RID OF 17600
5527 JMS I (BLZERO
5528 JMS I (NEXREC /DO A NEXREC TO READ IN FIRST FILE BLOCK
5529 JMP I PILOOP /DONE
5530
5531 /ROUTINE FOR INTERPRETER EXIT
5532
5533FSTOP, KSF /IS THE KEYBOARD FLAG SET?
5534 JMP NOCTC /NO-THERE IS NO CHANGE ^C SENT US HERE
5535 TAD O200 /YES-FORCE PARITY BIT
5536 KRB /GET CHARACTER
5537 TAD (-203 /COMPARE AGAINST ^C
5538 SZA CLA /WAS IT ^C?
5539 JMP NOCTC /NO-THIS IS A NORMAL EXIT
5540 TSF
5541 JMP .-1
5542 TAD ("^ /YES -ECHO ^
5543 TLS
5544 CLA
5545 TSF
5546 JMP .-1
5547 TAD ("C /ECHO "C"
5548 TLS
5549NOCTC, TSF
5550 JMP .-1
5551 JMP I (MEXIT
5552
5553 PAGE
5554\f /FILE OPENING ROUTINE
5555
5556OPENAV, TAD (4 /ALPHANUMERIC,VARIABLE LENGTH
5557OPENAF, IAC /ALPHANUMERIC,FIXED LENGTH
5558 JMP OPENNF
5559OPENNV, TAD (4 /NUMERIC,VARIABLE LENGTH
5560OPENNF, DCA I IOTHDR /SET UP HEADER WORD
5561 TAD ENTNO /IS FILE TTY?
5562 SNA CLA
5563 JMP I PILOOP /YES-DON'T DO ANYTHING
5564 TAD I IOTHND /GET HANDLER ENTRY
5565 SZA CLA /IS FILE IDLE?
5566FB, JMS I PERROR /ATTEMPT TO OPEN FILE ALREADY OPEN
5567 JMS I PPSWAP /RESTORE 17600
5568 JMS I (NAMEG /GET FILE DEVICE NAME AND FILE NAME INTO WORDS 7-14 FROM SAC
5569 CIF 10
5570 JMS I O7700 /CALL TO USR
5571 10 /LOCK USR IN CORE
5572 TAD I IOTDEV
5573 DCA DEVNA1 /DEVICE NAME INTO INQUIRE CALL
5574 TAD I IOTDEV+1
5575 DCA DEVNA2
5576 CIF 10
5577 JMS I USR /CALL TO USR
5578 12 /INQUIRE
5579DEVNA1, . /DEVICE NAME
5580DEVNA2, .
5581ENTRYN, 0 /ENTRY POINT
5582IN, JMS I PERROR /INQUIRE ERROR
5583 TAD DEVNA2 /GET DEVICE #
5584 CLL RAR
5585 RTR /PUT INTO BITS 0-3
5586 RTR
5587 TAD I IOTHDR
5588 DCA I IOTHDR /STORE IN HEADER WORD
5589 TAD ENTRYN /GET DRIVER ADDRESS
5590 SZA /IS IT IN CORE?
5591 JMP I (DRIVRN /YES-NO NEED TO FETCH IT
5592 TAD DMAP /NO-GET MAP OF DRIVER PAGES
5593 CLL RAR /PAGE 7000 BIT IN LINK
5594 SNL /IS PAGE 7000 FREE?
5595 JMP FREE70 /YES
5596 CLL RAR /NO-7200 BIT TO LINK
5597 SNL /IS PAGE 7200 FREE?
5598 JMP FREE72 /YES
5599\f CLL RAR /NO-7400 BIT TO LINK
5600 SZL CLA /IS PAGE 7400 FREE?
5601DO, JMS I PERROR /NO-NO MORE ROOM FOR DRIVERS
5602 TAD O7400 /YES-LOAD HANDLER INTO 7400
5603 DCA FETPAG /SET UP IN FETCH CALL
5604 TAD (4 /SET BIT 9 TO SHOW PAGE 7400 OCCUPIED
5605 JMP DFETCH /FETCH DRIVER
5606
5607FREE70, CLL RAR /PAGE 7200 BIT TO LINK
5608 SNL CLA /IS 7200 FREE?
5609 IAC /YES-THERE IS ROOM FOR A TWO PAGE HANDLER
5610 TAD (7000
5611 DCA FETPAG /SET UP FETCH TO USE PAGE 7000
5612 CLL CLA CML RTL /TURN ON BIT 10
5613 DCA TPH /SAVE IN TWO PAGE SET WORD
5614 IAC /SET BIT 11 TO SHOW PAGE 7000 OCCUPIED
5615 JMP DFETCH /FETCH HANDLER
5616
5617FREE72, CLL RAR /7400 BIT TO LINK
5618 SNL CLA /IS 7400 PAGE FREE?
5619 IAC /YES-THEN THERE IS ROOM FOR A 2 PAGE HANDLER
5620 TAD (7200
5621 DCA FETPAG /SET ADDRESS IN FETCH CALL
5622 TAD (4
5623 DCA TPH /IF TWO PAGE LOADED,SET BIT 9 ALSO
5624 AC0002 /TURN ON BIT 10 TO SHOW PAGE 7200 OCCUPIED
5625DFETCH, TAD DMAP /TURN ON PAGE BIT FOR WHERE BUFFER WILL BE LOADED
5626 DCA DMAP
5627 TAD DEVNA2 /DEVICE # IN AC
5628 CIF 10
5629 JMS I USR /CALL TO USR
5630 1 /FETCH
5631FETPAG, . /DRIVER ADDRESS
5632FE, JMS I PERROR /FETCH ERROR
5633 CDF 10
5634 CLA CMA
5635 TAD I (37 /GET ADDR OF HANDLER INFO TABLE
5636 TAD DEVNA2 /USE THE DEVICE # AS AN INDEX INTO THAT TABLE
5637 DCA TEMP1 /SAVE POINTER
5638 TAD I TEMP1 /GET THE INFO WORD FOR THE HANDLER JUST FETCHED
5639 CDF
5640 SMA CLA /IS HANDLER 2 PAGES LONG?
5641 JMP DRAP /NO MAP IS COMPLETE
5642 TAD TPH /YES-UPDATE DRIVER MAP TO INCLUDE
5643 TAD DMAP /SECOND PAGE OF TWO PAGE HANDLERS
5644 DCA DMAP
5645 TAD O10
5646 TAD I IOTHDR /SET 2 PAGE BIT IN HEADER WORD
5647 DCA I IOTHDR
5648DRAP, TAD FETPAG /HANDLER ENTRY ADDRESS
5649 JMP I (DRIVRN /PAGE ESCAPE
5650
5651TPH, 0
5652\f/ROUTINE TO MOVE THE COMPILER READER INTO FIELD 1 AND START IT
5653
5654CSMOVE, TAD (CREAD-1
5655 DCA XR1 /POINTES TO COMPILER STARTING CODE
5656 TAD (-13
5657 DCA TEMP1 /COUNTER
5658 TAD (2000
5659 DCA XR2 /MOVE TO LOC 2001 IN FIELD 1
5660 CDF
5661 TAD I XR1 /GET WORD OF CODE
5662 CDF 10
5663 DCA I XR2 /MOVE IT
5664 ISZ TEMP1 /DONE?
5665 JMP .-5 /NO
5666 CIF 10 /YES-START IT
5667 JMS I (2000
5668
5669 PAGE
5670\fDRIVRN, DCA I IOTHND /DRIVER ENTRY INTO I/O TABLE
5671 TAD BMAP /GET BUFFER MAP
5672 CLL RAR /BUFF1 BIT TO LINK
5673 SNL /IS IT FREE?
5674 JMP B1 /YES-ASSIGN BUFF1
5675 RAR /BUFF2 BIT TO LINK
5676 SNL /IS IT FREE?
5677 JMP B2 /YES-ASSIGN BUFF2
5678 RAR /BUFF3 BIT TO LINK
5679 SNL /IS IT FREE
5680 JMP B3 /YES-ASSIGN BUFF3
5681 RAR /NO-BUFF4 BIT TO LINK
5682 SZL CLA /IS IT FREE?
5683BO, JMS I PERROR /NO-NO MORE BUFFERS AVAILABLE
5684 TAD (1400
5685 DCA I IOTBUF /SET BUFFER ADDRESS TO 1400
5686 TAD O10 /SET BUFF4 BIR IN MAP
5687 JMP BUFASS
5688
5689B3, CLA
5690 TAD (1000
5691 DCA I IOTBUF /SET BUFFER ADDRESS TO 1000
5692 TAD (4
5693 JMP BUFASS /SET BUFF3 BIT IN MAP
5694
5695B2, CLA
5696 TAD O400
5697 DCA I IOTBUF /SET BUFF ADDRESS TO 400
5698 CLL CML CLA RTL /SET BUFF2 BIT IN MAP
5699 JMP BUFASS
5700
5701B1, CLA
5702 DCA I IOTBUF /SET BUFF ADDRESS TO 0000
5703 CLA IAC /TURN ON BUFF1 BIT IN MAP
5704\fBUFASS, TAD BMAP
5705 DCA BMAP /UPDATE BUFFER ASSIGNMENT MAP
5706 TAD I IOTHDR /GET HEADER WORD
5707 CLL RTR
5708 RAR /FIXED,VARIABLE BIT TO LINK
5709 SNL CLA /IS IT FIXED?
5710 JMP I (FLOOK /YES-DO A LOOKUP
5711 TAD (3 /NO-DO AN ENTER
5712 JMS ENTLOK /ENTER
5713 DCA I IOTMAX /MAXIMUM LENGTH IN WORD 7
5714 DCA I IOTLEN /ZERO ACTUAL LENGTH
5715 JMP I (CLEANP /FINALIZE I/O TABLE ENTRY
5716
5717MEXIT, CLA
5718 JMS I PPSWAP
5719 JMS I (PSWAP2 /RESTORE PG 27600
5720 CDF 10
5721 TAD I (EDBLK /GET BLOCK # FOR EDITOR
5722 CDF
5723 SNA /SHALL WE CALL THE EDITOR?
5724 JMP I (7600 /NOkJUST CALL OS/8
5725 DCA EBLK /YES-PUT THE BLOCK # IN DRIVER CALL
5726 JMS I (7607 /CALL SYS DRIVER
5727 2100 /READ 8 BLOCKS
5728 0 /INTO 0-3377
5729EBLK, . /BLOCK # OF EDITOR
5730 HLT /SYS ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
5731 JMP I .+1 /START THE EDITOR
5732 3212
5733\fENTLOK, 0
5734 DCA FNOM /FUNCTION NUMBER IN PLACE
5735 TAD IOTFIL /POINTER TO FILE NAME
5736 DCA STARTB /INTO CALL
5737 TAD I (DEVNA2 /DEVICE NUMBER
5738 CIF 10
5739 JMS I USR /CALL TO USR
5740FNOM, . /ENTER OR LOOKUP
5741STARTB, .
5742FLEN, .
5743EN, JMS I PERROR /ENTER ERROR
5744 TAD STARTB /FILE STARTING BLOCK #
5745 SZA CLA /IS IT NON-ZERO?
5746 JMP FILSTU /YES-DEVICE IS FILE STRUCTURED
5747 TAD FLEN /NO-GET FILE LENGTH
5748 SZA CLA /IS IT EMPTY?
5749 JMP FILSTU /NO-DEVICE IS FILE STRUCTURED
5750 TAD (20 /NO-FILE IS READ/WRITE ONLY
5751 TAD I IOTHDR
5752 DCA I IOTHDR /SET READ/WRITE ONLY BIT
5753 TAD FNOM
5754 CLL RAR
5755 SNL CLA
5756 IAC
5757FILSTU, TAD STARTB /GET STARTING BLOCK # OF FILE
5758 DCA I IOTLOC /PUT IN I/O TABLE
5759 TAD FLEN /FILE LENGTH
5760 CIA /MAKE FILE LENGTH POSITIVE
5761 JMP I ENTLOK /RETURN
5762\f/SUBROUTINE P2SWAP-RESTORE OS/8 RESIDENT MONITOR PRIOR TO EXIT FROM INTERPRETERTER
5763/THIS IS DESTRUCTIVE CODE,AND ONCE THIS ROUTINE HAS BEEN EXECUTED
5764/THERE IS NO PLACE TO GO BUT OUT.
5765/HAS 3 FUNCTIONS:
5766/ 1) REMOVES CTRL/C HOOKS FROM SYS DRIVER
5767/ 2) RESTORES BATCH CONTROL WORDS TO 27774-27777
5768/ 3) IF SYS=TD/8E,RESTORES PAGE 27600 AND RETURNS CDFS TO PAGE 07600
5769
5770PSWAP2, 0
5771 TAD (4207
5772 DCA I (7600 /REMOVE CTRL/C HOOKS
5773 TAD (6213
5774 DCA I (7605
5775 TAD (7600
5776 DCA I (HICORE /FUDGE POINTER IN SWAP ROUTINE (IN CASE IT WAS TD8E)
5777 TAD PSFLAG /GET RESIDENT STATUS FLAG
5778 SPA CLA /IS THIS TD8/E SYS?
5779 JMS I (PSWP2P /YES-RESTORE PAGE 27600 AND PAGE 07600
5780 TAD CDFIO
5781 DCA .+3 /CDF TO HI CORE
5782 CDF 10
5783 TAD I BOSPT1 /GET BATCH WORD
5784 CDF 10
5785 DCA I BOSPT2 /BACK INTO LOFTY STATE
5786 ISZ BOSPT1
5787 ISZ BOSPT2
5788 JMP .-6
5789 CDF
5790 JMP I PSWAP2 /YES-WE ARE FINISHED,SO RETURN
5791BOSPT1, 7600
5792BOSPT2, 7774
5793
5794 PAGE
5795\f /PARSE A FILENAME OF THE FORM "DEVN:FILENM.EX" IN THE SAC
5796 /DSK: AND A NULL EXTENSION ARE THE DEFAULTS
5797 /THE END OF THE SAC IS USED AS A WORK AREA
5798 /IF SYNTAX IS CORRECT, THE NAME IS PACKED INTO
5799 /THE FILENAME FIELD OF THE CURRENT FILE
5800 /OTHERWISE A FATAL ERROR IS RETURNED
5801 /ENTERED WITH OS/8 SWAPPED IN
5802
5803 WKAREA= SAC+16 /DEFINE SCRATCH AREA
5804
5805NAMEG, 0
5806 TAD SACLEN
5807 TAD (16 /COMPARE STRING LENGTH TO 16
5808 SPA CLA
5809IF, JMS I PERROR /TOO MANY CHARS IN "DEV:FILENM.EX"
5810 TAD SACLEN
5811 DCA TEMP2 /STRING LENGTH COUNTER
5812 TAD PSACM1
5813 DCA SACXR
5814 TAD (DSK-1 /FIRST USE THE DEFAULT DEVICE
5815 JMS DEVFUD
5816NCG, TAD I SACXR /GET CHAR FROM SAC
5817 DCA TEMP1 /SAVE
5818 TAD TEMP1
5819 TAD (-72 /IS IT A COLON?
5820 SNA
5821 JMP CAD /YES-CHARS SO FAR=DEVICE NAME
5822 TAD (14 /NO-IS IT A PERIOD?
5823 SNA CLA
5824 JMP SSAD /YES-NEXT TWO CHARS=EXTENSION
5825 TAD TEMP1 /NO-GET CHAR AGAIN
5826 DCA I XR2 /STORE IN WORK AREA
5827 ISZ TEMP4 /BUMP COUNT FOR CURRENT SECTION
5828NCGS, ISZ TEMP2 /END OF STRING YET?
5829 JMP NCG /NO-NEXT CHAR
5830\f TAD TEMP4 /YES-GET CHAR COUNT FOR THIS SECTION (NAME)
5831 TAD (-6
5832 SMA SZA CLA /IS IT >6?
5833 JMP IF /YES-TOO MANY CHARACTERS IN FILE NAME
5834 TAD (WKAREA-1 /NO-ADDRESS OF SCRATCH NAME BLOCK
5835 DCA XR1
5836 STA /-1
5837 TAD IOTDEV /ADDRESS OF FINAL NAME BLOCK-1
5838 DCA XR2
5839 TAD (-6 /MOVE 6 WORDS
5840 DCA TEMP2
5841MML, TAD I XR1
5842 CLL RTL
5843 RTL
5844 RTL
5845 TAD I XR1
5846 DCA I XR2 /MOVE NAME WORD FROM SCRATCH AREA TO FINAL DEST
5847 ISZ TEMP2 /DONE?
5848 JMP MML /NO
5849 JMP I NAMEG /YES-RETURN
5850
5851CAD, TAD TEMP4 /GET CHAR COUNT FOR THIS SECTION
5852 TAD (-4 /COMPARE AGAINST 4
5853 SMA SZA CLA /TOO MANY CHARS?
5854 JMP IF /YES-DEVICE NAME TOO LONG
5855 TAD (WKAREA-1+4
5856 JMS DEVFUD /CLEAR BUF AND GET NAME FROM FILE FIELD THIS TIME
5857 JMP NCGS
5858
5859SSAD, TAD TEMP4 /COUNT FOR THIS SECTION (FILE NAME)
5860 TAD (-6
5861 SMA SZA CLA /TOO MANY?
5862 JMP IF /YES-FILE NAME TOO LONG
5863 DCA TEMP4 /NO-CLEAR COUNT
5864 TAD DSK
5865 TAD TEMP2 /COMPARE AGAINST # OF CHARS LEFT
5866 SPA SNA CLA
5867 JMP IF /TOO MANY CHARS IN EXTENSION
5868 TAD (WKAREA-1+12
5869 DCA XR2
5870 JMP NCGS
5871
5872DEVFUD, 0
5873 DCA XR1 /POINT AT LOC OF DEV:
5874 TAD (WKAREA-1
5875 DCA XR2 /POINT AT START OF WORK AREA
5876 TAD (-10
5877 DCA TEMP4
5878 TAD (-4
5879 DCA TEMP3
5880 TAD I XR1 /GET A DEVICE NAME BYTE
5881 DCA I XR2 /STORE IN WORK AREA DEVICE FIELD
5882 ISZ TEMP3
5883 JMP .-3 /ITERATE
5884 DCA I XR2 /NOW CLEAR REST OF FILE NAME
5885 ISZ TEMP4
5886 JMP .-2 /ITERATE
5887 TAD (WKAREA-1+4 /POINT XR2 AT FILENAME FIELD
5888 DCA XR2
5889 JMP I DEVFUD /RETURN WITH TEMP4 CLEAR
5890
5891DSK, 4;23;13;0 /6BIT DEFAULT DEVICE NAME "DSK"
5892\f/SUBROUTINE TO RESTORE PAGE 27600 OF TD8/E DRIVER
5893/AND READJUST THE CDFS IN FIELD 0
5894
5895PSWP2P, 0
5896 TAD PSFLAG
5897 RTL
5898 SNL CLA /BIT 1 SET MEANS PHONEY TD8E
5899 JMP .+3
5900 DCA PSFLAG
5901 JMP I PSWP2P
5902 DCA PSFLAG /CLEAR RESIDENT STATUS FLAG
5903 TAD (CDF 20
5904 DCA I (P2CDF /PUT CDF 20 IN SWAP ROUTINE
5905 TAD (CDF 20
5906 DCA I (P2CDF1
5907 JMS I PPSWAP /MOVE DOWN PAGE 27600
5908 TAD (6223
5909 DCA I (7642
5910 TAD (6222
5911 DCA I (7721
5912 TAD (6222 /RESTORE CDFS IN PAGE 07600
5913 DCA I (7727
5914 JMP I PSWP2P /RETURN
5915
5916 PAGE
5917\f
5918
5919
5920 FIELD 0
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935/////////////////////////////////////////////////////////////////////
5936/////////////////////////////////////////////////////////////////////
5937/////////////// END OF OVERLAY AREA /////////////////////////////////
5938/////////////////////////////////////////////////////////////////////
5939/////////////////////////////////////////////////////////////////////
5940
5941 $
5942\f<:STTYF, 1\e+1"E0;'
5943J<S\13PRINT\13\e;R-5DI[XPRINT\e>
5944J<S\13SACPTR\13\e;R-6DI[SAC-1\e>
5945J<S\13PUTCHL\13\e;R-6DI[PUTCH\e>
5946J<S\13ILOOPL\13\e;R-6DI[ILOOP\e>
5947J<S\13INTL\13\e;R-4DI[UNSFIX\e>
5948J<S\13CDFPSL\13\e;R-6DI[CDFPSU\e>
5949J<S\13ERROR\13\e;R-5DI[ERRDIS\e>
5950J<S\13FBITS\13\e;R-5DI[FBITGT\e>
5951J<S\13PWFECL\13\e;R-5DI[PWFECH\e>
5952J<S\13MPYLNK\13\e;R-6DI[MPY\e>
5953J<S\13XPUT\13\e;R-4DI[XPUTCH\e>
5954J<S\13FIDLE\13\e;R-5DI[IDLE\e>
5955J<S\13DEVCAL\13\e;R-6DI[DRCALL\e>
5956J<S\13WRITFW\13\e;R-6DI[WRITFL\e>
5957J<S\13STHINL\13\e;R-6DI[STHINI\e>
5958J<S\13LDHINL\13\e;R-6DI[LDHINI\e>
5959J<S\13STH\13\e;R-3DI[STHL\e>
5960J<S\13LDH\13\e;R-3DI[LDHL\e>
5961J<S\13FACSAL\13\e;R-6DI[FACSAV\e>
5962J<S\13FACREL\13\e;R-6DI[FACRES\e>
5963J<S\13FGETL\13\e;R-5DI[FFGET\e>
5964J<S\13FPUTL\13\e;R-5DI[FFPUT\e>
5965J<S\13FNORL\13\e;R-5DI[FFNOR\e>
5966J<S\13FCLR\13\e;R-4DI[FACCLR\e>
5967J<S\13FNEGL\13\e;R-5DI[FFNEG\e>
5968J<S\13FLOATL\13\e;R-6DI[FFLOAT\e>
5969J<S\13GETCHL\13\e;R-6DI[GETCH\e>
5970J<S\13EOFSEL\13\e;R-6DI[EOFSET\e>
5971J<S\13BSWL\13\e;R-4DI[BSWP\e>
5972J<S\13PACKL\13\e;R-5DI[PACKCH\e>
5973J<S\13CNOCLL\13\e;R-6DI[CNOCLR\e>
5974J<S\13BUFCHL\13\e;R-6DI[BUFCHK\e>
5975J<S\13FTYPL\13\e;R-5DI[FTYPE\e>
5976J<S\13CHRNOL\13\e;R-6DI[CHARNO\e>
5977J<S\13NEXREL\13\e;R-6DI[NEXREC\e>
5978J<S\13CRLF\13\e;R-4DI[CRLFR\e>
5979J<S\13VALLK\13\e;R-5DI[VALGET\e>
5980J<S\13PATCHP\13\e;R-6DI[PATCHF\e>
5981J<S\13P1SWAP\13\e;R-6DI[PSWAP\e>
5982J<S\13LDHRST\13\e;R-6DI[LRESET\e>
5983J<S\13STHRST\13\e;R-6DI[SRESET\e>
5984P>
5985\f
My complete PDP-8 universe