1module rdebug; % REDUCE print extension for PSL's debug commands. 2 3% Author: Herbert Melenk 4 5% Redistribution and use in source and binary forms, with or without 6% modification, are permitted provided that the following conditions are met: 7% 8% * Redistributions of source code must retain the relevant copyright 9% notice, this list of conditions and the following disclaimer. 10% * Redistributions in binary form must reproduce the above copyright 11% notice, this list of conditions and the following disclaimer in the 12% documentation and/or other materials provided with the distribution. 13% 14% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 16% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 17% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 18% CONTRIBUTORS 19% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 20% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 21% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 22% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 23% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 24% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 25% POSSIBILITY OF SUCH DAMAGE. 26% 27 28 29% June 1994 30 31if not ('psl member lispsystem!*) 32 then rederr "incompatible LISP support"; 33 34load debug; 35 36errorset('(psl!-import '(break !*break breaker breakfunction !$break!$ 37 evtrwhen msgchnl!* !*redefmsg trprinter* 38 trstinsidefn !-trstprog !-mktrst1 !-trget 39 unbreak vartype)),nil,nil); 40 41if null getd '!-trget then 42 symbolic procedure !-trget(id,ind); 43 (if w then cdr w) where w=atsoc(ind,get(id,'trace)); 44 45switch break; 46 47remprop('statcounter,'vartype); 48remprop('inputbuflis!*,'vartype); 49remprop('resultbuflis!*,'vartype); 50 51fluid '(!*nat out!* statcounter inputbuflis!* resultbuflis!* lispsystem!*); 52global '(trprinter!* msgchnl!*); 53 54 55if null getd 'assgnpri then 56 symbolic procedure assgnpri(val,vars,mode); 57 <<for each x in vars do <<writepri(mkquote x,'nil);writepri(":=",nil)>>; 58 writepri(mkquote val,mode)>>; 59 60%------------------------------------------------------------------ 61% Print algebraic expressions by REDUCE printer. 62 63fluid '(trlimit); 64share trlimit; 65trlimit := 5; 66 67symbolic procedure rdbprint u; 68 % Try to print an expression u as algebraic expression rather than 69 % LISP internal style. 70 <<algpri1(u,0); assgnpri("",nil,'last)>> 71 where out!* = (msgchnl!* or out!*), !*nat=nil; 72 73symbolic procedure rdbprin2 u; 74 algpri1(u,0) where out!* = (msgchnl!* or out!*), !*nat=nil; 75 76symbolic procedure algpri1(u,n); 77 begin scalar r; 78 n:=n+1; 79 if (r:=algpriform u) then return algpri2 r; 80 algpri2 "["; 81 while u do 82 if atom u then <<algpri2 "."; algpri2 u; u:=nil>> 83 else <<algpri1(car u,n); 84 u:=cdr u; n:=n+1; 85 if pairp u then algpri2 ","; 86 if n>trlimit then <<algpri2 " ...";u:=nil>> 87 >>; 88 algpri2 "]"; 89 end; 90 91symbolic procedure algpriform u; 92 % is expression printable in algebraic mode? 93 if atom u then u else 94 if get(car u,'prifn) or get(car u,'pprifn) then u else 95 if eqcar(u,'!*sq) then prepsq cadr u else 96 if is!-algebraic!? u then u else 97 if get(car u,'prepfn) then prepf u else 98 if is!-sform!? u then prepf u else 99 if is!-sfquot!? u then prepsq u; 100 101symbolic procedure is!-algebraic!? u; 102 atom u or get(car u,'dname) 103 or (get(car u,'simpfn) or get(car u,'psopfn)) 104 and algebraic!-args cdr u; 105 106symbolic procedure algebraic!-args u; 107 null u or is!-algebraic!? car u and algebraic!-args cdr u; 108 109symbolic procedure is!-sform!? u; 110 if atom u then t else 111 if get(car u,'dname) then t else 112 pairp car u and pairp caar u and 113 (is!-algebraic!? mvar u or is!-sform!? mvar u) 114 and fixp ldeg u and ldeg u>0 115 and is!-sform!? lc u and is!-sform!? red u; 116 117symbolic procedure is!-sfquot!? u; 118 pairp u and is!-sform!? numr u and is!-sform!? denr u; 119 120symbolic procedure algpri2 u; 121 assgnpri(u,nil,nil) 122 where out!* = (msgchnl!* or out!*), !*nat=nil; 123 124trprinter!* := 'rdbprint; 125 126%------------------------------------------------------------------ 127% TRST extended to algebraic assignments (SETK function). 128 129symbolic procedure !-trstsetk u; 130 {'prog,'(!*nat),{'assgnpri, u,{'list,cadr u},''last}}; 131 132put('setk,'trstinsidefn,'!-trstsetk); 133 134% prevent wrapper to go into assgnpri. 135 136put('assgnpri,'trstinsidefn,'(lambda(u) u)); 137 138symbolic procedure !-trstprog!* u; 139 % trst wrapper for prog: print labels additionally 140 begin scalar c,r; 141 c:=car u; 142 r:= c . cadr u . for each s in cddr u join 143 if pairp s then {s} else 144 if c neq 'lambda and idp s and not gensymp s then 145 {s,{'prin2,mkquote s},'(prin2t ":")} 146 else {s}; 147 return !-trstprog r; 148 end; 149 150put('prog,'trstinsidefn,'!-trstprog!*); 151 152symbolic procedure gensymp u; 153 idp u and car(u:=explode2 u)= '!G and cdr u and gensymp1 cdr u; 154 155symbolic procedure gensymp1 u; 156 null u or digit car u and gensymp1 cdr u; 157 158%------------------------------------------------------------------ 159% TROUT 160 161symbolic operator trout; 162 163%------------------------------------------------------------------ 164% TRWHEN 165 166remd 'trwhen; 167 168symbolic procedure trwhen u; 169 <<evtrwhen{car u,nil}; % Install target function. 170 evtrwhen{car u,formbool(cadr u, 171 for each x in !-trget(car u,'argnames) 172 collect x . !*mode ,'algebraic)}>>; 173 174put('trwhen,'stat,'rlis); 175 176%------------------------------------------------------------------ 177% BR 178 179 180 181put('br,'stat,'rlis); 182put('unbr,'stat,'rlis); 183flag('(br unbr),'noform); 184 185fluid '(breaklevel!*); 186 187breaklevel!*:=0; 188 189symbolic procedure break(); 190 (begin scalar pp,q,statcounter,inputbuflis!*,resultbuflis!*,!*redefmsg; 191 breaklevel!*:=breaklevel!* + 1; 192 statcounter := 0; 193 pp:=getd 'printprompt; 194 q:=get('!_,'psopfn); 195 put('!_,'psopfn,'break_); 196 remflag('(printprompt),'lose); 197 putd('printprompt,'expr, cdr getd 'break_prompt); 198 catch('!$break!$, eval '(begin)); 199 putd('printprompt,'expr,cdr pp); 200 remprop('!_,'psopfn); 201 if q then put('!_,'psopfn,q); 202 end) where breaklevel!*=breaklevel!*; 203 204 205symbolic procedure break_ u; 206 <<if not atom car u then u:=car u; 207 if get(car u,'breakfunction) then apply(get(car u,'breakfunction),cdr u) 208 else prin2t "### unknown break function">>; 209 210symbolic procedure break_prompt(); 211 <<prin2 "break["; prin2 breaklevel!*; prin2"]";>>; 212 213symbolic procedure local_var u; 214 begin scalar r; 215 r:=errorset(u,nil,nil); 216 return if errorp r then <<prin2l{"### variable",u," not bound"}; terpri();>> 217 else car r; 218 end; 219 220put('l,'breakfunction,'local_var); 221 222%------------------------------------------------------------------ 223% BRWHEN 224 225remd 'brwhen; 226 227symbolic procedure brwhen u; 228 <<!-trinstall(car u,nil); 229 evtrwhen{car u,formbool(cadr u, 230 for each x in !-trget(car u,'argnames) 231 collect x . !*mode ,'algebraic)}>>; 232 233put('brwhen,'stat,'rlis); 234 235%------------------------------------------------------------------ 236% RULE Trace 237 238symbolic procedure rule!-trprint!* u; 239 begin scalar r; 240 rdbprin2 "Rule "; 241 rdbprin2 car u; %name 242 if cadr u then<<rdbprin2 "."; rdbprin2 cadr u>>; 243 rdbprin2 ": "; 244 rdbprin2 caddr u; 245 rdbprin2 " => "; 246 rdbprint (r:=cadddr u); 247 return reval r; 248 end; 249 250put('rule!-trprint,'psopfn,'rule!-trprint!*); 251 252fluid '(trace!-rules!*); 253 254symbolic procedure trrl w; 255 for each u in w do 256 begin scalar name,rs,rsx,n; 257 if idp u then 258 <<name:=u; 259 rs:=reval u; 260 if rs=u then rs:=showrules u; 261 if atom rs or car rs neq 'list or null cdr rs 262 then rederr {"could not find rules for",u}; 263 >> 264 else 265 <<name:=gensym(); 266 prin2 "*** using name "; 267 prin2 name; 268 prin2t " for rule set">>; 269 if eqcar(rs,'list) then <<rs:=cdr rs;n:=1>> else <<rs:={rs};n:=nil>>; 270 rsx := trrules1(name,n,rs); 271 trace!-rules!* := {name,rs,rsx} . trace!-rules!*; 272 algebraic clearrules ('list.rs); 273 algebraic let ('list.rsx); 274 return name; 275 end; 276 277put('trrl,'stat,'rlis); 278 279symbolic procedure trrules1(name,n,rs); 280 begin scalar rl,nrl,rh,lh; 281 rl:=car rs; rs:=cdr rs; 282 if atom rl or not memq(car rl,'(replaceby equal)) 283 then typerr(rl,'rule); 284 lh:=cadr rl; rh:=caddr rl; 285 if constant_exprp lh then go to a; 286 rh := if eqcar(rh,'when) then 287 {'when,{'rule!-trprint,name,n,lh,cadr rh},caddr rh} 288 else {'rule!-trprint,name,n,lh,rh}; 289a: nrl := {car rl,lh,rh}; 290 return if null rs then {nrl} else 291 nrl . trrules1(name,n+1,rs); 292 end; 293 294symbolic procedure untrrl u; 295 begin scalar w,v; 296 for each r in u do 297 <<if not idp r then typerr(r,"rule set name"); 298 w:=assoc(r,trace!-rules!*); 299 if w then 300 << v:='list.caddr w; 301 algebraic clearrules v; 302 v:='list.cadr w; 303 algebraic let v; 304 trace!-rules!*:=delete(w,trace!-rules!*); 305 >> ; 306 >>; 307 end; 308 309put('untrrl,'stat,'rlis); 310 311% Make 'rule!-trprint invisible when printed. 312 313put('rule!-trprint,'prifn, 314 function(lambda(u); maprin car cddddr u)); 315 316put('rule!-trprint,'fancy!-prifn, 317 function(lambda(u);fancy!-maprin car cddddr u)); 318 319endmodule; 320 321end; 322 323