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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

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