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 /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indend,dclind5,idind32 */
 12 
 13 tape_nstd_attach:
 14      proc (iocb_ptr, args, loud_sw, arg_code);
 15 
 16 /*
 17 
 18    tape_nstd_ created 05/03/76 by Richard Bratt
 19 
 20    This program is a temporary dim.  It is intended to serve as a rough iox_ writearound to
 21    the ios_ dim nstd_.  This dim evolved from repeated attempts to bash ntape_ into usefulness.
 22    When the smoke cleared little remained of ntape_; hence the new name, tape_nstd_.
 23    This dim makes no pretense at being pretty or clever.
 24 
 25    Last modified:
 26    *      09/19/77 by R.J.C. Kissel to get buffer size from a control argument,
 27    *                and to add the entry max_buf_size to return the buffer size.
 28    *      11/01/77 by M. R. Jordan to fix forward_record control call.
 29    *      04/07/78 by M. R. Jordan for major overhaul.  Changes included:
 30    *                adding -density control argument, implementing all
 31    *                nstd control orders, and changes to -block processing
 32    *                such that nstd_ now handles it.
 33    *      01/3/79  by Maria Bozzuto to add -com control argument.
 34    *      4/79     by R.J.C. Kissel to add 6250 bpi support.
 35    *      05/10/79 by C. D. Tavares to add name canonicalization support.
 36    *      4/82     by J. A. Bush to compile with iocb.incl.pl1
 37 
 38    NOTES:
 39 
 40    * Since this dim does not copy buffers and since it calls nstd_ directly, bufptr
 41    * in the read and write calls must be word aligned. In addition, buflen must be 0 modulo 4
 42    * for write calls.
 43 
 44 */
 45 
 46 /* Parameters. */
 47 
 48 dcl  actlen                          fixed (21);
 49 dcl  args                            (*) char (*) varying;
 50 dcl  buflen                          fixed (21);
 51 dcl  bufptr                          ptr;
 52 dcl  extend_bit                      bit (1) aligned;
 53 dcl  iocb_ptr                        ptr;
 54 dcl  loud_sw                         bit (1) aligned;
 55 dcl  mode                            fixed;
 56 dcl  arg_code                        fixed bin (35);
 57 
 58 /* Automatic. */
 59 
 60 dcl  actual_iocb_ptr                 ptr;
 61 dcl  density                         char (9) varying;
 62 dcl  block                           char (13) varying;
 63 dcl  pic                             pic "zzzzz9";
 64 dcl  blkptr                          ptr;
 65 dcl  block_size                      fixed bin (21);
 66 dcl  fix_num                         fixed;
 67 dcl  nn                              fixed bin;
 68 dcl  code                            fixed (35);
 69 dcl  1 ics                           aligned,
 70        2 sdbptr                      ptr,
 71        2 dimptr                      ptr,
 72        2 entry                       fixed;
 73 dcl  mask                            fixed (35);
 74 dcl  comment                         char (256) aligned varying;
 75 dcl  n                               fixed (21);
 76 dcl  (leader_ok, eof_ok)             bit (1) aligned;
 77 dcl  reel                            char (32) varying;
 78 dcl  track                           char (8) varying;
 79 dcl  chars                           fixed;
 80 dcl  st                              bit (12) aligned;
 81 dcl  status_story                    char (100) varying;
 82 dcl  1 status                        aligned,
 83        2 code                        fixed (35),
 84        2 bits                        bit (36);
 85 dcl  write_sw                        bit (1);
 86 dcl  order_index                     fixed bin;
 87 dcl  reel_name                       char (256);
 88 
 89 /* Based. */
 90 
 91 dcl  1 blk                           aligned based (blkptr),
 92        2 sdbptr                      ptr,
 93        2 dimptr                      ptr,
 94        2 attach                      char (59) varying,
 95        2 write_ring                  bit (1) unaligned,
 96        2 extend                      bit (1) unaligned,
 97        2 open                        char (31) varying,
 98        2 maxbuf                      fixed bin (18);
 99 
100 /* Internal static. */
101 
102 dcl  free_blks_ptr                   ptr int static init (null ());
103 
104 /* Procedures. */
105 
106 dcl  com_err_                        ext entry options (variable);
107 dcl  cv_dec_check_                   entry (char (*), fixed bin (35)) returns (fixed bin (35));
108 dcl  cu_$arg_list_ptr                ext entry () returns (ptr);
109 dcl  cu_$gen_call                    ext entry (entry, ptr);
110 dcl  default_handler_$set            ext entry (entry);
111 dcl  error                           entry variable options (variable) init (ERROR);
112 dcl  hcs_$assign_linkage             ext entry (fixed, ptr) returns (fixed (35));
113 dcl  hcs_$set_ips_mask               ext entry (fixed (35), fixed (35));
114 dcl  hcs_$reset_ips_mask             ext entry (fixed (35), fixed (35));
115 dcl  iox_$ios_call                   ext entry options (variable);
116 dcl  iox_$ios_call_attach            ext entry options (variable);
117 dcl  iox_$propagate                  ext entry (ptr);
118 dcl  nstd_$nstd_module               fixed ext;
119 dcl  analyze_device_stat_$rsnnl      entry (char (*) varying, ptr, bit (72) aligned, bit (18) aligned);
120 
121 /* Constants. */
122 
123 dcl  error_table_$bad_arg            fixed (35) ext;
124 dcl  error_table_$bad_conversion     fixed bin (35) ext;
125 dcl  error_table_$bad_mode           fixed (35) ext;
126 dcl  error_table_$bad_tapeid         fixed bin (35) ext;
127 dcl  error_table_$badopt             fixed (35) ext;
128 dcl  error_table_$end_of_info        fixed (35) ext;
129 dcl  error_table_$long_record        fixed (35) ext;
130 dcl  error_table_$noarg              fixed (35) ext;
131 dcl  error_table_$not_detached       fixed (35) ext;
132 dcl  error_table_$tape_error         fixed (35) ext;
133 dcl  error_table_$invalid_record_length
134                                      fixed (35) ext;
135 dcl  error_table_$undefined_order_request
136                                      fixed bin (35) ext;
137 dcl  tape_status_table_$tape_status_table_
138                                      ext;
139 
140 dcl  iox_$err_not_attached           ext entry options (variable);
141 dcl  iox_$err_not_closed             ext entry options (variable);
142 dcl  iox_$err_not_open               ext entry options (variable);
143 
144 dcl  detach_offset                   fixed int static init (1);
145 dcl  read_offset                     fixed int static init (2);
146 dcl  write_offset                    fixed int static init (3);
147 dcl  order_offset                    fixed int static init (5);
148 
149 dcl  leader_status                   fixed (35) based (addr (leader_bits));
150 dcl  leader_bits                     bit (36) int static init ("100000000000000000000000000101001000"b);
151 
152 dcl  sequential_input_mode           fixed int static init (4);
153 dcl  sequential_output_mode          fixed int static init (5);
154 
155 
156 dcl  1 ORDER_TAB                     (24) internal static options (constant),
157        2 NAME                        char (20)
158                                      init ("backspace_file", "backspace_record", "bcd", "binary", "d1600", "d200", "d556",
159                                      "d6250", "d800", "data_security_erase", "erase", "fixed_record_length",
160                                      "forward_file", "forward_record", "io_call", "nine", "protect", "request_status",
161                                      "reset_status", "retry_count", "rewind", "saved_status", "unload", "write_eof"),
162        2 ACTION                      fixed bin
163                                      init (1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 4, 0, 0, 0, 0, 5, 6, 0, 0, 7);
164 dcl  sequential_input_output_mode    fixed int static init (6);
165 
166 /* Built-in. */
167 
168 dcl  (addr, divide, hbound, index, length, mod, null, rtrim, size, substr, bin, ltrim, min, maxlength)
169                                      builtin;
170 ^L
171 /* Beginning of entry point ..... tape_nstd_$tape_nstd_attach(iocb_ptr,args,loud_sw) ..... */
172 
173 
174           arg_code = 0;
175           mask = 0;
176           comment = "";
177           call default_handler_$set (HANDLER);
178           if hbound (args, 1) < 1 then call error (error_table_$noarg, "tape_nstd_", "No volume id specified.");
179           n = index (args (1), " ") - 1;
180           if n < 0 then n = length (args (1));
181           if n = 0 | n > maxlength (reel) then call error (error_table_$bad_tapeid, "tape_nstd_", "^a", args (1));
182           reel = substr (args (1), 1, n);
183           write_sw = "0"b;
184           track = "";
185           density = "";
186           block_size = 2800 * 4;
187           block = "";
188           do n = 2 to hbound (args, 1);
189                if args (n) = "-write" then write_sw = "1"b;
190                else if args (n) = "-track" | args (n) = "-tk"
191                     then do;
192                          n = n + 1;
193                          if n > hbound (args, 1)
194                               then call error (error_table_$noarg, "tape_nstd_",
195                                         "No value specified following the ^a control argument.", args (n - 1));
196                          fix_num = cv_dec_check_ ((args (n)), code);
197                          if code ^= 0 then fix_num = 0;
198                          if fix_num = 7 then track = ",7track";
199                          else if fix_num = 9 then track = ",9track";
200                          else call error (error_table_$bad_arg, "tape_nstd_", "Bad track specification. ^a", args (n));
201                     end;
202 
203                else if args (n) = "-density" | args (n) = "-den"
204                     then do;
205                          n = n + 1;
206                          if n > hbound (args, 1)
207                               then call error (error_table_$noarg, "tape_nstd_",
208                                         "No value specified following the ^a control argument.", args (n - 1));
209                          fix_num = cv_dec_check_ ((args (n)), code);
210                          if code ^= 0 then fix_num = 0;
211                          if fix_num = 200 then density = ",den=200";
212                          else if fix_num = 556 then density = ",den=556";
213                          else if fix_num = 800 then density = ",den=800";
214                          else if fix_num = 1600 then density = ",den=1600";
215                          else if fix_num = 6250 then density = ",den=6250";
216                          else call error (error_table_$bad_arg, "tape_nstd_", "Bad density specification. ^a", args (n));
217                     end;
218 
219                else if args (n) = "-block" | args (n) = "-bk"
220                     then do;
221                          n = n + 1;
222 
223                          if n > hbound (args, 1)
224                               then call error (error_table_$noarg, "tape_nstd_",
225                                         "No size specified following the ^a control argument.", args (n - 1));
226 
227                          block_size = cv_dec_check_ ((args (n)), code);
228 
229                          if block_size = 0 | code ^= 0 | mod (block_size, 4) ^= 0
230                               then call error (error_table_$bad_arg, "tape_nstd_", "Bad block size specification. ^a",
231                                         args (n));
232                     end;
233                else if args (n) = "-comment" | args (n) = "-com"
234                     then do;
235                          n = n + 1;
236                          if n > hbound (args, 1)
237                               then call error (error_table_$noarg, "tape_nstd_",
238                                         "No comment specified following the ^a control argument", args (n - 1));
239                          if length (args (n)) > maxlength (comment) - 2
240                               then call error (error_table_$bad_arg, "tape_nstd_",
241                                         "Comment '^a' longer than ^d characters", args (n), maxlength (comment) - 2);
242                          comment = ",*" || args (n);
243                     end;
244 
245                else call error (error_table_$badopt, "tape_nstd_", "^a", args (n));
246                end;
247           pic = divide (block_size, 4, 18);
248           block = ",blk=" || ltrim (pic);
249 ^L
250           if iocb_ptr -> iocb.attach_data_ptr ^= null ()
251                then call error (error_table_$not_detached, "tape_nstd_", "^a", iocb_ptr -> iocb.name);
252           ics.dimptr = addr (nstd_$nstd_module);
253           ics.sdbptr = null;
254           reel_name = reel || track || density || block || comment;
255           call iox_$ios_call_attach (iocb_ptr -> iocb.name, "nstd_", reel_name, substr ("rw", 1, 1 + bin (write_sw, 1)),
256                status, addr (ics));
257           if status.code ^= 0 then call error (status.code, "tape_nstd_");
258           call hcs_$set_ips_mask (0, mask);
259           if iocb_ptr -> iocb.attach_descrip_ptr ^= null () then go to unattach;
260           blkptr = free_blks_ptr;
261           if blkptr ^= null ()
262                then free_blks_ptr = blkptr -> blk.sdbptr;
263                else code = hcs_$assign_linkage (size (blkptr -> blk), blkptr);
264           if blkptr = null ()
265                then do;
266 unattach:
267                     call hcs_$reset_ips_mask (mask, mask);
268                     ics.entry = detach_offset;
269                     call iox_$ios_call (addr (ics), "", "", status);
270                     call error (code, "tape_nstd_", "^a", iocb_ptr -> iocb.name);
271                end;
272           blkptr -> blk.sdbptr = ics.sdbptr;
273           blkptr -> blk.dimptr = ics.dimptr;
274           blkptr -> blk.attach = "tape_nstd_ " || rtrim (reel_name);
275           if write_sw then blkptr -> blk.attach = blkptr -> blk.attach || " -write";
276           blkptr -> blk.open = "";
277           blkptr -> blk.write_ring = write_sw;
278           blkptr -> blk.extend = "0"b;
279           blkptr -> blk.maxbuf = divide (block_size, 4, 18);
280           iocb_ptr -> iocb.attach_descrip_ptr = addr (blkptr -> blk.attach);
281           iocb_ptr -> iocb.attach_data_ptr = blkptr;
282           iocb_ptr -> iocb.detach_iocb = tape_detach;
283           iocb_ptr -> iocb.open = tape_open;
284           call iox_$propagate (iocb_ptr);
285           call hcs_$reset_ips_mask (mask, mask);
286           return;
287 ^L
288 /*
289 
290    This entry processes iox_$detach_iocb requests for tape_nstd_.
291 
292 */
293 
294 
295 tape_detach:
296      entry (iocb_ptr, arg_code);
297 
298 
299           arg_code = 0;
300           mask = 0;
301           call default_handler_$set (HANDLER);
302           call hcs_$set_ips_mask (0, mask);
303           blkptr = iocb_ptr -> iocb.attach_data_ptr;
304           ics.sdbptr = blkptr -> blk.sdbptr;
305           ics.dimptr = blkptr -> blk.dimptr;
306           ics.entry = detach_offset;
307           call iox_$ios_call (addr (ics), "", "", status);
308           if status.code ^= 0
309                then do;
310                     call hcs_$reset_ips_mask (mask, mask);
311                     arg_code = status.code;
312                     return;
313                end;
314           blkptr -> blk.sdbptr = free_blks_ptr;
315           free_blks_ptr = blkptr;
316           iocb_ptr -> iocb.attach_descrip_ptr, iocb_ptr -> iocb.attach_data_ptr = null;
317           iocb_ptr -> iocb.detach_iocb = iox_$err_not_attached;
318           iocb_ptr -> iocb.open = iox_$err_not_attached;
319           call iox_$propagate (iocb_ptr);
320           call hcs_$reset_ips_mask (mask, mask);
321           return;
322 ^L
323 /*
324 
325    This entry processes iox_$open requests for tape_nstd_.
326 
327 */
328 
329 
330 tape_open:
331      entry (iocb_ptr, mode, extend_bit, arg_code);
332 
333 
334           if extend_bit
335                then do;
336                     arg_code = error_table_$bad_arg;
337                     return;
338                end;
339           mask = 0;
340           call default_handler_$set (HANDLER);
341           call hcs_$set_ips_mask (0, mask);
342           call SETUP;
343           if mode = sequential_input_mode then blkptr -> blk.open = "sequential_input";
344           else if blkptr -> blk.write_ring & mode = sequential_output_mode then blkptr -> blk.open = "sequential_output";
345           else if blkptr -> blk.write_ring & mode = sequential_input_output_mode
346                then blkptr -> blk.open = "sequential_input_output";
347           else do;
348                call hcs_$reset_ips_mask (mask, mask);
349                arg_code = error_table_$bad_mode;
350                return;
351           end;
352           actual_iocb_ptr -> iocb.open_descrip_ptr = addr (blkptr -> blk.open);
353           actual_iocb_ptr -> iocb.detach_iocb = iox_$err_not_closed;
354           actual_iocb_ptr -> iocb.open = iox_$err_not_closed;
355           actual_iocb_ptr -> iocb.close = tape_close;
356           actual_iocb_ptr -> iocb.control = tape_control;
357           if mode ^= sequential_output_mode then actual_iocb_ptr -> iocb.read_record = tape_read;
358           if mode ^= sequential_input_mode then actual_iocb_ptr -> iocb.write_record = tape_write;
359           call iox_$propagate (actual_iocb_ptr);
360           call hcs_$reset_ips_mask (mask, mask);
361           return;
362 ^L
363 /*
364 
365    This entry processes all iox_$close requests for tape_nstd_.
366 
367 */
368 
369 
370 tape_close:
371      entry (iocb_ptr, arg_code);
372 
373 
374           call SETUP;
375           ics.entry = order_offset;
376           call iox_$ios_call (addr (ics), "rewind", null (), status);
377           mask = 0;
378           call default_handler_$set (HANDLER);
379           call hcs_$set_ips_mask (0, mask);
380           actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
381           actual_iocb_ptr -> iocb.open_descrip_ptr = null;
382           actual_iocb_ptr -> iocb.detach_iocb = tape_detach;
383           actual_iocb_ptr -> iocb.open = tape_open;
384           actual_iocb_ptr -> iocb.close = iox_$err_not_open;
385           actual_iocb_ptr -> iocb.read_record = iox_$err_not_open;
386           actual_iocb_ptr -> iocb.write_record = iox_$err_not_open;
387           call iox_$propagate (actual_iocb_ptr);
388           call hcs_$reset_ips_mask (mask, mask);
389           return;
390 ^L
391 /*
392 
393    This entry processes all iox_$read_record requests for tape_nstd_.
394 
395 */
396 
397 
398 tape_read:
399      entry (iocb_ptr, bufptr, buflen, actlen, arg_code);
400 
401 
402           call SETUP;
403           actlen = 0;
404           if buflen < 1 then return;
405           ics.entry = read_offset;
406           call iox_$ios_call (addr (ics), bufptr, 0, (min (blkptr -> blk.maxbuf, divide (buflen, 4, 17, 0))), nn, status);
407           actlen, chars = 4 * nn;
408           call SET_CODE;
409           if buflen < chars
410                then arg_code = error_table_$long_record;
411                else arg_code = code;
412           return;
413 ^L
414 /*
415 
416    This entry processes all iox_$write_record requests for tape_nstd_.
417 
418 */
419 
420 
421 tape_write:
422      entry (iocb_ptr, bufptr, buflen, arg_code);
423 
424 
425           call SETUP;
426           if buflen < 1 then return;
427           if mod (buflen, 4) ^= 0
428                then do;
429                     arg_code = error_table_$invalid_record_length;
430                     return;
431                end;
432           ics.entry = write_offset;
433           nn = divide (buflen, 4, 17, 0);
434 
435           if nn > blkptr -> blk.maxbuf
436                then arg_code = error_table_$long_record;
437                else do;
438                     call iox_$ios_call (addr (ics), bufptr, 0, nn, 1, status);
439                     call SET_CODE;
440                     arg_code = code;
441                end;
442           return;
443 ^L
444 /*
445 
446    This entry processes all iox_$control requests for tape_nstd_.
447 
448 */
449 
450 
451 tape_control:
452      entry (iocb_ptr, order, info_ptr, arg_code);
453 
454 dcl  order                           char (*);
455 dcl  info_ptr                        ptr;
456 
457 
458           call SETUP;
459           ics.entry = order_offset;
460 
461           do order_index = 1 to hbound (ORDER_TAB, 1);
462                if ORDER_TAB.NAME (order_index) = order then goto ACT (ORDER_TAB.ACTION (order_index));
463                end;
464 
465           arg_code = error_table_$undefined_order_request;
466           return;
467 
468 ACT (0):                                                    /* no mapping or special handling */
469           call iox_$ios_call (addr (ics), order, info_ptr, status);
470           call SET_CODE;
471           arg_code = code;
472           return;
473 
474 
475 ACT (1):                                                    /* backspace_file */
476           leader_ok, eof_ok = "1"b;
477           goto ACT (0);
478 
479 
480 ACT (2):                                                    /* backspace_record */
481           call MAPPED_ORDER ("back");
482           if status.code = leader_status
483                then arg_code = error_table_$end_of_info;
484                else arg_code = code;
485           return;
486 
487 
488 ACT (3):                                                    /* forward_file */
489           eof_ok = "1"b;
490           goto ACT (0);
491 
492 
493 ACT (4):                                                    /* io_call */
494           call IO_CALL ();
495           arg_code = code;
496           return;
497 
498 
499 ACT (5):                                                    /* retry_count */
500           call MAPPED_ORDER ("err_count");
501           arg_code = code;
502           return;
503 
504 
505 ACT (6):                                                    /* rewind */
506           leader_ok = "1"b;
507           goto ACT (0);
508 
509 
510 ACT (7):                                                    /* write_eof */
511           call MAPPED_ORDER ("eof");
512           arg_code = code;
513           return;
514 ^L
515 /* Internal procedure to handle all attach errors.  Calls "com_err_" if the "loud_sw"
516    is set.  In any case, returns to caller of attach external procedure with proper
517    error code after ensuring that the IPS interrupt mask is restored. */
518 
519 ERROR:
520      proc (c);
521 
522 
523 dcl  c                               fixed (35);
524 
525 
526           if mask ^= 0 then call hcs_$reset_ips_mask (mask, mask);
527           if loud_sw then call cu_$gen_call (com_err_, (cu_$arg_list_ptr ()));
528           arg_code = c;
529           go to return;
530 
531 
532      end ERROR;
533 
534 
535 return:
536           return;
537 ^L
538 /* Internal procedure to handle faults while IPS interrupts
539    are masked.  While not masked, any signals are simply
540    passed on up the stack to their normal handlers.  For a
541    fault while masked, the process is terminated (with the
542    reason "unable to do critical I/O") because the I/O
543    control blocks are in an inconsistent state, and we can
544    tolerate neither spawning a command loop with interrupts
545    masked nor a restart with a possibly changed mask. */
546 
547 
548 HANDLER:
549      proc (p1, name, p2, p3, continue);
550 
551 
552 dcl  (p1, p2, p3)                    ptr;
553 dcl  name                            char (*);
554 dcl  continue                        bit (1) aligned;
555 dcl  error_table_$unable_to_do_io    fixed (35) ext;
556 dcl  terminate_process_              ext entry (char (*), ptr);
557 dcl  1 ti                            aligned,
558        2 version                     fixed,
559        2 code                        fixed (35);
560 
561 
562           if mask ^= 0
563                then do;
564                     ti.version = 0;
565                     ti.code = error_table_$unable_to_do_io;
566                     call terminate_process_ ("fatal_error", addr (ti));
567                end;
568           if name ^= "cleanup" then continue = "1"b;
569           return;
570 
571 
572      end HANDLER;
573 ^L
574 /*
575 
576    This procedure processes all order calls that must be handled special for io_call.
577 
578 */
579 
580 
581 IO_CALL:
582      proc ();
583 
584 
585           io_call_infop = info_ptr;
586           if io_call_info.order_name = "request_status" | io_call_info.order_name = "saved_status"
587                then do;
588                     call iox_$ios_call (addr (ics), io_call_info.order_name, addr (st), status);
589                     if status.code = 0
590                          then do;
591                               call analyze_device_stat_$rsnnl (status_story, addr (tape_status_table_$tape_status_table_),
592                                    (st), ("0"b));
593                               if status_story = ""
594                                    then call io_call_info.report ("no interesting status");
595                                    else call io_call_info.report ("status:^-^a", status_story);
596                          end;
597                     code = status.code;
598                end;
599           else if io_call_info.order_name = "fixed_record_length" then call IO_CALL_W_FB ("fixed_record_length");
600           else if io_call_info.order_name = "retry_count" then call IO_CALL_W_FB ("err_count");
601           else code = error_table_$undefined_order_request;
602 
603           return;
604 
605 
606 IO_CALL_W_FB:
607      proc (ord);
608 
609 
610 dcl  ord                             char (*);
611 dcl  value                           fixed bin (35);
612 
613 
614           if io_call_info.nargs < 1
615                then do;
616                     call io_call_info
617                          .
618                          error (error_table_$noarg, io_call_info.caller_name, "Argument for ^a control order missing.",
619                          order);
620                     code = 0;
621                     return;
622                end;
623           value = cv_dec_check_ ((io_call_info.args (1)), code);
624           if code ^= 0
625                then do;
626                     call io_call_info
627                          .
628                          error (error_table_$bad_conversion, io_call_info.caller_name,
629                          "Error converting ""^a"" to binary.", io_call_info.args (1));
630                     code = 0;
631                     return;
632                end;
633           call iox_$ios_call (addr (ics), ord, addr (value), status);
634           call SET_CODE ();
635           return;
636 
637 
638      end IO_CALL_W_FB;
639 
640 
641      end IO_CALL;
642 ^L
643 /*
644 
645    The mapped order procedure handles nstd_ calls where the order name is
646    to be mapped to an nstd_ compatible order.
647 
648 */
649 
650 
651 MAPPED_ORDER:
652      proc (ord);
653 
654 
655 dcl  ord                             char (*);
656 
657 
658           call iox_$ios_call (addr (ics), ord, info_ptr, status);
659           call SET_CODE;
660           return;
661 
662 
663      end MAPPED_ORDER;
664 ^L
665 /*
666 
667    The SET_CODE procedure interprets status and sets code accordingly.
668 
669 */
670 
671 
672 SET_CODE:
673      proc;
674 
675 
676 dcl  1 s                             aligned based (addr (status.code)),
677        2 (
678        io                            bit (1),
679        junk                          bit (25),
680        major                         bit (4),
681        minor                         bit (6)
682        )                             unaligned;
683 
684 
685           if status.code = 0 then code = 0;
686           else if ^s.io then code = status.code;
687           else if status.code = leader_status
688                then if leader_ok
689                          then code = 0;
690                          else code = error_table_$tape_error;
691           else if (s.major = "0100"b) & s.io
692                then if eof_ok
693                          then code = 0;
694                          else code = error_table_$end_of_info;
695           else code = error_table_$tape_error;
696           return;
697 
698 
699      end SET_CODE;
700 ^L
701 /*
702 
703    The procedure setup performs setup common to a number of entries.
704 
705 */
706 
707 
708 SETUP:
709      proc;
710 
711 
712           actual_iocb_ptr = iocb_ptr -> iocb.actual_iocb_ptr;
713           blkptr = actual_iocb_ptr -> iocb.attach_data_ptr;
714           ics.sdbptr = blkptr -> blk.sdbptr;
715           ics.dimptr = blkptr -> blk.dimptr;
716           leader_ok, eof_ok = "0"b;
717           arg_code, code = 0;
718           return;
719 
720 
721      end SETUP;
722 ^L
723 %include iocb;
724 ^L
725 %include io_call_info;
726 
727 
728      end tape_nstd_attach;