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

Last change on this file since 8816 was 8816, checked in by gz, 12 years ago

Propagate 'recompile' load restart (r8813) from working-0711 branch

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