Changeset 9981


Ignore:
Timestamp:
09/17/05 19:48:03 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/pathnames.lisp

    r9969 r9981  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: pathnames.lisp,v 1.18 2005-09-13 21:36:23 piso Exp $
     4;;; $Id: pathnames.lisp,v 1.19 2005-09-17 19:48:03 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    114114
    115115(defun casify (thing case)
    116   (if (stringp thing)
    117       (case case
    118         (:upcase (string-upcase thing))
    119         (:downcase (string-downcase thing))
    120         (t thing))
    121       thing))
     116  (typecase thing
     117    (string
     118     (case case
     119       (:upcase (string-upcase thing))
     120       (:downcase (string-downcase thing))
     121       (t thing)))
     122    (list
     123     (let (result)
     124       (dolist (component thing (nreverse result))
     125         (push (casify component case) result))))
     126    (t
     127     thing)))
     128
     129(defun split-directory-components (directory)
     130  (declare (optimize safety))
     131  (declare (type list directory))
     132  (unless (memq (car directory) '(:absolute :relative))
     133    (error "Ill-formed directory list: ~S" directory))
     134  (let (result sublist)
     135    (push (car directory) result)
     136    (dolist (component (cdr directory))
     137      (cond ((memq component '(:wild :wild-inferiors))
     138             (when sublist
     139               (push (nreverse sublist) result)
     140               (setf sublist nil))
     141             (push component result))
     142            (t
     143             (push component sublist))))
     144    (when sublist
     145      (push (nreverse sublist) result))
     146    (nreverse result)))
    122147
    123148(defun translate-component (source from to &optional case)
     
    140165         (error "Unsupported TO-WILDCARD pattern: ~S" to))))
    141166
     167(defun translate-directory-components (source from to case)
     168  (cond ((null to)
     169         nil
     170         )
     171        ((memq (car to) '(:absolute :relative))
     172         (cons (car to)
     173               (translate-directory-components (cdr source) (cdr from) (cdr to) case))
     174         )
     175        ((eq (car to) :wild)
     176         (if (eq (car from) :wild)
     177             ;; Grab the next chunk from SOURCE.
     178             (append (casify (car source) case)
     179                     (translate-directory-components (cdr source) (cdr from) (cdr to) case))
     180             (error "Unsupported case 1: ~S ~S ~S" source from to))
     181         )
     182        ((eq (car to) :wild-inferiors)
     183         ;; Grab the next chunk from SOURCE.
     184         (append (casify (car source) case)
     185                 (translate-directory-components (cdr source) (cdr from) (cdr to) case))
     186         )
     187        (t
     188         ;; "If the piece in TO-WILDCARD is present and not wild, it is copied
     189         ;; into the result."
     190         (append (casify (car to) case)
     191                 (translate-directory-components source from (cdr to) case))
     192         )
     193        ))
     194
    142195(defun translate-directory (source from to case)
    143196  ;; FIXME The IGNORE-CASE argument to DIRECTORY-MATCH-P should not be nil on
     
    150203         (remove :wild-inferiors to))
    151204        (t
    152          (mapcar #'(lambda (source from to)
    153                     (translate-component source from to case))
    154                  source from to))))
     205         (translate-directory-components (split-directory-components source)
     206                                         (split-directory-components from)
     207                                         (split-directory-components to)
     208                                         case))))
    155209
    156210;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
Note: See TracChangeset for help on using the changeset viewer.