1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
 12 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
 13 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
 14 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
 15 
 16 mrpg: proc;
 17 
 18 dcl MRPG_version    char (8) int static init ("1.1b");
 19 
 20 /* report generator language                                                 */
 21 
 22       code = 0;
 23       ifp = null ();
 24       call cu_$arg_ptr (1, argp, argl, code);
 25       if (code = 0)
 26       then do;
 27          if (substr (arg, 1, 1) ^= "-")
 28          then do;
 29             if (ifp ^= null ())
 30             then do;
 31                call com_err_ (0, command_name, "Multiple input segments not allowed.");
 32                return;
 33             end;
 34             call expand_pathname_$add_suffix (arg, "mrpg", dname, ename, code);
 35             if (code ^= 0)
 36             then do;
 37                call com_err_ (code, command_name, "^a", arg);
 38                return;
 39             end;
 40             if (verify (before (ename, ".mrpg"), chars) ^= 0)
 41                | (index ("_0123456789", substr (ename, 1, 1)) ^= 0)
 42             then do;
 43                call com_err_ (0, "mrpg", "Syntax error in report name.");
 44                return;
 45             end;
 46             call hcs_$initiate_count (dname, ename, "", bc, 0, ifp, code);
 47             if (ifp = null ())
 48 
 49             then do;
 50                call com_err_ (code, command_name, "^a>^a", dname, ename);
 51                return;
 52             end;
 53             if (bc = 0)
 54             then do;
 55                call com_err_ (error_table_$zero_length_seg, command_name, "^a>^a", dname, ename);
 56                return;
 57             end;
 58             ife = divide (bc, 9, 24, 0);
 59             arg = before (ename, ".mrpg");
 60          end;
 61          else do;
 62             call com_err_ (error_table_$badopt, command_name, "^a", arg);
 63             return;
 64          end;
 65       end;
 66       else do;
 67          call com_err_ (code, command_name || MRPG_version, "
 68 Usage:    mrpg pathname {PL/I options}");
 69          return;
 70       end;
 71       if (ifp = null ())
 72       then do;
 73          call com_err_ (error_table_$noarg, command_name, "Input segment.");
 74          return;
 75       end;
 76       call ioa_ ("MRPG ^a", MRPG_version);
 77       ai.version = area_info_version_1;
 78       ai.zero_on_alloc = "1"b;
 79       ai.zero_on_free = "0"b;
 80       ai.dont_free = "0"b;
 81       ai.no_freeing = "1"b;
 82       ai.owner = command_name;
 83       ai.size = sys_info$max_seg_size;
 84       if hold_sw
 85       then do;
 86          ai.extend = "0"b;
 87          call hcs_$make_seg (get_wdir_ (), "mrpg.area", "mrpg.area", 01010b, ai.areap, code);
 88          if (ai.areap = null ())
 89          then do;
 90             call com_err_ (code, "mrpg", "Getting work area");
 91             return;
 92          end;
 93       end;
 94       else do;
 95          ai.areap = null ();
 96          ai.extend = "1"b;
 97       end;
 98       call define_area_ (addr (ai), code);
 99       if (code ^= 0)
100       then do;
101          call com_err_ (code, command_name, "define_area_");
102          return;
103       end;
104       on condition (cleanup) begin;
105             if ^hold_sw
106             then call release_area_ (ai.areap);
107          end;
108       on condition (mrpg_fatal) goto done;
109       call mrpg_error_$init;
110       call mrpg_parse_ (ifp, ife, ai.areap, code);
111       if mrpg_error_$stat ()
112       then goto done;
113       call mrpg_generate_ (ai.areap, ename, ifp, code);
114       if (code ^= 0)
115       then goto done;
116       if ^hold_sw then
117            call release_area_ (ai.areap);
118       ai.areap = null ();
119       call hcs_$make_ptr (null (), "pl1", "pl1", pl1p, code);
120       call cu_$arg_list_ptr (arglp);
121       call cu_$gen_call (pl1p, arglp);
122 done:
123       if ^hold_sw & (ai.areap ^= null ()) then
124            call release_area_ (ai.areap);
125       return;
126 
127 dcl 1 ai            like area_info;
128 %include area_info;
129 dcl arg             char (argl) based (argp); /* current argument            */
130 dcl argl            fixed bin (24);     /* length of current argument        */
131 dcl arglp           ptr;
132 dcl argp            ptr;                /* pointer to current argument       */
133 dcl bc              fixed bin (24);
134 dcl chars           char (63) int static
135   init ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789");
136 dcl cleanup         condition;
137 dcl code            fixed bin (35);
138 dcl com_err_        entry options (variable);
139 dcl command_name    char (4) int static init ("mrpg");
140 dcl cu_$arg_list_ptr entry (ptr);
141 dcl cu_$arg_ptr     entry (fixed bin (24), ptr, fixed bin (24), fixed bin (35));
142 dcl cu_$gen_call    entry (ptr, ptr);
143 dcl define_area_    entry (ptr, fixed bin (35));
144 dcl dname           char (168);         /* directory portion of input name   */
145 dcl ename           char (32);          /* entry portion of input name       */
146 dcl error_table_$zero_length_seg fixed bin (35) ext static;
147 dcl error_table_$badopt fixed bin (35) ext static;
148 dcl error_table_$noarg fixed bin (35) ext static;
149 dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
150 dcl get_wdir_       entry returns (char (168));
151 dcl hcs_$initiate_count entry options (variable);
152 dcl hcs_$make_ptr   entry (ptr, char (*), char (*), ptr, fixed bin (35));
153 dcl hcs_$make_seg   entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
154 dcl i               fixed bin (24);
155 dcl ife             fixed bin (24);     /* length of input segment           */
156 dcl ifp             ptr;                /* pointer to input sgment           */
157 dcl ioa_            entry options (variable);
158 dcl mrpg_error_$init entry;
159 dcl mrpg_error_$stat entry returns (bit (1));
160 dcl mrpg_fatal      condition;
161 dcl mrpg_generate_  entry (ptr, char (32), ptr, fixed bin (35));
162 dcl mrpg_parse_     entry (ptr, fixed bin (24), ptr, fixed bin (35));
163 dcl pl1p            ptr;
164 dcl release_area_   entry (ptr);
165 dcl sys_info$max_seg_size fixed bin (24) ext static;
166 
167 dcl (addr, before, codeptr, divide, index, null, substr, verify) builtin;
168 
169 dcl hold_sw         bit (1) int static init ("0"b);
170 holdn: entry; hold_sw = "1"b; return;
171 holdf: entry; hold_sw = "0"b; return;
172    end;