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