Artifact 43cb2f493fb2d1d6df208e136dbd1989a26452498485ba0f6be74e6dfa5b0b79:

• File psl-1983/3-1/nmode/buffer-io.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7833) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/nmode/buffer-io.sl — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7833) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Buffer-IO.SL - PSL I/O to and from NMODE buffers
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        26 August 1982
% Revised:     18 February 1983
%
% Adapted from Will Galway's EMODE
%
% 18-Feb-83 Alan Snyder
%   Fix to adjust an exposed window when displaying output.
% 16-Feb-83 Alan Snyder
%   Recode using objects; add output cache for efficiency.
%   Remove time-since-last-redisplay check (it causes a 2X slowdown);
%   now display output only after Newline or cache full.
%   Declare -> Declare-Flavor.
% 30-Dec-82 Alan Snyder
%   Add declarations for buffers and windows; use fast-vectors (for efficiency).
% 27-Dec-82 Alan Snyder
%   Use generic arithmetic for Time (for portability); reformat.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects fast-vectors))

(fluid '(nmode-current-window *nmode-init-running))

(DefConst MaxChannels 32) % Maximum number of channels supported by PSL.

(defflavor buffer-channel
  (
   (editor-function NIL)	% NIL or a function to obtain new input
   (input-buffer NIL)		% NIL or a buffer to obtain input from
   (input-position NIL)		% the current read pointer
   (output-buffer NIL)		% NIL or a buffer to send output to
   (output-cache NIL)		% cache of output (for efficiency)
   output-cache-pos		% pointer into output cache
   )
  ()
  (settable-instance-variables)
  )

(fluid '(buffer-channel-vector))

(when (or (not (BoundP 'buffer-channel-vector)) (null buffer-channel-vector))
  (setf buffer-channel-vector (MkVect (const MaxChannels)))
  )

(fluid '(*outwindow		% T => expose output window on output
	 ))

(setf *outwindow T)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(declare-flavor text-buffer input-buffer output-buffer)
(declare-flavor buffer-window w)
(declare-flavor buffer-channel bc)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de OpenBufferChannel (input-buffer output-buffer Editor)

  % Open a channel for buffer I/O.  Input-Buffer and Output-Buffer may be buffer
  % objects or NIL.  Input will be read from the current location in the Input
  % Buffer.  Output will be inserted at the current location in the Output
  % Buffer.  Editor may be a function object (ID) or NIL.  The Editor function
  % can be used if you want something to "happen" every time a reader begins to
  % read from the channel.  If Editor is NIL, then the reader will simply
  % continue reading from the current location in the input buffer.

  (setf SpecialWriteFunction* 'buffer-print-character)
  (setf SpecialReadFunction* 'buffer-read-character)
  (setf SpecialCloseFunction* 'buffer-channel-close)
  (let ((chn (open "buffers" 'SPECIAL))
	(bc (make-instance 'buffer-channel))
	)
    (vector-store buffer-channel-vector chn bc)
    (=> bc set-input-buffer input-buffer)
    (=> bc set-input-position (and input-buffer (=> input-buffer position)))
    (=> bc set-output-buffer output-buffer)
    (=> bc set-editor-function Editor)
    chn
    ))

(de buffer-channel-close (chn)
  % Close up an NMODE buffer channel.
  (vector-store buffer-channel-vector chn NIL)
  )

(de buffer-channel-set-input-buffer (chn input-buffer)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc set-input-buffer input-buffer)
      (=> bc set-input-position (=> input-buffer position))
      )))

(de buffer-channel-set-input-position (chn bp)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc set-input-position bp)
      )))

(de buffer-channel-set-output-buffer (chn output-buffer)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc set-output-buffer output-buffer)
      )))

(de buffer-print-character (chn ch)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc putc ch)
      )))

(de buffer-channel-flush (chn)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc flush)
      )))

(defmethod (buffer-channel flush) ()
  % If there is output lingering in the output cache, then append it to the
  % output buffer and return T.  Otherwise return NIL.

  (when (and output-buffer output-cache (> output-cache-pos 0))
    (let ((old-pos (=> output-buffer position)))
      (=> output-buffer move-to-buffer-end)
      (=> output-buffer insert-string
	  (substring output-cache 0 output-cache-pos))
      (=> output-buffer set-position old-pos)
      (setf output-cache-pos 0)
      T
      )))

(defmethod (buffer-channel refresh) ()
  % If this channel is being used for output, then refresh the display of that
  % output.  The buffer will automatically be exposed in a window (if
  % requested by the *OutWindow flag), the output cache will be flushed, the
  % display window will be adjusted, and the screen refreshed.

  (when output-buffer
    (if (and *OutWindow
	     (not *nmode-init-running)
	     (not (buffer-is-displayed? output-buffer)))
      (nmode-expose-output-buffer output-buffer))
    (let ((window-list (find-buffer-in-exposed-windows output-buffer)))
      (when window-list
	(=> self flush)
	(nmode-adjust-output-window (car window-list))
	))))

(defmethod (buffer-channel put-newline) ()
  (=> self flush)
  (let ((old-pos (=> output-buffer position)))
    (=> output-buffer move-to-buffer-end)
    (=> output-buffer insert-eol)
    (=> output-buffer set-position old-pos)
    )
  (=> self refresh)
  )

(defmethod (buffer-channel putc) (ch)
  % "Print" character CH by appending it to the output buffer.
  (if (= ch #\EOL)
    (=> self put-newline)
    (when output-buffer
      (when (null output-cache)
	(setf output-cache (make-string 200 #\space))
	(setf output-cache-pos 0)
	)
      (string-store output-cache output-cache-pos ch)
      (setf output-cache-pos (+ output-cache-pos 1))
      (when (>= output-cache-pos 200)
	(=> self flush)
	(=> self refresh)
	))))

(de nmode-adjust-output-window (w)
  (let ((output-buffer (=> w buffer)))
    (=> w set-position (=> output-buffer buffer-end-position))
    (nmode-adjust-window w)
    (if (=> w exposed?) (nmode-refresh))
    ))

(de buffer-read-character (chn)
  (let ((bc (vector-fetch buffer-channel-vector chn)))
    (when bc
      (=> bc getc)
      )))

(defmethod (buffer-channel getc) ()

  % Read a character from the input buffer; advance over that character.
  % Return End Of File if at end of buffer or if no buffer.  If the "read
  % point" equals the "buffer cursor", then the "buffer cursor" will be
  % advanced also.

  (if (not input-buffer)
    #\EOF
    % Otherwise (there is an input buffer)
    (let* ((old-position (=> input-buffer position))
	   (was-at-cursor (buffer-position-equal input-position old-position))
	   result
	   )
      (=> input-buffer set-position input-position)
      (if (=> input-buffer at-buffer-end?)
	(setf result #\EOF)
	% Otherwise (not at end of buffer)
	(setf result (=> input-buffer next-character))
	(=> input-buffer move-forward)
	(setf input-position (=> input-buffer position))
	)
      (if (not was-at-cursor)
	(=> input-buffer set-position old-position))
      (if *ECHO (=> self putc result))
      result
      )))

(de MakeInputAvailable ()
  % THIS IS THE MAGIC FUNCTION invoked by READ, and other "reader functions".
  % IN* is a FLUID (actually GLOBAL) variable.
  (let ((bc (vector-fetch buffer-channel-vector IN*)))
    (when bc
      (=> bc run-editor)
      )))

(defmethod (buffer-channel run-editor) ()
  (if editor-function (apply editor-function (list IN*)))
  NIL
  )

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(undeclare-flavor input-buffer output-buffer)
(undeclare-flavor w)
(undeclare-flavor bc)