path: root/dviware/crudetype/version3/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;