Newer
Older
;;;; -------------------------------------------------------------------------
;;;; Handle ASDF portability to multiple implementations
Francois-Rene Rideau
committed
(asdf/package:define-package :asdf/implementation
(:use :common-lisp :asdf/package)
Francois-Rene Rideau
committed
(:recycle :asdf/implementation :asdf)
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
#+cormanlisp
(:export
#:logical-pathname #:translate-logical-pathname
#:make-broadcast-stream #:file-namestring)
#+ecl (:export #:use-ecl-byte-compiler-p)
#+genera (:import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
(:export
#:strcat #:compatfmt
#:asdf-message #:*asdf-verbose* #:*verbose-out*))
(in-package :asdf/implementation)
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "ASDF is not supported on your implementation. Please help us port it.")
;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
;;;; Early meta-level tweaks
#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
clozure lispworks (and sbcl sb-unicode) scl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(pushnew :asdf-unicode *features*))
#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
(defparameter *acl-warn-save*
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
excl:*warn-on-nested-reader-conditionals*))
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
(setf excl:*warn-on-nested-reader-conditionals* nil)))
#+ecl
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
(unless (use-ecl-byte-compiler-p) (require :cmp)))
#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
(eval-when (:load-toplevel :compile-toplevel :execute)
(when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 lacks output-translations and more.
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
(shadow 'type-of :asdf/implementation)
(pushnew 'ignorable pcl::*variable-declarations-without-argument*)
(pushnew :gcl<2.7 *features*)))
#+mkcl
(eval-when (:load-toplevel :compile-toplevel :execute)
(require :cmp)
(setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
;;;; Compatibility layers
#+cormanlisp
(progn
(deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*)
(defun translate-logical-pathname (x) x)
(defun file-namestring (p)
(setf p (pathname p))
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
#+gcl<2.7
(progn ;; Doesn't support either logical-pathnames or output-translations.
(deftype logical-pathname () nil)
(defun type-of (x) (class-name (class-of x)))
(defun wild-pathname-p (path) (declare (ignore path)) nil)
(defun translate-logical-pathname (x) x)
(defvar *compile-file-pathname* nil)
(defun pathname-match-p (in-pathname wild-pathname)
(declare (ignore in-wildname wild-wildname)) nil)
(defun translate-pathname (source from-wildname to-wildname &key)
(declare (ignore from-wildname to-wildname)) source)
(defun %print-unreadable-object (object stream type identity thunk)
(format stream "#<~@[~S ~]" (when type (type-of object)))
(funcall thunk)
(format stream "~@[ ~X~]>" (when identity (system:address object))))
(defmacro with-compilation-unit (options &body body)
(declare (ignore options)) `(progn ,@body))
(defmacro print-unreadable-object ((object stream &key type identity) &body body)
`(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
(defun ensure-directories-exist (path)
(run-shell-command "mkdir -p ~S" (namestring (pathname-directory-pathname path)))))
#+genera
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
(fs:create-directories-recursively (pathname path))))
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
(read-from-string
"(eval-when (:compile-toplevel :load-toplevel :execute)
(ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
(ccl:define-entry-point (_system \"system\") ((name :string)) :int)
;; Note: ASDF may expect user-homedir-pathname to provide
;; the pathname of the current user's home directory, whereas
;; MCL by default provides the directory from which MCL was started.
;; See http://code.google.com/p/mcl/wiki/Portability
(defun current-user-homedir-pathname ()
(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
(defun probe-posix (posix-namestring)
\"If a file exists for the posix namestring, return the pathname\"
(ccl::with-cstrs ((cpath posix-namestring))
(ccl::rlet ((is-dir :boolean)
(fsref :fsref))
(when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
(ccl::%path-from-fsref fsref is-dir))))))"))
;;;; compatfmt: avoid fancy format directives when unsupported
;; Confirm (?) has to be inside an eval-when to make Lispworks happy
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun strcat (&rest strings)
(apply 'concatenate 'string strings)))
(defmacro compatfmt (format)
#+(or gcl genera)
(loop :for (unsupported . replacement)
:in (append
'(("~3i~_" . ""))
#+(or genera gcl<2.7) '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
(loop :for found = (search unsupported format) :while found :do
(setf format (strcat (subseq format 0 found) replacement
(subseq format (+ found (length unsupported)))))))
format)
(defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
(defvar *verbose-out* nil)
(defun asdf-message (format-string &rest format-args)
(apply 'format *verbose-out* format-string format-args))