aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog43
-rw-r--r--src/input/exsum.input.pamphlet2
-rw-r--r--src/input/mapleok.input.pamphlet36
-rw-r--r--src/interp/apply.boot18
-rw-r--r--src/interp/as.boot6
-rw-r--r--src/interp/br-con.boot6
-rw-r--r--src/interp/br-data.boot12
-rw-r--r--src/interp/br-op1.boot12
-rw-r--r--src/interp/br-op2.boot12
-rw-r--r--src/interp/br-prof.boot6
-rw-r--r--src/interp/br-saturn.boot6
-rw-r--r--src/interp/br-search.boot2
-rw-r--r--src/interp/br-util.boot2
-rw-r--r--src/interp/cattable.boot20
-rw-r--r--src/interp/clam.boot6
-rw-r--r--src/interp/clammed.boot6
-rw-r--r--src/interp/compiler.boot116
-rw-r--r--src/interp/construc.lisp2
-rw-r--r--src/interp/daase.lisp1275
-rw-r--r--src/interp/database.boot22
-rw-r--r--src/interp/define.boot6
-rw-r--r--src/interp/domain.lisp2
-rw-r--r--src/interp/format.boot4
-rw-r--r--src/interp/g-cndata.boot15
-rw-r--r--src/interp/g-util.boot2
-rw-r--r--src/interp/i-eval.boot4
-rw-r--r--src/interp/i-funsel.boot2
-rw-r--r--src/interp/i-resolv.boot2
-rw-r--r--src/interp/i-syscmd.boot10
-rw-r--r--src/interp/interop.boot4
-rw-r--r--src/interp/lisplib.boot16
-rw-r--r--src/interp/nrunfast.boot4
-rw-r--r--src/interp/parse.boot2
-rw-r--r--src/interp/setvars.boot4
-rw-r--r--src/interp/spad-parser.boot4
-rw-r--r--src/interp/sys-constants.boot2
-rw-r--r--src/interp/template.boot2
-rw-r--r--src/interp/trace.boot2
-rw-r--r--src/interp/types.boot8
-rw-r--r--src/interp/wi2.boot2
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'