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 expand:proc;
12 
13           /* This program implements the expand command and maintains the old entry point for expand
14           (pct_ex_ is the entry point used by pl1d, pl1,and eplbsa). The expand command implements
15           % include statements in pl1 and eplbsa syntax */
16           dcl pct_entry bit(1) aligned;
17           dcl (com_err_,hcs_$initiate_count) ext entry options (variable);
18           dcl path char(168) aligned,ent char(32) aligned;
19           dcl code1 fixed bin(17),(segp,segp2) ptr, (bit_count,bit_count2) fixed bin(24);
20           dcl expand_path_ ext entry(ptr,fixed bin(17),ptr,ptr,fixed bin(17));
21           dcl hcs_$fs_search_get_wdir ext entry(ptr,fixed bin(17));
22           dcl hcs_$terminate_noname ext entry(ptr,fixed bin (17));
23           dcl expand_ ext entry(char(168) aligned,char(32) aligned,ptr,fixed bin(24),ptr,fixed bin(24),fixed bin(17));
24           dcl(code,arglen,nargs) fixed bin(17),argptr ptr,name char(arglen) based(argptr);
25           dcl cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(17));
26 dcl null builtin;
27 
28           pct_entry = "0"b;             /* this is to keep track of whether I am a command or a subroutine */
29 
30                               /* as a command , there can be more than one file to be expanded */
31           do nargs=1 by 1;
32 
33           call cu_$arg_ptr(nargs,argptr,arglen,code);
34           if code^=0 then return;                 /* this can only mean that there are no more arguments */
35 
36 prepare:  call expand_path_(addr(name),arglen,addr(path),addr(ent),code);
37           if code^=0
38           then do;
39                ent=name;      /* if there was an error in expand_path_ then I must use the oldname*/
40                go to error;
41                end;
42 
43           call hcs_$initiate_count(path,ent,"",bit_count,1,segp,code);
44           if segp = null then go to error;
45 
46           call hcs_$fs_search_get_wdir(addr(path),code);
47 
48           call expand_(path,ent,segp,bit_count,segp2,bit_count2,code1);
49 
50           if segp2^=null      /* this is the only way a fatal error by expand_ shows up */
51           then do;  /* since a pointer is passed, file is not terminated */
52 
53                call hcs_$terminate_noname(segp2,code);
54                if code ^= 0 then go to error;
55 
56                end;
57 
58 cont:     if pct_entry then go to old_call_return;          /* we cannot terminate the original file if this is a
59                                                                       subroutine call */
60           call hcs_$terminate_noname(segp,code);
61           if code ^= 0 then go to error;
62 
63 cont1:    end;
64 
65 pct_ex_:entry(nm,mode,val);
66           /* This entry point is used by pl1d, pl1, eplbsa(or at least it used to be)
67                     nm is a relative pathname to the file to be expanded, mode is an obsolete parameter
68                     that is ignored, val is the error code - it can be either 0, or 2
69                     depending upon whether there has been an error or not. */
70           dcl (nm,mode) char(*),val fixed bin(17);
71 
72           /* try to make it look as if we had called cu_$arg_ptr */
73 
74           val=0;
75           argptr = addr(nm);
76           arglen = length(nm);
77           pct_entry = "1"b;             /* this will keep us out of the loop for multiple arguments, above */
78 
79           go to prepare;      /* enter the code for processing the command */
80 
81 old_call_return:
82           if code1 ^= 0 then val = 2;
83 
84           return;
85 
86 error:    call com_err_(code,"expand","^N^a^O^/",ent);
87 
88           if pct_entry = "1"b then do;
89 
90                               val = 2;
91 
92                               go to old_call_return;
93 
94                               end;
95 
96           go to cont1;
97 end expand;