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