1 &version 2
  2 &ready_proc off
  3 &-
  4 &-  ***********************************************************
  5 &-  *                                                         *
  6 &-  * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  7 &-  *                                                         *
  8 &-  ***********************************************************
  9 &-
 10 &- Compare two PL/I programs ignoring most formatting.  First remove all
 11 &- format_pl1 control comments from both programs.  Secondly, format_pl1 both
 12 &- programs into a canonical style.  Finally, use compare_ascii to see how they
 13 &- differ.  The line numbers in the compare_ascii output will not be accurate.
 14 &- Vertical white space inserted or deleted between statements isn't ignored.
 15 &-
 16 &- Written 3 September 1980 by M. N. Davidoff.
 17 &- Modified 16 March 1981 by M. N. Davidoff for format_pl1 version 6.0.
 18 &- Modified 28 April 1981 by M. N. Davidoff to delete temporary segments.
 19 &- Modified 1 May 1981 by M. N. Davidoff to format using indcomtxt mode.
 20 &- Modified 22 May 1981 by M. N. Davidoff to not initiate >exl>o>format_pl1.
 21 &- Modified May 1982 by B. Braun to use shriek names in the [pd] for seg names,
 22 &- to support archive component names, to not use >exl>exec_coms, to add a cleanup handler
 23 &- Modified September 1983 by E. N. Kittlitz for ready_proc off, 0j in teco.
 24 &-
 25 &trace &command off
 26 &goto &ec_name
 27 &-
 28 &label compare_pl1
 29 &label cpp
 30 on cleanup  "exec_com &ec_dir>cpp_cleanup_" -bf exec_com  &ec_dir>&ec_name_ &rf1
 31 &quit
 32 &-
 33 &label compare_pl1_
 34 &label cpp_
 35 &-
 36 &if &[value_defined cpp.ec.already_invoked -perprocess]
 37 &then &goto check_value &else &goto set_value
 38 &-
 39 &label check_value
 40 &if &[value_get cpp.ec.already_invoked -perprocess] &then &goto already_invoked
 41 &-
 42 &label set_value
 43 value_set cpp.ec.already_invoked true -perprocess
 44 &-
 45 &label cpp_check_usage
 46 &-
 47 &if &[nless &n 2] &then &do
 48    &print compare_pl1.ec: Wrong number of arguments.
 49    &print Usage: ec cpp path1 path2
 50    &goto cpp_cleanup_
 51 &end
 52 &-
 53 &if &[ngreater [search &1 *?] 0] &then &do
 54    &print compare_pl1.ec: Star convention is not allowed. &1
 55    &goto cpp_cleanup_
 56 &end
 57 &if &[ngreater [search &2 *?] 0] &then &do
 58    &print compare_pl1.ec: Star convention is not allowed. &2
 59    &goto cpp_cleanup_
 60 &end
 61 &goto compare_pl1_usage_ok
 62 &-
 63 &label do_continue
 64 &print compare_pl1.ec: The previous cpp invocation cannot be restarted.
 65 value_set cpp.ec.already_invoked false -perprocess
 66 &goto cpp_check_usage
 67 &-
 68 &label already_invoked
 69 &if &[query "A previous invocation of cpp is in effect. This will be overridden if you continue. Do you wish to continue?"]
 70 &then &goto do_continue &else &goto do_not_continue
 71 &-
 72 &label do_not_continue
 73 value_set cpp.ec.already_invoked true -perprocess
 74 &print compare_pl1.ec: Current invocation aborted. Previous cpp can be restarted.
 75 &quit
 76 &-
 77 &label compare_pl1_usage_ok
 78 &-
 79 value_set cpp.ec.expanded_path1 [path [strip &1 pl1].pl1] -perprocess
 80 value_set cpp.ec.seg_path1 [entry_path [path [strip &1 pl1].pl1]] -perprocess
 81 &-
 82 &if &[exists segment [value_get cpp.ec.seg_path1 -perprocess] -chase] &then &do
 83    &if &[ngreater [index [status [value_get cpp.ec.seg_path1 -perprocess] -mode -chase] "r"] 0] &then &do
 84       &if &[ngreater [index [status [directory &1] -directory -mode -chase] "s"] 0] &then &do
 85          &if &[is_component_pathname &1] &then &do
 86             &if &[exists component [strip &1 pl1].pl1 -chase] &then &do
 87                answer yes -bf archive x [entry_path &1] [process_dir]>[strip_component &1 pl1].pl1
 88                value_set cpp.ec.component1 [process_dir]>[unique].component1.pl1 -perprocess
 89                rename [process_dir]>[strip_component &1 pl1].pl1 [entry [value_get cpp.ec.component1 -perprocess]]
 90             &end
 91             &else &do
 92                &print compare_pl1.ec: Archive component not found. &[strip &1 pl1].pl1
 93                &goto cpp_cleanup_
 94                &end
 95          &end
 96          &else &do &end
 97       &end
 98       &else &do
 99          &print compare_pl1.ec: Status permission missing on directory. &[strip &1 pl1].pl1
100          &goto cpp_cleanup_
101       &end
102    &end
103    &else &do
104       &print compare_pl1.ec: Incorrect access on entry. &[value_get cpp.ec.seg_path1 -perprocess]
105       &goto cpp_cleanup_
106    &end
107 &end
108 &else &do
109    &print compare_pl1.ec: Segment not found. &[value_get cpp.ec.seg_path1 -perprocess]
110    &goto cpp_cleanup_
111 &end
112 &-
113 value_set cpp.ec.expanded_path2 [path [strip [equal_name &1 &2] pl1].pl1] -perprocess
114 value_set cpp.ec.seg_path2 [entry_path [path [strip [equal_name &1 &2] pl1].pl1]] -perprocess
115 &-
116 &if &[exists segment [value_get cpp.ec.seg_path2 -perprocess] -chase] &then &do
117    &if &[ngreater [index [status [value_get cpp.ec.seg_path2 -perprocess] -mode -chase] "r"] 0] &then &do
118       &if &[ngreater [index [status [directory &2] -directory -mode -chase] "s"] 0] &then &do
119          &if &[is_component_pathname &2] &then &do
120             &if &[exists component [value_get cpp.ec.expanded_path2 -perprocess] -chase] &then &do
121                answer yes -bf archive x [value_get cpp.ec.seg_path2 -perprocess] [process_dir]>[strip_component [value_get cpp.ec.expanded_path2] pl1].pl1
122                value_set cpp.ec.component2 [process_dir]>[unique].component2.pl1 -perprocess
123                rename [process_dir]>[strip_component [value_get cpp.ec.expanded_path2] pl1].pl1 [entry [value_get cpp.ec.component2 -perprocess]]
124             &end
125             &else &do
126                &print compare_pl1.ec: Archive component not found. &[strip [equal_name &1 &2] pl1].pl1
127                &goto cpp_cleanup_
128             &end
129          &end
130          &else &do &end
131       &end
132       &else &do
133          &print compare_pl1.ec: Status permission missing on directory. &[value_get cpp.ec.expanded_path2 -perprocess]
134          &goto cpp_cleanup_
135       &end
136    &end
137    &else &do
138       &print compare_pl1.ec: Incorrect access on entry. &[value_get cpp.ec.seg_path1 -perprocess]
139       &goto cpp_cleanup_
140    &end
141 &end
142 &else &do
143    &print compare_pl1.ec: Segment not found. &[value_get cpp.ec.seg_path2 -perprocess]
144    &goto cpp_cleanup_
145 &end
146 &-
147 value_set cpp.ec.path1 [process_dir]>[unique].1.pl1 -perprocess
148 value_set cpp.ec.path2 [process_dir]>[unique].2.pl1 -perprocess
149 &-
150 &if &[is_component_pathname &1]
151 &then exec_com &ec_dir>cpp_dl_ctl_comments_ [value_get cpp.ec.component1 -perprocess] [value_get cpp.ec.path1 -perprocess]
152 &else exec_com &ec_dir>cpp_dl_ctl_comments_ [strip &1 pl1].pl1  [value_get cpp.ec.path1 -perprocess]
153 &-
154 &if &[is_component_pathname &2]
155 &then exec_com &ec_dir>cpp_dl_ctl_comments_ [value_get cpp.ec.component2 -perprocess] [value_get cpp.ec.path2 -perprocess]
156 &else exec_com &ec_dir>cpp_dl_ctl_comments_ [strip [equal_name [component &1] &2] pl1].pl1 [value_get cpp.ec.path2 -perprocess]
157 &-
158 format_pl1 [value_get cpp.ec.path1 -perprocess] -output_file [process_dir]>== -modes style3,^indattr,ifthenstmt,ifthendo,ifthen,indcomtxt,ind0,initcol1,declareind8,dclind4
159 &-
160 format_pl1 [value_get cpp.ec.path2 -perprocess] -output_file [process_dir]>== -modes style3,^indattr,ifthenstmt,ifthendo,ifthen,indcomtxt,ind0,initcol1,declareind8,dclind4
161 &-
162 compare_ascii [value_get cpp.ec.path1 -perprocess] [value_get cpp.ec.path2 -perprocess]
163 &-
164 &label cpp_cleanup_
165 &-
166 &if &[value_defined cpp.ec.path1 -perprocess]
167 &then delete [value_get cpp.ec.path1  -perprocess] -bf;value_delete cpp.ec.path1 -perprocess
168 &-
169 &if &[value_defined cpp.ec.path2 -perprocess]
170 &then delete [value_get cpp.ec.path2  -perprocess] -bf;value_delete cpp.ec.path2 -perprocess
171 &-
172 &if &[value_defined cpp.ec.expanded_path1 -perprocess]
173 &then value_delete cpp.ec.expanded_path1 -perprocess
174 &-
175 &if &[value_defined cpp.ec.seg_path1 -perprocess]
176 &then value_delete cpp.ec.seg_path1 -perprocess
177 &-
178 &if &[value_defined cpp.ec.component1 -perprocess]
179 &then delete [value_get cpp.ec.component1 -perprocess] -bf;value_delete cpp.ec.component1 -perprocess
180 &-
181 &if &[value_defined cpp.ec.expanded_path2 -perprocess]
182 &then value_delete cpp.ec.expanded_path2 -perprocess
183 &-
184 &if &[value_defined cpp.ec.seg_path2 -perprocess]
185 &then value_delete cpp.ec.seg_path2 -perprocess
186 &-
187 &if &[value_defined cpp.ec.component2 -perprocess]
188 &then delete [value_get cpp.ec.component2  -perprocess] -bf;value_delete cpp.ec.component2 -perprocess
189 &-
190 &if &[value_defined cpp.ec.already_invoked -perprocess]
191 &then value_delete cpp.ec.already_invoked -perprocess
192 &-
193 &quit
194 &-
195 &label cpp_dl_ctl_comments_
196 &-
197 &if &[ not [nequal &n 2]] &then &do
198    &print Usage: ec &ec_name path1 path2
199    &goto cpp_cleanup_
200 &end
201 &-
202 &if &[not [exists segment [strip &1 pl1].pl1 -chase]] &then &do
203    &print compare_pl1.ec: Segment not found. &[strip &1 pl1].pl1
204    &goto cpp_cleanup_
205 &end
206 &-
207 &attach
208 &trace &input off
209 discard_output >tools>teco
210 ei/&1/0j
211 :is|<1a,32"n 1a,9"n 1;'' c>|            ! qs = macro to skip over SP and HT !
212 :iq|"|                                  ! qq = double quote !
213 <.u1                                    ! q1 = point before searching !
214 &SP(3):sqq "n .u2 :' zu2' q1j           ! q2 = start of quoted string !
215 &SP(3):s|/*|"n .u3 :' zu3' q1j                    ! q3 = start of comment text !
216 
217 &SP(3)q2,q3"e 1;'                       ! q2 = q3: no quote or comment, exit !
218 &SP(3)q2,q3"l                           ! q2 lt q3: found quote first !
219 &SP(6)q2j :sqq "e 1;''                  ! find matching quote, exit if none !
220 &SP(3)q2,q3"g                           ! q2 gt q3: found comment first !
221 &SP(6)q3j :s|*/| "e 1;'                 ! find matching */, exit if none !
222 &SP(6).-2u4                             ! q4 = end of comment text !
223 &SP(6)q3j ms                            ! skip leading white space !
224 &SP(6)1<"m/format:/                     ! check for format: !
225 &SP(9)s/format:/ ms           ! skip format: and white space !
226 &SP(9)<1a,32"e 1;' 1a,9"e 1;' .,q4"e 1;' c>
227 &HT(4)! skip until ws or end of comment !
228 &SP(9)ms                      ! skip white space after modes string !
229 &SP(9).,q4"e q3-2,q4+2k 1;'   ! if at end of comment, it is a control
230 &HT(4)&SP(2)comment, so delete it !
231 &SP(6)' q4+2j>                          ! not a control comment, skip it !
232 &SP(3)'>
233 
234 eo/&2/ eq
235 $
236 &detach
237 &trace &input off
238 &quit