Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP
Path: utzoo!mnetor!seismo!ll-xn!ames!necntc!ncoast!allbery
From: rcb@rti.UUCP (Randy Buckland)
Newsgroups: comp.sources.misc
Subject: VMS DVI preview (part 1 of 3)
Message-ID: <2807@ncoast.UUCP>
Date: Mon, 6-Jul-87 21:46:15 EDT
Article-I.D.: ncoast.2807
Posted: Mon Jul  6 21:46:15 1987
Date-Received: Fri, 10-Jul-87 01:18:58 EDT
Sender: allbery@ncoast.UUCP
Lines: 2264
Approved: allbery@ncoast.UUCP
X-Archive: comp.sources.misc/8707/


[It came in two chunks, but part 2 was 96K so I split it in half.  ++bsa]

This is it folks!!! The VMS DVI previewer source. It is a DCL archive file,
so cut at the obvious point and execute it as a ".COM" file (i.e. @foobar)
This archive is in 2 parts, so you will have to get both parts and 
concatenate them together into a single command file and then execute it.
There is a file "read.me" in the "[.doc]" subdirectory. It will tell you
how to build this beast. Have fun.

---------------------------cut here--------------------------
$ write sys$output "Creating ada.reb"
$ create ada.reb
$ deck
$SET DEFAULT USER:[RCB.PREVIEW]
$ADA := ""
$ON ERROR THEN CONTINUE
$ADA/LIBR=tex_base:[misc.preview.ada]/NOCHECK-
 tex_base:[misc.preview.src]FONT_DEF_.ADA-
,UIS_.ADA-
,tex_base:[misc.preview.rtl]OTS_.ADA-
,tex_base:[misc.preview.src]DVI_DEF_.ADA-
,tex_base:[misc.preview.rtl]STR_.ADA-
,STR.ADA-
,SYS_.ADA-
,SYS.ADA-
,CLI_.ADA-
,CLI.ADA-

$ON ERROR THEN CONTINUE
$ADA/LIBR=tex_base:[misc.preview.ada]/NOCHECK-
 tex_base:[misc.preview.src]FONT_IO_.ADA-
,FONT_IO_PK.ADA-
,DVI_IO_.ADA-
,DVI_IO.ADA-
,FONT_TASKS_.ADA-
,FONT_TASKS.ADA-
,FONT.ADA-
,DVI_TRANSLATE_.ADA-
,DVI_TRANSLATE.ADA-
,DVI_TASKS_.ADA-

$ON ERROR THEN CONTINUE
$ADA/LIBR=tex_base:[misc.preview.ada]/NOCHECK-
 tex_base:[misc.preview.src]DVI_TASKS.ADA-
,PREVIEW.ADA-

$EOD
$ eod
$ checksum ada.reb
$ if checksum$checksum .nes. "158486304" then write sys$output -
    "    ******Checksum error for file ada.reb******"
$ create/directory [.doc]
$ write sys$output "Creating font.cld"
$ create font.cld
$ deck
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!									 !!
!!  Title:  Font							 !!
!!  Date:   23-JUN-1987							 !!
!!  Name:   Randy Buckland						 !!
!!									 !!
!!  Purpose:	Display a font file on a vaxstation.			 !!
!!									 !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! 									 !!
!!  Copyright (c) 1987 by Research Triangle Institute.			 !!
!!  Written by Randy Buckland. Not derived from licensed software.	 !!
!! 									 !!
!!  Permission is granted to anyone to use this software for any	 !!
!!  purpose on any computer system, and to redistribute it freely,	 !!
!!  subject to the following restrictions.				 !!
!! 									 !!
!!  1. Research Triangle Institute supplies this software "as is",	 !!
!! 	without any warranty. The author and the Institute do not	 !!
!! 	accept any responsibility for any damage caused by use or	 !!
!! 	mis-use of this program.					 !!
!!  2. The copyright notice must remain a part of all sources files.	 !!
!!  3. This software may not be sold in any fashion.			 !!
!! 									 !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
define verb font
    image user:[rcb.preview]font
    
    parameter p1, prompt="Font file", label=font_file,value(required,type=$file)
$ eod
$ checksum font.cld
$ if checksum$checksum .nes. "1567830183" then write sys$output -
    "    ******Checksum error for file font.cld******"
$ write sys$output "Creating preview.cld"
$ create preview.cld
$ deck
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!									 !!
!!  Title:  Preview							 !!
!!  Date:    3-SEP-1986							 !!
!!  Name:   Randy Buckland						 !!
!!									 !!
!!  Purpose:	Preview a dvi file on a vaxstation.			 !!
!!									 !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! 									 !!
!!  Copyright (c) 1987 by Research Triangle Institute.			 !!
!!  Written by Randy Buckland. Not derived from licensed software.	 !!
!! 									 !!
!!  Permission is granted to anyone to use this software for any	 !!
!!  purpose on any computer system, and to redistribute it freely,	 !!
!!  subject to the following restrictions.				 !!
!! 									 !!
!!  1. Research Triangle Institute supplies this software "as is",	 !!
!! 	without any warranty. The author and the Institute do not	 !!
!! 	accept any responsibility for any damage caused by use or	 !!
!! 	mis-use of this program.					 !!
!!  2. The copyright notice must remain a part of all sources files.	 !!
!!  3. This software may not be sold in any fashion.			 !!
!! 									 !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
define verb preview
    image user:[rcb.preview]preview
    
    parameter p1, prompt="Dvi file", label=dvi_file, value (required,type=$file)

    qualifier magstep, default, value (type=$number, default=0)
$ eod
$ checksum preview.cld
$ if checksum$checksum .nes. "493566788" then write sys$output -
    "    ******Checksum error for file preview.cld******"
$ create/directory [.rtl]
$ create/directory [.src]
$ write sys$output "Creating waits.mf_frag"
$ create waits.mf_frag
$ deck
%
%   Definition for a VAXstation or VAXstation/GPX
%
mode_def gpx =  % VaxStation GPX
 proofing:=0;      % no, we're not making proofs
 fontmaking:=1;      % yes, we are making a font
 tracingtitles:=0;    % no, don't show titles in the log
 pixels_per_inch:=78;    % lowres
 blacker:=0;      % don't make the pens any blacker
 fillin:=0;      % and don't compensate for fillin
 o_correction:=0;    % kill the overshoots
 enddef;
$ eod
$ checksum waits.mf_frag
$ if checksum$checksum .nes. "275470781" then write sys$output -
    "    ******Checksum error for file waits.mf_frag******"
$ write sys$output "Creating [.doc]preview.hlp"
$ create [.doc]preview.hlp
$ deck
1 PREVIEW

 Previews a DVI file created by TeX or LaTeX.  Will operate  only
 on the graphics tube of a VAXstation.

 Format:

           $ PREVIEW dvi-file-spec

2 Parameters

 dvi-file-spec

     Specification of the DVI file to be previewed.  No wildcards
     are allowed in this specification.  The default extension is
     ".DVI".

2 /MAGSTEP=n

 Magnify the displayed page by  the  integer  magstep  specified.
 Applies an overall magnification of the page by 1.2**n

2 Keypad

3 Control/Z

 Exit program.

3 Find (E1)

 Overlay display with a grid  for  alignment  purposes.   Program
 will  prompt terminal window for the spacing of the grid.  (real
 number)

3 Select (E4)

 Goto aribtrary page  in  the  file.   Page  numbers  are  simply
 physical page numbers as measured from the front of the file.

3 Prev Screen (E5)

 Goto previous page.

3 Next Screen (E6)

 Goto next page.

3 Arrow keys

 When page does not fit on the display window, the arrow keys can
 be  used to move the the window relative to the page (i.e.  Down
 arrow will let you see something that is off the bottom  of  the
 window)
$ eod
$ checksum [.doc]preview.hlp
$ if checksum$checksum .nes. "1516589356" then write sys$output -
    "    ******Checksum error for file [.doc]preview.hlp******"
$ write sys$output "Creating [.doc]preview.rnh"
$ create [.doc]preview.rnh
$ deck
.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
.!!									  !!
.!!  Title:  Preview.rnh						  !!
.!!  Date:   25-JUN-1987						  !!
.!!  Name:   Randy Buckland						  !!
.!!									  !!
.!!  Purpose:	Preview help file.					  !!
.!!									  !!
.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
.!!									  !!
.!!  Revision History							  !!
.!!									  !!
.!!  Who	    Date	Description				  !!
.!!  ---	    ----	-----------				  !!
.!!  rcb	    25-JUN-1987	New file.				  !!
.!!									  !!
.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
.!! 									  !!
.!!  Copyright (c) 1987 by Research Triangle Institute.			  !!
.!!  Written by Randy Buckland. Not derived from licensed software.	  !!
.!! 									  !!
.!!  Permission is granted to anyone to use this software for any	  !!
.!!  purpose on any computer system, and to redistribute it freely,	  !!
.!!  subject to the following restrictions.				  !!
.!! 									  !!
.!!  1. Research Triangle Institute supplies this software "as is",	  !!
.!! 	without any warranty. The author and the Institute do not	  !!
.!! 	accept any responsibility for any damage caused by use or	  !!
.!! 	mis-use of this program.					  !!
.!!  2. The copyright notice must remain a part of all sources files.	  !!
.!!  3. This software may not be sold in any fashion.			  !!
.!! 									  !!
.!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
.lm 1
.rm 65
.ap
.i-1
1 PREVIEW
.b
Previews a DVI file created by TeX or LaTeX. Will operate only on the
graphics tube of a VAXstation.
.b
Format:
.b.i+10    
$ PREVIEW dvi-file-spec
.b.i-1
2 Parameters
.b
dvi-file-spec
.b.lm 5
Specification of the DVI file to be previewed. No wildcards are allowed
in this specification. The default extension is ".DVI".
.lm 1
.b.i-1
2 /MAGSTEP=n
.b
Magnify the displayed page by the integer magstep specified. Applies an
overall magnification of the page by 1.2**n
.b.i-1
2 Keypad
.b.i-1
3 Control/Z
.b
Exit program.
.b.i-1
3 Find (E1)
.b
Overlay display with a grid for alignment purposes. Program will prompt
terminal window for the spacing of the grid. (real number)
.b.i-1
3 Select (E4)
.b
Goto aribtrary page in the file. Page numbers are simply physical page
numbers as measured from the front of the file.
.b.i-1
3 Prev Screen (E5)
.b
Goto previous page.
.b.i-1
3 Next Screen (E6)
.b
Goto next page.
.b.i-1
3 Arrow keys
.b
When page does not fit on the display window, the arrow keys can be used
to move the the window relative to the page (i.e. Down arrow will let you
see something that is off the bottom of the window)
$ eod
$ checksum [.doc]preview.rnh
$ if checksum$checksum .nes. "1920434122" then write sys$output -
    "    ******Checksum error for file [.doc]preview.rnh******"
$ write sys$output "Creating [.doc]read.me"
$ create [.doc]read.me
$ deck
Hi,
    You are now the proud owner of a copy of the VMS previewer program.
The file ADA.REB will allow you to rebuild the source by following these
steps:
    
    - Create an ada library directory as in
    
	ACS CREATE LIBRARY [.ADA]
    
    - Edit the file ADA.REB to show the location of the source files and the
	ada library directory. It is set up so that everything is in 
	subdirectories off of TEX_BASE:[MISC.PREVIEW]
    
    - Execute the file ADA.REB
    
    - Link the two programs PREVIEW and FONT
    
	- PREVIEW is the main previewer programs
	- FONT is a utility program to view a font file one character at a time
    
    - Insert the command defintions into the DCLTABLES file. These files,
	FONT.CLD and PREVIEW.CLD, need to be edited first to reflect where
	you wish to place the executables. The command to create these commands
	is
	    SET COMMAND/TABLES=SYS$SHARE:DCLTABLES/OUTPUT=SYS$SHARE:DCLTABLES -
		FONT.CLD,PREVIEW.CLD
    
    - Define a system wide logical name TEX_VS_FONTS to point to the 
	directory that will contain the preview fonts.
    
    - Insert the files WAITS.MF_FRAG into your WAITS.MF file and rebuild
	the programs MF and CMMF.
    
    - Run METAFONT to build a set of fonts for the device GPX. You should
	build a wide set of magsteps to allow for magnifications of files.
	You may also need different "halfsteps" (i.e. magstep 1.5, 2.5, 3.5...)
	if you normally use magstephalf or LaTeX 11pt and wish to magnify
	the image. The commands to run CMMF for a set of magnifications
	should look something like:
	
	    @TEX_BASE:[CM]FONTS "\MODE=GPX" "MAGSTEP 0"
	    @TEX_BASE:[CM]FONTS "\MODE=GPX" "MAGSTEP 0.5"
	    @TEX_BASE:[CM]FONTS "\MODE=GPX" "MAGSTEP 1"
	    @TEX_BASE:[CM]FONTS "\MODE=GPX" "MAGSTEP 1.5"
	    @TEX_BASE:[CM]FONTS "\MODE=GPX" "MAGSTEP 2"

    - You then have to convert the fonts to PK format as this is the only
	supported file format currently. This is done with the program
	GFTOPK that is part of the TeX distribution. Just enter the
	command 
	    
	    GFPK font_file_name
	
	for each file file produced in the previous step.
    
    - Move the file PK fonts into the proper directory pointed to by
	TEX_VS_FONTS. They should be named something like
	
	    CMR10.78PK, CMR10.85PK...
    
    - Start previewing! If you have any questions or bug report 
	(or bug fixes) you can contact me by the E-mail or phone.
	
	    Randy Buckland
	    rcb@rti.rti.org [128.109.139.2]
	    {decvax,seismo,ihnp4}!mcnc!rti!rcb
	    (919)-541-7103
	    
$ eod
$ checksum [.doc]read.me
$ if checksum$checksum .nes. "1261261701" then write sys$output -
    "    ******Checksum error for file [.doc]read.me******"
$ write sys$output "Creating [.rtl]cli.ada"
$ create [.rtl]cli.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Cli								|--
--| Date:   21-APR-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Useful cli routines.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    21-APR-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with text_io, integer_text_io;
use  text_io, integer_text_io;

with starlet;

package body cli is

---------------------------------------------------------------------------
--|									|--
--| Global variables.							|--
--|									|--
---------------------------------------------------------------------------
command_file : file_type;
current_line : d_string;

get_value_temp : d_string;

---------------------------------------------------------------------------
--|									|--
--| Next_line								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Status value.					|--
--|		    2. Output string.					|--
--|		    3. Prompt string.					|--
--|		    4. Output length.					|--
--|									|--
--| Description:    Get the next line from the command file.		|--
--|									|--
---------------------------------------------------------------------------
procedure next_line (
    status  : out    cond_value_type;
    out_str : in out d_string;
    prompt  : in     d_string;
    out_len : in out integer) is

begin
    copy (current_line, "");
    get_line (command_file, current_line);
    copy (out_str, current_line);
    out_len := length (current_line);
    status := 1;

exception
    when end_error =>
	out_len := 0;
	copy (out_str, "");
	status := import_value ("RMS$_EOF");
    
    when others =>
	out_len := 0;
	copy (out_str, "");
	status := 0;
end;

---------------------------------------------------------------------------
--|									|--
--| Execute_file							|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Command file name.				|--
--|		    2. Command table address.				|--
--|									|--
--| Description:    Execute the commands in a given file.		|--
--|									|--
---------------------------------------------------------------------------
function execute_file (
    command_file_name : in string;
    command_table     : in address;
    default_name      : in string := "")
    return cond_value_type is

status : cond_value_type;		-- System service status value.

begin
    open (command_file, in_file, command_file_name, 
	"file; default_name " & default_name & ";");
    loop
	status := dcl_parse (
	    table    => command_table, 
	    param_r  => address_zero,
	    prompt_r => next_line'address);

	if (status /= import_value ("CLI$_NOCOMD")) then
	    if success (status) then
		status := dispatch;
		if not success (status) then
		    exit;
		end if;
	    else
		if (status = import_value ("RMS$_EOF")) then
		    status := 1;
		    exit;
		else
		    exit;
		end if;
	    end if;
	end if;
    end loop;
    close (command_file);
    return status;

exception
    when status_error | name_error | use_error =>
	put_line ("Error accessing file '" & command_file_name & "'.");
	return 0;

end;

---------------------------------------------------------------------------
--|									|--
--| Get_entity								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. String with name of entity.			|--
--|									|--
--| Description:    Return either string or integer value.		|--
--|									|--
---------------------------------------------------------------------------
function get_entity (
    entity : in string)
    return string is

status : cond_value_type;

begin
    get_value (status, entity, get_value_temp);
    if not success (status) then
	raise list_end_error;
    end if;
    return (value (get_value_temp));
end;

function get_entity (
    entity : in string)
    return integer is

status : cond_value_type;
temp   : integer;
last   : natural;

begin
    get_value (status, entity, get_value_temp);
    if not success (status) then
	raise list_end_error;
    end if;
    get (value (get_value_temp), temp, last);
    return temp;
end;

end;
$ eod
$ checksum [.rtl]cli.ada
$ if checksum$checksum .nes. "1831581613" then write sys$output -
    "    ******Checksum error for file [.rtl]cli.ada******"
$ write sys$output "Creating [.rtl]cli_.ada"
$ create [.rtl]cli_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Cli								|--
--| Date:   21-APR-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Define access to the cli$ routines.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    21-APR-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with str, condition_handling, system;
use  str, condition_handling, system;

package cli is

---------------------------------------------------------------------------
--|									|--
--| Utility routines.							|--
--|									|--
---------------------------------------------------------------------------
--|
--| Get next line from file.
--|
procedure next_line (
    status  : out    cond_value_type;
    out_str : in out d_string;
    prompt  : in     d_string;
    out_len : in out integer);
--|
--| Execute a file as a command set.
--|
function execute_file (
    command_file_name : in string;
    command_table     : in address;
    default_name      : in string := "")
    return cond_value_type;
--|
--| Get values in a more reasonable fashion
--|
function get_entity (
    entity : in string)
    return string;

function get_entity (
    entity : in string)
    return integer;
    
list_end_error : exception;

---------------------------------------------------------------------------
--|									|--
--| Cli routines.							|--
--|									|--
---------------------------------------------------------------------------
--|
--| Parse a string.
--|
function dcl_parse (
    command  : in string := string'null_parameter;
    table    : in address;
    param_r  : in address := address_zero;
    prompt_r : in address := address_zero;
    prompt   : in string := string'null_parameter)
    return cond_value_type;
--|
--| Dispatch a function routine.
--|
function dispatch (
    userarg : in address := address_zero)
    return cond_value_type;
--|
--| Get a value for a parameter or switch
--|
procedure get_value (
    status : out    cond_value_type;
    entity : in     string;
    value  : in out d_string);
--|
--| See if a value is present
--|
function present (
    entity : in string)
    return cond_value_type;

---------------------------------------------------------------------------
--|									|--
--| Import everything.							|--
--|									|--
---------------------------------------------------------------------------
private

pragma export_valued_procedure (next_line, "cli_next_line");

pragma interface (rtl, dcl_parse);
pragma import_function (dcl_parse, "cli$dcl_parse",
    (string, address, address, address, string), cond_value_type,
    (descriptor(s), value, value, value, descriptor(s)));

pragma interface (rtl, dispatch);
pragma import_function (dispatch, "cli$dispatch",
    (address), cond_value_type, (value));

pragma interface (rtl, get_value);
pragma import_valued_procedure (get_value, "cli$get_value",
    (cond_value_type, string, d_string),
    (value, descriptor(s), reference));

pragma interface (rtl, present);
pragma import_function (present, "cli$present");

end cli;
$ eod
$ checksum [.rtl]cli_.ada
$ if checksum$checksum .nes. "69221235" then write sys$output -
    "    ******Checksum error for file [.rtl]cli_.ada******"
$ write sys$output "Creating [.rtl]ots_.ada"
$ create [.rtl]ots_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Ots								|--
--| Date:   21-APR-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Define access to the OTS routines.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    21-APR-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with system, condition_handling;
use  system, condition_handling;

package ots is

---------------------------------------------------------------------------
--|									|--
--| Ots routines.							|--
--|									|--
---------------------------------------------------------------------------
--|
--| Convert text binary to longword
--|
function cvt_tb_l (
    in_str   : in string;
    value    : in address;
    val_size : in integer;
    flags    : in integer := 1)
    return cond_value_type;
--|
--| Convert text integer to longword
--|
function cvt_ti_l (
    in_str   : in string;
    value    : in address;
    val_size : in integer;
    flags    : in integer := 1)
    return cond_value_type;
--|
--| Convert text octal to longword
--|
function cvt_to_l (
    in_str   : in string;
    value    : in address;
    val_size : in integer;
    flags    : in integer := 1)
    return cond_value_type;
--|
--| Convert unsigned decimal to longword
--|
function cvt_tu_l (
    in_str   : in string;
    value    : in address;
    val_size : in integer;
    flags    : in integer := 1)
    return cond_value_type;
--|
--| Convert text hex to longword
--|
function cvt_tz_l (
    in_str   : in string;
    value    : in address;
    val_size : in integer;
    flags    : in integer := 1)
    return cond_value_type;
--|
--| Convert longword to text binary
--|
procedure cvt_l_tb (
    status   : out    cond_value_type;
    value    : in     address;
    out_str  : in out string;
    int_dig  : in     integer;
    val_size : in     integer;
    flags    : in     integer := 1);
--|
--| Convert longword to text integer
--|
procedure cvt_l_ti (
    status   : out    cond_value_type;
    value    : in     address;
    out_str  : in out string;
    int_dig  : in     integer;
    val_size : in     integer;
    flags    : in     integer := 1);
--|
--| Convert longword to text octal
--|
procedure cvt_l_to (
    status   : out    cond_value_type;
    value    : in     address;
    out_str  : in out string;
    int_dig  : in     integer;
    val_size : in     integer;
    flags    : in     integer := 1);
--|
--| Convert longword to text unsigned decimal
--|
procedure cvt_l_tu (
    status   : out    cond_value_type;
    value    : in     address;
    out_str  : in out string;
    int_dig  : in     integer;
    val_size : in     integer;
    flags    : in     integer := 1);
--|
--| Convert longword to text hex.
--|
procedure cvt_l_tz (
    status   : out    cond_value_type;
    value    : in     address;
    out_str  : in out string;
    int_dig  : in     integer;
    val_size : in     integer;
    flags    : in     integer := 1);
--|
--| Convert text to f_float
--|
procedure cvt_t_f (
    status :    out cond_value_type;
    in_str : in     string;
    value  : in out f_float;
    fdigit : in     integer := 0;
    scale  : in     integer := 0;
    flags  : in     integer := 39);
--|
--| Convert text to d_float
--|
procedure cvt_t_d (
    status :    out cond_value_type;
    in_str : in     string;
    value  : in out d_float;
    fdigit : in     integer := 0;
    scale  : in     integer := 0;
    flags  : in     integer := 39);
--|
--| Convert text to g_float
--|
procedure cvt_t_g (
    status :    out cond_value_type;
    in_str : in     string;
    value  : in out g_float;
    fdigit : in     integer := 0;
    scale  : in     integer := 0;
    flags  : in     integer := 39);
--|
--| Convert text to h_float
--|
procedure cvt_t_h (
    status :    out cond_value_type;
    in_str : in     string;
    value  : in out h_float;
    fdigit : in     integer := 0;
    scale  : in     integer := 0;
    flags  : in     integer := 39);
--|
--| Move bytes
--|
procedure move3 (
    length : in integer;
    source : in address;
    dest   : in address);

procedure move5 (
    srclen : in integer;
    source : in address;
    fill   : in integer;
    dstlen : in integer;
    dest   : in address);

---------------------------------------------------------------------------
--|									|--
--| Import everybody.							|--
--|									|--
---------------------------------------------------------------------------
private
--
--  Import all procedures
--
pragma interface (rtl, cvt_tb_l);
pragma import_function (cvt_tb_l, "ots$cvt_tb_l", 
    (string, address, integer, integer), cond_value_type,
    (descriptor(s), value, value, value));

pragma interface (rtl, cvt_ti_l);
pragma import_function (cvt_ti_l, "ots$cvt_ti_l",
    (string, address, integer, integer), cond_value_type,
    (descriptor(s), value, value, value));

pragma interface (rtl, cvt_to_l);
pragma import_function (cvt_to_l, "ots$cvt_to_l",
    (string, address, integer, integer), cond_value_type,
    (descriptor(s), value, value, value));

pragma interface (rtl, cvt_tu_l);
pragma import_function (cvt_tu_l, "ots$cvt_tu_l",
    (string, address, integer, integer), cond_value_type,
    (descriptor(s), value, value, value));

pragma interface (rtl, cvt_tz_l);
pragma import_function (cvt_tz_l, "ots$cvt_tz_l",
    (string, address, integer, integer), cond_value_type,
    (descriptor(s), value, value, value));

pragma interface (rtl, cvt_l_tb);
pragma import_valued_procedure (cvt_l_tb, "ots$cvt_l_tb",
    (cond_value_type, address, string, integer, integer, integer),
    (value, value, descriptor(s), value, value, value));

pragma interface (rtl, cvt_l_ti);
pragma import_valued_procedure (cvt_l_ti, "ots$cvt_l_ti",
    (cond_value_type, address, string, integer, integer, integer),
    (value, value, descriptor(s), value, value, value));

pragma interface (rtl, cvt_l_to);
pragma import_valued_procedure (cvt_l_to, "ots$cvt_l_to",
    (cond_value_type, address, string, integer, integer, integer),
    (value, value, descriptor(s), value, value, value));

pragma interface (rtl, cvt_l_tu);
pragma import_valued_procedure (cvt_l_tu, "ots$cvt_l_tu",
    (cond_value_type, address, string, integer, integer, integer),
    (value, value, descriptor(s), value, value, value));

pragma interface (rtl, cvt_l_tz);
pragma import_valued_procedure (cvt_l_tz, "ots$cvt_l_tz",
    (cond_value_type, address, string, integer, integer, integer),
    (value, value, descriptor(s), value, value, value));

pragma interface (rtl, cvt_t_f);
pragma import_valued_procedure (cvt_t_f, "ots$cvt_t_f",
    (cond_value_type, string, f_float, integer, integer, integer),
    (value, descriptor(s), reference, value, value, value));

pragma interface (rtl, cvt_t_d);
pragma import_valued_procedure (cvt_t_d, "ots$cvt_t_d",
    (cond_value_type, string, d_float, integer, integer, integer),
    (value, descriptor(s), reference, value, value, value));

pragma interface (rtl, cvt_t_g);
pragma import_valued_procedure (cvt_t_g, "ots$cvt_t_g",
    (cond_value_type, string, g_float, integer, integer, integer),
    (value, descriptor(s), reference, value, value, value));

pragma interface (rtl, cvt_t_h);
pragma import_valued_procedure (cvt_t_h, "ots$cvt_t_h",
    (cond_value_type, string, h_float, integer, integer, integer),
    (value, descriptor(s), reference, value, value, value));

pragma interface (rtl, move3);
pragma import_procedure (move3, "ots$move3",
    (integer, address, address),
    value);

pragma interface (rtl, move5);
pragma import_procedure (move5, "ots$move5",
    (integer, address, integer, integer, address),
    value);


end;
$ eod
$ checksum [.rtl]ots_.ada
$ if checksum$checksum .nes. "574206714" then write sys$output -
    "    ******Checksum error for file [.rtl]ots_.ada******"
$ write sys$output "Creating [.rtl]str.ada"
$ create [.rtl]str.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Str								|--
--| Date:   18-APR-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Body for string utility procedures.			|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    18-APR-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
package body str is

---------------------------------------------------------------------------
--|									|--
--| De_tab								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Output string.					|--
--|		    2. Input string.					|--
--|									|--
--| Description:    Remove all tabs from an string and replace		|--
--|		    them with spaces.					|--
--|									|--
---------------------------------------------------------------------------
procedure de_tab (
    out_str : in out d_string;
    in_str  : in     string) is

tmp_str : string (1..(in_str'last)*8);	    -- Temporary string
tmp_ptr : integer := 1;			    -- Pointer to temp string
in_ptr  : integer := 1;			    -- Pointer to input string.

begin
    while (in_str'last >= in_ptr) loop
	case in_str(in_ptr) is
	
	    when ascii.ht =>
		loop
		    tmp_str(tmp_ptr) := ' ';
		    tmp_ptr := tmp_ptr + 1;
		    exit when ((tmp_ptr mod 8) = 0);
		end loop;
	    
	    when others =>
		tmp_str(tmp_ptr) := in_str(in_ptr);
		tmp_ptr := tmp_ptr + 1;
	
	end case;
	
	in_ptr := in_ptr + 1;
    end loop;
    
    if (tmp_ptr = 1) then
	copy(out_str, "");
    else
	copy(out_str, tmp_str(1..tmp_ptr-1));
    end if;
end;
--|
--| Conversion calls
--|
procedure de_tab (
    out_str : in out string;
    in_str  : in     d_string) is

tmp_str : d_string;

begin
    de_tab(tmp_str, value(in_str));
    copy(out_str, tmp_str);
    free(tmp_str);
end;

procedure de_tab (
    out_str : in out d_string;
    in_str  : in     d_string) is

tmp_str : d_string;

begin
    de_tab(out_str, value(tmp_str));
end;

procedure de_tab (
    out_str : in out string;
    in_str  : in     string) is

tmp_str : d_string;

begin
    de_tab(tmp_str, in_str);
    copy(out_str, tmp_str);
    free(tmp_str);
end;

---------------------------------------------------------------------------
--|									|--
--| Value								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Dynamic string.					|--
--|									|--
--| Description:    Return static string from dynamic.			|--
--|									|--
---------------------------------------------------------------------------
function value (
    item : in d_string) 
    return string is

begin
    if (item.length /= 0) then
	return item.addr(1 .. integer(item.length));
    else
	return "";
    end if;
end;

---------------------------------------------------------------------------
--|									|--
--| Length								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Dynamic string.					|--
--|									|--
--| Description:    Return length of the string.			|--
--|									|--
---------------------------------------------------------------------------
function length (
    item : in d_string)
    return integer is

begin
    return integer(item.length);
end;

---------------------------------------------------------------------------
--|									|--
--| Put, Put_line							|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Optional file pointer.				|--
--|		    2. Dynamic string.					|--
--|									|--
--| Description:    Output a dynamic string to a file.			|--
--|									|--
---------------------------------------------------------------------------
procedure put (
    item : in d_string) is

begin
    put(value(item));
end;

procedure put (
    file : in file_type;
    item : in d_string) is

begin
    put(file, value(item));
end;

procedure put_line (
    item : in d_string) is

begin
    put_line(value(item));
end;

procedure put_line (
    file : in file_type;
    item : in d_string) is

begin
    put_line(file, value(item));
end;

---------------------------------------------------------------------------
--|									|--
--| Get_line								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Optional file pointer.				|--
--|		    2. Dynamic string.					|--
--|									|--
--| Description:    Get a dynamic string from a file.			|--
--|									|--
---------------------------------------------------------------------------
procedure get_line (
    item : out d_string) is

temp_str : string(1..1024);
last     : natural;

begin
    get_line(temp_str, last);
    trim(item, temp_str(1..last));
end;

procedure get_line (
    file : in  file_type;
    item : out d_string) is

temp_str : string(1..1024);
last     : natural;

begin
    get_line(file, temp_str, last);
    trim(item, temp_str(1..last));
end;

end;
$ eod
$ checksum [.rtl]str.ada
$ if checksum$checksum .nes. "290857973" then write sys$output -
    "    ******Checksum error for file [.rtl]str.ada******"
$ write sys$output "Creating [.rtl]str_.ada"
$ create [.rtl]str_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Str								|--
--| Date:   18-APR-1986							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	Define a dynamic string data type and definitions	|--
--|		for all the str$ functions.				|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    18-APR-1986	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with system, text_io, condition_handling;
use  system, text_io, condition_handling;

package str is

---------------------------------------------------------------------------
--|									|--
--| Type definitions.							|--
--|									|--
---------------------------------------------------------------------------
type d_string_pointer is access string(1..32767);

type d_string is record
    length : unsigned_word := 0;
    d_type : unsigned_byte := 14;
    class  : unsigned_byte := 2;
    addr   : d_string_pointer := null;
end record;

type s_string is record
    length : unsigned_word := 0;
    d_type : unsigned_byte := 14;
    class  : unsigned_byte := 1;
    addr   : address := address_zero;
end record;

---------------------------------------------------------------------------
--|									|--
--| Utility routines.							|--
--|									|--
---------------------------------------------------------------------------
procedure de_tab (
    out_str : in out d_string;
    in_str  : in     d_string);

procedure de_tab (
    out_str : in out string;
    in_str  : in     d_string);

procedure de_tab (
    out_str : in out d_string;
    in_str  : in     string);

procedure de_tab (
    out_str : in out string;
    in_str  : in     string);

procedure put (
    item : in d_string);

procedure put (
    file : in file_type;
    item : in d_string);

procedure put_line (
    item : in d_string);

procedure put_line (
    file : in file_type;
    item : in d_string);

procedure get_line (
    item : out d_string);

procedure get_line (
    file : in  file_type;
    item : out d_string);

function value (
    item : in d_string)
    return string;

function length (
    item : in d_string)
    return integer;

---------------------------------------------------------------------------
--|									|--
--| Str$ calls.								|--
--|									|--
---------------------------------------------------------------------------
--|
--| Append one string to another.
--|
procedure append (
    destination : in out d_string;
    source      : in     d_string);

procedure append (
    destination : in out d_string;
    source      : in     string);

pragma interface (rtl, append);
pragma import_procedure (append, "str$append", (d_string, d_string), 
    (reference, reference));
pragma import_procedure (append, "str$append", (d_string, string),
    (reference, descriptor(s)));
--|
--| Compare two strings without regard to case.
--|
function case_blind_compare (
    string1 : in d_string;
    string2 : in d_string)
    return integer;

function case_blind_compare (
    string1 : in string;
    string2 : in d_string)
    return integer;

function case_blind_compare (
    string1 : in d_string;
    string2 : in string)
    return integer;

function case_blind_compare (
    string1 : in string;
    string2 : in string)
    return integer;

pragma interface (rtl, case_blind_compare);
pragma import_function (case_blind_compare, "str$case_blind_compare",
    (d_string, d_string), integer, (reference, reference));
pragma import_function (case_blind_compare, "str$case_blind_compare",
    (string, d_string), integer, (descriptor(s), reference));
pragma import_function (case_blind_compare, "str$case_blind_compare",
    (d_string, string), integer, (reference, descriptor(s)));
pragma import_function (case_blind_compare, "str$case_blind_compare",
    (string, string), integer, (descriptor(s), descriptor(s)));
--|
--| Compare two strings.
--|
function compare (
    string1 : in d_string;
    string2 : in d_string)
    return integer;

function compare (
    string1 : in string;
    string2 : in d_string)
    return integer;

function compare (
    string1 : in d_string;
    string2 : in string)
    return integer;

function compare (
    string1 : in string;
    string2 : in string)
    return integer;

pragma interface (rtl, compare);
pragma import_function (compare, "str$compare",
    (d_string, d_string), integer, (reference, reference));
pragma import_function (compare, "str$compare",
    (string, d_string), integer, (descriptor(s), reference));
pragma import_function (compare, "str$compare",
    (d_string, string), integer, (reference, descriptor(s)));
pragma import_function (compare, "str$compare",
    (string, string), integer, (descriptor(s), descriptor(s)));
--|
--| Concatenate two strings.
--|
procedure concat (
    output : out d_string;
    input1 : in  d_string;
    input2 : in  d_string);

procedure concat (
    output : out d_string;
    input1 : in  string;
    input2 : in  d_string);

procedure concat (
    output : out d_string;
    input1 : in  d_string;
    input2 : in  string);

procedure concat (
    output : out d_string;
    input1 : in  string;
    input2 : in  string);

procedure concat (
    output : out string;
    input1 : in  d_string;
    input2 : in  d_string);

procedure concat (
    output : out string;
    input1 : in  string;
    input2 : in  d_string);

procedure concat (
    output : out string;
    input1 : in  d_string;
    input2 : in  string);

procedure concat (
    output : out string;
    input1 : in  string;
    input2 : in  string);

pragma interface (rtl, concat);
pragma import_procedure (concat, "str$concat",
    (d_string, d_string, d_string), (reference, reference, reference));
pragma import_procedure (concat, "str$concat",
    (d_string, string, d_string), (reference, descriptor(s), reference));
pragma import_procedure (concat, "str$concat",
    (d_string, d_string, string), (reference, reference, descriptor(s)));
pragma import_procedure (concat, "str$concat",
    (d_string, string, string), (reference, descriptor(s), descriptor(s)));
pragma import_procedure (concat, "str$concat",
    (string, d_string, d_string), (descriptor(s), reference, reference));
pragma import_procedure (concat, "str$concat",
    (string, string, d_string), (descriptor(s), descriptor(s), reference));
pragma import_procedure (concat, "str$concat",
    (string, d_string, string), (descriptor(s), reference, descriptor(s)));
pragma import_procedure (concat, "str$concat",
    (string, string, string), (descriptor(s), descriptor(s), descriptor(s)));
--|
--| Copy one string to another
--|
procedure copy (
    destination : out d_string;
    source      : in  d_string);

procedure copy (
    destination : out s_string;
    source      : in  d_string);

procedure copy (
    destination : out string;
    source      : in  d_string);

procedure copy (
    destination : out d_string;
    source      : in  s_string);

procedure copy (
    destination : out s_string;
    source      : in  s_string);

procedure copy (
    destination : out string;
    source      : in  s_string);

procedure copy (
    destination : out d_string;
    source      : in  string);

procedure copy (
    destination : out s_string;
    source      : in  string);

procedure copy (
    destination : out string;
    source      : in  string);

pragma interface (rtl, copy);
pragma import_procedure (copy, "str$copy_dx",
    (d_string, d_string), (reference, reference));
pragma import_procedure (copy, "str$copy_dx",
    (s_string, d_string), (reference, reference));
pragma import_procedure (copy, "str$copy_dx",
    (string, d_string), (descriptor(s), reference));
pragma import_procedure (copy, "str$copy_dx",
    (d_string, s_string), (reference, reference));
pragma import_procedure (copy, "str$copy_dx",
    (s_string, s_string), (reference, reference));
pragma import_procedure (copy, "str$copy_dx",
    (string, s_string), (descriptor(s), reference));
pragma import_procedure (copy, "str$copy_dx",
    (d_string, string), (reference, descriptor(s)));
pragma import_procedure (copy, "str$copy_dx",
    (s_string, string), (reference, descriptor(s)));
pragma import_procedure (copy, "str$copy_dx",
    (string, string), (descriptor(s), descriptor(s)));
--|
--| Duplicate a character into a string
--|
procedure duplicate (
    destination : out d_string;
    length      : in  integer   := 1;
    char        : in  character := ' ');

procedure duplicate (
    destination : out string;
    length      : in  integer   := 1;
    char        : in  character := ' ');

pragma interface (rtl, duplicate);
pragma import_procedure (duplicate, "str$dupl_char",
    (d_string, integer, character), (reference, reference, reference));
pragma import_procedure (duplicate, "str$dupl_char",
    (string, integer, character), (descriptor(s), reference, reference));
--|
--| Find first match in a string
--|
function find_first (
    instring : in d_string;
    char_set : in d_string)
    return integer;

function find_first (
    instring : in string;
    char_set : in d_string)
    return integer;

function find_first (
    instring : in d_string;
    char_set : in string)
    return integer;

function find_first (
    instring : in string;
    char_set : in string)
    return integer;

pragma interface (rtl, find_first);
pragma import_function (find_first, "str$find_first_in_set",
    (d_string, d_string), integer, (reference, reference));
pragma import_function (find_first, "str$find_first_in_set",
    (string, d_string), integer, (descriptor(s), reference));
pragma import_function (find_first, "str$find_first_in_set",
    (d_string, string), integer, (reference, descriptor(s)));
pragma import_function (find_first, "str$find_first_in_set",
    (string, string), integer, (descriptor(s), descriptor(s)));
--|
--| Find first non match in a string
--|
function find_first_not (
    instring : in d_string;
    char_set : in d_string)
    return integer;

function find_first_not (
    instring : in string;
    char_set : in d_string)
    return integer;

function find_first_not (
    instring : in d_string;
    char_set : in string)
    return integer;

function find_first_not (
    instring : in string;
    char_set : in string)
    return integer;

pragma interface (rtl, find_first_not);
pragma import_function (find_first_not, "str$find_first_not_in_set",
    (d_string, d_string), integer, (reference, reference));
pragma import_function (find_first_not, "str$find_first_not_in_set",
    (string, d_string), integer, (descriptor(s), reference));
pragma import_function (find_first_not, "str$find_first_not_in_set",
    (d_string, string), integer, (reference, descriptor(s)));
pragma import_function (find_first_not, "str$find_first_not_in_set",
    (string, string), integer, (descriptor(s), descriptor(s)));
--|
--| Free a string
--|
procedure free (
    in_str : in out d_string);

pragma interface (rtl, free);
pragma import_procedure (free, "str$free1_dx", (d_string), reference);
--|
--| Get left part of string
--|
procedure left (
    destination : in d_string;
    source      : in d_string;
    position    : in integer);

procedure left (
    destination : in string;
    source      : in d_string;
    position    : in integer);

procedure left (
    destination : in d_string;
    source      : in string;
    position    : in integer);

procedure left (
    destination : in string;
    source      : in string;
    position    : in integer);

pragma interface (rtl, left);
pragma import_procedure (left, "str$left",
    (d_string, d_string, integer), (reference, reference, reference));
pragma import_procedure (left, "str$left",
    (string, d_string, integer), (descriptor(s), reference, reference));
pragma import_procedure (left, "str$left",
    (d_string, string, integer), (reference, descriptor(s), reference));
pragma import_procedure (left, "str$left",
    (string, string, integer), (descriptor(s), descriptor(s), reference));
--|
--| Get a substring by length
--|
procedure len_extr (
    destination : in d_string;
    source      : in d_string;
    start       : in integer;
    length      : in integer);

procedure len_extr (
    destination : in string;
    source      : in d_string;
    start       : in integer;
    length      : in integer);

procedure len_extr (
    destination : in d_string;
    source      : in string;
    start       : in integer;
    length      : in integer);

procedure len_extr (
    destination : in string;
    source      : in string;
    start       : in integer;
    length      : in integer);

pragma interface (rtl, len_extr);
pragma import_procedure (len_extr, "str$len_extr",
    (d_string, d_string, integer, integer), (reference, reference, reference, reference));
pragma import_procedure (len_extr, "str$len_extr",
    (string, d_string, integer, integer), (descriptor(s), reference, reference, reference));
pragma import_procedure (len_extr, "str$len_extr",
    (d_string, string, integer, integer), (reference, descriptor(s), reference, reference));
pragma import_procedure (len_extr, "str$len_extr",
    (string, string, integer, integer), (descriptor(s), descriptor(s), reference, reference));
--|
--| Match a string with a wildcard specification
--|
function match_wild (
    candidate : in d_string;
    pattern   : in d_string)
    return cond_value_type;

function match_wild (
    candidate : in string;
    pattern   : in d_string)
    return cond_value_type;

function match_wild (
    candidate : in d_string;
    pattern   : in string)
    return cond_value_type;

function match_wild (
    candidate : in string;
    pattern   : in string)
    return cond_value_type;

pragma interface (rtl, match_wild);
pragma import_function (match_wild, "str$match_wild",
    (d_string, d_string), cond_value_type, (reference, reference));
pragma import_function (match_wild, "str$match_wild",
    (string, d_string), cond_value_type, (descriptor(s), reference));
pragma import_function (match_wild, "str$match_wild",
    (d_string, string), cond_value_type, (reference, descriptor(s)));
pragma import_function (match_wild, "str$match_wild",
    (string, string), cond_value_type, (descriptor(s), descriptor(s)));
--|
--| Find substring in string
--|
function position (
    source     : in d_string;
    sub_string : in d_string;
    start      : in integer := 1)
    return integer;

function position (
    source     : in string;
    sub_string : in d_string;
    start      : in integer := 1)
    return integer;

function position (
    source     : in d_string;
    sub_string : in string;
    start      : in integer := 1)
    return integer;

function position (
    source     : in string;
    sub_string : in string;
    start      : in integer := 1)
    return integer;

pragma interface (rtl, position);
pragma import_function (position, "str$position",
    (d_string, d_string, integer), integer,( reference, reference, reference));
pragma import_function (position, "str$position",
    (string, d_string, integer), integer, (descriptor(s), reference, reference));
pragma import_function (position, "str$position",
    (d_string, string, integer), integer, (reference, descriptor(s), reference));
pragma import_function (position, "str$position",
    (string, string, integer), integer, (descriptor(s), descriptor(s), reference));
--|
--| Extract a substring by position
--|
procedure pos_extr (
    destination : in d_string;
    source      : in d_string;
    start       : in integer;
    stop        : in integer);

procedure pos_extr (
    destination : in string;
    source      : in d_string;
    start       : in integer;
    stop        : in integer);

procedure pos_extr (
    destination : in d_string;
    source      : in string;
    start       : in integer;
    stop        : in integer);

procedure pos_extr (
    destination : in string;
    source      : in string;
    start       : in integer;
    stop        : in integer);

pragma interface (rtl, pos_extr);
pragma import_procedure (pos_extr, "str$pos_extr",
    (d_string, d_string, integer, integer), (reference, reference, reference, reference));
pragma import_procedure (pos_extr, "str$pos_extr",
    (string, d_string, integer, integer), (descriptor(s), reference, reference, reference));
pragma import_procedure (pos_extr, "str$pos_extr",
    (d_string, string, integer, integer), (reference, descriptor(s), reference, reference));
pragma import_procedure (pos_extr, "str$pos_extr",
    (string, string, integer, integer), (descriptor(s), descriptor(s), reference, reference));
--|
--| Prefix a string with another
--|
procedure prefix (
    destination : in out d_string;
    source      : in d_string);

procedure prefix (
    destination : in out d_string;
    source      : in string);

pragma interface (rtl, prefix);
pragma import_procedure (prefix, "str$prefix",
    (d_string, d_string), (reference, reference));
pragma import_procedure (prefix, "str$prefix",
    (d_string, string), (reference, descriptor(s)));
--|
--| Get right part of a string.
--|
procedure right (
    destination : in d_string;
    source      : in d_string;
    position    : in integer);

procedure right (
    destination : in string;
    source      : in d_string;
    position    : in integer);

procedure right (
    destination : in d_string;
    source      : in string;
    position    : in integer);

procedure right (
    destination : in string;
    source      : in string;
    position    : in integer);

pragma interface (rtl, right);
pragma import_procedure (right, "str$right",
    (d_string, d_string, integer), (reference, reference, reference));
pragma import_procedure (right, "str$right",
    (string, d_string, integer), (descriptor(s), reference, reference));
pragma import_procedure (right, "str$right",
    (d_string, string, integer), (reference, descriptor(s), reference));
pragma import_procedure (right, "str$right",
    (string, string, integer), (descriptor(s), descriptor(s), reference));
--|
--| Translate a string
--|
procedure translate (
    destination : out d_string;
    source      : in  d_string;
    translate   : in  d_string;
    match       : in  d_string);

procedure translate (
    destination : out string;
    source      : in  d_string;
    translate   : in  d_string;
    match       : in  d_string);

procedure translate (
    destination : out d_string;
    source      : in  string;
    translate   : in  d_string;
    match       : in  d_string);

procedure translate (
    destination : out d_string;
    source      : in  d_string;
    translate   : in  string;
    match       : in  d_string);

procedure translate (
    destination : out d_string;
    source      : in  d_string;
    translate   : in  d_string;
    match       : in  string);

procedure translate (
    destination : out string;
    source      : in  string;
    translate   : in  d_string;
    match       : in  d_string);

procedure translate (
    destination : out string;
    source      : in  d_string;
    translate   : in  string;
    match       : in  d_string);

procedure translate (
    destination : out string;
    source      : in  d_string;
    translate   : in  d_string;
    match       : in  string);

procedure translate (
    destination : out d_string;
    source      : in  string;
    translate   : in  string;
    match       : in  d_string);

procedure translate (
    destination : out d_string;
    source      : in  string;
    translate   : in  d_string;
    match       : in  string);

procedure translate (
    destination : out d_string;
    source      : in  d_string;
    translate   : in  string;
    match       : in  string);

procedure translate (
    destination : out string;
    source      : in  string;
    translate   : in  string;
    match       : in  d_string);

procedure translate (
    destination : out string;
    source      : in  string;
    translate   : in  d_string;
    match       : in  string);

procedure translate (
    destination : out string;
    source      : in  d_string;
    translate   : in  string;
    match       : in  string);

procedure translate (
    destination : out d_string;
    source      : in  string;
    translate   : in  string;
    match       : in  string);

procedure translate (
    destination : out string;
    source      : in  string;
    translate   : in  string;
    match       : in  string);

pragma interface (rtl, translate);
pragma import_procedure (translate, "str$translate",
    (d_string, d_string, d_string, d_string), (reference, reference, reference, reference));
pragma import_procedure (translate, "str$translate",
    (string, d_string, d_string, d_string), (descriptor(s), reference, reference, reference));
pragma import_procedure (translate, "str$translate",
    (d_string, string, d_string, d_string), (reference, descriptor(s), reference, reference));
pragma import_procedure (translate, "str$translate",
    (d_string, d_string, string, d_string), (reference, reference, descriptor(s), reference));
pragma import_procedure (translate, "str$translate",
    (d_string, d_string, d_string, string), (reference, reference, reference, descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (string, string, d_string, d_string), (descriptor(s), descriptor(s), reference, reference));
pragma import_procedure (translate, "str$translate",
    (string, d_string, string, d_string), (descriptor(s), reference, descriptor(s), reference));
pragma import_procedure (translate, "str$translate",
    (string, d_string, d_string, string), (descriptor(s), reference, reference, descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (d_string, string, string, d_string), (reference, descriptor(s), descriptor(s), reference));
pragma import_procedure (translate, "str$translate",
    (d_string, string, d_string, string), (reference, descriptor(s), reference, descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (d_string, d_string, string, string), (reference, reference, descriptor(s), descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (string, string, string, d_string), (descriptor(s), descriptor(s), descriptor(s), reference));
pragma import_procedure (translate, "str$translate",
    (string, string, d_string, string), (descriptor(s), descriptor(s), reference, descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (string, d_string, string, string), (descriptor(s), reference, descriptor(s), descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (d_string, string, string, string), (reference, descriptor(s), descriptor(s), descriptor(s)));
pragma import_procedure (translate, "str$translate",
    (string, string, string, string), (descriptor(s), descriptor(s), descriptor(s), descriptor(s)));
--|
--| Trim trailing blanks from a string
--|
procedure trim (
    destination : out    d_string;
    source      : in     d_string;
    length      : in out integer);

procedure trim (
    destination : out d_string;
    source      : in  d_string);

procedure trim (
    destination : out    string;
    source      : in     d_string;
    length      : in out integer);

procedure trim (
    destination : out string;
    source      : in  d_string);

procedure trim (
    destination : out    d_string;
    source      : in     string;
    length      : in out integer);

procedure trim (
    destination : out d_string;
    source      : in  string);

procedure trim (
    destination : out    string;
    source      : in     string;
    length      : in out integer);

procedure trim (
    destination : out string;
    source      : in  string);

pragma interface (rtl, trim);
pragma import_procedure (trim, "str$trim",
    (d_string, d_string, integer), (reference, reference, reference)); 
pragma import_procedure (trim, "str$trim",
    (string, d_string, integer), (descriptor(s), reference, reference));
pragma import_procedure (trim, "str$trim",
    (d_string, string, integer), (reference, descriptor(s), reference));
pragma import_procedure (trim, "str$trim",
    (string, string, integer), (descriptor(s), descriptor(s), reference));
pragma import_procedure (trim, "str$trim",
    (d_string, d_string), (reference, reference));
pragma import_procedure (trim, "str$trim",
    (string, d_string), (descriptor(s), reference));
pragma import_procedure (trim, "str$trim",
    (d_string, string), (reference, descriptor(s)));
pragma import_procedure (trim, "str$trim",
    (string, string), (descriptor(s), descriptor(s)));
--|
--| Convert a string to upper case
--|
procedure upcase (
    destination : out d_string;
    source      : in  d_string);

procedure upcase (
    destination : out string;
    source      : in  d_string);

procedure upcase (
    destination : out d_string;
    source      : in  string);

procedure upcase (
    destination : out string;
    source      : in  string);

pragma interface (rtl, upcase);
pragma import_procedure (upcase, "str$upcase",
    (d_string, d_string), (reference, reference));
pragma import_procedure (upcase, "str$upcase",
    (string, d_string), (descriptor(s), reference));
pragma import_procedure (upcase, "str$upcase",
    (d_string, string), (reference, descriptor(s)));
pragma import_procedure (upcase, "str$upcase",
    (string, string), (descriptor(s), descriptor(s)));

end;
$ eod
$ checksum [.rtl]str_.ada
$ if checksum$checksum .nes. "478034284" then write sys$output -
    "    ******Checksum error for file [.rtl]str_.ada******"
$ write sys$output "Creating [.rtl]sys.ada"
$ create [.rtl]sys.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Sys								|--
--| Date:   20-MAR-1987							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	System service easy routines.				|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    20-MAR-1987	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with str, system;
use  str, system;

with starlet;

package body sys is

---------------------------------------------------------------------------
--|									|--
--| Exi									|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. Exit status value.				|--
--|									|--
--| Description:    Exit with a given status value.			|--
--|									|--
---------------------------------------------------------------------------
procedure sys_exit (
    status : in cond_value_type := 1) is

ret_stat : cond_value_type;

begin
    starlet.exi (ret_stat, status);
end;

---------------------------------------------------------------------------
--|									|--
--| Trnlnm								|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Parameters:	    1. String to translate.				|--
--|		    2. Index of value to return.			|--
--|									|--
--| Description:    Translate a logical name to it's value.		|--
--|		    Return a null string if no translation.		|--
--|									|--
---------------------------------------------------------------------------
function trnlnm (
    lognam : in string;
    index  : in integer := 0)
    return string is

status : cond_value_type;
items  : starlet.item_list_type(1..3);
val    : string(1..256);
len    : integer := 0;

begin
    items(1).item_code := starlet.lnm_index;
    items(1).buf_len := 4;
    items(1).buf_address := index'address;
    items(1).ret_address := address_zero;
    
    items(2).item_code := starlet.lnm_string;
    items(2).buf_len := 256;
    items(2).buf_address := val'address;
    items(2).ret_address := len'address;
    
    items(3).buf_len := 0;
    items(3).item_code := 0;
	
    starlet.trnlnm (status, starlet.lnm_m_case_blind, "LNM$DCL_LOGICAL", 
	lognam, 3, items);
    
    if success (status) then
	return val(1..len);
    else
	return "";
    end if;
end;

end;
$ eod
$ checksum [.rtl]sys.ada
$ if checksum$checksum .nes. "319727695" then write sys$output -
    "    ******Checksum error for file [.rtl]sys.ada******"
$ write sys$output "Creating [.rtl]sys_.ada"
$ create [.rtl]sys_.ada
$ deck
---------------------------------------------------------------------------
--|									|--
--| Title:  Sys								|--
--| Date:   20-MAR-1987							|--
--| Name:   Randy Buckland						|--
--|									|--
--| Purpose:	System service easy routines.				|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Revision History							|--
--|									|--
--| Who	    Date	Description					|--
--| ---	    ----	-----------					|--
--| rcb	    20-MAR-1987	New file.					|--
--|									|--
---------------------------------------------------------------------------
--|									|--
--| Copyright (c) 1987 by Research Triangle Institute.			|--
--| Written by Randy Buckland. Not derived from licensed software.	|--
--|									|--
--| Permission is granted to anyone to use this software for any	|--
--| purpose on any computer system, and to redistribute it freely,	|--
--| subject to the following restrictions.				|--
--|									|--
--| 1. The author is not responsible for the consequences of use of	|--
--|	this software, no matter how awful, even if they arise from	|--
--|	defects in it.							|--
--| 2. The copyright notice must remain a part of all sources files.	|--
--| 3. This software may not be sold in any fashion.			|--
--|									|--
---------------------------------------------------------------------------
with condition_handling;
use  condition_handling;

package sys is

---------------------------------------------------------------------------
--|									|--
--| Routine defintions.							|--
--|									|--
---------------------------------------------------------------------------
procedure sys_exit (
    status : in cond_value_type := 1);

function trnlnm (
    lognam : in string;
    index  : in integer := 0)
    return string;

end;
$ eod
$ checksum [.rtl]sys_.ada
$ if checksum$checksum .nes. "24748231" then write sys$output -
    "    ******Checksum error for file [.rtl]sys_.ada***es hs