/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Diff of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.90 by rtoy, Wed Sep 21 20:01:34 2005 UTC revision 1.91 by rtoy, Thu Sep 22 20:27:16 2005 UTC
# Line 501  Line 501 
501    (flet ((lose ()    (flet ((lose ()
502             (error "~S cannot be represented relative to ~S"             (error "~S cannot be represented relative to ~S"
503                    pathname defaults)))                    pathname defaults)))
504      (collect ((strings))      ;; Only the first path in a search-list is considered.
505        (let* ((pathname-directory (%pathname-directory pathname))      (enumerate-search-list (pathname pathname)
506               (defaults-directory (%pathname-directory defaults))        (enumerate-search-list (defaults defaults)
507               (prefix-len (length defaults-directory))          (collect ((strings))
508               (result-dir            (let* ((pathname-directory (%pathname-directory pathname))
509                (cond ((null pathname-directory)                   (defaults-directory (%pathname-directory defaults))
510                       ;; No directory, so relative to default.                   (prefix-len (length defaults-directory))
511                       (list :relative))                   (result-dir
512                      ((eq (first pathname-directory) :relative)                    (cond ((null pathname-directory)
513                       ;; Relative directory so relative to default.                           ;; No directory, so relative to default.
514                       pathname-directory)                           (list :relative))
515                      ((and (>= prefix-len 1)                          ((eq (first pathname-directory) :relative)
516                             ;; Relative directory so relative to default.
517                             pathname-directory)
518                            ((and (>= prefix-len 1)
519                                (>= (length pathname-directory) prefix-len)                                (>= (length pathname-directory) prefix-len)
520                                (compare-component (subseq pathname-directory                                (compare-component (subseq pathname-directory
521                                                           0 prefix-len)                                                           0 prefix-len)
522                                                   defaults-directory))                                                   defaults-directory))
523                       ;; Pathname starts with a prefix of default.  So just                           ;; Pathname starts with a prefix of default.  So just
524                       ;; use a relative directory from then on out.                           ;; use a relative directory from then on out.
525                       (cons :relative (nthcdr prefix-len pathname-directory)))                           (cons :relative (nthcdr prefix-len pathname-directory)))
526                      ((eq (car pathname-directory) :absolute)                          ((eq (car pathname-directory) :absolute)
527                       ;; We are an absolute pathname, so we can just use it.                           ;; We are an absolute pathname, so we can just use it.
528                       pathname-directory)                           pathname-directory)
529                      (t                          (t
530                       ;; We are a relative directory.  So we lose.                           ;; We are a relative directory.  So we lose.
531                       (lose)))))                           (lose)))))
532          (strings (unparse-unix-directory-list result-dir)))              (strings (unparse-unix-directory-list result-dir)))
533        (let* ((pathname-version (%pathname-version pathname))            (let* ((pathname-version (%pathname-version pathname))
534               (version-needed (and pathname-version                   (version-needed (and pathname-version
535                                    (not (eq pathname-version :newest))))                                        (not (eq pathname-version :newest))))
536               (pathname-type (%pathname-type pathname))                   (pathname-type (%pathname-type pathname))
537               (type-needed (or version-needed                   (type-needed (or version-needed
538                                (and pathname-type                                    (and pathname-type
539                                     (not (eq pathname-type :unspecific)))))                                         (not (eq pathname-type :unspecific)))))
540               (pathname-name (%pathname-name pathname))                   (pathname-name (%pathname-name pathname))
541               (name-needed (or type-needed                   (name-needed (or type-needed
542                                (and pathname-name                                    (and pathname-name
543                                     (not (compare-component pathname-name                                         (not (compare-component pathname-name
544                                                             (%pathname-name                                                                 (%pathname-name
545                                                              defaults)))))))                                                                  defaults)))))))
546          (when name-needed              (when name-needed
547            (unless pathname-name (lose))                (unless pathname-name (lose))
548            (strings (unparse-unix-piece pathname-name)))                (strings (unparse-unix-piece pathname-name)))
549          (when type-needed              (when type-needed
550            (when (or (null pathname-type) (eq pathname-type :unspecific))                (when (or (null pathname-type) (eq pathname-type :unspecific))
551              (lose))                  (lose))
552            (strings ".")                (strings ".")
553            (strings (unparse-unix-piece pathname-type)))                (strings (unparse-unix-piece pathname-type)))
554          (when version-needed              (when version-needed
555            (typecase pathname-version                (typecase pathname-version
556              ((member :wild)                  ((member :wild)
557               (strings ".~*~"))                   (strings ".~*~"))
558              (integer                  (integer
559               (strings (format nil ".~~~D~~" pathname-version)))                   (strings (format nil ".~~~D~~" pathname-version)))
560              (t                  (t
561               (lose)))))                   (lose)))))
562        (apply #'concatenate 'simple-string (strings)))))            (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))
563    
564    
565  (defstruct (unix-host  (defstruct (unix-host

Legend:
Removed from v.1.90  
changed lines
  Added in v.1.91

  ViewVC Help
Powered by ViewVC 1.1.5