|
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: 9984 (0x2700)
Types: TextFile
Names: »mvmcltxt «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »mvmcltxt «
begin
<********************************************************************>
<* Utility MOVEMCL til flytning af oversatte mcl programmer til *>
<* Tas mcl-database *>
<* *>
<* Kald: movemcl <move spec.> *>
<* *>
<* include.<name> *>
<* <move spec.> ::= get.<name> *>
<* lookup.<name> *>
<* lookup *>
<* *>
<* Henning Godske A/S Regnecentralen 861121 *>
<* Compiler call: movemcl=algol mvmcltxt connect.no *>
<********************************************************************>
<**************************************************************>
<* Revision history *>
<* *>
<* 86.12.01 movemcl release 1.0 *>
<**************************************************************>
<* Globale variable *>
zone buf(128,1,std_error); <* Zone til message m.m. *>
integer array user_id(1:4); <* Bruger id fra terminal *>
long password; <* Password fra terminal *>
integer array prog_name(1:4); <* Program navn *>
integer param; <* fp parameter tæller *>
integer array mcl_bases(1:2); <* Bases for mcl files *>
integer array user_bases(1:2); <* Egne bruger baser *>
integer array empty(1:4); <* Tomt navn *>
boolean eof; <* End Of File *>
integer array arr(1:8); <* Work *>
integer array field iaf; <* Work *>
real array field raf; <* Work *>
boolean array field baf; <* Work *>
long array field laf; <* Work *>
integer i; <* Work *>
<* Globale procedure *>
procedure get_userid;
<*-------------------------------------------------------------------*>
<* Set user id og password i de globale variable user_id og password *>
<* Id og password hentes fra terminalen tilknyttet prim. output *>
<*-------------------------------------------------------------------*>
begin
long array term_name(1:2);
integer i;
integer array ia(1:20);
system(7,0,term_name);
open(buf,0,term_name,0);
close(buf,false);
getzone6(buf,ia);
i:=ia(19);
getshare6(buf,ia,1);
ia(4):=131 shift 12;
ia(5):=i+1;
ia(6):=i+11;
ia(7):=0;
setshare6(buf,ia,1);
if monitor(16,buf,1,ia)=0 then
error(8,empty);
if monitor(18,buf,1,ia)<>1 then
error(11,empty);
if ia(1)<>0 then
error(13,empty);
for i:=1,2,3,4 do
user_id(i):=buf.iaf(i);
password:=buf.laf(3);
end;
procedure error(err_nr,name);
<*-----------------------------------------------*>
<* Udskriv fejlmeddelelse på cur. output og stop *>
<*-----------------------------------------------*>
integer err_nr;
integer array name;
begin
write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: :>);
if err_nr<1 or err_nr>13 then
write(out,<:internal :>,err_nr)
else
write(out,case err_nr of (
<:not found:>,<:error - not moved:>,
<:exist allready:>,<:protected:>,
<:in use:>,<:illegal name:>,
<:no privilegie:>,<:claims:>,
<:not a permanent file:>,<:parameter:>,
<:no system:>,<:internal 12:>,
<:not allowed:>));
write(out,<:<10>:>);
goto stop;
end;
procedure set_buf_zone;
<*-------------------------------------------*>
<* Sæt zonen buf klar til message til tas *>
<*-------------------------------------------*>
begin
open(buf,0,<:tas:>,0);
close(buf,false);
end;
procedure send_move_mess(mode,name,bases,result);
<*--------------------------------------------------------------*>
<* Send move message til Tas. Repeter hvis process stoppes *>
<* Message sendes via zonen buf *>
<* *>
<* mode (call) : 0= Base, 1=To, 2=From *>
<* name (call) : Navn på fil der skal flyttes *>
<* bases(call) : Bruger baser hvor fil skal til/fra *>
<* result (ret) : Resultat fra message, 0=OK *>
<*--------------------------------------------------------------*>
integer mode,result;
integer array name,bases;
begin
integer array share(1:12),zone_ia(1:20);
boolean send;
integer i;
send:=false;
while not send do
begin
getshare6(buf,share,1);
getzone6(buf,zone_ia);
share(1):=0;
share(4):=(15 shift 12)+mode;
share(5):=zone_ia(19)+1;
share(6):=share(5)+22;
setshare6(buf,share,1);
for i:=1 step 1 until 4 do
buf.iaf(i):=user_id(i);
buf.iaf(5):=password shift (-24);
buf.iaf(6):=password extract 24;
for i:=1,2,3,4 do
buf.iaf(6+i):=name(i);
buf.iaf(11):=bases(1);
buf.iaf(12):=bases(2);
if monitor(16,buf,1,share)=0 then
error(8,empty);
if monitor(18,buf,1,share)<>1 then
error(11,empty);
result:=share(1);
mcl_bases(1):=share(4);
mcl_bases(2):=share(5);
if result<>8 then
send:=true;
end;
end;
procedure cat_error(z,s,b);
<*------------------------------------------*>
<* Catalog læsnings fejl procedure *>
<*------------------------------------------*>
zone z;
integer s,b;
begin
if false add (s shift (-18)) then
begin
b:=34;
eof:=true;
end
else
std_error(z,s,b);
end;
procedure lookup_entry(name);
<*---------------------------------------------*>
<* Find mcl-fil entry i katalog med givet navn *>
<*---------------------------------------------*>
integer array name;
begin
integer result;
long array field llaf;
real r;
send_move_mess(0,name,mcl_bases,result);
if result=0 then
begin
write(out,<:<10>:>,true,14,name.laf,<: :>);
outdate(out,round systime(6,buf.iaf(11),r));
write(out,<: :>);
outdate(out,round r);
llaf:=2;
write(out,<: :>,true,12,buf.llaf,<<ddddd>,buf.iaf(12));
end
else
if result=1 then
write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: not found:>)
else
error(result,name);
end;
procedure lookup_all;
<*---------------------------*>
<* Find mcl-filer i catalog *>
<*---------------------------*>
begin
zone cat(128,1,cat_error);
long array field llaf;
real r;
integer result;
send_move_mess(0,prog_name,mcl_bases,result);
if result>6 then
error(result,empty);
open(cat,4,<:catalog:>,1 shift 18);
eof:=false;
inrec6(cat,34);
while not eof do
begin
if cat.iaf(1)<>-1 then
begin
if cat.iaf(2)=mcl_bases(1) and
cat.iaf(3)=mcl_bases(2) and
cat.iaf(16)=29 shift 12 then
begin
llaf:=6;
write(out,<:<10>:>,true,14,cat.llaf,<: :>);
outdate(out,round systime(6,cat.iaf(13),r));
write(out,<: :>);
outdate(out,round r);
llaf:=16;
write(out,<: :>,true,12,cat.llaf,<<ddddd>,cat.iaf(17));
end;
end;
inrec6(cat,34);
end;
end;
procedure lookup_files;
<*---------------------------*>
<* Lookup parameter funktion *>
<*---------------------------*>
begin
integer array name(1:4);
if system(4,param,name.raf)<>(8 shift 12 + 10) then
lookup_all
else
repeat
param:=param+1;
lookup_entry(name);
until system(4,param,name.raf)<>(8 shift 12 + 10);
end;
procedure move_file(mode);
<*---------------------------------*>
<* Flyt filer til/fra system *>
<* *>
<* mode (call) : 1=To, 2=From *>
<*---------------------------------*>
integer mode;
begin
integer array name(1:4);
integer result;
while system(4,param,name.raf)=(8 shift 12 + 10) do
begin
param:=param+1;
send_move_mess(mode,name,user_bases,result);
if result<>0 then
error(result,name);
end;
end;
procedure move;
<*-----------------*>
<* Hoved procedure *>
<*-----------------*>
begin
integer array parameter(1:4);
while system(4,param,parameter.raf)=(4 shift 12 + 10) do
begin
param:=param+1;
if parameter.laf(1)=long <:inclu:> add 'd' then
move_file(1)
else
if parameter.laf(1)=long <:get:> then
move_file(2)
else
if parameter.laf(1)=long <:looku:> add 'p' then
lookup_files
else
error(10,parameter);
end;
if system(4,param,parameter.raf)<>0 then
error(10,parameter);
end;
<* Hoved program *>
trapmode:=1 shift 10;
raf:=laf:=iaf:=0;
for i:=1,2,3,4 do empty(i):=0;
if system(4,1,prog_name.raf)=(6 shift 12 + 10) then
param:=2
else
begin
system(4,0,prog_name.raf);
param:=1;
end;
get_userid;
set_buf_zone;
system(11,0,arr);
user_bases(1):=arr(5);
user_bases(2):=arr(6);
move;
write(out,<:<10>:>);
stop:
end;
▶EOF◀