compatibility.lisp 6.44 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
(asdf/package:define-package :asdf/compatibility
8
  (:use :common-lisp :asdf/package)
9
  (:recycle :asdf/compatibility :asdf)
10
  #+allegro (:intern #:*acl-warn-save*)
11 12 13 14 15 16 17
  #+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)
18
  #+mcl (:export #:probe-posix #:current-user-homedir-pathname)
19
  (:export
20 21
   #:strcat #:compatfmt))
(in-package :asdf/compatibility)
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41

#-(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*)
42 43
    (setf excl:*warn-on-nested-reader-conditionals* nil))
  (setf *print-readably* nil))
44 45 46 47 48 49 50 51 52 53 54

#+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)))
55
    (format t "Detected an old GCL 2.6. Only limited functionality available.~%")
56
    (shadow 'type-of :asdf/compatibility)
57
    (export 'with-standard-io-syntax)
58
    (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
59 60 61 62 63
    (pushnew :gcl<2.7 *features*))
  (unless (member :ansi-cl *features*)
    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
  (setf compiler::*compiler-default-type* (pathname "")
        compiler::*lsp-ext* ""))
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83

#+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.
84
  (defvar *gcl<2.7* t)
85 86 87 88 89 90 91 92 93 94 95 96 97
  (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))))
98 99
  (defmacro with-standard-io-syntax (&body body)
    `(progn ,@body))
100 101 102 103 104
  (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)
105 106
    (lisp:system (format nil "mkdir -p ~S"
                         (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
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 145 146 147 148 149

#+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)