1module reval4;   % Support for REDUCE 4 evaluation.
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% The following selectors and constructors could be inlines.
30
31symbolic procedure type u; car u;
32
33% mkobject -- defined in block4.red.
34
35symbolic procedure value u; cadr u;
36
37symbolic procedure mknovalobj; mkobject(nil,'noval);
38
39symbolic procedure getobject u;
40   (if x and type x eq 'generic then n_form print value x else x)
41    where x=get(u,'avalue);
42
43symbolic procedure putobject(u,v,w);
44   % Store value v for object u of type w.
45   put(u,'avalue,mkobject(v,w));
46
47% ---------------------------------------
48
49symbolic procedure xtype(u,v);
50   % True if type of u is liftable to type v.
51   xtype1(type u,v);
52
53symbolic procedure xtype1(u,v);
54   if null type_in_pckgp u then nil
55    else u eq v or xtypelist(get(u,'uptree),v);
56
57symbolic procedure xtypelist(u,v);
58   u and (xtype1(car u,v) or xtypelist(cdr u,v));
59
60symbolic procedure rapply(u,v);
61   % Apply generic operator u to argument list v.
62%  type_reduce1 rapply1(u,v);   % Already done by rapply1.
63   rapply1(u,v);
64
65symbolic procedure rapply1(u,v);
66   begin scalar x,y;
67      % Look for named structure (e.g., array or matrix).
68      if (x := getobject u) and (y := get(type x,'getfn))
69        then return type_reduce1 apply2(y,x,v);
70      x := for each j in v collect type j;
71      y := type_function(u,x,v);
72      if null y then if flagp(u,'opr) then u := eval_generic(u,v) else
73        if null cdr x then rederr list(u,"not defined for type",car x) else
74        rederr(u . "not defined for types" . x) else
75       u := apply(car y,v);
76%     if !*specification_reduce then
77      u := type_reduce1 u;      % Always reduce to ground type for now.
78      if null !*reduce4    % It must have been turned off.
79        then return value u
80       else return u
81   end;
82
83endmodule;
84
85end;
86