Artifact 4540cd6db58978a98cdd428053fe0633f77d2e238a19c7198bd3267c06587ccc:

• File psl-1983/20-util/output-stream.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: 7163) [annotate] [blame] [check-ins using] [more...]

• File psl-1983/3-1/util/20/output-stream.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: 7163) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 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