From 57dff7bf047f7364a8ffe27453d7f66de0b159f5 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 29 Aug 2011 17:32:37 +0000 Subject: * interp/lisplib.boot (laodIfNecessaryAndExists): Remove as unused. (loadLibIfnecessary): Fold definition into loadIfNecessary. (loadDB): New. (writeAttributes): Likewise. (finalizeLisplib): Use it. * interp/daase.lisp (MAKE-DATABASES): Fix SQUEEZE snafu. * interp/c-util.boot (extendsCategoryForm): Prefer existing translation of category definition to re-evaluation on the fly. --- src/ChangeLog | 11 +++++++++++ src/interp/c-util.boot | 9 ++++++++- src/interp/daase.lisp | 12 +++++++++--- src/interp/lisplib.boot | 27 +++++++++++++++++++-------- 4 files changed, 47 insertions(+), 12 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index 2adf1737..b75e7032 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,14 @@ +2011-08-29 Gabriel Dos Reis + + * interp/lisplib.boot (laodIfNecessaryAndExists): Remove as unused. + (loadLibIfnecessary): Fold definition into loadIfNecessary. + (loadDB): New. + (writeAttributes): Likewise. + (finalizeLisplib): Use it. + * interp/daase.lisp (MAKE-DATABASES): Fix SQUEEZE snafu. + * interp/c-util.boot (extendsCategoryForm): Prefer existing + translation of category definition to re-evaluation on the fly. + 2011-08-29 Gabriel Dos Reis * interp/lisplib.boot (loadLib): Remove deadcode. diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 24a3a041..ecc72c79 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -1027,7 +1027,14 @@ extendsCategoryForm(domain,form,form') == domain = "$" and form = $definition => extendsCategoryForm(domain, $currentCategoryBody, form') isCategoryForm(form,$EmptyEnvironment) => - --Constructs the associated vector + -- If we have an existing definition for this category, use it. + (db := constructorDB form.op) and loadDB db => + form' is ['SIGNATURE,op,types,:.] => assoc([op,args],dbOperations db) + form' is ['ATTRIBUTE,a] => assoc(a,dbAttributes db) + subst := pairList(dbConstructorForm(db).args,form.args) + or/[extendsCategoryForm(domain,applySubst(subst,cat),form') + for [cat,:.] in dbAncestors db] + -- Otherwise constructs the associated domain shell formVec:=(compMakeCategoryObject(form,$e)).expr --Must be $e to pick up locally bound domains form' is ["SIGNATURE",op,args,:.] => diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 678c390f..f4fad844 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -1242,11 +1242,17 @@ (when (setq dbstruct (|constructorDB| con)) (setf (|dbDualSignature| dbstruct) (cons nil (mapcar #'|categoryForm?| - (cddar (|dbConstructorModemap| dbstruct))))) - (when (and (|categoryForm?| con) + ;; The DBs have been munged by SQUEEZE + ;; in WRITE-BROWSEDB, WRITE-OPERATIONDB + ;; WRITE-CATEGORYDB. Unsqueeze a copy + ;; of them before checking for category + ;; form-ness. This is sick! FIXME. + (unsqueeze (copy-tree + (cddar (|dbConstructorModemap| dbstruct))))))) + (when (and (eq (|dbConstructorKind| dbstruct) '|category|) (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) (setq d (caar d)) - (when (= (length d) (length (|getConstructorForm| con))) + (when (= (length d) (length (|dbConstructorForm| dbstruct))) (format t " ~a has a default domain of ~a~%" con (car d)) (setf (|dbDefaultDomain| dbstruct) (car d))))))) ; note: genCategoryTable creates *ancestors-hash*. write-interpdb diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index de8a2cad..5d1446bc 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -339,18 +339,14 @@ loadLibNoUpdate(cname, libName, fullLibName) == stopTimingProcess 'load 'T -loadIfNecessary u == loadLibIfNecessary(u,true) - -loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) - -loadLibIfNecessary(u,mustExist) == +loadIfNecessary u == u is '$EmptyMode => u - cons? u => loadLibIfNecessary(first u,mustExist) + cons? u => loadIfNecessary first u value:= functionp(u) or macrop(u) => u property(u,'LOADED) => u loadLib u => u - null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) + not $InteractiveMode and (null (y:= getProplist(u,$CategoryFrame)) or (null symbolLassoc('isFunctor,y)) and (null symbolLAssoc('isCategory,y))) => y:= getConstructorKindFromDB u => y = "category" => @@ -358,6 +354,18 @@ loadLibIfNecessary(u,mustExist) == updateCategoryFrameForConstructor u throwKeyedMsg("S2IL0005",[u]) value + +++ Load the module associated with `db' and return the module's path. +loadDB db == + try + startTimingProcess 'load + dbBeingDefined? db => nil + ctor := dbConstructor db + property(ctor,'LOADED) => db --FIXME: this should be a db operation + lib := findModule ctor or return nil + loadModule(lib,ctor) + property(ctor,'LOADED) := lib + finally stopTimingProcess 'load convertOpAlist2compilerInfo(opalist) == "append"/[[formatSig(op,sig) for sig in siglist] @@ -548,6 +556,9 @@ writeSuperDomain(ctor,domPred,file) == writeOperations(ctor,ops,file) == writeInfo(ctor,ops,'operationAlist,'dbOperations,file) +writeAttributes(ctor,ats,file) == + writeInfo(ctor,ats,'attributes,'dbAttributes,file) + writeConstructorModemap(ctor,mm,file) == writeInfo(ctor,mm,'constructorModemap,'dbConstructorModemap,file) @@ -590,7 +601,7 @@ finalizeLisplib(ctor,libName) == lisplibWrite('"signaturesAndLocals", removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, $lisplibVariableAlist),$libFile) - lisplibWrite('"attributes",removeZeroOne dbAttributes db,$libFile) + writeAttributes(ctor,removeZeroOne dbAttributes db,$libFile) lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) lisplibWrite('"abbreviation",dbAbbreviation constructorDB ctor,$libFile) writePrincipals(ctor,removeZeroOne $lisplibParents,$libFile) -- cgit v1.2.3