!Modified 13/ 4/82 15.30 !**********************************************************************! !**********************************************************************! ! ! ! ! ! This Module is designed to provide I/0 support ! ! ! ! for OPEN CLOSE INQUIRE ! ! ! ! and REWIND ENDFILE BACKSPACE statements ! ! ! ! for FORTRAN77 Programs ! ! ! ! on ICL PERQ Machines ! ! ! ! ! !**********************************************************************! !**********************************************************************! !-----Module History-----! ! ! ! ! ! FIO7701Q --------first version (numerous restrictions) ! (derived from FIO7731N) ! ! FIO7731N ---conversion to IMP80 ! ! FIO7730N -----includes reps to B70 release !Conditional Compilation Variables: ! %CONSTINTEGER EMAS= 0 %CONSTINTEGER PERQ= 1 ! {********************} %CONSTINTEGER SYSTEM=PERQ {********************} ! ! %CONSTINTEGER CURRENT= 0 %CONSTINTEGER FUTURE= 1 ! {********************} %CONSTINTEGER RELEASE=CURRENT {*****************} %CONSTHALFINTEGER FALSE= 0 %CONSTHALFINTEGER TRUE = 1 !*********************************************************************** ! ! RECORD FORMATS ! !*********************************************************************** ! %RECORDFORMAT FILE DEFINITION TABLE ( %C %C %INTEGER LINK , BACK , %INTEGER DSNUM , %BYTEINTEGER STATUS , CUR STATE , %BYTEINTEGER VALID ACTION , Spare1 , %BYTEINTEGER MODE OF USE , ACCESS TYPE , %HALFINTEGER EXISTENCE , ACCESS ROUTE , %HALFINTEGER RECORD TYPE , %HALFINTEGER RECORD LEN , {of the current record} %HALFINTEGER RECSIZE , %HALFINTEGER MINREC , %HALFINTEGER MAXREC , %INTEGER DA RECNUM , %INTEGER LINES IN , %INTEGER LINES OUT , %HALFINTEGER FILE ID , %HALFINTEGER SCRATCH ID , %HALFINTEGER LAST BLK , MAX BLK , %HALFINTEGER BLK , {the current one} %HALFINTEGER POS , {and position within it} %HALFINTEGER REC POS , %HALFINTEGER UFD , %HALFINTEGER F77BLANK , %HALFINTEGER F77RECL , %HALFINTEGER FLAGS , %INTEGER ID ADDR ) ! ! %C Values That May Be Set in a File Definition Table: ! ! %CONSTINTEGER F77 DEFINED = X'48'; ! Bit Values %CONSTINTEGER FORMATTED BIT = X'01'; ! of the %CONSTINTEGER FREEFMT BIT = X'02'; ! F77UFD field %CONSTINTEGER FMTED FILE BITS= X'49'; !and byte values %CONSTINTEGER FREEFMT FILE BITS= X'4B'; ! of the field %RECORDFORMAT FORM OF AN INTERNAL FILE DESC{ription} ( %C %C %INTEGER ADDRESS {of first word} , %HALFINTEGER INC{rement to 1st char from ADDRESS}, %HALFINTEGER LENGTH {of each element} , %INTEGER COUNT {of number of elements} ) %RECORDFORMAT FORM OF A CHARACTER DESC{ription} ( %C %C %INTEGER ADDRESS , %HALFINTEGER INC{rement from ADDRESS} , %HALFINTEGER LENGTH ) %RECORDFORMAT FORM OF A PARAMETER PAIR ( %C %C %HALFINTEGER Word 1 %C %OR %BYTEINTEGER I2 FLAG , ID{entifier}, %C ( %INTEGER INTEGER VALUE {if OPEN or CLOSE} %C %OR %INTEGER INTEGER ADDRESS {if INQUIRE only } %C %C %OR %RECORD (Form of a CHARACTER Desc) %NAME C )) %RECORDFORMAT FORM OF A PARAMETER PAIR LIST ( %C %C %HALFINTEGER Word 1 %C %OR %BYTEINTEGER I2 FLAG , ID{entifier}, %C ( %INTEGER INTEGER VALUE {if OPEN or CLOSE} %C %OR %INTEGER INTEGER ADDRESS {if INQUIRE only } %C %C %OR %RECORD (Form of a CHARACTER Desc) %NAME C ), %C %RECORD (Form of a Parameter Pair) NEXT PP PAIR ) %RECORDFORMAT TRANSFER CONTROL TABLE ( %C %C %INTEGER DSNUM , %INTEGER REC NUMBER , %HALFINTEGER COROUTINE INDEX , %HALFINTEGER IOSTAT VALUE , %INTEGER IOSTAT ADDRESS {used only by user code} , %INTEGER FORMAT ADDRESS , %HALFINTEGER FORMAT INC{rement} , %HALFINTEGER FORMAT LENGTH , %RECORD (Form of an Internal File Desc{ription}) %C INTERNAL FILE DESC , %RECORD (Form of a Parameter Pair) %ARRAY PPs(0:17) ) ! !*********************************************************************** ! ! GLOBAL PROCEDURE SPECIFICATIONS ! !*********************************************************************** ! %HALFINTEGERFNSPEC F77 IOF %C (%RECORD (Transfer Control Table) %NAME TCT , %HALFINTEGER KEY , FORM , %HALFINTEGER IO MODE, FLAGS, MARKERS , %HALFINTEGERFN IO ITEM %C (%HALFINTEGER KEY , %INTEGER LEN TYPE ADR, %INTEGERNAME ADDRESS) ) %EXTERNALHALFINTEGERFN F77 IOF ( %C {! }%C {! }%C {! }%C {! }%C {! THIS PROCEDURE IS THE INTERFACE BETWEEN AN AUXILARY I/O }%C {! }%C {! STATEMENT IN THE USER PROGRAM AND THE UNDERLYING }%C {! }%C {! SYSTEM-DEPENDENT PROCEDURES OF THE FORTRAN77 }%C {! }%C {! RUN-TIME SYSTEM. }%C {! }%C {! }%C {! At Exit: RESULT= 1 if the END= label is to be used }%C {! RESULT= 2 if the ERR= label is to be used }%C {! RESULT= 0 otherwise }%C {! }%C {!-Parameters: }%C {! ! }%C {parm1} %RECORD (Transfer Control Table) %NAME TCT , {parm2} %HALFINTEGER KEY , {parm3} %HALFINTEGER FORM , {parm4} %HALFINTEGER IO MODE , {parm5} %HALFINTEGER FLAGS , {parm6} %HALFINTEGER SPECIFIER FLAGS , %C {parm7} %HALFINTEGERFN IO ITEM (%HALFINTEGER KEY , %INTEGER SIZE TYPE ADR, %INTEGERNAME ADDRESS ) ) !The Parameters have the following meanings: ! ! %C DSNUM the FORTRAN channel number, IO MODE classifies the I/O statement ! X'5x' if Internal File I/O, ! X'6x' if Sequential File I/O, ! X'7x' if Direct-Access File I/O {where x=1 if input } { or x=2 if output} !also X'04' if Rewind and X'20' if Open, X'08' if Backspace X'40' if Close, X'10' if Endfile X'80' if Inquire, !%C FORM classifies the processing required, as follows: %CONSTHALFINTEGERC UNFORMATTED IO = 0 , FORMAT IO = 1 , FORMAT IN ARRAY= 2 , LIST DIRECTED IO= 3 , REWIND = 7 , BACKSPACE = 7 , ENDFILE = 7 , OPEN CLOSE AND INQUIRE= 8 ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT) %EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C TRACEBACK) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL I/O ROUTINES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM , %HALFINTEGER ACTION, FILE TYPE, %INTEGERNAME FD TABLE ADDRESS) %EXTERNALHALFINTEGERFNSPEC F77OPEN (%INTEGER DSNUM , %HALFINTEGER STATUS, ACCESS, %HALFINTEGER FORM, BLANKS, %INTEGER RECL , %STRINGNAME FILE NAME ) %EXTERNALHALFINTEGERFNSPEC F77INQUIRE (%INTEGER DSNUM , %STRINGNAME FILE NAME , %INTEGER ADDR OF VALUES ) %EXTERNALHALFINTEGERFNSPEC F77CLOSE (%INTEGER DSNUM , %HALFINTEGER STATUS ) ! !*********************************************************************** ! ! SPECIFICATIONS FOR MAIN UTILITY ROUTINES ! !*********************************************************************** ! %HALFINTEGERFNSPEC OPEN (%INTEGER PPLIST ADDRESS) %HALFINTEGERFNSPEC CLOSE (%INTEGER PPLIST ADDRESS) %HALFINTEGERFNSPEC INQUIRE (%INTEGER PPLIST ADDRESS) %HALFINTEGERFNSPEC BYTE AT (%INTEGER ADR, %HALFINTEGER INC) %ROUTINESPEC PROPAGATE (%INTEGER LENGTH, %INTEGER BASE, %HALFINTEGER AT INC, WITH) %ROUTINESPEC COPY (%INTEGER LENGTH, %INTEGER FROM, %HALFINTEGER FROM DISP , %INTEGER TO , %HALFINTEGER TO DISP ) !*********************************************************************** ! ! ERROR MESSAGES ! !*********************************************************************** ! %CONSTHALFINTEGER UNASSIGNED VARIABLE = 401 %CONSTHALFINTEGER INVALID UNIT NUMBER = 164 %CONSTHALFINTEGER INVALID FILENAME = 128 %CONSTHALFINTEGER NO FILENAME GIVEN = 129 %CONSTHALFINTEGER ILLEGAL SPECIFIER VALUE = 127 %CONSTHALFINTEGER RECORD LENGTH MISSING = 130 %CONSTHALFINTEGER SPECIFIER NOT RECOGNISED = 125 %CONSTHALFINTEGER SPECIFIERS INCONSISTENT = 126 %CONSTHALFINTEGER BACKSPACE NOT ALLOWED = 195 !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER BLANK = ' ' %CONSTHALFINTEGER NULL = 0 %CONSTHALFINTEGER NONE = 0 %CONSTHALFINTEGER NOT SET = 0, SET = 1 %CONSTHALFINTEGER NOT USED= 0 %CONSTHALFINTEGER NOT REQD= 0, REQD= 1 %CONSTHALFINTEGER NIL = 0 %CONSTHALFINTEGER OFF = 0, ON = 1 %CONSTINTEGER UNDEFINED =-9 !Values taken by 'boolean' variables ! (ie. Integers used as flags) !*********************************************************************** ! ! GLOBAL VARIABLES ! !*********************************************************************** ! !Initialisation Criterion on PERQ is determined via: ! %OWNHALFINTEGER F77IO FLAG= FALSE {= TRUE if F77IO is initialised} %OWNHALFINTEGER RUN MODE; ! =-1 => Running in JOBBER mode ! = 0 => Running in STAND-ALONE mode but ! using Subsystem Diagnostics ! = 1 => Running in OPEH mode {Set At Initialisation} ! ! Variables defining the compilation options specified ! %HALFINTEGER CHECK %HALFINTEGER RELAX ANSI ! !the operating values of these variables is governed ! by the values within the Transfer Control Table ! {also} %HALFINTEGER CASE; !set LOWER if lower case input acceptable !set UPPER if only upper case is accepted %CONSTHALFINTEGER UPPER = 0 ;!%C LOWER\= 0 ! ! Variables Controlling Access to the File Definition Table ! %RECORD (File Definition Table) %NAME F %INTEGER AFD ;!%C address of the File Definition Table for BACKSPACE,REWIND,etc ! ! Auxilary I/O Statement Variables ! %OWNSTRING(1) UNASSIGNED SPECIFIER= ""; ! !Local representation of a Character specifier ! which is unassigned %INTEGER PPLIST ADDRESS ;!%C Address of the Parameter-Pairs List %C (if zero then there is none) ! ! Declarations of Variables Extracted from the Parameter list ! %INTEGER DSNUM ! ! Variables associated with Error Reporting ! %HALFINTEGER ERROR ; !the value to be assigned to the IOSTAT scalar %HALFINTEGER FAULT ; !the error that has been detected %SWITCH IO FORM (BACKSPACE {REWIND and ENDFILE}:OPEN CLOSE AND INQUIRE) %IF F77IO FLAG= FALSE %THENSTART; ! ! ! ! ! Initialise FIO Itself ! ! ! ! ! RUN MODE={COMREG (42)} 0 F77IO FLAG= TRUE; ! (for EMAS or PERQ) ! !----->END OF INTERNAL INITIALISATION ! %FINISH ! ! Analyse The Parameters ! CASE = FLAGS & 16 RELAX ANSI = FLAGS & 8 CHECK = FLAGS & 4 ! DSNUM = TCT_DSNUM -> IO FORM (FORM) ! ! ! %C IO FORM (BACKSPACE): %C IO FORM (ENDFILE): IO FORM (REWIND) : ! FAULT= NEW FILE OP (DSNUM,IOMODE,4,AFD) %UNLESS FAULT=NONE %THENRESULT=FAULT %IF IOMODE= BACKSPACE %AND RELAX ANSI=FALSE %THENSTART ! ! Validate the BACKSPACE Operation ! F== RECORD(AFD) FAULT=BACKSPACE NOT ALLOWED %AND -> BASIC IO ERROR %C %IF F_UFD= FREEFMTFILE BITS %FINISH -> RETURN IO FORM (OPEN CLOSE AND INQUIRE): ! %IF DSNUM<0 %THENSTART %IF DSNUM=-2 %OR IO MODE\=128 %THENSTART ! {NOTE: IO MODE=128 => Inquire} !Fail on the channel number { IO MODE= 64 => Close } ! { IO MODE= 32 => Open } FAULT=INVALID UNIT NUMBER -> BASIC IO ERROR %FINISH %FINISH %IF TCT_PPs(0)_Word 1= -1 %THEN PPLIST ADDRESS= NONE %C %ELSE PPLIST ADDRESS= ADDR(TCT_PPs(0)) %IF IO MODE=32 %THEN FAULT= OPEN (PPLIST ADDRESS) %ELSESTART %IF IO MODE=64 %THEN FAULT= CLOSE (PPLIST ADDRESS) %C %ELSE FAULT= INQUIRE (PPLIST ADDRESS) ; %FINISH ! -> BASIC IO ERROR %IF FAULT\=NONE RETURN: !*********************************************************************** ! ! RETURN (after successful completion) ! !*********************************************************************** ! !Set the IOSTAT field in the Transfer Control Table ! TCT_IOSTAT VALUE= 0 ! %RESULT= 0 !*********************************************************************** ! ! REPORT AN ERROR ! !*********************************************************************** ! BASIC IO ERROR: %IF SPECIFIER FLAGS\=NONE %THENSTART ! ! ! Examine the I/O error specifiers given ! ! ERROR= FAULT ! TCT_IOSTAT VALUE= ERROR {first set the IOSTAT value} ! ! Check Label Exits ! %RESULT=2 %IF SPECIFIER FLAGS&2\= 0 ! %RESULT=0 %IF SPECIFIER FLAGS>= 4 ! !Continue with ordinary error reporting !if no label exit was taken and %FINISH; !if no IOSTAT specifier was given %IF FAULT>0 %THENSTART ! ! ! Report a fault detected by FIO ! ! {SELECT OUTPUT (107)} SSMESS (FAULT) {print the error message} ! %FINISH {give a %MONITOR and %STOP} F77IOERR ( 1 {stack frame to unwind}) ! !*********************************************************************** ! ! OPEN and CLOSE and INQUIRE servicing procedures ! !*********************************************************************** ! %STRING(255) %MAP TEXT AT (%INTEGER ADDRESS) ! ! ! ! ! AN AUXILARY ROUTINE WHICH CONVERTS A CHARACTER VARIABLE INTO ! ! AN ISO STRING WITH ALL TRAILING SPACES REMOVED. THE RESULT ! ! IS THE ADDRESS OF THE CONVERTED TEXT. THE PARAMETER POINTS ! ! AT THE WORD PRECEDING THE ADDRESS OF A DESCRIPTOR TO THE VARIABLE. ! ! !NOTE that by returning the address of the result rather than the result ! itself the calling procedure has the capability of validating the ! result (ie. the text and its length) before exercising its option ! to save the result. ! ! !NOTE also that the result is also translated to ! upper case if the Lower Case Option is in force ! ! ! %RESULT= " " => the Character variable is all spaces ! %RESULT= "" => the Character variable is unassigned ! %RESULT= Character text otherwise ! ! ! %OWNSTRING(255) RESULT ;!%C RESULT contains the Character text %INTEGER ADR {address of RESULT} %HALFINTEGER DISP { and a word displacement into RESULT} ! %HALFINTEGER CONST {set to 1 if 1st trailing blank is word aligned} {set to 0 if 1st trailing blank is byte aligned} ! %RECORD (Form of a CHARACTER Desc) %NAME C %RECORD (Form of a Parameter Pair) %NAME PP PP==RECORD(ADDRESS) C==PP_C ADR= ADDR(RESULT ) ! ! Get a Copy of the Character Text ! %RESULT==UNASSIGNED SPECIFIER %C %IF CHECK\=FALSE %AND BYTE AT(C_ADDRESS,C_INC)=X'80' COPY(C_LENGTH,C_ADDRESS,C_INC,ADR,1) {into RESULT} ! ! Prepare to Locate Trailing Spaces ! DISP= C_LENGTH>> 1 ! %IF C_LENGTH & 1={even} 0 %THENSTART ! ! First Check the Last Byte ! %IF BYTEINTEGER(ADR+DISP)\=BLANK %THEN CONST= 0 %C %AND -> SET LENGTH DISP= -1+DISP %FINISH ! ! Now Locate Any Trailing Spaces ! CONST= 1 %WHILE DISP> 0 %CYCLE ! %IF HALFINTEGER(ADR+DISP) \=X'2020' %THENSTART %IF HALFINTEGER(ADR+DISP)>>4= X'20' %THEN CONST= 0 %EXIT %FINISH DISP= DISP-1 %REPEAT ! ! Finalise the Result ! SET LENGTH: LENGTH(RESULT)=DISP + DISP + CONST ! {IF CASE\= UPPER (only) %THEN Translate Lower Case into Upper Case} ! %RESULT == RESULT %END; !of TEXT AT %HALFINTEGERFN OPEN (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS IS THE PROCEDURE RESPONSIBLE FOR SERVICING ! ! A REQUEST TO OPEN A GIVEN CHANNEL. ! ! ! !The parameter points to the Parameter-Pairs List within the Transfer ! Control Table. If there is no list, then the parameter is set zero. !The individual parameter pairs are identified as follows: ! !0 => integer value of RECL= !1 => integer value of NREC= !2 => descriptor to character value of FILE= !3 => descriptor to character value of STATUS= !4 => descriptor to character value of ACCESS= !5 => descriptor to character value of FORM= !6 => descriptor to character value of BLANK= !7 => descriptor to character value of FILETYPE= (or DESC=) %INTEGERFNSPEC VALUE AT (%INTEGER ADDRESS OF VALUE) !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTSTRING(7) %ARRAY STATUS TEXTS (0:3) %C ="UNKNOWN" , "SCRATCH", %C "NEW" , "OLD" ; !%C these are the valid texts that may be taken by the STATUS= specifier %C they are translated into the following values: ! %CONSTHALFINTEGER UNKNOWN=0 , SCRATCH=1 , NEW=2 , OLD=3 !Values taken by the ACCESS= specifier: ! %CONSTHALFINTEGER SEQUENTIAL=0 %CONSTHALFINTEGER DIRECT=1 !Values taken by the FORM= specifier: ! %CONSTHALFINTEGER UNFORMATTED=0 %CONSTHALFINTEGER FORMATTED=1 !Values taken by the BLANK= specifier: ! %C %CONSTHALFINTEGER NULL=0 %CONSTHALFINTEGER ZEROS=1 !*********************************************************************** ! ! LOCAL VARIABLES ! !*********************************************************************** ! %STRINGNAME SPECIFIER; ! text of the current specifier being evaluated %INTEGER ADDRESS ; !address of the current specifier being evaluated {Extracted } %STRING(255) FILE NAME ; ! text of FILE= { (and } !STRING(255) FILE TYPE ; ! text of FILETYPE= { transformed)} %INTEGER RECL ; !value of RECL= { values } !INTEGER NREC ; !value of NREC= { of } %HALFINTEGER FORM ; !value of FORM= { the } %HALFINTEGER ACCESS ; !value of ACCESS= { various } %HALFINTEGER BLANKS ; !value of BLANKS= { specifiers} %HALFINTEGER STATUS ; !value of STATUS= ! %INTEGERARRAY SPECIFIER ADDRS (0:7); !%C SPECIFIER ADDRS is a list of addresses which point %C to the corresponding entry in the %C Parameter-Pairs List (zero=>not given) %RECORD (Form of a Parameter Pair List) %NAME PP %INTEGER VALUE; !value of current specifier if it's an Integer %HALFINTEGER FAULT; !reported by this routine %INTEGER TEXT ID; !utility variable %INTEGER I ; !utility variable (another one) ! ! ! Examine the Parameter-Pairs List ! ! %CYCLE I=0,1,7 ! SPECIFIER ADDRS(I)= NOT SET ! %REPEAT {initialising the array of ptrs (to each specifier given)} %UNLESS PPLIST ADDRESS= NOT SET %THENSTART ! ! Prepare to Scan the Parameter-Pairs List ! PP==RECORD(PPLIST ADDRESS) ! ! Extract the 1st/next Specifier Address ! %WHILE PP_Word 1>= 0 %CYCLE ! SPECIFIER ADDRS(PP_ID)= ADDR(PP_Word 1) PP== PP_NEXT PP PAIR %REPEAT %FINISH !Extract and Validate the STATUS Specifier ! STATUS = UNKNOWN ADDRESS=SPECIFIER ADDRS(3) %UNLESS ADDRESS=NONE %THENSTART; ! STATUS= was specified ! SPECIFIER==TEXT AT (ADDRESS) ! ! Examine STATUS text ! %CYCLE TEXT ID= UNKNOWN,1,OLD STATUS=TEXT ID %ANDEXIT %IF SPECIFIER=STATUS TEXTS (TEXT ID) %REPEAT %UNLESS STATUS=TEXT ID %THEN -> CHECK TYPE OF FAULT %FINISH !Extract and Validate the FILE Specifier ! ADDRESS=SPECIFIER ADDRS(2) %UNLESS ADDRESS=NONE %THENSTART; ! FILE= was specified ! SPECIFIER==TEXT AT (ADDRESS) %IF SPECIFIER<"." %THEN -> CHECK TYPE OF FAULT FILE NAME=SPECIFIER %FINISHELSE FILE NAME="" !Only if it was not specified ! ! Validate the Use made of STATUS= and FILE= ! %IF FILENAME="" %THENSTART %IF STATUS>SCRATCH %THEN -> NO FILENAME GIVEN %FINISHELSESTART %IF STATUS=SCRATCH %THEN -> SPECIFIERS INCONSISTENT %FINISH !Extract and Validate the RECL Specifier ! VALUE=VALUE AT (SPECIFIER ADDRS(0) ) %IF VALUE< 0 %THEN -> ERROR REPORTED ! RECL = VALUE !Extract and Validate the NREC Specifier ! %C VALUE=VALUE AT (SPECIFIER ADDRS(1) ) %C %IF VALUE< 0 %THEN -> ERROR REPORTED ! %C NREC = VALUE !Extract the ACCESS Specifier ! ACCESS =SEQUENTIAL ADDRESS=SPECIFIER ADDRS(4) %UNLESS ADDRESS=NONE %THENSTART; ! ACCESS= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="DIRECT" %THEN ACCESS=DIRECT %ELSESTART %IF SPECIFIER\="SEQUENTIAL" %THEN -> CHECK TYPE OF FAULT %FINISH; %FINISH ! ! Validate Use made of ACCESS=, and RECL= and NREC= ! %IF ACCESS=SEQUENTIAL %THENSTART %IF RECL\=NOT SET %THEN -> SPECIFIERS INCONSISTENT {OR NREC\=NOT SET } %FINISHELSESTART %IF RECL =NOT SET %THEN -> RECORD LENGTH MISSING %FINISH !Extract and Validate the FORM Specifier ! ADDRESS=SPECIFIER ADDRS(5) %UNLESS ADDRESS=NONE %THENSTART; ! FORM= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="UNFORMATTED" %THEN FORM=UNFORMATTED %ELSESTART %IF SPECIFIER ="FORMATTED" %THEN FORM= FORMATTED %C %ELSE -> CHECK TYPE OF FAULT; %FINISH %FINISHELSE FORM=1-ACCESS; ! FORM= was not specified !Extract and Validate the BLANK Specifier ! BLANKS =NULL ADDRESS=SPECIFIER ADDRS(6) %UNLESS ADDRESS=NONE %THENSTART; ! BLANK= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="ZERO" %THEN BLANKS=ZEROS %ELSESTART %IF SPECIFIER\="NULL" %THEN -> CHECK TYPE OF FAULT %FINISH ! ! Validate Use made of FORM= and BLANK= ! %IF FORM=UNFORMATTED %THEN -> SPECIFIERS INCONSISTENT %FINISH !Extract the FILETYPE (DESC) Specifier ! %C ADDRESS=SPECIFIER ADDRS(7) %C %UNLESS ADDRESS=NONE %THENSTART ! %C SPECIFIER==TEXT AT (ADDRESS) %C %IF SPECIFIER<"*" %THEN -> CHECK TYPE OF FAULT %C FILE TYPE = SPECIFIER %C %FINISHELSE FILE TYPE = "" !(ie. not given) ! !Now perform the Machine Dependencies ! FAULT= F77OPEN(DSNUM,STATUS, ACCESS,FORM, BLANKS,RECL,FILE NAME) %IF FAULT> 0 %THEN -> REPORT FAULT %RESULT= 0 !*********************************************************************** ! ! REPORT ERRORS DETECTED ! !*********************************************************************** ! CHECK TYPE OF FAULT: !when some specifier was not recognised, either the ! character variable was unassigned, or the ! character value was invalid ! %RESULT=SPECIFIER NOT RECOGNISED %IF SPECIFIER\=UNASSIGNED SPECIFIER %RESULT=UNASSIGNED VARIABLE ERROR REPORTED: !while extracting an integer value from a specifier ! %RESULT=-VALUE; !reported by VALUE AT RECORD LENGTH MISSING : %RESULT=RECORD LENGTH MISSING SPECIFIERS INCONSISTENT: %RESULT=SPECIFIERS INCONSISTENT NO FILENAME GIVEN : %RESULT=NO FILENAME GIVEN ! REPORT FAULT : %RESULT= FAULT %INTEGERFN VALUE AT (%INTEGER ADDRESS) ! ! ! ! A local function to establish the integer value of a ! ! specifier. The parameter points at the value bar a word. ! ! %INTEGER VALUE; !as specified in the parameter-pairs list ! %RESULT= NOT SET %IF ADDRESS =NOT SET VALUE =INTEGER(ADDRESS+1) %RESULT= VALUE %IF VALUE >NONE %RESULT=-UNASSIGNED VARIABLE %IF CHECK\=FALSE %AND VALUE=X'80808080' %RESULT=-ILLEGAL SPECIFIER VALUE ! %END; !of VALUE AT %END; !of OPEN %HALFINTEGERFN CLOSE (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS PROCEDURE IS RESPONSIBLE FOR SERVICING A ! ! REQUEST TO DISCONNECT A GIVEN CHANNEL. ! ! !The parameter is the address of the parameter-pairs list within the ! Transfer Control Table. If there is no list then the address is ! set to zero. ! ! ! %HALFINTEGER STATUS; !set to indicate the value of the ! STATUS= specifier as follows: ! %C %CONSTHALFINTEGER NOT SPECIFIED= 0 %CONSTHALFINTEGER DELETE = 1 %CONSTHALFINTEGER KEEP = 2 %STRINGNAME STATUS TEXT; !acquired from TEXT AT ! via the parameter-pairs list %IF PPLIST ADDRESS\=NOT SET %THENSTART ! ! Extract and Evaluate the STATUS specifier ! STATUS TEXT==TEXT AT (PPLIST ADDRESS) %IF STATUS TEXT="KEEP" %THEN STATUS= KEEP %ELSESTART %IF STATUS TEXT="DELETE" %THEN STATUS= DELETE %C %ELSE ->REPORT A FAULT %FINISH; %FINISHELSE STATUS=NOT SET !if not specified ! ! Perform the CLOSE ! %RESULT= F77CLOSE (DSNUM,STATUS) ! ! Report Invalid STATUS text ! REPORT A FAULT: !when the STATUS text was not recognised ! %RESULT=SPECIFIER NOT RECOGNISED %IF STATUS TEXT\=UNASSIGNED SPECIFIER %RESULT=UNASSIGNED VARIABLE ! %END; !of CLOSE %HALFINTEGERFN INQUIRE (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS PROCEDURE IS RESPONSIBLE FOR SERVICING AN INQUIRE ! ! REQUEST, EITHER ON A GIVEN UNIT OR ON A GIVEN FILE. ! ! !The parameter is the address of the Parameter-Pairs list located within !the Transfer Control Table. If there is no list then PPLIST ADDRESS is !then set to zero. ! !The individual parameter pairs are identified as follows: ! ! 1 => descriptor to EXIST specifier (type Logical) ! 2 => descriptor to OPENED specifier (type Logical) ! 3 => descriptor to NUMBER specifier (type Integer) ! 4 => descriptor to NAMED specifier (type Logical) !12 => descriptor to RECL specifier (type Integer) !13 => descriptor to NEXTREC specifier (type Integer) !16 => descriptor to NREC specifier (type Integer) !64 => descriptor to FILE specifier (type Character) !69 => descriptor to NAME specifier (type Character) !70 => descriptor to ACCESS specifier (type Character) !71 => descriptor to SEQUENTIAL specifier (type Character) !72 => descriptor to DIRECT specifier (type Character) !73 => descriptor to FORM specifier (type Character) !74 => descriptor to FORMATTED specifier (type Character) !75 => descriptor to UNFORMATTED specifier (type Character) !78 => descriptor to BLANK specifier (type Character) !79 => descriptor to FILETYPE specifier (type Character) ! !Note that the identifiers corresponding to Specifiers of type ! Character have had 64 added to their true identification ! to differentiate them from word-aligned specifiers. !-------------------------------LOCAL---------------------------------- !----------------------------DECLARATIONS------------------------------- ! %INTEGER C ADR; !the address of a Character Specifier %HALFINTEGER C LEN; !the length of a Character Specifier %HALFINTEGER V LEN; !the length of the value to be assigned to a Character %INTEGER VALUE; !the actual value to be assigned to an Integer Specifier ! %INTEGER ADDRESS OF VALUES !the address of a list of values established by F77INQUIRE ! %HALFINTEGER ID ; !id of a current Parameter-Pairs List entry %HALFINTEGER I ; !------a utility variable ! ! %RECORD (Form of a Parameter Pair List) %NAME PP %RECORD (Form of a CHARACTER Desc ) %NAME C %HALFINTEGER FAULT ! ! Variables Associated with INQUIRE by File ! %STRING(255) FILE NAME; !name of the given file %INTEGER PTR ; !used in locating name - ptr through the PP-list %IF DSNUM<0 %THENSTART ! ! Extract Filename for INQUIRE by File ! PP==RECORD(PPLIST ADDRESS) ; !locate filename PP==PP_NEXT PP PAIR %WHILE PP_ID\= 64; ! description in the PP-List ! FILENAME=TEXT AT (ADDR(PP_Word 1)) ; !then extract the filename %IF FILENAME<"." %THEN -> INVALID FILENAME %FINISHELSESTART ! ! Prepare for INQUIRE by Unit ! FILENAME="" %FINISH ! ! Perform the INQUIRE ! FAULT= F77INQUIRE (DSNUM,FILE NAME,ADDRESS OF VALUES) %IF FAULT> 0 %THEN -> REPORT FAULT %IF PPLIST ADDRESS\=NOT SET %THENSTART ! ! Prepare to Assign Values to the Various Specifiers ! PP==RECORD(PPLIST ADDRESS) ! ! Assign Values to the Given Specifiers ! NEXT SPECIFIER: %IF PP_Word 1>=0 %THENSTART ! ID= PP_ID %IF ID>63 %THEN -> STRING VALUE ! ! Perform an Integer Assignment ! VALUE= INTEGER(ADDRESS OF VALUES + (ID + ID)) %IF VALUE< 0 %THEN -> UNDEFINED VALUE ! %IF PP_I2 FLAG= SET %C %THEN HALFINTEGER(PP_INTEGER ADDRESS)= VALUE %C %ELSE INTEGER(PP_INTEGER ADDRESS)= VALUE -> NEXT SPECIFIER ! ! Perform a Character Assignment ! STRING VALUE: C == PP_C {point to the CHARACTER Descriptor} ! PTR= INTEGER(ADDRESS OF VALUES + ((ID-64)<<1) ) %IF PTR=-1 %THEN -> UNDEFINED TEXT ! C ADR= C_ADDRESS ; !---address of Character scalar C LEN= C_LENGTH ; !----length of Character scalar V LEN= LENGTH(STRING(PTR)); !----length of string value ! I= C LEN - V LEN %IF I< 0 %THEN V LEN= C LEN COPY (V LEN,PTR,1,C ADR,C_INC) %IF I> 0 %THEN %C PROPAGATE ( I,C ADR,V LEN + C_INC, BLANK ) ;!%C (append any trailing spaces reqd) ! ! Point to the next Entry in the Parameter-Pairs List ! NEXT ONE: PP== PP_NEXT PP PAIR -> NEXT SPECIFIER ! ! Handle an Undefined Character Value ! UNDEFINED TEXT: %IF CHECK\=FALSE %AND PP_ID\=64 %THENSTART ! PROPAGATE(C_LENGTH,C_ADDRESS,C_INC, X'80') ! %FINISH -> NEXT ONE ! ! Handle an Undefined Integer Value ! UNDEFINED VALUE: %IF CHECK\=FALSE %THENSTART ! %IF PP_I2 FLAG= SET %THEN I= 2{bytes} %C %ELSE I= 4{bytes} PROPAGATE ( I,PP_INTEGER %C ADDRESS,0,X'80') ! %FINISH -> NEXT ONE %FINISH END OF LIST: %FINISH ! ! RETURN ! %RESULT=0; !if there are no errors ! {otherwise} REPORT FAULT: %RESULT=FAULT ! {or} INVALID FILENAME: ! %RESULT=UNASSIGNED VARIABLE %IF FILE NAME=UNASSIGNED SPECIFIER %RESULT= INVALID FILENAME %END; !of INQUIRE ! !*********************************************************************** ! ! UTILITY PROCEDURES ! !*********************************************************************** ! %ROUTINE PROPAGATE (%INTEGER LEN,BASE %HALFINTEGER INC,WITH) ! ! ! ! ! This is a utility procedure to fill part of an area which ! ! is usually a CHARACTER variable with a specified number ! ! of a given character. ! ! ! %BYTEINTEGERARRAYNAME AREA %BYTEINTEGERARRAYFORMAT AREA FORM (0:32767) ! AREA==ARRAY(BASE,AREA FORM) %WHILE LEN> 0 %CYCLE ! AREA(INC)= WITH INC = INC + 1 LEN = LEN - 1 %REPEAT %END; !of PROPAGATE %IF SYSTEM=PERQ %THENSTART ! ! %HALFINTEGERFN BYTE AT (%INTEGER DATA AD, %HALFINTEGER DATA INC) ! ! ! %HALFINTEGER I I=HALFINTEGER(DATA AD + DATA INC>>1) %RESULT= I & 255 %IF (DATA INC&1)= 0 %RESULT= I >> 8 %END; !of BYTE AT %ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP, %INTEGER TBASE,%HALFINTEGER TDISP) **@TBASE; *LDDW; **TDISP **@SBASE; *LDDW; **SDISP **LEN *STLATE_X'63'; *MVBW %END ! ! %FINISH; !if PERQ %IF SYSTEM=EMAS %THENSTART ! ! %ROUTINE COPY (%INTEGER LENGTH, FROM BASE {word address} , %HALFINTEGER FROM DISP {byte displacement} , %INTEGER TO BASE {word address again} , %HALFINTEGER TO DISP {byte displacement again} ) %WHILE LENGTH> 0 %CYCLE ! BYTEINTEGER(TO BASE + TO DISP)=BYTEINTEGER(FROM BASE + FROM DISP) TO DISP= TO DISP + 1 FROM DISP=FROM DISP + 1 LENGTH= LENGTH - 1 %REPEAT %END; !of COPY %HALFINTEGERFN BYTE AT (%INTEGER DATA AD {word address} , %HALFINTEGER DATA DISP {byte displacement} ) %RESULT= BYTEINTEGER (DATA AD + DATA DISP) %END; !of BYTE AT ! ! %FINISH; !if EMAS %END; !of F77 IOF ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! %ENDOFFILE