| 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 |