Support --output in compiler, for bootstrapping stage.

6 files changed, 67 insertions, 37 deletions

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 12aa3654..6d7161c4 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -135,28 +135,21 @@ macro domainData d ==
   domainRef(d,4)
 
 --%  
---% Constructor Compilation Data.
---% Operational Semantics:
---%    structure CompilationData ==
---%       Record(formalSubst: Substitution,implicits: List Identifier,
---%         byteList: List SingleInteger,
---%           usedEntities: VectorBuffer Pair(SourceEntity,Elaboration))
---%
-
 structure %CompilationData ==
   Record(subst: %Substitution,idata: %Substitution,bytes: List %Fixnum,
     shell: %Vector %Thing, items: %Buffer %Pair(%SourceEntity,%Code),
-      output: %OutputStream) with
+      lib: %Libstream,outpath: %Pathname) with
         cdSubstitution == (.subst)
         cdImplicits == (.idata)
         cdBytes == (.bytes)
         cdShell == (.shell)
         cdItems == (.items)
-        cdOutput == (.output)
+        cdLib == (.lib)
+        cdOutput == (.outpath)
 
 ++ Make a fresh compilation data structure.
 makeCompilationData() ==
-  mk%CompilationData(nil,nil,nil,nil,[nil,:0],nil)
+  mk%CompilationData(nil,nil,nil,nil,[nil,:0],nil,nil)
 
 ++ Subsitution that replaces parameters with formals.
 macro dbFormalSubst db ==
@@ -197,7 +190,7 @@ macro dbEntityCount db ==
   rest dbEntityBuffer db
 
 macro dbLibstream db ==
-  cdOutput dbCompilerData db
+  cdLib dbCompilerData db
 
 macro dbCodeStream db ==
   libCodeStream dbLibstream db
@@ -205,6 +198,9 @@ macro dbCodeStream db ==
 macro dbInsnStream db ==
   libInsnStream dbLibstream db
 
+macro dbOutputPath db ==
+  cdOutput dbCompilerData db
+
 ++ Return the existential substitution of `db'.
 dbQuerySubst db ==
   x := dbImplicitData db => first x
@@ -1765,3 +1761,12 @@ cleanParameterList! parms ==
 --% Other compiler artifact support
 --%
 
+moveLibdirByCopy lib ==
+  checkMkdir libDirname lib
+  for src in directoryEntries libStationaryDirname lib repeat
+    dst := makeFilePath(directory <- libDirname lib,
+             name <- filePathName src, type <- filePathType src)
+    copyFile(filePathString src,filePathString dst)
+  removeFile libStationaryDirname lib = 0 => libDirname lib
+  systemError ['"Could not remove stationary directory",
+                :bright libStationaryDirname lib]
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 585c5461..f3f70c72 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1201,6 +1201,7 @@ compDefineCategory(df,m,e,fal) ==
   dbClearForCompilation! db
   dbConstructorForm(db) := lhs
   dbCompilerData(db) := makeCompilationData()
+  dbOutputPath(db) := getOutputPath()
   $backend: local := function(x +-> printBackendStmt(dbLibstream db,x))
   try
     $insideFunctorIfTrue => compDefineCategory1(db,df,m,e,fal)
@@ -1442,6 +1443,16 @@ setDollarName(form,env) ==
 getDollarName env ==
   get('%compilerData,'%dollar,env)
 
+getOutputPath() ==
+  outfile := getOptionValue "output"
+  outfile = nil => nil
+  $insideCategoryPackageIfTrue =>
+    d := filePathDirectory outfile
+    n := strconc(filePathString filePathName outfile,'"-")
+    t := filePathType outfile
+    filePathString makeFilePath(directory <- d,name <- n,type <- t)
+  outfile
+
 compDefineFunctor(df,m,e,fal) ==
   $profileCompiler: local := true
   $profileAlist:    local := nil
@@ -1450,6 +1461,7 @@ compDefineFunctor(df,m,e,fal) ==
   dbClearForCompilation! db
   dbConstructorForm(db) := form
   dbCompilerData(db) := makeCompilationData()
+  dbOutputPath(db) := getOutputPath()
   $backend: local := function(x +-> printBackendStmt(dbLibstream db,x))
   try compDefineLisplib(db,df,m,e,fal,'compDefineFunctor1)
   finally dbCompilerData(db) := nil
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 74e54194..8dceae5d 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -410,22 +410,19 @@ compDefineLisplib(db,df:=["DEF",[op,:.],:.],m,e,fal,fn) ==
   if dbSourceFile db = nil then
     dbSourceFile(db) := namestring $editFile
   $compileDocumentation => compileDocumentation(db,libName)
-  sayMSG ['"   initializing ",$spadLibFT,:bright libName,
-    '"for",:bright op]
-  initializeLisplib(db,libName)
-  sayMSG ['"   compiling into ",$spadLibFT,:bright libName]
-  -- following guarantee's compiler output files get closed.
-  ok := false;
+  sayMSG ['"   initializing stationary directory for",:bright op]
+  lib := initializeLisplib(db,libName)
+  sayMSG ['"   compiling into ",:bright libStationaryDirname lib]
+  -- following guarantees compiler output files get closed.
   try
-    res:= FUNCALL(fn,db,df,m,e,fal)
+    res:= apply(fn,[db,df,m,e,fal])
     leaveIfErrors(libName,dbConstructorKind db)
     sayMSG ['"   finalizing ",$spadLibFT,:bright libName]
-    ok := finalizeLisplib(db,libName)
+    finalizeLisplib(db,libName)
+    RECOMPILE_-LIB_-FILE_-IF_-NECESSARY filePath libCodeStream lib
   finally
     RSHUT dbLibstream db
-  if ok then lisplibDoRename(libName)
-  filearg := makeFullFilePath [libName,$spadLibFT,nil]
-  RPACKFILE filearg
+  lisplibDoRename db
   sayMSG fillerSpaces(72,char "-")
   unloadOneConstructor op
   $buildingSystemAlgebra => res
@@ -444,11 +441,15 @@ compileDocumentation(db,libName) ==
   ['dummy, $EmptyMode, $e]
 
 initializeLisplib(db,libName) ==
-  removeFile makeFullFilePath [libName,'ERRORLIB,nil]
   resetErrorCount()
-  lib := writeLib(libName,'ERRORLIB)
-  dbLibstream(db) := lib
-  dbCodeStream(db) := outputTextFile strconc(libDirname lib,'"/code.lsp")
+  tmpdir := acquireTemporaryPathname()
+  removeFile tmpdir
+  checkMkdir tmpdir
+  [stream,:table] := getIndexIOStreamAndTable tmpdir
+  lsp := outputTextFile strconc(tmpdir,'"/code.lsp")
+  libdir := makeFullFilePath [libName,$spadLibFT,nil]
+  dbLibstream(db) := mk%Libstream('OUTPUT,libdir,table,stream,lsp,nil,tmpdir)
+
 
 mkCtorDBForm db ==
   ['constructorDB,quote dbConstructor db]
@@ -570,13 +571,23 @@ finalizeLisplib(db,libName) ==
   writeAncestors db
   if not $bootStrapMode then
     writeDocumentation(db,finalizeDocumentation db)
-  if $profileCompiler then profileWrite db
+  if $profileCompiler then profileWrite dbLibstream db
   leaveIfErrors(libName,dbConstructorKind db)
   true
 
-lisplibDoRename(libName) ==
-  _$REPLACE([libName,$spadLibFT,nil],
-    [libName,'ERRORLIB,nil])
+lisplibDoRename db ==
+  lib := dbLibstream db
+  output := dbOutputPath db =>
+    modpath := filePathString
+      makeFilePath(type <- $faslType,defaults <- filePath libCodeStream lib)
+    do
+      renameFile(modpath,output) = 0 => nil
+      copyFile(modpath,output)
+      removeFile libStationaryDirname lib
+    output
+  removeFile libDirname lib
+  renameFile(libStationaryDirname lib,libDirname lib) = 0 => libDirname lib
+  moveLibdirByCopy lib
  
 lisplibError(cname,fname,type,cn,fn,typ,error) ==
   sayMSG bright ['"  Illegal ",$spadLibFT]
diff --git a/src/interp/nlib.lisp b/src/interp/nlib.lisp
index 79c19b64..901928e1 100644
--- a/src/interp/nlib.lisp
+++ b/src/interp/nlib.lisp
@@ -162,11 +162,9 @@
 
 (defun rshut (rstream)
   (when (|libCodeStream| rstream)
-    (close (|libCodeStream| rstream))
-    (setf (|libCodeStream| rstream) nil))
+    (close (|libCodeStream| rstream)))
   (when (|libInsnStream| rstream)
-    (close (|libInsnStream| rstream))
-    (setf (|libInsnStream| rstream) nil))
+    (close (|libInsnStream| rstream)))
   (if (eq (|libIOMode| rstream) 'output)
       (write-indextable (|libIndexTable| rstream) (|libIndexStream| rstream)))
   (close (|libIndexStream| rstream)))
diff --git a/src/interp/profile.boot b/src/interp/profile.boot
index ff6577a9..a9b9d58e 100644
--- a/src/interp/profile.boot
+++ b/src/interp/profile.boot
@@ -40,8 +40,8 @@ namespace BOOT
 --$profileCompiler := true
 $profileAlist := nil
 
-profileWrite db ==  --called from finalizeLisplib
-  outStream := MAKE_-OUTSTREAM strconc(libDirname dbLibstream db,'"/info")
+profileWrite lib ==  --called from finalizeLisplib
+  outStream := outputTextFile strconc(libStationaryDirname lib,'"/info")
   SETQ(_*PRINT_-PRETTY_*, true)
   PRINT_-FULL(profileTran $profileAlist,outStream)
   SHUT outStream
diff --git a/src/interp/sys-os.boot b/src/interp/sys-os.boot
index d6c5e8e0..c4f7209d 100644
--- a/src/interp/sys-os.boot
+++ b/src/interp/sys-os.boot
@@ -49,6 +49,10 @@ loadSystemRuntimeCore()
 
 --% File System Support
 
+++ Get a temporary pathname
+import oa__acquire__temporary__pathname: () -> string for
+  acquireTemporaryPathname
+
 ++ Current working directory
 import oa__getcwd: () -> string for doGetWorkingDirectory