1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2-- All rights reserved. 3-- 4-- Redistribution and use in source and binary forms, with or without 5-- modification, are permitted provided that the following conditions are 6-- met: 7-- 8-- - Redistributions of source code must retain the above copyright 9-- notice, this list of conditions and the following disclaimer. 10-- 11-- - Redistributions in binary form must reproduce the above copyright 12-- notice, this list of conditions and the following disclaimer in 13-- the documentation and/or other materials provided with the 14-- distribution. 15-- 16-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17-- names of its contributors may be used to endorse or promote products 18-- derived from this software without specific prior written permission. 19-- 20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32)package "BOOT" 33 34-- This file contains the constructors for the domains that cannot 35-- be written in ScratchpadII yet. They are not cached because they 36-- are very cheap to instantiate. 37-- SMW and SCM July 86 38 39DEFPARAMETER($noCategoryDomains, '(Mode)) 40DEFPARAMETER($nonLisplibDomains, 41 APPEND($Primitives,$noCategoryDomains)) 42 43--% Record 44-- Want to eventually have the elts and setelts. 45-- Record is a macro in BUILDOM LISP. It takes out the colons. 46 47isRecord type == type is ['Record,:.] 48 49Record0 args == 50 dom := GETREFV 11 51 -- JHD added an extra slot to cache EQUAL methods 52 dom.0 := ['Record, :[['_:, first a, devaluate rest a] for a in args]] 53 dom.1 := 54 [function lookupInTable,dom, 55 [['_=,[[['Boolean],'_$,'_$],:6]], 56 ['_~_=,[[['Boolean],'_$,'_$],:10]], 57 ['coerce, [[$OutputForm, '_$], :7]]]] 58 dom.2 := NIL 59 dom.3 := ['RecordCategory,:QCDR dom.0] 60 dom.4 := 61 [[ '(SetCategory) ], [ '(BasicType), 62 '(CoercibleTo (OutputForm)), '(SetCategory) ]] 63 dom.5 := [rest a for a in args] 64 dom.6 := [function RecordEqual, :dom] 65 dom.7 := [function RecordPrint, :dom] 66 dom.8 := [function Undef, :dom] 67 -- following is cache for equality functions 68 dom.9 := if (n:= LENGTH args) <= 2 69 then [NIL,:NIL] 70 else GETREFV n 71 dom.10 := [function RecordUnEqual, :dom] 72 dom 73 74RecordEqual(x,y,dom) == 75 PAIRP x => 76 b:= 77 SPADCALL(first x, first y, first(dom.9) or 78 first RPLACA(dom.9, findEqualFun(dom.5.0))) 79 NULL rest(dom.5) => b 80 b and 81 SPADCALL(rest x, rest y, rest(dom.9) or 82 rest RPLACD(dom.9, findEqualFun(dom.5.1))) 83 VECP x => 84 equalfuns := dom.9 85 and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) 86 for i in 0.. for fdom in dom.5] 87 error '"Bug: Silly record representation" 88 89RecordUnEqual(x,y,dom) == not(RecordEqual(x,y,dom)) 90 91RecordPrint(x,dom) == coerceRe2E(x,dom.3) 92 93coerceVal2E(x,m) == 94 -- first catch "failed" etc. 95 STRINGP m and (x = m) => STRCONC('"_"", x, '"_"") 96 objValUnwrap coerceByFunction(objNewWrap(x, m), $OutputForm) 97 98findEqualFun(dom) == 99 compiledLookup('_=,[$Boolean,'$,'$],dom) 100 101coerceRe2E(x,source) == 102 n := #rest(source) 103 n = 1 => 104 ['construct, 105 ['_=, source.1.1, coerceVal2E(first x, source.1.2)] ] 106 n = 2 => 107 ['construct, 108 ['_=, source.1.1, coerceVal2E(first x, source.1.2)], _ 109 ['_=, source.2.1, coerceVal2E(rest x, source.2.2)] ] 110 VECP x => 111 ['construct, 112 :[['_=,tag,coerceVal2E(x.i, fdom)] 113 for i in 0.. for [.,tag,fdom] in rest source]] 114 error '"Bug: ridiculous record representation" 115 116 117--% Union 118-- Want to eventually have the coerce to and from branch types. 119 120Union(:args) == 121 dom := GETREFV 10 122 dom.0 := ['Union, :[(if a is ['_:,tag,domval] then ['_:,tag,devaluate domval] 123 else devaluate a) for a in args]] 124 dom.1 := 125 [function lookupInTable,dom, 126 [['_=,[[['Boolean],'_$,'_$],:6]], 127 ['_~_=, [[['Boolean],'_$,'_$],:9]], 128 ['coerce,[[$OutputForm, '_$],:7]]]] 129 dom.2 := NIL 130 dom.3 := 131 '(SetCategory) 132 dom.4 := 133 [[ '(SetCategory) ],[ '(BasicType), 134 '(CoercibleTo (OutputForm)), '(SetCategory) ]] 135 dom.5 := args 136 dom.6 := [function UnionEqual, :dom] 137 dom.7 := [function UnionPrint, :dom] 138 dom.8 := [function Undef, :dom] 139 dom.9 := [function UnionUnEqual, :dom] 140 dom 141 142UnionEqual(x, y, dom) == 143 ['Union,:branches] := dom.0 144 predlist := mkPredList branches 145 same := false 146 res := false 147 for b in stripUnionTags branches for p in predlist while not same repeat 148 p is ["EQCAR", "#1", n] => 149 EQCAR(x, n) and EQCAR(y, n) => 150 same := true 151 STRINGP b => res := (x = y) 152 x := rest x 153 y := rest y 154 res := SPADCALL(x, y, findEqualFun(evalDomain b)) 155 typeFun := COERCE(['LAMBDA, '(_#1), p], 'FUNCTION) 156 FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => 157 same := true 158 STRINGP b => res := (x = y) 159 res := SPADCALL(x, y, findEqualFun(evalDomain b)) 160 res 161 162UnionUnEqual(x, y, dom) == not(UnionEqual(x, y, dom)) 163 164UnionPrint(x, dom) == coerceUn2E(x, dom.0) 165 166coerceUn2E(x,source) == 167 ['Union,:branches] := source 168 predlist := mkPredList branches 169 found := false 170 for b in stripUnionTags branches for p in predlist while not(found) repeat 171 found := 172 p is ["EQCAR", "#1", n] => EQCAR(x, n) 173 typeFun := COERCE(['LAMBDA, '(_#1), p], 'FUNCTION) 174 FUNCALL(typeFun,x) 175 if found then 176 if p is ['EQCAR, :.] then x := rest x 177 res := coerceVal2E(x,b) 178 not(found) => 179 error '"Union bug: Cannot find appropriate branch for coerce to E" 180 res 181 182mkPredList listOfEntries == 183 [['EQCAR,"#1",i] for arg in listOfEntries for i in 0..] 184 185--% Mapping 186-- Want to eventually have elt: ($, args) -> target 187 188Mapping(:args) == 189 dom := GETREFV 10 190 dom.0 := ['Mapping, :[devaluate a for a in args]] 191 dom.1 := 192 [function lookupInTable,dom, 193 [['_=,[[['Boolean],'_$,'_$],:6]], 194 ['coerce,[[$OutputForm, '_$],:7]]]] 195 dom.2 := NIL 196 dom.3 := 197 '(SetCategory) 198 dom.4 := 199 [[ '(SetCategory) ],[ '(BasicType), 200 '(CoercibleTo (OutputForm)), '(SetCategory) ]] 201 dom.5 := args 202 dom.6 := [function MappingEqual, :dom] 203 dom.7 := [function MappingPrint, :dom] 204 dom.8 := [function Undef, :dom] 205 dom.9 := [function MappingUnEqual, :dom] 206 dom 207 208MappingEqual(x, y, dom) == EQ(x,y) 209 210MappingUnEqual(x, y, dom) == not(EQ(x,y)) 211 212MappingPrint(x, dom) == coerceMap2E(x) 213 214coerceMap2E(x) == 215 -- nrlib domain 216 ARRAYP rest x => ['theMap, BPINAME first x, 217 if $testingSystem then 0 else REMAINDER(HASHEQ rest x, 1000)] 218 -- aldor 219 ['theMap, BPINAME first x] 220 221--% Enumeration 222-- Enumeration is a Lisp macro since it wants unevaluated arguments 223-- Enumeration0 below is a function, so it needs explicit quotes for 224-- arguments 225 226Enumeration0(:args) == 227 dom := GETREFV 10 228 -- JHD added an extra slot to cache EQUAL methods 229 dom.0 := ['Enumeration, :args] 230 dom.1 := 231 [function lookupInTable,dom, 232 [['_=,[[['Boolean],'_$,'_$],:6]], 233 ['coerce,[[$OutputForm, '_$],:7], [['_$, $Symbol], :8]] 234 ]] 235 dom.2 := NIL 236 dom.3 := ['EnumerationCategory,:QCDR dom.0] 237 dom.4 := 238 [[ '(SetCategory) ], [ '(BasicType), 239 '(CoercibleTo (OutputForm)), '(SetCategory) ]] 240 dom.5 := args 241 dom.6 := [function EnumEqual, :dom] 242 dom.7 := [function EnumPrint, :dom] 243 dom.8 := [function createEnum, :dom] 244 dom.9 := [function EnumUnEqual, :dom] 245 dom 246 247EnumEqual(e1,e2,dom) == e1=e2 248EnumUnEqual(e1,e2,dom) == not(EnumEqual(e1,e2,dom)) 249EnumPrint(enum, dom) == dom.5.enum 250createEnum(sym, dom) == 251 args := dom.5 252 val := -1 253 for v in args for i in 0.. repeat 254 sym=v => return(val:=i) 255 val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] 256 val 257 258--% INSTANTIATORS 259 260get_oplist_maker(op) == 261 op = "Record" => "mkRecordFunList" 262 op = "Union" => "mkUnionFunList" 263 op = "Mapping" => "mkMappingFunList" 264 op = "Enumeration" => "mkEnumerationFunList" 265 false 266 267RecordCategory(:x) == constructorCategory ['Record,:x] 268 269EnumerationCategory(:x) == constructorCategory ["Enumeration",:x] 270 271UnionCategory(:x) == constructorCategory ["Union",:x] 272 273 274constructorCategory (title is [op,:.]) == 275 constructorFunction := get_oplist_maker(op) or 276 systemErrorHere '"constructorCategory" 277 [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) 278 oplist:= [[[a,b],true,c] for [a,b,c] in funlist] 279 cat:= 280 JoinInner([SetCategory(), mkCategory(oplist, nil, nil, nil)]) 281 cat.(0):= title 282 cat 283 284--mkMappingFunList(nam,mapForm,e) == [[],e] 285mkMappingFunList(nam,mapForm,e) == 286 dc := GENSYM() 287 sigFunAlist:= 288 [['_=,[['Boolean],nam ,nam],['ELT,dc,6]], 289 ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 9]], 290 ['coerce, [$OutputForm, nam], ['ELT, dc, 7]]] 291 [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] 292 293mkRecordFunList(nam,['Record,:Alist],e) == 294 len:= #Alist 295 296-- for (.,a,.) in Alist do 297-- if getmode(a,e) then MOAN("Symbol: ",a, 298-- " must not be both a variable and literal") 299-- e:= put(a,"isLiteral","true",e) 300 dc := GENSYM() 301 sigFunAlist:= 302 --:((a,(A,nam),('XLAM,("$1","$2"),('RECORDELT,"$1",i,len))) 303 -- for i in 0..,(.,a,A) in Alist), 304 305 [['construct,[nam,:[A for [.,a,A] in Alist]],'mkRecord], 306 ['_=, [['Boolean], nam, nam], ['ELT, dc, 6]], 307 ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 10]], 308 ['coerce, [$OutputForm, nam], ['ELT, dc, 7]],: 309 [['elt,[A,nam,PNAME a],['XLAM,["$1","$2"],['RECORDELT,"$1",i,len]]] 310 for i in 0.. for [.,a,A] in Alist],: 311 [["setelt!", [A, nam, PNAME a, A], ['XLAM, ["$1", "$2", "$3"], 312 ['SETRECORDELT,"$1",i, len,"$3"]]] 313 for i in 0.. for [.,a,A] in Alist],: 314 [['copy,[nam,nam],['XLAM,["$1"],['RECORDCOPY, 315 "$1",len]]]]] 316 [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] 317 318mkNewUnionFunList(name,form is ['Union,:listOfEntries],e) == 319 dc := name 320 if name = 'Rep then name := '$ 321 --2. create coercions from subtypes to subUnion 322 cList:= 323 [['_=,[['Boolean],name ,name],['ELT,dc,6]], 324 ['_~_=, [['Boolean], name, name], ['ELT, dc, 9]], 325 ['coerce, [$OutputForm, name], ['ELT, dc, 7]],: 326 ("append"/ 327 [[['construct,[name,type],['XLAM,["#1"],['CONS,i,"#1"]]], 328 ['elt,[type,name,tag],cdownFun], 329 ["case", ['(Boolean), name, tag], 330 ['XLAM,["#1"],['QEQCAR,"#1",i]]]] 331 for [.,tag,type] in listOfEntries for i in 0..])] where 332 cdownFun() == 333 gg:=GENSYM() 334 $InteractiveMode => 335 ['XLAM,["#1"],['PROG1,['QCDR,"#1"], 336 ['check_union2, ['QEQCAR, "#1", i], type, form, "#1"]]] 337 ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],['QCDR,gg], 338 ['check_union2, ['QEQCAR, gg, i], type, form, gg]]] 339 [cList,e] 340 341mkEnumerationFunList(nam,['Enumeration,:SL],e) == 342 len:= #SL 343 dc := nam 344 cList := 345 [nil, 346 ['_=,[['Boolean],nam ,nam],['ELT,dc,6]], 347 ['_~_=, [['Boolean], nam, nam], ['ELT, dc, 9]], 348 ['_^_=,[['Boolean],nam ,nam],['ELT,dc,7]], 349 ['coerce,[nam, ['Symbol]], ['ELT, dc, 8]], 350 ['coerce,[['OutputForm],nam],['ELT,dc, 9]]] 351 [substitute(nam, dc, cList),e] 352 353mkUnionFunList(op,form is ['Union,:listOfEntries],e) == 354 first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) 355 --1. create representations of subtypes 356 predList:= mkPredList listOfEntries 357 g:=GENSYM() 358 --2. create coercions from subtypes to subUnion 359 cList:= 360 [['_=,[['Boolean],g ,g],['ELT,op,6]], 361 ['_~_=, [['Boolean], g, g], ['ELT,op,9]], 362 ['coerce, [$OutputForm, g], ['ELT, op, 7]],: 363 ("append"/ 364 [[['autoCoerce,[g,t],upFun], 365 ['coerce,[t,g],cdownFun], 366 ['autoCoerce,[t,g],downFun], --this should be removed eventually 367 ["case", ['(Boolean), g, t], typeFun]] 368 for p in predList for t in listOfEntries])] where 369 upFun() == 370 p is ['EQCAR,x,n] => ['XLAM,["#1"],['CONS,n,"#1"]] 371 ['XLAM,["#1"],"#1"] 372 cdownFun() == 373 gg:=GENSYM() 374 if p is ['EQCAR,x,n] then 375 ref:=['QCDR,gg] 376 q:= ['QEQCAR, gg, n] 377 else 378 ref:=gg 379 q:= substitute(gg,"#1",p) 380 ['XLAM,["#1"],['PROG2,['LET,gg,"#1"],ref, 381 ['check_union2, q, t, form, gg]]] 382 downFun() == 383 p is ['EQCAR,x,.] => 384 ['XLAM,["#1"],['QCDR,"#1"]] 385 ['XLAM,["#1"],"#1"] 386 typeFun() == 387 p is ['EQCAR,x,n] => 388 ['XLAM,["#1"],['QEQCAR,x,n]] 389 ['XLAM,["#1"],p] 390 op:= 391 op='Rep => '$ 392 op 393 cList:= substitute(op,g,cList) 394 [cList,e] 395