Greetings, and thanks so much for this report! Alas, the quote option
won't work as is, as the directory implementation depends on the shell
expanding wildcards. gcl won't even build xgcl with your patch. (Other
non-directory popen quotes might be good, though.)
I'll include the almost finished path.l lisp implementation for gcl in
case you have any comments. It will require slight edits for
Version_2_6_13pre.
Take care,
--
Camm Maguire c...@maguirefamily.org
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
=============================================================================
path.l
=============================================================================
(in-package :si)
(defun asub (s l)
(labels ((m (s l &optional (b 0))
(let* ((z (reduce (lambda (y x &aux (f (string-match (car x) s
b)))
(if (when (>= f 0) (if y (> (car y) f) t))
(cons f x) y))
l :initial-value nil))
(d (pop z)))
(cond (z (concatenate 'string (subseq s b d) (cdr z) (m s l (1+
d))))
((eql b 0) s)
((subseq s b))))))
(m s l)))
(defun regexp-conv (stream)
(let ((tem (make-array 10 :element-type 'character :fill-pointer 0)))
(or (eql (read-char stream) #\")
(error "sharp-u-reader reader needs a \" right after it"))
(loop
(let ((ch (read-char stream)))
(cond ((eql ch #\") (return tem))
((eql ch #\\)
(setq ch (read-char stream))
(setq ch (or (cdr (assoc ch '((#\n . #\newline)
(#\t . #\tab)
(#\r . #\return))))
ch))))
(vector-push-extend ch tem)))
tem))
(defun sharp-u-reader (stream subchar arg)
(declare (ignore subchar arg))
(regexp-conv stream))
(defun sharp-v-reader (stream subchar arg)
(declare (ignore subchar arg))
`(load-time-value (compile-regexp ,(regexp-conv stream))))
(set-dispatch-macro-character #\# #\u 'sharp-u-reader)
(set-dispatch-macro-character #\# #\v 'sharp-v-reader)
(defconstant +glob-to-regexp+ (list (cons #v"\\?" "(.)")(cons #v"\\*"
"(.*)")(cons #v"\\." "\\.")))
(defun mregexp (x) (compile-regexp (concatenate 'string "^" (asub x
+glob-to-regexp+) "$")))
(defun peq (x y) (or (eq x y) (eq y :wild) (not y) (when (and (vectorp y)
(stringp x)) (eql (string-match y x) 0))))
(defun match-list-1 (x)
(labels ((m (&optional (s 0) (i 1) &aux (b (match-beginning i)))
(unless (eql b -1)
(let* ((e (match-end i))(r (m e (1+ i))))
(if (>= b s) (cons (subseq x b e) r) r)))))
(or (m) x)))
(defun peqq (x y)
(cond ((or (eq x y) (eq y :wild) (not y)) x)
((when (and (vectorp y) (stringp x)) (eql (string-match y x) 0))
(match-list-1 x))
(:false)))
(defun pedd (x y &optional f)
(cond ((eq x y) x)
((unless f (not y)) x)
((and x y)
(let* ((cx (pop x))(cy (pop y)))
(if (eq cy :wild-inferiors)
(let ((r (pedd (last x (length y)) y t)))
(if (eq r :false) r (cons cx (nconc (butlast x (length y))
r))))
(let ((rq (peqq cx cy))(rd (pedd x y t)))
(if (or (eq rq :false) (eq rd :false)) :false (cons rq rd))))))
((equal y '(:absolute :wild-inferiors)) x)
(:false)))
(defun ped (x y &optional f)
(cond ((eq x y))
((unless f (not y)))
((and x y)
(let* ((cx (pop x))(cy (pop y)))
(if (eq cy :wild-inferiors)
(ped (last x (length y)) y t)
(when (peq cx cy) (ped x y t)))))))
(defun pmp (lp lw)
(mapcar (lambda (cp cw &aux (r (if (listp cp) (pedd cp cw) (peqq cp cw))))
(if (eq :false r) (return-from pmp nil) r)) lp lw))
#.`(defun mlp (p &optional r &aux (p (pathname p)))
(labels ((mrxp (x) (cond ((listp x) (mapcar #'mrxp x))((when r (stringp
x)) (mregexp x))(x))))
(list
,@(mapcar (lambda (x &aux (y (intern (concatenate 'string "PATHNAME-"
(string-upcase x)))))
`(mrxp (,y p)))
'(:host :device :directory :name :type :version)))))
(defun pathname-match-p (p w)
(pmp (mlp p) (mlp w t)))
(defun host-key (k) (if (stringp k) (string-right-trim ":" (string-downcase k))
k))
(defun (setf logical-pathname-translations) (v k &aux (k (host-key k)))
(setf (cdr (or (assoc k *pathname-logical* :test 'equal) (car (push (cons k
nil) *pathname-logical*))))
(if (listp v) (mapcar (lambda (x) (list (parse-namestring (car x) k)
(parse-namestring (cadr x)))) v) v)))
(defun logical-pathname-translations (k)
(cdr (assoc (host-key k) *pathname-logical* :test 'equal)))
(remprop 'logical-pathname-translations 'si::setf-update-fn)
(defun match-list (fr s &aux (f (string-match fr s)))
(labels ((m (&optional (i 1) &aux (c (cons (match-beginning i) (match-end
i))))
(unless (eql -1 (car c))
(cons c (member-if (lambda (x) (> (cdr x) (cdr c))) (m (1+
i)))))))
(unless (eql -1 f)
(m))))
(defun repss (s fr to)
(labels ((r (x l &optional (b 0) &aux (f (string-match #v"\\*" x b)))
(if (eql f -1) (if (eql b 0) x (subseq x b))
(concatenate 'string (subseq x b f) (subseq s (caar l) (cdar
l)) (r x (cdr l) (1+ f))))))
(r to (match-list fr s))))
(defun translate-pathname-component (x fr to &aux (to (if (if to (eq to :wild)
t) "*" to)))
(cond ((stringp to) (if (stringp x) (repss x fr to) x))
((listp to) (mapcar (lambda (x y z) (translate-pathname-component x y
z)) x fr to))
(to)))
(defun do-repl (x y)
(labels ((r (x l &optional (b 0) &aux (f (string-match #v"\\*" x b)))
(if (eql f -1) (if (eql b 0) x (subseq x b))
(concatenate 'string (subseq x b f) (car l) (r x (cdr l) (1+
f))))))
(r y x)))
(defun splice-pathname (lr lt)
(mapcar (lambda (x y) (if (consp y) (splice-pathname x y)
(cond ((if y (eq y :wild) t) x)
((stringp y) (do-repl x y))
(y)))) lr lt))
#.`(defun translate-pathname (s fr to &key &aux (r (pathname-match-p s fr)))
(apply 'make-pathname (cddr (mapcan 'list '(:host :device :directory :name
:type :version) (splice-pathname r (mlp to))))))
(defun translate-logical-pathname (p &key &aux (p (pathname p)))
(if (typep p 'logical-pathname)
(apply 'translate-pathname p (assoc p (logical-pathname-translations
(pathname-host p)) :test 'pathname-match-p))
p))
(defconstant +d-type-alist+ (d-type-list))
(defun wreaddir (x y &aux (r (readdir x y))(c (consp r))(s (if c (car r) r)))
(cond ((or (member s '("." "..") :test 'string-equal)) (wreaddir x y))
(c (cons s (cdr (assoc (cdr r) +d-type-alist+))))
(r)))
(defun getdir-loop (x y &aux (z (wreaddir x y)))
(if z (cons z (getdir-loop x y)) (progn (closedir x) nil)))
(defun getsdir (x &optional (y :unknown) &aux (x (namestring x)))
(getdir-loop (opendir x) (car (or (rassoc y +d-type-alist+) (rassoc :unknown
+d-type-alist+)))))
(defun getdir (x &optional (y :unknown) &aux (x (namestring x)))
(labels ((mp (s tp) (pathname (concatenate 'string x s (if (eq tp :directory)
"/" "")))))
(mapcar (lambda (q) (if (consp q) (cons (mp (pop q) q) q) (mp q y)))
(getsdir x y))))
(defun getrdir (x &aux (r (getdir x :directory)))
(if r (mapcan 'getrdir r) (list x)))
(defun wjoind (l &aux (w (member :wild l)))
(if w
(let ((d (ldiff l w)))
(mapcan (lambda (x) (wjoind (append d (cons x (cdr w))))) (getsdir
(make-pathname :directory d) :directory)))
(when (stat (make-pathname :directory l))
(list l))))
(defun wjoinp (p)
(mapcar (lambda (x) (make-pathname :directory x)) (wjoind (pathname-directory
p))))
(defun wjoini (p &aux (l (pathname-directory p))(w (member :wild-inferiors l)))
(when w
(remove-if-not (lambda (x) (pathname-match-p x p))
(getrdir (make-pathname :directory (ldiff l w))))))
(defun exppathd (p)
(or (wjoini p) (wjoinp p)))
(defun directory (p &key &aux (p (pathname p))(l (exppathd p)))
(if (or (pathname-name p) (pathname-type p) (pathname-version p))
(let ((pp (make-pathname :name (pathname-name p) :type (pathname-type p)
:version (pathname-version p))))
(mapcan (lambda (x) (when (pathname-match-p x pp) (list
(merge-pathnames x p))))
(mapcan (lambda (x) (mapcar 'pathname (getsdir x :file))) l)))
l))
=============================================================================
