1module forall4;  % Support for "let" etc. statements in REDUCE 4.
2
3% Author: Anthony C. Hearn.
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% For the time being, we are defaulting to the REDUCE 3 model until we
30% decide how such rules should be handled.
31
32symbolic procedure n_formforall(u,vars);
33   mkobject(formforall(u,vars,'algebraic),'noval);
34
35put('forall,'n_formfn,'n_formforall);
36
37symbolic procedure n_formlet(u,vars);
38   mkobject(formlet(u,vars,'algebraic),'noval);
39
40put('let,'n_formfn,'n_formlet);
41
42symbolic procedure n_formclear(u,vars);
43   mkobject(formclear(u,vars,'algebraic),'noval);
44
45put('clear,'n_formfn,'n_formclear);
46
47symbolic procedure n_formmatch(u,vars);
48   mkobject(formmatch(u,vars,'algebraic),'noval);
49
50put('match,'n_formfn,'n_formmatch);
51
52symbolic procedure form4where(u,vars);
53   begin scalar expn,equivs;
54      expn := n_form1(cadr u,vars);
55      equivs := remcomma caddr u;
56      equivs := formc('list . equivs,vars,'algebraic);
57      equivs := cadr equivs;  % FIX THIS.
58      return mkobject(
59        {'prog, '(newrule!* oldrules!* v w),
60            {'setq, 'w, {'set_rules,{'cdr, equivs}, nil}}, % FIX THIS.
61            {'setq, 'u, {'errorset!*,
62                            {'mkquote, {'simp4!*,value expn}}, nil}},
63            '(restore_rules w),
64            '(return (cond ((errorp u) (rederr nil)) (t (car u))))},
65        type expn)
66   end;
67
68put('where,'n_formfn,'form4where);
69
70endmodule;
71
72end;
73