common-lisp.lisp 9.86 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
(uiop/package:define-package :uiop/common-lisp
10
  (:nicknames :uoip/cl)
11
12
  (:use :uiop/package)
  (:use-reexport #-genera :common-lisp #+genera :future-common-lisp)
13
  #+allegro (:intern #:*acl-warn-save*)
14
  #+cormanlisp (:shadow #:user-homedir-pathname)
15
16
17
18
  #+cormanlisp
  (:export
   #:logical-pathname #:translate-logical-pathname
   #:make-broadcast-stream #:file-namestring)
19
  #+genera (:shadowing-import-from :scl #:boolean)
20
  #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence)
21
  #+(or mcl cmucl) (:shadow #:user-homedir-pathname))
22
(in-package :uiop/common-lisp)
23

24
#-(or abcl allegro clasp clisp clozure cmucl cormanlisp ecl gcl genera lispworks mcl mezzano mkcl sbcl scl xcl)
25
26
27
28
29
30
31
(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

32
#+(or allegro clasp clisp clozure cmucl ecl mezzano mkcl sbcl)
33
(eval-when (:load-toplevel :compile-toplevel :execute)
34
  (when (and #+allegro (member :ics *features*)
35
             #+(or clasp clisp cmucl ecl mkcl) (member :unicode *features*)
36
             #+clozure (member :openmcl-unicode-strings *features*)
37
             #+sbcl (member :sb-unicode *features*))
38
39
    ;; 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.
40
    (pushnew :asdf-unicode *features*)))
41
42
43

#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
44
45
46
47
48
49
  ;; We need to disable autoloading BEFORE any mention of package ASDF.
  ;; In particular, there must NOT be a mention of package ASDF in the defpackage of this file
  ;; or any previous file.
  (setf excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
                :test 'equalp :key 'car))
50
51
52
53
  (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*)
54
55
    (setf excl:*warn-on-nested-reader-conditionals* nil))
  (setf *print-readably* nil))
56

Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
57
58
59
60
61
#+clasp
(eval-when (:load-toplevel :compile-toplevel :execute)
  (setf *load-verbose* nil)
  (defun use-ecl-byte-compiler-p () nil))

62
#+clozure (in-package :ccl)
63
#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117
64
65
66
67
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (fboundp 'external-process-wait)
    (in-development-mode
     (defun external-process-wait (proc)
68
       (when (and (external-process-pid proc) (eq (external-process-%status proc) :running))
69
         (with-interrupts-enabled
70
71
72
             (wait-on-semaphore (external-process-completed proc))))
       (values (external-process-%exit-code proc)
               (external-process-%status proc))))))
73
74
75
76
#+clozure (in-package :uiop/common-lisp) ;; back in this package.

#+cmucl
(eval-when (:load-toplevel :compile-toplevel :execute)
77
78
79
  (setf ext:*gc-verbose* nil)
  (defun user-homedir-pathname ()
    (first (ext:search-list (cl:user-homedir-pathname)))))
80

81
#+cormanlisp
82
(eval-when (:load-toplevel :compile-toplevel :execute)
83
84
85
  (deftype logical-pathname () nil)
  (defun make-broadcast-stream () *error-output*)
  (defun translate-logical-pathname (x) x)
86
87
88
  (defun user-homedir-pathname (&optional host)
    (declare (ignore host))
    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
89
90
91
92
  (defun file-namestring (p)
    (setf p (pathname p))
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))

Elias Pipping's avatar
Elias Pipping committed
93
#+ecl
94
(eval-when (:load-toplevel :compile-toplevel :execute)
95
  (setf *load-verbose* nil)
96
97
98
  (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
  (unless (use-ecl-byte-compiler-p) (require :cmp)))

99
#+gcl
100
(eval-when (:load-toplevel :compile-toplevel :execute)
101
102
103
  (unless (member :ansi-cl *features*)
    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
  (setf compiler::*compiler-default-type* (pathname "")
104
105
106
107
108
109
110
111
112
113
        compiler::*lsp-ext* "")
  #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later.
            (cond
              #+gcl
              ((or (< system::*gcl-major-version* 2)
                   (and (= system::*gcl-major-version* 2)
                        (< system::*gcl-minor-version* 7)))
               '(error "GCL 2.7 or later required to use ASDF")))))
      (eval code)
      code))
114
115

#+genera
116
(eval-when (:load-toplevel :compile-toplevel :execute)
117
118
119
120
  (unless (fboundp 'lambda)
    (defmacro lambda (&whole form &rest bvl-decls-and-body)
      (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1))
      `#',(cons 'lisp::lambda (cdr form))))
121
122
  (unless (fboundp 'ensure-directories-exist)
    (defun ensure-directories-exist (path)
123
124
125
126
127
128
129
130
      (fs:create-directories-recursively (pathname path))))
  (unless (fboundp 'read-sequence)
    (defun read-sequence (sequence stream &key (start 0) end)
      (scl:send stream :string-in nil sequence start end)))
  (unless (fboundp 'write-sequence)
    (defun write-sequence (sequence stream &key (start 0) end)
      (scl:send stream :string-out sequence start end)
      sequence)))
131

132
133
134
135
136
137
138
139
140
141
142
#+lispworks
(eval-when (:load-toplevel :compile-toplevel :execute)
  ;; lispworks 3 and earlier cannot be checked for so we always assume
  ;; at least version 4
  (unless (member :lispworks4 *features*)
    (pushnew :lispworks5+ *features*)
    (unless (member :lispworks5 *features*)
      (pushnew :lispworks6+ *features*)
      (unless (member :lispworks6 *features*)
        (pushnew :lispworks7+ *features*)))))

143
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
144
      (read-from-string
145
       "(eval-when (:load-toplevel :compile-toplevel :execute)
146
147
148
149
150
151
          (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
152
          (defun user-homedir-pathname ()
153
154
155
156
157
158
159
160
161
            (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))))))"))

162
163
164
165
166
#+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

167

168
;;;; Looping
169
170
171
172
(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.
173

174
175

;;;; compatfmt: avoid fancy format directives when unsupported
176
(eval-when (:load-toplevel :compile-toplevel :execute)
177
  (defun frob-substrings (string substrings &optional frob)
178
179
180
181
182
183
    "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."
184
    (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3)))
185
    (let ((length (length string)) (stream nil))
186
      (labels ((emit-string (x &optional (start 0) (end (length x)))
187
188
                 (when (< start end)
                   (unless stream (setf stream (make-string-output-stream)))
189
190
191
192
193
                   (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))
194
195
               (recurse (substrings start end)
                 (cond
196
                   ((>= start end))
197
198
199
200
                   ((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))
201
                             (found (search sub string :start2 start :end2 end))
202
203
204
205
                             (more (rest substrings)))
                        (cond
                          (found
                           (recurse more start found)
206
207
208
209
                           (etypecase fun
                             (null)
                             (string (emit-string fun))
                             (function (funcall fun sub #'emit-string)))
210
                           (recurse substrings (+ found (length sub)) end))
211
212
213
                          (t
                           (recurse more start end))))))))
        (recurse substrings 0 length))
214
      (if stream (get-output-stream-string stream) "")))
215

216
217
  (defmacro compatfmt (format)
    #+(or gcl genera)
218
    (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>")))
219
    #-(or gcl genera) format))