diff options
40 files changed, 970 insertions, 737 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 0a1c821a..9f368b0c 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,46 @@ +2008-04-13 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/apply.boot: Tidy signature declarations. + * interp/as.boot: Use getConstructorKindFromDB throughout. + * interp/br-con.boot: Likewise. + * interp/br-data.boot: Likewise. + * interp/br-op1.boot: Likewise. + * interp/br-op2.boot: Likewise. + * interp/br-prof.boot: Likewise. + * interp/br-saturn.boot: Likewise. + * interp/br-search.boot: Likewise. + * interp/br-util.boot: Likewise. + * interp/cattable.boot: Likewise. + * interp/clam.boot: Likewise. + * interp/clammed.boot: Likewise. + * interp/compiler.boot: Tidy signature declarations. + * interp/construct.lisp: Use getConstructorKindFromDB throughout. + * interp/daase.lisp: Likewise. + * interp/database.boot (getConstructorAbbreviationFromDB): New. + (getConstructorCategoryFromDB): Likewise. + (getConsructorKindFromDB): Likewise. + (getConstructorAncestorsFromDB): Likewise. + (getConstructorSourceFileFromDB): Likewise. + * interp/define.boot: Use getConstructorKindFromDB throughout. + * interp/domain.lisp: Likewise. + * interp/format.boot: Likewise. + * interp/g-cndata.boot: Likewise. + * interp/g-util.boot: Likewise. + * interp/i-eval.boot: Likewise. + * interp/i-funsel.boot: Likewise. + * interp/i-resolv.boot: Likewise. + * interp/i-syscmd.boot: Likewise. + * interp/interop.boot: Likewise. + * interp/lisplib.boot: Likewise. + * interp/nrunfast.boot: Likewise. + * interp/parse.boot: Likewise. + * interp/setvars.boot: Likewise. + * interp/sys-constant.boot ($EmptyVector): Fix thinko + * interp/types.boot (%Maybe): New. + (%ConstructorKind): Likewise. + * input/exsum.input.pamphlet: Fix thinko. + * input/mapleok.input.pamphlet: Fix typos. + 2008-04-12 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/ax.boot: Use getConstructorModemap throughout. diff --git a/src/input/exsum.input.pamphlet b/src/input/exsum.input.pamphlet index a1ce9798..a6905af1 100644 --- a/src/input/exsum.input.pamphlet +++ b/src/input/exsum.input.pamphlet @@ -37,7 +37,7 @@ sum(3*k**2/(c**2 + 1) + 12*k/d,k = (3*a)..(4*b)) )clear all [1..15] -reduce(+,[1..15]) +reduce(+,expand [1..15]) -- Input for page ExSumApproximateE )clear all diff --git a/src/input/mapleok.input.pamphlet b/src/input/mapleok.input.pamphlet index 6954d858..bce65f47 100644 --- a/src/input/mapleok.input.pamphlet +++ b/src/input/mapleok.input.pamphlet @@ -518,7 +518,7 @@ in1120a:=integrate((z^2)^(1/2), z= 1..2,"noPole") -- Type: Union(f1: OrderedCompletion Expression Integer,...) ------------------------------------------------------ -in1130a:=integrate(3^log(z), z= -I..I,"noPole") +in1130a:=integrate(3^log(z), z= -%i..%i,"noPole") -- -- -- log(3)log(I) log(3)log(- I) @@ -529,7 +529,7 @@ in1130a:=integrate(3^log(z), z= -I..I,"noPole") -- ------------------------------------------------------ -in1149:=integrate(imag(z)*z^(1/6), z= -I..I) +in1149:=integrate(imag(z)*z^(1/6), z= -%i..%i) -- -- (49) 0 -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -539,7 +539,7 @@ in1149:=integrate(imag(z)*z^(1/6), z= -%i..%i) -- (64) 0 -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in1150a:=integrate(1/z^(1/2), z= -I..I,"noPole") +in1150a:=integrate(1/z^(1/2), z= -%i..%i,"noPole") -- -- +-+ +---+ -- (51) 2\|I - 2\|- I @@ -551,7 +551,7 @@ in1150c:=integrate(1/z^(1/2), z= -%i..%i,"noPole") -- (66) 2\|%i - 2\|- %i -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in1161:=integrate(hermiteH(1, z), z= -I..I) +in1161:=integrate(hermiteH(1, z), z= -%i..%i) -- -- (76) 0 -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -569,7 +569,7 @@ in1160:=integrate(HermiteH(2, z), z= -%i..%i) -- 3 -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in1162:=integrate(laguerreL(1, z), z= -I..I) +in1162:=integrate(laguerreL(1, z), z= -%i..%i) -- -- (78) 2I -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -579,7 +579,7 @@ in1162:=integrate(laguerreL(1, z), z= -%i..%i) -- (79) 2%i -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in1163:=integrate(legendreP(3, z), z= -I..I) +in1163:=integrate(legendreP(3, z), z= -%i..%i) -- -- (80) 0 -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -590,7 +590,7 @@ in1163:=integrate(legendreP(3, z), z= -%i..%i) -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in1164:=integrate(legendreP(2, z), z= -I..I) +in1164:=integrate(legendreP(2, z), z= -%i..%i) -- -- 3 -- (82) I - I @@ -842,7 +842,7 @@ in1180:=integrate(z^(1/3)/(z^2+1), z= 0..100000000000000000000000000000000000000 -- 24 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in1183a:=integrate(csc(z), z= 1-I..1+I,"noPole") +in1183a:=integrate(csc(z), z= 1-%i..1+%i,"noPole") -- -- 2 2 -- sin(I + 1) sin(I - 1) @@ -2468,7 +2468,7 @@ in128a:=integrate(atan(sqrt(1-cos(z)^2)/(1+cos(z))), z= 0..1,"noPole") -- 4 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in134:=integrate(log(exp(z)), z= -I..I) +in134:=integrate(log(exp(z)), z= -%i..%i) -- -- 0 -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -2844,7 +2844,7 @@ in144:=integrate(1, z= I*infinity..%plusInfinity) -- + infinity -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in146a:=integrate(csc(z), z= 1-I..1+I,"noPole") +in146a:=integrate(csc(z), z= 1-%i..1+%i,"noPole") -- -- 2 2 -- sin(I + 1) sin(I - 1) @@ -2868,7 +2868,7 @@ in156a:=integrate(z^(2/3), z= 1..10,"noPole") -- 5 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in159a:=integrate(log(z)/z^2, z= -I..-1,"noPole") +in159a:=integrate(log(z)/z^2, z= -%i..-1,"noPole") -- -- 2 -- - log(I ) + 2I - 2 @@ -3269,7 +3269,7 @@ in1796a:=integrate((1+(1-z)^(1/2))^(1/2), z= 0..1,"noPole") -- 15 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in183:=integrate(1/z, z= I..2*I) +in183:=integrate(1/z, z= %i..2*%i) -- -- 2 2 -- log(4I ) - log(I ) @@ -3278,7 +3278,7 @@ in183:=integrate(1/z, z= I..2*I) -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in184:=integrate(exp(I*z), z= I..2*I) +in184:=integrate(exp(I*z), z= %i..2*%i) -- -- 2 2 -- 2I I @@ -3296,7 +3296,7 @@ in184a:=integrate(exp(%i*z), z= %i..2*%i) -- %e %e -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in187a:=integrate(2^log(z), z= -I..I,"noPole") +in187a:=integrate(2^log(z), z= -%i..%i,"noPole") -- -- log(2)log(I) log(2)log(- I) -- I %e + I %e @@ -4441,7 +4441,7 @@ in2124a:=integrate(-1/z-1/(I/(z+I))^(1/2), z= -1..0,"noPole") -- + infinity -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in25:=integrate(cos(z), z= I..a) +in25:=integrate(cos(z), z= %i..a) -- -- sin(a) - sin(I) -- Type: Union(f1: OrderedCompletion Expression Integer,...) @@ -4451,7 +4451,7 @@ in25a:=integrate(cos(z), z= %i..a) -- sin(a) - sin(%i) -- Type: Union(f1: OrderedCompletion Expression Complex Integer,...) -in25b:=integrate(exp(I*z), z= I..I*infinity) +in25b:=integrate(exp(I*z), z= %i..%i*infinity) -- -- 2 2 -- I infinity I @@ -5399,7 +5399,7 @@ in271a:=integrate(1/sqrt((z^2-1)*(z^2-1)), z= 2..%plusInfinity,"noPole") -- 4 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in275c:=integrate(sqrt(z), z= -I..I,"noPole") +in275c:=integrate(sqrt(z), z= -%i..%i,"noPole") -- -- +-+ +---+ -- 2I\|I + 2I\|- I @@ -5407,7 +5407,7 @@ in275c:=integrate(sqrt(z), z= -I..I,"noPole") -- 3 -- Type: Union(f1: OrderedCompletion Expression Integer,...) -in275a:=integrate(1/(1+z), z= -I..I,"noPole") +in275a:=integrate(1/(1+z), z= -%i..%i,"noPole") -- -- 2 2 -- log(I + 2I + 1) - log(I - 2I + 1) diff --git a/src/interp/apply.boot b/src/interp/apply.boot index 03186e75..386a7a6f 100644 --- a/src/interp/apply.boot +++ b/src/interp/apply.boot @@ -1,4 +1,4 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2008, Gabriel Dos Reis. -- All rights reserved. @@ -15,7 +15,7 @@ -- the documentation and/or other materials provided with the -- distribution. -- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- - Neither the name of The Numerical Algorithms Group Ltd. nor the -- names of its contributors may be used to endorse or promote products -- derived from this software without specific prior written permission. -- @@ -35,7 +35,7 @@ import '"compiler" )package "BOOT" -compAtomWithModemap: (%Form,%Mode,%Env,%Thing) -> %Triple +compAtomWithModemap: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple compAtomWithModemap(x,m,e,v) == Tl := [[transImplementation(x,map,fn),target,e] @@ -52,7 +52,7 @@ transImplementation(op,map,fn) == fn is ["XLAM",:.] => [fn] ["call",fn] -compApply: (%List,%List,%Thing,%List,%Mode,%Env) -> %Triple +compApply: (%List,%List,%Thing,%List,%Mode,%Env) -> %Maybe %Triple compApply(sig,varl,body,argl,m,e) == argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl] contour:= @@ -63,14 +63,14 @@ compApply(sig,varl,body,argl,m,e) == body':= (comp(body,m',addContour(contour,e))).expr [code,m',e] -compToApply: (%Form,%List,%Mode,%Env) -> %Triple +compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple compToApply(op,argl,m,e) == T:= compNoStacking(op,$EmptyMode,e) or return nil m1:= T.mode T.expr is ["QUOTE", =m1] => nil compApplication(op,argl,m,T.env,T) -compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Triple +compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple compApplication(op,argl,m,e,T) == T.mode is ['Mapping, retm, :argml] => #argl ^= #argml => nil @@ -92,7 +92,7 @@ compApplication(op,argl,m,e,T) == eltForm := ['elt, op, :argl] comp(eltForm, m, e) -compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Triple +compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple compFormWithModemap(form is [op,:argl],m,e,modemap) == [map:= [.,target,:.],[pred,impl]]:= modemap -- this fails if the subsuming modemap is conditional @@ -156,7 +156,7 @@ compFormWithModemap(form is [op,:argl],m,e,modemap) == -- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] -- convert([form,SUBLIS(pairlis,first ml),e],m) -applyMapping: (%Form,%Mode,%Env,%List) -> %Triple +applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple applyMapping([op,:argl],m,e,ml) == #argl^=#ml-1 => nil isCategoryForm(first ml,e) => @@ -186,7 +186,7 @@ applyMapping([op,:argl],m,e,ml) == --% APPLY MODEMAPS -compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Triple +compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple compApplyModemap(form,modemap,$e,sl) == [op,:argl] := form --form to be compiled [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing diff --git a/src/interp/as.boot b/src/interp/as.boot index 93286283..8ed116d9 100644 --- a/src/interp/as.boot +++ b/src/interp/as.boot @@ -297,7 +297,7 @@ asGetModemaps(opAlist,oform,kind,modemap) == NREVERSE acc asIsCategoryForm m == - m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category + m = "BasicType" or getConstructorKindFromDB opOf m = "category" asyDocumentation con == docHash := HGET($docHash,con) @@ -454,8 +454,8 @@ asytranDeclaration(dform,levels,predlist,local?) == asyLooksLikeCatForm? form => 'category form is ['Apply, '_-_>,.,u] => if u is ['Apply, construc,:.] then u:= construc - GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function - asyLooksLikeCatForm? u => 'category + getConstructorKindFromDB opOf u = "domain" => "function" + asyLooksLikeCatForm? u => "category" 'domain 'domain first levels diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index 6300c40d..927e8256 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -683,7 +683,7 @@ dbMkEvalable form == --like mkEvalable except that it does NOT quote domains --does not do "loadIfNecessary" [op,:.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB op kind = 'category => form mkEvalable form @@ -865,7 +865,7 @@ dbDocTable conform == originsInOrder conform == --domain = nil or set to live domain --from dcCats [con,:argl] := conform - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB con = "category" => ASSOCLEFT ancestorsOf(conform,nil) acc := ASSOCLEFT parentsOf con for x in acc repeat @@ -1130,7 +1130,7 @@ dbShowConsDoc1(htPage,conform,indexOrNil) == doc := [getConstructorDocumentation conname] signature := getConstructorSignature conname sig := - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB conname = "category" => SUBLISLIS(conargs,$TriangleVariableList,signature) sublisFormal(conargs,signature) htSaySaturn '"\begin{description}" diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot index e60107c6..06b24ba7 100644 --- a/src/interp/br-data.boot +++ b/src/interp/br-data.boot @@ -107,7 +107,7 @@ buildLibdbConEntry conname == $exposed? := (isExposedConstructor conname => '"x"; '"n") $doc := GETDATABASE(conname, 'DOCUMENTATION) pname := PNAME conname - kind := GETDATABASE(conname,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB conname if kind = 'domain and getConstructorModemap conname is [[.,t,:.],:.] and t is ['CATEGORY,'package,:.] then kind := 'package @@ -529,7 +529,7 @@ getParentsForDomain domname == --called by parentsOf acc := nil for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat x := - GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB domname = "category" => sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) sublisFormal(IFCDR getConstructorForm domname,x) acc := [:explodeIfs x,:acc] @@ -562,7 +562,7 @@ folks u == --called by getParents and getParentsForDomain [u] descendantsOf(conform,domform) == --called by kcdPage - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => + "category" = getConstructorKindFromDB(conname := opOf conform) => cats := catsOf(conform,domform) [op,:argl] := conform null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) @@ -602,8 +602,8 @@ childArgCheck(argl, nargl) == -- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - alist := GETDATABASE(conname,'ANCESTORS) + "category" = getConstructorKindFromDB(conname := opOf conform) => + alist := getConstructorAncestorsFromDB conname argl := IFCDR domform or IFCDR conform [pair for [a,:b] in alist | pair] where pair() == left := sublisFormal(argl,a) @@ -667,7 +667,7 @@ catsOf(conform,domname,:options) == conname := opOf conform alist := nil for key in allConstructors() repeat - for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat + for item in getConstructorAncestorsFromDB key | conname = CAAR item repeat [[op,:args],:pred] := item newItem := args => [[args,:pred],:LASSOC(key,alist)] diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot index 605f8fa3..8ffd824a 100644 --- a/src/interp/br-op1.boot +++ b/src/interp/br-op1.boot @@ -56,7 +56,7 @@ dbPresentOps(htPage,which,:exclusions) == asharp? := htpProperty(htPage,'isAsharpConstructor) fromConPage? := (conname := opOf htpProperty(htPage,'conform)) usage? := $UserLevel = 'development and fromConPage? and which = '"operation" - and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + and getConstructorKindFromDB conname ^= "category" and not asharp? star? := not fromConPage? or which = '"package operation" implementation? := not asharp? and @@ -114,7 +114,7 @@ dbPresentOps(htPage,which,:exclusions) == -- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] htTab tabs.0 if usage? then - if empty? or member('usage,exclusions) or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category or HGET($defaultPackageNamesHT,conname) or htpProperty(htPage,'noUsage) + if empty? or member('usage,exclusions) or getConstructorKindFromDB conname = "category" or HGET($defaultPackageNamesHT,conname) or htpProperty(htPage,'noUsage) then htSay '"{\em usage}" else htMakePage [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] htTab tabs.1 @@ -124,7 +124,7 @@ dbPresentOps(htPage,which,:exclusions) == htTab tabs.2 if implementation? then if member('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + ((conname := opOf htpProperty(htPage,'conform)) and getConstructorKindFromDB conname = "category") then htSay '"{\em implementation}" else htMakePage [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] else if empty? or member('conditions,exclusions) or (htpProperty(htPage,'condition?) = 'no) @@ -629,7 +629,7 @@ dbShowOpAllDomains(htPage,opAlist,which) == for [op,:items] in opAlist repeat for [.,predicate,origin,:.] in items repeat conname := CAR origin - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB conname = "category" => pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) catOriginAlist := insertAlist(conname,pred,catOriginAlist) pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) @@ -698,8 +698,8 @@ dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == dbShowKind conform == conname := CAR conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - kind = 'domain => + kind := getConstructorKindFromDB conname + kind = "domain" => (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" '"domain" PNAME kind diff --git a/src/interp/br-op2.boot b/src/interp/br-op2.boot index d8a4a151..02832a49 100644 --- a/src/interp/br-op2.boot +++ b/src/interp/br-op2.boot @@ -90,7 +90,7 @@ displayDomainOp(htPage,which,origin,op,sig,predicate, constring := form2HtString conform conname := first conform $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) + or STRINGIMAGE getConstructorKindFromDB conname $conlength : local := #constring $conform : local := conform $conargs : local := rest conform @@ -195,8 +195,8 @@ htSayConstructor(key,u) == bcConform(u,true) htSay key = 'is => '"the domain " - kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) - kind = 'domain => '"an element of " + kind := getConstructorKindFromDB opOf u + kind = "domain" => '"an element of " '"a domain of " u is ['Join,:middle,r] => rest middle => @@ -319,7 +319,7 @@ dbChooseOperandName(typ) == name := opOf typ kind := name = "$" => 'domain - GETDATABASE(name,'CONSTRUCTORKIND) + getConstructorKindFromDB name s := PNAME opOf typ kind ^= 'category => anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => @@ -490,7 +490,7 @@ whoUsesMatch1?(signumList,sig,al) == koAttrs(conform,domname) == [conname,:args] := conform --asharpConstructorName? conname => nil --assumed - 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => + "category" = getConstructorKindFromDB conname => koCatAttrs(conform,domname) $infovec: local := dbInfovec conname or return nil $predvec: local := @@ -534,7 +534,7 @@ koOps(conform,domname,:options) == main where subargs: local := args ----------> new <------------------ u := koCatOps(conform,domname) => u --- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => +-- "category" = getConstructorKindFromDB conname => -- koCatOps(conform,domname) asharpConstructorName? opOf conform => nil ----------> new <------------------ diff --git a/src/interp/br-prof.boot b/src/interp/br-prof.boot index 876348b3..bbb36293 100644 --- a/src/interp/br-prof.boot +++ b/src/interp/br-prof.boot @@ -75,7 +75,7 @@ dbShowInfoOp(htPage,op,sig,alist) == conform := htpProperty(htPage,'conform) opAlist := htpProperty(htPage,'opAlist) conname := opOf conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB conname honestConform := kind = 'category => [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform] @@ -213,7 +213,7 @@ dbInfoChoose1(htPage,con,alist) == opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)] page := htInitPage(nil,nil) htpSetProperty(page,'conform,con) - htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND)) + htpSetProperty(page,'kind,PNAME getConstructorKindFromDB opOf con) dbShowOperationsFromConform(page,'"operation",opAlist) dbInfoSigMatch(x,alist) == @@ -251,7 +251,7 @@ hasNewInfoText u == null sig or null atom sig and null atom alist for item in items] for [op,:items] in u] getInfoAlist conname == - cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category + cat? := getConstructorKindFromDB conname = "category" if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&") abb := constructor? conname or return '"not a constructor" fs := STRCONC(PNAME abb,'".NRLIB/info") diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index fe38e3cb..bfa95d0d 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -1089,7 +1089,7 @@ dbPresentOps(htPage,which,:exclusions) == htSay '"}{" if not implementation? or member('implementation,exclusions) or which = '"attribute" or ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + and getConstructorKindFromDB conname = "category") then htSay '"{\em Implementations}" else htMakePage [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] @@ -1150,7 +1150,7 @@ dbPresentOpsSaturn(htPage,which,exclusions) == else htMakeSaturnFilterPage ['dbShowOps, which, 'filter] if not implementation? or member('implementation,exclusions) or which = '"attribute" or ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + and getConstructorKindFromDB conname = "category") then htSayCold '"\&Implementations" else htMakePage [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]] @@ -1254,7 +1254,7 @@ displayDomainOp(htPage,which,origin,op,sig,predicate, constring := form2HtString conform conname := first conform $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) + or STRINGIMAGE getConstructorKindFromDB conname $conlength : local := #constring $conform : local := conform $conargs : local := rest conform diff --git a/src/interp/br-search.boot b/src/interp/br-search.boot index 8cc82604..3c7089d3 100644 --- a/src/interp/br-search.boot +++ b/src/interp/br-search.boot @@ -328,7 +328,7 @@ oPage(a,:b) == --called by \spadfun{opname} oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} htPage := htInitPage(nil,nil) --create empty page and fill in needed properties htpSetProperty(htPage,'conform,conform := getConstructorForm conname) - htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) + htpSetProperty(htPage,'kind,STRINGIMAGE getConstructorKindFromDB conname) itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" null itemlist => systemError [conform,'" has no operation named ",opname] opAlist := [itemlist] diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot index 12556dd0..cc28cb4d 100644 --- a/src/interp/br-util.boot +++ b/src/interp/br-util.boot @@ -583,7 +583,7 @@ nothingFoundPage(:options) == htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] dbInfovec name == - 'category = GETDATABASE(name,'CONSTRUCTORKIND) => nil + "category" = getConstructorKindFromDB name => nil GETDATABASE(name, 'ASHARP?) => nil loadLibIfNotLoaded(name) u := GETL(name,'infovec) => u diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot index 68c57dab..b9c95bcb 100644 --- a/src/interp/cattable.boot +++ b/src/interp/cattable.boot @@ -59,7 +59,7 @@ genCategoryTable() == genTempCategoryTable() domainList:= [con for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] + | getConstructorKindFromDB con = "domain"] domainTable:= [addDomainToTable(con,getConstrCat catl) for con in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT @@ -76,7 +76,7 @@ genCategoryTable() == simpTempCategoryTable() == for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat + for (u:=[a,:b]) in getConstructorAncestorsFromDB id repeat RPLACA(u,SUBST('Type,'Object,a)) RPLACD(u,simpHasPred b) @@ -144,7 +144,7 @@ simpHasSignature(pred,conform,op,sig) == --eval w/o loading simpHasAttribute(pred,conform,attr) == --eval w/o loading IDENTP conform => pred conname := opOf conform - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB conname = "category" => simpCatHasAttribute(conform,attr) asharpConstructorName? conname => p := LASSOC(attr,GETDATABASE(conname,'attributes)) => @@ -195,7 +195,7 @@ genTempCategoryTable() == -- "IF pred THEN ofCategory(key,form)" -- where form can involve #1, #2, ... the parameters of key for con in allConstructors() repeat - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB con = "category" => addToCategoryTable con for id in HKEYS _*ANCESTORS_-HASH_* repeat item := HGET(_*ANCESTORS_-HASH_*, id) @@ -260,14 +260,14 @@ simpCategoryOr(new,l) == ['OR,:newList] tempExtendsCat(b,c) == - or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] + or/[first c = a for [[a,:.],:.] in getConstructorAncestorsFromDB first b] getCategoryExtensionAlist0 cform == [[cform,:'T],:getCategoryExtensionAlist cform] getCategoryExtensionAlist cform == --avoids substitution as much as possible - u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) + u:= getConstructorAncestorsFromDB first cform => formalSubstitute(cform,u) mkCategoryExtensionAlist cform formalSubstitute(form:=[.,:argl],u) == @@ -339,7 +339,7 @@ mergeOr(x,y) == nil testExtend(a:=[op,:argl],b) == - (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => + (u:= getConstructorAncestorsFromDB op) and (val:= LASSOC(b,u)) => formalSubstitute(a,val) nil @@ -382,7 +382,7 @@ categoryParts(conform,category,:options) == main where $oplist := listSort(function GLESSEQP,$oplist) res := [$attrlist,:$oplist] if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then + if getConstructorKindFromDB conname = "category" then tvl := TAKE(#rest conform,$TriangleVariableList) res := SUBLISLIS($FormalMapVariableList,tvl,res) res @@ -469,7 +469,7 @@ updateCategoryTableForCategory(cname) == clearTempCategoryTable([[cname,'category]]) addToCategoryTable(cname) for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat + for (u:=[.,:b]) in getConstructorAncestorsFromDB id repeat RPLACD(u,simpCatPredicate simpBool b) updateCategoryTableForDomain(cname,category) == @@ -491,7 +491,7 @@ clearTempCategoryTable(catNames) == for key in HKEYS(_*ANCESTORS_-HASH_*) repeat MEMQ(key,catNames) => nil extensions:= nil - for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) + for (extension:= [catForm,:.]) in getConstructorAncestorsFromDB key repeat MEMQ(CAR catForm,catNames) => nil extensions:= [extension,:extensions] diff --git a/src/interp/clam.boot b/src/interp/clam.boot index ff119529..e9f4a787 100644 --- a/src/interp/clam.boot +++ b/src/interp/clam.boot @@ -344,8 +344,8 @@ clearConstructorCaches() == CLRHASH $ConstructorCache clearConstructorCache(cname) == - (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => - kind = 'category => clearCategoryCache cname + (kind := getConstructorKindFromDB cname) => + kind = "category" => clearCategoryCache cname HREM($ConstructorCache,cname) clearConstructorAndLisplibCaches() == @@ -354,7 +354,7 @@ clearConstructorAndLisplibCaches() == clearCategoryCaches() == for name in allConstructors() repeat - if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then + if getConstructorKindFromDB name = "category" then if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL")) then setDynamicBinding(cacheName,nil) if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT")) diff --git a/src/interp/clammed.boot b/src/interp/clammed.boot index 6f874dbe..14c98e85 100644 --- a/src/interp/clammed.boot +++ b/src/interp/clammed.boot @@ -120,7 +120,11 @@ isValidType form == and/[isValid for x in argl for c in cl] where isValid() == categoryForm?(c) => evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x - GETDATABASE(opOf x,'CONSTRUCTORKIND) ^= 'domain + -- Arguments to constructors are general expressions. Below + -- domain constructors are not considered valid arguments (yet). + x' := opOf x + not atom x' or not IDENTP x' => true -- surely not constructors + getConstructorKindFromDB x' ^= "domain" selectMms1(op,tar,args1,args2,$Coerce) == -- for new compiler/old world compatibility, sometimes have to look diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index d3313980..2e880a24 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -48,7 +48,7 @@ $coreDiagnosticFunctions == ++ list of functions to compile $compileOnlyCertainItems := [] -compTopLevel: (%Form,%Mode,%Env) -> %Triple +compTopLevel: (%Form,%Mode,%Env) -> %Maybe %Triple compTopLevel(x,m,e) == --+ signals that target is derived from lhs-- see NRTmakeSlot1Info $NRTderivedTargetIfTrue: local := false @@ -62,15 +62,15 @@ compTopLevel(x,m,e) == --keep old environment after top level function defs compOrCroak(x,m,e) -compUniquely: (%Form,%Mode,%Env) -> %Triple +compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple compUniquely(x,m,e) == $compUniquelyIfTrue: local:= true CATCH("compUniquely",comp(x,m,e)) -compOrCroak: (%Form,%Mode,%Env) -> %Triple +compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple compOrCroak(x,m,e) == compOrCroak1(x,m,e,'comp) -compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Triple +compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple compOrCroak1(x,m,e,compFn) == fn(x,m,e,nil,nil,compFn) where fn(x,m,e,$compStack,$compErrorMessageStack,compFn) == @@ -100,13 +100,13 @@ tc() == comp($x,$m,$f) -comp: (%Form,%Mode,%Env) -> %Triple +comp: (%Form,%Mode,%Env) -> %Maybe %Triple comp(x,m,e) == T:= compNoStacking(x,m,e) => ($compStack:= nil; T) $compStack:= [[x,m,e,$exitModeStack],:$compStack] nil -compNoStacking: (%Form,%Mode,%Env) -> %Triple +compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple compNoStacking(x,m,e) == T:= comp2(x,m,e) => $useRepresentationHack and m=$EmptyMode and T.mode=$Representation => @@ -119,13 +119,13 @@ compNoStacking(x,m,e) == --hack only when `Rep' is defined the old way. -- gdr 2008/01/26 compNoStacking1(x,m,e,$compStack) -compNoStacking1: (%Form,%Mode,%Env,%List) -> %Triple +compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple compNoStacking1(x,m,e,$compStack) == u:= get(RepIfRepHack m,"value",e) => (T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil) nil -comp2: (%Form,%Mode,%Env) -> %Triple +comp2: (%Form,%Mode,%Env) -> %Maybe %Triple comp2(x,m,e) == [y,m',e]:= comp3(x,m,e) or return nil if $LISPLIB and isDomainForm(x,e) then @@ -138,7 +138,7 @@ comp2(x,m,e) == --$bootStrapMode-test necessary for compiling Ring in $bootStrapMode [y,m',e] -comp3: (%Form,%Mode,%Env) -> %Triple +comp3: (%Form,%Mode,%Env) -> %Maybe %Triple comp3(x,m,$e) == --returns a Triple or %else nil to signalcan't do' $e:= addDomain(m,$e) @@ -163,7 +163,7 @@ comp3(x,m,$e) == [x',m',addDomain(m',e')] t -compTypeOf: (%Form,%Mode,%Env) -> %Triple +compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple compTypeOf(x:=[op,:argl],m,e) == $insideCompTypeOf: local := true newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e)) @@ -280,14 +280,14 @@ extractCodeAndConstructTriple(u, m, oldE) == [op,:.,env] := u [["CONS",["function",op],env],m,oldE] -compExpression: (%Form,%Mode,%Env) -> %Triple +compExpression: (%Form,%Mode,%Env) -> %Maybe %Triple compExpression(x,m,e) == $insideExpressionIfTrue: local:= true atom first x and (fn:= GETL(first x,"SPECIAL")) => FUNCALL(fn,x,m,e) compForm(x,m,e) -compAtom: (%Form,%Mode,%Env) -> %Triple +compAtom: (%Form,%Mode,%Env) -> %Maybe %Triple compAtom(x,m,e) == T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T x="nil" => @@ -314,7 +314,7 @@ primitiveType x == FLOATP x => $DoubleFloat nil -compSymbol: (%Form,%Mode,%Env) -> %Triple +compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple compSymbol(s,m,e) == s="$NoValue" => ["$NoValue",$NoValueMode,e] isFluid s => [s,getmode(s,e) or return nil,e] @@ -346,13 +346,13 @@ hasUniqueCaseView(x,m,e) == p = "value" => return false -convertOrCroak: (%Triple,%Mode) -> %Triple +convertOrCroak: (%Maybe %Triple,%Mode) -> %Maybe %Triple convertOrCroak(T,m) == u:= convert(T,m) => u userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l", " TO MODE: ",m,"%l"] -convert: (%Triple,%Mode) -> %Triple +convert: (%Maybe %Triple,%Mode) -> %Maybe %Triple convert(T,m) == coerce(T,resolve(T.mode,m) or return nil) @@ -377,12 +377,12 @@ hasType(x,e) == --% General Forms -compForm: (%Form,%Mode,%Env) -> %Triple -compForm1: (%Form,%Mode,%Env) -> %Triple -compForm2: (%Form,%Mode,%Env,%List) -> %Triple -compForm3: (%Form,%Mode,%Env,%List) -> %Triple -compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Triple -compExpressionList: (%List,%Mode,%Env) -> %Triple +compForm: (%Form,%Mode,%Env) -> %Maybe %Triple +compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple +compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple +compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple +compExpressionList: (%List,%Mode,%Env) -> %Maybe %Triple compForm(form,m,e) == T:= @@ -591,12 +591,12 @@ substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) == compConstructorCategory(x,m,e) == [x,resolve($Category,m),e] -compString: (%Form,%Mode,%Env) -> %Triple +compString: (%Form,%Mode,%Env) -> %Maybe %Triple compString(x,m,e) == [x,resolve($StringCategory,m),e] --% SUBSET CATEGORY -compSubsetCategory: (%Form,%Mode,%Env) -> %Triple +compSubsetCategory: (%Form,%Mode,%Env) -> %Maybe %Triple compSubsetCategory(["SubsetCategory",cat,R],m,e) == --1. put "Subsets" property on R to allow directly coercion to subset; -- allow automatic coercion from subset to R but not vice versa @@ -611,8 +611,8 @@ compSubsetCategory(["SubsetCategory",cat,R],m,e) == --% CONS -compCons: (%Form,%Mode,%Env) -> %Triple -compCons1: (%Form,%Mode,%Env) -> %Triple +compCons: (%Form,%Mode,%Env) -> %Maybe %Triple +compCons1: (%Form,%Mode,%Env) -> %Maybe %Triple compCons(form,m,e) == compCons1(form,m,e) or compForm(form,m,e) @@ -647,7 +647,7 @@ compSetq1(form,val,m,E) == op="Tuple" => setqMultiple(l,val,m,E) setqSetelt(form,val,m,E) -compMakeDeclaration: (%Form,%Mode,%Env) -> %Triple +compMakeDeclaration: (%Form,%Mode,%Env) -> %Maybe %Triple compMakeDeclaration(x,m,e) == $insideExpressionIfTrue: local compColon(x,m,e) @@ -771,7 +771,7 @@ compileQuasiquote(["[||]",:form],m,e) == --% WHERE -compWhere: (%Form,%Mode,%Env) -> %Triple +compWhere: (%Form,%Mode,%Env) -> %Maybe %Triple compWhere([.,form,:exprList],m,eInit) == $insideExpressionIfTrue: local:= false $insideWhereIfTrue: local:= true @@ -787,7 +787,7 @@ compWhere([.,form,:exprList],m,eInit) == eInit [x,m,eFinal] -compConstruct: (%Form,%Mode,%Env) -> %Triple +compConstruct: (%Form,%Mode,%Env) -> %Maybe %Triple compConstruct(form is ["construct",:l],m,e) == y:= modeIsAggregateOf("List",m,e) => T:= compList(l,["List",CADR y],e) => convert(T,m) @@ -806,14 +806,14 @@ compConstruct(form is ["construct",:l],m,e) == compQuote(expr,m,e) == [expr,m,e] -compList: (%Form,%Mode,%Env) -> %Triple +compList: (%Form,%Mode,%Env) -> %Maybe %Triple compList(l,m is ["List",mUnder],e) == null l => [NIL,m,e] Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] Tl="failed" => nil T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] -compVector: (%Form,%Mode,%Env) -> %Triple +compVector: (%Form,%Mode,%Env) -> %Maybe %Triple compVector(l,m is ["Vector",mUnder],e) == null l => [$EmptyVector,m,e] Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] @@ -837,8 +837,8 @@ compMacro(form,m,e) == --% SEQ -compSeq: (%Form,%Mode,%Env) -> %Triple -compSeq1: (%Form,%List,%Env) -> %Triple +compSeq: (%Form,%Mode,%Env) -> %Maybe %Triple +compSeq1: (%Form,%List,%Env) -> %Maybe %Triple compSeqItem: (%Thing,%Thing,%List) -> %List compSeq(["SEQ",:l],m,e) == compSeq1(l,[m,:$exitModeStack],e) @@ -884,7 +884,7 @@ replaceExitEtc(x,tag,opFlag,opMode) == replaceExitEtc(rest x,tag,opFlag,opMode) --% SUCHTHAT -compSuchthat: (%Form,%Mode,%Env) -> %Triple +compSuchthat: (%Form,%Mode,%Env) -> %Maybe %Triple compSuchthat([.,x,p],m,e) == [x',m',e]:= comp(x,m,e) or return nil [p',.,e]:= comp(p,$Boolean,e) or return nil @@ -893,7 +893,7 @@ compSuchthat([.,x,p],m,e) == --% exit -compExit: (%Form,%Mode,%Env) -> %Triple +compExit: (%Form,%Mode,%Env) -> %Maybe %Triple compExit(["exit",level,x],m,e) == index:= level-1 $exitModeStack = [] => comp(x,m,e) @@ -911,7 +911,7 @@ modifyModeStack(m,index) == ($exitModeStack.index:= resolve(m,$exitModeStack.index); $exitModeStack)) $exitModeStack.index:= resolve(m,$exitModeStack.index) -compLeave: (%Form,%Mode,%Env) -> %Triple +compLeave: (%Form,%Mode,%Env) -> %Maybe %Triple compLeave(["leave",level,x],m,e) == index:= #$exitModeStack-1-$leaveLevelStack.(level-1) [x',m',e']:= u:= comp(x,$exitModeStack.index,e) or return nil @@ -920,7 +920,7 @@ compLeave(["leave",level,x],m,e) == --% return -compReturn: (%Form,%Mode,%Env) -> %Triple +compReturn: (%Form,%Mode,%Env) -> %Maybe %Triple compReturn(["return",level,x],m,e) == null $exitModeStack => stackSemanticError(["the return before","%b",x,"%d","is unneccessary"],nil) @@ -936,7 +936,7 @@ compReturn(["return",level,x],m,e) == --% ELT -compElt: (%Form,%Mode,%Env) -> %Triple +compElt: (%Form,%Mode,%Env) -> %Maybe %Triple compElt(form,m,E) == form isnt ["elt",aDomain,anOp] => compForm(form,m,E) aDomain="Lisp" => @@ -964,7 +964,7 @@ compElt(form,m,E) == --% HAS -compHas: (%Form,%Mode,%Env) -> %Triple +compHas: (%Form,%Mode,%Env) -> %Maybe %Triple compHas(pred is ["has",a,b],m,$e) == --b is (":",:.) => (.,.,E):= comp(b,$EmptyMode,E) $e:= chaseInferences(pred,$e) @@ -989,9 +989,9 @@ compHasFormat (pred is ["has",olda,b]) == --% IF -compIf: (%Form,%Mode,%Env) -> %Triple +compIf: (%Form,%Mode,%Env) -> %Maybe %Triple compBoolean: (%Form,%Mode,%Env) -> %List -compFromIf: (%Form,%Mode,%Env) -> %Triple +compFromIf: (%Form,%Mode,%Env) -> %Maybe %Triple compIf(["IF",a,b,c],m,E) == [xa,ma,Ea,Einv]:= compBoolean(a,$Boolean,E) or return nil @@ -1108,7 +1108,7 @@ compFromIf(a,m,E) == quotify x == x -compImport: (%Form,%Mode,%Env) -> %Triple +compImport: (%Form,%Mode,%Env) -> %Maybe %Triple compImport(["import",:doms],m,e) == for dom in doms repeat e:=addDomain(dom,e) ["/throwAway",$NoValueMode,e] @@ -1118,7 +1118,7 @@ compImport(["import",:doms],m,e) == --% etc. ++ compile a logical negation form `(not ...)'. -compileNot: (%Form,%Mode,%Env) -> %Triple +compileNot: (%Form,%Mode,%Env) -> %Maybe %Triple compileNot(x,m,e) == x isnt ["not", y] => nil -- If there is a modemap available that can make this work, just use it. @@ -1133,8 +1133,8 @@ compileNot(x,m,e) == --% Case -compCase: (%Form,%Mode,%Env) -> %Triple -compCase1: (%Form,%Mode,%Env) -> %Triple +compCase: (%Form,%Mode,%Env) -> %Maybe %Triple +compCase1: (%Form,%Mode,%Env) -> %Maybe %Triple --Will the jerk who commented out these two functions please NOT do so --again. These functions ARE needed, and case can NOT be done by @@ -1174,7 +1174,7 @@ maybeSpliceMode m == (m' := isQuasiquote m) => m' m -compColon: (%Form,%Mode,%Env) -> %Triple +compColon: (%Form,%Mode,%Env) -> %Maybe %Triple compColon([":",f,t],m,e) == $insideExpressionIfTrue=true => compColonInside(f,m,e,t) --if inside an expression, ":" means to convert to m "on faith" @@ -1212,7 +1212,7 @@ unknownTypeError name == name stackSemanticError(["%b",name,"%d","is not a known type"],nil) -compPretend: (%Form,%Mode,%Env) -> %Triple +compPretend: (%Form,%Mode,%Env) -> %Maybe %Triple compPretend(["pretend",x,t],m,e) == e:= addDomain(t,e) T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil @@ -1232,7 +1232,7 @@ compColonInside(x,m,e,m') == stackWarning [":",m'," -- should replace by pretend"] T' -compIs: (%Form,%Mode,%Env) -> %Triple +compIs: (%Form,%Mode,%Env) -> %Maybe %Triple compIs(["is",a,b],m,e) == [aval,am,e] := comp(a,$EmptyMode,e) or return nil [bval,bm,e] := comp(b,$EmptyMode,e) or return nil @@ -1246,7 +1246,7 @@ compIs(["is",a,b],m,e) == -- One should always call the correct function, since the represent- -- ation of basic objects may not be the same. -coerce: (%Triple,%Mode) -> %Triple +coerce: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerce(T,m) == $InteractiveMode => keyedSystemError("S2GE0016",['"coerce", @@ -1265,7 +1265,7 @@ coerce(T,m) == " to mode","%b",m2,"%d"] -coerceEasy: (%Triple,%Mode) -> %Triple +coerceEasy: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerceEasy(T,m) == m=$EmptyMode => T m=$NoValueMode or m=$Void => [T.expr,m,T.env] @@ -1278,7 +1278,7 @@ coerceEasy(T,m) == [T.expr,m,T.env] -coerceSubset: (%Triple,%Mode) -> %Triple +coerceSubset: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerceSubset([x,m,e],m') == isSubset(m,m',e) => [x,m',e] m is ['SubDomain,=m',:.] => [x,m',e] @@ -1290,7 +1290,7 @@ coerceSubset([x,m,e],m') == [x,m',e] nil -coerceHard: (%Triple,%Mode) -> %Triple +coerceHard: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerceHard(T,m) == $e: local:= T.env m':= T.mode @@ -1309,7 +1309,7 @@ coerceHard(T,m) == [T.expr,m,$e] coerceExtraHard(T,m) -coerceExtraHard: (%Triple,%Mode) -> %Triple +coerceExtraHard: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerceExtraHard(T is [x,m',e],m) == T':= autoCoerceByModemap(T,m) => T' isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and @@ -1337,22 +1337,22 @@ coerceable(m,m',e) == coerce(["$fromCoerceable$",m,e],m') => m' nil -coerceExit: (%Triple,%Mode) -> %Triple +coerceExit: (%Maybe %Triple,%Mode) -> %Maybe %Triple coerceExit([x,m,e],m') == m':= resolve(m,m') x':= replaceExitEtc(x,catchTag:= MKQ GENSYM(),"TAGGEDexit",$exitMode) coerce([["CATCH",catchTag,x'],m,e],m') -compAtSign: (%Form,%Mode,%Env) -> %Triple +compAtSign: (%Form,%Mode,%Env) -> %Maybe %Triple compAtSign(["@",x,m'],m,e) == e:= addDomain(m',e) T:= comp(x,m',e) or return nil coerce(T,m) -compCoerce: (%Form,%Mode,%Env) -> %Triple -compCoerce1: (%Form,%Mode,%Env) -> %Triple -coerceByModemap: (%Triple,%Mode) -> %Triple -autoCoerceByModemap: (%Triple,%Mode) -> %Triple +compCoerce: (%Form,%Mode,%Env) -> %Maybe %Triple +compCoerce1: (%Form,%Mode,%Env) -> %Maybe %Triple +coerceByModemap: (%Maybe %Triple,%Mode) -> %Maybe %Triple +autoCoerceByModemap: (%Maybe %Triple,%Mode) -> %Maybe %Triple compCoerce(["::",x,m'],m,e) == e:= addDomain(m',e) diff --git a/src/interp/construc.lisp b/src/interp/construc.lisp index 3d5aeca0..9d0d252d 100644 --- a/src/interp/construc.lisp +++ b/src/interp/construc.lisp @@ -271,7 +271,7 @@ (let (fullLibName libDir kind) (setq fullLibName (make-input-filename (mergelib libName) |$spadLibFT|)) (setq libDir (directory-namestring fullLibName)) - (setq kind (GETDATABASE cname 'CONSTRUCTORKIND)) + (setq kind (|getConstuctorKindFromDB| cname)) (when |$printLoadMsgs| (|sayKeyedMsg| 'S2IL0002 (list (|namestring| fullLibName) kind cname))) (load (concatenate 'string libDir (mergelib libName))) diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index dd9a7a8b..f01aac3e 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -254,9 +254,11 @@ ; have category y?". this is answered by constructing a pair of ; (x . y) and doing an equal hash into this table. -(defvar *operation-hash* nil "given an operation name, what are its modemaps?") +(defvar *operation-hash* nil + "given an operation name, what are its modemaps?") -(defvar *miss* nil "print out cache misses on getdatabase calls") +(defvar *miss* nil + "if true print out cache misses on getdatabase calls") ; note that constructorcategory information need only be kept for ; items of type category. this will be fixed in the next iteration @@ -277,29 +279,52 @@ ; position information in the database then the database is NOT ; read in and is assumed to match the in-core version -(defvar *compressvector* nil "a vector of things to compress in the databases") -(defvar *compressVectorLength* 0 "length of the compress vector") -(defvar *compress-stream* nil "an stream containing the compress vector") -(defvar *compress-stream-stamp* 0 "*compress-stream* (position . time)") +(defvar *compressvector* nil + "a vector of things to compress in the databases") -(defvar *interp-stream* nil "an open stream to the interpreter database") -(defvar *interp-stream-stamp* 0 "*interp-stream* (position . time)") +(defvar *compressVectorLength* 0 + "length of the compress vector") + +(defvar *compress-stream* nil + "an stream containing the compress vector") + +(defvar *compress-stream-stamp* 0 + "*compress-stream* (position . time)") + +(defvar *interp-stream* nil + "an open stream to the interpreter database") + +(defvar *interp-stream-stamp* 0 + "*interp-stream* (position . time)") ; this is indexed by operation, not constructor -(defvar *operation-stream* nil "the stream to operation.daase") -(defvar *operation-stream-stamp* 0 "*operation-stream* (position . time)") +(defvar *operation-stream* + nil "the stream to operation.daase") + +(defvar *operation-stream-stamp* 0 + "*operation-stream* (position . time)") -(defvar *browse-stream* nil "an open stream to the browser database") -(defvar *browse-stream-stamp* 0 "*browse-stream* (position . time)") +(defvar *browse-stream* nil + "an open stream to the browser database") + +(defvar *browse-stream-stamp* 0 + "*browse-stream* (position . time)") ; this is indexed by (domain . category) -(defvar *category-stream* nil "an open stream to the category table") -(defvar *category-stream-stamp* 0 "*category-stream* (position . time)") +(defvar *category-stream* nil + "an open stream to the category table") + +(defvar *category-stream-stamp* 0 + "*category-stream* (position . time)") + +(defvar *allconstructors* nil + "a list of all the constructors in the system") -(defvar *allconstructors* nil "a list of all the constructors in the system") -(defvar *allOperations* nil "a list of all the operations in the system") +(defvar *allOperations* nil + "a list of all the operations in the system") -(defvar *asharpflags* "-O -laxiom -Fasy -Flsp" "library compiler flags") +(defvar *asharpflags* + "-O -laxiom -Fasy -Flsp" "library compiler flags") (defun asharp (file &optional (flags *asharpflags*)) "call the asharp compiler" @@ -332,90 +357,184 @@ ) (defun initial-getdatabase () - "fetch data we want in the saved system" - (let (hascategory constructormodemapAndoperationalist operation constr) - (format t "Initial getdatabase~%") - (setq hascategory '( - (|Equation| . |Ring|) - (|Expression| . |CoercibleTo|) (|Expression| . |CommutativeRing|) - (|Expression| . |IntegralDomain|) (|Expression| . |Ring|) - (|Float| . |RetractableTo|) - (|Fraction| . |Algebra|) (|Fraction| . |CoercibleTo|) - (|Fraction| . |OrderedSet|) (|Fraction| . |RetractableTo|) - (|Integer| . |Algebra|) (|Integer| . |CoercibleTo|) - (|Integer| . |ConvertibleTo|) (|Integer| . |LinearlyExplicitRingOver|) - (|Integer| . |RetractableTo|) - (|List| . |CoercibleTo|) (|List| . |FiniteLinearAggregate|) - (|List| . |OrderedSet|) - (|Polynomial| . |CoercibleTo|) (|Polynomial| . |CommutativeRing|) - (|Polynomial| . |ConvertibleTo|) (|Polynomial| . |OrderedSet|) - (|Polynomial| . |RetractableTo|) - (|Symbol| . |CoercibleTo|) (|Symbol| . |ConvertibleTo|) - (|Variable| . |CoercibleTo|))) - (dolist (pair hascategory) (getdatabase pair 'hascategory)) - (setq constructormodemapAndoperationalist '( - |BasicOperator| |Boolean| - |CardinalNumber| |Color| |Complex| - |Database| - |Equation| |EquationFunctions2| |Expression| - |Float| |Fraction| |FractionFunctions2| - |Integer| |IntegralDomain| - |Kernel| - |List| - |Matrix| |MappingPackage1| - |Operator| |OutputForm| - |NonNegativeInteger| - |ParametricPlaneCurve| |ParametricSpaceCurve| |Point| |Polynomial| - |PolynomialFunctions2| |PositiveInteger| - |Ring| - |SetCategory| |SegmentBinding| |SegmentBindingFunctions2| |DoubleFloat| - |SparseMultivariatePolynomial| |SparseUnivariatePolynomial| |Segment| - |String| |Symbol| - |UniversalSegment| - |Variable| |Vector|)) - (dolist (con constructormodemapAndoperationalist) - (|getConstructorModemap| con) - (getdatabase con 'operationalist)) - (setq operation '( - |+| |-| |*| |/| |**| |coerce| |convert| |elt| |equation| - |float| |sin| |cos| |map| |SEGMENT|)) - (dolist (op operation) (getdatabase op 'operation)) - (setq constr '( ;these are sorted least-to-most freq. delete early ones first - |Factored| |SparseUnivariatePolynomialFunctions2| |TableAggregate&| - |RetractableTo&| |RecursiveAggregate&| |UserDefinedPartialOrdering| - |None| |UnivariatePolynomialCategoryFunctions2| |IntegerPrimesPackage| - |SetCategory&| |IndexedExponents| |QuotientFieldCategory&| |Polynomial| - |EltableAggregate&| |PartialDifferentialRing&| |Set| - |UnivariatePolynomialCategory&| |FlexibleArray| - |SparseMultivariatePolynomial| |PolynomialCategory&| - |DifferentialExtension&| |IndexedFlexibleArray| |AbelianMonoidRing&| - |FiniteAbelianMonoidRing&| |DivisionRing&| |FullyLinearlyExplicitRingOver&| - |IndexedVector| |IndexedOneDimensionalArray| |LocalAlgebra| |Localize| - |Boolean| |Field&| |Vector| |IndexedDirectProductObject| |Aggregate&| - |PolynomialRing| |FreeModule| |IndexedDirectProductAbelianGroup| - |IndexedDirectProductAbelianMonoid| |SingletonAsOrderedSet| - |SparseUnivariatePolynomial| |Fraction| |Collection&| |HomogeneousAggregate&| - |RepeatedSquaring| |IntegerNumberSystem&| |AbelianSemiGroup&| - |AssociationList| |OrderedRing&| |SemiGroup&| |Symbol| - |UniqueFactorizationDomain&| |EuclideanDomain&| |IndexedAggregate&| - |GcdDomain&| |IntegralDomain&| |DifferentialRing&| |Monoid&| |Reference| - |UnaryRecursiveAggregate&| |OrderedSet&| |AbelianGroup&| |Algebra&| - |Module&| |Ring&| |StringAggregate&| |AbelianMonoid&| - |ExtensibleLinearAggregate&| |PositiveInteger| |StreamAggregate&| - |IndexedString| |IndexedList| |ListAggregate&| |LinearAggregate&| - |Character| |String| |NonNegativeInteger| |SingleInteger| - |OneDimensionalArrayAggregate&| |FiniteLinearAggregate&| |PrimitiveArray| - |Integer| |List| |OutputForm|)) - (dolist (con constr) - (let ((c (|getSystemModulePath| (string (getdatabase con 'abbreviation))))) - (format t " preloading ~a.." c) - (if (probe-file c) - (progn - (put con 'loaded c) - (|loadModule| c con) - (format t "loaded.~%")) - (format t "skipped.~%")))) - (format t "~%"))) + "fetch data we want in the saved system" + (let (hascategory constructormodemapAndoperationalist operation constr) + (format t "Initial getdatabase~%") + (setq hascategory '( + (|Equation| . |Ring|) + (|Expression| . |CoercibleTo|) + (|Expression| . |CommutativeRing|) + (|Expression| . |IntegralDomain|) + (|Expression| . |Ring|) + (|Float| . |RetractableTo|) + (|Fraction| . |Algebra|) + (|Fraction| . |CoercibleTo|) + (|Fraction| . |OrderedSet|) + (|Fraction| . |RetractableTo|) + (|Integer| . |Algebra|) + (|Integer| . |CoercibleTo|) + (|Integer| . |ConvertibleTo|) + (|Integer| . |LinearlyExplicitRingOver|) + (|Integer| . |RetractableTo|) + (|List| . |CoercibleTo|) + (|List| . |FiniteLinearAggregate|) + (|List| . |OrderedSet|) + (|Polynomial| . |CoercibleTo|) + (|Polynomial| . |CommutativeRing|) + (|Polynomial| . |ConvertibleTo|) + (|Polynomial| . |OrderedSet|) + (|Polynomial| . |RetractableTo|) + (|Symbol| . |CoercibleTo|) + (|Symbol| . |ConvertibleTo|) + (|Variable| . |CoercibleTo|))) + (dolist (pair hascategory) + (getdatabase pair 'hascategory)) + (setq constructormodemapAndoperationalist + '(|BasicOperator| + |Boolean| + |CardinalNumber| + |Color| + |Complex| + |Database| + |Equation| + |EquationFunctions2| + |Expression| + |Float| + |Fraction| + |FractionFunctions2| + |Integer| + |IntegralDomain| + |Kernel| + |List| + |Matrix| + |MappingPackage1| + |Operator| + |OutputForm| + |NonNegativeInteger| + |ParametricPlaneCurve| + |ParametricSpaceCurve| + |Point| + |Polynomial| + |PolynomialFunctions2| + |PositiveInteger| + |Ring| + |SetCategory| + |SegmentBinding| + |SegmentBindingFunctions2| + |DoubleFloat| + |SparseMultivariatePolynomial| + |SparseUnivariatePolynomial| + |Segment| + |String| + |Symbol| + |UniversalSegment| + |Variable| + |Vector|)) + (dolist (con constructormodemapAndoperationalist) + (|getConstructorModemap| con) + (getdatabase con 'operationalist)) + (setq operation + '(|+| |-| |*| |/| |**| + |coerce| |convert| |elt| |equation| + |float| |sin| |cos| |map| |SEGMENT|)) + (dolist (op operation) + (getdatabase op 'operation)) + (setq constr + '( ;these are sorted least-to-most freq. delete early ones first + |Factored| + |SparseUnivariatePolynomialFunctions2| + |TableAggregate&| + |RetractableTo&| + |RecursiveAggregate&| + |UserDefinedPartialOrdering| + |None| + |UnivariatePolynomialCategoryFunctions2| + |IntegerPrimesPackage| + |SetCategory&| + |IndexedExponents| + |QuotientFieldCategory&| + |Polynomial| + |EltableAggregate&| + |PartialDifferentialRing&| + |Set| + |UnivariatePolynomialCategory&| + |FlexibleArray| + |SparseMultivariatePolynomial| + |PolynomialCategory&| + |DifferentialExtension&| + |IndexedFlexibleArray| + |AbelianMonoidRing&| + |FiniteAbelianMonoidRing&| + |DivisionRing&| + |FullyLinearlyExplicitRingOver&| + |IndexedVector| + |IndexedOneDimensionalArray| + |LocalAlgebra| + |Localize| + |Boolean| + |Field&| + |Vector| + |IndexedDirectProductObject| + |Aggregate&| + |PolynomialRing| + |FreeModule| + |IndexedDirectProductAbelianGroup| + |IndexedDirectProductAbelianMonoid| + |SingletonAsOrderedSet| + |SparseUnivariatePolynomial| + |Fraction| + |Collection&| + |HomogeneousAggregate&| + |RepeatedSquaring| + |IntegerNumberSystem&| + |AbelianSemiGroup&| + |AssociationList| + |OrderedRing&| + |SemiGroup&| + |Symbol| + |UniqueFactorizationDomain&| + |EuclideanDomain&| + |IndexedAggregate&| + |GcdDomain&| + |IntegralDomain&| + |DifferentialRing&| + |Monoid&| + |Reference| + |UnaryRecursiveAggregate&| + |OrderedSet&| + |AbelianGroup&| + |Algebra&| + |Module&| + |Ring&| + |StringAggregate&| + |AbelianMonoid&| + |ExtensibleLinearAggregate&| + |PositiveInteger| + |StreamAggregate&| + |IndexedString| + |IndexedList| + |ListAggregate&| + |LinearAggregate&| + |Character| + |String| + |NonNegativeInteger| + |SingleInteger| + |OneDimensionalArrayAggregate&| + |FiniteLinearAggregate&| + |PrimitiveArray| + |Integer| + |List| + |OutputForm|)) + (dolist (con constr) + (let ((c (|getSystemModulePath| (string (getdatabase con 'abbreviation))))) + (format t " preloading ~a.." c) + (if (probe-file c) + (progn + (put con 'loaded c) + (|loadModule| c con) + (format t "loaded.~%")) + (format t "skipped.~%")))) + (format t "~%"))) ; format of an entry in interp.daase: ; (constructor-name @@ -434,33 +553,33 @@ ; ancestors -- used to compute new category updates ; ) (defun interpOpen () - "open the interpreter database and hash the keys" - (let (constructors pos stamp dbstruct) - (setq *interp-stream* (open (DaaseName "interp.daase" nil))) - (setq stamp (read *interp-stream*)) - (unless (equal stamp *interp-stream-stamp*) - (format t " Re-reading interp.daase") - (setq *interp-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *interp-stream* pos) - (setq constructors (read *interp-stream*)) - (dolist (item constructors) - (setq item (unsqueeze item)) - (setq *allconstructors* (adjoin (first item) *allconstructors*)) - (setq dbstruct (make-database)) - (setf (get (car item) 'database) dbstruct) - (setf (database-operationalist dbstruct) (second item)) - (setf (database-constructormodemap dbstruct) (third item)) - (setf (database-modemaps dbstruct) (fourth item)) - (setf (database-object dbstruct) (fifth item)) - (setf (database-constructorcategory dbstruct) (sixth item)) - (setf (database-niladic dbstruct) (seventh item)) - (setf (database-abbreviation dbstruct) (eighth item)) - (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert - (setf (database-cosig dbstruct) (ninth item)) - (setf (database-constructorkind dbstruct) (tenth item)) - (setf (database-ancestors dbstruct) (nth 11 item)))) - (format t "~&"))) + "open the interpreter database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *interp-stream* (open (DaaseName "interp.daase" nil))) + (setq stamp (read *interp-stream*)) + (unless (equal stamp *interp-stream-stamp*) + (format t " Re-reading interp.daase") + (setq *interp-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *interp-stream* pos) + (setq constructors (read *interp-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (setq *allconstructors* (adjoin (first item) *allconstructors*)) + (setq dbstruct (make-database)) + (setf (get (car item) 'database) dbstruct) + (setf (database-operationalist dbstruct) (second item)) + (setf (database-constructormodemap dbstruct) (third item)) + (setf (database-modemaps dbstruct) (fourth item)) + (setf (database-object dbstruct) (fifth item)) + (setf (database-constructorcategory dbstruct) (sixth item)) + (setf (database-niladic dbstruct) (seventh item)) + (setf (database-abbreviation dbstruct) (eighth item)) + (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert + (setf (database-cosig dbstruct) (ninth item)) + (setf (database-constructorkind dbstruct) (tenth item)) + (setf (database-ancestors dbstruct) (nth 11 item)))) + (format t "~&"))) ; this is an initialization function for the constructor database ; it sets up 2 hash tables, opens the database and hashes the index values @@ -489,306 +608,330 @@ ; ) (defun browseOpen () - "open the constructor database and hash the keys" - (let (constructors pos stamp dbstruct) - (setq *browse-stream* (open (DaaseName "browse.daase" nil))) - (setq stamp (read *browse-stream*)) - (unless (equal stamp *browse-stream-stamp*) - (format t " Re-reading browse.daase") - (setq *browse-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *browse-stream* pos) - (setq constructors (read *browse-stream*)) - (dolist (item constructors) - (setq item (unsqueeze item)) - (unless (setq dbstruct (get (car item) 'database)) - (format t "browseOpen:~%") - (format t "the browse database contains a contructor ~a~%" item) - (format t "that is not in the interp.daase file. we cannot~%") - (format t "get the database structure for this constructor and~%") - (warn "will create a new one~%") - (setf (get (car item) 'database) (setq dbstruct (make-database))) - (setq *allconstructors* (adjoin item *allconstructors*))) - (setf (database-sourcefile dbstruct) (second item)) - (setf (database-constructorform dbstruct) (third item)) - (setf (database-documentation dbstruct) (fourth item)) - (setf (database-attributes dbstruct) (fifth item)) - (setf (database-predicates dbstruct) (sixth item)) - (setf (database-parents dbstruct) (seventh item)))) - (format t "~&"))) + "open the constructor database and hash the keys" + (let (constructors pos stamp dbstruct) + (setq *browse-stream* (open (DaaseName "browse.daase" nil))) + (setq stamp (read *browse-stream*)) + (unless (equal stamp *browse-stream-stamp*) + (format t " Re-reading browse.daase") + (setq *browse-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *browse-stream* pos) + (setq constructors (read *browse-stream*)) + (dolist (item constructors) + (setq item (unsqueeze item)) + (unless (setq dbstruct (get (car item) 'database)) + (format t "browseOpen:~%") + (format t "the browse database contains a contructor ~a~%" item) + (format t "that is not in the interp.daase file. we cannot~%") + (format t "get the database structure for this constructor and~%") + (warn "will create a new one~%") + (setf (get (car item) 'database) (setq dbstruct (make-database))) + (setq *allconstructors* (adjoin item *allconstructors*))) + (setf (database-sourcefile dbstruct) (second item)) + (setf (database-constructorform dbstruct) (third item)) + (setf (database-documentation dbstruct) (fourth item)) + (setf (database-attributes dbstruct) (fifth item)) + (setf (database-predicates dbstruct) (sixth item)) + (setf (database-parents dbstruct) (seventh item)))) + (format t "~&"))) (defun categoryOpen () - "open category.daase and hash the keys" - (let (pos keys stamp) - (setq *category-stream* (open (DaaseName "category.daase" nil))) - (setq stamp (read *category-stream*)) - (unless (equal stamp *category-stream-stamp*) - (format t " Re-reading category.daase") - (setq *category-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *category-stream* pos) - (setq keys (read *category-stream*)) - (setq *hasCategory-hash* (make-hash-table :test #'equal)) - (dolist (item keys) - (setq item (unsqueeze item)) - (setf (gethash (first item) *hasCategory-hash*) (second item)))) - (format t "~&"))) + "open category.daase and hash the keys" + (let (pos keys stamp) + (setq *category-stream* (open (DaaseName "category.daase" nil))) + (setq stamp (read *category-stream*)) + (unless (equal stamp *category-stream-stamp*) + (format t " Re-reading category.daase") + (setq *category-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *category-stream* pos) + (setq keys (read *category-stream*)) + (setq *hasCategory-hash* (make-hash-table :test #'equal)) + (dolist (item keys) + (setq item (unsqueeze item)) + (setf (gethash (first item) *hasCategory-hash*) (second item)))) + (format t "~&"))) (defun operationOpen () - "read operation database and hash the keys" - (let (operations pos stamp) - (setq *operation-stream* (open (DaaseName "operation.daase" nil))) - (setq stamp (read *operation-stream*)) - (unless (equal stamp *operation-stream-stamp*) - (format t " Re-reading operation.daase") - (setq *operation-stream-stamp* stamp) - (setq pos (car stamp)) - (file-position *operation-stream* pos) - (setq operations (read *operation-stream*)) - (dolist (item operations) - (setq item (unsqueeze item)) - (setf (gethash (car item) *operation-hash*) (cdr item)))) - (format t "~&"))) + "read operation database and hash the keys" + (let (operations pos stamp) + (setq *operation-stream* (open (DaaseName "operation.daase" nil))) + (setq stamp (read *operation-stream*)) + (unless (equal stamp *operation-stream-stamp*) + (format t " Re-reading operation.daase") + (setq *operation-stream-stamp* stamp) + (setq pos (car stamp)) + (file-position *operation-stream* pos) + (setq operations (read *operation-stream*)) + (dolist (item operations) + (setq item (unsqueeze item)) + (setf (gethash (car item) *operation-hash*) (cdr item)))) + (format t "~&"))) (defun addoperations (constructor oldmaps) - "add ops from a )library domain to *operation-hash*" - (declare (special *operation-hash*)) - (dolist (map oldmaps) ; out with the old - (let (oldop op) - (setq op (car map)) - (setq oldop (getdatabase op 'operation)) - (setq oldop (delete (cdr map) oldop :test #'equal)) - (setf (gethash op *operation-hash*) oldop))) - (dolist (map (getdatabase constructor 'modemaps)) ; in with the new - (let (op newmap) - (setq op (car map)) - (setq newmap (getdatabase op 'operation)) - (setf (gethash op *operation-hash*) (cons (cdr map) newmap))))) + "add ops from a )library domain to *operation-hash*" + (declare (special *operation-hash*)) + (dolist (map oldmaps) ; out with the old + (let (oldop op) + (setq op (car map)) + (setq oldop (getdatabase op 'operation)) + (setq oldop (delete (cdr map) oldop :test #'equal)) + (setf (gethash op *operation-hash*) oldop))) + (dolist (map (getdatabase constructor 'modemaps)) ; in with the new + (let (op newmap) + (setq op (car map)) + (setq newmap (getdatabase op 'operation)) + (setf (gethash op *operation-hash*) (cons (cdr map) newmap))))) (defun showdatabase (constructor) - (format t "~&~a: ~a~%" 'constructorkind - (getdatabase constructor 'constructorkind)) - (format t "~a: ~a~%" 'cosig - (getdatabase constructor 'cosig)) - (format t "~a: ~a~%" 'operation - (getdatabase constructor 'operation)) - (format t "~a: ~%" 'constructormodemap) + (format t "~&~a: ~a~%" 'constructorkind + (getdatabase constructor 'constructorkind)) + (format t "~a: ~a~%" 'cosig + (getdatabase constructor 'cosig)) + (format t "~a: ~a~%" 'operation + (getdatabase constructor 'operation)) + (format t "~a: ~%" 'constructormodemap) (pprint (|getConstructorModemap| constructor)) - (format t "~&~a: ~%" 'constructorcategory) + (format t "~&~a: ~%" 'constructorcategory) (pprint (getdatabase constructor 'constructorcategory)) - (format t "~&~a: ~%" 'operationalist) + (format t "~&~a: ~%" 'operationalist) (pprint (getdatabase constructor 'operationalist)) - (format t "~&~a: ~%" 'modemaps) + (format t "~&~a: ~%" 'modemaps) (pprint (getdatabase constructor 'modemaps)) - (format t "~a: ~a~%" 'hascategory - (getdatabase constructor 'hascategory)) - (format t "~a: ~a~%" 'object - (getdatabase constructor 'object)) - (format t "~a: ~a~%" 'niladic - (getdatabase constructor 'niladic)) - (format t "~a: ~a~%" 'abbreviation - (getdatabase constructor 'abbreviation)) - (format t "~a: ~a~%" 'constructor? - (getdatabase constructor 'constructor?)) - (format t "~a: ~a~%" 'constructor - (getdatabase constructor 'constructor)) - (format t "~a: ~a~%" 'defaultdomain - (getdatabase constructor 'defaultdomain)) - (format t "~a: ~a~%" 'ancestors - (getdatabase constructor 'ancestors)) - (format t "~a: ~a~%" 'sourcefile - (getdatabase constructor 'sourcefile)) - (format t "~a: ~a~%" 'constructorform - (getdatabase constructor 'constructorform)) - (format t "~a: ~a~%" 'constructorargs - (getdatabase constructor 'constructorargs)) - (format t "~a: ~a~%" 'attributes - (getdatabase constructor 'attributes)) - (format t "~a: ~%" 'predicates) + (format t "~a: ~a~%" 'hascategory + (getdatabase constructor 'hascategory)) + (format t "~a: ~a~%" 'object + (getdatabase constructor 'object)) + (format t "~a: ~a~%" 'niladic + (getdatabase constructor 'niladic)) + (format t "~a: ~a~%" 'abbreviation + (getdatabase constructor 'abbreviation)) + (format t "~a: ~a~%" 'constructor? + (getdatabase constructor 'constructor?)) + (format t "~a: ~a~%" 'constructor + (getdatabase constructor 'constructor)) + (format t "~a: ~a~%" 'defaultdomain + (getdatabase constructor 'defaultdomain)) + (format t "~a: ~a~%" 'ancestors + (getdatabase constructor 'ancestors)) + (format t "~a: ~a~%" 'sourcefile + (getdatabase constructor 'sourcefile)) + (format t "~a: ~a~%" 'constructorform + (getdatabase constructor 'constructorform)) + (format t "~a: ~a~%" 'constructorargs + (getdatabase constructor 'constructorargs)) + (format t "~a: ~a~%" 'attributes + (getdatabase constructor 'attributes)) + (format t "~a: ~%" 'predicates) (pprint (getdatabase constructor 'predicates)) - (format t "~a: ~a~%" 'documentation - (getdatabase constructor 'documentation)) - (format t "~a: ~a~%" 'parents - (getdatabase constructor 'parents))) + (format t "~a: ~a~%" 'documentation + (getdatabase constructor 'documentation)) + (format t "~a: ~a~%" 'parents + (getdatabase constructor 'parents))) (defun setdatabase (constructor key value) - (let (struct) - (when (symbolp constructor) - (unless (setq struct (get constructor 'database)) - (setq struct (make-database)) - (setf (get constructor 'database) struct)) - (case key - (abbreviation - (setf (database-abbreviation struct) value) - (when (symbolp value) - (setf (get value 'abbreviationfor) constructor))) - (constructorkind - (setf (database-constructorkind struct) value)))))) + (let (struct) + (when (symbolp constructor) + (unless (setq struct (get constructor 'database)) + (setq struct (make-database)) + (setf (get constructor 'database) struct)) + (case key + (abbreviation + (setf (database-abbreviation struct) value) + (when (symbolp value) + (setf (get value 'abbreviationfor) constructor))) + (constructorkind + (setf (database-constructorkind struct) value)))))) (defun deldatabase (constructor key) (when (symbolp constructor) - (case key - (abbreviation - (setf (get constructor 'abbreviationfor) nil))))) + (case key + (abbreviation + (setf (get constructor 'abbreviationfor) nil))))) (defun getdatabase (constructor key) - (declare (special *miss*)) - (when (eq *miss* t) (format t "getdatabase call: ~20a ~a~%" constructor key)) - (let (data table stream ignore struct) - (declare (ignore ignore)) - (when (or (symbolp constructor) - (and (eq key 'hascategory) (pairp constructor))) - (case key + (declare (special *miss*)) + (when (eq *miss* t) + (format t "getdatabase call: ~20a ~a~%" constructor key)) + (let (data table stream ignore struct) + (declare (ignore ignore)) + (when (or (symbolp constructor) + (and (eq key 'hascategory) (pairp constructor))) + (case key ; note that abbreviation, constructorkind and cosig are heavy hitters ; thus they occur first in the list of things to check - (abbreviation - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-abbreviation struct)))) - (constructorkind - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorkind struct)))) - (cosig - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-cosig struct)))) - (operation - (setq stream *operation-stream*) - (setq data (gethash constructor *operation-hash*))) - (constructormodemap - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructormodemap struct)))) - (constructorcategory - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorcategory struct)) - (when (null data) ;domain or package then subfield of constructormodemap - (setq data (cadar (|getConstructorModemap| constructor)))))) - (operationalist - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-operationalist struct)))) - (modemaps - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-modemaps struct)))) - (hascategory - (setq table *hasCategory-hash*) - (setq stream *category-stream*) - (setq data (gethash constructor table))) - (object - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-object struct)))) - (asharp? - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-object struct)))) - (niladic - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-niladic struct)))) - (constructor? - (when (setq struct (get constructor 'database)) - (setq data (when (database-operationalist struct) t)))) - (superdomain ; only 2 superdomains in the world - (case constructor - (|NonNegativeInteger| - (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) - (|PositiveInteger| - (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) - (constructor - (when (setq data (get constructor 'abbreviationfor)))) - (defaultdomain - (setq data (cadr (assoc constructor *defaultdomain-list*)))) - (ancestors - (setq stream *interp-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-ancestors struct)))) - (sourcefile - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-sourcefile struct)))) - (constructorform - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-constructorform struct)))) - (constructorargs - (setq data (cdr (getdatabase constructor 'constructorform)))) - (attributes - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-attributes struct)))) - (predicates - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-predicates struct)))) - (documentation - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-documentation struct)))) - (parents - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-parents struct)))) - (users - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-users struct)))) - (dependents - (setq stream *browse-stream*) - (when (setq struct (get constructor 'database)) - (setq data (database-dependents struct)))) - (otherwise (warn "~%(GETDATABASE ~a ~a) failed~%" constructor key))) - (when (numberp data) ;fetch the real data - (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) - (file-position stream data) - (setq data (unsqueeze (read stream))) - (case key ; cache the result of the database read - (operation (setf (gethash constructor *operation-hash*) data)) - (hascategory (setf (gethash constructor *hascategory-hash*) data)) - (constructorkind (setf (database-constructorkind struct) data)) - (cosig (setf (database-cosig struct) data)) - (constructormodemap (setf (database-constructormodemap struct) data)) - (constructorcategory (setf (database-constructorcategory struct) data)) - (operationalist (setf (database-operationalist struct) data)) - (modemaps (setf (database-modemaps struct) data)) - (object (setf (database-object struct) data)) - (niladic (setf (database-niladic struct) data)) - (abbreviation (setf (database-abbreviation struct) data)) - (constructor (setf (database-constructor struct) data)) - (ancestors (setf (database-ancestors struct) data)) - (constructorform (setf (database-constructorform struct) data)) - (attributes (setf (database-attributes struct) data)) - (predicates (setf (database-predicates struct) data)) - (documentation (setf (database-documentation struct) data)) - (parents (setf (database-parents struct) data)) - (users (setf (database-users struct) data)) - (dependents (setf (database-dependents struct) data)) - (sourcefile (setf (database-sourcefile struct) data)))) - (case key ; fixup the special cases - (sourcefile - (when (and data (string= (directory-namestring data) "") - (string= (pathname-type data) "spad")) - (setq data - (concatenate 'string (|systemRootDirectory|) "src/algebra/" data)))) - (asharp? ; is this asharp code? - (if (consp data) - (setq data (cdr data)) - (setq data nil))) - (object ; fix up system object pathname - (if (consp data) - (setq data - (if (string= (directory-namestring (car data)) "") - (|getSystemModulePath| (car data)) - (car data))) - (when (and data (string= (directory-namestring data) "")) - (setq data (|getSystemModulePath| data))))))) - data)) - -; )library top level command -- soon to be obsolete + (abbreviation + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-abbreviation struct)))) + (constructorkind + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorkind struct)))) + (cosig + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-cosig struct)))) + (operation + (setq stream *operation-stream*) + (setq data (gethash constructor *operation-hash*))) + (constructormodemap + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructormodemap struct)))) + (constructorcategory + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorcategory struct)) + (when (null data) ;domain or package then subfield of constructormodemap + (setq data (cadar (|getConstructorModemap| constructor)))))) + (operationalist + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-operationalist struct)))) + (modemaps + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-modemaps struct)))) + (hascategory + (setq table *hasCategory-hash*) + (setq stream *category-stream*) + (setq data (gethash constructor table))) + (object + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (asharp? + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-object struct)))) + (niladic + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-niladic struct)))) + (constructor? + (when (setq struct (get constructor 'database)) + (setq data (when (database-operationalist struct) t)))) + (superdomain ; only 2 superdomains in the world + (case constructor + (|NonNegativeInteger| + (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) + (|PositiveInteger| + (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) + (constructor + (when (setq data (get constructor 'abbreviationfor)))) + (defaultdomain + (setq data (cadr (assoc constructor *defaultdomain-list*)))) + (ancestors + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-ancestors struct)))) + (sourcefile + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-sourcefile struct)))) + (constructorform + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-constructorform struct)))) + (constructorargs + (setq data (cdr (getdatabase constructor 'constructorform)))) + (attributes + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-attributes struct)))) + (predicates + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-predicates struct)))) + (documentation + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-documentation struct)))) + (parents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-parents struct)))) + (users + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-users struct)))) + (dependents + (setq stream *browse-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-dependents struct)))) + (otherwise + (warn "~%(GETDATABASE ~a ~a) failed~%" constructor key))) + (when (numberp data) ;fetch the real data + (when *miss* + (format t "getdatabase miss: ~20a ~a~%" key constructor)) + (file-position stream data) + (setq data (unsqueeze (read stream))) + (case key ; cache the result of the database read + (operation + (setf (gethash constructor *operation-hash*) data)) + (hascategory + (setf (gethash constructor *hascategory-hash*) data)) + (constructorkind + (setf (database-constructorkind struct) data)) + (cosig + (setf (database-cosig struct) data)) + (constructormodemap + (setf (database-constructormodemap struct) data)) + (constructorcategory + (setf (database-constructorcategory struct) data)) + (operationalist + (setf (database-operationalist struct) data)) + (modemaps + (setf (database-modemaps struct) data)) + (object + (setf (database-object struct) data)) + (niladic + (setf (database-niladic struct) data)) + (abbreviation + (setf (database-abbreviation struct) data)) + (constructor + (setf (database-constructor struct) data)) + (ancestors + (setf (database-ancestors struct) data)) + (constructorform + (setf (database-constructorform struct) data)) + (attributes + (setf (database-attributes struct) data)) + (predicates + (setf (database-predicates struct) data)) + (documentation + (setf (database-documentation struct) data)) + (parents + (setf (database-parents struct) data)) + (users + (setf (database-users struct) data)) + (dependents + (setf (database-dependents struct) data)) + (sourcefile + (setf (database-sourcefile struct) data)))) + (case key ; fixup the special cases + (sourcefile + (when (and data (string= (directory-namestring data) "") + (string= (pathname-type data) "spad")) + (setq data + (concatenate 'string + (|systemRootDirectory|) + "src/algebra/" data)))) + (asharp? ; is this asharp code? + (if (consp data) + (setq data (cdr data)) + (setq data nil))) + (object ; fix up system object pathname + (if (consp data) + (setq data + (if (string= (directory-namestring (car data)) "") + (|getSystemModulePath| (car data)) + (car data))) + (when (and data (string= (directory-namestring data) "")) + (setq data (|getSystemModulePath| data))))))) + data)) ;; Current directory ;; Contributed by Juergen Weiss. @@ -902,11 +1045,12 @@ (defun localasy (asy object only make-database? noexpose) - "given an alist from the asyfile and the objectfile update the database" - (labels ( - (fetchdata (alist index) - (cdr (assoc index alist :test #'string=)))) - (let (cname kind key alist (systemdir? nil) oldmaps asharp-name dbstruct abbrev) + "given an alist from the asyfile and the objectfile update the database" + (labels ( + (fetchdata (alist index) + (cdr (assoc index alist :test #'string=)))) + (let (cname kind key alist (systemdir? nil) + oldmaps asharp-name dbstruct abbrev) #+:CCL ;; Open the library (let (lib) @@ -928,142 +1072,153 @@ oldmaps :test #'equal)) (asharpMkAutoloadFunction object asharp-name)) (when (if (null only) (not (eq key '%%)) (member key only)) - (setq *allOperations* nil) ; force this to recompute - (setq oldmaps (getdatabase key 'modemaps)) - (setq dbstruct (make-database)) - (setf (get key 'database) dbstruct) - (setq *allconstructors* (adjoin key *allconstructors*)) - (setf (database-constructorform dbstruct) - (fetchdata alist "constructorForm")) - (setf (database-constructorkind dbstruct) - (fetchdata alist "constructorKind")) - (setf (database-constructormodemap dbstruct) - (fetchdata alist "constructorModemap")) - (unless (setf (database-abbreviation dbstruct) - (fetchdata alist "abbreviation")) - (setf (database-abbreviation dbstruct) key)) ; default - (setq abbrev (database-abbreviation dbstruct)) - (setf (get abbrev 'abbreviationfor) key) - (setf (database-constructorcategory dbstruct) - (fetchdata alist "constructorCategory")) - (setf (database-attributes dbstruct) - (fetchdata alist "attributes")) - (setf (database-sourcefile dbstruct) - (fetchdata alist "sourceFile")) - (setf (database-operationalist dbstruct) - (fetchdata alist "operationAlist")) - (setf (database-modemaps dbstruct) - (fetchdata alist "modemaps")) - (setf (database-documentation dbstruct) - (fetchdata alist "documentation")) - (setf (database-predicates dbstruct) - (fetchdata alist "predicates")) - (setf (database-niladic dbstruct) - (fetchdata alist "NILADIC")) - (addoperations key oldmaps) - (setq cname (|opOf| (database-constructorform dbstruct))) - (setq kind (database-constructorkind dbstruct)) - (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) - (unless make-database? - (|updateDatabase| key cname systemdir?) ;makes many hashtables??? - (|installConstructor| cname kind) - ;; following can break category database build - (if (eq kind '|category|) - (setf (database-ancestors dbstruct) - (fetchdata alist "ancestors"))) - (if (eq kind '|domain|) - (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) - (setf (gethash (cons cname (caar pair)) *hascategory-hash*) - (cdr pair)))) - (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (setf (database-object dbstruct) (cons object asharp-name)) - (if (eq kind '|category|) - (asharpMkAutoLoadCategory object cname asharp-name - (database-cosig dbstruct)) - (asharpMkAutoLoadFunctor object cname asharp-name - (database-cosig dbstruct))) - (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) + (setq *allOperations* nil) ; force this to recompute + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setf (get key 'database) dbstruct) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (database-constructorform dbstruct) + (fetchdata alist "constructorForm")) + (setf (database-constructorkind dbstruct) + (fetchdata alist "constructorKind")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist "constructorModemap")) + (unless (setf (database-abbreviation dbstruct) + (fetchdata alist "abbreviation")) + (setf (database-abbreviation dbstruct) key)) ; default + (setq abbrev (database-abbreviation dbstruct)) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-constructorcategory dbstruct) + (fetchdata alist "constructorCategory")) + (setf (database-attributes dbstruct) + (fetchdata alist "attributes")) + (setf (database-sourcefile dbstruct) + (fetchdata alist "sourceFile")) + (setf (database-operationalist dbstruct) + (fetchdata alist "operationAlist")) + (setf (database-modemaps dbstruct) + (fetchdata alist "modemaps")) + (setf (database-documentation dbstruct) + (fetchdata alist "documentation")) + (setf (database-predicates dbstruct) + (fetchdata alist "predicates")) + (setf (database-niladic dbstruct) + (fetchdata alist "NILADIC")) + (addoperations key oldmaps) + (setq cname (|opOf| (database-constructorform dbstruct))) + (setq kind (database-constructorkind dbstruct)) + (if (null noexpose) (|setExposeAddConstr| (cons cname nil))) + (unless make-database? + (|updateDatabase| key cname systemdir?) ;makes many hashtables??? + (|installConstructor| cname kind) + ;; following can break category database build + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (fetchdata alist "ancestors"))) + (if (eq kind '|domain|) + (dolist (pair (cdr (assoc "ancestors" alist :test #'string=))) + (setf (gethash (cons cname (caar pair)) *hascategory-hash*) + (cdr pair)))) + (if |$InteractiveMode| + (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (setf (database-object dbstruct) (cons object asharp-name)) + (if (eq kind '|category|) + (asharpMkAutoLoadCategory object cname asharp-name + (database-cosig dbstruct)) + (asharpMkAutoLoadFunctor object cname asharp-name + (database-cosig dbstruct))) + (|sayKeyedMsg| 'S2IU0001 (list cname object)))))))) (defun localnrlib (key nrlib object make-database? noexpose) - "given a string pathname of an index.KAF and the object update the database" - (labels ( - (fetchdata (alist in index) - (let (pos) - (setq pos (third (assoc index alist :test #'string=))) - (when pos - (file-position in pos) - (read in))))) - (let (alist kind (systemdir? nil) pos constructorform oldmaps abbrev dbstruct) - (with-open-file (in nrlib) - (file-position in (read in)) - (setq alist (read in)) - (setq pos (third (assoc "constructorForm" alist :test #'string=))) - (file-position in pos) - (setq constructorform (read in)) - (setq key (car constructorform)) - (setq oldmaps (getdatabase key 'modemaps)) - (setq dbstruct (make-database)) - (setq *allconstructors* (adjoin key *allconstructors*)) - (setf (get key 'database) dbstruct) ; store the struct, side-effect it... - (setf (database-constructorform dbstruct) constructorform) - (setq *allOperations* nil) ; force this to recompute - (setf (database-object dbstruct) object) - (setq abbrev - (intern (pathname-name (first (last (pathname-directory object)))))) - (setf (database-abbreviation dbstruct) abbrev) - (setf (get abbrev 'abbreviationfor) key) - (setf (database-operationalist dbstruct) nil) - (setf (database-operationalist dbstruct) - (fetchdata alist in "operationAlist")) - (setf (database-constructormodemap dbstruct) - (fetchdata alist in "constructorModemap")) - (setf (database-modemaps dbstruct) (fetchdata alist in "modemaps")) - (setf (database-sourcefile dbstruct) (fetchdata alist in "sourceFile")) - (when make-database? - (setf (database-sourcefile dbstruct) - (file-namestring (database-sourcefile dbstruct)))) - (setf (database-constructorkind dbstruct) - (setq kind (fetchdata alist in "constructorKind"))) - (setf (database-constructorcategory dbstruct) - (fetchdata alist in "constructorCategory")) - (setf (database-documentation dbstruct) - (fetchdata alist in "documentation")) - (setf (database-attributes dbstruct) - (fetchdata alist in "attributes")) - (setf (database-predicates dbstruct) - (fetchdata alist in "predicates")) - (setf (database-niladic dbstruct) - (when (fetchdata alist in "NILADIC") t)) - (addoperations key oldmaps) - (unless make-database? - (if (eq kind '|category|) - (setf (database-ancestors dbstruct) - (SUBLISLIS |$FormalMapVariableList| (cdr constructorform) (fetchdata alist in "ancestors")))) - (|updateDatabase| key key systemdir?) ;makes many hashtables??? - (|installConstructor| key kind) ;used to be key cname ... - (|updateCategoryTable| key kind) - (if |$InteractiveMode| (setq |$CategoryFrame| |$EmptyEnvironment|))) - (setf (database-cosig dbstruct) - (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) - (remprop key 'loaded) - (if (null noexpose) (|setExposeAddConstr| (cons key nil))) - #-:CCL - (setf (symbol-function key) ; sets the autoload property for cname - #'(lambda (&rest args) - (unless (get key 'loaded) - (|startTimingProcess| '|load|) - (|loadLibNoUpdate| key key object)) ; used to be cname key - (apply key args))) - #+:CCL - (let (lib) - (if (filep (setq lib (make-pathname :name object :type "lib")) ) - (setq input-libraries (cons (open-library (truename lib)) input-libraries))) - (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) ) - (|sayKeyedMsg| 'S2IU0001 (list key object)))))) + "given a string pathname of an index.KAF and the object update the database" + (labels + ((fetchdata (alist in index) + (let (pos) + (setq pos (third (assoc index alist :test #'string=))) + (when pos + (file-position in pos) + (read in))))) + (let (alist kind (systemdir? nil) pos + constructorform oldmaps abbrev dbstruct) + (with-open-file (in nrlib) + (file-position in (read in)) + (setq alist (read in)) + (setq pos (third (assoc "constructorForm" alist :test #'string=))) + (file-position in pos) + (setq constructorform (read in)) + (setq key (car constructorform)) + (setq oldmaps (getdatabase key 'modemaps)) + (setq dbstruct (make-database)) + (setq *allconstructors* (adjoin key *allconstructors*)) + (setf (get key 'database) dbstruct) ; store the struct, side-effect it... + (setf (database-constructorform dbstruct) constructorform) + (setq *allOperations* nil) ; force this to recompute + (setf (database-object dbstruct) object) + (setq abbrev + (intern (pathname-name (first (last (pathname-directory object)))))) + (setf (database-abbreviation dbstruct) abbrev) + (setf (get abbrev 'abbreviationfor) key) + (setf (database-operationalist dbstruct) nil) + (setf (database-operationalist dbstruct) + (fetchdata alist in "operationAlist")) + (setf (database-constructormodemap dbstruct) + (fetchdata alist in "constructorModemap")) + (setf (database-modemaps dbstruct) + (fetchdata alist in "modemaps")) + (setf (database-sourcefile dbstruct) + (fetchdata alist in "sourceFile")) + (when make-database? + (setf (database-sourcefile dbstruct) + (file-namestring (database-sourcefile dbstruct)))) + (setf (database-constructorkind dbstruct) + (setq kind (fetchdata alist in "constructorKind"))) + (setf (database-constructorcategory dbstruct) + (fetchdata alist in "constructorCategory")) + (setf (database-documentation dbstruct) + (fetchdata alist in "documentation")) + (setf (database-attributes dbstruct) + (fetchdata alist in "attributes")) + (setf (database-predicates dbstruct) + (fetchdata alist in "predicates")) + (setf (database-niladic dbstruct) + (when (fetchdata alist in "NILADIC") t)) + (addoperations key oldmaps) + (unless make-database? + (if (eq kind '|category|) + (setf (database-ancestors dbstruct) + (SUBLISLIS |$FormalMapVariableList| + (cdr constructorform) + (fetchdata alist in "ancestors")))) + (|updateDatabase| key key systemdir?) ;makes many hashtables??? + (|installConstructor| key kind) ;used to be key cname ... + (|updateCategoryTable| key kind) + (if |$InteractiveMode| + (setq |$CategoryFrame| |$EmptyEnvironment|))) + (setf (database-cosig dbstruct) + (cons nil (mapcar #'|categoryForm?| + (cddar (database-constructormodemap dbstruct))))) + (remprop key 'loaded) + (if (null noexpose) + (|setExposeAddConstr| (cons key nil))) + #-:CCL + (setf (symbol-function key) ; sets the autoload property for cname + #'(lambda (&rest args) + (unless (get key 'loaded) + (|startTimingProcess| '|load|) + (|loadLibNoUpdate| key key object)) ; used to be cname key + (apply key args))) + #+:CCL + (let (lib) + (if (filep + (setq lib (make-pathname :name object :type "lib")) ) + (setq input-libraries + (cons (open-library (truename lib)) + input-libraries))) + (|unloadOneConstructor| (get abbrev 'abbreviationfor) abbrev) ) + (|sayKeyedMsg| 'S2IU0001 (list key object)))))) ; making new databases consists of: ; 1) reset all of the system hash tables @@ -1085,7 +1240,7 @@ ; to be written out last. (defun make-databases (dirlist) - (labels ( + (labels ( ;; these are types which have no library object associated with them. ;; we store some constructed data to make them perform like library ;; objects, the *operationalist-hash* key entry is used by allConstructors @@ -1432,24 +1587,24 @@ (close out))) (defun write-warmdata () - "write out information to be loaded into the image at build time" - (declare (special |$topicHash|)) - (with-open-file (out "warm.data" :direction :output) - (format out "(in-package \"BOOT\")~%") - (format out "(setq |$topicHash| (make-hash-table))~%") - (maphash #'(lambda (k v) - (format out "(setf (gethash '|~a| |$topicHash|) ~a)~%" k v)) |$topicHash|))) + "write out information to be loaded into the image at build time" + (declare (special |$topicHash|)) + (with-open-file (out "warm.data" :direction :output) + (format out "(in-package \"BOOT\")~%") + (format out "(setq |$topicHash| (make-hash-table))~%") + (maphash #'(lambda (k v) + (format out "(setf (gethash '|~a| |$topicHash|) ~a)~%" k v)) |$topicHash|))) (defun |allConstructors| () - (declare (special *allconstructors*)) - *allconstructors*) + (declare (special *allconstructors*)) + *allconstructors*) (defun |allOperations| () - (declare (special *allOperations*)) - (unless *allOperations* - (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) - *operation-hash*)) - *allOperations*) + (declare (special *allOperations*)) + (unless *allOperations* + (maphash #'(lambda (k v) (declare (ignore v)) (push k *allOperations*)) + *operation-hash*)) + *allOperations*) ; the variable NOPfuncall is a funcall-able object that is a dummy ; initializer for libaxiom asharp domains. diff --git a/src/interp/database.boot b/src/interp/database.boot index f0d18926..2d25edb4 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -42,6 +42,28 @@ import '"compat" $getUnexposedOperations := true $globalExposureGroupAlist := [] +--% + +getConstructorAbbreviationFromDB: %Symbol -> %Maybe %Symbol +getConstructorAbbreviationFromDB ctor == + GETDATABASE(ctor,"ABBREVIATION") + +getConstructorCategoryFromDB: %Symbol -> %Form +getConstructorCategoryFromDB ctor == + GETDATABASE(ctor,"CONSTRCTORCATEGORY") + +getConstructorKindFromDB: %Symbol -> %Maybe %ConstructorKind +getConstructorKindFromDB ctor == + GETDATABASE(ctor,"CONSTRUCTORKIND") + +getConstructorAncestorsFromDB: %Symbol -> %List +getConstructorAncestorsFromDB ctor == + GETDATABASE(ctor,"ANCESTORS") + +getConstructorSourceFile: %Symbol -> %Maybe %String +getConstructorSourceFile ctor == + GETDATABASE(ctor,"SOURCEFILE") + --% Functions for manipulating MODEMAP DATABASE augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == diff --git a/src/interp/define.boot b/src/interp/define.boot index 58afdba9..d99cc278 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -518,7 +518,7 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], if $LISPLIB then $lisplibKind:= ------->This next line prohibits changing the KIND once given ---------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk +--------kk:=getConstructorKindFromDB $op => kk $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package 'domain $lisplibForm:= form @@ -1150,13 +1150,13 @@ compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == -- counts $clamList: local lambdaOrSlam := - GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM + getConstructorKindFromDB fn = "category" => 'SPADSLAM $mutableDomain => 'LAMBDA $clamList:= [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] 'LAMBDA compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]] - if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category + if getConstructorKindFromDB fn = "category" then u:= compAndDefine compForm else u:=COMP compForm clearConstructorCache fn --clear cache for constructor diff --git a/src/interp/domain.lisp b/src/interp/domain.lisp index 952b3a5e..beed4d52 100644 --- a/src/interp/domain.lisp +++ b/src/interp/domain.lisp @@ -168,7 +168,7 @@ (defun |mkAutoLoad| (fn cname) (cond ((or (memq cname |$CategoryNames|) - (eq (GETDATABSE cname 'CONSTRUCTORKIND) '|category|)) + (eq (|getConstructorKindFromDB| cname) '|category|)) (function (lambda (&rest args) (|autoLoad| fn cname) (apply cname args)))) diff --git a/src/interp/format.boot b/src/interp/format.boot index 4e948e41..52bfbdd8 100644 --- a/src/interp/format.boot +++ b/src/interp/format.boot @@ -455,7 +455,7 @@ formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where STRINGP(x) or IDENTP(x) => x x is [ ='_:,:.] => form2String1 x isValidType(m) and PAIRP(m) and - (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => + (getConstructorKindFromDB first(m) = "domain") => (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => form2String1 objValUnwrap x' form2String1 x @@ -763,7 +763,7 @@ string2Float s == form2Fence form == -- body of dbMkEvalable [op, :.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB op kind = 'category => form2Fence1 form form2Fence1 mkEvalable form diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot index 2b1a05c3..d6ad6b1c 100644 --- a/src/interp/g-cndata.boot +++ b/src/interp/g-cndata.boot @@ -79,17 +79,20 @@ constructor? name == -- if it is a constructor name, return the abbreviation GETDATABASE(name,'ABBREVIATION) +domainForm?: %Form -> %Boolean domainForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain + getConstructorKindFromDB opOf d = "domain" +packageForm?: %Form -> %Boolean packageForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package + getConstructorKindFromDB opOf d = "package" +categoryFrom?: %Form -> %Boolean categoryForm? c == op := opOf c MEMQ(op, $CategoryNames) => true - GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true - nil + getConstructorKindFromDB op = "category" => true + false getImmediateSuperDomain(d) == IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) @@ -117,7 +120,7 @@ mkUserConstructorAbbreviation(c,a,type) == abbQuery(x) == abb := GETDATABASE(x,'ABBREVIATION) => - sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) + sayKeyedMsg("S2IZ0001",[abb,getConstructorKindFromDB x,x]) sayKeyedMsg("S2IZ0003",[x]) installConstructor(cname,type) == @@ -140,7 +143,7 @@ constructorAbbreviationErrorCheck(c,a,typ,errmess) == if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) abb := GETDATABASE(c,'ABBREVIATION) name:= GETDATABASE(a,'CONSTRUCTOR) - type := GETDATABASE(c,'CONSTRUCTORKIND) + type := getConstructorKindFromDB c a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 80dceba0..3bcb22da 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -504,7 +504,7 @@ str2Tex s == val := objValUnwrap val CAR val.1 -opOf: %Form -> %Symbol +opOf: %Thing -> %Thing opOf x == atom x => x first x diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot index 156caec9..6d31ceb8 100644 --- a/src/interp/i-eval.boot +++ b/src/interp/i-eval.boot @@ -55,7 +55,7 @@ mkEvalable form == op="Mapping"=> mkEvalableMapping form op="Enumeration" => form loadIfNecessary op - kind:= GETDATABASE(op,'CONSTRUCTORKIND) + kind:= getConstructorKindFromDB op cosig := GETDATABASE(op, 'COSIG) => [op,:[val for x in argl for typeFlag in rest cosig]] where val() == typeFlag => @@ -182,7 +182,7 @@ evaluateType1 (form is [op,:argl]) == evalCategory(x' := (evaluateType x), m) => x' throwEvalTypeMsg("S2IE0004",[form]) m := evaluateType m - GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and + getConstructorKindFromDB opOf m = "domain" and (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => [zt,:zv]:= z1:= getAndEvalConstructorArgument tree (v' := coerceOrRetract(z1,m)) => objValUnwrap v' diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot index e037061a..0857b4a4 100644 --- a/src/interp/i-funsel.boot +++ b/src/interp/i-funsel.boot @@ -985,7 +985,7 @@ filterModemapsFromPackages(mms, names, op) == type := getDomainFromMm mm null type => bad := cons(mm,bad) if PAIRP type then type := first type - GETDATABASE(type,'CONSTRUCTORKIND) = 'category => bad := cons(mm,bad) + getConstructorKindFromDB type = "category" => bad := cons(mm,bad) name := object2String type found := nil for n in names while not found repeat diff --git a/src/interp/i-resolv.boot b/src/interp/i-resolv.boot index ec359b1c..037b83c7 100644 --- a/src/interp/i-resolv.boot +++ b/src/interp/i-resolv.boot @@ -426,7 +426,7 @@ getConditionalCategoryOfType1(cat,conditions,match,seen) == RPLACD(conditions,CONS(cat,CDR conditions)) conditions conditions - cat is [catName,:.] and (GETDATABASE(catName,'CONSTRUCTORKIND) = 'category) => + cat is [catName,:.] and (getConstructorKindFromDB catName = "category") => cat in CDR seen => conditions RPLACD(seen,[cat,:CDR seen]) subCat := GETDATABASE(catName,'CONSTRUCTORCATEGORY) diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index 77b2283a..06ce2db5 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -1111,7 +1111,7 @@ displayValue($op,u,omitVariableNameIfTrue) == STRCONC('"Value of ", PNAME $op,'": ") labmode := prefix2String objMode(u) if ATOM labmode then labmode := [labmode] - GETDATABASE(expr,'CONSTRUCTORKIND) = 'domain => + getConstructorKindDB expr = "domain" => sayMSG concat('" ",label,labmode,rhs,form2String expr) mathprint ['CONCAT,label,:labmode,rhs, outputFormat(expr,objMode(u))] @@ -2334,7 +2334,7 @@ reportOpsFromUnitDirectly unitForm == isRecordOrUnion := unitForm is [a,:.] and a in '(Record Union) unit:= evalDomain unitForm top:= CAR unitForm - kind:= GETDATABASE(top,'CONSTRUCTORKIND) + kind:= getConstructorKindFromDB top sayBrightly concat('%b,formatOpType unitForm, '%d,'"is a",'%b,kind,'%d, '"constructor.") @@ -2389,7 +2389,7 @@ reportOpsFromLisplib(op,u) == argml := (s := getConstructorSignature op) => KDR s NIL - typ:= GETDATABASE(op,'CONSTRUCTORKIND) + typ:= getConstructorKindFromDB op nArgs:= #argml argList:= KDR GETDATABASE(op,'CONSTRUCTORFORM) functorForm:= [op,:argList] @@ -2428,7 +2428,7 @@ reportOpsFromLisplib(op,u) == displayOperationsFromLisplib form == [name,:argl] := form - kind := GETDATABASE(name,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB name centerAndHighlight('"Operations",$LINELENGTH,specialChar 'hbar) opList:= GETDATABASE(name,'OPERATIONALIST) null opList => @@ -2750,7 +2750,7 @@ whatConstructors constrType == -- here constrType should be one of 'category, 'domain, 'package MSORT [CONS(GETDATABASE(con,'ABBREVIATION), STRING(con)) for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = constrType] + | getConstructorKindFromDB con = constrType] apropos l == -- l is a list of operation name fragments diff --git a/src/interp/interop.boot b/src/interp/interop.boot index 63ce4fd6..a2cc3301 100644 --- a/src/interp/interop.boot +++ b/src/interp/interop.boot @@ -115,7 +115,7 @@ CompStrToString(str) == runOldAxiomFunctor(:allArgs) == [:args,env] := allArgs - GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB env = "category" => [$oldAxiomPreCategoryDispatch,: [env, :args]] dom:=APPLY(env, args) makeOldAxiomDispatchDomain dom @@ -123,7 +123,7 @@ runOldAxiomFunctor(:allArgs) == makeLazyOldAxiomDispatchDomain domform == attribute? domform => [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)] - GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB opOf domform = "category" => [$oldAxiomPreCategoryDispatch,: domform] dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] NCONC(dd,dd) -- installs back pointer to head of domain. diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 47501659..39952bf0 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -154,7 +154,7 @@ loadLib cname == update? := $forceDatabaseUpdate or not systemdir? not update? => loadLibNoUpdate(cname, cname, fullLibName) - kind := GETDATABASE(cname,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB cname if $printLoadMsgs then sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) loadModule(fullLibName,cname) @@ -180,7 +180,7 @@ loadLib cname == 'T loadLibNoUpdate(cname, libName, fullLibName) == - kind := GETDATABASE(cname,'CONSTRUCTORKIND) + kind := getConstructorKindFromDB cname if $printLoadMsgs then sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) if CATCH('VERSIONCHECK,loadModule(fullLibName,cname)) = -1 @@ -210,8 +210,8 @@ loadLibIfNecessary(u,mustExist) == loadLib u => u null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => - y:= GETDATABASE(u,'CONSTRUCTORKIND) => - y = 'category => + y:= getConstructorKindFromDB u => + y = "category" => updateCategoryFrameForCategory u updateCategoryFrameForConstructor u throwKeyedMsg("S2IL0005",[u]) @@ -257,7 +257,7 @@ makeConstructorsAutoLoad() == systemDependentMkAutoload(fn,cnam) == FBOUNDP(cnam) => "next" asharpName := GETDATABASE(cnam, 'ASHARP?) => - kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) + kind := getConstructorKindFromDB cnam cosig := GETDATABASE(cnam, 'COSIG) file := GETDATABASE(cnam, 'OBJECT) SET_-LIB_-FILE_-GETTER(file, cnam) @@ -675,7 +675,7 @@ mkEvalableCategoryForm c == --from DEFINE MEMQ(op,$CategoryNames) => ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) --loadIfNecessary op - GETDATABASE(op,'CONSTRUCTORKIND) = 'category or + getConstructorKindFromDB op = 'category or get(op,"isCategory",$CategoryFrame) => [op,:[quotifyCategoryArgument x for x in argl]] [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) @@ -699,12 +699,12 @@ isFunctor x == not IDENTP op => false $InteractiveMode => MEMQ(op,$DomainNames) => true - MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) + MEMQ(getConstructorKindFromDB op,'(domain package)) u:= get(op,'isFunctor,$CategoryFrame) or MEMQ(op,'(SubDomain Union Record)) => u constructor? op => prop := get(op,'isFunctor,$CategoryFrame) => prop - if GETDATABASE(op,'CONSTRUCTORKIND) = 'category + if getConstructorKindFromDB op = "category" then updateCategoryFrameForCategory op else updateCategoryFrameForConstructor op get(op,'isFunctor,$CategoryFrame) diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index 8a50582a..e35ab522 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -589,9 +589,9 @@ newHasTest(domform,catOrAtt) == null isAtom and op = 'Join => and/[newHasTest(domform,x) for x in rest catOrAtt] -- we will refuse to say yes for 'Cat has Cat' ---GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) +--getConstructorKindFromDB opOf domform = "category" => throwKeyedMsg("S2IS0025",NIL) -- on second thoughts we won't! - GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => + getConstructorKindFromDB opOf domform = "category" => domform = catOrAtt => 'T for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat return evalCond cond where diff --git a/src/interp/parse.boot b/src/interp/parse.boot index 9f5cb73e..91273ced 100644 --- a/src/interp/parse.boot +++ b/src/interp/parse.boot @@ -247,7 +247,7 @@ parseHas [x,y] == [["SIGNATURE",op,map]] y is ["Join",:u] => "append"/[fn z for z in u] y is ["CATEGORY",:u] => "append"/[fn z for z in u] - kk:= GETDATABASE(opOf y,'CONSTRUCTORKIND) + kk:= getConstructorKindFromDB opOf y kk = "domain" or kk = "category" => [makeNonAtomic y] y is ["ATTRIBUTE",:.] => [y] y is ["SIGNATURE",:.] => [y] diff --git a/src/interp/setvars.boot b/src/interp/setvars.boot index 35193b48..fe6393d9 100644 --- a/src/interp/setvars.boot +++ b/src/interp/setvars.boot @@ -554,7 +554,7 @@ setExposeAddConstr arg == x := unabbrev x if PAIRP x then x := QCAR x -- if the constructor is known, we know what type it is - null GETDATABASE(x,'CONSTRUCTORKIND) => + null getConstructorKindFromDB x => sayKeyedMsg("S2IZ0049J",[x]) member(x,$localExposureData.1) => sayKeyedMsg("S2IZ0049K",[x,$interpreterFrameName]) @@ -621,7 +621,7 @@ setExposeDropConstr arg == x := unabbrev x if PAIRP x then x := QCAR x -- if the constructor is known, we know what type it is - null GETDATABASE(x,'CONSTRUCTORKIND) => + null getConstructorKindFromDB x => sayKeyedMsg("S2IZ0049J",[x]) member(x,$localExposureData.2) => sayKeyedMsg("S2IZ0049O",[x,$interpreterFrameName]) diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot index 484e171c..8d031b8c 100644 --- a/src/interp/spad-parser.boot +++ b/src/interp/spad-parser.boot @@ -59,8 +59,8 @@ parseSpadFile sourceFile == FILE_-CLOSED : local := false -- current stream closed? $OutputStream := MAKE_-SYNONYM_-STREAM "*STANDARD-OUTPUT*" -- noise to standard output - -- we need tell the post-parsing transformers that we're compiling - -- because few parse forms have slightly different representations + -- we need to tell the post-parsing transformers that we're compiling + -- Spad because few parse forms have slightly different representations -- depending on whether we are interpreter mode or compiler mode. savedInteractiveMode := $InteractiveMode $InteractiveMode := false diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index c79941ea..862edb65 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -538,7 +538,7 @@ $EmptyString == '"" ++ The empty vector constant $EmptyVector == - VECTOR() + ["VECTOR"] ++ A symbol denoting failure $failure == diff --git a/src/interp/template.boot b/src/interp/template.boot index 352c02f1..42913388 100644 --- a/src/interp/template.boot +++ b/src/interp/template.boot @@ -202,7 +202,7 @@ mkSigPredVectors() == $predVectorFrontier:= 1 --slot 0 in vector will be vacant $predVector:= newShell 100 for nam in allConstructors() | - null (GETDATABASE(nam, 'CONSTRUCTORKIND) = 'package) repeat + getConstuctorKindFromDB nam ^= "package" repeat for [op,:sigList] in GETDATABASE(nam,'OPERATIONALIST) repeat for [sig,:r] in sigList repeat addConsDB sig diff --git a/src/interp/trace.boot b/src/interp/trace.boot index b6ba828b..fa173b58 100644 --- a/src/interp/trace.boot +++ b/src/interp/trace.boot @@ -274,7 +274,7 @@ removeOption(op,options) == domainToGenvar x == $doNotAddEmptyModeIfTrue: local:= true - (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain => + (y:= unabbrevAndLoad x) and getConstructorKindFromDB opOf y = "domain" => g:= genDomainTraceName y setDynamicBinding(g,evalDomain y) g diff --git a/src/interp/types.boot b/src/interp/types.boot index 43d99bd6..0a7898a6 100644 --- a/src/interp/types.boot +++ b/src/interp/types.boot @@ -46,13 +46,19 @@ import '"boot-pkg" %Thing <=> true %Sequence <=> SEQUENCE +%Maybe a <=> null or a + --% Data structures for the compiler %Form <=> NUMBER or %Symbol or %String or CONS -- input syntax form %Env <=> %List -- compiling env %Mode <=> %Symbol or %String or %List -- type of forms %Code <=> %Form -- generated code -%Triple <=> %List -- form + type + env +%Triple <=> -- form + type + env + cons(%Code,cons(%Mode,cons(%Env,null))) %Modemap <=> %List -- modemap +%ConstructorKind <=> -- kind of ctor instances + MEMBER("category","domain","package") + %Shell <=> SIMPLE_-VECTOR -- constructor instantiation diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index a9311920..3d65de7a 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -96,7 +96,7 @@ compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == $functorForm:= $form:= [$op,:argl] $globalImportStack := [markKillAll x for x in rest $functorForm for typ in rest signature' - | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] + | getConstructorKindFromDB opOf typ = "category"] if null first signature' then signature':= modemap2Signature getModemap($form,$e) target:= first signature' |