|
DataMuseum.dkPresents historical artifacts from the history of: DKUUG/EUUG Conference tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DKUUG/EUUG Conference tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: T n
Length: 49368 (0xc0d8)
Types: TextFile
Names: »nosvebind.cyb«
└─⟦060c9c824⟧ Bits:30007080 DKUUG TeX 2/12/89
└─⟦this⟧ »./DVIware/lpr-viewers/crudetype/CYBER/nosvebind.cyb«
└─⟦52210d11f⟧ Bits:30007239 EUUGD2: TeX 3 1992-12
└─⟦af5ba6c8e⟧ »unix3.0/DVIWARE.tar.Z«
└─⟦ca79c7339⟧
└─⟦this⟧ »DVIware/lpr-viewers/crudetype/CYBER/nosvebind.cyb«
Here you find Norbert Schwarz's cybil routines for dynamic file
binding in Pascal which he devoloped for his NOS/VE TeX
implementation. There are four files combined into this file:
ASSOCIATE_FILE_CYBIL and UTM_OPEN2_CYBIL are the Cybil sources,
BINCOR_PAS is a program to do a binary correction to the compiled
output and MAKE_UTM_OPEN2_LIB the installation procedure (study it
to find out what's going on). The binary correction is likely to
change at new system releases.
THe software is by
Norbert Schwarz
Ruhr-Universitaet Bochum, Rechenzentrum
Postfach 102148
D-4630 Bochum 1
P920012 at DBORUB01.BITNET
%%%%%%%%%%%%%%%%% MAKE_UTM_OPEN2_LIB %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
proc make_utm_open2_lib (ergebnis : file = $required ;
debug : name = all );
create_variable ss kind=status;
copy_file $user.tex122.utm_open2_exp_cybil $local.compile
DELETE_FILE $local.UTM_OPEN status=ss
CYBIL $local.COMPILE DA=$value(debug) B=$local.UTM_OPEN l=$local.cybil_liste
" ---> correct the debug match information (loader problem)
" 06c7... is the old declaration matching value
" To get the required new one, use DISPLAY_OBJECT_TEXT
" for the module PAM$$FILE_TABLE_ROUTINE in $SYSTEM.PASCAL.PAF$LIBRARY
collect_text $local.DATEN
UTM_OPEN
06C764D1A410E3EB*
0AAD64BCC195277B*
**
old_catalog=$string($catalog)
set_working_catalog $local
.zztv.tex122.bincor $local.DATEN
set_working_catalog $fname(old_catalog)
create_object_library
add_module $local.utm_open
generate_library $value(ergebnis)
quit
put_line ' utm_open_lib erstellt in'//$string($value(ergebnis))
PROCEND;
%%%%%%%%%%%%%%%%% BINCOR_PAS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
program bincor (input, output);
type byte = 0..255;
t_p = packed array[1..100000] of byte;
t_packed = ^t_p;
twochar = packed array[1..2] of char;
string31 = packed array[1..31] of char;
string_type = packed array[1..17] of char;
word_type = array[1..8] of 0..255;
var infile,outfile : t_packed;
status : integer;
i,j,position : integer;
corr_file_name : string31;
old_wordstring : string_type;
new_wordstring : string_type;
old_word : word_type;
new_word : word_type;
old_lng : integer;
new_lng :integer;
procedure get_string(var instring : string_type);
var i: integer;
c:char;
begin
for i:=1 to 17 do instring[i] := '*';
i:=0;
repeat
if eoln(input) then readln(input);
read(c);
if (c<>'*') and (c<>' ') then begin i:=i+1; instring[i]:=c; end;
until (i=17) or (c='*');
end;
function tobin(c2 : twochar) : integer;
var c: char; i1,i2 : integer;
begin
c :=c2[1];
if (c>='A') then i1:=10+ord(c)-ord('A') else i1:= ord(c)-ord('0');
c :=c2[2];
if (c>='A') then i2:=10+ord(c)-ord('A') else i2:= ord(c)-ord('0');
tobin := i1*16 + i2;
end;
procedure string_value (instring : string_type; var count : integer;
var bytes : word_type);
var i,k : integer; c: char;
c2 : twochar;
begin
count:=0;
i:=1;
while (i<=17) and (instring[i]<>'*') do
begin
c2[1] := instring[i];
c2[2] := instring[i+1];
i:=i+2;
count:=count+1;
bytes[count] := tobin(c2);
end;
end;
procedure tohex(i:byte; var erg : twochar);
var hilf : byte;
begin
hilf := i div 16;
if hilf>9 then erg[1] := chr(ord('A')+hilf-10)
else erg[1] := chr(ord('0')+hilf);
hilf:= i mod 16;
if hilf>9 then erg[2] := chr(ord('A')+hilf-10)
else erg[2] := chr(ord('0')+hilf);
end;
procedure search_string(f : t_packed; to_search : word_type; lng : integer;
var found : integer);
const max_search =20000;
var i,k,l : integer;
gefunden : boolean;
begin
i:=0;
found := -1;
while (i<max_search) do
begin
i:=i+1;
gefunden := true;
j:=0;
while (gefunden) and (j<lng) do
begin if f^[i+j]<> to_search[j+1] then gefunden := false;
j:=j+1;
end;
if gefunden then begin
found := i;
i:= max_search+1;
end;
end;
end;
procedure dump(f : t_packed);
var b :byte;
c2 : twochar;
column : integer;
i:integer;
begin
column :=0;
write(' ');
for i:=1 to 300 do
begin
tohex(f^[i],c2);
write(output,c2);
column :=column + 2;
if column=40 then begin column:= 0; writeln(output); write(' ') end;
end;
end;
procedure associate_file(f:string31;var ff : t_packed; var ii :integer);
external;
begin
for i:=1 to 31 do corr_file_name[i] := ' ';
write(' FILE to be changed: ');
i:=1;
while (not eoln(input)) and (i<32) do begin read(corr_file_name[i]); i:=i+1 end;
readln;
status:=0;
associate_file(corr_file_name,infile,status);
writeln(' Assoziation - status ',status);
dump(infile);
get_string(old_wordstring); get_string(new_wordstring);
string_value(old_wordstring,old_lng,old_word);
string_value(new_wordstring,new_lng,new_word);
write(' to replace >');
for i:=1 to 2*old_lng do write(old_wordstring[i]);
write(' (',old_lng:1,') ');
write('< by the new >');
write(' (',new_lng:1,')');
for i:=1 to 2*new_lng do write(new_wordstring[i]);
writeln('<');
search_string(infile, old_word,old_lng,position);
writeln(' Position ',position);
if position > 0 then
begin
for i:=1 to new_lng do
infile^[position-1+i] := new_word[i];
end;
end .
%%%%%%%%%%%%%%%%% ASSOCIATE_FILE_CYBIL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
module nsm_associate_file;
*copyc AMP$OPEN
*copyc AMP$GET_SEGMENT_POINTER
procedure [XDCL] associate_file (file_name : ost$name;
var file_pointer : ^cell;
var status : integer);
var local_file_name : ost$name;
var file_id : amt$file_identifier;
var status1,status2 : ost$status;
var segment_pointer : amt$segment_pointer;
local_file_name := file_name;
amp$open ( local_file_name, amc$segment, NIL, file_id,status1);
if status1.normal then
amp$get_segment_pointer ( file_id,
amc$cell_pointer,
segment_pointer,
status2);
file_pointer := segment_pointer.cell_pointer;
if status2.normal then status := 0 else
status := status2.condition;
ifend;
else
status := status1.condition;
ifend;
procend ;
*copyc AMP$GET_FILE_ATTRIBUTES
procedure [XDCL] get_file_length (file_name : ost$name;
var length : integer );
var attributes : ^amt$get_attributes;
var local : boolean;
var old_file : boolean;
var non_empty : boolean;
var status : ost$status;
PUSH attributes : [1..1];
attributes^[1].key := amc$file_length;
amp$get_file_attributes(file_name,attributes^,local,old_file,
non_empty,status);
if status.normal then
length := attributes^[1].file_length;
else
length := -1;
ifend;
procend get_file_length;
modend;
%%%%%%%%%%%%%%%%% UTM_OPEN2_CYBIL %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
module utm_open_module;
{ This routines looks into the file-table-area of the PASCAL-runtime system
{ an searches an entry with an matching "file-variable"-pointer.
{ It is found the file-name will be replaced by the given one of
{ the proceure call }
{ Very very important: As the parameter definition is not known
{ of the corresponding CYBIL-routines of
{ PAF$LIBRARY there has a binary correction
{ of the matching value for the entry
{ PAV$FILE_TABLE_PTR to be done !!!}
{ -------- last change 21.11.1986 Ruhr Universitaet Bochum, Germany
{ Norbert Schwarz }
{ change 12.06.86 included the function }
{ }
{ if a "file-name" begins with a '<' character }
{ then the part between '<' and '>' will be inter- }
{ preted as a SCL string-name, which contains }
{ the catalog/file name }
{ the SCL-string may be an array of strings then }
{ a hierarchical search will be done. }
{ }
{ 16.06.1986 splitting of various open functions in }
{ 'open,openread,openwrite,openintern' }
{ 20.01.1987 introduction of opensegmented / closesegmented }
{ 12.03.1987 introduction of PUT_PARTIAL }
*copyc FSP$OPEN_FILE
*copyc FSP$CLOSE_FILE
*copyc AMP$get_segment_pointer
*copyc AMP$SET_SEGMENT_EOI
*copyc AMP$PUT_NEXT
*copyc AMP$PUT_PARTIAL
*copyc CLP$PUSH_PARAMETERS
*copyc CLP$POP_PARAMETERS
*copyc CLP$SCAN_PARAMETER_LIST
*copyc CLP$GET_VALUE
*copyc CLP$GET_PATH_DESCRIPTION
*copyc CLP$CONVERT_INTEGER_TO_STRING
*copyc AMP$CLOSE
*copyc AMP$GET_FILE_ATTRIBUTES
{*copyc IFP$STORE_TERMINAL }
*copyc CLP$READ_VARIABLE
*copyc PMP$ABORT
*copyc PMP$EXIT
type eightbit_range = 0..255;
type two_word = array[1..2] of integer;
type two_word_id = record
case boolean of
= true = int : two_word,
=false = id : amt$file_identifier,
casend,
recend;
var PAV$FILE_TABLE_PTR : [XREF,READ] ^cell;
procedure [XDCL] set_pascal_name
( VAR file_variable : cell;
file_name : string(31) );
type table_entry = packed record
file_adress : ^cell,
new_name : string(31),
old_name : string(31),
rest1 : string(6),
buffer_ptr : ^cell,
rest2 : string(64),
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var i : integer;
hilf_ptr := PAV$FILE_TABLE_PTR;
for i:=1 to 100 do
if hilf_ptr^[i].file_adress=^file_variable then
hilf_ptr^[i].new_name := file_name;
EXIT set_pascal_name;
ifend;
forend;
PROCEND set_pascal_name;
{ This routine looks into the file_table and searches an entry
{ with an matching file name. Then it replaces the adress of
{ the file-variable by the new given file-variable }
procedure [XDCL] set_file_variable
( VAR file_variable : cell;
file_name : string(31) );
type table_entry = packed record
file_adress : ^cell,
new_name : string(31),
old_name : string(31),
rest1 : string(6),
buffer_ptr : ^cell,
rest2 : string(64),
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var i : integer;
hilf_ptr := PAV$FILE_TABLE_PTR;
for i:=1 to 100 do
if hilf_ptr^[i].new_name = file_name then
hilf_ptr^[i].file_adress:=^file_variable ;
EXIT set_file_variable;
ifend;
forend;
PROCEND set_file_variable;
{ This procedure inserts a new file_name and a new_pointer into }
{ the file-table ! }
procedure [XDCL] insert_file_variable
( VAR file_variable : cell;
file_name : string(31) ;
textfile : boolean );
type byte6 = packed array[1..6] of eightbit_range;
type byte64 = packed array[1..64] of eightbit_range;
type file_ref = packed record
case boolean of
= true = file_adress : ^cell,
= false = file_adress_bin : byte6,
casend,
recend;
type table_entry = packed record
file_pt : file_ref,
new_name : string(31),
old_name : string(31),
rest1 : byte6,
buffer_ptr : ^cell,
rest3 : byte64,
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var nil_test : ^cell;
var i : integer;
var k : integer;
var file_adress_bin : integer;
nil_test :=NIL;
hilf_ptr := PAV$FILE_TABLE_PTR;
FOR i:=1 to 100 DO
IF hilf_ptr^[i].file_pt.file_adress_bin[1]=0
THEN
for k:=1 to 6 do hilf_ptr^[i].rest1[k] :=0; forend;
for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
hilf_ptr^[i].file_pt.file_adress:=^file_variable ;
hilf_ptr^[i].old_name:=file_name ;
hilf_ptr^[i].new_name:=file_name;
hilf_ptr^[i].rest1[6] := 050(16);
hilf_ptr^[i].buffer_ptr := NIL;
hilf_ptr^[i].rest3[16] := 0;
IF textfile THEN
hilf_ptr^[i].rest3[17] := 1;
ELSE
hilf_ptr^[i].rest3[17] := 0;
IFEND;
hilf_ptr^[i].rest3[23] := 1;
hilf_ptr^[i].rest3[56] := 1;
EXIT insert_file_variable;
ELSE
IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
for k:=1 to 6 do hilf_ptr^[i].rest1[k] :=0; forend;
for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
hilf_ptr^[i].old_name:=file_name ;
hilf_ptr^[i].new_name:=file_name;
hilf_ptr^[i].rest1[6] := 050(16);
hilf_ptr^[i].buffer_ptr := NIL;
hilf_ptr^[i].rest3[16] := 0;
hilf_ptr^[i].rest3[56] := 1;
IF textfile THEN
hilf_ptr^[i].rest3[17] := 1;
ELSE
hilf_ptr^[i].rest3[17] := 0;
IFEND;
hilf_ptr^[i].rest3[23] := 1;
EXIT insert_file_variable;
IFEND
IFEND;
FOREND;
PROCEND insert_file_variable;
{ ====================================================================== }
{ }
{ There are 4 'open' interfaces with different handling of existing files: }
{ }
{ open,openread,openwrite,openintern }
{ }
{ The parameter 'long_name_of_file' may contain a 'path-description' }
{ in '<' and '>' at the beginning of the name. The name betweeen < and > }
{ will be interpreted as a name of a SCL (!) - variable of kind string }
{ which contains a catalog reference }
{ }
{ For example: in SCL CREATE_VARIABLE MY_BASE K=STRING D=1..4 }
{ MY_BASE(1)='$CATALOG' }
{ MY_BASE(2)='$LOCAL' }
{ MY_BASE(3)='$USER.BASE_CATALOG' }
{ MY_BASE(4)=':NVE.SMITH.FRIEND_CATALOG' }
{ }
{ then a content of 'long_name_of_file' like }
{ }
{ '<MY_BASE>DATA' }
{ }
{ will be expanded to (1.) '$CATALOG.DATA' }
{ (2.) '$LOCAL.DATA' }
{ (3.) '$USER.BASE_CATALOG.DATA' }
{ (4.) ':NVE.SMITH.FRIEND_CATALOG.DATA' }
{ }
{ if 'must_be_old'=true !!! }
{ }
{ Then the file, which is found first, will be used. }
{ }
{ if 'must_be_old=false' then the first element only will be used. }
{ }
{ ----------------------------------------------------------------------- }
{ }
{ The procedure 'open' will use only the first element of an }
{ SCL-array and returns if that required file exists. }
{ }
{ The procedure 'openread' requires an existing file and gives }
{ an error if it does an exist. It will will take a search. }
{ }
{ The procedure 'openwrite' uses the first element of an existing }
{ SCL-reference. There is no error return, if that file does not exit. }
{ }
{ The procedure 'openintern' is the internally called routine. }
{ and is given as an outer interface. }
{ }
{ open openread openwrite openintern }
{ ---------------------------------------------------------------------------- }
{ var file_variable : cell X X X X }
{ long_name_of_file : string(64) X X X X }
{ textfile : boolean X X X X }
{ var effektiv_file_name : string(64) X X X X }
{ must_be_old : boolean (false) (true) (false) X }
{ var is_old_file : boolean X - - X }
{ var error : integer X X X X }
{ }
{ parameter-description: }
{ }
{ file_variable : PASCAL file variable e.g. file of char }
{ long_name_of_file : name of the file }
{ textfile : true if the file is of type 'text' }
{ : That is needed in PASCAL (buffering handling) }
{ must_be_old : true, if the file m u s t exist. }
{ If 'true' then an hierarchically search will }
{ be done }
{ is_old_file : returns if the file exists }
{ error : <>0 then an error has happened }
{ }
{------------------------------------------------------------------------------}
const string_length = 64;
type string_type = string(string_length);
PROCEDURE [XDCL] openread (var file_variable : cell;
long_name_of_file : string_type;
textfile : boolean;
var effektiv_file_name : string_type;
var error : integer);
var is_old_file : boolean;
openintern (file_variable,long_name_of_file,textfile,
effektiv_file_name, true ,is_old_file, error)
PROCEND;
PROCEDURE [XDCL] openwrite(var file_variable : cell;
long_name_of_file : string_type;
textfile : boolean;
var effektiv_file_name : string_type;
var error : integer);
var is_old_file : boolean;
openintern (file_variable,long_name_of_file,textfile,
effektiv_file_name, false , is_old_file, error)
PROCEND ;
PROCEDURE [XDCL] open (var file_variable : cell;
long_name_of_file : string_type;
textfile : boolean;
var effektiv_file_name : string_type;
var is_old_file : boolean;
var error : integer);
openintern (file_variable,long_name_of_file,textfile,
effektiv_file_name, false , is_old_file, error)
PROCEND ;
procedure [XDCL] openintern (var file_variable : cell;
long_name_of_file : string_type;
textfile : boolean;
var effektiv_file_name : string_type;
must_be_old : boolean;
var is_old_file : boolean;
var error : integer);
var i : integer;
{ pdt file_pdt ( f : file = $required )
?? PUSH (LISTEXT := ON) ??
VAR
file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
:= [^file_pdt_names, ^file_pdt_params];
VAR
file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
VAR
file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
of clt$parameter_descriptor := [
{ F }
[[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$file_value]]];
?? POP ??
VAR k : integer;
VAR old_file : boolean;
VAR status : ost$status;
var status1,status2,status3,status4 : ost$status;
VAR parameter_pt : ^clt$parameter_list;
VAR value : clt$value;
VAR string_pt : ^ost$string;
var param1 : [STATIC] string(1) := 'F';
var laenge : integer;
var file_reference : clt$file_reference;
var path_container : clt$path_container;
var path : ^pft$path;
var cycle_selector : clt$cycle_selector;
var open_position : clt$open_position;
var local_file : clt$file;
var file_length : integer;
var position : integer;
var expanded_name_of_file: string_type;
var more : boolean;
error :=0;
PUSH parameter_pt : [[ost$string]];
RESET parameter_pt;
NEXT string_pt IN parameter_pt;
position := 1;
/expand/
WHILE TRUE DO
expand_file_name(long_name_of_file, position,
expanded_name_of_file,more);
IF NOT more THEN
error := -1;
is_old_file := false;
RETURN;
IFEND;
position := position + 1; { prepare for next cycle }
string_pt^.value := expanded_name_of_file;
string_pt^.size := string_length;
CLP$PUSH_PARAMETERS (status1);
CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
if not status2.normal then
error := status2.condition;
PMP$ABORT(status2);
ifend;
CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
CLP$POP_PARAMETERS (status4);
if not status3.normal then
error := status3.condition;
PMP$ABORT(status3);
ifend;
CLP$GET_PATH_DESCRIPTION(value.file,
file_reference,
path_container,
path,
cycle_selector,
open_position,
status3);
if status3.normal then
effektiv_file_name :=
file_reference.path_name(1,file_reference.path_name_size);
else
error := status3.condition;
cycle /expand/;
ifend;
get_file_length (value.file.local_file_name,file_length,old_file);
IF old_file or NOT must_be_old THEN
insert_file_variable (file_variable,value.file.local_file_name,
textfile);
is_old_file := old_file ;
RETURN;
IFEND;
WHILEND;
procend;
procedure [XDCL] buildfname (var file_variable : cell;
long_name_of_file : string_type;
textfile : boolean;
var effektiv_file_name : string_type;
must_be_old : boolean;
var is_old_file : boolean;
var error : integer);
var i : integer;
{ pdt file_pdt ( f : file = $required )
?? PUSH (LISTEXT := ON) ??
VAR
file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
:= [^file_pdt_names, ^file_pdt_params];
VAR
file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
VAR
file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
of clt$parameter_descriptor := [
{ F }
[[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$file_value]]];
?? POP ??
VAR k : integer;
VAR old_file : boolean;
VAR status : ost$status;
var status1,status2,status3,status4 : ost$status;
VAR parameter_pt : ^clt$parameter_list;
VAR value : clt$value;
VAR string_pt : ^ost$string;
var param1 : [STATIC] string(1) := 'F';
var laenge : integer;
var file_reference : clt$file_reference;
var path_container : clt$path_container;
var path : ^pft$path;
var cycle_selector : clt$cycle_selector;
var open_position : clt$open_position;
var local_file : clt$file;
var file_length : integer;
var position : integer;
var expanded_name_of_file: string_type;
var more : boolean;
error :=0;
PUSH parameter_pt : [[ost$string]];
RESET parameter_pt;
NEXT string_pt IN parameter_pt;
position := 1;
/expand/
WHILE TRUE DO
expand_file_name(long_name_of_file, position,
expanded_name_of_file,more);
IF NOT more THEN
error := -1;
is_old_file := false;
RETURN;
IFEND;
position := position + 1; { prepare for next cycle }
string_pt^.value := expanded_name_of_file;
string_pt^.size := string_length;
CLP$PUSH_PARAMETERS (status1);
CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
if not status2.normal then
error := status2.condition;
PMP$ABORT(status2);
ifend;
CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
CLP$POP_PARAMETERS (status4);
if not status3.normal then
error := status3.condition;
PMP$ABORT(status3);
ifend;
CLP$GET_PATH_DESCRIPTION(value.file,
file_reference,
path_container,
path,
cycle_selector,
open_position,
status3);
if status3.normal then
effektiv_file_name :=
file_reference.path_name(1,file_reference.path_name_size);
else
error := status3.condition;
cycle /expand/;
ifend;
get_file_length (value.file.local_file_name,file_length,old_file);
IF old_file or NOT must_be_old THEN
is_old_file := old_file ;
RETURN;
IFEND;
WHILEND;
procend;
procedure get_file_length (file_name : ost$name;
var length : integer ;
var old_file : boolean);
var attributes : ^amt$get_attributes;
var local : boolean;
var non_empty : boolean;
var status : ost$status;
PUSH attributes : [1..1];
attributes^[1].key := amc$file_length;
amp$get_file_attributes(file_name,attributes^,local,old_file,
non_empty,status);
if status.normal then
length := attributes^[1].file_length;
else
length := -1;
ifend;
procend get_file_length;
procedure [XDCL] closeread
( VAR file_variable : cell );
type byte2 = packed array[1..2] of eightbit_range;
type byte6 = packed array[1..6] of eightbit_range;
type byte64 = packed array[1..64] of eightbit_range;
type file_ref = packed record
case boolean of
= true = file_adress : ^cell,
= false = file_adress_bin : byte6,
casend,
recend;
type table_entry = packed record
file_pt : file_ref,
new_name : string(31),
old_name : string(31),
file_id : amt$file_identifier,
rest1 : byte2,
buffer_ptr : ^cell,
rest3 : byte64,
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var nil_test : ^cell;
var i : integer;
var k : integer;
var file_adress_bin : integer;
var status : ost$status;
hilf_ptr := PAV$FILE_TABLE_PTR;
FOR i:=1 to 100 DO
IF hilf_ptr^[i].file_pt.file_adress_bin[1]=0 THEN
ELSE
IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
AMP$CLOSE(hilf_ptr^[i].file_id,status);
hilf_ptr^[i].file_id.ordinal := 0;
hilf_ptr^[i].file_id.sequence:= 1;
hilf_ptr^[i].rest1[1] := 0;
hilf_ptr^[i].rest1[2] :=50(16);
for k:=1 to 64 do hilf_ptr^[i].rest3[k] :=0; forend;
hilf_ptr^[i].buffer_ptr := NIL;
hilf_ptr^[i].rest3[16] := 0;
hilf_ptr^[i].rest3[17] := 1;
hilf_ptr^[i].rest3[23] := 1;
EXIT closeread;
IFEND
IFEND;
FOREND;
PROCEND closeread;
procedure [XDCL] get_file_id
( VAR file_variable : cell;
VAR file_id : amt$file_identifier );
type byte2 = packed array[1..2] of eightbit_range;
type byte6 = packed array[1..6] of eightbit_range;
type byte64 = packed array[1..64] of eightbit_range;
type file_ref = packed record
case boolean of
= true = file_adress : ^cell,
= false = file_adress_bin : byte6,
casend,
recend;
type table_entry = packed record
file_pt : file_ref,
new_name : string(31),
old_name : string(31),
file_id : amt$file_identifier,
rest1 : byte2,
buffer_ptr : ^cell,
rest3 : byte64,
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var nil_test : ^cell;
var i : integer;
var k : integer;
var file_adress_bin : integer;
var status : ost$status;
hilf_ptr := PAV$FILE_TABLE_PTR;
FOR i:=1 to 100 DO
IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
file_id := hilf_ptr^[i].file_id;
EXIT get_file_id;
IFEND
FOREND;
PROCEND get_file_id;
{ get the local file name of the file }
procedure [XDCL] get_local_file_name
( VAR file_variable : cell;
VAR file_name : amt$local_file_name );
type byte2 = packed array[1..2] of eightbit_range;
type byte6 = packed array[1..6] of eightbit_range;
type byte64 = packed array[1..64] of eightbit_range;
type file_ref = packed record
case boolean of
= true = file_adress : ^cell,
= false = file_adress_bin : byte6,
casend,
recend;
type table_entry = packed record
file_pt : file_ref,
new_name : amt$local_file_name, {string(31)}
old_name : amt$local_file_name, {string(31)}
file_id : amt$file_identifier,
rest1 : byte2,
buffer_ptr : ^cell,
rest3 : byte64,
recend;
type table_type = packed array[1..100] of table_entry;
var hilf_ptr : ^table_type;
var nil_test : ^cell;
var i : integer;
var k : integer;
var file_adress_bin : integer;
var status : ost$status;
hilf_ptr := PAV$FILE_TABLE_PTR;
FOR i:=1 to 100 DO
IF hilf_ptr^[i].file_pt.file_adress = ^file_variable THEN
file_name:= hilf_ptr^[i].new_name;
EXIT get_local_file_name;
IFEND
FOREND;
PROCEND get_local_file_name;
PROCEDURE [XDCL] put_next (var file_id : amt$file_identifier;
var buffer : cell;
number_of_bytes : amt$working_storage_length);
VAR status : ost$status;
VAR adress : amt$file_byte_address;
AMP$put_next(file_id,^buffer,number_of_bytes,adress,status);
PROCEND put_next;
{ Ausgabe eines mittleren Satzstueckes }
PROCEDURE [XDCL] put_partial (var file_id : amt$file_identifier;
var buffer : cell;
number_of_bytes : amt$working_storage_length);
VAR status : ost$status;
VAR adress : amt$file_byte_address;
AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
amc$continue,status);
PROCEND put_partial;
{ Ausgabe des ersten Teilsatzes }
PROCEDURE [XDCL] put_f_partial (var file_id : amt$file_identifier;
var buffer : cell;
number_of_bytes : amt$working_storage_length);
VAR status : ost$status;
VAR adress : amt$file_byte_address;
AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
amc$start ,status);
PROCEND put_f_partial;
{ Ausgabe des letzten Teilsatzes }
PROCEDURE [XDCL] put_l_partial (var file_id : amt$file_identifier;
var buffer : cell;
number_of_bytes : amt$working_storage_length);
VAR status : ost$status;
VAR adress : amt$file_byte_address;
AMP$put_partial(file_id,^buffer,number_of_bytes,adress,
amc$terminate ,status);
PROCEND put_l_partial;
PROCEDURE expand_file_name ( file_name : string_type;
position : integer; {immer von 1}
var new_file_name : string_type;
var ok : boolean);
var SCL_string_name : string(string_length);
var i,j,k : integer;
var SCL_variable : clt$variable_reference;
var status : ost$status;
var actual_name : string_type;
var curpos : integer;
var begin_of_name : integer;
var test_length : integer;
var test_oldfile : boolean;
var string_position : ost$string;
var string_ptr : ^ ost$string;
{ 1. test of old version without '<' }
IF file_name(1) <> '<' THEN
ok := position = 1;
new_file_name := file_name;
RETURN;
IFEND;
{ get the part between '< ... >' }
i:=1;
REPEAT
i:=i+1;
UNTIL ( file_name(i)='>') or (i=string_length);
begin_of_name := i+ 1; { first character of rest name }
SCL_string_name := file_name(2,begin_of_name-3);
CLP$CONVERT_INTEGER_TO_STRING(position,10,FALSE,string_position,status);
SCL_string_name(begin_of_name-2) := '(';
SCL_string_name(begin_of_name-1,*) :=
string_position.value(1,string_position.size);
SCL_string_name(begin_of_name-1+string_position.size) := ')';
CLP$READ_VARIABLE ( SCL_string_name,SCL_variable,status);
IF NOT status.normal THEN
ok := FALSE;
RETURN;
IFEND;
string_ptr:=^ SCL_variable.value.string_value^[1];
actual_name:=string_ptr^.value;
curpos := string_ptr^.size+1;
actual_name(curpos) := '.';
actual_name(curpos+1,*) := file_name(begin_of_name,*);
ok := TRUE;
new_file_name := actual_name;
PROCEND expand_file_name;
{ The opensegmented/opensegment-routines give the pointer }
{ to the beginning of the file-information usable as a pascal }
{ referenz. }
{ }
{ You can define (in PASCAL) }
{ file_refenz : ^packed array[0..???] of 0..255; }
{ }
{ Then you can do input easily by array references. }
{ Hint: A file of record type "VARIABLE" begins with 14 bytes }
{ header informations }
{ }
{ (There is one "if file_length=0..." with inhibits Output, but }
{ without this, you can do output in the same way. }
{ }
{ in PASCAL }
{ }
{ type byte = 0..255; }
{ two_word = array[1..2] of integer; }
{ byte_ref = ^byte; }
{ string_type = packed array[1..64] of char; }
{ }
{ procedure opensegmented (long_name_of_file }
{ var current_adress : byte_ref; }
{ var effektiv_file_name : string_type; }
{ var is_old_file : boolean; }
{ var file_length : integer; }
{ var file_identifier : two_word; }
{ var error : integer; }
procedure [XDCL] opensegmented (long_name_of_file : string_type;
var file_variable : ^cell;
var effektiv_file_name : string_type;
var is_old_file : boolean;
var file_length : integer;
var file_identifier : amt$file_identifier;
var error : integer);
var i : integer;
{ pdt file_pdt ( f : file = $required )
?? PUSH (LISTEXT := ON) ??
VAR
file_pdt: [STATIC, READ, cls$pdt] clt$parameter_descriptor_table
:= [^file_pdt_names, ^file_pdt_params];
VAR
file_pdt_names: [STATIC, READ, cls$pdt_names_and_defaults]
array [1 .. 1] of clt$parameter_name_descriptor := [['F', 1]];
VAR
file_pdt_params: [STATIC, READ, cls$pdt_parameters] array [1 .. 1]
of clt$parameter_descriptor := [
{ F }
[[clc$required], 1, 1, 1, 1, clc$value_range_not_allowed, [NIL,
clc$file_value]]];
?? POP ??
VAR k : integer;
VAR old_file : boolean;
VAR status : ost$status;
var status1,status2,status3,status4 : ost$status;
var segment_pointer : amt$segment_pointer;
VAR parameter_pt : ^clt$parameter_list;
VAR value : clt$value;
VAR string_pt : ^ost$string;
var param1 : [STATIC] string(1) := 'F';
var laenge : integer;
var file_reference : clt$file_reference;
var path_container : clt$path_container;
var path : ^pft$path;
var cycle_selector : clt$cycle_selector;
var open_position : clt$open_position;
var local_file : clt$file;
var position : integer;
var expanded_name_of_file : string_type;
var more : boolean;
error :=0;
PUSH parameter_pt : [[ost$string]];
RESET parameter_pt;
NEXT string_pt IN parameter_pt;
position := 1;
/expand/
WHILE TRUE DO
expand_file_name(long_name_of_file, position,
expanded_name_of_file,more);
IF NOT more THEN
error := -1;
is_old_file := false;
RETURN;
IFEND;
position := position + 1; { prepare for next cycle }
string_pt^.value := expanded_name_of_file;
string_pt^.size := string_length;
CLP$PUSH_PARAMETERS (status1);
CLP$SCAN_PARAMETER_LIST(parameter_pt^,file_pdt,status2);
if not status2.normal then
error := status2.condition;
PMP$ABORT(status2);
ifend;
CLP$GET_VALUE(param1,1,1,clc$LOW,value,status3);
CLP$POP_PARAMETERS (status4);
if not status3.normal then
error := status3.condition;
PMP$ABORT(status3);
ifend;
CLP$GET_PATH_DESCRIPTION(value.file,
file_reference,
path_container,
path,
cycle_selector,
open_position,
status3);
if status3.normal then
effektiv_file_name :=
file_reference.path_name(1,file_reference.path_name_size);
else
error := status3.condition;
cycle /expand/;
ifend;
get_file_length (value.file.local_file_name,file_length,old_file);
if file_length=0 then
cycle /expand/;
ifend;
FSP$OPEN_FILE (value.file.local_file_name,
amc$segment,
NIL, { file_attachment }
NIL, { default_creation_attributes }
NIL, { mandated_creation_attributes }
NIL, { attribute_validation }
NIL, { attribute_override }
file_identifier,status4);
if status4.normal then
amp$get_segment_pointer(file_identifier,
amc$cell_pointer,
segment_pointer,
status4);
file_variable := segment_pointer.cell_pointer;
if status4.normal then
RETURN;
ifend;
ifend;
WHILEND;
error:=1;
procend opensegmented;
{ set the file_size of a segmented file : the second parameter must }
{ contain the address of the byte behind the last byte of the file }
procedure [XDCL] setsegmenteoi (
file_identifier : two_word_id;
var byte_behind_the_last : cell);
var segment_pointer : amt$segment_pointer;
var file_id : amt$file_identifier;
var status : ost$status;
file_id := file_identifier.id;
segment_pointer.kind := amc$cell_pointer;
segment_pointer.cell_pointer := ^byte_behind_the_last;
AMP$SET_SEGMENT_EOI(file_id,segment_pointer,status);
if not status.normal then
PMP$ABORT(status);
ifend;
procend setsegmenteoi;
{ close the segmented opened file }
procedure [XDCL] closesegmented (file_identifier : two_word_id);
var file_id : amt$file_identifier;
var status : ost$status;
file_id := file_identifier.id;
FSP$CLOSE_FILE(file_id,status);
procend closesegmented;
{ alias definition --- needed as the tangle program shortens the }
{ names to 12 characters }
procedure [XDCL] opensegmente (long_name_of_file : string_type;
var file_variable : ^cell;
var effektiv_file_name : string_type;
var is_old_file : boolean;
var file_length : integer;
var file_identifier : amt$file_identifier;
var error : integer);
opensegmented (long_name_of_file ,
file_variable ,
effektiv_file_name ,
is_old_file ,
file_length ,
file_identifier ,
error )
procend opensegmente;
procedure [XDCL] closesegment (file_identifier : two_word_id);
closesegmented(file_identifier);
procend closesegment;
{ to display any status message for control usage of the job }
procedure [XDCL] display_status ( text : string_type);
var status : ost$status;
*COPYC OFP$DISPLAY_STATUS_MESSAGE
OFP$DISPLAY_STATUS_MESSAGE(text,status);
RETURN;
procend display_status;
{ condition handler for user break two }
{ It must be called with the parameter 'flag' and the name of }
{ a procedure which will be executed with condition handling }
{ PROCEDURE NONBREAK_RUN (VAR FLAG : INTEGER; PROCEDURE P); EXTERNAL; }
{ Then 'P' will be called. 'FLAG' will receive the value '1', if an }
{ user break 2 has occurred. 'FLAG' should be global to 'P', then }
{ 'P' can examince the current value of 'FLAG' }
*copyc pmp$establish_condition_handler
type two_pointer = packed record
binding : ^cell,
static_link : ^cell,
recend;
PROCEDURE [XDCL] nonbreak_run (VAR flag : integer;
main1 : integer; main2 : integer);
VAR routine : record
case boolean of
=true= proc : ^procedure,
=false= cellar : record
int1 : integer,
int2 : integer,
recend,
casend,
recend,
interactive_break : [STATIC] pmt$condition :=
[ifc$interactive_condition, ifc$terminate_break],
interactive_break_descriptor: pmt$established_handler,
status: ost$status;
PROCEDURE ib_handler
( condition: pmt$condition;
condition_descriptor: ^pmt$condition_information;
save_area: ^ost$stack_frame_save_area;
VAR c_status: ost$status);
c_status.normal := TRUE;
CASE condition.interactive_condition OF
= ifc$pause_break =
RETURN;
= ifc$terminate_break =
if flag>0 then
pmp$exit(c_status);
ifend;
flag := 1;
RETURN;
= ifc$terminal_connection_broken =
RETURN;
= ifc$job_reconnect =
RETURN;
CASEND;
PROCEND ib_handler;
flag := 0;
pmp$establish_condition_handler (interactive_break, ^ib_handler,
^interactive_break_descriptor, status);
IF NOT status.normal THEN
PMP$ABORT(status);
IFEND;
routine.cellar.int1 := main1;
routine.cellar.int2 := main2;
routine.proc^;
PROCEND nonbreak_run;
*copyc RMP$GET_DEVICE_CLASS
PROCEDURE [XDCL] terminal_device ( VAR pascal_file_id : cell;
VAR terminal : boolean );
VAR file_name : amt$local_file_name,
device_class : rmt$device_class,
device_assigned : boolean,
status : ost$status;
get_local_file_name ( pascal_file_id, file_name);
RMP$GET_DEVICE_CLASS (file_name,device_assigned,device_class, status);
terminal := status.normal AND
device_assigned AND (device_class<> RMC$MASS_STORAGE_DEVICE)
AND (device_class<> RMC$MAGNETIC_TAPE_DEVICE);
procend terminal_device;
modend;
▶1a◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀▶00◀