;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; If you want to use this code or any part of CMU Common Lisp, please contact ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment "$Header: files.lisp,v 1.2.1.4 91/07/26 10:25:21 chiles Exp $") ;;; ;;; ********************************************************************** ;;; ;;; Hemlock File manipulation functions. ;;; Written by Skef Wholey, Horribly Hacked by Rob MacLachlan. ;;; (in-package "HEMLOCK-INTERNALS") (export '(read-file write-file)) ;;;; Utility functions. (defun find-char-from-sap (sap start end char) (declare (type system-area-pointer sap) (type (integer 0 (#.most-positive-fixnum)) start end) (type base-character char)) (do ((index start (1+ index)) (code (char-code char))) ((>= index end) nil) (declare (type (integer 0 #.most-positive-fixnum) index) (type (unsigned-byte 8) code)) (when (= (sap-ref-8 sap index) code) (return index)))) ;;; Read-File: (defun read-file (pathname mark) "Inserts the contents of the file named by Pathname at the Mark." (with-mark ((mark mark :left-inserting)) (let* ((tn (truename pathname)) (name (namestring tn)) (sap nil) (size 0)) (declare (fixnum size) (type (or null system-area-pointer) sap)) (multiple-value-bind (fd err) (mach:unix-open name mach:o_rdonly 0) (when fd (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) (mach:unix-fstat fd) (declare (ignore ino mode nlnk uid gid rdev)) (cond ((null res) (setq err dev)) (t (setf sap (system:allocate-system-memory len)) (setf size len) (multiple-value-bind (bytes err3) (mach:unix-read fd sap len) (if (or (null bytes) (not (= len bytes))) (setq err err3) (setq err nil)))))) (mach:unix-close fd)) (when err (error "Reading file ~A, unix error ~A." name (mach:get-unix-error-msg err))) (when (zerop size) (return-from read-file nil)) (let* ((first-line (mark-line mark)) (buffer (line-%buffer first-line)) (index (find-char-from-sap sap 0 size #\newline))) (declare (type (or null (integer 0 (#.most-positive-fixnum))) index)) (modifying-buffer buffer) (let* ((len (or index size)) (chars (make-string len))) (%primitive byte-blt sap 0 chars 0 len) (insert-string mark chars)) (when index (insert-character mark #\newline) (do* ((old-index (1+ index) (1+ index)) (index (find-char-from-sap sap old-index size #\newline) (find-char-from-sap sap old-index size #\newline)) (number (+ (line-number first-line) line-increment) (+ number line-increment)) (previous first-line)) ((not index) (let* ((length (- size old-index)) (chars (make-string length)) (line (mark-line mark))) (declare (fixnum length)) (%primitive byte-blt sap old-index chars 0 length) (insert-string mark chars) (setf (line-next previous) line) (setf (line-previous line) previous) (do ((line line (line-next line)) (number number (+ number line-increment))) ((null line)) (declare (fixnum number)) (setf (line-number line) number)))) (declare (fixnum number old-index)) (let ((line (make-line :previous previous :%buffer buffer :number number :chars (system:sap+ sap old-index) :buffered-p (the fixnum (- (the fixnum index) old-index))))) (setf (line-next previous) line) (setq previous line))) nil)))))) ;;; Hackish stuff for disgusting speed: (defun read-buffered-line (line) (let* ((len (line-buffered-p line)) (chars (make-string len))) (%primitive byte-blt (line-%chars line) 0 chars 0 len) (setf (line-buffered-p line) nil) (setf (line-chars line) chars))) ;;; Write-File: (defun write-file (region pathname &key append (keep-backup (value ed::keep-backup-files)) access) "Writes the characters in region to the file named by pathname. This writes region using a stream opened with :if-exists :rename-and-delete, unless either append or keep-backup is supplied. If append is supplied, this writes the file opened with :if-exists :append. If keep-backup is supplied, this writes the file opened with :if-exists :rename. This signals an error if both append and keep-backup are supplied. Access is an implementation dependent value that is suitable for setting pathname's access or protection bits." (let ((if-exists-action (cond ((and keep-backup append) (error "Cannot supply non-nil values for ~ both keep-backup and append.")) (keep-backup :rename) (append :append) (t :rename-and-delete)))) (with-open-file (file pathname :direction :output :element-type 'base-character :if-exists if-exists-action) (close-line) (fast-write-file region file)) (when access (multiple-value-bind (winp code) ;; Must do a TRUENAME in case the file has never been written. ;; It may have Common Lisp syntax that Unix can't handle. ;; If this is ever moved to the beginning of this function to use ;; Unix CREAT to create the file protected initially, they TRUENAME ;; will signal an error, and LISP::PREDICT-NAME will have to be used. (mach:unix-chmod (namestring (truename pathname)) access) (unless winp (error "Could not set access code: ~S" (mach:get-unix-error-msg code))))))) (defun fast-write-file (region file) (let* ((start (region-start region)) (start-line (mark-line start)) (start-charpos (mark-charpos start)) (end (region-end region)) (end-line (mark-line end)) (end-charpos (mark-charpos end))) (if (eq start-line end-line) (write-string (line-chars start-line) file :start start-charpos :end end-charpos) (let* ((first-length (- (line-length start-line) start-charpos)) (length (+ first-length end-charpos 1))) (do ((line (line-next start-line) (line-next line))) ((eq line end-line)) (incf length (1+ (line-length line)))) (let ((sap (system:allocate-system-memory length))) (unwind-protect (macrolet ((chars (line) `(if (line-buffered-p ,line) (line-%chars ,line) (line-chars ,line)))) (system:%primitive byte-blt (chars start-line) start-charpos sap 0 first-length) (setf (system:sap-ref-8 sap first-length) (char-code #\newline)) (let ((offset (1+ first-length))) (do ((line (line-next start-line) (line-next line))) ((eq line end-line)) (let ((end (+ offset (line-length line)))) (system:%primitive byte-blt (chars line) 0 sap offset end) (setf (system:sap-ref-8 sap end) (char-code #\newline)) (setf offset (1+ end)))) (unless (zerop end-charpos) (system:%primitive byte-blt (chars end-line) 0 sap offset (+ offset end-charpos)))) (multiple-value-bind (okay errno) (mach:unix-write (system:fd-stream-fd file) sap 0 length) (unless okay (error "Could not write ~S: ~A" file (mach:get-unix-error-msg errno))))) (system:deallocate-system-memory sap length)))))))))