1
2% Author: Anthony C. Hearn.
3
4% This code is designed to structure Lisp and REDUCE code.  The result
5% should have the same execution behavior as the input.
6
7% The next few bits are to make this code free-standing...
8
9symbolic procedure lprim x; print x;
10
11symbolic procedure no!-side!-effectp u;
12   if atom u then numberp u or idp u and not(fluidp u or globalp u)
13    else if car u eq 'quote then t
14    else if flagp!*!*(car u,'nosideeffects)
15     then no!-side!-effect!-listp u
16    else nil;
17
18symbolic procedure no!-side!-effect!-listp u;
19   null u or no!-side!-effectp car u and no!-side!-effect!-listp cdr u;
20
21flag('(car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
22       cddar cdddr cons),'nosideeffects);
23
24% Currently code does not check for duplicate labels.
25
26symbolic procedure structchk u;
27   % Top level structuring function.
28   begin scalar v;
29      repeat <<v := copy u; u := structchk1 u>> until u = v;
30      return u
31   end;
32
33symbolic procedure structchk1 u;
34   begin scalar x;
35   if atom u or car u eq 'quote then return u
36    else if atom car u and (x := get(car u,'structfn))
37     then return apply(x,list u)
38    else if car u eq 'lambda
39     then return list('lambda,cadr u,structchk1 caddr u)
40    else if car u eq 'procedure
41     then return list('procedure,cadr u,caddr u,cadddr u,
42		      car cddddr u,structchk1 cadr cddddr u)
43    else return for each x in u collect structchk1 x
44 end;
45
46put('cond,'structfn,'strcond);
47
48put('rblock,'structfn,'blockchk);
49
50put('prog,'structfn,'progchk);
51
52put('progn,'structfn,'prognchk);
53
54symbolic procedure strcond u;
55   begin
56      u := for each x in cdr u collect list(car x,structchk1 cadr x);
57      if length u = 2 and eqcar(cadar u,'cond) and caadr u = 't
58       then u := {mknot caar u,cadadr u} . cdadar u;
59      return 'cond . u
60   end;
61
62symbolic procedure mknot u;
63  if not atom u and car u memq '(not null) then cadr u else {'not,u};
64
65fluid '(flg lablist);
66
67symbolic procedure addlbl lbl;
68   if atsoc(lbl,lablist) then nil
69     else lablist := list(lbl,nil) . lablist;
70
71symbolic procedure addblock lst;
72   rplacd(cdr atsoc(getlbl caar lst,lablist),cdar lst . cdr lst);
73
74symbolic procedure gochk u;
75   if atom u or car u memq '(quote prog) then nil
76    else if car u eq 'go then updlbl(cadr u,u)
77    else <<gochk car u; gochk cdr u>>;
78
79symbolic procedure updlbl(lbl,exp);
80  begin
81    scalar x;
82    x := atsoc(lbl,lablist);
83    if x then rplaca(cdr x,exp . cadr x)
84    else lablist := list(lbl,list exp) . lablist
85  end;
86
87
88symbolic procedure transferp u;
89   if atom u or not idp car u then nil
90    else if flagp(car u,'transfer) then car u
91    else if car u eq 'cond then condtranp cdr u
92    else if car u memq '(prog2 progn) then transferp car reverse cdr u
93    else nil;
94
95flag('(go return rederr error errach),'transfer);
96
97symbolic procedure condtranp u;
98   % Determines if every branch of a COND is a transfer.
99   if null u then nil
100    else if null cdr u and caar u eq t then transferp cadar u
101    else transferp cadar u and condtranp cdr u;
102
103symbolic procedure progchk u; blockchk1(u,'prog);
104
105symbolic procedure blockchk u; blockchk1(u,'rblock);
106
107symbolic procedure blockchk1(u,v);
108   begin scalar flg,lablist,laststat,vars,top,x,z;
109      % Format of element of LABLIST is (label,list of references,body).
110      vars := cadr u;
111      % Define independent blocks.
112      u := cddr u;
113      if null u then lprie "empty block";
114      % First make sure that block does not 'fall through'.
115      x := u;
116      while cdr x do x := cdr x;
117%     if not transferp car x then rplacd(x,list '(return nil));
118      % Now look for first label.
119      while u and not labelp car u do
120	 <<top := car u . top; gochk car u;  u := cdr u>>;
121	   % Should that be structchk1 car u?
122      if null u then <<top := reversip top; go to ret>>
123       else if null top or not transferp car top
124	  then <<top := list('go,getlbl car u) . top; gochk car top>>;
125      top := reversip top;
126      top := list nil . nil . top . car reverse top;   % lablist format.
127      while u do
128	if labelp car u
129	       then <<addlbl getlbl car u;
130		 if null laststat or transferp laststat
131		   then <<laststat := nil;
132			  x := list car u; u := cdr u;
133			  while u and not transferp laststat do
134			   <<if labelp car u
135			       then u := list('go,getlbl car u) . u;
136				gochk car u;
137				laststat := car u;
138			     x := car u . x;
139			     u := cdr u>>;
140			  addblock(reversip x . laststat);
141			  x := nil>>>>
142		 else rederr list("unreachable statement",car u);
143      % Merging of blocks.
144      lablist := reversip lablist;   % To make final order correct.
145    a:
146      flg := nil;
147      % Removal of (cond ... (pi (go lab)) ...) ... (go lab)).
148      for each x in (top . lablist)
149	 do if cdr x and cddr x and eqcar(cdddr x,'go)
150	      then condgochk(caddr x,cdddr x);
151      % Replacement of singly referenced labels by PROGN.
152      x := nil;
153      while lablist do
154	<<z := length cadar lablist;
155	   if z=0 or z=1 and cdddar lablist=caadar lablist
156	    then lprim list("unreferenced block at label",caar lablist)
157	 else if z=1
158	  then <<flg := t; lprim list("label",caar lablist,"removed");
159		rplacw(caadar lablist,prognchk1 caddar lablist)>>
160	 else x := car lablist . x; lablist := cdr lablist>>;
161      lablist := reversip x;
162      % WHILE/REPEAT insertion.
163      for each z in lablist do
164	if cdddr z = caadr z
165	   and eqcar(caaddr z,'cond)
166	   and null cddr caaddr z
167	   and transferp cadadr caaddr z
168	   and notranp cdaddr z
169	 then <<flg := t;
170		rplaca(cdr z,!&deleq(cdddr z,cadr z));
171		rplaca(cddr z,list(whilechk(mknull caadr caaddr z,
172		  cdr reverse cdaddr z),cadadr caaddr z));
173		rplacd(cddr z,nil)>>;
174      % Superfluous PROGN expansion.
175      if flg then for each y in top . lablist do
176	<<z := caddr y;
177	  while z do
178	     if eqcar(car z,'progn) then rplacw(z,nconc(cdar z,cdr z))
179	      else z := cdr z;
180	      if cdr y and cddr y and eqcar(cdddr y,'progn)
181		then rplacd(cddr y,car reverse cdddr y)>>;
182      if flg then go to a;
183      top := caddr top;   % Retrieve true expression.
184      x := top;
185      % Pick up remaining labels.
186      while x do
187	<<while cdr x do x := cdr x;
188	  if eqcar(car x,'go) and (z := atsoc(cadar x,lablist))
189	    then <<rplacw(x,if cdadr z then mklbl car z . caddr z
190			     else <<lprim list("label",caar lablist,
191					       "removed"); caddr z>>);
192		   lablist := delete(z,lablist)>>
193	   else if lablist
194	    then <<rplacd(x,mklbl caar lablist . caddar lablist);
195				lablist := cdr lablist>>
196	 else x := cdr x>>;
197 ret: top := miscchk structchk1 top;
198      if null vars and eqcar(car top,'return) then return cadar top
199       else return v . vars . top;
200   end;
201
202symbolic procedure miscchk u;
203   % Check for miscellaneous constructs.
204   begin scalar v,w;  % x
205      v := u;
206%     x := copy u;
207      while v do if eqcar(car v,'setq) and
208	 ((w := setqchk(car v,cdr v)) neq v) then rplacw(v,w)
209	  else if cdr v and eqcar(car v,'cond) and null cddar v
210	     and eqcar(cadr cadar v,'return)
211	  % Next line should be generalized to (...) ... (return ...).
212	     and eqcar(cadr v,'return)
213	   then rplacw(v,{'return,
214			   {'cond,{caadar v,cadr cadr cadar v},
215			     {'t,cadr cadr v}}} . cddr v)
216	 else v := cdr v;
217%     return if u = x then u else miscchk u
218      return u
219   end;
220
221symbolic procedure setqchk(u,v);
222   % Determine if setq in u is necessary.
223   begin scalar x,y,z;
224      x := cadr u; y := caddr u;
225      if not no!-side!-effectp y then return u . v;
226  a:  if null v then return u . reversip z
227%      else if eqcar(car v,'return) and not smemq(x,cdar v)
228%       then return nconc(reversip z,v)
229       else if eqcar(car v,'return) and used!-oncep(x,cadar v)
230	then <<lprim list("assignment for",x,"removed");
231	       return nconc(reversip z,substq(x,y,car v) . cdr v)>>
232       else if not smemq(x,car v)
233	then <<z := car v . z; v := cdr v; go to a>>
234       else return u . nconc(reversip z,v)
235   end;
236
237symbolic procedure used!-oncep(u,v);
238   % Determines if u is used at most once in v.
239   if atom v then t
240    else if car v eq 'quote then t
241    else if u eq car v then not smemq(u,cdr v)
242    else used!-oncep(u,cdr v);
243
244symbolic procedure substq(u,v,w);
245   % Substitute first occurrence of atom u in w by v.
246   if atom w then if u eq w then v else w
247    else if car w eq 'quote then w
248    else if u eq car w then v . cdr w
249    else if not atom car w then substq(u,v,car w) . substq(u,v,cdr w)
250    else car w . substq(u,v,cdr w);
251
252symbolic procedure labelp u;
253   atom u or car u eq '!*label;
254
255symbolic procedure getlbl u;
256   if atom u then u else cadr u;
257
258symbolic procedure mklbl u; list('!*label,u);
259
260symbolic procedure notranp u;
261   null smemqlp('(go return),cdr reverse u);
262
263symbolic procedure !&deleq(u,v);
264   if null v then nil else if u eq car v then cdr v
265    else car v . !&deleq(u,cdr v);
266
267symbolic procedure prognchk u; prognchk1 cdr u;
268
269symbolic procedure prognchk1 u;
270   if null cdr u or null cdr(u:= miscchk u) then car u else 'progn . u;
271
272symbolic procedure mknull u;
273   if not atom u and car u memq '(null not) then cadr u
274    else list('null,u);
275
276symbolic procedure condgochk(u,v);
277   if null u then nil
278    else <<condgochk(cdr u,v);
279	   if eqcar(car u,'cond) then cgchk1(cdar u,u,v)>>;
280
281symbolic procedure cgchk1(u,v,w);
282   if null u then nil
283    else if not transferp cadar u then nil
284	% We could look for following (T transfer) here.
285    else begin scalar x,y,z;
286	cgchk1(cdr u,v,w);
287	x := cadar u;
288	if x=w
289	    or eqcar(x,'progn) and (x := car reverse x)=w
290		and (y := reverse cdr reverse cdadar u)
291	then <<flg := t;
292	z := atsoc(cadr w,lablist);
293	rplaca(cdr z,!&deleq(x,cadr z));
294	rplaca(car u,mknull caar u);
295	z := reverse cdr reverse cdr v;
296	if cdr u then <<z := ('cond . cdr u) . z; rplacd(u,nil)>>;
297	if y then rplacd(u,list list(t,prognchk1 y));
298	rplaca(cdar u,prognchk1 z);
299	rplacd(v,list w)>>
300   else nil
301   end;
302
303% The following routines transform MAPs into FOR EACH statements
304% were possible;
305
306symbolic procedure mapox u; mapsox(u,'on,'do);
307
308symbolic procedure mapcox u; mapsox(u,'in,'do);
309
310symbolic procedure maplistox u; mapsox(u,'on,'collect);
311
312symbolic procedure mapcarox u; mapsox(u,'in,'collect);
313
314symbolic procedure mapconox u; mapsox(u,'on,'conc);
315
316symbolic procedure mapcanox u; mapsox(u,'in,'conc);
317
318symbolic procedure mapsox(u,v,w);
319   begin scalar x,y,z;
320      x := cadr u;
321      y := caddr u;
322      if not eqcar(y,'function)
323	then rederr list("syntax error in map expression",u);
324      y := cadr y;
325      if atom y then <<z := 'x; y := list(y,z)>>
326       else if not(car y eq 'lambda) or null cadr y or cdadr y
327	then rederr list("syntax error in map expression",u)
328       else <<z := caadr y; y := caddr y>>;
329      return list('foreach,z,v,x,w,y)
330   end;
331
332put('map,'structfn,'mapox);
333
334put('mapc,'structfn,'mapcox);
335
336put('maplist,'structfn,'maplistox);
337
338put('mapcar,'structfn,'mapcarox);
339
340put('mapcan,'structfn,'mapcanox);
341
342put('mapcon,'structfn,'mapconox);
343
344symbolic procedure whilechk(u,v);
345   begin scalar w;
346      % Note that V is in reversed order.
347      return if idp(u) and car v = list('setq,u,list('cdr,u))
348	and not((w := caronly(u,cdr v,'j)) eq '!*failed!*)
349	then list('progn,list('foreach,'j,'in,u,'do,prognchk1 reversip w),
350		  list('setq,u,nil))
351       else list('while,u,prognchk1 reversip v)
352   end;
353
354symbolic procedure caronly(u,v,w);
355   begin scalar x;
356      return if not smemq(u,v) then v
357	  else if atom v then if u eq v then '!*failed!* else v
358    else if not idp car v
359       or not(eqcar(cdr v,u) and cdr v and null cddr v
360		and (x := get(car v,'carfn)))
361     then cmerge(caronly(u,car v,w),caronly(u,cdr v,w))
362    else if car v eq 'car then w
363    else list(x,w)
364   end;
365
366deflist('((car t) (caar car) (cdar cdr) (caaar caar) (cadar cadr)
367	  (cdaar cdar) (cddar cddr) (caaaar caaar) (caadar caadr)
368	  (cadaar cadar) (caddar caddr) (cdaaar cdaar) (cdadar cdadr)
369	  (cddaar cddar) (cdddar cdddr)),
370	'carfn);
371
372symbolic procedure cmerge(u,v);
373   if u eq '!*failed!* or v eq '!*failed!* then '!*failed!* else u . v;
374
375
376end;
377