common-lisp.lisp 7.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
9
10
11
12
13
;;; A few functions are defined here, but actually exported from utility;
;;; from this package only common-lisp symbols are exported.

(asdf/package:define-package :asdf/common-lisp
  (:nicknames :asdf/cl)
  (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
  (:reexport :common-lisp)
  (:recycle :asdf/common-lisp :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
25
  #+mcl (:shadow #:user-homedir-pathname))
(in-package :asdf/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
#+cormanlisp
50
(eval-when (:load-toplevel :compile-toplevel :execute)
51
52
53
  (deftype logical-pathname () nil)
  (defun make-broadcast-stream () *error-output*)
  (defun translate-logical-pathname (x) x)
54
55
56
  (defun user-homedir-pathname (&optional host)
    (declare (ignore host))
    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
57
58
59
60
  (defun file-namestring (p)
    (setf p (pathname p))
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))

61
62
#+ecl
(eval-when (:load-toplevel :compile-toplevel :execute)
63
  (setf *load-verbose* nil)
64
65
66
67
68
  (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)
69
70
71
72
  (unless (member :ansi-cl *features*)
    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
  (setf compiler::*compiler-default-type* (pathname "")
        compiler::*lsp-ext* ""))
73

74
75
76
77
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadow 'type-of :asdf/common-lisp)
  (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
78

79
80
81
82
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
  (export 'type-of :asdf/common-lisp)
  (export 'system:*load-pathname* :asdf/common-lisp))
83

84
85
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(eval-when (:load-toplevel :compile-toplevel :execute)
86
  (defvar *gcl2.6* t)
87
88
89
90
91
92
93
94
95
96
97
98
99
  (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))))
100
101
  (defmacro with-standard-io-syntax (&body body)
    `(progn ,@body))
102
103
104
105
106
  (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)
107
108
    (lisp:system (format nil "mkdir -p ~S"
                         (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
109
110

#+genera
111
112
113
114
(eval-when (:load-toplevel :compile-toplevel :execute)
  (unless (fboundp 'ensure-directories-exist)
    (defun ensure-directories-exist (path)
      (fs:create-directories-recursively (pathname path)))))
115

116
#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
117
      (read-from-string
118
       "(eval-when (:load-toplevel :compile-toplevel :execute)
119
120
121
122
123
124
          (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
125
          (defun user-homedir-pathname ()
126
127
128
129
130
131
132
133
134
            (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))))))"))

135
136
137
138
139
#+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

140

141
;;;; Looping
142
143
144
145
(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.
146

147
148

;;;; compatfmt: avoid fancy format directives when unsupported
149
(eval-when (:load-toplevel :compile-toplevel :execute)
150
151
152
153
154
  (defun remove-substrings (substrings string)
    (let ((length (length string)) (stream nil))
      (labels ((emit (start end)
                 (when (and (zerop start) (= end length))
                   (return-from remove-substrings string))
155
156
157
                 (when (< start end)
                   (unless stream (setf stream (make-string-output-stream)))
                   (write-string string stream :start start :end end)))
158
159
               (recurse (substrings start end)
                 (cond
160
                   ((>= start end))
161
162
                   ((null substrings) (emit start end))
                   (t (let* ((sub (first substrings))
163
                             (found (search sub string :start2 start :end2 end))
164
165
166
167
                             (more (rest substrings)))
                        (cond
                          (found
                           (recurse more start found)
168
                           (recurse substrings (+ found (length sub)) end))
169
170
171
172
                          (t
                           (recurse more start end))))))))
        (recurse substrings 0 length))
      (if stream (get-output-stream-string stream) ""))))
173
174
175

(defmacro compatfmt (format)
  #+(or gcl genera)
176
177
178
179
  (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
  #-(or gcl genera) format)