home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
intel86.tar.gz
/
intel86.tar
/
kersys.p86
< prev
next >
Wrap
Text File
|
1986-06-06
|
37KB
|
1,047 lines
$large ram
Kermit$sys: do;
/*
* K e r m i t File Transfer Utility
*
* iRMX-86 Kermit, Version 2.3
* by Albert J. Goodman, Grinnell College
*
* System-dependent interface and utility procedures module.
* Edit date: 2-June-1985
*/
/* Define the iRMX-86 operating system interface */
/* Define the exception codes we use */
declare
E$OK literally '0000h',
E$FNEXIST literally '0021h', /* non-existent file */
E$FACCESS literally '0026h', /* file access not granted */
E$FTYPE literally '0027h', /* bad file type */
E$CONTINUED literally '0083h'; /* continued command line */
/* Define the system type TOKEN */
$include(:I:LTKSEL.LIT)
/* Include external definitions for the iRMX-86 system calls we use */
$include(:I:HSNCOR.EXT)
$include(:I:HFMTEX.EXT)
$include(:I:HGTICN.EXT)
$include(:I:HCRCCN.EXT)
$include(:I:HSNCMD.EXT)
$include(:I:HGTCMD.EXT)
$include(:I:IEXIOJ.EXT)
$include(:I:ISATFL.EXT)
$include(:I:ISCRFL.EXT)
$include(:I:ISOPEN.EXT)
$include(:I:ISSPEC.EXT)
$include(:I:ISRDMV.EXT)
$include(:I:ISWRMV.EXT)
$include(:I:ISCLOS.EXT)
$include(:I:ISDLCN.EXT)
$include(:I:NSTEXH.EXT)
$include(:I:NCRSEM.EXT)
$include(:I:NDSABL.EXT)
$include(:I:NENABL.EXT)
declare
/* CONSTANTS */
/* Useful text substitutions */
boolean literally 'byte', /* define a new type */
TRUE literally '0FFh', /* and constants */
FALSE literally '000h', /* of that type */
/* ASCII control character constants */
CTRL$C literally '03h', /* CTRL/C */
HT literally '09h', /* horizontal tab */
LF literally '0Ah', /* line-feed */
CR literally '0Dh', /* carriage-return */
/* Hardware port addresses for our system */
T0$data$port literally '0D8h', /* T0 data port */
T0$status$port literally '0DAh', /* T0 status port */
base$port literally '030h', /* Base port for 534 board */
/* Encoded interrupt levels which we might have to disable */
level$534 literally '038h', /* 534-board interrupt level */
level$T0$in literally '068h', /* T0 (system console) input */
level$T0$out literally '078h', /* & output interrupt levels */
/* String constants */
file$list$name(*) byte data( 20, ':WORK:KERMITFLST.TMP' ),
/* GET$CONSOLE$CHAR and GET$REMOTE$CHAR return codes */
TIMEOUT literally '0FFFFh', /* Time limit expired */
CTRL$C$CODE literally '08003h', /* CTRL/C abort */
BREAK literally '08000h', /* Break key */
/* READ$CHAR return code */
EOF$CODE literally '0FF00h', /* end-of-file */
/* GLOBAL VARIABLES */
/* Tokens (what the system uses to identify objects) */
cur$file token public, /* Connection to the current file */
comm$conn token, /* token for our command connection */
file$list token, /* Connection to the file containg a filename list */
/* Port addresses */
console$data$port word, /* Data port of the console (usually T0) */
console$status$port word, /* Status port of the console */
remote$data$port word, /* Data port of T3 (on 534-board) */
remote$status$port word, /* Status port of T3 (on 534-board) */
/* Flag affecting all console output */
communicating boolean initial( FALSE ),
/* Whether we're communicating, i.e. console interrupts are disabled */
/* Buffers */
com$line structure( /* The buffer for the command line */
len byte,
ch(80) byte) public;
/* External procedures defined in KERMIT$UTIL */
get$filespec: procedure( keyword$num, info$ptr ) external;
declare
keyword$num byte,
info$ptr pointer;
end get$filespec;
upcase: procedure( x ) byte external;
declare
x byte;
end upcase;
/*
*
* Hardware port communication routines.
*
*/
console$char$available: procedure boolean;
/*
* Return TRUE if there is a character available
* at the console port.
*/
if ( ( input( console$status$port ) AND 02h ) = 0 ) then
return( FALSE );
else
return( TRUE );
end console$char$available;
get$console$char: procedure( time$limit ) word public;
/*
* Return the next character from the console, waiting until
* a character is available or until approximately TIME$LIMIT
* seconds have elapsed, whichever comes first. If the
* break key is pressed when this routine is first called,
* it will return the constant BREAK (which is not a character
* because it is larger than 0FFh). If not, the break key
* is not checked for while waiting out a time limit. If the
* time limit expires before any key is pressed, the constant
* TIMEOUT (which also is larger than 0FFh) is returned.
* If TIME$LIMIT is zero it will return immediately, with a
* character if one was waiting or else with TIMEOUT. If
* TIME$LIMIT = 0FFFFh it is taken to be infinite, i.e. TIMEOUT
* will never be returned. This procedure assumes that
* interrupts from the console are disabled.
*/
declare
( time$limit, i, j ) word;
if ( ( input( console$status$port ) AND 40h ) <> 0 ) then
return( BREAK ); /* The break key was pressed */
if ( time$limit = 0 ) then
do;
if ( console$char$available ) then
return( input( console$data$port ) );
else
return( TIMEOUT );
end;
else if ( time$limit = 0FFFFh ) then
do;
do while ( not console$char$available );
/* just wait for a character */
end;
return( input( console$data$port ) );
end;
else
do;
do i = 1 to time$limit;
do j = 1 to 1000;
if ( console$char$available ) then
return( input( console$data$port ) );
else
call time( 9 ); /* wait about a millisecond */
end;
end;
return( TIMEOUT );
end;
end get$console$char;
xmit$console$char: procedure( ch ) public;
/*
* Send character CH to the console.
*/
declare
ch byte;
do while ( ( input( console$status$port ) AND 01h ) = 0 );
/* Wait for TxRDY (transmitter ready) */
end;
output( console$data$port ) = ch;
end xmit$console$char;
select$data$block: procedure;
/*
* Select the 534-board "data block" ports.
* This must be done once before accessing the
* USART status and data ports.
*/
output( base$port + 0Dh ) = 0;
end select$data$block;
remote$char$available: procedure boolean;
/*
* Return TRUE if there is a character available
* at the remote port.
*/
if ( ( input( remote$status$port ) AND 02h ) = 0 ) then
return( FALSE );
else
return( TRUE );
end remote$char$available;
get$remote$char: procedure( time$limit ) word public;
/*
* Return the next character from the remote port, waiting until
* a character is available or until approximately TIME$LIMIT
* seconds have elapsed, whichever comes first. If the time
* limit expires first, the constant TIMEOUT (which cannot be
* a character because it is larger than 0FFh) is returned.
* If TIME$LIMIT is zero it will return immediately, with a
* character if one was waiting or else with TIMEOUT. If
* TIME$LIMIT = 0FFFFh it is taken to be infinite. If a key
* is pressed on the console while this procedure is waiting
* for a remote character it will stop waiting; it will return
* CTRL$C$CODE (which also cannot be a character since it too
* is larger than 0FFh) if the key pressed was CTRL/C; otherwise
* it will simply return TIMEOUT. This procedure assumes
* that interrupts from both the console and the remote port
* are disabled.
*/
declare
( time$limit, i, j ) word;
if ( time$limit = 0 ) then
do;
if ( remote$char$available ) then
return( input( remote$data$port ) );
else
return( TIMEOUT );
end;
else if ( time$limit = 0FFFFh ) then
do;
do while ( not remote$char$available );
if ( console$char$available ) then
do;
if ( input( console$data$port ) = CTRL$C ) then
return( CTRL$C$CODE );
else
return( TIMEOUT );
end;
end;
return( input( remote$data$port ) );
end;
else
do;
do i = 1 to time$limit;
do j = 1 to 1000;
if ( remote$char$available ) then
return( input( remote$data$port ) );
else if ( console$char$available ) then
do;
if ( input( console$data$port ) = CTRL$C ) then
return( CTRL$C$CODE );
else
return( TIMEOUT );
end;
else
call time( 9 ); /* wait about a millisecond */
end;
end;
return( TIMEOUT );
end;
end get$remote$char;
xmit$remote$char: procedure( ch ) public;
/*
* Send character CH out to the remote port.
*/
declare
ch byte;
do while ( ( input( remote$status$port ) AND 01h ) = 0 );
/* Wait for TxRDY (transmitter ready) */
end;
output( remote$data$port ) = ch;
end xmit$remote$char;
xmit$break: procedure public;
/*
* Send a hardware break signal to the remote port.
*/
do while ( ( input( remote$status$port ) AND 01h ) = 0 );
/* Wait for TxRDY (transmitter ready) */
end;
output( remote$status$port ) = 03Dh;
call time( 5000 ); /* Wait about half a second */
output( remote$status$port ) = 035h;
end xmit$break;
/*
*
* System-dependent utility procedures used by Kermit.
*
*/
print: procedure( string$ptr ) public;
/*
* Print the string pointed to by STRING$PTR on the console.
* A string consists of a length byte followed by the specified
* number of characters (bytes).
*/
declare
string$ptr pointer,
status word,
string based string$ptr structure(
len byte,
ch(1) byte),
i byte;
if ( communicating ) then /* we must send it directly to the ports */
do;
if ( string.len > 0 ) then /* there are some characters */
do i = 0 to ( string.len - 1 );
call xmit$console$char( string.ch( i ) );
end;
end;
else /* we can use a system call */
call rq$c$send$co$response( 0, 0, string$ptr, @status );
end print;
new$line: procedure public;
/*
* Get the cursor to a new line on the console (i.e. print CR/LF).
*/
call print( @( 2,CR,LF ) );
end new$line;
print$char: procedure( char ) public;
/*
* Print the character CHAR on the console.
*/
declare
char byte,
string structure(
len byte,
ch byte);
if ( communicating ) then /* just send it to the hardware ports */
call xmit$console$char( char );
else
do; /* Form a one-character string and then print it */
string.ch = char;
string.len = 1;
call print( @string );
end;
end print$char;
setup$for$communication: procedure public;
/*
* This procedure does the setup to prepare for
* communication by Kermit. It disables interrupts
* from the remote port and the console and then
* initializes the ports.
*/
declare
i byte,
status word;
communicating = TRUE; /* flag that we are now communicating */
/* Disable the 534-board's interrupt level */
call rq$disable( level$534, @status );
/* Disable the console's interrupt levels too */
if ( console$data$port = T0$data$port ) then /* the console is T0 */
do; /* disable T0's interrupt levels */
call rq$disable( level$T0$in, @status );
call rq$disable( level$T0$out, @status );
end;
/* Otherwise the console is T4 which is on the 534-board and so its */
/* interrupts have already been disabled above */
/* Next, initialize T3, the port to the remote system */
output( base$port + 0Ch ) = 0; /* select control block */
/* put counter 2 in mode 3 (for baud-rate generator) */
output( base$port + 3 ) = 0B6h;
/* load count of 32 to get 2400 baud */
output( base$port + 2 ) = 32; /* LSB of count */
output( base$port + 2 ) = 0; /* and MSB */
remote$data$port = base$port + 4; /* for T3 */
remote$status$port = remote$data$port + 1;
call select$data$block;
do i = 1 to 4; /* Send USART 2 four zeros */
output( remote$status$port ) = 0; /* to get it into a known state */
call time( 1 ); /* Give the USART time to recover between writes */
end;
/* Now reset the USART (USART 2 = port T3) */
output( remote$status$port ) = 40h;
call time( 1 ); /* Give the USART time to recover between writes */
/* Send it a mode instruction: 1 stop bit, no parity, 8 bits, */
output( remote$status$port ) = 4Eh; /* and baud rate factor of X16 */
call time( 1 ); /* Give the USART time to recover between writes */
/* And a standard command instruction: set RTS, error reset, and */
output( remote$status$port ) = 35h; /* enable both receive and transmit */
/* We know the console has been initialized by the system */
/* So just give it a standard command instruction */
output( console$status$port ) = 35h;
end setup$for$communication;
finish$communication: procedure public;
/*
* This procedure finishes communication by
* re-enabling the interrupt level(s) disabled
* by SETUP$FOR$COMMUNICATION (above).
*/
declare
status word;
/* Re-enable the 534-board's interrupt level */
call rq$enable( level$534, @status );
/* Re-enable the console's interrupt levels too */
if ( console$data$port = T0$data$port ) then /* the console is T0 */
do; /* Re-enable T0's interrupt levels */
call rq$enable( level$T0$in, @status );
call rq$enable( level$T0$out, @status );
end;
/* Otherwise the console is T4 which is on the 534-board and so its */
/* interrupts have already been re-enabled above */
communicating = FALSE; /* we are no longer communicating */
end finish$communication;
exit$program: procedure public;
/*
* Exit from the program, i.e. return to the operating system.
* This procedure does not return to the calling routine.
*/
declare
status word;
call new$line; /* make sure the cursor's on a new line */
if ( communicating ) then /* make sure to restore interrupts */
call finish$communication;
call rq$exit$io$job( 0, 0, @status );
end exit$program;
disp$excep: procedure( excep$code );
/*
* Display the exception code and associated mnemonic (error
* message) on the console. (Does not include any CRLFs.)
*/
declare
( excep$code, status ) word,
string$buffer structure(
len byte,
ch(40) byte);
string$buffer.len = 0; /* Init to null string */
/* Get the exception code and mnemonic */
call rq$c$format$exception( @string$buffer, size(string$buffer),
excep$code, 1, @status );
call print( @string$buffer ); /* Display the exception message */
end disp$excep;
check$status: procedure( status );
/*
* Check the exception code returned by a system call to the
* variable STATUS. If it is not E$OK, display the exception code
* and mnemonic at the console and abort the program.
*/
declare
status word;
if ( status <> E$OK ) then
do; /* Handle an exceptional condition */
call new$line; /* Make sure we're at the start of a line */
call disp$excep( status ); /* Display the error message */
call print( @( 18,', program aborted.' ) ); /* And what we're doing */
call new$line;
/* And abort the program. */
call exit$program;
end; /* if ( status <> E$OK ) */
end check$status;
disable$exception$handler: procedure;
/*
* Disable the default exception handler, to prevent it from gaining
* control and aborting the program as soon as any exception occurs.
*/
declare
status word,
exception$handler$info structure(
offset word,
base word,
mode byte);
exception$handler$info.offset = 0;
exception$handler$info.base = 0;
exception$handler$info.mode = 0; /* Never pass control to EH */
call rq$set$exception$handler( @exception$handler$info, @status );
call check$status( status );
end disable$exception$handler;
setup: procedure public;
/*
* This procedure does the system-dependent setup
* which must be done when the Kermit program
* is first started.
*/
declare
status word,
console token,
cc$sema4 token,
buffer structure(
len byte,
ch(5) byte),
signal$pair structure(
semaphore token,
character byte);
/* First, disable the system's exception handler */
call disable$exception$handler;
/* Next, determine what ports to use for the console */
call rq$c$send$co$response( @buffer, size( buffer ),
@( 37,'Are you at the system console <yes>? ' ), @status );
call check$status( status );
if ( buffer.len > 0 ) and ( upcase( buffer.ch(0) ) = 'N' ) then
do; /* They said no, so assume they're at T4 */
console$data$port = base$port + 6; /* for T4 */
console$status$port = console$data$port + 1;
end;
else
do; /* Otherwise they're at T0 (the system console) */
console$data$port = T0$data$port;
console$status$port = T0$status$port;
end;
call new$line; /* Leave a blank line below that question */
/* Now get a connection to the console */
console = rq$s$attach$file( @( 4,':CO:' ), @status );
call check$status( status );
/* Open it for both reading and writing */
/* (specify zero buffers for interactive use) */
call rq$s$open( console, 3, 0, @status );
call check$status( status );
/* Create a command connection, using the console for :CI: and :CO: */
comm$conn = rq$c$create$command$connection( console, console, 0, @status );
call check$status( status );
/* Prevent a CTRL/C typed on the console from aborting the program */
/* Create a semaphore to receive a unit when a CTRL/C is pressed */
cc$sema4 = rq$create$semaphore( 0, 1, 0, @status );
call check$status( status );
/* Associate CTRL/C from the console with our semaphore */
signal$pair.semaphore = cc$sema4;
signal$pair.character = CTRL$C;
call rq$s$special( console, 6, @signal$pair, 0, @status );
call check$status( status );
end setup;
read$char: procedure( file ) word public;
/*
* Return the next character from the file specified
* by FILE (which must be a connection open for reading).
* Returns the constant EOF$CODE (which cannot be a character
* because it is larger than 0FFh) if the file pointer is
* at end-of-file.
*/
declare
file token,
( bytes$read, status ) word,
ch byte;
/* Read the next byte from the file */
bytes$read = rq$s$read$move( file, @ch, 1, @status );
call check$status( status );
if ( bytes$read = 0 ) then /* we ran into end-of-file */
return( EOF$CODE ); /* so signal that */
else /* we got a character */
return( ch ); /* so return it */
end read$char;
get$next$file$name: procedure( info$ptr ) public;
/*
* Place the name of the next file to be sent into the buffer
* pointed to by INFO$PTR. This assumes that GET$FIRST$FILE$NAME
* has previously been called. When there are no more filenames,
* the buffer receives a null string (length zero).
*/
declare
info$ptr pointer,
( ch, status ) word,
info based info$ptr structure(
len byte,
ch(1) byte);
info.len = 0; /* init to null string */
ch = read$char( file$list ); /* read the first character */
/* Read characters from the file-list file up to return or EOF */
do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) );
info.ch( info.len ) = ch; /* store previous char */
info.len = ( info.len + 1 ); /* update length */
ch = read$char( file$list ); /* get next char */
end; /* do while ( ( ch <> CR ) and ( ch <> EOF$CODE ) ) */
if ( ch = CR ) then /* we got a return */
ch = read$char( file$list ); /* discard the line-feed too */
if ( info.len = 0 ) then /* there are no more filenames */
do; /* Delete the file connection */
call rq$s$delete$connection( file$list, @status );
call check$status( status );
end;
end get$next$file$name;
get$first$file$name: procedure( keyword$num, info$ptr ) public;
/*
* Get the first filename matching the filespec in keyword number
* KEYWORD$NUM into the buffer pointed to by INFO$PTR. This routine
* also does the setup necessary for handling wild-card file names so
* that GET$NEXT$FILE$NAME can return the subsequent matching file
* names. Returns a null string to the buffer if the name cannot
* be parsed (e.g. contains wildcards which don't match any files).
*/
declare
keyword$num byte,
info$ptr pointer,
( status, com$status ) word,
info based info$ptr structure(
len byte,
ch(1) byte);
/* Get the filespec (possibly with wildcards) into the INFO buffer */
call get$filespec( keyword$num, info$ptr );
/* Send the ITEMIZE command to list the matching filenames */
call rq$c$send$command( comm$conn, @( 9,'ITEMIZE &' ), @com$status,
@status );
if ( status <> E$CONTINUED ) then /* should be continued */
call check$status( status );
/* Append an ampersand to the filespec */
info.ch( info.len ) = '&';
info.len = ( info.len + 1 );
/* And concatenate it to the ITEMIZE command */
call rq$c$send$command( comm$conn, @info, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
/* Form the rest of the command in the INFO buffer */
call movb( @( ' OVER ' ), @info.ch( 0 ), 6 ); /* the preposition */
/* and the output filename */
call movb( @file$list$name( 1 ), @info.ch( 6 ), file$list$name( 0 ) );
info.len = ( file$list$name( 0 ) + 8 ); /* store length */
info.ch( info.len - 2 ) = CR;
info.ch( info.len - 1 ) = LF;
/* Send the rest of the command and exectue it */
call rq$c$send$command( comm$conn, @info, @com$status, @status );
call check$status( status );
if ( com$status = E$OK ) then /* it executed O.K. */
do;
/* Get a connection to the file produced */
file$list = rq$c$get$input$connection( @file$list$name, @status );
call check$status( status );
call get$next$file$name( @info ); /* and get the first filename */
end; /* if ( com$status = E$OK ) */
else /* A problem with the ITEMIZE command */
info.len = 0; /* Return null-string as the file-name */
end get$first$file$name;
prepare$file$name: procedure( info$ptr ) public;
/*
* Prepare the filename in the buffer pointed to by INFO$PTR for
* sending to the other Kermit--i.e. remove directory and/or device
* names, leaving only the filename itself in the buffer.
*/
declare
info$ptr pointer,
( i, ch ) byte,
info based info$ptr structure(
len byte,
ch(1) byte);
i = info.len; /* Start at the end of the pathname */
ch = info.ch( i - 1 ); /* Get last character */
do while ( ( ch <> '/' ) and ( ch <> '^' ) and ( ch <> ':' )
and ( i > 0 ) ); /* while we're still in the filename */
i = ( i - 1 ); /* scan backwards to the start of actual filename */
ch = info.ch( i - 1 ); /* get current character */
end; /* do while ... */
if ( i > 0 ) then /* there's a logical or directory name to be trimmed */
do;
/* move the actual filename to the beginning of the buffer */
call movb( @info.ch( i ), @info.ch( 0 ), ( info.len - i ) );
info.len = ( info.len - i ); /* and update length */
end; /* if ( i > 0 ) */
end prepare$file$name;
open$file: procedure( name$ptr ) boolean public;
/*
* Open the file specified in the string (length byte followed
* by the characters of the name) pointed to by NAME$PTR, which is
* assumed to already exist, for reading. Sets the global CUR$FILE.
* Returns TRUE if the open was successful, otherwise it prints
* an error message on the console describing the problem
* encountered and returns FALSE.
*/
declare
status word,
name$ptr pointer;
/* Get a connection to the file */
cur$file = rq$s$attach$file( name$ptr, @status );
if ( status = E$OK ) then /* we got a connection */
/* so open it, for reading only, with two buffers */
call rq$s$open( cur$file, 1, 2, @status );
if ( status = E$OK ) then /* we successfully opened the file */
return( TRUE ); /* indicate success */
else /* we encountered a problem */
do; /* Display an error message */
call print( @( 17,'Can''t open file "' ) );
call print( name$ptr );
call print( @( 3,'"; ' ) );
if ( status = E$FACCESS ) then
call print( @( 20,'read access required' ) );
else if ( status = E$FNEXIST ) then
call print( @( 19,'file does not exist' ) );
else if ( status = E$FTYPE ) then
call print( @( 32,'can''t use data file as directory' ) );
else
call disp$excep( status );
return( FALSE ); /* and indicate failure */
end;
end open$file;
create$file: procedure( name$ptr ) boolean public;
/*
* Create the file specified in the string (length byte followed
* by the characters of the name pointed to by NAME$PTR and open
* it for writing. If it already exists the user will be asked
* whether to overwrite it. If the operation is successful the
* global CUR$FILE is set and TRUE is returned, otherwise an
* error message is displayed at the console and FALSE is returned.
*/
declare
status word,
answer byte,
name$ptr pointer;
/* First, check whether the file already exists */
cur$file = rq$s$attach$file( name$ptr, @status );
if ( status = E$OK ) then /* the file does already exist */
do;
/* First, delete the connection we didn't really want */
call rq$s$delete$connection( cur$file, @status );
call check$status( status );
/* Now, ask the user whether to overwrite the file */
call print( @( 6,'File "' ) );
call print( name$ptr );
call print( @( 37,'" already exists; overwrite it <no>? ' ) );
answer = get$console$char( 0FFFFh ); /* wait for an answer */
call print$char( answer ); /* show them what they typed */
call new$line; /* and that the question is finished */
if ( upcase( answer ) = 'Y' ) then
status = E$FNEXIST; /* act as if the file didn't exist */
else /* they don't want to overwrite it */
return( FALSE ); /* indicate failure, with no error message */
end;
if ( status = E$FNEXIST ) then /* it's O.K. to go ahead and create it */
do;
cur$file = rq$s$create$file( name$ptr, @status );
if ( status = E$OK ) then /* we created the file O.K. */
/* so open it, for writing only, with two buffers */
call rq$s$open( cur$file, 2, 2, @status );
end;
if ( status = E$OK ) then /* we successfully created the file */
return( TRUE ); /* indicate success */
else /* we encountered a problem */
do; /* Display an error message */
call print( @( 19,'Can''t create file "' ) );
call print( name$ptr );
call print( @( 3,'"; ' ) );
if ( status = E$FACCESS ) then
call print( @( 21,'write access required' ) );
else if ( status = E$FNEXIST ) then
call print( @( 19,'file does not exist' ) );
else if ( status = E$FTYPE ) then
call print( @( 32,'can''t use data file as directory' ) );
else
call disp$excep( status );
return( FALSE ); /* and indicate failure */
end;
end create$file;
close$file: procedure public;
/*
* Close the file specified by the connection in the global
* token CUR$FILE.
*/
declare
status word;
call rq$s$close( cur$file, @status ); /* close the file */
call check$status( status );
/* and delete the connection */
call rq$s$delete$connection( cur$file, @status );
call check$status( status );
end close$file;
write$char: procedure( file, ch ) public;
/*
* Write the character CH out to the file specified by FILE
* (which must be a connection open for writing).
*/
declare
file token,
ch byte,
( bytes$written, status ) word;
bytes$written = rq$s$write$move( file, @ch, 1, @status );
call check$status( status );
end write$char;
get$command$line: procedure( prompt$ptr ) public;
/*
* Display the string pointed to by PROMPT$PTR and get a command
* line from the console into the global buffer COM$LINE. This
* procedure also does some preliminary processing of the command line:
* All letters are converted to upper-case, tabs are converted to
* spaces, spaces which are redundant or at the beginning of the
* command line are removed, and line terminators are removed.
* Thus upon return the COM$LINE buffer should contain simply the
* keyword(s), separated by only one space each.
*/
declare
prompt$ptr pointer,
space$flag boolean, /* TRUE if a space here is significant */
( i, j ) byte, /* Indicies into the command line buffer */
status word;
/* Issue the prompt and get the command line into the buffer */
call rq$c$send$co$response( @com$line, size( com$line ),
prompt$ptr, @status );
call check$status( status );
if ( com$line.len = 0 ) then /* We got EOF (end-of-file, or ^Z) */
do; /* Treat the EOF like an EXIT command */
call print( @( 2,'^Z' ) ); /* Echo the ^Z */
call new$line; /* And echo a CRLF */
/* Put the EXIT command in the buffer */
call movb( @( 4,'EXIT' ), @com$line, 5 );
end; /* if ( com$line.len = 0 ) */
else /* We got a command line */
do; /* do the preliminary processing of the command line */
/* If the last character wasn't a line-feed */
if ( com$line.ch( com$line.len - 1 ) <> LF ) then
call new$line; /* Get the cursor onto a new line */
/* Add a CR at the end in case there isn't one */
com$line.ch( com$line.len ) = CR;
i, j = 0; /* init the pointers to the start of the buffer */
space$flag = FALSE; /* Initial spaces are meaningless */
/* Process the line until the CR */
do while ( com$line.ch( i ) <> CR );
if ( com$line.ch( i ) = HT ) then
com$line.ch( i ) = ' '; /* convert tabs to spaces */
/* If this is a significant character */
if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) then
do; /* Process this character */
/* Store it (capitalized) in the resulting command line */
com$line.ch( j ) = upcase( com$line.ch( i ) );
j = j + 1; /* Increment the pointer to the result */
if ( com$line.ch( i ) = ' ' ) then /* if it's a space */
space$flag = FALSE; /* further spaces are redundant */
else /* it's not a space */
space$flag = TRUE; /* so a space after it is meaningful */
end; /* if ( space$flag or ( com$line.ch( i ) <> ' ' ) ) */
i = i + 1; /* Move to the next character of input */
end; /* do while ( com$line.ch( i ) <> CR ) */
com$line.len = j; /* Store the length of the result */
end; /* else -- we got a command line */
end get$command$line;
do$help: procedure( num$params ) public;
/*
* Perform the HELP command. This procedure passes the name
* of our help library and the number of parameters specified
* by NUM$PARAMS to the HELP program.
*/
declare
( num$params, i ) byte,
( com$status, status ) word,
buffer structure(
len byte,
ch(50) byte);
/* Get the name of the file containing this program */
call rq$c$get$command$name( @buffer, size( buffer ), @status );
call check$status( status );
/* Append the .HLP suffix to it, forming the name of the help library */
call movb( @( '.HLP &' ), @buffer.ch( buffer.len ), 6 );
buffer.len = ( buffer.len + 6 );
/* Send the HELP command, with @ to signal library name comes next */
call rq$c$send$command( comm$conn, @( 7,'HELP @&' ), @com$status,
@status );
if ( status <> E$CONTINUED ) then /* should be continued */
call check$status( status );
/* Add our help library name to it */
call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
/* For each parameter which we have */
do i = 1 to num$params;
call get$filespec( i, @buffer ); /* get the parameter */
buffer.ch( buffer.len ) = ' ';
buffer.ch( buffer.len + 1 ) = '&'; /* add space and ampersand */
buffer.len = ( buffer.len + 2 );
/* Append the parameter to the HELP command line */
call rq$c$send$command( comm$conn, @buffer, @com$status, @status );
if ( status <> E$CONTINUED ) then /* should still be continued */
call check$status( status );
end; /* do i = 1 to num$params */
/* And finally execute the command */
call rq$c$send$command( comm$conn, @( 2,CR,LF ), @com$status, @status );
call check$status( status );
end do$help;
end kermit$sys;