source: branches/working-0711/ccl/level-1/l1-files.lisp @ 8836

Last change on this file since 8836 was 8836, checked in by mb, 12 years ago

Extend compiler and fasloader to store, and set, toplevel source notes.

This allows functions, such as record-source-file, to get the
source-note for the current toplevel form. I'm not yet committing the
(essential) change to record-source-file. This tree can reliably build
itself and, if nothing else, starts up qres.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.0 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        ;; we could call load, via an eval-when, when compiling a file so make sure we disable
1142        ;; source code recording. if we subsequently call compile *fcomp-stream* will get rebound to
1143        ;; the right value.
1144        ;(*fcomp-stream* nil)
1145        ;; Don't bind these: let OPTIMIZE proclamations/declamations
1146        ;; persist, unless debugging.
1147        #|
1148        (*nx-speed* *nx-speed*)
1149        (*nx-space* *nx-space*)
1150        (*nx-safety* *nx-safety*)
1151        (*nx-debug* *nx-debug*)
1152        (*nx-cspeed* *nx-cspeed*)
1153        |#
1154        )
1155    (declare (special *load-pathname* *load-truename*))
1156    (when (typep file-name 'string-input-stream)
1157      (when verbose
1158          (format t "~&;Loading from stream ~S..." file-name)
1159          (force-output))
1160      (let ((*package* *package*)
1161            (*readtable* *readtable*))
1162        (load-from-stream file-name print))
1163      (return-from %load file-name))
1164    (unless (streamp file-name)
1165      (multiple-value-setq (*load-truename* *load-pathname* source-file)
1166        (find-load-file (merge-pathnames file-name)))
1167      (when (not *load-truename*)
1168        (return-from %load (if if-does-not-exist
1169                             (signal-file-error $err-no-file file-name))))
1170      (setq file-name *load-truename*))
1171    (let* ((*package* *package*)
1172           (*readtable* *readtable*)
1173           (*loading-files* (cons file-name (specialv *loading-files*)))
1174           ;reset by fasload to logical name stored in the file?
1175           (*loading-file-source-file* (namestring source-file))
1176           ;set by the fasloader (rebinding here so concurrent %load will work
1177           (*loading-toplevel-location* nil)) 
1178      (declare (special *loading-files* *loading-file-source-file*))
1179      (when verbose
1180        (format t "~&;Loading ~S..." *load-pathname*)
1181        (force-output))
1182      (cond ((fasl-file-p file-name)
1183             (let ((*fasload-print* print)
1184                   (restart-setup nil)
1185                   (restart-source nil)
1186                   (restart-fasl nil))
1187               (declare (special *fasload-print*))
1188               (flet ((restart-test (c)
1189                        (unless restart-setup
1190                          (setq restart-setup t)
1191                          (let ((source *loading-file-source-file*)
1192                                (fasl *load-pathname*))
1193                            (when (and (not (typep c 'file-error))
1194                                       source
1195                                       fasl
1196                                       (setq source (probe-file source))
1197                                       (setq fasl (probe-file fasl))
1198                                       (not (equalp source fasl)))
1199                              (setq restart-fasl (namestring *load-pathname*)
1200                                    restart-source *loading-file-source-file*))))
1201                        (not (null restart-fasl)))
1202                      (fname (p)
1203                        #-versioned-file-system
1204                        (namestring (make-pathname :version :unspecific :defaults p))
1205                        #+versioned-file-system
1206                        (namestring p)))
1207                 (restart-case (multiple-value-bind (winp err) 
1208                                   (%fasload (native-translated-namestring file-name))
1209                                 (if (not winp) 
1210                                   (%err-disp err)))
1211                   (load-source 
1212                    ()
1213                    :test restart-test
1214                    :report (lambda (s) 
1215                              (format s "Load ~s instead of ~s" 
1216                                      (fname restart-source) (fname restart-fasl)))
1217                    (%load source-file verbose print if-does-not-exist external-format))
1218                   (recompile
1219                    ()
1220                    :test restart-test
1221                    :report (lambda (s)
1222                              (let ((*print-circle* NIL))
1223                                (format s
1224                                        (if (equalp
1225                                             restart-source
1226                                             (make-pathname :type (pathname-type *.lisp-pathname*)
1227                                                            :defaults restart-fasl))
1228                                          "Compile ~s and then load ~s again"
1229                                          "Compile ~s into ~s then load ~:*~s again")
1230                                        (fname restart-source) (fname restart-fasl))))
1231                    (compile-file restart-source :output-file restart-fasl)
1232                    (%load restart-fasl verbose print if-does-not-exist external-format))))))
1233            (t 
1234             (with-open-file (stream file-name
1235                                     :element-type 'base-char
1236                                     :external-format external-format)
1237               (load-from-stream stream print))))))
1238  file-name)
1239
1240(defun load-from-stream (stream print &aux (eof-val (list ())) val)
1241  (with-compilation-unit (:override nil) ; try this for included files
1242    (let ((env (new-lexical-environment (new-definition-environment 'eval))))
1243      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
1244      (while (neq eof-val (setq val (read stream nil eof-val)))
1245        (when (eq print :source) (format t "~&Source: ~S~%" val))
1246        (setq val (cheap-eval-in-environment val env))
1247        (when print
1248          (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val))))))
1249
1250(defun include (filename)
1251  (load
1252   (if (null *loading-files*)
1253     filename
1254     (merge-pathnames filename (directory-namestring (car *loading-files*))))))
1255
1256(%fhave '%include #'include)
1257
1258(defun delete-file (path)
1259  "Delete the specified FILE."
1260  (let* ((namestring (native-translated-namestring path)))
1261    (when (%realpath namestring)
1262      (let* ((err (%delete-file namestring)))
1263        (or (eql 0 err) (signal-file-error err path))))))
1264
1265(defvar *known-backends* ())
1266
1267(defun fasl-file-p (pathname)
1268  (let* ((type (pathname-type pathname)))
1269    (or (and (null *known-backends*)
1270             (equal type (pathname-type *.fasl-pathname*)))
1271        (dolist (b *known-backends*)
1272          (when (equal type (pathname-type (backend-target-fasl-pathname b)))
1273            (return t)))
1274        (ignore-errors
1275          (with-open-file (f pathname
1276                             :direction :input
1277                             :element-type '(unsigned-byte 8))
1278            ;; Assume that (potential) FASL files start with #xFF00 (big-endian),
1279            ;; and that source files don't.
1280            (and (eql (read-byte f nil nil) #xff)
1281                 (eql (read-byte f nil nil) #x00)))))))
1282
1283(defun provide (module)
1284  "Adds a new module name to *MODULES* indicating that it has been loaded.
1285   Module-name is a string designator"
1286  (pushnew (string module) *modules* :test #'string=)
1287  module)
1288
1289(defparameter *loading-modules* () "Internal. Prevents circularity")
1290(defparameter *module-provider-functions* '(module-provide-search-path)
1291  "A list of functions called by REQUIRE to satisfy an unmet dependency.
1292Each 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."
1293  )
1294
1295(defun module-provide-search-path (module)
1296  ;; (format *debug-io* "trying module-provide-search-path~%")
1297  (let* ((module-name (string module))
1298         (pathname (find-module-pathnames module-name)))
1299    (when pathname
1300      (if (consp pathname)
1301        (dolist (path pathname) (load path))
1302        (load pathname))
1303      (provide module))))
1304
1305(defun require (module &optional pathname)
1306  "Loads a module, unless it already has been loaded. PATHNAMES, if supplied,
1307   is a designator for a list of pathnames to be loaded if the module
1308   needs to be. If PATHNAMES is not supplied, functions from the list
1309   *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME
1310   as an argument, until one of them returns non-NIL.  User code is
1311   responsible for calling PROVIDE to indicate a successful load of the
1312   module."
1313  (let* ((str (string module))
1314         (original-modules (copy-list *modules*)))
1315    (unless (or (member str *modules* :test #'string=)
1316                (member str *loading-modules* :test #'string=))
1317      ;; The check of (and binding of) *LOADING-MODULES* is a
1318      ;; traditional defense against circularity.  (Another
1319      ;; defense is not having circularity, of course.)  The
1320      ;; effect is that if something's in the process of being
1321      ;; REQUIREd and it's REQUIREd again (transitively),
1322      ;; the inner REQUIRE is a no-op.
1323      (let ((*loading-modules* (cons str *loading-modules*)))
1324        (if pathname
1325          (dolist (path (if (atom pathname) (list pathname) pathname))
1326            (load path))
1327          (unless (some (lambda (p) (funcall p module))
1328                        *module-provider-functions*)
1329            (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*)))))
1330    (values module
1331            (set-difference *modules* original-modules))))
1332
1333(defun find-module-pathnames (module)
1334  "Returns the file or list of files making up the module"
1335  (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path)
1336        (dolist (path-cand *module-search-path* nil)
1337          (let ((mod-cand (merge-pathnames mod-path path-cand)))
1338            (if (wild-pathname-p path-cand)
1339                (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific)))
1340                       (matches (if untyped-p
1341                                    (or (directory (merge-pathnames mod-cand *.lisp-pathname*))
1342                                        (directory (merge-pathnames mod-cand *.fasl-pathname*)))
1343                                    (directory mod-cand))))
1344                  (when (and matches (null (cdr matches)))
1345                    (return (if untyped-p
1346                                (make-pathname :type nil :defaults (car matches))
1347                                (car matches)))))
1348                (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
1349                  (return path)))))))
1350
1351(defun wild-pathname-p (pathname &optional field-key)
1352  "Predicate for determining whether pathname contains any wildcards."
1353  (flet ((wild-p (name) (or (eq name :wild)
1354                            (eq name :wild-inferiors)
1355                            (and (stringp name) (%path-mem "*" name)))))
1356    (case field-key
1357      ((nil)
1358       (or (some #'wild-p (pathname-directory pathname))
1359           (wild-p (pathname-name pathname))
1360           (wild-p (pathname-type pathname))
1361           (wild-p (pathname-version pathname))))
1362      (:host nil)
1363      (:device nil)
1364      (:directory (some #'wild-p (pathname-directory pathname)))
1365      (:name (wild-p (pathname-name pathname)))
1366      (:type (wild-p (pathname-type pathname)))
1367      (:version (wild-p (pathname-version pathname)))
1368      (t (wild-pathname-p pathname
1369                          (require-type field-key 
1370                                        '(member nil :host :device 
1371                                          :directory :name :type :version)))))))
Note: See TracBrowser for help on using the repository browser.