Skip to content
Snippets Groups Projects
streams.lisp 10.8 KiB
Newer Older
ram's avatar
ram committed
;;; -*- 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: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/streams.lisp,v 1.1.1.6 1992/02/15 01:02:09 wlott Exp $")
ram's avatar
ram committed
;;; **********************************************************************
;;;
;;;    This file contains definitions of various types of streams used
;;; in Hemlock.  They are implementation dependant, but should be
;;; portable to all implementations based on Spice Lisp with little
;;; difficulty.
;;;
;;; Written by Skef Wholey and Rob MacLachlan.
;;;

(in-package "HEMLOCK-INTERNALS")

(export '(make-hemlock-output-stream
	  hemlock-region-stream hemlock-region-stream-p
	  hemlock-output-stream make-hemlock-region-stream
	  hemlock-output-stream-p make-kbdmac-stream
	  modify-kbdmac-stream))

(defstruct (hemlock-output-stream
	    (:include stream
		      (:misc #'hemlock-output-misc))
	    (:print-function %print-hemlock-output-stream)
	    (:constructor internal-make-hemlock-output-stream ()))
  ;;
  ;; The mark we insert at.
  mark)

(defun %print-hemlock-output-stream (s stream d)
  (declare (ignore d s))
  (write-string "#<Hemlock output stream>" stream))

(defun make-hemlock-output-stream (mark &optional (buffered :line))
  "Returns an output stream whose output will be inserted at the Mark.
  Buffered, which indicates to what extent the stream may be buffered
  is one of the following:
   :None  -- The screen is brought up to date after each stream operation.
   :Line  -- The screen is brought up to date when a newline is written.
   :Full  -- The screen is not updated except explicitly via Force-Output."
  (modify-hemlock-output-stream (internal-make-hemlock-output-stream) mark
                                buffered))


(defun modify-hemlock-output-stream (stream mark buffered)
  (unless (and (markp mark)
	       (memq (mark-kind mark) '(:right-inserting :left-inserting)))
    (error "~S is not a permanent mark." mark))
  (setf (hemlock-output-stream-mark stream) mark)
  (case buffered
    (:none
     (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out
	   (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout))
    (:line
     (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out
	   (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout))
    (:full
     (setf (lisp::stream-out stream) #'hemlock-output-buffered-out
	   (lisp::stream-sout stream) #'hemlock-output-buffered-sout))
    (t
     (error "~S is a losing value for Buffered." buffered)))
  stream)

(defmacro with-left-inserting-mark ((var form) &body forms)
  (let ((change (gensym)))
    `(let* ((,var ,form)
	    (,change (eq (mark-kind ,var) :right-inserting)))
       (unwind-protect
	   (progn
	     (when ,change
	       (setf (mark-kind ,var) :left-inserting))
	     ,@forms)
	 (when ,change
	   (setf (mark-kind ,var) :right-inserting))))))

(defun hemlock-output-unbuffered-out (stream character)
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-character mark character)
    (redisplay-windows-from-mark mark)))

(defun hemlock-output-unbuffered-sout (stream string start end)
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-string mark string start end)
    (redisplay-windows-from-mark mark)))

(defun hemlock-output-buffered-out (stream character)
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-character mark character)))

(defun hemlock-output-buffered-sout (stream string start end)
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-string mark string start end)))

(defun hemlock-output-line-buffered-out (stream character)
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-character mark character)
    (when (char= character #\newline)
      (redisplay-windows-from-mark mark))))

(defun hemlock-output-line-buffered-sout (stream string start end)
  (declare (simple-string string))
  (with-left-inserting-mark (mark (hemlock-output-stream-mark stream))
    (insert-string mark string start end)
    (when (find #\newline string :start start :end end)
      (redisplay-windows-from-mark mark))))

(defun hemlock-output-misc (stream operation &optional arg1 arg2)
  (declare (ignore arg1 arg2))
  (case operation
    (:charpos (mark-charpos (hemlock-output-stream-mark stream)))
    (:line-length
     (let* ((buffer (line-buffer (mark-line (hemlock-output-stream-mark stream)))))
       (when buffer
	 (do ((w (buffer-windows buffer) (cdr w))
	      (min most-positive-fixnum (min (window-width (car w)) min)))
	     ((null w)
	      (if (/= min most-positive-fixnum) min))))))
    ((:finish-output :force-output)
     (redisplay-windows-from-mark (hemlock-output-stream-mark stream)))
    (:close (setf (hemlock-output-stream-mark stream) nil))
    (:element-type 'base-char)))
ram's avatar
ram committed

(defstruct (hemlock-region-stream
	    (:include stream
		      (:in #'region-in)
		      (:misc #'region-misc)
		      (:in-buffer (make-string lisp::in-buffer-length)))
	    (:print-function %print-region-stream)
	    (:constructor internal-make-hemlock-region-stream (region mark)))
  ;;
  ;; The region we read from.
  region
  ;;
  ;; The mark pointing to the next character to read.
  mark)

(defun %print-region-stream (s stream d)
  (declare (ignore s d))
  (write-string "#<Hemlock region stream>" stream))

(defun make-hemlock-region-stream (region)
  "Returns an input stream that will return successive characters from the
  given Region when asked for input."
  (internal-make-hemlock-region-stream
   region (copy-mark (region-start region) :right-inserting)))

(defun modify-hemlock-region-stream (stream region)
  (setf (hemlock-region-stream-region stream) region
	(lisp::stream-in-index stream) lisp::in-buffer-length)
  (let* ((mark (hemlock-region-stream-mark stream))
	 (start (region-start region))
	 (start-line (mark-line start)))
    ;; Make sure it's dead.
    (delete-mark mark)
    (setf (mark-line mark) start-line  (mark-charpos mark) (mark-charpos start))
    (push mark (line-marks start-line)))
  stream)

(defun region-readline (stream eof-errorp eof-value)
  (close-line)
  (let ((mark (hemlock-region-stream-mark stream))
	(end (region-end (hemlock-region-stream-region stream))))
    (cond ((mark>= mark end)
	   (if eof-errorp
	       (error "~A hit end of file." stream)
	       (values eof-value nil)))
	  ((eq (mark-line mark) (mark-line end))
	   (let* ((limit (mark-charpos end))
		  (charpos (mark-charpos mark))
		  (dst-end (- limit charpos))
		  (result (make-string dst-end)))
	     (declare (simple-string result))
	     (%sp-byte-blt (line-chars (mark-line mark)) charpos
			   result 0 dst-end)
	     (setf (mark-charpos mark) limit)
	     (values result t)))
	  ((= (mark-charpos mark) 0)
	   (let* ((line (mark-line mark))
		  (next (line-next line)))
	     (always-change-line mark next)
	     (values (line-chars line) nil)))
	  (t
	   (let* ((line (mark-line mark))
		  (chars (line-chars line))
		  (next (line-next line))
		  (charpos (mark-charpos mark))
		  (dst-end (- (length chars) charpos))
		  (result (make-string dst-end)))
	     (declare (simple-string chars result))
	     (%sp-byte-blt chars charpos result 0 dst-end)
	     (setf (mark-charpos mark) 0)
	     (always-change-line mark next)
	     (values result nil))))))

(defun region-in (stream eof-errorp eof-value)
  (close-line)
  (let* ((mark (hemlock-region-stream-mark stream))
	 (charpos (mark-charpos mark))
	 (line (mark-line mark))
	 (chars (line-chars line))
	 (length (length chars))
	 (last (region-end (hemlock-region-stream-region stream)))
	 (last-line (mark-line last))
	 (buffer (lisp::stream-in-buffer stream))
	 (start 0)
	 (len 0))
    (declare (fixnum length charpos start len)
ram's avatar
ram committed
	     (simple-string chars))
    (cond 
     ((eq line last-line)
      (let ((last-charpos (mark-charpos last)))
	(setq len (- last-charpos charpos))
	(cond
	 ((>= charpos last-charpos)
	  (if eof-errorp
	      (error "~A hit end of file." stream) 
	      (return-from region-in eof-value)))
	 ((> len lisp::in-buffer-length)       
	  (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
	  (setq start 0  len lisp::in-buffer-length))
	 (t
	  (setq start (- lisp::in-buffer-length len))
	  (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length)))))
     ((line> line last-line)
      (if eof-errorp
	  (error "~a hit end of file." stream) 
	  (return-from region-in eof-value)))
     (t
      (setq len (- length charpos))
      (cond
       ((< len lisp::in-buffer-length)
	(let ((end (1- lisp::in-buffer-length)))
	  (setq start (- lisp::in-buffer-length len 1))
	  (%sp-byte-blt chars charpos buffer start end)
	  (setf (schar buffer end) #\newline))
	(incf len))
       (t
	(%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length)
	(setq start 0  len lisp::in-buffer-length)))))
    (setf (lisp::stream-in-index stream) (1+ start))
    (character-offset mark len)
    (schar buffer start)))

(defun region-misc (stream operation &optional arg1 arg2)
  (case operation
    (:listen (mark< (hemlock-region-stream-mark stream)
		    (region-end (hemlock-region-stream-region stream))))
    (:read-line (region-readline stream arg1 arg2))
    (:clear-input (move-mark
                   (hemlock-region-stream-mark stream)
                   (region-end (hemlock-region-stream-region stream))))
    (:close
     (delete-mark (hemlock-region-stream-mark stream))
     (setf (hemlock-region-stream-region stream) nil))
    (:element-type 'base-char)))
ram's avatar
ram committed

;;;; Stuff to support keyboard macros.

(defstruct (kbdmac-stream
ram's avatar
ram committed
	    (:include editor-input
		      (:get #'kbdmac-get)
		      (:unget #'kbdmac-unget)
		      (:listen #'kbdmac-listen))
ram's avatar
ram committed
	    (:constructor make-kbdmac-stream ()))
ram's avatar
ram committed
  buffer    ; The simple-vector that holds the characters.
  index)    ; Index of the next character.
ram's avatar
ram committed

ram's avatar
ram committed
(defun kbdmac-get (stream ignore-abort-attempts-p)
  (declare (ignore ignore-abort-attempts-p))
ram's avatar
ram committed
  (let ((index (kbdmac-stream-index stream)))
ram's avatar
ram committed
    (setf (kbdmac-stream-index stream) (1+ index))
    (setq *last-key-event-typed*
	  (svref (kbdmac-stream-buffer stream) index))))
ram's avatar
ram committed

ram's avatar
ram committed
(defun kbdmac-unget (ignore stream)
  (declare (ignore ignore))
  (if (plusp (kbdmac-stream-index stream))
      (decf (kbdmac-stream-index stream))
      (error "Nothing to unread.")))

(defun kbdmac-listen (stream)
  (declare (ignore stream))
ram's avatar
ram committed
  t)

ram's avatar
ram committed
;;; MODIFY-KBDMAC-STREAM  --  Internal
ram's avatar
ram committed
;;;
;;;    Bash the kbdmac-stream Stream so that it will return the Input.
;;;
(defun modify-kbdmac-stream (stream input)
  (setf (kbdmac-stream-index stream) 0)
  (setf (kbdmac-stream-buffer stream) input)
  stream)