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 copy_words: cw: proc;
 12 
 13 /* Fixed to show its long name in error messages 07/07/81 S. Herbst */
 14 
 15 dcl
 16      whoami char (32) aligned varying,
 17      cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)),
 18      expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)),
 19      hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
 20      hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)),
 21      hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)),
 22      cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
 23      com_err_ entry options (variable),
 24      words (nwords) fixed bin (35) based,
 25     (i, j, k, nwords) fixed bin,
 26     (inp, outp, p) ptr,
 27     (onamep, inamep) pointer,
 28     (inlen, outlen) fixed bin,
 29      iname char (inlen) based (inamep),
 30      outname char (outlen) based (onamep),
 31     (indir, outdir) char (168),
 32     (inename, outename) char (32),
 33      bc fixed bin (24),
 34      number char (numlen) based (np),
 35      numlen fixed bin,
 36      np ptr,
 37      hcs_$terminate_noname entry (ptr, fixed bin (35));
 38 dcl  code fixed bin (35);
 39 
 40 dcl (addr, divide, mod, null, pointer) builtin;
 41 dcl  cleanup condition;
 42 
 43           whoami = "copy_words";
 44           inp = null;
 45           outp = null;
 46 
 47           call cu_$arg_ptr (1, inamep, inlen, code);
 48           if code ^= 0 then do;
 49 err1:          call com_err_ (code, whoami);
 50                return;
 51           end;
 52 
 53           call expand_pathname_ (iname, indir, inename, code);
 54           if code ^= 0 then do;
 55 err2:          call com_err_ (code, whoami, iname);
 56                return;
 57           end;
 58 
 59 
 60           call hcs_$initiate_count (indir, inename, "", bc, 0, inp, code);
 61 
 62           on cleanup begin;
 63                if inp ^= null then call hcs_$terminate_noname (inp, code);
 64                if outp ^= null then call hcs_$terminate_noname (outp, code);
 65           end;
 66 
 67           if inp = null then go to err2;
 68 
 69 
 70           call cu_$arg_ptr (2, onamep, outlen, code);
 71           if code ^= 0 then go to err1;
 72 
 73           call expand_pathname_ (outname, outdir, outename, code);
 74           if code ^= 0 then do;
 75 err3:          call com_err_ (code, whoami, outname);
 76                return;
 77           end;
 78 
 79           call hcs_$make_seg (outdir, outename, "", 01011b, outp, code);
 80           if outp = null then go to err3;
 81           call cu_$arg_ptr (3, np, numlen, code);
 82           if code ^= 0 then go to err1;
 83 
 84           i = cv_oct_check_ (number, code);
 85           if code ^= 0 then do;
 86 err4:          code = 0;
 87                call com_err_ (code, whoami, "Illegal conversion.  "||number);
 88                return;
 89           end;
 90 
 91           call cu_$arg_ptr (4, np, numlen, code);
 92           if code ^= 0 | numlen = 0 then do;
 93                j = divide (bc, 36, 17, 0)-1;
 94                k = mod (bc, 36);
 95                if k ^= 0 then j = j+1;
 96           end;
 97           else do;
 98                k = 0;
 99                j = cv_oct_check_ (number, code);
100                if code ^= 0 then go to err4;
101           end;
102 
103           nwords = j-i+1;
104           p = pointer (inp, i);
105 
106           outp -> words = p -> words;                       /* make the copy */
107 
108           call hcs_$set_bc (outdir, outename, (nwords*36)+k, code);
109           if code ^= 0 then go to err3;
110 
111           call hcs_$terminate_noname (inp, code);
112           if code ^= 0 then go to err2;
113 
114           call hcs_$terminate_noname (outp, code);
115           if code ^= 0 then go to err3;
116 
117      end;