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

Last change on this file since 12763 was 12260, checked in by gb, 10 years ago

If ASDF is loaded, try to use it to provide modules.
(I'm not necessarily advocating this and haven't even tested this
code, which tries to lookup ASDF-package symbols at runtime. We
used to ship a custom ASDF that did this, but that change got lost
in a merge. We can always have a *PROVIDE-USING-ASDF* flag that
controls whether the ASDF provider function works, but it seems better
to have the functionality in the lisp than to wrestle with getting
it in the upstream ASDF.)

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