Trailing-Edge
-
PDP-10 Archives
-
msv11ck
-
10,7/mail/mx/mxufil.bli
There are 7 other files named mxufil.bli in the archive. Click here to see a list.
MODULE mxfil (
IDENT = 'X03.09'
) =
BEGIN
!
! COPYRIGHT (c) 1984 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! Facility: MX file system interface.
!
! Abstract:
!
! This module provides a common interface for file system access.
!
! Environment: User Mode on TOPS-20, TOPS-10
!
! Author: Richard B. Waddington October 3, 1984
!
!--
!
! Include files:
!
%IF %SWITCHES(TOPS20) %THEN
LIBRARY 'bli:monsym';
LIBRARY 'mxjlnk';
%FI
LIBRARY 'mxnlib'; ! Get all required definitions
LIBRARY 'mxlib';
!
! Table of contents
!
SWITCHES LIST (REQUIRE); ! Allow listing of specific code
FORWARD ROUTINE
mx$file_initialize : NOVALUE, ! Initialize file interface
mx$file_open, ! open file for access
mx$file_read,
mx$file_write,
mx$file_seek,
mx$file_size,
seek_file,
mx$file_close,
%IF $tops10 %THEN
mx$file_build_buffers,
mx$file_kill_buffers: NOVALUE,
filpar,
%FI
!
! System specific routines.
!
alloc_buffer,
dealloc_buffer : NOVALUE,
open_file,
map_page,
%IF $tops20 %THEN
unmap_page,
%FI
close_file;
%module_name ('MXFIL');
!
! Own storage:
!
OWN
file_table: INITIAL (0) ; ! Base address of file table data base
!
! External references:
!
EXTERNAL
%debug_data_base;
EXTERNAL ROUTINE
mx$error_processor,
nmu$text,
nmu$table_routines,
nmu$memory_manager;
%global_routine ('MX$FILE_DELETE', spec) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(gtjfn,delf);
REGISTER
t = 1;
IF .spec EQL 0
THEN
RETURN 0;
IF .spec<18,18,0> EQL 0
THEN
spec = CH$PTR(.spec);
IF $$gtjfn(gj_sht OR gj_old, .spec;t)
THEN
$$delf(df_exp OR .t<0,18,0>);
RETURN 0;
%ELSE
STACKLOCAL
flpblk: BLOCK[$fofsp+1] FIELD (filop_block_fields)
INITIAL(REP $fofsp+1 OF (0)),
lkpblk: BLOCK[$rbtim+1] FIELD (lookup_block_fields)
INITIAL (REP $rbtim+1 OF (0)),
pthblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0));
IF .spec EQL 0
THEN
RETURN 0;
IF .spec<18,18,0> EQL 0
THEN
spec = CH$PTR(.spec);
flpblk [filop_flags] = fo$prv OR fo$asc OR $fodlt;
flpblk [filop_open_flags] = $ioasc;
flpblk [filop_device] = %SIXBIT'DSK ';
flpblk [filop_lookup_pointer] = lkpblk;
lkpblk [lookup_path] = pthblk;
IF NOT filpar(.spec,flpblk,lkpblk,pthblk)
THEN
RETURN $false;
BEGIN
BUILTIN UUO;
REGISTER t;
LOCAL
scratch,
value;
set_in_your_behalf(flpblk,lkpblk);
t = ($fofsp+1)^18 + flpblk; !Do the delete...
value = UUO(1,filop$(t));
scratch = .flpblk[filop_channel]^18 + $forel; !Release the channel
t = 1^18 + scratch;
UUO(1,filop$(t));
RETURN .value
END
%FI
END;
%global_routine('MX$FILE_SET_WRITER', spcptr, namptr): NOVALUE =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
LOCAL
jfn;
declare_jsys(gtjfn,sfust,rljfn);
IF $$gtjfn(gj_old OR gj_sht, .spcptr; jfn)
THEN
BEGIN
$$sfust($sflwr^18 OR .jfn, .namptr);
$$rljfn(.jfn);
RETURN 0
END;
RETURN -2;
%ELSE
! Not needed on TOPS-10 (?)
RETURN -2 %FI
END;
%global_routine('MX$FILE_SIZE', spec_, pages_, bytes_) =
BEGIN
BIND
pages = .pages_,
bytes = .bytes_;
%IF %SWITCHES(TOPS20) %THEN
LOCAL
jfn;
declare_jsys(gtjfn,sizef,rljfn);
IF $$gtjfn(gj_old OR gj_sht, CH$PTR(.spec_);jfn)
THEN
BEGIN
$$sizef(;,bytes);
$$rljfn(.jfn);
pages = .bytes/(512*5) + 1;
RETURN 0
END;
RETURN -2;
%ELSE
LOCAL
error,
eop,
buffer: REF VECTOR;
STACKLOCAL
flpblk: BLOCK[$fofsp+1] FIELD (filop_block_fields)
INITIAL(REP $fofsp+1 OF (0)),
tmpblk: BLOCK[4] FIELD (lookup_block_fields)
INITIAL (REP 4 OF (0)),
lkpblk: BLOCK[$rbtim+1] FIELD (extended_lookup_block_fields)
INITIAL (REP $rbtim+1 OF (0)),
pthblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0));
flpblk [filop_flags] = fo$prv OR fo$asc OR $fored;
flpblk [filop_open_flags] = $iodmp;
flpblk [filop_device] = %SIXBIT'DSK ';
flpblk [filop_lookup_pointer] = lkpblk;
lkpblk [exlookup_count] = $rbtim+1;
tmpblk [lookup_path] = pthblk;
IF .spec_ EQL 0
THEN
RETURN 0;
IF .spec_<18,18,0> EQL 0
THEN
spec_ = CH$PTR(.spec_);
IF NOT filpar(.spec_,flpblk,tmpblk,pthblk)
THEN
RETURN $false;
lkpblk[exlookup_name] = .tmpblk[lookup_name];
lkpblk[exlookup_ext] = .tmpblk[lookup_ext];
lkpblk[exlookup_ppn] = .tmpblk[lookup_ppn];
BEGIN
BUILTIN UUO;
REGISTER t;
LOCAL
scratch,
value,
last_word,
iolist: vector[2];
set_in_your_behalf(flpblk,lkpblk);
t = ($fofsp+1)^18 + flpblk; !Do the lookup
IF UUO(1,filop$(t))
THEN
BEGIN
scratch = .lkpblk[$rbsiz,wrd] - 1; !zero based address of last word in file
flpblk[filop_function] = $fousi; !set file to
flpblk[1,wrd] = .scratch<7,28,0> + 1; !last block number
t = 2^18 + flpblk;
value = .value OR UUO(1,filop$(t)); !do the USETI
buffer = nmu$memory_get(128); !allocate a buffer
iolist[0] = (-128)^18 OR (.buffer-1);
iolist[1] = 0;
flpblk[filop_function] = $foinp;
flpblk[1,wrd] = iolist;
t = 2^18 OR flpblk;
UUO(1,filop$(t));
last_word = .buffer[.scratch<0,7,0>] AND (NOT 1);
nmu$memory_release(.buffer,128);
eop = 0;
WHILE (.last_word NEQ 0) DO
BEGIN
last_word = .last_word ^ 7;
eop = .eop + 1;
END;
bytes = .eop + (5*.scratch);
pages = (.bytes+(128*5)-1)/(128*5);
scratch = .flpblk[filop_channel]^18 + $forel; !Release the channel
t = 1^18 + scratch;
UUO(1,filop$(t));
RETURN $true
END
ELSE
BEGIN
$error(FACILITY=$internal, !Oh well, try again later
SEVERITY=$warning,
CODE=uf$len,
MESSAGE_DATA=CH$PTR(.spec_),
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
RETURN $false
END;
END %FI
END;
%global_routine('MX$FILE_EXISTS', ptr) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
LOCAL
jfn;
declare_jsys(gtjfn,rljfn);
$TRACE('MX$FILE_EXISTS called');
IF $$gtjfn(gj_old OR gj_sht, .ptr)
THEN
BEGIN
$$rljfn();
RETURN 1
END;
RETURN 0;
%ELSE
STACKLOCAL
flpblk: BLOCK[$fofsp+1] FIELD (filop_block_fields)
INITIAL(REP $fofsp+1 OF (0)),
lkpblk: BLOCK[$rbtim+1] FIELD (lookup_block_fields)
INITIAL (REP $rbtim+1 OF (0)),
pthblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0));
IF .ptr EQL 0
THEN
RETURN 0;
IF .ptr<18,18,0> EQL 0
THEN
ptr = CH$PTR(.ptr);
flpblk [filop_flags] = fo$prv OR fo$asc OR $fored;
flpblk [filop_open_flags] = $ioasc;
flpblk [filop_device] = %SIXBIT'DSK ';
flpblk [filop_lookup_pointer] = lkpblk;
lkpblk [lookup_path] = pthblk;
IF NOT filpar(.ptr,flpblk,lkpblk,pthblk)
THEN
RETURN $false;
BEGIN
BUILTIN UUO;
REGISTER t;
LOCAL
scratch,
value;
set_in_your_behalf(flpblk,lkpblk);
t = ($fofsp+1)^18 + flpblk; !Do the delete...
value = UUO(1,filop$(t));
scratch = .flpblk[filop_channel]^18 + $forel; !Release the channel
t = 1^18 + scratch;
UUO(1,filop$(t));
RETURN .value
END
%FI
END;
%global_routine('MX$FILE_COPY',src,dst)=
BEGIN
STACKLOCAL
buffer: VECTOR[CH$ALLOCATION(132)];
LOCAL
ifil,
ofil,
len,
error;
ifil = mx$file_open(.src, FILE_ACCESS_READ_ONLY, error);
IF .ifil LEQ 0
THEN
BEGIN
$error(FACILITY=$internal,
SEVERITY=$warning,
CODE=uf$fof,
MESSAGE_DATA=.src,
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
RETURN $false;
END;
ofil = mx$file_open(.dst, FILE_ACCESS_WRITE_ONLY, error);
IF .ofil LEQ 0
THEN
BEGIN
$error(FACILITY=$internal,
SEVERITY=$warning,
CODE=uf$fof,
MESSAGE_DATA=.dst,
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
mx$file_close(.ifil, file_abort, error);
RETURN $false;
END;
WHILE (len = mx$file_read(.ifil, CH$PTR(buffer), 132, error)) GTR 0 DO
BEGIN
IF NOT mx$file_write(.ofil, CH$PTR(buffer), .len, error)
THEN
BEGIN
$error(FACILITY=$internal,
SEVERITY=$warning,
CODE=uf$fwf,
MESSAGE_DATA=.dst,
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
mx$file_close(.ifil, file_abort, error);
RETURN $false;
END;
END;
IF .len NEQ 0
THEN
BEGIN
$error(FACILITY=$internal,
SEVERITY=$warning,
CODE=uf$frf,
MESSAGE_DATA=.dst,
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
mx$file_close(.ofil, file_abort, error);
RETURN $false;
END;
IF NOT mx$file_close(.ofil, file_keep, error)
THEN
BEGIN
$error(FACILITY=$internal,
SEVERITY=$warning,
CODE=uf$fcf,
MESSAGE_DATA=.dst,
OPTIONAL_MESSAGE=$error_code,
OPTIONAL_DATA=.error);
mx$file_close(.ifil, file_abort, error);
RETURN $false;
END;
mx$file_close(.ifil, file_abort, error);
RETURN $true
END;
%global_routine('MX$FILE_WRITTEN_DATE', ptr) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
DECLARE_JSYS(gtjfn,gtfdb,rljfn);
LOCAL
date;
date = 0;
IF mx$file_exists(.ptr)
THEN
BEGIN
REGISTER
jfn;
$$gtjfn(gj_old OR gj_sht, .ptr; jfn);
$$gtfdb(.jfn, 1^18 + $fbcre, date);
$$rljfn(.jfn);
END;
RETURN .date;
%ELSE
STACKLOCAL
flpblk: BLOCK[$fofsp+1] FIELD (filop_block_fields)
INITIAL(REP $fofsp+1 OF (0)),
tmpblk: BLOCK[4] FIELD (lookup_block_fields)
INITIAL (REP 4 OF (0)),
lkpblk: BLOCK[$rbtim+1] FIELD (extended_lookup_block_fields)
INITIAL (REP $rbtim+1 OF (0)),
pthblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0));
flpblk [filop_flags] = fo$prv OR fo$asc OR $fored;
flpblk [filop_open_flags] = $ioasc;
flpblk [filop_device] = %SIXBIT'DSK ';
flpblk [filop_lookup_pointer] = lkpblk;
lkpblk [exlookup_count] = $rbtim+1;
tmpblk [lookup_path] = pthblk;
IF NOT filpar(.ptr,flpblk,tmpblk,pthblk)
THEN
RETURN $false;
lkpblk[exlookup_name] = .tmpblk[lookup_name];
lkpblk[exlookup_ext] = .tmpblk[lookup_ext];
lkpblk[exlookup_ppn] = .tmpblk[lookup_ppn];
BEGIN
BUILTIN UUO;
REGISTER t;
LOCAL
scratch,
value;
set_in_your_behalf(flpblk,lkpblk);
t = ($fofsp+1)^18 + flpblk; !Do the lookup
value = UUO(1,filop$(t));
scratch = .flpblk[filop_channel]^18 + $forel; !Release the channel
t = 1^18 + scratch;
UUO(1,filop$(t));
RETURN (IF .value THEN .lkpblk[exlookup_create_udt]
ELSE $false)
END
%FI
END;
%global_routine('MX$FILE_RENAME', ptr1, ptr2) =
BEGIN
%IF %SWITCHES(TOPS20) %THEN
declare_jsys(gtjfn,rnamf,rljfn);
REGISTER
jfn1,
jfn2;
$$gtjfn(gj_old OR gj_sht, .ptr1; jfn1);
$$gtjfn(gj_fou OR gj_sht, .ptr2; jfn2);
IF $$rnamf(.jfn1,.jfn2)
THEN
BEGIN
$$rljfn(.jfn2);
RETURN 1
END
ELSE
BEGIN
$$rljfn(.jfn1);
$$rljfn(.jfn2);
RETURN 0
END
%ELSE
BUILTIN UUO;
STACKLOCAL
flpblk: BLOCK[$fofsp+1] FIELD (filop_block_fields)
INITIAL(REP $fofsp+1 OF (0)),
lkpblk: BLOCK[4] FIELD (lookup_block_fields)
INITIAL (REP 4 OF (0)),
renblk: BLOCK[4] FIELD (lookup_block_fields)
INITIAL (REP 4 OF (0)),
ptlblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0)),
ptrblk: BLOCK[$ptmax] FIELD (path_block_fields)
INITIAL (REP $ptmax OF (0));
flpblk [filop_flags] = fo$prv OR fo$asc OR $fornm;
flpblk [filop_open_flags] = $ioasc;
flpblk [filop_device] = %SIXBIT'DSK ';
flpblk [filop_lookup_pointer] = lkpblk;
flpblk [filop_rename_pointer] = renblk;
lkpblk [lookup_path] = ptlblk;
renblk [lookup_path] = ptrblk;
IF NOT filpar(.ptr1,flpblk,lkpblk,ptlblk)
THEN
RETURN $false;
IF NOT filpar(.ptr2,flpblk,renblk,ptrblk)
THEN
RETURN $false;
BEGIN
REGISTER t;
LOCAL
scratch,
value;
WHILE $true DO
BEGIN
set_in_your_behalf(flpblk,lkpblk);
t = ($fofsp+1)^18 + flpblk;
IF (value = UUO(1,filop$(t)))
THEN
EXITLOOP
ELSE
IF .t EQL eraef_
THEN
(IF NOT mx$file_delete(.ptr2)
THEN
EXITLOOP)
ELSE
RETURN $false;
END;
scratch = .flpblk[filop_channel]^18 + $forel;
t = 1^18 + scratch;
UUO(1,filop$(t));
RETURN .value
END
! mx$file_copy(.ptr1,.ptr2);
! mx$file_delete(.ptr1)
%FI
END;
%global_routine ('MX$FILE_INITIALIZE') : NOVALUE =
!++
! Functional description:
!
! Initializes the file system at start up or restart time.
! The internal file table data base is cleared and reset to
! an initial state.
!
! Formal parameters: none
! Implicit inputs: none
!
! Routine value: none
! Side effects: none
!
!--
BEGIN
nmu$table_clear (file_table) ;
%debug (FILE_TRACE,
(TRACE_INFO ('File system interface initialized')));
END; ! END of MX$FILE_INITIALIZE
%global_routine ('MX$FILE_OPEN', FILE_NAME, ACCESS, ERROR) =
!++
! Functional description:
!
! This routine opens a local file. The ACCESS specifies
! the accessing technique. The file is assumed to be a 7-bit
! ASCII stream file. If the file can not be opened, an error
! code is returned in ERROR.
!
! Formal parameters:
!
! .FILE_NAME Pointer to file spec string (ASCIZ)
! .ACCESS READ_ACCESS
! WRITE_ACCESS
! APPEND_ACCESS
! .ERROR Address to return error code in
!
! Implicit inputs: none
!
! Routine value:
!
! gtr 0 File identifier to be used on any future reference
! leq 0 Error occured while opening file
!
! Side effects: none
!
!--
BEGIN
LOCAL
fn: file_name_block,
file : REF file_data_block,
file_id;
$TRACE('Opening %A',.file_name);
!
! Allocate a file block and fill it in with known information.
!
file = nmu$memory_get (file_data_block_allocation);
file [fd_access] = .access ;
file [fd_byte_size] = 7;
file [fd_error] = 0;
fn[fn_pointer] =.file_name;
fn[fn_length] = CH$LENGTH(.file_name);
%IF $tops20
%THEN
CH$COPY (.fn[fn_length], .fn[fn_pointer], 0,
MIN ((.fn[fn_length] + 1), (max_file_name_length + 1)),
CH$PTR (file [fd_name]));
%FI
!
! Initialize the buffer ring. It is now a ring of 1 item.
!
file [fd_current_buffer] = 0;
alloc_buffer (.file);
!
! Open the file
!
file [fd_length] = 0;
IF NOT open_file (.file, fn)
THEN
BEGIN
dealloc_buffer (.file);
nmu$memory_release (.file, file_data_block_allocation);
.error = .file [fd_error];
file_id = 0;
RETURN .file_id;
END;
!
! Initialize the user's position in the file.
! Initialize MX$FILE's position in the file.
! Indicate that no seeks have been done yet.
!
file [fd_current_position] = 0;
file [fd_file_position] = 0;
%IF $tops20 %THEN ! I have to roll my own APPEND on TOPS-20...
IF .access EQL file_access_append_only
THEN
IF NOT seek_file( .file, .file [fd_length], .error)
THEN
RETURN 0;
%FI
!
! Insert file block into the file table data base and return the
! index into the data base
!
file_id = nmu$table_insert (file_table, .file);
%debug (FILE_TRACE,
(TRACE_INFO ('File id %O assigned to FD block at %O',
.FILE_ID,
.FILE)));
RETURN .file_id
END; ! End of MX$FILE_OPEN
%global_routine ('MX$FILE_READ', FILE_ID, DEST_PTR, MAX_BYTES, ERROR) =
!++
! Functional description:
!
! This routine reads a line of text, of maximum length specified
! by caller, from a file into callers buffer. The actual number
! of bytes read is returned to caller.
!
! Formal parameters:
!
! .FILE_ID File identifier
! .DEST_PTR Pointer to buffer to receive the file data
! .MAX_BYTES The maximum number of bytes to transfer
! .ERROR Pointer to error message buffer
!
! Implicit inputs: none
!
! Routine value:
!
! gtr 0 Number of bytes actually read from file
! eql 0 End of file encountered
! lss 0 Error occured while reading file:
! -1 Fatal I/O error of some sort
!
! Side effects: none
!
!--
BEGIN
BIND
crlf_pointer = CH$PTR(UPLIT(%CHAR(%O'15',%O'12')));
OWN
file : REF file_data_block,
xfr_count,
eol_pointer,
done,
move_count;
%debug (FILE_TRACE,
(TRACE_INFO ('File id %O read request for %D bytes',
.FILE_ID,
.MAX_BYTES)));
!
! Setup the file data base pointer
!
IF NOT nmu$table_fetch (file_table, .file_id, file)
THEN
BEGIN
%debug (FILE_TRACE,
(TRACE_INFO ('Table lookup of FD for FILE_ID %O failed',
.FILE_ID)));
.error = uf$tlf;
RETURN -1
END;
done = $false;
xfr_count = 0;
DO
BEGIN
BIND
buffer = (file [fd_current_buffer]): REF buffer_data_block;
IF NOT .buffer [bd_valid]
THEN
IF NOT map_page (.file)
THEN
BEGIN
.error = .file [fd_error];
RETURN -1;
END;
move_count = MIN( .buffer [bd_remaining_count], .max_bytes );
eol_pointer = CH$FIND_SUB( .move_count, .buffer [bd_pointer],
2, crlf_pointer);
IF CH$FAIL (.eol_pointer)
THEN
BEGIN
IF .file [fd_length] EQL 0
THEN
move_count = 0
ELSE
IF CH$RCHAR(.buffer [bd_pointer]) EQL 0
THEN
move_count = 0;
IF (.buffer [bd_end_of_file] OR
(.buffer [bd_remaining_count] GEQ .max_bytes))
THEN
done = $true
ELSE
buffer [bd_valid] = $false;
END
ELSE
BEGIN
move_count = CH$DIFF(.eol_pointer, .buffer [bd_pointer]) + 2 ;
done = $true;
END;
transfer_bytes(.move_count, buffer [bd_pointer], dest_ptr);
xfr_count = .xfr_count + .move_count;
max_bytes = .max_bytes - .move_count;
END
UNTIL .done;
RETURN .xfr_count
END; ! End of MX$FILE_READ
%global_routine ('MX$FILE_WRITE', FILE_ID, SOURCE_PTR, WRITE_COUNT, ERROR) =
!++
! Functional description:
!
! Writes a byte stream, of length specified by caller, into a file.
!
! Formal parameters:
!
! .FILE_ID File identifier
! .WRITE_COUNT Number of bytes to write to the file
! .SOURCE_PTR Pointer to byte string to be written to file
! .ERROR The address to return the error code in.
!
! Implicit inputs: none
!
! Routine value:
!
! $true if data was written successfully to file
! $false otherwise
!
! Side effects: none
!
!--
BEGIN
LOCAL
file : REF file_data_block,
move_count,
space_in_buffer;
%debug (FILE_TRACE,
(TRACE_INFO ('Write request on file id %O, %D bytes',
.FILE_ID,
.WRITE_COUNT)));
!
! Setup pointer to file data base
!
IF NOT nmu$table_fetch (file_table, .file_id, file)
THEN
BEGIN
%debug (FILE_TRACE,
(TRACE_INFO ('Table lookup of FD for FILE_ID %O failed',
.FILE_ID)));
.error = uf$tlf;
RETURN $false
END;
DO
BEGIN
BIND
buffer = (file [fd_current_buffer]): REF buffer_data_block;
IF NOT .buffer [bd_valid]
THEN
IF NOT map_page (.file)
THEN
BEGIN
.error = .file [fd_error];
RETURN $false;
END;
space_in_buffer =
%IF $tops20 %THEN
bytes_per_page - .buffer [bd_current_position];
%ELSE
.buffer [bd_remaining_count];
%FI
IF .space_in_buffer LSS .write_count
THEN
buffer [bd_valid] = $false;
move_count = MIN(.space_in_buffer, .write_count);
write_count = .write_count - .move_count;
transfer_bytes(.move_count, source_ptr, buffer [bd_pointer]);
END
UNTIL .write_count LEQ 0;
file [fd_length] = MAX( .file [fd_length], .file [fd_current_position]);
RETURN $true
END; ! End of MX$FILE_WRITE
%global_routine ('MX$FILE_SEEK', FILE_ID, BYTE_POSITION, ERROR) =
!++
! Functional description:
!
! Sets the current position within a file to an arbitrary
! byte position. Subsequent reads or writes will begin at
! the new byte position within the file.
!
! Formal parameters:
!
! .FILE_ID File identifier
! .BYTE_POSITION The byte offset at which the file is to positioned
!
! Implicit inputs: none
!
! Routine value:
!
! $true File positioned successfully
! $false Invalid ID or failure during seek
!
! Side effects: none
!
!--
BEGIN
LOCAL
file : REF file_data_block;
%debug (FILE_TRACE,
(TRACE_INFO ('File id %O seek request to byte position %D',
.FILE_ID,
.BYTE_POSITION)));
!
! Setup pointer to file data base
!
IF NOT nmu$table_fetch (file_table, .file_id, file)
THEN
BEGIN
%debug (FILE_TRACE,
(TRACE_INFO ('Table lookup of FD for FILE_ID %O failed',
.FILE_ID)));
.error = uf$tlf;
RETURN -1
END;
IF NOT seek_file (.file, .byte_position, .error)
THEN
RETURN $false;
RETURN $true
END; ! End of MX$FILE_SEEK
%routine ('SEEK_FILE', FILE: ref FILE_DATA_BLOCK, BYTE_POSITION, ERROR) =
!++
! Functional Description:
!
! Sets the current position within a file to an arbitrary
! byte position. Subsequent reads or writes will begin at
! the new byte position within the file.
!
! Formal Parameters:
!
! .FILE File Data Block
! .BYTE_POSITION The byte offset at which the file is to be positioned.
! .ERROR The address to return the error code in.
!
! Implicit Imputs: none
!
! Routine Value:
!
! $TRUE File positioned successfully.
! $FALSE Invalid ID or failure during seek.
!
! Side effects: none
!
!--
BEGIN
!
! Set current byte position within file.
!
file [fd_current_position] = .byte_position;
%IF $tops20 %THEN
BEGIN
BIND
buffer = (.file [fd_current_buffer]): REF buffer_data_block;
IF .file [fd_access] EQL file_access_append_only
THEN
IF .file [fd_append_in_progress]
THEN
BEGIN
.error = uf$ifa;
RETURN $false;
END
ELSE
file [fd_append_in_progress] = $true;
IF .buffer [bd_valid]
THEN
IF NOT ((.byte_position GEQ .buffer [bd_file_position]) AND
(.byte_position LSS
(.buffer [bd_file_position] + .buffer [bd_length])))
THEN
buffer [bd_valid] = $false;
END;
%FI
%debug (FILE_TRACE,
(local
CP;
CP = .FILE [FD_CURRENT_POSITION];
TRACE_INFO ('File at byte position %D',
.CP)));
RETURN $true;
END; ! End of SEEK_FILE
%global_routine ('MX$FILE_CLOSE', FILE_ID, ABORT, ERROR) =
!++
! Functional description:
!
! Closes a file and invalidates further access. Resources are
! released and any buffered data is written to file. If ABORT
! is set to 1, then the file is not updated. *** WARNING ***
! ABORT = 1 does not work on TOPS-10 for APPEND mode access!
! If ABORT is set to 2, then the file is deleted...
!
! Formal parameters:
!
! .FILE_ID File identifier
! .ABORT 0 to keep, 1 to abort any changes
! .RSP_PTR Pointer to NICE response buffer
!
! Implicit inputs: none
!
! Routine value:
!
! $true File closed successfully
! $false Invalid file id or unable to close file
!
! Side effects: none
!
!--
BEGIN
LOCAL
file : REF file_data_block;
%debug (FILE_TRACE,
(TRACE_INFO ('File id %O close requested',
.FILE_ID,)));
!
! Setup pointer to file data base
!
IF NOT nmu$table_fetch (file_table, .file_id, file)
THEN
BEGIN
%debug (FILE_TRACE,
(TRACE_INFO ('Table lookup of FD for FILE_ID %O failed',
.FILE_ID)));
.error = uf$tlf;
RETURN $false
END;
!
! Set up and maintain the address of the current BD block
! for the file.
!
BEGIN
!
! Perform actions necessary to close the file.
!
$TRACE('Closing %A',CH$PTR(file[fd_name]));
%IF $tops20 %THEN
unmap_page (.file);
%FI
IF .abort EQL file_abort
THEN
file [fd_abort] = 1;
IF .abort EQL file_delete
THEN
file [fd_delete] = 1;
IF NOT close_file (.file)
THEN
BEGIN
.error = .file [fd_error];
RETURN $false;
END;
!
! Deallocate all storage associated with the file.
! Delete FD from table. Release storage for FD.
!
nmu$table_delete (file_table, .file_id);
dealloc_buffer (.file);
nmu$memory_release (.file, file_data_block_allocation);
%IF NOT $tops10 %THEN
%debug (FILE_TRACE,
(TRACE_INFO ('File on JFN %O closed',
.FILE [FD_JFN])));
%FI
%IF $tops10 %THEN
%debug (FILE_TRACE,
(TRACE_INFO ('File on channel %O closed',
.FILE [FD_CHANNEL])));
%FI
END; ! End buffer context
RETURN $true
END; ! End of MX$FILE_CLOSE
%IF $tops20 %THEN
REQUIRE 'newt20'
%ELSE
REQUIRE 'newt10'
%FI ;
END
ELUDOM