Changeset 15737 for release


Ignore:
Timestamp:
Feb 16, 2013, 5:47:16 PM (6 years ago)
Author:
rme
Message:

Merge ASDF 2.29 from trunk.

Location:
release/1.9/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.9/source

  • release/1.9/source/tools/asdf.lisp

    r15634 r15737  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.28: Another System Definition Facility.
     2;;; This is ASDF 2.29: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    7575        (rename-package :asdf away)
    7676        (when *load-verbose*
    77           (format t "; First thing, renamed package ~A away to ~A~%" :asdf away))))))
     77          (format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
    7878
    7979;;;; ---------------------------------------------------------------------------
     
    833833
    834834#+cormanlisp
    835 (progn
     835(eval-when (:load-toplevel :compile-toplevel :execute)
    836836  (deftype logical-pathname () nil)
    837837  (defun make-broadcast-stream () *error-output*)
     
    867867  (export 'system:*load-pathname* :asdf/common-lisp))
    868868
    869 #+gcl2.6
    870 (progn ;; Doesn't support either logical-pathnames or output-translations.
     869#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
     870(eval-when (:load-toplevel :compile-toplevel :execute)
    871871  (defvar *gcl2.6* t)
    872872  (deftype logical-pathname () nil)
     
    894894
    895895#+genera
    896 (unless (fboundp 'ensure-directories-exist)
    897   (defun ensure-directories-exist (path)
    898     (fs:create-directories-recursively (pathname path))))
    899 
    900 #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
     896(eval-when (:load-toplevel :compile-toplevel :execute)
     897  (unless (fboundp 'ensure-directories-exist)
     898    (defun ensure-directories-exist (path)
     899      (fs:create-directories-recursively (pathname path)))))
     900
     901#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick
    901902      (read-from-string
    902        "(eval-when (:compile-toplevel :load-toplevel :execute)
     903       "(eval-when (:load-toplevel :compile-toplevel :execute)
    903904          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
    904905          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
     
    924925
    925926;;;; Looping
    926 (defmacro loop* (&rest rest)
    927   #-genera `(loop ,@rest)
    928   #+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
     927(eval-when (:load-toplevel :compile-toplevel :execute)
     928  (defmacro loop* (&rest rest)
     929    #-genera `(loop ,@rest)
     930    #+genera `(lisp:loop ,@rest))) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
    929931
    930932
     
    953955                           (recurse more start end))))))))
    954956        (recurse substrings 0 length))
    955       (if stream (get-output-stream-string stream) ""))))
    956 
    957 (defmacro compatfmt (format)
    958   #+(or gcl genera)
    959   (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
    960   #-(or gcl genera) format)
     957      (if stream (get-output-stream-string stream) "")))
     958
     959  (defmacro compatfmt (format)
     960    #+(or gcl genera)
     961    (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
     962    #-(or gcl genera) format))
    961963
    962964
     
    975977   ;; magic helper to define debugging functions:
    976978   #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
    977    #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions
     979   #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
    978980   #:if-let ;; basic flow control
    979981   #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
     
    10371039                 (,',def ,name ,formals ,@rest))))))
    10381040    (defdef defgeneric* defgeneric)
    1039     (defdef defun* defun)))
    1040 
     1041    (defdef defun* defun))
     1042  (defmacro with-upgradability ((&optional) &body body)
     1043    `(eval-when (:compile-toplevel :load-toplevel :execute)
     1044       ,@(loop :for form :in body :collect
     1045               (if (consp form)
     1046                   (destructuring-bind (car . cdr) form
     1047                     (case car
     1048                       ((defun) `(defun* ,@cdr))
     1049                       ((defgeneric)
     1050                        (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr))))
     1051                          `(defgeneric* ,@cdr)))
     1052                       (otherwise form)))
     1053                   form)))))
    10411054
    10421055;;; Magic debugging help. See contrib/debug.lisp
    1043 (defvar *asdf-debug-utility*
    1044   '(or (ignore-errors
    1045         (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
    1046     (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
    1047   "form that evaluates to the pathname to your favorite debugging utilities")
    1048 
    1049 (defmacro asdf-debug (&rest keys)
    1050   `(eval-when (:compile-toplevel :load-toplevel :execute)
    1051      (load-asdf-debug-utility ,@keys)))
    1052 
    1053 (defun* load-asdf-debug-utility (&key package utility-file)
    1054   (let* ((*package* (if package (find-package package) *package*))
    1055          (keyword (read-from-string
    1056                    (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
    1057     (unless (member keyword *features*)
    1058       (let* ((utility-file (or utility-file *asdf-debug-utility*))
    1059              (file (ignore-errors (probe-file (eval utility-file)))))
    1060         (if file (load file)
    1061             (error "Failed to locate debug utility file: ~S" utility-file))))))
     1056(with-upgradability ()
     1057  (defvar *asdf-debug-utility*
     1058    '(or (ignore-errors
     1059          (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
     1060      (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
     1061    "form that evaluates to the pathname to your favorite debugging utilities")
     1062
     1063  (defmacro asdf-debug (&rest keys)
     1064    `(eval-when (:compile-toplevel :load-toplevel :execute)
     1065       (load-asdf-debug-utility ,@keys)))
     1066
     1067  (defun load-asdf-debug-utility (&key package utility-file)
     1068    (let* ((*package* (if package (find-package package) *package*))
     1069           (keyword (read-from-string
     1070                     (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
     1071      (unless (member keyword *features*)
     1072        (let* ((utility-file (or utility-file *asdf-debug-utility*))
     1073               (file (ignore-errors (probe-file (eval utility-file)))))
     1074          (if file (load file)
     1075              (error "Failed to locate debug utility file: ~S" utility-file)))))))
    10621076
    10631077
    10641078;;; Flow control
    1065 (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
    1066   ;; bindings can be (var form) or ((var1 form1) ...)
    1067   (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
    1068                            (list bindings)
    1069                            bindings))
    1070          (variables (mapcar #'car binding-list)))
    1071     `(let ,binding-list
    1072        (if (and ,@variables)
    1073            ,then-form
    1074            ,else-form))))
     1079(with-upgradability ()
     1080  (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
     1081    ;; bindings can be (var form) or ((var1 form1) ...)
     1082    (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
     1083                             (list bindings)
     1084                             bindings))
     1085           (variables (mapcar #'car binding-list)))
     1086      `(let ,binding-list
     1087         (if (and ,@variables)
     1088             ,then-form
     1089             ,else-form)))))
    10751090
    10761091;;; List manipulation
    1077 (defmacro while-collecting ((&rest collectors) &body body)
    1078   "COLLECTORS should be a list of names for collections.  A collector
     1092(with-upgradability ()
     1093  (defmacro while-collecting ((&rest collectors) &body body)
     1094    "COLLECTORS should be a list of names for collections.  A collector
    10791095defines a function that, when applied to an argument inside BODY, will
    10801096add its argument to the corresponding collection.  Returns multiple values,
     
    10861102             \(bar \(second x\)\)\)\)
    10871103Returns two values: \(A B C\) and \(1 2 3\)."
    1088   (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
    1089         (initial-values (mapcar (constantly nil) collectors)))
    1090     `(let ,(mapcar #'list vars initial-values)
    1091        (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
    1092          ,@body
    1093          (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    1094 
    1095 (define-modify-macro appendf (&rest args)
    1096   append "Append onto list") ;; only to be used on short lists.
    1097 
    1098 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
    1099   (check-type n (integer 0 *))
    1100   (loop
    1101     :for l = x :then (cdr l)
    1102     :for i :downfrom n :do
    1103     (cond
    1104       ((zerop i) (return (null l)))
    1105       ((not (consp l)) (return nil)))))
     1104    (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
     1105          (initial-values (mapcar (constantly nil) collectors)))
     1106      `(let ,(mapcar #'list vars initial-values)
     1107         (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
     1108           ,@body
     1109           (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
     1110
     1111  (define-modify-macro appendf (&rest args)
     1112    append "Append onto list") ;; only to be used on short lists.
     1113
     1114  (defun length=n-p (x n) ;is it that (= (length x) n) ?
     1115    (check-type n (integer 0 *))
     1116    (loop
     1117      :for l = x :then (cdr l)
     1118      :for i :downfrom n :do
     1119        (cond
     1120          ((zerop i) (return (null l)))
     1121          ((not (consp l)) (return nil))))))
    11061122
    11071123;;; remove a key from a plist, i.e. for keyword argument cleanup
    1108 (defun* remove-plist-key (key plist)
    1109   "Remove a single key from a plist"
    1110   (loop* :for (k v) :on plist :by #'cddr
    1111     :unless (eq k key)
    1112     :append (list k v)))
    1113 
    1114 (defun* remove-plist-keys (keys plist)
    1115   "Remove a list of keys from a plist"
    1116   (loop* :for (k v) :on plist :by #'cddr
    1117     :unless (member k keys)
    1118     :append (list k v)))
     1124(with-upgradability ()
     1125  (defun remove-plist-key (key plist)
     1126    "Remove a single key from a plist"
     1127    (loop* :for (k v) :on plist :by #'cddr
     1128           :unless (eq k key)
     1129           :append (list k v)))
     1130
     1131  (defun remove-plist-keys (keys plist)
     1132    "Remove a list of keys from a plist"
     1133    (loop* :for (k v) :on plist :by #'cddr
     1134           :unless (member k keys)
     1135           :append (list k v))))
    11191136
    11201137
    11211138;;; Sequences
    1122 (defun* emptyp (x)
    1123   "Predicate that is true for an empty sequence"
    1124   (or (null x) (and (vectorp x) (zerop (length x)))))
     1139(with-upgradability ()
     1140  (defun emptyp (x)
     1141    "Predicate that is true for an empty sequence"
     1142    (or (null x) (and (vectorp x) (zerop (length x))))))
    11251143
    11261144
    11271145;;; Strings
    1128 (defun* strcat (&rest strings)
    1129   (apply 'concatenate 'string strings))
    1130 
    1131 (defun* first-char (s)
    1132   (and (stringp s) (plusp (length s)) (char s 0)))
    1133 
    1134 (defun* last-char (s)
    1135   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    1136 
    1137 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
    1138   "Split STRING into a list of components separated by
     1146(with-upgradability ()
     1147  (defun strcat (&rest strings)
     1148    (apply 'concatenate 'string strings))
     1149
     1150  (defun first-char (s)
     1151    (and (stringp s) (plusp (length s)) (char s 0)))
     1152
     1153  (defun last-char (s)
     1154    (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
     1155
     1156  (defun split-string (string &key max (separator '(#\Space #\Tab)))
     1157    "Split STRING into a list of components separated by
    11391158any of the characters in the sequence SEPARATOR.
    11401159If MAX is specified, then no more than max(1,MAX) components will be returned,
    11411160starting the separation from the end, e.g. when called with arguments
    11421161 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    1143   (block ()
    1144     (let ((list nil) (words 0) (end (length string)))
    1145       (flet ((separatorp (char) (find char separator))
    1146              (done () (return (cons (subseq string 0 end) list))))
    1147         (loop
    1148           :for start = (if (and max (>= words (1- max)))
    1149                            (done)
    1150                            (position-if #'separatorp string :end end :from-end t)) :do
    1151           (when (null start)
    1152             (done))
    1153           (push (subseq string (1+ start) end) list)
    1154           (incf words)
    1155           (setf end start))))))
    1156 
    1157 (defun* string-prefix-p (prefix string)
    1158   "Does STRING begin with PREFIX?"
    1159   (let* ((x (string prefix))
    1160          (y (string string))
    1161          (lx (length x))
    1162          (ly (length y)))
    1163     (and (<= lx ly) (string= x y :end2 lx))))
    1164 
    1165 (defun* string-suffix-p (string suffix)
    1166   "Does STRING end with SUFFIX?"
    1167   (let* ((x (string string))
    1168          (y (string suffix))
    1169          (lx (length x))
    1170          (ly (length y)))
    1171     (and (<= ly lx) (string= x y :start1 (- lx ly)))))
    1172 
    1173 (defun* string-enclosed-p (prefix string suffix)
    1174   "Does STRING begin with PREFIX and end with SUFFIX?"
    1175   (and (string-prefix-p prefix string)
    1176        (string-suffix-p string suffix)))
     1162    (block ()
     1163      (let ((list nil) (words 0) (end (length string)))
     1164        (flet ((separatorp (char) (find char separator))
     1165               (done () (return (cons (subseq string 0 end) list))))
     1166          (loop
     1167            :for start = (if (and max (>= words (1- max)))
     1168                             (done)
     1169                             (position-if #'separatorp string :end end :from-end t)) :do
     1170                               (when (null start)
     1171                                 (done))
     1172                               (push (subseq string (1+ start) end) list)
     1173                               (incf words)
     1174                               (setf end start))))))
     1175
     1176  (defun string-prefix-p (prefix string)
     1177    "Does STRING begin with PREFIX?"
     1178    (let* ((x (string prefix))
     1179           (y (string string))
     1180           (lx (length x))
     1181           (ly (length y)))
     1182      (and (<= lx ly) (string= x y :end2 lx))))
     1183
     1184  (defun string-suffix-p (string suffix)
     1185    "Does STRING end with SUFFIX?"
     1186    (let* ((x (string string))
     1187           (y (string suffix))
     1188           (lx (length x))
     1189           (ly (length y)))
     1190      (and (<= ly lx) (string= x y :start1 (- lx ly)))))
     1191
     1192  (defun string-enclosed-p (prefix string suffix)
     1193    "Does STRING begin with PREFIX and end with SUFFIX?"
     1194    (and (string-prefix-p prefix string)
     1195         (string-suffix-p string suffix))))
    11771196
    11781197
    11791198;;; CLOS
    1180 (defun* find-class* (x &optional (errorp t) environment)
    1181   (etypecase x
    1182     ((or standard-class built-in-class) x)
    1183     #+gcl2.6 (keyword nil)
    1184     (symbol (find-class x errorp environment))))
     1199(with-upgradability ()
     1200  (defun find-class* (x &optional (errorp t) environment)
     1201    (etypecase x
     1202      ((or standard-class built-in-class) x)
     1203      #+gcl2.6 (keyword nil)
     1204      (symbol (find-class x errorp environment)))))
    11851205
    11861206
    11871207;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
    1188 (deftype stamp () '(or real boolean))
    1189 (defun* stamp< (x y)
    1190   (etypecase x
    1191     (null (and y t))
    1192     ((eql t) nil)
    1193     (real (etypecase y
    1194             (null nil)
    1195             ((eql t) t)
    1196             (real (< x y))))))
    1197 (defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
    1198 (defun* stamp*< (&rest list) (stamps< list))
    1199 (defun* stamp<= (x y) (not (stamp< y x)))
    1200 (defun* earlier-stamp (x y) (if (stamp< x y) x y))
    1201 (defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
    1202 (defun* earliest-stamp (&rest list) (stamps-earliest list))
    1203 (defun* later-stamp (x y) (if (stamp< x y) y x))
    1204 (defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
    1205 (defun* latest-stamp (&rest list) (stamps-latest list))
    1206 (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)
     1208(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
     1209  (deftype stamp () '(or real boolean)))
     1210(with-upgradability ()
     1211  (defun stamp< (x y)
     1212    (etypecase x
     1213      (null (and y t))
     1214      ((eql t) nil)
     1215      (real (etypecase y
     1216              (null nil)
     1217              ((eql t) t)
     1218              (real (< x y))))))
     1219  (defun stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
     1220  (defun stamp*< (&rest list) (stamps< list))
     1221  (defun stamp<= (x y) (not (stamp< y x)))
     1222  (defun earlier-stamp (x y) (if (stamp< x y) x y))
     1223  (defun stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
     1224  (defun earliest-stamp (&rest list) (stamps-earliest list))
     1225  (defun later-stamp (x y) (if (stamp< x y) y x))
     1226  (defun stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
     1227  (defun latest-stamp (&rest list) (stamps-latest list))
     1228  (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp))
    12071229
    12081230
    12091231;;; Hash-tables
    1210 (defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
    1211   (dolist (x list h) (setf (gethash x h) t)))
     1232(with-upgradability ()
     1233  (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
     1234    (dolist (x list h) (setf (gethash x h) t))))
    12121235
    12131236
    12141237;;; Function designators
    1215 (defun* ensure-function (fun &key (package :cl))
    1216   "Coerce the object FUN into a function.
     1238(with-upgradability ()
     1239  (defun ensure-function (fun &key (package :cl))
     1240    "Coerce the object FUN into a function.
    12171241
    12181242If FUN is a FUNCTION, return it.
     
    12241248If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
    12251249and EVAL that in a (FUNCTION ...) context."
    1226   (etypecase fun
    1227     (function fun)
    1228     ((or boolean keyword character number pathname) (constantly fun))
    1229     ((or function symbol) fun)
    1230     (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
    1231     (string (eval `(function ,(with-standard-io-syntax
    1232                                 (let ((*package* (find-package package)))
    1233                                   (read-from-string fun))))))))
    1234 
    1235 (defun* access-at (object at)
    1236   "Given an OBJECT and an AT specifier, list of successive accessors,
     1250    (etypecase fun
     1251      (function fun)
     1252      ((or boolean keyword character number pathname) (constantly fun))
     1253      ((or function symbol) fun)
     1254      (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
     1255      (string (eval `(function ,(with-standard-io-syntax
     1256                                  (let ((*package* (find-package package)))
     1257                                    (read-from-string fun))))))))
     1258
     1259  (defun access-at (object at)
     1260    "Given an OBJECT and an AT specifier, list of successive accessors,
    12371261call each accessor on the result of the previous calls.
    12381262An accessor may be an integer, meaning a call to ELT,
     
    12431267As a degenerate case, the AT specifier may be an atom of a single such accessor
    12441268instead of a list."
    1245   (flet ((access (object accessor)
    1246            (etypecase accessor
    1247              (function (funcall accessor object))
    1248              (integer (elt object accessor))
    1249              (keyword (getf object accessor))
    1250              (null object)
    1251              (symbol (funcall accessor object))
    1252              (cons (funcall (ensure-function accessor) object)))))
    1253     (if (listp at)
    1254         (dolist (accessor at object)
    1255           (setf object (access object accessor)))
    1256         (access object at))))
    1257 
    1258 (defun* access-at-count (at)
    1259   "From an AT specification, extract a COUNT of maximum number
     1269    (flet ((access (object accessor)
     1270             (etypecase accessor
     1271               (function (funcall accessor object))
     1272               (integer (elt object accessor))
     1273               (keyword (getf object accessor))
     1274               (null object)
     1275               (symbol (funcall accessor object))
     1276               (cons (funcall (ensure-function accessor) object)))))
     1277      (if (listp at)
     1278          (dolist (accessor at object)
     1279            (setf object (access object accessor)))
     1280          (access object at))))
     1281
     1282  (defun access-at-count (at)
     1283    "From an AT specification, extract a COUNT of maximum number
    12601284   of sub-objects to read as per ACCESS-AT"
    1261   (cond
    1262     ((integerp at)
    1263      (1+ at))
    1264     ((and (consp at) (integerp (first at)))
    1265      (1+ (first at)))))
    1266 
    1267 (defun* call-function (function-spec &rest arguments)
    1268   (apply (ensure-function function-spec) arguments))
    1269 
    1270 (defun* call-functions (function-specs)
    1271   (map () 'call-function function-specs))
    1272 
    1273 (defun* register-hook-function (variable hook &optional call-now-p)
    1274   (pushnew hook (symbol-value variable))
    1275   (when call-now-p (call-function hook)))
     1285    (cond
     1286      ((integerp at)
     1287       (1+ at))
     1288      ((and (consp at) (integerp (first at)))
     1289       (1+ (first at)))))
     1290
     1291  (defun call-function (function-spec &rest arguments)
     1292    (apply (ensure-function function-spec) arguments))
     1293
     1294  (defun call-functions (function-specs)
     1295    (map () 'call-function function-specs))
     1296
     1297  (defun register-hook-function (variable hook &optional call-now-p)
     1298    (pushnew hook (symbol-value variable))
     1299    (when call-now-p (call-function hook))))
    12761300
    12771301
    12781302;;; Version handling
    1279 (eval-when (:compile-toplevel :load-toplevel :execute)
    1280 (defun* unparse-version (version-list)
    1281   (format nil "~{~D~^.~}" version-list))
    1282 
    1283 (defun* parse-version (version-string &optional on-error)
    1284   "Parse a VERSION-STRING as a series of natural integers separated by dots.
     1303(with-upgradability ()
     1304  (defun unparse-version (version-list)
     1305    (format nil "~{~D~^.~}" version-list))
     1306
     1307  (defun parse-version (version-string &optional on-error)
     1308    "Parse a VERSION-STRING as a series of natural integers separated by dots.
    12851309Return a (non-null) list of integers if the string is valid;
    12861310otherwise return NIL.
     
    12901314ON-ERROR is also called if the version is not canonical
    12911315in that it doesn't print back to itself, but the list is returned anyway."
    1292   (block nil
    1293    (unless (stringp version-string)
    1294      (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
    1295      (return))
    1296    (unless (loop :for prev = nil :then c :for c :across version-string
    1297                  :always (or (digit-char-p c)
    1298                              (and (eql c #\.) prev (not (eql prev #\.))))
    1299                  :finally (return (and c (digit-char-p c))))
    1300      (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
    1301                     'parse-version version-string)
    1302      (return))
    1303    (let* ((version-list
    1304             (mapcar #'parse-integer (split-string version-string :separator ".")))
    1305           (normalized-version (unparse-version version-list)))
    1306      (unless (equal version-string normalized-version)
    1307        (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
    1308      version-list)))
    1309 
    1310 (defun* lexicographic< (< x y)
    1311   (cond ((null y) nil)
    1312         ((null x) t)
    1313         ((funcall < (car x) (car y)) t)
    1314         ((funcall < (car y) (car x)) nil)
    1315         (t (lexicographic< < (cdr x) (cdr y)))))
    1316 
    1317 (defun* lexicographic<= (< x y)
    1318   (not (lexicographic< < y x)))
    1319 
    1320 (defun* version< (version1 version2)
    1321   (let ((v1 (parse-version version1 nil))
    1322         (v2 (parse-version version2 nil)))
    1323     (lexicographic< '< v1 v2)))
    1324 
    1325 (defun* version<= (version1 version2)
    1326   (not (version< version2 version1)))
    1327 
    1328 (defun* version-compatible-p (provided-version required-version)
    1329   "Is the provided version a compatible substitution for the required-version?
     1316    (block nil
     1317      (unless (stringp version-string)
     1318        (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
     1319        (return))
     1320      (unless (loop :for prev = nil :then c :for c :across version-string
     1321                    :always (or (digit-char-p c)
     1322                                (and (eql c #\.) prev (not (eql prev #\.))))
     1323                    :finally (return (and c (digit-char-p c))))
     1324        (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
     1325                       'parse-version version-string)
     1326        (return))
     1327      (let* ((version-list
     1328               (mapcar #'parse-integer (split-string version-string :separator ".")))
     1329             (normalized-version (unparse-version version-list)))
     1330        (unless (equal version-string normalized-version)
     1331          (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
     1332        version-list)))
     1333
     1334  (defun lexicographic< (< x y)
     1335    (cond ((null y) nil)
     1336          ((null x) t)
     1337          ((funcall < (car x) (car y)) t)
     1338          ((funcall < (car y) (car x)) nil)
     1339          (t (lexicographic< < (cdr x) (cdr y)))))
     1340
     1341  (defun lexicographic<= (< x y)
     1342    (not (lexicographic< < y x)))
     1343
     1344  (defun version< (version1 version2)
     1345    (let ((v1 (parse-version version1 nil))
     1346          (v2 (parse-version version2 nil)))
     1347      (lexicographic< '< v1 v2)))
     1348
     1349  (defun version<= (version1 version2)
     1350    (not (version< version2 version1)))
     1351
     1352  (defun version-compatible-p (provided-version required-version)
     1353    "Is the provided version a compatible substitution for the required-version?
    13301354If major versions differ, it's not compatible.
    13311355If they are equal, then any later version is compatible,
    13321356with later being determined by a lexicographical comparison of minor numbers."
    1333   (let ((x (parse-version provided-version nil))
    1334         (y (parse-version required-version nil)))
    1335     (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))
    1336 ); eval-when for version support
     1357    (let ((x (parse-version provided-version nil))
     1358          (y (parse-version required-version nil)))
     1359      (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x))))))
    13371360
    13381361
    13391362;;; Condition control
    13401363
    1341 (defvar *uninteresting-conditions* nil
    1342   "Uninteresting conditions, as per MATCH-CONDITION-P")
    1343 
    1344 (defparameter +simple-condition-format-control-slot+
    1345   #+abcl 'system::format-control
    1346   #+allegro 'excl::format-control
    1347   #+clisp 'system::$format-control
    1348   #+clozure 'ccl::format-control
    1349   #+(or cmu scl) 'conditions::format-control
    1350   #+ecl 'si::format-control
    1351   #+(or gcl lispworks) 'conditions::format-string
    1352   #+sbcl 'sb-kernel:format-control
    1353   #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
    1354   "Name of the slot for FORMAT-CONTROL in simple-condition")
    1355 
    1356 (defun* match-condition-p (x condition)
    1357   "Compare received CONDITION to some pattern X:
     1364(with-upgradability ()
     1365  (defvar *uninteresting-conditions* nil
     1366    "Uninteresting conditions, as per MATCH-CONDITION-P")
     1367
     1368  (defparameter +simple-condition-format-control-slot+
     1369    #+abcl 'system::format-control
     1370    #+allegro 'excl::format-control
     1371    #+clisp 'system::$format-control
     1372    #+clozure 'ccl::format-control
     1373    #+(or cmu scl) 'conditions::format-control
     1374    #+ecl 'si::format-control
     1375    #+(or gcl lispworks) 'conditions::format-string
     1376    #+sbcl 'sb-kernel:format-control
     1377    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
     1378    "Name of the slot for FORMAT-CONTROL in simple-condition")
     1379
     1380  (defun match-condition-p (x condition)
     1381    "Compare received CONDITION to some pattern X:
    13581382a symbol naming a condition class,
    13591383a simple vector of length 2, arguments to find-symbol* with result as above,
    13601384or a string describing the format-control of a simple-condition."
    1361   (etypecase x
    1362     (symbol (typep condition x))
    1363     ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
    1364     (function (funcall x condition))
    1365     (string (and (typep condition 'simple-condition)
    1366                  ;; On SBCL, it's always set and the check triggers a warning
    1367                  #+(or allegro clozure cmu lispworks scl)
    1368                 (slot-boundp condition +simple-condition-format-control-slot+)
    1369                  (ignore-errors (equal (simple-condition-format-control condition) x))))))
    1370 
    1371 (defun* match-any-condition-p (condition conditions)
    1372   "match CONDITION against any of the patterns of CONDITIONS supplied"
    1373   (loop :for x :in conditions :thereis (match-condition-p x condition)))
    1374 
    1375 (defun* call-with-muffled-conditions (thunk conditions)
    1376   (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
    1377                                     (muffle-warning c)))))
    1378     (funcall thunk)))
    1379 
    1380 (defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
    1381   `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
     1385    (etypecase x
     1386      (symbol (typep condition x))
     1387      ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
     1388      (function (funcall x condition))
     1389      (string (and (typep condition 'simple-condition)
     1390                   ;; On SBCL, it's always set and the check triggers a warning
     1391                   #+(or allegro clozure cmu lispworks scl)
     1392                  (slot-boundp condition +simple-condition-format-control-slot+)
     1393                   (ignore-errors (equal (simple-condition-format-control condition) x))))))
     1394
     1395  (defun match-any-condition-p (condition conditions)
     1396    "match CONDITION against any of the patterns of CONDITIONS supplied"
     1397    (loop :for x :in conditions :thereis (match-condition-p x condition)))
     1398
     1399  (defun call-with-muffled-conditions (thunk conditions)
     1400    (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
     1401                                      (muffle-warning c)))))
     1402      (funcall thunk)))
     1403
     1404  (defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
     1405    `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions)))
    13821406
    13831407
     
    14011425
    14021426;;; Features
    1403 (eval-when (:compile-toplevel :load-toplevel :execute)
    1404   (defun* featurep (x &optional (*features* *features*))
     1427(with-upgradability ()
     1428  (defun featurep (x &optional (*features* *features*))
    14051429    (cond
    14061430      ((atom x) (and (member x *features*) t))
     
    14101434      (t (error "Malformed feature specification ~S" x))))
    14111435
    1412   (defun* os-unix-p ()
     1436  (defun os-unix-p ()
    14131437    (or #+abcl (featurep :unix)
    14141438        #+(and (not abcl) (or unix cygwin darwin)) t))
    14151439
    1416   (defun* os-windows-p ()
     1440  (defun os-windows-p ()
    14171441    (or #+abcl (featurep :windows)
    14181442        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
    14191443
    1420   (defun* os-genera-p ()
     1444  (defun os-genera-p ()
    14211445    (or #+genera t))
    14221446
    1423   (defun* detect-os ()
     1447  (defun detect-os ()
    14241448    (flet ((yes (yes) (pushnew yes *features*))
    14251449           (no (no) (setf *features* (remove no *features*))))
     
    14351459;;;; Environment variables: getting them, and parsing them.
    14361460
    1437 (defun* getenv (x)
    1438   (declare (ignorable x))
    1439   #+(or abcl clisp ecl xcl) (ext:getenv x)
    1440   #+allegro (sys:getenv x)
    1441   #+clozure (ccl:getenv x)
    1442   #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
    1443   #+cormanlisp
    1444   (let* ((buffer (ct:malloc 1))
    1445          (cname (ct:lisp-string-to-c-string x))
    1446          (needed-size (win:getenvironmentvariable cname buffer 0))
    1447          (buffer1 (ct:malloc (1+ needed-size))))
    1448     (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
    1449                nil
    1450                (ct:c-string-to-lisp-string buffer1))
    1451       (ct:free buffer)
    1452       (ct:free buffer1)))
    1453   #+gcl (system:getenv x)
    1454   #+genera nil
    1455   #+lispworks (lispworks:environment-variable x)
    1456   #+mcl (ccl:with-cstrs ((name x))
    1457           (let ((value (_getenv name)))
    1458             (unless (ccl:%null-ptr-p value)
    1459               (ccl:%get-cstring value))))
    1460   #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
    1461   #+sbcl (sb-ext:posix-getenv x)
    1462   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    1463   (error "~S is not supported on your implementation" 'getenv))
    1464 
    1465 (defun* getenvp (x)
    1466   "Predicate that is true if the named variable is present in the libc environment,
     1461(with-upgradability ()
     1462  (defun getenv (x)
     1463    (declare (ignorable x))
     1464    #+(or abcl clisp ecl xcl) (ext:getenv x)
     1465    #+allegro (sys:getenv x)
     1466    #+clozure (ccl:getenv x)
     1467    #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
     1468    #+cormanlisp
     1469    (let* ((buffer (ct:malloc 1))
     1470           (cname (ct:lisp-string-to-c-string x))
     1471           (needed-size (win:getenvironmentvariable cname buffer 0))
     1472           (buffer1 (ct:malloc (1+ needed-size))))
     1473      (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
     1474                 nil
     1475                 (ct:c-string-to-lisp-string buffer1))
     1476        (ct:free buffer)
     1477        (ct:free buffer1)))
     1478    #+gcl (system:getenv x)
     1479    #+genera nil
     1480    #+lispworks (lispworks:environment-variable x)
     1481    #+mcl (ccl:with-cstrs ((name x))
     1482            (let ((value (_getenv name)))
     1483              (unless (ccl:%null-ptr-p value)
     1484                (ccl:%get-cstring value))))
     1485    #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
     1486    #+sbcl (sb-ext:posix-getenv x)
     1487    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     1488    (error "~S is not supported on your implementation" 'getenv))
     1489
     1490  (defun getenvp (x)
     1491    "Predicate that is true if the named variable is present in the libc environment,
    14671492then returning the non-empty string value of the variable"
    1468   (let ((g (getenv x))) (and (not (emptyp g)) g)))
     1493    (let ((g (getenv x))) (and (not (emptyp g)) g))))
    14691494
    14701495
     
    14751500;; We're back to runtime checking, for the sake of e.g. ABCL.
    14761501
    1477 (defun* first-feature (feature-sets)
    1478   (dolist (x feature-sets)
    1479     (multiple-value-bind (short long feature-expr)
    1480         (if (consp x)
    1481             (values (first x) (second x) (cons :or (rest x)))
    1482             (values x x x))
    1483       (when (featurep feature-expr)
    1484         (return (values short long))))))
    1485 
    1486 (defun* implementation-type ()
    1487   (first-feature
    1488    '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
    1489      (:cmu :cmucl :cmu) :ecl :gcl
    1490      (:lwpe :lispworks-personal-edition) (:lw :lispworks)
    1491      :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
    1492 
    1493 (defvar *implementation-type* (implementation-type))
    1494 
    1495 (defun* operating-system ()
    1496   (first-feature
    1497    '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
    1498      (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
    1499      (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
    1500      (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
    1501      :genera)))
    1502 
    1503 (defun* architecture ()
    1504   (first-feature
    1505    '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
    1506      (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
    1507      (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
    1508      :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
    1509      :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
    1510      ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
    1511      ;; we may have to segregate the code still by architecture.
    1512      (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
    1513 
    1514 #+clozure
    1515 (defun* ccl-fasl-version ()
    1516   ;; the fasl version is target-dependent from CCL 1.8 on.
    1517   (or (let ((s 'ccl::target-fasl-version))
    1518         (and (fboundp s) (funcall s)))
    1519       (and (boundp 'ccl::fasl-version)
    1520            (symbol-value 'ccl::fasl-version))
    1521       (error "Can't determine fasl version.")))
    1522 
    1523 (defun* lisp-version-string ()
    1524   (let ((s (lisp-implementation-version)))
    1525     (car ; as opposed to OR, this idiom prevents some unreachable code warning
    1526      (list
    1527       #+allegro
    1528       (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
    1529               excl::*common-lisp-version-number*
    1530               ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
    1531               (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
    1532               ;; Note if not using International ACL
    1533               ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
    1534               (excl:ics-target-case (:-ics "8"))
    1535               (and (member :smp *features*) "S"))
    1536       #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
    1537       #+clisp
    1538       (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
    1539       #+clozure
    1540       (format nil "~d.~d-f~d" ; shorten for windows
    1541               ccl::*openmcl-major-version*
    1542               ccl::*openmcl-minor-version*
    1543               (logand (ccl-fasl-version) #xFF))
    1544       #+cmu (substitute #\- #\/ s)
    1545       #+scl (format nil "~A~A" s
    1546                     ;; ANSI upper case vs lower case.
    1547                     (ecase ext:*case-mode* (:upper "") (:lower "l")))
    1548       #+ecl (format nil "~A~@[-~A~]" s
    1549                     (let ((vcs-id (ext:lisp-implementation-vcs-id)))
    1550                       (subseq vcs-id 0 (min (length vcs-id) 8))))
    1551       #+gcl (subseq s (1+ (position #\space s)))
    1552       #+genera
    1553       (multiple-value-bind (major minor) (sct:get-system-version "System")
    1554         (format nil "~D.~D" major minor))
    1555       #+mcl (subseq s 8) ; strip the leading "Version "
    1556       s))))
    1557 
    1558 (defun* implementation-identifier ()
    1559   (substitute-if
    1560    #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
    1561    (format nil "~(~a~@{~@[-~a~]~}~)"
    1562            (or (implementation-type) (lisp-implementation-type))
    1563            (or (lisp-version-string) (lisp-implementation-version))
    1564            (or (operating-system) (software-type))
    1565            (or (architecture) (machine-type)))))
     1502(with-upgradability ()
     1503  (defun first-feature (feature-sets)
     1504    (dolist (x feature-sets)
     1505      (multiple-value-bind (short long feature-expr)
     1506          (if (consp x)
     1507              (values (first x) (second x) (cons :or (rest x)))
     1508              (values x x x))
     1509        (when (featurep feature-expr)
     1510          (return (values short long))))))
     1511
     1512  (defun implementation-type ()
     1513    (first-feature
     1514     '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
     1515       (:cmu :cmucl :cmu) :ecl :gcl
     1516       (:lwpe :lispworks-personal-edition) (:lw :lispworks)
     1517       :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
     1518
     1519  (defvar *implementation-type* (implementation-type))
     1520
     1521  (defun operating-system ()
     1522    (first-feature
     1523     '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
     1524       (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
     1525       (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
     1526       (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
     1527       :genera)))
     1528
     1529  (defun architecture ()
     1530    (first-feature
     1531     '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
     1532       (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     1533       (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
     1534       :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
     1535       :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
     1536       ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
     1537       ;; we may have to segregate the code still by architecture.
     1538       (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
     1539
     1540  #+clozure
     1541  (defun ccl-fasl-version ()
     1542    ;; the fasl version is target-dependent from CCL 1.8 on.
     1543    (or (let ((s 'ccl::target-fasl-version))
     1544          (and (fboundp s) (funcall s)))
     1545        (and (boundp 'ccl::fasl-version)
     1546             (symbol-value 'ccl::fasl-version))
     1547        (error "Can't determine fasl version.")))
     1548
     1549  (defun lisp-version-string ()
     1550    (let ((s (lisp-implementation-version)))
     1551      (car ; as opposed to OR, this idiom prevents some unreachable code warning
     1552       (list
     1553        #+allegro
     1554        (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
     1555                excl::*common-lisp-version-number*
     1556                ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
     1557                (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
     1558                ;; Note if not using International ACL
     1559                ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     1560                (excl:ics-target-case (:-ics "8"))
     1561                (and (member :smp *features*) "S"))
     1562        #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     1563        #+clisp
     1564        (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     1565        #+clozure
     1566        (format nil "~d.~d-f~d" ; shorten for windows
     1567                ccl::*openmcl-major-version*
     1568                ccl::*openmcl-minor-version*
     1569                (logand (ccl-fasl-version) #xFF))
     1570        #+cmu (substitute #\- #\/ s)
     1571        #+scl (format nil "~A~A" s
     1572                      ;; ANSI upper case vs lower case.
     1573                      (ecase ext:*case-mode* (:upper "") (:lower "l")))
     1574        #+ecl (format nil "~A~@[-~A~]" s
     1575                      (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     1576                        (subseq vcs-id 0 (min (length vcs-id) 8))))
     1577        #+gcl (subseq s (1+ (position #\space s)))
     1578        #+genera
     1579        (multiple-value-bind (major minor) (sct:get-system-version "System")
     1580          (format nil "~D.~D" major minor))
     1581        #+mcl (subseq s 8) ; strip the leading "Version "
     1582        s))))
     1583
     1584  (defun implementation-identifier ()
     1585    (substitute-if
     1586     #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     1587     (format nil "~(~a~@{~@[-~a~]~}~)"
     1588             (or (implementation-type) (lisp-implementation-type))
     1589             (or (lisp-version-string) (lisp-implementation-version))
     1590             (or (operating-system) (software-type))
     1591             (or (architecture) (machine-type))))))
    15661592
    15671593
    15681594;;;; Other system information
    15691595
    1570 (defun* hostname ()
    1571   ;; Note: untested on RMCL
    1572   #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
    1573   #+cormanlisp "localhost" ;; is there a better way? Does it matter?
    1574   #+allegro (symbol-call :excl.osi :gethostname)
    1575   #+clisp (first (split-string (machine-instance) :separator " "))
    1576   #+gcl (system:gethostname))
     1596(with-upgradability ()
     1597  (defun hostname ()
     1598    ;; Note: untested on RMCL
     1599    #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
     1600    #+cormanlisp "localhost" ;; is there a better way? Does it matter?
     1601    #+allegro (symbol-call :excl.osi :gethostname)
     1602    #+clisp (first (split-string (machine-instance) :separator " "))
     1603    #+gcl (system:gethostname)))
    15771604
    15781605
    15791606;;; Current directory
    1580 #+cmu
    1581 (defun* parse-unix-namestring* (unix-namestring)
    1582   (multiple-value-bind (host device directory name type version)
    1583       (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
    1584     (make-pathname :host (or host lisp::*unix-host*) :device device
    1585                    :directory directory :name name :type type :version version)))
    1586 
    1587 (defun* getcwd ()
    1588   "Get the current working directory as per POSIX getcwd(3), as a pathname object"
    1589   (or #+abcl (parse-namestring
    1590               (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
    1591       #+allegro (excl::current-directory)
    1592       #+clisp (ext:default-directory)
    1593       #+clozure (ccl:current-directory)
    1594       #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
    1595                       (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
    1596       #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
    1597       #+ecl (ext:getcwd)
    1598       #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
    1599              (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
    1600       #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
    1601       #+lispworks (system:current-directory)
    1602       #+mkcl (mk-ext:getcwd)
    1603       #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
    1604       #+xcl (extensions:current-directory)
    1605       (error "getcwd not supported on your implementation")))
    1606 
    1607 (defun* chdir (x)
    1608   "Change current directory, as per POSIX chdir(2), to a given pathname object"
    1609   (if-let (x (pathname x))
    1610     (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
    1611         #+allegro (excl:chdir x)
    1612         #+clisp (ext:cd x)
    1613         #+clozure (setf (ccl:current-directory) x)
    1614         #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
    1615         #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
    1616                        (error "Could not set current directory to ~A" x))
    1617         #+ecl (ext:chdir x)
    1618         #+genera (setf *default-pathname-defaults* x)
    1619         #+lispworks (hcl:change-directory x)
    1620         #+mkcl (mk-ext:chdir x)
    1621         #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
    1622         (error "chdir not supported on your implementation"))))
     1607(with-upgradability ()
     1608
     1609  #+cmu
     1610  (defun parse-unix-namestring* (unix-namestring)
     1611    (multiple-value-bind (host device directory name type version)
     1612        (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
     1613      (make-pathname :host (or host lisp::*unix-host*) :device device
     1614                     :directory directory :name name :type type :version version)))
     1615
     1616  (defun getcwd ()
     1617    "Get the current working directory as per POSIX getcwd(3), as a pathname object"
     1618    (or #+abcl (parse-namestring
     1619                (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
     1620        #+allegro (excl::current-directory)
     1621        #+clisp (ext:default-directory)
     1622        #+clozure (ccl:current-directory)
     1623        #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
     1624                        (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
     1625        #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
     1626        #+ecl (ext:getcwd)
     1627        #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
     1628               (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
     1629        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
     1630        #+lispworks (system:current-directory)
     1631        #+mkcl (mk-ext:getcwd)
     1632        #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
     1633        #+xcl (extensions:current-directory)
     1634        (error "getcwd not supported on your implementation")))
     1635
     1636  (defun chdir (x)
     1637    "Change current directory, as per POSIX chdir(2), to a given pathname object"
     1638    (if-let (x (pathname x))
     1639      (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
     1640          #+allegro (excl:chdir x)
     1641          #+clisp (ext:cd x)
     1642          #+clozure (setf (ccl:current-directory) x)
     1643          #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
     1644          #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
     1645                         (error "Could not set current directory to ~A" x))
     1646          #+ecl (ext:chdir x)
     1647          #+genera (setf *default-pathname-defaults* x)
     1648          #+lispworks (hcl:change-directory x)
     1649          #+mkcl (mk-ext:chdir x)
     1650          #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
     1651          (error "chdir not supported on your implementation")))))
    16231652
    16241653
     
    16291658;;;; http://www.wotsit.org/list.asp?fc=13
    16301659
    1631 #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
    1632 (progn
    1633 (defparameter *link-initial-dword* 76)
    1634 (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
    1635 
    1636 (defun* read-null-terminated-string (s)
    1637   (with-output-to-string (out)
    1638     (loop :for code = (read-byte s)
    1639       :until (zerop code)
    1640       :do (write-char (code-char code) out))))
    1641 
    1642 (defun* read-little-endian (s &optional (bytes 4))
    1643   (loop :for i :from 0 :below bytes
    1644     :sum (ash (read-byte s) (* 8 i))))
    1645 
    1646 (defun* parse-file-location-info (s)
    1647   (let ((start (file-position s))
    1648         (total-length (read-little-endian s))
    1649         (end-of-header (read-little-endian s))
    1650         (fli-flags (read-little-endian s))
    1651         (local-volume-offset (read-little-endian s))
    1652         (local-offset (read-little-endian s))
    1653         (network-volume-offset (read-little-endian s))
    1654         (remaining-offset (read-little-endian s)))
    1655     (declare (ignore total-length end-of-header local-volume-offset))
    1656     (unless (zerop fli-flags)
    1657       (cond
    1658         ((logbitp 0 fli-flags)
    1659           (file-position s (+ start local-offset)))
    1660         ((logbitp 1 fli-flags)
    1661           (file-position s (+ start
    1662                               network-volume-offset
    1663                               #x14))))
    1664       (strcat (read-null-terminated-string s)
    1665               (progn
    1666                 (file-position s (+ start remaining-offset))
    1667                 (read-null-terminated-string s))))))
    1668 
    1669 (defun* parse-windows-shortcut (pathname)
    1670   (with-open-file (s pathname :element-type '(unsigned-byte 8))
    1671     (handler-case
    1672         (when (and (= (read-little-endian s) *link-initial-dword*)
    1673                    (let ((header (make-array (length *link-guid*))))
    1674                      (read-sequence header s)
    1675                      (equalp header *link-guid*)))
    1676           (let ((flags (read-little-endian s)))
    1677             (file-position s 76)        ;skip rest of header
    1678             (when (logbitp 0 flags)
    1679               ;; skip shell item id list
    1680               (let ((length (read-little-endian s 2)))
    1681                 (file-position s (+ length (file-position s)))))
    1682             (cond
    1683               ((logbitp 1 flags)
    1684                 (parse-file-location-info s))
    1685               (t
    1686                 (when (logbitp 2 flags)
    1687                   ;; skip description string
     1660(with-upgradability ()
     1661  #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
     1662  (progn
     1663    (defparameter *link-initial-dword* 76)
     1664    (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
     1665
     1666    (defun read-null-terminated-string (s)
     1667      (with-output-to-string (out)
     1668        (loop :for code = (read-byte s)
     1669              :until (zerop code)
     1670              :do (write-char (code-char code) out))))
     1671
     1672    (defun read-little-endian (s &optional (bytes 4))
     1673      (loop :for i :from 0 :below bytes
     1674            :sum (ash (read-byte s) (* 8 i))))
     1675
     1676    (defun parse-file-location-info (s)
     1677      (let ((start (file-position s))
     1678            (total-length (read-little-endian s))
     1679            (end-of-header (read-little-endian s))
     1680            (fli-flags (read-little-endian s))
     1681            (local-volume-offset (read-little-endian s))
     1682            (local-offset (read-little-endian s))
     1683            (network-volume-offset (read-little-endian s))
     1684            (remaining-offset (read-little-endian s)))
     1685        (declare (ignore total-length end-of-header local-volume-offset))
     1686        (unless (zerop fli-flags)
     1687          (cond
     1688            ((logbitp 0 fli-flags)
     1689             (file-position s (+ start local-offset)))
     1690            ((logbitp 1 fli-flags)
     1691             (file-position s (+ start
     1692                                 network-volume-offset
     1693                                 #x14))))
     1694          (strcat (read-null-terminated-string s)
     1695                  (progn
     1696                    (file-position s (+ start remaining-offset))
     1697                    (read-null-terminated-string s))))))
     1698
     1699    (defun parse-windows-shortcut (pathname)
     1700      (with-open-file (s pathname :element-type '(unsigned-byte 8))
     1701        (handler-case
     1702            (when (and (= (read-little-endian s) *link-initial-dword*)
     1703                       (let ((header (make-array (length *link-guid*))))
     1704                         (read-sequence header s)
     1705                         (equalp header *link-guid*)))
     1706              (let ((flags (read-little-endian s)))
     1707                (file-position s 76)        ;skip rest of header
     1708                (when (logbitp 0 flags)
     1709                  ;; skip shell item id list
    16881710                  (let ((length (read-little-endian s 2)))
    16891711                    (file-position s (+ length (file-position s)))))
    1690                 (when (logbitp 3 flags)
    1691                   ;; finally, our pathname
    1692                   (let* ((length (read-little-endian s 2))
    1693                          (buffer (make-array length)))
    1694                     (read-sequence buffer s)
    1695                     (map 'string #'code-char buffer)))))))
    1696       (end-of-file (c)
    1697         (declare (ignore c))
    1698         nil)))))
     1712                (cond
     1713                  ((logbitp 1 flags)
     1714                   (parse-file-location-info s))
     1715                  (t
     1716                   (when (logbitp 2 flags)
     1717                     ;; skip description string
     1718                     (let ((length (read-little-endian s 2)))
     1719                       (file-position s (+ length (file-position s)))))
     1720                   (when (logbitp 3 flags)
     1721                     ;; finally, our pathname
     1722                     (let* ((length (read-little-endian s 2))
     1723                            (buffer (make-array length)))
     1724                       (read-sequence buffer s)
     1725                       (map 'string #'code-char buffer)))))))
     1726          (end-of-file (c)
     1727            (declare (ignore c))
     1728            nil))))))
    16991729
    17001730
     
    17421772;;; Normalizing pathnames across implementations
    17431773
    1744 (defun* normalize-pathname-directory-component (directory)
    1745   "Given a pathname directory component, return an equivalent form that is a list"
    1746   #+gcl2.6 (setf directory (substitute :back :parent directory))
    1747   (cond
    1748     #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    1749     ((stringp directory) `(:absolute ,directory))
     1774(with-upgradability ()
     1775  (defun normalize-pathname-directory-component (directory)
     1776    "Given a pathname directory component, return an equivalent form that is a list"
     1777    #+gcl2.6 (setf directory (substitute :back :parent directory))
     1778    (cond
     1779      #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
     1780      ((stringp directory) `(:absolute ,directory))
     1781      #+gcl2.6
     1782      ((and (consp directory) (eq :root (first directory)))
     1783       `(:absolute ,@(rest directory)))
     1784      ((or (null directory)
     1785           (and (consp directory) (member (first directory) '(:absolute :relative))))
     1786       directory)
     1787      #+gcl2.6
     1788      ((consp directory)
     1789       `(:relative ,@directory))
     1790      (t
     1791       (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
     1792
     1793  (defun denormalize-pathname-directory-component (directory-component)
     1794    #-gcl2.6 directory-component
    17501795    #+gcl2.6
    1751     ((and (consp directory) (eq :root (first directory)))
    1752      `(:absolute ,@(rest directory)))
    1753     ((or (null directory)
    1754          (and (consp directory) (member (first directory) '(:absolute :relative))))
    1755      directory)
    1756     #+gcl2.6
    1757     ((consp directory)
    1758      `(:relative ,@directory))
    1759     (t
    1760      (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
    1761 
    1762 (defun* denormalize-pathname-directory-component (directory-component)
    1763   #-gcl2.6 directory-component
    1764   #+gcl2.6
    1765   (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
    1766                           directory-component)))
    1767     (cond
    1768       ((and (consp d) (eq :relative (first d))) (rest d))
    1769       ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
    1770       (t d))))
    1771 
    1772 (defun* merge-pathname-directory-components (specified defaults)
    1773   ;; Helper for merge-pathnames* that handles directory components.
    1774   (let ((directory (normalize-pathname-directory-component specified)))
    1775     (ecase (first directory)
    1776       ((nil) defaults)
    1777       (:absolute specified)
    1778       (:relative
    1779        (let ((defdir (normalize-pathname-directory-component defaults))
    1780              (reldir (cdr directory)))
    1781          (cond
    1782            ((null defdir)
    1783             directory)
    1784            ((not (eq :back (first reldir)))
    1785             (append defdir reldir))
    1786            (t
    1787             (loop :with defabs = (first defdir)
    1788               :with defrev = (reverse (rest defdir))
    1789               :while (and (eq :back (car reldir))
    1790                           (or (and (eq :absolute defabs) (null defrev))
    1791                               (stringp (car defrev))))
    1792               :do (pop reldir) (pop defrev)
    1793               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    1794 
    1795 ;; Giving :unspecific as :type argument to make-pathname is not portable.
    1796 ;; See CLHS make-pathname and 19.2.2.2.3.
    1797 ;; This will be :unspecific if supported, or NIL if not.
    1798 (defparameter *unspecific-pathname-type*
    1799   #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
    1800   #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
    1801 
    1802 (defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
    1803                               host (device () #+allegro devicep) name type version defaults
    1804                               #+scl &allow-other-keys)
    1805   "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
     1796    (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
     1797                            directory-component)))
     1798      (cond
     1799        ((and (consp d) (eq :relative (first d))) (rest d))
     1800        ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
     1801        (t d))))
     1802
     1803  (defun merge-pathname-directory-components (specified defaults)
     1804    ;; Helper for merge-pathnames* that handles directory components.
     1805    (let ((directory (normalize-pathname-directory-component specified)))
     1806      (ecase (first directory)
     1807        ((nil) defaults)
     1808        (:absolute specified)
     1809        (:relative
     1810         (let ((defdir (normalize-pathname-directory-component defaults))
     1811               (reldir (cdr directory)))
     1812           (cond
     1813             ((null defdir)
     1814              directory)
     1815             ((not (eq :back (first reldir)))
     1816              (append defdir reldir))
     1817             (t
     1818              (loop :with defabs = (first defdir)
     1819                    :with defrev = (reverse (rest defdir))
     1820                    :while (and (eq :back (car reldir))
     1821                                (or (and (eq :absolute defabs) (null defrev))
     1822                                    (stringp (car defrev))))
     1823                    :do (pop reldir) (pop defrev)
     1824                    :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
     1825
     1826  ;; Giving :unspecific as :type argument to make-pathname is not portable.
     1827  ;; See CLHS make-pathname and 19.2.2.2.3.
     1828  ;; This will be :unspecific if supported, or NIL if not.
     1829  (defparameter *unspecific-pathname-type*
     1830    #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
     1831    #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
     1832
     1833  (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
     1834                                      host (device () #+allegro devicep) name type version defaults
     1835                                      #+scl &allow-other-keys)
     1836    "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
    18061837   tries hard to make a pathname that will actually behave as documented,
    18071838   despite the peculiarities of each implementation"
    1808   (declare (ignorable host device directory name type version defaults))
    1809   (apply 'make-pathname
    1810          (append
    1811           #+allegro (when (and devicep (null device)) `(:device :unspecific))
    1812           #+gcl2.6
    1813           (when directoryp
    1814             `(:directory ,(denormalize-pathname-directory-component directory)))
    1815           keys)))
    1816 
    1817 (defun* make-pathname-component-logical (x)
    1818   "Make a pathname component suitable for use in a logical-pathname"
    1819   (typecase x
    1820     ((eql :unspecific) nil)
    1821     #+clisp (string (string-upcase x))
    1822     #+clisp (cons (mapcar 'make-pathname-component-logical x))
    1823     (t x)))
    1824 
    1825 (defun* make-pathname-logical (pathname host)
    1826   "Take a PATHNAME's directory, name, type and version components,
     1839    (declare (ignorable host device directory name type version defaults))
     1840    (apply 'make-pathname
     1841           (append
     1842            #+allegro (when (and devicep (null device)) `(:device :unspecific))
     1843            #+gcl2.6
     1844            (when directoryp
     1845              `(:directory ,(denormalize-pathname-directory-component directory)))
     1846            keys)))
     1847
     1848  (defun make-pathname-component-logical (x)
     1849    "Make a pathname component suitable for use in a logical-pathname"
     1850    (typecase x
     1851      ((eql :unspecific) nil)
     1852      #+clisp (string (string-upcase x))
     1853      #+clisp (cons (mapcar 'make-pathname-component-logical x))
     1854      (t x)))
     1855
     1856  (defun make-pathname-logical (pathname host)
     1857    "Take a PATHNAME's directory, name, type and version components,
    18271858and make a new pathname with corresponding components and specified logical HOST"
    1828   (make-pathname*
    1829    :host host
    1830    :directory (make-pathname-component-logical (pathname-directory pathname))
    1831    :name (make-pathname-component-logical (pathname-name pathname))
    1832    :type (make-pathname-component-logical (pathname-type pathname))
    1833    :version (make-pathname-component-logical (pathname-version pathname))))
    1834 
    1835 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    1836   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     1859    (make-pathname*
     1860     :host host
     1861     :directory (make-pathname-component-logical (pathname-directory pathname))
     1862     :name (make-pathname-component-logical (pathname-name pathname))
     1863     :type (make-pathname-component-logical (pathname-type pathname))
     1864     :version (make-pathname-component-logical (pathname-version pathname))))
     1865
     1866  (defun merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     1867    "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
    18371868if the SPECIFIED pathname does not have an absolute directory,
    18381869then the HOST and DEVICE both come from the DEFAULTS, whereas
     
    18441875this is unlike MERGE-PATHNAME which always merges with a pathname,
    18451876by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
    1846   (when (null specified) (return-from merge-pathnames* defaults))
    1847   (when (null defaults) (return-from merge-pathnames* specified))
    1848   #+scl
    1849   (ext:resolve-pathname specified defaults)
    1850   #-scl
    1851   (let* ((specified (pathname specified))
    1852          (defaults (pathname defaults))
    1853          (directory (normalize-pathname-directory-component (pathname-directory specified)))
    1854          (name (or (pathname-name specified) (pathname-name defaults)))
    1855          (type (or (pathname-type specified) (pathname-type defaults)))
    1856          (version (or (pathname-version specified) (pathname-version defaults))))
    1857     (labels ((unspecific-handler (p)
    1858                (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
    1859       (multiple-value-bind (host device directory unspecific-handler)
    1860           (ecase (first directory)
    1861             ((:absolute)
    1862              (values (pathname-host specified)
    1863                      (pathname-device specified)
    1864                      directory
    1865                      (unspecific-handler specified)))
    1866             ((nil :relative)
    1867              (values (pathname-host defaults)
    1868                      (pathname-device defaults)
    1869                      (merge-pathname-directory-components directory (pathname-directory defaults))
    1870                      (unspecific-handler defaults))))
    1871         (make-pathname* :host host :device device :directory directory
    1872                         :name (funcall unspecific-handler name)
    1873                         :type (funcall unspecific-handler type)
    1874                         :version (funcall unspecific-handler version))))))
    1875 
    1876 (defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
    1877   "A pathname that is as neutral as possible for use as defaults
     1877    (when (null specified) (return-from merge-pathnames* defaults))
     1878    (when (null defaults) (return-from merge-pathnames* specified))
     1879    #+scl
     1880    (ext:resolve-pathname specified defaults)
     1881    #-scl
     1882    (let* ((specified (pathname specified))
     1883           (defaults (pathname defaults))
     1884           (directory (normalize-pathname-directory-component (pathname-directory specified)))
     1885           (name (or (pathname-name specified) (pathname-name defaults)))
     1886           (type (or (pathname-type specified) (pathname-type defaults)))
     1887           (version (or (pathname-version specified) (pathname-version defaults))))
     1888      (labels ((unspecific-handler (p)
     1889                 (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
     1890        (multiple-value-bind (host device directory unspecific-handler)
     1891            (ecase (first directory)
     1892              ((:absolute)
     1893               (values (pathname-host specified)
     1894                       (pathname-device specified)
     1895                       directory
     1896                       (unspecific-handler specified)))
     1897              ((nil :relative)
     1898               (values (pathname-host defaults)
     1899                       (pathname-device defaults)
     1900                       (merge-pathname-directory-components directory (pathname-directory defaults))
     1901                       (unspecific-handler defaults))))
     1902          (make-pathname* :host host :device device :directory directory
     1903                          :name (funcall unspecific-handler name)
     1904                          :type (funcall unspecific-handler type)
     1905                          :version (funcall unspecific-handler version))))))
     1906
     1907  (defun nil-pathname (&optional (defaults *default-pathname-defaults*))
     1908    "A pathname that is as neutral as possible for use as defaults
    18781909   when merging, making or parsing pathnames"
    1879   ;; 19.2.2.2.1 says a NIL host can mean a default host;
    1880   ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
    1881   ;; strings and lists of strings or :unspecific
    1882   ;; But CMUCL decides to die on NIL.
    1883   #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
    1884                      :host (or #+cmu lisp::*unix-host*)
    1885                      #+scl ,@'(:scheme nil :scheme-specific-part nil
    1886                                :username nil :password nil :parameters nil :query nil :fragment nil)
    1887                      ;; the default shouldn't matter, but we really want something physical
    1888                      :defaults defaults))
    1889 
    1890 (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
    1891 
    1892 (defmacro with-pathname-defaults ((&optional defaults) &body body)
    1893   `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))
     1910    ;; 19.2.2.2.1 says a NIL host can mean a default host;
     1911    ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
     1912    ;; strings and lists of strings or :unspecific
     1913    ;; But CMUCL decides to die on NIL.
     1914    #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
     1915                       :host (or #+cmu lisp::*unix-host*)
     1916                       #+scl ,@'(:scheme nil :scheme-specific-part nil
     1917                                 :username nil :password nil :parameters nil :query nil :fragment nil)
     1918                       ;; the default shouldn't matter, but we really want something physical
     1919                       :defaults defaults))
     1920
     1921  (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
     1922
     1923  (defmacro with-pathname-defaults ((&optional defaults) &body body)
     1924    `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body)))
    18941925
    18951926
    18961927;;; Some pathname predicates
    1897 
    1898 (defun* pathname-equal (p1 p2)
    1899   (when (stringp p1) (setf p1 (pathname p1)))
    1900   (when (stringp p2) (setf p2 (pathname p2)))
    1901   (flet ((normalize-component (x)
    1902            (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
    1903              x)))
    1904     (macrolet ((=? (&rest accessors)
    1905                  (flet ((frob (x)
    1906                           (reduce 'list (cons 'normalize-component accessors)
    1907                                   :initial-value x :from-end t)))
    1908                    `(equal ,(frob 'p1) ,(frob 'p2)))))
    1909       (or (and (null p1) (null p2))
    1910           (and (pathnamep p1) (pathnamep p2)
    1911                (and (=? pathname-host)
    1912                     (=? pathname-device)
    1913                     (=? normalize-pathname-directory-component pathname-directory)
    1914                     (=? pathname-name)
    1915                     (=? pathname-type)
    1916                     (=? pathname-version)))))))
    1917 
    1918 (defun* logical-pathname-p (x)
    1919   (typep x 'logical-pathname))
    1920 
    1921 (defun* physical-pathname-p (x)
    1922   (and (pathnamep x) (not (logical-pathname-p x))))
    1923 
    1924 (defun* absolute-pathname-p (pathspec)
    1925   "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1928(with-upgradability ()
     1929  (defun pathname-equal (p1 p2)
     1930    (when (stringp p1) (setf p1 (pathname p1)))
     1931    (when (stringp p2) (setf p2 (pathname p2)))
     1932    (flet ((normalize-component (x)
     1933             (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
     1934               x)))
     1935      (macrolet ((=? (&rest accessors)
     1936                   (flet ((frob (x)
     1937                            (reduce 'list (cons 'normalize-component accessors)
     1938                                    :initial-value x :from-end t)))
     1939                     `(equal ,(frob 'p1) ,(frob 'p2)))))
     1940        (or (and (null p1) (null p2))
     1941            (and (pathnamep p1) (pathnamep p2)
     1942                 (and (=? pathname-host)
     1943                      (=? pathname-device)
     1944                      (=? normalize-pathname-directory-component pathname-directory)
     1945                      (=? pathname-name)
     1946                      (=? pathname-type)
     1947                      (=? pathname-version)))))))
     1948
     1949  (defun logical-pathname-p (x)
     1950    (typep x 'logical-pathname))
     1951
     1952  (defun physical-pathname-p (x)
     1953    (and (pathnamep x) (not (logical-pathname-p x))))
     1954
     1955  (defun absolute-pathname-p (pathspec)
     1956    "If PATHSPEC is a pathname or namestring object that parses as a pathname
    19261957possessing an :ABSOLUTE directory component, return the (parsed) pathname.
    19271958Otherwise return NIL"
    1928   (and pathspec
    1929        (typep pathspec '(or null pathname string))
    1930        (let ((pathname (pathname pathspec)))
    1931          (and (eq :absolute (car (normalize-pathname-directory-component
    1932                                   (pathname-directory pathname))))
    1933               pathname))))
    1934 
    1935 (defun* relative-pathname-p (pathspec)
    1936   "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1959    (and pathspec
     1960         (typep pathspec '(or null pathname string))
     1961         (let ((pathname (pathname pathspec)))
     1962           (and (eq :absolute (car (normalize-pathname-directory-component
     1963                                    (pathname-directory pathname))))
     1964                pathname))))
     1965
     1966  (defun relative-pathname-p (pathspec)
     1967    "If PATHSPEC is a pathname or namestring object that parses as a pathname
    19371968possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
    19381969Otherwise return NIL"
    1939   (and pathspec
    1940        (typep pathspec '(or null pathname string))
    1941        (let* ((pathname (pathname pathspec))
    1942               (directory (normalize-pathname-directory-component
    1943                           (pathname-directory pathname))))
    1944          (when (or (null directory) (eq :relative (car directory)))
    1945            pathname))))
    1946 
    1947 (defun* hidden-pathname-p (pathname)
    1948   "Return a boolean that is true if the pathname is hidden as per Unix style,
     1970    (and pathspec
     1971         (typep pathspec '(or null pathname string))
     1972         (let* ((pathname (pathname pathspec))
     1973                (directory (normalize-pathname-directory-component
     1974                            (pathname-directory pathname))))
     1975           (when (or (null directory) (eq :relative (car directory)))
     1976             pathname))))
     1977
     1978  (defun hidden-pathname-p (pathname)
     1979    "Return a boolean that is true if the pathname is hidden as per Unix style,
    19491980i.e. its name starts with a dot."
    1950   (and pathname (equal (first-char (pathname-name pathname)) #\.)))
    1951 
    1952 (defun* file-pathname-p (pathname)
    1953   "Does PATHNAME represent a file, i.e. has a non-null NAME component?
     1981    (and pathname (equal (first-char (pathname-name pathname)) #\.)))
     1982
     1983  (defun file-pathname-p (pathname)
     1984    "Does PATHNAME represent a file, i.e. has a non-null NAME component?
    19541985
    19551986Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
     
    19591990
    19601991Returns the (parsed) PATHNAME when true"
    1961   (when pathname
    1962     (let* ((pathname (pathname pathname))
    1963            (name (pathname-name pathname)))
    1964       (when (not (member name '(nil :unspecific "") :test 'equal))
    1965         pathname))))
     1992    (when pathname
     1993      (let* ((pathname (pathname pathname))
     1994             (name (pathname-name pathname)))
     1995        (when (not (member name '(nil :unspecific "") :test 'equal))
     1996          pathname)))))
    19661997
    19671998
    19681999;;; Directory pathnames
    1969 (defun* pathname-directory-pathname (pathname)
    1970   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     2000(with-upgradability ()
     2001  (defun pathname-directory-pathname (pathname)
     2002    "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    19712003and NIL NAME, TYPE and VERSION components"
    1972   (when pathname
    1973     (make-pathname :name nil :type nil :version nil :defaults pathname)))
    1974 
    1975 (defun* pathname-parent-directory-pathname (pathname)
    1976   "Returns a new pathname that corresponds to the parent of the current pathname's directory,
     2004    (when pathname
     2005      (make-pathname :name nil :type nil :version nil :defaults pathname)))
     2006
     2007  (defun pathname-parent-directory-pathname (pathname)
     2008    "Returns a new pathname that corresponds to the parent of the current pathname's directory,
    19772009i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
    19782010Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
    1979   (when pathname
    1980     (make-pathname* :name nil :type nil :version nil
    1981                     :directory (merge-pathname-directory-components
    1982                                 '(:relative :back) (pathname-directory pathname))
    1983                     :defaults pathname)))
    1984 
    1985 (defun* directory-pathname-p (pathname)
    1986   "Does PATHNAME represent a directory?
     2011    (when pathname
     2012      (make-pathname* :name nil :type nil :version nil
     2013                      :directory (merge-pathname-directory-components
     2014                                  '(:relative :back) (pathname-directory pathname))
     2015                      :defaults pathname)))
     2016
     2017  (defun directory-pathname-p (pathname)
     2018    "Does PATHNAME represent a directory?
    19872019
    19882020A directory-pathname is a pathname _without_ a filename. The three
     
    19922024Note that this does _not_ check to see that PATHNAME points to an
    19932025actually-existing directory."
    1994   (when pathname
    1995     (let ((pathname (pathname pathname)))
    1996       (flet ((check-one (x)
    1997                (member x '(nil :unspecific "") :test 'equal)))
    1998         (and (not (wild-pathname-p pathname))
    1999              (check-one (pathname-name pathname))
    2000              (check-one (pathname-type pathname))
    2001              t)))))
    2002 
    2003 (defun* ensure-directory-pathname (pathspec &optional (on-error 'error))
    2004   "Converts the non-wild pathname designator PATHSPEC to directory form."
    2005   (cond
    2006    ((stringp pathspec)
    2007     (ensure-directory-pathname (pathname pathspec)))
    2008    ((not (pathnamep pathspec))
    2009     (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
    2010    ((wild-pathname-p pathspec)
    2011     (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
    2012    ((directory-pathname-p pathspec)
    2013     pathspec)
    2014    (t
    2015     (make-pathname* :directory (append (or (normalize-pathname-directory-component
    2016                                             (pathname-directory pathspec))
    2017                                            (list :relative))
    2018                                        (list (file-namestring pathspec)))
    2019                     :name nil :type nil :version nil :defaults pathspec))))
     2026    (when pathname
     2027      (let ((pathname (pathname pathname)))
     2028        (flet ((check-one (x)
     2029                 (member x '(nil :unspecific "") :test 'equal)))
     2030          (and (not (wild-pathname-p pathname))
     2031               (check-one (pathname-name pathname))
     2032               (check-one (pathname-type pathname))
     2033               t)))))
     2034
     2035  (defun ensure-directory-pathname (pathspec &optional (on-error 'error))
     2036    "Converts the non-wild pathname designator PATHSPEC to directory form."
     2037    (cond
     2038      ((stringp pathspec)
     2039       (ensure-directory-pathname (pathname pathspec)))
     2040      ((not (pathnamep pathspec))
     2041       (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
     2042      ((wild-pathname-p pathspec)
     2043       (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
     2044      ((directory-pathname-p pathspec)
     2045       pathspec)
     2046      (t
     2047       (make-pathname* :directory (append (or (normalize-pathname-directory-component
     2048                                               (pathname-directory pathspec))
     2049                                              (list :relative))
     2050                                          (list (file-namestring pathspec)))
     2051                       :name nil :type nil :version nil :defaults pathspec)))))
    20202052
    20212053
    20222054;;; Parsing filenames
    2023 (defun* split-unix-namestring-directory-components
    2024     (unix-namestring &key ensure-directory dot-dot)
    2025   "Splits the path string UNIX-NAMESTRING, returning four values:
     2055(with-upgradability ()
     2056  (defun split-unix-namestring-directory-components
     2057      (unix-namestring &key ensure-directory dot-dot)
     2058    "Splits the path string UNIX-NAMESTRING, returning four values:
    20262059A flag that is either :absolute or :relative, indicating
    20272060   how the rest of the values are to be interpreted.
     
    20452078The intention of this function is to support structured component names,
    20462079e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
    2047   (check-type unix-namestring string)
    2048   (check-type dot-dot (member nil :back :up))
    2049   (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
    2050            (plusp (length unix-namestring)))
    2051       (values :relative () unix-namestring t)
    2052       (let* ((components (split-string unix-namestring :separator "/"))
    2053              (last-comp (car (last components))))
    2054         (multiple-value-bind (relative components)
    2055             (if (equal (first components) "")
    2056                 (if (equal (first-char unix-namestring) #\/)
    2057                     (values :absolute (cdr components))
    2058                     (values :relative nil))
    2059                 (values :relative components))
    2060           (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
    2061                                       components))
    2062           (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
    2063           (cond
    2064             ((equal last-comp "")
    2065              (values relative components nil nil)) ; "" already removed from components
    2066             (ensure-directory
    2067              (values relative components nil nil))
    2068             (t
    2069              (values relative (butlast components) last-comp nil)))))))
    2070 
    2071 (defun* split-name-type (filename)
    2072   "Split a filename into two values NAME and TYPE that are returned.
     2080    (check-type unix-namestring string)
     2081    (check-type dot-dot (member nil :back :up))
     2082    (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
     2083             (plusp (length unix-namestring)))
     2084        (values :relative () unix-namestring t)
     2085        (let* ((components (split-string unix-namestring :separator "/"))
     2086               (last-comp (car (last components))))
     2087          (multiple-value-bind (relative components)
     2088              (if (equal (first components) "")
     2089                  (if (equal (first-char unix-namestring) #\/)
     2090                      (values :absolute (cdr components))
     2091                      (values :relative nil))
     2092                  (values :relative components))
     2093            (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
     2094                                        components))
     2095            (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
     2096            (cond
     2097              ((equal last-comp "")
     2098               (values relative components nil nil)) ; "" already removed from components
     2099              (ensure-directory
     2100               (values relative components nil nil))
     2101              (t
     2102               (values relative (butlast components) last-comp nil)))))))
     2103
     2104  (defun split-name-type (filename)
     2105    "Split a filename into two values NAME and TYPE that are returned.
    20732106We assume filename has no directory component.
    20742107The last . if any separates name and type from from type,
     
    20772110NAME is always a string.
    20782111For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
    2079   (check-type filename string)
    2080   (assert (plusp (length filename)))
    2081   (destructuring-bind (name &optional (type *unspecific-pathname-type*))
    2082       (split-string filename :max 2 :separator ".")
    2083     (if (equal name "")
    2084         (values filename *unspecific-pathname-type*)
    2085         (values name type))))
    2086 
    2087 (defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
    2088                                     &allow-other-keys)
    2089   "Coerce NAME into a PATHNAME using standard Unix syntax.
     2112    (check-type filename string)
     2113    (assert (plusp (length filename)))
     2114    (destructuring-bind (name &optional (type *unspecific-pathname-type*))
     2115        (split-string filename :max 2 :separator ".")
     2116      (if (equal name "")
     2117          (values filename *unspecific-pathname-type*)
     2118          (values name type))))
     2119
     2120  (defun parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
     2121                                &allow-other-keys)
     2122    "Coerce NAME into a PATHNAME using standard Unix syntax.
    20902123
    20912124Unix syntax is used whether or not the underlying system is Unix;
     
    21282161even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
    21292162to throw an error if the pathname is absolute"
    2130   (block nil
    2131     (check-type type (or null string (eql :directory)))
    2132     (when ensure-directory
    2133       (setf type :directory))
    2134     (etypecase name
    2135       ((or null pathname) (return name))
    2136       (symbol
    2137        (setf name (string-downcase name)))
    2138       (string))
    2139     (multiple-value-bind (relative path filename file-only)
    2140         (split-unix-namestring-directory-components
    2141          name :dot-dot dot-dot :ensure-directory (eq type :directory))
    2142       (multiple-value-bind (name type)
    2143           (cond
    2144             ((or (eq type :directory) (null filename))
    2145              (values nil nil))
    2146             (type
    2147              (values filename type))
    2148             (t
    2149              (split-name-type filename)))
    2150         (apply 'ensure-pathname
    2151                (make-pathname*
    2152                 :directory (unless file-only (cons relative path))
    2153                 :name name :type type
    2154                 :defaults (or defaults *nil-pathname*))
    2155                (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
    2156 
    2157 (defun* unix-namestring (pathname)
    2158   "Given a non-wild PATHNAME, return a Unix-style namestring for it.
     2163    (block nil
     2164      (check-type type (or null string (eql :directory)))
     2165      (when ensure-directory
     2166        (setf type :directory))
     2167      (etypecase name
     2168        ((or null pathname) (return name))
     2169        (symbol
     2170         (setf name (string-downcase name)))
     2171        (string))
     2172      (multiple-value-bind (relative path filename file-only)
     2173          (split-unix-namestring-directory-components
     2174           name :dot-dot dot-dot :ensure-directory (eq type :directory))
     2175        (multiple-value-bind (name type)
     2176            (cond
     2177              ((or (eq type :directory) (null filename))
     2178               (values nil nil))
     2179              (type
     2180               (values filename type))
     2181              (t
     2182               (split-name-type filename)))
     2183          (apply 'ensure-pathname
     2184                 (make-pathname*
     2185                  :directory (unless file-only (cons relative path))
     2186                  :name name :type type
     2187                  :defaults (or defaults *nil-pathname*))
     2188                 (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
     2189
     2190  (defun unix-namestring (pathname)
     2191    "Given a non-wild PATHNAME, return a Unix-style namestring for it.
    21592192If the PATHNAME is NIL or a STRING, return it unchanged.
    21602193
     
    21662199An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
    21672200or if it is a PATHNAME but some of its components are not recognized."
    2168   (etypecase pathname
    2169     ((or null string) pathname)
    2170     (pathname
    2171      (with-output-to-string (s)
    2172        (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
    2173          (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
    2174                 (name (pathname-name pathname))
    2175                 (type (pathname-type pathname))
    2176                 (type (and (not (eq type :unspecific)) type)))
    2177            (cond
    2178              ((eq dir ()))
    2179              ((eq dir '(:relative)) (princ "./" s))
    2180              ((consp dir)
    2181               (destructuring-bind (relabs &rest dirs) dir
    2182                 (or (member relabs '(:relative :absolute)) (err))
    2183                 (when (eq relabs :absolute) (princ #\/ s))
    2184                 (loop :for x :in dirs :do
    2185                   (cond
    2186                     ((member x '(:back :up)) (princ "../" s))
    2187                     ((equal x "") (err))
    2188                     ;;((member x '("." "..") :test 'equal) (err))
    2189                     ((stringp x) (format s "~A/" x))
    2190                     (t (err))))))
    2191              (t (err)))
    2192            (cond
    2193              (name
    2194               (or (and (stringp name) (or (null type) (stringp type))) (err))
    2195               (format s "~A~@[.~A~]" name type))
    2196              (t
    2197               (or (null type) (err))))))))))
     2201    (etypecase pathname
     2202      ((or null string) pathname)
     2203      (pathname
     2204       (with-output-to-string (s)
     2205         (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
     2206           (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
     2207                  (name (pathname-name pathname))
     2208                  (type (pathname-type pathname))
     2209                  (type (and (not (eq type :unspecific)) type)))
     2210             (cond
     2211               ((eq dir ()))
     2212               ((eq dir '(:relative)) (princ "./" s))
     2213               ((consp dir)
     2214                (destructuring-bind (relabs &rest dirs) dir
     2215                  (or (member relabs '(:relative :absolute)) (err))
     2216                  (when (eq relabs :absolute) (princ #\/ s))
     2217                  (loop :for x :in dirs :do
     2218                    (cond
     2219                      ((member x '(:back :up)) (princ "../" s))
     2220                      ((equal x "") (err))
     2221                      ;;((member x '("." "..") :test 'equal) (err))
     2222                      ((stringp x) (format s "~A/" x))
     2223                      (t (err))))))
     2224               (t (err)))
     2225             (cond
     2226               (name
     2227                (or (and (stringp name) (or (null type) (stringp type))) (err))
     2228                (format s "~A~@[.~A~]" name type))
     2229               (t
     2230                (or (null type) (err)))))))))))
    21982231
    21992232;;; Absolute and relative pathnames
    2200 (defun* subpathname (pathname subpath &key type)
    2201   "This function takes a PATHNAME and a SUBPATH and a TYPE.
     2233(with-upgradability ()
     2234  (defun subpathname (pathname subpath &key type)
     2235    "This function takes a PATHNAME and a SUBPATH and a TYPE.
    22022236If SUBPATH is already a PATHNAME object (not namestring),
    22032237and is an absolute pathname at that, it is returned unchanged;
     
    22052239as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
    22062240then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
    2207   (or (and (pathnamep subpath) (absolute-pathname-p subpath))
    2208       (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
    2209                         (pathname-directory-pathname pathname))))
    2210 
    2211 (defun* subpathname* (pathname subpath &key type)
    2212   "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
    2213   (and pathname
    2214        (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    2215 
    2216 
    2217 ;;; Pathname host and its root
    2218 (defun* pathname-root (pathname)
    2219   (make-pathname* :directory '(:absolute)
    2220                   :name nil :type nil :version nil
    2221                   :defaults pathname ;; host device, and on scl, *some*
    2222                   ;; scheme-specific parts: port username password, not others:
    2223                   . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    2224 
    2225 (defun* pathname-host-pathname (pathname)
    2226   (make-pathname* :directory nil
    2227                   :name nil :type nil :version nil :device nil
    2228                   :defaults pathname ;; host device, and on scl, *some*
    2229                   ;; scheme-specific parts: port username password, not others:
    2230                   . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    2231 
    2232 (defun* subpathp (maybe-subpath base-pathname)
    2233   (and (pathnamep maybe-subpath) (pathnamep base-pathname)
    2234        (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
    2235        (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
    2236        (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
    2237        (with-pathname-defaults ()
    2238          (let ((enough (enough-namestring maybe-subpath base-pathname)))
    2239            (and (relative-pathname-p enough) (pathname enough))))))
    2240 
    2241 (defun* ensure-absolute-pathname (path &optional defaults (on-error 'error))
    2242   (cond
    2243     ((absolute-pathname-p path))
    2244     ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
    2245     ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
    2246     ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
    2247        (or (if (absolute-pathname-p default-pathname)
    2248                (absolute-pathname-p (merge-pathnames* path default-pathname))
    2249                (call-function on-error "Default pathname ~S is not an absolute pathname"
    2250                               default-pathname))
    2251            (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
    2252                           path default-pathname))))
    2253     (t (call-function on-error
    2254                       "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
    2255                       path defaults))))
     2241    (or (and (pathnamep subpath) (absolute-pathname-p subpath))
     2242        (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
     2243                          (pathname-directory-pathname pathname))))
     2244
     2245  (defun subpathname* (pathname subpath &key type)
     2246    "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
     2247    (and pathname
     2248         (subpathname (ensure-directory-pathname pathname) subpath :type type)))
     2249
     2250  (defun pathname-root (pathname)
     2251    (make-pathname* :directory '(:absolute)
     2252                    :name nil :type nil :version nil
     2253                    :defaults pathname ;; host device, and on scl, *some*
     2254                    ;; scheme-specific parts: port username password, not others:
     2255                    . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
     2256
     2257  (defun pathname-host-pathname (pathname)
     2258    (make-pathname* :directory nil
     2259                    :name nil :type nil :version nil :device nil
     2260                    :defaults pathname ;; host device, and on scl, *some*
     2261                    ;; scheme-specific parts: port username password, not others:
     2262                    . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
     2263
     2264  (defun subpathp (maybe-subpath base-pathname)
     2265    (and (pathnamep maybe-subpath) (pathnamep base-pathname)
     2266         (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
     2267         (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
     2268         (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
     2269         (with-pathname-defaults ()
     2270           (let ((enough (enough-namestring maybe-subpath base-pathname)))
     2271             (and (relative-pathname-p enough) (pathname enough))))))
     2272
     2273  (defun ensure-absolute-pathname (path &optional defaults (on-error 'error))
     2274    (cond
     2275      ((absolute-pathname-p path))
     2276      ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
     2277      ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
     2278      ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
     2279         (or (if (absolute-pathname-p default-pathname)
     2280                 (absolute-pathname-p (merge-pathnames* path default-pathname))
     2281                 (call-function on-error "Default pathname ~S is not an absolute pathname"
     2282                                default-pathname))
     2283             (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
     2284                            path default-pathname))))
     2285      (t (call-function on-error
     2286                        "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
     2287                        path defaults)))))
    22562288
    22572289
    22582290;;; Wildcard pathnames
    2259 (defparameter *wild* (or #+cormanlisp "*" :wild))
    2260 (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
    2261 (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
    2262 (defparameter *wild-file*
    2263   (make-pathname :directory nil :name *wild* :type *wild*
    2264                  :version (or #-(or allegro abcl xcl) *wild*)))
    2265 (defparameter *wild-directory*
    2266   (make-pathname* :directory `(:relative ,*wild-directory-component*)
    2267                   :name nil :type nil :version nil))
    2268 (defparameter *wild-inferiors*
    2269   (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
    2270                   :name nil :type nil :version nil))
    2271 (defparameter *wild-path*
    2272   (merge-pathnames* *wild-file* *wild-inferiors*))
    2273 
    2274 (defun* wilden (path)
    2275   (merge-pathnames* *wild-path* path))
     2291(with-upgradability ()
     2292  (defparameter *wild* (or #+cormanlisp "*" :wild))
     2293  (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
     2294  (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
     2295  (defparameter *wild-file*
     2296    (make-pathname :directory nil :name *wild* :type *wild*
     2297                   :version (or #-(or allegro abcl xcl) *wild*)))
     2298  (defparameter *wild-directory*
     2299    (make-pathname* :directory `(:relative ,*wild-directory-component*)
     2300                    :name nil :type nil :version nil))
     2301  (defparameter *wild-inferiors*
     2302    (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
     2303                    :name nil :type nil :version nil))
     2304  (defparameter *wild-path*
     2305    (merge-pathnames* *wild-file* *wild-inferiors*))
     2306
     2307  (defun wilden (path)
     2308    (merge-pathnames* *wild-path* path)))
    22762309
    22772310
    22782311;;; Translate a pathname
    2279 (defun relativize-directory-component (directory-component)
    2280   (let ((directory (normalize-pathname-directory-component directory-component)))
     2312(with-upgradability ()
     2313  (defun relativize-directory-component (directory-component)
     2314    (let ((directory (normalize-pathname-directory-component directory-component)))
     2315      (cond
     2316        ((stringp directory)
     2317         (list :relative directory))
     2318        ((eq (car directory) :absolute)
     2319         (cons :relative (cdr directory)))
     2320        (t
     2321         directory))))
     2322
     2323  (defun relativize-pathname-directory (pathspec)
     2324    (let ((p (pathname pathspec)))
     2325      (make-pathname*
     2326       :directory (relativize-directory-component (pathname-directory p))
     2327       :defaults p)))
     2328
     2329  (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     2330    (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
     2331      (last-char (namestring foo))))
     2332
     2333  #-scl
     2334  (defun directorize-pathname-host-device (pathname)
     2335    #+(or unix abcl)
     2336    (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
     2337      (return-from directorize-pathname-host-device pathname))
     2338    (let* ((root (pathname-root pathname))
     2339           (wild-root (wilden root))
     2340           (absolute-pathname (merge-pathnames* pathname root))
     2341           (separator (directory-separator-for-host root))
     2342           (root-namestring (namestring root))
     2343           (root-string
     2344             (substitute-if #\/
     2345                            #'(lambda (x) (or (eql x #\:)
     2346                                              (eql x separator)))
     2347                            root-namestring)))
     2348      (multiple-value-bind (relative path filename)
     2349          (split-unix-namestring-directory-components root-string :ensure-directory t)
     2350        (declare (ignore relative filename))
     2351        (let ((new-base
     2352                (make-pathname* :defaults root :directory `(:absolute ,@path))))
     2353          (translate-pathname absolute-pathname wild-root (wilden new-base))))))
     2354
     2355  #+scl
     2356  (defun directorize-pathname-host-device (pathname)
     2357    (let ((scheme (ext:pathname-scheme pathname))
     2358          (host (pathname-host pathname))
     2359          (port (ext:pathname-port pathname))
     2360          (directory (pathname-directory pathname)))
     2361      (flet ((specificp (x) (and x (not (eq x :unspecific)))))
     2362        (if (or (specificp port)
     2363                (and (specificp host) (plusp (length host)))
     2364                (specificp scheme))
     2365            (let ((prefix ""))
     2366              (when (specificp port)
     2367                (setf prefix (format nil ":~D" port)))
     2368              (when (and (specificp host) (plusp (length host)))
     2369                (setf prefix (strcat host prefix)))
     2370              (setf prefix (strcat ":" prefix))
     2371              (when (specificp scheme)
     2372                (setf prefix (strcat scheme prefix)))
     2373              (assert (and directory (eq (first directory) :absolute)))
     2374              (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
     2375                              :defaults pathname)))
     2376        pathname)))
     2377
     2378  (defun* (translate-pathname*) (path absolute-source destination &optional root source)
     2379    (declare (ignore source))
    22812380    (cond
    2282       ((stringp directory)
    2283        (list :relative directory))
    2284       ((eq (car directory) :absolute)
    2285        (cons :relative (cdr directory)))
     2381      ((functionp destination)
     2382       (funcall destination path absolute-source))
     2383      ((eq destination t)
     2384       path)
     2385      ((not (pathnamep destination))
     2386       (error "Invalid destination"))
     2387      ((not (absolute-pathname-p destination))
     2388       (translate-pathname path absolute-source (merge-pathnames* destination root)))
     2389      (root
     2390       (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
    22862391      (t
    2287        directory))))
    2288 
    2289 (defun* relativize-pathname-directory (pathspec)
    2290   (let ((p (pathname pathspec)))
    2291     (make-pathname*
    2292      :directory (relativize-directory-component (pathname-directory p))
    2293      :defaults p)))
    2294 
    2295 (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
    2296   (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
    2297     (last-char (namestring foo))))
    2298 
    2299 #-scl
    2300 (defun* directorize-pathname-host-device (pathname)
    2301   #+(or unix abcl)
    2302   (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
    2303     (return-from directorize-pathname-host-device pathname))
    2304   (let* ((root (pathname-root pathname))
    2305          (wild-root (wilden root))
    2306          (absolute-pathname (merge-pathnames* pathname root))
    2307          (separator (directory-separator-for-host root))
    2308          (root-namestring (namestring root))
    2309          (root-string
    2310           (substitute-if #\/
    2311                          #'(lambda (x) (or (eql x #\:)
    2312                                            (eql x separator)))
    2313                          root-namestring)))
    2314     (multiple-value-bind (relative path filename)
    2315         (split-unix-namestring-directory-components root-string :ensure-directory t)
    2316       (declare (ignore relative filename))
    2317       (let ((new-base
    2318              (make-pathname* :defaults root :directory `(:absolute ,@path))))
    2319         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    2320 
    2321 #+scl
    2322 (defun* directorize-pathname-host-device (pathname)
    2323   (let ((scheme (ext:pathname-scheme pathname))
    2324         (host (pathname-host pathname))
    2325         (port (ext:pathname-port pathname))
    2326         (directory (pathname-directory pathname)))
    2327     (flet ((specificp (x) (and x (not (eq x :unspecific)))))
    2328       (if (or (specificp port)
    2329               (and (specificp host) (plusp (length host)))
    2330               (specificp scheme))
    2331         (let ((prefix ""))
    2332           (when (specificp port)
    2333             (setf prefix (format nil ":~D" port)))
    2334           (when (and (specificp host) (plusp (length host)))
    2335             (setf prefix (strcat host prefix)))
    2336           (setf prefix (strcat ":" prefix))
    2337           (when (specificp scheme)
    2338             (setf prefix (strcat scheme prefix)))
    2339           (assert (and directory (eq (first directory) :absolute)))
    2340           (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
    2341                           :defaults pathname)))
    2342     pathname)))
    2343 
    2344 (defun* (translate-pathname*) (path absolute-source destination &optional root source)
    2345   (declare (ignore source))
    2346   (cond
    2347     ((functionp destination)
    2348      (funcall destination path absolute-source))
    2349     ((eq destination t)
    2350      path)
    2351     ((not (pathnamep destination))
    2352      (error "Invalid destination"))
    2353     ((not (absolute-pathname-p destination))
    2354      (translate-pathname path absolute-source (merge-pathnames* destination root)))
    2355     (root
    2356      (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
    2357     (t
    2358      (translate-pathname path absolute-source destination))))
    2359 
    2360 (defvar *output-translation-function* 'identity) ; Hook for output translations
     2392       (translate-pathname path absolute-source destination))))
     2393
     2394  (defvar *output-translation-function* 'identity)) ; Hook for output translations
    23612395
    23622396
     
    23902424
    23912425;;; Native namestrings, as seen by the operating system calls rather than Lisp
    2392 (defun* native-namestring (x)
    2393   "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
    2394   (when x
    2395     (let ((p (pathname x)))
    2396       #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
    2397       #+(or cmu scl) (ext:unix-namestring p nil)
    2398       #+sbcl (sb-ext:native-namestring p)
    2399       #-(or clozure cmu sbcl scl)
    2400       (if (os-unix-p) (unix-namestring p)
    2401           (namestring p)))))
    2402 
    2403 (defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
    2404   "From a native namestring suitable for use by the operating system, return
     2426(with-upgradability ()
     2427  (defun native-namestring (x)
     2428    "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
     2429    (when x
     2430      (let ((p (pathname x)))
     2431        #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
     2432        #+(or cmu scl) (ext:unix-namestring p nil)
     2433        #+sbcl (sb-ext:native-namestring p)
     2434        #-(or clozure cmu sbcl scl)
     2435        (if (os-unix-p) (unix-namestring p)
     2436            (namestring p)))))
     2437
     2438  (defun parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
     2439    "From a native namestring suitable for use by the operating system, return
    24052440a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
    2406   (check-type string (or string null))
    2407   (let* ((pathname
    2408            (when string
    2409              (with-pathname-defaults ()
    2410                #+clozure (ccl:native-to-pathname string)
    2411                #+sbcl (sb-ext:parse-native-namestring string)
    2412                #-(or clozure sbcl)
    2413                (if (os-unix-p)
    2414                    (parse-unix-namestring string :ensure-directory ensure-directory)
    2415                    (parse-namestring string)))))
    2416          (pathname
    2417            (if ensure-directory
    2418                (and pathname (ensure-directory-pathname pathname))
    2419                pathname)))
    2420     (apply 'ensure-pathname pathname constraints)))
     2441    (check-type string (or string null))
     2442    (let* ((pathname
     2443             (when string
     2444               (with-pathname-defaults ()
     2445                 #+clozure (ccl:native-to-pathname string)
     2446                 #+sbcl (sb-ext:parse-native-namestring string)
     2447                 #-(or clozure sbcl)
     2448                 (if (os-unix-p)
     2449                     (parse-unix-namestring string :ensure-directory ensure-directory)
     2450                     (parse-namestring string)))))
     2451           (pathname
     2452             (if ensure-directory
     2453                 (and pathname (ensure-directory-pathname pathname))
     2454                 pathname)))
     2455      (apply 'ensure-pathname pathname constraints))))
    24212456
    24222457
    24232458;;; Probing the filesystem
    2424 (defun* truename* (p)
    2425   ;; avoids both logical-pathname merging and physical resolution issues
    2426   (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
    2427 
    2428 (defun* safe-file-write-date (pathname)
    2429   ;; If FILE-WRITE-DATE returns NIL, it's possible that
    2430   ;; the user or some other agent has deleted an input file.
    2431   ;; Also, generated files will not exist at the time planning is done
    2432   ;; and calls compute-action-stamp which calls safe-file-write-date.
    2433   ;; So it is very possible that we can't get a valid file-write-date,
    2434   ;; and we can survive and we will continue the planning
    2435   ;; as if the file were very old.
    2436   ;; (or should we treat the case in a different, special way?)
    2437   (handler-case (file-write-date (translate-logical-pathname pathname)) (file-error () nil)))
    2438 
    2439 (defun* probe-file* (p &key truename)
    2440   "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
     2459(with-upgradability ()
     2460  (defun truename* (p)
     2461    ;; avoids both logical-pathname merging and physical resolution issues
     2462    (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
     2463
     2464  (defun safe-file-write-date (pathname)
     2465    ;; If FILE-WRITE-DATE returns NIL, it's possible that
     2466    ;; the user or some other agent has deleted an input file.
     2467    ;; Also, generated files will not exist at the time planning is done
     2468    ;; and calls compute-action-stamp which calls safe-file-write-date.
     2469    ;; So it is very possible that we can't get a valid file-write-date,
     2470    ;; and we can survive and we will continue the planning
     2471    ;; as if the file were very old.
     2472    ;; (or should we treat the case in a different, special way?)
     2473    (and pathname
     2474         (handler-case (file-write-date (translate-logical-pathname pathname))
     2475           (file-error () nil))))
     2476
     2477  (defun probe-file* (p &key truename)
     2478    "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
    24412479probes the filesystem for a file or directory with given pathname.
    24422480If it exists, return its truename is ENSURE-PATHNAME is true,
    24432481or the original (parsed) pathname if it is false (the default)."
    2444   (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
    2445     (etypecase p
    2446       (null nil)
    2447       (string (probe-file* (parse-namestring p) :truename truename))
    2448       (pathname
    2449        (handler-case
    2450            (or
    2451             #+allegro
    2452             (probe-file p :follow-symlinks truename)
    2453             #-(or allegro clisp gcl2.6)
    2454             (if truename
    2455                 (probe-file p)
    2456                 (and (not (wild-pathname-p p))
    2457                      (ignore-errors
    2458                       (let ((pp (translate-logical-pathname p)))
    2459                         #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
    2460                         #+(and lispworks unix) (system:get-file-stat pp)
    2461                         #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
    2462                         #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
    2463                      p))
    2464             #+(or clisp gcl2.6)
    2465             #.(flet ((probe (probe)
    2466                        `(let ((foundtrue ,probe))
    2467                           (cond
    2468                             (truename foundtrue)
    2469                             (foundtrue p)))))
    2470                 #+gcl2.6
    2471                 (probe '(or (probe-file p)
    2472                          (and (directory-pathname-p p)
    2473                           (ignore-errors
    2474                            (ensure-directory-pathname
    2475                             (truename* (subpathname
    2476                                         (ensure-directory-pathname p) ".")))))))
    2477                 #+clisp
    2478                 (let* ((fs (find-symbol* '#:file-stat :posix nil))
    2479                        (pp (find-symbol* '#:probe-pathname :ext nil))
    2480                        (resolve (if pp
    2481                                     `(ignore-errors (,pp p))
    2482                                     '(or (truename* p)
    2483                                       (truename* (ignore-errors (ensure-directory-pathname p)))))))
    2484                   (if fs
    2485                       `(if truename
    2486                            ,resolve
    2487                            (and (ignore-errors (,fs p)) p))
    2488                       (probe resolve)))))
    2489          (file-error () nil))))))
    2490 
    2491 (defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
    2492   (apply 'directory pathname-spec
    2493          (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
    2494                              #+clozure '(:follow-links nil)
    2495                              #+clisp '(:circle t :if-does-not-exist :ignore)
    2496                              #+(or cmu scl) '(:follow-links nil :truenamep nil)
    2497                              #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
    2498                                       '(:resolve-symlinks nil))))))
    2499 
    2500 (defun* filter-logical-directory-results (directory entries merger)
    2501   (if (logical-pathname-p directory)
    2502       ;; Try hard to not resolve logical-pathname into physical pathnames;
    2503       ;; otherwise logical-pathname users/lovers will be disappointed.
    2504       ;; If directory* could use some implementation-dependent magic,
    2505       ;; we will have logical pathnames already; otherwise,
    2506       ;; we only keep pathnames for which specifying the name and
    2507       ;; translating the LPN commute.
    2508       (loop :for f :in entries
    2509         :for p = (or (and (logical-pathname-p f) f)
    2510                      (let* ((u (ignore-errors (funcall merger f))))
    2511                        ;; The first u avoids a cumbersome (truename u) error.
    2512                        ;; At this point f should already be a truename,
    2513                        ;; but isn't quite in CLISP, for it doesn't have :version :newest
    2514                        (and u (equal (truename* u) (truename* f)) u)))
    2515         :when p :collect p)
    2516       entries))
    2517 
    2518 (defun* directory-files (directory &optional (pattern *wild-file*))
    2519   (let ((dir (pathname directory)))
    2520     (when (logical-pathname-p dir)
    2521       ;; Because of the filtering we do below,
    2522       ;; logical pathnames have restrictions on wild patterns.
    2523       ;; Not that the results are very portable when you use these patterns on physical pathnames.
    2524       (when (wild-pathname-p dir)
    2525         (error "Invalid wild pattern in logical directory ~S" directory))
    2526       (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
    2527         (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
    2528       (setf pattern (make-pathname-logical pattern (pathname-host dir))))
    2529     (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     2482    (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
     2483      (etypecase p
     2484        (null nil)
     2485        (string (probe-file* (parse-namestring p) :truename truename))
     2486        (pathname
     2487         (handler-case
     2488             (or
     2489              #+allegro
     2490              (probe-file p :follow-symlinks truename)
     2491              #-(or allegro clisp gcl2.6)
     2492              (if truename
     2493                  (probe-file p)
     2494                  (and (not (wild-pathname-p p))
     2495                       (ignore-errors
     2496                        (let ((pp (translate-logical-pathname p)))
     2497                          #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
     2498                          #+(and lispworks unix) (system:get-file-stat pp)
     2499                          #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
     2500                          #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
     2501                       p))
     2502              #+(or clisp gcl2.6)
     2503              #.(flet ((probe (probe)
     2504                         `(let ((foundtrue ,probe))
     2505                            (cond
     2506                              (truename foundtrue)
     2507                              (foundtrue p)))))
     2508                  #+gcl2.6
     2509                  (probe '(or (probe-file p)
     2510                           (and (directory-pathname-p p)
     2511                            (ignore-errors
     2512                             (ensure-directory-pathname
     2513                              (truename* (subpathname
     2514                                          (ensure-directory-pathname p) ".")))))))
     2515                  #+clisp
     2516                  (let* ((fs (find-symbol* '#:file-stat :posix nil))
     2517                         (pp (find-symbol* '#:probe-pathname :ext nil))
     2518                         (resolve (if pp
     2519                                      `(ignore-errors (,pp p))
     2520                                      '(or (truename* p)
     2521                                        (truename* (ignore-errors (ensure-directory-pathname p)))))))
     2522                    (if fs
     2523                        `(if truename
     2524                             ,resolve
     2525                             (and (ignore-errors (,fs p)) p))
     2526                        (probe resolve)))))
     2527           (file-error () nil))))))
     2528
     2529  (defun directory* (pathname-spec &rest keys &key &allow-other-keys)
     2530    (apply 'directory pathname-spec
     2531           (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     2532                               #+clozure '(:follow-links nil)
     2533                               #+clisp '(:circle t :if-does-not-exist :ignore)
     2534                               #+(or cmu scl) '(:follow-links nil :truenamep nil)
     2535                               #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
     2536                                        '(:resolve-symlinks nil))))))
     2537
     2538  (defun filter-logical-directory-results (directory entries merger)
     2539    (if (logical-pathname-p directory)
     2540        ;; Try hard to not resolve logical-pathname into physical pathnames;
     2541        ;; otherwise logical-pathname users/lovers will be disappointed.
     2542        ;; If directory* could use some implementation-dependent magic,
     2543        ;; we will have logical pathnames already; otherwise,
     2544        ;; we only keep pathnames for which specifying the name and
     2545        ;; translating the LPN commute.
     2546        (loop :for f :in entries
     2547              :for p = (or (and (logical-pathname-p f) f)
     2548                           (let* ((u (ignore-errors (funcall merger f))))
     2549                             ;; The first u avoids a cumbersome (truename u) error.
     2550                             ;; At this point f should already be a truename,
     2551                             ;; but isn't quite in CLISP, for it doesn't have :version :newest
     2552                             (and u (equal (truename* u) (truename* f)) u)))
     2553              :when p :collect p)
     2554        entries))
     2555
     2556  (defun directory-files (directory &optional (pattern *wild-file*))
     2557    (let ((dir (pathname directory)))
     2558      (when (logical-pathname-p dir)
     2559        ;; Because of the filtering we do below,
     2560        ;; logical pathnames have restrictions on wild patterns.
     2561        ;; Not that the results are very portable when you use these patterns on physical pathnames.
     2562        (when (wild-pathname-p dir)
     2563          (error "Invalid wild pattern in logical directory ~S" directory))
     2564        (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     2565          (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
     2566        (setf pattern (make-pathname-logical pattern (pathname-host dir))))
     2567      (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     2568        (filter-logical-directory-results
     2569         directory entries
     2570         #'(lambda (f)
     2571             (make-pathname :defaults dir
     2572                            :name (make-pathname-component-logical (pathname-name f))
     2573                            :type (make-pathname-component-logical (pathname-type f))
     2574                            :version (make-pathname-component-logical (pathname-version f))))))))
     2575
     2576  (defun subdirectories (directory)
     2577    (let* ((directory (ensure-directory-pathname directory))
     2578           #-(or abcl cormanlisp genera xcl)
     2579           (wild (merge-pathnames*
     2580                  #-(or abcl allegro cmu lispworks sbcl scl xcl)
     2581                  *wild-directory*
     2582                  #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
     2583                  directory))
     2584           (dirs
     2585             #-(or abcl cormanlisp genera xcl)
     2586             (ignore-errors
     2587              (directory* wild . #.(or #+clozure '(:directories t :files nil)
     2588                                       #+mcl '(:directories t))))
     2589             #+(or abcl xcl) (system:list-directory directory)
     2590             #+cormanlisp (cl::directory-subdirs directory)
     2591             #+genera (fs:directory-list directory))
     2592           #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
     2593           (dirs (loop :for x :in dirs
     2594                       :for d = #+(or abcl xcl) (extensions:probe-directory x)
     2595                       #+allegro (excl:probe-directory x)
     2596                       #+(or cmu sbcl scl) (directory-pathname-p x)
     2597                       #+genera (getf (cdr x) :directory)
     2598                       #+lispworks (lw:file-directory-p x)
     2599                       :when d :collect #+(or abcl allegro xcl) d
     2600                         #+genera (ensure-directory-pathname (first x))
     2601                       #+(or cmu lispworks sbcl scl) x)))
    25302602      (filter-logical-directory-results
    2531        directory entries
    2532        #'(lambda (f)
    2533            (make-pathname :defaults dir
    2534                           :name (make-pathname-component-logical (pathname-name f))
    2535                           :type (make-pathname-component-logical (pathname-type f))
    2536                           :version (make-pathname-component-logical (pathname-version f))))))))
    2537 
    2538 (defun* subdirectories (directory)
    2539   (let* ((directory (ensure-directory-pathname directory))
    2540          #-(or abcl cormanlisp genera xcl)
    2541          (wild (merge-pathnames*
    2542                 #-(or abcl allegro cmu lispworks sbcl scl xcl)
    2543                 *wild-directory*
    2544                 #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
    2545                 directory))
    2546          (dirs
    2547           #-(or abcl cormanlisp genera xcl)
    2548           (ignore-errors
    2549             (directory* wild . #.(or #+clozure '(:directories t :files nil)
    2550                                      #+mcl '(:directories t))))
    2551           #+(or abcl xcl) (system:list-directory directory)
    2552           #+cormanlisp (cl::directory-subdirs directory)
    2553           #+genera (fs:directory-list directory))
    2554          #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
    2555          (dirs (loop :for x :in dirs
    2556                  :for d = #+(or abcl xcl) (extensions:probe-directory x)
    2557                           #+allegro (excl:probe-directory x)
    2558                           #+(or cmu sbcl scl) (directory-pathname-p x)
    2559                           #+genera (getf (cdr x) :directory)
    2560                           #+lispworks (lw:file-directory-p x)
    2561                  :when d :collect #+(or abcl allegro xcl) d
    2562                                   #+genera (ensure-directory-pathname (first x))
    2563                                   #+(or cmu lispworks sbcl scl) x)))
    2564     (filter-logical-directory-results
    2565      directory dirs
    2566      (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
    2567                        '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
    2568        #'(lambda (d)
    2569            (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
    2570              (and (consp dir) (consp (cdr dir))
    2571                   (make-pathname
    2572                    :defaults directory :name nil :type nil :version nil
    2573                    :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
    2574 
    2575 (defun* collect-sub*directories (directory collectp recursep collector)
    2576   (when (funcall collectp directory)
    2577     (funcall collector directory))
    2578   (dolist (subdir (subdirectories directory))
    2579     (when (funcall recursep subdir)
    2580       (collect-sub*directories subdir collectp recursep collector))))
     2603       directory dirs
     2604       (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
     2605                         '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
     2606         #'(lambda (d)
     2607             (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
     2608               (and (consp dir) (consp (cdr dir))
     2609                    (make-pathname
     2610                     :defaults directory :name nil :type nil :version nil
     2611                     :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
     2612
     2613  (defun collect-sub*directories (directory collectp recursep collector)
     2614    (when (funcall collectp directory)
     2615      (funcall collector directory))
     2616    (dolist (subdir (subdirectories directory))
     2617      (when (funcall recursep subdir)
     2618        (collect-sub*directories subdir collectp recursep collector)))))
    25812619
    25822620;;; Resolving symlinks somewhat
    2583 (defun* truenamize (pathname)
    2584   "Resolve as much of a pathname as possible"
    2585   (block nil
    2586     (when (typep pathname '(or null logical-pathname)) (return pathname))
    2587     (let ((p pathname))
    2588       (unless (absolute-pathname-p p)
    2589         (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
    2590                     (return p))))
    2591       (when (logical-pathname-p p) (return p))
    2592       (let ((found (probe-file* p :truename t)))
    2593         (when found (return found)))
    2594       (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
    2595              (up-components (reverse (rest directory)))
    2596              (down-components ()))
    2597         (assert (eq :absolute (first directory)))
    2598         (loop :while up-components :do
    2599           (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
    2600                                                        :name nil :type nil :version nil :defaults p)))
    2601             (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
    2602                                                       :defaults p)
    2603                                       (ensure-directory-pathname parent)))
    2604             (push (pop up-components) down-components))
    2605           :finally (return p))))))
    2606 
    2607 (defun* resolve-symlinks (path)
    2608   #-allegro (truenamize path)
    2609   #+allegro
    2610   (if (physical-pathname-p path)
    2611       (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
    2612       path))
    2613 
    2614 (defvar *resolve-symlinks* t
    2615   "Determine whether or not ASDF resolves symlinks when defining systems.
     2621(with-upgradability ()
     2622  (defun truenamize (pathname)
     2623    "Resolve as much of a pathname as possible"
     2624    (block nil
     2625      (when (typep pathname '(or null logical-pathname)) (return pathname))
     2626      (let ((p pathname))
     2627        (unless (absolute-pathname-p p)
     2628          (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
     2629                      (return p))))
     2630        (when (logical-pathname-p p) (return p))
     2631        (let ((found (probe-file* p :truename t)))
     2632          (when found (return found)))
     2633        (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
     2634               (up-components (reverse (rest directory)))
     2635               (down-components ()))
     2636          (assert (eq :absolute (first directory)))
     2637          (loop :while up-components :do
     2638            (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
     2639                                                         :name nil :type nil :version nil :defaults p)))
     2640              (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
     2641                                                        :defaults p)
     2642                                        (ensure-directory-pathname parent)))
     2643              (push (pop up-components) down-components))
     2644                :finally (return p))))))
     2645
     2646  (defun resolve-symlinks (path)
     2647    #-allegro (truenamize path)
     2648    #+allegro
     2649    (if (physical-pathname-p path)
     2650        (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
     2651        path))
     2652
     2653  (defvar *resolve-symlinks* t
     2654    "Determine whether or not ASDF resolves symlinks when defining systems.
    26162655Defaults to T.")
    26172656
    2618 (defun* resolve-symlinks* (path)
    2619   (if *resolve-symlinks*
    2620       (and path (resolve-symlinks path))
    2621       path))
     2657  (defun resolve-symlinks* (path)
     2658    (if *resolve-symlinks*
     2659        (and path (resolve-symlinks path))
     2660        path)))
    26222661
    26232662
    26242663;;; Check pathname constraints
    2625 
    2626 (defun* ensure-pathname
    2627     (pathname &key
    2628               on-error
    2629               defaults type dot-dot
    2630               want-pathname
    2631               want-logical want-physical ensure-physical
    2632               want-relative want-absolute ensure-absolute ensure-subpath
    2633               want-non-wild want-wild wilden
    2634               want-file want-directory ensure-directory
    2635               want-existing ensure-directories-exist
    2636               truename resolve-symlinks truenamize
    2637               &aux (p pathname)) ;; mutable working copy, preserve original
    2638   "Coerces its argument into a PATHNAME,
     2664(with-upgradability ()
     2665  (defun ensure-pathname
     2666      (pathname &key
     2667                  on-error
     2668                  defaults type dot-dot
     2669                  want-pathname
     2670                  want-logical want-physical ensure-physical
     2671                  want-relative want-absolute ensure-absolute ensure-subpath
     2672                  want-non-wild want-wild wilden
     2673                  want-file want-directory ensure-directory
     2674                  want-existing ensure-directories-exist
     2675                  truename resolve-symlinks truenamize
     2676       &aux (p pathname)) ;; mutable working copy, preserve original
     2677    "Coerces its argument into a PATHNAME,
    26392678optionally doing some transformations and checking specified constraints.
    26402679
     
    26862725RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
    26872726TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
    2688   (block nil
    2689     (flet ((report-error (keyword description &rest arguments)
    2690              (call-function (or on-error 'error)
    2691                             "Invalid pathname ~S: ~*~?"
    2692                             pathname keyword description arguments)))
    2693       (macrolet ((err (constraint &rest arguments)
    2694                    `(report-error ',(intern* constraint :keyword) ,@arguments))
    2695                  (check (constraint condition &rest arguments)
    2696                    `(when ,constraint
    2697                       (unless ,condition (err ,constraint ,@arguments))))
    2698                  (transform (transform condition expr)
    2699                    `(when ,transform
    2700                       (,@(if condition `(when ,condition) '(progn))
    2701                        (setf p ,expr)))))
    2702         (etypecase p
    2703           ((or null pathname))
    2704           (string
    2705            (setf p (parse-unix-namestring
    2706                     p :defaults defaults :type type :dot-dot dot-dot
    2707                     :ensure-directory ensure-directory :want-relative want-relative))))
    2708         (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
    2709         (unless (pathnamep p) (return nil))
    2710         (check want-logical (logical-pathname-p p) "Expected a logical pathname")
    2711         (check want-physical (physical-pathname-p p) "Expected a physical pathname")
    2712         (transform ensure-physical () (translate-logical-pathname p))
    2713         (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
    2714         (check want-relative (relative-pathname-p p) "Expected a relative pathname")
    2715         (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
    2716         (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
    2717         (check ensure-absolute (absolute-pathname-p p)
    2718                "Could not make into an absolute pathname even after merging with ~S" defaults)
    2719         (check ensure-subpath (absolute-pathname-p defaults)
    2720                "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
    2721         (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
    2722         (check want-file (file-pathname-p p) "Expected a file pathname")
    2723         (check want-directory (directory-pathname-p p) "Expected a directory pathname")
    2724         (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
    2725         (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
    2726         (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
    2727         (transform wilden (not (wild-pathname-p p)) (wilden p))
    2728         (when want-existing
    2729           (let ((existing (probe-file* p :truename truename)))
    2730             (if existing
    2731                 (when truename
    2732                   (return existing))
    2733                 (err want-existing "Expected an existing pathname"))))
    2734         (when ensure-directories-exist (ensure-directories-exist p))
    2735         (when truename
    2736           (let ((truename (truename* p)))
    2737             (if truename
    2738                 (return truename)
    2739                 (err truename "Can't get a truename for pathname"))))
    2740         (transform resolve-symlinks () (resolve-symlinks p))
    2741         (transform truenamize () (truenamize p))
    2742         p))))
     2727    (block nil
     2728      (flet ((report-error (keyword description &rest arguments)
     2729               (call-function (or on-error 'error)
     2730                              "Invalid pathname ~S: ~*~?"
     2731                              pathname keyword description arguments)))
     2732        (macrolet ((err (constraint &rest arguments)
     2733                     `(report-error ',(intern* constraint :keyword) ,@arguments))
     2734                   (check (constraint condition &rest arguments)
     2735                     `(when ,constraint
     2736                        (unless ,condition (err ,constraint ,@arguments))))
     2737                   (transform (transform condition expr)
     2738                     `(when ,transform
     2739                        (,@(if condition `(when ,condition) '(progn))
     2740                         (setf p ,expr)))))
     2741          (etypecase p
     2742            ((or null pathname))
     2743            (string
     2744             (setf p (parse-unix-namestring
     2745                      p :defaults defaults :type type :dot-dot dot-dot
     2746                        :ensure-directory ensure-directory :want-relative want-relative))))
     2747          (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
     2748          (unless (pathnamep p) (return nil))
     2749          (check want-logical (logical-pathname-p p) "Expected a logical pathname")
     2750          (check want-physical (physical-pathname-p p) "Expected a physical pathname")
     2751          (transform ensure-physical () (translate-logical-pathname p))
     2752          (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
     2753          (check want-relative (relative-pathname-p p) "Expected a relative pathname")
     2754          (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
     2755          (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
     2756          (check ensure-absolute (absolute-pathname-p p)
     2757                 "Could not make into an absolute pathname even after merging with ~S" defaults)
     2758          (check ensure-subpath (absolute-pathname-p defaults)
     2759                 "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
     2760          (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
     2761          (check want-file (file-pathname-p p) "Expected a file pathname")
     2762          (check want-directory (directory-pathname-p p) "Expected a directory pathname")
     2763          (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
     2764          (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
     2765          (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
     2766          (transform wilden (not (wild-pathname-p p)) (wilden p))
     2767          (when want-existing
     2768            (let ((existing (probe-file* p :truename truename)))
     2769              (if existing
     2770                  (when truename
     2771                    (return existing))
     2772                  (err want-existing "Expected an existing pathname"))))
     2773          (when ensure-directories-exist (ensure-directories-exist p))
     2774          (when truename
     2775            (let ((truename (truename* p)))
     2776              (if truename
     2777                  (return truename)
     2778                  (err truename "Can't get a truename for pathname"))))
     2779          (transform resolve-symlinks () (resolve-symlinks p))
     2780          (transform truenamize () (truenamize p))
     2781          p)))))
    27432782
    27442783
    27452784;;; Pathname defaults
    2746 (defun* get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
    2747   (or (absolute-pathname-p defaults)
    2748       (merge-pathnames* defaults (getcwd))))
    2749 
    2750 (defun* call-with-current-directory (dir thunk)
    2751   (if dir
    2752       (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
    2753              (*default-pathname-defaults* dir)
    2754              (cwd (getcwd)))
    2755         (chdir dir)
    2756         (unwind-protect
    2757              (funcall thunk)
    2758           (chdir cwd)))
    2759       (funcall thunk)))
    2760 
    2761 (defmacro with-current-directory ((&optional dir) &body body)
    2762   "Call BODY while the POSIX current working directory is set to DIR"
    2763   `(call-with-current-directory ,dir #'(lambda () ,@body)))
     2785(with-upgradability ()
     2786  (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
     2787    (or (absolute-pathname-p defaults)
     2788        (merge-pathnames* defaults (getcwd))))
     2789
     2790  (defun call-with-current-directory (dir thunk)
     2791    (if dir
     2792        (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
     2793               (*default-pathname-defaults* dir)
     2794               (cwd (getcwd)))
     2795          (chdir dir)
     2796          (unwind-protect
     2797               (funcall thunk)
     2798            (chdir cwd)))
     2799        (funcall thunk)))
     2800
     2801  (defmacro with-current-directory ((&optional dir) &body body)
     2802    "Call BODY while the POSIX current working directory is set to DIR"
     2803    `(call-with-current-directory ,dir #'(lambda () ,@body))))
    27642804
    27652805
    27662806;;; Environment pathnames
    2767 (defun* inter-directory-separator ()
    2768   (if (os-unix-p) #\: #\;))
    2769 
    2770 (defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
    2771   (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
    2772         :collect (apply 'parse-native-namestring namestring constraints)))
    2773 
    2774 (defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
    2775   (apply 'parse-native-namestring (getenvp x)
    2776          :on-error (or on-error
    2777                        `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
    2778          constraints))
    2779 (defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
    2780   (apply 'split-native-pathnames-string (getenvp x)
    2781          :on-error (or on-error
    2782                        `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
    2783          constraints))
    2784 (defun* getenv-absolute-directory (x)
    2785   (getenv-pathname x :want-absolute t :ensure-directory t))
    2786 (defun* getenv-absolute-directories (x)
    2787   (getenv-pathnames x :want-absolute t :ensure-directory t))
    2788 
    2789 (defun* lisp-implementation-directory (&key truename)
    2790   (declare (ignorable truename))
    2791   #+(or clozure ecl gcl mkcl sbcl)
    2792   (let ((dir
    2793           (ignore-errors
    2794            #+clozure #p"ccl:"
    2795            #+(or ecl mkcl) #p"SYS:"
    2796            #+gcl system::*system-directory*
    2797            #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
    2798                      (funcall it)
    2799                      (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
    2800     (if (and dir truename)
    2801         (truename* dir)
    2802         dir)))
    2803 
    2804 (defun* lisp-implementation-pathname-p (pathname)
    2805   ;; Other builtin systems are those under the implementation directory
    2806   (and (when pathname
    2807          (if-let (impdir (lisp-implementation-directory))
    2808            (or (subpathp pathname impdir)
    2809                (when *resolve-symlinks*
    2810                  (if-let (truename (truename* pathname))
    2811                    (if-let (trueimpdir (truename* impdir))
    2812                      (subpathp truename trueimpdir)))))))
    2813        t))
     2807(with-upgradability ()
     2808  (defun inter-directory-separator ()
     2809    (if (os-unix-p) #\: #\;))
     2810
     2811  (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
     2812    (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
     2813          :collect (apply 'parse-native-namestring namestring constraints)))
     2814
     2815  (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
     2816    (apply 'parse-native-namestring (getenvp x)
     2817           :on-error (or on-error
     2818                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
     2819           constraints))
     2820  (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
     2821    (apply 'split-native-pathnames-string (getenvp x)
     2822           :on-error (or on-error
     2823                         `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
     2824           constraints))
     2825  (defun getenv-absolute-directory (x)
     2826    (getenv-pathname x :want-absolute t :ensure-directory t))
     2827  (defun getenv-absolute-directories (x)
     2828    (getenv-pathnames x :want-absolute t :ensure-directory t))
     2829
     2830  (defun lisp-implementation-directory (&key truename)
     2831    (declare (ignorable truename))
     2832    #+(or clozure ecl gcl mkcl sbcl)
     2833    (let ((dir
     2834            (ignore-errors
     2835             #+clozure #p"ccl:"
     2836             #+(or ecl mkcl) #p"SYS:"
     2837             #+gcl system::*system-directory*
     2838             #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
     2839                      (funcall it)
     2840                      (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
     2841      (if (and dir truename)
     2842          (truename* dir)
     2843          dir)))
     2844
     2845  (defun lisp-implementation-pathname-p (pathname)
     2846    ;; Other builtin systems are those under the implementation directory
     2847    (and (when pathname
     2848           (if-let (impdir (lisp-implementation-directory))
     2849             (or (subpathp pathname impdir)
     2850                 (when *resolve-symlinks*
     2851                   (if-let (truename (truename* pathname))
     2852                     (if-let (trueimpdir (truename* impdir))
     2853                       (subpathp truename trueimpdir)))))))
     2854         t)))
    28142855
    28152856
    28162857;;; Simple filesystem operations
    2817 (defun* ensure-all-directories-exist (pathnames)
    2818    (dolist (pathname pathnames)
    2819      (ensure-directories-exist (translate-logical-pathname pathname))))
    2820 
    2821 (defun* rename-file-overwriting-target (source target)
    2822   #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
    2823   (posix:copy-file source target :method :rename)
    2824   #-clisp
    2825   (rename-file source target
    2826                #+clozure :if-exists #+clozure :rename-and-delete))
    2827 
    2828 (defun* delete-file-if-exists (x)
    2829   (when x (handler-case (delete-file x) (file-error () nil))))
     2858(with-upgradability ()
     2859  (defun ensure-all-directories-exist (pathnames)
     2860    (dolist (pathname pathnames)
     2861      (ensure-directories-exist (translate-logical-pathname pathname))))
     2862
     2863  (defun rename-file-overwriting-target (source target)
     2864    #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
     2865    (posix:copy-file source target :method :rename)
     2866    #-clisp
     2867    (rename-file source target
     2868                 #+clozure :if-exists #+clozure :rename-and-delete))
     2869
     2870  (defun delete-file-if-exists (x)
     2871    (when x (handler-case (delete-file x) (file-error () nil)))))
    28302872
    28312873
     
    28382880  (:export
    28392881   #:*default-stream-element-type* #:*stderr* #:setup-stderr
     2882   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
     2883   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
     2884   #:*default-encoding* #:*utf-8-external-format*
    28402885   #:with-safe-io-syntax #:call-with-safe-io-syntax
    28412886   #:with-output #:output-string #:with-input
     
    28482893   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
    28492894   #:eval-input #:eval-thunk #:standard-eval-thunk
    2850    #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
    2851    #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
    2852    #:*default-encoding* #:*utf-8-external-format*
    28532895   ;; Temporary files
    28542896   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
     
    28592901(in-package :asdf/stream)
    28602902
    2861 (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
    2862   "default element-type for open (depends on the current CL implementation)")
    2863 
    2864 (defvar *stderr* *error-output*
    2865   "the original error output stream at startup")
    2866 
    2867 (defun setup-stderr ()
    2868   (setf *stderr*
    2869         #+allegro excl::*stderr*
    2870         #+clozure ccl::*stderr*
    2871         #-(or allegro clozure) *error-output*))
    2872 (setup-stderr)
     2903(with-upgradability ()
     2904  (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
     2905    "default element-type for open (depends on the current CL implementation)")
     2906
     2907  (defvar *stderr* *error-output*
     2908    "the original error output stream at startup")
     2909
     2910  (defun setup-stderr ()
     2911    (setf *stderr*
     2912          #+allegro excl::*stderr*
     2913          #+clozure ccl::*stderr*
     2914          #-(or allegro clozure) *error-output*))
     2915  (setup-stderr))
     2916
     2917
     2918;;; Encodings (mostly hooks only; full support requires asdf-encodings)
     2919(with-upgradability ()
     2920  (defvar *default-encoding* :default
     2921    "Default encoding for source files.
     2922The default value :default preserves the legacy behavior.
     2923A future default might be :utf-8 or :autodetect
     2924reading emacs-style -*- coding: utf-8 -*- specifications,
     2925and falling back to utf-8 or latin1 if nothing is specified.")
     2926
     2927  (defparameter *utf-8-external-format*
     2928    #+(and asdf-unicode (not clisp)) :utf-8
     2929    #+(and asdf-unicode clisp) charset:utf-8
     2930    #-asdf-unicode :default
     2931    "Default :external-format argument to pass to CL:OPEN and also
     2932CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
     2933On modern implementations, this will decode UTF-8 code points as CL characters.
     2934On legacy implementations, it may fall back on some 8-bit encoding,
     2935with non-ASCII code points being read as several CL characters;
     2936hopefully, if done consistently, that won't affect program behavior too much.")
     2937
     2938  (defun always-default-encoding (pathname)
     2939    (declare (ignore pathname))
     2940    *default-encoding*)
     2941
     2942  (defvar *encoding-detection-hook* #'always-default-encoding
     2943    "Hook for an extension to define a function to automatically detect a file's encoding")
     2944
     2945  (defun detect-encoding (pathname)
     2946    (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
     2947        (funcall *encoding-detection-hook* pathname)
     2948        *default-encoding*))
     2949
     2950  (defun default-encoding-external-format (encoding)
     2951    (case encoding
     2952      (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
     2953      (:utf-8 *utf-8-external-format*)
     2954      (otherwise
     2955       (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
     2956       :default)))
     2957
     2958  (defvar *encoding-external-format-hook*
     2959    #'default-encoding-external-format
     2960    "Hook for an extension to define a mapping between non-default encodings
     2961and implementation-defined external-format's")
     2962
     2963  (defun encoding-external-format (encoding)
     2964    (funcall *encoding-external-format-hook* encoding)))
    28732965
    28742966
    28752967;;; Safe syntax
    2876 
    2877 (defvar *standard-readtable* (copy-readtable nil))
    2878 
    2879 (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
    2880   "Establish safe CL reader options around the evaluation of BODY"
    2881   `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
    2882 
    2883 (defun* call-with-safe-io-syntax (thunk &key (package :cl))
    2884   (with-standard-io-syntax ()
    2885     (let ((*package* (find-package package))
    2886           (*readtable* *standard-readtable*)
    2887           (*read-default-float-format* 'double-float)
    2888           (*print-readably* nil)
    2889           (*read-eval* nil))
    2890       (funcall thunk))))
     2968(with-upgradability ()
     2969  (defvar *standard-readtable* (copy-readtable nil))
     2970
     2971  (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
     2972    "Establish safe CL reader options around the evaluation of BODY"
     2973    `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
     2974
     2975  (defun call-with-safe-io-syntax (thunk &key (package :cl))
     2976    (with-standard-io-syntax
     2977      (let ((*package* (find-package package))
     2978            (*read-default-float-format* 'double-float)
     2979            (*print-readably* nil)
     2980            (*read-eval* nil))
     2981        (funcall thunk)))))
    28912982
    28922983
    28932984;;; Output to a stream or string, FORMAT-style
    2894 
    2895 (defun* call-with-output (output function)
    2896   "Calls FUNCTION with an actual stream argument,
     2985(with-upgradability ()
     2986  (defun call-with-output (output function)
     2987    "Calls FUNCTION with an actual stream argument,
    28972988behaving like FORMAT with respect to how stream designators are interpreted:
    28982989If OUTPUT is a stream, use it as the stream.
     
    29012992If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
    29022993Otherwise, signal an error."
    2903   (etypecase output
    2904     (null
    2905      (with-output-to-string (stream) (funcall function stream)))
    2906     ((eql t)
    2907      (funcall function *standard-output*))
    2908     (stream
    2909      (funcall function output))
    2910     (string
    2911      (assert (fill-pointer output))
    2912      (with-output-to-string (stream output) (funcall function stream)))))
    2913 
    2914 (defmacro with-output ((output-var &optional (value output-var)) &body body)
    2915   "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
     2994    (etypecase output
     2995      (null
     2996       (with-output-to-string (stream) (funcall function stream)))
     2997      ((eql t)
     2998       (funcall function *standard-output*))
     2999      (stream
     3000       (funcall function output))
     3001      (string
     3002       (assert (fill-pointer output))
     3003       (with-output-to-string (stream output) (funcall function stream)))))
     3004
     3005  (defmacro with-output ((output-var &optional (value output-var)) &body body)
     3006    "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
    29163007as per FORMAT, and evaluate BODY within the scope of this binding."
    2917   `(call-with-output ,value #'(lambda (,output-var) ,@body)))
    2918 
    2919 (defun* output-string (string &optional output)
    2920   "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
    2921   (if output
    2922       (with-output (output) (princ string output))
    2923       string))
     3008    `(call-with-output ,value #'(lambda (,output-var) ,@body)))
     3009
     3010  (defun output-string (string &optional output)
     3011    "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
     3012    (if output
     3013        (with-output (output) (princ string output))
     3014        string)))
    29243015
    29253016
    29263017;;; Input helpers
    2927 
    2928 (defun* call-with-input (input function)
    2929   "Calls FUNCTION with an actual stream argument, interpreting
     3018(with-upgradability ()
     3019  (defun call-with-input (input function)
     3020    "Calls FUNCTION with an actual stream argument, interpreting
    29303021stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
    29313022If INPUT is a STREAM, use it as the stream.
     
    29343025As an extension, if INPUT is a string, use it as a string-input-stream.
    29353026Otherwise, signal an error."
    2936   (etypecase input
    2937     (null (funcall function *standard-input*))
    2938     ((eql t) (funcall function *terminal-io*))
    2939     (stream (funcall function input))
    2940     (string (with-input-from-string (stream input) (funcall function stream)))))
    2941 
    2942 (defmacro with-input ((input-var &optional (value input-var)) &body body)
    2943   "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
     3027    (etypecase input
     3028      (null (funcall function *standard-input*))
     3029      ((eql t) (funcall function *terminal-io*))
     3030      (stream (funcall function input))
     3031      (string (with-input-from-string (stream input) (funcall function stream)))))
     3032
     3033  (defmacro with-input ((input-var &optional (value input-var)) &body body)
     3034    "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
    29443035as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
    2945   `(call-with-input ,value #'(lambda (,input-var) ,@body)))
    2946 
    2947 (defun* call-with-input-file (pathname thunk
    2948                                        &key
    2949                                        (element-type *default-stream-element-type*)
    2950                                        (external-format :default)
    2951                                        (if-does-not-exist :error))
    2952   "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     3036    `(call-with-input ,value #'(lambda (,input-var) ,@body)))
     3037
     3038  (defun call-with-input-file (pathname thunk
     3039                               &key
     3040                                 (element-type *default-stream-element-type*)
     3041                                 (external-format *utf-8-external-format*)
     3042                                 (if-does-not-exist :error))
     3043    "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
    29533044Other keys are accepted but discarded."
    2954   #+gcl2.6 (declare (ignore external-format))
    2955   (with-open-file (s pathname :direction :input
    2956                      :element-type element-type
    2957                      #-gcl2.6 :external-format #-gcl2.6 external-format
    2958                      :if-does-not-exist if-does-not-exist)
    2959     (funcall thunk s)))
    2960 
    2961 (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
    2962   (declare (ignore element-type external-format))
    2963   `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     3045    #+gcl2.6 (declare (ignore external-format))
     3046    (with-open-file (s pathname :direction :input
     3047                                :element-type element-type
     3048                                #-gcl2.6 :external-format #-gcl2.6 external-format
     3049                                :if-does-not-exist if-does-not-exist)
     3050      (funcall thunk s)))
     3051
     3052  (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
     3053    (declare (ignore element-type external-format))
     3054    `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
    29643055
    29653056
    29663057;;; Ensure output buffers are flushed
    2967 
    2968 (defun* finish-outputs (&rest streams)
    2969   "Finish output on the main output streams as well as any specified one.
     3058(with-upgradability ()
     3059  (defun finish-outputs (&rest streams)
     3060    "Finish output on the main output streams as well as any specified one.
    29703061Useful for portably flushing I/O before user input or program exit."
    2971   ;; CCL notably buffers its stream output by default.
    2972   (dolist (s (append streams
    2973                      (list *stderr* *error-output* *standard-output* *trace-output*
    2974                            *debug-io* *terminal-io* *debug-io* *query-io*)))
    2975     (ignore-errors (finish-output s)))
    2976   (values))
    2977 
    2978 (defun* format! (stream format &rest args)
    2979   "Just like format, but call finish-outputs before and after the output."
    2980   (finish-outputs stream)
    2981   (apply 'format stream format args)
    2982   (finish-output stream))
    2983 
    2984 (defun* safe-format! (stream format &rest args)
    2985   (with-safe-io-syntax ()
    2986     (ignore-errors (apply 'format! stream format args))
    2987     (finish-outputs stream))) ; just in case format failed
     3062    ;; CCL notably buffers its stream output by default.
     3063    (dolist (s (append streams
     3064                       (list *stderr* *error-output* *standard-output* *trace-output*
     3065                             *debug-io* *terminal-io* *debug-io* *query-io*)))
     3066      (ignore-errors (finish-output s)))
     3067    (values))
     3068
     3069  (defun format! (stream format &rest args)
     3070    "Just like format, but call finish-outputs before and after the output."
     3071    (finish-outputs stream)
     3072    (apply 'format stream format args)
     3073    (finish-output stream))
     3074
     3075  (defun safe-format! (stream format &rest args)
     3076    (with-safe-io-syntax ()
     3077      (ignore-errors (apply 'format! stream format args))
     3078      (finish-outputs stream)))) ; just in case format failed
    29883079
    29893080
    29903081;;; Simple Whole-Stream processing
    2991 
    2992 
    2993 (defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
    2994   "Copy the contents of the INPUT stream into the OUTPUT stream.
     3082(with-upgradability ()
     3083  (defun copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
     3084    "Copy the contents of the INPUT stream into the OUTPUT stream.
    29953085If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
    29963086Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
    2997   (with-open-stream (input input)
    2998     (if linewise
    2999         (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
    3000                :while line :do
    3001                (when prefix (princ prefix output))
    3002                (princ line output)
    3003                (unless eof (terpri output))
    3004                (finish-output output)
    3005                (when eof (return)))
    3006         (loop
    3007           :with buffer-size = (or buffer-size 8192)
    3008           :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
    3009           :for end = (read-sequence buffer input)
    3010           :until (zerop end)
    3011           :do (write-sequence buffer output :end end)
    3012               (when (< end buffer-size) (return))))))
    3013 
    3014 (defun* concatenate-files (inputs output)
    3015   (with-open-file (o output :element-type '(unsigned-byte 8)
    3016                             :direction :output :if-exists :rename-and-delete)
    3017     (dolist (input inputs)
    3018       (with-open-file (i input :element-type '(unsigned-byte 8)
    3019                                :direction :input :if-does-not-exist :error)
    3020         (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
    3021 
    3022 (defun* slurp-stream-string (input &key (element-type 'character))
    3023   "Read the contents of the INPUT stream as a string"
    3024   (with-open-stream (input input)
    3025     (with-output-to-string (output)
    3026       (copy-stream-to-stream input output :element-type element-type))))
    3027 
    3028 (defun* slurp-stream-lines (input &key count)
    3029   "Read the contents of the INPUT stream as a list of lines, return those lines.
     3087    (with-open-stream (input input)
     3088      (if linewise
     3089          (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
     3090                 :while line :do
     3091                 (when prefix (princ prefix output))
     3092                 (princ line output)
     3093                 (unless eof (terpri output))
     3094                 (finish-output output)
     3095                 (when eof (return)))
     3096          (loop
     3097            :with buffer-size = (or buffer-size 8192)
     3098            :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
     3099            :for end = (read-sequence buffer input)
     3100            :until (zerop end)
     3101            :do (write-sequence buffer output :end end)
     3102                (when (< end buffer-size) (return))))))
     3103
     3104  (defun concatenate-files (inputs output)
     3105    (with-open-file (o output :element-type '(unsigned-byte 8)
     3106                              :direction :output :if-exists :rename-and-delete)
     3107      (dolist (input inputs)
     3108        (with-open-file (i input :element-type '(unsigned-byte 8)
     3109                                 :direction :input :if-does-not-exist :error)
     3110          (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
     3111
     3112  (defun slurp-stream-string (input &key (element-type 'character))
     3113    "Read the contents of the INPUT stream as a string"
     3114    (with-open-stream (input input)
     3115      (with-output-to-string (output)
     3116        (copy-stream-to-stream input output :element-type element-type))))
     3117
     3118  (defun slurp-stream-lines (input &key count)
     3119    "Read the contents of the INPUT stream as a list of lines, return those lines.
    30303120
    30313121Read no more than COUNT lines."
    3032   (check-type count (or null integer))
    3033   (with-open-stream (input input)
    3034     (loop :for n :from 0
    3035           :for l = (and (or (not count) (< n count))
    3036                         (read-line input nil nil))
    3037           :while l :collect l)))
    3038 
    3039 (defun* slurp-stream-line (input &key (at 0))
    3040   "Read the contents of the INPUT stream as a list of lines,
     3122    (check-type count (or null integer))
     3123    (with-open-stream (input input)
     3124      (loop :for n :from 0
     3125            :for l = (and (or (not count) (< n count))
     3126                          (read-line input nil nil))
     3127            :while l :collect l)))
     3128
     3129  (defun slurp-stream-line (input &key (at 0))
     3130    "Read the contents of the INPUT stream as a list of lines,
    30413131then return the ACCESS-AT of that list of lines using the AT specifier.
    30423132PATH defaults to 0, i.e. return the first line.
     
    30473137where N is the index specified by path
    30483138if path is either an integer or a list that starts with an integer."
    3049   (access-at (slurp-stream-lines input :count (access-at-count at)) at))
    3050 
    3051 (defun* slurp-stream-forms (input &key count)
    3052 "Read the contents of the INPUT stream as a list of forms,
     3139    (access-at (slurp-stream-lines input :count (access-at-count at)) at))
     3140
     3141  (defun slurp-stream-forms (input &key count)
     3142    "Read the contents of the INPUT stream as a list of forms,
    30533143and return those forms.
    30543144
     
    30573147
    30583148BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    3059   (check-type count (or null integer))
    3060   (loop :with eof = '#:eof
    3061         :for n :from 0
    3062         :for form = (if (and count (>= n count))
    3063                         eof
    3064                         (read-preserving-whitespace input nil eof))
    3065         :until (eq form eof) :collect form))
    3066 
    3067 (defun* slurp-stream-form (input &key (at 0))
    3068 "Read the contents of the INPUT stream as a list of forms,
     3149    (check-type count (or null integer))
     3150    (loop :with eof = '#:eof
     3151          :for n :from 0
     3152          :for form = (if (and count (>= n count))
     3153                          eof
     3154                          (read-preserving-whitespace input nil eof))
     3155          :until (eq form eof) :collect form))
     3156
     3157  (defun slurp-stream-form (input &key (at 0))
     3158    "Read the contents of the INPUT stream as a list of forms,
    30693159then return the ACCESS-AT of these forms following the AT.
    30703160AT defaults to 0, i.e. return the first form.
     
    30773167
    30783168BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    3079   (access-at (slurp-stream-forms input :count (access-at-count at)) at))
    3080 
    3081 (defun* read-file-string (file &rest keys)
    3082   "Open FILE with option KEYS, read its contents as a string"
    3083   (apply 'call-with-input-file file 'slurp-stream-string keys))
    3084 
    3085 (defun* read-file-lines (file &rest keys)
    3086   "Open FILE with option KEYS, read its contents as a list of lines
     3169    (access-at (slurp-stream-forms input :count (access-at-count at)) at))
     3170
     3171  (defun read-file-string (file &rest keys)
     3172    "Open FILE with option KEYS, read its contents as a string"
     3173    (apply 'call-with-input-file file 'slurp-stream-string keys))
     3174
     3175  (defun read-file-lines (file &rest keys)
     3176    "Open FILE with option KEYS, read its contents as a list of lines
    30873177BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    3088   (apply 'call-with-input-file file 'slurp-stream-lines keys))
    3089 
    3090 (defun* read-file-forms (file &rest keys &key count &allow-other-keys)
    3091   "Open input FILE with option KEYS (except COUNT),
     3178    (apply 'call-with-input-file file 'slurp-stream-lines keys))
     3179
     3180  (defun read-file-forms (file &rest keys &key count &allow-other-keys)
     3181    "Open input FILE with option KEYS (except COUNT),
    30923182and read its contents as per SLURP-STREAM-FORMS with given COUNT.
    30933183BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    3094   (apply 'call-with-input-file file
    3095          #'(lambda (input) (slurp-stream-forms input :count count))
    3096          (remove-plist-key :count keys)))
    3097 
    3098 (defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
    3099   "Open input FILE with option KEYS (except AT),
     3184    (apply 'call-with-input-file file
     3185           #'(lambda (input) (slurp-stream-forms input :count count))
     3186           (remove-plist-key :count keys)))
     3187
     3188  (defun read-file-form (file &rest keys &key (at 0) &allow-other-keys)
     3189    "Open input FILE with option KEYS (except AT),
    31003190and read its contents as per SLURP-STREAM-FORM with given AT specifier.
    31013191BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
    3102   (apply 'call-with-input-file file
    3103          #'(lambda (input) (slurp-stream-form input :at at))
    3104          (remove-plist-key :at keys)))
    3105 
    3106 (defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
    3107   "Reads the specified form from the top of a file using a safe standardized syntax.
     3192    (apply 'call-with-input-file file
     3193           #'(lambda (input) (slurp-stream-form input :at at))
     3194           (remove-plist-key :at keys)))
     3195
     3196  (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
     3197    "Reads the specified form from the top of a file using a safe standardized syntax.
    31083198Extracts the form using READ-FILE-FORM,
    31093199within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
    3110   (with-safe-io-syntax (:package package)
    3111     (apply 'read-file-form pathname (remove-plist-key :package keys))))
    3112 
    3113 (defun* eval-input (input)
    3114   "Portably read and evaluate forms from INPUT, return the last values."
    3115   (with-input (input)
    3116     (loop :with results :with eof ='#:eof
    3117           :for form = (read input nil eof)
    3118           :until (eq form eof)
    3119           :do (setf results (multiple-value-list (eval form)))
    3120           :finally (return (apply 'values results)))))
    3121 
    3122 (defun* eval-thunk (thunk)
    3123   "Evaluate a THUNK of code:
     3200    (with-safe-io-syntax (:package package)
     3201      (apply 'read-file-form pathname (remove-plist-key :package keys))))
     3202
     3203  (defun eval-input (input)
     3204    "Portably read and evaluate forms from INPUT, return the last values."
     3205    (with-input (input)
     3206      (loop :with results :with eof ='#:eof
     3207            :for form = (read input nil eof)
     3208            :until (eq form eof)
     3209            :do (setf results (multiple-value-list (eval form)))
     3210            :finally (return (apply 'values results)))))
     3211
     3212  (defun eval-thunk (thunk)
     3213    "Evaluate a THUNK of code:
    31243214If a function, FUNCALL it without arguments.
    31253215If a constant literal and not a sequence, return it.
    31263216If a cons or a symbol, EVAL it.
    31273217If a string, repeatedly read and evaluate from it, returning the last values."
    3128   (etypecase thunk
    3129     ((or boolean keyword number character pathname) thunk)
    3130     ((or cons symbol) (eval thunk))
    3131     (function (funcall thunk))
    3132     (string (eval-input thunk))))
    3133 
    3134 (defun* standard-eval-thunk (thunk &key (package :cl))
    3135   "Like EVAL-THUNK, but in a more standardized evaluation context."
    3136   ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
    3137   (when thunk
    3138     (with-safe-io-syntax (:package package)
    3139       (let ((*read-eval* t))
    3140         (eval-thunk thunk)))))
    3141 
    3142 
    3143 ;;; Encodings
    3144 
    3145 (defvar *default-encoding* :default
    3146   "Default encoding for source files.
    3147 The default value :default preserves the legacy behavior.
    3148 A future default might be :utf-8 or :autodetect
    3149 reading emacs-style -*- coding: utf-8 -*- specifications,
    3150 and falling back to utf-8 or latin1 if nothing is specified.")
    3151 
    3152 (defparameter *utf-8-external-format*
    3153   #+(and asdf-unicode (not clisp)) :utf-8
    3154   #+(and asdf-unicode clisp) charset:utf-8
    3155   #-asdf-unicode :default
    3156   "Default :external-format argument to pass to CL:OPEN and also
    3157 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
    3158 On modern implementations, this will decode UTF-8 code points as CL characters.
    3159 On legacy implementations, it may fall back on some 8-bit encoding,
    3160 with non-ASCII code points being read as several CL characters;
    3161 hopefully, if done consistently, that won't affect program behavior too much.")
    3162 
    3163 (defun* always-default-encoding (pathname)
    3164   (declare (ignore pathname))
    3165   *default-encoding*)
    3166 
    3167 (defvar *encoding-detection-hook* #'always-default-encoding
    3168   "Hook for an extension to define a function to automatically detect a file's encoding")
    3169 
    3170 (defun* detect-encoding (pathname)
    3171   (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
    3172       (funcall *encoding-detection-hook* pathname)
    3173       *default-encoding*))
    3174 
    3175 (defun* default-encoding-external-format (encoding)
    3176   (case encoding
    3177     (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
    3178     (:utf-8 *utf-8-external-format*)
    3179     (otherwise
    3180      (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
    3181      :default)))
    3182 
    3183 (defvar *encoding-external-format-hook*
    3184   #'default-encoding-external-format
    3185   "Hook for an extension to define a mapping between non-default encodings
    3186 and implementation-defined external-format's")
    3187 
    3188 (defun* encoding-external-format (encoding)
    3189   (funcall *encoding-external-format-hook* encoding))
     3218    (etypecase thunk
     3219      ((or boolean keyword number character pathname) thunk)
     3220      ((or cons symbol) (eval thunk))
     3221      (function (funcall thunk))
     3222      (string (eval-input thunk))))
     3223
     3224  (defun standard-eval-thunk (thunk &key (package :cl))
     3225    "Like EVAL-THUNK, but in a more standardized evaluation context."
     3226    ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
     3227    (when thunk
     3228      (with-safe-io-syntax (:package package)
     3229        (let ((*read-eval* t))
     3230          (eval-thunk thunk))))))
    31903231
    31913232
    31923233;;; Using temporary files
    3193 (defun* default-temporary-directory ()
    3194   (or
    3195    (when (os-unix-p)
    3196      (or (getenv-pathname "TMPDIR" :ensure-directory t)
    3197          (parse-native-namestring "/tmp/")))
    3198    (when (os-windows-p)
    3199      (getenv-pathname "TEMP" :ensure-directory t))
    3200    (subpathname (user-homedir-pathname) "tmp/")))
    3201 
    3202 (defvar *temporary-directory* nil)
    3203 
    3204 (defun* temporary-directory ()
    3205   (or *temporary-directory* (default-temporary-directory)))
    3206 
    3207 (defun setup-temporary-directory ()
    3208   (setf *temporary-directory* (default-temporary-directory))
    3209   ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
    3210   #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
    3211 
    3212 (defun* call-with-temporary-file
    3213     (thunk &key
    3214      prefix keep (direction :io)
    3215      (element-type *default-stream-element-type*)
    3216      (external-format :default))
    3217   #+gcl2.6 (declare (ignorable external-format))
    3218   (check-type direction (member :output :io))
    3219   (loop
    3220     :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
    3221     :for counter :from (random (ash 1 32))
    3222     :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
    3223      ;; TODO: on Unix, do something about umask
    3224      ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
    3225      ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
    3226     (with-open-file (stream pathname
    3227                             :direction direction
    3228                             :element-type element-type
    3229                             #-gcl2.6 :external-format #-gcl2.6 external-format
    3230                             :if-exists nil :if-does-not-exist :create)
    3231       (when stream
    3232         (return
    3233           (if keep
    3234               (funcall thunk stream pathname)
    3235               (unwind-protect
    3236                    (funcall thunk stream pathname)
    3237                 (ignore-errors (delete-file pathname)))))))))
    3238 
    3239 (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
    3240                                 (pathname (gensym "PATHNAME") pathnamep)
    3241                                 prefix keep direction element-type external-format)
    3242                                &body body)
    3243   "Evaluate BODY where the symbols specified by keyword arguments
     3234(with-upgradability ()
     3235  (defun default-temporary-directory ()
     3236    (or
     3237     (when (os-unix-p)
     3238       (or (getenv-pathname "TMPDIR" :ensure-directory t)
     3239           (parse-native-namestring "/tmp/")))
     3240     (when (os-windows-p)
     3241       (getenv-pathname "TEMP" :ensure-directory t))
     3242     (subpathname (user-homedir-pathname) "tmp/")))
     3243
     3244  (defvar *temporary-directory* nil)
     3245
     3246  (defun temporary-directory ()
     3247    (or *temporary-directory* (default-temporary-directory)))
     3248
     3249  (defun setup-temporary-directory ()
     3250    (setf *temporary-directory* (default-temporary-directory))
     3251    ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
     3252    #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
     3253
     3254  (defun call-with-temporary-file
     3255      (thunk &key
     3256               prefix keep (direction :io)
     3257               (element-type *default-stream-element-type*)
     3258               (external-format :default))
     3259    #+gcl2.6 (declare (ignorable external-format))
     3260    (check-type direction (member :output :io))
     3261    (loop
     3262      :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
     3263      :for counter :from (random (ash 1 32))
     3264      :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
     3265        ;; TODO: on Unix, do something about umask
     3266        ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
     3267        ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
     3268        (with-open-file (stream pathname
     3269                                :direction direction
     3270                                :element-type element-type
     3271                                #-gcl2.6 :external-format #-gcl2.6 external-format
     3272                                :if-exists nil :if-does-not-exist :create)
     3273          (when stream
     3274            (return
     3275              (if keep
     3276                  (funcall thunk stream pathname)
     3277                  (unwind-protect
     3278                       (funcall thunk stream pathname)
     3279                    (ignore-errors (delete-file pathname)))))))))
     3280
     3281  (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
     3282                                    (pathname (gensym "PATHNAME") pathnamep)
     3283                                    prefix keep direction element-type external-format)
     3284                                 &body body)
     3285    "Evaluate BODY where the symbols specified by keyword arguments
    32443286STREAM and PATHNAME are bound corresponding to a newly created temporary file
    32453287ready for I/O. Unless KEEP is specified, delete the file afterwards."
    3246   (check-type stream symbol)
    3247   (check-type pathname symbol)
    3248   `(flet ((think (,stream ,pathname)
    3249             ,@(unless pathnamep `((declare (ignore ,pathname))))
    3250             ,@(unless streamp `((when ,stream (close ,stream))))
    3251             ,@body))
    3252      #-gcl (declare (dynamic-extent #'think))
    3253      (call-with-temporary-file
    3254       #'think
    3255       ,@(when direction `(:direction ,direction))
    3256       ,@(when prefix `(:prefix ,prefix))
    3257       ,@(when keep `(:keep ,keep))
    3258       ,@(when element-type `(:element-type ,element-type))
    3259       ,@(when external-format `(:external-format external-format)))))
    3260 
    3261 ;;; Temporary pathnames
    3262 (defun* add-pathname-suffix (pathname suffix)
    3263   (make-pathname :name (strcat (pathname-name pathname) suffix)
    3264                  :defaults pathname))
    3265 
    3266 (defun* tmpize-pathname (x)
    3267   (add-pathname-suffix x "-ASDF-TMP"))
    3268 
    3269 (defun* call-with-staging-pathname (pathname fun)
    3270   "Calls fun with a staging pathname, and atomically
     3288    (check-type stream symbol)
     3289    (check-type pathname symbol)
     3290    `(flet ((think (,stream ,pathname)
     3291              ,@(unless pathnamep `((declare (ignore ,pathname))))
     3292              ,@(unless streamp `((when ,stream (close ,stream))))
     3293              ,@body))
     3294       #-gcl (declare (dynamic-extent #'think))
     3295       (call-with-temporary-file
     3296        #'think
     3297        ,@(when direction `(:direction ,direction))
     3298        ,@(when prefix `(:prefix ,prefix))
     3299        ,@(when keep `(:keep ,keep))
     3300        ,@(when element-type `(:element-type ,element-type))
     3301        ,@(when external-format `(:external-format external-format)))))
     3302
     3303  ;; Temporary pathnames in simple cases where no contention is assumed
     3304  (defun add-pathname-suffix (pathname suffix)
     3305    (make-pathname :name (strcat (pathname-name pathname) suffix)
     3306                   :defaults pathname))
     3307
     3308  (defun tmpize-pathname (x)
     3309    (add-pathname-suffix x "-ASDF-TMP"))
     3310
     3311  (defun call-with-staging-pathname (pathname fun)
     3312    "Calls fun with a staging pathname, and atomically
    32713313renames the staging pathname to the pathname in the end.
    32723314Note: this protects only against failure of the program,
    32733315not against concurrent attempts.
    32743316For the latter case, we ought pick random suffix and atomically open it."
    3275   (let* ((pathname (pathname pathname))
    3276          (staging (tmpize-pathname pathname)))
    3277     (unwind-protect
    3278          (multiple-value-prog1
    3279              (funcall fun staging)
    3280            (rename-file-overwriting-target staging pathname))
    3281       (delete-file-if-exists staging))))
    3282 
    3283 (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
    3284   `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
    3285 
     3317    (let* ((pathname (pathname pathname))
     3318           (staging (tmpize-pathname pathname)))
     3319      (unwind-protect
     3320           (multiple-value-prog1
     3321               (funcall fun staging)
     3322             (rename-file-overwriting-target staging pathname))
     3323        (delete-file-if-exists staging))))
     3324
     3325  (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     3326    `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body))))
    32863327
    32873328;;;; -------------------------------------------------------------------------
     
    33073348(in-package :asdf/image)
    33083349
    3309 (defvar *lisp-interaction* t
    3310   "Is this an interactive Lisp environment, or is it batch processing?")
    3311 
    3312 (defvar *command-line-arguments* nil
    3313   "Command-line arguments")
    3314 
    3315 (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
    3316   "Is this a dumped image? As a standalone executable?")
    3317 
    3318 (defvar *image-restore-hook* nil
    3319   "Functions to call (in reverse order) when the image is restored")
    3320 
    3321 (defvar *image-prelude* nil
    3322   "a form to evaluate, or string containing forms to read and evaluate
     3350(with-upgradability ()
     3351  (defvar *lisp-interaction* t
     3352    "Is this an interactive Lisp environment, or is it batch processing?")
     3353
     3354  (defvar *command-line-arguments* nil
     3355    "Command-line arguments")
     3356
     3357  (defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
     3358    "Is this a dumped image? As a standalone executable?")
     3359
     3360  (defvar *image-restore-hook* nil
     3361    "Functions to call (in reverse order) when the image is restored")
     3362
     3363  (defvar *image-prelude* nil
     3364    "a form to evaluate, or string containing forms to read and evaluate
    33233365when the image is restarted, but before the entry point is called.")
    33243366
    3325 (defvar *image-entry-point* nil
    3326   "a function with which to restart the dumped image when execution is restored from it.")
    3327 
    3328 (defvar *image-postlude* nil
    3329   "a form to evaluate, or string containing forms to read and evaluate
     3367  (defvar *image-entry-point* nil
     3368    "a function with which to restart the dumped image when execution is restored from it.")
     3369
     3370  (defvar *image-postlude* nil
     3371    "a form to evaluate, or string containing forms to read and evaluate
    33303372before the image dump hooks are called and before the image is dumped.")
    33313373
    3332 (defvar *image-dump-hook* nil
    3333   "Functions to call (in order) when before an image is dumped")
    3334 
    3335 (defvar *fatal-conditions* '(error)
    3336   "conditions that cause the Lisp image to enter the debugger if interactive,
    3337 or to die if not interactive")
     3374  (defvar *image-dump-hook* nil
     3375    "Functions to call (in order) when before an image is dumped")
     3376
     3377  (defvar *fatal-conditions* '(error)
     3378    "conditions that cause the Lisp image to enter the debugger if interactive,
     3379or to die if not interactive"))
    33383380
    33393381
    33403382;;; Exiting properly or im-
    3341 (defun* quit (&optional (code 0) (finish-output t))
    3342   "Quits from the Lisp world, with the given exit status if provided.
     3383(with-upgradability ()
     3384  (defun quit (&optional (code 0) (finish-output t))
     3385    "Quits from the Lisp world, with the given exit status if provided.
    33433386This is designed to abstract away the implementation specific quit forms."
    3344   (when finish-output ;; essential, for ClozureCL, and for standard compliance.
    3345     (finish-outputs))
    3346   #+(or abcl xcl) (ext:quit :status code)
    3347   #+allegro (excl:exit code :quiet t)
    3348   #+clisp (ext:quit code)
    3349   #+clozure (ccl:quit code)
    3350   #+cormanlisp (win32:exitprocess code)
    3351   #+(or cmu scl) (unix:unix-exit code)
    3352   #+ecl (si:quit code)
    3353   #+gcl (lisp:quit code)
    3354   #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
    3355   #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
    3356   #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
    3357   #+mkcl (mk-ext:quit :exit-code code)
    3358   #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
    3359                 (quit (find-symbol* :quit :sb-ext nil)))
    3360              (cond
    3361                (exit `(,exit :code code :abort (not finish-output)))
    3362                (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
    3363   #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    3364   (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
    3365 
    3366 (defun* die (code format &rest arguments)
    3367   "Die in error with some error message"
    3368   (with-safe-io-syntax ()
    3369     (ignore-errors
    3370      (fresh-line *stderr*)
    3371      (apply #'format *stderr* format arguments)
    3372      (format! *stderr* "~&")))
    3373   (quit code))
    3374 
    3375 (defun* raw-print-backtrace (&key (stream *debug-io*) count)
    3376   "Print a backtrace, directly accessing the implementation"
    3377   (declare (ignorable stream count))
    3378   #+abcl
    3379   (let ((*debug-io* stream)) (top-level::backtrace-command count))
    3380   #+allegro
    3381   (let ((*terminal-io* stream)
    3382         (*standard-output* stream)
    3383         (tpl:*zoom-print-circle* *print-circle*)
    3384         (tpl:*zoom-print-level* *print-level*)
    3385         (tpl:*zoom-print-length* *print-length*))
    3386     (tpl:do-command "zoom"
    3387       :from-read-eval-print-loop nil
    3388       :count t
    3389       :all t))
    3390   #+clisp
    3391   (system::print-backtrace :out stream :limit count)
    3392   #+(or clozure mcl)
    3393   (let ((*debug-io* stream))
    3394     (ccl:print-call-history :count count :start-frame-number 1)
    3395     (finish-output stream))
    3396   #+(or cmucl scl)
    3397   (let ((debug:*debug-print-level* *print-level*)
    3398         (debug:*debug-print-length* *print-length*))
    3399     (debug:backtrace most-positive-fixnum stream))
    3400   #+ecl
    3401   (si::tpl-backtrace)
    3402   #+lispworks
    3403   (let ((dbg::*debugger-stack*
    3404           (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
    3405         (*debug-io* stream)
    3406         (dbg:*debug-print-level* *print-level*)
    3407         (dbg:*debug-print-length* *print-length*))
    3408     (dbg:bug-backtrace nil))
    3409   #+sbcl
    3410   (sb-debug:backtrace
    3411    #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
    3412    stream))
    3413 
    3414 (defun* print-backtrace (&rest keys &key stream count)
    3415   (declare (ignore stream count))
    3416   (with-safe-io-syntax (:package :cl)
    3417     (let ((*print-readably* nil)
    3418           (*print-circle* t)
    3419           (*print-miser-width* 75)
    3420           (*print-length* nil)
    3421           (*print-level* nil)
    3422           (*print-pretty* t))
    3423       (ignore-errors (apply 'raw-print-backtrace keys)))))
    3424 
    3425 (defun* print-condition-backtrace (condition &key (stream *stderr*) count)
    3426   ;; We print the condition *after* the backtrace,
    3427   ;; for the sake of who sees the backtrace at a terminal.
    3428   ;; It is up to the caller to print the condition *before*, with some context.
    3429   (print-backtrace :stream stream :count count)
    3430   (when condition
    3431     (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
    3432                   condition)))
    3433 
    3434 (defun fatal-condition-p (condition)
    3435   (match-any-condition-p condition *fatal-conditions*))
    3436 
    3437 (defun* handle-fatal-condition (condition)
    3438   "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
    3439   (cond
    3440     (*lisp-interaction*
    3441      (invoke-debugger condition))
    3442     (t
    3443      (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
    3444      (print-condition-backtrace condition :stream *stderr*)
    3445      (die 99 "~A" condition))))
    3446 
    3447 (defun* call-with-fatal-condition-handler (thunk)
    3448   (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
    3449     (funcall thunk)))
    3450 
    3451 (defmacro with-fatal-condition-handler ((&optional) &body body)
    3452   `(call-with-fatal-condition-handler #'(lambda () ,@body)))
    3453 
    3454 (defun* shell-boolean-exit (x)
    3455   "Quit with a return code that is 0 iff argument X is true"
    3456   (quit (if x 0 1)))
     3387    (when finish-output ;; essential, for ClozureCL, and for standard compliance.
     3388      (finish-outputs))
     3389    #+(or abcl xcl) (ext:quit :status code)
     3390    #+allegro (excl:exit code :quiet t)
     3391    #+clisp (ext:quit code)
     3392    #+clozure (ccl:quit code)
     3393    #+cormanlisp (win32:exitprocess code)
     3394    #+(or cmu scl) (unix:unix-exit code)
     3395    #+ecl (si:quit code)
     3396    #+gcl (lisp:quit code)
     3397    #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
     3398    #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
     3399    #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
     3400    #+mkcl (mk-ext:quit :exit-code code)
     3401    #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
     3402                  (quit (find-symbol* :quit :sb-ext nil)))
     3403               (cond
     3404                 (exit `(,exit :code code :abort (not finish-output)))
     3405                 (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
     3406    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     3407    (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
     3408
     3409  (defun die (code format &rest arguments)
     3410    "Die in error with some error message"
     3411    (with-safe-io-syntax ()
     3412      (ignore-errors
     3413       (fresh-line *stderr*)
     3414       (apply #'format *stderr* format arguments)
     3415       (format! *stderr* "~&")))
     3416    (quit code))
     3417
     3418  (defun raw-print-backtrace (&key (stream *debug-io*) count)
     3419    "Print a backtrace, directly accessing the implementation"
     3420    (declare (ignorable stream count))
     3421    #+abcl
     3422    (let ((*debug-io* stream)) (top-level::backtrace-command count))
     3423    #+allegro
     3424    (let ((*terminal-io* stream)
     3425          (*standard-output* stream)
     3426          (tpl:*zoom-print-circle* *print-circle*)
     3427          (tpl:*zoom-print-level* *print-level*)
     3428          (tpl:*zoom-print-length* *print-length*))
     3429      (tpl:do-command "zoom"
     3430        :from-read-eval-print-loop nil
     3431        :count t
     3432        :all t))
     3433    #+clisp
     3434    (system::print-backtrace :out stream :limit count)
     3435    #+(or clozure mcl)
     3436    (let ((*debug-io* stream))
     3437      (ccl:print-call-history :count count :start-frame-number 1)
     3438      (finish-output stream))
     3439    #+(or cmucl scl)
     3440    (let ((debug:*debug-print-level* *print-level*)
     3441          (debug:*debug-print-length* *print-length*))
     3442      (debug:backtrace most-positive-fixnum stream))
     3443    #+ecl
     3444    (si::tpl-backtrace)
     3445    #+lispworks
     3446    (let ((dbg::*debugger-stack*
     3447            (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
     3448          (*debug-io* stream)
     3449          (dbg:*debug-print-level* *print-level*)
     3450          (dbg:*debug-print-length* *print-length*))
     3451      (dbg:bug-backtrace nil))
     3452    #+sbcl
     3453    (sb-debug:backtrace
     3454     #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
     3455     stream))
     3456
     3457  (defun print-backtrace (&rest keys &key stream count)
     3458    (declare (ignore stream count))
     3459    (with-safe-io-syntax (:package :cl)
     3460      (let ((*print-readably* nil)
     3461            (*print-circle* t)
     3462            (*print-miser-width* 75)
     3463            (*print-length* nil)
     3464            (*print-level* nil)
     3465            (*print-pretty* t))
     3466        (ignore-errors (apply 'raw-print-backtrace keys)))))
     3467
     3468  (defun print-condition-backtrace (condition &key (stream *stderr*) count)
     3469    ;; We print the condition *after* the backtrace,
     3470    ;; for the sake of who sees the backtrace at a terminal.
     3471    ;; It is up to the caller to print the condition *before*, with some context.
     3472    (print-backtrace :stream stream :count count)
     3473    (when condition
     3474      (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
     3475                    condition)))
     3476
     3477  (defun fatal-condition-p (condition)
     3478    (match-any-condition-p condition *fatal-conditions*))
     3479
     3480  (defun handle-fatal-condition (condition)
     3481    "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
     3482    (cond
     3483      (*lisp-interaction*
     3484       (invoke-debugger condition))
     3485      (t
     3486       (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
     3487       (print-condition-backtrace condition :stream *stderr*)
     3488       (die 99 "~A" condition))))
     3489
     3490  (defun call-with-fatal-condition-handler (thunk)
     3491    (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
     3492      (funcall thunk)))
     3493
     3494  (defmacro with-fatal-condition-handler ((&optional) &body body)
     3495    `(call-with-fatal-condition-handler #'(lambda () ,@body)))
     3496
     3497  (defun shell-boolean-exit (x)
     3498    "Quit with a return code that is 0 iff argument X is true"
     3499    (quit (if x 0 1))))
    34573500
    34583501
    34593502;;; Using image hooks
    3460 
    3461 (defun* register-image-restore-hook (hook &optional (call-now-p t))
    3462   (register-hook-function '*image-restore-hook* hook call-now-p))
    3463 
    3464 (defun* register-image-dump-hook (hook &optional (call-now-p nil))
    3465   (register-hook-function '*image-dump-hook* hook call-now-p))
    3466 
    3467 (defun* call-image-restore-hook ()
    3468   (call-functions (reverse *image-restore-hook*)))
    3469 
    3470 (defun* call-image-dump-hook ()
    3471   (call-functions *image-dump-hook*))
     3503(with-upgradability ()
     3504  (defun register-image-restore-hook (hook &optional (call-now-p t))
     3505    (register-hook-function '*image-restore-hook* hook call-now-p))
     3506
     3507  (defun register-image-dump-hook (hook &optional (call-now-p nil))
     3508    (register-hook-function '*image-dump-hook* hook call-now-p))
     3509
     3510  (defun call-image-restore-hook ()
     3511    (call-functions (reverse *image-restore-hook*)))
     3512
     3513  (defun call-image-dump-hook ()
     3514    (call-functions *image-dump-hook*)))
    34723515
    34733516
    34743517;;; Proper command-line arguments
    3475 
    3476 (defun* raw-command-line-arguments ()
    3477   "Find what the actual command line for this process was."
    3478   #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
    3479   #+allegro (sys:command-line-arguments) ; default: :application t
    3480   #+clisp (coerce (ext:argv) 'list)
    3481   #+clozure (ccl::command-line-arguments)
    3482   #+(or cmu scl) extensions:*command-line-strings*
    3483   #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
    3484   #+gcl si:*command-args*
    3485   #+genera nil
    3486   #+lispworks sys:*line-arguments-list*
    3487   #+sbcl sb-ext:*posix-argv*
    3488   #+xcl system:*argv*
    3489   #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
    3490   (error "raw-command-line-arguments not implemented yet"))
    3491 
    3492 (defun* command-line-arguments (&optional (arguments (raw-command-line-arguments)))
    3493   "Extract user arguments from command-line invocation of current process.
     3518(with-upgradability ()
     3519  (defun raw-command-line-arguments ()
     3520    "Find what the actual command line for this process was."
     3521    #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
     3522    #+allegro (sys:command-line-arguments) ; default: :application t
     3523    #+clisp (coerce (ext:argv) 'list)
     3524    #+clozure (ccl::command-line-arguments)
     3525    #+(or cmu scl) extensions:*command-line-strings*
     3526    #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
     3527    #+gcl si:*command-args*
     3528    #+genera nil
     3529    #+lispworks sys:*line-arguments-list*
     3530    #+sbcl sb-ext:*posix-argv*
     3531    #+xcl system:*argv*
     3532    #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
     3533    (error "raw-command-line-arguments not implemented yet"))
     3534
     3535  (defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
     3536    "Extract user arguments from command-line invocation of current process.
    34943537Assume the calling conventions of a generated script that uses --
    34953538if we are not called from a directly executable image."
    3496   #+abcl arguments
    3497   #-abcl
    3498   (let* (#-(or sbcl allegro)
    3499         (arguments
    3500           (if (eq *image-dumped-p* :executable)
    3501               arguments
    3502               (member "--" arguments :test 'string-equal))))
    3503     (rest arguments)))
    3504 
    3505 (defun setup-command-line-arguments ()
    3506   (setf *command-line-arguments* (command-line-arguments)))
    3507 
    3508 (defun* restore-image (&key
    3509                        ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
    3510                        ((:restore-hook *image-restore-hook*) *image-restore-hook*)
    3511                        ((:prelude *image-prelude*) *image-prelude*)
    3512                        ((:entry-point *image-entry-point*) *image-entry-point*))
    3513   (with-fatal-condition-handler ()
    3514     (call-image-restore-hook)
    3515     (standard-eval-thunk *image-prelude*)
    3516     (let ((results (multiple-value-list
    3517                     (if *image-entry-point*
    3518                         (call-function *image-entry-point*)
    3519                         t))))
    3520       (if *lisp-interaction*
    3521           (apply 'values results)
    3522           (shell-boolean-exit (first results))))))
     3539    #+abcl arguments
     3540    #-abcl
     3541    (let* (#-(or sbcl allegro)
     3542          (arguments
     3543             (if (eq *image-dumped-p* :executable)
     3544                 arguments
     3545                 (member "--" arguments :test 'string-equal))))
     3546      (rest arguments)))
     3547
     3548  (defun setup-command-line-arguments ()
     3549    (setf *command-line-arguments* (command-line-arguments)))
     3550
     3551  (defun restore-image (&key
     3552                          ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
     3553                          ((:restore-hook *image-restore-hook*) *image-restore-hook*)
     3554                          ((:prelude *image-prelude*) *image-prelude*)
     3555                          ((:entry-point *image-entry-point*) *image-entry-point*))
     3556    (with-fatal-condition-handler ()
     3557      (call-image-restore-hook)
     3558      (standard-eval-thunk *image-prelude*)
     3559      (let ((results (multiple-value-list
     3560                      (if *image-entry-point*
     3561                          (call-function *image-entry-point*)
     3562                          t))))
     3563        (if *lisp-interaction*
     3564            (apply 'values results)
     3565            (shell-boolean-exit (first results)))))))
    35233566
    35243567
    35253568;;; Dumping an image
    35263569
    3527 #-(or ecl mkcl)
    3528 (defun* dump-image (filename &key output-name executable
    3529                              ((:postlude *image-postlude*) *image-postlude*)
    3530                              ((:dump-hook *image-dump-hook*) *image-dump-hook*))
    3531   (declare (ignorable filename output-name executable))
    3532   (setf *image-dumped-p* (if executable :executable t))
    3533   (standard-eval-thunk *image-postlude*)
    3534   (call-image-dump-hook)
    3535   #-(or clisp clozure cmu lispworks sbcl scl)
    3536   (when executable
    3537     (error "Dumping an executable is not supported on this implementation! Aborting."))
    3538   #+allegro
    3539   (progn
    3540     (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
    3541     (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
    3542   #+clisp
    3543   (apply #'ext:saveinitmem filename
    3544    :quiet t
    3545    :start-package *package*
    3546    :keep-global-handlers nil
    3547    :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
    3548    (when executable
    3549      (list
    3550       ;; :parse-options nil ;--- requires a non-standard patch to clisp.
    3551       :norc t :script nil :init-function #'restore-image)))
    3552   #+clozure
    3553   (ccl:save-application filename :prepend-kernel t
    3554                         :toplevel-function (when executable #'restore-image))
    3555   #+(or cmu scl)
    3556   (progn
    3557    (ext:gc :full t)
    3558    (setf ext:*batch-mode* nil)
    3559    (setf ext::*gc-run-time* 0)
    3560    (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
    3561           (when executable '(:init-function restore-image :process-command-line nil))))
    3562   #+gcl
    3563   (progn
    3564    (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
    3565    (si::save-system filename))
    3566   #+lispworks
    3567   (if executable
    3568       (lispworks:deliver 'restore-image filename 0 :interface nil)
    3569       (hcl:save-image filename :environment nil))
    3570   #+sbcl
    3571   (progn
    3572     ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
    3573    (setf sb-ext::*gc-run-time* 0)
    3574    (apply 'sb-ext:save-lisp-and-die filename
    3575     :executable t ;--- always include the runtime that goes with the core
    3576     (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
    3577   #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
    3578   (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
    3579        filename (nth-value 1 (implementation-type))))
    3580 
    3581 
    3582 #+ecl
    3583 (defun create-image (destination object-files
    3584                      &key kind output-name prologue-code epilogue-code
    3585                        (prelude () preludep) (entry-point () entry-point-p) build-args)
    3586   ;; Is it meaningful to run these in the current environment?
    3587   ;; only if we also track the object files that constitute the "current" image,
    3588   ;; and otherwise simulate dump-image, including quitting at the end.
    3589   ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
    3590   (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
    3591   (apply 'c::builder
    3592          kind (pathname destination)
    3593          :lisp-files object-files
    3594          :init-name (c::compute-init-name (or output-name destination) :kind kind)
    3595          :prologue-code prologue-code
    3596          :epilogue-code
    3597          `(progn
    3598             ,epilogue-code
    3599             ,@(when (eq kind :program)
    3600                 `((setf *image-dumped-p* :executable)
    3601                   (restore-image ;; default behavior would be (si::top-level)
    3602                    ,@(when preludep `(:prelude ',prelude))
    3603                    ,@(when entry-point-p `(:entry-point ',entry-point))))))
    3604          build-args))
     3570(with-upgradability ()
     3571  #-(or ecl mkcl)
     3572  (defun dump-image (filename &key output-name executable
     3573                                ((:postlude *image-postlude*) *image-postlude*)
     3574                                ((:dump-hook *image-dump-hook*) *image-dump-hook*))
     3575    (declare (ignorable filename output-name executable))
     3576    (setf *image-dumped-p* (if executable :executable t))
     3577    (standard-eval-thunk *image-postlude*)
     3578    (call-image-dump-hook)
     3579    #-(or clisp clozure cmu lispworks sbcl scl)
     3580    (when executable
     3581      (error "Dumping an executable is not supported on this implementation! Aborting."))
     3582    #+allegro
     3583    (progn
     3584      (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
     3585      (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
     3586    #+clisp
     3587    (apply #'ext:saveinitmem filename
     3588           :quiet t
     3589           :start-package *package*
     3590           :keep-global-handlers nil
     3591           :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
     3592           (when executable
     3593             (list
     3594              ;; :parse-options nil ;--- requires a non-standard patch to clisp.
     3595              :norc t :script nil :init-function #'restore-image)))
     3596    #+clozure
     3597    (ccl:save-application filename :prepend-kernel t
     3598                                   :toplevel-function (when executable #'restore-image))
     3599    #+(or cmu scl)
     3600    (progn
     3601      (ext:gc :full t)
     3602      (setf ext:*batch-mode* nil)
     3603      (setf ext::*gc-run-time* 0)
     3604      (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
     3605                                     (when executable '(:init-function restore-image :process-command-line nil))))
     3606    #+gcl
     3607    (progn
     3608      (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
     3609      (si::save-system filename))
     3610    #+lispworks
     3611    (if executable
     3612        (lispworks:deliver 'restore-image filename 0 :interface nil)
     3613        (hcl:save-image filename :environment nil))
     3614    #+sbcl
     3615    (progn
     3616      ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
     3617      (setf sb-ext::*gc-run-time* 0)
     3618      (apply 'sb-ext:save-lisp-and-die filename
     3619             :executable t ;--- always include the runtime that goes with the core
     3620             (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
     3621    #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
     3622    (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
     3623         filename (nth-value 1 (implementation-type))))
     3624
     3625
     3626  #+ecl
     3627  (defun create-image (destination object-files
     3628                       &key kind output-name prologue-code epilogue-code
     3629                         (prelude () preludep) (entry-point () entry-point-p) build-args)
     3630    ;; Is it meaningful to run these in the current environment?
     3631    ;; only if we also track the object files that constitute the "current" image,
     3632    ;; and otherwise simulate dump-image, including quitting at the end.
     3633    ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
     3634    (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
     3635    (apply 'c::builder
     3636           kind (pathname destination)
     3637           :lisp-files object-files
     3638           :init-name (c::compute-init-name (or output-name destination) :kind kind)
     3639           :prologue-code prologue-code
     3640           :epilogue-code
     3641           `(progn
     3642              ,epilogue-code
     3643              ,@(when (eq kind :program)
     3644                  `((setf *image-dumped-p* :executable)
     3645                    (restore-image ;; default behavior would be (si::top-level)
     3646                     ,@(when preludep `(:prelude ',prelude))
     3647                     ,@(when entry-point-p `(:entry-point ',entry-point))))))
     3648           build-args)))
    36053649
    36063650
    36073651;;; Some universal image restore hooks
    3608 (map () 'register-image-restore-hook
    3609      '(setup-temporary-directory setup-stderr setup-command-line-arguments
    3610        #+abcl detect-os))
     3652(with-upgradability ()
     3653  (map () 'register-image-restore-hook
     3654       '(setup-temporary-directory setup-stderr setup-command-line-arguments
     3655         #+abcl detect-os)))
    36113656;;;; -------------------------------------------------------------------------
    36123657;;;; run-program initially from xcvb-driver.
     
    36313676;;;; ----- Escaping strings for the shell -----
    36323677
    3633 (defun* requires-escaping-p (token &key good-chars bad-chars)
    3634   "Does this token require escaping, given the specification of
     3678(with-upgradability ()
     3679  (defun requires-escaping-p (token &key good-chars bad-chars)
     3680    "Does this token require escaping, given the specification of
    36353681either good chars that don't need escaping or bad chars that do need escaping,
    36363682as either a recognizing function or a sequence of characters."
    3637   (some
    3638    (cond
    3639      ((and good-chars bad-chars)
    3640       (error "only one of good-chars and bad-chars can be provided"))
    3641      ((functionp good-chars)
    3642       (complement good-chars))
    3643      ((functionp bad-chars)
    3644       bad-chars)
    3645      ((and good-chars (typep good-chars 'sequence))
    3646       #'(lambda (c) (not (find c good-chars))))
    3647      ((and bad-chars (typep bad-chars 'sequence))
    3648       #'(lambda (c) (find c bad-chars)))
    3649      (t (error "requires-escaping-p: no good-char criterion")))
    3650    token))
    3651 
    3652 (defun* escape-token (token &key stream quote good-chars bad-chars escaper)
    3653   "Call the ESCAPER function on TOKEN string if it needs escaping as per
     3683    (some
     3684     (cond
     3685       ((and good-chars bad-chars)
     3686        (error "only one of good-chars and bad-chars can be provided"))
     3687       ((functionp good-chars)
     3688        (complement good-chars))
     3689       ((functionp bad-chars)
     3690        bad-chars)
     3691       ((and good-chars (typep good-chars 'sequence))
     3692        #'(lambda (c) (not (find c good-chars))))
     3693       ((and bad-chars (typep bad-chars 'sequence))
     3694        #'(lambda (c) (find c bad-chars)))
     3695       (t (error "requires-escaping-p: no good-char criterion")))
     3696     token))
     3697
     3698  (defun escape-token (token &key stream quote good-chars bad-chars escaper)
     3699    "Call the ESCAPER function on TOKEN string if it needs escaping as per
    36543700REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
    36553701using STREAM as output (or returning result as a string if NIL)"
    3656   (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
    3657       (with-output (stream)
    3658         (apply escaper token stream (when quote `(:quote ,quote))))
    3659       (output-string token stream)))
    3660 
    3661 (defun* escape-windows-token-within-double-quotes (x &optional s)
    3662   "Escape a string token X within double-quotes
     3702    (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
     3703        (with-output (stream)
     3704          (apply escaper token stream (when quote `(:quote ,quote))))
     3705        (output-string token stream)))
     3706
     3707  (defun escape-windows-token-within-double-quotes (x &optional s)
     3708    "Escape a string token X within double-quotes
    36633709for use within a MS Windows command-line, outputing to S."
    3664   (labels ((issue (c) (princ c s))
    3665            (issue-backslash (n) (loop :repeat n :do (issue #\\))))
    3666     (loop
    3667       :initially (issue #\") :finally (issue #\")
    3668       :with l = (length x) :with i = 0
    3669       :for i+1 = (1+ i) :while (< i l) :do
    3670       (case (char x i)
    3671         ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
    3672         ((#\\)
    3673          (let* ((j (and (< i+1 l) (position-if-not
    3674                                    #'(lambda (c) (eql c #\\)) x :start i+1)))
    3675                 (n (- (or j l) i)))
    3676            (cond
    3677              ((null j)
    3678               (issue-backslash (* 2 n)) (setf i l))
    3679              ((and (< j l) (eql (char x j) #\"))
    3680               (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
    3681              (t
    3682               (issue-backslash n) (setf i j)))))
    3683         (otherwise
    3684          (issue (char x i)) (setf i i+1))))))
    3685 
    3686 (defun* escape-windows-token (token &optional s)
    3687   "Escape a string TOKEN within double-quotes if needed
     3710    (labels ((issue (c) (princ c s))
     3711             (issue-backslash (n) (loop :repeat n :do (issue #\\))))
     3712      (loop
     3713        :initially (issue #\") :finally (issue #\")
     3714        :with l = (length x) :with i = 0
     3715        :for i+1 = (1+ i) :while (< i l) :do
     3716          (case (char x i)
     3717            ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
     3718            ((#\\)
     3719             (let* ((j (and (< i+1 l) (position-if-not
     3720                                       #'(lambda (c) (eql c #\\)) x :start i+1)))
     3721                    (n (- (or j l) i)))
     3722               (cond
     3723                 ((null j)
     3724                  (issue-backslash (* 2 n)) (setf i l))
     3725                 ((and (< j l) (eql (char x j) #\"))
     3726                  (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
     3727                 (t
     3728                  (issue-backslash n) (setf i j)))))
     3729            (otherwise
     3730             (issue (char x i)) (setf i i+1))))))
     3731
     3732  (defun escape-windows-token (token &optional s)
     3733    "Escape a string TOKEN within double-quotes if needed
    36883734for use within a MS Windows command-line, outputing to S."
    3689   (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
    3690                 :escaper 'escape-windows-token-within-double-quotes))
    3691 
    3692 (defun* escape-sh-token-within-double-quotes (x s &key (quote t))
    3693   "Escape a string TOKEN within double-quotes
     3735    (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
     3736                        :escaper 'escape-windows-token-within-double-quotes))
     3737
     3738  (defun escape-sh-token-within-double-quotes (x s &key (quote t))
     3739    "Escape a string TOKEN within double-quotes
    36943740for use within a POSIX Bourne shell, outputing to S;
    36953741omit the outer double-quotes if key argument :QUOTE is NIL"
    3696   (when quote (princ #\" s))
    3697   (loop :for c :across x :do
    3698     (when (find c "$`\\\"") (princ #\\ s))
    3699     (princ c s))
    3700   (when quote (princ #\" s)))
    3701 
    3702 (defun* easy-sh-character-p (x)
    3703   (or (alphanumericp x) (find x "+-_.,%@:/")))
    3704 
    3705 (defun* escape-sh-token (token &optional s)
    3706   "Escape a string TOKEN within double-quotes if needed
     3742    (when quote (princ #\" s))
     3743    (loop :for c :across x :do
     3744      (when (find c "$`\\\"") (princ #\\ s))
     3745      (princ c s))
     3746    (when quote (princ #\" s)))
     3747
     3748  (defun easy-sh-character-p (x)
     3749    (or (alphanumericp x) (find x "+-_.,%@:/")))
     3750
     3751  (defun escape-sh-token (token &optional s)
     3752    "Escape a string TOKEN within double-quotes if needed
    37073753for use within a POSIX Bourne shell, outputing to S."
    3708   (escape-token token :stream s :quote #\" :good-chars
    3709                 #'easy-sh-character-p
    3710                 :escaper 'escape-sh-token-within-double-quotes))
    3711 
    3712 (defun* escape-shell-token (token &optional s)
    3713   (cond
    3714     ((os-unix-p) (escape-sh-token token s))
    3715     ((os-windows-p) (escape-windows-token token s))))
    3716 
    3717 (defun* escape-command (command &optional s
    3718                        (escaper 'escape-shell-token))
    3719   "Given a COMMAND as a list of tokens, return a string of the
     3754    (escape-token token :stream s :quote #\" :good-chars
     3755                  #'easy-sh-character-p
     3756                        :escaper 'escape-sh-token-within-double-quotes))
     3757
     3758  (defun escape-shell-token (token &optional s)
     3759    (cond
     3760      ((os-unix-p) (escape-sh-token token s))
     3761      ((os-windows-p) (escape-windows-token token s))))
     3762
     3763  (defun escape-command (command &optional s
     3764                                  (escaper 'escape-shell-token))
     3765    "Given a COMMAND as a list of tokens, return a string of the
    37203766spaced, escaped tokens, using ESCAPER to escape."
    3721   (etypecase command
    3722     (string (output-string command s))
    3723     (list (with-output (s)
    3724             (loop :for first = t :then nil :for token :in command :do
    3725               (unless first (princ #\space s))
    3726               (funcall escaper token s))))))
    3727 
    3728 (defun* escape-windows-command (command &optional s)
    3729   "Escape a list of command-line arguments into a string suitable for parsing
     3767    (etypecase command
     3768      (string (output-string command s))
     3769      (list (with-output (s)
     3770              (loop :for first = t :then nil :for token :in command :do
     3771                (unless first (princ #\space s))
     3772                (funcall escaper token s))))))
     3773
     3774  (defun escape-windows-command (command &optional s)
     3775    "Escape a list of command-line arguments into a string suitable for parsing
    37303776by CommandLineToArgv in MS Windows"
    37313777    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
    37323778    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
    3733   (escape-command command s 'escape-windows-token))
    3734 
    3735 (defun* escape-sh-command (command &optional s)
    3736   "Escape a list of command-line arguments into a string suitable for parsing
     3779    (escape-command command s 'escape-windows-token))
     3780
     3781  (defun escape-sh-command (command &optional s)
     3782    "Escape a list of command-line arguments into a string suitable for parsing
    37373783by /bin/sh in POSIX"
    3738   (escape-command command s 'escape-sh-token))
    3739 
    3740 (defun* escape-shell-command (command &optional stream)
    3741   "Escape a command for the current operating system's shell"
    3742   (escape-command command stream 'escape-shell-token))
     3784    (escape-command command s 'escape-sh-token))
     3785
     3786  (defun escape-shell-command (command &optional stream)
     3787    "Escape a command for the current operating system's shell"
     3788    (escape-command command stream 'escape-shell-token)))
    37433789
    37443790
    37453791;;;; Slurping a stream, typically the output of another program
    3746 
    3747 (defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys))
    3748 
    3749 #-(or gcl2.6 genera)
    3750 (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
    3751   (funcall function input-stream))
    3752 
    3753 (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
    3754   (apply (first list) (cons input-stream (rest list))))
    3755 
    3756 #-(or gcl2.6 genera)
    3757 (defmethod slurp-input-stream ((output-stream stream) input-stream
    3758                                &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
    3759   (copy-stream-to-stream
    3760    input-stream output-stream
    3761    :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    3762 
    3763 (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
    3764   (declare (ignorable x))
    3765   (slurp-stream-string stream))
    3766 
    3767 (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
    3768   (declare (ignorable x))
    3769   (slurp-stream-string stream))
    3770 
    3771 (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
    3772   (declare (ignorable x))
    3773   (slurp-stream-lines stream :count count))
    3774 
    3775 (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
    3776   (declare (ignorable x))
    3777   (slurp-stream-line stream :at at))
    3778 
    3779 (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
    3780   (declare (ignorable x))
    3781   (slurp-stream-forms stream :count count))
    3782 
    3783 (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
    3784   (declare (ignorable x))
    3785   (slurp-stream-form stream :at at))
    3786 
    3787 (defmethod slurp-input-stream (x stream
    3788                                &key linewise prefix (element-type 'character) buffer-size
    3789                                &allow-other-keys)
    3790   (declare (ignorable stream linewise prefix element-type buffer-size))
    3791   (cond
    3792     #+(or gcl2.6 genera)
    3793     ((functionp x) (funcall x stream))
    3794     #+(or gcl2.6 genera)
    3795     ((output-stream-p x)
    3796      (copy-stream-to-stream
    3797       input-stream output-stream
    3798       :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
    3799     (t
    3800      (error "Invalid ~S destination ~S" 'slurp-input-stream x))))
     3792(with-upgradability ()
     3793  (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys))
     3794 
     3795  #-(or gcl2.6 genera)
     3796  (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
     3797    (funcall function input-stream))
     3798
     3799  (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
     3800    (apply (first list) (cons input-stream (rest list))))
     3801
     3802  #-(or gcl2.6 genera)
     3803  (defmethod slurp-input-stream ((output-stream stream) input-stream
     3804                                 &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
     3805    (copy-stream-to-stream
     3806     input-stream output-stream
     3807     :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     3808
     3809  (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
     3810    (declare (ignorable x))
     3811    (slurp-stream-string stream))
     3812
     3813  (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
     3814    (declare (ignorable x))
     3815    (slurp-stream-string stream))
     3816
     3817  (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
     3818    (declare (ignorable x))
     3819    (slurp-stream-lines stream :count count))
     3820
     3821  (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
     3822    (declare (ignorable x))
     3823    (slurp-stream-line stream :at at))
     3824
     3825  (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
     3826    (declare (ignorable x))
     3827    (slurp-stream-forms stream :count count))
     3828
     3829  (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys)
     3830    (declare (ignorable x))
     3831    (slurp-stream-form stream :at at))
     3832
     3833  (defmethod slurp-input-stream (x stream
     3834                                 &key linewise prefix (element-type 'character) buffer-size
     3835                                 &allow-other-keys)
     3836    (declare (ignorable stream linewise prefix element-type buffer-size))
     3837    (cond
     3838      #+(or gcl2.6 genera)
     3839      ((functionp x) (funcall x stream))
     3840      #+(or gcl2.6 genera)
     3841      ((output-stream-p x)
     3842       (copy-stream-to-stream
     3843        input-stream output-stream
     3844        :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     3845      (t
     3846       (error "Invalid ~S destination ~S" 'slurp-input-stream x)))))
    38013847
    38023848
     
    38043850;;; Simple variant of run-program with no input, and capturing output
    38053851;;; On some implementations, may output to a temporary file...
    3806 
    3807 (define-condition subprocess-error (error)
    3808   ((code :initform nil :initarg :code :reader subprocess-error-code)
    3809    (command :initform nil :initarg :command :reader subprocess-error-command)
    3810    (process :initform nil :initarg :process :reader subprocess-error-process))
    3811   (:report (lambda (condition stream)
    3812              (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
    3813                      (subprocess-error-process condition)
    3814                      (subprocess-error-command condition)
    3815                      (subprocess-error-code condition)))))
    3816 
    3817 (defun* run-program (command
    3818                      &key output ignore-error-status force-shell
    3819                      (element-type *default-stream-element-type*)
    3820                      (external-format :default)
    3821                      &allow-other-keys)
    3822   "Run program specified by COMMAND,
     3852(with-upgradability ()
     3853  (define-condition subprocess-error (error)
     3854    ((code :initform nil :initarg :code :reader subprocess-error-code)
     3855     (command :initform nil :initarg :command :reader subprocess-error-command)
     3856     (process :initform nil :initarg :process :reader subprocess-error-process))
     3857    (:report (lambda (condition stream)
     3858               (format stream "Subprocess~@[ ~S~]~@[ run with command ~S~] exited with error~@[ code ~D~]"
     3859                       (subprocess-error-process condition)
     3860                       (subprocess-error-command condition)
     3861                       (subprocess-error-code condition)))))
     3862
     3863  (defun run-program (command
     3864                       &key output ignore-error-status force-shell
     3865                       (element-type *default-stream-element-type*)
     3866                       (external-format :default)
     3867                       &allow-other-keys)
     3868    "Run program specified by COMMAND,
    38233869either a list of strings specifying a program and list of arguments,
    38243870or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
     
    38323878Return the exit status code of the process that was called.
    38333879Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
    3834   (declare (ignorable ignore-error-status element-type external-format))
    3835   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
    3836   (error "RUN-PROGRAM not implemented for this Lisp")
    3837   (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
    3838            (run-program (command &key pipe interactive)
    3839              "runs the specified command (a list of program and arguments).
     3880    (declare (ignorable ignore-error-status element-type external-format))
     3881    #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
     3882    (error "RUN-PROGRAM not implemented for this Lisp")
     3883    (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
     3884             (run-program (command &key pipe interactive)
     3885               "runs the specified command (a list of program and arguments).
    38403886              If using a pipe, returns two values: process and stream
    38413887              If not using a pipe, returns one values: the process result;
    38423888              also, inherits the output stream."
    3843              ;; NB: these implementations have unix vs windows set at compile-time.
    3844              (assert (not (and pipe interactive)))
    3845              (let* ((wait (not pipe))
    3846                     #-(and clisp os-windows)
    3847                     (command
    3848                      (etypecase command
    3849                        #+os-unix (string `("/bin/sh" "-c" ,command))
    3850                        #+os-unix (list command)
    3851                        #+os-windows
    3852                        (string
    3853                         ;; NB: We do NOT add cmd /c here. You might want to.
    3854                         #+allegro command
    3855                         ;; On ClozureCL for Windows, we assume you are using
    3856                         ;; r15398 or later in 1.9 or later,
    3857                         ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
    3858                         #+clozure (cons "cmd" (strcat "/c " command))
    3859                         ;; NB: On other Windows implementations, this is utterly bogus
    3860                         ;; except in the most trivial cases where no quoting is needed.
    3861                         ;; Use at your own risk.
    3862                         #-(or allegro clozure) (list "cmd" "/c" command))
    3863                        #+os-windows
    3864                        (list
    3865                         #+(or allegro clozure) (escape-windows-command command)
    3866                         #-(or allegro clozure) command)))
    3867                     #+(and clozure os-windows) (command (list command))
    3868                     (process*
    3869                      (multiple-value-list
    3870                       #+allegro
    3871                       (excl:run-shell-command
    3872                        #+os-unix (coerce (cons (first command) command) 'vector)
    3873                        #+os-windows command
    3874                        :input interactive :output (or (and pipe :stream) interactive) :wait wait
    3875                        #+os-windows :show-window #+os-windows (and pipe :hide))
    3876                       #+clisp
    3877                       (flet ((run (f &rest args)
    3878                                (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
    3879                                           ,(if pipe :stream :terminal)))))
     3889               ;; NB: these implementations have unix vs windows set at compile-time.
     3890               (assert (not (and pipe interactive)))
     3891               (let* ((wait (not pipe))
     3892                      #-(and clisp os-windows)
     3893                      (command
    38803894                        (etypecase command
    3881                           #+os-windows (run 'ext:run-shell-command command)
    3882                           (list (run 'ext:run-program (car command)
    3883                                      :arguments (cdr command)))))
    3884                       #+lispworks
    3885                       (system:run-shell-command
    3886                        (cons "/usr/bin/env" command) ; lispworks wants a full path.
    3887                        :input interactive :output (or (and pipe :stream) interactive)
    3888                        :wait wait :save-exit-status (and pipe t))
    3889                       #+(or clozure cmu ecl sbcl scl)
    3890                       (#+(or cmu ecl scl) ext:run-program
    3891                        #+clozure ccl:run-program
    3892                        #+sbcl sb-ext:run-program
    3893                        (car command) (cdr command)
    3894                        :input interactive :wait wait
    3895                        :output (if pipe :stream t)
    3896                        . #.(append
    3897                             #+(or clozure cmu ecl sbcl scl) '(:error t)
    3898                             ;; note: :external-format requires a recent SBCL
    3899                             #+sbcl '(:search t :external-format external-format)))))
    3900                     (process
    3901                      #+(or allegro lispworks) (if pipe (third process*) (first process*))
    3902                      #+ecl (third process*)
    3903                      #-(or allegro lispworks ecl) (first process*))
    3904                     (stream
    3905                      (when pipe
    3906                        #+(or allegro lispworks ecl) (first process*)
    3907                        #+clisp (first process*)
    3908                        #+clozure (ccl::external-process-output process)
    3909                        #+(or cmu scl) (ext:process-output process)
    3910                        #+sbcl (sb-ext:process-output process))))
    3911                (values process stream)))
    3912            #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
    3913            (process-result (process pipe)
    3914              (declare (ignorable pipe))
    3915              ;; 1- wait
    3916              #+(and clozure os-unix) (ccl::external-process-wait process)
    3917              #+(or cmu scl) (ext:process-wait process)
    3918              #+(and ecl os-unix) (ext:external-process-wait process)
    3919              #+sbcl (sb-ext:process-wait process)
    3920              ;; 2- extract result
    3921              #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
    3922              #+clisp process
    3923              #+clozure (nth-value 1 (ccl:external-process-status process))
    3924              #+(or cmu scl) (ext:process-exit-code process)
    3925              #+ecl (nth-value 1 (ext:external-process-status process))
    3926              #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
    3927              #+sbcl (sb-ext:process-exit-code process))
    3928            (check-result (exit-code process)
    3929              #+clisp
    3930              (setf exit-code
    3931                    (typecase exit-code (integer exit-code) (null 0) (t -1)))
    3932              (unless (or ignore-error-status
    3933                          (equal exit-code 0))
    3934                (error 'subprocess-error :command command :code exit-code :process process))
    3935              exit-code)
    3936            (use-run-program ()
    3937              #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
    3938              (let* ((interactive (eq output :interactive))
    3939                     (pipe (and output (not interactive))))
    3940                (multiple-value-bind (process stream)
    3941                    (run-program command :pipe pipe :interactive interactive)
     3895                          #+os-unix (string `("/bin/sh" "-c" ,command))
     3896                          #+os-unix (list command)
     3897                          #+os-windows
     3898                          (string
     3899                           ;; NB: We do NOT add cmd /c here. You might want to.
     3900                           #+allegro command
     3901                           ;; On ClozureCL for Windows, we assume you are using
     3902                           ;; r15398 or later in 1.9 or later,
     3903                           ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858
     3904                           #+clozure (cons "cmd" (strcat "/c " command))
     3905                           ;; NB: On other Windows implementations, this is utterly bogus
     3906                           ;; except in the most trivial cases where no quoting is needed.
     3907                           ;; Use at your own risk.
     3908                           #-(or allegro clozure) (list "cmd" "/c" command))
     3909                          #+os-windows
     3910                          (list
     3911                           #+(or allegro clozure) (escape-windows-command command)
     3912                           #-(or allegro clozure) command)))
     3913                      #+(and clozure os-windows) (command (list command))
     3914                      (process*
     3915                        (multiple-value-list
     3916                         #+allegro
     3917                         (excl:run-shell-command
     3918                          #+os-unix (coerce (cons (first command) command) 'vector)
     3919                          #+os-windows command
     3920                          :input interactive :output (or (and pipe :stream) interactive) :wait wait
     3921                          #+os-windows :show-window #+os-windows (and pipe :hide))
     3922                         #+clisp
     3923                         (flet ((run (f &rest args)
     3924                                  (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
     3925                                                    ,(if pipe :stream :terminal)))))
     3926                           (etypecase command
     3927                             #+os-windows (run 'ext:run-shell-command command)
     3928                             (list (run 'ext:run-program (car command)
     3929                                        :arguments (cdr command)))))
     3930                         #+lispworks
     3931                         (system:run-shell-command
     3932                          (cons "/usr/bin/env" command) ; lispworks wants a full path.
     3933                          :input interactive :output (or (and pipe :stream) interactive)
     3934                          :wait wait :save-exit-status (and pipe t))
     3935                         #+(or clozure cmu ecl sbcl scl)
     3936                         (#+(or cmu ecl scl) ext:run-program
     3937                            #+clozure ccl:run-program
     3938                            #+sbcl sb-ext:run-program
     3939                            (car command) (cdr command)
     3940                            :input interactive :wait wait
     3941                            :output (if pipe :stream t)
     3942                            . #.(append
     3943                                 #+(or clozure cmu ecl sbcl scl) '(:error t)
     3944                                 ;; note: :external-format requires a recent SBCL
     3945                                 #+sbcl '(:search t :external-format external-format)))))
     3946                      (process
     3947                        #+(or allegro lispworks) (if pipe (third process*) (first process*))
     3948                        #+ecl (third process*)
     3949                        #-(or allegro lispworks ecl) (first process*))
     3950                      (stream
     3951                        (when pipe
     3952                          #+(or allegro lispworks ecl) (first process*)
     3953                          #+clisp (first process*)
     3954                          #+clozure (ccl::external-process-output process)
     3955                          #+(or cmu scl) (ext:process-output process)
     3956                          #+sbcl (sb-ext:process-output process))))
     3957                 (values process stream)))
     3958             #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl)
     3959             (process-result (process pipe)
     3960               (declare (ignorable pipe))
     3961               ;; 1- wait
     3962               #+(and clozure os-unix) (ccl::external-process-wait process)
     3963               #+(or cmu scl) (ext:process-wait process)
     3964               #+(and ecl os-unix) (ext:external-process-wait process)
     3965               #+sbcl (sb-ext:process-wait process)
     3966               ;; 2- extract result
     3967               #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process)
     3968               #+clisp process
     3969               #+clozure (nth-value 1 (ccl:external-process-status process))
     3970               #+(or cmu scl) (ext:process-exit-code process)
     3971               #+ecl (nth-value 1 (ext:external-process-status process))
     3972               #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
     3973               #+sbcl (sb-ext:process-exit-code process))
     3974             (check-result (exit-code process)
     3975               #+clisp
     3976               (setf exit-code
     3977                     (typecase exit-code (integer exit-code) (null 0) (t -1)))
     3978               (unless (or ignore-error-status
     3979                           (equal exit-code 0))
     3980                 (error 'subprocess-error :command command :code exit-code :process process))
     3981               exit-code)
     3982             (use-run-program ()
     3983               #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl)
     3984               (let* ((interactive (eq output :interactive))
     3985                      (pipe (and output (not interactive))))
     3986                 (multiple-value-bind (process stream)
     3987                     (run-program command :pipe pipe :interactive interactive)
     3988                   (if (and output (not interactive))
     3989                       (unwind-protect
     3990                            (slurp-input-stream output stream)
     3991                         (when stream (close stream))
     3992                         (check-result (process-result process pipe) process))
     3993                       (unwind-protect
     3994                            (check-result
     3995                             #+(or allegro lispworks) ; when not capturing, returns the exit code!
     3996                             process
     3997                             #-(or allegro lispworks) (process-result process pipe)
     3998                             process))))))
     3999             (system-command (command)
     4000               (etypecase command
     4001                 (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
     4002                 (list (escape-shell-command
     4003                        (if (os-unix-p) (cons "exec" command) command)))))
     4004             (redirected-system-command (command out)
     4005               (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
     4006                       (system-command command) (native-namestring out)))
     4007             (system (command &key interactive)
     4008               (declare (ignorable interactive))
     4009               #+(or abcl xcl) (ext:run-shell-command command)
     4010               #+allegro
     4011               (excl:run-shell-command command :input interactive :output interactive :wait t)
     4012               #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
     4013               (process-result (run-program command :pipe nil :interactive interactive) nil)
     4014               #+ecl (ext:system command)
     4015               #+cormanlisp (win32:system command)
     4016               #+gcl (lisp:system command)
     4017               #+(and lispworks os-windows)
     4018               (system:call-system-showing-output
     4019                command :show-cmd interactive :prefix "" :output-stream nil)
     4020               #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
     4021               #+mkcl (nth-value 2
     4022                                 (mkcl:run-program #+windows command #+windows ()
     4023                                                   #-windows "/bin/sh" (list "-c" command)
     4024                                                   :input nil :output nil)))
     4025             (call-system (command-string &key interactive)
     4026               (check-result (system command-string :interactive interactive) nil))
     4027             (use-system ()
     4028               (let ((interactive (eq output :interactive)))
    39424029                 (if (and output (not interactive))
    3943                      (unwind-protect
    3944                           (slurp-input-stream output stream)
    3945                        (when stream (close stream))
    3946                        (check-result (process-result process pipe) process))
    3947                      (unwind-protect
    3948                           (check-result
    3949                            #+(or allegro lispworks) ; when not capturing, returns the exit code!
    3950                            process
    3951                            #-(or allegro lispworks) (process-result process pipe)
    3952                            process))))))
    3953            (system-command (command)
    3954              (etypecase command
    3955                (string (if (os-windows-p) (format nil "cmd /c ~A" command) command))
    3956                (list (escape-shell-command
    3957                       (if (os-unix-p) (cons "exec" command) command)))))
    3958            (redirected-system-command (command out)
    3959              (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A")
    3960                      (system-command command) (native-namestring out)))
    3961            (system (command &key interactive)
    3962              (declare (ignorable interactive))
    3963              #+(or abcl xcl) (ext:run-shell-command command)
    3964              #+allegro
    3965              (excl:run-shell-command command :input interactive :output interactive :wait t)
    3966              #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
    3967              (process-result (run-program command :pipe nil :interactive interactive) nil)
    3968              #+ecl (ext:system command)
    3969              #+cormanlisp (win32:system command)
    3970              #+gcl (lisp:system command)
    3971              #+(and lispworks os-windows)
    3972              (system:call-system-showing-output
    3973               command :show-cmd interactive :prefix "" :output-stream nil)
    3974              #+mcl (ccl::with-cstrs ((%command command)) (_system %command))
    3975              #+mkcl (nth-value 2
    3976                                (mkcl:run-program #+windows command #+windows ()
    3977                                                  #-windows "/bin/sh" (list "-c" command)
    3978                                                  :input nil :output nil)))
    3979            (call-system (command-string &key interactive)
    3980              (check-result (system command-string :interactive interactive) nil))
    3981            (use-system ()
    3982              (let ((interactive (eq output :interactive)))
    3983                (if (and output (not interactive))
    3984                    (with-temporary-file (:pathname tmp :direction :output)
    3985                      (call-system (redirected-system-command command tmp))
    3986                      (with-open-file (stream tmp
    3987                                              :direction :input
    3988                                              :if-does-not-exist :error
    3989                                              :element-type element-type
    3990                                              #-gcl2.6 :external-format #-gcl2.6 external-format)
    3991                        (slurp-input-stream output stream)))
    3992                    (call-system (system-command command) :interactive interactive)))))
    3993     (if (and (not force-shell)
    3994              #+(or clisp ecl) ignore-error-status
    3995              #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
    3996         (use-run-program)
    3997         (use-system))))
     4030                     (with-temporary-file (:pathname tmp :direction :output)
     4031                       (call-system (redirected-system-command command tmp))
     4032                       (with-open-file (stream tmp
     4033                                               :direction :input
     4034                                               :if-does-not-exist :error
     4035                                               :element-type element-type
     4036                                               #-gcl2.6 :external-format #-gcl2.6 external-format)
     4037                         (slurp-input-stream output stream)))
     4038                     (call-system (system-command command) :interactive interactive)))))
     4039      (if (and (not force-shell)
     4040               #+(or clisp ecl) ignore-error-status
     4041               #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil)
     4042          (use-run-program)
     4043          (use-system)))))
    39984044
    39994045;;;; -------------------------------------------------------------------------
     
    40284074(in-package :asdf/lisp-build)
    40294075
    4030 (defvar *compile-file-warnings-behaviour*
    4031   (or #+clisp :ignore :warn)
    4032   "How should ASDF react if it encounters a warning when compiling a file?
     4076(with-upgradability ()
     4077  (defvar *compile-file-warnings-behaviour*
     4078    (or #+clisp :ignore :warn)
     4079    "How should ASDF react if it encounters a warning when compiling a file?
    40334080Valid values are :error, :warn, and :ignore.")
    40344081
    4035 (defvar *compile-file-failure-behaviour*
    4036   (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
    4037   "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
     4082  (defvar *compile-file-failure-behaviour*
     4083    (or #+(or mkcl sbcl) :error #+clisp :ignore :warn)
     4084    "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
    40384085when compiling a file, which includes any non-style-warning warning.
    40394086Valid values are :error, :warn, and :ignore.
    4040 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
     4087Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling."))
    40414088
    40424089
    40434090;;; Optimization settings
    4044 
    4045 (defvar *optimization-settings* nil)
    4046 (defvar *previous-optimization-settings* nil)
    4047 (defun* get-optimization-settings ()
    4048   "Get current compiler optimization settings, ready to PROCLAIM again"
    4049   (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
    4050     #-(or clisp clozure cmu ecl sbcl scl)
    4051     (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
    4052     #.`(loop :for x :in settings
    4053          ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
    4054                #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
    4055                #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
    4056          :for y = (or #+clisp (gethash x system::*optimize*)
    4057                       #+(or clozure ecl) (symbol-value v)
    4058                       #+(or cmu scl) (funcall f c::*default-cookie*)
    4059                       #+sbcl (cdr (assoc x sb-c::*policy*)))
    4060          :when y :collect (list x y))))
    4061 (defun* proclaim-optimization-settings ()
    4062   "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
    4063   (proclaim `(optimize ,@*optimization-settings*))
    4064   (let ((settings (get-optimization-settings)))
    4065     (unless (equal *previous-optimization-settings* settings)
    4066       (setf *previous-optimization-settings* settings))))
     4091(with-upgradability ()
     4092  (defvar *optimization-settings* nil)
     4093  (defvar *previous-optimization-settings* nil)
     4094  (defun get-optimization-settings ()
     4095    "Get current compiler optimization settings, ready to PROCLAIM again"
     4096    (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
     4097      #-(or clisp clozure cmu ecl sbcl scl)
     4098      (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
     4099      #.`(loop :for x :in settings
     4100               ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
     4101                     #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
     4102                     #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
     4103               :for y = (or #+clisp (gethash x system::*optimize*)
     4104                            #+(or clozure ecl) (symbol-value v)
     4105                            #+(or cmu scl) (funcall f c::*default-cookie*)
     4106                            #+sbcl (cdr (assoc x sb-c::*policy*)))
     4107               :when y :collect (list x y))))
     4108  (defun proclaim-optimization-settings ()
     4109    "Proclaim the optimization settings in *OPTIMIZATION-SETTINGS*"
     4110    (proclaim `(optimize ,@*optimization-settings*))
     4111    (let ((settings (get-optimization-settings)))
     4112      (unless (equal *previous-optimization-settings* settings)
     4113        (setf *previous-optimization-settings* settings)))))
    40674114
    40684115
    40694116;;; Condition control
    4070 
    4071 #+sbcl
    4072 (progn
    4073   (defun sb-grovel-unknown-constant-condition-p (c)
    4074     (and (typep c 'sb-int:simple-style-warning)
    4075          (string-enclosed-p
    4076           "Couldn't grovel for "
    4077           (simple-condition-format-control c)
    4078           " (unknown to the C compiler).")))
    4079   (deftype sb-grovel-unknown-constant-condition ()
    4080     '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
    4081 
    4082 (defvar *uninteresting-compiler-conditions*
    4083   (append
    4084    ;;#+clozure '(ccl:compiler-warning)
    4085    #+cmu '("Deleting unreachable code.")
    4086    #+sbcl
    4087    '(sb-c::simple-compiler-note
    4088      "&OPTIONAL and &KEY found in the same lambda list: ~S"
    4089      sb-int:package-at-variance
    4090      sb-kernel:uninteresting-redefinition
    4091      sb-kernel:undefined-alien-style-warning
    4092      ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
    4093      sb-kernel:lexical-environment-too-complex
    4094      sb-grovel-unknown-constant-condition ; defined above.
    4095      ;; BEWARE: the below four are controversial to include here.
    4096      sb-kernel:redefinition-with-defun
    4097      sb-kernel:redefinition-with-defgeneric
    4098      sb-kernel:redefinition-with-defmethod
    4099      sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
    4100    '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
    4101   "Conditions that may be skipped while compiling")
    4102 
    4103 (defvar *uninteresting-loader-conditions*
    4104   (append
    4105    '("Overwriting already existing readtable ~S." ;; from named-readtables
    4106      #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
    4107    #+clisp '(clos::simple-gf-replacing-method-warning))
    4108   "Additional conditions that may be skipped while loading")
     4117(with-upgradability ()
     4118  #+sbcl
     4119  (progn
     4120    (defun sb-grovel-unknown-constant-condition-p (c)
     4121      (and (typep c 'sb-int:simple-style-warning)
     4122           (string-enclosed-p
     4123            "Couldn't grovel for "
     4124            (simple-condition-format-control c)
     4125            " (unknown to the C compiler).")))
     4126    (deftype sb-grovel-unknown-constant-condition ()
     4127      '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
     4128
     4129  (defvar *uninteresting-compiler-conditions*
     4130    (append
     4131     ;;#+clozure '(ccl:compiler-warning)
     4132     #+cmu '("Deleting unreachable code.")
     4133     #+lispworks '("~S being redefined in ~A (previously in ~A)."
     4134                   "~S defined more than once in ~A.") ;; lispworks gets confused by eval-when.
     4135     #+sbcl
     4136     '(sb-c::simple-compiler-note
     4137       "&OPTIONAL and &KEY found in the same lambda list: ~S"
     4138       sb-int:package-at-variance
     4139       sb-kernel:uninteresting-redefinition
     4140       sb-kernel:undefined-alien-style-warning
     4141       ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
     4142       #+sb-eval sb-kernel:lexical-environment-too-complex
     4143       sb-grovel-unknown-constant-condition ; defined above.
     4144       ;; BEWARE: the below four are controversial to include here.
     4145       sb-kernel:redefinition-with-defun
     4146       sb-kernel:redefinition-with-defgeneric
     4147       sb-kernel:redefinition-with-defmethod
     4148       sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
     4149     '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
     4150    "Conditions that may be skipped while compiling")
     4151
     4152  (defvar *uninteresting-loader-conditions*
     4153    (append
     4154     '("Overwriting already existing readtable ~S." ;; from named-readtables
     4155       #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
     4156     #+clisp '(clos::simple-gf-replacing-method-warning))
     4157    "Additional conditions that may be skipped while loading"))
    41094158
    41104159;;;; ----- Filtering conditions while building -----
    4111 
    4112 (defun* call-with-muffled-compiler-conditions (thunk)
    4113   (call-with-muffled-conditions
    4114     thunk *uninteresting-compiler-conditions*))
    4115 (defmacro with-muffled-compiler-conditions ((&optional) &body body)
    4116   "Run BODY where uninteresting compiler conditions are muffled"
    4117   `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
    4118 (defun* call-with-muffled-loader-conditions (thunk)
    4119   (call-with-muffled-conditions
    4120    thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
    4121 (defmacro with-muffled-loader-conditions ((&optional) &body body)
    4122   "Run BODY where uninteresting compiler and additional loader conditions are muffled"
    4123   `(call-with-muffled-loader-conditions #'(lambda () ,@body)))
     4160(with-upgradability ()
     4161  (defun call-with-muffled-compiler-conditions (thunk)
     4162    (call-with-muffled-conditions
     4163     thunk *uninteresting-compiler-conditions*))
     4164  (defmacro with-muffled-compiler-conditions ((&optional) &body body)
     4165    "Run BODY where uninteresting compiler conditions are muffled"
     4166    `(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
     4167  (defun call-with-muffled-loader-conditions (thunk)
     4168    (call-with-muffled-conditions
     4169     thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
     4170  (defmacro with-muffled-loader-conditions ((&optional) &body body)
     4171    "Run BODY where uninteresting compiler and additional loader conditions are muffled"
     4172    `(call-with-muffled-loader-conditions #'(lambda () ,@body))))
    41244173
    41254174
    41264175;;;; Handle warnings and failures
    4127 (define-condition compile-condition (condition)
    4128   ((context-format
    4129     :initform nil :reader compile-condition-context-format :initarg :context-format)
    4130    (context-arguments
    4131     :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
    4132    (description
    4133     :initform nil :reader compile-condition-description :initarg :description))
    4134   (:report (lambda (c s)
     4176(with-upgradability ()
     4177  (define-condition compile-condition (condition)
     4178    ((context-format
     4179      :initform nil :reader compile-condition-context-format :initarg :context-format)
     4180     (context-arguments
     4181      :initform nil :reader compile-condition-context-arguments :initarg :context-arguments)
     4182     (description
     4183      :initform nil :reader compile-condition-description :initarg :description))
     4184    (:report (lambda (c s)
    41354185               (format s (compatfmt "~@<~A~@[ while ~?~]~@:>")
    41364186                       (or (compile-condition-description c) (type-of c))
    41374187                       (compile-condition-context-format c)
    41384188                       (compile-condition-context-arguments c)))))
    4139 (define-condition compile-file-error (compile-condition error) ())
    4140 (define-condition compile-warned-warning (compile-condition warning) ())
    4141 (define-condition compile-warned-error (compile-condition error) ())
    4142 (define-condition compile-failed-warning (compile-condition warning) ())
    4143 (define-condition compile-failed-error (compile-condition error) ())
    4144 
    4145 (defun* check-lisp-compile-warnings (warnings-p failure-p
    4146                                                 &optional context-format context-arguments)
    4147   (when failure-p
    4148     (case *compile-file-failure-behaviour*
    4149       (:warn (warn 'compile-failed-warning
    4150                    :description "Lisp compilation failed"
    4151                    :context-format context-format
    4152                    :context-arguments context-arguments))
    4153       (:error (error 'compile-failed-error
    4154                    :description "Lisp compilation failed"
    4155                    :context-format context-format
    4156                    :context-arguments context-arguments))
    4157       (:ignore nil)))
    4158   (when warnings-p
    4159     (case *compile-file-warnings-behaviour*
    4160       (:warn (warn 'compile-warned-warning
    4161                    :description "Lisp compilation had style-warnings"
    4162                    :context-format context-format
    4163                    :context-arguments context-arguments))
    4164       (:error (error 'compile-warned-error
    4165                    :description "Lisp compilation had style-warnings"
    4166                    :context-format context-format
    4167                    :context-arguments context-arguments))
    4168       (:ignore nil))))
    4169 
    4170 (defun* check-lisp-compile-results (output warnings-p failure-p
    4171                                            &optional context-format context-arguments)
    4172   (unless output
    4173     (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
    4174   (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))
     4189  (define-condition compile-file-error (compile-condition error) ())
     4190  (define-condition compile-warned-warning (compile-condition warning) ())
     4191  (define-condition compile-warned-error (compile-condition error) ())
     4192  (define-condition compile-failed-warning (compile-condition warning) ())
     4193  (define-condition compile-failed-error (compile-condition error) ())
     4194
     4195  (defun check-lisp-compile-warnings (warnings-p failure-p
     4196                                                  &optional context-format context-arguments)
     4197    (when failure-p
     4198      (case *compile-file-failure-behaviour*
     4199        (:warn (warn 'compile-failed-warning
     4200                     :description "Lisp compilation failed"
     4201                     :context-format context-format
     4202                     :context-arguments context-arguments))
     4203        (:error (error 'compile-failed-error
     4204                       :description "Lisp compilation failed"
     4205                       :context-format context-format
     4206                       :context-arguments context-arguments))
     4207        (:ignore nil)))
     4208    (when warnings-p
     4209      (case *compile-file-warnings-behaviour*
     4210        (:warn (warn 'compile-warned-warning
     4211                     :description "Lisp compilation had style-warnings"
     4212                     :context-format context-format
     4213                     :context-arguments context-arguments))
     4214        (:error (error 'compile-warned-error
     4215                       :description "Lisp compilation had style-warnings"
     4216                       :context-format context-format
     4217                       :context-arguments context-arguments))
     4218        (:ignore nil))))
     4219
     4220  (defun check-lisp-compile-results (output warnings-p failure-p
     4221                                             &optional context-format context-arguments)
     4222    (unless output
     4223      (error 'compile-file-error :context-format context-format :context-arguments context-arguments))
     4224    (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments)))
    41754225
    41764226
    41774227;;;; Deferred-warnings treatment, originally implemented by Douglas Katzman.
    4178 ;;
    4179 ;; To support an implementation, three functions must be implemented:
    4180 ;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
    4181 ;; See their respective docstrings.
    4182 
    4183 (defun reify-simple-sexp (sexp)
    4184   (etypecase sexp
    4185     (symbol (reify-symbol sexp))
    4186     ((or number character simple-string pathname) sexp)
    4187     (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
    4188 (defun unreify-simple-sexp (sexp)
    4189   (etypecase sexp
    4190     ((or symbol number character simple-string pathname) sexp)
    4191     (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
    4192     ((simple-vector 2) (unreify-symbol sexp))))
    4193 
    4194 #+clozure
    4195 (progn
    4196   (defun reify-source-note (source-note)
    4197     (when source-note
    4198       (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
    4199                        (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
     4228;;;
     4229;;; To support an implementation, three functions must be implemented:
     4230;;; reify-deferred-warnings unreify-deferred-warnings reset-deferred-warnings
     4231;;; See their respective docstrings.
     4232(with-upgradability ()
     4233  (defun reify-simple-sexp (sexp)
     4234    (etypecase sexp
     4235      (symbol (reify-symbol sexp))
     4236      ((or number character simple-string pathname) sexp)
     4237      (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
     4238  (defun unreify-simple-sexp (sexp)
     4239    (etypecase sexp
     4240      ((or symbol number character simple-string pathname) sexp)
     4241      (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
     4242      ((simple-vector 2) (unreify-symbol sexp))))
     4243
     4244  #+clozure
     4245  (progn
     4246    (defun reify-source-note (source-note)
     4247      (when source-note
     4248        (with-accessors ((source ccl::source-note-source) (filename ccl:source-note-filename)
     4249                         (start-pos ccl:source-note-start-pos) (end-pos ccl:source-note-end-pos)) source-note
    42004250          (declare (ignorable source))
    42014251          (list :filename filename :start-pos start-pos :end-pos end-pos
    42024252                #|:source (reify-source-note source)|#))))
    4203   (defun unreify-source-note (source-note)
    4204     (when source-note
    4205       (destructuring-bind (&key filename start-pos end-pos source) source-note
    4206         (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
    4207                                :source (unreify-source-note source)))))
    4208   (defun reify-deferred-warning (deferred-warning)
    4209     (with-accessors ((warning-type ccl::compiler-warning-warning-type)
    4210                      (args ccl::compiler-warning-args)
    4211                      (source-note ccl:compiler-warning-source-note)
    4212                      (function-name ccl:compiler-warning-function-name)) deferred-warning
    4213       (list :warning-type warning-type :function-name (reify-simple-sexp function-name)
    4214             :source-note (reify-source-note source-note) :args (reify-simple-sexp args))))
    4215   (defun unreify-deferred-warning (reified-deferred-warning)
    4216     (destructuring-bind (&key warning-type function-name source-note args)
    4217         reified-deferred-warning
    4218       (make-condition (or (cdr (ccl::assq warning-type ccl::*compiler-whining-conditions*))
    4219                           'ccl::compiler-warning)
    4220                       :function-name (unreify-simple-sexp function-name)
    4221                       :source-note (unreify-source-note source-note)
    4222                       :warning-type warning-type
    4223                       :args (unreify-simple-sexp args)))))
    4224 
    4225 #+sbcl
    4226 (defun reify-undefined-warning (warning)
    4227   ;; Extracting undefined-warnings from the compilation-unit
    4228   ;; To be passed through the above reify/unreify link, it must be a "simple-sexp"
    4229   (list*
    4230    (sb-c::undefined-warning-kind warning)
    4231    (sb-c::undefined-warning-name warning)
    4232    (sb-c::undefined-warning-count warning)
    4233    (mapcar
    4234     #'(lambda (frob)
    4235         ;; the lexenv slot can be ignored for reporting purposes
    4236         `(:enclosing-source ,(sb-c::compiler-error-context-enclosing-source frob)
    4237           :source ,(sb-c::compiler-error-context-source frob)
    4238           :original-source ,(sb-c::compiler-error-context-original-source frob)
    4239           :context ,(sb-c::compiler-error-context-context frob)
    4240           :file-name ,(sb-c::compiler-error-context-file-name frob) ; a pathname
    4241           :file-position ,(sb-c::compiler-error-context-file-position frob) ; an integer
    4242           :original-source-path ,(sb-c::compiler-error-context-original-source-path frob)))
    4243     (sb-c::undefined-warning-warnings warning))))
    4244 
    4245 (defun reify-deferred-warnings ()
    4246   "return a portable S-expression, portably readable and writeable in any Common Lisp implementation
     4253    (defun unreify-source-note (source-note)
     4254      (when source-note
     4255        (destructuring-bind (&key filename start-pos end-pos source) source-note
     4256          (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
     4257                                 :source (unreify-source-note source)))))
     4258    (defun reify-function-name (function-name)
     4259      (reify-simple-sexp