common-lisp.lisp 9.48 KB
Newer Older
1
;;;; -------------------------------------------------------------------------
2
3
4
5
;;;; Handle compatibility with multiple implementations.
;;; This file is for papering over the deficiencies and peculiarities
;;; of various Common Lisp implementations.
;;; For implementation-specific access to the system, see os.lisp instead.
6
7
8
;;; A few functions are defined here, but actually exported from utility;
;;; from this package only common-lisp symbols are exported.

9
10
11
(uiop/package:define-package :uiop/common-lisp
  (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
  (: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)
16
17
18
19
  #+cormanlisp
  (:export
   #:logical-pathname #:translate-logical-pathname
   #:make-broadcast-stream #:file-namestring)
20
21
22
  #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
  #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
  #+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)
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

#-(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)
  (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*)
46
47
    (setf excl:*warn-on-nested-reader-conditionals* nil))
  (setf *print-readably* nil))
48

49
#+clozure (in-package :ccl)
50
#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
51
52
53
54
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (fboundp 'external-process-wait)
    (in-development-mode
     (defun external-process-wait (proc)
55
       (when (and (external-process-pid proc) (eq (external-process-:%status proc) :running))
56
         (with-interrupts-enabled
57
58
59
60
             (wait-on-semaphore (external-process-completed proc))))
       (values (external-process-%exit-code proc)
               (external-process-%status proc))))))
#+clozure (in-package :uiop/common-lisp)
61
62


63
#+cormanlisp
64
(eval-when (:load-toplevel :compile-toplevel :execute)
65
66
67
  (deftype logical-pathname () nil)
  (defun make-broadcast-stream () *error-output*)
  (defun translate-logical-pathname (x) x)
68
69
70
  (defun user-homedir-pathname (&optional host)
    (declare (ignore host))
    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
71
72
73
74
  (defun file-namestring (p)
    (setf p (pathname p))
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))

75
76
#+ecl
(eval-when (:load-toplevel :compile-toplevel :execute)
77
  (setf *load-verbose* nil)
78
79
80
81
82
  (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)
83
84
85
86
  (unless (member :ansi-cl *features*)
    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
  (setf compiler::*compiler-default-type* (pathname "")
        compiler::*lsp-ext* ""))
87

88
89
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
90
91
  (shadow 'type-of :uiop/common-lisp)
  (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
92

93
94
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
95
96
  (export 'type-of :uiop/common-lisp)
  (export 'system:*load-pathname* :uiop/common-lisp))
97

98
99
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(eval-when (:load-toplevel :compile-toplevel :execute)
100
  (defvar *gcl2.6* t)
101
102
103
104
105
106
107
108
109
110
111
112
113
  (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))))
114
115
  (defmacro with-standard-io-syntax (&body body)
    `(progn ,@body))
116
117
118
119
120
  (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)
121
122
    (lisp:system (format nil "mkdir -p ~S"
                         (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
123
124

#+genera
125
126
127
128
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (fboundp 'ensure-directories-exist)
    (defun ensure-directories-exist (path)
      (fs:create-directories-recursively (pathname path)))))
129

130
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
131
      (read-from-string
132
       "(eval-when (:load-toplevel :compile-toplevel :execute)
133
134
135
136
137
138
          (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
139
          (defun user-homedir-pathname ()
140
141
142
143
144
145
146
147
148
            (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))))))"))

149
150
151
152
153
#+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

154

155
;;;; Looping
156
157
158
159
(eval-when (:load-toplevel :compile-toplevel :execute)
  (defmacro loop* (&rest rest)
    #-genera `(loop ,@rest)
    #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
160

161
162

;;;; compatfmt: avoid fancy format directives when unsupported
163
(eval-when (:load-toplevel :compile-toplevel :execute)
164
  (defun frob-substrings (string substrings &optional frob)
165
166
167
168
169
170
    "for each substring in SUBSTRINGS, find occurrences of it within STRING
that don't use parts of matched occurrences of previous strings, and
FROB them, that is to say, remove them if FROB is NIL,
replace by FROB if FROB is a STRING, or if FROB is a FUNCTION,
call FROB with the match and a function that emits a string in the output.
Return a string made of the parts not omitted or emitted by FROB."
171
    (declare (optimize (speed 0) (safety 3) (debug 3)))
172
    (let ((length (length string)) (stream nil))
173
      (labels ((emit-string (x &optional (start 0) (end (length x)))
174
175
                 (when (< start end)
                   (unless stream (setf stream (make-string-output-stream)))
176
177
178
179
180
                   (write-string x stream :start start :end end)))
               (emit-substring (start end)
                 (when (and (zerop start) (= end length))
                   (return-from frob-substrings string))
                 (emit-string string start end))
181
182
               (recurse (substrings start end)
                 (cond
183
                   ((>= start end))
184
185
186
187
                   ((null substrings) (emit-substring start end))
                   (t (let* ((sub-spec (first substrings))
                             (sub (if (consp sub-spec) (car sub-spec) sub-spec))
                             (fun (if (consp sub-spec) (cdr sub-spec) frob))
188
                             (found (search sub string :start2 start :end2 end))
189
190
191
192
                             (more (rest substrings)))
                        (cond
                          (found
                           (recurse more start found)
193
194
195
196
                           (etypecase fun
                             (null)
                             (string (emit-string fun))
                             (function (funcall fun sub #'emit-string)))
197
                           (recurse substrings (+ found (length sub)) end))
198
199
200
                          (t
                           (recurse more start end))))))))
        (recurse substrings 0 length))
201
      (if stream (get-output-stream-string stream) "")))
202

203
204
  (defmacro compatfmt (format)
    #+(or gcl genera)
205
    (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
206
    #-(or gcl genera) format))