aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/interp/c-util.boot4
-rw-r--r--src/interp/daase.lisp10
-rw-r--r--src/interp/database.boot17
-rw-r--r--src/interp/define.boot6
-rw-r--r--src/interp/lisplib.boot29
5 files changed, 36 insertions, 30 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 569e25d8..3f7dd18a 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -232,10 +232,6 @@ macro dbSubstituteQueries(db,x) ==
dbSubstituteAllQuantified(db,x) ==
applySubst([:dbQuerySubst db,:dbFormalSubst db],x)
-++ This predicate holds if this DB is for a category constructor.
-dbForCategory? db ==
- db ~= nil and dbConstructorKind db is 'category
-
--%
$SetCategory ==
'(SetCategory)
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index 86504bdb..d80cd961 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -209,15 +209,16 @@
parents ; browse.
users ; browse.
dependents ; browse.
- superdomain ; interp.
+ superdomain ; interp. overloaded field
+ ; for domain: base domain of a subdomain
+ ; for category: default package constructor
instantiations ; nil if mutable constructor
compiler-data ; holds compiler data when processing constructor
load-path ; full object path name, when loaded.
capsule-definitions ; capsule-level definitions
template ; for a category, this is the generic instance.
; for a functor, this is the template.
- lookup-function ; for a functor, lookup function. For category
- ; constructor, default package constructor.
+ lookup-function ; for a functor, lookup function.
optable ; for a functor, operation table.
) ; database structure
@@ -1009,7 +1010,8 @@
(finish-output out))
(setq ancestorspos nil))
(setq superpos
- (let ((super (|dbSuperDomain| struct)))
+ (let ((super (and (not (|dbForCategory?| struct))
+ (|dbSuperDomain| struct))))
(when super
(prog1 (file-position out)
(print (list (car super) (second super)) out)
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 091b2ff9..f7ba0516 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -41,10 +41,19 @@ import compat
import daase
namespace BOOT
+module database where
+ dbForCategory? : %Maybe %Database -> %Boolean
+
$getUnexposedOperations := true
$globalExposureGroupAlist := []
+--%
+
+++ This predicate holds if this DB is for a category constructor.
+dbForCategory? db ==
+ db ~= nil and dbConstructorKind db = 'category
+
--%
pathToDatabase name ==
@@ -74,13 +83,13 @@ makeConstructor(s,k == nil,a == nil) ==
++ Access to the default constructor of a category.
++ Note: Meaningful only for categories
-macro dbConstructorDefault db ==
- dbLookupFunction db
+macro dbDefaultPackage db ==
+ dbSuperDomain db
getCategoryConstructorDefault: %Symbol -> %Maybe %Symbol
getCategoryConstructorDefault ctor ==
builtinConstructor? ctor => nil
- dbConstructorDefault loadDBIfNecessary constructorDB ctor
+ dbDefaultPackage loadDBIfNecessary constructorDB ctor
getConstructorAbbreviationFromDB: %Symbol -> %Maybe %Symbol
getConstructorAbbreviationFromDB ctor ==
@@ -858,7 +867,7 @@ writeMinimalDB(lhs,rhs,path,dbfile) ==
writeNewline dbfile
-- If this is a category with defaults, write out the data for
-- associated package.
- dbConstructorKind db isnt 'category or rhs isnt ['add,:.] => nil
+ not dbForCategory? db or rhs isnt ['add,:.] => nil
data := [defaultPackageForm lhs,'package,
makeDefaultPackageAbbreviation db,path]
prettyPrint(['makeInitialDB,quote data],dbfile)
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 8f4cb615..ed1a565c 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1002,7 +1002,7 @@ mkExportFromDescription desc ==
mkCategoryPackage(db,cat,def,e) ==
[op,:argl] := dbConstructorForm db
packageName:= makeDefaultPackageName symbolName op
- dbConstructorDefault(db) := packageName
+ dbDefaultPackage(db) := packageName
packageAbb := makeDefaultPackageAbbreviation db
$options:local := []
-- This stops the next line from becoming confused
@@ -2134,7 +2134,7 @@ compileConstructor1(db,form:=[fn,[key,vl,:bodyl]]) ==
-- fn is the name of some category/domain/package constructor;
-- we will cache all of its values on $ConstructorCache with reference
-- counts
- dbConstructorKind db = 'category =>
+ dbForCategory? db =>
first compAndDefine(db,[[fn,['%slam,vl,:bodyl]]])
dbInstanceCache db = nil =>
first backendCompile(db,[[fn,['%lambda,vl,:bodyl]]])
@@ -2491,7 +2491,7 @@ compForMode(x,m,e) ==
$bootStrapMode and m = $Category =>
op := opOf x
ident? op and (db := constructorDB op) =>
- dbConstructorKind db = "category" => [x,m,e]
+ dbForCategory? db => [x,m,e]
nil
comp(x,m,e)
comp(x,m,e)
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 30803167..3ab82e64 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -470,11 +470,11 @@ writeLoadInfo(db,info,key,prop) ==
printBackendStmt(dbLibstream db,expandToVMForm insn)
writeTemplate db ==
- dbConstructorKind db = 'category => nil
+ dbForCategory? db => nil
writeLoadInfo(db,dbTemplate db,'template,'dbTemplate)
writeOperationTable db ==
- dbConstructorKind db = 'category => nil
+ dbForCategory? db => nil
writeLoadInfo(db,dbOperationTable db,'optable,'dbOperationTable)
writeLookupFunction db ==
@@ -482,10 +482,9 @@ writeLookupFunction db ==
writeLoadInfo(db,quote fun,'lookupFunction,'dbLookupFunction)
nil
-writeCategoryDefault db ==
- pac := dbConstructorDefault db
- insn := ['%store,['dbConstructorDefault,mkCtorDBForm db],quote pac]
- printBackendStmt(dbLibstream db,expandToVMForm insn)
+writeDefaultPackage db ==
+ pac := dbDefaultPackage db or return nil
+ writeLoadInfo(db,quote pac,'defaultPackage,'dbDefaultPackage)
writeKind db ==
writeInfo(db,dbConstructorKind db,'constructorKind,'dbConstructorKind)
@@ -537,7 +536,7 @@ writePrincipals db ==
writeInfo(db,dbPrincipals db,'parents,'dbPrincipals)
writeCapsuleLevelDefinitions db ==
- dbConstructorKind db = 'category => nil -- categories don't have capsules
+ dbForCategory? db => nil -- categories don't have capsules
writeLoadInfo(db,quote dbCapsuleDefinitions db,
'signaturesAndLocals,'dbCapsuleDefinitions)
@@ -553,27 +552,27 @@ leaveIfErrors(libName,kind) ==
finalizeLisplib(db,libName) ==
form := dbConstructorForm db
writeTemplate db
- do -- shared slot; careful.
- dbConstructorKind db = 'category => writeCategoryDefault db
- writeLookupFunction db
+ writeLookupFunction db
writeConstructorForm db
writeKind db
writeConstructorModemap db
writeDualSignature db
-- set to target of dbConstructorModemap for package/domain constructors;
-- to the right-hand sides (the definition) for category constructors
- if dbConstructorKind db = 'category then
+ if dbForCategory? db then
writeCategory db
writeSourceFile db
writeInteractiveModemaps db
opsAndAtts :=
- dbConstructorKind db = 'category => getCategoryOpsAndAtts db
+ dbForCategory? db => getCategoryOpsAndAtts db
getFunctorOpsAndAtts db
writeOperations(db,first opsAndAtts)
- if dbConstructorKind db = 'category then
+ if dbForCategory? db then
$NRTslot1PredicateList : local := []
genInitialAttributeAlist(db,rest opsAndAtts)
- writeSuperDomain db
+ if dbForCategory? db -- careful: overloaded field.
+ then writeDefaultPackage db
+ else writeSuperDomain db
writeOperationTable db
writeCapsuleLevelDefinitions db
writeAttributes db
@@ -756,7 +755,7 @@ isFunctor x ==
u := get(op,'isFunctor,$CategoryFrame) => u
builtinFunctorName? op => true
db := constructorDB op or return false
- dbConstructorKind db = 'category => false
+ dbForCategory? db => false
loadDBIfNecessary db
updateCategoryFrameForConstructor op
get(op,'isFunctor,$CategoryFrame)