common-lisp.lisp 9.38 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 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 cmucl ecl mkcl 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
             #+sbcl (member :sb-unicode *features*))
37 38
    ;; 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.
39
    (pushnew :asdf-unicode *features*)))
40 41 42

#+allegro
(eval-when (:load-toplevel :compile-toplevel :execute)
43 44 45 46 47 48
  ;; 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))
49 50 51 52
  (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*)
53 54
    (setf excl:*warn-on-nested-reader-conditionals* nil))
  (setf *print-readably* nil))
55

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

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

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

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

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

98
#+gcl
99
(eval-when (:load-toplevel :compile-toplevel :execute)
100 101 102
  (unless (member :ansi-cl *features*)
    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
  (setf compiler::*compiler-default-type* (pathname "")
103 104 105 106 107 108 109 110 111 112
        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))
113 114

#+genera
115
(eval-when (:load-toplevel :compile-toplevel :execute)
116 117 118 119
  (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))))
120 121
  (unless (fboundp 'ensure-directories-exist)
    (defun ensure-directories-exist (path)
122 123 124 125 126 127 128 129
      (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)))
130

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

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

155

156
;;;; Looping
157 158 159 160
(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.
161

162 163

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

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