.MCALL .MODULE .MODULE MGETR,VERSION=03,COMMENT=,IDENT=NO,LIB=YES ; Copyright (c) 1998 by Mentec, Inc., Nashua, NH. ; All rights reserved ; ; This software is furnished under a license for use only on a ; single computer system and may be copied only with the ; inclusion of the above copyright notice. This software, or ; any other copies thereof, may not be provided or otherwise ; made available to any other person except for use on such ; system and to one who agrees to these license terms. Title ; to and ownership of the software shall at all times remain ; in Mentec, Inc. ; ; The information in this document is subject to change without ; notice and should not be construed as a commitment by Digital ; Equipment Corporation, or Mentec, Inc. ; ; Digital and Mentec assume no responsibility for the use or ; reliability of its software on equipment which is not supplied ; by Digital or Mentec, and listed in the Software Product ; Description. ;++ ; ; Edit Who Date Description of modification ; ---- --- ---- --------------------------- ; 001 WLD 17-OCT-90 Standardize PSECT names. ;-- .SBTTL MGETR - FORTRAN callable system subroutine ;+ ; MGETR ; ; MGETR is used to attach to a global region. It can ; optionally also initialize a global region either by ; reading in a portion of a file into it, or calling a ; user specified subroutine. ; ; Calling Sequence: ; ;I=MGETR(WORK,WRKSIZ,{'Private'},[NAME],ADDR[,MEMADR][,CSIZE][,MSIZE][,OFFSET] ; {'Shared' } ; {'Age' } ; {'Local' } ; ; [{,CHAN[,BLK]}][{,'UI'}][{,'ReadOnly'}][{, 'Bypass'}]) ; [{,FILE[,BLK]}][{,'UD'}][{,'Writable'}][{,'NoBypass'}]) ; [{,SBRTN,-1 }][{,'SI'}] ; [{,'SD'}] ; [{,'CI'}] ; [{,'CD'}] ; ; ; Arguments: ; ; INTEGER*2 WORK (15) ! Work area, must be passed to IFREER ; ; INTEGER*2 WRKSIZ ! Number of words in the work area ; Char Constant ! 'Private' indicates not shared ; ! 'Shared' indicates shared ; ! 'Age' indicates shared and aged ; | 'Local' indicates not global ; INTEGER*2 NAME (2) ! Name of global region in 6 RAD50 chars ; ! this arg must be accounted for with 'Local' ; ! but is otherwise ignored with 'Local' ; INTEGER*2 ADDR ! Variable which is the region's base. It ; ! must be on a PAR boundary (0, "20000, ...). ; INTEGER*2 MEMADR ! Chunk address to use in physical memory ; INTEGER*2 CSIZE ! Creation size of global region in words. ; ! this will be rounded up to nearest 32 ; ! word boundary. 0 means use actual region ; ! size, invalid if region must be created. ; INTEGER*2 MSIZE ! The number of words to map, 0 or omitted ; ! indicates all of the (rest) of the region. ; ! It is rounded up to the next 32 word bound. ; INTEGER*2 OFFSET ! The offset in chunks (64. byte units) from ; ! the beginning of the global region to ; ! begin mapping. 0 means begin at beginning. ; INTEGER*2 CHAN ! Open channel to read initialization data ; ! from. [This arg is a channel number if ; ! its value is 0 to 255. and BLK is not -1] ; INTEGER*2 FILE (4) ! DBLK containing the device and file ; ! specification for a file to open and read ; ! initialization data from. [This arg is a ; ! DBLK if the value in the first word is ; ! greater than 255. and BLK is not -1] ; EXTERNAL SBRTN ! Subroutine to be called to initialize the ; ! global area. The subroutine is called with ; ! two arguments (ADDR, ASIZE), where ASIZE ; ! is an INTEGER*2 argument and contains the ; ! actual size of the mapped window in words. ; ! [This arg is a subroutine if BLK is -1] ; INTEGER*2 BLK ! The first block to use in the file for ; ! initialization of the global area. Use ; ! 0 as the value if the entire file is to be ; ! loaded. -1 is reserved to be used as the ; ! subroutine indicator. ; Char Constant ! mode and space to map into ; ! {'UI'|'UD'|'SI'|'SD'|'CI'|'CD'} ; Char Constant ! access to mapped area (default writable) ; ! {'ReadOnly'|'Writable'} ; Char Constant ! cache bypass status ; ! '[No]Bypass' bypass caching hardware ; ! (default no bypass) ; ; NOTE: any required handler must be loaded or prefetched, MGETR ; will not fetch any handlers. ; ; Outputs: ; ;0 Success ; ;-1 Invalid ADDR alignment (detected by MGETR) ; ;-2 No WDB for .CRAW (-.CRAW) ;-3 Any .CRAW error except No WDB (-2) ; ;-4 EOF on .READW (-.READW-4) ;-5 I/O Error on .READW (-.READW-4) ;-6 Channel closed when .READW attempted (-.READW-4) ;-6 No Chan available from IGETC ; ;-7 No RCB for .CRRG (-.CRRG) ;-8 Insufficient memory for .CRRG (-.CRRG) ;-9 0 Size create (will be reported as Region not found, -11) ;-10 Memory too fragmented to return at .ELRG (-.ELRG) ;-11 Global region not found (and no non-zero SIZE specified) (-.CRRG) ;-12 No GRCB for .CRRG (-.CRRG) ;-13 Global region already exists at a different base address ;-14 Global Region private (Not reported, MGETR hangs in a loop) ; ;-15 .LOOKUP found channel already open (-.LOOKUP-15) ;-16 .LOOKUP could not find requested file (-.LOOKUP-15) ;-17 .LOOKUP found device in use and not sharable (-.LOOKUP-15) ; ;-18 Any .ELRG error except Mem Frag (-10) ; ;-19 First char of TYPE invalid (Not "P", "S", "A", or "L") ; String supplied for MODES invalid ;-20 Required argument is missing (IWORK, WRKSIZ, ITYPE, NAME, or ADDR) ;-21 Work area too small ; JFW 27-Dec-84 ;- .PSECT SYS$I,I .GLOBL $SYSLB ;Display library version number .GLOBL $NXADR $NXVAL ;Routines to access arguments .GLOBL $ERRM0 ;Routine to return error codes .GLOBL CALL$F ;Routine to call FORTRAN calling ; conventions while saving registers .GLOBL IGETC IFREEC ;Routines to allocate/free channel .MCALL .CKXX .ASSUME .BR ;Assumption checking macros .CKXX .MCALL .RDBDF ;Define names in RDB block .MCALL .WDBDF ;Define names in WDB block .MCALL .CRRG .TWAIT .CRAW .MCALL .LOOKUP .READC .ELRG .MCALL .CLOSE .RDBDF .WDBDF .LIBRARY "SRC:SYSTEM" .MCALL ..READ ..READ e=<=:> F.ARGS =: -2 ;offset from parm base to parm count F.PMTR = 2 ;offset from R5 to parm base NOARG =: -1 ;value of omitted addr PWORK =: 0 ;Work area PWKSIZ =: 2 ;Work area size ;MGTR$W is minimum size PTYPE =: 4 ;Access type TYPEA =: 'A ;Age TYPEL =: 'L ;Local TYPEP =: 'P ;Private TYPES =: 'S ;Shared PNAME =: 6 ;2 words of RAD50 region name PADDR =: 10 ;Virtual address to map it into PMADDR =: 12 ;Physical address to map it into PCSIZE =: 14 ;Creation SIZE in words PMSIZE =: 16 ;Mapping size in words POFFST =: 20 ;Offset value in chunks PINIT =: 22 ;ICHAN/IFILE/SBRTN address PIBLK =: 24 ;Block offset in file ISSBRTN =: -1 ;Subroutine indicator PMODES =: 26 ;Mode and space to map MODEU =: 'U ;User mode MODES =: 'S ;Supy mode MODEC =: 'C ;Current MODEI =: 'I ;I space MODED =: 'D ;D space PRW =: 30 ;R/O or R/W READON =: 'R ;ReadOnly READWR =: 'W ;Writable PCACHE =: 32 ;Cache [no]bypass CACBYP =: 'B ;Bypass CACNOB =: 'N ;NoBypass ;SYSCOM REFERENCES ERRBYT =: 52 ;EMT error byte ;ERROR VALUES SUCCES =: 0 ;Successful completion ILADDR =: -1. ;ADDR not on PAR boundary ERWDB =:1 ; -2. ;No WDB for .CRAW ILCRAW =: -3. ;.CRAW error other than 1 ERREAD =:4 ; -4. ;.READW EOF ; -5. ;.READW I/O error ; -6. ;.READW Channel closed ILCHAN =: -6. ;No channel available from IGETC ERRCB =:6 ; -7. ;.CRRG no RCB available ERMEM =:7 ; -8. ;.CRRG insufficient memory ERSIZ =:10; -9. ;.CRRG invalid region size ERFRAG =:11 ; -10. ;.ELRG memory too fragmented to return ERGRNF =:12 ; -11. ;.CRRG Global region not found ; (and ISIZE specfied as 0) ERGRCB =:13 ; -12. ;.CRRG no GRCB available ; -13. ;Global region exists at different base addr ERPRIV =:15 ; ;.CRRG Region exists, but is private (loop) ERBASE =:16 ; -14. ;.CRRG Global region exists at other addr ;NOTE: ERBASE value adjusted to -14. return ERLOOK =:17 ; -15. ;.LOOKUP channel in use ; -16. ;.LOOKUP file not found ; -17. ;.LOOKUP device in use and not sharable ILELRG =:22 ; -18. ;.ELRG error other than 11 ILTYPE =: -19. ;Unknown TYPE letter ILLARG =: -20. ;Missing required Argument ILLSIZ =: -21. ;Work area too small ; WORK AREA LAYOUT W.GID =: R.GID ;Id word in RDB W.GSIZ =: R.GSIZ ;Region size word in RDB W.GSTS =: R.GSTS ;Status word in RDB W.GNAM =: R.GNAM ;Region name (2 RAD50 words) in RDB W.GBAS =: R.GBAS ;Region chunk address in RDB W.SP =: R.GLGH ;Saved SP in work area W.CHAN =: W.SP+2 ;Channel number in use W.RMOD =: W.CHAN+2 ;Mapping to use for .READ W.R4 =: W.RMOD+2 ;Saved R4 value for redoing CRRG W.R5 =: W.R4+2 ;Saved R5 value for redoing CRRG W.WMOD =: W.R5+2 ;save status bits for .CRAW PAD =: 4*2 ;pad area with 4 words for future W.LENG =: W.WMOD+PAD ;Size, in bytes, of work area MGTR$W ==: W.LENG/2 ;Global def of number of words in work area ; Stack alignment control S.RET =: 1000 ;Stack value at entry (1000 used to ;prevent confusion with arg offsets) NEXADR =: 1234 ;test value for $NXADR in reg PAR2T =: 160000 ;Valid PAR PART (PAR**2T) of an address ;used to check for proper alignment CHUNK =: 100 ;Size of memory management unit bytes/chunk UCASE =: 040 ;Bit to clear to uppercase a letter .CRAW =: 36*400+2 ;CRAW request code .CRRG =: 36*400+0 ;CRRG request code .ELRG =: 36*400+1 ;ELRG request code .LOOKUP =: 1*400+0 ;LOOKUP request code .TWAIT =: 24*400+0 ;TWAIT request code ;The following bit definition must not clash with RS.* bits SHARE =: 1 ;Indicate sharing request DOELRG =: 2 ;Indicate ELRG on error DOFREC =: 4 ;Indicate IFREEC on error DOCLOS =: 10 ;Indicate CLOSE on error LOCALX =: SHARE!DOELRG!DOFREC!DOCLOS RDBBIT = RS.CRR!RS.UNM!RS.NAL!RS.NEW!RS.GBL!RS.CGR!RS.AGE!RS.EGR!RS.EXI RDBBIT = RDBBIT!RS.CAC!RS.BAS!RS.NSM .ASSUME LOCALX&RDBBIT EQ 0 DOILAG: MOV #ILLARG,R0 ;Load error code BR ERROR1 DOILSZ: MOV #ILLSIZ,R0 ;Load error code BR ERROR1 DOILMO: MOV W.SP(R3),SP ;Restore stack .BR DOILTY ;Issue error DOILTY: MOV #ILTYPE,R0 ;Load error code BR ERROR1 DOILAD: MOV #ILADDR,R0 ;Load error code ERROR1: JMP ERROR .SBTTL Get all the arguments .ENABLE LSB CK.R5=F.ARGS CK.SP=S.RET MGETR:: MOV #$NXADR,R1 ;Point to subroutine CK.R1=NEXADR CK.R5 F.ARGS,+2 MOV (R5)+,R4 ;Get count, point to first arg CK.R5 PWORK,+2 CK.R1 NEXADR CALL @R1 ;Point to work area CK.R0=W.GID BCS DOILAG ;Required argument missing MOV R0,R3 ;Save work area pointer CK.R3=CK.R0 CK.R5 PWKSIZ,+2 CK.R1 NEXADR CALL @R1 ;WRKSIZ BCS DOILAG ;Required argument missing CMP #MGTR$W,@R0 ;Is it big enough? BHI DOILSZ ;No, then quit CK.R3 W.GID CLR W.RMOD(R3) ;Initialize mapping info CLR R2 ;Assume nothing CK.R5 PTYPE,+2 CK.R1 NEXADR CALL @R1 ;Point to type letter BCS DOILAG ;Required argument missing MOVB @R0,R0 ;Load the first byte BIC #UCASE,R0 ;Force uppercase CK.R3 W.GID MOV SP,W.SP(R3) ;Save SP for error recovery .BR 10$ 10$: CMPB #TYPEA,R0 ;Is it "Age"? BNE 20$ ;No BIS #,R2 ;Indicate global, aging, and share 20$: CMPB #TYPEP,R0 ;Is it "Private"? BNE 30$ ;No BIS #RS.GBL,R2 ;Indicate global 30$: CMPB #TYPES,R0 ;Is it "Share"? BNE 40$ ;No BIS #,R2 ;Yes, indicate sharing 40$: CMPB #TYPEL,R0 ;Is it "Local"? BNE 50$ ;No CK.R1 NEXADR CK.R5A=CK.R5 CK.R5A PNAME,+2 CALL @R1 ;skip NAME argument BR 60$ ;join common code 50$: TST R2 ;Any bits set? CK.SP S.RET BEQ DOILTY ;No, unknown TYPE specified CK.R5 PNAME,+2 CK.R1 NEXADR CALL @R1 ;Point to region name CK.SP S.RET BCS DOILAG ;Required argument missing CK.R3 W.GID MOV (R0)+,W.GNAM(R3) ;Put in name area CK.R3 W.GID MOV @R0,W.GNAM+2(R3) ; ... 60$: CK.R5 CK.R5A CK.R1 NEXADR CK.R5 PADDR,+2 CALL @R1 ;Get address CK.SP S.RET BCS DOILAG ;Required argument missing BIT #^cPAR2T,R0 ;Is it aligned on a PAR boundary? CK.SP S.RET BNE DOILAD ;No, invalid address MOV R0,R1 ;Save the address in R1 CK.R1=152525;not NEXADR CK.R5 PMADDR,+2 CALL $NXVAL ;Get chunk address BCS 70$ ;Not supplied CK.R3 W.GID MOV R0,W.GBAS(R3) ;Put in request block BIS #RS.BAS,R2 ;Indicate it's there 70$: CLR R0 ;Assume no size, default to 0 CK.R5 PCSIZE,+2 CALL $NXVAL ;Get area size value CALL RCHUNK ;Round and change to chunks CK.R3 W.GID MOV R0,W.GSIZ(R3) ;Put in RDB .BR 80$ ;R1=ADDR, R2=RDB_status, R3=WORK, R4=arg_count, R5=arg_pointer .SBTTL Create/attach to the region 80$: .ENABLE LSB ; ;Cond Code set by prev MOV BEQ 10$ ;No size specified BIS #RS.CGR,R2 ;Size given, allow creation 10$: CK.R3 W.GID MOV R5,W.R5(R3) ;Save R5 CK.R3 W.GID MOV R4,W.R4(R3) ;Save R4 CK.SP ,-2,S.NSTS ADD #,R5 ;Point to MODES argument SUB #/2,R4 ;Adjust arg count MOV #WS.MAP,-(SP) ;W.NSTS = map it, too CALL $NXADR ;Get it BCS 40$ ;Omitted CK.SP ,-2,S.CTMP MOVB (R0)+,-(SP) ;Get the first char CK.SP S.CTMP MOVB @R0,1(SP) ;And the second one, too CK.SP S.CTMP,+2 MOV (SP)+,R0 ;Load back into register BIC #UCASE*400+UCASE,R0 ;Force both upper case CMPB #MODEU,R0 ;Is it User mode? .Assume WS.U EQ 0 BEQ 20$ ;Yes .Assume WS.S EQ WS.U+1 .Assume WS.C EQ WS.U+2 CK.SP S.NSTS INC @SP ; CMPB #MODES,R0 ;Is it Supy mode? BEQ 20$ ;Yes .Assume WS.C EQ WS.S+1 CK.SP S.NSTS INC @SP ; CMPB #MODEC,R0 ;Is it Current mode? BNE DOILMO ;Unknown letter 20$: SWAB R0 ;get other character to test CK.SP S.NSTS BIS #WS.I,@SP ;Assume I space CMPB #MODEI,R0 ;was it? BEQ 30$ ;yes CK.SP S.NSTS ADD #WS.D-WS.I,@SP ;then it must be D space CMPB #MODED,R0 ;was it? DOILM1: BNE DOILMO ;Unknown letter .BR 30$ 30$: CK.SP S.NSTS CK.SP ,-2,S.ATMP MOV @SP,-(SP) ;Replicate mapping bits CK.SP S.ATMP ASL @SP ;Shift up 2 bit positions CK.SP S.ATMP ASL @SP ; ... RMOD.M = <..USER!..SUPY!..CURR!..DSPA!..ISPA> CK.SP S.ATMP BIC #^cRMOD.M,@SP ;Clear unused bits .Assume <..USER!..DSPA> eq <<*4>&RMOD.M> .Assume <..USER!..ISPA> eq <<*4>&RMOD.M> .Assume <..SUPY!..DSPA> eq <<*4>&RMOD.M> .Assume <..SUPY!..ISPA> eq <<*4>&RMOD.M> .Assume <..CURR!..DSPA> eq <<*4>&RMOD.M> .Assume <..CURR!..ISPA> eq <<*4>&RMOD.M> CK.SP S.ATMP BIS #..EMIO,@SP ;Force bottom two bits on to indicate mapping CK.SP S.ATMP,+2 CK.R3 W.GID MOV (SP)+,W.RMOD(R3) ;Save for possible read request 40$: CALL $NXADR ;Get RW argument address BCS 50$ ;Omitted MOVB @R0,R0 ;Get the first letter BIC #UCASE,R0 ;Force upper case CMPB #READWR,R0 ;Writeable? BEQ 50$ ;Yes, leave default setting CMPB #READON,R0 ;ReadOnly? BNE DOILM1 ;No, then unknown letter CK.SP S.NSTS BIS #WS.RO,@SP ;Else set ReadOnly bit 50$: CLR R0 ;If skipped, ignore it CALL $NXADR ;Get RW argument address BCS 60$ ;Omitted MOVB @R0,R0 ;Get the first letter BIC #UCASE,R0 ;Force upper case CMPB #CACNOB,R0 ;NOBYPASS? BEQ 60$ ;Yes, leave default setting CMPB #CACBYP,R0 ;BYPASS? BNE DOILM1 ;No, then unknown letter BIS #RS.CAC,R2 ;Else set ReadOnly bit 60$: CK.SP S.NSTS,+2 CK.R3 W.GID MOV (SP)+,W.WMOD(R3) ;and status bits .BR 70$ 70$: MOV R2,R0 ;Copy bits BIC #^cRDBBIT,R0 ;Save only RDB status bits CK.R3 W.GID MOV R0,W.GSTS(R3) ;Put status bits in request RDB CRRG: S.ACRR=CK.SP CK.R3 W.GID CK.SP ,-2,S.RDB MOV R3,-(SP) ;Put addr of RDB on stack CK.SP ,-2,S.CREQ MOV #.CRRG,-(SP) ;Put request code on stack 80$: CK.SP S.CREQ .ASSUME S.CREQ+2 EQ S.RDB .CRRG SP,CODE=NOSET ;Try to create/attach to region BCC MAP ;No error CMPB #ERPRIV,@#ERRBYT ;Region private, but exists? BEQ 90$ ;Yes, wait for it CMP #ERBASE,@#ERRBYT ;bad physical address? BNE DOERRB ;No, bad error DECB @#ERRBYT ;yes, return as -13. error code BR DOERRB ;... .SBTTL Region is currently 'Private', wait and retry 90$: S.ATIM=CK.SP CK.SP ,-2,S.TIME MOV #TIME,-(SP) ;Put addr of ticks on stack CK.SP ,-2,S.TREQ MOV #.TWAIT,-(SP) ;put request code on stack CK.SP S.TREQ .ASSUME S.TREQ+2 EQ S.TIME .TWAIT SP,CODE=NOSET ;Bide a wee ; BCS ;Ignore errors CK.SP ,+2+2 CMP (SP)+,(SP)+ ;Remove .TWAIT request from stack CK.SP S.ATIM BR 80$ ;try to attach again CK.SP S.CREQ .SBTTL Error processing and exit DOERRB: SEC ;Insure carry is set CALL $ERRM0 ;Use standard EMT error routine BR FIXSP DONE: CLR R0 ;SUCCESS! FIXSP: CK.R3 W.GID MOV W.SP(R3),SP ;Clean up stack (really!!) MOV R0,-(SP) ;Save return value CALL WRAPUP ;Do possible cleanup stuff MOV (SP)+,R0 ;Return it ERROR: RETURN .SBTTL Create window and map to region .ENABLE LSB MAP: CK.R3 W.GID MOV W.R4(R3),R4 ;Restore R4 CK.R3 W.GID MOV W.R5(R3),R5 ;Restore R5 CK.SP ,+2+2 CK.SP S.ACRR CMP (SP)+,(SP)+ ;Remove .CRRG request from stack S.ACRA=CK.SP CK.R3 W.GID CK.SP ,-2,S.NSTS MOV W.WMOD(R3),-(SP) ;Set the status bit word CLR R0 ;Default MSIZE to 0 CK.R5 PMSIZE,+2 CALL $NXVAL ;Pick up possible Mapping SIZE CALL RCHUNK ;Round and change to chunks CK.SP ,-2,S.NLEN MOV R0,-(SP) ;Put MSIZE onto the stack ;Compute the Offset value CLR R0 ;Default offset is 0 CK.R5 POFFST,+2 CALL $NXVAL ;Pick up possible Offset value in chunks CK.SP ,-2,S.NOFF MOV R0,-(SP) ;W.NOFF = OFFSET in chunks CK.R3 W.GID CK.SP ,-2,S.NRID MOV @R3,-(SP) ;W.NRID = W.GID CK.SP S.NRID CK.SP ,-2,S.NSIZ MOV S.NLEN-S.NRID(SP),-(SP) ;Check for MSIZE = 0 BNE 10$ ;Leave non-zero MSIZE alone CK.R3 W.GID SUB W.GSIZ(R3),R0 ;Calculate (region_size-OFFSET) to NEG R0 ; get remainder of region size ;.CRAW will catch bad offset value CK.SP S.NSIZ MOV R0,@SP ;Use remainder of region size as MSIZE MOV R1,R0 ;Get base address of window ASH #-6,R0 ;Convert to chunk offset BIC #^c1777,R0 ; into virtual address space SUB #2000,R0 ;Calculate largest amount of NEG R0 ; address space possible to map CK.SP S.NSIZ CMP R0,@SP ;Is MSIZE too big? BHIS 10$ ;Branch if not CK.SP S.NSIZ MOV R0,@SP ;Set MSIZE to largest possible to map 10$: CK.SP S.NSIZ MOV @SP,S.NLEN-S.NSIZ(SP) ;Copy adjusted MSIZE from W.NSIZ ; to W.NLEN in WDB CK.SP ,-2,S.NBAS MOV R1,-(SP) ;Copy par addr into W.NBAS MOV R1,R0 ;Copy for manipulation ASH #-5,R0 ;Convert address to PAR number in high byte BIC #^c7*400,R0 ;Clear any sign extend CK.SP ,-2,S.NID MOV R0,-(SP) ;W.NAPR = PAR num (high byte) S.NAPR=CK.SP+1 S.WDB=CK.SP ; Following instruction is different on different processors ; it is replaced by the next two instructions ; MOV SP,-(SP) ;Put addr of WDB on stack MOV SP,R0 ;Save addr of WDB in R0 CK.R0=S.WDB CK.SP ,-2,S.AWDB MOV R0,-(SP) ;Put addr in request block on stack CK.SP ,-2,S.CREQ MOV #.CRAW,-(SP) ;Put request code on stack .BR 20$ 20$: .ENABLE LSB CK.SP S.CREQ .ASSUME S.CREQ+2 EQ S.AWDB .ASSUME S.WDB EQ S.NID .ASSUME S.NID+1 EQ S.NAPR .ASSUME S.NAPR+1 EQ S.NBAS .ASSUME S.NBAS+2 EQ S.NSIZ .ASSUME S.NSIZ+2 EQ S.NRID .ASSUME S.NRID+2 EQ S.NOFF .ASSUME S.NOFF+2 EQ S.NLEN .ASSUME S.NLEN+2 EQ S.NSTS .CRAW SP,CODE=NOSET ;Create a window and map to it BCC 10$ ;No error CMPB @#ERRBYT,#ERWDB ;Was it no WDB? D1ERRB: BEQ DOERRB ;Yes, return negative of code MOV #ILCRAW,R0 ;Load generic .CRAW error code FIXSP1: BR FIXSP ;Return fixed error code DOERRI: MOVB @#ERRBYT,R4 ;Get Error byte value BMI DOERRB ;SERR code ADD R4,R0 ;Add in offset NEG R0 ;make error code negative BR FIXSP ;return the value DONOCH: MOV #ILCHAN,R0 ;Load error code BR FIXSP 10$: MOV S.NLEN-CK.SP(SP),R0 ;Get actual size mapped ASH #+5,R0 ;Change count from chunks to words ADD #,SP ;Clean up stack CK.SP ,+ CK.SP S.ACRA CK.SP ,-2,S.MWSZ MOV R0,-(SP) ;And save it on the stack for later .SBTTL See if we need to init it, and if so how CK.R3 W.GID BIT #RS.NEW,W.GSTS(R3) ;Did we just create the region? DONE1: BEQ DONE ;No, no need to init (or share) CK.SP ,-2,S.PADD MOV R1,-(SP) ;Put ADDR on stack CK.R5 PINIT,+2 CALL $NXADR ;Get address of ICHAN/IFILE/SUBRN BCS ELLOOP ;No address, no need to init ; (but we might have to share) BIS #DOELRG,R2 ;Indicate .ELRG required on error MOV R0,R1 ;Copy given address to R1 CLR R0 ;Assume no IBLK CK.R5 PIBLK,+2 CALL $NXVAL ;Get Value of IBLK MOV R0,R4 ;Copy given value ;R1=ICHAN/IFILE/SUBRN, R2=ITYPE, R3=WORK, R4=IBLK, @SP=ADDR, 2(SP)=ISIZE CMP #ISSBRTN,R4 ;Is this a subroutine to call? S.ZSUB=CK.SP BEQ INISUB ;Yes, do it CMP #255.,@R1 ;It it a channel number? BLO INICHN ;no, go get one MOV @R1,R1 ;get value instead of address BR INIRD ;yes, no need to open it .SBTTL Setup for .LOOKUP (and call IGETC) .ENABLE LSB INICHN: S.ALOO=CK.SP CK.SP ,-2,S.SEQN S.ZERO=CK.SP CLR -(SP) ;No Args for IGETC AND SEQNUM = 0 MOV SP,R5 ;Point to 0 CK.R5=CK.SP CK.SP ,-2,S.DBLK MOV R1,-(SP) ;DBLK = IFILE CK.SP ,-2,S.LREQ MOV #.LOOKUP,-(SP) ;Put request code on stack MOV #IGETC,R0 ;Call IGETC CK.R5=S.ZERO CALL CALL$F ;Call a FORTRAN subroutine MOV R0,R1 ;Copy channel number allocated BMI DONOCH ;None available BIS #DOFREC,R2 ;Set flag in TYPE reg to indicate IFREEC CK.SP S.LREQ MOVB R1,@SP ;Put in channel number CK.R3 W.GID MOVB R1,W.CHAN(R3) ;And save it for error exits CK.SP S.LREQ .ASSUME S.LREQ+2 EQ S.DBLK .ASSUME S.DBLK+2 EQ S.SEQN .LOOKUP SP,CODE=NOSET ;Lookup the file MOV #ERLOOK,R0 ;*C*Load offset value DOERR1: BCS DOERRI ;Add in offset, then standard error stuff BIS #DOCLOS,R2 ;Set flag in TYPE reg to indicate close ADD #,SP ;Clean stack CK.SP ,+ CK.SP S.ALOO .BR INIRD .SBTTL Read in data from open channel .ENABLE LSB ;+ ; It is possible to create a window that is 32KW long in supervisor mode. ; Unfortunately, it is not possible to read 32KW from a file with one ; read, since the maximum word size for .READx is one word less than this. ; Accordingly, INIRD detects this case and breaks the read up into two ; reads, each of which is 16KW long. ;- INIRD: S.AREA=CK.SP CK.SP ,-2,S.SRTN CLR -(SP) ;SRTN = 0 (.READW) CK.SP ,-2,S.FUNC MOV W.RMOD(R3),-(SP) ;Mapping (or zero) CLR R5 ;Assume one read suffices and clear carry CK.SP S.FUNC CK.SP ,-2,S.WCNT MOV S.MWSZ-S.FUNC(SP),-(SP) ;*C*WCNT = mapped size (in words) BPL 10$ ;*C*Branch if one read suffices CK.SP S.WCNT MOV @SP,R5 ;*C*Byte count of halved word count ROR @SP ;Halve the WCNT (will always be 40000) 10$: CK.SP S.WCNT CK.SP ,-2,S.BUF MOV S.PADD-S.WCNT(SP),-(SP) ;BUF = ADDR CK.SP ,-2,S.BLK MOV R4,-(SP) ;BLK = IBLK CK.SP ,-2,S.RREQ MOV #.READ*400,-(SP) ;request code to stack CK.SP S.RREQ MOVB R1,@SP ;Put in channel number CK.R3 W.GID MOVB R1,W.CHAN(R3) ;And save it for error exits 20$: CK.SP S.RREQ .ASSUME S.RREQ+2 EQ S.BLK .ASSUME S.BLK+2 EQ S.BUF .ASSUME S.BUF+2 EQ S.WCNT .ASSUME S.WCNT+2 EQ S.FUNC .ASSUME S.FUNC+2 EQ S.SRTN .READC SP,CODE=NOSET ;Read into the region MOV #ERREAD,R0 ;*C*Load offset value BCS DOERR1 ;Error TST R5 ;Any more reading left to do? BEQ 30$ ;Branch if not CK.SP S.RREQ ADD R5,S.BUF-S.RREQ(SP) ;Advance buffer for next read CK.SP S.RREQ ADD #100,S.BLK-S.RREQ(SP) ;Advance to starting blk for next buffer CLR R5 ;Indicate no more reads BR 20$ ;Go do another read 30$: ADD #,SP ;Clean stack CK.SP ,+ CK.SP S.AREA .BR ELLOOP ;Check for sharing .SBTTL Check for sharing, if so .ELRG, and begin again .ENABLE LSB ELLOOP: CK.SP S.PADD,+2 MOV (SP)+,R1 ;Restore ADDR CK.SP S.MWSZ,+2 TST (SP)+ ;Dump actual mapped size CK.SP S.ACRR BIC #DOELRG,R2 ;Indicate .ELRG not required on error CK.R3 W.GID BIT #RS.NEW,W.GSTS(R3) ;Did we just create the region? BEQ DONE1 ;No, then nothing special for sharing it BIT #SHARE,R2 ;Are we sharing? BEQ DONE1 ;No, then nothing special to do CALL ELRG ;Eliminate the region BCC 10$ ;No error CMPB @#ERRBYT,#ERFRAG ;Was it too fragmented to return memory? BEQ D1ERRB ;Yes, return negative of code MOV #ILELRG,R0 ;Load generic .ELRG error code BR FIXSP1 ;Return generic .ELRG error 10$: JMP CRRG ;Try creation loop again .SBTTL Call the user's routine to init the area .ENABLE LSB CK.SP=S.ZSUB INISUB: CK.SP ,-2,S.TWO MOV SP,R5 ;Store pointers to the pushed parameters ;for the fortran subroutine. TST (R5)+ ;Move pointer to second parameter value. MOV R5,-(SP) ;Push pointer to second parameter TST -(R5) ;Move pointer to first parameter value. MOV R5,-(SP) ;Push pointer to first parameter. MOV #2,-(SP) ;Push Arg count. MOV SP,R5 ;Point to arg list CK.R5=CK.SP MOV R1,R0 ;Point to user's routine CK.R5 S.TWO .ASSUME S.TWO+2 EQ S.PADD .ASSUME S.PADD+2 EQ S.MWSZ CALL CALL$F ;Call it CK.SP ,+2 TST (SP)+ ;Clean up the stack CMP (SP)+,(SP)+ CK.SP S.ZSUB BR ELLOOP ;Check for sharing .SBTTL WRAPUP routine ;+ ; WRAPUP clean up on exit or some errors ; ; input: ; ; R2 = flag word ; R3 = pointer to work ; ; output: ; ; R0, R1, and R5 destroyed ;- .ENABLE LSB WRAPUP: BIT #DOELRG,R2 ;ELRG needed? BEQ 10$ ;No CK.R3 W.GID BIS #RS.EGR,R.GSTS(R3) ;Yes, do a global eliminate CALL ELRG ;Eliminate the region ; BCS ;Ignore errors on wrapup 10$: CK.R3 W.GID MOVB W.CHAN(R3),R1 ;Get channel number BIT #DOCLOS,R2 ;Do a close? BEQ 20$ ;No .CLOSE R1 ;Close the channel ; BCS ;Ignore errors 20$: BIT #DOFREC,R2 ;Do a IFREEC? BEQ 40$ ;No S.AFRE=CK.SP CK.SP ,-2,S.CHAN MOV R1,-(SP) ;Put channel number on stack MOV SP,R1 ;Push a pointer to the value onto the stack. MOV R1,-(SP) ;MOV SP,-(SP) CK.R1=CK.SP CK.R1 S.CHAN CK.SP ,-2,S.ACHN CK.SP ,-2,S.ONE MOV #1,-(SP) ;Indicate a single arg MOV SP,R5 ;Point to arg list CK.R5=CK.SP MOV #IFREEC,R0 ;Point to routine to call CK.R5 S.ONE .ASSUME S.ONE+2 EQ S.ACHN CALL CALL$F ;Call it CK.SP ,+2 TST (SP)+ ;realign stack ; TST R0 ;Ignore errors ; BMI ;... BR 30$ ;Pop 2 words and return CK.SP S.AFRE-2-2 .SBTTL ELRG -- eliminate region routine ;+ ; ELRG eliminate region ; ; input: ; ; R2 = flag word ; R3 = pointer to work ; ; output: ; ; R0, R1, and R5 destroyed ; R2 = flag word (with DOELRG cleared) ;- ELRG: S.AELR=CK.SP CK.SP ,-2,S.RDB CK.R3 W.GID MOV R3,-(SP) ;Put RDB addr on stack CK.SP ,-2,S.EREQ MOV #.ELRG,-(SP) ;Put request code on stack CK.SP S.EREQ .ASSUME S.EREQ+2 EQ S.RDB .ELRG SP,CODE=NOSET ;Do a local eliminate BIC #DOELRG,R2 ;*C*Indicate ELRG not needed??? 30$: CK.SP ,+2+2 BIT (SP)+,(SP)+ ;*C*Clean stack 40$: RETURN ;+ ; RCHUNK round up word size to next chunk size ; ; input: ; ; R0 = size in words ; ; output: ; ; R0 = size in chunks ;- .ENABLE LSB RCHUNK: ADD #CHUNK/2-1,R0 ;Round size up to nearest chunk ROR R0 ;Get carry into R0 and finish ASH #-4,R0 ; converting from word count to chunk count BIC #^c7777,R0 ;Clear any sign extend RETURN .PSECT SYS$S,D TIME: .WORD 0,5 ;Wait 5 ticks .END