Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 7 < prev next >

Wrap

Text File | 1993-09-02 | 68.7 KB | 2,281 lines

Article 98 of comp.sources.misc: Relay-Version: version B 2.10.3 alpha 5/22/85; site osu-eddie.UUCP Path: osu-eddie!cbosgd!ihnp4!ptsfa!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: 7 Jul 87 01:46:15 GMT Date-Received: 8 Jul 87 03:33:28 GMT Sender: allbery@ncoast.UUCP Lines: 2264 Approved: allbery@ncoast.UUCP X-Archive: comp.sources.misc/8707/7 [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******"