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