From 64aeafac79d72f440b6546bae91583e6efd6b674 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 1 Jun 2013 07:35:18 +0000 Subject: Support --output in compiler, for bootstrapping stage. --- src/ChangeLog | 23 ++++++++++++++ src/algebra/Makefile.am | 24 +++------------ src/algebra/Makefile.in | 24 +++------------ src/boot/ast.boot | 6 +++- src/boot/strap/ast.clisp | 23 +++++++++----- src/boot/strap/parser.clisp | 4 +-- src/boot/strap/tokens.clisp | 12 ++++---- src/boot/strap/translator.clisp | 2 +- src/include/cfuns.h | 6 ++-- src/interp/c-util.boot | 29 ++++++++++-------- src/interp/define.boot | 12 ++++++++ src/interp/lisplib.boot | 49 ++++++++++++++++++------------ src/interp/nlib.lisp | 6 ++-- src/interp/profile.boot | 4 +-- src/interp/sys-os.boot | 4 +++ src/lib/cfuns-c.c | 67 +++++++++++++++++++++++++++++------------ src/lisp/core.lisp.in | 21 +++++++++++-- 17 files changed, 200 insertions(+), 116 deletions(-) (limited to 'src') 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 + + 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 * 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 +#include #include #include #include @@ -47,7 +48,7 @@ #include -#ifdef __WIN32__ +#ifdef OPENAXIOM_MS_WINDOWS_HOST # include #else # include @@ -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(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 -- cgit v1.2.3