From e27fcd9e3bcb44ae147bbea76abaeba4e3876b89 Mon Sep 17 00:00:00 2001
From: Gabriel Dos Reis <gdr@axiomatics.org>
Date: Tue, 12 Jan 2016 20:59:14 -0800
Subject: Share more code between various parts of the compiler.

---
 src/boot/tokens.boot     |  1 +
 src/interp/c-util.boot   | 10 ++++++++++
 src/interp/database.boot | 19 ++++++++++++++++---
 src/interp/define.boot   |  6 +++---
 4 files changed, 30 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index c2d0c578..3a444433 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -283,6 +283,7 @@ for i in [ _
   ["false",        'NIL]   , _
   ["fifth",      "FIFTH"]  , _
   ["first",        "CAR"]  , _
+  ["fileNameString", "FILE-NAMESTRING" ] , _
   ["filePath",  "PATHNAME"] , _
   ["filePath?", "PATHNAMEP"] , _
   ["filePathDirectory", "PATHNAME-DIRECTORY"] , _
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 9e56bb12..cd030a21 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -51,6 +51,8 @@ module c_-util where
   currentDB: %Env -> %Maybe %Database
   -- functor data manipulation
   dbInfovec: %Symbol -> %Maybe %FunctorData
+  makeDefaultPackageParameters: %Database -> %List %Symbol
+  makeDefaultPackageAbbreviation: %Database -> %Symbol
 
 --% Accessors of domain and category objects
 
@@ -235,6 +237,14 @@ $SetCategory ==
   
 --%
 
+makeDefaultPackageParameters db ==
+  parms := dbConstructorForm(db).args
+  dollar := first setDifference('(S A B C D E F G H I),parms)
+  [dollar,:parms]
+
+makeDefaultPackageAbbreviation db ==
+  makeSymbol strconc(symbolName dbAbbreviation db,'"-")
+
 dbInfovec name ==
   getConstructorKindFromDB name is "category" => nil
   loadLibIfNotLoaded(name)
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 01034700..aa460332 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -808,12 +808,18 @@ 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,:.] => fn(lhs,path,dbfile)
-      x is ["where",['DEF,lhs,:.],:.] => fn(lhs,path,dbfile)
-  fn(lhs,path,dbfile) ==
+      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
@@ -822,6 +828,13 @@ printInitdbInfo(path,dbfile) == main(path,dbfile) where
     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
 
 printAllInitdbInfo(srcdir,dbfile) ==
   paths := DIRECTORY strconc(ensureTrailingSlash srcdir,'"*.spad")
diff --git a/src/interp/define.boot b/src/interp/define.boot
index de919848..a1c1765f 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1023,14 +1023,14 @@ mkCategoryPackage(db,cat,def,e) ==
   [op,:argl] := dbConstructorForm db
   packageName:= makeDefaultPackageName symbolName op
   dbConstructorDefault(db) := packageName
-  packageAbb := makeSymbol strconc(symbolName dbAbbreviation db,'"-")
+  packageAbb := makeDefaultPackageAbbreviation db
   $options:local := []
   -- This stops the next line from becoming confused
   abbreviationsSpad2Cmd ['package,packageAbb,packageName]
   -- This is a little odd, but the parser insists on calling
   -- domains, rather than packages
-  nameForDollar := first setDifference('(S A B C D E F G H I),argl)
-  packageArgl := [nameForDollar,:argl]
+  packageArgl := makeDefaultPackageParameters db
+  nameForDollar := first packageArgl
   capsuleDefAlist := fn(def,nil) where fn(x,oplist) ==
     x isnt [.,:.] => oplist
     x is ['DEF,y,:.] => [opOf y,:oplist]
-- 
cgit v1.2.3