diff options
| -rw-r--r-- | src/interp/c-util.boot | 4 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 10 | ||||
| -rw-r--r-- | src/interp/database.boot | 17 | ||||
| -rw-r--r-- | src/interp/define.boot | 6 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 29 |
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) |