aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot29
-rw-r--r--src/interp/define.boot12
-rw-r--r--src/interp/lisplib.boot49
-rw-r--r--src/interp/nlib.lisp6
-rw-r--r--src/interp/profile.boot4
-rw-r--r--src/interp/sys-os.boot4
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 18:17:07 +0000