1module redfront;
2
3revision('redfront, "$Id: redfront.red 5188 2019-11-12 21:12:26Z eschruefer $");
4
5copyright('redfront, "(c) 1999-2009 A. Dolzmannm, T. Sturm, 2010-2017 T. Sturm");
6
7% Redistribution and use in source and binary forms, with or without
8% modification, are permitted provided that the following conditions
9% are met:
10%
11%    * Redistributions of source code must retain the relevant
12%      copyright notice, this list of conditions and the following
13%      disclaimer.
14%    * Redistributions in binary form must reproduce the above
15%      copyright notice, this list of conditions and the following
16%      disclaimer in the documentation and/or other materials provided
17%      with the distribution.
18%
19% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
20% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
21% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
22% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
23% OWNERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
24% SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
25% LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
26% DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
27% THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
28% (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29% OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30%
31
32global '(statcounter);
33
34fluid '(posn!* orig!*);
35
36procedure redfront_oh(m,l);
37   begin scalar outputhandler!*;
38      if m eq 'maprin then
39         if ofl!* or posn!* neq orig!* then
40            maprin l
41	 else <<
42            redfront_on();
43	    assgnpri(l,nil,nil);
44            redfront_off()
45         >>
46      else if m eq 'prin2!* then
47         prin2!* l
48      else if m eq 'terpri then
49         terpri!* l
50      else if m eq 'assgnpri then <<
51            redfront_on();
52	    assgnpri(car l,nil,nil);
53            redfront_off()
54         >>
55      else
56         rederr {"unknown method ",m," in redfront_oh"}
57   end;
58
59procedure redfront_on();
60   <<
61      terpri!* nil;
62      prin2 int2id 3;
63      terpri!* nil
64   >>;
65
66procedure redfront_off();
67   <<
68      terpri!* nil;
69      prin2 int2id 4
70   >>;
71
72procedure redfront_formwrite(u,vars,mode);
73   % Workaround to avoid linebreaks with "write 1,2,3". This is based
74   % on a patch of the original formwrite(), which TS wanted to avoid.
75   begin scalar z;
76      z := formwrite(u,vars,mode);
77      if null z then return nil;
78      return {'cond,
79         {{'and,{'eq,'outputhandler!*,'(quote redfront_oh)},'(not ofl!*)},
80            {'prog,'(outputhandler!*),'(redfront_on),z,'(redfront_off)}},
81         {t,z}}
82   end;
83
84put('write,'formfn,'redfront_formwrite);
85
86outputhandler!*:='redfront_oh;
87
88fluid '(promptstring!* redfront_switches!* redfront_switches!-this!-sl!*
89   lispsystem!* breaklevel!* input!-libraries output!-library);
90
91redfront_switches!* := {!*msg,!*output};
92
93off1 'msg;
94off1 'output;
95
96procedure redfront_pslp();
97   'psl memq lispsystem!*;
98
99if redfront_pslp() then <<
100   redfront_switches!-this!-sl!* := {!*usermode};
101   off1 'usermode
102>>;
103
104procedure redfront_color(c);
105   if stringp c then
106      compress('!" . int2id 1 .
107               reversip('!" . int2id 2 . cdr reversip cdr explode c))
108   else
109      intern compress(int2id 1 . nconc(explode c,{int2id 2}));
110
111procedure redfront_uncolor(c);
112   if stringp c then
113      compress('!" . reversip('!" . cddr reversip cddr explode c))
114   else
115      intern compress('!! . reversip cdr reversip cdr explode c);
116
117procedure redfront_setpchar!-psl(c);
118   begin scalar w;
119      w := redfront_setpchar!-orig c;
120      promptstring!* := redfront_color promptstring!*;
121      return redfront_uncolor w
122   end;
123
124procedure redfront_setpchar!-csl(c);
125   redfront_uncolor redfront_setpchar!-orig redfront_color c;
126
127global '(redfront_setpchar_redefined!*);
128
129if not redfront_setpchar_redefined!* then
130  copyd('redfront_setpchar!-orig,'setpchar);
131
132if redfront_pslp() then
133   copyd('setpchar,'redfront_setpchar!-psl)
134else
135   copyd('setpchar,'redfront_setpchar!-csl);
136
137redfront_setpchar_redefined!* := t;
138
139procedure redfront_yesp!-psl(u);
140   begin scalar ifl,ofl,x,y;
141      if ifl!* then <<
142         ifl := ifl!* := {car ifl!*,cadr ifl!*,curline!*};
143         rds nil
144      >>;
145      if ofl!* then <<
146         ofl:= ofl!*;
147          wrs nil
148      >>;
149      if null !*lessspace then
150          terpri();
151      if atom u then
152          prin2 u
153      else
154          lpri u;
155      if null !*lessspace then
156          terpri();
157      y := setpchar "?";
158      x := yesp1();
159      setpchar y;
160      if ofl then wrs cdr ofl;
161      if ifl then rds cadr ifl;
162      cursym!* := '!*semicol!*;
163      return x
164   end;
165
166if redfront_pslp() then <<
167   remflag('(yesp),'lose);
168   copyd('redfront_yesp!-orig,'yesp);
169   copyd('yesp,'redfront_yesp!-psl);
170   flag('(yesp),'lose)
171>>;
172
173% Color PSL prompts, in case user falls through:
174
175procedure redfront_compute!-prompt!-string(count,level);
176   redfront_color redfront_compute!-prompt!-string!-orig(count,level);
177
178if redfront_pslp() then <<
179   copyd('redfront_compute!-prompt!-string!-orig,'compute!-prompt!-string);
180   copyd('compute!-prompt!-string,'redfront_compute!-prompt!-string)
181>>;
182
183procedure redfront_break_prompt();
184   <<
185      prin2 "break["; prin2 breaklevel!*; prin2 "]";
186      promptstring!* := redfront_color promptstring!*
187   >>;
188
189if redfront_pslp() then <<
190   copyd('break_prompt,'redfront_break_prompt);
191   flag('(break_prompt),'lose);
192>>;
193
194if redfront_pslp() then
195   onoff('usermode,car redfront_switches!-this!-sl!*);
196
197% Support for editline completion
198
199procedure redfront_learncolor(c);
200   if stringp c then
201      compress('!" . int2id 5 .
202               reversip('!" . int2id 6 . cdr reversip cdr explode c))
203   else
204      intern compress(int2id 5 . nconc(explode c,{int2id 6}));
205
206
207!#if (memq 'psl lispsystem!*)
208
209fluid '(redfront_l!*);
210
211symbolic procedure redfront_oblist_sub x;
212  redfront_l!* := x . redfront_l!*;
213
214symbolic procedure redfront_oblist();
215  begin
216    scalar redfront_l!*;
217    mapobl function redfront_oblist_sub;
218    return redfront_l!*;
219  end;
220
221!#else
222
223symbolic procedure redfront_oblist(); oblist();
224
225!#endif
226
227procedure redfront_swl();
228   begin scalar swl;
229      swl := for each x in redfront_oblist() join if flagp(x,'switch) then {x};
230      return sort(swl,'ordp)
231   end;
232
233procedure redfront_send!-switches();
234   <<
235      for each sw in redfront_swl() do
236	 prin2t redfront_learncolor sw;
237      statcounter := statcounter - 1;
238      nil
239   >>;
240
241procedure redfront_modl();
242   begin scalar libl,l;
243      if redfront_pslp() then
244      	 return nil;
245      libl := input!-libraries;
246      if output!-library then
247	 libl := output!-library . libl;
248      l := for each x in libl join library!-members x;
249      return sort(l,'ordp)
250   end;
251
252procedure redfront_send!-modules();
253   <<
254      for each mod in redfront_modl() do
255	 prin2t redfront_learncolor mod;
256      statcounter := statcounter - 1;
257      nil
258   >>;
259
260% Making this a MACRO means that its body gets evaluated at the the
261% that a use of it is COMPILED. That means that the path to package.map
262% as used here is only relevant at system-building time, which is a time
263% when the full source tree is guaranteed to be available. The notation
264% "$reduce" is set up (at that time, but not when the fully built system
265% is complete. During a PSL build a shell variable called "reduce" should
266% be set and so I make a path by concatenating based on that.
267
268% An issue I found awkward when coding this is that in PSL a function that is
269% defined here is not made available immediatly, and so if expanding a macro
270% depends on it you are out of luck. I had to work around that by implementing
271% the macro as one big function rather than several several smaller ones.
272
273symbolic macro procedure redfront_package_names u;
274  begin
275    scalar fn,i,w,e,basel,extral;;
276    fn := "$reduce/packages/package.map";
277    if memq('psl, lispsystem!*) then
278    begin
279      scalar r1, r2, r3;
280      r2 := explode2 (r1 := getenv "reduce");
281      r3 := explode2 "/cygdrive/";
282% I will map a prefix "/cygdrive/x" to "x:"
283      while r2 and r3 and car r2 = car r3 do <<
284        r2 := cdr r2;
285        r3 := cdr r3 >>;
286      if null r3 then
287        r1 := list2string (car r2 . '!: . '!/ . cddr r2);
288      fn := concat(r1, "/packages/package.map");
289    end;
290    prin2 "**** File name for packages = "; print fn;
291    i := fn;
292    i := open(i, 'input);
293    i := rds i;
294    e := !*echo;
295    !*echo := nil;
296    w := read();
297    !*echo := e;
298    i := rds i;
299    close i;
300    basel := for each x in w join
301      if member('core, cddr x) then {car x};
302    extral := for each x in w join
303      if not member('core, cddr x) then {car x};
304    return mkquote (basel . extral)
305  end;
306
307
308procedure redfront_send!-packages(fn);
309   <<
310      for each pack in cdr redfront_package_names() do
311	 prin2t redfront_learncolor pack;
312      statcounter := statcounter - 1;
313      nil
314   >>;
315
316procedure redfront_fwl();
317   begin scalar fwl;
318      fwl := for each x in redfront_oblist() join
319 	 if get(x, 'psopfn) or get(x, 'opfn) or get(x, 'polyfn) then
320 	    {x};
321      return sort(fwl,'ordp)
322   end;
323
324procedure redfront_send!-functions();
325   <<
326      for each fw in redfront_fwl() do
327	 prin2t redfront_learncolor fw;
328      statcounter := statcounter - 1;
329      nil
330   >>;
331
332onoff('msg,car redfront_switches!*);
333onoff('output,cadr redfront_switches!*);
334
335crbuf!* := nil;
336inputbuflis!* := nil;
337%!*lessspace := t;
338statcounter := 0;
339
340endmodule;
341
342end;
343