!Modified 2/July/82 14.00 !**********************************************************************! !**********************************************************************! ! ! ! ! ! Complete FILE INPUT/OUTPUT Procedures ! ! ! ! for FORTRAN77 Programs ! ! ! ! on ICL PERQ Machines ! ! ! ! ! !**********************************************************************! !**********************************************************************! %RECORDFORMAT FILE DEFINITION TABLE ( %C %C %INTEGER LINK , BACK {LINK}, %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 Spare2 , %HALFINTEGER UFD , %HALFINTEGER F77BLANK , %HALFINTEGER F77RECL , %HALFINTEGER FLAGS , %INTEGER CUR POS {in bytes from start of file}, %INTEGER CUR LEN {In bytes from start of file}, %INTEGER ID ADDR ) %CONSTHALFINTEGER Fdsize= 78 {bytes} %RECORDFORMAT FILENAME LIST ENTRY ( %C %C %INTEGER LINK {to next list entry } , %INTEGER BACK {to previous entry } , %INTEGER FD ADDR {of correspondinding FD Table}, %C %STRING(100) ID {---full system-dependent name}) !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER Screen Width= 84 %CONSTHALFINTEGER Max Maxrec= 16384 {for the Release 1.5 onwards} %CONSTHALFINTEGER Not Set = 0 %CONSTHALFINTEGER Nil = 0 %CONSTHALFINTEGER None= 0 %CONSTHALFINTEGER Null= 0 %CONSTHALFINTEGER Zero= 0 %CONSTHALFINTEGER False= 0 , True= 1 %CONSTHALFINTEGER Read = 1 %CONSTHALFINTEGER Write = 2 %CONSTHALFINTEGER Append= 3 %CONSTSTRING( 8) The Console Name = "console:" %OWNSTRING( 1) Null Name = "" %CONSTHALFINTEGER Console= 0; !Possible %CONSTHALFINTEGER The Console= 0; ! File %CONSTHALFINTEGER TXT File = 1; ! Access %CONSTHALFINTEGER DTA File = 2; ! Routes %CONSTHALFINTEGER Unknown= 0; !Possible %CONSTHALFINTEGER Scratch= 1; ! File %CONSTHALFINTEGER New = 2; ! Existence %CONSTHALFINTEGER Old = 3; ! Values %CONSTHALFINTEGER UnFormatted= 0; !Possible %CONSTHALFINTEGER Formatted= 1; ! FORM values %CONSTHALFINTEGER Formless = 0; !Possible %CONSTHALFINTEGER Fixed = 1; ! RECORD %CONSTHALFINTEGER Variable = 2; ! TYPEs %CONSTHALFINTEGER Sequential= 0; !Possible %CONSTHALFINTEGER Direct = 1; ! ACCESS %CONSTHALFINTEGER Da Mode = 1; ! values %CONSTHALFINTEGER Sq Mode = 0; ! %CONSTHALFINTEGER Read Only =X'01'; !Possible %CONSTHALFINTEGER Read and %C Write=X'23'; ! Values %CONSTHALFINTEGER Write Only =X'02'; ! for %CONSTHALFINTEGER All =X'7F'; ! VALID ACTION %CONSTHALFINTEGER Not Open = 0; !Possible %CONSTHALFINTEGER Opened = 1; ! %CONSTHALFINTEGER After Open = 1; ! values %CONSTHALFINTEGER After Read = 2; ! %CONSTHALFINTEGER After Write = 3; ! for %CONSTHALFINTEGER After Rewind = 4; ! %CONSTHALFINTEGER After Backspace = 5; ! CUR %CONSTHALFINTEGER After Endfile = 6; ! STATE %CONSTHALFINTEGER Unformatted File= X'48'; !Possible %CONSTHALFINTEGER Formatted File= X'49'; ! Values %CONSTHALFINTEGER Formatted Bit = X'01'; ! for %CONSTHALFINTEGER List Directed Bit = X'02'; ! UFD %CONSTHALFINTEGER NUL= X'00' {Carriage Control } %CONSTHALFINTEGER LF= X'0A' { Characters } %CONSTHALFINTEGER FF= X'0C' { which may be written to the Screen } %CONSTHALFINTEGER CR= X'0D' { or to a Text File} !*********************************************************************** ! ! ERROR MESSAGES ! !*********************************************************************** ! %CONSTHALFINTEGER Unit Not Connected = 117 %CONSTHALFINTEGER Unit Not Defined = 151 %CONSTHALFINTEGER File Unsuitable = 190 %CONSTHALFINTEGER File Already Exists = 168 %CONSTHALFINTEGER File Already Connected = 118 %CONSTHALFINTEGER File Does Not Exist = 152 %CONSTHALFINTEGER Recl Conflict = 120 %CONSTHALFINTEGER Form Conflict = 121 %CONSTHALFINTEGER Access Conflict = 119 %CONSTHALFINTEGER Status Conflict = 122 %CONSTHALFINTEGER No Write Permission = 162 %CONSTHALFINTEGER Input Ended = 153 %CONSTHALFINTEGER Form Not Suitable = 124 %CONSTHALFINTEGER Not Enough Space = 191 %CONSTHALFINTEGER Recl Too Large = 188 %CONSTHALFINTEGER Facility Not Available = 181 %CONSTHALFINTEGER Invalid Unit Number = 164 %CONSTHALFINTEGER Invalid IO Operation = 171 %CONSTHALFINTEGER Invalid File Name = 128 %CONSTHALFINTEGER Invalid Status = 123 %CONSTHALFINTEGER System Open Failure = 197 %CONSTHALFINTEGER Record Too Large = 192 %CONSTHALFINTEGER Read After Write = 156 %CONSTHALFINTEGER Read After Endfile = 160 %CONSTHALFINTEGER Write After Endfile = 157 ! !*********************************************************************** ! ! SPECIFICATIONS OF DECLARED PROCEDURES ! !********************************************************************** ! %HALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM, %HALFINTEGER ACTION, FILE TYPE , %INTEGERNAME FILE DEFINITION ADDRESS) %HALFINTEGERFNSPEC IN REC %HALFINTEGERFNSPEC IN CHAR (%HALFINTEGER BUFF PTR ) %HALFINTEGERFNSPEC IN FIELD (%HALFINTEGER LENGTH, BUFF PTR , %INTEGER TO, TO INC ) %HALFINTEGERFNSPEC OUT CHAR (%HALFINTEGER CHAR, BUFF PTR ) %HALFINTEGERFNSPEC OUT FILL (%HALFINTEGER LENGTH, BUFF PTR , WITH ) %HALFINTEGERFNSPEC OUT FIELD (%HALFINTEGER LENGTH, %INTEGER FROM, FROM INC , %HALFINTEGER BUFF PTR ) %HALFINTEGERFNSPEC OUT REC %HALFINTEGERFNSPEC BSP REC %HALFINTEGERFNSPEC F77OPEN (%INTEGER DSNUM , %HALFINTEGER STATUS, ACCESS, %HALFINTEGER FORM, BLANKS, %INTEGER RECL , %STRINGNAME FILE NAME) %HALFINTEGERFNSPEC F77INQUIRE (%INTEGER DSNUM , %STRINGNAME FILE NAME , %INTEGERNAME ADDR OF VALUES ) %HALFINTEGERFNSPEC F77CLOSE (%INTEGER DSNUM, %HALFINTEGER STATUS) %ROUTINESPEC CLOSE FILES %HALFINTEGERFNSPEC OPEN FD (%INTEGER DSNUM , RECL, %HALFINTEGER ACCESS, FORM, STATUS, %HALFINTEGER ACCESS ROUTE, BLANKS, %INTEGERNAME ADDR OF FD TABLE , %STRINGNAME FULL FILENAME ) %INTEGERFNSPEC LOCATE FILENAME(%STRINGNAME FULL FILENAME ) %HALFINTEGERFNSPEC FILE EXISTENCE %C (%STRINGNAME FULL FILENAME ) %HALFINTEGERFNSPEC POSITION DA FILE (%HALFINTEGER ACTION , %INTEGER RECORD NUMBER ) ! !*********************************************************************** ! ! SPECIFICATIONS OF OTHER (LOCAL) PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFNSPEC OPEN (%INTEGER AFD, %HALFINTEGER OPEN MODE) %HALFINTEGERFNSPEC CLOSE (%INTEGER AFD) %INTEGERMAPSPEC FDMAP (%INTEGER DSNUM ) %INTEGERFNSPEC LOCATE FD (%INTEGER DSNUM ) %HALFINTEGERFNSPEC GET SPACE (%HALFINTEGER SPACE REQD , %INTEGERNAME SPACE ADDRESS) %ROUTINESPEC RELEASE SPACE (%HALFINTEGER SPACE TO FREE, %INTEGER SPACE ADDRESS) %HALFINTEGERFNSPEC GET FD (%INTEGER DSNUM , %HALFINTEGER ACCESS, ACCESS ROUTE , %HALFINTEGER VALID ACTION, %STRINGNAME ID, %INTEGERNAME AFD ) %HALFINTEGERFNSPEC DEFINE FD (%INTEGER DSNUM , %HALFINTEGER ACTION, FILE TYPE, %INTEGERNAME FILE DEFINITION TABLE ADR) ! !*********************************************************************** ! ! SPECIFICATIONS OF SUPPORT PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFNSPEC FILE OPEN (%INTEGER AFD, %HALFINTEGER OPEN MODE) %HALFINTEGERFNSPEC FILE CLOSE (%INTEGER AFD) %HALFINTEGERFNSPEC FILE WRITE (%HALFINTEGER BLOCK NUMBER ) %HALFINTEGERFNSPEC FILE READ (%HALFINTEGER BLOCK NUMBER ) %STRING(100) %FNSPEC SYSTEM FILENAME (%STRINGNAME FILENAME) ! !*********************************************************************** ! ! SPECIFICATIONS OF EXTERNAL IMP PROCEDURES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFNSPEC PROMPT FILE DEFIN{ITION} %C (%INTEGER DSNUM , %HALFINTEGER ACTION, FILE TYPE, %INTEGERNAME AFD ) ! !*********************************************************************** ! ! SPECIFICATIONS OF EXTERNAL PASCAL PROCEDURES ! !*********************************************************************** ! %EXTERNALROUTINESPEC GET LINE (%INTEGER BUFFER ADDRESS, %HALFINTEGERNAME AMOUNT READ ) %EXTERNALROUTINESPEC NEWSEG (%HALFINTEGERNAME SEGMENT NUMBER , %HALFINTEGER INITIAL,INC, and MAX SIZE {in blocks}) %EXTERNALROUTINESPEC EXTEND SEG (%HALFINTEGER SEGMENT NUMBER , NEW SIZE {in blocks}) %EXTERNALROUTINESPEC NOMINATE PROC (%HALFINTEGER PROC ID , %ROUTINE CLOSE FILES ) !*********************************************************************** ! ! GLOBAL VARIABLES ! !*********************************************************************** ! %OWNINTEGERARRAY FD ADR (-2:25)= NOT SET (*); !%C address of %C the file definitions for units 0-25 and for %C the preconnected input and output channels %OWNINTEGER CURRENT FD= Not Set %OWNRECORD (File Definition Table) %NAME F ;!%C F is mapped onto CURRENT FD %OWNINTEGER FD LIST LISTHEAD= Not Set ;!%C the listhead of list of file definition tables %C which are associated with channels %C greater than 25, and which are open %C the list is ordered on data-set number ascendency %OWNINTEGER FILENAME LIST LISTHEAD= Not Set ;!%C listhead of list of file names that are %C known (and therefore open) %OWNINTEGER FD LIST PTR, FN LIST PTR; !ptrs set by the search of the FD list and %C Filename list respectively when a key %C was not found (see LOCATE FD %C and LOCATE FILENAME) %OWNHALFINTEGER SCRATCH ID='@' ;!%C SCRATCH ID is incremented each time a new Scratch File%C is required by the user program. It is used%C by FILEOPEN as a basis for a unique filename %OWNHALFINTEGER NL REQD= False ;!%C NL REQD= True when a NL character should be sent %C to the screen to tidy up the last %C line written %OWNINTEGER FIVE12= 512 !*********************************************************************** ! ! BUFFER VARIABLES ! !*********************************************************************** ! %CONSTBYTEINTEGERARRAYFORMAT %C FORMAT OF IO BUFFER (0:511) %OWNBYTEINTEGERARRAYNAME IO BUFFER !%C All Input and Output is performed through IO BUFFER which is %C large enough to hold just one block. IO BUFFER is part %C of a segment that is created as part of the internal %C initialisation performed at the first I/O request. %OWNHALFINTEGER BPOS ;!%C BPOS is the displacement from the start of %C the contents of IO BUFFER from the %C start of the current logical record %OWNHALFINTEGER BBLK ;!%C BBLK identifies the block number of %C the contents of IO BUFFER %OWNINTEGER BUFF ADR ;!%C BUFF ADR is the address of IO BUFFER %C BUFF ADR is initialised by GET SPACE !*********************************************************************** ! ! Procedure NEW FILE OP ! !*********************************************************************** ! %EXTERNALHALFINTEGERFN NEW FILE OP (%INTEGER DSNUM, %HALFINTEGER ACTION, FILE TYPE , %INTEGERNAME FD ADDRESS) ! ! ! ! ! A Global Procedure to Position a File for an I/O Operation ! ! ! ! !The ACTION Parameter may be one of: ! %CONSTHALFINTEGER Read = 1 %CONSTHALFINTEGER Write = 2 %CONSTHALFINTEGER Rewind = 4 %CONSTHALFINTEGER Backspace= 8 %CONSTHALFINTEGER Endfile= 16 ! ! %SWITCH HANDLE (Read:Endfile) %CONSTHALFINTEGERARRAY SIMPLE VALID ACTION (Not Open:After Endfile ) %C %C = None { Not Open } , Rewind + Read {After Open } , Backspace + Rewind + Read {After Read } , Backspace + Endfile + Rewind + Write {After Write } , Backspace + Endfile + Rewind + Read {After Rewind } , Backspace + Endfile + Rewind + Read {After Backspace} , Rewind {After Endfile } ! !An action is mentioned above if no particular action is ! prerequired before performing it. If an action ! is not mentioned then a call on: %HALFINTEGERFNSPEC SPECIAL ACTION {is made} %OWNHALFINTEGER LAST ACTION=Not Set ;!%C LAST ACTION is used to check if the file %C is already set for current action %HALFINTEGER FAULT %INTEGER AFD %INTEGER CUR POS {copy of F_CUR POS sometimes} F==RECORD(CURRENT FD) %IF F==RECORD(Null) %OR F_DSNUM\=DSNUM %THENSTART ! ! Look for the Required Table ! %IF DSNUM<-2 %THENRESULT= Invalid Unit Number ! %IF DSNUM> 25 %THEN AFD= LOCATE FD (DSNUM) %C %ELSE AFD= FDMAP (DSNUM) %IF AFD=Not Set %THENSTART ! ! Get a New File Definition Table ! FAULT=DEFINE FD (DSNUM,ACTION,FILE TYPE, AFD) %IF FAULT> 0 %THENRESULT=FAULT %FINISH F== RECORD (AFD) CURRENT FD= AFD %FINISHELSESTART ! ! Check if There is Anything to do ! %IF ACTION\= Backspace %AND %C ACTION = LAST ACTION %THEN FD ADDRESS= CURRENT FD %C %AND %RESULT= 0 %FINISH FD ADDRESS= CURRENT FD LAST ACTION = ACTION ! ! Validate the I/O Operation ! %IF ACTION & F_VALID ACTION= 0 %THENSTART ! %IF ACTION= Write %THENRESULT=No Write Permission %C %ELSERESULT=Invalid IO Operation %FINISH %IF ACTION & SIMPLE VALID ACTION(F_CUR STATE) = 0 %THENSTART ! ! Perform Special Actions (or Tests) ! FAULT= SPECIAL ACTION %IF FAULT> 0 %THENRESULT= FAULT %IF FAULT< 0 %THENRESULT= 0 %FINISH !PREPARE FOR REQUESTED I/O OPERATION: ! ! %RESULT = 0 %IF F_ACCESS ROUTE=The Console %OR F_ACCESS TYPE=Direct ! -> HANDLE (ACTION) ! ! Prepare for a Read Operation ! HANDLE (Read): %RESULT= Input Ended %IF F_CUR POS>=F_CUR LEN CUR POS =F_CUR POS ! ! Position at the Next Record ! BBLK= CUR POS // 512 BPOS= CUR POS - (BBLK*FIVE12) ! F_CUR STATE= After Read %RESULT= FILE READ (BBLK) ! ! Prepare for a Write Operation ! HANDLE (Write): %IF F_POS\= 0 %THENSTART ! %IF F_POS= 512 %THEN F_BLK= {select the } F_BLK+1 %C %AND F_POS= { next record} 0 %C %ELSESTART FAULT= FILE READ (F_BLK) %RESULT=FAULT %UNLESS FAULT=None !Report result of reading the current block %FINISH; ! %FINISH; ! {Identify } BBLK= F_BLK {the buffer } BPOS= F_POS { contents} BPOS= BPOS+2 %IF F_RECORD TYPE=Variable !leave room for the record header F_CUR STATE= After Write %RESULT= 0 ! ! Perform a Rewind Operation ! HANDLE (Rewind): F_BLK= 0 %AND F_CUR POS = 0 F_CUR STATE= After Rewind %RESULT= 0 ! ! Perform a Backspace Operation ! HANDLE (Backspace): %UNLESS F_CUR POS= 0 %THENSTART FAULT = BSP REC %IF FAULT\=None %THENRESULT=FAULT %FINISH F_CUR STATE=After Backspace ! %RESULT=0 ! ! Perform an Endfile Operation ! HANDLE (Endfile): F_MAX BLK= F_BLK %AND F_CUR LEN= F_CUR POS F_POS= F_CUR POS - (F_CUR POS//512)*512 ! F_CUR STATE= After Endfile %RESULT= 0 %HALFINTEGERFN SPECIAL ACTION ! ! ! ! ! A Local Procedure to Perform Detailed Processing ! ! and/or tests for the Requested I/O Operation ! ! ! %HALFINTEGER FAULT,I %HALFINTEGER OPEN MODE ! %SWITCH STATE (After Open:After Endfile) %IF F_CUR STATE= Not Open %THENSTART ! ! OPEN A CHANNEL ! %IF FILE TYPE< 2 %THEN OPEN MODE={DA Mode} 4 %ELSESTART %IF ACTION=Write %THEN OPEN MODE= Write %C %ELSE OPEN MODE= Read; %FINISH %RESULT= -1 %IF ACTION= Rewind %AND FILE TYPE= 8 %AND F_EXISTENCE= New ! ! REWINDing a F77 file which does not exist has no effect FAULT = OPEN (CURRENT FD,OPEN MODE) %IF FAULT\= None %THENRESULT=FAULT %RESULT= 0 %UNLESS ACTION=Backspace %RESULT= -1 {=> no further action reqd by NEW FILE OP} %FINISHELSESTART -> STATE (F_CUR STATE) %UNLESS F_ACCESS ROUTE=The Console %C %OR F_ACCESS TYPE = Direct %RESULT=-1 {if direct or console IO} ! ! SET FILE SIZE (after an OPEN) ! STATE (After Open): %RESULT= -1 %IF ACTION=Backspace SET FILE LIMIT: F_CUR LEN=F_CUR POS F_MAX BLK=F_BLK F_POS=F_CUR POS - (F_CUR POS//512)*512 ! %RESULT=0 ! ! SELECT NEXT RECORD (after Reading) ! STATE (After Read): I = F_CUR POS//512 F_BLK = I F_POS = F_CUR POS - (I*FIVE12) %RESULT= 0 ! ! READING AFTER WRITING ! STATE (After Write): %RESULT= Read After Write ! ! RE-START PROCESSING A FILE ! STATE (After Rewind): -> SET FILE LIMIT ! ! DO POSITIONING AFTER BACKSPACING ! STATE (After Backspace): -> SET FILE LIMIT ! ! Check Conditions at End of File ! STATE (After Endfile): %RESULT=Write After Endfile %IF ACTION=Write %RESULT= Read After Endfile %IF ACTION=Read F_CUR STATE= After Backspace %IF ACTION=Backspace ! %RESULT=-1 {ignore Backspace and Endfile now} %FINISH ! %END; !of SPECIAL ACTION %END; !of NEW FILE OP %ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP, %INTEGER TBASE,%HALFINTEGER TDISP) **@TBASE; *LDDW; **TDISP **@SBASE; *LDDW; **SDISP **LEN *STLATE_X'63'; *MVBW %END ! !*********************************************************************** ! ! INPUT PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFN BLOCK READ (%HALFINTEGER BPTR) ! ! ! ! ! A Utility Procedure for the Input Procedures which ! get the block that contains the BPTR'th ! character of the current logical record. ! ! ! %HALFINTEGER J {block displacement from current to required block} %HALFINTEGER I { work variable} I=BPTR+BPOS %IF I>0 %THEN I=I-512 %AND J= (I>> 9)+1 %C %ELSE J= (I//512)-1 ! ! I is -ve if a preceding block is required ! I is +ve if a following block is required ! ! and J is a block displacement from current to required block BBLK= BBLK + J {identify the block required} BPOS= BPOS - (J<<9) { and set the relative displacement of 1st char} ! %RESULT= FILE READ (BBLK) {then read in the block} %END; !of BLOCK READ %OWNHALFINTEGER LAST CHAR ;!%C LAST CHAR{acter} is used while performing carriage %C control conversion on input from a TXT file %C and is set to the last character of the %C preceding record. %C LAST CHAR normally equals CR of LF %EXTERNALHALFINTEGERFN INREC ! ! ! ! ! A Global Procedure to Read a Record ! ! from the Current File. ! ! ! %HALFINTEGER AMOUNT READ; !length of next logical record %HALFINTEGER PTR ; !ptr through buffer while looking for CR character %HALFINTEGER BUFF LEN ; !the limit value of PTR %HALFINTEGER NEXT CHAR; !the 2nd character of a TXT File record %HALFINTEGER FAULT ! %HALFINTEGER CUR BLK; !block id of next record %INTEGER CUR POS; !position within file of next record %IF F_ACCESS ROUTE= The Console %THENSTART ! ! ! Get the Next Line from The Screen ! ! NEWLINE %AND NL REQD=False %UNLESS NL REQD=False ! GET LINE (BUFF ADR,AMOUNT READ) ! IO BUFFER(AMOUNT READ)=' ' %FINISHELSESTART ! ! ! Get the Next Record from a File ! ! CUR POS =F_CUR POS %IF CUR POS>=F_CUR LEN %AND F_ACCESS TYPE=Sequential %THENRESULT=Input Ended CUR BLK = CUR POS // 512 %IF CUR BLK\=BBLK %THENSTART ! ! Get the Appropriate Block ! FAULT = FILE READ (CUR BLK) %IF FAULT\= None %THENRESULT= FAULT ! B BLK = CUR BLK %FINISH {Select the next } F_BLK= CUR BLK { Logical Record} BPOS= CUR POS - (CUR BLK*FIVE12) %IF F_ACCESS ROUTE= TXT File %THENSTART ! ! ! Get the Next Record from a TXT File ! ! %IF CUR POS= 0 %THEN LAST CHAR= LF {only for the 1st record}%C %ELSE LAST CHAR= IN CHAR (-1) { for any subsequent ones} ! %C LAST CHAR is the trailing carriage control %C character of the previous record ! ! Check for an Empty Record ! %IF CUR POS\=F_CUR LEN-1 %THENSTART ! NEXT CHAR= IN CHAR (1) %AND CUR BLK= BBLK %IF NEXT CHAR= LF %THEN PTR=BPOS %AND -> FOUND END %FINISH ! ! Look for the end of the next record ! PTR= BPOS + 1 {to ignore the 1st character which normally is CR or LF} ! LOOP: %IF BBLK=F_MAX BLK %THEN BUFF LEN=F_POS %C %ELSE BUFF LEN= 512 {Scan } %WHILE PTR FOUND END %IF IO BUFFER(PTR)= CR { a } PTR = PTR+1 { CR } %REPEAT %UNLESS BBLK=F_MAX BLK %THENSTART {read in the next block} ! BBLK = BBLK+1 FAULT= FILE READ (BBLK) %RESULT=FAULT %IF FAULT> 0 ! PTR= 0 %AND -> LOOP %FINISH; !reading in the next block FOUND END: ! ! Set the Record Length and Tidy Up ! AMOUNT READ= (PTR - BPOS) + (BBLK - CUR BLK)<<9 BPOS = PTR - AMOUNT READ {because we are at the end of the current record} CUR POS = CUR POS + 2 %FINISHELSESTART ! ! ! Get the Next Record from a DTA File ! ! %IF F_RECORD TYPE= Variable %THENSTART ! ! Determine RECSIZE for Variable Length Record ! FAULT = IN FIELD (2{bytes}, {at} 0, ADDR(AMOUNT READ), 0) %IF FAULT\=None %THENRESULT=FAULT {Read the record length from the file} ! CUR POS= CUR POS + 4; !allow for lengths at start and end of record BPOS= BPOS + 2; !allow for length at start of record %FINISHELSESTART ! ! Determine RECSIZE for Fixed Length Record ! AMOUNT READ= F_RECSIZE F_DARECNUM = F_DARECNUM + 1 {if DA Mode set number of next record} ! %FINISH %FINISH; !doing DTA File specials ! ! TIDY UP READING FROM A FILE ! F_CUR POS= CUR POS + AMOUNT READ ! ! point at the following record %FINISH; !reading a record ! ! RETURN ! F_RECSIZE = AMOUNT READ F_LINES IN=F_LINES IN + 1 %RESULT=0 %END; !of INREC %EXTERNALHALFINTEGERFN IN CHAR (%HALFINTEGER BPTR) ! ! ! ! ! A Global Procedure to Extract a Character ! ! from the Input Buffer. ! ! ! %HALFINTEGER CHAR {the next character} %HALFINTEGER FAULT %IF F_ACCESS ROUTE\= The Console %THENSTART ! ! ! Handle Input from a File ! ! %UNLESS 0<=BPTR+BPOS<512 %THENSTART ! !Get the relevant block: ! FAULT= BLOCK READ (BPTR) %UNLESS FAULT= None %THENRESULT=FAULT %FINISH CHAR= IO BUFFER(BPOS+BPTR); !extract the required character %IF BPTR= 0 %AND F_ACCESS ROUTE= TXT File %THENSTART ! ! Convert Carriage Control Character to a FORTRAN CCC ! %IF CHAR= FF %THEN CHAR= '1' %ELSESTART %IF CHAR= LF %THEN CHAR= '0' %ELSESTART %IF CHAR= CR %THENSTART %IF LAST CHAR=CR %THEN CHAR= '+' %C %ELSE CHAR= ' ' %FINISH; %FINISH; %FINISH %FINISH; %FINISHELSESTART ! ! ! Handle Input from the Console ! ! CHAR= IO BUFFER(BPTR) %FINISH %RESULT= CHAR %END; !of IN CHAR %EXTERNALHALFINTEGERFN IN FIELD (%HALFINTEGER LENGTH, BPTR , %INTEGER TO, TO INC ) ! ! ! ! ! A Global Procedure to Extract Characters ! ! from the Input Buffer. ! ! ! %BYTEINTEGERARRAYNAME TO AREA %CONSTBYTEINTEGERARRAYFORMAT AREA FORM (0:32767); !%C used on occasions (when BPTR=0) %C to access the first character %C of the target address ! %HALFINTEGER BUFF PTR; !ptr into IO BUFFER, -the position to start copying %HALFINTEGER COPY LEN; !len of text to copy out of IO BUFFER %HALFINTEGER FAULT %IF F_ACCESS ROUTE\= The Console %THENSTART ! ! ! Read a Record from a File ! ! %IF BPTR=0 %AND F_ACCESS ROUTE=TXT File %THENSTART ! ! Convert the First Character from Carriage Control ! TO AREA==ARRAY(TO,AREA FORM) ! TO AREA(TO INC)= IN CHAR(0) TO INC = TO INC + 1 LENGTH = LENGTH - 1 BPTR = 1 %FINISH %UNLESS 0<=BPTR+BPOS<512 %THENSTART ! !Get the relevant block: ! A: FAULT= BLOCK READ (BPTR) %UNLESS FAULT= None %THENRESULT=FAULT %FINISH ! ! Determine How Much of the Buffer Can be Read ! BUFF PTR= BPTR + BPOS COPY LEN= 512 - BUFF PTR %IF COPY LEN> LENGTH %THEN COPY LEN=LENGTH ! ! Now Read the Buffer (as much as possible/required) ! COPY (COPY LEN, BUFF ADR, BUFF PTR, TO, TO INC) {Check if } TO INC= TO INC + COPY LEN { there is} BPTR= BPTR + COPY LEN { more to} LENGTH= LENGTH - COPY LEN { do} ! %UNLESS LENGTH= None %THEN -> A %FINISHELSESTART ! ! ! Handle Input from the Console ! ! COPY (LENGTH,BUFF ADR,BPTR,TO,TO INC) ! %FINISH %RESULT=0 %END; !of IN FIELD ! !*********************************************************************** ! ! OUTPUT PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFN GET BLOCK (%HALFINTEGER BPTR) ! ! ! ! ! A Utility Procedure for the Output Routines below which ! writes out the current buffer and reads in the block ! which contains the character in the logical ! record as identified by the parameter BPTR. ! ! ! %HALFINTEGER I {work variable} %HALFINTEGER J {displacement of block required from the current block} %HALFINTEGER FAULT ! ! First Write Out the Current Buffer (it will always have something ! of interest inside it ) FAULT = FILE WRITE (BBLK) %IF FAULT\= None %THENRESULT=FAULT ! %IF B BLK>F_BLK %THEN F_BLK= BBLK ! !Note that F_POS is not updated as it applies to ! the start of the logical record and is only ! re-set when the current record is closed, ! That is by OUTREC. ! ! Check if a Preceding or Following Record is Required ! %IF BPTR+BPOS< 0 %THEN I= BPTR+BPOS %AND J= (I//512) - 1 %C %ELSE I= BPTR+BPOS-512 %AND J= (I>> 9) + 1 ! ! I= -ve if a preceding block is required ! I= +ve if a following block is required ! ! and J is the block displacement from current position BBLK=BBLK+ J; !%C BBLK is the block required ! ! Check if the Block exists ! %IF BBLK<=F_BLK %OR F_ACCESS TYPE=Direct %THENSTART ! FAULT = FILE READ (B BLK) %IF FAULT\= None %THENRESULT=FAULT %FINISH ! ! Return ! BPOS= BPOS - (J<<9) %RESULT= 0 ! %END; !of GET BLOCK %EXTERNALHALFINTEGERFN OUT CHAR (%HALFINTEGER CHAR, BPTR) ! ! ! ! ! A Global Procedure to Place a Character in the Output Buffer ! ! ! %HALFINTEGER FAULT %IF F_ACCESS ROUTE\= The Console %THENSTART ! ! ! Place a Character into a File ! ! %UNLESS 0<=BPTR+BPOS<512 %THENSTART ! !Get the relevant block: ! FAULT= GET BLOCK (BPTR) %UNLESS FAULT=None %THENRESULT=FAULT %FINISH ! ! Insert the Character ! IO BUFFER(BPTR+BPOS)= CHAR %FINISHELSESTART ! ! ! Write a Character to the Screen ! ! IO BUFFER(BPTR)= CHAR %FINISH ! ! Update the Record Length ! BPTR= BPTR+1 %IF BPTR>F_RECORD LEN %THEN %C F_RECORD LEN= BPTR %RESULT= 0 %END; !of OUTCHAR %EXTERNALHALFINTEGERFN OUT FILL (%HALFINTEGER LENGTH, BPTR, WITH) ! ! ! ! ! A Global Procedure to (partially) Fill the Output Buffer ! ! with a Specified Character ! ! ! %HALFINTEGER PTR ; !ptr into IO BUFFER, -the next position to fill %HALFINTEGER PTR MAX; !--a work variable (limit of PTR when filling) %HALFINTEGER FILL LEN; !--a work variable (amount of IO BUFFER to fill) %HALFINTEGER FAULT %IF F_ACCESS ROUTE\= The Console %THENSTART ! ! ! Write to a Record in a File ! ! %UNLESS 0<=BPTR+BPOS<512 %THENSTART ! !Get the relevant (always the next) block: ! A: FAULT= GET BLOCK (BPTR) %UNLESS FAULT=None %THENRESULT=FAULT %FINISH ! ! Determine How Much of the Buffer is Empty ! PTR= BPTR + BPOS FILL LEN= 512 - PTR %IF FILL LEN> LENGTH %THEN FILL LEN=LENGTH ! ! Now Fill the Buffer (as much as reqd/possible) ! PTR MAX= PTR + FILL LEN %WHILE PTR A %FINISHELSESTART ! ! ! Write to the Console ! ! %WHILE LENGTH> 0 %CYCLE ! IO BUFFER(BPTR)= WITH BPTR = BPTR+1 LENGTH = LENGTH-1 %REPEAT %FINISH ! ! Update the Record Length ! %IF BPTR>F_RECORD LEN %THEN %C F_RECORD LEN= BPTR %RESULT=0 %END; !of OUTFILL %EXTERNALHALFINTEGERFN OUT FIELD (%HALFINTEGER LENGTH , %INTEGER FROM ADR, FROM INC, %HALFINTEGER BPTR ) ! ! ! ! ! A Global Procedure to Copy Characters into the Output Buffer ! ! ! %HALFINTEGER BUFF PTR; !ptr into IO BUFFER, -the position to start copying %HALFINTEGER COPY LEN; !len of text to copy into IO BUFFER %HALFINTEGER FAULT %IF F_ACCESS ROUTE\= The Console %THENSTART ! ! ! Write to a Record in a File ! ! %UNLESS 0<=BPTR+BPOS<512 %THENSTART ! !Get the relevant block: ! A: FAULT= GET BLOCK (BPTR) %UNLESS FAULT=None %THENRESULT=FAULT %FINISH ! ! Determine How Much of the Buffer is Empty ! BUFF PTR= BPTR + BPOS COPY LEN= 512 - BUFF PTR %IF COPY LEN> LENGTH %THEN COPY LEN=LENGTH ! ! Now Fill the Buffer (as much as reqd/possible) ! COPY (COPY LEN, FROM ADR, FROM INC , BUFF ADR, BUFF PTR) ! {Check if } FROM INC= FROM INC + COPY LEN { there is} BPTR= BPTR + COPY LEN { more to} LENGTH= LENGTH - COPY LEN { do} ! %UNLESS LENGTH= None %THEN -> A %FINISHELSESTART ! ! ! Write to the Console ! ! COPY (LENGTH,FROM ADR,FROM INC,BUFF ADR,BPTR) BPTR=LENGTH + BPTR %FINISH ! ! Update the Current Record Length ! %IF BPTR>F_RECORD LEN %THEN %C F_RECORD LEN= BPTR %RESULT=0 %END; !of OUTFIELD %EXTERNALHALFINTEGERFN OUTREC ! ! ! ! ! A Global Procedure to Output a Record ! ! to the Current File. ! ! ! %HALFINTEGER FAULT %INTEGER CUR POS {current byte displacement within file} %HALFINTEGER CC ;!%C CC is the 1st character of the logical record %C that is CC is the FORTRAN77 carriage control character %HALFINTEGER FE ;!%C FE is the PERQ Standard equivalent of CC and %C is used when writing to TXT Files %OWNHALFINTEGER CR LF= X'0A0D'; !=Carriage Return - Line Feed Characters ! that are appended onto each logical ! record written to a TXT File. %IF F_ACCESS ROUTE= The Console %THENSTART ! ! ! Output a Logical Record to the Console ! ! CC=IO BUFFER(0) ! ! Examine the Carriage Control Character ! %IF CC='+' %THENSTART PRINT SYMBOL (CR) %AND NL REQD= True ! %FINISHELSESTART %IF CC='1' %THENSTART PRINT SYMBOL (FF) %IF F_RECORD LEN= 1 %THEN NL REQD= False %C %ELSE NL REQD= True %FINISHELSESTART %IF CC='0' %THEN PRINT SYMBOL (LF) ! %UNLESS NL REQD=False %THEN PRINT SYMBOL (LF) %C %ELSE NL REQD= True %FINISH %FINISH ! ! Output the Record ! IO BUFFER(0)=F_RECORD LEN-1 PRINT STRING (STRING(ADDR(IO BUFFER(0)))) %FINISHELSESTART %IF F_ACCESS ROUTE= TXT File %THENSTART ! ! ! Output a Logical Record to a TXT File ! ! %UNLESS 0<=BPOS< 512 %THENSTART ! !Get the block with the 1st character ! FAULT= GET BLOCK ( {with 1st character} 0 ) %RESULT=FAULT %UNLESS FAULT=None %FINISH CC=IO BUFFER(BPOS) ! ! Examine the FORTRAN Carriage Control Character ! %IF CC='1' %THEN FE= FF %ELSEC %IF CC='0' %THEN FE= LF %C %ELSE FE= CR ! IO BUFFER(BPOS)=FE {update CC to a PERQ Standard control character} %IF CC='+' %AND F_CUR POS\=0 %THENSTART ! ! Update the Trailing LF character in last record ! FAULT = OUT CHAR ( CR, -1) %IF FAULT\=None %THENRESULT=FAULT %FINISH ! ! Now Append the CR/LF Characters ! FAULT = OUT FIELD ( 2, ADDR(CR LF), 0, F_RECORD LEN) %IF FAULT\=None %THENRESULT= FAULT ! CUR POS=F_CUR POS %FINISHELSESTART ! ! ! Output a Logical Record to a DTA File ! ! %IF F_RECORD TYPE=Variable %THENSTART ! ! Fill in the Record Header and Trailer (with its length) ! %UNLESS 2<=BPOS< 514 %THENSTART ! FAULT= GET BLOCK (-2) %IF FAULT>None %THENRESULT=FAULT %FINISH; !positioning in front of the current record FAULT= OUT FIELD (2,ADDR(F_RECORD LEN),0,-2) FAULT= OUT FIELD (2,ADDR(F_RECORD LEN),0,F_RECORD LEN) %RESULT= FAULT %IF FAULT\= None ! CUR POS= F_CUR POS + 2{for the record header} %FINISHELSE {for fixed length record} CUR POS=F_CUR POS %FINISH ! ! Write Out the Current Buffer ! FAULT = FILE WRITE (BBLK) %IF FAULT\= None %THENRESULT=FAULT ! ! Tidy Up - update filesize/prepare for next write ! %IF BBLK= 0 %CYCLE {Scan } ! { buffer} %IF IO BUFFER(PTR)= CR %THEN -> FOUND START { for } PTR =PTR-1 { a CR} %REPEAT %UNLESS BBLK=0 %THENSTART {read in the previous block} ! BBLK=BBLK - 1 FAULT=FILE READ (BBLK) %RESULT=FAULT %UNLESS FAULT=None ! PTR=511 %AND -> LOOP %FINISH FOUND START: ! ! Check if at Start of File ! RECSIZE = F_CUR POS -((BBLK*FIVE12) + PTR) %IF RECSIZE\= F_CUR POS %THENSTART ! !We now have to make up our minds whether the CR character found represents ! the start of the previous record or the end of the record before the ! previous one. ! !That is we could have encountered any of the following clusters: ! ! CR/LF/CR -generated ! CR/CR/CR by the ! CR/LF/FF procedure ! CR/LF/LF OUTREC ! CR/LF/xx -generated by the Editor ! CR/xx -generated by somethingelse !So Acquire the Characters on either side of the CR Character ! BPOS=PTR FAULT= IN FIELD ( 3{bytes},{at}-1,ADDR(CCC(0)),0) %RESULT=FAULT %IF FAULT\= None %IF CCC(2)=LF %THEN RECSIZE= RECSIZE-2 %ELSESTART %IF CCC(0)#LF %AND %C CCC(0)#CR %THEN RECSIZE= RECSIZE+1; %FINISH %FINISH %FINISH %FINISH ! ! TIDY UP - PERFORM POSITIONING ! RECSIZE = RECSIZE + 4 %IF F_RECORD TYPE=Variable F_CUR POS = F_CUR POS - RECSIZE F_BLK = F_CUR POS// 512 ! F_LINES IN= F_LINES IN + 1 %AND F_CUR STATE=After Backspace %C %ANDRESULT=0 %END; !of BSP REC %EXTERNALHALFINTEGERFN POSITION DA FILE (%HALFINTEGER ACTION, %INTEGER REC NUMBER) ! ! ! ! ! A Global Procedure used by F77IO to Prepare the Current ! ! File for a Direct-Access File Operation. ! ! !This procedure would be called after NEW FILE OP but before any input ! or output procedure. ! ! ! %INTEGER CUR POS; !the new position within the file ! ! Determine Position Within File ! CUR POS= F_RECSIZE * (REC NUMBER-1) F_CUR POS= CUR POS F_DA RECNUM= REC NUMBER ! ! Prepare the IO BUFFER ! BBLK= CUR POS // 512 F_BLK= BBLK BPOS= CUR POS - (BBLK*FIVE12) ! %IF BBLK<= F_MAX BLK %OR ACTION=Read %THENRESULT=FILE READ(BBLK) %RESULT= 0 %END; !of POSITION DA FILE ! !*********************************************************************** ! ! GLOBAL UTILITY PROCEDURES ! !*********************************************************************** ! %INTEGERMAP FDMAP (%INTEGER DSNUM) ! ! ! ! ! A Utility Procedure which returns a reference to ! ! the File Definition Table which corresponds ! ! to the given channel number. ! ! ! %RESULT=ADDR(FD ADR(DSNUM)) %END; !of FDMAP %INTEGERFN LOCATE FD (%INTEGER DSNUM) ! ! ! ! ! A Procedure to Locate a File Definition Table for a ! ! Unit Number greater than 25. Such an FD Table ! ! is kept in a list ordered on the data-set number. ! ! !At Exit: RESULT=address of the File Definition Table if it was found ! RESULT=0 otherwise, and FD LIST PTR is set to address ! the point at which the scan was terminated ! ! ! %RECORD (File Definition Table) %NAME F ! %INTEGER LAST PTR %INTEGER PTR ! PTR= ADDR(FD LIST LISTHEAD) NEXT: {look at the next} LAST PTR=PTR { list entry} PTR=INTEGER(LAST PTR) { } %UNLESS PTR=Null %THENSTART; F==RECORD(PTR) ! %IF DSNUM= F_DSNUM %THENRESULT=PTR %IF DSNUM> F_DSNUM %THEN -> NEXT %FINISH ! ! Report Unit Unknown ! FD LIST PTR=LAST PTR %ANDRESULT=None ! %END; !of LOCATE FD %EXTERNALINTEGERFN LOCATE FILENAME (%STRINGNAME FULL FILENAME) ! ! ! ! ! A Procedure to Scan the List of Known Filenames for a ! ! given filename which is the full system-dependent ! ! filename. ! ! !At Exit: RESULT=address of the corresponding File Definition Table ! if the file is known ! RESULT=0 otherwise, and FN LIST PTR is set ! to the point at which the scan terminated ! ! ! %RECORD (File Name List Entry) %NAME FN ! %INTEGER LAST PTR %INTEGER PTR ! PTR= ADDR(FILENAME LIST LISTHEAD) NEXT: {look at the next} LAST PTR=PTR { list entry} PTR=INTEGER(LAST PTR) { } %UNLESS PTR=Null %THENSTART; FN==RECORD(PTR) ! %IF FN_ID=FULL FILENAME %THENRESULT= FN_FD ADDR %IF FN_ID NEXT %FINISH ! ! Report File Unknown ! FN LIST PTR=LAST PTR %ANDRESULT=None ! %END; !of LOCATE FILENAME ! !*********************************************************************** ! ! FREE-SPACE DATA AND PROCEDURES ! !*********************************************************************** ! %CONSTHALFINTEGER Maximum Space Reqd= 9 {blocks} %CONSTHALFINTEGER Initial Space Reqd= 2 {blocks} {1 for an I/O Buffer } {1 for FD and FileName Tables} %OWNINTEGER FREE SPACE LISTHEAD %HALFINTEGERFN GET SPACE (%HALFINTEGER SPACE REQD {in bytes}, %INTEGERNAME SPACE GIVEN) ! ! ! ! ! A Utility Procedure to Acquire Space for Either a File ! ! Definition Table or for a FileName List Entry. ! ! !NOTE: Currently the free space is acquired via a call on NEWSEG. ! ! ! At Exit: RESULT = 0 if all is well ! RESULT\= 0 if there is some fault and RESULT=fault ! ! ! %OWNHALFINTEGER WORKSEG SIZE = 0 {blocks}, WORKSEG NUMBER= Not Set ! %INTEGER PTR1; !ptr to previous free space list entry %INTEGER PTR2; !ptr to current free space list entry ! %HALFINTEGER SPACE AVAILABLE ! ! SPACE REQD= (SPACE REQD+1)>> 1 {number of halfwords required} START: {initialise search address} PTR2= ADDR(FREE SPACE LISTHEAD) LOOP: {examine the next } PTR1= PTR2 { list entry} PTR2= INTEGER(PTR1) %UNLESS PTR2= Null %THENSTART ! SPACE AVAILABLE= HALFINTEGER(PTR2+2) - SPACE REQD %UNLESS SPACE AVAILABLE< 0 %THENSTART ! ! Found the Space Required ! %UNLESS SPACE AVAILABLE<20 %THENSTART ! {take the space from } HALFINTEGER(PTR2+2)=SPACE AVAILABLE { the current entry} SPACE GIVEN =SPACE AVAILABLE + PTR2 %FINISHELSESTART ! {else use the current entry } SPACE GIVEN = PTR2 { and accept any fragmenting} INTEGER(PTR1)= INTEGER(PTR2) %FINISH {then return--------------->} %RESULT= 0 ! %FINISH; -> LOOP ;!%C Examine the next entry otherwise %FINISH; !----space not available !----check if we are initialised ! %IF WORKSEG SIZE>= Maximum Space Reqd %THENRESULT= Not Enough Space %UNLESS WORKSEG SIZE = None %THENSTART ! ! Extend the Work-Segment Size ! PTR2 = BUFF ADR + (WORKSEG SIZE<<8) INTEGER(PTR1 )= PTR2 WORKSEG SIZE = WORKSEG SIZE + 1 EXTEND SEG(WORKSEG NUMBER , WORKSEG SIZE) ! INTEGER(PTR2 )= Null HALFINTEGER(PTR2+2)= 256 {halfwords} PTR2=PTR1; -> LOOP ! %FINISH ! ! ! Acquire the Free/Work Space ! ! NEWSEG (WORKSEG NUMBER, Initial Space Reqd , 1 {block extensions}, Maximum Space Reqd ) ! ! Reserve Space for I/O Buffer ! BUFF ADR= INTEGER(ADDR(WORKSEG SIZE)) IO BUFFER == ARRAY(BUFF ADR,FORMAT OF IO BUFFER) ! ! Initialise Rest of Free Space ! FREE SPACE LISTHEAD = BUFF ADR + 256 INTEGER(FREE SPACE LISTHEAD )= Null HALFINTEGER(FREE SPACE LISTHEAD+2)= 256 {halfwords} ! WORKSEG SIZE = 2 {blocks} ! ! Tell F77INIT about CLOSE FILES ! NOMINATE PROC ( 1, CLOSE FILES) -> START %END; !of GET SPACE %ROUTINE RELEASE SPACE (%HALFINTEGER AMOUNT {in bytes} %INTEGER ADDRESS) ! ! ! ! ! A Utility Procedure to Return Space to the Free Space ! ! which was acquired for a File Definition Table or ! ! a FileName List Entry. ! ! !NOTE: The Free Space List is ordered on the space available in ! each list entry. It is hoped that this will reduce the ! effect of any fragmentation that might occur. ! ! ! %INTEGER PTR,PTR1 ! {Initialise Variables} AMOUNT= (AMOUNT+1)>> 1 PTR= ADDR(FREE SPACE LISTHEAD) PTR1=PTR %AND PTR=INTEGER(PTR) %UNTIL PTR=Null %C %OR HALFINTEGER(PTR+2)>=AMOUNT !Locate position in list for the new entry !Insert the new entry into the list ! HALFINTEGER(ADDRESS+2)= AMOUNT INTEGER(ADDRESS )= INTEGER(PTR1) ! INTEGER( PTR1 )= ADDRESS ! %END; !of RELEASE SPACE ! !*********************************************************************** ! ! OPEN AND CLOSE PROCEDURES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFN OPEN FD (%INTEGER DSNUM, RECL, %HALFINTEGER ACCESS, FORM, STATUS, %HALFINTEGER ACCESS ROUTE, BLANKS, %INTEGERNAME AFD , %STRINGNAME FULL FILENAME ) ! ! ! ! ! A Global Utility Procedure to Acquire a File Definition Table ! ! and to Physically Open the Associated File. ! ! !This procedure is used by F77OPEN and PROMPT FILE DEFIN{ITION}. ! ! ! %HALFINTEGER VALID ACTION; !permissible actions to be allowed on a file %HALFINTEGER FAULT ; !--as reported by other procedures %HALFINTEGER OPEN MODE ; !type of open to be performed ! %RECORD (File Definition Table) %NAME F ! ! ! CREATE A FILE DEFINITION TABLE ! ! %IF ACCESS=Direct %OR ACCESS ROUTE = The Console %C %THEN VALID ACTION= Read and Write %C %ELSE VALID ACTION= All FAULT= GET FD (DSNUM,ACCESS,ACCESS ROUTE , VALID ACTION, FULL FILENAME,AFD) %IF FAULT> 0 %THENRESULT=FAULT ! F==RECORD(AFD) ! ! Fill in Other Fields in the File Definition Table ! F_EXISTENCE = STATUS F_F77RECL = RECL ! ! ! NOW (Create and) OPEN THE FILE ! ! %IF ACCESS=Sequential %THEN OPEN MODE= 0 {for any sequential I/O} %C %ELSE OPEN MODE= 4 {for direct-access } FAULT= OPEN (AFD, OPEN MODE) %IF FAULT> 0 %THENRESULT= FAULT ! ! Analyse the Form of the Connection ! %IF F_UFD= Not Set %THENSTART ! ! Set the Form ! F_UFD= Unformatted File + FORM %FINISHELSESTART ! ! Validate the Form ! %IF F_UFD& FORM\= FORM %THENRESULT=Form Not Suitable %FINISH %RESULT=Recl Too Large %IF F_MAXREC< RECL ! ! Return with a new connection ! F_F77BLANK=BLANKS ! %RESULT=0 %END; !of OPEN FD %HALFINTEGERFN OPEN (%INTEGER AFD, %HALFINTEGER OPEN MODE) ! ! ! ! ! A Procedure to Open a File ! ! !-----parameter settings: OPEN MODE= 0 => open for anything sequential ! OPEN MODE= 1 => open for input (and maybe output) ! OPEN MODE= 2 => open for output ! OPEN MODE= 3 => open for append ! OPEN MODE= 4 => open for direct-access ! ! ! %CONSTHALFINTEGERARRAY STATES (0:4)= After Open , After Read , After Write, After Write, After Read; !%C ---the setting of CUR STATE after opening %C the file, dependent upon the value of OPEN MODE %HALFINTEGER I,FAULT,LAST BLK %INTEGER FILE SIZE ! %SWITCH OPEN (Console:DTA File) ! %RECORD (File Definition Table) %NAME F F==RECORD(AFD) -> OPEN (F_ACCESS ROUTE) ! ! CONNECT A UNIT TO THE SCREEN ! OPEN (Console): F_MINREC = 1 F_MAXREC = Screen Width F_MAXREC = 132 %IF F_DSNUM=-2 %ORC F_DSNUM= 6 F_UFD = Formatted File -> RETURN ! ! ! CONNECT A UNIT TO A FILE ! ! OPEN (DTA File): SCRATCH ID= SCRATCH ID + 1 %AND %C F_SCRATCH ID= SCRATCH ID %IF F_EXISTENCE=Scratch OPEN (TXT File): FAULT= FILEOPEN (AFD,OPEN MODE) %RESULT=FAULT %IF FAULT\=None ! ! Analyse Record Length and Record Format ! %IF F_MAXREC> Max Maxrec %THEN FAULT=Record Too Large %AND -> FAIL %IF F_RECORD TYPE\=Fixed %ANDC OPEN MODE = 4 %THEN FAULT=File Unsuitable %AND -> FAIL ! ! Perform File Positioning ! LAST BLK = F_LAST BLK LAST BLK = LAST BLK - 1 %UNLESS LAST BLK=Zero FILE SIZE= (LAST BLK * FIVE12) + F_POS ! %IF OPEN MODE= Write %THEN F_MAX BLK= Zero %AND FILE SIZE=0 %C %ELSE F_MAX BLK= LAST BLK %IF OPEN MODE=Append %THEN F_BLK = LAST BLK %C %AND F_CUR POS= FILE SIZE F_CUR LEN= FILE SIZE ! ! Fill in other File-Specific Values ! F_EXISTENCE=Old %IF F_EXISTENCE = New ! ! Return Triumphant ! RETURN: F_LINES IN = 0 F_LINES OUT= 0 F_STATUS = Opened F_CUR STATE= STATES (OPEN MODE) %RESULT= 0 ! ! Handle a Failure After Open ! FAIL: F_STATUS= Opened ! I=CLOSE (AFD) %RESULT=FAULT ! %END; !of OPEN %HALFINTEGERFN CLOSE (%INTEGER AFD) ! ! ! ! ! A Procedure to Close a File. ! ! ! %HALFINTEGER FAULT %SWITCH CLOSE (The Console:DTA File) ! %RECORD (FileName List Entry ) %NAME FN %RECORD (File Definition Table) %NAME F ! F==RECORD(AFD) %IF AFD=CURRENT FD %THENSTART ! ! Shut-Down the Current File ! %IF F_RECORD LEN\=None %THENSTART ! ! Flush Out the Buffer ! FAULT=OUTREC %IF FAULT>0 %THENRESULT=FAULT %FINISH CURRENT FD=Not Set %FINISH %IF F_STATUS= Opened %THENSTART ! -> CLOSE (F_ACCESS ROUTE) ! ! Close a Screen Connection ! CLOSE (The Console): NEWLINE %AND NL REQD=False %UNLESS NL REQD=False ! -> RELEASE SPACE ! ! Close a File Connection ! CLOSE (TXT File): CLOSE (DTA File): CLOSE FILE : %IF F_MAX BLK= 0 %AND F_POS= 0 %C %THEN F_LAST BLK= 0 %C %ELSE F_LAST BLK=F_MAX BLK+1 FAULT=FILE CLOSE(AFD) !FILE CLOSE will disconnect the file ! will delete the file ! if EXISTENCE= New or Scratch ! %UNLESS FAULT=None %THEN -> RELEASE SPACE %FINISHELSESTART ! ! Handle a File which is not (wholely) Open ! -> CLOSE FILE %IF F_ACCESS ROUTE\=The Console %C %AND F_FILE ID \=Not Set %FINISH FAULT=0 ! ! ! Return Space Occupied by FD and FileName Entry to Free List ! ! RELEASE SPACE: ! %UNLESS F_ID ADDR=Not Set %THENSTART; FN==RECORD(F_ID ADDR) ! ! Remove FileName from FileName List ! INTEGER(FN_LINK+2)=FN_BACK %IF FN_LINK\=Null INTEGER(FN_BACK )=FN_LINK ! ! Return FileName Entry to Free Space ! RELEASE SPACE (LENGTH(FN_ID)+ 14, F_ID ADDR) %FINISH %IF F_DSNUM>25 %THENSTART ! ! Remove File Definition Table from List ! INTEGER(F_LINK+2)= F_BACK %IF F_LINK\=Null INTEGER(F_BACK )= F_LINK %FINISHELSE {zero appropriate FD Table entry} FDMAP(F_DSNUM)= Null !Now Return the Space: ! RELEASE SPACE (Fdsize, AFD) %RESULT= FAULT %END; !of CLOSE %EXTERNALROUTINE CLOSE FILES ! ! ! ! ! A Global Procedure that is called at Program Exit ! ! to Close All Files that are Open. ! ! ! %INTEGER I; %HALFINTEGER J %INTEGER AFD ! ! Close all Units in the Range -2 to 25 ! %FOR I= -2, 1, 25 %CYCLE ! AFD = FD ADR(I) %IF AFD\=Null %THEN J=CLOSE (AFD) ! %REPEAT ! ! Close all Units in the Range 26 to (2**32)-1 ! J= CLOSE (FD LIST %C LIST HEAD) %WHILE FD LIST LISTHEAD\=Null %END; !of CLOSE FILES ! !*********************************************************************** ! ! LOCAL UTILITY PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFN GET FD (%INTEGER DSNUM , %HALFINTEGER ACCESS , ACCESS ROUTE , %HALFINTEGER VALID ACTION , %STRINGNAME ID , %INTEGERNAME AFD) ! ! ! ! ! A Procedure to Create a File Definition Table (and the ! ! associated Filename Entry if required), and to fill ! ! in some basic fields. ! ! ! %HALFINTEGERARRAYNAME TABLE %CONSTHALFINTEGERARRAYFORMAT FORM OF TABLE (1:Fdsize>>1) ! %RECORD (File Definition Table) %NAME F %RECORD (File Name List Entry ) %NAME FN ! %INTEGER FD ADDR {address of the new file definition table} %INTEGER FN ADDR {address of the new filename list entry } %INTEGER I ! ! %RESULT=Not Enough Space %IF GET SPACE (Fd Size,FD ADDR)\= 0 ! F== RECORD (FD ADDR) ! ! Zero Out the FD Table ! TABLE==ARRAY(FD ADDR,FORM OF TABLE) ! %FOR I=1,1,Fdsize>>1 %CYCLE TABLE(I)= Zero %REPEAT %IF DSNUM>25 %THENSTART ! ! Add new FD Table to the List ! F_LINK= INTEGER(FD LIST PTR) {set forward} INTEGER(FD LIST PTR)= FD ADDR { links} F_BACK= FD LIST PTR {set backward} INTEGER( F_LINK +2)= FD ADDR { links} %C %UNLESS F_LINK=Null %FINISH %C %ELSE FD ADR(DSNUM)= FD ADDR %UNLESS ID="" %THENSTART ! ! Now Get a Filename List Entry ! %RESULT=Not Enough Space %C %IF GET SPACE (LENGTH(ID)+14,FN ADDR)\= 0 ! FN==RECORD(FN ADDR) ! ! Add the Entry to the Filename List ! FN_LINK= INTEGER(FN LIST PTR) INTEGER(FN LIST PTR)= FN ADDR FN_BACK= FN LIST PTR INTEGER(FN_LINK +2)= FN ADDR %UNLESS FN_LINK=Null ! ! Complete the Filename List Entry ! FN_FD ADDR= FD ADDR FN_ID = ID ! ! Link the Entry to the File Definition Table ! F_ID ADDR= FN ADDR %FINISH; !%C %ELSE F_ID ADDR= Not Set ! ! Fill in the File Definition Table ! F_DSNUM = DSNUM F_ACCESS TYPE = ACCESS F_ACCESS ROUTE= ACCESS ROUTE F_VALID ACTION= VALID ACTION ! AFD= FD ADDR %RESULT= 0 ! %END; !of GET FD %HALFINTEGERFN DEFINE FD (%INTEGER DSNUM , %HALFINTEGER ACTION, FILE TYPE, %INTEGERNAME FD ADR ) ! ! ! ! ! A Utility Procedure which Locates an External File Definition ! ! and which constructs an appropriate File Defintion Table. ! ! !NOTE: The given channel is assumed not to be defined internally. ! ! ! %HALFINTEGER VALID ACTION %HALFINTEGER FAULT %INTEGER AFD ! %RECORD (File Definition Table) %NAME F %IF DSNUM< 0 %THENSTART ! ! Connect to Console Input or Output ! %IF DSNUM=-1 %THEN VALID ACTION= Read Only %C %ELSE VALID ACTION=Write Only FAULT=GET FD(DSNUM,Sequential,The Console,VALID ACTION,Null Name,AFD) %IF FAULT> 0 %THENRESULT= FAULT ! ! F==RECORD(AFD); F_F77BLANK= 1 {Significant} ! FD ADR=AFD %RESULT=0 %FINISH ! ! ! Prompt for File Definition ! ! NEWLINE %AND NL REQD=False %UNLESS NL REQD=False ! %RESULT= PROMPT FILE DEFIN{ITION} (DSNUM,ACTION,FILE TYPE,FD ADR) %END; !of DEFINE FD ! !*********************************************************************** ! ! FORTRAN77 OPEN, CLOSE, and INQUIRE PROCEDURES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFN F77OPEN (%INTEGER DSNUM , %HALFINTEGER STATUS, ACCESS, %HALFINTEGER FORM, BLANKS, %INTEGER RECL , %STRINGNAME FILE NAME) ! ! ! ! ! THIS IS THE PROCEDURE CALLED BY F77 IO TO PERFORM ! ! THE NECESSARY ACTIONS TO SERVICE AN OPEN ! ! STATEMENT CORRECTLY. ! ! !F77 IO will have validated the specifiers as they relate to each other, !while this procedure validates the request with respect to the current !status of the filestore. If the specified file is not open it will call !OPEN which in turn will call FILEOPEN (which will create the file if !necessary). ! ! ! %RECORD (File Definition Table) %NAME F ! %HALFINTEGER FAULT ; !as reported by this procedure %HALFINTEGER ACCESS ROUTE ; !categorises the file type %INTEGER AFD ; !address of a file definition table ! %STRING(100) FULL FILENAME; !a full system-dependent filename %STRING(100) R ; !a work variable (used in string resolutions) %STRING(15) SUFFIX ; !the suffix associated with FULL FILENAME ! ! First Determine the Type of File Required ! %IF ACCESS=Direct %OR FORM=Unformatted %THEN ACCESS ROUTE= DTA File %C %ELSE ACCESS ROUTE= TXT File %IF FILENAME = The Console Name %THEN ACCESS ROUTE= The Console%C %AND FULL FILENAME= "" %C %ELSESTART %UNLESS FILENAME="" %THENSTART ! ! Analyse the File Suffix ! %IF FILENAME-> R . (".") . SUFFIX %THENSTART ! %IF SUFFIX = "dta" %THEN ACCESS ROUTE= DTA File %C %ELSE %C %IF ACCESS ROUTE= DTA File %C %THENRESULT= File Unsuitable %FINISHELSESTART ! ! Choose a Suitable File Suffix ! FILENAME= FILENAME . ".dta" %C %IF ACCESS ROUTE=DTA File %FINISH FULL FILENAME= SYSTEM FILENAME (FILENAME) %IF FULL FILENAME= "" %THENRESULT= Invalid Filename %FINISHELSE FULL FILENAME= "" {if the FILE= specifier was not given} %FINISH ! ! Check if the Unit is Connected ! %IF DSNUM>25 %THEN AFD=LOCATE FD (DSNUM) %C %ELSE AFD= FDMAP (DSNUM) %UNLESS AFD=Not Set %THENSTART ! ! ! THE UNIT IS ALREADY CONNECTED ! ! F==RECORD(AFD) %IF FILENAME="" %THENSTART ! !"If the FILE= specifier is not included in the OPEN EXTRACT ! statement, the file to be connected to the unit FROM ! is the same as the file to which the unit is ANSI77 ! connected". STANDARD ! !----Check this out: ! %IF STATUS=Scratch %THENSTART ! ! Discontinue the Current Connection ! TERMINATE CONNECTION: FAULT= F77CLOSE (AFD,-1) %IF FAULT= None %THEN -> UNIT NOT CONNECTED %RESULT = FAULT %FINISH STATUS=F_EXISTENCE {if filename was not specified } { and STATUS=UNKNOWN} %FINISHELSESTART ! ! Check if the Connection is to the Specified File ! %IF F_ID ADDR= Not Set %THENSTART ! -> TERMINATE CONNECTION %IF F_ACCESS ROUTE\= The Console %C %OR FILENAME\= The Console Name %FINISHELSESTART ! -> TERMINATE CONNECTION %IF FULL FILENAME\= STRING(F_ID ADDR+6) %FINISH %FINISH !At this point the specified file is already connected to !the unit and hence, because files cannot be preconnected !on PERQs the file exists and hence only the BLANK= !specifier may have a value which differs from the current !connection. ! !--------So Validate the Specifiers: ! %RESULT=Access Conflict %IF F_ACCESS TYPE\=ACCESS %RESULT=Status Conflict %IF STATUS = New %RESULT=Recl Conflict %IF F_F77RECL \=RECL %RESULT=Form Conflict %IF F_UFD&1 \=FORM ! ! Return if the File is already Connected to the Unit ! F_F77BLANK= BLANKS %RESULT= 0 %FINISH ! ! ! THE UNIT IS NOT CONNECTED ! ! UNIT NOT CONNECTED: ! %UNLESS FULL FILENAME="" %THENSTART ! ! Check if the Specified File is Known (internally) ! %RESULT=File Already Connected %C %UNLESS LOCATE FILENAME(FULL FILENAME)=Nil ! ! Check Existence of the Specified File ! %IF FILE EXISTENCE(FULL FILENAME)=False %THENSTART ! %IF STATUS =Old %THENRESULT=File Does Not Exist STATUS =New %FINISHELSESTART; %IF STATUS =New %THENRESULT=File ALready Exists STATUS =Old %FINISH %FINISHELSESTART; !here, the unit is not connected and ! the FILE= specifier wasn't given ! ! STATUS= Scratch ACCESS ROUTE = DTA File %IF ACCESS ROUTE=TXT File %FINISH %RESULT=Recl Too Large %IF RECL>Max Maxrec ! ! ! NOW (Create and) OPEN THE FILE ! ! %RESULT= OPEN FD (DSNUM,RECL,ACCESS,FORM ,STATUS, ACCESS ROUTE,BLANKS,AFD,FULL FILENAME) %END; !of F77OPEN %EXTERNALHALFINTEGERFN F77INQUIRE (%INTEGER DSNUM , %STRINGNAME FILE NAME , %INTEGERNAME ADDR OF VALUES) ! ! ! ! ! THIS IS THE PROCEDURE CALLED BY F77 IO TO PERFORM ! ! THE NECESSARY ACTIONS TO SERVICE AN ! ! INQUIRE STATEMENT CORRECTLY. ! ! THE ACTIONS OF THIS PROCEDURE ARE SYSTEM-DEPENDENT. ! ! !Values for all the possible specifiers of an INQUIRE statement ! are obtained and returned to F77 IO in a word 'array' whose ! entries correspond to a particular specifier. Each entry is ! set as: ! minus one if the value is undefined, or ! the actual value if the specifier is an integer, or ! the address of the value if the specifier is a character ! ! ! %ROUTINESPEC F77 FILE INFO (%INTEGERNAME OPENED, NUMBER, NAMED , NAME , %RECORD (File Definition Table) %NAME F) %ROUTINESPEC GET FILE DETAILS (%STRINGNAME FULL FILENAME , %RECORD (File Definition Table) %NAME F) !CONSTANT VALUES: ! %CONSTSTRING( 7) UNKNOWN STRING= "UNKNOWN" %CONSTSTRING( 2) NO STRING= "NO" %CONSTSTRING( 3) YES STRING= "YES" %CONSTSTRING(10) SEQUENTIAL STRING= "SEQUENTIAL" %CONSTSTRING( 6) DIRECT STRING= "DIRECT" %CONSTSTRING( 9) FORMATTED STRING= "FORMATTED" %CONSTSTRING(11) UNFORMATTED STRING= "UNFORMATTED" %CONSTSTRING( 4) NULL STRING= "NULL" %CONSTSTRING( 4) ZERO STRING= "ZERO" ! ! %OWNINTEGER FORMATTED TEXT, NULL TEXT, UNKNOWN TEXT %OWNINTEGER UNFORMATTED TEXT, ZERO TEXT %OWNINTEGER SEQUENTIAL TEXT, NO TEXT %OWNINTEGER DIRECT TEXT, YES TEXT ! !addresses of the corresponding values given above %OWNHALFINTEGER INQUIRE INITIALISED= False ;!%C INQUIRE INITIALISED= True if above variables have %C been assigned the %C relevant addresses !RESULT VALUES: ! %OWNINTEGER VALUES %OWNINTEGER EXIST ; !The %OWNINTEGER OPENED ; ! address %OWNINTEGER NUMBER ; ! %OWNINTEGER NAMED ; ! of these %OWNINTEGER NAME ; ! %OWNINTEGER ACCESS ; ! variables is %OWNINTEGER SEQUENTIAL; ! %OWNINTEGER DIRECT ; ! returned %OWNINTEGER FORM ; ! %OWNINTEGER FORMATTED; ! to F77 IO %OWNINTEGER UNFORMATTED; ! %OWNINTEGER RECL ; ! (thus %OWNINTEGER NEXT REC ; ! the order %OWNINTEGER BLANK ; ! given is %OWNINTEGER FILE TYPE; ! important) %OWNINTEGER NREC %INTEGERARRAYNAME RESULTS {mapped onto result } %CONSTINTEGERARRAYFORMAT FORM OF RESULTS { values above} %C ( 0:16) %STRING(100) FULL FILENAME !LOCAL VARIABLES: ! %INTEGER AFD ; !FD Table address if unit/file is connected %HALFINTEGER F77 UFD ; !Copy of System File Details %INTEGER I ; !Work variable ! %RECORD (File Definition Table) %NAME F %RECORD (File Definition Table) FD TABLE %IF INQUIRE INITIALISED=False %THENSTART ! ! ! Initialise variables with constant values ! ! UNKNOWN TEXT= ADDR( UNKNOWN STRING) NO TEXT= ADDR( NO STRING) YES TEXT= ADDR( YES STRING) SEQUENTIAL TEXT= ADDR( SEQUENTIAL STRING) DIRECT TEXT= ADDR( DIRECT STRING) UNFORMATTED TEXT= ADDR(UNFORMATTED STRING) FORMATTED TEXT= ADDR( FORMATTED STRING) NULL TEXT= ADDR( NULL STRING) ZERO TEXT= ADDR( ZERO STRING) ! INQUIRE INITIALISED= True %FINISH ! ! Initialise values to be returned to F77 IO ! RESULTS== ARRAY(ADDR(VALUES),FORM OF RESULTS) ! %FOR I=0,1,16 %CYCLE; !set EXIST ! ; ! through to RESULTS(I)= -1; ! FILETYPE to %REPEAT ; ! Undefined {ie minus 1} %IF DSNUM>=0 %THENSTART ! ! ! Perform Inquire by Unit specific valuation ! ! EXIST= True %IF DSNUM> 25 %THEN AFD= LOCATE FD (DSNUM) %C %ELSE AFD= FDMAP (DSNUM) !check if the unit is connected ! OPENED=False %AND -> RETURN %IF AFD=None; !connection does not exist ! ! Evaluate the name of the connected file ! F==RECORD(AFD) F77 FILE INFO (OPENED,NUMBER,NAMED,NAME,F) %FINISHELSESTART ! ! ! Perform Inquire by File specific valuation ! ! FULL FILENAME= SYSTEM FILENAME(FILE NAME) ; !get the full %IF FULL FILENAME= "" %THENRESULT= Invalid Filename; ! system filename ! AFD= LOCATE FILENAME (FULL FILENAME) ; !and see if its known %IF AFD= None %THENSTART ! ! Check existence of file which is not connected ! OPENED=False EXIST =False %AND -> RETURN %C %IF FILE EXISTENCE(FULL FILENAME)=False ! EXIST =True; !if file exists ! and address acquired file characteristics ! F==FD TABLE GET FILE DETAILS (FULL FILENAME,F) ! NAMED=True NAME =ADDR(FULL FILENAME) %FINISHELSESTART ! ! Check properties of a file which is connected ! F==RECORD(AFD) F77 FILE INFO( OPENED,NUMBER,NAMED,NAME,F) ! !get the value of OPENED,NUMBER,NAMED,NAME %FINISH ! %FINISH; !At this point either the specified unit is connected ! or the specified file exists ! ! ! Perform Unit Connected or File Exists Valuation ! ! F77 UFD=F_UFD %IF F77 UFD= Not Set %THEN UNFORMATTED=UNKNOWN TEXT %C %AND FORMATTED=UNKNOWN TEXT %C %ELSESTART ! ! Examine the FORM of the records ! %IF F77 UFD&Formatted Bit=False %C %THEN FORMATTED= NO TEXT %C %AND UNFORMATTED=YES TEXT %C %ELSE UNFORMATTED= NO TEXT %C %AND FORMATTED=YES TEXT %FINISH ! ! Examine Permissible Access Methods ! %IF F_ACCESS TYPE=Sq Mode %THENSTART; !the connection is sequential ! %IF F_ACCESS ROUTE\= DTA File %OR %C F_EXISTENCE = Scratch %OR %C F_RECORD TYPE \= Fixed %THEN DIRECT= NO TEXT %C %ELSE DIRECT= YES TEXT SEQUENTIAL = YES TEXT %FINISHELSESTART; DIRECT = YES TEXT {the connection is Direct-Access} ! %IF F_EXISTENCE = Scratch %THEN SEQUENTIAL= NO TEXT %C %ELSE SEQUENTIAL=YES TEXT %FINISH ! If the unit or the file are connected %C then FORM %C RECL %C ACCESS %C BLANK %C and NEXTREC may become defined -> RETURN %IF OPENED=False ! ! Define the ACCESS= Specifier ! %IF F_ACCESS TYPE=Sq Mode %THEN ACCESS= SEQUENTIAL TEXT %C %ELSESTART; ACCESS= DIRECT TEXT ! ! Define RECL and NEXTREC ! RECL= F_F77RECL NEXTREC= F_DARECNUM NEXTREC= 1 %IF NEXTREC=NOT SET %FINISH ! ! Define the FORM= Specifier ! %IF F_UFD & FORMATTED BIT=False %THEN FORM=UNFORMATTED TEXT %C %C %ELSESTART ! FORM=FORMATTED TEXT ! ! Define the BLANK= Specifier ! %IF F_F77BLANK=0 %THEN BLANK=NULL TEXT %C %ELSE BLANK=ZERO TEXT %FINISH RETURN: ! ! ! RETURN ALL THE ACQUIRED VALUES BACK TO F77 IO ! ! ADDR OF VALUES=ADDR(VALUES) %RESULT= 0 %ROUTINE F77 FILE INFO (%INTEGERNAME OPENED, NUMBER, NAMED , NAME , %RECORD (File Definition Table) %NAME F) ! ! ! ! ! A local procedure for F77INQUIRE which examines whether a ! ! file connected with a given File Definition Table exists, ! ! that is whether STATUS=OLD may be specified in an OPEN statement. ! ! This routine may be used for Inquire by Unit or by Inquire by File. ! ! !The various parameters are set as follows: ! !As the file is connected then OPENED=true !As the file is connected then NUMBER=unit number !As the file exists then NAMED=true if the file is not a workfile !As the file exists then NAME=A(filename) if the file is not a workfile ! ! ! NUMBER= F_DSNUM OPENED= True EXIST= True ! ! Check if a Temporary File ! %IF F_ACCESS ROUTE=The Console %OR %C F_EXISTENCE = Scratch %THEN NAMED=False %ANDRETURN ! ! Handle a Permanent File ! NAMED= True NAME =F_ID ADDR+6 ! %END; !of F77 FILE INFO %ROUTINE GET FILE DETAILS (%STRINGNAME FULL FILENAME , %RECORD (File Definition Table) %NAME F ) ! ! ! ! ! A local procedure for F77INQUIRE which fills in a given ! ! file definition table with details of a given filename. ! ! !It is assumed that the given file is not currently connected. ! ! ! %HALFINTEGER FAULT; !work %STRING(100) S ; ! variables !Initialise Fields in the File Definition Table: ! F_EXISTENCE = Old {always} ! F_ACCESS TYPE= Sq Mode {always} %IF FULL FILENAME-> S . (".dta") %THENSTART ! ! Get Details of a DTA File ! F_ACCESS ROUTE = DTA File; F_ID ADDR= ADDR(FULL FILENAME)-6 ! FAULT = FILE OPEN (ADDR(F),0) FAULT = FILE CLOSE (ADDR(F) ) %FINISHELSESTART ! ! Set Details for a TXT File ! F_ACCESS ROUTE= TXT File ! F_RECORD TYPE = Formless F_UFD = Formatted File %FINISH %END; !of GET FILE DETAILS %END; !of F77INQUIRE %EXTERNALHALFINTEGERFN F77CLOSE (%INTEGER DSNUM, %HALFINTEGER STATUS) ! ! ! ! ! THIS IS THE PROCEDURE CALLED BY F77 IO TO PERFORM ! ! THE NECESSARY ACTIONS TO SERVICE A CLOSE ! ! STATEMENT CORRECTLY. ! ! !This procedure may be called by F77OPEN to terminate a connection !when a unit to be connected is connected to another file. ! ! !The steps performed by this procedure are: ! ! (i). locate the File Definition Table, ! (ii). validate the STATUS parameter ! (iii). call the procedure CLOSE ! ! !The values taken by the parameter STATUS may be one of: ! %CONSTHALFINTEGER Not Specified= 0 %CONSTHALFINTEGER Delete = 1 %CONSTHALFINTEGER Keep = 2 ! %RECORD (File Definition Table) %NAME F %INTEGER AFD ! ! %IF STATUS< 0 %THEN AFD=DSNUM %AND STATUS=Not Specified %C {ie F77CLOSE has been called from F77OPEN} %C %C %ELSESTART %IF DSNUM>25 %THEN AFD= LOCATE FD (DSNUM) %C %ELSE AFD= FDMAP (DSNUM) ! %IF AFD=None %THENRESULT= 0 {=> unit is not connected} %FINISH F== RECORD(AFD) {=>unit is connected} %IF F_EXISTENCE=Scratch %THENSTART ! ! Validate the STATUS Specifier ! %IF STATUS=Keep %THENRESULT=Invalid Status %FINISHELSESTART ! ! Check for STATUS=DELETE ! F_EXISTENCE=New %IF STATUS=Delete %FINISH ! ! ! Physically Close the File ! ! %RESULT= CLOSE (AFD) ! CLOSE will empty any associated output buffer ! will physically close the file ! will return the File Definition Table to free space ! will delete the file if so indicated ! will return any FileName List Entry to free space ! %END; !of F77CLOSE !* top !**************************************************** !* * !* Fortran77 FILE IO interface to Perq system. * !* * !**************************************************** %externalhalfintegerfnspec createfile(%integer namead) %externalroutinespec read block(%halfinteger fileid,block, %integer bufad) %externalhalfintegerfnspec close file(%halfinteger fileid,blocks,bits) %externalhalfintegerfnspec destroyfile(%string(100) s) %externalroutinespec writeblock(%halfinteger fileid,block,%integer ad) %externalhalfintegerfnspec open file(%integer adfilename,block,bit) %externalroutinespec extend file name(%integer namead,%halfinteger flag) %externalhalfintegerfnspec filelookup(%string(100) filename,%halfintegername blocks,bits) !---------------------------------------- ! File Definition Table Format !---------------------------------------- !%include "ercs03.fdtable" !--------------------------------------- ! F77 Data file header format !--------------------------------------- %recordformat data file header( %c %string(17) title, {"FORTRAN DATA FILE"} %halfinteger type, {Record type, 0=V,1=F} reclen, {Record length} ufd, {Record form} version {of file format}) !---------- ! OWNS !---------- %ownrecord(file definition table) %name FD !----------------- ! SUBROUTINES !----------------- %string(16) %map scratchname {generate a scratch file name of form} { "SCRATCH"."nn" and maybe .".dta"} %ownstring(16) name="f77_scratchx.dta" byteinteger(addr(name)+6)=FD_scratch id %result== name %end !-------------------- ! FILE OPEN !-------------------- %halfintegerfn FILE OPEN (%integer Afd,%halfinteger Mode) ! Mode 1 = Open for input. ! 2 = Open for output. ! 4 = Open for direct access. %record (data file header) %name FH %halfintegerarray buf(0:255) %halfinteger blocks,bits {---- Create file if neccesary ----} FD == record(Afd) %if FD_existence = 1 %start {scratch file} FD_file id = create file(addr(scratchname)) %Finishelseif FD_existence=2 %thenstart FD_file id = createfile(FD_id addr + 6) {Permanent file} %if FD_file id = 0 %thenresult=System Open Failure {Note: fileid=0 implies failed to create} %finish blocks=0 ; bits=0 {---- Open the File ----} %if FD_existence=3 %then FD_file id= Open file(FD_id addr+6,addr(blocks),addr(bits)) %if FD_access route = 1 %start {Txt type file} FD_minrec=1 FD_maxrec= Max Maxrec FD_lastblk=blocks FD_pos=bits>>3 FD_ufd=x'49' {formatted IO} FD_record type=0 {variable} %finishelsestart { DTA type file} %if FD_existence=3 %Start { An existing DTA file } FD_last blk=blocks-1 FD_pos = bits>>3 readblock(FD_fileid,0,addr(buf(0))) FH == record(addr(buf(0))) %result=System Open Failure %unless FH_title="FORTRAN DATA FILE" FD_ufd = FH_ufd FD_record type = FH_type %if FD_record type =1 %start {fixed} FD_recsize= FH_reclen FD_minrec = FH_reclen FD_maxrec = FH_reclen %Finishelsestart {Variable } FD_minrec=1 FD_maxrec= Max Maxrec %finish %finishelsestart { New DTA file} FD_ufd=0 %if FD_access type = 1 %start {direct access} FD_record type = 1 FD_minrec=FD_f77recl FD_recsize=FD_f77recl FD_maxrec = FD_f77recl %Finishelsestart {Sequential access} FD_minrec=1 FD_maxrec= Max Maxrec FD_record type=Variable %finish FD_flags=2 %finish %finish %unless FD_existence=Old %then FD_last blk=0 %result=0 %end !--------------------- ! FILE CLOSE !--------------------- %halfintegerfn FILE CLOSE (%integer afd) %halfintegerarray buf(0:255) %halfinteger blocks,i %record (data file header) %name FH FD == record(afd) %if FD_existence=3 %and FD_access route = 2 %Start {Old DTA file, to be kept} %if FD_flags#0 %Start FH==record(addr(buf(0))) %if FD_flags=1 %then %start {Update header} read block(FD_file id,0,addr(buf(0))) FH_ufd=FD_ufd %finishelsestart {Create new header} buf(i)=0 %for i=0,1,255 FH_version= 1 FH_ufd=FD_ufd FH_type = FD_record type FH_reclen = FD_maxrec FH_title="FORTRAN DATA FILE" %Finish write block(FD_file id,0,addr(buf(0))) %finish %finish blocks = FD_last blk %if FD_access route = 2 {DTA} %then blocks = blocks + 1 i=Close file(FD_file id,blocks,FD_pos<<3) %if FD_existence=1 %start i=destroy file(system filename(scratchname)) %finish%elsec %if FD_existence=2 %then i=destroy file(string(FD_id addr+6)) %result=0 %end !-------------------- ! FILE WRITE !-------------------- %halfintegerfn FILE WRITE (%halfinteger Block number) Block number= Block number+1 %if F_Access Route=DTA File write block(F_file id,Block number,Buff Adr) %result=0 {No failures are returned by POS to write block} %end !------------------------- ! SYSTEM FILE NAME !------------------------- %string(100) %fn SYSTEM FILE NAME (%stringname filename) %string(100) s s = filename extend file name(addr(s),0) %result = s %end !------------------- ! FILE READ !------------------- %halfintegerfn FILE READ (%halfinteger Block number) Block number= Block number+1 %if F_Access Route=DTA File readblock(F_file id, Block number, Buff Adr) %result=0 {No failures are returned by POS to read block} %end !------------------------ ! FILE EXISTENCE !------------------------ %externalhalfintegerfn FILE EXISTENCE (%stringname Full filename) %halfinteger blocks,bits,fileid fileid = File look up(full filename,blocks,bits) %if fileid=0 %then %result=0 %else %result=1 {0 = file not found} %end %ENDOFFILE