module reread (ident = '01') = 
begin

!++
! 
! This module contains the routines for implementing the FORTRAN reread
! statement. 
!
! The routine FOR$IO_END, which is called to run down all FORTRAN I/O 
! operations is patched to put the address of the current RMS buffer and
! length into global variables REREAD_BUFADR and REREAD_BUFLEN. To implement
! rereading, the user calls REREAD, passing the logical unit to implement
! rereading on. A mailbox is created, and opened on that logical unit.
! A read attention AST is maintained on that mailbox. In order to effect
! a reread operation, the user merely issues a FORTRAN read on that logical
! unit. An AST routine gains control, obtains the unformatted input from the
! RMS buffer and moves it to the mailbox. The user's FORTRAN read then 
! obtains this buffer through the mailbox.
!
! To use this routine, the user must link to the objects for reread
! as well as sys$library:starlet/lib.
! The maximum buffer that can be reread is max_length bytes 
! (larger buffers are truncated).
!
! Neal Lippman, October, 1980
!
!--

library 'sys$library:lib';

literal
    max_length=512;		!maximum buffer size we can reread

global
    reread_bufadr,		!addr of last string read
    reread_buflen;		!length last read

own
    mbox_chan 	: word;		!channel of mailbox

external
    reread_canerr	: addressing_mode(long_relative),!error cancelling I/O on channel
    reread_astset	: addressing_mode(long_relative),!error setting ast on mailbox
    reread_transerr	: addressing_mode(long_relative),!error moving text to mailbox
    reread_jpierr	: addressing_mode(long_relative),!error on getjpi
    reread_mbxcre	: addressing_mode(long_relative);!error creating mbox

forward routine
    create_mbox	: novalue,
    ast_handle	: novalue,
    ast_set	: novalue,
    length,
    cancel_io	: novalue;

global routine create_mbox (desc_addr) : novalue =
begin

!++
!
! This routine creates the mailbox for the reread operation, and returns
! its logical name (character*19) to the caller.
!
!--

bind
    desc   = .desc_addr : vector[,long],	!descriptor
    len    = desc 	: vector[,word],	!length
    string = .(desc+4),				!string addr
    log	   = uplit byte('_REREAD');		!part of log name for mbox

local 
    istat;

own
    lognam      : vector[63,byte],
    lognam_desc : vector[2,long] initial(0,lognam),
    username    : vector[13,byte]
    			initial(
    				rep 13 of byte(%c' ')),
    jpi_buf     : vector[4,long]
    			initial(
        			word(12,jpi$_username),
        			username,
        			0,
        			0);

istat = $getjpi(			!get username
    		itmlst=jpi_buf
    		);
if .istat neq ss$_normal then $exit(code = reread_jpierr);

ch$move((istat=length(username)),
    	username,
    	lognam);

ch$move(7,
    	log,
    	lognam+.istat);

lognam_desc[0] = .istat + 7;

ch$move(.lognam_desc[0],
    	lognam,
    	string);

len[0] = .lognam_desc[0];


istat = $crembx(			!create the mbox
    		prmflg=0,		!temporary
    		chan=mbox_chan,		!channel address
    		maxmsg=max_length,	!maximum message size
    		bufquo=max_length,	!only allow one message at a time
    		lognam=lognam_desc	!logical name
    		);
if .istat neq ss$_normal then $exit(code = reread_mbxcre);

return
end;


global routine ast_handle : novalue = 
begin

!++
!
! Transfer data from RMS buffer to mailbox.
!
!--

local
    istat;


istat = $qiow(				!move the text to the mbox
    		chan=.mbox_chan,	!channel
    		func=io$_writevblk or io$m_now, !write function, no wait
    		p1=.reread_bufadr,	!address of RMS buffer
    		p2=			!size of buffer
    			(if .reread_buflen gtr max_length
    			then
    				max_length
    			else
    				.reread_buflen)
    		);

if .istat neq ss$_normal then $exit(code = reread_transerr);

ast_set();

return
end;


global routine ast_set : novalue =
begin


!++
!
! Set the read attention AST on the mailbox.
!
!--

local
    istat;

istat = $qiow(
    		chan=.mbox_chan,	!channel
    		func=io$_setmode or io$m_readattn, !attention function code
    		p1=ast_handle		!AST routine
    		);

if .istat neq ss$_normal then $exit(code = reread_astset);

return
end;

routine length (string_addr) = 
begin

!++
!
! This routine returns the length of a string in a buffer...There must
! be at least one blank at the end of the string, or it will crap out
! badly (infinite loop style).
!
!--

bind
    string	= .string_addr : vector[,byte];

local
    i : signed;

i = -1;

while 1 do 
    if .string[i=.i+1] eql %c' ' then 
    	return .i;

0
end;

global routine cancel_io : novalue =
begin

!++
!
! This routine cancels outstanding I/O on the mailbox channel.
!
!--

local
    istat;

istat = $cancel(			!cancel I/O on the channel
    		chan=.mbox_chan		!channel number
    		);
if .istat neq ss$_normal then $exit(code=reread_canerr);

return
end;


end
eludom