File: USRS.RA of Tape: Various/Disk-backup/dsk10
(Source file text)
/ / SUBROUTINE USR (UNIT, NAME, FUNCT, STATUS) (FRTS) / / SUBROUTINE USR3 (UNIT, NAME, FUNCT, STATUS) ASSEMBLE WITH /3 (FRUN) / / THIS ROUTINE ALLOWS RUN-TIME DECLARATION OF FILES / IN D.E.C. FORTRAN IV FOR THE PDP-8. THE HANDLER / AND BUFFER ALLOCATION IS FULLY DYNAMICAL, I.E. / THE FUNCTIONS 'RELEASE' AND 'CLOSE' RECOVER / ALL SPACE USED FOR HANDLER AND BUFFER. / / DESCRIPTION OF PARAMETERS: / / UNIT - LOGICAL UNIT NUMBER / NUMBERS 1 THRU 9 ARE ALLOWED. / NAME - DEV:FILE.EX / STORED IN FORMAT 3A6 (6A3 FOR FRUN) / DEVICE ASSUMED TO BE DSK: IF NOT / EXPLICITLY STATED. THIS PARAMETER MAY / ALSO BE A HOLLERITH LITERAL. / SPACES ARE IGNORED IN THIS FIELD. / @ (NULL IN FRUN) IS END OF NAME / FUNCT - FUNCTION: 1 - RELEASE UNIT / 2 - OPEN FILE FOR INPUT / 3 - OPEN FILE FOR OUTPUT / 4 - CLOSE OUTPUT FILE / THE OUTPUT FILE NAME GIVEN FOR A <CLOSE> / MUST AGREE WITH THE CORRESPONDING <OPEN> / FILE NAME FOR THAT UNIT. CLOSING A FILE / WITH 0 BLOCKS OR AN INPUT (FUNCT=2) FILE WILL / DELETE THAT FILENAME FROM THE DIRECTORY. / STATUS - A POSITIVE CALLING VALUE INHIBITS FORMS CONTROL / A NEGATIVE CALLING VALUE ENABLES FORMS CONTROL / ON THE SPECIFIED UNIT. (ABS(STATUS)-1) IS / A DECLARATION OF THE MAXIMUM FILE LENGTH. / - RETURNS / IF NO ERRORS FILE LENGTH IF FUNCT=2 / MAX FILE LENGTH IF FUNCT=3 / 0 IF FUNCT=1 OR =4 / IF ERROR THE STATUS WILL BE A NEGATIVE / ERROR NUMBER / -1 - ILLEGAL FUNCTION CODE FOR UNIT / -2 - ILLEGAL UNIT NUMBER / -3 - ILLEGAL FILE NAME / -4 - MEMORY OVERFLOW / -5 - DEVICE DOES NOT EXIST / -6 - FILE NOT FOUND OR DEVICE FULL / -7 - SYS: WRITE-LOCKED / -10 - I-O ERROR /NOTES: / 1 - UNIT NUMBERS 1-4 ARE NOT STRONGLY RECOMMENDED / BECAUSE THE INTERNAL HANDLERS CANNOT BE RE- / CLAIMED. OTHERWISE THEY ARE EQUIVALENT TO 5-9. / 2 - THE RELEASE FUNCTION (WHICH ALWAYS SUCCEEDS) / ALLOWS DELETING A UNIT EVEN IF NO FREE MEMORY / IS AVAILABLE. PRINCIPAL USE WILL BE FOR RE- / OPENING A UNIT FOR INPUT: / OPEN INPUT 1...PROG...EOF...RELEASE...OPEN INPUT 2 / 3 - STANDARD PROCEDURE FOR DELETING A FILE IS: / RELEASE...OPEN INPUT...CLOSE / 4 - U S R CONSIST OF 2 PARTS: / USRS (FPP CODE) (1000 WORDS) (CAN BE IN OVERLAY) / USR8 (PDP8 CODE) (1000 WORDS) (MUST BE IN MAIN) / 5 - THE FATAL USER ERRORS CAN BE MADE NON-FATAL / FOR PROGRAM DEVELOPMENT BY USING /E IN FRTS. / 6 - A SLIGHTLY MODIFIED VERSION OF FRTS HAS TO BE / USED. IT CAN BE RECOGNIZED BY THE SINGLE LETTER / U IN IT'S VERSION NUMBER. (FRTS V5AXYZ U) <-- / THIS PROGRAM REQUIRES THAT THE LOCATIONS: HKEY=2761 DSRN=4244 HPLACE=5200 MAXCOR=121 BOTHAN=122 TOPBUF=124 / BE CONSISTENT WITH THE VERSION OF / FIV BEING USED. EXTERN CGET EXTERN CGET3 /FOR FRUN EXTERN CPUT EXTERN USRS8 EXTERN #ENDF #DEV=USRS8+637 #FILE=USRS8+744 #LDSRN=USRS8+167 #LHNDR=USRS8+163 #LBUFF=USRS8+165 #USRLC=USRS8+171 #USRLD=USRS8+173 #CLNLC=USRS8+175 #CLBLC=USRS8+352 #SB=USRS8+34 #FUNCT=USRS8+160 #CLEN=USRS8+350 #SB2=USRS8+701 #FD1=USRS8+15 #FD2=USRS8+30 #FI1=USRS8+31 #FUSR=USRS8+13 #USRDF=USRS8+604 #UEXIT=USRS8+722 #USCLN=USRS8+147 #CBFIF=USRS8+330 IFNSW 3 < SECT USR > IFSW 3 < SECT USR3 > JA #ST #XR, ORG .+10 /THE 8 XR REGISTERS USED AS: /0: PSEUDO ISN /1: INCREMENTING /5: FORMS CONTROL /6: HCW OF THIS UNIT /7: PERIOD SWITCH TEXT +USR + /FOR TRACEBACK #RET, SETX #XR /RESET TO MY XR,BASE WHEN SETB #BASE /RETURNING FROM CALLED SUBROUTINE JA .+3 /JUMP TO 'JSR' GENERATED 'JA CALL+2' #BASE, ORG .+3 /GETS ABOVE 'JA' IN D.P. FORMAT BDSRN, ORG .+3 /SECOND LOC FREE FOR USE BY SUBROUTINES UNIT, ORG .+3 /MY ARGUMENTS. WELL ... NOT ALL FUNCT, ORG .+3 ERROR, ORG .+3 /FUNCT,ERROR STAY AS ADDRESSES X, F 0.0 I, F 0.0 N, F 0.0 ORG #BASE+30 /STANDARD LOCATION FNOP JA #RET /CALLED SUBROUTINE LOADS THIS RETURN FNOP #GOBAK, 0;0 /I STORE THE ABOVE RETURN HERE #RTN, FCLA JA #GOBAK /RETURN TO LOWER LEVEL XR,BASE RESET ENTLEN, F 0. /FILE LENGTH FOR ENTER DSK, TEXT +DSK@@@+ COLON, F 58. /OCTAL 72 PERIOD, F 46. /OCTAL 56 F1, F 1. F4, F 4. F6, F 6. F8, F 8. F9, F 9. F16, F 16. F26, F 26. F32, F 32. F4096, F 4096. D00001, 27;0;1 D00200, 27;0;200 D00400, 27;0;400 D17400, 27;1;7400 DCDF, 27;0;CDF DSBASE, 27;ADDR DSRN DSETXI, 27;SETX 0 /DUMMY SETX ADUSR8, ADDR USRS8 BASE #BASE #ST, STARTD /USUAL 'SETUP' ROUTINE 0210 /LOAD LOWER LEVEL BASE+30 FSTA #GOBAK,0 /AND STORE THAT 'JA #RET' 0200 /LOAD LL 'JA ARG' SETX #XR SETB #BASE /NOW WE ARE BORN! LDX 0,1 FSTA #BASE /DON'T FORGET THIS GETS CLOBBERED /IF WE CALL ANOTHER SUBROUTINE FLDA% #BASE,1+ /PREINC XR 1 TO SKIP 'JA' AFTER CALL FSTA UNIT FLDA% #BASE,1+ FSTA# NAME FLDA% #BASE,1+ FSTA FUNCT FLDA% #BASE,1+ FSTA ERROR STARTF LDX 2,0 /FOR ERROR #2 LDX 0,5 /SET NO FORMS CONTROL FLDA% ERROR /GET FORMS INDICATION JGE FORM /GE 0 IS NO FORMS LDX 2,5 /SET CORRECT VALUE FOR FORMS CONTROL FNEG /FILE LENGTH IS POSITIVE FORM, JEQ FZERO FSUB F1 /FILE LENGTH IS ABS VALUE -1 FZERO, FMUL F16 /BUMP OVER DEV # FSTA ENTLEN /KEEP IT FOR ENTER FSUB F4096 /TOO BIG ? JGE ERRARG /YES, BIGGER THAN 255 BLOCKS FLDA% UNIT FSTA UNIT FSUB F9 /CHECK RANGE JGT ERRARG FLDA UNIT FSUB F1 /MAKE UNIT # START FROM 0 JLT ERRARG FMUL F9 /MAKE DSRN SLOT ALN 0 STARTD FADD DSBASE FSTA BDSRN /PUT IN BASE PAGE AND FSTA# #LDSRN /STORE FAR AWAY STARTF FLDA% FUNCT FSUB F1 /RELEASE DOES NOT USE USRUSR STARTD JEQ NOMEM /SO WE CAN RELEASE WITH 0 FREE PAGES / INITIALIZE PROGRAM / LDX 4,0 /FOR ERROR #4 FLDA# BOTHAN FSTA# #LHNDR FLDA# TOPBUF FSTA# #LBUFF FSUB D17400 /IF PROG ENDS AT 17400 JEQ SPCLOC /WE MUST BE CAREFUL FLDA# #LHNDR /FIND OUT IF WE HAVE FSUB# #LBUFF /ENOUGH SPACE TO COPY FSUB D00400 /'USRUSR' INTO (LENGTH 400) JLT ERRARG /FATAL USER ERROR NOMEM, FLDA# #LBUFF /OK, PUT 'USRUSR' AT TOP JA OKMEM /OF PROGRAM AND BUFFERS. SPCLOC, FLDA# #LHNDR /IF END OF PROG AT 17400 FSUB D17400 /WE MUST LOAD 'USRUSR' AT FSUB D00400 /20000. CHECK IF ROOM FSUB D00400 /UP TOO 20400 JLT ERRARG /NO! TOO BAD - ERROR FLDA D17400 /OK, SET LOC TO 20000 FADD D00400 /THIS WAS ALL DONE IN D.P. MODE OKMEM, FSTA# #USRLC /HOLDS LOC TO LOAD 'USRUSR' FSUB# #USRLD /RELOCATION DISTANCE FADD# FILADR /RELOCATED ADDRESS OF '#FILE' SETX #SB2 ATX 0 /SET ADDRESS OF '#FILE' SETX #USRLC JSA MAKCDF SETX #FD1 ATX 0 /SET LOCATION FOR 'USRUSR' TRANSFER SETX #USRDF ATX 0 /ALSO IN 'USRUSR' ITSELF FADD D00001 /MAKE IT CIF USRUSR SETX #FI1 ATX 0 /FOR 'JMS% USRUSR' SETX #USRLD /MAKE CDF ORIGINAL 'USRUSR' JSA MAKCDF SETX #FUSR ATX 0 /FOR COPYING 'USRUSR' SETX ADUSR8 /USE TRAP USRS8 JSA MAKCDF SETX #FD2 ATX 0 /SET CURRENT FIELD IN USRS8 FADD D00001 /MAKE CIF CDF FADD D00001 SETX #UEXIT ATX 0 /FOR USRUSR RETURN TO USRS8 SETX #CLNLC JSA MAKCDF FADD D00001 /MAKE CIF SETX #USCLN ATX 0 /FOR JMS% #CLNLC+1 SETX #CLBLC JSA MAKCDF FADD D00001 /MAKE CIF SETX #CBFIF ATX 0 /FOR JMS% #CLBLC+1 JSA SETDS XTA 0 /GET HANDLER ENTRY POINT SETX #XR ATX 6 /KEEP FOR LATER STARTF FLDA% FUNCT /RELEASE IS ALWAYS ALLOWED FSUB F1 JEQ OPINOT /OK: RELEASE LDX 1,0 /FOR ERROR #1 XTA 6 /GET HCW BACK JEQ FREE FLDA% FUNCT FSUB F4 JEQ GODFUN /OK: CLOSE JA ERRARG /NO: BAD FUNCTION FREE, FLDA% FUNCT /IF SLOT FREE FSUB F1 FSUB F1 JEQ GODFUN /OPEN INPUT IS OK FSUB F1 JNE ERRARG /NO OPEN OUTPUT IS BAD / PUT DEV:FILE.EXT INTO CORRECT FORMAT FOR USR CALL / GODFUN, LDX -1,7 /NO PERIODS YET LDX 3,0 /FOR ERROR #3 FLDA DSK /INIT DEV: TO DSK: FSTA# #DEV FCLA /INITIALIZE SOME VARIABLES... FSTA# #FILE FSTA# #FILE+3 FSTA N FSTA I / DO I=1,18 JA SKIP GETLUP, IFNSW 3 < JSR CGET / CALL CGET (NAME, I, X) > IFSW 3 < JSR CGET3 / CALL CGET3 (NAME, I, X) > JA .+10 NAME, JA . /**RA FORMAL PARAM ADDRESS JA I JA X FLDA X / IF (X.NE.COLON) GO TO NOCOL JEQ EOIN /IGNORE NULLS FSUB COLON JNE NOCOL FLDA I /COLON MUST BE COLUMN 5 OR BEFORE FSUB F6 JGE ERRARG FLDA# #FILE /COLON DEFINES DEVICE NAME FSTA# #DEV FCLA FSTA# #FILE JA SKIP NOCOL, FLDA X / IF (X.NE.PERIOD) GO TO NOPER FSUB PERIOD JNE NOPER JXN ERRARG,7+ /ONLY ONE PERIOD ALLOWED FLDA F6 JA SKIP /POSITION FOR EXTENSION NOPER, FLDA X IFNSW 3 < FSUB F26 JLE GODCHR /ALPHAS FSUB F6 JLT ERRARG /[ TO _ > IFSW 3 < FSUB F32 JLT ERRARG /CONTROL CODES > JEQ IGNOR /SKIP SPACES FSUB F16 JLT ERRARG /! TO / FSUB F9 IFNSW 3 < JGT ERRARG /: TO ? /DIGITS > IFSW 3 < JLE GODCHR /DIGITS FSUB F6 JLE ERRARG /: TO ? FSUB F1 JEQ EOIN /@ IS NAME TERMINATOR FSUB F26 JGT ERRARG /[ TO END (LOWER CASE) /ALPHAS > GODCHR, JSR CPUT / CALL CPUT (FILE, N, X) JA .+10 FILADR, JA #FILE JA N JA X FLDA N / N=N+1 SKIP, FADD F1 MORE, FSTA N FSUB F9 /MORE THAN 8 CHARS? JGT ERRARG /YES, PROTECT USRUSR IGNOR, FLDA I / CONTINUE FADD F1 FSTA I FSUB F9 FSUB F9 JLE GETLUP EOIN, FLDA% FUNCT FSUB F4 JEQ XCLOSE /IT IS CLOSE FLDA ENTLEN /GET INDICATED FILE-LENGTH JA BYPASS /STORE IN '#SB' XCLOSE, STARTD /USER PROGRAM HAS ENDFILED JSA SETDS XTA 7 /OUR FILE LENGTH BYPASS, SETX #SB ATX 0 /TO '#SB' FOR CLOSE STARTF SETX #XR / START OF RELEASE OPINOT, XTA 5 /GET FORMS SETX #FUNCT /USR XR TO PASS PARAMETERS ATX 2 /TO #FORMS IN USRS8 FLDA% FUNCT ATX 0 TRAP4 USRS8 /TRAP TO THE USR CALLING ROUTINE XTA 1 /GET ERRNO AND RETURN IT SETX #XR JNE ERARUS /ERROR: LEAVE CORE INTACT FLDA% FUNCT FSUB F4 /CLOSE IS SPECIAL JEQ ENDCLS FLDA% FUNCT FSUB F1 JEQ ENDCLS /RELEASE LIKE CLOSE FCLA /FOR HW FPP! STARTD FLDA# #LHNDR /GET MODIFIED TOP-OF-MEM FSUB# TOPBUF /OLD TOP-OF-BUFFERS FSUB D00400 /NEED 400 FOR BUFFER JLT OVRFLW /NO ROOM! FLDA# #LHNDR FSTA# BOTHAN /SET NEW BOTTOM OF HANDLRES FLDA D00400 FADDM# TOPBUF /SET NEW TOP-OF-BUFFERS JA RETURN ENDCLS, JSA WIPE /WIPE-OUT UNIT SLOT STARTD SETX #CLEN XTA 0 /GET SIZE OF DELETED HANDLER FADDM# BOTHAN /GAINED SOME SPACE XTA 1 /GET SIZE OF DELETED BUFFER FADDM# TOPBUF /AND SOME MORE STARTF FCLA /RETURN WITH 0 STATUS JA OK RETURN, STARTF SETX #SB XTA 1 / GET FILE LENGTH (-2047 TO 2048) JGE OK FADD F4096 / NEG MEANS GT 2048 JA OK OVRFLW, JSA WIPE /NOBODY KNOWS THE TROUBLE I HAVE ERARUS, FADD F4 /BACK FROM USRUSR ERROR ATX 0 /ERRORS (4)5-10 ERRARG, STARTF XTA 0 FNEG /NEGATIVE ERROR STATUS OK, FNORM FSTA% ERROR JA #RTN MAKCDF, JA . /ENTER IN D-MODE STARTF XTA 0 /GET FIELD FMUL F8 /PUT IT INTO BITS 6-8 ALN 0 /CHANGE TO D-FORMAT STARTD FADD DCDF /MAKE IT CDF FIELD JA MAKCDF WIPE, JA . /WIPE OUT SLOT STARTF FCLA LDX 0,1 FSTA% BDSRN,1 FSTA% BDSRN,1+ FSTA% BDSRN,1+ JA WIPE /THIS TIME I LIKE LENGTH 9 SETDS, JA . /ENTER IN D-MODE FLDA BDSRN /GET SLOT AGAIN FADD DSETXI /INITIALIZE SETX INSTRUCTION FSTA# .+2 SETX DSRN /**RA MODIFIED BY RALF JA SETDS END