1
;;;; -------------------------------------------------------------------------
2
;;;; Handle compatibility with multiple implementations.
3
;;; This file is for papering over the deficiencies and peculiarities
4
;;; of various Common Lisp implementations.
5
;;; For implementation-specific access to the system, see os.lisp instead.
6
;;; A few functions are defined here, but actually exported from utility;
7
;;; from this package only common-lisp symbols are exported.
9
(uiop/package:define-package :uiop/common-lisp
10
(:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
11
(:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
12
(:reexport :common-lisp)
13
(:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
14
#+allegro (:intern #:*acl-warn-save*)
15
#+cormanlisp (:shadow #:user-homedir-pathname)
18
#:logical-pathname #:translate-logical-pathname
19
#:make-broadcast-stream #:file-namestring)
20
#+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
21
#+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
22
#+genera (:shadowing-import-from :scl #:boolean)
23
#+genera (:export #:boolean #:ensure-directories-exist)
24
#+mcl (:shadow #:user-homedir-pathname))
25
(in-package :uiop/common-lisp)
27
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
28
(error "ASDF is not supported on your implementation. Please help us port it.")
30
;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
33
;;;; Early meta-level tweaks
35
#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
36
clozure lispworks (and sbcl sb-unicode) scl)
37
(eval-when (:load-toplevel :compile-toplevel :execute)
38
(pushnew :asdf-unicode *features*))
41
(eval-when (:load-toplevel :compile-toplevel :execute)
42
(defparameter *acl-warn-save*
43
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
44
excl:*warn-on-nested-reader-conditionals*))
45
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)
46
(setf excl:*warn-on-nested-reader-conditionals* nil))
47
(setf *print-readably* nil))
50
(eval-when (:load-toplevel :compile-toplevel :execute)
51
(deftype logical-pathname () nil)
52
(defun make-broadcast-stream () *error-output*)
53
(defun translate-logical-pathname (x) x)
54
(defun user-homedir-pathname (&optional host)
55
(declare (ignore host))
56
(parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
57
(defun file-namestring (p)
59
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
62
(eval-when (:load-toplevel :compile-toplevel :execute)
63
(setf *load-verbose* nil)
64
(defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
65
(unless (use-ecl-byte-compiler-p) (require :cmp)))
67
#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
68
(eval-when (:load-toplevel :compile-toplevel :execute)
69
(unless (member :ansi-cl *features*)
70
(error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
71
(setf compiler::*compiler-default-type* (pathname "")
72
compiler::*lsp-ext* ""))
75
(eval-when (:compile-toplevel :load-toplevel :execute)
76
(shadow 'type-of :uiop/common-lisp)
77
(shadowing-import 'system:*load-pathname* :uiop/common-lisp))
80
(eval-when (:compile-toplevel :load-toplevel :execute)
81
(export 'type-of :uiop/common-lisp)
82
(export 'system:*load-pathname* :uiop/common-lisp))
84
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
85
(eval-when (:load-toplevel :compile-toplevel :execute)
87
(deftype logical-pathname () nil)
88
(defun type-of (x) (class-name (class-of x)))
89
(defun wild-pathname-p (path) (declare (ignore path)) nil)
90
(defun translate-logical-pathname (x) x)
91
(defvar *compile-file-pathname* nil)
92
(defun pathname-match-p (in-pathname wild-pathname)
93
(declare (ignore in-wildname wild-wildname)) nil)
94
(defun translate-pathname (source from-wildname to-wildname &key)
95
(declare (ignore from-wildname to-wildname)) source)
96
(defun %print-unreadable-object (object stream type identity thunk)
97
(format stream "#<~@[~S ~]" (when type (type-of object)))
99
(format stream "~@[ ~X~]>" (when identity (system:address object))))
100
(defmacro with-standard-io-syntax (&body body)
102
(defmacro with-compilation-unit (options &body body)
103
(declare (ignore options)) `(progn ,@body))
104
(defmacro print-unreadable-object ((object stream &key type identity) &body body)
105
`(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
106
(defun ensure-directories-exist (path)
107
(lisp:system (format nil "mkdir -p ~S"
108
(namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
111
(eval-when (:load-toplevel :compile-toplevel :execute)
112
(unless (fboundp 'ensure-directories-exist)
113
(defun ensure-directories-exist (path)
114
(fs:create-directories-recursively (pathname path)))))
116
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
118
"(eval-when (:load-toplevel :compile-toplevel :execute)
119
(ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
120
(ccl:define-entry-point (_system \"system\") ((name :string)) :int)
121
;; Note: ASDF may expect user-homedir-pathname to provide
122
;; the pathname of the current user's home directory, whereas
123
;; MCL by default provides the directory from which MCL was started.
124
;; See http://code.google.com/p/mcl/wiki/Portability
125
(defun user-homedir-pathname ()
126
(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
127
(defun probe-posix (posix-namestring)
128
\"If a file exists for the posix namestring, return the pathname\"
129
(ccl::with-cstrs ((cpath posix-namestring))
130
(ccl::rlet ((is-dir :boolean)
132
(when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
133
(ccl::%path-from-fsref fsref is-dir))))))"))
136
(eval-when (:load-toplevel :compile-toplevel :execute)
138
(setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
142
(eval-when (:load-toplevel :compile-toplevel :execute)
143
(defmacro loop* (&rest rest)
144
#-genera `(loop ,@rest)
145
#+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
148
;;;; compatfmt: avoid fancy format directives when unsupported
149
(eval-when (:load-toplevel :compile-toplevel :execute)
150
(defun frob-substrings (string substrings &optional frob)
151
(declare (optimize (speed 0) (safety 3) (debug 3)))
152
(let ((length (length string)) (stream nil))
153
(labels ((emit-string (x &optional (start 0) (end (length x)))
155
(unless stream (setf stream (make-string-output-stream)))
156
(write-string x stream :start start :end end)))
157
(emit-substring (start end)
158
(when (and (zerop start) (= end length))
159
(return-from frob-substrings string))
160
(emit-string string start end))
161
(recurse (substrings start end)
164
((null substrings) (emit-substring start end))
165
(t (let* ((sub-spec (first substrings))
166
(sub (if (consp sub-spec) (car sub-spec) sub-spec))
167
(fun (if (consp sub-spec) (cdr sub-spec) frob))
168
(found (search sub string :start2 start :end2 end))
169
(more (rest substrings)))
172
(recurse more start found)
175
(string (emit-string fun))
176
(function (funcall fun sub #'emit-string)))
177
(recurse substrings (+ found (length sub)) end))
179
(recurse more start end))))))))
180
(recurse substrings 0 length))
181
(if stream (get-output-stream-string stream) "")))
183
(defmacro compatfmt (format)
185
(frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
186
#-(or gcl genera) format))
added
removed
uiop/common-lisp.lisp
