1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11           /*        IOCALL -
 12                     This command allows the user to make calls directly to the I/O system from
 13                               command level. The following I/O calls are provided:
 14 
 15                               attach
 16                               detach
 17                               read
 18                               write
 19                               seek
 20                               tell
 21                               setsize
 22                               getsize
 23                               abort
 24                               order
 25                               changemode
 26                               resetread
 27                               resetwrite
 28                               readsync
 29                               writesync
 30                               worksync
 31 
 32                     In addition the entry checkstatus is provided so that an I/O system
 33                               caller may interpret the status returned from an I/O call.
 34 
 35                     Originally coded by R. J. Feiertag on February 21, 1970 due to unremitting
 36                               pressure.                                                             */
 37           /*        Modified on April 8, 1971 by R. J. Feiertag to add some new calls.              */
 38 
 39 iocall:   proc;
 40 
 41 dcl whoami char(8) static aligned init("iocall");
 42 
 43           /*        AUTOMATIC VARIABLES */
 44 
 45           dcl (l1,l2,l3,l4,l5) fixed bin(17),     /* arg lengths */
 46               (p1,p2,p3,p4,p5) ptr,               /* arg pointers */
 47               statusp ptr,                        /* pointer to status string */
 48               call_name char(l1) based(p1),       /* the name of the I/O call */
 49               command_name char(32) init(whoami),           /* name of this command */
 50               ioname char(l2) based(p2),          /* the stream name for this call */
 51               arg3 char(l3) based(p3),            /* third arg */
 52               arg4 char(l4) based(p4),  /* fourth arg */
 53               arg5 char(l5) based(p5),            /* fifth arg */
 54               count fixed bin(17),      /* the number of arguments for this call */
 55               mode char(128),           /* the mode to be passed to the I/O system */
 56               pos fixed bin,            /* position in mode string */
 57               old_mode char(128),       /* the previous mode of this device */
 58               old_status bit(72) aligned,         /* a previous status string */
 59               limit fixed bin,          /* the limit of readahead or writebehind */
 60               status bit(72) aligned,             /* the status string returned by the I/O system */
 61               ioname2 char(32),         /* the detach id for a detach call */
 62               path char(168),           /* the path name of a segment */
 63               dir char(168),            /* the directory of a segment */
 64               entry char(32),           /* the name of a segment */
 65               code fixed bin(35),       /* error code */
 66               segptr ptr,               /* pointer to a segment */
 67               offset fixed bin(17),     /* an offset from the beginning of a segment */
 68               nelem fixed bin(17),      /* the number of elements to be read or written */
 69               bit_count fixed bin(24),  /* bit-count from hcs_$initiate_count */
 70               nelemt fixed bin(17),     /* the number of elements read or written */
 71               ptrname2 char(32),
 72               element_size fixed bin(17),         /* the size in bits of an element */
 73               name char(32);            /* the stream name */
 74 
 75           dcl 1 s based(statusp) aligned,
 76                     2 code fixed bin(17),         /* error code */
 77                     2 comp bit(5) unaligned,
 78                     2 p1 bit(4) unaligned,
 79                     2 eof bit(1) unaligned,       /* end of file */
 80                     2 p2 bit(4) unaligned,
 81                     2 abs bit(1) unaligned,       /* device absent */
 82                     2 det bit(1) unaligned,       /* detached */
 83                     2 quit bit(1) unaligned,      /* quit detected */
 84                     2 abort bit(1) unaligned,     /* transaction aborted */
 85                     2 p3 bit(18) unaligned;
 86 
 87           /*        EXTERNAL DATA */
 88 
 89           dcl (error_table_$noarg fixed bin(35),
 90                sys_info$max_seg_size fixed bin) ext;        /* # of pages/segment */
 91 
 92           /*        EXTERNAL ENTRIES */
 93 
 94           dcl cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(35)),
 95               expand_path_ ext entry(ptr,fixed bin(17),ptr,ptr,fixed bin(35)),
 96           hcs_$make_seg entry(char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35)),
 97           hcs_$initiate_count entry(char(*), char(*), char(*), fixed bin(24), fixed bin, ptr, fixed bin(35)),
 98           hcs_$set_bc entry(char(*), char(*), fixed bin(24), fixed bin(35)),
 99           cv_dec_check_ entry(char(*), fixed bin(35), fixed bin),
100               (com_err_, ioa_) entry options(variable);
101 
102 dcl       ios_$attach entry(char(*), char(*), char(*), char(*), bit(72) aligned),
103           ios_$detach entry(char(*), char(*), char(*), bit(72) aligned),
104           ios_$read entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
105           ios_$write entry(char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned),
106           ios_$seek entry(char(*), char(*), char(*), fixed bin, bit(72) aligned),
107           ios_$tell entry(char(*), char(*), char(*), fixed bin, bit(72) aligned),
108           ios_$setsize entry(char(*), fixed bin, bit(72) aligned),
109           ios_$getsize entry(char(*), fixed bin, bit(72) aligned),
110           ios_$order entry(char(*), char(*), ptr, bit(72) aligned),
111           ios_$changemode entry(char(*), char(*), char(*), bit(72) aligned),
112           ios_$resetread entry(char(*), bit(72) aligned),
113           ios_$resetwrite entry(char(*), bit(72) aligned),
114           ios_$abort entry(char(*), bit(72) aligned, bit(72) aligned),
115           ios_$readsync entry(char(*), char(*), fixed bin, bit(72) aligned),
116           ios_$writesync entry(char(*), char(*), fixed bin, bit(72) aligned),
117           ios_$worksync entry(char(*), char(*), char(*), bit(72) aligned);
118 
119 dcl (addr, bin, divide, length, null, substr) builtin;
120 
121 /*^L*/
122 
123           statusp = addr(status);
124           call cu_$arg_ptr(1,p1,l1,code); /* get call name */
125           if code ^= 0 then go to bad_args;
126           call cu_$arg_ptr(2,p2,l2,code); /* get ioname */
127           if code ^= 0 then go to bad_args;
128           call cu_$arg_ptr(3,p3,l3,code); /* get third arg */
129           if code ^= 0 then count = 2; /* remember which is last arg */
130            else do;
131                     call cu_$arg_ptr(4,p4,l4,code);
132                     if code ^= 0 then count = 3; /* remember last arg */
133                      else do;
134                               call cu_$arg_ptr(5,p5,l5,code);
135                               if code ^= 0 then count = 4;
136                                else count = 5;
137                               end;
138                     end;
139           if call_name = "attach" then do;        /* this is an attach call */
140                     if count < 4 then go to bad_args;
141                     mode = ""; /* initialize mode string */
142                     pos = 1; /* start from beginning of mode string */
143                     do count = 6 by 1 while(code = 0); /* process remaining arguments */
144                               substr(mode,pos,l5) = arg5; /* place next mode in mode string */
145                               pos = pos + l5 + 1; /* update position in mode string */
146                               call cu_$arg_ptr(count,p5,l5,code); /* pick up next argument */
147                               if code = 0 then substr(mode,pos-1,1) = ","; /* insert delimiter in mode string */
148                               end;
149                     call ios_$attach(ioname,arg3,arg4,mode,status);   /* make attach call */
150                     end;
151            else if call_name = "detach" then do;  /* detach call */
152                     if count = 2 then ioname2,mode = "";
153                      else if count = 3 then do;
154                               ioname2 = arg3;
155                               mode = "";
156                               end;
157                       else if count = 4 then do;
158                               ioname2 = arg3;
159                               mode = arg4;
160                               end;
161                        else go to bad_args;
162                     call ios_$detach(ioname,ioname2,mode,status); /* make detach call */
163                     end;
164            else if call_name = "read" then do; /* read call */
165                     if count < 3 | count > 5 then go to bad_args;
166                     path = arg3;        /* align for expand_path_ */
167                     call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
168                               /* get the directory and entry */
169                     if code ^= 0 then go to path_err;
170                     call hcs_$make_seg(dir,entry,"",01011b,segptr,code);
171                               /* create the segment */
172                     if segptr = null then go to path_err;
173                     call ios_$getsize(ioname,element_size,status); /* get element size */
174                     if substr(status,1,36) ^= "0"b then element_size = 9; /* if can't get element size assume 9 */
175                     if count = 3 then do; /* set up args */
176                               offset = 0;
177                               nelem = divide(sys_info$max_seg_size * 36, element_size, 17, 0);
178                               end;
179                      else if count = 4 then do;
180                               offset = 0;
181                               call cv_dec_check_(arg4, code, nelem); /* convert count */
182                               if code ^= 0
183                               then /* ! */
184 nelem_4:                           call num_err(arg4, "nelem");
185                               end;
186                       else if count = 5 then do;
187                               call cv_dec_check_(arg4, code, offset);
188                               if code ^= 0
189                               then /* ! */
190 offset_4:                          call num_err(arg4, "offset");
191                               call cv_dec_check_(arg5, code, nelem);
192                               if code ^= 0
193                               then /* ! */
194 nelem_5:                           call num_err(arg5, "nelem");
195                               end;
196                     call ios_$read(ioname,segptr,offset,nelem,nelemt,status); /* make read call */
197                     if s.code = 0 then do; /* no problems */
198                               call hcs_$set_bc(dir,entry,nelemt*element_size,code);       /* set segment bit count */
199                               if code ^= 0 then
200                                         call ioa_("iocall: Unable to set bit count for segment. ^a",path);
201                               call ioa_("The number of elements read is ^d.",nelemt);
202                               end;
203                     end;
204            else if call_name = "write" then do;   /* write call */
205                     if count < 3 | count > 5 then go to bad_args;
206                     path = arg3;        /* align for expand_path_ */
207                     call expand_path_(addr(path),length(arg3),addr(dir),addr(entry),code);
208                               /* process path name */
209                     if code ^= 0 then go to path_err;
210                     call hcs_$initiate_count(dir,entry,"",bit_count,1,segptr,code);
211                               /* get pointer to segment */
212                     if segptr = null then go to path_err;
213                     call ios_$getsize(ioname,element_size,status); /* get element size */
214                     if substr(status,1,36) then element_size = 9; /* if can't get element size assume 9 */
215                     if count = 3 then do;         /* set up args */
216                               offset = 0;
217                               nelem = divide(bit_count,element_size,17,0); /* get element count */
218                               nelemt = nelem * element_size;                    /* Calc # bits to be sent */
219                               bit_count = bit_count - nelemt;
220                               if bit_count ^= 0
221                               then call ioa_("^d bits at bit-offset ^d not transmitted to device ^a",
222                                         bit_count, nelemt, ioname);
223                               end;
224                      else if count = 4 then do;
225                               offset = 0;
226                               call cv_dec_check_(arg4, code, nelem);
227                               if code ^= 0
228                               then go to nelem_4;
229                               end;
230                       else if count = 5 then do;
231                               call cv_dec_check_(arg4, code, offset);
232                               if code ^= 0
233                               then go to offset_4;
234                               call cv_dec_check_(arg5, code, nelem);
235                               if code ^= 0
236                               then go to nelem_5;
237                               end;
238                     call ios_$write(ioname,segptr,offset,nelem,nelemt,status); /* make write call */
239                     if s.code = 0 then call ioa_("The number of elements written is ^d.",nelemt);
240                     end;
241            else if call_name = "seek" then do; /* seek call */
242                     if count = 3 then do; /* set up args */
243                               ptrname2 = "first";
244                               offset = 0;
245                               end;
246                      else if count = 4 then do;
247                               ptrname2 = arg4;
248                               offset = 0;
249                               end;
250                       else if count = 5 then do;
251                               ptrname2 = arg4;
252                               call cv_dec_check_(arg5, code, offset);
253                               if code ^= 0
254                               then call num_err(arg5, "offset");
255                               end;
256                        else go to bad_args;
257                     call ios_$seek(ioname,arg3,ptrname2,offset,status);         /* make seek call */
258                     end;
259            else if call_name = "tell" then do;    /* tell call */
260                     if count = 3 then ptrname2 = "first";   /* set up args */
261                      else if count = 4 then ptrname2 = arg4;
262                       else go to bad_args;
263                     call ios_$tell(ioname,arg3,ptrname2,offset,status);         /* make tell call */
264                     if s.code = 0 then call ioa_("Offset is ^d.",offset);
265                     end;
266            else if call_name = "setsize" then do; /* setsize call */
267                     if count ^= 3 then go to bad_args;
268                     call cv_dec_check_(arg3, code, element_size); /* convert element size */
269                     if code ^= 0
270                     then call num_err(arg3, "element_size");
271                     call ios_$setsize(ioname,element_size,status); /* make setsize call */
272                     end;
273            else if call_name = "getsize" then do; /* getsize call */
274                     if count ^= 2 then go to bad_args;
275                     call ios_$getsize(ioname,element_size,status); /* make getsize call */
276                     if s.code = 0 then call ioa_("Element size is ^d.",element_size); /* tell user the element size */
277                     end;
278            else if call_name = "order" then do; /* order call */
279                     if count ^= 3 then go to bad_args;
280                     call ios_$order(ioname,arg3,null,status); /* make order call */
281                     end;
282            else if call_name = "changemode" then do; /* changemode call */
283                     mode = ""; /* initialize mode string */
284                     if count >= 3 then code = 0; /* we have at least three arguments */
285                     pos = 1; /* start at beginning of mode string */
286                     do count = 4 by 1 while(code = 0); /* process remaining arguments */
287                               substr(mode,pos,l3) = arg3; /* add mode to mode string */
288                               pos = pos + l3 + 1; /* update position in mode string */
289                               call cu_$arg_ptr(count,p3,l3,code); /* get next argument */
290                               if code = 0 then substr(mode,pos-1,1) = ","; /* insert mode delimiter */
291                               end;
292                     call ios_$changemode(ioname,mode,old_mode,status); /* issue changemode call */
293                     if s.code = 0 then call ioa_("Mode changed from ^a",old_mode); /* tell user old mode */
294                     end;
295            else if call_name = "resetread" then do; /* resetread call */
296                     if count ^= 2 then go to bad_args;
297                     call ios_$resetread(ioname,status); /* issue resetread call */
298                     end;
299            else if call_name = "resetwrite" then do; /* resetwrite call */
300                     if count ^= 2 then go to bad_args;
301                     call ios_$resetwrite(ioname,status); /* issue resetwrite call */
302                     end;
303            else if call_name = "abort" then do; /* abort call */
304                     if count ^= 2 then go to bad_args;
305                     old_status = ""b; /* abort all transactions */
306                     call ios_$abort(ioname,old_status,status); /* issue abort call */
307                     end;
308            else if call_name = "readsync" then do; /* readsync call */
309                     if count = 3 then limit = bin(131071, 17); /* set high limit for default */
310                      else if count = 4 then do;
311                               call cv_dec_check_(arg4, code, limit); /* else set given limit */
312                               if code ^= 0
313                               then /* ! */
314 limit_4:                           call num_err(arg4, "limit");
315                               end;
316                       else go to bad_args;
317                     call ios_$readsync(ioname,arg3,limit,status); /* issue readsync call */
318                     end;
319            else if call_name = "writesync" then do; /* writesync call */
320                     if count = 3 then limit = bin(131071, 17); /* set high default limit */
321                      else if count = 4 then do;
322                               call cv_dec_check_(arg4, code, limit); /* else set given limit */
323                               if code ^= 0
324                               then go to limit_4;
325                               end;
326                       else go to bad_args;
327                     call ios_$writesync(ioname,arg3,limit,status); /* issue writesync call */
328                     end;
329            else if call_name = "worksync" then do; /* worksync call */
330                     if count ^= 3 then go to bad_args;
331                     call ios_$worksync(ioname,arg3,"",status); /* issue worksync call */
332                     end;
333            else do;
334                     call ioa_("iocall: The ^a call to the I/O system is not permitted by iocall.",call_name);
335                     return;
336                     end;
337           name = ioname;
338           go to status_check; /* go interpret status */
339 
340 path_err: call com_err_(code,whoami,path);        /* report error to user */
341           return;
342 
343 
344 bad_args: call com_err_(error_table_$noarg,whoami,""); /* incorrect number of args */
345           return;
346 
347           /* This entry point interprets a status string */
348 
349 checkstatus:        entry(input_status);
350 
351           dcl input_status bit(72) aligned;
352 
353           name = "";
354           statusp = addr(status);
355           status = input_status;
356           command_name = "I/O Error";
357 status_check:
358           /* print out status interpretation */
359           if s.code ^= 0 then call com_err_(s.code,command_name,name);
360           if s.eof then call ioa_("^a at end of file.",name);
361           if s.abs then call ioa_("^a device absent.",name);
362           if s.det then call ioa_("^a device detached.",name);
363           if s.quit then call ioa_("^a quit detected.",name);
364           if s.abort then call ioa_("^a transaction aborted.",name);
365 
366 num_err: proc(str, id);
367 
368 dcl (str, id) char(*);
369 
370           call com_err_(0, whoami, "Non-numeric digits in ^a argument to ^a request: ^a", id, call_name, str);
371 
372           go to end_iocall;
373 
374 end;
375 
376 end_iocall:
377 end iocall;