;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.115 1991/08/28 13:52:20 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.116 1991/11/04 20:50:20 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(prompt-for-confirmation?
"File has changed on disk; really want to edit the buffer"))))
(editor-error "File changed on disk: "
- (pathname->string (buffer-pathname buffer))))
+ (->namestring (buffer-pathname buffer))))
(message
"File on disk now will become a backup file if you save these changes.")
(set-buffer-backed-up?! buffer false))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.147 1991/10/29 13:39:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.148 1991/11/04 20:50:26 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (set-buffer-pathname! buffer pathname)
(vector-set! buffer buffer-index:pathname pathname)
(if pathname
- (set-buffer-default-directory! buffer
- (pathname-directory-path pathname)))
+ (set-buffer-default-directory! buffer (directory-pathname pathname)))
(buffer-modeline-event! buffer 'BUFFER-PATHNAME))
(define (set-buffer-truename! buffer truename)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.116 1991/05/10 22:19:16 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.117 1991/11/04 20:50:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(group-length (buffer-group buffer)))
(mode-display-name (buffer-major-mode buffer))
(let ((truename (buffer-truename buffer)))
- (if truename (pathname->string truename) ""))))
+ (if truename (->namestring truename) ""))))
(newline))))
(buffer-list)))))
(set-buffer-point! buffer (line-start (buffer-start buffer) 2))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.10 1991/10/25 00:02:54 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comint.scm,v 1.11 1991/11/04 20:50:38 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
(let ((filename (region->string region)))
(set-current-point! (region-end region))
(comint-filename-complete
- (merge-pathnames (->pathname filename)
- (buffer-default-directory (current-buffer)))
+ (merge-pathnames filename (buffer-default-directory (current-buffer)))
filename
(lambda (filename*)
(region-delete! region)
(lambda ()
(let ((region (comint-current-filename-region)))
(let ((pathname
- (merge-pathnames (->pathname (region->string region))
+ (merge-pathnames (region->string region)
(buffer-default-directory (current-buffer)))))
- (let ((filename (pathname->string pathname)))
+ (let ((filename (->namestring pathname)))
(set-current-point! (region-end region))
(comint-filename-complete
pathname
(pop-up-generated-completions
(lambda ()
(filename-completions-list
- (merge-pathnames
- (->pathname (region->string (comint-current-filename-region)))
- (buffer-default-directory (current-buffer))))))))
+ (merge-pathnames (region->string (comint-current-filename-region))
+ (buffer-default-directory (current-buffer))))))))
(define (comint-current-filename-region)
(let ((point (current-point))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.88 1991/10/21 23:40:40 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.89 1991/11/04 20:50:44 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
((#\d)
(varies (current-point) '(CURRENT-POINT)))
((#\D)
- (prompting
- (pathname->string (prompt-for-directory prompt false false))))
+ (prompting (prompt-for-directory prompt false)))
((#\f)
- (prompting (pathname->string (prompt-for-input-truename prompt false))))
+ (prompting (prompt-for-existing-file prompt false)))
((#\F)
- (prompting (pathname->string (prompt-for-pathname prompt false false))))
+ (prompting (prompt-for-file prompt false)))
((#\k)
(prompting (prompt-for-key prompt (current-comtabs))))
((#\m)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.42 1991/05/10 04:52:20 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.43 1991/11/04 20:50:48 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(if (and (buffer-modified? buffer)
(buffer-writeable? buffer))
(let ((pathname
- (let ((pathname (buffer-pathname buffer)))
- (cond ((not pathname)
- (and (y-or-n? "Save buffer "
- (buffer-name buffer)
- " (Y or N)? ")
- (->pathname (prompt-for-expression "Filename"))))
- ((integer? (pathname-version pathname))
- (pathname-new-version pathname 'NEWEST))
- (else
- pathname)))))
+ (merge-pathnames
+ (let ((pathname (buffer-pathname buffer)))
+ (cond ((not pathname)
+ (and (y-or-n? "Save buffer "
+ (buffer-name buffer)
+ " (Y or N)? ")
+ (prompt-for-expression "Filename")))
+ ((integer? (pathname-version pathname))
+ (pathname-new-version pathname 'NEWEST))
+ (else
+ pathname))))))
(if pathname
- (let ((truename (pathname->output-truename pathname)))
- (let ((filename (pathname->string truename)))
- (if (or (not (file-exists? filename))
- (y-or-n? "File '"
- (pathname->string pathname)
- "' exists. Write anyway (Y or N)? "))
- (begin
- (newline)
- (write-string "Writing file '")
- (write-string filename)
- (write-string "'")
- (write-region (buffer-region buffer) filename false)
- (write-string " -- done")
- (set-buffer-pathname! buffer pathname)
- (set-buffer-truename! buffer truename)
- (buffer-not-modified! buffer)))))))))
+ (let ((filename (->namestring pathname)))
+ (if (or (not (file-exists? pathname))
+ (y-or-n? "File '"
+ filename
+ "' exists. Write anyway (Y or N)? "))
+ (begin
+ (newline)
+ (write-string "Writing file '")
+ (write-string filename)
+ (write-string "'")
+ (write-region (buffer-region buffer) filename false)
+ (write-string " -- done")
+ (set-buffer-pathname! buffer pathname)
+ (set-buffer-truename! buffer (->truename pathname))
+ (buffer-not-modified! buffer))))))))
(define-command debug-count-marks
"Show the number of in-use and GC'ed marks for the current buffer."
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.119 1991/10/26 21:07:59 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.120 1991/11/04 20:50:53 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((directory (->pathname directory)))
(let ((buffer (get-dired-buffer directory)))
(set-buffer-major-mode! buffer (ref-mode-object dired))
- (set-buffer-default-directory! buffer
- (pathname-directory-path directory))
+ (set-buffer-default-directory! buffer (directory-pathname directory))
(buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer)
(buffer-put! buffer 'DIRED-DIRECTORY directory)
(fill-dired-buffer! buffer directory)
(define (get-dired-buffer directory)
(or (list-search-positive (buffer-list)
(lambda (buffer)
- (let ((directory* (buffer-get buffer 'DIRED-DIRECTORY)))
- (and directory*
- (pathname=? directory* directory)))))
+ (equal? directory (buffer-get buffer 'DIRED-DIRECTORY))))
(new-buffer (pathname->buffer-name directory))))
(define (dired-buffer-directory buffer)
(set-buffer-writeable! buffer)
(region-delete! (buffer-region buffer))
(temporary-message
- (string-append "Reading directory "
- (pathname->string pathname)
- "..."))
+ (string-append "Reading directory " (->namestring pathname) "..."))
(read-directory pathname
(ref-variable dired-listing-switches)
(buffer-point buffer))
(set-buffer-read-only! buffer))
(define (read-directory pathname switches mark)
- (let ((directory (pathname-directory-path pathname)))
+ (let ((directory (directory-pathname pathname)))
(if (file-directory? pathname)
(run-synchronous-process false mark directory false
(find-program "ls" false)
switches
- (pathname->string pathname))
+ (->namestring pathname))
(shell-command false mark directory false
(string-append "ls "
switches
" "
- (pathname-name-string pathname))))))
+ (file-namestring pathname))))))
(define (add-dired-entry pathname)
(let ((lstart (line-start (current-point) 0))
- (directory (pathname-directory-path pathname)))
+ (directory (directory-pathname pathname)))
(if (pathname=? (buffer-default-directory (mark-buffer lstart)) directory)
(let ((start (mark-right-inserting lstart)))
(run-synchronous-process false lstart directory false
(find-program "ls" directory)
"-d"
(ref-variable dired-listing-switches)
- (pathname->string pathname))
+ (->namestring pathname))
(insert-string " " start)
(let ((start (mark-right-inserting (dired-filename-start start))))
(insert-string
- (pathname-name-string
- (string->pathname
- (extract-and-delete-string start (line-end start 0))))
+ (file-namestring
+ (extract-and-delete-string start (line-end start 0)))
start))))))
\f
(define-command dired-find-file
"Rename this file to TO-FILE."
(lambda ()
(list
- (pathname->string
+ (->namestring
(let ((pathname (dired-current-pathname)))
(prompt-for-pathname (string-append "Rename "
- (pathname-name-string pathname)
+ (file-namestring pathname)
" to")
pathname
false)))))
"Copy this file to TO-FILE."
(lambda ()
(list
- (pathname->string
+ (->namestring
(let ((pathname (dired-current-pathname)))
(prompt-for-pathname (string-append "Copy "
- (pathname-name-string pathname)
+ (file-namestring pathname)
" to")
pathname
false)))))
(define (dired-change-line program argument)
(let ((pathname (dired-current-pathname)))
- (let ((directory (pathname-directory-path pathname)))
+ (let ((directory (directory-pathname pathname)))
(run-synchronous-process false false directory false
(find-program program directory)
argument
- (pathname->string pathname)))
+ (->namestring pathname)))
(dired-redisplay pathname)))
(define (dired-redisplay pathname)
(define (dired-pathname lstart)
(merge-pathnames
- (pathname-directory-path (dired-buffer-directory (current-buffer)))
- (string->pathname (region->string (dired-filename-region lstart)))))
+ (directory-pathname (dired-buffer-directory (current-buffer)))
+ (region->string (dired-filename-region lstart))))
(define (dired-mark char n)
(with-read-only-defeated (current-point)
(let ((buffer (temporary-buffer " *Deletions*")))
(write-strings-densely
(map (lambda (filename)
- (pathname-name-string (car filename)))
+ (file-namestring (car filename)))
filenames)
(mark->output-port (buffer-point buffer))
(window-x-size (current-window)))
(loop (cdr filenames)
(if (dired-kill-file! (car filenames))
failures
- (cons (pathname-name-string (caar filenames))
+ (cons (file-namestring (caar filenames))
failures))))
((not (null? failures))
(message "Deletions failed: " failures)))))
(define (dired-kill-file! filename)
(let ((deleted?
(catch-file-errors (lambda () false)
- (lambda () (delete-file (car filename))))))
+ (lambda () (delete-file (car filename)) true))))
(if deleted?
(with-read-only-defeated (cdr filename)
(lambda ()
(let ((buffer (temporary-buffer " *Copies*")))
(write-strings-densely
(map (lambda (filename)
- (pathname-name-string (car filename)))
+ (file-namestring (car filename)))
filenames)
(mark->output-port (buffer-point buffer))
(window-x-size (current-window)))
(set-buffer-read-only! buffer)
(let ((destination
(pathname-directory
- (with-selected-buffer
- buffer
- (lambda ()
- (local-set-variable! truncate-partial-width-windows false)
- (prompt-for-directory "Copy these files to directory"
- false
- true))))))
+ (with-selected-buffer buffer
+ (lambda ()
+ (local-set-variable! truncate-partial-width-windows
+ false)
+ (prompt-for-existing-directory
+ "Copy these files to directory"
+ false))))))
(let loop ((filenames filenames) (failures '()))
(cond ((not (null? filenames))
(loop (cdr filenames)
(if (dired-copy-file! (car filenames) destination)
failures
- (cons (pathname-name-string (caar filenames))
+ (cons (file-namestring (caar filenames))
failures))))
((not (null? failures))
(message "Copies failed: " (reverse! failures))))))
and list-directory-verbose-switches."
(lambda ()
(let ((argument (command-argument)))
- (list (pathname->string
- (prompt-for-directory (if argument
- "List directory (verbose)"
- "List directory (brief)")
- false false))
+ (list (prompt-for-directory (if argument
+ "List directory (verbose)"
+ "List directory (brief)")
+ false)
argument)))
(lambda (directory argument)
(let ((directory (->pathname directory))
(disable-group-undo! (buffer-group buffer))
(let ((point (buffer-end buffer)))
(insert-string "Directory " point)
- (insert-string (pathname->string directory) point)
+ (insert-string (->namestring directory) point)
(insert-newline point)
(read-directory directory
(if argument
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.160 1991/10/11 03:31:24 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.161 1991/11/04 20:50:58 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(select-buffer-other-screen (find-file-noselect filename true)))
(define (find-file-noselect filename warn?)
- (let ((pathname (pathname->absolute-pathname (->pathname filename))))
+ (let ((pathname (merge-pathnames filename)))
(if (file-directory? pathname)
(if (ref-variable find-file-run-dired)
(make-dired-buffer (pathname-as-directory pathname))
- (editor-error (pathname->string pathname) " is a directory."))
+ (editor-error (->namestring pathname) " is a directory."))
(let ((buffer (pathname->buffer pathname)))
(if buffer
(begin
(let ((pathname (buffer-pathname buffer)))
(cond ((not (file-exists? pathname))
(editor-error "File "
- (pathname->string pathname)
+ (->namestring pathname)
" no longer exists!"))
((prompt-for-yes-or-no?
(string-append
"Buffer does not seem to be associated with any file"))
((not (file-readable? pathname))
(editor-error "File "
- (pathname->string pathname)
+ (->namestring pathname)
" no longer "
(if (file-exists? pathname) "exists" "readable")
"!"))
((or dont-confirm?
(prompt-for-yes-or-no?
(string-append "Revert buffer from file "
- (pathname->string pathname))))
+ (->namestring pathname))))
;; If file was backed up but has changed since, we
;; should make another backup.
(if (and (not auto-save?)
"File is write protected")
((file-attributes pathname)
"File exists, but is read-protected.")
- ((file-attributes (pathname-directory-path pathname))
+ ((file-attributes (directory-pathname pathname))
"File not found and directory write-protected")
(else
"File not found and directory doesn't exist"))))
(if (and (ref-variable enable-emacs-write-file-message)
(> (buffer-length buffer) 50000))
(message "Saving file "
- (pathname->string (buffer-pathname buffer))
+ (->namestring (buffer-pathname buffer))
"..."))
(write-buffer-interactive buffer backup-mode))
(message "(No changes need to be written)")))
(let ((pathname (buffer-pathname buffer)))
(if pathname
(string-append "Save file "
- (pathname->string pathname))
+ (->namestring pathname))
(string-append "Save buffer "
(buffer-name buffer)))))
(write-buffer-interactive buffer false))))
(lambda (filename)
(set-visited-pathname
(current-buffer)
- (let ((pathname (string->pathname filename)))
- (and (not (string-null? (pathname-name-string pathname)))
+ (let ((pathname (->pathname filename)))
+ (and (not (string-null? (file-namestring pathname)))
pathname)))))
(define (set-visited-pathname buffer pathname)
(insert-file point filename)
(set-current-point! point)
(push-current-mark! mark)))))
-\f
+
(define (pathname->buffer-name pathname)
- (if (pathname-name pathname)
- (pathname-name-string pathname)
- (let ((name
- (let ((directory (pathname-directory pathname)))
- (and (pair? directory)
- (car (last-pair directory))))))
- (if (string? name)
- name
- (pathname->string pathname)))))
+ (file-namestring
+ (let ((pathname (->pathname pathname)))
+ (if (pathname-name pathname)
+ pathname
+ (directory-pathname-as-file pathname)))))
(define (pathname->buffer pathname)
- (or (list-search-positive (buffer-list)
- (lambda (buffer)
- (let ((pathname* (buffer-pathname buffer)))
- (and pathname*
- (pathname=? pathname pathname*)))))
- (let ((truename (pathname->input-truename pathname)))
- (and truename
- (list-search-positive (buffer-list)
- (lambda (buffer)
- (let ((pathname* (buffer-pathname buffer)))
- (and pathname*
- (or (pathname=? pathname pathname*)
- (pathname=? truename pathname*)
- (let ((truename* (buffer-truename buffer)))
- (and truename*
- (pathname=? truename truename*))))))))))))
+ (let ((pathname (->pathname pathname)))
+ (list-search-positive (buffer-list)
+ (lambda (buffer)
+ (equal? pathname (buffer-pathname buffer))))))
\f
(define-command copy-file
"Copy a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
(lambda ()
- (let ((old (prompt-for-input-truename "Copy file" false)))
- (list old (prompt-for-output-truename "Copy to" old))))
+ (let ((old (prompt-for-existing-file "Copy file" false)))
+ (list old (prompt-for-file "Copy to" old))))
(lambda (old new)
(if (or (not (file-exists? new))
(prompt-for-yes-or-no?
(string-append "File "
- (pathname->string new)
+ (->namestring new)
" already exists; copy anyway")))
(begin (copy-file old new)
- (message "Copied " (pathname->string old)
- " => " (pathname->string new))))))
+ (message "Copied " (->namestring old)
+ " => " (->namestring new))))))
(define-command rename-file
"Rename a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
(lambda ()
- (let ((old (prompt-for-input-truename "Rename file" false)))
- (list old (prompt-for-output-truename "Rename to" old))))
+ (let ((old (prompt-for-existing-file "Rename file" false)))
+ (list old (prompt-for-file "Rename to" old))))
(lambda (old new)
(let ((do-it
(lambda ()
(rename-file old new)
- (message "Renamed " (pathname->string old)
- " => " (pathname->string new)))))
+ (message "Renamed " (->namestring old)
+ " => " (->namestring new)))))
(if (file-exists? new)
(if (prompt-for-yes-or-no?
(string-append "File "
- (pathname->string new)
+ (->namestring new)
" already exists; rename anyway"))
(begin (delete-file new) (do-it)))
(do-it)))))
()
(lambda ()
(message "Directory "
- (pathname->string (buffer-default-directory (current-buffer))))))
+ (->namestring (buffer-default-directory (current-buffer))))))
(define-command cd
"Make DIR become the current buffer's default directory."
(let ((buffer (current-buffer)))
(let ((directory
(pathname-as-directory
- (merge-pathnames (->pathname directory)
- (buffer-default-directory buffer)))))
+ (merge-pathnames directory (buffer-default-directory buffer)))))
(if (not (file-directory? directory))
- (editor-error (pathname->string directory) " is not a directory"))
- (if (not (unix/file-access directory 1))
+ (editor-error (->namestring directory) " is not a directory"))
+ (if (not (file-access directory 1))
(editor-error "Cannot cd to "
- (pathname->string directory)
+ (->namestring directory)
": Permission denied"))
(set-buffer-default-directory! buffer directory))))
\f
;;;; Prompting
-(define (prompt-for-input-truename prompt default)
- (pathname->input-truename
- (prompt-for-pathname-non-directory prompt default true)))
+(define (prompt-for-file prompt default)
+ (->namestring
+ (prompt-for-pathname* prompt default file-non-directory? false)))
-(define (prompt-for-output-truename prompt default)
- (pathname->output-truename (prompt-for-pathname prompt default false)))
+(define (prompt-for-existing-file prompt default)
+ (->namestring
+ (prompt-for-pathname* prompt default file-non-directory? true)))
-(define (prompt-for-directory prompt default require-match?)
- (let ((directory
- (prompt-for-pathname* prompt default file-directory? require-match?)))
- (if (file-directory? directory)
- (pathname-as-directory directory)
- directory)))
+(define (file-non-directory? file)
+ (and (file-exists? file)
+ (not (file-directory? file))))
+
+(define (prompt-for-directory prompt default)
+ (->namestring
+ (let ((directory
+ (prompt-for-pathname* prompt default file-directory? false)))
+ (if (file-directory? directory)
+ (pathname-as-directory directory)
+ directory))))
+
+(define (prompt-for-existing-directory prompt default)
+ (->namestring
+ (pathname-as-directory
+ (prompt-for-pathname* prompt default file-directory? true))))
(define-integrable (prompt-for-pathname prompt default require-match?)
(prompt-for-pathname* prompt default file-exists? require-match?))
-(define-integrable (prompt-for-pathname-non-directory
- prompt default require-match?)
- (prompt-for-pathname* prompt
- default
- (lambda (file)
- (and (file-exists? file)
- (not (file-directory? file))))
- require-match?))
-
(define (prompt-for-pathname* prompt directory
verify-final-value? require-match?)
(let ((directory
(if directory
- (pathname-directory-path (->pathname directory))
+ (directory-pathname directory)
(buffer-default-directory (current-buffer)))))
(prompt-string->pathname
(prompt-for-completed-string
(unique-case (car filtered-filenames)))
(else
(non-unique-case filtered-filenames)))))))
- (let ((directory (pathname-directory-string pathname))
- (prefix (pathname-name-string pathname)))
+ (let ((directory (directory-namestring pathname))
+ (prefix (file-namestring pathname)))
(cond ((not (os/file-directory? directory))
(if-not-found))
((string-null? prefix)
(loop directory filenames)))))))
(define (filename-completions-list pathname)
- (let ((directory (pathname-directory-string pathname)))
+ (let ((directory (directory-namestring pathname)))
(canonicalize-filename-completions
directory
(os/directory-list-completions directory
- (pathname-name-string pathname)))))
+ (file-namestring pathname)))))
(define-integrable (prompt-string->pathname string directory)
- (merge-pathnames (string->pathname (os/trim-pathname-string string))
- directory))
+ (merge-pathnames (os/trim-pathname-string string) directory))
(define (canonicalize-filename-completions directory filenames)
(do ((filenames filenames (cdr filenames)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.102 1991/09/17 14:05:09 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.103 1991/11/04 20:51:04 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(define (read-buffer buffer pathname visit?)
(set-buffer-writeable! buffer)
- (let ((truename (pathname->input-truename pathname)))
+ (let ((truename
+ (catch-file-errors (lambda () false)
+ (lambda () (->truename pathname)))))
(if truename
(begin
;; Set modified so that file supercession check isn't done.
(define (insert-file mark filename)
(%insert-file
mark
- (let ((pathname (->pathname filename)))
- (let ((truename (pathname->input-truename pathname)))
- (if (not truename)
- (editor-error "File " (pathname->string pathname) " not found"))
- truename))))
+ (bind-condition-handler (list condition-type:file-error)
+ (lambda (condition)
+ condition
+ (editor-error "File " (->namestring filename) " not found"))
+ (lambda () (->truename filename)))))
(define (%insert-file mark truename)
(if (ref-variable read-file-message)
(let ((msg
(string-append "Reading file \""
- (pathname->string truename)
+ (->namestring truename)
"\"...")))
(temporary-message msg)
(group-insert-file! (mark-group mark) (mark-index mark) truename)
(group-insert-file! (mark-group mark) (mark-index mark) truename)))
(define (group-insert-file! group index truename)
- (let ((channel (file-open-input-channel (pathname->string truename))))
+ (let ((channel (file-open-input-channel (->namestring truename))))
(let ((length (file-length channel)))
(without-interrupts
(lambda ()
(prompt-for-confirmation?
(string-append
"Set local variables as specified at end of "
- (pathname-name-string (buffer-pathname buffer)))))
+ (file-namestring (buffer-pathname buffer)))))
(parse-local-variables buffer start end)))))))))
(define edwin-environment (->environment '(edwin)))
list?)
\f
(define (write-buffer-interactive buffer backup-mode)
- (let ((truename (pathname->output-truename (buffer-pathname buffer))))
- (let ((writable? (file-writable? truename)))
+ (let ((pathname (buffer-pathname buffer)))
+ (let ((writable? (file-writable? pathname)))
(if (or writable?
(prompt-for-yes-or-no?
(string-append "File "
- (pathname-name-string truename)
+ (file-namestring pathname)
" is write-protected; try to save anyway"))
(editor-error
"Attempt to save to a file which you aren't allowed to write"))
(begin
(if (not (or (verify-visited-file-modification-time? buffer)
- (not (file-exists? truename))
+ (not (file-exists? pathname))
(prompt-for-yes-or-no?
"Disk file has changed since visited or saved. Save anyway")))
(editor-error "Save not confirmed"))
- (let ((modes (backup-buffer! buffer truename backup-mode)))
+ (let ((modes (backup-buffer! buffer pathname backup-mode)))
(require-newline buffer)
(cond ((let loop ((hooks (ref-variable write-file-hooks buffer)))
(and (not (null? hooks))
(loop (cdr hooks)))))
unspecific)
((ref-variable file-precious-flag buffer)
- (let ((old (os/precious-backup-pathname truename)))
+ (let ((old (os/precious-backup-pathname pathname)))
(let ((rename-back?
(catch-file-errors (lambda () false)
(lambda ()
- (rename-file truename old)
+ (rename-file pathname old)
(set! modes (file-modes old))
true))))
(dynamic-wind
(lambda ()
(if rename-back?
(begin
- (rename-file old truename)
+ (rename-file old pathname)
(clear-visited-file-modification-time!
buffer))))))))
(else
(if (and (not writable?)
(not modes)
- (file-exists? truename))
+ (file-exists? pathname))
(bind-condition-handler
(list condition-type:file-error)
(lambda (condition)
condition
(editor-error
"Can't get write permission for file: "
- (pathname->string truename)))
+ (->namestring pathname)))
(lambda ()
- (let ((m (file-modes truename)))
- (set-file-modes! truename #o777)
+ (let ((m (file-modes pathname)))
+ (set-file-modes! pathname #o777)
(set! modes m)))))
(write-buffer buffer)))
(if modes
(catch-file-errors
(lambda () unspecific)
- (lambda () (set-file-modes! truename modes))))))))))
+ (lambda () (set-file-modes! pathname modes))))))))))
\f
(define (verify-visited-file-modification-time? buffer)
(let ((truename (buffer-truename buffer))
(define (write-buffer buffer)
(let ((truename
- (string->pathname
+ (->pathname
(write-region (buffer-unclipped-region buffer)
(buffer-pathname buffer)
true))))
- (if truename
- (begin
- (set-buffer-truename! buffer truename)
- (delete-auto-save-file! buffer)
- (set-buffer-save-length! buffer)
- (buffer-not-modified! buffer)
- (set-buffer-modification-time! buffer
- (file-modification-time truename))))))
+ (set-buffer-truename! buffer truename)
+ (delete-auto-save-file! buffer)
+ (set-buffer-save-length! buffer)
+ (buffer-not-modified! buffer)
+ (set-buffer-modification-time! buffer (file-modification-time truename))))
\f
(define-variable enable-emacs-write-file-message
"If true, generate Emacs-style message when writing files.
boolean?)
(define (write-region region filename message?)
- (let ((filename (canonicalize-output-filename filename))
- (start (region-start-index region))
- (end (region-end-index region)))
- (let ((do-it
- (lambda ()
- (group-write-to-file (region-group region) start end filename))))
- (cond ((not message?)
- (do-it))
- ((or (ref-variable enable-emacs-write-file-message)
- (<= (- end start) 50000))
- (do-it)
- (message "Wrote " filename))
- (else
- (let ((msg (string-append "Writing file " filename "...")))
- (message msg)
- (do-it)
- (message msg "done")))))
- filename))
+ (write-region* region filename message? group-write-to-file))
(define (append-to-file region filename message?)
- (let ((filename (canonicalize-overwrite-filename filename))
+ (write-region* region filename message? group-append-to-file))
+
+(define (write-region* region filename message? group-write-to-file)
+ (let ((filename (->namestring filename))
(start (region-start-index region))
(end (region-end-index region)))
(let ((do-it
(lambda ()
- (group-append-to-file (region-group region) start end filename))))
+ (group-write-to-file (region-group region) start end filename))))
(cond ((not message?)
(do-it))
((or (ref-variable enable-emacs-write-file-message)
- (< (- end start) 50000))
+ (<= (- end start) 50000))
(do-it)
(message "Wrote " filename))
(else
(message msg)
(do-it)
(message msg "done")))))
+ ;; This isn't the correct truename on systems that support version
+ ;; numbers. For those systems, the truename must be supplied by
+ ;; the operating system after the channel is closed.
filename))
(define (group-write-to-file group start end filename)
(temporary-message
"Cannot write backup file; backing up in "
filename)
- (copy-file truename (string->pathname filename))
+ (copy-file truename filename)
false))
(lambda ()
(if (or (ref-variable file-precious-flag buffer)
(prompt-for-confirmation?
(string-append
"Delete excess backup versions of "
- (pathname->string (buffer-pathname buffer))))))
+ (->namestring (buffer-pathname buffer))))))
(for-each (lambda (target)
(catch-file-errors
(lambda () unspecific)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.100 1991/08/06 15:39:10 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.101 1991/11/04 20:51:09 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
()
(lambda ()
(delete-other-windows (current-window))
- (let ((pathname
- (merge-pathnames (string->pathname "TUTORIAL")
- (home-directory-pathname))))
+ (let ((pathname (merge-pathnames "TUTORIAL" (user-homedir-pathname))))
(let ((buffer (pathname->buffer pathname)))
(if buffer
(select-buffer buffer)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.107 1991/10/18 16:02:39 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.108 1991/11/04 20:51:14 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
"Info: ("
(let ((pathname (ref-variable info-current-file)))
(if pathname
- (pathname-name-string pathname)
+ (file-namestring pathname)
""))
")"
(or (ref-variable info-current-node) ""))))
(begin
(let ((pathname (subfile-pathname (car subfiles))))
(message "Searching subfile "
- (pathname-name-string pathname)
+ (file-namestring pathname)
"...")
(set-current-subfile! pathname))
(let ((mark (perform-search (buffer-start buffer))))
;; unless filename is explicitly self-relative.
(if (let ((directory (pathname-directory pathname)))
(and (pair? directory)
- (eq? (car directory) 'SELF)))
+ (eq? (car directory) 'RELATIVE)
+ (pair? (cdr directory))
+ (equal? (cadr directory) ".")))
(buffer-default-directory (current-buffer))
- (let ((info-directory
- (ref-variable info-directory)))
- (if info-directory
- (->pathname info-directory)
- (edwin-info-directory))))))))
+ (or (ref-variable info-directory)
+ (edwin-info-directory)))))))
(if (file-exists? pathname)
pathname
(let ((pathname*
(ref-variable info-current-node)
(mark-index (current-point))))
;; Switch files if necessary.
- (if (and pathname
- (let ((pathname* (ref-variable info-current-file)))
- (not (and pathname* (pathname=? pathname pathname*)))))
+ (if (and pathname (equal? pathname (ref-variable info-current-file)))
(begin
(read-buffer buffer pathname true)
(if (not (eq? (buffer-major-mode buffer) (ref-mode-object info)))
(loop (cdr subfiles)))))
(define (set-current-subfile! pathname)
- (let ((subfile (ref-variable info-current-subfile)))
- (if (or (not subfile)
- (not (pathname=? subfile pathname)))
- (begin
- (read-buffer (current-buffer) pathname true)
- (set-variable! info-current-subfile pathname)))))
+ (if (not (equal? pathname (ref-variable info-current-subfile)))
+ (begin
+ (read-buffer (current-buffer) pathname true)
+ (set-variable! info-current-subfile pathname))))
(define-integrable subfile-filename car)
(define-integrable subfile-index cdr)
(define (subfile-pathname subfile)
- (merge-pathnames (->pathname (subfile-filename subfile))
+ (merge-pathnames (subfile-filename subfile)
(ref-variable info-current-file)))
(define (subfile-list)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.61 1991/10/25 00:16:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.62 1991/11/04 20:51:20 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 61 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 62 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.11 1991/08/28 22:28:33 arthur Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modlin.scm,v 1.12 1991/11/04 20:51:24 cph Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
(cond ((not pathname)
"[none]")
((pathname? pathname)
- (os/truncate-filename-for-modeline (pathname->string pathname)
+ (os/truncate-filename-for-modeline (->namestring pathname)
max-width))
(else
""))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/paths.scm,v 1.10 1991/07/16 21:00:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/paths.scm,v 1.11 1991/11/04 20:51:29 cph Exp $
Copyright (c) 1989-91 Massachusetts Institute of Technology
(declare (usual-integrations))
(define edwin-library-directory-pathname
- (let ((directory (pathname-as-directory (string->pathname "edwin"))))
+ (let ((directory (pathname-as-directory "edwin")))
(lambda (name)
(let ((pathname
(system-library-directory-pathname
- (merge-pathnames (->pathname name) directory))))
+ (merge-pathnames name directory))))
(if (not pathname)
(error "Can't find edwin library directory:" name))
pathname))))
(define (edwin-etc-pathname filename)
- (let ((pathname
- (merge-pathnames (->pathname filename) (edwin-etc-directory))))
+ (let ((pathname (merge-pathnames filename (edwin-etc-directory))))
(if (not (file-exists? pathname))
- (error "Unable to find file:" (pathname->string pathname)))
+ (error "Unable to find file:" (->namestring pathname)))
pathname))
(define (edwin-binary-directory)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.12 1991/10/29 13:48:22 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.13 1991/11/04 20:51:36 cph Exp $
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
;;; These procedures are not specific to the process abstraction.
(define (find-program program default-directory)
- (pathname->string
- (let ((program (->pathname program))
- (lose (lambda () (error "Can't find program:" program))))
+ (->namestring
+ (let ((lose
+ (lambda () (error "Can't find program:" (->namestring program)))))
(cond ((pathname-absolute? program)
- (if (not (unix/file-access program 1)) (lose))
+ (if (not (file-access program 1)) (lose))
program)
((not default-directory)
(let loop ((path (ref-variable exec-path)))
(or (and (car path)
(pathname-absolute? (car path))
(let ((pathname (merge-pathnames program (car path))))
- (and (unix/file-access pathname 1)
+ (and (file-access pathname 1)
pathname)))
(loop (cdr path)))))
(else
- (let ((default-directory
- (pathname->absolute-pathname default-directory)))
+ (let ((default-directory (merge-pathnames default-directory)))
(let loop ((path (ref-variable exec-path)))
(if (null? path) (lose))
(let ((pathname
((pathname-absolute? (car path)) (car path))
(else (merge-pathnames (car path)
default-directory))))))
- (if (unix/file-access pathname 1)
+ (if (file-access pathname 1)
pathname
(loop (cdr path)))))))))))
(let ((end (string-length string))
(substring
(lambda (string start end)
- (pathname-as-directory
- (string->pathname (substring string start end))))))
+ (pathname-as-directory (substring string start end)))))
(let loop ((start 0))
(if (< start end)
(let ((index (substring-find-next-char string start end #\:)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.10 1991/10/26 21:08:26 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.11 1991/11/04 20:51:47 cph Exp $
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
(let ((inboxes (parse-file-inboxes buffer)))
(if (and (null? inboxes)
(pathname=? (buffer-pathname buffer)
- (->pathname (ref-variable rmail-file-name))))
+ (ref-variable rmail-file-name)))
(ref-variable rmail-primary-inbox-list)
inboxes)))
(buffer-put! buffer 'REVERT-BUFFER-METHOD rmail-revert-buffer)
but does not copy any new mail into the file."
(lambda ()
(list (and (command-argument)
- (pathname->string
- (prompt-for-input-truename "Run rmail on RMAIL file"
- false)))))
+ (prompt-for-existing-file "Run rmail on RMAIL file" false))))
(lambda (filename)
(rmail-find-file (or filename (ref-variable rmail-file-name)))
(let ((mode (current-major-mode)))
and use that file as the inbox."
(lambda ()
(list (and (command-argument)
- (pathname->string
- (prompt-for-input-truename "Get new mail from file"
- false)))))
+ (prompt-for-existing-file "Get new mail from file" false))))
(lambda (filename)
(let ((buffer (current-buffer)))
(rmail-find-file-revert buffer)
(let ((source (->pathname filename)))
(cond ((not rename?)
(insert source))
- ((string=? rmail-spool-directory
- (pathname-directory-string source))
+ ((string=? rmail-spool-directory (directory-namestring source))
(rename-inbox-using-movemail source
insert
(buffer-default-directory buffer)))
(rename-inbox-using-rename source insert))))))
(define (rename-inbox-using-rename source insert)
- (let ((target
- (string->pathname (string-append (pathname->string source) "~"))))
+ (let ((target (string-append (->namestring source) "~")))
(let ((msg
(string-append "Getting mail from "
- (pathname->string source)
+ (->namestring source)
"...")))
(message msg)
(if (and (file-exists? source) (not (file-exists? target)))
;; On some systems, /usr/spool/mail/foo is a directory and
;; the actual inbox is /usr/spool/mail/foo/foo.
(if (file-directory? source)
- (merge-pathnames (string->pathname (pathname-name source))
+ (merge-pathnames (pathname-name source)
(pathname-as-directory source))
source))
- (target
- (merge-pathnames (string->pathname ".newmail")
- (->pathname directory))))
+ (target (merge-pathnames ".newmail" directory)))
(let ((msg
- (string-append "Getting mail from "
- (pathname->string source)
- "...")))
+ (string-append "Getting mail from " (->namestring source) "...")))
(message msg)
(if (and (file-exists? source)
(not (file-exists? target)))
(let ((start (buffer-start error-buffer))
(end (buffer-end error-buffer)))
(run-synchronous-process false start false false
- (pathname->string
+ (->namestring
(edwin-etc-pathname "movemail"))
- (pathname->string source)
- (pathname->string target))
+ (->namestring source)
+ (->namestring target))
(if (mark< start end)
(error
(let ((m
buffer visiting that file."
(lambda ()
(list
- (pathname->string
+ (->namestring
(get-rmail-output-pathname "Output message to Rmail file"
(ref-variable rmail-last-rmail-file)))))
(lambda (filename)
(let* ((pathname (->pathname filename))
- (filename (pathname->string pathname)))
+ (filename (->namestring pathname)))
(set-variable! rmail-last-rmail-file filename)
(let* ((memo (current-msg-memo))
(message
"Append this message to Unix mail file named FILE-NAME."
(lambda ()
(list
- (pathname->string
+ (->namestring
(get-rmail-output-pathname "Output message to Unix mail file"
(ref-variable rmail-last-file)))))
(lambda (filename)
(let* ((pathname (->pathname filename)))
- (set-variable! rmail-last-file (pathname->string pathname))
+ (set-variable! rmail-last-file (->namestring pathname))
(let ((memo (current-msg-memo)))
(let ((buffer (temporary-buffer " rmail output")))
(let ((end (mark-left-inserting-copy (buffer-end buffer))))
(define (get-rmail-output-pathname prompt default)
(let ((default (->pathname default)))
- (let ((name (pathname-name-path default)))
+ (let ((name (file-pathname default)))
(let ((pathname
(prompt-for-pathname
- (string-append prompt " (default " (pathname->string name) ")")
- (pathname-directory-path default)
+ (string-append prompt " (default " (->namestring name) ")")
+ (directory-pathname default)
false)))
(if (file-directory? pathname)
(merge-pathnames name (pathname-as-directory pathname))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.11 1991/10/26 21:08:33 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.12 1991/11/04 20:51:55 cph Exp $
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
(define-variable sendmail-program
"Filename of sendmail program."
- "/usr/lib/sendmail"
+ (if (file-exists? "/usr/lib/sendmail")
+ "/usr/lib/sendmail"
+ "fakemail")
string?)
(define-variable mail-yank-ignored-headers
(extract-string (re-match-start 1) (re-match-end 1))))
(move-mark-to! m (line-start (re-match-start 0) 0))
(delete-string m (line-start m 1))
- (loop (cons (string->pathname filename) pathnames)))
+ (loop (cons (->pathname filename) pathnames)))
(begin
(mark-temporary! m)
pathnames)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.7 1991/10/25 00:03:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/shell.scm,v 1.8 1991/11/04 20:52:03 cph Exp $
Copyright (c) 1991 Massachusetts Institute of Technology
(let ((variable
(string-table-get editor-variables
(string-append "explicit-"
- (pathname-name-string
- (->pathname program))
+ (file-namestring program)
"-args"))))
(if variable
(variable-value variable)
\f
(define (shell-process-pushd arg)
(let ((default-directory
- (pathname->string (buffer-default-directory (current-buffer))))
+ (->namestring (buffer-default-directory (current-buffer))))
(dirstack (ref-variable shell-dirstack)))
(if (string-null? arg)
;; no arg -- swap pwd and car of shell stack
(lambda ()
(set-default-directory
(if (string-null? filename)
- (home-directory-pathname)
+ (user-homedir-pathname)
filename))))))
(shell-dirstack-message))
((dirs
(cons (buffer-default-directory (current-buffer))
(ref-variable shell-dirstack))))
- (cons (os/pathname->display-string (->pathname (car dirs)))
+ (cons (os/pathname->display-string (car dirs))
(if (null? (cdr dirs))
'()
(cons " " (loop (cdr dirs))))))))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.43 1991/10/11 03:32:51 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.44 1991/11/04 20:52:09 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(let ((pathname
(merge-pathnames
(tag->pathname tag)
- (pathname-directory-path (buffer-pathname buffer))))
+ (directory-pathname (buffer-pathname buffer))))
(regexp
(string-append
"^"
(if (not mark)
(editor-failure regexp
" not found in "
- (pathname-name-string pathname))
+ (file-namestring pathname))
(set-current-point! (line-start mark 0))))))))))
(define find-tag-match-regexp
(set! tags-loop-pathnames (cdr pathnames))
(find-file (car pathnames))
(message "Scanning file "
- (pathname->string (buffer-truename (current-buffer)))
+ (->namestring (buffer-truename (current-buffer)))
"...")
(set-current-point! (buffer-start (current-buffer)))
(tags-loop-continuation)))))
(revert-buffer buffer true true))
(if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
(editor-error "File "
- (pathname->string pathname)
+ (->namestring pathname)
" not a valid tag table"))
buffer)))
(let ((mark (mark+ (line-start file-mark 1)
(with-input-from-mark file-mark read))))
(if (mark> mark tag)
- (string->pathname (extract-string (line-start file-mark 0)
- (mark-1+ file-mark)))
+ (->pathname (extract-string (line-start file-mark 0)
+ (mark-1+ file-mark)))
(loop mark)))))
(loop (group-start tag)))
(or (buffer-get buffer tags-table-pathnames)
(let ((pathnames
(let ((directory
- (pathname-directory-path (buffer-truename buffer))))
+ (directory-pathname (buffer-truename buffer))))
(let loop ((mark (buffer-start buffer)))
(let ((file-mark
(skip-chars-backward "^,\n" (line-end mark 1))))
(mark+ (line-start file-mark 1)
(with-input-from-mark file-mark read))))
(cons (merge-pathnames
- (string->pathname
- (extract-string (line-start file-mark 0)
- (mark-1+ file-mark)))
+ (extract-string (line-start file-mark 0)
+ (mark-1+ file-mark))
directory)
(if (group-end? mark)
'()
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.18 1991/10/23 06:14:21 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.19 1991/11/04 20:52:15 cph Exp $
;;;
;;; Copyright (c) 1989-91 Massachusetts Institute of Technology
;;;
(loop (-1+ slash))))))))
(define (os/pathname->display-string pathname)
- (let ((relative (pathname-relative? pathname (home-directory-pathname))))
- (if relative
- (string-append "~/" (pathname->string relative))
- (pathname->string pathname))))
+ (let ((pathname (enough-pathname pathname (user-homedir-pathname))))
+ (if (pathname-absolute? pathname)
+ (->namestring pathname)
+ (string-append "~/" (->namestring pathname)))))
(define (os/filename->display-string filename)
(let ((home (unix/current-home-directory)))
(define (os/auto-save-pathname pathname buffer)
(let ((wrap
(lambda (name directory)
- (merge-pathnames (string->pathname (string-append "#" name "#"))
- directory))))
+ (merge-pathnames (string-append "#" name "#") directory))))
(if (not pathname)
(wrap (string-append "%" (buffer-name buffer))
(buffer-default-directory buffer))
- (wrap (pathname-name-string pathname)
- (pathname-directory-path pathname)))))
+ (wrap (file-namestring pathname)
+ (directory-pathname pathname)))))
(define (os/precious-backup-pathname pathname)
- (string->pathname (string-append (pathname->string pathname) "#")))
+ (->pathname (string-append (->namestring pathname) "#")))
(define (os/backup-buffer? truename)
(and (memv (string-ref (vector-ref (file-attributes truename) 8) 0)
(not
(let ((directory (pathname-directory truename)))
(and (pair? directory)
- (eq? 'ROOT (car directory))
+ (eq? 'ABSOLUTE (car directory))
(pair? (cdr directory))
(eqv? "tmp" (cadr directory)))))))
(define (os/default-backup-filename)
"~/%backup%~")
+
+(define (os/truncate-filename-for-modeline filename width)
+ (let ((length (string-length filename)))
+ (if (< 0 width length)
+ (let ((result
+ (substring
+ filename
+ (let ((index (- length width)))
+ (or (and (not (char=? #\/ (string-ref filename index)))
+ (substring-find-next-char filename index length
+ #\/))
+ (1+ index)))
+ length)))
+ (string-set! result 0 #\$)
+ result)
+ filename)))
\f
(define (os/backup-by-copying? truename)
(let ((attributes (file-attributes truename)))
(let ((no-versions
(lambda ()
(values
- (string->pathname (string-append (pathname->string truename) "~"))
+ (->pathname (string-append (->namestring truename) "~"))
'()))))
(if (eq? 'NEVER (ref-variable version-control))
(no-versions)
- (let ((prefix (string-append (pathname-name-string truename) ".~")))
+ (let ((prefix (string-append (file-namestring truename) ".~")))
(let ((filenames
(os/directory-list-completions
- (pathname-directory-string truename)
+ (directory-namestring truename)
prefix))
(prefix-length (string-length prefix)))
(let ((possibilities
(if (or (ref-variable version-control)
(positive? high-water-mark))
(let ((version->pathname
- (let ((directory
- (pathname-directory-path truename)))
+ (let ((directory (directory-pathname truename)))
(lambda (version)
(merge-pathnames
- (string->pathname
- (string-append prefix
- (number->string version)
- "~"))
+ (string-append prefix
+ (number->string version)
+ "~")
directory)))))
(values
(version->pathname (1+ high-water-mark))
'()))))
(no-versions))))))))))
\f
-(define (os/make-dired-line pathname)
- (let ((attributes (file-attributes pathname)))
- (and attributes
- (string-append
- " "
- (file-attributes/mode-string attributes)
- " "
- (pad-on-left-to
- (number->string (file-attributes/n-links attributes) 10)
- 3)
- " "
- (pad-on-right-to (unix/uid->string (file-attributes/uid attributes))
- 8)
- " "
- (pad-on-right-to (unix/gid->string (file-attributes/gid attributes))
- 8)
- " "
- (pad-on-left-to
- (number->string (file-attributes/length attributes) 10)
- 7)
- " "
- (substring (unix/file-time->string
- (file-attributes/modification-time attributes))
- 4
- 16)
- " "
- (pathname-name-string pathname)
- (let ((type (file-attributes/type attributes)))
- (if (string? type)
- (string-append " -> " type)
- ""))))))
-
-(define (os/dired-filename-region lstart)
- (let ((lend (line-end lstart 0)))
- (if (not (re-search-forward
- "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\) +[0-9]+ +[0-9:]+ "
- lstart
- lend))
- (editor-error "No filename on this line"))
- (make-region (re-match-end 0) lend)))
-
-(define (os/dired-sort-pathnames pathnames)
- (sort pathnames
- (lambda (x y)
- (string<? (pathname-name-string x) (pathname-name-string y)))))
-
-(define (os/truncate-filename-for-modeline filename width)
- (let ((length (string-length filename)))
- (if (< 0 width length)
- (let ((result
- (substring
- filename
- (let ((index (- length width)))
- (or (and (not (char=? #\/ (string-ref filename index)))
- (substring-find-next-char filename index length
- #\/))
- (1+ index)))
- length)))
- (string-set! result 0 #\$)
- result)
- filename)))
-\f
(define (os/directory-list directory)
((ucode-primitive directory-close 0))
((ucode-primitive directory-open-noread 1) directory)
(define (os/init-file-name)
"~/.edwin")
-\f
-(define os/find-file-initialization-filename
- (let ((name-path (string->pathname ".edwin-ffi")))
- (lambda (pathname)
- (or (and (equal? "scm" (pathname-type pathname))
- (let ((pathname (pathname-new-version pathname "ffi")))
- (and (file-exists? pathname)
- pathname)))
- (let ((pathname
- (merge-pathnames name-path
- (pathname-directory-path pathname))))
- (and (file-exists? pathname)
- pathname))))))
-(define-integrable (file-readable? filename)
- (unix/file-access filename 4))
\ No newline at end of file
+(define (os/find-file-initialization-filename pathname)
+ (or (and (equal? "scm" (pathname-type pathname))
+ (let ((pathname (pathname-new-type pathname "ffi")))
+ (and (file-exists? pathname)
+ pathname)))
+ (let ((pathname
+ (merge-pathnames ".edwin-ffi" (directory-pathname pathname))))
+ (and (file-exists? pathname)
+ pathname))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.25 1991/05/16 23:06:00 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.26 1991/11/04 20:52:22 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
;;;
(continuation (if-error)))
thunk))))
-(define (pathname=? x y)
- (string=? (pathname->string x)
- (pathname->string y)))
-
(define (string-or-false? object)
;; Useful as a type for option variables.
(or (false? object)
projects / mit-scheme.git / commitdiff