reduce-historical/psl-1983/20-util/output-stream.sl

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Output-Stream.SL (TOPS-20 Version) - File Output Stream Objects
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        29 July 1982
%
% This package is 6.7 times faster than the standard unbuffered I/O.
% (Using message passing, it is only 1.9 times faster.)
%
% Note: this code will only run COMPILED.
%
% See TESTING code at the end of this file for examples of use.
% Be sure to include "(CompileTime (load objects))" at the beginning
% of any file that uses this package.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load fast-int fast-vectors fast-strings))
(BothTimes (load objects jsys))

(de attempt-to-open-output (file-name)
  (let ((p (ErrorSet (list 'open-output file-name) NIL NIL)))
    (and (PairP p) (car p))
    ))

(de attempt-to-open-append (file-name)
  (let ((p (ErrorSet (list 'open-append file-name) NIL NIL)))
    (and (PairP p) (car p))
    ))

(de open-output (file-name)
  (let ((s (make-instance 'output-stream)))
    (=> s open file-name)
    s))

(de open-append (file-name)
  (let ((s (make-instance 'output-stream)))
    (=> s open-append file-name)
    s))

(defconst FILE-BUFFER-SIZE #.(* 5 512))

(defflavor output-stream ((jfn NIL)	% TOPS-20 file number
			  ptr		% "pointer" to next free slot in buffer
			  file-name	% full name of actual file
			  buffer	% output buffer
			  )
  ()
  (gettable-instance-variables file-name)
  )

(CompileTime (put 'SOUT 'OpenCode '((jsys 43) (move (reg 1) (reg 3)))))
(CompileTime (put 'CLOSF 'OpenCode '((jsys 18) (move (reg 1) (reg 1)))))

(defmethod (output-stream putc) (ch)

  % Append the character CH to the file.  Line termination is indicated by
  % writing a single NEWLINE (LF) character.

  % Implementation note:  It was determined by experiment that the PSL
  % compiler produces much better code if there are no function calls other
  % than tail-recursive ones.  That's why this function is written the way
  % it is.

  (if (= ch #\LF)
    (=> self put-newline)
    % Otherwise:
    (string-store buffer ptr ch)
    (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE))
      (=> self flush))
    ))

(defmethod (output-stream put-newline) ()

  % Output a line terminator.

  (string-store buffer ptr #\CR)
  (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE))
      (=> self flush))
  (string-store buffer ptr #\LF)
  (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE))
      (=> self flush))
  )

(defmethod (output-stream putc-image) (ch)

  % Append the character CH to the file.  No translation of LF character.

  (string-store buffer ptr ch)
  (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE))
    (=> self flush))
  )

(defmethod (output-stream puts) (str)

  % Write string to output stream (highly optimized!)

  (let ((i 0)
	(high (string-upper-bound str))
	)
    (while (<= i high)
      (string-store buffer ptr (string-fetch str i))
      (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE))
        (=> self flush))
      (setf i (+ i 1))
      )))

(defmethod (output-stream putl) (str)

  % Write string followed by line terminator to output stream.

  (=> self puts str)
  (=> self put-newline)
  )

(defmethod (output-stream open) (name-of-file)

  % Open the specified file for output via SELF.  If the file cannot
  % be opened, a Continuable Error is generated.

  (if jfn (=> self close))
  (setf jfn (Dec20Open name-of-file 
	         (int2sys 2#100000000000000001000000000000000000)
	         (int2sys 2#000111000000000000001000000000000000)
	         ))
  (if (= jfn 0) (setf jfn NIL))
  (if (null JFN)
    (=> self open
      (ContinuableError 0
			(BldMsg "Unable to Open '%w' for Output" name-of-file)
			name-of-file))
    (=> self &fixup)
    ))

(defmethod (output-stream open-append) (name-of-file)

  % Open the specified file for append output via SELF.  If the file cannot
  % be opened, a Continuable Error is generated.

  (if jfn (=> self close))
  (setf jfn (Dec20Open name-of-file 
	         (int2sys 2#000000000000000001000000000000000000)
	         (int2sys 2#000111000000000000000010000000000000)
	         ))
  (if (= jfn 0) (setf jfn NIL))
  (if (null JFN)
    (=> self open-append
      (ContinuableError 0
			(BldMsg "Unable to Open '%w' for Append" name-of-file)
			name-of-file))
    (=> self &fixup)
    ))

(defmethod (output-stream attach-to-jfn) (new-jfn)

  % Attach the output-stream to the specified JFN.

  (if jfn (=> self close))
  (setf jfn new-jfn)
  (=> self &fixup)
  )

(defmethod (output-stream &fixup) ()
  % Internal method for initializing instance variables after setting JFN.

  (setf buffer (make-string (const FILE-BUFFER-SIZE) #\space))
  % It is necessary to clear out the low-order bit, lest some programs
  % think we are writing "line numbers" (what a crock!).
  (for (from i 0 (- (/ (const FILE-BUFFER-SIZE) 5) 1))
       (do (vector-store buffer i 0)))
  (setf ptr 0)
  (setf file-name (jfn-truename jfn))
  )

(defmethod (output-stream close) ()
  (when jfn
    (=> self flush)
    (CLOSF jfn)
    (setf jfn NIL)
    (setf buffer NIL)
    ))

(defmethod (output-stream flush) ()
  (when (> ptr 0)
    (SOUT jfn (jconv buffer) (- ptr))
    (setf ptr 0)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% TESTING CODE
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime
 (setf time-output-test-string "This is a line of text for testing."))

(CommentOutCode (progn

(de time-buffered-output (n-lines)
  % This is the FAST way to do buffered output.

  (setf start-time (time))
  (setf s (open-output "test.output"))
  (for (from i 1 n-lines 1)
       (do (for (in ch '#.(String2List time-output-test-string))
		(do (output-stream$putc s ch))
		)
	   (output-stream$put-newline s)
	   ))
  (=> s close)
  (- (time) start-time)
  )

(de time-buffered-output-1 (n-lines)
  % This is the SLOW (but GENERAL) way to do buffered output.

  (setf start-time (time))
  (setf s (open-output "test.output"))
  (for (from i 1 n-lines 1)
       (do (for (in ch '#.(String2List time-output-test-string))
		(do (=> s putc ch))
		)
	   (=> s put-newline)
	   ))
  (=> s close)
  (- (time) start-time)
  )

(de time-standard-output (n-lines)
  (setf start-time (time))
  (setf chan (open "test.output" 'OUTPUT))
  (for (from i 1 n-lines 1)
       (do (for (in ch '#.(String2List time-output-test-string))
		(do (ChannelWriteChar chan ch))
		)
	   (ChannelWriteChar chan #\LF)
	   ))
  (close chan)
  (- (time) start-time)
  )

(de time-output (n-lines)
  (list
    (time-buffered-output-string n-lines)
    (time-buffered-output n-lines)
    (time-buffered-output-1 n-lines)
    (time-standard-output n-lines)
    ))

(de time-buffered-output-string (n-lines)
  % This is the FAST way to do buffered output from strings.

  (setf start-time (time))
  (setf s (open-output "test.output"))
  (for (from i 1 n-lines 1)
       (do (output-stream$putl s #.time-output-test-string))
       )
  (=> s close)
  (- (time) start-time)
  )

)) % End CommentOutCode