Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2446
Modified Files: file-commands.lisp Log Message: These definitions are not necessary anymore (and haven't been for quite a while).
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/11/12 16:06:06 1.26 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/12/18 17:54:40 1.27 @@ -30,91 +30,6 @@
(in-package :climacs-commands)
-(defun filename-completer (so-far mode) - (flet ((remove-trail (s) - (subseq s 0 (let ((pos (position #/ s :from-end t))) - (if pos (1+ pos) 0))))) - (let* ((directory-prefix - (if (and (plusp (length so-far)) (eql (aref so-far 0) #/)) - "" - (namestring #+sbcl *default-pathname-defaults* - #+cmu (ext:default-directory) - #-(or sbcl cmu) *default-pathname-defaults*))) - (full-so-far (concatenate 'string directory-prefix so-far)) - (pathnames - (loop with length = (length full-so-far) - and wildcard = (concatenate 'string (remove-trail so-far) "*.*") - for path in - #+(or sbcl cmu lispworks) (directory wildcard) - #+openmcl (directory wildcard :directories t) - #+allegro (directory wildcard :directories-are-files nil) - #+cormanlisp (nconc (directory wildcard) - (cl::directory-subdirs dirname)) - #-(or sbcl cmu lispworks openmcl allegro cormanlisp) - (directory wildcard) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) - (strings (mapcar #'namestring pathnames)) - (first-string (car strings)) - (length-common-prefix nil) - (completed-string nil) - (full-completed-string nil)) - (unless (null pathnames) - (setf length-common-prefix - (loop with length = (length first-string) - for string in (cdr strings) - do (setf length (min length (or (mismatch string first-string) length))) - finally (return length)))) - (unless (null pathnames) - (setf completed-string - (subseq first-string (length directory-prefix) - (if (null (cdr pathnames)) nil length-common-prefix))) - (setf full-completed-string - (concatenate 'string directory-prefix completed-string))) - (case mode - ((:complete-limited :complete-maximal) - (cond ((null pathnames) - (values so-far nil nil 0 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:complete - (cond ((null pathnames) - (values so-far t so-far 1 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - ((find full-completed-string strings :test #'string-equal) - (let ((pos (position full-completed-string strings :test #'string-equal))) - (values completed-string - t (elt pathnames pos) (length pathnames) nil))) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:possibilities - (values nil nil nil (length pathnames) - (loop with length = (length directory-prefix) - for name in pathnames - collect (list (subseq (namestring name) length nil) - name)))))))) - -(define-presentation-method present (object (type pathname) - stream (view drei-textual-view) &key) - (princ (namestring object) stream)) - -(define-presentation-method accept ((type pathname) stream (view drei-textual-view) - &key (default nil defaultp) (default-type type)) - (multiple-value-bind (pathname success string) - (complete-input stream - #'filename-completer - :allow-any-input t) - (cond (success - (values (or pathname (parse-namestring string)) type)) - ((and (zerop (length string)) - defaultp) - (values default default-type)) - (t (values string 'string))))) - (define-command (com-reparse-attribute-list :name t :command-table buffer-table) () "Reparse the current buffer's attribute list.