Commit | Line | Data |
---|---|---|
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 | |
138 | USECON, 0 /USE CONSTANT GENERATED BY "USE" STATEMENT | |
139 | FSTOP1, 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 | |
144 | SACXR, 15 /INDEX REGISTER FOR STRING ROUTINES | |
145 | XR1, VCHECK | |
146 | XR2, 0 | |
147 | XR3, 0 | |
148 | XR4, 4 /INDEX REGISTERS | |
149 | XR5, 0 | |
150 | DATAXR, 0 /POINTER FOR IN-CORE DATA LIST | |
151 | SPINNR, 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 | ||
159 | CDFIO, 6211 /* CDF FOR I/O TABLE AND SYMBOL TABLES | |
160 | SCSTRT, 0 /* POINTER TO START OF SCALAR SYMBOL TABLE | |
161 | ARSTRT, 0 /* POINTER TO START OF ARRAY SYMBOL TABLE-1 | |
162 | STSTRT, 0 /* POINTER TO START OF STRING SYMBOL TABLE-1 | |
163 | SASTRT, 0 /* POINTER TO START OF STRING ARRAY TABLE-1 | |
164 | CDFPS, 0 /* CDF FOR START OF PSEUDO-CODE | |
165 | PSSTRT, 0 /* POINTER TO START OF PSEUDO CODE-1 | |
166 | DLSTOP, 0 /* POINTER TO TOP OF DATA LIST | |
167 | DLSTRT, 0 /* POINTER TO BOTTOM OF INCORE DATA LIST-1 | |
168 | PSFLAG, 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 | ||
176 | SACLEN, 0 /LENGTH OF STRING IN SAC | |
177 | S1, 0 /SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!) | |
178 | S2, 0 /SUBSCRIPT 2 (MUST BE PRECEEDED BY S1!) | |
179 | DMAP, 0 /MAP OF DRIVER PAGES | |
180 | BMAP, 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 | ||
189 | FF, 0 /SPECIAL MODE FLIP-FLOP | |
190 | TEMP1, | |
191 | AC0, 0 | |
192 | AC1, 0 | |
193 | TEMP3, | |
194 | AC2, 0 | |
195 | TM, | |
196 | TEMP4, 6201 | |
197 | ACX, 0 /FAC-EXPONENT | |
198 | ACH, 0 /FAC-HIGH ORDER MANTISSA | |
199 | ACL, 0 /FAC-MANTISSA LOW | |
200 | TEMP5, | |
201 | OPX, 0 | |
202 | TEMP6, | |
203 | OPH, 0 | |
204 | TEMP7, | |
205 | OPL, 0 | |
206 | DSWIT, 0 /SWITCH USED BY INPUT ROUTINE | |
207 | CHAR, 215 /TERMINATOR OF LAST INPUT | |
208 | TEMP10, 0 /LOC NEEDED BY FPP | |
209 | ||
210 | DECEXP= TEMP10 | |
211 | ||
212 | /SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE | |
213 | ||
214 | MODESW, 0 /0 FOR ARTHIMETIC MODE,1 FOR STRING MODE | |
215 | INSAV, 0 /CURRENT PSEUDO-INSTRUCTION BEING EXECUTED | |
216 | LINEHI, 0 /HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED | |
217 | LINELO, 0 /LOW ORDER BITS OF CURRENT LINE NUMBER | |
218 | STRMAX, 0 /MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING | |
219 | STRCNT, 0 /- # OF CHARACTERS IN CURRENT STRING | |
220 | STRPTR, 0 /POINTER TO SIZE WORD OF CURRENT OPERAND STRING | |
221 | TEMP2, 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 | ||
243 | ENTNO, 0 /ENTRY NUMBER NOW IN AREA | |
244 | IOTHDR, TTYF /HEADER WORD | |
245 | IOTBUF, TTYF+1 /BUFFER ADDRESS | |
246 | IOTBLK, TTYF+2 /CURRENT BLOCK IN BUFFER | |
247 | IOTPTR, TTYF+3 /READ\WRITE POINTER | |
248 | IOTHND, TTYF+4 /HANDLER ENTRY POINT | |
249 | IOTLOC, TTYF+5 /FILE STARTING BLOCK # | |
250 | IOTLEN, TTYF+6 /ACTUAL FILE LENGTH | |
251 | IOTMAX, TTYF+7 / DEVICE / (FILE MAXIMUM LENGTH) | |
252 | IOTPOS, TTYF+10 / NAME / (POSITION OF PRINT HEAD) | |
253 | IOTFIL, TTYF+11 / | |
254 | / TTYF+12 / FILE | |
255 | / TTYF+13 / NAME | |
256 | / TTYF+14 / .EX | |
257 | ||
258 | IOTDEV= IOTMAX | |
259 | \f *200 | |
260 | ||
261 | /FETCH NEXT PSEUDO WORD | |
262 | ||
263 | PWFECH, 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 | |
269 | CDFPSU, 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 | |
273 | O7770, 7770 | |
274 | ||
275 | SSMODE, IAC /SET INTERPRETER TO STRING MODE | |
276 | AMODE, DCA MODESW /SET INTERPRETER TO ARITH MODE | |
277 | /FALL BACK INTO I-LOOP | |
278 | ||
279 | /BRTS I-LOOP | |
280 | ||
281 | ILOOP, 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 | |
303 | ILOOPF, . /JMS TO THE FLOATING POINT PACKAGE ROUTINE | |
304 | NOP /FPP SOMETIMES RETURNS TO CALL+2 | |
305 | JMP ILOOP /DONE | |
306 | ||
307 | SCASE, TAD JMPI /JUST DISPATCH TO ROUTINE CALLED FOR | |
308 | DCA .+1 | |
309 | . /JUMP TO APPROPRIATE ROUTINE | |
310 | ||
311 | JMSI, JMS I SEP1 /JMS USED FOR CALLS TO FPP BY AMODE INST | |
312 | JMPI, 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 | |
324 | SEP1, 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 | ||
334 | SMODE, 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 | |
339 | SDIS, . /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 | |
349 | INTPC, . /* INTERPRETER PC | |
350 | SLOAD /SAC_C(A$) | |
351 | SSTORE /C(A$)_SAC | |
352 | STFINL, STFIND /* LINK TO STRING FINDING ROUTINE | |
353 | JMSSI, 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 | ||
357 | ARGPRE, 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 | |
365 | SCALDF, 1000 /DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER) | |
366 | JMP I ARGPRE /RETURN | |
367 | ||
368 | /ROUTINE TO ZERO FAC | |
369 | ||
370 | FACCLR, -4 | |
371 | L7600, 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 | ||
380 | START1, | |
381 | SAC, 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 | |
405 | OVML, 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 | |
414 | L7746, 7746 | |
415 | PINFO, 7607 | |
416 | POVTAB, ARITHA-1 | |
417 | PS1L, P1CDF | |
418 | PS2L, P1CDF1 | |
419 | PFUDSC, FUDSC | |
420 | ||
421 | PAGE | |
422 | ||
423 | FUDSC, 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 | |
441 | PHEIGHT,HEIGHT | |
442 | PHCTR, HCTR | |
443 | PSCOPW, SCOPWD | |
444 | PSCOPF, SCOPFG | |
445 | PHICOR, HICORE | |
446 | \f *SAC+SACLIM+1 /ORIGIN PAST SAC+ONE GUARD CHAR | |
447 | ||
448 | /JUMP ON CONDITION | |
449 | ||
450 | FJOCI, 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 | |
461 | JFAIL, JMS I [PWFECH /CONDITION FALSE-DON'T JUMP,BUT BUMP PC | |
462 | JMP I [ILOOP /DONE | |
463 | ||
464 | /JUMP ON END OF FILE | |
465 | ||
466 | JEOFI, 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 | ||
473 | SUCJMP, 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 | ||
482 | K7554, 7554 /MUST PRECEDE SKIP TABLE | |
483 | ||
484 | /SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS | |
485 | ||
486 | K7600, 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 | ||
495 | JFORL, JFOR | |
496 | INTPCL, INTPC | |
497 | 0000;0 /MARK BEGINNING OF GOSUB STACK | |
498 | GSTCK, 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 | ||
510 | DRCALL, 0 | |
511 | DCA DRARG1 /FUNCTION WORD INTO DRIVER CALL | |
512 | CDFINL, 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 | |
520 | DRARG1, 0 /FUNCTION CONTROL WORD | |
521 | DRARG2, 0 /BUFFER ADDRESS | |
522 | DRARG3, 0 /BLOCK # | |
523 | SMA CLA /DEVICE ERROR-IS IT FATAL? | |
524 | JMP I DRCALL /ALLS WELL | |
525 | DE, JMS I [ERROR /FATAL | |
526 | DRIVER, 0 | |
527 | ||
528 | /CALL TO INTERPRETER EXITING ROUTINE | |
529 | ||
530 | FSTOPN, JMS I [XPRINT /ON NORMAL EXITS,WE MUST EMPTY RING BUFFER | |
531 | JMP .-1 /FIRST | |
532 | FSTOPI, 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 | ||
540 | USE, 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 | ||
549 | ARRAYI, 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 | |
557 | ATABDF, . /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? | |
568 | SU, 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 | |
581 | ADCALC, 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" | |
620 | ADFC, . /CHANGE DF TO DF OF ARRAY ELEMNT | |
621 | TAD XR1 /AC POINTS TO ARRAY ELEMENT | |
622 | ARJMP, . /PERFORM THE REQUIRED OPERATION | |
623 | NOP /FPP SOMETIMES RETURNS TO CALL+2 | |
624 | JMP I [ILOOP /DONE | |
625 | ||
626 | /ARRAY JUMP TABLE | |
627 | ||
628 | AJT, 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 | |
634 | FPUTLL, FFPUT /C(A(S1,S2)=FAC OPCODE 6 | |
635 | FFDIV1 /FAC=A(S1,S2)/FAC OPCODE 7 | |
636 | \f /STRING ARRAY DISPATCH | |
637 | ||
638 | SARRAY, 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 | |
647 | SAD, . /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 | ||
654 | JMPISA, 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 | |
659 | K0037, 37 /* | |
660 | STFILK, STFIND /* LINK TO STRING FINDING ROUTINE | |
661 | SLOAD /SAC_C(A$(S1)) | |
662 | SSTORE /C(A$(S1))_SAC | |
663 | JMPI2, JMS I AJT /* DISPATCH JUMP FOR ARRAY INST | |
664 | \f/ROUTINE TO PUT ONE WORD IN FILE BUFFER IN FIELD 1 | |
665 | ||
666 | BCPUT, 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 | |
676 | CDF0, 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 | ||
695 | XPUTCH, 0 | |
696 | DCA CHRSAV /SAVE THE CHARACTER | |
697 | XPUT1, 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 | |
703 | PUTCHR, 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 | ||
717 | BUFIN, BSTRT /POINTER TO NEXT SLOT FOR BUFFER INPUT | |
718 | BUFOUT, BSTRT /POINTER TO NEXT CHARACTER TO BE PRINTED | |
719 | BSTRTA, BSTRT /ADDR OF START OF TTY BUFFER | |
720 | BCNT, 30 /# OF AVAILABLE SLOTS IN BUFFER (40 INITIALLY) | |
721 | CHRSAV=TEMP1 | |
722 | MBEND, -BEND /-ADDR OF END OF RING BUFFER | |
723 | MCTRLC, -3 | |
724 | M50, -30 | |
725 | MXON, -21+3 | |
726 | MXOFF, -23+21 | |
727 | XFLAG, 0 | |
728 | ||
729 | ||
730 | XPRINT, 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 | |
748 | NOCC, 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 | |
770 | BOUTRS, ISZ BCNT /INCREMENT # OF FREE SLOTS (WE JUST PRINTED ONE) | |
771 | JMP I XPRINT /RETURN | |
772 | ||
773 | RECP2, ISZ XPRINT /BUMP RETURN | |
774 | JMP I XPRINT /RETURN TO CALL+2 FOR EMPTY BUFFER | |
775 | ||
776 | ||
777 | /TELETYPE RING BUFFER | |
778 | ||
779 | BSTRT, "B /START OF BUFFER | |
780 | "R | |
781 | "T | |
782 | "S | |
783 | " | |
784 | "V | |
785 | VERLOC, 260+VERSON | |
786 | 300+SUBVER | |
787 | 0215 | |
788 | 0212 | |
789 | VEREND, 0212 | |
790 | VCHECK, 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 | |
802 | BEND, | |
803 | N7644, 7644 | |
804 | ||
805 | \f /LINE NUMBERS | |
806 | ||
807 | LINEI, 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 # | |
811 | TRHOOK, 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 | ||
822 | KC240, 240 /STOPPER TO MARK BEGINNING OF BUFFER | |
823 | INTERB, | |
824 | START3, 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 | |
831 | FPPTM5, TAD CDFIO /CDF FOR SYMBOL TABLES | |
832 | DCA I ATABDL /PUT IN LINE FOR ARRAY CALCULATIONS | |
833 | TAD CDFIO /CDF FOR SCALAR TABLE | |
834 | FPPTM4, DCA I SCALDL /PUT IN LINE FOR ARGPRE | |
835 | TAD CDFIO | |
836 | DCA I DLCDFL /DATA FIELD FOR DATA LIST | |
837 | FPPTM3, TAD DLSTRT | |
838 | DCA DATAXR /DO A RESTORE IN INCORE DATA LIST | |
839 | JMP I .+1 /CONTINUE INITAILIZATION CODE IN TTY INPUT BUFFER | |
840 | FPPTM2, START4 | |
841 | ATABDL, ATABDF | |
842 | STDFL, STDF | |
843 | FPPTM1, /FLOATING POINT TEMPORARY | |
844 | INTPCK, INTPC | |
845 | DLCDFL, DLCDF | |
846 | SCALDL, SCALDF | |
847 | ||
848 | PAGE | |
849 | \f /VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE) | |
850 | ||
851 | HEIGHT, 0 /NEGATIVE SCREEN HEIGHT | |
852 | DELAY, 0 /NEGATIVE DELAY VALUE | |
853 | IFNZRO HEIGHT-1200 <__FIX SET COMMAND__> | |
854 | HCTR, 0 /HEIGHT COUNTER INITIALIZED BY SET | |
855 | DCTR, 0 /DELAY COUNTER INITIALIZED BY SET | |
856 | ||
857 | /LOW LEVEL ROUTINE TO TYPE A CHAR | |
858 | ||
859 | PCH, 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 | |
875 | DLOOP, 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 | ||
886 | OPERI, 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 | ||
892 | JMPI3, 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 | |
904 | MSPACE, 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 | ||
915 | PSWAP, 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 | |
924 | P1CDF, HLT /DF TO HI CORE | |
925 | TAD I TEMP2 /GET WORD FROM HI CORE | |
926 | DCA TEMP4 /SAVE IT | |
927 | P2CDF, CDF 10 | |
928 | TAD I TEMP1 /GET WORD FROM 17600 | |
929 | P1CDF1, HLT /DF TO HI CORE AGAIN | |
930 | DCA I TEMP2 /PUT 17600 WORD IN HI CORE | |
931 | P2CDF1, 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 | |
935 | KK7600, 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 | |
940 | HICORE, 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 | ||
948 | OADD, 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 | ||
965 | AL1, 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 | ||
980 | LSUB2I, ISZ DCASUB | |
981 | JMP LSUB1I | |
982 | LS2I, ISZ DCASUB | |
983 | LS1I, 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) | |
986 | LSUB1I, JMS I [FACSAV /SAVE THE FAC | |
987 | JMS I [UNSFIX /GET INT(FAC) | |
988 | DCASUB, 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 | |
993 | DCAS1, DCA S1 | |
994 | ARGPRL, ARGPRE | |
995 | ||
996 | /JMP DISPATCH FOR FUNC1 CALLS | |
997 | ||
998 | JMSI4, 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 | ||
1015 | JMSI5, 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 | ||
1035 | JMPFIL, 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 | ||
1049 | IA, JMS I [ERROR | |
1050 | \f /FUNCTION OVERLAY DRIVER | |
1051 | ||
1052 | FUNC4I, JMS I [XPRINT /PURGE TTY RING BUFFER | |
1053 | JMP .-1 /BEFORE CALLING USER FUNCTION | |
1054 | IAC /LOOK FOR OVERLAY FLAG=3 | |
1055 | FUNC5I, IAC /LOOK FOR OVERLAY FLAG=2 | |
1056 | FUNC2I, IAC /LOOK FOR OVERLAY FLAG=1 | |
1057 | FUNC1I, 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 | |
1072 | OVADD, . /STARTING BLOCK # OF OVERLAY | |
1073 | OE, JMS I [ERROR /I/O ERROR | |
1074 | TAD TEMP1 | |
1075 | DCA OVRLAY /CHANGE RESIDENT FLAG | |
1076 | OVDNE, 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 | |
1083 | FUJUMP, DCA .+1 /PUT JUMP IN LINE | |
1084 | . /GO TO DESIRED FUNCTION | |
1085 | JMP I [ILOOP /DONE | |
1086 | ||
1087 | OATADI, ARITHA | |
1088 | L7607, 7607 | |
1089 | OVRLAY, 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 | ||
1095 | ARITHA, . /STARTING BLOCK OF ARITHMETIC OVERLAY | |
1096 | STRNGA, . /STARTING BLOCK OF STRING OVERLAY | |
1097 | FILEFA, . /STARTING BLOCK OF FILE OVERLAY | |
1098 | USRA, . /STARTING BLOCK OF USER FUNCTIONS | |
1099 | ||
1100 | JMSTAD, TAD I TADTAB | |
1101 | ||
1102 | TADTAB, JMSI4 | |
1103 | JMSI5 | |
1104 | JMPFIL | |
1105 | JMSUSR | |
1106 | ||
1107 | \f/CALL FOR RESIDENT FUNCTION | |
1108 | ||
1109 | FUNC3I, 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 | ||
1113 | JMSI7, 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 | |
1130 | JMSUSR, 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 | ||
1153 | SPFUNC, JMS I [FBITGT /ISOLATE FUNCTION BITS | |
1154 | TAD JMPI6 /MAKE A JUMP OFF SPECIAL FUNCTION TABLE | |
1155 | DCA .+1 /PUT IN LINE | |
1156 | . | |
1157 | ||
1158 | JMPI6, 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 | ||
1174 | UNSFIX, 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? | |
1181 | FM, 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? | |
1192 | FO, JMS I [ERROR /YES | |
1193 | DCA ACX /NO-STORE COUNT | |
1194 | TAD ACH /HI MANTISSA | |
1195 | UNSLP, CLL RAR /SCALE RIGHT | |
1196 | ISZ ACX /DONE? | |
1197 | JMP UNSLP /NO | |
1198 | JMP I UNSFIX /YES-RETURN | |
1199 | ||
1200 | UNSOUT, TAD ACH /ANSWER IN AC | |
1201 | JMP I UNSFIX | |
1202 | ||
1203 | /RESTORE ROUTINE | |
1204 | ||
1205 | RESTOR, 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 | |
1219 | RESDLS, 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 | ||
1228 | STFIND, 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 | |
1238 | STCOM, DCA XR2 /POINTER TO THIS ENTRY IN STRING TABLE | |
1239 | STDF, . /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 | |
1269 | STRCDF, 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 | ||
1278 | SAFIND, 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 | ||
1288 | PNT, 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 | ||
1298 | SFN, JMS I [UNSFIX /FIX FAC TO GET FILE # | |
1299 | CSFN, 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 | |
1304 | FN, 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 | ||
1326 | GOSUB, TAD I GSP | |
1327 | SMA CLA | |
1328 | GS, 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 | ||
1339 | RETRNI, 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 | |
1349 | GR, JMS I [ERROR /FATAL ERROR IF NO RETURN | |
1350 | DCA I [CDFPSU | |
1351 | JMP I (JFAIL /BUMP PC PAST ADDR WORD AND CONTINUE | |
1352 | ||
1353 | GSP, GSTCK /GOSUB STACK POINTER | |
1354 | ||
1355 | /FOR-LOOP JUMP ROUTINE | |
1356 | /ENTER WITH AC = HORD | |
1357 | ||
1358 | JFOR, 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 | ||
1367 | SETF, AC4000 | |
1368 | AND ACH /ISOLATE SIGN OF MANTISSA | |
1369 | DCA FSWITC /STORE IN FSWITCH | |
1370 | JMP I [ILOOP /DONE | |
1371 | FSWITC, 0 | |
1372 | \f/ROUTINE TO RESET CHARACTER NUMBER TO 1 | |
1373 | ||
1374 | CNOCLR, 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 | ||
1382 | BLZERO, 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 | ||
1398 | CNOBML, 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 | ||
1407 | SCOMP, DCA MODESW /SET INTERPRETER TO ARITH MODE NOW | |
1408 | JMS I [FACCLR /TENTATIVELY ASSUME EQUAL (FAC = 0) | |
1409 | SCOMLP, 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 | |
1427 | L40, 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 | |
1436 | SNEQ, 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 | ||
1443 | SRLIST, 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 | |
1447 | SLOAD, 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 | |
1451 | SCON1, 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 | |
1460 | SEGCOM, 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 | |
1468 | SC, JMS I [ERROR /FATAL ERROR IF SAC OVERFLOW | |
1469 | ISZ STRCNT | |
1470 | JMP SEGCOM /ITERATE IF MORE | |
1471 | JMP I [ILOOP /--RETURN-- | |
1472 | ||
1473 | SCLDB, 0 | |
1474 | ||
1475 | /ROUTINE TO GET A BYTE FROM THE DATA LIST | |
1476 | ||
1477 | DRGCH, 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 | |
1489 | CHR2, TAD DRCHR /GET SECOND CHAR | |
1490 | AND [77 /MASK TO 6BIT | |
1491 | JMP I DRGCH /RETURN | |
1492 | ||
1493 | DRCHR, 0 | |
1494 | \f | |
1495 | /ROUTINE TO SET EOF BIT IN I/O ENTRY | |
1496 | EOFSET, 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 | ||
1507 | MPY, 0 | |
1508 | DCA TEMP10 | |
1509 | DCA TEMP6 | |
1510 | TAD [-14 | |
1511 | DCA TEMP5 | |
1512 | MP12LP, 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 | ||
1530 | IDLE, 0 | |
1531 | TAD I IOTHND /GET HANDLER ENTRY | |
1532 | SNA CLA /IS IT EMPTY? | |
1533 | FI, 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 | ||
1537 | DLREAD, 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? | |
1542 | DA, JMS I [ERROR /YES | |
1543 | DLCDF, . /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 | ||
1550 | FRANDM, 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 | |
1554 | RSEED, 2713 | |
1555 | ||
1556 | /SUBROUTINE CR,LF | |
1557 | ||
1558 | CRLFR, 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 | ||
1569 | FOTYPE, 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 | ||
1578 | XABSVL, JMS ABSVAL /NEGATE FAC IF NEGATIVE | |
1579 | JMP I [ILOOP /--RETURN-- | |
1580 | ||
1581 | /SUBROUTINE TO TAKE ABS VALUE OF FAC | |
1582 | ||
1583 | ABSVAL, 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 | ||
1591 | FACRES, 0 | |
1592 | JMS I [FFGET /GET FAC | |
1593 | INTERB | |
1594 | JMP I FACRES /RETURN | |
1595 | ||
1596 | PAGE | |
1597 | \f /STRING STORE | |
1598 | ||
1599 | SSTORE, 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 | |
1607 | SL, 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 | ||
1616 | SREAD, 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 | |
1631 | ST, 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 | ||
1637 | SWRITE, 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 | |
1650 | SWRLP, 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 | ||
1662 | COMMA, 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 | |
1674 | COMLOP, 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 | ||
1686 | CRFUNC, 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 | ||
1696 | TAB, 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 | ||
1704 | SLOVER, 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 | ||
1713 | COMMAS, 1 /SET TO 1 IF LAST PRINT WAS A COMMA MOVE | |
1714 | COLCNT, 0 | |
1715 | ||
1716 | /ROUTINE TO CALL ERROR ROUTINE BY FAKING A FUNC2 CALL TO FUNCTION #10 | |
1717 | ||
1718 | ERROR, 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 | |
1726 | XERRRET,JMP I ERROR /RETURN TO CALLER IF NON FATAL ERROR | |
1727 | ||
1728 | /FLOATING NEGATE | |
1729 | ||
1730 | FNEGI, JMS I [FFNEG /CALL NEGATE ROUTINE | |
1731 | JMP I [ILOOP /RETURN TO ILOOP | |
1732 | ||
1733 | NUMBUF, ZBLOCK 6 /6 DIGIT BUFFER USED BY FFOUT | |
1734 | ||
1735 | PAGE | |
1736 | \f /INCREMENT AND LOAD 6BIT BYTE FROM MEMORY | |
1737 | ||
1738 | LDB, 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 | ||
1752 | DPB, 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 | ||
1775 | BUMP, 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 | |
1785 | BYTCDF, 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 | ||
1790 | BYTSET, 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 | ||
1804 | SSTEX, 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 | ||
1810 | BYTCNT, 0 | |
1811 | BYTPTR, 0 | |
1812 | BYTSWT, 0 | |
1813 | BYTE, 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 | ||
1821 | BUFCHK, 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 | ||
1839 | EBC, 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 | ||
1848 | PACKCH, 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 | ||
1858 | CHAR3P, 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 | ||
1874 | COMBNE, 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 | ||
1886 | READFL, 0 | |
1887 | JMS I (FOTYPE /IS FILE VARIABLE LENGTH | |
1888 | SKP | |
1889 | VR, 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 | |
1894 | RE, 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 | ||
1902 | WRITFL, 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 | |
1909 | WE, 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 | ||
1914 | BCGET, 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 | ||
1927 | UNPACK, 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 | |
1933 | U123C, 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 | ||
1944 | CHAR3U, 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 | ||
1961 | READI, 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-- | |
1965 | RIMAGE, 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 | ||
1979 | GETCH, 0 | |
1980 | JMS I [FTYPE /IS FILE ASCII? | |
1981 | SR, 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 | |
1989 | NTTY, JMS I [BUFCHK /NO-CHECK STATUS OF BUFFER | |
1990 | JMS I [NEXREC /LAST CHAR READ-NEXT RECORD | |
1991 | NOP /CHAR 3 NOT USED YET | |
1992 | TCHAR, 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 | ||
2004 | CHARNO, 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 | ||
2018 | WRITEI, 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 | |
2033 | CPLOOP, 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 | |
2040 | WIMAGE, JMS I [BUFCHK /FILE IS NUMERIC-CHECK BUFFER STATUS | |
2041 | O240, 240 /PAST END-NEW RECORD (AND INST SERVES AS NOP) | |
2042 | O210, 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 | |
2050 | WDONE, 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 | ||
2054 | PUTCH, 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? | |
2061 | SW, 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 | |
2068 | O40, 40 /THERE IS A CHAR 3 LEFT (AND IS A NOP) | |
2069 | O20, 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 | ||
2074 | TOUT, 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 | ||
2081 | NEXREC, 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 | |
2089 | RWONC, ISZ I IOTBLK | |
2090 | JMS BLINIT /INIT FILE TABLE ENTRIES | |
2091 | JMP I NEXREC /DONE | |
2092 | ||
2093 | RONLY, JMS BLREAD | |
2094 | JMP RWONC | |
2095 | ||
2096 | FILSTR, 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 | ||
2110 | LASTB, 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 | ||
2121 | BLREAD, 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 | ||
2129 | WRBLK, 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 | ||
2141 | BLINIT, 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 | ||
2151 | FACSAV, 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 | ||
2185 | INT, 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 | |
2196 | INSC, 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 | |
2201 | INTPOS, 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 | |
2208 | MASKL, 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 | |
2237 | JUSNEG, JMS I (FFADD /GET INT(X) | |
2238 | FPPTM2 | |
2239 | JNEG, JMS I [FFNEG /AND NEGATE (INT(5.3)=-6) | |
2240 | JMP I INT /DONE | |
2241 | ||
2242 | M1R, JMS I [FFGET /LOAD FAC WITH 1 | |
2243 | ONE | |
2244 | JMP JNEG /JUST NEGATE AND RETURN | |
2245 | ||
2246 | ONE, 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 | ||
2259 | EXPON, 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 | |
2269 | ARGPLL, 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 | |
2298 | EMLOOP, 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 | ||
2315 | RET0, 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 | ||
2328 | RETRN1, JMS I [FFGET | |
2329 | ONE /SET FAC TO 1 | |
2330 | JMP I [ILOOP | |
2331 | ||
2332 | USELOG, TAD I EXPONK /SIGN OF A | |
2333 | SPA CLA /A<0? | |
2334 | EM, 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 | ||
2344 | FFEXPL, EXPON1 | |
2345 | FFLOGL, LOG | |
2346 | FMPYLV, FFMPY | |
2347 | EXPONK, EXPON | |
2348 | FIDVP, FFDIV1 | |
2349 | ||
2350 | /SGN FUNCTION | |
2351 | ||
2352 | SGN, 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 | / | |
2369 | FROOT, 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 | |
2406 | SLOOP, 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 | |
2413 | LOP01, 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 | |
2433 | LOP02, 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 | |
2444 | GON, 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 | |
2448 | DONE, 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 | ||
2454 | K6000, 6000 | |
2455 | ZCNT, 0 | |
2456 | AL1K, AL1 | |
2457 | AN1, 0 | |
2458 | AN2, 0 | |
2459 | KM22, -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 | |
2469 | FROOT, 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 | |
2502 | RKNT, 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!!! | |
2507 | LOOP, DLD /GET THE FAC | |
2508 | ACH | |
2509 | SHL /SHIFT FAC APPROPRIATELY | |
2510 | 1 | |
2511 | LOP1, 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 | |
2517 | ACNT, 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 | |
2530 | ZREM, CMA /YES-SET SO LOOKS LIKE WE'RE DONE | |
2531 | DCA AC2 | |
2532 | NOTZRO, 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 | |
2537 | RBCNT, 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 | |
2542 | GON, ISZ AC2 /DONE 23 BITS? | |
2543 | JMP LOOP /NO-GO ON | |
2544 | DONE, 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 | |
2550 | KM22, -26 | |
2551 | K6000, 6000 | |
2552 | ||
2553 | PAGE | |
2554 | > | |
2555 | \f/23-BIT EXTENDED FUNCTIONS | |
2556 | ||
2557 | /1-31-72 R BEAN | |
2558 | ||
2559 | /******SINE****** | |
2560 | ||
2561 | SIN, 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 | |
2571 | JMPISN, 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 | ||
2577 | QUAD2, JMS I (FFSUB1 /1-X | |
2578 | ONE | |
2579 | JMP POLYSN /CALCULATE SIN(1-X) | |
2580 | QUAD3, JMS I [FFNEG /-X | |
2581 | JMP POLYSN /CALCULATE SIN(-X) | |
2582 | QUAD4, JMS I (FFSUB /X-1 | |
2583 | ONE | |
2584 | POLYSN, 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 | ||
2610 | COS, 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 | ||
2619 | FRACT, 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 | ||
2633 | NHNDLE, 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 | |
2639 | NFLGST, DCA NFLAG | |
2640 | JMP I NHNDLE | |
2641 | ||
2642 | /ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0 | |
2643 | ||
2644 | NCHK, 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 | ||
2653 | EXPON1, 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 | |
2689 | TOVPI, 0 /.6366198 | |
2690 | 2427 | |
2691 | 6302 | |
2692 | ||
2693 | MULLIM, 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 | ||
2705 | ATAN, 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 | |
2721 | ARGPOL, 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 | |
2752 | NGT, JMS I NCHKL /IF NFLAG SET,NEGATE FAC | |
2753 | JMP I ATAN /FAC=ATAN(X) | |
2754 | NHNDLL, NHNDLE | |
2755 | NCHKL, NCHK | |
2756 | \f/******NAPERIAN LOGARITHM****** | |
2757 | ||
2758 | GTFLG=ATAN | |
2759 | ||
2760 | LOG, 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 | |
2775 | LTRPRT, DCA ACH | |
2776 | JMP I LOG /YES-LOG(1)=0 | |
2777 | POLYNL, 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 | |
2821 | FMPYM, FFMPY | |
2822 | FADDM, FFADD | |
2823 | FDIVM, FFDIV | |
2824 | FDIV1M, FFDIV1 | |
2825 | FSUBM, FFSUB | |
2826 | FSUB1M, FFSUB1 | |
2827 | FSQRM, FFSQ | |
2828 | ARTRAP, LM | |
2829 | /CONSTANTS USED BY VARIOUS FUNCTIONS | |
2830 | ||
2831 | SINA1, 1 /1.5707949 | |
2832 | 3110 | |
2833 | 3747 | |
2834 | SINA3, 0 /-.64592098 | |
2835 | 5325 | |
2836 | 1167 | |
2837 | SINA5, 7775 /.07948766 | |
2838 | 2426 | |
2839 | 2466 | |
2840 | SINA7, 7771 /-.004362476 | |
2841 | 5610 | |
2842 | 3164 | |
2843 | PIOV2, 1 /1.5707963 | |
2844 | 3110 | |
2845 | 3756 | |
2846 | LOG2E, 1 /1.442695 | |
2847 | 2705 | |
2848 | 2434 | |
2849 | LN2OV2, 7777 /.34657359 | |
2850 | 2613 | |
2851 | 4415 | |
2852 | EXPB1, 6 /60.090191 | |
2853 | 3602 | |
2854 | 7054 | |
2855 | EXPA1, 12 /-601.80427 | |
2856 | 5514 | |
2857 | 3104 | |
2858 | EXPA0, 4 /12.015017 | |
2859 | 3001 | |
2860 | 7301 | |
2861 | ATANB0, 7776 /.17465544 | |
2862 | 2626 | |
2863 | 6157 | |
2864 | ATANA1, 2 /3.7092563 | |
2865 | 3553 | |
2866 | 1071 | |
2867 | ATANB1, 3 /6.762139 | |
2868 | 3303 | |
2869 | 670 | |
2870 | ATANA2, 3 /-7.10676 | |
2871 | 4344 | |
2872 | 5267 | |
2873 | ATANB2, 2 /3.3163354 | |
2874 | 3241 | |
2875 | 7554 | |
2876 | ATANA3, 7777 /-.26476862 | |
2877 | 5703 | |
2878 | 4040 | |
2879 | ATANB3, 1 /1.44863154 | |
2880 | 2713 | |
2881 | 3140 | |
2882 | SQRP5, 0 /.7071068 | |
2883 | 2650 | |
2884 | 1170 | |
2885 | LOGC1, 2 /2.8853913 | |
2886 | 2705 | |
2887 | 2440 | |
2888 | LOGC3, 0 /.9614706 | |
2889 | 3661 | |
2890 | 566 | |
2891 | LOGC5, 0 /.59897865 | |
2892 | 2312 | |
2893 | 5525 | |
2894 | ONEHAF, 0 /.5 | |
2895 | 2000 | |
2896 | 0 | |
2897 | LN2, 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 | ||
2906 | FFIX, 0 | |
2907 | CLA | |
2908 | TAD ACX /FETCH EXPONENT | |
2909 | SZA SMA /IS NUMBER <1? | |
2910 | JMP .+3 /NO-CONTINUE ON | |
2911 | FTRPRT, 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 | |
2919 | FIXLP, 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 | |
2927 | FIXDNE, 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 | ||
2934 | FFLOAT, 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 | ||
2944 | RND, 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 | ||
2966 | FFOUT, 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 | |
2975 | OKPOS, 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 | ||
3022 | SMLFMT, 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 | ||
3031 | REGFMT, TAD (-7 | |
3032 | DCA AC1 /INIT COUNT OF NONZERO DIGITS | |
3033 | TAD (NUMBUF+6 | |
3034 | DCA AC2 /POINT AT END OF DIGIT BUFFER | |
3035 | SHRINK, 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 | |
3047 | PRTLP, 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 | |
3056 | NODP, 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 | ||
3062 | ZERXIT, JMS PUTD | |
3063 | JMP I FFOUT /--RETURN-- | |
3064 | ||
3065 | /DIVIDE DECEXP BY -DIVISOR IN CALL+1 | |
3066 | ||
3067 | IDIV, 0 | |
3068 | DCA AC1 /CLEAR QUOTIENT | |
3069 | IDIVLP, 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 | |
3076 | IDVOUT, 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 | ||
3085 | PUTD, 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 | ||
3100 | CVTNUM, 0 | |
3101 | DCA AC1 /CLEAR OVERFLOW WORD | |
3102 | SKP /SKP IN AND CLEAR DECIMAL EXPONENT | |
3103 | ADJDEC, TAD DECEXP | |
3104 | DCA DECEXP /STORE UPDATED DECIMAL EXPONENT | |
3105 | NORML, 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 | |
3114 | NORMED, 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 | ||
3127 | DIVCHK, TAD (-5 /SEE IF EXP GT 4 | |
3128 | SPA | |
3129 | JMP INRANG /JMP IF NOT, NUMBER MAY BE IN RANGE | |
3130 | DIVGO, 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 | |
3134 | DVLOOP, 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 | ||
3151 | INRANG, 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 | |
3179 | O4, 4 /EFFECTIVE NOP | |
3180 | ||
3181 | /NOW CONVERT TO DECIMAL DIGITS | |
3182 | ||
3183 | CVT10, TAD (-6 /DO 6 DIGITS | |
3184 | DCA AC0 | |
3185 | TAD (NUMBUF-1 | |
3186 | DCA XR3 | |
3187 | JMP CVTGO /FIRST DIGIT IS ALREADY IN | |
3188 | CVTLP, TAD ACH /ZERO OUT PREV DIGIT | |
3189 | AND [177 | |
3190 | DCA ACH | |
3191 | JMS MPY10 /MULTIPLY BY 10. | |
3192 | CVTGO, 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 | ||
3204 | MPY10, 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 | ||
3219 | AR1, 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 | ||
3236 | FFIN, 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 | |
3243 | DECONV, DCA ACX /ZERO OUT THE FAC! | |
3244 | DCA ACL | |
3245 | P200, 200 | |
3246 | DCA ACH | |
3247 | DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT. | |
3248 | DECON, 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 | |
3262 | FFIN1, 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. | |
3271 | FIGO2, 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 | |
3278 | GETE, 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 | |
3299 | FCNT, ISZ DNUMBR /DONE ALL OPERATIONS? | |
3300 | JMP SIGNF /NO | |
3301 | JMP I FFIN /YES-RETURN | |
3302 | SIGNF, 0 /NO- MUL OR DIV. MANTISSA | |
3303 | TEN /BY TEN | |
3304 | JMP FCNT /GO ON | |
3305 | FFNEGP, FFNEG | |
3306 | DNUMBR, 0 | |
3307 | KME, -305 | |
3308 | MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER | |
3309 | FMPYLL, FFMPY | |
3310 | FDVPT, FFDIV /!!!!!!!!!!!!!!!!! | |
3311 | FADDLL, FFADD | |
3312 | ||
3313 | KK12, 12 | |
3314 | TP, 13 | |
3315 | TP1, 0 | |
3316 | 0 | |
3317 | TEN, 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!! | |
3324 | GCHR, 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 | |
3335 | DECON1, 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 | |
3344 | K7506, 7506 | |
3345 | / | |
3346 | /INPUT ROUTINE-IGNORES LEADING SPACES | |
3347 | / | |
3348 | INPUT, 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 | |
3359 | IOUT, JMP I INPUT /RETURN | |
3360 | IGETCH, GETCH /POINTER TO GET CHAR ROUTINE | |
3361 | /ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL) | |
3362 | M240, -240 | |
3363 | PLUS, -253 | |
3364 | MINUS, 253-255 | |
3365 | / | |
3366 | /ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS | |
3367 | / | |
3368 | PATCHF, 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 | |
3373 | RTN2, 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 | / | |
3380 | FFSUB1, 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 | |
3388 | FFNEGA, FFNEG | |
3389 | SUB0P, SUB0 | |
3390 | / | |
3391 | /INVERSE FLOATING DIVIDE | |
3392 | /FSWITCH=1 | |
3393 | /THIS IS OP/FAC | |
3394 | / | |
3395 | FFDIV1, 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 | ||
3421 | MD1P, MD1 | |
3422 | ARGETL, ARGET | |
3423 | MDSETP, MDSET | |
3424 | FFDP, FFDIV | |
3425 | KFD1, 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 | / | |
3432 | MDSET, 0 | |
3433 | JMS I ARGETK /GET ARGUMENT | |
3434 | MD1, 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 | |
3455 | LEV, TAD OPX /EXIT WITH OPERAND EXPONENT IN AC | |
3456 | JMP I MDSET | |
3457 | ||
3458 | FFNEGK, FFNEG | |
3459 | OPNEGP, OPNEG | |
3460 | ARGETK, ARGET | |
3461 | ||
3462 | / | |
3463 | /CONTINUATION OF FLOATING DIVIDE ROUTINE | |
3464 | / | |
3465 | FD1, 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) | |
3473 | DVL1, 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 | |
3489 | FD, DCA ACH /STORE HIGH ORDER RESULT | |
3490 | JMP I FDDONP /GO LEAVE DIVIDE | |
3491 | ||
3492 | FDDONP, FDDON /END OF FLTG. DIV. ROUTINE | |
3493 | DV24P, DV24 /ROUTINE TO DO A 24X12BIT DIVIDE | |
3494 | DVOPSP, 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 | / | |
3500 | DBAD1, DCA ACX /DIVIDE OVERFLO-ZERO ALL | |
3501 | DVOP2, 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 | |
3514 | FFMPY, 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 | |
3530 | RTZRO, 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 | |
3537 | MDONE, 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 | |
3543 | SHLFT, 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. | |
3548 | AL1PTR, 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 | |
3553 | MP24, 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 | |
3561 | MPLP, TAD OPL /SHIFT A BIT OUT OF LOW ORDER | |
3562 | MPLP1, 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 | |
3572 | MPLP2, 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 | |
3585 | MP12L, 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 | |
3593 | DVLP1, 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 | |
3601 | FD1P, FD1 /POINTER TO REST OF DIVIDE ROUTINE | |
3602 | / | |
3603 | /FLOATING DIVIDE ROUTINE | |
3604 | /USES THE METHOD OF TRIAL DIVISION BY HI ORDER | |
3605 | FFDIV, 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. | |
3609 | FFD1, 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 | / | |
3625 | FDDON, 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 | / | |
3634 | DV24, 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 | |
3642 | DV2, 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 | |
3650 | DV1, 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 | |
3656 | FFNEGR, FFNEG | |
3657 | MDSETK, MDSET | |
3658 | KKM12, -14 | |
3659 | KM13, -15 | |
3660 | DVOVR, DV | |
3661 | ||
3662 | PAGE | |
3663 | \f/ | |
3664 | /FLOATING ADD | |
3665 | / | |
3666 | FFADD, 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 | |
3670 | FAD1, 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 | |
3685 | DOADD, TAD OPX /SET EXPONENT OF RESULT | |
3686 | DCA ACX | |
3687 | JMS OADD /DO THE ADDITION | |
3688 | JMS I FNORP /NORMALIZE RESULT | |
3689 | DONA, ISZ FFADD /BUMP RETURN | |
3690 | JMP I FFADD /RETURN | |
3691 | FACR, 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 | |
3697 | OPSR, 0 | |
3698 | CMA /- (COUNT+1) TO SHIFT COUNTER | |
3699 | DCA AC0 | |
3700 | LOP2, 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 | |
3712 | NOP2, 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 | / | |
3719 | AL1, 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 | / | |
3733 | ACSR, 0 | |
3734 | CMA /AC CONTAINS COUNT-1 | |
3735 | DCA AC0 /STORE COUNT | |
3736 | LOP1, 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 | |
3748 | NOP1, 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 | / | |
3755 | DBAD, CLA CLL /NECESSARY SO WE DON'T GET OVRFLO AGAIN | |
3756 | JMP I DBAD1P /GO ZERO ALL | |
3757 | / | |
3758 | /FLOATING SUBTRACT | |
3759 | / | |
3760 | FFSUB, 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 | |
3766 | SUB0, DCA FFADD /AFTER SETTING UP RETURN | |
3767 | JMP FAD1 | |
3768 | ARGETP, ARGET | |
3769 | \f *6135 | |
3770 | / | |
3771 | /FLOATING NEGATE | |
3772 | / | |
3773 | FFNEG, 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 | / | |
3785 | OPNEG, 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 | / | |
3797 | OADD, 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. | |
3811 | DBAD1P, DBAD1 | |
3812 | FNORP, 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 | |
3849 | FFIN, 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 | |
3856 | DECONV, DCA ACX /ZERO OUT THE FAC! | |
3857 | DCA ACL | |
3858 | DCA ACH | |
3859 | DECNV, DCA DNUMBR /ZERO # OF DIGITS SINCE DEC. PT. | |
3860 | DECON, 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 | |
3875 | FFIN1, 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. | |
3883 | FIGO2, 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 | |
3892 | GETE, 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 | |
3910 | FCNT, ISZ DNUMBR /DONE ALL OPERATIONS? | |
3911 | JMP FINST /NO | |
3912 | JMP I FFIN /YES-RETURN | |
3913 | FINST, 0 /NO- MUL OR DIV. MANTISSA | |
3914 | TEN /BY TEN | |
3915 | JMP FCNT /GO ON | |
3916 | FFNEGP, FFNEG | |
3917 | PRSW, 0 | |
3918 | DNUMBR, 0 | |
3919 | SIGNF, 0 | |
3920 | K2, 2 | |
3921 | KME, -305 | |
3922 | MDV, JMS I .+1 /THESE 3 WDS. MUST BE IN THIS ORDER | |
3923 | FMPYLL, FFMPY | |
3924 | FFDIV /!!!!!!!!!!!!!!!!! | |
3925 | FADDLL, FFADD | |
3926 | ||
3927 | K12, 12 | |
3928 | TP, 13 | |
3929 | TP1, 0 | |
3930 | 0 | |
3931 | TEN, 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!! | |
3938 | GCHR, 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 | |
3948 | DECON1, 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 | |
3956 | K7506, 7506 | |
3957 | PLUS, -253 | |
3958 | MINUS, 253-255 | |
3959 | / | |
3960 | / | |
3961 | /INPUT ROUTINE-IGNORES LEADING SPACES | |
3962 | / | |
3963 | INPUT, 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 | |
3974 | IOUT, JMP I INPUT /RETURN | |
3975 | M240, -240 | |
3976 | IGETCH, GETCH /ALTERED BY VAL FUNCITON TO PICK FROM SAC | |
3977 | / | |
3978 | /ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS | |
3979 | / | |
3980 | PATCHF, 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 | |
3985 | RTN2, 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!! | |
3992 | FFSUB1, 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 | |
4000 | FFNEGA, FFNEG | |
4001 | SUB0P, SUB0 | |
4002 | ||
4003 | ||
4004 | / | |
4005 | /FLOATING DIVIDE | |
4006 | /FSWITCH=1 | |
4007 | /THIS IS OP/FAC | |
4008 | / | |
4009 | FFDIV1, 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 | ||
4035 | MD1P, MD1 | |
4036 | ARGETL, ARGET | |
4037 | MDSETP, MDSET | |
4038 | FFDP, FFDIV | |
4039 | FD1, FFD1 | |
4040 | ||
4041 | \f | |
4042 | /PATCH TO EAE ADD ROUTINE | |
4043 | ||
4044 | ADDPCH, 0 | |
4045 | TAD AC1 | |
4046 | TAD RB4000 | |
4047 | DPSZ | |
4048 | JMP ADDP1 | |
4049 | CLL CML RTR | |
4050 | ISZ ACX | |
4051 | NOP | |
4052 | ADDP1, TAD RB4000 | |
4053 | JMP I ADDPCH | |
4054 | RB4000, 4000 | |
4055 | ||
4056 | ||
4057 | / | |
4058 | PTCHAD, 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 | |
4072 | JADON, ADON | |
4073 | JFAD1, 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 | |
4080 | FFMPY, 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 | |
4119 | RTZRO, 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 | |
4124 | SNCK, 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 | |
4129 | MPOS, SWP /LOW ORDER TO AC | |
4130 | DCA ACL /STORE AWAY | |
4131 | ISZ FFMPY /BUMP RETURN | |
4132 | JMP I FFMPY /RETIRN | |
4133 | MSIGN, 0 | |
4134 | ARGETK, ARGET | |
4135 | DVOFL, DV | |
4136 | ||
4137 | / | |
4138 | /ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE | |
4139 | / | |
4140 | MDSET, 0 | |
4141 | JMS I ARGETK /GET OPERAND (ADDR. IN AC) | |
4142 | CDF /CHANGE TO DATA FIELD OF PACKAGE | |
4143 | MD1, 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 | |
4163 | FPOS, 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 | |
4173 | FFDIV, 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 | |
4177 | FFD1, 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 | |
4190 | DVLP, 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 | |
4200 | DVLP1, 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 | |
4210 | DBAD1, DCA ACH /STORE IT BACK | |
4211 | SWP | |
4212 | DCA ACL | |
4213 | ISZ FFDIV | |
4214 | JMP I FFDIV /BUMP RETN. AND RETN. | |
4215 | ||
4216 | DVOPSP, DVOPS | |
4217 | DBAD, 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 | |
4225 | FFADD, 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 | |
4230 | FAD1, 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 | |
4255 | DADR, 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 # | |
4262 | SHFBG, 0 | |
4263 | SWP /PUT IT IN RIGHT ORDER | |
4264 | ASR /DO THE ALIGNMENT SHIFT | |
4265 | CNT, 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 | |
4279 | NOOV, JMS I ADDPCL /JUMP TO PATCH FOR THIS ROUTINE | |
4280 | LOD, 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 | |
4288 | ADON, ISZ FFADD /BUMP RETURN PAST ADDRESS | |
4289 | JMP I FFADD /RETURN | |
4290 | OVRFLO, 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 | |
4300 | KK4000, 4000 | |
4301 | M27, -27 | |
4302 | ADDRS, OPH | |
4303 | ACH | |
4304 | ARGETP, ARGET | |
4305 | /FLOATING SUBTRACT-USES FLOATING ADD | |
4306 | /FSW0!! | |
4307 | FFSUB, 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 | |
4319 | SUB0, DCA FFADD | |
4320 | JMP FAD1-1 | |
4321 | \f/ | |
4322 | /FLOATING NEGATE--NEGATE FLOATING AC | |
4323 | / | |
4324 | FFNEG, 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 | / | |
4341 | DVOPS, 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 | |
4352 | DVOP1, 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 | |
4362 | DVLP1P, DVLP1 | |
4363 | DVOVR, DV | |
4364 | ADDPCL, ADDPCH | |
4365 | PATCHK, 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 | / | |
4373 | ARGET, 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 | / | |
4397 | FFNOR, 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 | |
4405 | NORMLP, 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 | ||
4415 | FFNORR, DCA AC1 /DONE W/NORMALIZE-CLEAR AC1 | |
4416 | JMP I FFNOR /RETURN | |
4417 | AL1P, AL1 | |
4418 | > | |
4419 | IFNZRO EAE < | |
4420 | ||
4421 | / | |
4422 | /ROUTINE TO NORMALIZE THE FAC | |
4423 | / | |
4424 | *6215 | |
4425 | FFNOR, 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 | |
4446 | FFGET, 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 | / | |
4462 | FFPUT, 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 | ||
4481 | ISZFGT, 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 | |
4485 | NEWCDF, 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 | ||
4492 | CDF10, CDF 10 | |
4493 | ||
4494 | ISZAC2, 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 | / | |
4505 | DVOPS, 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 | |
4516 | DVOP1, CLA CLL | |
4517 | TAD ACH /GET HI ORD OF REMAINDER | |
4518 | JMP I DVOP2P /GO ON | |
4519 | DVOP2P, DVOP2 | |
4520 | ||
4521 | FNLP, 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 | |
4526 | ZEXP, DCA ACX | |
4527 | JMP FFNORR | |
4528 | > | |
4529 | \f/ | |
4530 | /FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF | |
4531 | / | |
4532 | *6347 | |
4533 | A, | |
4534 | FFSQ, 0 | |
4535 | JMS I TMPY /CALL MULTIPLY TO MULTIPLY | |
4536 | ACX /FAC BY ITSELF | |
4537 | JMP I FFSQ /DONE | |
4538 | TMPY, FFMPY | |
4539 | / | |
4540 | / ERROR TRAPS | |
4541 | O0, JMS I [ERROR /OVERFLOW | |
4542 | DV, JMS I [ERROR /DIVISION ERROR | |
4543 | JMS I [FACCLR /RETURN 0 IN FAC | |
4544 | JMP I [ILOOP | |
4545 | LM, 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 | ||
4556 | TTYDRI, 0 | |
4557 | JMP LFLUSH+1 | |
4558 | IO, JMS I [ERROR | |
4559 | LFLUSH, 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 | |
4565 | TTYIN, 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 | |
4570 | KSFA, 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 | |
4597 | MCTRLU, -225 | |
4598 | MCR, 377-215 | |
4599 | CRUBOT, -377 | |
4600 | K5252, 5252 | |
4601 | K277, 277 | |
4602 | ||
4603 | BACKUP, 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 | |
4617 | NOSCOP, 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 | |
4623 | PBACK, CLA CMA /-1 | |
4624 | TAD I IOTPTR /BACK UP BUFFER POINTER | |
4625 | DCA I IOTPTR | |
4626 | JMP TTYIN /NEXT CHAR | |
4627 | K334, 334 | |
4628 | ||
4629 | C1B, 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 | ||
4635 | C3B, 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 | ||
4642 | CR, 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 | |
4652 | K4, 4 | |
4653 | ||
4654 | ||
4655 | SPIN, ISZ SPINNR /SPIN RANDOM # SEED | |
4656 | SKP | |
4657 | CMA CML RAL /MARCH TO THE LEFT | |
4658 | JMP KSFA /CHECK FOR CHAR YET | |
4659 | SCOPFG, 0 /GETS SET TO SCOPE FLAG BY STARTUP CODE | |
4660 | \f/SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC | |
4661 | ||
4662 | FBITGT, 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 | ||
4671 | RDLIST, 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 | ||
4681 | FTYPE, 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 | ||
4694 | TTYBUF, | |
4695 | START4, 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 | |
4706 | CHKB2, 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 | |
4713 | CHKB3, 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 | |
4720 | CHKB4, 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 | |
4726 | BAS, DCA BMAP | |
4727 | JMP I [ILOOP /START INTERPRETER | |
4728 | 0 | |
4729 | MCDF1, -6211 | |
4730 | K2000, 2000 | |
4731 | C14, 14 | |
4732 | C16, 16 | |
4733 | C1000, 1000 | |
4734 | C1400, 1400 | |
4735 | ZBLOCK 10 | |
4736 | TTYEND, 0 | |
4737 | \f *OVERLAY+3277 | |
4738 | ||
4739 | //////////////////////////////////////////////////////////////// | |
4740 | /////// I/O TABLE 5 13-WORD ENTRIES //////////////////////////// | |
4741 | //////////////////////////////////////////////////////////////// | |
4742 | ||
4743 | TTYF, 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 | |
4749 | FILE1, ZBLOCK 15 /FILE #1 | |
4750 | FILE2, ZBLOCK 15 /FILE #2 | |
4751 | FILE3, ZBLOCK 15 /FILE #3 | |
4752 | FILE4, 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 | ||
4800 | CHR, 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 | ||
4810 | ASC, 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 | ||
4816 | LEN, TAD SACLEN /LENGTH OF STRING IN SAC | |
4817 | CIA /MAKE POSITIVE | |
4818 | ||
4819 | /ROUTINE TO FLOAT FAC AND RETURN | |
4820 | ||
4821 | FLOATS, 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 | ||
4834 | STR, 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 | |
4843 | STRLUP, 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 | ||
4859 | VAL, 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 | ||
4868 | VALGET, 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 | |
4879 | EOVAL, TAD O215 | |
4880 | DCA CHAR | |
4881 | JMP I VALGET /RETURN WITH CHAR IN 'CHAR' | |
4882 | ||
4883 | VALCNT, 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 | ||
4891 | DATE, TAD CDFIO /COPY CDF TO FIELD 17600 IN LINE | |
4892 | DCA .+1 | |
4893 | YEAREX, 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 | ||
4929 | PUTN, 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 | |
4945 | NHIGH, 0 | |
4946 | NLOW, 0 | |
4947 | DATEWD, 0 | |
4948 | \f/TRACE FUNCTION PRINTER. WHEN TRACE IS ENABLED,THIS ROUTINE | |
4949 | /PRINTS THE LINE # EACH TIME IT IS STORED | |
4950 | ||
4951 | TPRINT, 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 | |
4958 | IGS, 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 | |
4964 | PREST, 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 | |
4973 | TDONE, 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 | |
4984 | TCHR, 0 | |
4985 | ||
4986 | PAGE | |
4987 | \f/TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF | |
4988 | ||
4989 | TRACE, 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 | |
4993 | TRREST, JMP I PILOOP | |
4994 | ||
4995 | HOOKL, TRHOOK | |
4996 | ||
4997 | /ERROR ROUTINE | |
4998 | ||
4999 | ERRORR, 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 | |
5003 | FERRLP, 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 | |
5023 | ETLOP, 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 | ||
5029 | FATCHK, 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 | ||
5036 | ERRETN, XERRRET | |
5037 | STOPI, FSTOPN | |
5038 | ||
5039 | MAKED, 0 | |
5040 | AND O17 /ISOLATE BCD DIGIT | |
5041 | TAD K260 /MAKE ASCII DIGIT | |
5042 | JMP I MAKED | |
5043 | ||
5044 | K260, 260 | |
5045 | K0300, 300 | |
5046 | \f/SUBROUTINE LMAKE-MAKES THE CURRENT LINE NUMBER INTO FIVE DIGITS | |
5047 | /STARTING AT DIG1 | |
5048 | ||
5049 | LMAKE, 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 | ||
5075 | EMESS, 215 | |
5076 | 212 | |
5077 | ESTRNG, 0000 | |
5078 | 0000 | |
5079 | " | |
5080 | "A | |
5081 | "T | |
5082 | " | |
5083 | "L | |
5084 | "I | |
5085 | "N | |
5086 | "E | |
5087 | " | |
5088 | DIG1, 0 | |
5089 | DIG2, 0 | |
5090 | DIG3, 0 | |
5091 | DIG4, 0 | |
5092 | DIG5, 0 | |
5093 | 215 | |
5094 | 212 | |
5095 | ESTRA, 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 | ||
5099 | ETABA, ETAB-1 | |
5100 | MFATAL, -EFATAL | |
5101 | ETAB, 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 | /*********************************************************** | |
5164 | EFATAL, /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 | ||
5187 | SEG, 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 | |
5204 | ARGPLK, 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-- | |
5229 | NULLST, CLA CLL | |
5230 | DCA SACLEN /ZERO SAC | |
5231 | JMP I PILOOP /--RETURN-- | |
5232 | YARG, 0 | |
5233 | ||
5234 | PAGE | |
5235 | \f /POS FUNCTION | |
5236 | /RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z | |
5237 | ||
5238 | POS, 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? | |
5249 | PA, 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 | |
5257 | POSSET, 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 | |
5269 | SRCLP, 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 | ||
5277 | SCONTU, ISZ TEMP3 /MORE CHARS IN Y$? | |
5278 | JMP SRCLP /YES, ITERATE | |
5279 | TAD POSITN /NO FOUND A MATCH | |
5280 | JMP I (FLOATS | |
5281 | ZRORET, JMS I PFACCLR /SEARCH FAILS-RETURN 0 | |
5282 | JMP I PILOOP | |
5283 | ||
5284 | ONERET, CLA IAC | |
5285 | JMP I (FLOATS /RETURN 1 | |
5286 | POSITN, 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 | ||
5304 | ANDPTR, ANDLST | |
5305 | ANDLST, 7776 /MASKS FOR CLEARING BUFFER AND HANDLER STATUS BITS | |
5306 | 7775 | |
5307 | 7773 | |
5308 | 7767 | |
5309 | ||
5310 | CLOSE, 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 | |
5320 | NOCZ, 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 | |
5336 | FNAP, . /POINTER TO FILE NAME | |
5337 | CLENG, . | |
5338 | FC, JMS I PERROR /FILE CLOSING ERROR | |
5339 | CLOSED, 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 | |
5354 | CHECKL, 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 | |
5367 | PSTCHK, 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 | |
5379 | RELCOM, DCA TEMP1 | |
5380 | TAD DMAP /DRIVER PAGE MAP | |
5381 | AND I TEMP1 /CLEAR HANDLER PAGE BIT | |
5382 | DCA DMAP | |
5383 | CRETN, DCA I IOTHND /SET FILE AS IDLE | |
5384 | JMS I PPSWAP /GET RID OF 17600 AGAIN | |
5385 | JMP I PILOOP /DONE | |
5386 | ||
5387 | TPREL, 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 | ||
5395 | W0PTR, FILE1 | |
5396 | FILE2 /FILE TABLE ENTRIES | |
5397 | FILE3 | |
5398 | FILE4 | |
5399 | ||
5400 | MM4, | |
5401 | ANDLS2, 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 | ||
5408 | CREAD, CDF 10 | |
5409 | CIF 0 | |
5410 | 4613 /"JMS I L7607K" | |
5411 | 3700 /31 PAGES | |
5412 | 0 /0-7577 | |
5413 | CBLK, 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 | |
5418 | K7607K, 7607 | |
5419 | /LESS THAN THE DESIRED VALUE | |
5420 | ||
5421 | EXTCHK, 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 | |
5431 | EXTEMP, 0 | |
5432 | ||
5433 | PAGE | |
5434 | \f/CHAIN FUNCTION | |
5435 | /SETS UP COMMAND DECODER AREA,THEN CHAINS TO BCOMP.SV | |
5436 | ||
5437 | CHAIN, 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 | |
5451 | DNA1, 0 /DEVICE NAME | |
5452 | DNA2, NAMEG | |
5453 | CDIN, 0 | |
5454 | CI, 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 | |
5464 | DISIN, TAD IOTFIL | |
5465 | DCA STB /POINTER TO FILE NAME | |
5466 | TAD DNA2 /GET DEVICE # | |
5467 | CIF 10 | |
5468 | JMS I USR | |
5469 | 2 /LOOKUP | |
5470 | STB, 0 /POINTER TO FILE NAME | |
5471 | FLN, 0 | |
5472 | CL, 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 | ||
5497 | CICHAIN,CDF | |
5498 | JMS I (EXTCHK /SKP IF EXTENSION IS .SV | |
5499 | CX, 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 | |
5509 | CHNSTB, HLT | |
5510 | \f /FILE LOOKUP | |
5511 | ||
5512 | FLOOK, AC0002 | |
5513 | JMS I (ENTLOK /LOOKUP | |
5514 | DCA I IOTLEN /ACTUAL LENGTH | |
5515 | TAD I IOTLEN | |
5516 | DCA I IOTMAX /ALSO EQUALS MAXIMUM LENGTH | |
5517 | CLEANP, 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 | ||
5533 | FSTOP, 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 | |
5549 | NOCTC, TSF | |
5550 | JMP .-1 | |
5551 | JMP I (MEXIT | |
5552 | ||
5553 | PAGE | |
5554 | \f /FILE OPENING ROUTINE | |
5555 | ||
5556 | OPENAV, TAD (4 /ALPHANUMERIC,VARIABLE LENGTH | |
5557 | OPENAF, IAC /ALPHANUMERIC,FIXED LENGTH | |
5558 | JMP OPENNF | |
5559 | OPENNV, TAD (4 /NUMERIC,VARIABLE LENGTH | |
5560 | OPENNF, 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? | |
5566 | FB, 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 | |
5579 | DEVNA1, . /DEVICE NAME | |
5580 | DEVNA2, . | |
5581 | ENTRYN, 0 /ENTRY POINT | |
5582 | IN, 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? | |
5601 | DO, 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 | ||
5607 | FREE70, 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 | ||
5617 | FREE72, 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 | |
5625 | DFETCH, 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 | |
5631 | FETPAG, . /DRIVER ADDRESS | |
5632 | FE, 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 | |
5648 | DRAP, TAD FETPAG /HANDLER ENTRY ADDRESS | |
5649 | JMP I (DRIVRN /PAGE ESCAPE | |
5650 | ||
5651 | TPH, 0 | |
5652 | \f/ROUTINE TO MOVE THE COMPILER READER INTO FIELD 1 AND START IT | |
5653 | ||
5654 | CSMOVE, 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? | |
5683 | BO, 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 | ||
5689 | B3, 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 | ||
5695 | B2, 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 | ||
5701 | B1, 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 | ||
5717 | MEXIT, 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 | |
5729 | EBLK, . /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 | |
5740 | FNOM, . /ENTER OR LOOKUP | |
5741 | STARTB, . | |
5742 | FLEN, . | |
5743 | EN, 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 | |
5757 | FILSTU, 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 | ||
5770 | PSWAP2, 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 | |
5791 | BOSPT1, 7600 | |
5792 | BOSPT2, 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 | ||
5805 | NAMEG, 0 | |
5806 | TAD SACLEN | |
5807 | TAD (16 /COMPARE STRING LENGTH TO 16 | |
5808 | SPA CLA | |
5809 | IF, 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 | |
5816 | NCG, 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 | |
5828 | NCGS, 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 | |
5841 | MML, 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 | ||
5851 | CAD, 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 | ||
5859 | SSAD, 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 | ||
5872 | DEVFUD, 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 | ||
5891 | DSK, 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 | ||
5895 | PSWP2P, 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;' | |
5943 | J<S\13PRINT\13\e;R-5DI[XPRINT\e> | |
5944 | J<S\13SACPTR\13\e;R-6DI[SAC-1\e> | |
5945 | J<S\13PUTCHL\13\e;R-6DI[PUTCH\e> | |
5946 | J<S\13ILOOPL\13\e;R-6DI[ILOOP\e> | |
5947 | J<S\13INTL\13\e;R-4DI[UNSFIX\e> | |
5948 | J<S\13CDFPSL\13\e;R-6DI[CDFPSU\e> | |
5949 | J<S\13ERROR\13\e;R-5DI[ERRDIS\e> | |
5950 | J<S\13FBITS\13\e;R-5DI[FBITGT\e> | |
5951 | J<S\13PWFECL\13\e;R-5DI[PWFECH\e> | |
5952 | J<S\13MPYLNK\13\e;R-6DI[MPY\e> | |
5953 | J<S\13XPUT\13\e;R-4DI[XPUTCH\e> | |
5954 | J<S\13FIDLE\13\e;R-5DI[IDLE\e> | |
5955 | J<S\13DEVCAL\13\e;R-6DI[DRCALL\e> | |
5956 | J<S\13WRITFW\13\e;R-6DI[WRITFL\e> | |
5957 | J<S\13STHINL\13\e;R-6DI[STHINI\e> | |
5958 | J<S\13LDHINL\13\e;R-6DI[LDHINI\e> | |
5959 | J<S\13STH\13\e;R-3DI[STHL\e> | |
5960 | J<S\13LDH\13\e;R-3DI[LDHL\e> | |
5961 | J<S\13FACSAL\13\e;R-6DI[FACSAV\e> | |
5962 | J<S\13FACREL\13\e;R-6DI[FACRES\e> | |
5963 | J<S\13FGETL\13\e;R-5DI[FFGET\e> | |
5964 | J<S\13FPUTL\13\e;R-5DI[FFPUT\e> | |
5965 | J<S\13FNORL\13\e;R-5DI[FFNOR\e> | |
5966 | J<S\13FCLR\13\e;R-4DI[FACCLR\e> | |
5967 | J<S\13FNEGL\13\e;R-5DI[FFNEG\e> | |
5968 | J<S\13FLOATL\13\e;R-6DI[FFLOAT\e> | |
5969 | J<S\13GETCHL\13\e;R-6DI[GETCH\e> | |
5970 | J<S\13EOFSEL\13\e;R-6DI[EOFSET\e> | |
5971 | J<S\13BSWL\13\e;R-4DI[BSWP\e> | |
5972 | J<S\13PACKL\13\e;R-5DI[PACKCH\e> | |
5973 | J<S\13CNOCLL\13\e;R-6DI[CNOCLR\e> | |
5974 | J<S\13BUFCHL\13\e;R-6DI[BUFCHK\e> | |
5975 | J<S\13FTYPL\13\e;R-5DI[FTYPE\e> | |
5976 | J<S\13CHRNOL\13\e;R-6DI[CHARNO\e> | |
5977 | J<S\13NEXREL\13\e;R-6DI[NEXREC\e> | |
5978 | J<S\13CRLF\13\e;R-4DI[CRLFR\e> | |
5979 | J<S\13VALLK\13\e;R-5DI[VALGET\e> | |
5980 | J<S\13PATCHP\13\e;R-6DI[PATCHF\e> | |
5981 | J<S\13P1SWAP\13\e;R-6DI[PSWAP\e> | |
5982 | J<S\13LDHRST\13\e;R-6DI[LRESET\e> | |
5983 | J<S\13STHRST\13\e;R-6DI[SRESET\e> | |
5984 | P> | |
5985 | \f |