Reduce dependencies on databases to catgeory.daase during algebra build

8 files changed, 77 insertions, 55 deletions

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index cd030a21..3c8bee94 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -53,6 +53,7 @@ module c_-util where
   dbInfovec: %Symbol -> %Maybe %FunctorData
   makeDefaultPackageParameters: %Database -> %List %Symbol
   makeDefaultPackageAbbreviation: %Database -> %Symbol
+  completeDefaultPackageParameters: %List %Symbol -> %List %Symbol
 
 --% Accessors of domain and category objects
 
@@ -237,11 +238,13 @@ $SetCategory ==
   
 --%
 
-makeDefaultPackageParameters db ==
-  parms := dbConstructorForm(db).args
+completeDefaultPackageParameters parms ==
   dollar := first setDifference('(S A B C D E F G H I),parms)
   [dollar,:parms]
 
+makeDefaultPackageParameters db ==
+  completeDefaultPackageParameters dbConstructorForm(db).args
+
 makeDefaultPackageAbbreviation db ==
   makeSymbol strconc(symbolName dbAbbreviation db,'"-")
 
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index ed761760..3e799091 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -640,18 +640,10 @@
 	      (operation
 	       (setq stream *operation-stream*)
 	       (setq data (gethash constructor *operation-hash*)))
-	      (constructormodemap
-	       (setq stream *interp-stream*)
-	       (when struct
-		 (setq data (|dbConstructorModemap| struct))))
 	      (constructorcategory
 	       (setq stream *interp-stream*)
 	       (when struct
 		 (setq data (|dbCategory| struct))))
-	      (operationalist
-	       (setq stream *interp-stream*)
-	       (when struct
-		 (setq data (|dbOperations| struct))))
 	      (modemaps
 	       (setq stream *interp-stream*)
 	       (when struct
@@ -712,12 +704,8 @@
 		 (setf (gethash constructor *operation-hash*) data))
 		(hascategory 
 		 (setf (gethash constructor |$HasCategoryTable|) data))
-		(constructormodemap 
-		 (setf (|dbConstructorModemap| struct) data))
 		(constructorcategory 
 		 (setf (|dbCategory| struct) data))
-		(operationalist
-		 (setf (|dbOperations| struct) data))
 		(modemaps  
 		 (setf (|dbModemaps| struct) data))
 		(object    
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 863def62..423cf547 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -106,8 +106,10 @@ getConstructorAncestorsFromDB ctor ==
 ++ of the constructor `form'. 
 getConstructorModemap: %Symbol -> %Mode
 getConstructorModemap ctor ==
-  mm := GETDATABASE(ctor, 'CONSTRUCTORMODEMAP) => mm
-  dbConstructorModemap loadDBIfNecessary constructorDB ctor
+  db := constructorDB ctor
+  if not dbBeingDefined? db and dbConstructorModemap db isnt [.,:.] then
+    loadDBIfNecessary db
+  dbConstructorModemap db
 
 getConstructorFormFromDB: %Symbol -> %Form
 getConstructorFormFromDB ctor ==
@@ -135,7 +137,10 @@ getConstructorDocumentationFromDB ctor ==
 
 getConstructorOperationsFromDB: %Symbol -> %List %List %Form
 getConstructorOperationsFromDB ctor ==
-  GETDATABASE(ctor,"OPERATIONALIST")
+  db := constructorDB ctor
+  if not dbBeingDefined? db and dbOperations db isnt [.,:.] then
+    loadDBIfNecessary db
+  dbOperations db
 
 getConstructorFullNameFromDB: %Symbol -> %Symbol
 getConstructorFullNameFromDB ctor ==
@@ -166,6 +171,7 @@ getConstructorParentsFromDB ctor ==
 
 getSuperDomainFromDB: %Symbol -> %Form
 getSuperDomainFromDB ctor ==
+  builtinConstructor? ctor => nil
   db := constructorDB ctor
   if not dbBeingDefined? db then
     loadDBIfNecessary db
@@ -811,33 +817,51 @@ makeInitialDB [form,kind,abbrev,srcfile] ==
   dbSourceFile(db) := srcfile
   setAutoLoadProperty form.op
   
-makeDefaultPackageForm db ==
-  [makeDefaultPackageName symbolName dbConstructor db,
-     :makeDefaultPackageParameters db]
-
-printInitdbInfo(path,dbfile) == main(path,dbfile) where
-  main(path,dbfile) ==
-    for x in parseSpadFile path repeat
-      x is ['DEF,lhs,.,rhs] =>
-        fn(lhs,rhs,fileNameString path,dbfile)
-      x is ["where",['DEF,lhs,.,rhs],:.] =>
-        fn(lhs,rhs,fileNameString path,dbfile)
-  fn(lhs,rhs,path,dbfile) ==
-    if lhs isnt [.,:.] then lhs := [lhs]
-    db := constructorDB lhs.op
-    db = nil => nil
-    args := [id for x in lhs.args]
-              where id() == (x is [":",x',:.] => x'; x)
-    data := [[lhs.op,:args],dbConstructorKind db,dbAbbreviation db,path]
-    prettyPrint(['makeInitialDB,quote data],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
-    data := [makeDefaultPackageForm db,'package,
-               makeDefaultPackageAbbreviation db,path]
-    prettyPrint(['makeInitialDB,quote data],dbfile)
-    writeNewline dbfile
+defaultPackageForm lhs ==
+  [makeDefaultPackageName symbolName lhs.op,
+     :completeDefaultPackageParameters lhs.args]
+
+++ If `decl` is a simple macro definition for `x, return
+++ the definiens.  Otherwise, return nil.
+simpleMacro?(x,decl) ==
+  not ident? x => nil
+  decl is ['MDEF,=x,=nil,body] => body
+  decl is ['DEF,[=x],[=nil],body] => body
+  nil
+
+++ If `x` is defined as a simple macro in `decl`, return the body
+++ of that definition.
+macroDefined?(x,decl) ==
+  decl is ['SEQ,:stmts,['exit,.,val]] =>
+    or/[body for stmt in stmts | body := simpleMacro?(x,stmt)]
+      or simpleMacro?(x,val)
+  simpleMacro?(x,decl)
+
+writeMinimalDB(lhs,rhs,path,dbfile) ==
+  if lhs isnt [.,:.] then lhs := [lhs]
+  db := constructorDB lhs.op
+  db = nil => nil
+  args := [id for x in lhs.args]
+            where id() == (x is [":",x',:.] => x'; x)
+  data := [[lhs.op,:args],dbConstructorKind db,dbAbbreviation db,path]
+  prettyPrint(['makeInitialDB,quote data],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
+  data := [defaultPackageForm lhs,'package,
+             makeDefaultPackageAbbreviation db,path]
+  prettyPrint(['makeInitialDB,quote data],dbfile)
+  writeNewline dbfile
+
+printInitdbInfo(path,dbfile) ==
+  for x in parseSpadFile path repeat
+    x is ['DEF,lhs,.,rhs] =>
+      writeMinimalDB(lhs,rhs,fileNameString path,dbfile)
+    x is ["where",['DEF,lhs,.,rhs],decl] =>
+      if ident? rhs and (body := macroDefined?(rhs,decl)) then
+        rhs := body
+      writeMinimalDB(lhs,rhs,fileNameString path,dbfile)
 
 printAllInitdbInfo(srcdir,dbfile) ==
   paths := DIRECTORY strconc(ensureTrailingSlash srcdir,'"*.spad")
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index 4d1675e7..7c2bf3df 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -690,6 +690,7 @@ getFunctionFromDomain(op,dc,args) ==
 isOpInDomain(opName,dom,nargs) ==
   -- returns true only if there is an op in the given domain with
   -- the given number of arguments
+  builtinFunctorName? dom.op => nil  -- FIXME
   mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
   mmList := subCopy(mmList,constructSubst dom)
   mmList = nil => nil
@@ -720,6 +721,7 @@ findCommonSigInDomain(opName,dom,nargs) ==
 
 findUniqueOpInDomain(op,opName,dom) ==
   -- return function named op in domain dom if unique, choose one if not
+  builtinFunctorName? dom.op => nil  -- FIXME
   mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
   mmList := subCopy(mmList,constructSubst dom)
   mmList = nil =>
@@ -1613,6 +1615,7 @@ hasSig(dom,foo,sig,SL) ==
   -- under substitution SL
   $domPvar: local := nil
   fun:= getConstructorAbbreviationFromDB dom.op =>
+    builtinFunctorName? dom.op => nil  -- FIXME
     S0:= constructSubst dom
     p := objectAssoc(foo,getConstructorOperationsFromDB dom.op) =>
       for [x,.,cond,.] in rest p until S isnt 'failed repeat
diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot
index eb9f984d..17d3d275 100644
--- a/src/interp/i-special.boot
+++ b/src/interp/i-special.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -1331,6 +1331,7 @@ upDEF t ==
 ++   <%Mode>: the type of the constant.
 ++   T: too many constants designated by `form'.
 constantInDomain?(form,domainForm) ==
+    builtinFunctorName? domainForm.op => nil
     opAlist := getConstructorOperationsFromDB domainForm.op
     key := opOf form
     entryList := [entry for (entry := [.,.,.,k]) in LASSOC(key,opAlist) 
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 2d02af64..a47ed36c 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2015, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -754,8 +754,9 @@ isFunctor x ==
     getConstructorKindFromDB op in '(domain package)
   u := get(op,'isFunctor,$CategoryFrame) => u
   builtinFunctorName? op => true
-  kind := getConstructorKindFromDB op
-  kind = nil or kind = 'category => false
+  db := constructorDB op or return false
+  dbConstructorKind db = 'category => false
+  loadDBIfNecessary db
   updateCategoryFrameForConstructor op
   get(op,'isFunctor,$CategoryFrame)
 
diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot
index 028a30b9..7e196d10 100644
--- a/src/interp/spad-parser.boot
+++ b/src/interp/spad-parser.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2007-2014, Gabriel Dos Reis.
+-- Copyright (C) 2007-2016, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -91,6 +91,10 @@ indentationLocation line ==
     tabChar? line.i => loc := 8 * (loc quo 8 + 1)
     return loc
 
+storeBlanks!(line,n) ==
+  #line >= n => nil
+  stringChar(line,n) := char " "
+
 skipIfBlock rs ==
   [n,:line] := z := preparseReadLine1 rs
   not string? line => z
diff --git a/src/interp/sys-driver.boot b/src/interp/sys-driver.boot
index 5abf11fd..010a6bab 100644
--- a/src/interp/sys-driver.boot
+++ b/src/interp/sys-driver.boot
@@ -1,4 +1,4 @@
--- Copyright (C) 2007-2014 Gabriel Dos Reis
+-- Copyright (C) 2007-2016 Gabriel Dos Reis
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -174,10 +174,8 @@ restart() ==
 
 initializeDatabases firstTime? ==
   getOptionValue "build-initdb" => nil
-  --initdb := getOptionValue "initial-db" => LOAD initdb
-  --FIXME: Ideally we should execute the previous line.  The next line is
-  --FIXME: a short-term stopgap until build dependencies are in place.
-  if initdb := getOptionValue "initial-db" then
+  initdb := getOptionValue "initial-db" =>
+    CATEGORYOPEN()
     LOAD initdb
   not firstTime? => openDatabases()
   fillDatabasesInCore()