aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2013-06-01 07:35:18 +0000
committerdos-reis <gdr@axiomatics.org>2013-06-01 07:35:18 +0000
commit64aeafac79d72f440b6546bae91583e6efd6b674 (patch)
treede419861e4625d20bc0e1c68f5db1590a50708b9 /src
parentde3a19c35df30298d323c5882e39931f329ea29e (diff)
downloadopen-axiom-64aeafac79d72f440b6546bae91583e6efd6b674.tar.gz
Support --output in compiler, for bootstrapping stage.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog23
-rw-r--r--src/algebra/Makefile.am24
-rw-r--r--src/algebra/Makefile.in24
-rw-r--r--src/boot/ast.boot6
-rw-r--r--src/boot/strap/ast.clisp23
-rw-r--r--src/boot/strap/parser.clisp4
-rw-r--r--src/boot/strap/tokens.clisp12
-rw-r--r--src/boot/strap/translator.clisp2
-rw-r--r--src/include/cfuns.h6
-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
-rw-r--r--src/lib/cfuns-c.c67
-rw-r--r--src/lisp/core.lisp.in21
17 files changed, 200 insertions, 116 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 8ef8b738..cba7ca1c 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,26 @@
+2013-06-01 Gabriel Dos Reis <gdr@integrable-solutions.net>
+
+ Support --output in compiler, for bootstrapping stage.
+ * lisp/core.lisp.in (directoryEntries): New.
+ * interp/lisplib.boot (compDefineLisplib): Tidy. Honor --output.
+ (initializeLisplib): Rewrite.
+ (lisplibDoRename): Likewise.
+ * interp/nlib.lisp (RSHUT): Tidy.
+ * interp/define.boot (getOutputPath): New.
+ (compDefineFunctor): Use it.
+ (compDefineCategory): Likewise.
+ * interp/c-util.boot (%Libstream): Add field for output pathname.
+ (dbOutputPath): New accessor.
+ (moveLibdirByCopy): New.
+ * include/cfuns.h (oa_acquire_temporary_pathname): Declare.
+ (oa_release_temporary_pathname): Likewise.
+ * lib/cfuns-c.c: Implement them.
+ * interp/sys-os.boot: Define acquireTemporaryPathname.
+ * boot/ast.boot (lispKey): New.
+ (bfApplication): Use it.
+ (bfExpandKeys): Likewise.
+ * algebra/Makefile.am: Simplify bootstrapping rules.
+
2013-05-31 Gabriel Dos Reis <gdr@integrable-solutions.net>
* interp/nlib.lisp (getIndexIOStreamAndTable): New.
diff --git a/src/algebra/Makefile.am b/src/algebra/Makefile.am
index ae00743b..3c404d0d 100644
--- a/src/algebra/Makefile.am
+++ b/src/algebra/Makefile.am
@@ -1007,31 +1007,17 @@ strap-0 strap-1 strap-2:
.PRECIOUS: strap-0/%.$(FASLEXT)
strap-0/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-0
- $(BOOTSTRAP) --sysalg=strap-0 --bootstrap $< \
- && cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-0/$*.lsp; fi && \
- rm -rf $*.NRLIB
+ $(BOOTSTRAP) --sysalg=strap-0 --output=$@ --bootstrap $<
.PRECIOUS: strap-1/%.$(FASLEXT)
strap-1/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-1
- $(BOOTSTRAP) --strap=strap-0 --sysalg=strap-1 --optimize=3 $< && \
- cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test -d $*-.NRLIB; then cp $*-.NRLIB/code.$(FASLEXT) \
- strap-1/$*-.$(FASLEXT); else : ; fi && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-1/$*.lsp; fi && \
- rm -rf $*.NRLIB $*-.NRLIB
+ $(BOOTSTRAP) --strap=strap-0 --sysalg=strap-1 \
+ --output=$@ --optimize=3 $<
.PRECIOUS: strap-2/%.$(FASLEXT)
strap-2/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-2
- $(BOOTSTRAP) --strap=strap-1 --sysalg=strap-2 --optimize=3 $< && \
- cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test -d $*-.NRLIB; then cp $*-.NRLIB/code.$(FASLEXT) \
- strap-2/$*-.$(FASLEXT); else : ; fi && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-2/$*.lsp; fi && \
- rm -rf $*.NRLIB $*-.NRLIB
+ $(BOOTSTRAP) --strap=strap-1 --sysalg=strap-2 \
+ --output=$@ --optimize=3 $<
SPADFILES= \
diff --git a/src/algebra/Makefile.in b/src/algebra/Makefile.in
index 5fd78ad2..785aaa17 100644
--- a/src/algebra/Makefile.in
+++ b/src/algebra/Makefile.in
@@ -2512,31 +2512,17 @@ strap-0 strap-1 strap-2:
.PRECIOUS: strap-0/%.$(FASLEXT)
strap-0/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-0
- $(BOOTSTRAP) --sysalg=strap-0 --bootstrap $< \
- && cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-0/$*.lsp; fi && \
- rm -rf $*.NRLIB
+ $(BOOTSTRAP) --sysalg=strap-0 --output=$@ --bootstrap $<
.PRECIOUS: strap-1/%.$(FASLEXT)
strap-1/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-1
- $(BOOTSTRAP) --strap=strap-0 --sysalg=strap-1 --optimize=3 $< && \
- cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test -d $*-.NRLIB; then cp $*-.NRLIB/code.$(FASLEXT) \
- strap-1/$*-.$(FASLEXT); else : ; fi && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-1/$*.lsp; fi && \
- rm -rf $*.NRLIB $*-.NRLIB
+ $(BOOTSTRAP) --strap=strap-0 --sysalg=strap-1 \
+ --output=$@ --optimize=3 $<
.PRECIOUS: strap-2/%.$(FASLEXT)
strap-2/%.$(FASLEXT): %.spad initdb.$(FASLEXT) | strap-2
- $(BOOTSTRAP) --strap=strap-1 --sysalg=strap-2 --optimize=3 $< && \
- cp $*.NRLIB/code.$(FASLEXT) $@ && \
- if test -d $*-.NRLIB; then cp $*-.NRLIB/code.$(FASLEXT) \
- strap-2/$*-.$(FASLEXT); else : ; fi && \
- if test x@oa_keep_files@ = xyes; then \
- cp $*.NRLIB/code.lsp strap-2/$*.lsp; fi && \
- rm -rf $*.NRLIB $*-.NRLIB
+ $(BOOTSTRAP) --strap=strap-1 --sysalg=strap-2 \
+ --output=$@ --optimize=3 $<
# The root of the category hierarchy is the Type category.
# We require the basic integer domains are available at stage 2 of
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index dfffa58a..14259ebd 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -811,16 +811,20 @@ bfHas(expr,prop) ==
bfKeyArg(k,x) ==
['%Key,k,x]
+lispKey k ==
+ makeSymbol(stringUpcase symbolName k,'"KEYWORD")
+
bfExpandKeys l ==
args := nil
while l is [a,:l] repeat
a is ['%Key,k,x] =>
- args := [x,makeSymbol(stringUpcase symbolName k,'"KEYWORD"),:args]
+ args := [x,lispKey k,:args]
args := [a,:args]
reverse! args
bfApplication(bfop, bfarg) ==
bfTupleP bfarg => [bfop,:bfExpandKeys rest bfarg]
+ bfarg is ['%Key,k,v] => [bfop,lispKey k,v]
[bfop,bfarg]
-- returns the meaning of x in the appropriate Boot dialect.
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index a51ee1c2..6cb05e57 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1223,6 +1223,8 @@
(DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|))
+(DEFUN |lispKey| (|k|) (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD"))
+
(DEFUN |bfExpandKeys| (|l|)
(LET* (|x| |ISTMP#2| |k| |ISTMP#1| |a| |args|)
(PROGN
@@ -1241,17 +1243,24 @@
(SETQ |ISTMP#2| (CDR |ISTMP#1|))
(AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
(PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
- (SETQ |args|
- (CONS |x|
- (CONS
- (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD")
- |args|))))
+ (SETQ |args| (CONS |x| (CONS (|lispKey| |k|) |args|))))
(T (SETQ |args| (CONS |a| |args|)))))
(|reverse!| |args|))))
(DEFUN |bfApplication| (|bfop| |bfarg|)
- (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|))))
- (T (LIST |bfop| |bfarg|))))
+ (LET* (|v| |ISTMP#2| |k| |ISTMP#1|)
+ (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|))))
+ ((AND (CONSP |bfarg|) (EQ (CAR |bfarg|) '|%Key|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |bfarg|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |k| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |v| (CAR |ISTMP#2|)) T))))))
+ (LIST |bfop| (|lispKey| |k|) |v|))
+ (T (LIST |bfop| |bfarg|)))))
(DEFUN |bfReName| (|x|)
(LET* (|a|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index b6c95484..985611d3 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -388,7 +388,7 @@
(COND (|done| (RETURN NIL))
(T
(SETQ |found|
- (LET ((#1=#:G725
+ (LET ((#1=#:G720
(CATCH :OPEN-AXIOM-CATCH-POINT
(APPLY |f| |ps| NIL))))
(COND
@@ -1371,7 +1371,7 @@
(SETQ |op| (|enclosingFunction| (|parserLoadUnit| |ps|)))
(SETQ |varno| (|parserGensymSequenceNumber| |ps|))
(UNWIND-PROTECT
- (LET ((#1=#:G726
+ (LET ((#1=#:G721
(CATCH :OPEN-AXIOM-CATCH-POINT
(PROGN
(SETF (|enclosingFunction| (|parserLoadUnit| |ps|)) NIL)
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 3c0dd848..afd689ad 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -84,10 +84,10 @@
(LET* (|s|)
(COND
((SETQ |s|
- (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
(LET ((|bfVar#1| NIL))
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G725 |k| |v|)
+ (MULTIPLE-VALUE-BIND (#2=#:G720 |k| |v|)
(#1#)
(COND ((NOT #2#) (RETURN |bfVar#1|))
(T
@@ -138,9 +138,9 @@
(COND ((> |i| 255) (RETURN NIL)) (T (SETF (ELT |a| |i|) |b|)))
(SETQ |i| (+ |i| 1))))
|a|))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G726 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G721 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G727 |s| #:G728)
+ (MULTIPLE-VALUE-BIND (#2=#:G722 |s| #:G723)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
|d|)))
@@ -154,9 +154,9 @@
(LET ((|i| 0))
(LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
(SETQ |i| (+ |i| 1))))
- (WITH-HASH-TABLE-ITERATOR (#1=#:G729 |shoeKeyTable|)
+ (WITH-HASH-TABLE-ITERATOR (#1=#:G724 |shoeKeyTable|)
(LOOP
- (MULTIPLE-VALUE-BIND (#2=#:G730 |k| #:G731)
+ (MULTIPLE-VALUE-BIND (#2=#:G725 |k| #:G726)
(#1#)
(COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
(T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 4cc7a1bb..d3f85676 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -416,7 +416,7 @@
(SETQ |ps| (|makeParserState| |toks|))
(|bpFirstTok| |ps|)
(SETQ |found|
- (LET ((#1=#:G734
+ (LET ((#1=#:G729
(CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|))))
(COND
((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
diff --git a/src/include/cfuns.h b/src/include/cfuns.h
index d3a82fec..52a57e55 100644
--- a/src/include/cfuns.h
+++ b/src/include/cfuns.h
@@ -1,7 +1,7 @@
/*
- Copyright (C) 1991-2002, The Numerical ALgorithms Group Ltd.
+ Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd.
All rights reserved.
- Copyright (C) 2007-2010, Gabriel Dos Reis.
+ Copyright (C) 2007-2013, Gabriel Dos Reis.
All rights resrved.
Redistribution and use in source and binary forms, with or without
@@ -50,6 +50,8 @@ OPENAXIOM_C_EXPORT int copyEnvValue(char*, char*);
OPENAXIOM_C_EXPORT int oa_chdir(const char*);
OPENAXIOM_C_EXPORT int oa_unlink(const char*);
OPENAXIOM_C_EXPORT int oa_rename(const char*, const char*);
+OPENAXIOM_C_EXPORT const char* oa_acquire_temporary_pathname();
+OPENAXIOM_C_EXPORT void oa_release_temporary_pathname(const char*);
OPENAXIOM_C_EXPORT int oa_mkdir(const char*);
OPENAXIOM_C_EXPORT int oa_system(const char*);
OPENAXIOM_C_EXPORT char* oa_getenv(const char*);
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
diff --git a/src/lib/cfuns-c.c b/src/lib/cfuns-c.c
index e95abbee..cac76b6c 100644
--- a/src/lib/cfuns-c.c
+++ b/src/lib/cfuns-c.c
@@ -2,7 +2,7 @@
Copyright (C) 1991-2002, The Numerical Algorithms Group Ltd.
All rights reserved.
- Copyright (C) 2007-2011, Gabriel Dos Reis.
+ Copyright (C) 2007-2013, Gabriel Dos Reis.
All rights reserved.
Redistribution and use in source and binary forms, with or without
@@ -37,6 +37,7 @@
#include "openaxiom-c-macros.h"
#include <errno.h>
+#include <limits.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <stdlib.h>
@@ -47,7 +48,7 @@
#include <unistd.h>
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
# include <windows.h>
#else
# include <dirent.h>
@@ -103,7 +104,7 @@ addtopath(char *dir)
static inline int
openaxiom_is_path_separator(char c)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return c == '\\' || c == '/';
#else
return c == '/';
@@ -256,7 +257,7 @@ writeablep(const char *path)
the MinGW/MSYS port appears to use MS' StrDup as the real
worker. Consequently, the guarantee that the the string can
free'd no longer holds. We have to use MS's LocalFree. */
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
LocalFree(dir);
#else
free(dir);
@@ -338,7 +339,7 @@ OPENAXIOM_C_EXPORT int
std_stream_is_terminal(int fd)
{
assert(fd > -1 && fd < 3);
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
DWORD handle;
switch (fd) {
case 0: handle = STD_INPUT_HANDLE; break;
@@ -369,11 +370,11 @@ std_stream_is_terminal(int fd)
OPENAXIOM_C_EXPORT int
oa_chdir(const char* path)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return SetCurrentDirectory(path) ? 0 : -1;
#else
return chdir(path);
-#endif /* __WIN32__ */
+#endif /* OPENAXIOM_MS_WINDOWS_HOST */
}
@@ -394,7 +395,7 @@ oa_unlink(const char* path)
{
const char* curdir;
int status = -1;
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
WIN32_FIND_DATA findData;
HANDLE walkHandle;
@@ -478,7 +479,7 @@ oa_unlink(const char* path)
status = -1;
else
status = 0;
-#endif /* __WIN32__ */
+#endif /* OPENAXIOM_MS_WINDOWS_HOST */
sortie:
oa_chdir(curdir);
@@ -486,11 +487,37 @@ oa_unlink(const char* path)
return status;
}
+OPENAXIOM_C_EXPORT const char*
+oa_acquire_temporary_pathname() {
+#if OPENAXIOM_MS_WINDOWS_HOST
+ char buf[MAX_PATH];
+ const char* tmpdir = oa_get_tmpdir();
+ auto n = GetTempFileName(tmpdir, "oa-", rand() % SHORT_MAX, buf);
+ free(tmpdir);
+ if (n == 0) {
+ perror("oa_acquire_temporary_pathname");
+ exit(1);
+ }
+ return strdup(buf);
+#elif HAVE_DECL_TEMPNAM
+ return tempnam(oa_get_tmpdir(), "oa-");
+#else
+ std::string s = "oa-" + std::to_string(rand());
+ return strdup(s.c_str());
+#endif
+}
+
+OPENAXIOM_C_EXPORT void
+oa_release_temporary_pathname(const char* s)
+{
+ free(const_cast<char*>(s)); // yuck!
+}
+
/* Rename a file or directory. */
OPENAXIOM_C_EXPORT int
oa_rename(const char* old_path, const char* new_path)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return MoveFile(old_path, new_path) ? 0 : -1;
#else
return rename(old_path, new_path);
@@ -502,7 +529,7 @@ oa_rename(const char* old_path, const char* new_path)
OPENAXIOM_C_EXPORT int
oa_mkdir(const char* path)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return CreateDirectory(path, NULL) ? 0 : -1;
#else
# define DIRECTORY_PERM ((S_IRWXU|S_IRWXG|S_IRWXO) & ~(S_IWGRP|S_IWOTH))
@@ -521,7 +548,7 @@ oa_system(const char* cmd)
OPENAXIOM_C_EXPORT int
oa_getpid(void)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return GetCurrentProcessId();
#else
return getpid();
@@ -566,7 +593,7 @@ oa_strcat(const char* left, const char* right)
OPENAXIOM_C_EXPORT char*
oa_getenv(const char* var)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
#define BUFSIZE 128
char* buf = (char*) malloc(BUFSIZE);
int len = GetEnvironmentVariable(var, buf, BUFSIZE);
@@ -593,7 +620,7 @@ oa_getenv(const char* var)
OPENAXIOM_C_EXPORT int
oa_setenv(const char* var, const char* val)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return SetEnvironmentVariable(var, val);
#elif HAVE_DECL_SETENV
return !setenv(var, val, true);
@@ -615,7 +642,7 @@ oa_getcwd(void)
{
size_t bufsz = 256;
char* buf = (char*) malloc(bufsz);
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
DWORD n = GetCurrentDirectory(bufsz, buf);
if (n == 0) {
perror("oa_getcwd");
@@ -629,7 +656,7 @@ oa_getcwd(void)
}
}
return buf;
-#else /* __WIN32__ */
+#else /* OPENAXIOM_MS_WINDOWS_HOST */
errno = 0;
while (getcwd(buf,bufsz) == 0) {
if (errno == ERANGE) {
@@ -649,7 +676,7 @@ oa_getcwd(void)
OPENAXIOM_C_EXPORT int
oa_access_file_for_read(const char* path)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return GetFileAttributes(path) == INVALID_FILE_ATTRIBUTES ? -1 : 1;
#else
return access(path, R_OK);
@@ -660,7 +687,7 @@ oa_access_file_for_read(const char* path)
OPENAXIOM_C_EXPORT const char*
oa_get_tmpdir(void)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
char* buf;
/* First, probe. */
int bufsz = GetTempPath(0, NULL);
@@ -689,7 +716,7 @@ oa_get_tmpdir(void)
OPENAXIOM_C_EXPORT int
oa_copy_file(const char* src, const char* dst)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
return CopyFile(src,dst, /* bFailIfExists = */ 0) ? 0 : -1;
#else
#define OA_BUFSZ 512
@@ -767,7 +794,7 @@ oa_allocate_process_argv(Process* proc, int argc)
OPENAXIOM_C_EXPORT int
oa_spawn(Process* proc, SpawnFlags flags)
{
-#ifdef __WIN32__
+#ifdef OPENAXIOM_MS_WINDOWS_HOST
const char* path = NULL;
char* cmd_line = NULL;
int curpos = strlen(proc->argv[0]);
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index 38183144..4b72e76f 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -3,7 +3,7 @@
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
;;
-;; Copyright (C) 2007-2012, Gabriel Dos Reis.
+;; Copyright (C) 2007-2013, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
@@ -103,7 +103,8 @@
"$InputStream"
"$OutputStream"
"$ErrorStream"
-
+
+ "directoryEntries"
"inputBinaryFile"
"outputBinaryFile"
"inputTextFile"
@@ -551,6 +552,22 @@
(defparameter |$OutputStream| (make-synonym-stream '*standard-output*))
(defparameter |$ErrorStream| (make-synonym-stream '*standard-output*))
+;; Return all entries (except dot and dot-dot) in a directory
+(defun |directoryEntries| (dir &optional (pattern nil))
+ (let ((dirname (namestring dir)))
+ (cond (pattern (directory (concatenate 'string dirname "/" pattern)))
+ (t ;; list everything.
+ ;; There are two groups: those who do the right and obvious thing;
+ ;; and those that are anal-retentive about it.
+ #+(or :clisp :clozure :gcl)
+ (directory (concatenate 'string dirname "/*"))
+ #-(or :clisp :clozure :gcl)
+ (nunion
+ (directory (concatenate 'string dirname "/*"))
+ (directory (concatenate 'string dirname "/*.*")))))))
+
+
+
(defun |inputBinaryFile| (f)
(open f
:direction :input