|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 29184 (0x7200)
Types: TextFile
Names: »deletlinktx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »deletlinktx «
begin
<* LAN device delete link declarations first level page ... 1... *>
boolean repeat_param ,
test ;
integer item_count ,
action ,
sub_action ,
point_int ,
point_txt ,
space_int ,
space_txt ,
seplength ,
old_length ,
users ,
modekind ,
devno ,
devtype ,
status ,
result ,
links_removed ,
i ,
j ,
k ;
long reason ;
real array outfile ,
progname ,
chainname ,
item ,
old_item ,
main ,
old_main ,
devname ,
csp (1:2);
zone z_ld (1 , 1, stderror);
\f
<* LAN device delete link parameter scanning page ... 2... *>
procedure display_param_synt (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure displays on the zone z a parameter syn- *>
<* tax survey. *>
<* *>
<***********************************************************>
<*write (z,
<:
( )*
( )1 ( ( )1 ( <s><devname> )* )
( <outfile> = ) deletelink ( ( main.<main> ) ( ) )
( )0 ( ( )0 ( <s><devno> )1 )
( )1
<s> ::= ('sp'/.)
<main> ::= name of main process, default : lanmain1
<devname> ::= name of external process
<devno> ::= device number of external process
:>, "nl", 2);
*>
write (z,
<:
( )*
( )1 ( ( )1 ( <s><devname> )* )
( <outfile> = ) deletelink ( ( l.<lanno> ) ( ) )
( )0 ( ( )0 ( <s><devno> )1 )
( )1
<s> ::= ('sp'/.)
<lanno> ::= number of lan controller, default : 1
<devname> ::= name of external process
<devno> ::= device number of external process
:>, "nl", 2);
\f
<* LAN device delete link parameter scanning page ... 3... *>
procedure prepare_param_scan (item_no);
value item_no ;
integer item_no ;
<***********************************************************>
<* *>
<* The procedure prepares a sequential scan of the fp pa- *>
<* rameters in the fp command stack. *>
<* The scan is supposed to be carried out by the procedu- *>
<* re scan_param. *>
<* The scan is prepared to start in the fp item number *>
<* item_no. *>
<* The scan is implemented by means of the global variab- *>
<* les : *>
<* zone_level, item_count and repeat_param *>
<* where zone_level is the zone stack level and item_count *>
<* is the number of the item in the fp command stack to be *>
<* taken next. *>
<* *>
<* Call: prepare_param_scan (item_no); *>
<* *>
<* item_no (call value, integer). The item number in the *>
<* fp command stack where the parameter scan car- *>
<* ried out by scan_param or repeat_param will be *>
<* started. *>
<* *>
<* Function : *>
<* item_no is assigned to the global item_count *>
<* and the global boolean repeat_param is set false. *>
<* *>
<***********************************************************>
begin
item_count := item_no;
repeat_param := false;
end prepare_param_scan;
\f
<* LAN device delete link parameter scanning page ... 4... *>
integer
procedure scan_param ( item );
real array item ;
<***********************************************************>
<* *>
<* The procedure either returns the parameter which was la-*>
<* test returned or it returns the next parameter governed *>
<* by the global boolean repeat_param. *>
<* The parameter is coded as an item as for system (4,..) *>
<* and is taken from fp command stack *>
<* *>
<* Call: scan_param ( item ); *>
<* *>
<* scan_param (return value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (return value, array). An item is returned *>
<* in item (1:2) as for system (4, ...). *>
<* *>
<***********************************************************>
begin
own integer old_seplength;
own real old_param1, old_param2;
if repeat_param then
begin <*the item id repeated*>
scan_param := old_seplength;
item (1) := old_param1 ;
item (2) := old_param2 ;
repeat_param := false;
end else
begin <*take next item*>
old_seplength := system (4, increase (item_count), item);
old_param1 := item (1) ;
old_param2 := item (2) ;
scan_param := old_seplength ;
end;
end scan_param;
\f
<* LAN device delete link parameter scanning page ... 5... *>
procedure param_warning (z, text);
zone z ;
string text ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the text : *>
<* <:<10>*** <prog name> :> *>
<* followed by the text given in text and the current pa- *>
<* rameter. *>
<* At return, the fp mode bits are : warning.yes *>
<* *>
<* Call : param_warning (z, text); *>
<* *>
<* z (call and return value, zone).The name of the *>
<* document. Determines further the document, the *>
<* buffering and the position of the document. *>
<* text (call value, string). The text to be written. *>
<* *>
<***********************************************************>
begin
integer seplength;
real array item (1:2);
repeat_param := true; <*repeat current parameter*>
seplength := scan_param (item);
write_alarm (z, text);
write_param (z, seplength, item);
write (z, "nl", 1);
errorbits := 2 + errorbits extract 1 ; <*add warning.yes*>
end param_warning;
\f
<* LAN device delete link parameter scanning page ... 6... *>
integer
procedure write_alarm (z, text);
zone z ;
string text ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the text : *>
<* <:<10>_<program name>__<text>__ *>
<* and returns the number of characters written. *>
<* *>
<* call : write_alarm (z, text); *>
<* *>
<* write_alarm (return value, integer). The number of *>
<* characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* text (call value, string). The text to be *>
<* written after the program name. *>
<* *>
<**********************************************************>
begin
long array field laf;
laf := 0;
write (z, "nl", 2);
write_alarm :=
write (z, <:*** :>, prog_name.laf, <: :>, text, <: : :>);
end write_alarm;
\f
<* LAN device delete link parameter scanning page ... 7... *>
integer
procedure write_param (z, seplength, item);
value seplength ;
zone z ;
integer seplength ;
real array item ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the parameter coded *>
<* as an item as for system (4, ...), and returns the num- *>
<* ber of characters written. *>
<* *>
<* Call : write_param (z, seplength, item); *>
<* *>
<* write_param (return parameter, integer). The number *>
<* of characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* seplength (call value, integer). Separator < 12 + *>
<* length as for system (4, ...). *>
<* item (call value, array). An item in item(1:2) *>
<* as for system (4, ...). *>
<* *>
<***********************************************************>
begin
integer separator, length, chars;
long array field laf;
\f
<* LAN device delete link parameter scanning page ... 8... *>
laf := 0; <*fields array to long array*>
separator := seplength shift (-12) extract 12; <*2, 4, 6, or 8*>
length := seplength extract 12; <*4 or 10, or 10+n*8*>
write_param :=
if seplength = 0 then
write (z, <:<end parameter list>:>)
else
write (z, case (separator//2+1) of ("(", "nul", "sp", "=", "."), 1) +
(if length = 4 then
write (z, <<d>, round (item(1)))
else
if length = 10 then
write (z, item.laf)
else
write (z, <:":>, item.laf));
end write_param;
\f
<* LAN device delete link parameter scanning page ... 9..*>
integer
procedure write_char (z, char);
value char ;
zone z ;
integer char ;
<***********************************************************>
<* *>
<* The procedure writes on the zone z the character with *>
<* the iso-value char as a graphical and returns the num- *>
<* ber of characters written. *>
<* *>
<* Call : write_char (z, char); *>
<* *>
<* write_char (return value, integer). The number of *>
<* characters written. *>
<* z (call and return value, zone). The name *>
<* of the document. Determines further the *>
<* document, the buffering and the position *>
<* of the document. *>
<* char (call value, integer).The character with *>
<* iso-value char is written as a graphical. *>
<* *>
<***********************************************************>
begin
write_char := if char <= 'sp' then
write (z, <<d>, "<", 1, char, ">", 1) else
write (z, false add char, 1 ) ;
end write_char;
\f
<* LAN device delete link parameter scanning page ... 10... *>
integer
procedure stack_current_output (file_name);
array file_name ;
<***********************************************************>
<* *>
<* The procedure stacks the current output zone, establi- *>
<* shing a stack zone chain in the global long array *>
<* chain_name, connects the zone to the file file_name and *>
<* returns zero. *>
<* If the zone cannot be connected to the file, the proce- *>
<* dure returns a value > 0 with the zone unstacked again. *>
<* *>
<* Call : stack_current_output (file_name); *>
<* *>
<* stack_current_output (return value, integer). The re- *>
<* sult of the connection. *>
<* file_name (call value, real array). After *>
<* stacking the zone is connected to *>
<* the file whose name is in *>
<* file_name (1:2). *>
<* *>
<***********************************************************>
begin
integer result;
result := 1 shift 2; <*1<2 <=> 1 segment, temporary is enough*>
fp_proc (29, 0, out, chain_name); <*stack c o*>
fp_proc (28, result, out, file__name); <*connect *>
if result <> 0 then
fp_proc (30, 0, out, chain_name); <*unstack *>
stack_current_output := result;
end stack_current_output;
\f
<* LAN device delete link parameter scanning page ... 11... *>
procedure unstack_current_output;
<***********************************************************>
<* *>
<* The procedure unstacks the current output file from the *>
<* stack zone chain given in the global long array chain_ *>
<* name after having closed it up with an 'em' character *>
<* or a 'nl' character and terminated it. *>
<* *>
<***********************************************************>
begin
integer char;
integer array zdescr (1:20);
getzone6 (out, zdescr);
char :=
if zdescr (1) extract 12 = 4 <*bs*>
or zdescr (1) extract 12 = 18 <*mt*> then 'em' else 'nl';
fp_proc (34, 0, out, char); <*close up *>
fp_proc (79, 0, out, 0); <*terminate*>
fp_proc (30, 0, out, chain_name); <*unstack *>
end unstack_current_output;
\f
<* LAN device delete link parameter interpretation page ... 12... *>
integer
procedure unlink__param (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, *>
<* using one look ahead. *>
<* *>
<* Call : unlink__param (seplength, item); *>
<* *>
<* unlink__param (return value, integer). The kind of *>
<* the item : *>
<* 0 end parameter list *>
<* 1 <s>l.<integer> *>
<* 2 <s><name> *>
<* 3 <s><integer> *>
<* 4 <s><unknown> or .<unknown> *>
<* seplength (call value, integer). Separator < 12 *>
<* + length as for system (4, ...). *>
<* item (call value, array). An item in *>
<* item (1:2) as for system (4, ...). *>
<* *>
<* *>
<*********************************************************>
\f
<*make link parameter interpretation page ... 13... *>
begin
integer i, j,
space_txt, point_txt, space_int, point_int,
next_seplength;
real array next_item (1:2);
space_txt := 4 shift 12 + 10;
point_txt := 8 shift 12 + 10;
space_int := 4 shift 12 + 4;
point_int := 8 shift 12 + 4;
next_seplength := scan_param (next_item);
repeat_param := true;
if sep_length = space_txt and
item (1) = real <:l:> and
next_sep_length = point_int then
j := 1
else
if (seplength >= space_txt and
seplength < point_int)
or seplength >= point_txt then
j := 2
else
if seplength = space_int
or seplength = point_int then
j := 3
else
if seplength shift (-12) > 2 then
j := 4
else
j := 0;
unlink__param := j;
if test then
write (out,
"nl", 1, "*", 3, <: unlink_param = :>, case (j + 1) of (
<:<end param list>:>, <:<s>l.<integer>:>, <:<s><name>:>,
<:<s><integer>:>, <:< >unknown:>),
"nl", 1);
end unlink_param;
\f
<* LAN device delete link program head page ... 14... *>
outfile (1) := chain_name (1) := real <::>; <*no outfile, no zone stack*>
prepare_param_scan (0);
scan_param (outfile);
if scan_param (progname) shift (-12) extract 12 <> 6 <*equal*> then
begin <*no outfile, progname is next param after program name*>
for i := 1, 2 do
begin
progname (i) := outfile (i);
outfile (i) := real <::>;
repeat_param := true ; <*progname must be repeated*>
end;
end <*no outfile*>;
if outfile (1) <> real <::> then
begin <*stack current out and connect*>
result := stack_current_output (outfile);
if result <> 0 then
begin <*connect not ok*>
param_warning (out, <:warning outfile param connect impossible:>);
write (out, <: :>, case result of (
<:no resources:>, <:malfunction:>, <:not user, non exist:>,
<:convention error:>, <:not allowed:>, <:name format error:>));
end <*connect not ok*>;
end <*stack current out and connect*>;
\f
<* LAN device delete link program head page ... 15... *>
point_int := 8 shift 12 + 4; point_txt := 8 shift 12 + 10;
space_int := 4 shift 12 + 4; space_txt := 4 shift 12 + 10;
trapmode := 1 shift 10; <*no end <segs>*>
replacechar (8, 0); <*changes last character in write to array to null*>
links_removed := devtype := 0;
movestring (old_main, 1, <::> );
movestring ( main, 1, <:lanmain1:>); <*default*>
open (zld, 0, main, 0);
test := false;
seplength := scan_param (item);
if seplength = space_txt and
item (1) = real <:test:> then
begin
test := true;
seplength := scan_param (item);
end;
\f
<* LAN device delete link program page ... 16... *>
for action := unlink_param (seplength, item) while action > 0 do
begin <*l.<lanno>, <s>name, or <s>integer*>
case action of
begin
begin <*lanno*>
devtype := 0; <*a new device expected*>
seplength := scan_param (item);
if seplength <> point_int then
param_warning (out, <: l.<lanno>:>)
else
begin
write (main, <:lanmain:>, <<d>, round item (1));
main (2) := main (2) shift (-8) shift 8;
close (zld , true);
open (zld , 0, main, 0);
end;
seplength := scan_param (item);
end <*l.<lanno>*>;
begin <*<s>name*>
devtype := 1; <*device read*>
tofrom (devname, item, 8);
devname (2) := devname (2) shift (-8) shift 8; <*at most 11 chars*>
devno := 0;
seplength := scanparam (item);
end <*<s><name>*>;
begin <*<s><integer>*>
devtype := 2; <*device read*>
devno := item (1) ;
devname (1) := devname (2) := real <::>;
seplength := scanparam (item);
end <*<s><integer>*>;
begin <*unknown parameter*>
devtype := 0; <*device not read*>
param_warning (out, <: unknown parameter :>);
seplength := scanparam (item);
end;
end <*case action*>;
\f
<* LAN device delete link program page ... 17... *>
<*lan device unlink*>
if devtype > 0 then
begin <*device accepted*>
if old_main (1) <> main (1)
or old_main (2) <> main (2) then
write (out,
"nl", 2, <:main : :>, main, <: : :>,
"nl", 1);
tofrom (old_main, main, 8);
if ld_unlink (zld, devno, devname, reason) then
begin <*unlinked*>
links_removed := links_removed + 1;
write (out, <<ddd>,
"nl", 1, <:link removed : :>,
true, 12, devname, <: dev. no : :>, devno);
end <*unlinked*>
\f
<* LAN device delete link program page ... 18... *>
else
begin <*not unlinked*>
errorbits := errorbits shift (-1) shift 1 + 1; <*add alarm*>
result := reason shift (-24) extract 12 ;
write (out,
"nl", 1, <:link not removed : :>,
true, 12, devname, <: dev. no : :>);
if devno <= 0 then
write (out, <: - :>)
else
write (out, <<ddd>, devno);
write (out, <<ddd>, "sp", 3, "*", 1);
write (out, case result of (
<: result 1:>,
<: could not be reserved:>,
<: does not identify a link:>,
<: malfunction:>,
<: does not exist:>));
end <*not unlinked*>;
end <*device accepted*>;
end <*case action*>;
\f
<* LAN device delete link program page ... 19... *>
if item_count <=
(if chain_name (1) = real <::> then
(if not test then 3 else 4)
else
(if not test then 4 else 5)) then
display_param_synt (out)
else
write (out,
"nl", 2, <:links removed : :>, links_removed,
"nl", 1);
close (zld, true);
if chain_name (1) <> real <::> then
unstack_current_output;
end;
▶EOF◀