source: trunk/source/level-1/l1-files.lisp @ 10872

Last change on this file since 10872 was 10872, checked in by gb, 11 years ago

In STRING-TO-PATHNAME, only set a physical pathname's version slot
if the name is non-nil. (Among other things, the version of a pathname
created by (parse-namestring "") has to be NIL.) This (and the recent
change to EQUAL) seem to fix the test suite failures that were introduced
a few weeks ago.

In %COMPONENT-MATCH-P, treat a wild component of :NEWEST (which should
only be present if versions are being compared) like wildcard
designators (e.g., not as a concrete thing to be compared against a
string or list.) Among other things, this seems to fix some
cases involving CCL::BACK-TRANSLATE-PATHNAME and the ccl logical
host.

(The trunk passes all tests in the test suite again.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 57.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001 Clozure Associates
5;;;   This file is part of OpenMCL. 
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; L1-files.lisp - Object oriented file stuff
19
20(in-package "CCL")
21
22(defconstant $paramErr -50)   ; put this with the rest when we find the rest
23
24(defconstant pathname-case-type '(member :common :local :studly))
25(defconstant pathname-arg-type '(or string pathname stream))
26
27(defmacro signal-file-error (err-num &optional pathname &rest args)
28  `(%signal-file-error ,err-num
29    ,@(if pathname (list pathname))
30              ,@(if args args)))
31
32(defun %signal-file-error (err-num &optional pathname args)
33  (declare (fixnum err-num))
34  (let* ((err-code (logior (ash 2 16) (the fixnum (logand #xffff (the fixnum err-num))))))
35    (funcall (if (< err-num 0) '%errno-disp '%err-disp)
36             err-code
37             pathname
38             args)))
39
40
41(defvar %logical-host-translations% '())
42(defvar *load-pathname* nil
43  "the defaulted pathname that LOAD is currently loading")
44(defvar *load-truename* nil
45  "the TRUENAME of the file that LOAD is currently loading")
46
47
48(defparameter *default-pathname-defaults*
49  (let* ((hide-from-compile-file (%cons-pathname nil nil nil)))
50    hide-from-compile-file))
51
52;Right now, the only way it's used is that an explicit ";" expands into it.
53;Used to merge with it before going to ROM.  Might be worth to bring that back,
54;it doesn't hurt anything if you don't set it.
55;(defparameter *working-directory* (%cons-pathname nil nil nil))
56
57;These come in useful...  We should use them consistently and then document them,
58;thereby earning the eternal gratitude of any users who find themselves with a
59;ton of "foo.CL" files...
60(defparameter *.fasl-pathname*
61  (%cons-pathname nil nil
62                  #.(pathname-type
63                     (backend-target-fasl-pathname *target-backend*))))
64
65(defparameter *.lisp-pathname* (%cons-pathname nil nil "lisp"))
66
67(defun if-exists (if-exists filename &optional (prompt "Create ..."))
68  (case if-exists
69    (:error (signal-file-error (- #$EEXIST) filename))
70    ((:dialog) (overwrite-dialog filename prompt))
71    ((nil) nil)
72    ((:ignored :overwrite :append :supersede :rename-and-delete :new-version :rename) filename)
73    (t (report-bad-arg if-exists '(member :error :dialog nil :ignored :overwrite :append :supersede :rename-and-delete)))))
74
75(defun if-does-not-exist (if-does-not-exist filename)
76  (case if-does-not-exist 
77    (:error (signal-file-error (- #$ENOENT) filename)) ; (%err-disp $err-no-file filename))
78    (:create filename)
79    ((nil) (return-from if-does-not-exist nil))
80    (t (report-bad-arg if-does-not-exist '(member :error :create nil)))))
81
82
83(defun native-translated-namestring (path)
84  (let ((name (translated-namestring path)))
85    ;; Check that no quoted /'s
86    (when (%path-mem-last-quoted "/" name)
87      (signal-file-error $xbadfilenamechar name #\/))
88    ;; Check that no unquoted wildcards.
89    (when (%path-mem-last "*" name)
90      (signal-file-error $xillwild name))
91    (namestring-unquote name)))
92
93(defun native-untranslated-namestring (path)
94  (let ((name (namestring (translate-logical-pathname path))))
95    ;; Check that no quoted /'s
96    (when (%path-mem-last-quoted "/" name)
97      (signal-file-error $xbadfilenamechar name #\/))
98    ;; Check that no unquoted wildcards.
99    (when (%path-mem-last "*" name)
100      (signal-file-error $xillwild name))
101    (namestring-unquote name)))
102
103;; Reverse of above, take native namestring and make a Lisp pathname.
104(defun native-to-pathname (name)
105  (pathname (%path-std-quotes name nil
106                              #+windows-target "*;"
107                              #-windows-target "*;:")))
108
109(defun native-to-directory-pathname (name)
110  #+windows-target
111  (let* ((len (length name)))
112    (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/)
113                                  (eql (schar name (1- len)) #\\))))
114      (setq name (%str-cat name "/")))
115    (string-to-pathname name))
116  #-windows-target
117  (make-directory-pathname  :device nil :directory (%path-std-quotes name nil "*;:")))
118
119;;; Make a pathname which names the specified directory; use
120;;; explict :NAME, :TYPE, and :VERSION components of NIL.
121(defun make-directory-pathname (&key host device directory)
122  (make-pathname :host host
123                 :device device
124                 :directory directory
125                 :name nil
126                 :type nil
127                 :version nil))
128
129                   
130(defun %shrink-vector (vector to-size)
131  (cond ((eq (length vector) to-size)
132         vector)
133        ((array-has-fill-pointer-p vector)
134         (setf (fill-pointer vector) to-size)
135         vector)
136        (t (subseq vector 0 to-size))))
137
138(defun namestring-unquote (name)
139  #+(and windows-target bogus)
140  (when (and (> (length name) 1)
141             (eql (schar name 1) #\|))
142    (setq name (subseq name 0))
143    (setf (schar name 1) #\:))
144  (let ((esc *pathname-escape-character*))
145    (if (position esc name)
146      (multiple-value-bind (sstr start end) (get-sstring name)
147        (let ((result (make-string (%i- end start) :element-type 'base-char))
148              (dest 0))
149          (loop
150            (let ((pos (or (position esc sstr :start start :end end) end)))
151              (while (%i< start pos)
152                (setf (%schar result dest) (%schar sstr start)
153                      start (%i+ start 1)
154                      dest (%i+ dest 1)))
155              (when (eq pos end)
156                (return nil))
157              (setq start (%i+ pos 1))))
158          (shrink-vector result dest)))
159      name)))
160
161(defun translated-namestring (path)
162  (namestring (translate-logical-pathname (merge-pathnames path))))
163
164
165(defun truename (path)
166  "Return the pathname for the actual file described by PATHNAME.
167  An error of type FILE-ERROR is signalled if no such file exists,
168  or the pathname is wild.
169
170  Under Unix, the TRUENAME of a broken symlink is considered to be
171  the name of the broken symlink itself."
172  (or (probe-file path)
173      (signal-file-error $err-no-file path)))
174
175(defun check-pathname-not-wild (path)
176  (when (wild-pathname-p path)
177    (error 'file-error :error-type "Inappropriate use of wild pathname ~s"
178           :pathname path))
179  path)
180
181(defun probe-file (path)
182  "Return a pathname which is the truename of the file if it exists, or NIL
183  otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
184  (check-pathname-not-wild path)
185  (let* ((native (native-translated-namestring path))
186         (realpath (%realpath native))
187         (kind (if realpath (%unix-file-kind realpath))))
188    ;; Darwin's #_realpath will happily return non-nil for
189    ;; files that don't exist.  I don't think that
190    ;; %UNIX-FILE-KIND would do so.
191    (when kind
192      (if (eq kind :directory)
193          (unless (eq (aref realpath (1- (length realpath))) #\/)
194            (setq realpath (%str-cat realpath "/"))))
195      (if realpath
196        (native-to-pathname realpath)
197        nil))))
198
199(defun cwd (path) 
200  (multiple-value-bind (realpath kind) (%probe-file-x (native-translated-namestring path))
201    (if kind
202      (if (eq kind :directory)
203        (let* ((error (%chdir realpath)))
204          (if (eql error 0)
205            (mac-default-directory)
206            (signal-file-error error path)))
207        (error "~S is not a directory pathname." path))
208      (error "Invalid pathname : ~s." path))))
209
210(defun create-file (path &key (if-exists :error) (create-directory t))
211  (let* ((p (%create-file path :if-exists if-exists
212                                      :create-directory create-directory)))
213    (and p
214         (native-to-pathname p))))
215
216(defun %create-file (path &key
217                         (if-exists :error)
218                         (create-directory t))
219  (when create-directory
220    (create-directory path))
221  (when (directory-pathname-p path)
222    (return-from %create-file (probe-file-x path)))
223  (assert (or (eql if-exists :overwrite)
224              (null if-exists)
225              (eq if-exists :error)
226              (not (probe-file path))) ()
227          "~s ~s not implemented yet" :if-exists if-exists)
228  (let* ((unix-name (native-translated-namestring path))
229         (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC
230                                        (if (or (null if-exists)
231                                                (eq if-exists :error))
232                                          #$O_EXCL
233                                          0)))))
234    (if (< fd 0)
235      (if (and (null if-exists)
236               (eql fd (- #$EEXIST)))
237        (return-from %create-file nil)
238        (signal-file-error fd path))
239      (fd-close fd))
240    (%realpath unix-name)))
241
242
243;; The following assumptions are deeply embedded in all our pathname code:
244;; (1) Non-logical pathname host is always :unspecific.
245;; (2) Logical pathname host is never :unspecific.
246;; (3) Logical pathname host can however be NIL, e.g. "foo;bar;baz".
247
248(defun %pathname-host (pathname)
249  (if (logical-pathname-p pathname)
250      (%logical-pathname-host pathname)
251      :unspecific))
252
253(defun %pathname-version (pathname)
254  (if (logical-pathname-p pathname)
255    (%logical-pathname-version pathname)
256    (%physical-pathname-version pathname)))
257
258
259
260(defun pathname-host (thing)  ; redefined later in this file
261  (declare (ignore thing))
262  :unspecific)
263
264(defun pathname-version (thing)  ; redefined later in this file
265  (declare (ignore thing))
266  nil)
267
268(defmethod print-object ((pathname pathname) stream)
269  (let ((flags (if (logical-pathname-p pathname) 4
270                   (%i+ (if (eq (%pathname-type pathname) ':unspecific) 1 0)
271                        (if (equal (%pathname-name pathname) "") 2 0))))
272        (name (namestring pathname)))
273    (if (and (not *print-readably*) (not *print-escape*))
274      (write-string name stream)
275      (progn
276        (format stream (if (or *print-escape* (eql flags 0)) "#P" "#~DP") flags)
277        (write-escaped-string name stream #\")))))
278
279
280(defun mac-default-directory ()
281  (let* ((native-name (current-directory-name))
282         (len (length native-name)))
283    (declare (fixnum len))
284    (when (and (> len 1)
285               (not (eq #\/ (schar native-name (1- len)))))
286      (setq native-name (%str-cat native-name "/")))
287    (native-to-pathname native-name)))
288
289
290
291
292;;; I thought I wanted to call this from elsewhere but perhaps not
293(defun absolute-directory-list (dirlist)
294  ; just make relative absolute and remove ups where possible
295  (when (or (null dirlist) (eq (car dirlist) :relative))
296    (let ((default (mac-default-directory)) default-dir)
297      (when default
298        (setq default-dir (%pathname-directory default))
299        (when default-dir
300          (setq dirlist (append default-dir (cdr dirlist)))))))
301  (when (memq :up dirlist)
302    (setq dirlist (remove-up (copy-list dirlist))))
303  dirlist)
304
305; destructively mungs dir
306(defun remove-up (dir)
307  (setq dir (delete "." dir  :test #'string=))
308  (let ((n 0)
309        (last nil)
310        (sub dir)
311        has-abs kept-up)
312    ;; from %std-directory-component we get dir with :relative/:absolute stripped
313    (when (memq :up dir)
314      (when (memq (car dir) '(:relative :absolute))
315        (setq sub (cdr dir) n 1 has-abs t))
316      (do () ((null sub))
317        (cond ((eq (car sub) :up)
318               (cond ((or (eq n 0)
319                          (and (stringp last)(string= last "**"))
320                          (eq last :wild-inferiors)
321                          kept-up
322                          (and has-abs (eq n 1)))
323                      ;; up after "**" stays, initial :up stays, how bout 2 :ups
324                      (setq kept-up t)
325                      )
326                     ((eq n 1) (setq dir (cddr dir) kept-up nil n -1))
327                     (t (rplacd (nthcdr (- n 2) dir) (cdr sub))
328                        (setq n (- n 2) kept-up nil))))
329              (t (setq kept-up nil)))
330        (setq last (car sub)
331              n (1+ n) 
332              sub (cdr sub))))
333    dir))
334
335(defun namestring (path)
336  "Construct the full (name)string form of the pathname."
337  (%str-cat (device-namestring path)
338            (host-namestring path)
339            (directory-namestring path)
340            (file-namestring path)))
341
342(defun device-namestring (path)
343  (let* ((device (pathname-device path)))
344    (if (and device (not (eq device :unspecific)))
345      (%str-cat device ":")
346      "")))
347
348(defun host-namestring (path)
349  "Return a string representation of the name of the host in the pathname."
350  (let ((host (pathname-host path)))
351    (if (and host (neq host :unspecific)) (%str-cat host ":") "")))
352
353(defun directory-namestring (path)
354  "Return a string representation of the directories used in the pathname."
355  (%directory-list-namestring (pathname-directory path)
356                              (neq (pathname-host path) :unspecific)))
357
358(defun ensure-directory-namestring (string)
359  (namestring (ensure-directory-pathname string)))
360
361(defun ensure-directory-pathname (pathname)
362  (let ((path (pathname pathname)))
363    (if (directory-pathname-p path)
364        path
365        (cons-pathname (append (or (pathname-directory path)
366                                   ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not
367                                   ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/").
368                                   (if (eq (pathname-host path) :unspecific)
369                                       '(:relative)
370                                       '(:absolute)))
371                               ;; Don't use file-namestring, because that
372                               ;; includes the version for logical names.
373                               (list (file-namestring-from-parts
374                                      (pathname-name path)
375                                      (pathname-type path)
376                                      nil)))
377                       nil nil (pathname-host path)))))
378
379(defun %directory-list-namestring (list &optional logical-p)
380  (if (null list)
381    ""
382    (let ((len (if (eq (car list) (if logical-p :relative :absolute)) 1 0))
383
384          result)
385      (declare (fixnum len)(optimize (speed 3)(safety 0)))
386      (dolist (s (%cdr list))
387        (case s
388          (:wild (setq len (+ len 2)))
389          (:wild-inferiors (setq len (+ len 3)))
390          (:up (setq len (+ len 3)))
391          (t ;This assumes that special chars in dir components are escaped,
392             ;otherwise would have to pre-scan for escapes here.
393           (setq len (+ len 1 (length s))))))
394      (setq result
395            (make-string len))
396      (let ((i 0)
397            (sep (if logical-p #\; #\/)))
398        (declare (fixnum i))
399        (when (eq (%car list) (if logical-p :relative :absolute))
400          (setf (%schar result 0) sep)
401          (setq i 1))
402        (dolist (s (%cdr list))
403          (case s
404            (:wild (setq s "*"))
405            (:wild-inferiors (setq s "**"))
406            ;; There is no :up in logical pathnames, so this must be native
407            (:up (setq s "..")))
408          (let ((len (length s)))
409            (declare (fixnum len))
410            (move-string-bytes s result 0 i len)
411            (setq i (+ i len)))
412          (setf (%schar result i) sep)
413          (setq i (1+ i))))
414      result)))
415
416(defun file-namestring (path)
417  "Return a string representation of the name used in the pathname."
418  (let* ((path (pathname path))
419         (name (pathname-name path))
420         (type (pathname-type path))
421         (version (if (typep path 'logical-pathname) (pathname-version path))))
422    (file-namestring-from-parts name type version)))
423
424(defun file-namestring-from-parts (name type version)
425  (when (eq version :unspecific) (setq version nil))
426  (when (eq type :unspecific) (setq type nil))
427  (%str-cat (case name
428              ((nil :unspecific) "")
429              (:wild "*")
430              (t (%path-std-quotes name "*;:" ".")))
431            (if (or type version)
432              (%str-cat (case type
433                          ((nil) ".")
434                          (:wild ".*")
435                          (t (%str-cat "." (%path-std-quotes type "*;:" "."))))
436                        (case version
437                          ((nil) "")
438                          (:newest ".newest")
439                          (:wild ".*")
440                          (t (%str-cat "." (if (fixnump version)
441                                             (%integer-to-string version)
442                                             version)))))
443              "")))
444
445(defun enough-namestring (path &optional (defaults *default-pathname-defaults*))
446  "Return an abbreviated pathname sufficent to identify the pathname relative
447   to the defaults."
448  (if (null defaults)
449    (namestring path)
450    (let* ((dir (pathname-directory path))
451           (nam (pathname-name path))
452           (typ (pathname-type path))
453           (ver (pathname-version path))
454           (host (pathname-host path))
455           (logical-p (neq host :unspecific))
456           (default-dir (pathname-directory defaults)))
457      ;; enough-host-namestring
458      (setq host (if (and host
459                          (neq host :unspecific)
460                          (not (equalp host (pathname-host defaults))))
461                   (%str-cat host ":")
462                   ""))
463      ;; enough-directory-namestring
464      (cond ((equalp dir default-dir)
465             (setq dir '(:relative)))
466            ((and dir default-dir
467                  (eq (car dir) :absolute) (eq (car default-dir) :absolute))
468             ;; maybe make it relative to defaults             
469             (do ((p1 (cdr dir) (cdr p1))
470                  (p2 (cdr default-dir) (cdr p2)))
471                 ((or (null p2) (null p1) (not (equalp (car p1) (car p2))))
472                  (when (and (null p2) (or t (neq p1 (cdr dir))))
473                    (setq dir (cons :relative p1)))))))
474      (setq dir (%directory-list-namestring dir logical-p))
475      ;; enough-file-namestring
476      (when (or (equalp ver (pathname-version defaults))
477                (not logical-p))
478        (setq ver nil))
479      (when (and (null ver) (equalp typ (pathname-type defaults)))
480        (setq typ nil))
481      (when (and (null typ) (equalp nam (pathname-name defaults)))
482        (setq nam nil))
483      (setq nam (file-namestring-from-parts nam typ ver))
484      (%str-cat host dir nam))))
485
486(defun cons-pathname (dir name type &optional host version device)
487  (if (neq host :unspecific)
488    (%cons-logical-pathname dir name type host version)
489    (%cons-pathname dir name type version device)))
490
491(defun pathname (path)
492  "Convert thing (a pathname, string or stream) into a pathname."
493  (etypecase path
494    (pathname path)
495    (stream (%path-from-stream path))
496    (string (string-to-pathname path))))
497
498(defun %path-from-stream (stream)
499  (or (stream-filename stream) (error "Can't determine pathname of ~S ." stream)))      ; ???
500
501;Like (pathname stream) except returns NIL rather than error when there's no
502;filename associated with the stream.
503(defun stream-pathname (stream &aux (path (stream-filename stream)))
504  (when path (pathname path)))
505
506(defun string-to-pathname (string &optional (start 0) (end (length string))
507                                            (reference-host nil)
508                                            (defaults *default-pathname-defaults*))
509  (require-type reference-host '(or null string))
510  (multiple-value-bind (sstr start end) (get-sstring string start end)
511    #-windows-target
512    (if (and (> end start)
513             (eql (schar sstr start) #\~))
514      (setq sstr (tilde-expand (subseq sstr start end))
515            start 0
516            end (length sstr)))
517    (let (directory name type host version device (start-pos start) (end-pos end) has-slashes)
518      (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos))
519      (cond ((and host (neq host :unspecific))
520             (when (and reference-host (not (string-equal reference-host host)))
521               (error "Host in ~S does not match requested host ~S"
522                      (%substr sstr start end) reference-host)))
523            ((or reference-host
524                 (and defaults
525                      (neq (setq reference-host (pathname-host defaults)) :unspecific)))
526             ;;If either a reference-host is specified or defaults is a logical pathname
527             ;; then the string must be interpreted as a logical pathname.
528             (when has-slashes
529               (error "Illegal logical namestring ~S" (%substr sstr start end)))
530             (setq host reference-host)))
531      #+windows-target
532      (when (and (eq host :unspecific)
533                 (eql start-pos 0)
534                 (eql (position #\: sstr) 1))
535        (let* ((ch (schar sstr 0)))
536          (when (and (alpha-char-p ch)
537                     (standard-char-p ch))
538            (setq device (make-string 1 :initial-element ch)
539                  start-pos 2))))
540      (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host))
541      (unless (eq host :unspecific)
542        (multiple-value-setq (version end-pos) (pathname-version-sstr sstr start-pos end-pos)))
543      (multiple-value-setq (type end-pos) (pathname-type-sstr sstr start-pos end-pos))
544      ;; now everything else is the name
545      (unless (eq start-pos end-pos)
546        (setq name (%std-name-component (%substr sstr start-pos end-pos))))
547      (if (eq host :unspecific)
548        (%cons-pathname directory name type (if name :newest) device)
549        (%cons-logical-pathname directory name type host version)))))
550
551(defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*)
552                               &key (start 0) end junk-allowed)
553  (declare (ignore junk-allowed))
554  (unless (typep thing 'string)
555    (let* ((path (pathname thing))
556           (pathname-host (pathname-host path)))
557      (when (and host pathname-host
558                 (or (eq pathname-host :unspecific) ;physical
559                     (not (string-equal host pathname-host))))
560        (error "Host in ~S does not match requested host ~S" path host))
561      (return-from parse-namestring (values path start))))
562  (when host
563    (verify-logical-host-name host))
564  (setq end (check-sequence-bounds thing start end))
565  (values (string-to-pathname thing start end host defaults) end))
566
567
568
569(defun %std-device-component (device host)
570  (when (and (or (null host) (eq host :unspecific))
571             (and device (not (eq device :unspecific))))
572    #+windows-target
573    (unless (and (typep device 'string)
574                 (eql (length device) 1)
575                 (alpha-char-p (char device 0))
576                 (standard-char-p (char device 0)))
577      (error "Invalid pathname device ~s" device))
578    device))
579   
580(defun make-pathname (&key (host nil host-p) 
581                           (device nil device-p)
582                           (directory nil directory-p)
583                           (name nil name-p)
584                           (type nil type-p)
585                           (version nil version-p)
586                           (defaults nil defaults-p) case
587                           &aux path)
588  "Makes a new pathname from the component arguments. Note that host is
589a host-structure or string."
590  (when case (setq case (require-type case pathname-case-type)))
591  (if (null host-p)
592    (let ((defaulted-defaults (if defaults-p defaults *default-pathname-defaults*)))
593      (setq host (if defaulted-defaults
594                   (pathname-host defaulted-defaults)
595                   :unspecific)))
596    (unless host (setq host :unspecific)))
597  (if directory-p 
598    (setq directory (%std-directory-component directory host)))
599  (if (and defaults (not directory-p))
600    (setq directory (pathname-directory defaults)))
601  (if (and defaults (not device-p))
602    (setq device (pathname-device defaults)))
603  (setq device (%std-device-component device host))
604  (setq name
605        (if name-p
606             (%std-name-component name)
607             (and defaults (pathname-name defaults))))
608  (setq type
609        (if type-p
610             (%std-type-component type)
611             (and defaults (pathname-type defaults))))
612  (setq version (if version-p
613                  (%logical-version-component version)
614                  (if name-p
615                    nil
616                    (and defaults (pathname-version defaults)))))
617  (setq path
618        (if (eq host :unspecific)
619          (%cons-pathname directory name type version device)
620          (%cons-logical-pathname
621           (or directory
622               (unless directory-p '(:absolute)))
623           name type host version)))
624  (when (and (eq (car directory) :absolute)
625             (member (cadr directory) '(:up :back)))
626    (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory))))
627  (let* ((after-wif (cadr (member :wild-inferiors directory))))
628    (when (member after-wif '(:up :back))
629          (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif))))
630         
631  (when (and case (neq case :local))
632    (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)
633          (%pathname-name path) (%reverse-component-case (%pathname-name path) case)
634          (%pathname-type path) (%reverse-component-case (%pathname-type path) case)))
635  path)
636
637;;;  In portable CL, if the :directory argument to make pathname is a
638;;;  string, it should be the name of a top-level directory and should
639;;;  not contain any punctuation characters such as "/" or ";".  In
640;;;  MCL a string :directory argument with slashes or semi-colons will
641;;;  be parsed as a directory in the obvious way.
642(defun %std-directory-component (directory host)
643  (cond ((null directory) nil)
644        ((eq directory :wild) '(:absolute :wild-inferiors))
645        ((stringp directory) (%directory-string-list directory 0 (length directory) host))
646        ((listp directory)
647         ;Standardize the directory list, taking care not to cons if nothing
648         ;needs to be changed.
649         (let ((names (%cdr directory)) (new-names ()))
650           (do ((nn names (%cdr nn)))
651               ((null nn) (setq new-names (if new-names (nreverse new-names) names)))
652             (let* ((name (car nn))
653                    (new-name (%std-directory-part name)))
654               (unless (eq name new-name)
655                 (unless new-names
656                   (do ((new-nn names (%cdr new-nn)))
657                       ((eq new-nn nn))
658                     (push (%car new-nn) new-names))))
659               (when (or new-names (neq name new-name))
660                 (push new-name new-names))))
661           (when (memq :up (or new-names names))
662             (setq new-names (remove-up (copy-list (or new-names names)))))
663           (ecase (%car directory)
664             (:relative           
665                  (cond (new-names         ; Just (:relative) is the same as NIL. - no it isnt
666                         (if (eq new-names names)
667                           directory
668                           (cons ':relative new-names)))
669                        (t directory)))
670             (:absolute
671                  (cond ((null new-names) directory)  ; But just (:absolute) IS the same as NIL
672                        ((eq new-names names) directory)
673                        (t (cons ':absolute new-names)))))))
674        (t (report-bad-arg directory '(or string list (member :wild))))))
675
676(defun %std-directory-part (name)
677  (case name
678    ((:wild :wild-inferiors :up) name)
679    (:back :up)
680    (t (cond ((string= name "*") :wild)
681             ((string= name "**") :wild-inferiors)
682             ((string= name "..") :up)
683             (t (%path-std-quotes name "/:;*" "/:;"))))))
684
685; this will allow creation of garbage pathname "foo:bar;bas:" do we care?
686(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*)
687                                       (default-version :newest))
688  "Construct a filled in pathname by completing the unspecified components
689   from the defaults."
690  ;(declare (ignore default-version))
691  (when (not (pathnamep path))(setq path (pathname path)))
692  (when (and defaults (not (pathnamep defaults)))(setq defaults (pathname defaults)))
693  (let* ((path-dir (pathname-directory path))
694         (path-host (pathname-host path))
695         (path-name (pathname-name path))
696         (path-type (pathname-type path))
697         (path-device (pathname-device path))
698         (default-dir (and defaults (pathname-directory defaults)))
699         (default-host (and defaults (pathname-host defaults)))
700         (default-device (and defaults (pathname-device defaults)))
701         ; take host from defaults iff path-dir is logical or absent - huh?
702         (host (cond ((or (null path-host)  ; added 7/96
703                          (and (eq path-host :unspecific)
704                               (or (null path-dir)
705                                   (null (cdr path-dir))
706                                   (and (eq :relative (car path-dir))
707                                        (not (memq default-host '(nil :unspecific)))))))
708                         
709                      default-host)
710                     (t  path-host)))
711         (dir (cond ((null path-dir) default-dir)
712                    ((null default-dir) path-dir)
713                    ((eq (car path-dir) ':relative)
714                     (let ((the-dir (append default-dir (%cdr path-dir))))
715                       (when (memq ':up the-dir)(setq the-dir (remove-up (copy-list the-dir))))
716                       the-dir))
717                    (t path-dir)))
718         (nam (or path-name
719                  (and defaults (pathname-name defaults))))
720         (typ (or path-type
721                  (and defaults (pathname-type defaults))))
722         (version (or (pathname-version path)
723                      (cond ((not path-name)
724                             (or (and defaults (pathname-version defaults))
725                                 default-version))
726                            (t default-version))))
727         (device (or path-device default-device)))
728    (if (and (pathnamep path)
729             (eq dir (%pathname-directory path))
730             (eq nam path-name)
731             (eq typ (%pathname-type path))
732             (eq host path-host)
733             (eq device path-device)
734             (eq version (pathname-version path)))
735      path 
736      (cons-pathname dir nam typ host version device))))
737
738(defun directory-pathname-p (path)
739  (let ((name (pathname-name path))(type (pathname-type path)))
740    (and  (or (null name) (eq name :unspecific) (%izerop (length name)))
741          (or (null type) (eq type :unspecific)))))
742
743;In CCL, a pathname is logical if and only if pathname-host is not :unspecific.
744(defun pathname-host (thing &key case)
745  "Return PATHNAME's host."
746  (when (streamp thing)(setq thing (%path-from-stream thing)))
747  (when case (setq case (require-type case pathname-case-type)))
748  (let ((name
749         (typecase thing   
750           (logical-pathname (%logical-pathname-host thing))
751           (pathname :unspecific)
752           (string (multiple-value-bind (sstr start end) (get-sstring thing) 
753                     (pathname-host-sstr sstr start end)))
754           (t (report-bad-arg thing pathname-arg-type)))))
755    (if (and case (neq case :local))
756      (progn
757        (when (and (eq case :common) (neq name :unspecific)) (setq case :logical))
758        (%reverse-component-case name case))
759      name)))
760
761(defun pathname-host-sstr (sstr start end &optional no-check)
762  ;; A pathname with any (unescaped) /'s is always a physical pathname.
763  ;; Otherwise, if the pathname has either a : or a ;, then it's always logical.
764  ;; Otherwise, it's probably physical.
765  ;; Return :unspecific for physical, host string or nil for a logical.
766  (let* ((slash (%path-mem "/" sstr start end))
767         (pos (and (not slash) (%path-mem ":;" sstr start end)))
768         (pos-char (and pos (%schar sstr pos)))
769         (host (and (eql pos-char #\:) (%substr sstr start pos))))
770    (cond (host
771           (unless (or no-check (logical-host-p host))
772             (error "~S is not a defined logical host" host))
773           (values host (%i+ pos 1) nil))
774          ((eql pos-char #\;) ; logical pathname with missing host
775           (values nil start nil))
776          (t ;else a physical pathname.
777           (values :unspecific start slash)))))
778
779
780(defun pathname-device (thing &key case)
781  "Return PATHNAME's device."
782  (declare (ignore case))
783  (let* ((p (pathname thing)))
784    (etypecase p
785      (logical-pathname :unspecific)
786      (pathname (%physical-pathname-device p)))))
787
788
789
790;A directory is either NIL or a (possibly wildcarded) string ending in "/" or ";"
791;Quoted /'s are allowed at this stage, though will get an error when go to the
792;filesystem.
793(defun pathname-directory (path &key case)
794  "Return PATHNAME's directory."
795  (when (streamp path) (setq path (%path-from-stream path)))
796  (when case (setq case (require-type case pathname-case-type)))
797  (let* ((logical-p nil)
798         (names (typecase path
799                  (logical-pathname (setq logical-p t) (%pathname-directory path))
800                  (pathname (%pathname-directory path))
801                  (string
802                   (multiple-value-bind (sstr start end) (get-sstring path)
803                     #+no
804                     (if (and (> end start)
805                              (eql (schar sstr start) #\~))
806                       (setq sstr (tilde-expand (subseq sstr start end))
807                             start 0
808                             end (length sstr)))
809                     (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
810                       (unless (eq host :unspecific) (setq logical-p t))
811                       #+windows-target
812                       (unless logical-p
813                         (if (and (> end 1)
814                                  (eql (schar sstr 1) #\:))
815                           (setq pos2 2)))
816                      (pathname-directory-sstr sstr pos2 end host))))
817                  (t (report-bad-arg path pathname-arg-type)))))
818    (if (and case (neq case :local))
819      (progn
820        (when (and (eq case :common) logical-p) (setq case :logical))
821        (%reverse-component-case names case))
822      names)))
823
824;; Must match pathname-directory-end below
825(defun pathname-directory-sstr (sstr start end host)
826  (if (and (eq host :unspecific)
827           (> end start)
828           (eql (schar sstr start) #\~))
829    (setq sstr (tilde-expand (subseq sstr start end))
830          start 0
831          end (length sstr)))
832  (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr start end)))
833    (if pos
834      (values 
835       (%directory-string-list sstr start (setq pos (%i+ pos 1)) host)
836       pos)
837      (values (and (neq host :unspecific)
838                   (neq start end)
839                   '(:absolute))
840              start))))
841
842;; Must match pathname-directory-sstr above
843(defun pathname-directory-end (sstr start end)
844  (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
845    (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr pos2 end)))
846      (if pos
847        (values (%i+ pos 1) host)
848        (values pos2 host)))))
849
850(defun %directory-string-list (sstr start &optional (end (length sstr)) host)
851  ;; Should use host to split by / vs. ; but for now suport both for either host,
852  ;; like the mac version. It means that ';' has to be quoted in unix pathnames.
853  (declare (ignore host))
854  ;This must cons up a fresh list, %expand-logical-directory rplacd's it.
855  (labels ((std-part (sstr start end)
856             (%std-directory-part (if (and (eq start 0) (eq end (length sstr)))
857                                    sstr (%substr sstr start end))))
858           (split (sstr start end)
859             (unless (eql start end)
860               (let ((pos (%path-mem "/;" sstr start end)))
861                 (if (eq pos start)
862                   (split sstr (%i+ start 1) end) ;; treat multiple ////'s as one.
863                   (cons (std-part sstr start (or pos end))
864                         (when pos
865                           (split sstr (%i+ pos 1) end))))))))
866    (unless (eq start end)
867      (let* ((slash-pos (%path-mem "/" sstr start end))
868             (semi-pos (%path-mem ";" sstr start end))
869             (pos (or slash-pos semi-pos)))
870        ; this never did anything sensible but did not signal an error
871        (when (and slash-pos semi-pos)
872          (error "Illegal directory string ~s" (%substr sstr start end)))
873        (if (null pos)
874          (list :relative (std-part sstr start end))
875          (let ((pos-char (%schar sstr pos)))
876            (cons (if (eq pos start)
877                    (if (eq pos-char #\/) ':absolute ':relative)
878                    (if (eq pos-char #\/) ':relative ':absolute))
879                  (split sstr start end))))))))
880
881(defun pathname-version (path)
882  "Return PATHNAME's version."
883  (when (streamp path) (setq path (%path-from-stream path)))
884  (typecase path
885    (logical-pathname (%logical-pathname-version path))
886    (pathname (%physical-pathname-version path))
887    (string
888     (multiple-value-bind (sstr start end) (get-sstring path)
889       (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
890         (if (eq host :unspecific)
891           nil
892           (pathname-version-sstr sstr newstart end)))))
893    (t (report-bad-arg path pathname-arg-type))))
894
895(defun pathname-version-sstr (sstr start end)
896  (declare (fixnum start end))
897  (let ((pos (%path-mem-last "." sstr start end)))
898    (if (and pos (%i> pos start) (%path-mem "." sstr start (%i- pos 1)))
899      (values (%std-version-component (%substr sstr (%i+ pos 1) end)) pos)
900      (values nil end))))
901
902(defun %std-version-component (v)
903  (cond ((or (null v) (eq v :unspecific)) v)
904        ((eq v :wild) "*")
905        ((string= v "") :unspecific)
906        ((string-equal v "newest") :newest)
907        ((every #'digit-char-p v) (parse-integer v))
908        (t (%path-std-quotes v "./:;*" "./:;"))))
909
910
911;A name is either NIL or a (possibly wildcarded, possibly empty) string.
912;Quoted /'s are allowed at this stage, though will get an error if go to the
913;filesystem.
914(defun pathname-name (path &key case)
915  "Return PATHNAME's name."
916  (when (streamp path) (setq path (%path-from-stream path)))
917  (when case (setq case (require-type case pathname-case-type)))
918  (let* ((logical-p nil)
919         (name (typecase path
920                 (logical-pathname (setq logical-p t) (%pathname-name path))
921                 (pathname (%pathname-name path))
922                 (string
923                  (multiple-value-bind (sstr start end) (get-sstring path)
924                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
925                      (setq start newstart)
926                      (unless (eq host :unspecific)
927                        (setq logical-p t)
928                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
929                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
930                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
931                      ;; for native.
932                      (setq end (or (%path-mem-last "." sstr start end) end));; strip off type
933                      (unless (eq start end)
934                        (%std-name-component (%substr sstr start end))))))
935                 (t (report-bad-arg path pathname-arg-type)))))
936    (if (and case (neq case :local))
937      (progn
938        (when (and (eq case :common) logical-p) (setq case :logical))
939        (%reverse-component-case name case))
940      name)))
941
942(defun %std-name-component (name)
943  (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name)
944        ((equal name "*") :wild)
945        (t (%path-std-quotes name "/:;*" "/:;"))))
946
947;A type is either NIL or a (possibly wildcarded, possibly empty) string.
948;Quoted :'s are allowed at this stage, though will get an error if go to the
949;filesystem.
950(defun pathname-type (path &key case)
951  "Return PATHNAME's type."
952  (when (streamp path) (setq path (%path-from-stream path)))
953  (when case (setq case (require-type case pathname-case-type)))
954  (let* ((logical-p nil)
955         (name (typecase path
956                 (logical-pathname (setq logical-p t) (%pathname-type path))
957                 (pathname (%pathname-type path))
958                 (string
959                  (multiple-value-bind (sstr start end) (get-sstring path)
960                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
961                      (setq start newstart)
962                      (unless (eq host :unspecific)
963                        (setq logical-p t)
964                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
965                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
966                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
967                      ;; for native.
968                      (pathname-type-sstr sstr start end))))
969                 (t (report-bad-arg path pathname-arg-type)))))
970    (if (and case (neq case :local))
971      (progn
972        (when (and (eq case :common) logical-p) (setq case :logical))
973        (%reverse-component-case name case))
974      name)))
975
976; assumes dir & version if any has been stripped away
977(defun pathname-type-sstr (sstr start end)
978  (let ((pos (%path-mem-last "." sstr start end)))
979    (if pos
980      (values (%std-type-component (%substr sstr (%i+ 1 pos) end)) pos)
981      (values nil end))))
982
983(defun %std-type-component (type)
984  (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type)
985        ((equal type "*") :wild)
986        (t (%path-std-quotes type "./:;*" "./:;"))))
987
988(defun %std-name-and-type (native)
989  (let* ((end (length native))
990         (pos (position #\. native :from-end t))
991         (type (and pos
992                    (%path-std-quotes (%substr native (%i+ 1 pos) end)
993                                      nil "/:;*")))
994         (name (unless (eq (or pos end) 0)
995                 (%path-std-quotes (if pos (%substr native 0 pos) native)
996                                   nil "/:;*"))))
997    (values name type)))
998
999(defun %reverse-component-case (name case)
1000  (cond ((not (stringp name))
1001         (if (listp name)
1002           (mapcar #'(lambda (name) (%reverse-component-case name case))  name)
1003           name))
1004        #+advanced-studlification-feature
1005        ((eq case :studly) (string-studlify name))
1006        ((eq case :logical)
1007         (if (every #'(lambda (ch) (not (lower-case-p ch))) name)
1008           name
1009           (string-upcase name)))
1010        (t ; like %read-idiocy but non-destructive - need it be?
1011         (let ((which nil)
1012               (len (length name)))
1013           (dotimes (i len)
1014             (let ((c (%schar name i)))
1015               (if (alpha-char-p c)
1016                 (if (upper-case-p c)
1017                   (progn
1018                     (when (eq which :lower)(return-from %reverse-component-case name))
1019                     (setq which :upper))
1020                   (progn
1021                     (when (eq which :upper)(return-from %reverse-component-case name))
1022                     (setq which :lower))))))
1023           (case which
1024             (:lower (string-upcase name))
1025             (:upper (string-downcase name))
1026             (t name))))))
1027
1028;;;;;;; String-with-quotes utilities
1029(defun %path-mem-last-quoted (chars sstr &optional (start 0) (end (length sstr)))
1030  (while (%i< start end)
1031    (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars)
1032               (%path-quoted-p sstr end start))
1033      (return-from %path-mem-last-quoted end))))
1034
1035(defun %path-mem-last (chars sstr &optional (start 0) (end (length sstr)))
1036  (while (%i< start end)
1037    (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars)
1038               (not (%path-quoted-p sstr end start)))
1039      (return-from %path-mem-last end))))
1040
1041(defun %path-mem (chars sstr &optional (start 0) (end (length sstr)))
1042  (let ((one-char (when (eq (length chars) 1) (%schar chars 0))))
1043    (while (%i< start end)
1044      (let ((char (%schar sstr start)))
1045        (when (if one-char (eq char one-char)(%%str-member char chars))
1046          (return-from %path-mem start))
1047        (when (eq char *pathname-escape-character*)
1048          (setq start (%i+ start 1)))
1049        (setq start (%i+ start 1))))))
1050
1051; these for \:  meaning this aint a logical host. Only legal for top level dir
1052 
1053(defun %path-unquote-one-quoted (chars sstr &optional (start 0)(end (length sstr)))
1054  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1055    (when (and pos (neq pos 1))
1056      (cond ((or (%path-mem chars sstr start (1- pos))
1057                 (%path-mem-last-quoted chars sstr start (1- pos)))
1058             nil)
1059            (t (%str-cat (%substr sstr start (1- pos))(%substr sstr  pos end)))))))
1060
1061(defun %path-one-quoted-p (chars sstr &optional (start 0)(end (length sstr)))
1062  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1063    (when (and pos (neq pos 1))
1064      (not (or (%path-mem-last-quoted chars sstr start (1- pos))
1065               (%path-mem chars sstr start (1- pos)))))))
1066 
1067(defun %path-quoted-p (sstr pos start &aux (esc *pathname-escape-character*) (q nil))
1068  (while (and (%i> pos start) (eq (%schar sstr (setq pos (%i- pos 1))) esc))
1069    (setq q (not q)))
1070  q)
1071
1072
1073
1074;Standardize pathname quoting, so can do EQUAL.
1075;; Subtle point: when keep-quoted is NIL, arg is assumed native,
1076;; and therefore escape characters are made quoted.
1077;; if keep-quoted is not NIL, e.g. if it's "", arg is assumed
1078;;   to be escaped already, so escape chars are interpreted as quotes.
1079;; Note that this can't be used to remove quotes because it
1080;; always keeps the escape character quoted.
1081(defun %path-std-quotes (arg keep-quoted make-quoted)
1082  (when (symbolp arg)
1083    (error "Invalid pathname component ~S" arg))
1084  (let* ((str arg)
1085         (esc *pathname-escape-character*)
1086         (end (length str))
1087         res-str char)
1088    (multiple-value-bind (sstr start)(array-data-and-offset str)
1089      (setq end (+ start end))
1090      (let ((i start))
1091        (until (eq i end)
1092          (setq char (%schar sstr i))
1093          (cond ((or (%%str-member char make-quoted)
1094                     (and (null keep-quoted) (eq char esc)))
1095                 (unless res-str
1096                   (setq res-str (make-array (%i- end start)
1097                                             :element-type (array-element-type sstr)
1098                                             :adjustable t :fill-pointer 0))
1099                   (do ((j start (%i+ j 1))) ((eq j i))
1100                     (vector-push-extend (%schar sstr j) res-str)))
1101                 (vector-push-extend esc res-str))
1102                ((neq char esc) nil)
1103                ((eq (setq i (%i+ i 1)) end)
1104                 (error "Malformed pathname component string ~S" str))
1105                ((or (eq (setq char (%schar sstr i)) esc)
1106                     (%%str-member char keep-quoted))
1107                 (when res-str (vector-push-extend esc res-str)))
1108                (t
1109                 (unless res-str
1110                   (setq res-str (make-array (%i- end start)
1111                                             :element-type (array-element-type sstr)
1112                                             :adjustable t :fill-pointer 0))
1113                   (do ((j start (%i+ j 1)) (end (%i- i 1))) ((eq j end))
1114                     (vector-push-extend (%schar sstr j) res-str)))))
1115          (when res-str (vector-push-extend char res-str))
1116          (setq i (%i+ i 1)))
1117        (ensure-simple-string (or res-str str))))))
1118
1119
1120
1121(defun %%str-member (char string)
1122  (locally (declare (optimize (speed 3)(safety 0)))
1123    (dotimes (i (the fixnum (length string)))
1124      (when (eq (%schar string i) char)
1125        (return i)))))
1126
1127
1128(defun file-write-date (path)
1129  "Return file's creation date, or NIL if it doesn't exist.
1130  An error of type file-error is signaled if file is a wild pathname"
1131  (%file-write-date (native-translated-namestring path)))
1132
1133(defun file-author (path)
1134  "Return the file author as a string, or NIL if the author cannot be
1135  determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
1136  or FILE is a wild pathname."
1137  (%file-author (native-translated-namestring path)))
1138
1139(defun touch (path)
1140  (if (not (probe-file path))
1141    (progn
1142      (ensure-directories-exist path)
1143      (if (or (pathname-name path)
1144              (pathname-type path))
1145        (create-file path)))
1146    (%utimes (native-translated-namestring path)))
1147  t)
1148
1149
1150;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
1151; load, require, provide
1152
1153(defun find-load-file (file-name)
1154  (let ((full-name (full-pathname file-name :no-error nil))
1155        (kind nil))
1156    (when full-name
1157      (when (eq (pathname-host file-name) :unspecific) ;; if physical pathname to begin with, force absolute
1158        (setq file-name full-name))
1159      (let ((file-type (pathname-type full-name)))
1160        (if (and file-type (neq file-type :unspecific))
1161          (values (probe-file full-name) file-name file-name)
1162          (let* ((source (merge-pathnames file-name *.lisp-pathname*))
1163                 (fasl   (merge-pathnames file-name *.fasl-pathname*))
1164                 (true-source (probe-file source))
1165                 (true-fasl   (probe-file fasl)))
1166            (cond (true-source
1167                   (if (and true-fasl
1168                            (> (file-write-date true-fasl)
1169                               (file-write-date true-source)))
1170                     (values true-fasl fasl source)
1171                     (values true-source source source)))
1172                  (true-fasl
1173                   (values true-fasl fasl fasl))
1174                  ((and (multiple-value-setq (full-name kind)
1175                          (let* ((realpath (%realpath (native-translated-namestring full-name))))
1176                            (if realpath
1177                              (%probe-file-x realpath ))))
1178                        (eq kind :file))
1179                   (values full-name file-name file-name)))))))))
1180
1181
1182
1183
1184
1185(defun load (file-name &key (verbose *load-verbose*)
1186                       (print *load-print*)
1187                       (if-does-not-exist :error)
1188                       (external-format :default))
1189  "Load the file given by FILESPEC into the Lisp environment, returning
1190   T on success.
1191
1192   Extension: :PRINT :SOURCE means print source as well as value"
1193  (loop
1194    (restart-case
1195      (return (%load file-name verbose print if-does-not-exist external-format))
1196      (retry-load ()
1197                  :report (lambda (stream) (format stream "Retry loading ~s" file-name)))
1198      (skip-load ()
1199                 :report (lambda (stream) (format stream "Skip loading ~s" file-name))
1200                 (return nil))
1201      (load-other ()
1202                  :report (lambda (stream) (format stream "Load other file instead of ~s" file-name))
1203                  (return
1204                   (load (choose-file-dialog)
1205                         :verbose verbose
1206                         :print print
1207                         :if-does-not-exist if-does-not-exist))))))
1208
1209
1210(defun %load (file-name verbose print if-does-not-exist external-format)
1211  (let ((*load-pathname* file-name)
1212        (*load-truename* file-name)
1213        (source-file file-name)
1214        ;; Don't bind these: let OPTIMIZE proclamations/declamations
1215        ;; persist, unless debugging.
1216        #|
1217        (*nx-speed* *nx-speed*)
1218        (*nx-space* *nx-space*)
1219        (*nx-safety* *nx-safety*)
1220        (*nx-debug* *nx-debug*)
1221        (*nx-cspeed* *nx-cspeed*)
1222        |#
1223        )
1224    (declare (special *load-pathname* *load-truename*))
1225    (when (typep file-name 'string-input-stream)
1226      (when verbose
1227          (format t "~&;Loading from stream ~S..." file-name)
1228          (force-output))
1229      (let ((*package* *package*)
1230            (*readtable* *readtable*))
1231        (load-from-stream file-name print))
1232      (return-from %load file-name))
1233    (unless (streamp file-name)
1234      (multiple-value-setq (*load-truename* *load-pathname* source-file)
1235        (find-load-file (merge-pathnames file-name)))
1236      (when (not *load-truename*)
1237        (return-from %load (if if-does-not-exist
1238                             (signal-file-error $err-no-file file-name))))
1239      (setq file-name *load-truename*))
1240    (let* ((*package* *package*)
1241           (*readtable* *readtable*)
1242           (*loading-files* (cons file-name (specialv *loading-files*)))
1243           (*loading-file-source-file* (namestring source-file))) ;reset by fasload to logical name stored in the file?
1244      (declare (special *loading-files* *loading-file-source-file*))
1245      (when verbose
1246        (format t "~&;Loading ~S..." *load-pathname*)
1247        (force-output))
1248      (cond ((fasl-file-p file-name)
1249             (let ((*fasload-print* print)
1250                   (restart-setup nil)
1251                   (restart-source nil)
1252                   (restart-fasl nil))
1253               (declare (special *fasload-print*))
1254               (flet ((restart-test (c)
1255                        (unless restart-setup
1256                          (setq restart-setup t)
1257                          (let ((source *loading-file-source-file*)
1258                                (fasl *load-pathname*))
1259                            (when (and (not (typep c 'file-error))
1260                                       source
1261                                       fasl
1262                                       (setq source (probe-file source))
1263                                       (setq fasl (probe-file fasl))
1264                                       (not (equalp source fasl)))
1265                              (setq restart-fasl (namestring *load-pathname*)
1266                                    restart-source *loading-file-source-file*))))
1267                        (not (null restart-fasl)))
1268                      (fname (p)
1269                        #-versioned-file-system
1270                        (namestring (make-pathname :version :unspecific :defaults p))
1271                        #+versioned-file-system
1272                        (namestring p)))
1273                 (restart-case (multiple-value-bind (winp err) 
1274                                   (%fasload (native-translated-namestring file-name))
1275                                 (if (not winp) 
1276                                   (%err-disp err)))
1277                   (load-source 
1278                    ()
1279                    :test restart-test
1280                    :report (lambda (s) 
1281                              (format s "Load ~s instead of ~s" 
1282                                      (fname restart-source) (fname restart-fasl)))
1283                    (%load source-file verbose print if-does-not-exist external-format))
1284                   (recompile
1285                    ()
1286                    :test restart-test
1287                    :report (lambda (s)
1288                              (let ((*print-circle* NIL))
1289                                (format s
1290                                        (if (equalp
1291                                             restart-source
1292                                             (make-pathname :type (pathname-type *.lisp-pathname*)
1293                                                            :defaults restart-fasl))
1294                                          "Compile ~s and then load ~s again"
1295                                          "Compile ~s into ~s then load ~:*~s again")
1296                                        (fname restart-source) (fname restart-fasl))))
1297                    (compile-file restart-source :output-file restart-fasl)
1298                    (%load restart-fasl verbose print if-does-not-exist external-format))))))
1299            (t 
1300             (with-open-file (stream file-name
1301                                     :element-type 'base-char
1302                                     :external-format external-format)
1303               (load-from-stream stream print))))))
1304  file-name)
1305
1306(defun load-from-stream (stream print &aux (eof-val (list ())) val)
1307  (with-compilation-unit (:override nil) ; try this for included files
1308    (let ((env (new-lexical-environment (new-definition-environment 'eval))))
1309      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
1310      (while (neq eof-val (setq val (read stream nil eof-val)))
1311        (when (eq print :source) (format t "~&Source: ~S~%" val))
1312        (setq val (cheap-eval-in-environment val env))
1313        (when print
1314          (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val))))))
1315
1316(defun include (filename)
1317  (load
1318   (if (null *loading-files*)
1319     filename
1320     (merge-pathnames filename (directory-namestring (car *loading-files*))))))
1321
1322(%fhave '%include #'include)
1323
1324(defun delete-file (path)
1325  "Delete the specified FILE."
1326  (let* ((namestring (native-translated-namestring path)))
1327    (when (%realpath namestring)
1328      (let* ((err (%delete-file namestring)))
1329        (or (eql 0 err) (signal-file-error err path))))))
1330
1331(defvar *known-backends* ())
1332
1333(defun fasl-file-p (pathname)
1334  (let* ((type (pathname-type pathname)))
1335    (or (and (null *known-backends*)
1336             (equal type (pathname-type *.fasl-pathname*)))
1337        (dolist (b *known-backends*)
1338          (when (equal type (pathname-type (backend-target-fasl-pathname b)))
1339            (return t)))
1340        (ignore-errors
1341          (with-open-file (f pathname
1342                             :direction :input
1343                             :element-type '(unsigned-byte 8))
1344            ;; Assume that (potential) FASL files start with #xFF00 (big-endian),
1345            ;; and that source files don't.
1346            (and (eql (read-byte f nil nil) #xff)
1347                 (eql (read-byte f nil nil) #x00)))))))
1348
1349(defun provide (module)
1350  "Adds a new module name to *MODULES* indicating that it has been loaded.
1351   Module-name is a string designator"
1352  (pushnew (string module) *modules* :test #'string=)
1353  module)
1354
1355(defparameter *loading-modules* () "Internal. Prevents circularity")
1356(defparameter *module-provider-functions* '(module-provide-search-path)
1357  "A list of functions called by REQUIRE to satisfy an unmet dependency.
1358Each function receives a module name as a single argument; if the function knows how to load that module, it should do so, add the module's name as a string to *MODULES* (perhaps by calling PROVIDE) and return non-NIL."
1359  )
1360
1361(defun module-provide-search-path (module)
1362  ;; (format *debug-io* "trying module-provide-search-path~%")
1363  (let* ((module-name (string module))
1364         (pathname (find-module-pathnames module-name)))
1365    (when pathname
1366      (if (consp pathname)
1367        (dolist (path pathname) (load path))
1368        (load pathname))
1369      (provide module))))
1370
1371(defun require (module &optional pathname)
1372  "Loads a module, unless it already has been loaded. PATHNAMES, if supplied,
1373   is a designator for a list of pathnames to be loaded if the module
1374   needs to be. If PATHNAMES is not supplied, functions from the list
1375   *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME
1376   as an argument, until one of them returns non-NIL.  User code is
1377   responsible for calling PROVIDE to indicate a successful load of the
1378   module."
1379  (let* ((str (string module))
1380         (original-modules (copy-list *modules*)))
1381    (unless (or (member str *modules* :test #'string=)
1382                (member str *loading-modules* :test #'string=))
1383      ;; The check of (and binding of) *LOADING-MODULES* is a
1384      ;; traditional defense against circularity.  (Another
1385      ;; defense is not having circularity, of course.)  The
1386      ;; effect is that if something's in the process of being
1387      ;; REQUIREd and it's REQUIREd again (transitively),
1388      ;; the inner REQUIRE is a no-op.
1389      (let ((*loading-modules* (cons str *loading-modules*)))
1390        (if pathname
1391          (dolist (path (if (atom pathname) (list pathname) pathname))
1392            (load path))
1393          (unless (some (lambda (p) (funcall p module))
1394                        *module-provider-functions*)
1395            (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*)))))
1396    (values module
1397            (set-difference *modules* original-modules))))
1398
1399(defun find-module-pathnames (module)
1400  "Returns the file or list of files making up the module"
1401  (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path)
1402        (dolist (path-cand *module-search-path* nil)
1403          (let ((mod-cand (merge-pathnames mod-path path-cand)))
1404            (if (wild-pathname-p path-cand)
1405                (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific)))
1406                       (matches (if untyped-p
1407                                    (or (directory (merge-pathnames mod-cand *.lisp-pathname*))
1408                                        (directory (merge-pathnames mod-cand *.fasl-pathname*)))
1409                                    (directory mod-cand))))
1410                  (when (and matches (null (cdr matches)))
1411                    (return (if untyped-p
1412                                (make-pathname :type nil :defaults (car matches))
1413                                (car matches)))))
1414                (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
1415                  (return path)))))))
1416
1417(defun wild-pathname-p (pathname &optional field-key)
1418  "Predicate for determining whether pathname contains any wildcards."
1419  (flet ((wild-p (name) (or (eq name :wild)
1420                            (eq name :wild-inferiors)
1421                            (and (stringp name) (%path-mem "*" name)))))
1422    (case field-key
1423      ((nil)
1424       (or (some #'wild-p (pathname-directory pathname))
1425           (wild-p (pathname-name pathname))
1426           (wild-p (pathname-type pathname))
1427           (wild-p (pathname-version pathname))))
1428      (:host nil)
1429      (:device nil)
1430      (:directory (some #'wild-p (pathname-directory pathname)))
1431      (:name (wild-p (pathname-name pathname)))
1432      (:type (wild-p (pathname-type pathname)))
1433      (:version (wild-p (pathname-version pathname)))
1434      (t (wild-pathname-p pathname
1435                          (require-type field-key 
1436                                        '(member nil :host :device 
1437                                          :directory :name :type :version)))))))
Note: See TracBrowser for help on using the repository browser.