--- /dev/null
+/ SUBROUTINE USR (UNIT, NAME, FUNCT, ERROR)\r
+/ VERSION 01.18\r
+\r
+/ WRITTEN BY:\r
+/ ROBERT PHELPS\r
+/ BEHAVIOR LAB\r
+/ DEPT. RAD. BIOL. & BIOPHYSICS\r
+/ UNIVERSITY OF ROCHESTER\r
+/ ROCHESTER, NY 14642\r
+/\r
+/ THIS ROUTINE ALLOWS RUN-TIME DECLARATION OF FILES\r
+/ IN D.E.C. FORTRAN IV FOR THE PDP-8.\r
+/\r
+/ DESCRIPTION OF PARAMETERS:\r
+/\r
+/ UNIT - LOGICAL UNIT NUMBER\r
+/ ONLY NUMBERS 5 THRU 9 ARE ALLOWED.\r
+/ FEWER LOGICAL UNITS MAY BE ALLOWED DEPENDING\r
+/ ON CORE AVAILABILITY -- SEE PROGRAMMING NOTE\r
+/ BELOW.\r
+/ NAME - DEV:FILE.EX\r
+/ STORED IN FORMAT 3A6 OR EQUIVALENT.\r
+/ DEVICE ASSUMED TO BE DSK: IF NOT\r
+/ EXPLICITLY STATED. THIS PARAMETER MAY\r
+/ ALSO BE A HOLLERITH LITERAL.\r
+/ NULL CHARACTERS ('@') AND SPACES\r
+/ ARE IGNORED IN THIS FIELD.\r
+/ FUNCT - FUNCTION: 2 - OPEN FILE FOR INPUT\r
+/ 3 - OPEN FILE FOR OUTPUT\r
+/ 4 - CLOSE OUTPUT FILE\r
+/ THE OUTPUT FILE NAME GIVEN FOR A <CLOSE>\r
+/ MUST AGREE WITH THE CORRESPONDING <OPEN>\r
+/ FILE NAME FOR THAT UNIT. CLOSING A FILE\r
+/ WITH 0 BLOCKS OR AN INPUT (FUNCT=2) FILE WILL\r
+/ DELETE THAT FILENAME FROM THE DIRECTORY.\r
+/ ERROR - RETURN ERROR CONDITION\r
+/ 0 - NO ERRORS.\r
+/ 1 - ILLEGAL DEVICE\r
+/ 2 - ILLEGAL FILE NAME\r
+/ 3 - ILLEGAL UNIT NUMBER (CORE EXCEEDED!?)\r
+/ 4 - ILLEGAL FUNCTION CODE\r
+/\r
+/ USER ERRORS MAY TERMINATE EXECUTION UNLESS THE /E\r
+/ OPTION WAS SPECIFIED TO FRTS. THE FOLLOWING USER\r
+/ ERRORS FROM <USR> ARE DEFINED:\r
+/ 0002 - THE USER HAS DEFINED A NON-RESIDENT\r
+/ DEVICE HANDLER EXTERNAL TO <USR>.\r
+/\r
+/ PROGRAMMING NOTE: EACH UNIT IS ASSIGNED 1000(8) LOCATIONS\r
+/IN THE HIGHEST FIELD FOR BUFFER AND HANDLER (400 FOR ITS BUFFER\r
+/AND 400 FOR ITS HANDLER). THESE LOCATIONS ARE\r
+/NOT DYNAMICALLY ALLOCATED BUT ARE USED FOR DEVICE BUFFER AND\r
+/HANDLERS ONLY IF THEY ARE NOT USED BY THE\r
+/PROGRAM. TO USE CORE MOST EFFICIENTLY FOR LARGE\r
+/PROGRAMS, USE THE HIGHEST ORDER UNIT NUMBERS POSSIBLE. THAT IS,\r
+/USING UNIT 5 ALLOWS 1000(8) FEWER WORDS FOR SOURCE CODE THAN IF\r
+/UNIT 6 WERE THE LOWEST UNIT NUMBER USED.\r
+/\r
+/ RESTRICTIONS: BECAUSE <FRTS> LOADS NON-RESIDENT HANDLERS FROM\r
+/THE TOP OF CORE DOWN, AND <USR> ALSO USES THAT AREA, THE USER IS NOT\r
+/ALLOWED TO MAKE LOAD TIME\r
+/I/O UNIT DECLARATIONS TO DEVICES WITH NON-RESIDENT\r
+/HANDLERS EXTERNAL TO <USR>. TO DO SO WLL CAUSE A FATAL\r
+/USER ERROR 2. IT IS RECOMMENDED, AND GENERALLY\r
+/MORE CONVIENENT TO USE INTERNAL HANDLERS AND\r
+/DECLARE ALL OTHER FILES AT EXECUTION TIME\r
+/WITH CALLS TO THIS SUBROUTINE.\r
+/THE USE OF <FRTS> INTERNAL HANDLERS,\r
+/SYS:, AND DEVICES CO-RESIDENT WITH SYS: ARE LEGAL,\r
+/EVEN IF DEFINED EXTERNAL TO THIS SUBROUTINE.\r
+/\r
+/NOTE: THIS PROGRAM REQUIRES ONE PATCH BE MADE TO\r
+/ <FRTS> BEFORE IT WILL RUN. IT IS DESCRIBED\r
+/ BELOW:\r
+/\r
+/MAXCOR=121 /THESE ARE LOCATIONS IN THE RESIDENT PART OF\r
+/HGHLOC=123 /<FRTS> AND REQUIRE THE FOLLOWING PATCH BE PLACED\r
+ /IN FRTS SO THEY WILL BE SET PROPERLY. THE PATCH\r
+ /DELETES CODE WHICH INITIALIZES SYSTEMS WITH AN\r
+ /ANALEX PRINTER, SO IF YOU HAVE AN ANALEX ... WATCH OUT.\r
+\r
+/Note that MAXCOR and HGHLOC are 2 word variables which have been\r
+/created for this routine on page 0 of FRTS. If FRTS\r
+/is changed to use more page 0 locations, the patch\r
+/will have to be changed as well. \r
+\r
+/ FIELD 1; *2475\r
+/12475 7300 CLA CLL /Note, CDF CIF 0 is pending\r
+/12476 1311 TAD 12511 /Load address of VAR\r
+/12477 3010 DCA 10010 /Store in auto index\r
+/ 1023 TAD 10023 /Load value of MAX field\r
+/ 3410 DCA I 10010 /As high order part of MAXCOR\r
+/ 3410 DCA I 10010 /Zero low order part\r
+/ 1025 TAD 10025 /Load highest avail. field\r
+/ 3410 DCA I 10010 /Store high order word\r
+/ 1026 TAD 10026 /load high address\r
+/ 3410 DCA I 10010 /Store low order word of HGHLOC\r
+/ 7000 NOP /?\r
+/ 5766 JMP I 12566 /Start up FPP\r
+\r
+/12511 120 /ADDRESS-1 of MAXCOR\r
+\r
+ EXTERN CGET\r
+ EXTERN CPUT\r
+ DSRN=4244 /Address of DSRN table in FRTS\r
+\r
+ SECT USR\r
+ JA #ST\r
+\r
+/NOTE: MUCH OF THIS CODE WAS LIFTED FROM A FORTRAN\r
+/ GENERATED ASSEMBLY LISTING. ACCEPT THIS AS\r
+/ AN APOLOGY FOR THE LACK OF COMMENTS IN SOME SECTIONS.\r
+/\r
+#XR, ORG .+10\r
+ TEXT +USR +\r
+\r
+#RET, SETX #XR\r
+ SETB #BASE\r
+ JA .+3\r
+#BASE, ORG .+6 /BASE 0 AND 1\r
+UNIT, ORG .+3 /BASE 2\r
+FUNCT, ORG .+3 /BASE 3\r
+ERROR, ORG .+3 /BASE 4\r
+#DSK, TEXT +DSK@@@+ /DEFAULT DEVICE NAME\r
+I, F 0.0 /BASE 6\r
+N, F 0.0 /BASE 7\r
+ ORG #BASE+30\r
+ FNOP\r
+ JA #RET\r
+ FNOP\r
+#GOBAK, 0;0\r
+\r
+PERFLG, F 0.0 /PERIOD FLAG\r
+X,\r
+#TMP, ORG .+3\r
+ONE, F 1.0\r
+TWO, F 2.0\r
+THREE, F 3.0\r
+FOUR, F 4.0\r
+SEVEN, F 7.0\r
+MUNIT, 0027;0;0 /Low unit: Set according to CORE avail.\r
+NINE, F 9.0\r
+TEN, F 10.0\r
+ATEEN, F 18.0\r
+COLON, F 58.0\r
+PERIOD, F 46.0\r
+SPACE, F 32.0\r
+MAXCOR, 7; 0 /RHM: Don't require the FRTS patch.\r
+HGHLOC, 7; 3400 /RHM: Hope memory used doesn't get larger.\r
+/ ADVENT in the current implementation uses up thru 73000 at worst.\r
+/ This hopefully allows room for extra 2-page handlers and the TD8E ROM.\r
+#RTN, BASE #BASE\r
+ JA #GOBAK\r
+#ST, STARTD\r
+ 0210\r
+ FSTA #GOBAK,0\r
+ 0200\r
+ SETX #XR\r
+ SETB #BASE\r
+ LDX 0,1\r
+ FSTA #BASE\r
+ FLDA% #BASE,1+\r
+ FSTA UNIT\r
+ FLDA% #BASE,1+\r
+ FSTA NAME\r
+ FLDA% #BASE,1+\r
+ FSTA FUNCT\r
+ FLDA% #BASE,1+\r
+ FSTA ERROR\r
+\r
+/ INITIALIZE PROGRAM\r
+\r
+SKIP, /JA SKIP2 AFTER FIRST ENTRY\r
+\r
+/ FIND OUT HOW MANY UNITS TO ALLOW\r
+\r
+/Note that the original scheme was rather bizzare, and for\r
+/humerous purposes, I have left it here, commented out.\r
+/This worked OK with the old FPP interpreter, since it zeroed\r
+/the exponent with a STARTF. The FPP does not, and the\r
+/EXPONENT is left indeterminate. This meant that sometimes\r
+/you could use past 72400, and sometimes you couldn't.\r
+/(Note, that S.B.'s version of FRTS has been changed\r
+/so that the FPP interpreter works the same as the FPP.)\r
+\r
+/ FLDA MAXCOR /Load highest field number\r
+/ FSUB HGHLOC /Subtract high location\r
+/ FADD D2400 /1 FIELD LESS 5400 LOCS FOR 5 DEVICES\r
+ / NOTE: PG. 7600 RESERVED FOR OS/8\r
+ / PG. 7400 USED FOR OS/8 USR CALL\r
+/ JGE SKCONT /ROOM FOR 5 DEVICES?\r
+/ FADD D15000 /Note, FAC= how many locations short\r
+/ FMUL D1000 /HOW MANY 1000 WORD BLOCKS ARE THERE?\r
+/ STARTF\r
+/ FNORM\r
+/ FMUL E30 /ALTHOUGH WE WERE WORKING WITH AN\r
+/ /INTEGER ABOVE, THE FPP THOUGHT IT\r
+/ /HAD A BINARY POINT TO THE RT. OF THE\r
+/ /SIGN BIT. THIS INSTRUCTION EFFECTIVELY\r
+/ /CHANGES THE NUMBER TO A REAL FPP INTEGER.\r
+/ FSTA MUNIT /MINIMUM UNIT # ALLOWED\r
+/D15000, 1;5000\r
+/D1000, 4;0 /0.001\r
+/E30, 30;2000;0 /1.E30(2)\r
+\r
+/The routine should really be modified to check which handlers\r
+/are already loaded. This wouldn't be all that difficult,\r
+/since the field 1 tables of handler residency are saved on\r
+/SYS block 37, and restored each time USR is called. As long\r
+/as a reset isn't performed, it should be easy to determine\r
+/if a handler is already loaded. Then HGHLOC could be changed\r
+/dynamically, as handlers were loaded. The core usage would then\r
+/also be independent of the unit number used.\r
+\r
+ FLDA MAXCOR /Load Max field #\r
+ FADD D7400 /Offset to highest useable address\r
+ FSUB HGHLOC /Compute locations available\r
+ LDX 11,1 /Load shift argument\r
+ ALN 1 /Divide by 1000\r
+ FSTA MUNIT+1,0 /Store number of units\r
+ STARTF\r
+ FLDA TEN /Load MAX units+1\r
+ FSUB MUNIT /Subtract number of units\r
+ FSTA MUNIT /Store new minimum unit\r
+ FSUB THREE /Limit min. to three\r
+ JGE SKCONT /Ok if greater than 2\r
+ FLDA THREE /Just in case we need to avoid\r
+ FSTA MUNIT /field boundary problems\r
+\r
+SKCONT, STARTD\r
+ SETX MAXCOR\r
+ XTA 0 /GET HIGHEST FIELD\r
+ FDIV D10X /PUT IT INTO BITS 6-8 OF LO ORDER WORD\r
+ SETX LHIFLD\r
+ ATX 0 /LOAD HIGHEST FIELD INTO LHIFLD\r
+ FADD DCDF /MAKE IT CDF HIFLD\r
+ SETX FD1\r
+ ATX 0 /SET LOCATIONS USING IT\r
+ SETX FD2\r
+ ATX 0\r
+ FADD ONED /MAKE IT CIF HIFLD\r
+ SETX FI1\r
+ ATX 0\r
+ SETX #XR\r
+\r
+/ CHECK TO MAKE SURE USER DID NOT DECLARE\r
+/ DEVICE WITH HANDLER EXTERNAL TO THESE ROUTINES.\r
+\r
+ FLDA SKIPJA /SET INSTRUCTION SO THIS CODE\r
+ FSTA SKIP,0 / EXECUTES ONLY ONCE.\r
+/\r
+ FLDA SXDSRN /INITIALIZE SETX INSTRUCTION\r
+ FSTA SKCON2\r
+ LDX -11,6 /SET COUNTER (MAX # DSRN ENTRIES)\r
+SKCON2, SETX DSRN /STUFFED AND MODIFIED\r
+ XTA 0 /GET NEXT HANDLER ENTRY POINT\r
+ SETX #XR\r
+ FSUB D5200\r
+ JLT SKCON3 /INTERNAL HANDLER, IT'S OK\r
+ FSUB D2400\r
+ JGT SKCON3 /RESIDENT HANDLER (E.G. SYS:), IT'S OK TOO\r
+ LDX 2,0 /***SOME OTHER HANDLER***USER ERROR 2\r
+EXTERN #UE\r
+ TRAP3 #UE /USER ILLEGALLY DECLARED A FILE!\r
+/\r
+SKCON3, FLDA NINED /INCREMENT TO NEXT DSRN ENTRY\r
+ FADDM SKCON2\r
+ JXN SKCON2,6+\r
+/\r
+SKIP2, STARTF /***END OF INITILIZATIN CODE***\r
+ LDX 1,7\r
+ FCLA /INITIALIZE SOME VARIABLES...\r
+ FSTA PERFLG /NO PERIODS YET\r
+ FSTA FILE-0003,7\r
+ FSTA FILE-0003,7+\r
+ FLDA #DSK /SETUP DEFAULT DEVICE\r
+ FSTA DEV\r
+ FLDA ONE /FIRST CHARACTER IS # 1\r
+ FSTA N\r
+ FLDA% UNIT /CHECK FOR LEGAL UNIT #\r
+ FSUB MUNIT\r
+ JSA #LT / IF (UNIT.LT.MUNIT.OR.UNIT.GT.9) GO TO 900\r
+ FSTA #TMP+00\r
+ FLDA% UNIT\r
+ FSUB NINE\r
+ JSA #GT\r
+ FADD #TMP+00\r
+ JNE #900\r
+ FLDA% FUNCT /CHECK FOR LEGAL FUNCTION CODE\r
+ FSUB TWO\r
+ EXTERN #LT\r
+ JSA #LT / IF (FUNCT.LT.2.OR.FUNCT.GT.4) GO TO 901\r
+ FSTA #TMP+00\r
+ FLDA% FUNCT\r
+ FSUB FOUR\r
+ EXTERN #GT\r
+ JSA #GT\r
+ FADD #TMP+00\r
+ JNE #901\r
+/\r
+/ PUT DEV:FILE.EXT INTO CORRECT FORMAT FOR USR CALL\r
+/\r
+ FLDA ONE \r
+ FSTA I / DO 100 I=1,18\r
+\r
+#G0002, JSR CGET / CALL CGET (NAME, I, X)\r
+ JA .+10\r
+NAME, JA .\r
+ JA I\r
+ JA X\r
+ FLDA X / IF (X.NE.COLON) GO TO 40\r
+ FSUB COLON\r
+ JNE #40\r
+ FLDA I /COLON MUST BE COLUMN 6 OR BEFORE\r
+ FSUB SEVEN /7\r
+ JGE #DONE\r
+ FLDA FILE /COLON DEFINES DEVICE NAME\r
+ FSTA DEV\r
+ FCLA\r
+ FSTA FILE\r
+ FLDA ONE\r
+ FSTA N\r
+ JA #100\r
+\r
+#40, FLDA X / IF (X.NE.PERIOD) GO TO 60\r
+ FSUB PERIOD\r
+ JNE #60\r
+ FLDA PERFLG /ONLY ONE PERIOD ALLOWED\r
+ JNE #DONE\r
+ FLDA SEVEN /SET TO DECODE EXTENSION\r
+ FSTA PERFLG\r
+ FSTA N\r
+ JA #100\r
+\r
+#60, FLDA X\r
+ JEQ #100 /SKIP OVER NULL'S\r
+ FSUB SPACE\r
+ JEQ #100 /SKIP OVER SPACES\r
+ JSR CPUT / CALL CPUT (FILE, N, X)\r
+ JA .+10\r
+ JA FILE\r
+ JA N\r
+ JA X\r
+ FLDA N / N=N+1\r
+ FADD ONE\r
+ FSTA N\r
+\r
+#100, FLDA I / 100 CONTINUE\r
+ FADD ONE\r
+ FSTA I\r
+ FSUB ATEEN\r
+ JLE #G0002\r
+\r
+#DONE, FLDA% FUNCT\r
+ FSUB FOUR\r
+ JNE #101 /FUNCTION = CLOSE ?\r
+ EXTERN #ENDF\r
+ FLDA% UNIT /YES - END FILE\r
+ TRAP3 #ENDF\r
+\r
+#101, SETX FUNCTX /USR XR TO PASS PARAMETERS\r
+ FLDA% FUNCT\r
+ ATX 0\r
+ FLDA% UNIT\r
+ ATX 1\r
+\r
+ TRAP4 #USRSE /TRAP TO THE USR CALLING ROUTINE\r
+\r
+ XTA 2 /GET ERRNO AND RETURN IT\r
+ FSTA% ERROR\r
+ JA #RTN\r
+#900, FLDA THREE /ILLEGAL UNIT NUMBER!!!\r
+ FSTA% ERROR\r
+ JA #RTN\r
+\r
+#901, FLDA FOUR /ILLEGAL FUNCTION CODE!!!\r
+ FSTA% ERROR\r
+ JA #RTN\r
+/\r
+SKIPJA, JA SKIP2\r
+DCDF, 0;CDF\r
+ONED, 0;1\r
+D10X, 400;0 /0.1\r
+D10, 0;10\r
+SXDSRN, SETX DSRN\r
+NINED, 0;11\r
+D5200, 0;5200\r
+D2400, 0;2400\r
+D7400, 0;7400\r
+\r
+SECT8 #USRSE; 0\r
+/\r
+/THIS ROUTINE SETS UP, ON PAGE 7400 OF THE HIGHEST FIELD, A\r
+/ROUTINE WHICH CALLS THE OS/8 USR (USER SERVICE ROUTINE).\r
+/IT IS NECESSARY TO DO THIS BECAUSE THE FORTRAN IV LOADER\r
+/MAY LOAD ANY ROUTINE IN THE RESERVED AREA FOR\r
+/THE OS/8 USR (10000 - 11777). \r
+/\r
+/ THIS PROGRAM ALSO REQUIRES\r
+/ THAT 'HKEY' BE THE LOCATION IN <FRTS> AS DEFINED\r
+/ BELOW:\r
+\r
+HKEY=2761\r
+DSRN=4244 /Address of DSRN table in FRTS\r
+\r
+/\r
+/IN CASE CLOSE FUNCTION, GET # BLOCKS WRITTEN\r
+/\r
+ TAD UNITX\r
+ CLL RTL /MULTIPLY BY 9\r
+ RAL\r
+ TAD UNITX\r
+ TAD K6 /OFFSET TO CURRENT BLOCK\r
+ TAD LDSRN /START OF DSRN TABLE - 11\r
+ DCA TEMQ\r
+ CDF 0\r
+ TAD% TEMQ\r
+ DCA SB\r
+/\r
+/MOVE USR CALLING ROUTINE TO DEFINED LOCATION\r
+/ I.E. PROTECT LOCS 10000-11777\r
+/\r
+ TAD K7400 /Target address\r
+ DCA TEMQ /Store for indirect reference\r
+ TAD #LUSR+1 /Origin address\r
+ DCA TEMQ2 /Store for indirect reference\r
+ TAD M200 /Number of words to move\r
+ DCA TEMQ3 /Store in a counter\r
+ TAD #LUSR /Load field word\r
+ AND K7 /Strip it\r
+ CLL RTL /Into right bits\r
+ RAL\r
+ TAD #CDF\r
+ DCA .+1 /Store the CDF\r
+FUSR, HLT /Set field where USR loads\r
+ TAD% TEMQ2 /Load routine location\r
+FD1, CDF 00 /Set HIGH field\r
+ DCA% TEMQ /Store location in high field\r
+ ISZ TEMQ /Bump the pointers\r
+ ISZ TEMQ2\r
+ ISZ TEMQ3 /And the counters\r
+ JMP FUSR /Loop on it\r
+\r
+/SET FIELDS AND CALL IT\r
+\r
+ RIF /GET CURRENT FIELD\r
+ TAD #CDF\r
+ DCA .+1\r
+ HLT /Set this field\r
+FI1, CIF 00 /Set high field\r
+ TAD FUNCTX /Load function number\r
+ JMS% K7400 /Call routine\r
+SB, 0 /START BLOCK OF FILE OR LENGTH IF CLOSE\r
+NOBLKS, 0 /LENGTH OF FILE\r
+ENTPT, 0 /HANDLER ENTRY POINT\r
+ DCA ERRUSR /SAVE ERROR RETURN VALUE\r
+\r
+/SETUP TO MOVE DSRN TABLE APPROPRIATELY\r
+\r
+ TAD UNITX\r
+ CLL RTL /MULTIPLY BY 9\r
+ RAL\r
+ TAD UNITX\r
+ TAD LDSRN\r
+ DCA TEMQ\r
+#CDF, CDF 0\r
+ DCA% TEMQ /DISABLE FILE IN CASE CLOSE FUNCTION\r
+ CLA CLL CMA RTL /-3 => AC\r
+ TAD FUNCTX\r
+ SMA SZA CLA /CLOSE?\r
+ JMP USRSL5 /YES\r
+\r
+/MOVE HANDLER TO APROPRIATE BUFFER\r
+\r
+ CLA CMA CLL RAL /-2 => AC\r
+ TAD UNITX\r
+ CLL RTR\r
+ RTR /UNIT 9 => AC=7000; UNIT 8 => AC=6000\r
+ TAD M400\r
+ DCA LHNDR /LOCATION FOR THIS UNIT'S HANDLER\r
+ TAD K5200\r
+ DCA TEMQ2\r
+ TAD M400\r
+ DCA TEMQ3\r
+USRL4, CDF 0\r
+ TAD% TEMQ2\r
+FD2, CDF 00\r
+ DCA% LHNDR\r
+ ISZ TEMQ2\r
+ ISZ LHNDR\r
+ ISZ TEMQ3\r
+ JMP USRL4\r
+\r
+/BUILD UP NEW DSRN TABLE FOR THIS UNIT\r
+\r
+ CDF 0\r
+ TAD ENTPT\r
+ DCA% TEMQ /ENTRY POINT\r
+ ISZ TEMQ\r
+ CLL CML RTL /2 => AC (FORMS CONTROL BIT)\r
+ TAD LHNDR\r
+ TAD M400\r
+ TAD LHIFLD\r
+ DCA% TEMQ /HANDLER CODE WORD\r
+ TAD K7774 /*K* KLUDGE TO LET FRTS KNOW WHICH\r
+ AND% TEMQ / HANDLER IS IN CORE\r
+ DCA% #HKEY\r
+ ISZ TEMQ\r
+ TAD LHNDR\r
+ TAD LHIFLD\r
+ DCA% TEMQ /BUFFER ADDRESS & FIELD\r
+ ISZ TEMQ\r
+ TAD LHNDR\r
+ DCA% TEMQ /CHARACTER POINTER\r
+ ISZ TEMQ\r
+ CMA CLL RTL /-3 => AC\r
+ DCA% TEMQ /CHARACTER COUNTER\r
+ ISZ TEMQ\r
+ TAD SB\r
+ DCA% TEMQ /START BLOCK\r
+ ISZ TEMQ\r
+ DCA% TEMQ /RELATIVE BLOCK\r
+ ISZ TEMQ\r
+ TAD NOBLKS\r
+ DCA% TEMQ /LENGTH OF FILE\r
+ ISZ TEMQ\r
+ DCA% TEMQ /STATUS WORD\r
+\r
+USRSL5, CDF CIF 0\r
+ JMP% #USRSE\r
+\r
+\r
+K6, 6\r
+K7400, 7400\r
+M200, -200\r
+M400, -400\r
+K7, 7\r
+K5200, 5200\r
+\r
+LDSRN, DSRN-11 /START LOCATION OF DSRN TABLE\r
+\r
+LHIFLD, 0\r
+TEMQ, 0\r
+TEMQ2, 0\r
+TEMQ3, 0\r
+LHNDR, 0\r
+FUNCTX, 0 /STUFFED BY RALF CODE\r
+UNITX, 0 /STUFFED BY RALF CODE\r
+ERRUSR, 0 /READ BY RALF CODE\r
+\r
+#LUSR, ADDR #USR\r
+#HKEY, HKEY /LOCATION OF HKEY IN FRTS\r
+ / MUST AGREE WITH VERSION!!\r
+K7774, 7774\r
+/\r
+ ORG .+177&7600\r
+/USR CALLING SUBROUTINE FOR FORTRAN \r
+/\r
+/ THIS ROUTINE IS MOVED TO PAGE 7400 OF THE HIGHEST\r
+/ FIELD BEFORE EXECUTING TO AVOID BEING OVERWRITTEN BY THE USR\r
+/ ROUTINE. NO FILE SPECIFICATIONS OTHER THAN INTERNAL\r
+/ HANDLERS AND SYSTEM DEVICES MAY BE MADE EXTERNAL TO THESE\r
+/ ROUTINES BECAUSE THE USE OF THIS ROUTINE WILL OVERWRITE\r
+/ THE HANDLERS WHICH ARE STORED IN HIGH CORE.\r
+/\r
+/\r
+#USR, 0\r
+/\r
+/ ENTER WITH FUNCTION CODE IN THE AC\r
+/ 2 - LOOKUP (OPEN FOR INPUT)\r
+/ 3 - ENTER (OPEN FOR OUTPUT)\r
+/ 4 - CLOSE (CLOSE OUTPUT FILE)\r
+/\r
+/ DEVICE AND FILE NAMES ARE STUFFED BY THE CALLING\r
+/ PROGRAM BEFORE THIS SUBROUTINE IS CALLED.\r
+/\r
+/ CALLING SEQUENCE:\r
+/ JMS #USR\r
+/ START BLOCK OF FILE (RETURNED FOR CODE 2 & 3)\r
+/ # BLOCKS SUPPLIED IF CODE 4\r
+/ NUMBER OF BLOCKS IN FILE (RETURNED FOR CODE 2 & 3)\r
+/ ENTRY POINT OF HANDLER AS READ INTO PAGE 5200\r
+/ <RETURN>\r
+/\r
+/ AC ON EXIT CONTAINS ERROR CONDITION:\r
+/ 0 - NO ERROR\r
+/ 1 - ILLEGAL DEVICE\r
+/ 2 - ILLEGAL FILE NAME\r
+/\r
+ DCA FUNCTY /SAVE FUNCTION CODE\r
+ TAD% #USR /GET # BLOCKS IN CASE CLOSE FUNCTION\r
+ DCA #BLKS\r
+\r
+ RDF /SET INSTRUCTION FIELD FOR RETURN\r
+ TAD #CIF\r
+ DCA EXIT4\r
+ CMA /MAKE IT CDF\r
+ TAD EXIT4\r
+ DCA EXIT\r
+ DCA ERRNO /INITIALIZE ERROR RETURN VARIABLE\r
+ CMA\r
+ TAD #CIF /-1 IN AC MAKES IT CDF\r
+ RIF\r
+ DCA .+1\r
+ HLT /SET DATA FIELD TO CURRENT FIELD\r
+\r
+/ ********SWAP CORE FOR USR CALL\r
+\r
+/Note, that it would be much simpler to read in the field\r
+/one tables, and call USR at 17700. Let USR do the swapping.\r
+/We must only set the correct bits in the JSW.\r
+\r
+ IOF\r
+#CIF, CIF 0\r
+ JMS% K7607 /CALL SYSTEM HANDLER\r
+ 5210 / WRITE 17400-17777,10000-11777\r
+ 7400\r
+ 27\r
+ HLT /DEVICE ERROR\r
+\r
+ CIF 0\r
+ JMS% K7607 /READ IN USR\r
+ 610\r
+ 0\r
+ 13 /From block 13\r
+ HLT\r
+\r
+ CIF 0\r
+ JMS% K7607 /READ IN FIELD ONE TABLES\r
+ 210\r
+ 7400\r
+ 37 /From block 37 (where FRTS put it)\r
+ HLT\r
+\r
+/ ********PERFORM USR FUNCTIONS\r
+\r
+ CIF 10\r
+ JMS% K200 /RESET tables, so it looks like no handlers\r
+ 13\r
+ 0\r
+\r
+ TAD K5201 /SET PAGE FOR HANDLER (allow 2 page handler)\r
+ DCA ENTRY\r
+ CIF 10\r
+ JMS% K200 /FETCH\r
+ 1\r
+DEV, 0 /(STUFFED BY RALF ROUTINE)\r
+DEVNO, 0\r
+ENTRY, 5201\r
+ JMP ERR /ILLEGAL DEVICE\r
+\r
+ TAD #LFILE /SET POINTER TO FILE\r
+ TAD KOFSET\r
+ DCA LFILE\r
+ TAD DEVNO /GET DEVICE NUMBER\r
+ CIF 10\r
+ JMS% K200 /PERFORM FUNCTION\r
+FUNCTY, 0\r
+SB2,\r
+LFILE, 0\r
+#BLKS, 0\r
+ JMP ERR2 /FILE ERROR\r
+\r
+/ ********RESTORE CORE\r
+\r
+EXIT2, CIF 0\r
+ JMS% K7607 /SAVE FIELD ONE TABLES\r
+ 4210 /? Is this really necessary?\r
+ 7400 /Since they've already been saved?\r
+ 37 /by FRTS\r
+ HLT\r
+\r
+ CIF 0 /USROUT function would do this\r
+ JMS% K7607 /Read in the Stuff we saved\r
+ 1210\r
+ 7400\r
+ 27\r
+ HLT\r
+\r
+ ION /Is this necessary?\r
+EXIT, HLT\r
+ TAD SB2 /RETURN SB & #BLKS\r
+ DCA% #USR\r
+ ISZ #USR\r
+ TAD SB2\r
+ SZA CLA /NON-FILE STRUCTURED DEVICE?\r
+ JMP .+3\r
+ CMA /YES - SET MAX NUMBER OF BLOCKS\r
+ JMP .+3\r
+ TAD #BLKS\r
+ CIA\r
+ DCA% #USR\r
+ ISZ #USR\r
+ TAD ENTRY\r
+ DCA% #USR\r
+ ISZ #USR\r
+ TAD ERRNO\r
+EXIT4, HLT\r
+ JMP% #USR\r
+\r
+\r
+K7607, 7607 /SYSTEM HANDLER ENTRY POINT\r
+K200, 200 /USR ENTRY POINT\r
+K5201, 5201 /PAGE FOR HANDLER (& TWO PAGES AVAILABLE)\r
+\r
+ERR2, CLA IAC /ILLEGAL FILE NAME\r
+ERR, IAC /ILLEGAL DEVICE NAME\r
+ DCA ERRNO\r
+ JMP EXIT2\r
+ERRNO, 0\r
+\r
+#LFILE, AND FILE /LOCATION OF FILE ON PAGE 7400\r
+ /'AND' NEEDED TO TRICK ABSOLUTE REFERENCE\r
+ /CHECK IN RALF.\r
+KOFSET, 7200 /OFFSET TO REAL EXECUTION ADDRESS\r
+FILE, 0;0;0;0;0;0;0;0;0\r
+\r
projects / pdp8.git / blobdiff