File: USR8.RA of Tape: Sources/Fortran/os8-f4-1
(Source file text)
DSRN=4244 HPLACE=5200 HKEY=2761 MAXCOR=121 SECT8 USRS8 / /THIS ROUTINE SETS UP, AT THE TOP OF THE RALF PROGRAM, A /ROUTINE WHICH CALLS THE OS/8 USR (USER SERVICE ROUTINE). /IT IS NECESSARY TO DO THIS BECAUSE THE FORTRAN IV LOADER /MAY LOAD ANY ROUTINE IN THE RESERVED AREA FOR THE /OS/8 USR (10000 - 11777) AND FIELD 1 RES (17400-17777) /ALL THIS IS SKIPPED FOR THE 'RELEASE' FUNCTION AND /WE GO DIRECTLY TO THE HANDLER AND BUFFER CLEANUP CODE. / 0 CLA CMA TAD #FUNCT /IF RELEASE CALL CLNHAN ONLY SNA CLA JMP #USCLN / /MOVE USR CALLING ROUTINE TO DEFINED LOCATION /I.E. PROTECT LOCS 10000-11777, 17400-17777 / TAD #USRLC+1 DCA TEMQ TAD #USRLD+1 DCA TEMQ2 TAD M400 DCA TEMQ3 #FUSR, HLT /**RA CDF ORIG. FIELD OF USRUSR TAD% TEMQ2 #FD1, HLT /**RA CDF RELOCATED FIELD OF USRUSR DCA% TEMQ ISZ TEMQ M400, -400 /NOP ISZ TEMQ2 SKP TAD K10 /IF NEW FIELD INC CDF TAD #FUSR DCA #FUSR ISZ TEMQ3 JMP #FUSR /SET FIELDS AND CALL IT #FD2, HLT /**RA THIS DATA-FIELD #FI1, HLT /**RA CIF TO RELOCATED 'USRUSR' TAD #FUNCT JMS% #USRLC+1 #SB, 0 /START BLOCK OF FILE AND **RA CLOSE BLKS NOBLKS, 0 /LENGTH OF FILE ENTPT, 0 /HANDLER ENTRY POINT TWOPAG, 0 /**RA GET 0,1,2 PAGE INDICATOR SZA JMP USREX /GET OUT IF ERROR CLA CLL CMA RTL /=-3 TAD #FUNCT SMA SZA CLA JMP #USCLN /CLOSE: CALL CLNHAN / /FOR INPUT/OUTPUT MOVE HANDLER TO APPROPRIATE BUFFER / UCDF, CDF 0 TAD ENTPT JMS SEDSRN /DSRN #1: ENTRY POINT TAD TWOPAG CLL CIA SNA JMP RESIDE /0 MEANS RESIDENT HANDLER TAD #LHNDR+1 /BUMP DOWN CEILING FOR NEW HANDLER DCA #LHNDR+1 SNL CLA CMA TAD #LHNDR /DON'T FORGET HIGH ORDER DCA #LHNDR TAD #LHNDR CLL RTL RAL DCA% HANKEY /SAVE THESE BITS IN FIELD 0 TAD% HANKEY /WE NEED THEM FOR NEW HCW TAD UCDF /WE HAVE TO BUILD CDF HERE DCA FD3 /BECAUSE **RA IS NOT INFORMED YET. TAD #LHNDR+1 DCA TEMQ TAD KHPLC DCA TEMQ2 TAD TWOPAG CIA DCA TEMQ3 USRL4, CDF 0 TAD% TEMQ2 FD3, CDF 0 /NEW HANDLER FIELD DCA% TEMQ ISZ TEMQ2 ISZ TEMQ K10, 10 /NOP ISZ TEMQ3 JMP USRL4 /BUILD UP NEW DSRN TABLE FOR THIS UNIT / / /DSRN #1: DONE ON PREV PAGE CDF 0 TAD #LHNDR+1 /THIS HANDLER IS NON-RESIDENT TAD% HANKEY /FIELD BITS FROM BEFORE RESIDE, DCA% HANKEY /THIS HANDLER IS RESIDENT TAD #FORMS /+FORMS CONTROL TAD% HANKEY /MAKES FINAL HCW JMS SEDSRN /DSRN #2: HHH.HH0.FFF.0CI TAD #LBUFF CLL RTL RAL TAD #LBUFF+1 JMS SEDSRN /DSRN #3: BBB.B00.FFF.000 TAD #LBUFF+1 JMS SEDSRN /DSRN #4: BUFFER POINTER CMA CLL RTL /-3 => AC JMS SEDSRN /DSRN #5: CHARACTER COUNTER TAD #SB JMS SEDSRN /DSRN #6: STARTING BLOCK JMS SEDSRN /DSRN #7: RELATIVE BLOCK = 0 TAD NOBLKS JMS SEDSRN /DSRN #8: LENGTH OF FILE JMS SEDSRN /DSRN #9: FLAG WORD WFU.000.000.00E USREX, DCA #ERUSR /CLEAR OR SET ERROR CDF CIF 0 /TRAP4 EXIT JMP% USRS8 TEMQ3, SEDSRN, 0 /FILL IN DSRN ENTRY DCA% #LDSRN+1 ISZ #LDSRN+1 JMP% SEDSRN #USCLN, HLT /**RA CIF TO 'CLNHAN' TAD #LDSRN+1 /PASS OUR SLOT JMS% #CLNLC+1 /GO AND FREE-UP CORE CDF 0 DCA% HANKEY /THIS HANDLER IS NOT NICE ANY MORE JMP USREX /BACK TO RALF U70, 70 KHPLC, HPLACE /LOCATION OF HANDLER IN F0 HANKEY, HKEY /LOCATION OF HKEY IN FRTS /MUST AGREE WITH VERSION!! #FUNCT, 0 /**RA XR 0 #ERUSR, 0 /**RA XR 1 #FORMS, 2 /**RA XR2 FORMS CONTROL 2=NO CONTROL #LHNDR, ZBLOCK 2 /**RA TOP OF CORE (MODIFIED HERE) #LBUFF, ZBLOCK 2 /**RA END OF PROGRAM (NEXT BUFFER) TEMQ, #LDSRN, ZBLOCK 2 /**RA START LOCATION OF DSRN ENTRY TEMQ2, #USRLC, ADDR USRUSR /**RA CHANGED TO REAL LOCATION OF 'USRUSR' /CHANGED TO KUSR BY 'USRS8' #USRLD, ADDR USRUSR /LOC OF 'USRUSR' AS LOADED /FIELD PART USED BY SECT FOR CDF #CLNLC, ADDR CLNHAN /**RA FIELD PART USED FOR CIF ORG .+177&7600 /NEXT PAGE /THIS IS A VERY TRICKY ROUTINE THAT RESHUFFLES THE /HANDLERS IN HIGH CORE. IT DELETES THE HANDLER COR- /RESPONDING TO THE SELECTED CHANNEL AND MOVES ALL /LOWER HANDLERS UP SO THAT WE GAIN THIS SPACE. /NATCHERLY WE ALSO CHANGE THE CORRESPONDING ENTRIES /IN THE DSRN LIST. (DSRN=DYNAMIC SORTING RATHER NOT) CLNHAN, 0 DCA CSLOT /OUR DSRN SLOT DCA #CLEN /CLEAR FOR FAST EXIT CLA STL RTL /=2 RDF TAD CCDF DCA CLNRET /SET CDI RETURN CDF 0 TAD% CSLOT SMA CLA /IS IT AN INTERNAL HANDLER? JMP CEXIT /YES, GIVE BACK 0 LENGTH ISZ CSLOT TAD% CSLOT SNA JMP CMBUF /RESIDENT, ONLY CLEAN BUFFER DCA CLOAD /OUR LOAD ADDRESS+FIELD TAD% TOPCOR /SET UPPER LIMIT OF MEMORY(BATCH) DCA CTRY CHLOOP, TAD CTRY DCA CLAST /LAST BOTTOM TAD C7600 /WALK DOWN THRU CORE TAD CTRY SNA JMP CMBUF /STOP IT IF FIELD THROUGH DCA CTRY /NEW ADDRESS TO TRY IF IN DSRN TAD CDSRN DCA CTEM /INIT DSRN POINTER TAD C10 CMA /MAKES -11! DCA CCNT /INIT DSRN SLOT COUNT LOOKLP, CLA IAC TAD C10 /ALSO 11 TAD CTEM DCA CTEM /NEXT SLOT TAD% CTEM AND C7600 /GET HCW ADDRESS CIA TAD CTRY /IS IT AT TRIAL VALUE? SNA CLA JMP CGOT /YES ISZ CCNT /NO - MORE SLOTS? JMP LOOKLP /YES - SEE IF WE FIND IT AFTER ALL JMP CHLOOP+2 /NOT IN DSRN, STEP DOWN CGOT, TAD CLOAD /IN DSRN, CHECK WHERE AND C7600 CIA TAD CTRY /COMPARED TO OUR SLOT SNA JMP SLOTIS /OUR SLOT, DO SPECIAL THINGS SMA CLA /IF -, PAST OUR SLOT: MOVE JMP CHLOOP /IF +, BEFORE OUR SLOT: SET BOTTOM TAD CLAST CIA TAD CTRY /THIS BOTTOM - LAST BOTTOM=HND SIZE DCA CCNT /COUNT FOR TRANSFER TAD CLOAD AND C70 TAD CCDF DCA CHANDF CHANDF, HLT /HANDLER DATA FIELD CLA CMA TAD CLAST DCA CLAST /TRANSFER FROM TOP TO BOTTOM TAD #CLEN /LENGHT OF HOLE TAD CLAST /+ OLD BOTTOM DCA CNEW /= NEW TOP TAD% CLAST DCA% CNEW /CNEW WILL END UP AS NEW BOTTOM ISZ CCNT JMP CHANDF CCDF, CDF 0 TAD% CTEM /CTEM STILL POINTING AT THIS HANDLERS HCW AND C77 /PICK OUT FIELD AND CI BITS TAD CNEW /FILL IN NEW SLOT DCA% CTEM JMP CHLOOP+2 /LOOP AND LEAVE 'CLAST' BOTTOM SLOTIS, TAD CLOAD AND C7600 CIA TAD CLAST /OLD BOTTOM - OUR SLOT IS SIZE OF HOLE DCA #CLEN /STORED POSITIVE FOR USRUSR JMP CHLOOP /LOOP AND SET BOTTOM TO OUR SLOT CMBUF, RIF TAD CCDF DCA CBFDF /FOR SETTING OUR DF ISZ CSLOT /OUR BCW TAD% CSLOT /TO 'CLNBUF' CBFDF, HLT #CBFIF, HLT /**RA CIF CLNBUF JMS% #CLBLC+1 CEXIT, DCA #CBLEN /SET DELETED BUFFER LENGHT CLNRET, HLT /CDI RETURN JMP% CLNHAN C10, 10 C70, 70 C77, 77 C7600, 7600 CTRY, 0 CCNT, 0 CLAST, 0 CNEW, 0 CLOAD, 0 CTEM, 0 CSLOT, 0 #CLEN, 0 /**RA XR 0 DELTED HANDLER LENGHT (POSITIVE) #CBLEN, 0 /**RA XR 1 DELETED BUFFER LENGHT (NEGATIVE) #CLBLC, ADDR CLNBUF /**RA FIELD PART USED FOR CIF CDSRN, DSRN-11+1 /POINTING AT HCW 1 SLOT BELOW DSRN TOPCOR, MAXCOR /BATCH PROTECTION ORG .+177&7600 /NEXT PAGE /THIS IS STILL ANOTHER ROUTINE WHICH MOVES THE /BUFFERS DOWN OVER THE DELETED BUFFER. IT IS EASIER /THAN 'CLNHAN' BECAUSE ALL BUFFERS ARE 400 LONG. /BUT WATCH IT, THEY CROSS FIELDS!! / CLNBUF, 0 DCA CBOTT /SAVE OUR BCW STL RTL /=2 RDF TAD CBCDF DCA CBRET TAD CBOTT /IF ZERO NO DELETION SNA CLA JMP CBRET /GIVE BACK LENGHT = 0 CBLOOP, CLL TAD CBOTT TAD C400 /TO NEXT BUFFER SZL /NEXT FIELD? TAD CB10 /YES INC FIELD BITS DCA CHIGH /NEXT BUFFER ADDRESS TAD CBDSRN DCA CBTEM /INIT DSRN POINTER TAD CB10 CMA /MAKES -11! DCA CBCNT /INIT DSRN SLOT COUNT CBCDF, CDF 0 CLA IAC TAD CB10 /ALSO 11 TAD CBTEM DCA CBTEM /NEXT SLOT TAD% CBTEM AND C7770 /GET BCW ADDRESS+FIELD CIA TAD CHIGH /IS IT AT TRIAL VALUE? SNA CLA JMP CBGOT /YES ISZ CBCNT /NO - MORE SLOTS? JMP CBCDF /YES - SEE IF WE FIND IT AFTER ALL TAD C7400 /TRANSPORT DELETED BUFFER LENGHT CBRET, HLT /NO UNIT IS END JMP% CLNBUF CBGOT, TAD CHIGH AND CB70 TAD CBCDF /MAKE CDF FROM DCA CBCDFF TAD CBOTT AND CB70 TAD CBCDF DCA CBCDFT /MAKE CDF TO TAD CBOTT AND C7400 DCA CBTRT /BLOCK ADDRESS TAD CBOTT DCA% CBTEM /BUILD NEW BCW ISZ CBTEM /GO TO BUFFER POINTER CMA TAD C400 /GIVES MASK 377 AND% CBTEM /MAKES POINTER 0-377 TAD CBTRT /+ NEW BASE DCA% CBTEM /STORE BACK MODIFIED TAD C7400 DCA CBCNT /BUFFER SIZE COUNT CBTRLP, TAD CBTRT TAD C400 /MAKE FROM ADDRESS DCA CBTRF CBCDFF, HLT /MADE HERE TAD% CBTRF /FROM CBCDFT, HLT DCA% CBTRT /TO ISZ CBTRT C7400, 7400 /NOP ISZ CBCNT /BUFFER DONE? JMP CBTRLP /NO - LOOP TAD CHIGH /SET NEW BOTTOM DCA CBOTT JMP CBLOOP /YES - MORE BUFFERS? CBOTT, 0 CHIGH, 0 CBTEM, 0 CBCNT, 0 CBTRF, 0 CBTRT, 0 CBDSRN, DSRN-11+2 /POINTING AT BCW 1 SLOT BELOW DSRN C400, 400 CB10, 10 C7770, 7770 CB70, 70 / SOME ROOM FOR EXPANSION!? ORG .+177&7600 /NEXT PAGE /USR CALLING SUBROUTINE FOR FORTRAN / / THIS ROUTINE IS MOVED TO THE TOP OF RALF CODE (BUFFERS) / BY 'USR8' BEFORE EXECUTING TO AVOID BEING OVERWRITTEN BY / THE OS/8 USR ROUTINE. IMPORTANT! NO NEED TO INITIALIZE / ANY NON **RALF CONSTANTS, A FRESH COPY OF 'USRUSR' IS / USED FOR EACH CALL. / / / / ENTER WITH FUNCTION CODE IN THE AC / 1 - RELEASE (CLOSE INPUT FILE) / 2 - LOOKUP (OPEN FOR INPUT) / 3 - ENTER (OPEN FOR OUTPUT) / 4 - CLOSE (CLOSE OUTPUT FILE) / / DEVICE, FILE NAMES, ETC. ARE STUFFED BY THE CALLING / PROGRAM BEFORE THIS SUBROUTINE IS CALLED. / / CALLING SEQUENCE: / JMS USRUSR / - START BLOCK OF FILE (RETURNED FOR CODE 2 & 3) / # OF BLOCKS FOR CLOSE SUPPLIED / - NUMBER OF BLOCKS IN FILE (RETURNED FOR CODE 2 & 3) / - ENTRY POINT OF HANDLER AS READ INTO PAGE 'HPLACE' / - 0 IF RESIDENT HANDLER, 200 IF ONE PAGE HANDLER / 400 IF TWO PAGE HANDLER / <RETURN> / / AC ON EXIT CONTAINS ERROR CONDITION: / 0 - NO ERROR / 1 - NO SUCH DEVICE / 2 - NO FILE OR NO SPACE / 3 - SYS: WRITE LOCKED / 4 - I-O ERROR / USRUSR, KUSR, 0 DCA FUNCTY /SAVE FUNCTION CODE TAD% KUSR DCA BLKS #USRDF, HLT /**RA SET DATA FIELD TO CURRENT FIELD IOF /NOP FOR MULTI8 / / ********SWAP CORE FOR USR CALL / CCIF, CIF 0 JMS% K7607 /CALL SYSTEM HANDLER 5210 / WRITE 10000-11777 & 17400-17777 7400 27 JMP ERR3 /SYS: WRITE-LOCKED? CIF 0 JMS% K7607 /READ IN USR 610 ERRNO, 0 /*K* 13 JMP ERR4 /DEVICE ERROR CIF 0 JMS% K7607 /READ IN FIELD ONE TABLES 210 7400 37 JMP ERR4 /DEVICE ERROR / ********PERFORM USR FUNCTIONS CIF 10 JMS% K200 /RESET 13 0 CIF 10 JMS% K200 /INQUIRE 12 #DEV, 0423 /**RA 1 FP WORD DEVNO, 1300 / DSK: IS SET 0000 JMP ERR1 /ILLEGAL DEVICE TAD DEVNO+1 /SEE IF RESIDENT HANDLER SZA JMP HANOK /YES - NO NEED TO FETCH TWP, TAD HANSIZ TAD K200 DCA HANSIZ /SET SIZE TO 200,400 TAD DEVNO /DEVICE TO FETCH CIF 10 JMS% K200 1 /FETCH ENTRY, HPLACE /FIRST TIME: ONE PAGE SKP CLA /ERROR TRY 2-PAGE JMP HANOK /GOT HANDLER ISZ ENTRY /SET 2-PAGE TAD HANSIZ CLL RAR AND K200 SNA CLA /ALREADY TRIED 2-PAGE? JMP TWP /NO: TRY FOR 2-PAGE HLT /YES: IMPOSSIBLE ERROR! HANOK, SZA /RESIDENT? DCA ENTRY /YES - SAVE ENTRY POINT CLA CLL CMA RTL /=-3 TAD FUNCTY /IS IT ENTER ? SNA CLA /IF ENTER USE BLKS WHICH TAD BLKS /CONTAINS USER LENGTH TAD DEVNO /GET DEVICE NUMBER CIF 10 JMS% K200 /PERFORM FUNCTION FUNCTY, 0 /**USR AC #SB2, 0 /**RA ADDRESS OF '#FILE' BLKS, 0 /**USR ARG JMP ERR2 /FILE ERROR / ********RESTORE CORE CIF 0 JMS% K7607 /SAVE FIELD ONE TABLES 4210 7400 37 HLT EXIT2, CIF 0 JMS% K7607 /RESTORE CORE 1210 7400 27 HLT 6254 /SKIP ON MULTI8 ION #UEXIT, CIF CDF 0 /**RA RETURN TO #USRS8 TAD #SB2 /RETURN SB & #BLKS DCA% KUSR ISZ KUSR TAD BLKS /=0 FOR NON-FILE STRUCTURED CIA /WAS NEGATIVE SNA /NFS? CMA /YES - SET MAX NUMBER OF BLOCKS DCA% KUSR ISZ KUSR TAD ENTRY /RETURN ENTRY POINT DCA% KUSR ISZ KUSR TAD HANSIZ /RETURN HANDLER SIZE DCA% KUSR ISZ KUSR TAD ERRNO JMP% KUSR #FILE, ZBLOCK 6 /**RA 2 FP WORDS / HANSIZ=0: RESIDENT, =200: 1-PAGE, =400: 2-PAGE HANSIZ, 0 /SET BY LOOKUP,ENTER OR REL,CLOSE K7607, 7607 /SYSTEM HANDLER ENTRY POINT K200, 200 /USR ENTRY POINT ERR4, ISZ ERRNO /I-O ERROR ERR3, ISZ ERRNO /WL ERROR ERR2, ISZ ERRNO /NO FILE OR NO SPACE ERR1, ISZ ERRNO /NO SUCH DEVICE CLA CLL CMA RTL /=-3 TAD ERRNO /IF WL DON'T RESTORE SNA CLA JMP #UEXIT-2 JMP EXIT2 IFNZRO #DEV-637 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FILE-744 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #LDSRN-167 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #LHNDR-163 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #LBUFF-165 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #USRLC-171 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #USRLD-173 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #CLNLC-175 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #CLBLC-352 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #SB-34 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FUNCT-160 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #CLEN-350 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #SB2-701 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FD1-15 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FD2-30 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FI1-31 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #FUSR-13 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #USRDF-604 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #UEXIT-722 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #USCLN-147 <LISTON : CHANGE REFERENCE IN USRS.RA> IFNZRO #CBFIF-330 <LISTON : CHANGE REFERENCE IN USRS.RA> END