Commit | Line | Data |
---|---|---|
349a334a PH |
1 | / SUBROUTINE USR (UNIT, NAME, FUNCT, ERROR)\r\r |
2 | / WRITTEN BY:\r | |
3 | / ROBERT PHELPS\r | |
4 | / BEHAVIOR LAB\r | |
5 | / DEPT. RAD. BIOL. & BIOPHYSICS\r | |
6 | / UNIVERSITY OF ROCHESTER\r | |
7 | / ROCHESTER, NY 14642\r | |
8 | /\r | |
9 | / THIS ROUTINE ALLOWS RUN-TIME DECLARATION OF FILES\r | |
10 | / IN D.E.C. FORTRAN IV FOR THE PDP-8.\r | |
11 | /\r | |
12 | / DESCRIPTION OF PARAMETERS:\r | |
13 | /\r | |
14 | / UNIT - LOGICAL UNIT NUMBER\r | |
15 | / ONLY NUMBERS 5 THRU 9 ARE ALLOWED.\r | |
16 | / FEWER LOGICAL UNITS MAY BE ALLOWED DEPENDING\r | |
17 | / ON CORE AVAILABILITY -- SEE PROGRAMMING NOTE\r | |
18 | / BELOW.\r | |
19 | / NAME - DEV:FILE.EX\r | |
20 | / STORED IN FORMAT 3A6 OR EQUIVALENT.\r | |
21 | / DEVICE ASSUMED TO BE DSK: IF NOT\r | |
22 | / EXPLICITLY STATED. THIS PARAMETER MAY\r | |
23 | / ALSO BE A HOLLERITH LITERAL.\r | |
24 | / NULL CHARACTERS ('@') AND SPACES\r | |
25 | / ARE IGNORED IN THIS FIELD.\r | |
26 | / FUNCT - FUNCTION: 2 - OPEN FILE FOR INPUT\r | |
27 | / 3 - OPEN FILE FOR OUTPUT\r | |
28 | / 4 - CLOSE OUTPUT FILE\r | |
29 | / THE OUTPUT FILE NAME GIVEN FOR A <CLOSE>\r | |
30 | / MUST AGREE WITH THE CORRESPONDING <OPEN>\r | |
31 | / FILE NAME FOR THAT UNIT. CLOSING A FILE\r | |
32 | / WITH 0 BLOCKS OR AN INPUT (FUNCT=2) FILE WILL\r | |
33 | / DELETE THAT FILENAME FROM THE DIRECTORY.\r | |
34 | / ERROR - RETURN ERROR CONDITION\r | |
35 | / 0 - NO ERRORS.\r | |
36 | / 1 - ILLEGAL DEVICE\r | |
37 | / 2 - ILLEGAL FILE NAME\r | |
38 | / 3 - ILLEGAL UNIT NUMBER (CORE EXCEEDED!?)\r | |
39 | / 4 - ILLEGAL FUNCTION CODE\r | |
40 | /\r | |
41 | / USER ERRORS MAY TERMINATE EXECUTION UNLESS THE /E\r | |
42 | / OPTION WAS SPECIFIED TO FRTS. THE FOLLOWING USER\r | |
43 | / ERRORS FROM <USR> ARE DEFINED:\r | |
44 | / 0002 - THE USER HAS DEFINED A NON-RESIDENT\r | |
45 | / DEVICE HANDLER EXTERNAL TO <USR>.\r | |
46 | /\r | |
47 | / PROGRAMMING NOTE: EACH UNIT IS ASSIGNED 1000(8) LOCATIONS\r | |
48 | /IN THE HIGHEST FIELD FOR BUFFER AND HANDLER (400 FOR ITS BUFFER\r | |
49 | /AND 400 FOR ITS HANDLER). THESE LOCATIONS ARE\r | |
50 | /NOT DYNAMICALLY ALLOCATED BUT ARE USED FOR DEVICE BUFFER AND\r | |
51 | /HANDLERS ONLY IF THEY ARE NOT USED BY THE\r | |
52 | /PROGRAM. TO USE CORE MOST EFFICIENTLY FOR LARGE\r | |
53 | /PROGRAMS, USE THE HIGHEST ORDER UNIT NUMBERS POSSIBLE. THAT IS,\r | |
54 | /USING UNIT 5 ALLOWS 1000(8) FEWER WORDS FOR SOURCE CODE THAN IF\r | |
55 | /UNIT 6 WERE THE LOWEST UNIT NUMBER USED.\r | |
56 | /\r | |
57 | / RESTRICTIONS: BECAUSE <FRTS> LOADS NON-RESIDENT HANDLERS FROM\r | |
58 | /THE TOP OF CORE DOWN, AND <USR> ALSO USES THAT AREA, THE USER IS NOT\r | |
59 | /ALLOWED TO MAKE LOAD TIME\r | |
60 | /I/O UNIT DECLARATIONS TO DEVICES WITH NON-RESIDENT\r | |
61 | /HANDLERS EXTERNAL TO <USR>. TO DO SO WLL CAUSE A FATAL\r | |
62 | /USER ERROR 2. IT IS RECOMMENDED, AND GENERALLY\r | |
63 | /MORE CONVIENENT TO USE INTERNAL HANDLERS AND\r | |
64 | /DECLARE ALL OTHER FILES AT EXECUTION TIME\r | |
65 | /WITH CALLS TO THIS SUBROUTINE.\r | |
66 | /THE USE OF <FRTS> INTERNAL HANDLERS,\r | |
67 | /SYS:, AND DEVICES CO-RESIDENT WITH SYS: ARE LEGAL,\r | |
68 | /EVEN IF DEFINED EXTERNAL TO THIS SUBROUTINE.\r | |
69 | /\r | |
70 | /NOTE: THIS PROGRAM REQUIRES ONE PATCH BE MADE TO\r | |
71 | / <FRTS> BEFORE IT WILL RUN. IT IS DESCRIBED\r | |
72 | / BELOW:\r | |
73 | /\r | |
74 | /MAXCOR=121 /THESE ARE LOCATIONS IN THE RESIDENT PART OF\r | |
75 | /HGHLOC=123 /<FRTS> AND REQUIRE THE FOLLOWING PATCH BE PLACED\r | |
76 | /IN FRTS SO THEY WILL BE SET PROPERLY. THE PATCH\r | |
77 | /DELETES CODE WHICH INITIALIZES SYSTEMS WITH AN\r | |
78 | /ANALEX PRINTER, SO IF YOU HAVE AN ANALEX ... WATCH OUT.\r | |
79 | \r | |
80 | /Note that MAXCOR and HGHLOC are 2 word variables which have been\r | |
81 | /created for this routine on page 0 of FRTS. If FRTS\r | |
82 | /is changed to use more page 0 locations, the patch\r | |
83 | /will have to be changed as well. \r | |
84 | \r | |
85 | / FIELD 1; *2475\r | |
86 | /12475 7300 CLA CLL /Note, CDF CIF 0 is pending\r | |
87 | /12476 1311 TAD 12511 /Load address of VAR\r | |
88 | /12477 3010 DCA 10010 /Store in auto index\r | |
89 | / 1023 TAD 10023 /Load value of MAX field\r | |
90 | / 3410 DCA I 10010 /As high order part of MAXCOR\r | |
91 | / 3410 DCA I 10010 /Zero low order part\r | |
92 | / 1025 TAD 10025 /Load highest avail. field\r | |
93 | / 3410 DCA I 10010 /Store high order word\r | |
94 | / 1026 TAD 10026 /load high address\r | |
95 | / 3410 DCA I 10010 /Store low order word of HGHLOC\r | |
96 | / 7000 NOP /?\r | |
97 | / 5766 JMP I 12566 /Start up FPP\r | |
98 | \r | |
99 | /12511 120 /ADDRESS-1 of MAXCOR\r | |
100 | \r | |
101 | EXTERN CGET\r | |
102 | EXTERN CPUT\r | |
103 | DSRN=4244 /Address of DSRN table in FRTS\r | |
104 | \r | |
105 | SECT USR\r | |
106 | JA #ST\r | |
107 | \r | |
108 | /NOTE: MUCH OF THIS CODE WAS LIFTED FROM A FORTRAN\r | |
109 | / GENERATED ASSEMBLY LISTING. ACCEPT THIS AS\r | |
110 | / AN APOLOGY FOR THE LACK OF COMMENTS IN SOME SECTIONS.\r | |
111 | /\r | |
112 | #XR, ORG .+10\r | |
113 | TEXT +USR +\r | |
114 | \r | |
115 | #RET, SETX #XR\r | |
116 | SETB #BASE\r | |
117 | JA .+3\r | |
118 | #BASE, ORG .+6 /BASE 0 AND 1\r | |
119 | UNIT, ORG .+3 /BASE 2\r | |
120 | FUNCT, ORG .+3 /BASE 3\r | |
121 | ERROR, ORG .+3 /BASE 4\r | |
122 | #DSK, TEXT +DSK@@@+ /DEFAULT DEVICE NAME\r | |
123 | I, F 0.0 /BASE 6\r | |
124 | N, F 0.0 /BASE 7\r | |
125 | ORG #BASE+30\r | |
126 | FNOP\r | |
127 | JA #RET\r | |
128 | FNOP\r | |
129 | #GOBAK, 0;0\r | |
130 | \r | |
131 | PERFLG, F 0.0 /PERIOD FLAG\r | |
132 | X,\r | |
133 | #TMP, ORG .+3\r | |
134 | ONE, F 1.0\r | |
135 | TWO, F 2.0\r | |
136 | THREE, F 3.0\r | |
137 | FOUR, F 4.0\r | |
138 | SEVEN, F 7.0\r | |
139 | MUNIT, 0027;0;0 /Low unit: Set according to CORE avail.\r | |
140 | NINE, F 9.0\r | |
141 | TEN, F 10.0\r | |
142 | ATEEN, F 18.0\r | |
143 | COLON, F 58.0\r | |
144 | PERIOD, F 46.0\r | |
145 | SPACE, F 32.0\r | |
146 | MAXCOR, 3; 0 /RHM: Don't require the FRTS patch.\r | |
147 | HGHLOC, 7; 3400 /RHM: Hope memory used doesn't get larger.\r | |
148 | / ADVENT in the current implementation uses up thru 73000 at worst.\r | |
149 | / This hopefully allows room for extra 2-page handlers and the TD8E ROM.\r | |
150 | #RTN, BASE #BASE\r | |
151 | JA #GOBAK\r | |
152 | #ST, STARTD\r | |
153 | 0210\r | |
154 | FSTA #GOBAK,0\r | |
155 | 0200\r | |
156 | SETX #XR\r | |
157 | SETB #BASE\r | |
158 | LDX 0,1\r | |
159 | FSTA #BASE\r | |
160 | FLDA% #BASE,1+\r | |
161 | FSTA UNIT\r | |
162 | FLDA% #BASE,1+\r | |
163 | FSTA NAME\r | |
164 | FLDA% #BASE,1+\r | |
165 | FSTA FUNCT\r | |
166 | FLDA% #BASE,1+\r | |
167 | FSTA ERROR\r | |
168 | \r | |
169 | / INITIALIZE PROGRAM\r | |
170 | \r | |
171 | SKIP, /JA SKIP2 AFTER FIRST ENTRY\r | |
172 | \r | |
173 | / FIND OUT HOW MANY UNITS TO ALLOW\r | |
174 | \r | |
175 | /Note that the original scheme was rather bizzare, and for\r | |
176 | /humerous purposes, I have left it here, commented out.\r | |
177 | /This worked OK with the old FPP interpreter, since it zeroed\r | |
178 | /the exponent with a STARTF. The FPP does not, and the\r | |
179 | /EXPONENT is left indeterminate. This meant that sometimes\r | |
180 | /you could use past 72400, and sometimes you couldn't.\r | |
181 | /(Note, that S.B.'s version of FRTS has been changed\r | |
182 | /so that the FPP interpreter works the same as the FPP.)\r | |
183 | \r | |
184 | / FLDA MAXCOR /Load highest field number\r | |
185 | / FSUB HGHLOC /Subtract high location\r | |
186 | / FADD D2400 /1 FIELD LESS 5400 LOCS FOR 5 DEVICES\r | |
187 | / NOTE: PG. 7600 RESERVED FOR OS/8\r | |
188 | / PG. 7400 USED FOR OS/8 USR CALL\r | |
189 | / JGE SKCONT /ROOM FOR 5 DEVICES?\r | |
190 | / FADD D15000 /Note, FAC= how many locations short\r | |
191 | / FMUL D1000 /HOW MANY 1000 WORD BLOCKS ARE THERE?\r | |
192 | / STARTF\r | |
193 | / FNORM\r | |
194 | / FMUL E30 /ALTHOUGH WE WERE WORKING WITH AN\r | |
195 | / /INTEGER ABOVE, THE FPP THOUGHT IT\r | |
196 | / /HAD A BINARY POINT TO THE RT. OF THE\r | |
197 | / /SIGN BIT. THIS INSTRUCTION EFFECTIVELY\r | |
198 | / /CHANGES THE NUMBER TO A REAL FPP INTEGER.\r | |
199 | / FSTA MUNIT /MINIMUM UNIT # ALLOWED\r | |
200 | /D15000, 1;5000\r | |
201 | /D1000, 4;0 /0.001\r | |
202 | /E30, 30;2000;0 /1.E30(2)\r | |
203 | \r | |
204 | /The routine should really be modified to check which handlers\r | |
205 | /are already loaded. This wouldn't be all that difficult,\r | |
206 | /since the field 1 tables of handler residency are saved on\r | |
207 | /SYS block 37, and restored each time USR is called. As long\r | |
208 | /as a reset isn't performed, it should be easy to determine\r | |
209 | /if a handler is already loaded. Then HGHLOC could be changed\r | |
210 | /dynamically, as handlers were loaded. The core usage would then\r | |
211 | /also be independent of the unit number used.\r | |
212 | \r | |
213 | FLDA MAXCOR /Load Max field #\r | |
214 | FADD D7400 /Offset to highest useable address\r | |
215 | FSUB HGHLOC /Compute locations available\r | |
216 | LDX 11,1 /Load shift argument\r | |
217 | ALN 1 /Divide by 1000\r | |
218 | FSTA MUNIT+1,0 /Store number of units\r | |
219 | STARTF\r | |
220 | FLDA TEN /Load MAX units+1\r | |
221 | FSUB MUNIT /Subtract number of units\r | |
222 | FSTA MUNIT /Store new minimum unit\r | |
223 | FSUB THREE /Limit min. to three\r | |
224 | JGE SKCONT /Ok if greater than 2\r | |
225 | FLDA THREE /Just in case we need to avoid\r | |
226 | FSTA MUNIT /field boundary problems\r | |
227 | \r | |
228 | SKCONT, STARTD\r | |
229 | SETX MAXCOR\r | |
230 | XTA 0 /GET HIGHEST FIELD\r | |
231 | FDIV D10X /PUT IT INTO BITS 6-8 OF LO ORDER WORD\r | |
232 | SETX LHIFLD\r | |
233 | ATX 0 /LOAD HIGHEST FIELD INTO LHIFLD\r | |
234 | FADD DCDF /MAKE IT CDF HIFLD\r | |
235 | SETX FD1\r | |
236 | ATX 0 /SET LOCATIONS USING IT\r | |
237 | SETX FD2\r | |
238 | ATX 0\r | |
239 | FADD ONED /MAKE IT CIF HIFLD\r | |
240 | SETX FI1\r | |
241 | ATX 0\r | |
242 | SETX #XR\r | |
243 | \r | |
244 | / CHECK TO MAKE SURE USER DID NOT DECLARE\r | |
245 | / DEVICE WITH HANDLER EXTERNAL TO THESE ROUTINES.\r | |
246 | \r | |
247 | FLDA SKIPJA /SET INSTRUCTION SO THIS CODE\r | |
248 | FSTA SKIP,0 / EXECUTES ONLY ONCE.\r | |
249 | /\r | |
250 | FLDA SXDSRN /INITIALIZE SETX INSTRUCTION\r | |
251 | FSTA SKCON2\r | |
252 | LDX -11,6 /SET COUNTER (MAX # DSRN ENTRIES)\r | |
253 | SKCON2, SETX DSRN /STUFFED AND MODIFIED\r | |
254 | XTA 0 /GET NEXT HANDLER ENTRY POINT\r | |
255 | SETX #XR\r | |
256 | FSUB D5200\r | |
257 | JLT SKCON3 /INTERNAL HANDLER, IT'S OK\r | |
258 | FSUB D2400\r | |
259 | JGT SKCON3 /RESIDENT HANDLER (E.G. SYS:), IT'S OK TOO\r | |
260 | LDX 2,0 /***SOME OTHER HANDLER***USER ERROR 2\r | |
261 | EXTERN #UE\r | |
262 | TRAP3 #UE /USER ILLEGALLY DECLARED A FILE!\r | |
263 | /\r | |
264 | SKCON3, FLDA NINED /INCREMENT TO NEXT DSRN ENTRY\r | |
265 | FADDM SKCON2\r | |
266 | JXN SKCON2,6+\r | |
267 | /\r | |
268 | SKIP2, STARTF /***END OF INITILIZATIN CODE***\r | |
269 | LDX 1,7\r | |
270 | FCLA /INITIALIZE SOME VARIABLES...\r | |
271 | FSTA PERFLG /NO PERIODS YET\r | |
272 | FSTA FILE-0003,7\r | |
273 | FSTA FILE-0003,7+\r | |
274 | FLDA #DSK /SETUP DEFAULT DEVICE\r | |
275 | FSTA DEV\r | |
276 | FLDA ONE /FIRST CHARACTER IS # 1\r | |
277 | FSTA N\r | |
278 | FLDA% UNIT /CHECK FOR LEGAL UNIT #\r | |
279 | FSUB MUNIT\r | |
280 | JSA #LT / IF (UNIT.LT.MUNIT.OR.UNIT.GT.9) GO TO 900\r | |
281 | FSTA #TMP+00\r | |
282 | FLDA% UNIT\r | |
283 | FSUB NINE\r | |
284 | JSA #GT\r | |
285 | FADD #TMP+00\r | |
286 | JNE #900\r | |
287 | FLDA% FUNCT /CHECK FOR LEGAL FUNCTION CODE\r | |
288 | FSUB TWO\r | |
289 | EXTERN #LT\r | |
290 | JSA #LT / IF (FUNCT.LT.2.OR.FUNCT.GT.4) GO TO 901\r | |
291 | FSTA #TMP+00\r | |
292 | FLDA% FUNCT\r | |
293 | FSUB FOUR\r | |
294 | EXTERN #GT\r | |
295 | JSA #GT\r | |
296 | FADD #TMP+00\r | |
297 | JNE #901\r | |
298 | /\r | |
299 | / PUT DEV:FILE.EXT INTO CORRECT FORMAT FOR USR CALL\r | |
300 | /\r | |
301 | FLDA ONE \r | |
302 | FSTA I / DO 100 I=1,18\r | |
303 | \r | |
304 | #G0002, JSR CGET / CALL CGET (NAME, I, X)\r | |
305 | JA .+10\r | |
306 | NAME, JA .\r | |
307 | JA I\r | |
308 | JA X\r | |
309 | FLDA X / IF (X.NE.COLON) GO TO 40\r | |
310 | FSUB COLON\r | |
311 | JNE #40\r | |
312 | FLDA I /COLON MUST BE COLUMN 6 OR BEFORE\r | |
313 | FSUB SEVEN /7\r | |
314 | JGE #DONE\r | |
315 | FLDA FILE /COLON DEFINES DEVICE NAME\r | |
316 | FSTA DEV\r | |
317 | FCLA\r | |
318 | FSTA FILE\r | |
319 | FLDA ONE\r | |
320 | FSTA N\r | |
321 | JA #100\r | |
322 | \r | |
323 | #40, FLDA X / IF (X.NE.PERIOD) GO TO 60\r | |
324 | FSUB PERIOD\r | |
325 | JNE #60\r | |
326 | FLDA PERFLG /ONLY ONE PERIOD ALLOWED\r | |
327 | JNE #DONE\r | |
328 | FLDA SEVEN /SET TO DECODE EXTENSION\r | |
329 | FSTA PERFLG\r | |
330 | FSTA N\r | |
331 | JA #100\r | |
332 | \r | |
333 | #60, FLDA X\r | |
334 | JEQ #100 /SKIP OVER NULL'S\r | |
335 | FSUB SPACE\r | |
336 | JEQ #100 /SKIP OVER SPACES\r | |
337 | JSR CPUT / CALL CPUT (FILE, N, X)\r | |
338 | JA .+10\r | |
339 | JA FILE\r | |
340 | JA N\r | |
341 | JA X\r | |
342 | FLDA N / N=N+1\r | |
343 | FADD ONE\r | |
344 | FSTA N\r | |
345 | \r | |
346 | #100, FLDA I / 100 CONTINUE\r | |
347 | FADD ONE\r | |
348 | FSTA I\r | |
349 | FSUB ATEEN\r | |
350 | JLE #G0002\r | |
351 | \r | |
352 | #DONE, FLDA% FUNCT\r | |
353 | FSUB FOUR\r | |
354 | JNE #101 /FUNCTION = CLOSE ?\r | |
355 | EXTERN #ENDF\r | |
356 | FLDA% UNIT /YES - END FILE\r | |
357 | TRAP3 #ENDF\r | |
358 | \r | |
359 | #101, SETX FUNCTX /USR XR TO PASS PARAMETERS\r | |
360 | FLDA% FUNCT\r | |
361 | ATX 0\r | |
362 | FLDA% UNIT\r | |
363 | ATX 1\r | |
364 | \r | |
365 | TRAP4 #USRSE /TRAP TO THE USR CALLING ROUTINE\r | |
366 | \r | |
367 | XTA 2 /GET ERRNO AND RETURN IT\r | |
368 | FSTA% ERROR\r | |
369 | JA #RTN\r | |
370 | #900, FLDA THREE /ILLEGAL UNIT NUMBER!!!\r | |
371 | FSTA% ERROR\r | |
372 | JA #RTN\r | |
373 | \r | |
374 | #901, FLDA FOUR /ILLEGAL FUNCTION CODE!!!\r | |
375 | FSTA% ERROR\r | |
376 | JA #RTN\r | |
377 | /\r | |
378 | SKIPJA, JA SKIP2\r | |
379 | DCDF, 0;CDF\r | |
380 | ONED, 0;1\r | |
381 | D10X, 400;0 /0.1\r | |
382 | D10, 0;10\r | |
383 | SXDSRN, SETX DSRN\r | |
384 | NINED, 0;11\r | |
385 | D5200, 0;5200\r | |
386 | D2400, 0;2400\r | |
387 | D7400, 0;7400\r | |
388 | \r | |
389 | SECT8 #USRSE; 0\r | |
390 | /\r | |
391 | /THIS ROUTINE SETS UP, ON PAGE 7400 OF THE HIGHEST FIELD, A\r | |
392 | /ROUTINE WHICH CALLS THE OS/8 USR (USER SERVICE ROUTINE).\r | |
393 | /IT IS NECESSARY TO DO THIS BECAUSE THE FORTRAN IV LOADER\r | |
394 | /MAY LOAD ANY ROUTINE IN THE RESERVED AREA FOR\r | |
395 | /THE OS/8 USR (10000 - 11777). \r | |
396 | /\r | |
397 | / THIS PROGRAM ALSO REQUIRES\r | |
398 | / THAT 'HKEY' BE THE LOCATION IN <FRTS> AS DEFINED\r | |
399 | / BELOW:\r | |
400 | \r | |
401 | HKEY=2761\r | |
402 | DSRN=4244 /Address of DSRN table in FRTS\r | |
403 | \r | |
404 | /\r | |
405 | /IN CASE CLOSE FUNCTION, GET # BLOCKS WRITTEN\r | |
406 | /\r | |
407 | TAD UNITX\r | |
408 | CLL RTL /MULTIPLY BY 9\r | |
409 | RAL\r | |
410 | TAD UNITX\r | |
411 | TAD K6 /OFFSET TO CURRENT BLOCK\r | |
412 | TAD LDSRN /START OF DSRN TABLE - 11\r | |
413 | DCA TEMQ\r | |
414 | CDF 0\r | |
415 | TAD% TEMQ\r | |
416 | DCA SB\r | |
417 | /\r | |
418 | /MOVE USR CALLING ROUTINE TO DEFINED LOCATION\r | |
419 | / I.E. PROTECT LOCS 10000-11777\r | |
420 | /\r | |
421 | TAD K7400 /Target address\r | |
422 | DCA TEMQ /Store for indirect reference\r | |
423 | TAD #LUSR+1 /Origin address\r | |
424 | DCA TEMQ2 /Store for indirect reference\r | |
425 | TAD M200 /Number of words to move\r | |
426 | DCA TEMQ3 /Store in a counter\r | |
427 | TAD #LUSR /Load field word\r | |
428 | AND K7 /Strip it\r | |
429 | CLL RTL /Into right bits\r | |
430 | RAL\r | |
431 | TAD #CDF\r | |
432 | DCA .+1 /Store the CDF\r | |
433 | FUSR, HLT /Set field where USR loads\r | |
434 | TAD% TEMQ2 /Load routine location\r | |
435 | FD1, CDF 00 /Set HIGH field\r | |
436 | DCA% TEMQ /Store location in high field\r | |
437 | ISZ TEMQ /Bump the pointers\r | |
438 | ISZ TEMQ2\r | |
439 | ISZ TEMQ3 /And the counters\r | |
440 | JMP FUSR /Loop on it\r | |
441 | \r | |
442 | /SET FIELDS AND CALL IT\r | |
443 | \r | |
444 | RIF /GET CURRENT FIELD\r | |
445 | TAD #CDF\r | |
446 | DCA .+1\r | |
447 | HLT /Set this field\r | |
448 | FI1, CIF 00 /Set high field\r | |
449 | TAD FUNCTX /Load function number\r | |
450 | JMS% K7400 /Call routine\r | |
451 | SB, 0 /START BLOCK OF FILE OR LENGTH IF CLOSE\r | |
452 | NOBLKS, 0 /LENGTH OF FILE\r | |
453 | ENTPT, 0 /HANDLER ENTRY POINT\r | |
454 | DCA ERRUSR /SAVE ERROR RETURN VALUE\r | |
455 | \r | |
456 | /SETUP TO MOVE DSRN TABLE APPROPRIATELY\r | |
457 | \r | |
458 | TAD UNITX\r | |
459 | CLL RTL /MULTIPLY BY 9\r | |
460 | RAL\r | |
461 | TAD UNITX\r | |
462 | TAD LDSRN\r | |
463 | DCA TEMQ\r | |
464 | #CDF, CDF 0\r | |
465 | DCA% TEMQ /DISABLE FILE IN CASE CLOSE FUNCTION\r | |
466 | CLA CLL CMA RTL /-3 => AC\r | |
467 | TAD FUNCTX\r | |
468 | SMA SZA CLA /CLOSE?\r | |
469 | JMP USRSL5 /YES\r | |
470 | \r | |
471 | /MOVE HANDLER TO APROPRIATE BUFFER\r | |
472 | \r | |
473 | CLA CMA CLL RAL /-2 => AC\r | |
474 | TAD UNITX\r | |
475 | CLL RTR\r | |
476 | RTR /UNIT 9 => AC=7000; UNIT 8 => AC=6000\r | |
477 | TAD M400\r | |
478 | DCA LHNDR /LOCATION FOR THIS UNIT'S HANDLER\r | |
479 | TAD K5200\r | |
480 | DCA TEMQ2\r | |
481 | TAD M400\r | |
482 | DCA TEMQ3\r | |
483 | USRL4, CDF 0\r | |
484 | TAD% TEMQ2\r | |
485 | FD2, CDF 00\r | |
486 | DCA% LHNDR\r | |
487 | ISZ TEMQ2\r | |
488 | ISZ LHNDR\r | |
489 | ISZ TEMQ3\r | |
490 | JMP USRL4\r | |
491 | \r | |
492 | /BUILD UP NEW DSRN TABLE FOR THIS UNIT\r | |
493 | \r | |
494 | CDF 0\r | |
495 | TAD ENTPT\r | |
496 | DCA% TEMQ /ENTRY POINT\r | |
497 | ISZ TEMQ\r | |
498 | CLL CML RTL /2 => AC (FORMS CONTROL BIT)\r | |
499 | TAD LHNDR\r | |
500 | TAD M400\r | |
501 | TAD LHIFLD\r | |
502 | DCA% TEMQ /HANDLER CODE WORD\r | |
503 | TAD K7774 /*K* KLUDGE TO LET FRTS KNOW WHICH\r | |
504 | AND% TEMQ / HANDLER IS IN CORE\r | |
505 | DCA% #HKEY\r | |
506 | ISZ TEMQ\r | |
507 | TAD LHNDR\r | |
508 | TAD LHIFLD\r | |
509 | DCA% TEMQ /BUFFER ADDRESS & FIELD\r | |
510 | ISZ TEMQ\r | |
511 | TAD LHNDR\r | |
512 | DCA% TEMQ /CHARACTER POINTER\r | |
513 | ISZ TEMQ\r | |
514 | CMA CLL RTL /-3 => AC\r | |
515 | DCA% TEMQ /CHARACTER COUNTER\r | |
516 | ISZ TEMQ\r | |
517 | TAD SB\r | |
518 | DCA% TEMQ /START BLOCK\r | |
519 | ISZ TEMQ\r | |
520 | DCA% TEMQ /RELATIVE BLOCK\r | |
521 | ISZ TEMQ\r | |
522 | TAD NOBLKS\r | |
523 | DCA% TEMQ /LENGTH OF FILE\r | |
524 | ISZ TEMQ\r | |
525 | DCA% TEMQ /STATUS WORD\r | |
526 | \r | |
527 | USRSL5, CDF CIF 0\r | |
528 | JMP% #USRSE\r | |
529 | \r | |
530 | \r | |
531 | K6, 6\r | |
532 | K7400, 7400\r | |
533 | M200, -200\r | |
534 | M400, -400\r | |
535 | K7, 7\r | |
536 | K5200, 5200\r | |
537 | \r | |
538 | LDSRN, DSRN-11 /START LOCATION OF DSRN TABLE\r | |
539 | \r | |
540 | LHIFLD, 0\r | |
541 | TEMQ, 0\r | |
542 | TEMQ2, 0\r | |
543 | TEMQ3, 0\r | |
544 | LHNDR, 0\r | |
545 | FUNCTX, 0 /STUFFED BY RALF CODE\r | |
546 | UNITX, 0 /STUFFED BY RALF CODE\r | |
547 | ERRUSR, 0 /READ BY RALF CODE\r | |
548 | \r | |
549 | #LUSR, ADDR #USR\r | |
550 | #HKEY, HKEY /LOCATION OF HKEY IN FRTS\r | |
551 | / MUST AGREE WITH VERSION!!\r | |
552 | K7774, 7774\r | |
553 | /\r | |
554 | ORG .+177&7600\r | |
555 | /USR CALLING SUBROUTINE FOR FORTRAN \r | |
556 | /\r | |
557 | / THIS ROUTINE IS MOVED TO PAGE 7400 OF THE HIGHEST\r | |
558 | / FIELD BEFORE EXECUTING TO AVOID BEING OVERWRITTEN BY THE USR\r | |
559 | / ROUTINE. NO FILE SPECIFICATIONS OTHER THAN INTERNAL\r | |
560 | / HANDLERS AND SYSTEM DEVICES MAY BE MADE EXTERNAL TO THESE\r | |
561 | / ROUTINES BECAUSE THE USE OF THIS ROUTINE WILL OVERWRITE\r | |
562 | / THE HANDLERS WHICH ARE STORED IN HIGH CORE.\r | |
563 | /\r | |
564 | /\r | |
565 | #USR, 0\r | |
566 | /\r | |
567 | / ENTER WITH FUNCTION CODE IN THE AC\r | |
568 | / 2 - LOOKUP (OPEN FOR INPUT)\r | |
569 | / 3 - ENTER (OPEN FOR OUTPUT)\r | |
570 | / 4 - CLOSE (CLOSE OUTPUT FILE)\r | |
571 | /\r | |
572 | / DEVICE AND FILE NAMES ARE STUFFED BY THE CALLING\r | |
573 | / PROGRAM BEFORE THIS SUBROUTINE IS CALLED.\r | |
574 | /\r | |
575 | / CALLING SEQUENCE:\r | |
576 | / JMS #USR\r | |
577 | / START BLOCK OF FILE (RETURNED FOR CODE 2 & 3)\r | |
578 | / # BLOCKS SUPPLIED IF CODE 4\r | |
579 | / NUMBER OF BLOCKS IN FILE (RETURNED FOR CODE 2 & 3)\r | |
580 | / ENTRY POINT OF HANDLER AS READ INTO PAGE 5200\r | |
581 | / <RETURN>\r | |
582 | /\r | |
583 | / AC ON EXIT CONTAINS ERROR CONDITION:\r | |
584 | / 0 - NO ERROR\r | |
585 | / 1 - ILLEGAL DEVICE\r | |
586 | / 2 - ILLEGAL FILE NAME\r | |
587 | /\r | |
588 | DCA FUNCTY /SAVE FUNCTION CODE\r | |
589 | TAD% #USR /GET # BLOCKS IN CASE CLOSE FUNCTION\r | |
590 | DCA #BLKS\r | |
591 | \r | |
592 | RDF /SET INSTRUCTION FIELD FOR RETURN\r | |
593 | TAD #CIF\r | |
594 | DCA EXIT4\r | |
595 | CMA /MAKE IT CDF\r | |
596 | TAD EXIT4\r | |
597 | DCA EXIT\r | |
598 | DCA ERRNO /INITIALIZE ERROR RETURN VARIABLE\r | |
599 | CMA\r | |
600 | TAD #CIF /-1 IN AC MAKES IT CDF\r | |
601 | RIF\r | |
602 | DCA .+1\r | |
603 | HLT /SET DATA FIELD TO CURRENT FIELD\r | |
604 | \r | |
605 | / ********SWAP CORE FOR USR CALL\r | |
606 | \r | |
607 | /Note, that it would be much simpler to read in the field\r | |
608 | /one tables, and call USR at 17700. Let USR do the swapping.\r | |
609 | /We must only set the correct bits in the JSW.\r | |
610 | \r | |
611 | IOF\r | |
612 | #CIF, CIF 0\r | |
613 | JMS% K7607 /CALL SYSTEM HANDLER\r | |
614 | 5210 / WRITE 17400-17777,10000-11777\r | |
615 | 7400\r | |
616 | 27\r | |
617 | HLT /DEVICE ERROR\r | |
618 | \r | |
619 | CIF 0\r | |
620 | JMS% K7607 /READ IN USR\r | |
621 | 610\r | |
622 | 0\r | |
623 | 13 /From block 13\r | |
624 | HLT\r | |
625 | \r | |
626 | CIF 0\r | |
627 | JMS% K7607 /READ IN FIELD ONE TABLES\r | |
628 | 210\r | |
629 | 7400\r | |
630 | 37 /From block 37 (where FRTS put it)\r | |
631 | HLT\r | |
632 | \r | |
633 | / ********PERFORM USR FUNCTIONS\r | |
634 | \r | |
635 | CIF 10\r | |
636 | JMS% K200 /RESET tables, so it looks like no handlers\r | |
637 | 13\r | |
638 | 0\r | |
639 | \r | |
640 | TAD K5201 /SET PAGE FOR HANDLER (allow 2 page handler)\r | |
641 | DCA ENTRY\r | |
642 | CIF 10\r | |
643 | JMS% K200 /FETCH\r | |
644 | 1\r | |
645 | DEV, 0 /(STUFFED BY RALF ROUTINE)\r | |
646 | DEVNO, 0\r | |
647 | ENTRY, 5201\r | |
648 | JMP ERR /ILLEGAL DEVICE\r | |
649 | \r | |
650 | TAD #LFILE /SET POINTER TO FILE\r | |
651 | TAD KOFSET\r | |
652 | DCA LFILE\r | |
653 | TAD DEVNO /GET DEVICE NUMBER\r | |
654 | CIF 10\r | |
655 | JMS% K200 /PERFORM FUNCTION\r | |
656 | FUNCTY, 0\r | |
657 | SB2,\r | |
658 | LFILE, 0\r | |
659 | #BLKS, 0\r | |
660 | JMP ERR2 /FILE ERROR\r | |
661 | \r | |
662 | / ********RESTORE CORE\r | |
663 | \r | |
664 | EXIT2, CIF 0\r | |
665 | JMS% K7607 /SAVE FIELD ONE TABLES\r | |
666 | 4210 /? Is this really necessary?\r | |
667 | 7400 /Since they've already been saved?\r | |
668 | 37 /by FRTS\r | |
669 | HLT\r | |
670 | \r | |
671 | CIF 0 /USROUT function would do this\r | |
672 | JMS% K7607 /Read in the Stuff we saved\r | |
673 | 1210\r | |
674 | 7400\r | |
675 | 27\r | |
676 | HLT\r | |
677 | \r | |
678 | ION /Is this necessary?\r | |
679 | EXIT, HLT\r | |
680 | TAD SB2 /RETURN SB & #BLKS\r | |
681 | DCA% #USR\r | |
682 | ISZ #USR\r | |
683 | TAD SB2\r | |
684 | SZA CLA /NON-FILE STRUCTURED DEVICE?\r | |
685 | JMP .+3\r | |
686 | CMA /YES - SET MAX NUMBER OF BLOCKS\r | |
687 | JMP .+3\r | |
688 | TAD #BLKS\r | |
689 | CIA\r | |
690 | DCA% #USR\r | |
691 | ISZ #USR\r | |
692 | TAD ENTRY\r | |
693 | DCA% #USR\r | |
694 | ISZ #USR\r | |
695 | TAD ERRNO\r | |
696 | EXIT4, HLT\r | |
697 | JMP% #USR\r | |
698 | \r | |
699 | \r | |
700 | K7607, 7607 /SYSTEM HANDLER ENTRY POINT\r | |
701 | K200, 200 /USR ENTRY POINT\r | |
702 | K5201, 5201 /PAGE FOR HANDLER (& TWO PAGES AVAILABLE)\r | |
703 | \r | |
704 | ERR2, CLA IAC /ILLEGAL FILE NAME\r | |
705 | ERR, IAC /ILLEGAL DEVICE NAME\r | |
706 | DCA ERRNO\r | |
707 | JMP EXIT2\r | |
708 | ERRNO, 0\r | |
709 | \r | |
710 | #LFILE, AND FILE /LOCATION OF FILE ON PAGE 7400\r | |
711 | /'AND' NEEDED TO TRICK ABSOLUTE REFERENCE\r | |
712 | /CHECK IN RALF.\r | |
713 | KOFSET, 7200 /OFFSET TO REAL EXECUTION ADDRESS\r | |
714 | FILE, 0;0;0;0;0;0;0;0;0\r | |
715 | \r |