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

Last change on this file since 11373 was 11373, checked in by gz, 11 years ago

Finish source location and pc -> source mapping support, from working-0711 but with some modifications.

Details:

Source location are recorded in CCL:SOURCE-NOTE's, which are objects with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS, CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end positions are file positions (not character positions). The text will be NIL unless text recording was on at read-time. If the original file is still available, you can force missing source text to be read from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.

Source-note's are associated with definitions (via record-source-file) and also stored in function objects (including anonymous and nested functions). The former can be retrieved via CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.

The recording behavior is controlled by the new variable CCL:*SAVE-SOURCE-LOCATIONS*:

If NIL, don't store source-notes in function objects, and store only the filename for definitions (the latter only if *record-source-file* is true).
If T, store source-notes, including a copy of the original source text, for function objects and definitions (the latter only if *record-source-file* is true).
If :NO-TEXT, store source-notes, but without saved text, for function objects and defintions (the latter only if *record-source-file* is true). This is the default.

PC to source mapping is controlled by the new variable CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a compressed table mapping pc offsets to corresponding source locations. This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc) which returns a source-note for the source at offset pc in the function.

Currently the only thing that makes use of any of this is the disassembler. ILISP and current version of Slime still use backward-compatible functions that deal with filenames only. The plan is to make Slime, and our IDE, use this eventually.

Known bug: most of this only works through the file compiler. Still need to make it work with loading from source (not hard, just haven't gotten to it yet).

This checkin incidentally includes bits and pieces of support for code coverage, which is still
incomplete and untested. Ignore it.

The PPC version is untested. I need to check it in so I can move to a PPC for testing.

Sizes:

18387152 Nov 16 10:00 lx86cl64.image-no-loc-no-pc
19296464 Nov 16 10:11 lx86cl64.image-loc-no-text-no-pc
20517072 Nov 16 09:58 lx86cl64.image-loc-no-text-with-pc [default]
25514192 Nov 16 09:55 lx86cl64.image-loc-with-text-with-pc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 57.6 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 (stream-filename stream) (error "Can't determine pathname of ~S ." stream)))      ; ???
494
495;Like (pathname stream) except returns NIL rather than error when there's no
496;filename associated with the stream.
497(defun stream-pathname (stream &aux (path (stream-filename stream)))
498  (when path (pathname path)))
499
500(defun string-to-pathname (string &optional (start 0) (end (length string))
501                                            (reference-host nil)
502                                            (defaults *default-pathname-defaults*))
503  (require-type reference-host '(or null string))
504  (multiple-value-bind (sstr start end) (get-sstring string start end)
505    #-windows-target
506    (if (and (> end start)
507             (eql (schar sstr start) #\~))
508      (setq sstr (tilde-expand (subseq sstr start end))
509            start 0
510            end (length sstr)))
511    (let (directory name type host version device (start-pos start) (end-pos end) has-slashes)
512      (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos))
513      (cond ((and host (neq host :unspecific))
514             (when (and reference-host (not (string-equal reference-host host)))
515               (error "Host in ~S does not match requested host ~S"
516                      (%substr sstr start end) reference-host)))
517            ((or reference-host
518                 (and defaults
519                      (neq (setq reference-host (pathname-host defaults)) :unspecific)))
520             ;;If either a reference-host is specified or defaults is a logical pathname
521             ;; then the string must be interpreted as a logical pathname.
522             (when has-slashes
523               (error "Illegal logical namestring ~S" (%substr sstr start end)))
524             (setq host reference-host)))
525      #+windows-target
526      (when (and (eq host :unspecific)
527                 (eql start-pos 0)
528                 (eql (position #\: sstr) 1))
529        (let* ((ch (schar sstr 0)))
530          (when (and (alpha-char-p ch)
531                     (standard-char-p ch))
532            (setq device (make-string 1 :initial-element ch)
533                  start-pos 2))))
534      (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host))
535      (unless (eq host :unspecific)
536        (multiple-value-setq (version end-pos) (pathname-version-sstr sstr start-pos end-pos)))
537      (multiple-value-setq (type end-pos) (pathname-type-sstr sstr start-pos end-pos))
538      ;; now everything else is the name
539      (unless (eq start-pos end-pos)
540        (setq name (%std-name-component (%substr sstr start-pos end-pos))))
541      (if (eq host :unspecific)
542        (%cons-pathname directory name type (if name :newest) device)
543        (%cons-logical-pathname directory name type host version)))))
544
545(defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*)
546                               &key (start 0) end junk-allowed)
547  (declare (ignore junk-allowed))
548  (unless (typep thing 'string)
549    (let* ((path (pathname thing))
550           (pathname-host (pathname-host path)))
551      (when (and host pathname-host
552                 (or (eq pathname-host :unspecific) ;physical
553                     (not (string-equal host pathname-host))))
554        (error "Host in ~S does not match requested host ~S" path host))
555      (return-from parse-namestring (values path start))))
556  (when host
557    (verify-logical-host-name host))
558  (setq end (check-sequence-bounds thing start end))
559  (values (string-to-pathname thing start end host defaults) end))
560
561
562
563(defun %std-device-component (device host)
564  (when (and (or (null host) (eq host :unspecific))
565             (and device (not (eq device :unspecific))))
566    #+windows-target
567    (unless (and (typep device 'string)
568                 (eql (length device) 1)
569                 (alpha-char-p (char device 0))
570                 (standard-char-p (char device 0)))
571      (error "Invalid pathname device ~s" device))
572    device))
573   
574(defun make-pathname (&key (host nil host-p) 
575                           (device nil device-p)
576                           (directory nil directory-p)
577                           (name nil name-p)
578                           (type nil type-p)
579                           (version nil version-p)
580                           (defaults nil defaults-p) case
581                           &aux path)
582  "Makes a new pathname from the component arguments. Note that host is
583a host-structure or string."
584  (when case (setq case (require-type case pathname-case-type)))
585  (if (null host-p)
586    (let ((defaulted-defaults (if defaults-p defaults *default-pathname-defaults*)))
587      (setq host (if defaulted-defaults
588                   (pathname-host defaulted-defaults)
589                   :unspecific)))
590    (unless host (setq host :unspecific)))
591  (if directory-p 
592    (setq directory (%std-directory-component directory host)))
593  (if (and defaults (not directory-p))
594    (setq directory (pathname-directory defaults)))
595  (if (and defaults (not device-p))
596    (setq device (pathname-device defaults)))
597  (setq device (%std-device-component device host))
598  (setq name
599        (if name-p
600             (%std-name-component name)
601             (and defaults (pathname-name defaults))))
602  (setq type
603        (if type-p
604             (%std-type-component type)
605             (and defaults (pathname-type defaults))))
606  (setq version (if version-p
607                  (%logical-version-component version)
608                  (if name-p
609                    nil
610                    (and defaults (pathname-version defaults)))))
611  (setq path
612        (if (eq host :unspecific)
613          (%cons-pathname directory name type version device)
614          (%cons-logical-pathname
615           (or directory
616               (unless directory-p '(:absolute)))
617           name type host version)))
618  (when (and (eq (car directory) :absolute)
619             (member (cadr directory) '(:up :back)))
620    (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory))))
621  (let* ((after-wif (cadr (member :wild-inferiors directory))))
622    (when (member after-wif '(:up :back))
623          (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif))))
624         
625  (when (and case (neq case :local))
626    (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)
627          (%pathname-name path) (%reverse-component-case (%pathname-name path) case)
628          (%pathname-type path) (%reverse-component-case (%pathname-type path) case)))
629  path)
630
631;;;  In portable CL, if the :directory argument to make pathname is a
632;;;  string, it should be the name of a top-level directory and should
633;;;  not contain any punctuation characters such as "/" or ";".  In
634;;;  MCL a string :directory argument with slashes or semi-colons will
635;;;  be parsed as a directory in the obvious way.
636(defun %std-directory-component (directory host)
637  (cond ((null directory) nil)
638        ((eq directory :wild) '(:absolute :wild-inferiors))
639        ((stringp directory) (%directory-string-list directory 0 (length directory) host))
640        ((listp directory)
641         ;Standardize the directory list, taking care not to cons if nothing
642         ;needs to be changed.
643         (let ((names (%cdr directory)) (new-names ()))
644           (do ((nn names (%cdr nn)))
645               ((null nn) (setq new-names (if new-names (nreverse new-names) names)))
646             (let* ((name (car nn))
647                    (new-name (%std-directory-part name)))
648               (unless (eq name new-name)
649                 (unless new-names
650                   (do ((new-nn names (%cdr new-nn)))
651                       ((eq new-nn nn))
652                     (push (%car new-nn) new-names))))
653               (when (or new-names (neq name new-name))
654                 (push new-name new-names))))
655           (when (memq :up (or new-names names))
656             (setq new-names (remove-up (copy-list (or new-names names)))))
657           (ecase (%car directory)
658             (:relative           
659                  (cond (new-names         ; Just (:relative) is the same as NIL. - no it isnt
660                         (if (eq new-names names)
661                           directory
662                           (cons ':relative new-names)))
663                        (t directory)))
664             (:absolute
665                  (cond ((null new-names) directory)  ; But just (:absolute) IS the same as NIL
666                        ((eq new-names names) directory)
667                        (t (cons ':absolute new-names)))))))
668        (t (report-bad-arg directory '(or string list (member :wild))))))
669
670(defun %std-directory-part (name)
671  (case name
672    ((:wild :wild-inferiors :up) name)
673    (:back :up)
674    (t (cond ((string= name "*") :wild)
675             ((string= name "**") :wild-inferiors)
676             ((string= name "..") :up)
677             (t (%path-std-quotes name "/:;*" "/:;"))))))
678
679; this will allow creation of garbage pathname "foo:bar;bas:" do we care?
680(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*)
681                                       (default-version :newest))
682  "Construct a filled in pathname by completing the unspecified components
683   from the defaults."
684  ;(declare (ignore default-version))
685  (when (not (pathnamep path))(setq path (pathname path)))
686  (when (and defaults (not (pathnamep defaults)))(setq defaults (pathname defaults)))
687  (let* ((path-dir (pathname-directory path))
688         (path-host (pathname-host path))
689         (path-name (pathname-name path))
690         (path-type (pathname-type path))
691         (path-device (pathname-device path))
692         (default-dir (and defaults (pathname-directory defaults)))
693         (default-host (and defaults (pathname-host defaults)))
694         (default-device (and defaults (pathname-device defaults)))
695         ; take host from defaults iff path-dir is logical or absent - huh?
696         (host (cond ((or (null path-host)  ; added 7/96
697                          (and (eq path-host :unspecific)
698                               (or (null path-dir)
699                                   (null (cdr path-dir))
700                                   (and (eq :relative (car path-dir))
701                                        (not (memq default-host '(nil :unspecific)))))))
702                         
703                      default-host)
704                     (t  path-host)))
705         (dir (cond ((null path-dir) default-dir)
706                    ((null default-dir) path-dir)
707                    ((eq (car path-dir) ':relative)
708                     (let ((the-dir (append default-dir (%cdr path-dir))))
709                       (when (memq ':up the-dir)(setq the-dir (remove-up (copy-list the-dir))))
710                       the-dir))
711                    (t path-dir)))
712         (nam (or path-name
713                  (and defaults (pathname-name defaults))))
714         (typ (or path-type
715                  (and defaults (pathname-type defaults))))
716         (version (or (pathname-version path)
717                      (cond ((not path-name)
718                             (or (and defaults (pathname-version defaults))
719                                 default-version))
720                            (t default-version))))
721         (device (or path-device default-device)))
722    (if (and (pathnamep path)
723             (eq dir (%pathname-directory path))
724             (eq nam path-name)
725             (eq typ (%pathname-type path))
726             (eq host path-host)
727             (eq device path-device)
728             (eq version (pathname-version path)))
729      path 
730      (cons-pathname dir nam typ host version device))))
731
732(defun directory-pathname-p (path)
733  (let ((name (pathname-name path))(type (pathname-type path)))
734    (and  (or (null name) (eq name :unspecific) (%izerop (length name)))
735          (or (null type) (eq type :unspecific)))))
736
737;In CCL, a pathname is logical if and only if pathname-host is not :unspecific.
738(defun pathname-host (thing &key case)
739  "Return PATHNAME's host."
740  (when (streamp thing)(setq thing (%path-from-stream thing)))
741  (when case (setq case (require-type case pathname-case-type)))
742  (let ((name
743         (typecase thing   
744           (logical-pathname (%logical-pathname-host thing))
745           (pathname :unspecific)
746           (string (multiple-value-bind (sstr start end) (get-sstring thing) 
747                     (pathname-host-sstr sstr start end)))
748           (t (report-bad-arg thing pathname-arg-type)))))
749    (if (and case (neq case :local))
750      (progn
751        (when (and (eq case :common) (neq name :unspecific)) (setq case :logical))
752        (%reverse-component-case name case))
753      name)))
754
755(defun pathname-host-sstr (sstr start end &optional no-check)
756  ;; A pathname with any (unescaped) /'s is always a physical pathname.
757  ;; Otherwise, if the pathname has either a : or a ;, then it's always logical.
758  ;; Otherwise, it's probably physical.
759  ;; Return :unspecific for physical, host string or nil for a logical.
760  (let* ((slash (%path-mem "/" sstr start end))
761         (pos (and (not slash) (%path-mem ":;" sstr start end)))
762         (pos-char (and pos (%schar sstr pos)))
763         (host (and (eql pos-char #\:) (%substr sstr start pos))))
764    (cond (host
765           (unless (or no-check (logical-host-p host))
766             (error "~S is not a defined logical host" host))
767           (values host (%i+ pos 1) nil))
768          ((eql pos-char #\;) ; logical pathname with missing host
769           (values nil start nil))
770          (t ;else a physical pathname.
771           (values :unspecific start slash)))))
772
773
774(defun pathname-device (thing &key case)
775  "Return PATHNAME's device."
776  (declare (ignore case))
777  (let* ((p (pathname thing)))
778    (etypecase p
779      (logical-pathname :unspecific)
780      (pathname (%physical-pathname-device p)))))
781
782
783
784;A directory is either NIL or a (possibly wildcarded) string ending in "/" or ";"
785;Quoted /'s are allowed at this stage, though will get an error when go to the
786;filesystem.
787(defun pathname-directory (path &key case)
788  "Return PATHNAME's directory."
789  (when (streamp path) (setq path (%path-from-stream path)))
790  (when case (setq case (require-type case pathname-case-type)))
791  (let* ((logical-p nil)
792         (names (typecase path
793                  (logical-pathname (setq logical-p t) (%pathname-directory path))
794                  (pathname (%pathname-directory path))
795                  (string
796                   (multiple-value-bind (sstr start end) (get-sstring path)
797                     #+no
798                     (if (and (> end start)
799                              (eql (schar sstr start) #\~))
800                       (setq sstr (tilde-expand (subseq sstr start end))
801                             start 0
802                             end (length sstr)))
803                     (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
804                       (unless (eq host :unspecific) (setq logical-p t))
805                       #+windows-target
806                       (unless logical-p
807                         (if (and (> end 1)
808                                  (eql (schar sstr 1) #\:))
809                           (setq pos2 2)))
810                       (pathname-directory-sstr sstr pos2 end host))))
811                  (t (report-bad-arg path pathname-arg-type)))))
812    (if (and case (neq case :local))
813      (progn
814        (when (and (eq case :common) logical-p) (setq case :logical))
815        (%reverse-component-case names case))
816      names)))
817
818;; Must match pathname-directory-end below
819(defun pathname-directory-sstr (sstr start end host)
820  (if (and (eq host :unspecific)
821           (> end start)
822           (eql (schar sstr start) #\~))
823    (setq sstr (tilde-expand (subseq sstr start end))
824          start 0
825          end (length sstr)))
826  (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr start end)))
827    (if pos
828      (values 
829       (%directory-string-list sstr start (setq pos (%i+ pos 1)) host)
830       pos)
831      (values (and (neq host :unspecific)
832                   (neq start end)
833                   '(:absolute))
834              start))))
835
836;; Must match pathname-directory-sstr above
837(defun pathname-directory-end (sstr start end)
838  (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
839    (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr pos2 end)))
840      (if pos
841        (values (%i+ pos 1) host)
842        (values pos2 host)))))
843
844(defun %directory-string-list (sstr start &optional (end (length sstr)) host)
845  ;; Should use host to split by / vs. ; but for now suport both for either host,
846  ;; like the mac version. It means that ';' has to be quoted in unix pathnames.
847  (declare (ignore host))
848  ;This must cons up a fresh list, %expand-logical-directory rplacd's it.
849  (labels ((std-part (sstr start end)
850             (%std-directory-part (if (and (eq start 0) (eq end (length sstr)))
851                                    sstr (%substr sstr start end))))
852           (split (sstr start end)
853             (unless (eql start end)
854               (let ((pos (%path-mem "/;" sstr start end)))
855                 (if (eq pos start)
856                   (split sstr (%i+ start 1) end) ;; treat multiple ////'s as one.
857                   (cons (std-part sstr start (or pos end))
858                         (when pos
859                           (split sstr (%i+ pos 1) end))))))))
860    (unless (eq start end)
861      (let* ((slash-pos (%path-mem "/" sstr start end))
862             (semi-pos (%path-mem ";" sstr start end))
863             (pos (or slash-pos semi-pos)))
864        ; this never did anything sensible but did not signal an error
865        (when (and slash-pos semi-pos)
866          (error "Illegal directory string ~s" (%substr sstr start end)))
867        (if (null pos)
868          (list :relative (std-part sstr start end))
869          (let ((pos-char (%schar sstr pos)))
870            (cons (if (eq pos start)
871                    (if (eq pos-char #\/) ':absolute ':relative)
872                    (if (eq pos-char #\/) ':relative ':absolute))
873                  (split sstr start end))))))))
874
875(defun pathname-version (path)
876  "Return PATHNAME's version."
877  (when (streamp path) (setq path (%path-from-stream path)))
878  (typecase path
879    (logical-pathname (%logical-pathname-version path))
880    (pathname (%physical-pathname-version path))
881    (string
882     (multiple-value-bind (sstr start end) (get-sstring path)
883       (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
884         (if (eq host :unspecific)
885           nil
886           (pathname-version-sstr sstr newstart end)))))
887    (t (report-bad-arg path pathname-arg-type))))
888
889(defun pathname-version-sstr (sstr start end)
890  (declare (fixnum start end))
891  (let ((pos (%path-mem-last "." sstr start end)))
892    (if (and pos (%i> pos start) (%path-mem "." sstr start (%i- pos 1)))
893      (values (%std-version-component (%substr sstr (%i+ pos 1) end)) pos)
894      (values nil end))))
895
896(defun %std-version-component (v)
897  (cond ((or (null v) (eq v :unspecific)) v)
898        ((eq v :wild) "*")
899        ((string= v "") :unspecific)
900        ((string-equal v "newest") :newest)
901        ((every #'digit-char-p v) (parse-integer v))
902        (t (%path-std-quotes v "./:;*" "./:;"))))
903
904
905;A name is either NIL or a (possibly wildcarded, possibly empty) string.
906;Quoted /'s are allowed at this stage, though will get an error if go to the
907;filesystem.
908(defun pathname-name (path &key case)
909  "Return PATHNAME's name."
910  (when (streamp path) (setq path (%path-from-stream path)))
911  (when case (setq case (require-type case pathname-case-type)))
912  (let* ((logical-p nil)
913         (name (typecase path
914                 (logical-pathname (setq logical-p t) (%pathname-name path))
915                 (pathname (%pathname-name path))
916                 (string
917                  (multiple-value-bind (sstr start end) (get-sstring path)
918                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
919                      (setq start newstart)
920                      (unless (eq host :unspecific)
921                        (setq logical-p t)
922                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
923                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
924                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
925                      ;; for native.
926                      (setq end (or (%path-mem-last "." sstr start end) end));; strip off type
927                      (unless (eq start end)
928                        (%std-name-component (%substr sstr start end))))))
929                 (t (report-bad-arg path pathname-arg-type)))))
930    (if (and case (neq case :local))
931      (progn
932        (when (and (eq case :common) logical-p) (setq case :logical))
933        (%reverse-component-case name case))
934      name)))
935
936(defun %std-name-component (name)
937  (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name)
938        ((equal name "*") :wild)
939        (t (%path-std-quotes name "/:;*" "/:;"))))
940
941;A type is either NIL or a (possibly wildcarded, possibly empty) string.
942;Quoted :'s are allowed at this stage, though will get an error if go to the
943;filesystem.
944(defun pathname-type (path &key case)
945  "Return PATHNAME's type."
946  (when (streamp path) (setq path (%path-from-stream path)))
947  (when case (setq case (require-type case pathname-case-type)))
948  (let* ((logical-p nil)
949         (name (typecase path
950                 (logical-pathname (setq logical-p t) (%pathname-type path))
951                 (pathname (%pathname-type path))
952                 (string
953                  (multiple-value-bind (sstr start end) (get-sstring path)
954                    (multiple-value-bind (newstart host) (pathname-directory-end sstr start end)
955                      (setq start newstart)
956                      (unless (eq host :unspecific)
957                        (setq logical-p t)
958                        (setq end (nth-value 1 (pathname-version-sstr sstr start end))))
959                      ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type.
960                      ;;   -->> Need to make an exception so that foo/.. is a directory pathname,
961                      ;; for native.
962                      (pathname-type-sstr sstr start end))))
963                 (t (report-bad-arg path pathname-arg-type)))))
964    (if (and case (neq case :local))
965      (progn
966        (when (and (eq case :common) logical-p) (setq case :logical))
967        (%reverse-component-case name case))
968      name)))
969
970; assumes dir & version if any has been stripped away
971(defun pathname-type-sstr (sstr start end)
972  (let ((pos (%path-mem-last "." sstr start end)))
973    (if pos
974      (values (%std-type-component (%substr sstr (%i+ 1 pos) end)) pos)
975      (values nil end))))
976
977(defun %std-type-component (type)
978  (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type)
979        ((equal type "*") :wild)
980        (t (%path-std-quotes type "./:;*" "./:;"))))
981
982(defun %std-name-and-type (native)
983  (let* ((end (length native))
984         (pos (position #\. native :from-end t))
985         (type (and pos
986                    (%path-std-quotes (%substr native (%i+ 1 pos) end)
987                                      nil "/:;*")))
988         (name (unless (eq (or pos end) 0)
989                 (%path-std-quotes (if pos (%substr native 0 pos) native)
990                                   nil "/:;*"))))
991    (values name type)))
992
993(defun %reverse-component-case (name case)
994  (cond ((not (stringp name))
995         (if (listp name)
996           (mapcar #'(lambda (name) (%reverse-component-case name case))  name)
997           name))
998        #+advanced-studlification-feature
999        ((eq case :studly) (string-studlify name))
1000        ((eq case :logical)
1001         (if (every #'(lambda (ch) (not (lower-case-p ch))) name)
1002           name
1003           (string-upcase name)))
1004        (t ; like %read-idiocy but non-destructive - need it be?
1005         (let ((which nil)
1006               (len (length name)))
1007           (dotimes (i len)
1008             (let ((c (%schar name i)))
1009               (if (alpha-char-p c)
1010                 (if (upper-case-p c)
1011                   (progn
1012                     (when (eq which :lower)(return-from %reverse-component-case name))
1013                     (setq which :upper))
1014                   (progn
1015                     (when (eq which :upper)(return-from %reverse-component-case name))
1016                     (setq which :lower))))))
1017           (case which
1018             (:lower (string-upcase name))
1019             (:upper (string-downcase name))
1020             (t name))))))
1021
1022;;;;;;; String-with-quotes utilities
1023(defun %path-mem-last-quoted (chars sstr &optional (start 0) (end (length sstr)))
1024  (while (%i< start end)
1025    (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars)
1026               (%path-quoted-p sstr end start))
1027      (return-from %path-mem-last-quoted end))))
1028
1029(defun %path-mem-last (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               (not (%path-quoted-p sstr end start)))
1033      (return-from %path-mem-last end))))
1034
1035(defun %path-mem (chars sstr &optional (start 0) (end (length sstr)))
1036  (let ((one-char (when (eq (length chars) 1) (%schar chars 0))))
1037    (while (%i< start end)
1038      (let ((char (%schar sstr start)))
1039        (when (if one-char (eq char one-char)(%%str-member char chars))
1040          (return-from %path-mem start))
1041        (when (eq char *pathname-escape-character*)
1042          (setq start (%i+ start 1)))
1043        (setq start (%i+ start 1))))))
1044
1045; these for \:  meaning this aint a logical host. Only legal for top level dir
1046 
1047(defun %path-unquote-one-quoted (chars sstr &optional (start 0)(end (length sstr)))
1048  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1049    (when (and pos (neq pos 1))
1050      (cond ((or (%path-mem chars sstr start (1- pos))
1051                 (%path-mem-last-quoted chars sstr start (1- pos)))
1052             nil)
1053            (t (%str-cat (%substr sstr start (1- pos))(%substr sstr  pos end)))))))
1054
1055(defun %path-one-quoted-p (chars sstr &optional (start 0)(end (length sstr)))
1056  (let ((pos (%path-mem-last-quoted chars sstr start end)))
1057    (when (and pos (neq pos 1))
1058      (not (or (%path-mem-last-quoted chars sstr start (1- pos))
1059               (%path-mem chars sstr start (1- pos)))))))
1060 
1061(defun %path-quoted-p (sstr pos start &aux (esc *pathname-escape-character*) (q nil))
1062  (while (and (%i> pos start) (eq (%schar sstr (setq pos (%i- pos 1))) esc))
1063    (setq q (not q)))
1064  q)
1065
1066
1067
1068;Standardize pathname quoting, so can do EQUAL.
1069;; Subtle point: when keep-quoted is NIL, arg is assumed native,
1070;; and therefore escape characters are made quoted.
1071;; if keep-quoted is not NIL, e.g. if it's "", arg is assumed
1072;;   to be escaped already, so escape chars are interpreted as quotes.
1073;; Note that this can't be used to remove quotes because it
1074;; always keeps the escape character quoted.
1075(defun %path-std-quotes (arg keep-quoted make-quoted)
1076  (when (symbolp arg)
1077    (error "Invalid pathname component ~S" arg))
1078  (let* ((str arg)
1079         (esc *pathname-escape-character*)
1080         (end (length str))
1081         res-str char)
1082    (multiple-value-bind (sstr start)(array-data-and-offset str)
1083      (setq end (+ start end))
1084      (let ((i start))
1085        (until (eq i end)
1086          (setq char (%schar sstr i))
1087          (cond ((or (%%str-member char make-quoted)
1088                     (and (null keep-quoted) (eq char esc)))
1089                 (unless res-str
1090                   (setq res-str (make-array (%i- end start)
1091                                             :element-type (array-element-type sstr)
1092                                             :adjustable t :fill-pointer 0))
1093                   (do ((j start (%i+ j 1))) ((eq j i))
1094                     (vector-push-extend (%schar sstr j) res-str)))
1095                 (vector-push-extend esc res-str))
1096                ((neq char esc) nil)
1097                ((eq (setq i (%i+ i 1)) end)
1098                 (error "Malformed pathname component string ~S" str))
1099                ((or (eq (setq char (%schar sstr i)) esc)
1100                     (%%str-member char keep-quoted))
1101                 (when res-str (vector-push-extend esc res-str)))
1102                (t
1103                 (unless res-str
1104                   (setq res-str (make-array (%i- end start)
1105                                             :element-type (array-element-type sstr)
1106                                             :adjustable t :fill-pointer 0))
1107                   (do ((j start (%i+ j 1)) (end (%i- i 1))) ((eq j end))
1108                     (vector-push-extend (%schar sstr j) res-str)))))
1109          (when res-str (vector-push-extend char res-str))
1110          (setq i (%i+ i 1)))
1111        (ensure-simple-string (or res-str str))))))
1112
1113
1114
1115(defun %%str-member (char string)
1116  (locally (declare (optimize (speed 3)(safety 0)))
1117    (dotimes (i (the fixnum (length string)))
1118      (when (eq (%schar string i) char)
1119        (return i)))))
1120
1121
1122(defun file-write-date (path)
1123  "Return file's creation date, or NIL if it doesn't exist.
1124  An error of type file-error is signaled if file is a wild pathname"
1125  (%file-write-date (native-translated-namestring path)))
1126
1127(defun file-author (path)
1128  "Return the file author as a string, or NIL if the author cannot be
1129  determined. Signal an error of type FILE-ERROR if FILE doesn't exist,
1130  or FILE is a wild pathname."
1131  (%file-author (native-translated-namestring path)))
1132
1133(defun touch (path)
1134  (if (not (probe-file path))
1135    (progn
1136      (ensure-directories-exist path)
1137      (if (or (pathname-name path)
1138              (pathname-type path))
1139        (create-file path)))
1140    (%utimes (native-translated-namestring path)))
1141  t)
1142
1143
1144;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
1145; load, require, provide
1146
1147(defun find-load-file (file-name)
1148  (let ((full-name (full-pathname file-name :no-error nil))
1149        (kind nil))
1150    (when full-name
1151      (when (eq (pathname-host file-name) :unspecific) ;; if physical pathname to begin with, force absolute
1152        (setq file-name full-name))
1153      (let ((file-type (pathname-type full-name)))
1154        (if (and file-type (neq file-type :unspecific))
1155          (values (probe-file full-name) file-name file-name)
1156          (let* ((source (merge-pathnames file-name *.lisp-pathname*))
1157                 (fasl   (merge-pathnames file-name *.fasl-pathname*))
1158                 (true-source (probe-file source))
1159                 (true-fasl   (probe-file fasl)))
1160            (cond (true-source
1161                   (if (and true-fasl
1162                            (> (file-write-date true-fasl)
1163                               (file-write-date true-source)))
1164                     (values true-fasl fasl source)
1165                     (values true-source source source)))
1166                  (true-fasl
1167                   (values true-fasl fasl fasl))
1168                  ((and (multiple-value-setq (full-name kind)
1169                          (let* ((realpath (%realpath (native-translated-namestring full-name))))
1170                            (if realpath
1171                              (%probe-file-x realpath ))))
1172                        (eq kind :file))
1173                   (values full-name file-name file-name)))))))))
1174
1175
1176
1177
1178
1179(defun load (file-name &key (verbose *load-verbose*)
1180                       (print *load-print*)
1181                       (if-does-not-exist :error)
1182                       (external-format :default))
1183  "Load the file given by FILESPEC into the Lisp environment, returning
1184   T on success.
1185
1186   Extension: :PRINT :SOURCE means print source as well as value"
1187  (loop
1188    (restart-case
1189      (return (%load file-name verbose print if-does-not-exist external-format))
1190      (retry-load ()
1191                  :report (lambda (stream) (format stream "Retry loading ~s" file-name)))
1192      (skip-load ()
1193                 :report (lambda (stream) (format stream "Skip loading ~s" file-name))
1194                 (return nil))
1195      (load-other ()
1196                  :report (lambda (stream) (format stream "Load other file instead of ~s" file-name))
1197                  (return
1198                   (load (choose-file-dialog)
1199                         :verbose verbose
1200                         :print print
1201                         :if-does-not-exist if-does-not-exist))))))
1202
1203
1204(defun %load (file-name verbose print if-does-not-exist external-format)
1205  (let ((*load-pathname* file-name)
1206        (*load-truename* file-name)
1207        (source-file file-name)
1208        ;; Don't bind these: let OPTIMIZE proclamations/declamations
1209        ;; persist, unless debugging.
1210        #|
1211        (*nx-speed* *nx-speed*)
1212        (*nx-space* *nx-space*)
1213        (*nx-safety* *nx-safety*)
1214        (*nx-debug* *nx-debug*)
1215        (*nx-cspeed* *nx-cspeed*)
1216        |#
1217        )
1218    (declare (special *load-pathname* *load-truename*))
1219    (when (typep file-name 'string-input-stream)
1220      (when verbose
1221          (format t "~&;Loading from stream ~S..." file-name)
1222          (force-output))
1223      (let ((*package* *package*)
1224            (*readtable* *readtable*))
1225        (load-from-stream file-name print))
1226      (return-from %load file-name))
1227    (unless (streamp file-name)
1228      (multiple-value-setq (*load-truename* *load-pathname* source-file)
1229        (find-load-file (merge-pathnames file-name)))
1230      (when (not *load-truename*)
1231        (return-from %load (if if-does-not-exist
1232                             (signal-file-error $err-no-file file-name))))
1233      (setq file-name *load-truename*))
1234    (let* ((*package* *package*)
1235           (*readtable* *readtable*)
1236           (*loading-files* (cons file-name (specialv *loading-files*)))
1237           ;;reset by fasload to logical name stored in the file
1238           (*loading-file-source-file* (namestring source-file))
1239           (*loading-toplevel-location* nil))
1240      (declare (special *loading-files* *loading-file-source-file*))
1241      (when verbose
1242        (format t "~&;Loading ~S..." *load-pathname*)
1243        (force-output))
1244      (cond ((fasl-file-p file-name)
1245             (let ((*fasload-print* print)
1246                   (restart-setup nil)
1247                   (restart-source nil)
1248                   (restart-fasl nil))
1249               (declare (special *fasload-print*))
1250               (flet ((restart-test (c)
1251                        (unless restart-setup
1252                          (setq restart-setup t)
1253                          (let ((source *loading-file-source-file*)
1254                                (fasl *load-pathname*))
1255                            (when (and (not (typep c 'file-error))
1256                                       source
1257                                       fasl
1258                                       (setq source (probe-file source))
1259                                       (setq fasl (probe-file fasl))
1260                                       (not (equalp source fasl)))
1261                              (setq restart-fasl (namestring *load-pathname*)
1262                                    restart-source *loading-file-source-file*))))
1263                        (not (null restart-fasl)))
1264                      (fname (p)
1265                        #-versioned-file-system
1266                        (namestring (make-pathname :version :unspecific :defaults p))
1267                        #+versioned-file-system
1268                        (namestring p)))
1269                 (restart-case (multiple-value-bind (winp err) 
1270                                   (%fasload (native-translated-namestring file-name))
1271                                 (if (not winp) 
1272                                   (%err-disp err)))
1273                   (load-source 
1274                    ()
1275                    :test restart-test
1276                    :report (lambda (s) 
1277                              (format s "Load ~s instead of ~s" 
1278                                      (fname restart-source) (fname restart-fasl)))
1279                    (%load source-file verbose print if-does-not-exist external-format))
1280                   (recompile
1281                    ()
1282                    :test restart-test
1283                    :report (lambda (s)
1284                              (let ((*print-circle* NIL))
1285                                (format s
1286                                        (if (equalp
1287                                             restart-source
1288                                             (make-pathname :type (pathname-type *.lisp-pathname*)
1289                                                            :defaults restart-fasl))
1290                                          "Compile ~s and then load ~s again"
1291                                          "Compile ~s into ~s then load ~:*~s again")
1292                                        (fname restart-source) (fname restart-fasl))))
1293                    (compile-file restart-source :output-file restart-fasl)
1294                    (%load restart-fasl verbose print if-does-not-exist external-format))))))
1295            (t 
1296             (with-open-file (stream file-name
1297                                     :element-type 'base-char
1298                                     :external-format external-format)
1299               (load-from-stream stream print))))))
1300  file-name)
1301
1302(defun load-from-stream (stream print &aux (eof-val (list ())) val)
1303  (with-compilation-unit (:override nil) ; try this for included files
1304    (let ((env (new-lexical-environment (new-definition-environment 'eval))))
1305      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
1306      (while (neq eof-val (setq val (read stream nil eof-val)))
1307        (when (eq print :source) (format t "~&Source: ~S~%" val))
1308        (setq val (cheap-eval-in-environment val env))
1309        (when print
1310          (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val))))))
1311
1312(defun include (filename)
1313  (load
1314   (if (null *loading-files*)
1315     filename
1316     (merge-pathnames filename (directory-namestring (car *loading-files*))))))
1317
1318(%fhave '%include #'include)
1319
1320(defun delete-file (path)
1321  "Delete the specified FILE."
1322  (let* ((namestring (native-translated-namestring path)))
1323    (when (%realpath namestring)
1324      (let* ((err (%delete-file namestring)))
1325        (or (eql 0 err) (signal-file-error err path))))))
1326
1327(defvar *known-backends* ())
1328
1329(defun fasl-file-p (pathname)
1330  (let* ((type (pathname-type pathname)))
1331    (or (and (null *known-backends*)
1332             (equal type (pathname-type *.fasl-pathname*)))
1333        (dolist (b *known-backends*)
1334          (when (equal type (pathname-type (backend-target-fasl-pathname b)))
1335            (return t)))
1336        (ignore-errors
1337          (with-open-file (f pathname
1338                             :direction :input
1339                             :element-type '(unsigned-byte 8))
1340            ;; Assume that (potential) FASL files start with #xFF00 (big-endian),
1341            ;; and that source files don't.
1342            (and (eql (read-byte f nil nil) #xff)
1343                 (eql (read-byte f nil nil) #x00)))))))
1344
1345(defun provide (module)
1346  "Adds a new module name to *MODULES* indicating that it has been loaded.
1347   Module-name is a string designator"
1348  (pushnew (string module) *modules* :test #'string=)
1349  module)
1350
1351(defparameter *loading-modules* () "Internal. Prevents circularity")
1352(defparameter *module-provider-functions* '(module-provide-search-path)
1353  "A list of functions called by REQUIRE to satisfy an unmet dependency.
1354Each 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."
1355  )
1356
1357(defun module-provide-search-path (module)
1358  ;; (format *debug-io* "trying module-provide-search-path~%")
1359  (let* ((module-name (string module))
1360         (pathname (find-module-pathnames module-name)))
1361    (when pathname
1362      (if (consp pathname)
1363        (dolist (path pathname) (load path))
1364        (load pathname))
1365      (provide module))))
1366
1367(defun require (module &optional pathname)
1368  "Loads a module, unless it already has been loaded. PATHNAMES, if supplied,
1369   is a designator for a list of pathnames to be loaded if the module
1370   needs to be. If PATHNAMES is not supplied, functions from the list
1371   *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME
1372   as an argument, until one of them returns non-NIL.  User code is
1373   responsible for calling PROVIDE to indicate a successful load of the
1374   module."
1375  (let* ((str (string module))
1376         (original-modules (copy-list *modules*)))
1377    (unless (or (member str *modules* :test #'string=)
1378                (member str *loading-modules* :test #'string=))
1379      ;; The check of (and binding of) *LOADING-MODULES* is a
1380      ;; traditional defense against circularity.  (Another
1381      ;; defense is not having circularity, of course.)  The
1382      ;; effect is that if something's in the process of being
1383      ;; REQUIREd and it's REQUIREd again (transitively),
1384      ;; the inner REQUIRE is a no-op.
1385      (let ((*loading-modules* (cons str *loading-modules*)))
1386        (if pathname
1387          (dolist (path (if (atom pathname) (list pathname) pathname))
1388            (load path))
1389          (unless (some (lambda (p) (funcall p module))
1390                        *module-provider-functions*)
1391            (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*)))))
1392    (values module
1393            (set-difference *modules* original-modules))))
1394
1395(defun find-module-pathnames (module)
1396  "Returns the file or list of files making up the module"
1397  (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path)
1398        (dolist (path-cand *module-search-path* nil)
1399          (let ((mod-cand (merge-pathnames mod-path path-cand)))
1400            (if (wild-pathname-p path-cand)
1401                (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific)))
1402                       (matches (if untyped-p
1403                                    (or (directory (merge-pathnames mod-cand *.lisp-pathname*))
1404                                        (directory (merge-pathnames mod-cand *.fasl-pathname*)))
1405                                    (directory mod-cand))))
1406                  (when (and matches (null (cdr matches)))
1407                    (return (if untyped-p
1408                                (make-pathname :type nil :defaults (car matches))
1409                                (car matches)))))
1410                (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
1411                  (return path)))))))
1412
1413(defun wild-pathname-p (pathname &optional field-key)
1414  "Predicate for determining whether pathname contains any wildcards."
1415  (flet ((wild-p (name) (or (eq name :wild)
1416                            (eq name :wild-inferiors)
1417                            (and (stringp name) (%path-mem "*" name)))))
1418    (case field-key
1419      ((nil)
1420       (or (some #'wild-p (pathname-directory pathname))
1421           (wild-p (pathname-name pathname))
1422           (wild-p (pathname-type pathname))
1423           (wild-p (pathname-version pathname))))
1424      (:host nil)
1425      (:device nil)
1426      (:directory (some #'wild-p (pathname-directory pathname)))
1427      (:name (wild-p (pathname-name pathname)))
1428      (:type (wild-p (pathname-type pathname)))
1429      (:version (wild-p (pathname-version pathname)))
1430      (t (wild-pathname-p pathname
1431                          (require-type field-key 
1432                                        '(member nil :host :device 
1433                                          :directory :name :type :version)))))))
Note: See TracBrowser for help on using the repository browser.