rcb@rti.UUCP (Randy Buckland) (07/07/87)
[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 hsrcb@rti.UUCP (Randy Buckland) (07/07/87)
This is the second part of the DVI previewer code for VMS.
----------------------------cut here------------------------------
$ write sys$output "Creating [.src]dvi_def_.ada"
$ create [.src]dvi_def_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_def |--
--| Date: 9-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Defintions related to DVI file format. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 9-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. |--
--| |--
---------------------------------------------------------------------------
with font_def;
use font_def;
with unchecked_deallocation;
package dvi_def is
---------------------------------------------------------------------------
--| |--
--| Global types. |--
--| |--
---------------------------------------------------------------------------
type page_array (size : integer) is record
height : integer;
width : integer;
page_number : integer;
bits : pixel_array (1..size);
end record;
type page_ptr is access page_array;
procedure free is new unchecked_deallocation (page_array, page_ptr);
---------------------------------------------------------------------------
--| |--
--| Global variables. |--
--| |--
---------------------------------------------------------------------------
--|
--| Scaling parameters
--|
dvi_to_nano_meter : float;
magstep : float;
page_height : integer;
page_width : integer;
temp_page : page_ptr := null;
prev_page : page_ptr := null;
curr_page : page_ptr := null;
next_page : page_ptr := null;
---------------------------------------------------------------------------
--| |--
--| Constant definitions. |--
--| |--
---------------------------------------------------------------------------
--|
--| Misc constants
--|
resolution : constant := 78.0;
--|
--| Dvi commands
--|
set_char_0 : constant := 0;
set_char_127 : constant := 127;
set1 : constant := 128;
set2 : constant := 129;
set3 : constant := 130;
set4 : constant := 131;
set_rule : constant := 132;
put1 : constant := 133;
put2 : constant := 134;
put3 : constant := 135;
put4 : constant := 136;
put_rule : constant := 137;
nop : constant := 138;
bop : constant := 139;
eop : constant := 140;
push : constant := 141;
pop : constant := 142;
right1 : constant := 143;
right2 : constant := 144;
right3 : constant := 145;
right4 : constant := 146;
w0 : constant := 147;
w1 : constant := 148;
w2 : constant := 149;
w3 : constant := 150;
w4 : constant := 151;
x0 : constant := 152;
x1 : constant := 153;
x2 : constant := 154;
x3 : constant := 155;
x4 : constant := 156;
down1 : constant := 157;
down2 : constant := 158;
down3 : constant := 159;
down4 : constant := 160;
y0 : constant := 161;
y1 : constant := 162;
y2 : constant := 163;
y3 : constant := 164;
y4 : constant := 165;
z0 : constant := 166;
z1 : constant := 167;
z2 : constant := 168;
z3 : constant := 169;
z4 : constant := 170;
fnt_num_0 : constant := 171;
fnt_num_63 : constant := 234;
fnt1 : constant := 235;
fnt2 : constant := 236;
fnt3 : constant := 237;
fnt4 : constant := 238;
xxx1 : constant := 239;
xxx2 : constant := 240;
xxx3 : constant := 241;
xxx4 : constant := 242;
fnt_def1 : constant := 243;
fnt_def2 : constant := 244;
fnt_def3 : constant := 245;
fnt_def4 : constant := 246;
preamble : constant := 247;
postamble : constant := 248;
post_post : constant := 249;
end;
$ eod
$ checksum [.src]dvi_def_.ada
$ if checksum$checksum .nes. "1919110043" then write sys$output -
" ******Checksum error for file [.src]dvi_def_.ada******"
$ write sys$output "Creating [.src]dvi_io.ada"
$ create [.src]dvi_io.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_io |--
--| Date: 9-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Handle input of DVI file. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 9-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. |--
--| |--
---------------------------------------------------------------------------
with text_io, sys, system;
use text_io, sys, system;
with direct_io;
package body dvi_io is
---------------------------------------------------------------------------
--| |--
--| Instantiations. |--
--| |--
---------------------------------------------------------------------------
type dvi_block is array(0..511) of unsigned_byte;
package block_io is new direct_io (dvi_block); use block_io;
---------------------------------------------------------------------------
--| |--
--| Static variables. |--
--| |--
---------------------------------------------------------------------------
--|
--| File access variables.
--|
dvi_file : block_io.file_type;
dvi_record : block_io.count := 0;
dvi_offset : integer := 511;
dvi_buffer : dvi_block;
---------------------------------------------------------------------------
--| |--
--| Open |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Name of DVI file to open. |--
--| |--
--| Description: Open the DVI file. |--
--| |--
---------------------------------------------------------------------------
procedure open (
name : in string) is
begin
open (dvi_file, in_file, name, "file; default_name *.dvi");
exception
when others =>
put_line ("Error opening file " & name);
sys_exit (16#1000002c#);
end;
---------------------------------------------------------------------------
--| |--
--| Find_post |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Find the postamble and position at the POST byte. |--
--| |--
---------------------------------------------------------------------------
procedure find_post is
last_good_record : block_io.count;
offset : block_io.count;
begin
--|
--| Probe past end of file.
--|
begin
dvi_record := 1;
loop
read (dvi_file, dvi_buffer, dvi_record);
last_good_record := dvi_record;
dvi_record := dvi_record * 2;
end loop;
exception
when block_io.end_error => null;
end;
--|
--| Divide difference until end of file is found.
--|
offset := (dvi_record - last_good_record)/2;
while (offset /= 0) loop
begin
read (dvi_file, dvi_buffer, last_good_record + offset);
last_good_record := last_good_record + offset;
exception
when block_io.end_error => null;
end;
offset := offset / 2;
end loop;
--|
--| Scan backwards in buffer until byte with value of 2 is found.
--|
dvi_offset := 511;
dvi_record := last_good_record;
while (dvi_buffer (dvi_offset) = 223) loop
dvi_offset := dvi_offset - 1;
if (dvi_offset < 0) then
dvi_record := dvi_record - 1;
dvi_offset := 511;
read (dvi_file, dvi_buffer, dvi_record);
end if;
end loop;
--|
--| Get position of POST byte and go there
--|
go_to (integer((dvi_record-1)*512)+dvi_offset-4);
go_to (get_4byte);
end;
---------------------------------------------------------------------------
--| |--
--| Go_to |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Offset to goto. |--
--| |--
--| Description: Goto specified offset in file. |--
--| |--
---------------------------------------------------------------------------
procedure go_to (
offset : in integer) is
begin
if (dvi_record /= block_io.count((offset/512)+1)) then
dvi_record := block_io.count((offset/512)+1);
read (dvi_file, dvi_buffer, dvi_record);
end if;
dvi_offset := offset mod 512;
end;
---------------------------------------------------------------------------
--| |--
--| Get_byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return the next 1-4 bytes as an integer. |--
--| |--
---------------------------------------------------------------------------
function get_byte
return integer is
temp : integer;
begin
if (dvi_offset > 511) then
dvi_record := dvi_record + 1;
read (dvi_file, dvi_buffer, dvi_record);
dvi_offset := 0;
end if;
temp := integer (dvi_buffer (dvi_offset));
dvi_offset := dvi_offset + 1;
return temp;
end;
--|
--| Get a 2 byte value
--|
function get_2byte
return integer is
temp : integer := 0;
begin
for i in 1..2 loop
temp := temp*256 + get_byte;
end loop;
return temp;
end;
--|
--| Get a 3 byte value
--|
function get_3byte
return integer is
temp : integer := 0;
begin
for i in 1..3 loop
temp := temp*256 + get_byte;
end loop;
return temp;
end;
--|
--| Get a 4 byte value
--|
function get_4byte
return integer is
temp : bit_array_32;
begin
for i in reverse 0..3 loop
temp(i*8..i*8+7) := to_bit_array_8 (unsigned_byte (get_byte));
end loop;
return integer (to_unsigned_longword (temp));
end;
---------------------------------------------------------------------------
--| |--
--| Get_s_byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Get a sign extended value of 1-4 bytes in |--
--| length and return it as an integer. |--
--| |--
---------------------------------------------------------------------------
function get_s_byte
return integer is
temp : bit_array_32;
begin
temp := to_bit_array_32 (unsigned_longword (get_byte));
temp (8..31) := (8..31 => temp(7));
return integer (to_unsigned_longword (temp));
end;
--|
--| Get a 2 byte value
--|
function get_s_2byte
return integer is
temp : bit_array_32;
begin
temp := to_bit_array_32 (unsigned_longword (get_2byte));
temp (16..31) := (16..31 => temp(15));
return integer (to_unsigned_longword (temp));
end;
--|
--| Get a 3 byte value
--|
function get_s_3byte
return integer is
temp : bit_array_32;
begin
temp := to_bit_array_32 (unsigned_longword (get_3byte));
temp (24..31) := (24..31 => temp(23));
return integer (to_unsigned_longword (temp));
end;
---------------------------------------------------------------------------
--| |--
--| Close |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Close the DVI file. |--
--| |--
---------------------------------------------------------------------------
procedure close is
begin
close (dvi_file);
end;
end;
$ eod
$ checksum [.src]dvi_io.ada
$ if checksum$checksum .nes. "707123688" then write sys$output -
" ******Checksum error for file [.src]dvi_io.ada******"
$ write sys$output "Creating [.src]dvi_io_.ada"
$ create [.src]dvi_io_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_io |--
--| Date: 9-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Handle input of DVI file. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 9-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. |--
--| |--
---------------------------------------------------------------------------
package dvi_io is
---------------------------------------------------------------------------
--| |--
--| Routine definitions. |--
--| |--
---------------------------------------------------------------------------
procedure open (name : in string);
procedure find_post;
procedure go_to (offset : in integer);
function get_byte return integer;
function get_2byte return integer;
function get_3byte return integer;
function get_4byte return integer;
function get_s_byte return integer;
function get_s_2byte return integer;
function get_s_3byte return integer;
procedure close;
end;
$ eod
$ checksum [.src]dvi_io_.ada
$ if checksum$checksum .nes. "1701279364" then write sys$output -
" ******Checksum error for file [.src]dvi_io_.ada******"
$ write sys$output "Creating [.src]dvi_tasks.ada"
$ create [.src]dvi_tasks.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_tasks |--
--| Date: 9-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Task manager for DVI file related operations. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 9-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. |--
--| |--
---------------------------------------------------------------------------
with dvi_io, font_tasks, text_io, sys, str, dvi_translate, ots;
use dvi_io, font_tasks, text_io, sys, str, dvi_translate, ots;
package body dvi_tasks is
---------------------------------------------------------------------------
--| |--
--| Private types. |--
--| |--
---------------------------------------------------------------------------
type page_list_array is array (integer range <>) of integer;
type page_list_ptr is access page_list_array;
---------------------------------------------------------------------------
--| |--
--| Static variables. |--
--| |--
---------------------------------------------------------------------------
--|
--| Page information
--|
page_list : page_list_ptr;
---------------------------------------------------------------------------
--| |--
--| Read_pre |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Read the preamble and get scaling values. |--
--| |--
---------------------------------------------------------------------------
procedure read_pre (
magnification : in float) is
n : float;
d : float;
m : float;
begin
--|
--| Check file type is dvi file
--|
go_to (0);
if (get_byte /= preamble)
or else (get_byte /= 2) then
put_line ("Bad dvi file");
sys_exit (16#1000002c#);
end if;
--|
--| Load scaling parameters
--|
n := float (get_4byte);
d := float (get_4byte);
m := float (get_4byte);
dvi_to_nano_meter := n/d;
magstep := m/1000.0*magnification;
end;
---------------------------------------------------------------------------
--| |--
--| Load_font |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Font load command. |--
--| |--
--| Description: Read font definition and cause it to be loaded |--
--| by the font_load task |--
--| |--
---------------------------------------------------------------------------
procedure load_font (
command : in integer) is
font_number : integer;
name : string(1..60);
size : integer;
scale : float;
trash : integer;
begin
case command is
when fnt_def1 => font_number := get_byte;
when fnt_def2 => font_number := get_2byte;
when fnt_def3 => font_number := get_3byte;
when fnt_def4 => font_number := get_4byte;
when others => null;
end case;
trash := get_4byte; -- Trash checksum
scale := float (get_4byte);
scale := scale / float (get_4byte);
size := get_byte + get_byte;
for i in 1..size loop
name(i) := character'val(get_byte);
end loop;
copy (name(size+1..60), integer'image (integer (scale*magstep*resolution)) &
"PK");
name(size+1) := '.';
for i in name'range loop
size := i-1;
exit when (name(i) = ' ');
end loop;
font_load.add_font (name(1..size), font_number);
end;
---------------------------------------------------------------------------
--| |--
--| Read_post |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Read the postamble and activate the font loader. |--
--| |--
---------------------------------------------------------------------------
procedure read_post (
magnification : in float) is
trash : integer;
page_count : integer;
command : integer;
last_page : integer;
begin
--|
--| Trash header stuff
--|
trash := get_byte; -- Trash POST command
last_page := get_4byte;
trash := get_4byte; -- Trash numerator
trash := get_4byte; -- Trash denominator
trash := get_4byte; -- Trash magnification
trash := get_4byte; -- Trash max length
trash := get_4byte; -- Trash max width
trash := get_2byte; -- Trash max stack depth
page_count := get_2byte;
--|
--| Process font definitions.
--|
loop
command := get_byte;
case command is
when post_post => exit;
when nop => null;
when fnt_def1..fnt_def4 => load_font (command);
when others =>
put_line ("Unknown command in postamble" &
integer'image(command));
sys_exit (16#1000002c#);
end case;
end loop;
--|
--| Build page list
--|
page_list := new page_list_array (1..page_count);
page_list(page_count) := last_page;
loop
page_count := page_count - 1;
exit when (page_count = 0);
go_to (last_page+41);
last_page := get_4byte;
exit when (last_page = -1);
page_list (page_count) := last_page;
end loop;
end;
---------------------------------------------------------------------------
--| |--
--| Reset_page |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Pointer to page. |--
--| |--
--| Description: Reset the data in a page description. |--
--| |--
---------------------------------------------------------------------------
procedure reset_page (
page : in page_ptr) is
begin
page.height := page_height;
page.width := page_width;
page.page_number := 0;
move5 (0, page.bits'address, 0, (page.size+7)/8, page.bits'address);
end;
---------------------------------------------------------------------------
--| |--
--| Load_page |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Page number to load. |--
--| 2. Page pointer to place page into. |--
--| |--
--| Description: Load a page from a DVI file. |--
--| |--
---------------------------------------------------------------------------
procedure load_page (
page_number : in integer;
page : in out page_ptr) is
begin
go_to (page_list(page_number));
reset_page (page);
page.page_number := page_number;
build_page (page);
end;
---------------------------------------------------------------------------
--| |--
--| Dvi_read |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Task to handle reading of DVI file and building |--
--| page images in memory. |--
--| |--
---------------------------------------------------------------------------
task body dvi_read is
do_load : boolean;
begin
--|
--| Initialize file reader
--|
accept init (file_name : in string; magnification : in float;
page_count : out integer) do
open (file_name);
read_pre (magnification);
find_post;
read_post (magnification);
font_load.get_fonts;
page_height := integer (11.0 * resolution * magstep);
page_width := integer (8.5 * resolution * magstep);
page_width := (page_width+7)/8;
page_width := page_width*8;
page_count := page_list'last;
end;
--|
--| Main page loop
--|
loop
select
accept get_next (page : out page_ptr) do
if (next_page.page_number = 0) then
page := curr_page;
else
temp_page := prev_page;
prev_page := curr_page;
curr_page := next_page;
next_page := temp_page;
next_page.page_number := 0;
end if;
page := curr_page;
end;
if (curr_page.page_number < page_list.all'last) then
load_page (curr_page.page_number+1, next_page);
end if;
or
accept get_prev (page : out page_ptr) do
if (prev_page.page_number = 0) then
page := curr_page;
else
temp_page := next_page;
next_page := curr_page;
curr_page := prev_page;
prev_page := temp_page;
prev_page.page_number := 0;
end if;
page := curr_page;
end;
if (curr_page.page_number > 1) then
load_page (curr_page.page_number-1, prev_page);
end if;
or
accept get_page (page_num : in integer; page : out page_ptr) do
if (page_num in page_list'range) then
load_page (page_num, curr_page);
do_load := true;
else
do_load := false;
end if;
page := curr_page;
end;
if (curr_page.page_number > 1) then
load_page (curr_page.page_number-1, prev_page);
else
prev_page.page_number := 0;
end if;
if (curr_page.page_number < page_list.all'last) then
load_page (curr_page.page_number+1, next_page);
else
next_page.page_number := 0;
end if;
or
terminate;
end select;
end loop;
end;
end;
$ eod
$ checksum [.src]dvi_tasks.ada
$ if checksum$checksum .nes. "1332153152" then write sys$output -
" ******Checksum error for file [.src]dvi_tasks.ada******"
$ write sys$output "Creating [.src]dvi_tasks_.ada"
$ create [.src]dvi_tasks_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_tasks |--
--| Date: 9-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Task manager for DVI file related operations. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 9-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. |--
--| |--
---------------------------------------------------------------------------
with dvi_def;
use dvi_def;
package dvi_tasks is
---------------------------------------------------------------------------
--| |--
--| Task definitions. |--
--| |--
---------------------------------------------------------------------------
procedure reset_page (page : in page_ptr);
task dvi_read is
pragma priority(6);
entry init (file_name : in string; magnification : in float;
page_count : out integer);
entry get_next (page : out page_ptr);
entry get_prev (page : out page_ptr);
entry get_page (page_num : in integer; page : out page_ptr);
end;
end;
$ eod
$ checksum [.src]dvi_tasks_.ada
$ if checksum$checksum .nes. "1763783910" then write sys$output -
" ******Checksum error for file [.src]dvi_tasks_.ada******"
$ write sys$output "Creating [.src]dvi_translate.ada"
$ create [.src]dvi_translate.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_translate |--
--| Date: 12-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Translate DVI commands into a bitmap. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 12-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. |--
--| |--
---------------------------------------------------------------------------
with dvi_io, text_io, sys, font_tasks, font_def;
use dvi_io, text_io, sys, font_tasks, font_def;
with unchecked_deallocation;
package body dvi_translate is
---------------------------------------------------------------------------
--| |--
--| Local_types. |--
--| |--
---------------------------------------------------------------------------
type stack_node;
type stack_ptr is access stack_node;
type stack_node is record
h : integer;
v : integer;
w : integer;
x : integer;
y : integer;
z : integer;
next : stack_ptr;
end record;
procedure free is new unchecked_deallocation (stack_node, stack_ptr);
---------------------------------------------------------------------------
--| |--
--| Static values. |--
--| |--
---------------------------------------------------------------------------
--|
--| Positioning parameters.
--|
h : integer;
v : integer;
w : integer;
x : integer;
y : integer;
z : integer;
stack_head : stack_ptr := null;
--|
--| Misc variables
--|
curr_font : font_ptr;
curr_page : page_ptr;
trash : integer;
command : integer;
---------------------------------------------------------------------------
--| |--
--| Push_stack |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Push current positions onto stack. |--
--| |--
---------------------------------------------------------------------------
procedure push_stack is
temp : stack_ptr;
begin
temp := new stack_node;
temp.h := h;
temp.v := v;
temp.w := w;
temp.x := x;
temp.y := y;
temp.z := z;
temp.next := stack_head;
stack_head := temp;
end;
---------------------------------------------------------------------------
--| |--
--| Pop_stack |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Pop top stack positions and place into |--
--| position variables. |--
--| |--
---------------------------------------------------------------------------
procedure pop_stack is
temp : stack_ptr;
begin
if (stack_head /= null) then
temp := stack_head;
stack_head := temp.next;
h := temp.h;
v := temp.v;
w := temp.w;
x := temp.x;
y := temp.y;
z := temp.z;
free (temp);
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Dvi_to_pixel |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Dvi units value to convert. |--
--| |--
--| Description: Convert a DVI units value to a pixel count. |--
--| |--
---------------------------------------------------------------------------
function dvi_to_pixel (
dvi_value : in integer)
return integer is
temp : integer;
begin
temp := integer(float(dvi_value)*
(((dvi_to_nano_meter*magstep)/100000.0/2.54)*resolution));
return temp;
end;
---------------------------------------------------------------------------
--| |--
--| Pixel_to_dvi |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Pixel count to convert to DVI units. |--
--| |--
--| Description: Convert a pixel count to DVI units. |--
--| |--
---------------------------------------------------------------------------
function pixel_to_dvi (
pixel_value : in float)
return integer is
temp : integer;
begin
temp := integer(pixel_value/
(((dvi_to_nano_meter*magstep)/100000.0/2.54)*resolution));
return temp;
end;
---------------------------------------------------------------------------
--| |--
--| Set_font |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Font number. |--
--| |--
--| Description: Set current font to desired font number. |--
--| |--
---------------------------------------------------------------------------
procedure set_font (
font_number : in integer) is
begin
font_search.find_font (font_number, curr_font);
end;
---------------------------------------------------------------------------
--| |--
--| Set_character |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Character to set. |--
--| |--
--| Description: Set a character at current position on the |--
--| bit map and advance the H value. |--
--| |--
---------------------------------------------------------------------------
procedure set_character (
char : in integer) is
x_pos : integer;
y_pos : integer;
char_width : integer;
char_index : integer;
page_index : integer;
begin
x_pos := dvi_to_pixel (h) + integer(resolution*magstep) +
curr_font(char).x_offset;
y_pos := dvi_to_pixel (v) + integer(resolution*magstep) -
(curr_font(char).height + curr_font(char).y_offset);
char_width := curr_font(char).width;
char_index := 1;
page_index := (y_pos-1)*curr_page.width + x_pos;
for i in 1..curr_font(char).height loop
curr_page.bits(page_index..page_index+char_width-1) :=
curr_font(char).bits(char_index..char_index+char_width-1);
char_index := char_index + char_width;
page_index := page_index + curr_page.width;
end loop;
h := h + pixel_to_dvi (curr_font(char).x_delta);
end;
---------------------------------------------------------------------------
--| |--
--| Put_character |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Character to set. |--
--| |--
--| Description: Put a character at current position on the |--
--| bit map. |--
--| |--
---------------------------------------------------------------------------
procedure put_character (
char : in integer) is
x_pos : integer;
y_pos : integer;
char_width : integer;
char_index : integer;
page_index : integer;
begin
x_pos := dvi_to_pixel (h) + integer(resolution*magstep) +
curr_font(char).x_offset;
y_pos := dvi_to_pixel (v) + integer(resolution*magstep) -
(curr_font(char).height + curr_font(char).y_offset);
char_width := curr_font(char).width;
char_index := 1;
page_index := (y_pos-1)*curr_page.width + x_pos;
for i in 1..curr_font(char).height loop
curr_page.bits(page_index..page_index+char_width-1) :=
curr_font(char).bits(char_index..char_index+char_width-1);
char_index := char_index + char_width;
page_index := page_index + curr_page.width;
end loop;
end;
---------------------------------------------------------------------------
--| |--
--| Trash_fnt_def |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Font number being defined. |--
--| |--
--| Description: Read and ignore a font definition since the |--
--| fonts are already being loaded by the font |--
--| tasks. |--
--| |--
---------------------------------------------------------------------------
procedure trash_fnt_def (
font_number : in integer) is
trash : integer;
size : integer;
begin
trash := get_4byte;
trash := get_4byte;
trash := get_4byte;
size := get_byte + get_byte;
for i in 1..size loop
trash := get_byte;
end loop;
end;
---------------------------------------------------------------------------
--| |--
--| Do_special |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Length of special command |--
--| |--
--| Description: Read and discard special commands since they |--
--| are not to be implemented yet. |--
--| |--
---------------------------------------------------------------------------
procedure do_special (
size : in integer) is
temp : string(1..size);
begin
for i in 1..size loop
temp(i) := character'val(get_byte);
end loop;
end;
---------------------------------------------------------------------------
--| |--
--| Set_rule_box |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Set a rule box on the page and advance the |--
--| horizontal position. |--
--| |--
---------------------------------------------------------------------------
procedure set_rule_box is
x_pos : integer;
y_pos : integer;
x_offset : integer;
y_offset : integer;
page_index : integer;
row_count : integer;
row_width : integer;
begin
x_pos := dvi_to_pixel (h) + integer(resolution*magstep);
y_pos := dvi_to_pixel (v) + integer(resolution*magstep);
y_offset := get_4byte;
x_offset := get_4byte;
if (x_offset > 0)
and (y_offset > 0) then
page_index := (y_pos-1)*curr_page.width + x_pos;
row_count := dvi_to_pixel (y_offset);
row_width := dvi_to_pixel (x_offset);
if (row_count < 1) then row_count := 1; end if;
if (row_width < 1) then row_width := 1; end if;
for i in 1..row_count loop
if (row_width = 1) then
curr_page.bits(page_index) := true;
else
curr_page.bits(page_index..page_index+row_width-1) :=
(1..row_width => true);
end if;
page_index := page_index - curr_page.width;
end loop;
end if;
h := h + x_offset;
end;
---------------------------------------------------------------------------
--| |--
--| Put_rule_box |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Put a rule box on the page. |--
--| |--
---------------------------------------------------------------------------
procedure put_rule_box is
x_pos : integer;
y_pos : integer;
x_offset : integer;
y_offset : integer;
page_index : integer;
row_count : integer;
row_width : integer;
begin
x_pos := dvi_to_pixel (h) + integer(resolution*magstep);
y_pos := dvi_to_pixel (v) + integer(resolution*magstep);
y_offset := get_4byte;
x_offset := get_4byte;
if (x_offset > 0)
and (y_offset > 0) then
page_index := (y_pos-1)*curr_page.width + x_pos;
row_count := dvi_to_pixel (y_offset);
row_width := dvi_to_pixel (x_offset);
if (row_count < 1) then row_count := 1; end if;
if (row_width < 1) then row_width := 1; end if;
for i in 1..row_count loop
if (row_width = 1) then
curr_page.bits(page_index) := true;
else
curr_page.bits(page_index..page_index+row_width-1) :=
(1..row_width => true);
end if;
page_index := page_index - curr_page.width;
end loop;
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Build_page |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Pointer to page. |--
--| |--
--| Description: Build a bitmap representation of current page of |--
--| DVI file. Next byte of DVI file should be BOP |--
--| command. |--
--| |--
---------------------------------------------------------------------------
procedure build_page (
page : in page_ptr) is
temp : stack_ptr;
begin
--|
--| Check for valid page start.
--|
if (get_byte /= bop) then
put_line ("Invalid DVI file. Can't find BOP.");
sys_exit;
end if;
--|
--| Set to start state.
--|
curr_page := page;
h := 0;
v := 0;
w := 0;
x := 0;
y := 0;
z := 0;
while (stack_head /= null) loop
temp := stack_head;
stack_head := stack_head.next;
free (temp);
end loop;
curr_font := null;
--|
--| Trash BOP parameters
--|
for i in 1..11 loop
trash := get_4byte;
end loop;
--|
--| Main command loop
--|
loop
command := get_byte;
case command is
when set_char_0..set_char_127 => set_character (command);
when set1 => set_character (get_byte);
when set2 => set_character (get_2byte);
when set3 => set_character (get_3byte);
when set4 => set_character (get_4byte);
when set_rule => set_rule_box;
when put1 => put_character (get_byte);
when put2 => put_character (get_2byte);
when put3 => put_character (get_3byte);
when put4 => put_character (get_4byte);
when put_rule => put_rule_box;
when nop => null;
when eop => exit;
when push => push_stack;
when pop => pop_stack;
when right1 => h := h + get_s_byte;
when right2 => h := h + get_s_2byte;
when right3 => h := h + get_s_3byte;
when right4 => h := h + get_4byte;
when w0 => h := h + w;
when w1 => w := get_s_byte; h := h + w;
when w2 => w := get_s_2byte; h := h + w;
when w3 => w := get_s_3byte; h := h + w;
when w4 => w := get_4byte; h := h + w;
when x0 => h := h + x;
when x1 => x := get_s_byte; h := h + x;
when x2 => x := get_s_2byte; h := h + x;
when x3 => x := get_s_3byte; h := h + x;
when x4 => x := get_4byte; h := h + x;
when down1 => v := v + get_s_byte;
when down2 => v := v + get_s_2byte;
when down3 => v := v + get_s_3byte;
when down4 => v := v + get_4byte;
when y0 => v := v + y;
when y1 => y := get_s_byte; v := v + y;
when y2 => y := get_s_2byte; v := v + y;
when y3 => y := get_s_3byte; v := v + y;
when y4 => y := get_4byte; v := v + y;
when z0 => v := v + z;
when z1 => z := get_s_byte; v := v + z;
when z2 => z := get_s_2byte; v := v + z;
when z3 => z := get_s_3byte; v := v + z;
when z4 => z := get_4byte; v := v + z;
when fnt_num_0..fnt_num_63 => set_font (command - fnt_num_0);
when fnt1 => set_font (get_byte);
when fnt2 => set_font (get_2byte);
when fnt3 => set_font (get_3byte);
when fnt4 => set_font (get_4byte);
when xxx1 => do_special (get_byte);
when xxx2 => do_special (get_2byte);
when xxx3 => do_special (get_3byte);
when xxx4 => do_special (get_4byte);
when fnt_def1 => trash_fnt_def (get_byte);
when fnt_def2 => trash_fnt_def (get_2byte);
when fnt_def3 => trash_fnt_def (get_3byte);
when fnt_def4 => trash_fnt_def (get_4byte);
when others =>
put_line ("Invalid command while setting page.");
sys_exit (16#1000002c#);
end case;
end loop;
end;
end;
$ eod
$ checksum [.src]dvi_translate.ada
$ if checksum$checksum .nes. "947875448" then write sys$output -
" ******Checksum error for file [.src]dvi_translate.ada******"rcb@rti.UUCP (Randy Buckland) (07/07/87)
$ write sys$output "Creating [.src]dvi_translate_.ada"
$ create [.src]dvi_translate_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Dvi_translate |--
--| Date: 12-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Read and translate DVI commands into bitmap. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 12-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. |--
--| |--
---------------------------------------------------------------------------
with dvi_def;
use dvi_def;
package dvi_translate is
---------------------------------------------------------------------------
--| |--
--| Routine definitions. |--
--| |--
---------------------------------------------------------------------------
procedure build_page (
page : in page_ptr);
end;
$ eod
$ checksum [.src]dvi_translate_.ada
$ if checksum$checksum .nes. "1813187772" then write sys$output -
" ******Checksum error for file [.src]dvi_translate_.ada******"
$ write sys$output "Creating [.src]font.ada"
$ create [.src]font.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font |--
--| Date: 30-OCT-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Display a font picture |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 30-OCT-1986 New file. |--
--| rcb 23-JUN-1987 Modify to use version 2 I/O code. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| 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. |--
--| |--
---------------------------------------------------------------------------
with font_def, font_io, uis, text_io, cli, str, condition_handling, sys;
use font_def, font_io, uis, text_io, cli, str, condition_handling, sys;
with starlet, system, tasking_services;
use starlet, system, tasking_services;
procedure font is
---------------------------------------------------------------------------
--| |--
--| Static variables. |--
--| |--
---------------------------------------------------------------------------
type terminator is (up, down, done);
term : terminator;
term_chan : channel_type;
status : cond_value_type;
chars : char_set;
char : integer;
display : display_type;
window : window_type;
x_mag : float;
y_mag : float;
font_file : d_string;
---------------------------------------------------------------------------
--| |--
--| Get_command |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Command code. |--
--| |--
--| Description: Get bytes from the terminal and see if they |--
--| form a known command. |--
--| |--
---------------------------------------------------------------------------
procedure get_command (
term : in out terminator) is
trash : integer;
function get_char
return integer is
code : integer := 0;
status : cond_value_type;
begin
task_qiow (
status => status,
chan => term_chan,
func => io_readvblk or io_m_noecho,
p1 => to_unsigned_longword (code'address),
p2 => 1);
return code;
end;
begin
loop
case get_char is
when 26 => term := done; exit;
when 27 =>
case get_char is
when 91 =>
case get_char is
when 65 => term := up; exit;
when 66 => term := down; exit;
when others => put_line ("Invalid command.");
end case;
when others => put_line ("Invalid command.");
end case;
when others => put_line ("Invalid command.");
end case;
end loop;
end;
---------------------------------------------------------------------------
--| |--
--| Main program. |--
--| |--
---------------------------------------------------------------------------
begin
--|
--| Open channel to terminal
--|
assign (status, "tt:", term_chan);
if not success(status) then
sys_exit (status);
end if;
put_line ("Font display");
--|
--| Get parameters
--|
get_value (status, "font_file", font_file);
chars := load_font (value (font_file));
display := create_display (0.0, 0.0, 11.0, 22.0, 11.0, 22.0);
window := create_window (display, "sys$workstation", "Font display");
--|
--| Find first character
--|
char := 0;
while (chars(char) = null) and (char < 256) loop
char := char + 1;
end loop;
--|
--| Main program loop
--|
loop
erase (display);
x_mag := float(chars(char).width)/float(chars(char).height);
if (x_mag > 1.0) then x_mag := 1.0; end if;
y_mag := float(chars(char).height)/float(chars(char).width);
if (y_mag > 1.0) then y_mag := 1.0; end if;
image (display, 0, 1.0, 12.0, 9.0*x_mag+1.0, 9.0*y_mag+12.0,
chars(char).width, chars(char).height, 1,
chars(char).bits'address);
image_dc(window, 0, 10, 10, chars(char).width+10,
chars(char).height+10, chars(char).width,
chars(char).height, 1, chars(char).bits'address);
put_line ("Character" & integer'image(char));
get_command(term);
case term is
when done => exit;
when down =>
for i in reverse 0..char-1 loop
if (chars(i) /= null) then
char := i;
exit;
end if;
end loop;
when up =>
for i in char+1..255 loop
if (chars(i) /= null) then
char := i;
exit;
end if;
end loop;
when others =>
put_line ("Unknown command");
end case;
end loop;
end;
$ eod
$ checksum [.src]font.ada
$ if checksum$checksum .nes. "1782057255" then write sys$output -
" ******Checksum error for file [.src]font.ada******"
$ write sys$output "Creating [.src]font_def_.ada"
$ create [.src]font_def_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font_def |--
--| Date: 28-AUG-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Define internal font structures. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 28-AUG-1986 New file. |--
--| rcb 2-JUN-1987 Change storage for V2 previewer. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| 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. |--
--| |--
---------------------------------------------------------------------------
with unchecked_deallocation;
package font_def is
---------------------------------------------------------------------------
--| |--
--| Font type definitions. |--
--| |--
---------------------------------------------------------------------------
type pixel_array is array (integer range <>) of boolean;
pragma pack (pixel_array);
type char_array (size : integer) is record
height : integer;
width : integer;
x_offset : integer;
y_offset : integer;
x_delta : float;
bits : pixel_array (1..size);
end record;
type char_ptr is access char_array;
type char_set is array (0..255) of char_ptr;
procedure free is new unchecked_deallocation (char_array, char_ptr);
type font_ptr is access char_set;
procedure free is new unchecked_deallocation (char_set, font_ptr);
end;
$ eod
$ checksum [.src]font_def_.ada
$ if checksum$checksum .nes. "1392846240" then write sys$output -
" ******Checksum error for file [.src]font_def_.ada******"
$ write sys$output "Creating [.src]font_io_.ada"
$ create [.src]font_io_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font_io |--
--| Date: 28-AUG-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Handle all I/O to font files. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 28-AUG-1986 New file. |--
--| rcb 2-JUN-1987 Modified for version 2 previewer. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| 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. |--
--| |--
---------------------------------------------------------------------------
with font_def;
use font_def;
package font_io is
---------------------------------------------------------------------------
--| |--
--| Routine defintions. |--
--| |--
---------------------------------------------------------------------------
function load_font (
name : in string)
return char_set;
end;
$ eod
$ checksum [.src]font_io_.ada
$ if checksum$checksum .nes. "2816" then write sys$output -
" ******Checksum error for file [.src]font_io_.ada******"
$ write sys$output "Creating [.src]font_io_pk.ada"
$ create [.src]font_io_pk.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font_io_pk |--
--| Date: 28-AUG-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Handle all I/O to PK format font files. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 28-AUG-1986 New file. |--
--| rcb 7-MAY-1987 Modified GF font reader to be PK font reader. |--
--| rcb 2-JUN-1987 Modified for version 2 of previewer |--
--| |--
---------------------------------------------------------------------------
--| |--
--| 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. |--
--| |--
---------------------------------------------------------------------------
with system, condition_handling, sys, text_io, ots;
use system, condition_handling, sys, text_io, ots;
with sequential_io;
package body font_io is
---------------------------------------------------------------------------
--| |--
--| Constants |--
--| |--
---------------------------------------------------------------------------
--|
--| PK commands
--|
preamble : constant := 247;
postamble : constant := 245;
pk_format : constant := 89;
---------------------------------------------------------------------------
--| |--
--| Static variables. |--
--| |--
---------------------------------------------------------------------------
type font_node is array(1..512) of unsigned_byte;
package block_io is new sequential_io (font_node); use block_io;
font_file : block_io.file_type;
--font_rec : block_io.count;
font_byte : integer;
font_buff : font_node;
low_nibble : boolean;
high_nibble : integer;
dyn_f : integer; -- Dynamic packing factor.
black_first : boolean; -- Start character with black pixels
repeat_count : integer := 0; -- Number of repeats for current row.
---------------------------------------------------------------------------
--| |--
--| Get_byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return a byte from the file. |--
--| |--
---------------------------------------------------------------------------
function get_byte
return integer is
begin
font_byte := font_byte + 1;
if (font_byte > 512) then
font_byte := 1;
-- font_rec := font_rec + 1;
read (font_file, font_buff);
end if;
return integer (font_buff(font_byte));
end;
---------------------------------------------------------------------------
--| |--
--| Get_2byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return a 2 byte value from the file. |--
--| |--
---------------------------------------------------------------------------
function get_2byte
return integer is
temp : integer;
begin
temp := get_byte;
temp := temp*256 + get_byte;
return temp;
end;
---------------------------------------------------------------------------
--| |--
--| Get_3byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return a 3 byte value from the file. |--
--| |--
---------------------------------------------------------------------------
function get_3byte
return integer is
temp : integer;
begin
temp := get_byte;
temp := temp*256 + get_byte;
temp := temp*256 + get_byte;
return temp;
end;
---------------------------------------------------------------------------
--| |--
--| Get_4byte |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return a 4 byte value from the file. |--
--| |--
---------------------------------------------------------------------------
function get_4byte
return integer is
temp : bit_array_32;
begin
temp(24..31) := to_bit_array_8 (unsigned_byte (get_byte));
temp(16..23) := to_bit_array_8 (unsigned_byte (get_byte));
temp(8..15) := to_bit_array_8 (unsigned_byte (get_byte));
temp(0..7) := to_bit_array_8 (unsigned_byte (get_byte));
return integer (to_unsigned_longword (temp));
end;
---------------------------------------------------------------------------
--| |--
--| Get_nibble |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Return the next nibble from the file. |--
--| |--
---------------------------------------------------------------------------
function get_nibble
return integer is
temp : integer;
begin
if not low_nibble then
low_nibble := true;
return high_nibble;
else
low_nibble := false;
temp := get_byte;
high_nibble := temp mod 16;
return (temp / 16);
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Get_run |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Get the next run count value from the file. |--
--| |--
---------------------------------------------------------------------------
function get_run
return integer is
temp : integer;
count : integer := 0;
begin
temp := get_nibble;
if (temp = 0) then
loop
temp := get_nibble;
count := count + 1;
exit when (temp /= 0);
end loop;
for i in 1..count loop
temp := temp*16+get_nibble;
end loop;
return (temp - 15 + (13 - dyn_f)*16 + dyn_f);
else
if (temp <= dyn_f) then
return temp;
else
if (temp < 14) then
return ((temp - dyn_f - 1)*16 + get_nibble + dyn_f + 1);
else
if (repeat_count /= 0) then
put_line ("Second repeat count for a row");
sys_exit;
end if;
if (temp = 14) then
repeat_count := get_run;
else
repeat_count := 1;
end if;
return get_run;
end if;
end if;
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Get_bits |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Character array entry to get bits for. |--
--| |--
--| Description: Get the bit image of a character. |--
--| |--
---------------------------------------------------------------------------
procedure get_bits (
char : in out char_array) is
line : pixel_array (1..char.width);
pixel : boolean := not black_first;
row : integer := 1;
count : integer := 0;
bit_row : bit_array_8;
bit_count : integer := -1;
begin
--|
--| Check for a straight bitmap
--|
if (dyn_f = 14) then
for row in 1..char.height loop
for column in 1..char.width loop
if (bit_count = -1) then
bit_row := to_bit_array_8 (unsigned_byte (get_byte));
bit_count := 7;
end if;
char.bits((row-1)*char.width+column) := bit_row(bit_count);
bit_count := bit_count - 1;
end loop;
end loop;
--|
--| Get run-encoded character
--|
else
while (row <= char.height) loop
repeat_count := 0;
for column in 1..char.width loop
if (count = 0) then
count := get_run;
pixel := not pixel;
end if;
line(column) := pixel;
count := count - 1;
end loop;
for i in 0..repeat_count loop
char.bits((row-1)*char.width+1..row*char.width) :=
line(1..char.width);
row := row + 1;
end loop;
end loop;
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Load_font |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Name of font file. |--
--| |--
--| Description: Read in font file and convert it to internal |--
--| raster representation. |--
--| |--
---------------------------------------------------------------------------
function load_font (
name : in string)
return char_set is
new_chars : char_set := (others => null); -- Output character array
design_size : integer; -- Design size of font in points * 2e16
hppp : integer; -- Horizontal pixels per point * 2e16
vppp : integer; -- Vertical pixels per point * 2e16
pix_ratio : float; -- Design size in pixels
size : integer; -- Size of a string/packet
trash : integer; -- Any garbage value
x_size : integer; -- Width of character
y_size : integer; -- Height of character
x_offset : integer; -- Horizontal offset from top-left to reference
y_offset : integer; -- Vertical offset from top-left to reference
char : integer; -- Character number.
tfm : integer; -- TFM file width
begin
--|
--| Open font file
--|
begin
put_line ("Opening font file " & name & ".");
open (font_file, in_file, "tex_vs_fonts:" & name);
-- font_rec := 0;
font_byte := 512;
exception
when others =>
put_line ("Font file " & name & " not found.");
sys_exit;
end;
--|
--| Get and trash preamble
--|
if (get_byte /= preamble)
or else (get_byte /= pk_format) then
put_line ("File " & name & " is not PK file format.");
sys_exit;
end if;
size := get_byte;
for i in 1..size loop
trash := get_byte;
end loop;
design_size := get_4byte;
trash := get_4byte;
hppp := get_4byte;
vppp := get_4byte;
pix_ratio := (float(design_size) / 1048576.0) *
(float(hppp) / 1048576.0);
---------------------------------------------------------------------------
--| |--
--| Main character get loop. |--
--| |--
---------------------------------------------------------------------------
loop
trash := get_byte;
if (trash >= 240) then
loop
case trash is
when 240 => size := get_byte;
when 241 => size := get_2byte;
when 242 => size := get_3byte;
when 243 => size := get_4byte;
when 244 => size := 4;
when postamble => size := -1;
when others => size := 0;
end case;
for i in 1..size+1 loop
trash := get_byte;
end loop;
exit when (trash < 240) or (trash = postamble);
end loop;
end if;
exit when (trash = postamble);
--|
--| Get character header
--|
dyn_f := trash / 16; -- Get dynamic packing factor
trash := trash mod 16;
if (trash / 8 = 0) then -- Get black first value
black_first := false;
else
black_first := true;
end if;
trash := trash mod 8;
if (trash < 4) then -- One byte parameters
size := get_byte + ((trash mod 4)*256) - 8;
char := get_byte;
tfm := get_3byte;
trash := get_byte;
x_size := get_byte;
y_size := get_byte;
x_offset := get_byte;
y_offset := get_byte;
if (x_offset > 127) then x_offset := x_offset - 256; end if;
if (y_offset > 127) then y_offset := y_offset - 256; end if;
elsif (trash = 7) then -- Four byte parameters
size := get_4byte - 28;
char := get_4byte;
tfm := get_4byte;
trash := get_4byte;
trash := get_4byte;
x_size := get_4byte;
y_size := get_4byte;
x_offset := get_4byte;
y_offset := get_4byte;
else -- Two byte parameters
size := get_2byte + ((trash mod 4)*65536) - 13;
char := get_byte;
tfm := get_3byte;
trash := get_2byte;
x_size := get_2byte;
y_size := get_2byte;
x_offset := get_2byte;
y_offset := get_2byte;
if (x_offset > 32767) then x_offset := x_offset - 65536; end if;
if (y_offset > 32767) then y_offset := y_offset - 65536; end if;
end if;
--|
--| Create character
--|
new_chars(char) := new char_array (y_size*x_size);
new_chars(char).height := y_size;
new_chars(char).width := x_size;
new_chars(char).x_offset := -x_offset;
new_chars(char).y_offset := y_offset - new_chars(char).height + 1;
new_chars(char).x_delta := (float(tfm) / 65536.0) * pix_ratio;
move5 (0, new_chars(char).bits'address, 0, (new_chars(char).size+7)/8,
new_chars(char).bits'address);
low_nibble := true;
get_bits (new_chars(char).all);
end loop;
--|
--| Finish up
--|
close (font_file);
return new_chars;
end;
end;
$ eod
$ checksum [.src]font_io_pk.ada
$ if checksum$checksum .nes. "155960583" then write sys$output -
" ******Checksum error for file [.src]font_io_pk.ada******"
$ write sys$output "Creating [.src]font_tasks.ada"
$ create [.src]font_tasks.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font_tasks |--
--| Date: 2-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Driving tasks for font manipulation. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 2-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. |--
--| |--
---------------------------------------------------------------------------
with font_io, str, text_io, sys;
use font_io, str, text_io, sys;
package body font_tasks is
---------------------------------------------------------------------------
--| |--
--| Static types and variables. |--
--| |--
---------------------------------------------------------------------------
--|
--| Font list types
--|
type font_node;
type font_node_ptr is access font_node;
type font_node is record
font_number : integer := 0;
font_name : d_string;
font : font_ptr := null;
next : font_node_ptr := null;
end record;
font_head : font_node_ptr := null;
font_tail : font_node_ptr := null;
---------------------------------------------------------------------------
--| |--
--| Font_load |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Load a set of fonts in the background. |--
--| |--
---------------------------------------------------------------------------
task body font_load is
temp : font_node_ptr;
temp2 : font_ptr;
begin
loop
select
--|
--| Add new font to list
--|
accept add_font (font_name : in string; font_number : in integer) do
temp := new font_node;
temp.font_number := font_number;
copy (temp.font_name, font_name);
if (font_head = null) then
font_head := temp;
else
font_tail.next := temp;
end if;
font_tail := temp;
end;
or
--|
--| Go get fonts
--|
accept get_fonts;
exit;
or
terminate;
end select;
end loop;
---------------------------------------------------------------------------
--| |--
--| Main loop to get all fonts. |--
--| |--
---------------------------------------------------------------------------
temp := font_head;
while (temp /= null) loop
temp2 := new char_set;
temp2.all := load_font (value (temp.font_name));
temp.font := temp2;
font_search.check_again;
temp := temp.next;
end loop;
font_search.load_done;
end;
---------------------------------------------------------------------------
--| |--
--| Font_search |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Description: Search for a font and see if it has been |--
--| loaded yet. |--
--| |--
---------------------------------------------------------------------------
task body font_search is
temp : font_node_ptr;
done : boolean := false;
begin
loop
--|
--| Accept status calls outside of a search.
--|
select
accept check_again;
or
accept load_done;
done := true;
or
--|
--| Search for a font by number
--|
accept find_font (font_number : in integer; font : out font_ptr) do
temp := font_head;
while (temp /= null) loop
exit when (temp.font_number = font_number);
temp := temp.next;
end loop;
if (temp = null) then
put_line ("Font" & integer'image(font_number) &
" not found.");
sys_exit;
end if;
--|
--| Either return font pointer or wait for it to be loaded.
--|
if (temp.font = null) then
loop
if (done) then
put_line ("Font not being loaded");
sys_exit;
end if;
select
accept check_again;
or
accept load_done;
done := true;
or
terminate;
end select;
exit when (temp.font /= null);
end loop;
end if;
font := temp.font;
end;
or
terminate;
end select;
end loop;
end;
end;
$ eod
$ checksum [.src]font_tasks.ada
$ if checksum$checksum .nes. "1429518831" then write sys$output -
" ******Checksum error for file [.src]font_tasks.ada******"
$ write sys$output "Creating [.src]font_tasks_.ada"
$ create [.src]font_tasks_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Font_tasks |--
--| Date: 2-JUN-1987 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Driving tasks for font manipulation. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 2-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. |--
--| |--
---------------------------------------------------------------------------
with font_def;
use font_def;
package font_tasks is
---------------------------------------------------------------------------
--| |--
--| Task definitions. |--
--| |--
---------------------------------------------------------------------------
task font_load is
pragma priority(5);
entry add_font (font_name : in string; font_number : in integer);
entry get_fonts;
end;
task font_search is
pragma priority(6);
entry find_font (font_number : in integer; font : out font_ptr);
entry check_again;
entry load_done;
end;
end;
$ eod
$ checksum [.src]font_tasks_.ada
$ if checksum$checksum .nes. "823410064" then write sys$output -
" ******Checksum error for file [.src]font_tasks_.ada******"
$ write sys$output "Creating [.src]preview.ada"
$ create [.src]preview.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Preview |--
--| Date: 3-SEP-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Preview a dvi file on a vaxstation. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 3-SEP-1986 New file. |--
--| rcb 20-NOV-1986 Changed shift size to half of visable area. |--
--| rcb 2-JUN-1987 Modified to version 2 previewer. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| 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. |--
--| |--
---------------------------------------------------------------------------
with cli, str, text_io, integer_text_io, condition_handling, float_text_io;
use cli, str, text_io, integer_text_io, condition_handling, float_text_io;
with dvi_tasks, dvi_def, uis, starlet, tasking_services, system, sys;
use dvi_tasks, dvi_def, uis, starlet, tasking_services, system, sys;
procedure preview is
pragma priority (7);
---------------------------------------------------------------------------
--| |--
--| Static variables |--
--| |--
---------------------------------------------------------------------------
type terminator is (up, down, left, right, nxt_page, prv_page, goto_page,
grid, done);
term : terminator;
term_chan : channel_type;
status : cond_value_type;
in_line : d_string;
--|
--| Cli variables
--|
dvi_file : d_string;
temp : d_string;
magstep : integer;
magnify : float := 1.0;
last : natural;
--|
--| Display variables
--|
display_page : page_ptr := null;
curr_page_num : integer := 0;
next_page_num : integer := 0;
page_count : integer := 0;
redisplay : boolean := true;
display : uis.display_type;
window : uis.window_type;
grid_active : boolean := false;
grid_size : float;
grid_gap : integer;
grid_temp : integer;
max_height : constant float := 27.0;
height : float := 28.05;
visible_height : float := 28.05;
llx : integer;
urx : integer;
delta_x : integer;
min_x : integer;
max_width : constant float := 33.0;
width : float := 21.7;
visible_width : float := 21.7;
curr_offset : integer := 1;
max_offset : integer;
pixel_height : integer;
cent_to_pix : constant float := 30.588;
---------------------------------------------------------------------------
--| |--
--| Get_command |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Parameters: 1. Command code. |--
--| |--
--| Description: Get bytes from the terminal and see if they |--
--| form a known command. |--
--| |--
---------------------------------------------------------------------------
procedure get_command (
term : in out terminator) is
trash : integer;
function get_char
return integer is
code : integer := 0;
status : cond_value_type;
begin
task_qiow (
status => status,
chan => term_chan,
func => io_readvblk or io_m_noecho,
p1 => to_unsigned_longword (code'address),
p2 => 1);
return code;
end;
begin
loop
case get_char is
when 26 => term := done; exit;
when 27 =>
case get_char is
when 91 =>
case get_char is
when 65 => term := up; exit;
when 66 => term := down; exit;
when 67 => term := right; exit;
when 68 => term := left; exit;
when 49 => term := grid; exit;
when 52 => term := goto_page; exit;
when 53 => term := prv_page; exit;
when 54 => term := nxt_page; exit;
when others => put_line ("Invalid command.");
end case;
when others => put_line ("Invalid command.");
end case;
when others => put_line ("Invalid command.");
end case;
end loop;
if (term in nxt_page..grid) then
trash := get_char;
end if;
end;
---------------------------------------------------------------------------
--| |--
--| Main program |--
--| |--
---------------------------------------------------------------------------
begin
put_line ("Dvi Previewer");
--|
--| Get parameters
--|
get_value (status, "dvi_file", dvi_file);
get_value (status, "magstep", temp);
get (value (temp), magstep, last);
for i in 1..magstep loop
magnify := magnify * 1.2;
end loop;
--|
--| Activate dvi display code
--|
dvi_read.init (value (dvi_file), magnify, page_count);
prev_page := new page_array (page_width*page_height);
reset_page (prev_page);
curr_page := new page_array (page_width*page_height);
reset_page (curr_page);
next_page := new page_array (page_width*page_height);
reset_page (next_page);
--|
--| Open channel to terminal
--|
assign (status, "tt:", term_chan);
if not success(status) then
sys_exit (status);
end if;
--|
--| Start UIS stuff
--|
height := height * magnify;
if (height > max_height) then
visible_height := max_height;
else
visible_height := height;
end if;
width := width * magnify;
if (width > max_width) then
visible_width := max_width;
else
visible_width := width;
end if;
display := create_display (0.0, 0.0, visible_width, visible_height,
visible_width, visible_height);
disable_display_list (display);
window := create_window (display, "sys$workstation", "Dvi Previewer");
delta_x := integer(visible_width/2.0*cent_to_pix);
min_x := integer((visible_width-width)*cent_to_pix);
llx := 0;
urx := integer(visible_width * cent_to_pix);
pixel_height := integer(visible_height*cent_to_pix);
max_offset := (page_height-pixel_height)*page_width + 1;
set_writing_mode (display, 0, 1, 3);
set_line_style (display, 1, 1, 16#11111111#);
--|
--| Get first page
--|
dvi_read.get_page (1, display_page);
curr_page_num := 1;
put_line ("Page" & integer'image (curr_page_num) & " of" &
integer'image (page_count));
---------------------------------------------------------------------------
--| |--
--| Main loop |--
--| |--
---------------------------------------------------------------------------
loop
if redisplay then
image_dc (window, 0, llx, 0, urx, pixel_height,
page_width, pixel_height, 1,
display_page.bits(curr_offset)'address);
redisplay := false;
grid_active := false;
end if;
get_command (term);
case term is
--|
--| Exit program
--|
when done => exit;
--|
--| Goto next page.
--|
when nxt_page =>
if (curr_page_num < page_count) then
erase_dc (window);
dvi_read.get_next (display_page);
redisplay := true;
curr_page_num := curr_page_num + 1;
put_line ("Page" & integer'image (curr_page_num) &
" of" & integer'image (page_count));
else
put_line ("No next page.");
end if;
--|
--| Goto previous page
--|
when prv_page =>
if (curr_page_num > 1) then
erase_dc (window);
dvi_read.get_prev (display_page);
redisplay := true;
curr_page_num := curr_page_num - 1;
put_line ("Page" & integer'image (curr_page_num) &
" of" & integer'image (page_count));
else
put_line ("No previous page.");
end if;
--|
--| Goto arbitrary page
--|
when goto_page =>
put ("Enter page number: ");
begin
get (next_page_num);
exception
when others => next_page_num := 0;
end;
if (next_page_num in 1..page_count) then
erase_dc (window);
curr_page_num := next_page_num;
dvi_read.get_page (curr_page_num, display_page);
redisplay := true;
put_line ("Page" & integer'image (curr_page_num) &
" of" & integer'image (page_count));
else
put_line ("Invalid page number" & integer'image(next_page_num));
end if;
--|
--| Go up on page
--|
when up =>
curr_offset := curr_offset -
integer(visible_height/2.0*cent_to_pix)*page_width;
if (curr_offset < 1) then
curr_offset := 1;
end if;
erase_dc (window);
redisplay := true;
--|
--| Go down on page
--|
when down =>
curr_offset := curr_offset +
integer(visible_height/2.0*cent_to_pix)*page_width;
if (curr_offset > max_offset) then
curr_offset := max_offset;
end if;
erase_dc (window);
redisplay := true;
--|
--| Go right on page
--|
when right =>
llx := llx - delta_x;
if (llx < min_x) then
llx := min_x;
end if;
erase_dc (window);
redisplay := true;
--|
--| Go left on page
--|
when left =>
llx := llx + delta_x;
if (llx > 0) then
llx := 0;
end if;
erase_dc (window);
redisplay := true;
--|
--| Overlay display with grid
--|
when grid =>
if not grid_active then
put ("Grid size (in inches)? ");
begin
get_line (in_line);
get (value(in_line), grid_size, last);
exception
when others => grid_size := 1.0;
end;
end if;
grid_active := not grid_active;
grid_gap := integer(grid_size*resolution*magnify);
if (grid_gap < 1) then
grid_gap := 1;
end if;
grid_temp := 0;
while (grid_temp < display_page.width) loop
plot_dc (window, 1, grid_temp+llx, 0, grid_temp+llx,
integer(visible_height*cent_to_pix));
grid_temp := grid_temp + grid_gap;
end loop;
grid_temp := pixel_height-page_height+(curr_offset/page_width);
while (grid_temp < display_page.height) loop
plot_dc (window, 1, 0, grid_temp,
integer(visible_width*cent_to_pix), grid_temp);
grid_temp := grid_temp + grid_gap;
end loop;
end case;
end loop;
end;
$ eod
$ checksum [.src]preview.ada
$ if checksum$checksum .nes. "320031064" then write sys$output -
" ******Checksum error for file [.src]preview.ada******"
$ write sys$output "Creating [.src]uis_.ada"
$ create [.src]uis_.ada
$ deck
---------------------------------------------------------------------------
--| |--
--| Title: Uis |--
--| Date: 28-AUG-1986 |--
--| Name: Randy Buckland |--
--| |--
--| Purpose: Define UIS routines. |--
--| |--
---------------------------------------------------------------------------
--| |--
--| Revision History |--
--| |--
--| Who Date Description |--
--| --- ---- ----------- |--
--| rcb 28-AUG-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. 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. |--
--| |--
---------------------------------------------------------------------------
with system;
use system;
package uis is
---------------------------------------------------------------------------
--| |--
--| Type definitions |--
--| |--
---------------------------------------------------------------------------
subtype display_type is integer;
subtype window_type is integer;
---------------------------------------------------------------------------
--| |--
--| Routine defintions |--
--| |--
---------------------------------------------------------------------------
function create_display (
llx : in float;
lly : in float;
urx : in float;
ury : in float;
width : in float;
height : in float)
return display_type;
pragma interface (rtl, create_display);
pragma import_function (create_display, "uis$create_display");
function create_window (
display : in display_type;
name : in string := "sys$workstation";
label : in string := "";
llx : in float := float'null_parameter;
lly : in float := float'null_parameter;
urx : in float := float'null_parameter;
ury : in float := float'null_parameter;
width : in float := float'null_parameter;
height : in float := float'null_parameter)
return window_type;
pragma interface (rtl, create_window);
pragma import_function (create_window, "uis$create_window");
procedure disable_display_list (
display : in display_type;
flags : in integer := integer'null_parameter);
pragma interface (rtl, disable_display_list);
pragma import_procedure (disable_display_list, "uis$disable_display_list");
procedure erase_dc (
window : in window_type);
pragma interface (rtl, erase_dc);
pragma import_procedure (erase_dc, "uisdc$erase");
procedure erase (
display : in display_type);
pragma interface (rtl, erase);
pragma import_procedure (erase, "uis$erase");
procedure image (
display : in display_type;
attribute : in integer := 0;
llx : in float;
lly : in float;
urx : in float;
ury : in float;
width : in integer;
height : in integer;
pixel_bits : in integer := 1;
buffer : in address);
pragma interface (rtl, image);
pragma import_procedure (image, "uis$image",
(display_type, integer, float, float, float, float, integer,
integer, integer, address),
(reference, reference, reference, reference, reference, reference,
reference, reference, reference, value));
procedure image_dc (
window : in window_type;
attribute : in integer := 0;
llx : in integer;
lly : in integer;
urx : in integer;
ury : in integer;
width : in integer;
height : in integer;
pixel_bits : in integer := 1;
buffer : in address);
pragma interface (rtl, image_dc);
pragma import_procedure (image_dc, "uisdc$image",
(window_type, integer, integer, integer, integer, integer, integer,
integer, integer, address),
(reference, reference, reference, reference, reference, reference,
reference, reference, reference, value));
procedure plot (
display : in display_type;
attr : in integer;
x1 : in float;
y1 : in float;
x2 : in float;
y2 : in float);
pragma interface (rtl, plot);
pragma import_procedure (plot, "uis$plot");
procedure plot_dc (
window : in window_type;
attr : in integer;
x1 : in integer;
y1 : in integer;
x2 : in integer;
y2 : in integer);
pragma interface (rtl, plot_dc);
pragma import_procedure (plot_dc, "uisdc$plot");
procedure set_line_style (
display : in display_type;
in_attr : in integer;
out_attr : in integer;
pattern : in integer);
pragma interface (rtl, set_line_style);
pragma import_procedure (set_line_style, "uis$set_line_style");
procedure set_writing_mode (
display : in display_type;
in_attr : in integer;
out_attr : in integer;
pattern : in integer);
pragma interface (rtl, set_writing_mode);
pragma import_procedure (set_writing_mode, "uis$set_writing_mode");
end;
$ eod
$ checksum [.src]uis_.ada
$ if checksum$checksum .nes. "1212495686" then write sys$output -
" ******Checksum error for file [.src]uis_.ada******"
$ exit