⟦4d6965b44⟧

TextFile

procedure init_long_array(arr,init);
<***********************************>
value init; integer init;
long array arr;
begin
<* intialize an array of type long with the value of init *>
integer upper_bound,lower_bound;
long array field laf1,laf2;
lower_bound := system(3,upper_bound,arr);
laf1:= 4 * lower_bound; laf2 := laf1 - 4;
arr.laf2(1) := extend init;
tofrom(arr.laf1,arr.laf2,(upper_bound - lower_bound) * 4);
end init_long_table;
procedure std_table(table);
<*************************>
integer array table;
begin integer i;
for i:=0 step 1 until 127 do
table(i):= case i+1 of
  ( 0,7,7,7,7,7,7,7,7,7,8,7,8,0,7,7,
    7,7,7,7,7,7,7,7,7,8,7,7,7,7,7,7,
    7,7,7,7,7,7,7,5,7,7,7,3,7,3,4,7,
    2,2,2,2,2,2,2,2,2,2,7,7,7,7,7,7,
    7,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
    6,6,6,6,6,6,6,6,6,6,6,6,6,6,7,7,
    7,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
    6,6,6,6,6,6,6,6,6,6,6,6,6,6,7,0) shift 12 + i;
end std_table;
\f




message cg proc lib 800408                             page xx;
integer procedure get_bool_string(search_string,result);
<*******************************************************>
string search_string; boolean result;
begin
long array search_name(1:2);
real array field raf;
raf := 0;
movestring(search_name.raf,1,search_string);
get_bool_string := get_bool_arg(search_name,result);
end get_bool_string;

boolean procedure bool_arg_string(search_string);
<************************************************>
string search_string;
begin
boolean result;
long array search_name(1:2);
real array field raf;
raf := 0;
movestring(search_name.raf,1,search_string);
get_bool_arg(search_name,result);
bool_arg_string := result;
end bool_arg_string;



integer procedure get_bool_arg(search_name,result);
<**************************************************>
long array search_name;
boolean result;
begin
long array param_name,match_name(1:2);
integer sep_and_length,item_no;
boolean default;
real array field raf;
raf := 0;
result := default := false;
 
if search_param_name(search_name,item_no) = 0 then
  begin
  get_bool_arg := 0;
  item_no := item_no + 1;
  
  if system(4,item_no,param_name) extract 12 = 10 then
    begin
    if param_name(1) = long <:yes:> or
       param_name(1) = long <:ja:> then
       result := true
     else
    if param_name(1) = long <:no:> or
       param_name(1) = long <:nej:> then
       result := false
     else
       get_bool_arg := 4;
     end
    else
    get_bool_arg :=4;
   end
 else
  get_bool_arg := 2;
end get_bool_arg;
message cg proc lib 800707;
integer procedure get_text_string(search_string,return_name);
string search_string; long array return_name;
begin
long array search_name(1:2);
real array field raf;
raf := 0;
movestring(search_name.raf,1,search_string);
get_text_string := get_text_arg(search_name,return_name);
end get_text_string;

integer procedure get_text_arg(search_name,return_name);
<*******************************************************>
long array search_name,return_name;
begin
integer item_no,sep_and_length;
real array field raf;
raf := 0;
if search_param_name(search_name,item_no) = 0 then
  begin
  item_no := item_no + 1;
  sep_and_length := system(4,item_no,return_name.raf);
  if sep_and_length extract 12 = 10 then
    get_text_arg := 0
  else
    get_text_arg := 4;
  end
 else get_text_arg := 2;
end get_text_arg;
message cg proc lib 800707;
integer procedure get_int_string(search_string,return);
<*****************************************************>
string search_string; integer return;
begin
long array search_name(1:2);
real array field raf;
raf := 0;
movestring(search_name.raf,1,search_string);
get_int_string := get_int_arg(search_name,return);
end get_int_string;


integer procedure get_int_arg(search_name,return);
<************************************************>
long array search_name;
integer return;
begin
integer sep_and_length,item_no;
long array param_name(1:2);
real array field raf;
raf := 0;
if search_param_name(search_name,item_no) = 0 then
  begin
  item_no := item_no + 1;
  sep_and_length := system(4,item_no,param_name.raf);
  if system(4,item_no,param_name.raf) extract 12 = 4 then
    begin
    return := param_name.raf(1);
    get_int_arg := 0;
    end
   else
    get_int_arg := 4;
  end
 else
  get_int_arg := 2;
end get_int_arg;

integer procedure get_int_set_arg(search_name,return_set,no_in_set);
<******************************************************************>
long array search_name;
long array return_set;
integer no_in_set;
begin
integer sep_and_length,
        item_no,
        set_index,
        low_set,
        high_set;
long array param_name(1:2);
real array field raf;
raf := 0;
low_set := system(3,high_set,return_set);
set_index := low_set;

no_in_set := 0;
if search_param_name(search_name,item_no) = 0 then
  begin
  for item_no := item_no + 1 while
      set_index <= high_set
      and
       system(4,item_no,param_name.raf) = 8 shift 12 + 4 do
    begin
    return_set(set_index) := param_name.raf(1);
    set_index := set_index + 1;
    end;

  no_in_set := set_index - low_set;
  get_int_set_arg := if low_set = set_index then 4 else 0;
  end
 else get_int_set_arg := 2;
end get_int_set_arg;

integer procedure get_int_set_string(search_string,return_set,no_in_set);
string search_string;
long array return_set;
integer no_in_set;
begin
long array search_name(1:2);
real array field raf;
raf := 0;
movestring(search_name.raf,1,search_string);
get_int_set_string := get_int_set_arg(search_name,return_set,no_in_set);
end get_int_set_string;


message cg proc lib 800707;


integer procedure search_param_name(search_name,item_no);
<*******************************************************>
long array search_name;            
integer item_no;
begin
integer search_no,sep_and_length;
long array param_name(1:2);
boolean found;
real array field raf;
raf := 0;
found := false;
search_no := if get_left_side(param_name) = 0 then 2 else 1;
search_param_name := 2;
if search_name(1) extract 8 = 0 then search_name(2) := 0;
for sep_and_length := system(4,search_no,param_name.raf) while
    sep_and_length  <> 0 and -, found do
    begin

    if param_name(1) = search_name(1) and
       param_name(2) = search_name(2) then
       begin
       item_no := search_no;
       found := true;
       search_param_name := 0;
       end
     else search_no := search_no + 1;

     end;
end search_param_name;

integer procedure get_left_side(param_name);
<******************************************>
long array param_name;
begin
integer sep_and_length;
real array field raf;
raf := 0;

get_left_side := 2;
if system(4,1,param_name.raf) = 6 shift 12 + 10 
   <* fp left side *> then
  begin
  get_left_side :=0;
  sep_and_length := system(4,0,param_name.raf);
  end;
end get_left_side;

integer procedure get_next_free_text(param_name);
<***********************************************>
long array param_name;
begin own integer no;
get_next_free_text := get_free_text(no+1,param_name);
no := no + 1;
end get_next_free_text;

integer procedure get_free_text(no,param_name);
<**********************************************>
value no;
integer no;
long array param_name;
begin
real array look_ahead_param(1:2);
real array field raf;
integer start_index,sep_and_length,no_found;
raf:=0;               
no_found := 0;
if get_left_side(param_name) = 0 then
 start_index := 2 else start_index := 1;
repeat
  sep_and_length := system(4,start_index,param_name.raf);
  if sep_and_length  = 4 shift 12 + 10 then
    begin
    sep_and_length :=system(4,start_index + 1,look_ahead_param);                 
    if sep_and_length shift (-12) < 6 then
       no_found := no_found + 1;
     end;
  start_index := start_index+1;
 until sep_and_length = 0 or no_found = no;
 if no = no_found then
   get_free_text := 0
  else
   get_free_text := 2;
end get_free_text;
message cg proc lib 800707 < connect zone >                     page XX;


integer procedure connect_file_in(param_name);
<***************************************>
long array param_name;
begin
own boolean called_before;
integer result;
long array empty_param_name(1:1);
empty_param_name(1) := 0;
result := get_next_free_text(param_name);
if result <> 0 and -, called_before then
  begin
  get_connected_name(in,param_name);
  connect_file_in := 0;
  end
 else
if result <> 0 and called_before then
  begin
  connect_file_in := 2;
  end
 else
if result = 0 then
  begin
  stack_and_connect_in(empty_param_name);
  connect_file_in := stack_and_connect_in(param_name);
  end;
called_before := true;
end connect_file_in;


procedure get_connected_name(z,param_name);
<*****************************************>
zone z;
long array param_name;
begin
integer array tail(1:20);
getzone6(z,tail);

param_name(1) := extend tail(2) shift 24 + tail (3);
param_name(2) := extend tail(4) shift 24 + tail(5);
end get_connected_name;

integer procedure stack_and_connect_in(doc_name);
<**********************************************>
long array doc_name;
begin
<* stack current zone in if docname(1) <> 0 and
   connect current zone in to docname.
   if docname = 0 and in is previous stacked
   then current zone in is unstacked *>
own integer stacked;  
integer result;

if doc_name(1) <> 0 then
  begin
  fp_proc(29) stack current in :(0,in,0);
  fp_proc(27) connect current in:(result,in,doc_name);
  if result <> 0 then
    begin
    fp_proc(30) unstack current in:(0,in,0);
    stack_and_connect_in := 4
    end
   else
    begin
    stacked := stacked + 1;
    stack_and_connect_in := 0
    end;
  end
 else
  if doc_name(1) = 0 then
    begin
    if stacked > 0 then
      begin
      fp_proc(30) unstack current in:(0,in,0);
      stacked := stacked -1;
      end;
    stack_and_connect_in := 0;
    end docname empty;

end stack_and_connect_in;
integer procedure connect_out_to_left_side(allways,drum);
<*******************************************************>
value allways,drum; boolean allways,drum;
<* if all ways then a area is created on 1 segm 
   if the file is not existent then a area is created 
   on 1 segm. if drum the area is created on prefearable drum *>
begin
own integer connected;
integer result, create_mask;
long array docname(1:2);
result := 0;
if  connected = 0 then
  begin
  if get_left_side(doc_name)  = 0 then
     begin
     create_mask := if allways then ( 1 shift 2 ) else 0;
     create_mask := if drum then create_mask add 1 else create_mask;
     result := stack_and_connect_out(doc_name,create_mask);
     if result = 0 then connected := 2 else connected := 6;
      end
     else
     connected := 4;
  end
 else
if connected = 2 then
  begin
  fp_proc(34) close up:(0,out,25);
  fp_proc(79) terminate zone :(0,out,0);
  doc_name(1) :=0;
  result := stack_and_connect_out(doc_name,create_mask);
  connected := 6;
  end;
connect_out_to_left_side := result;
end connect_out_to_left_side;
integer procedure stack_and_connect_out(doc_name,create_mask);
<**********************************************************>
value create_mask; integer create_mask; long array doc_name;
begin
own integer stacked_out;
own long stack_chain_1,stack_chain_2;
integer result;
long array stack_chain_address(1:2);

if doc_name(1) = 0 and stacked_out > 0 then
  begin
  stack_chain_address(1) := stack_chain_1;
  stack_chain_address(2) := stack_chain_2;
  fp_proc(30,0,out,stack_chain_address);
  stacked_out := stacked_out -1;
  stack_and_connect_out := 1;
  end
 else
if doc_name(1) <> 0 then
  begin
  stacked_out := stacked_out + 1;
  fp_proc(29,0,out,stack_chain_address);
  stack_chain_1 := stack_chain_address(1);
  stack_chain_2 := stack_chain_address(2);
  result := create_mask;
  fp_proc(28) connect out:(result,out,doc_name);
  if result = 0 then
    stack_and_connect_out := 0 else
    stack_and_connect_out := result;
   end
  else stack_and_connect_out := 4;
end stack_and_connect_out;
message cg proc lib 800724 < print file and help >     page xx;
procedure get_doc_spec(z,mode,kind,name);
<***************************************>
zone z; integer mode,kind; long array name;
begin
integer array zone_description(1:20);
get_zone6(z,zone_description);
mode := zone_description(1) shift (-12);
kind := zone_description(1) extract 12;
name(1) := extend(zone_description(2)) shift 24
           add zone_description(3);
name(2) := extend(zone_description(4)) shift 24
           add zone_description(5);
end get_doc_spec;


procedure help_string(file_name_string);
<**************************************>
string file_name_string;
begin
long array file_name(1:2);
real array field raf;
raf:=0;
movestring(file_name.raf,1,file_name_string);
help(out,file_name);
end help_string;

procedure help(out,file_name);
<************************>
zone out; long array file_name;
begin
<*  prints the contents of the file <file_name> on current out.
    if current out is a terminal the file is printed 22 lines at 
    in blocks of 22 lines, after which a continuation char is
    asked for.
    if current out is anything else the whole file is printed.
*>

zone help_file(128,1,stderror);
integer array line(0:132); <* line of 0 contain no of last element *>
integer nextchar,linelimit,block_line_limit,
        continuation_char,line_length_limit,line_no,
        last_char, mode, kind;
long array out_doc_name(1:2);
boolean terminal;

integer procedure read_line;
begin
integer char;
nextchar := 1;
repeat
  read_char(help_file,char);
  line(next_char) := char;
  next_char := next_char + 1;
until char = 'nl' or char = 'em' or next_char >= line_length_limit;
read_line := char;
line(0) := nextchar -1;

end;

procedure write_line;
begin
integer char;
for index := 1 step 1 until line(0) do
  outchar(out,line(index));
end;
line_limit := 22;
line_length_limit := 79;

open(help_file,4,file_name,0);
get_doc_spec(out,mode,kind,out_doc_name);
terminal := if kind = 8 then true else false;

repeat
  line_no := 0;
  for line_no := line_no + 1 while last_char <> 'em' and 
                                   line_no <= line_limit do
    begin
    last_char := read_line;
    write_line;
    end;
 if last_char <> 'em' and terminal then
  begin
  write(out,<:<10>>>> MORE HELP? type 'c' otherwise 'e' :>);
  setposition(out,0,0);
  repeat
  read_char(in,continuation_char);
 until continuation_char>32;
  end;
until continuation_char <> 'c' or last_char = 'em' ;

 
close(help_file,true);
setposition(out,0,0);
 
fp_proc(7) finis program:(0,0,0);

end help;
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦4d6965b44⟧ TextFile

Derivation

TextFile
