|
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: 12288 (0x3000)
Types: TextFile
Names: »mvmcllist «
└─⟦9ccaf6601⟧ Bits:30008165 Bånd med SW8000 kildetekst/release værktøjer
└─⟦39138f30b⟧
└─⟦this⟧ »mvmcllist «
*movemcl=algol mvmcltxt connect.no list.yes
mvmcltxt d.861121.1142
1 begin
2 <********************************************************************>
3 <* Utility MOVEMCL til flytning af oversatte mcl programmer til *>
4 <* Tas mcl-database *>
5 <* *>
6 <* Kald: movemcl <move spec.> *>
7 <* *>
8 <* include.<name> *>
9 <* <move spec.> ::= get.<name> *>
10 <* lookup.<name> *>
11 <* lookup *>
12 <* *>
13 <* Henning Godske A/S Regnecentralen 861121 *>
14 <* Compiler call: movemcl=algol mvmcltxt connect.no *>
15 <********************************************************************>
16
16 <**************************************************************>
17 <* Revision history *>
18 <* *>
19 <* 86.12.01 movemcl release 1.0 *>
20 <**************************************************************>
21
21 <* Globale variable *>
22
22 zone buf(128,1,std_error); <* Zone til message m.m. *>
23 integer array user_id(1:4); <* Bruger id fra terminal *>
24 long password; <* Password fra terminal *>
25 integer array prog_name(1:4); <* Program navn *>
26 integer param; <* fp parameter tæller *>
27 integer array mcl_bases(1:2); <* Bases for mcl files *>
28 integer array user_bases(1:2); <* Egne bruger baser *>
29 integer array empty(1:4); <* Tomt navn *>
30 boolean eof; <* End Of File *>
31
31 integer array arr(1:8); <* Work *>
32 integer array field iaf; <* Work *>
33 real array field raf; <* Work *>
34 boolean array field baf; <* Work *>
35 long array field laf; <* Work *>
36 integer i; <* Work *>
37
37 <* Globale procedure *>
38
38 procedure get_userid;
39 <*-------------------------------------------------------------------*>
40 <* Set user id og password i de globale variable user_id og password *>
41 <* Id og password hentes fra terminalen tilknyttet prim. output *>
42 <*-------------------------------------------------------------------*>
43 begin
44 long array term_name(1:2);
45 integer i;
46 integer array ia(1:20);
47
47 system(7,0,term_name);
48 open(buf,0,term_name,0);
49 close(buf,false);
50 getzone6(buf,ia);
51 i:=ia(19);
52 getshare6(buf,ia,1);
53 ia(4):=131 shift 12;
54 ia(5):=i+1;
55 ia(6):=i+11;
56 ia(7):=0;
57 setshare6(buf,ia,1);
58 if monitor(16,buf,1,ia)=0 then
59 error(8,empty);
60 if monitor(18,buf,1,ia)<>1 then
61 error(11,empty);
62 if ia(1)<>0 then
63 error(13,empty);
64 for i:=1,2,3,4 do
65 user_id(i):=buf.iaf(i);
66 password:=buf.laf(3);
67 end;
68
68 procedure error(err_nr,name);
69 <*-----------------------------------------------*>
70 <* Udskriv fejlmeddelelse på cur. output og stop *>
71 <*-----------------------------------------------*>
72 integer err_nr;
73 integer array name;
74 begin
75 write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: :>);
76 if err_nr<1 or err_nr>13 then
77 write(out,<:internal :>,err_nr)
78 else
79 write(out,case err_nr of (
80 <:not found:>,<:error - not moved:>,
81 <:exist allready:>,<:protected:>,
82 <:in use:>,<:illegal name:>,
83 <:no privilegie:>,<:claims:>,
84 <:not a permanent file:>,<:parameter:>,
85 <:no system:>,<:internal 12:>,
86 <:not allowed:>));
87 write(out,<:<10>:>);
88 goto stop;
89 end;
90
90 procedure set_buf_zone;
91 <*-------------------------------------------*>
92 <* Sæt zonen buf klar til message til tas *>
93 <*-------------------------------------------*>
94 begin
95 open(buf,0,<:tas:>,0);
96 close(buf,false);
97 end;
98
98 procedure send_move_mess(mode,name,bases,result);
99 <*--------------------------------------------------------------*>
100 <* Send move message til Tas. Repeter hvis process stoppes *>
101 <* Message sendes via zonen buf *>
102 <* *>
103 <* mode (call) : 0= Base, 1=To, 2=From *>
104 <* name (call) : Navn på fil der skal flyttes *>
105 <* bases(call) : Bruger baser hvor fil skal til/fra *>
106 <* result (ret) : Resultat fra message, 0=OK *>
107 <*--------------------------------------------------------------*>
108 integer mode,result;
109 integer array name,bases;
110 begin
111 integer array share(1:12),zone_ia(1:20);
112 boolean send;
113 integer i;
114
114 send:=false;
115 while not send do
116 begin
117 getshare6(buf,share,1);
118 getzone6(buf,zone_ia);
119 share(1):=0;
120 share(4):=(15 shift 12)+mode;
121 share(5):=zone_ia(19)+1;
122 share(6):=share(5)+22;
123 setshare6(buf,share,1);
124 for i:=1 step 1 until 4 do
125 buf.iaf(i):=user_id(i);
126 buf.iaf(5):=password shift (-24);
127 buf.iaf(6):=password extract 24;
128 for i:=1,2,3,4 do
129 buf.iaf(6+i):=name(i);
130 buf.iaf(11):=bases(1);
131 buf.iaf(12):=bases(2);
132 if monitor(16,buf,1,share)=0 then
133 error(8,empty);
134 if monitor(18,buf,1,share)<>1 then
135 error(11,empty);
136 result:=share(1);
137 mcl_bases(1):=share(4);
138 mcl_bases(2):=share(5);
139 if result<>8 then
140 send:=true;
141 end;
142 end;
143
143 procedure cat_error(z,s,b);
144 <*------------------------------------------*>
145 <* Catalog læsnings fejl procedure *>
146 <*------------------------------------------*>
147 zone z;
148 integer s,b;
149 begin
150 if false add (s shift (-18)) then
151 begin
152 b:=34;
153 eof:=true;
154 end
155 else
156 std_error(z,s,b);
157 end;
158
158 procedure lookup_entry(name);
159 <*---------------------------------------------*>
160 <* Find mcl-fil entry i katalog med givet navn *>
161 <*---------------------------------------------*>
162 integer array name;
163 begin
164 integer result;
165 long array field llaf;
166 real r;
167
167 send_move_mess(0,name,mcl_bases,result);
168 if result=0 then
169 begin
170 write(out,<:<10>:>,true,14,name.laf,<: :>);
171 outdate(out,round systime(6,buf.iaf(11),r));
172 write(out,<: :>);
173 outdate(out,round r);
174 llaf:=2;
175 write(out,<: :>,true,12,buf.llaf,<<ddddd>,buf.iaf(12));
176 end
177 else
178 if result=1 then
179 write(out,<:<10>***:>,prog_name.laf,<: :>,name.laf,<: not found:>)
180 else
181 error(result,name);
182 end;
183
183 procedure lookup_all;
184 <*---------------------------*>
185 <* Find mcl-filer i catalog *>
186 <*---------------------------*>
187 begin
188 zone cat(128,1,cat_error);
189 long array field llaf;
190 real r;
191 integer result;
192
192 send_move_mess(0,prog_name,mcl_bases,result);
193 if result>6 then
194 error(result,empty);
195 open(cat,4,<:catalog:>,1 shift 18);
196 eof:=false;
197 inrec6(cat,34);
198 while not eof do
199 begin
200 if cat.iaf(1)<>-1 then
201 begin
202 if cat.iaf(2)=mcl_bases(1) and
203 cat.iaf(3)=mcl_bases(2) and
204 cat.iaf(16)=29 shift 12 then
205 begin
206 llaf:=6;
207 write(out,<:<10>:>,true,14,cat.llaf,<: :>);
208 outdate(out,round systime(6,cat.iaf(13),r));
209 write(out,<: :>);
210 outdate(out,round r);
211 llaf:=16;
212 write(out,<: :>,true,12,cat.llaf,<<ddddd>,cat.iaf(17));
213 end;
214 end;
215 inrec6(cat,34);
216 end;
217 end;
218
218 procedure lookup_files;
219 <*---------------------------*>
220 <* Lookup parameter funktion *>
221 <*---------------------------*>
222 begin
223 integer array name(1:4);
224
224 if system(4,param,name.raf)<>(8 shift 12 + 10) then
225 lookup_all
226 else
227 repeat
228 param:=param+1;
229 lookup_entry(name);
230 until system(4,param,name.raf)<>(8 shift 12 + 10);
231 end;
232
232 procedure move_file(mode);
233 <*---------------------------------*>
234 <* Flyt filer til/fra system *>
235 <* *>
236 <* mode (call) : 1=To, 2=From *>
237 <*---------------------------------*>
238 integer mode;
239 begin
240 integer array name(1:4);
241 integer result;
242
242 while system(4,param,name.raf)=(8 shift 12 + 10) do
243 begin
244 param:=param+1;
245 send_move_mess(mode,name,user_bases,result);
246 if result<>0 then
247 error(result,name);
248 end;
249 end;
250
250 procedure move;
251 <*-----------------*>
252 <* Hoved procedure *>
253 <*-----------------*>
254 begin
255 integer array parameter(1:4);
256
256 while system(4,param,parameter.raf)=(4 shift 12 + 10) do
257 begin
258 param:=param+1;
259 if parameter.laf(1)=long <:inclu:> add 'd' then
260 move_file(1)
261 else
262 if parameter.laf(1)=long <:get:> then
263 move_file(2)
264 else
265 if parameter.laf(1)=long <:looku:> add 'p' then
266 lookup_files
267 else
268 error(10,parameter);
269 end;
270 if system(4,param,parameter.raf)<>0 then
271 error(10,parameter);
272 end;
273
273 <* Hoved program *>
274 trapmode:=1 shift 10;
275 raf:=laf:=iaf:=0;
276 for i:=1,2,3,4 do empty(i):=0;
277 if system(4,1,prog_name.raf)=(6 shift 12 + 10) then
278 param:=2
279 else
280 begin
281 system(4,0,prog_name.raf);
282 param:=1;
283 end;
284 get_userid;
285 set_buf_zone;
286 system(11,0,arr);
287 user_bases(1):=arr(5);
288 user_bases(2):=arr(6);
289 move;
290 write(out,<:<10>:>);
291 stop:
292 end;\f
algol end 48
*o c
▶EOF◀