source: branches/win64/level-1/l1-files.lisp @ 8945

Last change on this file since 8945 was 8945, checked in by gb, 12 years ago

Move %SHRINK-VECTOR earlier, since some pathname hacks try to call it.

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