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 ¬ 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 &SP3:sqq "n .u2 :' zu2' q1j ! q2 = start of quoted string !
215 &SP3:s|/*|"n .u3 :' zu3' q1j ! q3 = start of comment text !
216
217 &SP3q2,q3"e 1;' ! q2 = q3: no quote or comment, exit !
218 &SP3q2,q3"l ! q2 lt q3: found quote first !
219 &SP6q2j :sqq "e 1;'' ! find matching quote, exit if none !
220 &SP3q2,q3"g ! q2 gt q3: found comment first !
221 &SP6q3j :s|*/| "e 1;' ! find matching */, exit if none !
222 &SP6.-2u4 ! q4 = end of comment text !
223 &SP6q3j ms ! skip leading white space !
224 &SP61<"m/format:/ ! check for format: !
225 &SP9s/format:/ ms ! skip format: and white space !
226 &SP9<1a,32"e 1;' 1a,9"e 1;' .,q4"e 1;' c>
227 &HT4! skip until ws or end of comment !
228 &SP9ms ! skip white space after modes string !
229 &SP9.,q4"e q3-2,q4+2k 1;' ! if at end of comment, it is a control
230 &HT4&SP2comment, so delete it !
231 &SP6' q4+2j> ! not a control comment, skip it !
232 &SP3'>
233
234 eo/&2/ eq
235 $
236 &detach
237 &trace &input off
238 &quit