Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Jan Moringen
asdf
Commits
f127ffb8
Commit
f127ffb8
authored
Mar 17, 2014
by
Robert P. Goldman
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Patch from Jean-Claude Beaudoin adding MKCL support.
parent
52bce047
Changes
23
Hide whitespace changes
Inline
Side-by-side
Showing
23 changed files
with
204 additions
and
63 deletions
+204
-63
Makefile
Makefile
+3
-0
bundle.lisp
bundle.lisp
+58
-17
footer.lisp
footer.lisp
+1
-1
source-registry.lisp
source-registry.lisp
+1
-1
test/dll-test.lisp
test/dll-test.lisp
+10
-0
test/dll-user.lisp
test/dll-user.lisp
+6
-0
test/hello-world-example.asd
test/hello-world-example.asd
+15
-0
test/hello.lisp
test/hello.lisp
+2
-1
test/make-hello-world.lisp
test/make-hello-world.lisp
+1
-1
test/monodll-1.lisp
test/monodll-1.lisp
+10
-0
test/monodll.lisp
test/monodll.lisp
+10
-0
test/script-support.lisp
test/script-support.lisp
+3
-0
test/test-bundle.script
test/test-bundle.script
+20
-0
test/test-program.script
test/test-program.script
+20
-2
uiop/common-lisp.lisp
uiop/common-lisp.lisp
+1
-1
uiop/driver.lisp
uiop/driver.lisp
+2
-0
uiop/filesystem.lisp
uiop/filesystem.lisp
+1
-1
uiop/image.lisp
uiop/image.lisp
+4
-3
uiop/lisp-build.lisp
uiop/lisp-build.lisp
+4
-3
uiop/os.lisp
uiop/os.lisp
+1
-1
uiop/pathname.lisp
uiop/pathname.lisp
+7
-6
uiop/run-program.lisp
uiop/run-program.lisp
+22
-23
uiop/utility.lisp
uiop/utility.lisp
+2
-2
No files found.
Makefile
View file @
f127ffb8
...
...
@@ -60,7 +60,9 @@ all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
# Making ASDF itself should be our first, default, target:
build/asdf.lisp
:
$(all_lisp)
mkdir
-p
build
rm
-f
$@
cat
$(all_lisp)
>
$@
chmod
-w
$@
# try to prevent accidental editing.
# This quickly locates such mistakes as unbalanced parentheses:
load
:
build/asdf.lisp
...
...
@@ -120,6 +122,7 @@ clean:
fi
;
\
done
rm
-rf
build/ LICENSE
test
/try-reloading-dependency.asd
test
/hello-world-example asdf.lisp
rm
-rf
test
/hello-world-example.exe
test
/mkcl_
*
.dll
# needed only on MS-Windows
rm
-rf
.pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/
# debian crap
${MAKE}
-C
doc clean
...
...
bundle.lisp
View file @
f127ffb8
...
...
@@ -26,9 +26,7 @@
((
build-args
:initarg
:args
:initform
nil
:accessor
bundle-op-build-args
)
(
name-suffix
:initarg
:name-suffix
:initform
nil
)
(
bundle-type
:initform
:no-output-file
:reader
bundle-type
)
#+
ecl
(
lisp-files
:initform
nil
:accessor
bundle-op-lisp-files
)
#+
mkcl
(
do-fasb
:initarg
:do-fasb
:initform
t
:reader
bundle-op-do-fasb-p
)
#+
mkcl
(
do-static-library
:initarg
:do-static-library
:initform
t
:reader
bundle-op-do-static-library-p
)))
#+
ecl
(
lisp-files
:initform
nil
:accessor
bundle-op-lisp-files
)))
(
defclass
monolithic-op
(
operation
)
()
(
:documentation
"A MONOLITHIC operation operates on a system *and all of its
...
...
@@ -47,6 +45,20 @@ itself.")) ;; operation on a system and its dependencies
((
prologue-code
:accessor
prologue-code
)
(
epilogue-code
:accessor
epilogue-code
)))
#+
mkcl
(
defclass
program
(
bundle-system
)
(
(
prologue-code
:initarg
:prologue-code
:initform
nil
:accessor
prologue-code
)
(
epilogue-code
:initarg
:epilogue-code
:initform
nil
:accessor
epilogue-code
)
(
prefix-lisp-object-files
:initarg
:prefix-lisp-object-files
:initform
nil
:accessor
program-prefix-lisp-object-files
)
(
postfix-lisp-object-files
:initarg
:postfix-lisp-object-files
:initform
nil
:accessor
program-postfix-lisp-object-files
)
(
object-files
:initarg
:object-files
:initform
nil
:accessor
program-object-files
)
(
extra-build-args
:initarg
:extra-build-args
:initform
nil
:accessor
program-extra-build-args
)))
(
defmethod
prologue-code
((
x
t
))
nil
)
(
defmethod
epilogue-code
((
x
t
))
nil
)
...
...
@@ -77,7 +89,7 @@ itself.")) ;; operation on a system and its dependencies
((
bundle-type
:initform
:fasl
)))
(
defclass
prepare-fasl-op
(
sideway-operation
)
((
sideway-operation
:initform
#+
ecl
'load-fasl-op
#-
ecl
'load-op
:allocation
:class
)))
((
sideway-operation
:initform
#+
(
or
ecl
mkcl
)
'load-fasl-op
#-
(
or
ecl
mkcl
)
'load-op
:allocation
:class
)))
(
defclass
lib-op
(
link-op
gather-op
non-propagating-operation
)
((
bundle-type
:initform
:lib
))
...
...
@@ -123,7 +135,7 @@ itself.")) ;; operation on a system and its dependencies
(
defclass
image-op
(
monolithic-bundle-op
selfward-operation
#+
ecl
link-op
#+
(
or
ecl
mkcl
)
gather-op
)
((
bundle-type
:initform
:image
)
(
selfward-operation
:initform
'
(
#-
ecl
load-op
)
:allocation
:class
))
(
selfward-operation
:initform
'
(
#-
(
or
ecl
mkcl
)
load-op
)
:allocation
:class
))
(
:documentation
"create an image file from the system and its dependencies"
))
(
defclass
program-op
(
image-op
)
...
...
@@ -139,8 +151,9 @@ itself.")) ;; operation on a system and its dependencies
((
member
:dll
:lib
:shared-library
:static-library
:program
:object
:program
)
(
compile-file-type
:type
bundle-type
))
((
member
:image
)
"image"
)
((
eql
:dll
)
(
cond
((
os-macosx-p
)
"dylib"
)
((
os-unix-p
)
"so"
)
((
os-windows-p
)
"dll"
)))
((
member
:lib
:static-library
)
(
cond
((
os-unix-p
)
"a"
)
((
os-windows-p
)
"lib"
)))
((
member
:dll
:shared-library
)
(
cond
((
os-macosx-p
)
"dylib"
)
((
os-unix-p
)
"so"
)
((
os-windows-p
)
"dll"
)))
((
member
:lib
:static-library
)
(
cond
((
os-unix-p
)
"a"
)
((
os-windows-p
)
(
if
(
featurep
'
(
:or
:mingw32
:mingw64
))
"a"
"lib"
))))
((
eql
:program
)
(
cond
((
os-unix-p
)
nil
)
((
os-windows-p
)
"exe"
)))))
(
defun
bundle-output-files
(
o
c
)
...
...
@@ -189,14 +202,14 @@ itself.")) ;; operation on a system and its dependencies
(
unless
name-suffix-p
(
setf
(
slot-value
instance
'name-suffix
)
(
unless
(
typep
instance
'program-op
)
(
if
(
operation-monolithic-p
instance
)
"--all-systems"
#-
ecl
"--system"
))))
; . no good for Logical Pathnames
(
if
(
operation-monolithic-p
instance
)
"--all-systems"
#-
(
or
ecl
mkcl
)
"--system"
))))
; . no good for Logical Pathnames
(
when
(
typep
instance
'monolithic-bundle-op
)
(
destructuring-bind
(
&key
lisp-files
prologue-code
epilogue-code
(
destructuring-bind
(
&key
#-
mkcl
lisp-files
prologue-code
epilogue-code
&allow-other-keys
)
(
operation-original-initargs
instance
)
(
setf
(
prologue-code
instance
)
prologue-code
(
epilogue-code
instance
)
epilogue-code
)
#-
ecl
(
assert
(
null
(
or
lisp-files
epilogue-code
prologue-code
)))
#-
(
or
ecl
mkcl
)
(
assert
(
null
(
or
lisp-files
epilogue-code
prologue-code
)))
#+
ecl
(
setf
(
bundle-op-lisp-files
instance
)
lisp-files
)))
(
setf
(
bundle-op-build-args
instance
)
(
remove-plist-keys
...
...
@@ -208,7 +221,9 @@ itself.")) ;; operation on a system and its dependencies
(
declare
(
ignorable
type
))
(
or
#+
ecl
(
or
(
equalp
type
(
compile-file-type
:type
:object
))
(
equalp
type
(
compile-file-type
:type
:static-library
)))
#+
mkcl
(
equalp
type
(
compile-file-type
:fasl-p
nil
))
#+
mkcl
(
or
(
equalp
type
(
compile-file-type
:fasl-p
nil
))
#+
(
or
unix
mingw32
mingw64
)
(
equalp
type
"a"
)
;; valid on Unix and MinGW
#+
(
and
windows
(
not
(
or
mingw32
mingw64
)))
(
equalp
type
"lib"
))
#+
(
or
abcl
allegro
clisp
clozure
cmu
lispworks
sbcl
scl
xcl
)
(
equalp
type
(
compile-file-type
)))))
(
defgeneric*
(
trivial-system-p
)
(
component
))
...
...
@@ -344,7 +359,15 @@ itself.")) ;; operation on a system and its dependencies
nil
)
(
defmethod
component-depends-on
((
o
monolithic-lib-op
)
(
c
prebuilt-system
))
nil
))
nil
)
#+
mkcl
(
defmethod
perform
((
o
fasl-op
)
(
c
prebuilt-system
))
nil
)
#+
mkcl
(
defmethod
output-files
((
o
lib-op
)
(
c
prebuilt-system
))
(
list
(
prebuilt-system-static-library
c
))))
;;;
...
...
@@ -361,6 +384,7 @@ itself.")) ;; operation on a system and its dependencies
(
library
(
second
inputs
))
(
asd
(
first
(
output-files
o
s
)))
(
name
(
if
(
and
fasl
asd
)
(
pathname-name
asd
)
(
return-from
perform
)))
(
version
(
component-version
s
))
(
dependencies
(
if
(
operation-monolithic-p
o
)
(
remove-if-not
'builtin-system-p
...
...
@@ -388,8 +412,9 @@ itself.")) ;; operation on a system and its dependencies
(
machine-type
)
(
software-version
))
(
let
((
*package*
(
find-package
:asdf-user
)))
(
pprint
`
(
defsystem
,
name
(
pprint
`
(
asdf/defsystem:
defsystem
,
name
:class
prebuilt-system
:version
,
version
:depends-on
,
depends-on
:components
((
:compiled-file
,
(
pathname-name
fasl
)))
,@
(
when
library
`
(
:lib
,
(
file-namestring
library
))))
...
...
@@ -430,7 +455,7 @@ itself.")) ;; operation on a system and its dependencies
(asdf:load-system :precompiled-asdf-utils)
|#
#+
(
or
ecl
mkcl
)
#+
ecl
(
with-upgradability
()
(
defun
uiop-library-file
()
(
or
(
and
(
find-system
:uiop
nil
)
...
...
@@ -447,8 +472,10 @@ itself.")) ;; operation on a system and its dependencies
(
and
(
system-source-directory
:asdf
)
(
plan-operates-on-p
plan
'
(
"asdf"
))))
(
pushnew
(
uiop-library-file
)
files
:test
'pathname-equal
))
files
))
files
))
)
#+
(
or
ecl
mkcl
)
(
with-upgradability
()
(
defun
register-pre-built-system
(
name
)
(
register-system
(
make-instance
'system
:name
(
coerce-name
name
)
:source-file
nil
))))
...
...
@@ -477,14 +504,28 @@ itself.")) ;; operation on a system and its dependencies
#+
mkcl
(
with-upgradability
()
(
defmethod
perform
((
o
dll-op
)
(
s
system
))
(
apply
#'
compiler::build-shared-library
(
output-file
o
s
)
:lisp-object-files
(
input-files
o
s
)
(
bundle-op-build-args
o
)))
(
defmethod
perform
((
o
lib-op
)
(
s
system
))
(
apply
#'
compiler::build-static-library
(
output-file
o
c
)
(
apply
#'
compiler::build-static-library
(
output-file
o
s
)
:lisp-object-files
(
input-files
o
s
)
(
bundle-op-build-args
o
)))
(
defmethod
perform
((
o
basic-fasl-op
)
(
s
system
))
(
apply
#'
compiler::build-bundle
(
output-file
o
c
)
;; second???
(
apply
#'
compiler::build-bundle
(
output-file
o
s
)
:lisp-object-files
(
input-files
o
s
)
(
bundle-op-build-args
o
)))
(
defmethod
perform
((
o
program-op
)
(
s
system
))
(
apply
#'
compiler::build-program
(
output-file
o
s
)
:lisp-object-files
(
append
(
program-prefix-lisp-object-files
s
)
(
input-files
o
s
)
(
program-postfix-lisp-object-files
s
))
:object-files
(
program-object-files
s
)
:prologue-code
(
prologue-code
s
)
:epilogue-code
(
epilogue-code
s
)
(
program-extra-build-args
s
)))
(
defun
bundle-system
(
system
&rest
args
&key
force
(
verbose
t
)
version
&allow-other-keys
)
(
declare
(
ignore
force
verbose
version
))
(
apply
#'
operate
'deliver-asd-op
system
args
)))
...
...
footer.lisp
View file @
f127ffb8
...
...
@@ -20,7 +20,7 @@
#+
(
or
ecl
mkcl
)
(
progn
(
pushnew
'
(
"fasb"
.
si::load-binary
)
si:*load-hooks*
:test
'equal
:key
'car
)
(
pushnew
'
(
"fasb"
.
si::load-binary
)
si:
:
*load-hooks*
:test
'equal
:key
'car
)
#+
(
or
(
and
ecl
win32
)
(
and
mkcl
windows
))
(
unless
(
assoc
"asd"
#+
ecl
ext:*load-hooks*
#+
mkcl
si::*load-hooks*
:test
'equal
)
...
...
source-registry.lisp
View file @
f127ffb8
...
...
@@ -155,8 +155,8 @@ system names to pathnames of .asd files")
(
defun
wrapping-source-registry
()
`
(
:source-registry
#+
(
or
ecl
sbcl
)
(
:tree
,
(
resolve-symlinks*
(
lisp-implementation-directory
)))
#+
mkcl
(
:tree
,
(
translate-logical-pathname
"CONTRIB:"
))
:inherit-configuration
#+
mkcl
(
:tree
,
(
translate-logical-pathname
"CONTRIB:"
))
#+
cmu
(
:tree
#p"modules:"
)
#+
scl
(
:tree
#p"file://modules/"
)))
(
defun
default-source-registry
()
...
...
test/dll-test.lisp
View file @
f127ffb8
...
...
@@ -9,3 +9,13 @@ int sample_function()
return 42;
}
"
)
#+
mkcl
(
ffi:clines
"
extern MKCL_DLLEXPORT int sample_function(void);
int sample_function(void)
{
return 42;
}
"
)
test/dll-user.lisp
View file @
f127ffb8
(
defpackage
:test-asdf/dll-user
(
:use
))
;; dummy, for package-system dependencies.
(
in-package
:test-package
)
#+
(
and
mkcl
windows
)
(
ffi:clines
"extern __declspec(dllimport) int sample_function(void);"
)
#-
(
and
mkcl
windows
)
(
ffi:clines
"extern int sample_function(void);"
)
(
ffi:def-function
"sample_function"
()
:returning
:int
)
test/hello-world-example.asd
View file @
f127ffb8
;; Example executable program
#-
mkcl
(
defsystem
:hello-world-example
:build-operation
program-op
:entry-point
"hello:entry-point"
:depends-on
(
:uiop
)
:components
((
:file
"hello"
)))
#+
mkcl
(
defsystem
:hello-world-example
:class
asdf/bundle::program
:build-operation
program-op
:entry-point
"hello:entry-point"
:depends-on
(
:uiop
)
:components
((
:file
"hello"
))
:prefix-lisp-object-files
#.
(
list
(
namestring
(
truename
(
translate-logical-pathname
#P"SYS:cmp.a"
))))
:extra-build-args
#.
(
or
#-
windows
'
(
:use-mkcl-shared-libraries
nil
))
:epilogue-code
(
progn
(
setq
uiop/image:*image-dumped-p*
:executable
)
(
uiop/image:restore-image
:entry-point
(
read-from-string
"hello:entry-point"
))))
test/hello.lisp
View file @
f127ffb8
...
...
@@ -12,4 +12,5 @@
t
)
(
defun
entry-point
()
(
apply
'main
*command-line-arguments*
))
(
apply
'main
*command-line-arguments*
)
#+
mkcl
(
quit
))
test/make-hello-world.lisp
View file @
f127ffb8
...
...
@@ -2,7 +2,7 @@
#+
lispworks
(
lispworks:load-all-patches
)
(
load
(
make-pathname
:name
"script-support"
:defaults
*load-pathname*
))
(
load-asdf
)
#+
ecl
(
require
:cmp
)
#+
(
or
ecl
mkcl
)
(
require
:cmp
)
(
asdf-test::register-directory
asdf-test::*asdf-directory*
)
;; we need UIOP, and ECL can dump.
(
asdf-test::register-directory
asdf-test::*uiop-directory*
)
...
...
test/monodll-1.lisp
View file @
f127ffb8
...
...
@@ -9,3 +9,13 @@ int always_7()
return 7;
}
"
)
#+
mkcl
(
ffi:clines
"
extern MKCL_DLLEXPORT int always_7(void);
int always_7(void)
{
return 7;
}
"
)
test/monodll.lisp
View file @
f127ffb8
...
...
@@ -9,3 +9,13 @@ int always_42()
return 6*always_7();
}
"
)
#+
mkcl
(
ffi:clines
"
extern MKCL_DLLEXPORT int always_42(void);
int always_42(void)
{
return 6*always_7();
}
"
)
test/script-support.lisp
View file @
f127ffb8
...
...
@@ -142,6 +142,9 @@ Some constraints:
(
cond
((
equal
x
y
)
(
format
t
"~S and~% ~S both evaluate to same path:~% ~S~%"
qx
qy
x
))
#+
mkcl
((
acall
:pathname-equal
x
y
)
(
format
t
"~S and ~S evaluate to functionaly equivalent paths, respectively:~% ~S~%and~% ~S~%"
qx
qy
x
y
))
((
acall
:pathname-equal
x
y
)
(
warn
"These two expressions yield pathname-equal yet not equal path~%~
the first expression ~S yields this:~% ~S~% ~S~%
...
...
test/test-bundle.script
View file @
f127ffb8
...
...
@@ -61,3 +61,23 @@
(si:load-foreign-module (first (output-files 'monolithic-dll-op :test-asdf/monodll)))
(operate 'load-op :test-asdf/monodll-user)
(assert-equal (test-package::always-42) 42))
;;; Test DLL-op and monolithic-dll-op on MKCL.
#+mkcl
(progn
(require 'sockets) ;; Test the pre-compiled system feature
(operate 'dll-op :test-asdf/dll-test)
(let ((dll (first (output-files 'dll-op :test-asdf/dll-test))))
(si:load-foreign-module dll)
(let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/dll-user)))
(assert (= (test-package::sample-function) 42))
(let* #+windows ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1)))
(compiler::*builder-default-libraries* (list (namestring lib))))
#-windows ()
(operate 'monolithic-dll-op :test-asdf/monodll))
(let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll))))
(si:load-foreign-module dll)
(let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/monodll-user)))
(assert-equal (test-package::always-42) 42))
test/test-program.script
View file @
f127ffb8
...
...
@@ -2,7 +2,7 @@
(DBG :foo (current-lisp-file-pathname))
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks sbcl) t
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks
mkcl
sbcl) t
#+cmu nil ;; uncomment if you have 32-bit gcc support - or can autodetect
#+clisp (version-satisfies
(first (split-string (lisp-implementation-version) :separator " "))
...
...
@@ -13,6 +13,8 @@
(defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example)))
(assert (absolute-pathname-p exe))
#-mkcl
(progn
;; Try to load lisp-invocation from xcvb
(setf *central-registry*
(list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF
...
...
@@ -35,7 +37,23 @@
(symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")))
:output t :error-output :output :input nil))
0)
0))
#+mkcl
(progn
(operate 'program-op :hello-world-example)
#+windows
(let*
((dll-orig (merge-pathnames (make-pathname :name (mkcl:str+ "mkcl_" (lisp-implementation-version)) :type "dll")
(si::self-truename)))
(exe (car (asdf::output-files 'program-op :hello-world-example)))
(exe-dir (make-pathname :name nil :type nil :defaults exe))
(dll-dest (merge-pathnames exe-dir dll-orig)))
;; make sure mkcl-X.X.X.dll is the same directory as the executable
(copy-file dll-orig dll-dest)))
(assert (probe-file* exe))
(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
...
...
uiop/common-lisp.lisp
View file @
f127ffb8
...
...
@@ -30,7 +30,7 @@
;;;; Early meta-level tweaks
#+
(
or
abcl
allegro
clisp
cmu
ecl
mkcl
clozure
lispworks
sbcl
scl
)
#+
(
or
abcl
allegro
clisp
cmu
ecl
mkcl
clozure
lispworks
mkcl
sbcl
scl
)
(
eval-when
(
:load-toplevel
:compile-toplevel
:execute
)
;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode
;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie.
...
...
uiop/driver.lisp
View file @
f127ffb8
...
...
@@ -13,3 +13,5 @@
:uiop/os
:uiop/pathname
:uiop/stream
:uiop/filesystem
:uiop/image
:uiop/run-program
:uiop/lisp-build
:uiop/configuration
:uiop/backward-driver
))
#+
mkcl
(
provide
:uiop
)
uiop/filesystem.lisp
View file @
f127ffb8
...
...
@@ -598,7 +598,7 @@ in an atomic way if the implementation allows."
`
(
,
dd
directory-pathname
)
;; requires SBCL 1.0.44 or later
`
(
progn
(
require
:sb-posix
)
(
symbol-call
:sb-posix
:rmdir
directory-pathname
)))
#+
xcl
(
symbol-call
:uiop
:run-program
`
(
"rmdir"
,
(
native-namestring
directory-pathname
)))
#-
(
or
abcl
allegro
clisp
clozure
cmu
cormanlisp
digitool
ecl
gcl
lispworks
sbcl
scl
xcl
)
#-
(
or
abcl
allegro
clisp
clozure
cmu
cormanlisp
digitool
ecl
gcl
lispworks
mkcl
sbcl
scl
xcl
)
(
error
"~S not implemented on ~S"
'delete-empty-directory
(
implementation-type
)))
; genera
(
defun
delete-directory-tree
(
directory-pathname
&key
(
validate
nil
validatep
)
(
if-does-not-exist
:error
))
...
...
uiop/image.lisp
View file @
f127ffb8
...
...
@@ -118,7 +118,7 @@ This is designed to abstract away the implementation specific quit forms."
(
let
((
debug:*debug-print-level*
*print-level*
)
(
debug:*debug-print-length*
*print-length*
))
(
debug:backtrace
(
or
count
most-positive-fixnum
)
stream
))
#+
ecl
#+
(
or
ecl
mkcl
)
(
let*
((
top
(
si:ihs-top
))
(
repeats
(
if
count
(
min
top
count
)
top
))
(
backtrace
(
loop
:for
ihs
:from
0
:below
top
...
...
@@ -233,9 +233,10 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
#+
gcl
si:*command-args*
#+
(
or
genera
mcl
)
nil
#+
lispworks
sys:*line-arguments-list*
#+
mkcl
(
loop
:for
i
:from
0
:below
(
mkcl:argc
)
:collect
(
mkcl:argv
i
))
#+
sbcl
sb-ext:*posix-argv*
#+
xcl
system:*argv*
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
genera
lispworks
mcl
sbcl
scl
xcl
)
#-
(
or
abcl
allegro
clisp
clozure
cmu
ecl
gcl
genera
lispworks
mcl
mkcl
sbcl
scl
xcl
)
(
error
"raw-command-line-arguments not implemented yet"
))
(
defun
command-line-arguments
(
&optional
(
arguments
(
raw-command-line-arguments
)))
...
...
@@ -266,7 +267,7 @@ Otherwise, return NIL."
;; NB: not currently available on ABCL, Corman, Genera, MCL, MKCL
(
or
#+
(
or
allegro
clisp
clozure
cmu
gcl
lispworks
sbcl
scl
xcl
)
(
first
(
raw-command-line-arguments
))
#+
ecl
(
si:argv
0
)))
#+
ecl
(
si:argv
0
)
#+
mkcl
(
mkcl:argv
0
)
))
(
t
;; argv[0] is the name of the interpreter.
;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8.
(
getenvp
"__CL_ARGV0"
))))
...
...
uiop/lisp-build.lisp
View file @
f127ffb8
...
...
@@ -62,16 +62,17 @@ This can help you produce more deterministic output for FASLs."))
"Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS"
)
(
defun
get-optimization-settings
()
"Get current compiler optimization settings, ready to PROCLAIM again"
#-
(
or
clisp
clozure
cmu
ecl
sbcl
scl
)
#-
(
or
clisp
clozure
cmu
ecl
mkcl
sbcl
scl
)
(
warn
"~S does not support ~S. Please help me fix that."
'get-optimization-settings
(
implementation-type
))
#+
clozure
(
ccl:declaration-information
'optimize
nil
)
#+
(
or
clisp
cmu
ecl
sbcl
scl
)
#+
(
or
clisp
cmu
ecl
mkcl
sbcl
scl
)
(
let
((
settings
'
(
speed
space
safety
debug
compilation-speed
#+
(
or
cmu
scl
)
c::brevity
)))
#.`
(
loop
:for
x
:in
settings
,@
(
or
#+
ecl
'
(
:for
v
:in
'
(
c::*speed*
c::*space*
c::*safety*
c::*debug*
))
#+
mkcl
'
(
:for
v
:in
'
(
si::*speed*
si::*space*
si::*safety*
si::*debug*
))
#+
(
or
cmu
scl
)
'
(
:for
f
:in
'
(
c::cookie-speed
c::cookie-space
c::cookie-safety
c::cookie-debug
c::cookie-cspeed
c::cookie-brevity
)))
:for
y
=
(
or
#+
clisp
(
gethash
x
system::*optimize*
)
#+
(
or
ecl
)
(
symbol-value
v
)
#+
(
or
ecl
mkcl
)
(
symbol-value
v
)
#+
(
or
cmu
scl
)
(
funcall
f
c::*default-cookie*
)
#+
sbcl
(
cdr
(
assoc
x
sb-c::*policy*
)))
:when
y
:collect
(
list
x
y
))))
...
...
uiop/os.lisp
View file @
f127ffb8
...
...
@@ -49,7 +49,7 @@ keywords explicitly."
(
defun
os-windows-p
()
"Is the underlying operating system Microsoft Windows?"
(
or
#+
abcl
(
featurep
:windows
)
#+
(
and
(
not
(
or
abcl
unix
cygwin
darwin
))
(
or
win32
windows
mswindows
mingw32
))
t
))
#+
(
and
(
not
(
or
abcl
unix
cygwin
darwin
))
(
or
win32
windows
mswindows
mingw32
mingw64
))
t
))
(
defun
os-genera-p
()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
...
...
uiop/pathname.lisp
View file @
f127ffb8
...
...
@@ -91,8 +91,8 @@ by the underlying implementation's MAKE-PATHNAME and other primitives"
;; See CLHS make-pathname and 19.2.2.2.3.
;; This will be :unspecific if supported, or NIL if not.
(
defparameter
*unspecific-pathname-type*
#+
(
or
abcl
allegro
clozure
cmu
genera
lispworks
mkcl
sbcl
scl
)
:unspecific
#+
(
or
clisp
ecl
gcl
xcl
#|These haven't been tested:|#
cormanlisp
mcl
)
nil
#+
(
or
abcl
allegro
clozure
cmu
genera
lispworks
sbcl
scl
)
:unspecific
#+
(
or
clisp
ecl
mkcl
gcl
xcl
#|These haven't been tested:|#
cormanlisp
mcl
)
nil
"Unspecific type component to use with the underlying implementation's MAKE-PATHNAME"
)
(
defun
make-pathname*
(
&rest
keys
&key
(
directory
nil
)
...
...
@@ -190,8 +190,9 @@ when merging, making or parsing pathnames"
;; But CMUCL decides to die on NIL.
;; MCL has issues with make-pathname, nil and defaulting
(
declare
(
ignorable
defaults
))
#.`
(
make-pathname*
:directory
nil
:name
nil
:type
nil
:version
nil
:device
nil
:host
(
or
#+
cmu
lisp::*unix-host*
)
#.`
(
make-pathname*
:directory
nil
:name
nil
:type
nil
:version
nil
:device
(
or
#+
(
and
mkcl
unix
)
:unspecific
)
:host
(
or
#+
cmu
lisp::*unix-host*
#+
(
and
mkcl
unix
)
"localhost"
)
#+
scl
,@'
(
:scheme
nil
:scheme-specific-part
nil
:username
nil
:password
nil
:parameters
nil
:query
nil
:fragment
nil
)
;; the default shouldn't matter, but we really want something physical
...
...
@@ -224,11 +225,11 @@ when merging, making or parsing pathnames"
(
or
(
and
(
null
p1
)
(
null
p2
))
(
and
(
pathnamep
p1
)
(
pathnamep
p2
)
(
and
(
=?
pathname-host
)
(
=?
pathname-device
)
#-
(
and
mkcl
unix
)
(
=?
pathname-device
)
(
=?
normalize-pathname-directory-component
pathname-directory
)
(
=?
pathname-name
)
(
=?
pathname-type
)
(
=?
pathname-version
)))))))
#-
mkcl
(
=?
pathname-version
)))))))
(
defun
absolute-pathname-p
(
pathspec
)
"If PATHSPEC is a pathname or namestring object that parses as a pathname
...
...
uiop/run-program.lisp
View file @
f127ffb8
...
...
@@ -341,6 +341,7 @@ for the implementation's underlying run-program function"
#+
os-unix
(
list
command
)
#+
os-windows
(
string
#+
mkcl
(
list
"cmd"
'
#:/c
command
)
;; NB: We do NOT add cmd /c here. You might want to.
#+
(
or
allegro
clisp
)
command
;; On ClozureCL for Windows, we assume you are using
...
...
@@ -350,7 +351,7 @@ for the implementation's underlying run-program function"
;; NB: On other Windows implementations, this is utterly bogus
;; except in the most trivial cases where no quoting is needed.
;; Use at your own risk.
#-
(
or
allegro
clisp
clozure
)
(
list
"cmd"
"/c"
command
))
#-
(
or
allegro
clisp
clozure
mkcl
)
(
list
"cmd"
"/c"
command
))
#+
os-windows
(
list
#+
allegro
(
escape-windows-command
command
)
...
...
@@ -377,8 +378,8 @@ argument to pass to the internal RUN-PROGRAM"
((
eql
:interactive
)
#+
allegro
nil
#+
clisp
:terminal
#+
(
or
clozure
cmu
ecl
sbcl
scl
)
t
)
#+
(
or
allegro
clozure
cmu
ecl
lispworks
sbcl
scl
)
#+
(
or
clozure
cmu
ecl
mkcl
sbcl
scl
)
t
)
#+
(
or
allegro
clozure
cmu
ecl
lispworks
mkcl
sbcl
scl
)
((
eql
:output
)
(
if
(
eq
role
:error-output
)
:output
...
...
@@ -409,12 +410,12 @@ to be normalized by %NORMALIZE-IO-SPECIFIER.
It returns a process-info plist with possible keys:
PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
;; NB: these implementations have unix vs windows set at compile-time.
(
declare
(
ignorable
if-input-does-not-exist
if-output-exists
if-error-output-exists
))
(
declare
(
ignorable
directory
if-input-does-not-exist
if-output-exists
if-error-output-exists
))
(
assert
(
not
(
and
wait
(
member
:stream
(
list
input
output
error-output
)))))
#-
(
or
allegro
clisp
clozure
cmu
(
and
lispworks
os-unix
)
sbcl
scl
)
#-
(
or
allegro
clisp
clozure
cmu
(
and
lispworks
os-unix
)
mkcl
sbcl
scl
)
(
progn
command
keys
directory
(
error
"run-program not available"
))
#+
(
or
allegro
clisp
clozure
cmu
(
and
lispworks
os-unix
)
sbcl
scl
)
#+
(
or
allegro
clisp
clozure
cmu
(
and
lispworks
os-unix
)
mkcl
sbcl
scl
)
(
let*
((
%command
(
%normalize-command
command
))
(
%input
(
%normalize-io-specifier
input
:input
))
(
%output
(
%normalize-io-specifier
output
:output
))
...
...
@@ -434,7 +435,7 @@ It returns a process-info plist with possible keys:
#+
os-windows
:show-window
#+
os-windows
(
if
interactive
nil
:hide
)
:allow-other-keys
t
keys
))
#-
allegro
(
with-current-directory
(
#-
sbcl
directory
)
(
with-current-directory
(
#-
(
or
sbcl
mkcl
)
directory
)
#+
clisp
(
flet
((
run
(
f
x
&rest
args
)
(
multiple-value-list
...
...
@@ -446,11 +447,11 @@ It returns a process-info plist with possible keys:
#+
os-windows
(
string
(
run
'ext:run-shell-command
%command
))
(
list
(
run
'ext:run-program
(
car
%command
)
:arguments
(
cdr
%command
)))))
#+
(
or
clozure
cmu
ecl
sbcl
scl
)
(
#-
ecl
progn
#+
ecl
multiple-value-list
#+
(
or
clozure
cmu
ecl
mkcl
sbcl
scl
)
(
#-
(
or
ecl
mkcl
)
progn
#+
(
or
ecl
mkcl
)
multiple-value-list
(
apply
'#+
(
or
cmu
ecl
scl
)
ext:run-program
#+
clozure
ccl:run-program
#+
sbcl
sb-ext:run-program
#+
clozure
ccl:run-program
#+
sbcl
sb-ext:run-program
#+
mkcl
mk-ext:run-program
(
car
%command
)
(
cdr
%command
)
:input
%input
:output
%output
...
...
@@ -458,7 +459,7 @@ It returns a process-info plist with possible keys:
:wait
wait
:allow-other-keys
t
(
append
#+
(
or
clozure
cmu
sbcl
scl
)
#+
(
or
clozure
cmu
mkcl
sbcl
scl
)
`
(
:if-input-does-not-exist
,
if-input-does-not-exist
:if-output-exists
,
if-output-exists
:if-error-exists
,
if-error-output-exists
)
...
...
@@ -525,8 +526,8 @@ It returns a process-info plist with possible keys:
#+
clozure
(
ccl:external-process-error-stream
process*
)
#+
(
or
cmu
scl
)
(
ext:process-error
process*
)
#+
sbcl
(
sb-ext:process-error
process*
))))
#+
ecl
(
destructuring-bind
(
stream
code
process
)
process*
#+
(
or
ecl
mkcl
)
(
destructuring-bind
#+
ecl
(
stream
code
process
)
#+
mkcl
(
stream
process
code
)
process*
(
let
((
mode
(
+
(
if
(
eq
input
:stream
)
1
0
)
(
if
(
eq
output
:stream
)
2
0
))))
(
cond
((
zerop
mode
))
...
...
@@ -553,8 +554,9 @@ It returns a process-info plist with possible keys:
#+
clozure
(
ccl::external-process-pid
process
)
#+
ecl
(
si:external-process-pid
process
)
#+
(
or
cmu
scl
)
(
ext:process-pid
process
)
#+
mkcl
(
mkcl:process-id
process
)
#+
sbcl
(
sb-ext:process-pid
process
)
#-
(
or
allegro
cmu
sbcl
scl
)
(
error
"~S not implemented"
'%process-info-pid
)))
#-
(
or
allegro
cmu
mkcl
sbcl
scl
)
(
error
"~S not implemented"
'%process-info-pid
)))
(
defun
%wait-process-result
(
process-info
)
(
or
(
getf
process-info
:exit-code
)
...
...
@@ -578,7 +580,8 @@ It returns a process-info plist with possible keys:
(
system:pipe-exit-status
stream
:wait
t
)
(
if-let
((
f
(
find-symbol*
:pid-exit-status
:system
nil
)))
(
funcall
f
process
:wait
t
)))
#+
sbcl
(
sb-ext:process-exit-code
process
)))))
#+
sbcl
(
sb-ext:process-exit-code
process
)
#+
mkcl
(
mkcl:join-process
process
)))))
(
defun
%check-result
(
exit-code
&key
command
process
ignore-error-status
)
(
unless
ignore-error-status
...
...
@@ -678,7 +681,7 @@ It returns a process-info plist with possible keys:
(
defun
%use-run-program
(
command
&rest
keys
&key
input
output
error-output
ignore-error-status
&allow-other-keys
)
;; helper for RUN-PROGRAM when using %run-program
#+
(
or
abcl
cormanlisp
gcl
(
and
lispworks
os-windows
)
mcl
mkcl
xcl
)
#+
(
or
abcl
cormanlisp
gcl
(
and
lispworks
os-windows
)
mcl
xcl
)
(
progn
command
keys
input
output
error-output
ignore-error-status
;; ignore
(
error
"Not implemented on this platform"
))
...
...
@@ -788,11 +791,7 @@ It returns a process-info plist with possible keys:
(
ext:system
%command
))
#+
gcl
(
system:system
%command
)
#+
mcl
(
ccl::with-cstrs
((
%%command
%command
))
(
_system
%%command
))
#+
mkcl
;; PROBABLY BOGUS -- ask jcb