|
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: 44544 (0xae00)
Types: TextFile
Names: »makelinktx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »makelinktx «
begin
<* LAN device make link declarations first level page ... 1... *>
boolean repeat_param ,
test ;
integer item_count ,
action ,
device_id ,
dev_id_count ,
point_int ,
point_txt ,
space_int ,
space_txt ,
seplength ,
old_length ,
buffers ,
users ,
modekind ,
devno ,
devtype ,
status ,
result ,
links_created ,
i ,
j ,
k ;
long reason ;
integer array zdescr (1:20);
real array outfile ,
progname ,
chainname ,
item ,
old_item ,
main ,
old_main ,
devname ,
lan (1:2);
zone z_ld (1 , 1, stderror);
\f
<* LAN device make link parameter scanning page ... 2... *>
procedure display_param_synt (z);
zone z ;
<***********************************************************>
<* *>
<* The procedure displays on the zone z a parameter syn- *>
<* tax survey. *>
<* *>
<***********************************************************>
if progname (1) = real <:makel:> add 'i' and
progname (2) = real <:nk:> then
write (z,
<:
( )1
( <outfile> = ) makelink,
( )0
( )*
( ( ( (.<name>.<devno>)* )* )* )
( ( )1 ( ( (all) )1 ( (.<name> ) ) ) )
( ( l.<lanno> ) ( ( users.( ) ) ( <type> ( ) ) ) )
( ( )0 ( ( (one) )0 ( (.<devno>.<name>) ) ) )
( ( ( (.<devno> )1 )1 )1 )
( )1
<type> ::= console / printer / 3270in / 3270out / floppy
all/one default : all
<lanno> ::= number of lan controller default : 1
<name> ::= (<devname> / <devname>.<lan dev>) (.log)
<devname> ::= name of external process default : wrk-name
<devno> ::= device number of external process default : first free
<lan dev> ::= name of lan device obl. for console / printer
.log opt. for console
:>, "nl", 0)
else
\f
<* LAN device make link parameter scanning page ... 2a... *>
write (z,
<:
( )1
( <outfile> = ) makelink,
( )0
( )*
( ( ( (.<name>.<devno>)* )* )* )
( ( )1 ( ( (all) )1 ( (.<name> ) ) ) )
( ( l.<lanno> ) ( ( users.( ) ) ( <type> (.buf.<buffers> ) ) ) )
( ( )0 ( ( (one) )0 ( (.<devno>.<name>) ) ) )
( ( ( (.<devno> )1 )1 )1 )
( )1
<type> ::= console / imc / mailbox / 3270in / 3270out / lanstat /
floppy / printer / streamer
<buffers> ::= integer, if 0 then default (imc) default : buffer claim
all/one default : all
<lanno> ::= number of lan controller default : 1
<name> ::= (<devname> / <devname>.<lan dev>) (.log)
<devname> ::= name of external process default : wrk-name
<devno> ::= device number of external process default : first free
<lan dev> ::= name of lan device obl. for console / printer
.log opt. for console
:>, "nl", 0);
\f
<* LAN device make 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 make 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 make 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 make 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 make 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 make 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 make 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 make 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 make 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 make link parameter interpretation page ... 12... *>
integer
procedure type__param (seplength, item);
value seplength ;
integer seplength ;
real array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given. *>
<* *>
<* Call : type__param (seplength, item); *>
<* *>
<* type__param (return value, integer). The kind of the *>
<* item : *>
<* 0 seplength <><s>, item not below *>
<* 1 seplength = <s>, item = console *>
<* 2 -"- , -"- imc *>
<* 3 -"- , -"- mailbox *>
<* 4 -"- , -"- 3270in *>
<* 5 -"- , -"- 3270out *>
<* 6 -"- , -"- lanstat *>
<* 7 -"- , -"- floppy *>
<* 8 -"- , -"- printer *>
<* 9 -"- , -"- streamer *>
<* 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
<* LAN device make link parameter interpretation page ... 13... *>
begin
integer i, j, space_txt, point_txt;
space_txt := 4 shift 12 + 10;
point_txt := 8 shift 12 + 10;
j := 0;
for i := 1 step 1 until
(if seplength < space_txt
or seplength >= point_txt then 0 else 9) do
if item (1) = real ( case i of (
<:conso:> add 'l',
<:imc:> ,
<:mailb:> add 'o',
<:3270i:> add 'n',
<:3270o:> add 'u',
<:lanst:> add 'a',
<:flopp:> add 'y',
<:print:> add 'e',
<:strea:> add 'm') ) and
item (2) = real ( case i of (
<:e:> ,
<::> ,
<:x:> ,
<::> ,
<:t:> ,
<:t:> ,
<::> ,
<:r:> ,
<:er:> ) ) then
begin j := i; i := 9; end;
type__param := j;
if test then
write (out,
"nl", 1, "*", 10, <: type_param = :>, case (j + 1) of (
<:unknown:>, <:console:>, <:imc:>, <:mailbox:>, <:3270in:>,
<:3270out:>, <:lanstat:>, <:floppy:>, <:printer:>, <:streamer:>),
"nl", 1);
end type__param;
\f
<* LAN device make link parameter interpretation page ... 15... *>
integer
procedure link____param (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, *>
<* using one look ahead. *>
<* *>
<* Call : link____param (seplength, item); *>
<* *>
<* link____param (return value, integer). The kind of *>
<* the item : *>
<* 0 end parameter list *>
<* 1 <s>l.<int> *>
<* 2 <s>users.<name> *>
<* 3 <s><name> and name is <type> *>
<* 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 ... 16... *>
begin
integer i, j, space_txt, point_txt, point_int, next_seplength;
real array next_item (1:2);
space_txt := 4 shift 12 + 10;
point_txt := 8 shift 12 + 10; point_int := 8 shift 12 + 4;
next_seplength := scan_param (next_item);
repeat_param := true;
if type_param (sep_length, item) > 0 then
j := 3
else
if sep_length = space_txt and
item (1) = real <:users:> and
next_seplength = point_txt then
j := 2
else
if sep_length = space_txt and
item (1) = real <:l:> and
next_seplength = point_int then
j := 1
else
if seplength shift (-12) > 2 then
j := 4
else
j := 0;
link____param := j;
if test then
write (out,
"nl", 1, "*", 3, <: link_param = :>, case (j + 1) of (
<:<end param list>:>, <:<s>l.<int>:>, <:<s>users.<name>:>,
<:<s><type>:>, <:< >unknown:>),
"nl", 1);
end link_param;
\f
<* LAN device make link parameter interpretation page ... 17... *>
boolean
procedure lanname_param (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, *>
<* using one look ahead. *>
<* *>
<* Call : lanname_param (seplength, item); *>
<* *>
<* lanname_param (return value, boolean). The kind of *>
<* the item : *>
<* false not <.><name> *>
<* true <.><name> *>
<* 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 ... 18... *>
begin
integer point_txt;
point_txt := 8 shift 12 + 10;
lan_name_param := seplength >= point_txt;
if test then
write (out,
"nl", 1, "*", 3, <:lan_name_param = :>,
if seplength >= point_txt then
<:yes:>
else
<:no:>,
"nl", 1);
end lan_name_param;
\f
<* LAN device make link parameter interpretation page ... 19... *>
integer
procedure dev_no_name_param (seplength, item);
value seplength ;
integer seplength ;
array item ;
<*********************************************************>
<* *>
<* The procedure returns the kind of the item given, *>
<* using one look ahead. *>
<* *>
<* Call : dev_no_name_param (seplength, item); *>
<* *>
<* dev_no_name_param (return value, boolean). The kind of*>
<* the item : *>
<* 0 none of below *>
<* 1 .buf.<integer> *>
<* 2 .<name>.<integer> *>
<* 3 .<integer>.<name> *>
<* 4 .<name> *>
<* 5 .<integer> *>
<* seplength (call value, integer). Sep. < 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 ... 20... *>
begin
integer j, point_int, point_txt, nextseplength;
real array next_item (1:2);
point_int := 8 shift 12 + 4;
point_txt := 8 shift 12 + 10;
next_seplength := scanparam (next_item);
repeat_param := true;
j :=
if sep_length >= point_txt and
item (1) = real <:buf:> and
next_sep_length = point_int then
1 <*.buf.<int>*>
else
if sep_length >= point_txt and
next_sep_length = point_int then
2 <*.name.integer*>
else
if sep_length = point_int and
next_sep_length >= point_txt then
3 <*.integer.name*>
else
if sep_length >= point_txt then
4 <*.name*>
else
if sep_length = point_int then
5 <*.integer*>
else
0; <*none of above*>
dev_no_name_param := j;
if test then
write (out,
"nl", 1, "*", 3, <:dev_no_name_param = :>, case (j + 1) of (
<:unknown:>, <:buf.<integer>:>, <:.<devname>.<devno>:>,
<:.<devno>.<devname>:>, <:.<devname>:>, <:.<devno>:>),
"nl", 1);
end dev_no_name;
\f
<* LAN device make link program head page ... 21... *>
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 make link program head page ... 22... *>
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 char in write to array to null*>
links_created := devtype := 0;
movestring (old_main, 1, <::> );
movestring ( main, 1, <:lanmain1:>); <*default*>
users := 1; <*all*> <*default*>
modekind := users shift 12 + 0 ;
open (zld, modekind, 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 make link program page ... 23... *>
for action := link_param (seplength, item) while action > 0 do
begin <*l.<int>, users.<name>, type>, or unknown*>
devtype := 0; <*a new <type> expected*>
case action of
begin
begin <*lan no*>
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 , modekind, main, 0);
end;
seplength := scan_param (item);
end <*lan no*>;
begin <*users.*>
seplength := scan_param (item);
if seplength < point_txt then
param_warning (out, <: users.<name>:>)
else
if item (1) <> real <:all:> and
item (1) <> real <:one:> then
param_warning (out, <: users.(all/one):>)
else
begin <*users.item accepted*>
users := if item (1) = real <:all:> then 1 else 0;
modekind := users shift 12 + 0;
close (zld, true);
open (zld, modekind, main, 0);
end <*users.item accepted*>;
seplength := scanparam (item);
end <*users.*>;
\f
<* LAN device make link program page ... 24... *>
begin <*<type>*>
dev_id_count :=
buffers := 0;
devno := -1; <*default*>
devname (1) :=
lan (1) := real <::>; <*default*>
devtype := type_param (seplength, item); <*a new <type> read*>
seplength := scanparam (item);
if dev_no_name_param (seplength, item) = 0 then
param_warning (out, <: <type>.(<name>/<integer>):>)
else
for device_id := dev_no_name_param (seplength, item)
while device_id > 0 do
begin <*for device_id*>
case device_id of
begin
begin <*.buf.<integer>*>
seplength := scanparam (item) ;
buffers := item (1);
end <*.buf.<integer>*>;
begin <*.name.no*>
tofrom (devname , item, 8);
seplength := scanparam (item) ;
devno := item (1);
end <*.name.no*>;
begin <*.no.name*>
devno := item (1);
seplength := scanparam (item) ;
tofrom (devname , item, 8);
end <*.no.name*>;
begin <*.name*>
devno := -1 ;
tofrom (devname , item, 8);
end <*.name*>;
begin <*.no*>
devno := item (1);
devname (1) := real<::>;
end <*.name*>;
end <*case device_id*>;
devname (2) := devname (2) shift (-8) shift 8; <*at most 11 chars*>
seplength := scanparam (item);
if dev__type = 1 <*console *>
or dev__type = 8 <*printer *> then
begin <*lan name required*>
if device_id = 2 <*.<name>.<integer>*>
or device_id = 5 <* .<integer>*> then
begin <*device_id not proper for lan*>
param_warning (out, <: lan device name missing:>);
device_id := 0;
end
else
if device_id = 3 <*.<integer>.<name>*>
or device_id = 4 <* .<name>*> then
begin <*proper device id*>
if not lan_name_param (seplength, item) then
begin <*lan name not accepted, <type> not accepted*>
param_warning (out, <: lan device name missing:>);
device_id := 0; <*the device_id skipped*>
end <*lan name not accepted, <type> not accepted*>
else
begin <*lan accepted*>
tofrom (lan, item, 8);
lan (2) := lan (2) shift (-16) shift 16; <*at most 10 chars*>
seplength := scan_param (item);
if device_id = 4 <*.<name>.<lan dev>*> and
seplength = point_int then
begin <*.<integer>*>
devno := item (1);
seplength := scan_param (item);
end;
end <*lan accepted*>;
end <*proper device id*>;
end <*lan name required*>;
if device_id > 1 then
increase (dev_id_count);
\f
<* LAN device make link program page ... 25... *>
<*lan device link*>
if dev__type > 0 and
device_id > 1 then
begin <*<type> and <device id> 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);
reason := buffers;
if ld_link (zld, devno, devname, devtype, lan, reason) then
begin <*linked*>
links_created := links_created + 1;
write (out, <<ddd>,
"nl", 1, <: link : :>,
true, 12, devname, <:dev.no : :>, devno,
<: ---> :>, true, 9, case devtype of (
<:console:>, <:imc:> , <:mailbox:>, <:3270in:>, <:3270out:>,
<:lanstat:>, <:floppy:>, <:printer:>, <:streamer:>));
<* if devtype = 2 then
write (out, <:buff. : :>, <<dd>, reason shift (-24) extract 8)
else
write (out, <:index : :>, <<dd>, reason extract 8);
*>
if devtype = 2 <*imc *> then
write (out,
<:max : :>, <<ddddd>, true, 11, reason shift (-32),
<:buf : :>, <<d>, reason shift (-24) extract 8)
else
if devtype = 4 <*3270in *>
or devtype = 5 <*3270out*> then
write (out, <:ix : :>, <<d>, reason extract 8)
else
\f
<* LAN device make link program page ... 26... *>
if devtype = 1
or devtype = 8 then
begin <*lan device*>
zone z1, z2 (128, 1, stderror),
z3 (1 , 1, stderror);
integer array mess, answ, tail(1:20);
integer char, cl_wait;
long array field laf;
write (out,
<:lan : :>, true, 11, lan);
open (z2, 8, devname , 0);
cl_wait := 30;
open (z3, 0, <:clock:>, 0);
close (z3, true);
repeat
getshare6 (z2, mess, 1);
mess (4) := 0; <* sense *>
setshare6 (z2, mess, 1);
monitor (16, z2, 1, answ);
monitor (18, z2, 1, answ);
if answ (1) <> 0 then begin
getshare6 (z3, mess, 1);
mess (4) := 0;
mess (5) := 3; <* wait in 3.sec *>
setshare6 (z3, mess, 1);
monitor (16, z3, 1, answ);
monitor (18, z3, 1, answ);
end else
cl_wait := 0;
cl_wait := cl_wait-1;
until cl_wait <= 0 ;
write (out, <:connected : :>,
if cl_wait < 0 then "+" else "-", 1);
if devtype = 1 and
seplength = point_txt and
item (1) = real <:log:> then
begin <* print s-log *>
seplength := scan_param (item);
open (z1, 4, <:slogarea:>, 0);
<* if devname (1) = long <::> then
begin
monitor (68) generate name: (z2, 1, tail);
laf:= 2;
getzone6 (z2, tail);
devname (1):= tail.laf (1);
devname (2):= tail.laf (2);
create_peripheral ( devname, devout);
end;
*>
if monitor (42) lookup entry :(z1, 1, tail) = 0 and
tail (1) > 0 and
clwait < 0 then
begin
getzone6 (out, tail);
write (out, "nl", 1, "em", 1);
stopzone (out, true);
if tail (1) extract 12 = 4
or tail (1) extract 12 = 18 then
setzone6 (out, tail);
repeat
read_char (z1, char);
out_char (z2, char);
until char = 'em';
out_char (z2, 'nl');
setposition (z2, 0, 0);
<* getzone6 (out, tail);
laf := 2;
*> <* change output document to console *>
<* tail (1):= 8; *><* kind *>
<* tail.laf (1):= devname (1);
tail.laf (2):= devname (2);
setzone6 (out, tail);
*> end;
close (z1, true);
end;
close (z2, true);
end <*lan device*>;
end <*linked*>
\f
<* LAN device make link program page ... 27... *>
else
begin <*not linked*>
errorbits := errorbits shift ( -1) shift 1 + 1; <*add alarm*>
status := reason shift (-36) extract 12;
result := reason shift (-24) extract 12;
write (out,
"nl", 1, <:no link : :>,
true, 12, devname, <:dev.no : :>);
if devno < 0 then
write (out, <: -:>)
else
write (out, <<ddd>, devno);
write (out,
<: +++> :>, true, 9, case devtype of (
<:console:>, <:imc:> , <:mailbox:>, <:3270in:> ,
<:3270out:>, <:lanstat:>, <:floppy:> , <:printer:>,
<:streamer:>));
if status = 0 then
begin <*dummy answer*>
write (out,
"sp", 0, "*", 1);
write (out,
<: lan/ext:>, case (result - 1) of (
<: not user/not res.:>,
<: unintelligible:>,
<: malfunction:>,
<: does not exist:>))
end <*dummy answer*>
\f
<* LAN device make link program page ... 28... *>
else
if status = 4095 then
begin <*create peripheral process*>
write (out,
"sp", 0, "*", 1,
case result of (
<: function forbidden:>,
<: calling process is not user:>,
<: name conflict:>,
<: no such device number:>,
<: reserved by another process:>,
<: name format illegal:>))
end <*create peripheral process*>
else
begin <*status error*>
write (out,
"sp", 0, "*", 1,
if status = 3 then
<: no free external process:>
else
if status = 4 then
<: no free device handler:>
else
<: unknown status:>);
end <*status error*>;
end <*not linked*>;
end <*<type> accepted*>;
end <*for device_id*>;
if dev_id_count = 0 then
param_warning (out, <: <type>.(<name>/<integer>):>);
end <*<type>*>;
begin <*unknown parameter*>
param_warning (out, <: unknown parameter:>);
seplength := scanparam (item);
end;
end <*case action*>;
end <*for action*>;
\f
<* LAN device make link program page ... 29... *>
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 created : :>, links_created,
"nl", 1);
close (zld, true);
if chain_name (1) <> real <::> then
unstack_current_output
else
begin <*empty current out*>
getzone6 (out, zdescr );
write (out, "nl", 1);
stopzone (out, true );
if zdescr (1) extract 12 = 4
or zdescr (1) extract 12 = 18 then
setzone6 (out, zdescr);
end;
end;
▶EOF◀