Artifact 7806b227711a396992cda8e58e47a2006c41fe8c7276bd738126536738bba6c0:

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

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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Input-Stream.SL (TOPS-20 Version) - File Input Stream Objects
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        29 July 1982
%
% This package is 6.6 times faster than the standard unbuffered I/O.
% (Using message passing, it is only 1.7 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.
%
% Summary of public functions:
%
% (setf s (open-input "file name")) % generates error on failure
% (setf s (attempt-to-open-input "file name")) % returns NIL on failure
% (setf ch (=> s getc)) % read character (map CRLF to LF)
% (setf ch (=> s getc-image)) % read character (don't map CRLF to LF)
% (setf ch (=> s peekc)) % peek at next character
% (setf ch (=> s peekc-image)) % peek at next character (don't map CRLF to LF)
% (setf str (=> s getl)) % Read a line; return string without terminating LF.
% (=> s empty?) % Are there no more characters?
% (=> s close) % Close the file.
% (setf fn (=> s file-name)) % Return "true" name of file.
% (setf date (=> s read-date)) % Return date that file was last read.
% (setf date (=> s write-date)) % Return date that file was last written.
% (=> s delete-file) % Delete the associated file.
% (=> s undelete-file) % Undelete the associated file.
% (=> s delete-and-expunge) % Delete and expunge the associated file.
% (setf name (=> s author)) % Return the name of the file's author.
% (setf name (=> s original-author)) % Return the original author's name.
% (setf count (=> s file-length)) % Return the byte count of the file.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Changes:
%
% 9/29/82 Alan Snyder
%   Changed GETC to return stray CRs.
%   Now uses (=> self ...) form (produces same object code).
%   Added operations PEEKC-IMAGE, GETL, TELL-POSITION, SEEK-POSITION
%    (written by Nancy Kendzierski).
%
% 11/22/82 Alan Snyder
%   Changed SEEK-POSITION to work with large byte pointers (> 256K).
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load fast-int fast-strings))
(BothTimes (load objects jsys))
(load directory file-support)

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

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

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

(defflavor input-stream ((jfn NIL)	% TOPS-20 file number
			ptr		% "pointer" to next char in buffer
			count		% number of valid chars in buffer
			eof-flag	% T => this bufferfull is the last
			file-name	% full name of actual file
			buffer		% input buffer
			)
  ()
  (gettable-instance-variables file-name)
  )

% Note: The JSYS function can't be used for the 'SIN' JSYS because the JSYS
% function handles errors.  The 'SIN' JSYS will report an error on end-of-file
% if errors are being handled.  We don't want that to happen!

(CompileTime (progn
  (put 'SIN 'OpenCode '((jsys 8#52) (move (reg 1) (reg 3))))
  (put 'BIN 'OpenCode '((jsys 8#50) (move (reg 1) (reg 2))))
  (put 'CLOSF 'OpenCode '((jsys 8#22) (move (reg 1) (reg 1))))
  (put 'RFPTR 'OpenCode '((jsys 8#43) (jfcl) (move (reg 1) (reg 2))))
  (put 'SFPTR 'OpenCode '((jsys 8#27) (jfcl) (move (reg 1) (reg 1))))
  ))

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

(defmethod (input-stream getc) ()

  % Return the next character from the file.  Line termination is represented
  % by a single NEWLINE (LF) character.  Returns NIL on end of file.

  % 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 (< ptr count)
        (let ((ch (prog1
		    (string-fetch buffer ptr)
		    (setf ptr (+ ptr 1))
		    )))
	  % Ignore CR followed by LF
	  (if (= ch #\CR)
	    (=> self &getc-after-CR)
	    ch
	    ))
	(=> self &fill-buffer-and-getc)
	))

(defmethod (input-stream &getc-after-CR) () % Internal method.
  % We have just read a CR from the buffer.  If the next character
  % is a LF, then we should ignore the CR and return the LF.
  % Otherwise, we should return the CR.

  (if (= (=> self peekc-image) #\LF)
      (=> self getc-image)
      #\CR
      ))

(defmethod (input-stream &fill-buffer-and-getc) () % Internal method.
  (and (=> self &fill-buffer) (=> self getc)))

(defmethod (input-stream getc-image) ()

    % Return the next character from the file.  Do not perform any translation.
    % In particular, return all <CR>s.  Returns NIL on end of file.

    (if (< ptr count)
        (prog1
	 (string-fetch buffer ptr)
	 (setf ptr (+ ptr 1))
	 )
	(=> self &fill-buffer-and-getc-image)
	))

(defmethod (input-stream &fill-buffer-and-getc-image) () % Internal method.
  (and (=> self &fill-buffer) (=> self getc-image)))

(defmethod (input-stream empty?) ()
  (null (=> self peekc-image)))

(defmethod (input-stream peekc) ()

    % Return the next character from the file, but don't advance to the next
    % character.  Returns NIL on end of file.  Maps CRLF to LF.

    (if (< ptr count)
        (let ((ch (string-fetch buffer ptr)))
	  % Ignore CR if followed by LF
	  (if (and (= ch #\CR)
		   (= (=> self &peek2) #\LF)
		   )
	    #\LF
	    ch
	    ))
	(=> self &fill-buffer-and-peekc)
	))

(defmethod (input-stream &fill-buffer-and-peekc) () % Internal method.
  (and (=> self &fill-buffer) (=> self peekc)))

(defmethod (input-stream peekc-image) ()

    % Return the next character from the file, but don't advance to the next
    % character.  Returns NIL on end of file.

    (if (< ptr count)
        (string-fetch buffer ptr)
	(=> self &fill-buffer-and-peekc-image)
	))

(defmethod (input-stream &fill-buffer-and-peekc-image) () % Internal method.
  (and (=> self &fill-buffer) (=> self peekc-image)))

(defmethod (input-stream &peek2) () % Internal method.

    % Return the character after the next character in the file, but don't
    % advance.  Does not map CRLF.  Returns Ascii NUL on end of file.  Requires
    % that the buffer contain at least one character.  This is a hack required
    % to implement PEEKC.

    (let ((next-ptr (+ ptr 1)))
      (cond ((>= next-ptr count)
	     % The next character has not yet been read into the buffer.
	     (let* ((old-pos (RFPTR jfn))
		    (ch (BIN jfn))
		    )
	       (SFPTR jfn old-pos)
	       ch
	       ))
	    (t (string-fetch buffer next-ptr))
	    )))

(defmethod (input-stream &fill-buffer) () % Internal method.
  % Return NIL iff there are no more characters.
  (if eof-flag
      NIL
      (let ((n (SIN jfn (jconv buffer) (- (const FILE-BUFFER-SIZE)))))
        (if (~= n 0) (setf eof-flag T))
        (setf count (+ (const FILE-BUFFER-SIZE) n))
        (setf ptr 0)
	(~= count 0))))

(defmethod (input-stream getl) ()
  % Read and return (the remainder of) the current input line.
  % Read, but don't return the terminating EOL (if any).
  % (EOL is interpreted as LF or CRLF)
  % Return NIL if no characters and end-of-file detected.

  (if (and (>= ptr count) (not (=> self &fill-buffer)))
    NIL
    % Else
    (let ((start ptr) (save-buffer NIL) (eof? NIL))
      (while (and (not eof?) (~= (string-fetch buffer ptr) #\LF))
	 (setf ptr (+ ptr 1))
	 (cond ((>= ptr count)
		(setf save-buffer
		      (concat save-buffer (subseq buffer start ptr)))
		(setf eof? (not (=> self &fill-buffer)))
		(setf start ptr)
		))
	 )
      (if eof?
	save-buffer
	% Else
	(setf ptr (+ ptr 1))
	(if (= ptr 1)
	  (if save-buffer
	    (if (= (string-fetch save-buffer (size save-buffer)) #\CR)
	      (subseq save-buffer 0 (size save-buffer))
	      (sub save-buffer 0 (size save-buffer)))
	    (subseq buffer start ptr))
	  (if (= (string-fetch buffer (- ptr 2)) #\CR)
	    (concat save-buffer (subseq buffer start (- ptr 2)))
	    (concat save-buffer (subseq buffer start (- ptr 1)))
	    )))
      )))

(defmethod (input-stream tell-position) ()
  % Return an integer representing the current "position" of the stream.  About
  % all we can guarantee about this integer is (1) it will be 0 at the
  % beginning of the file and (2) if you later SEEK-POSITION to this integer,
  % the stream will be reset to its current position.  The reason for this
  % fuzziness is that the translation of CRLF into LF performed by the "normal"
  % input operations makes it impossible to predict the relationship between
  % the apparent file position and the actual file position.

  (- (RFPTR jfn) (- count ptr))
  )

(defmethod (input-stream seek-position) (p)
  (setf p (int2sys p))
  (let* ((buffer-end (RFPTR jfn))
	 (buffer-start (- buffer-end count)))
    (if (and (>= p buffer-start) (< p buffer-end))
      (setf ptr (- p buffer-start))
      % Else
      (SFPTR jfn p)
      (setf ptr 0)
      (setf count 0)
      (setf eof-flag NIL)
      )
    ))

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

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

  (if jfn (=> self close))
  (setf buffer (MkString (const FILE-BUFFER-SIZE) #\space))
  (setf ptr 0)
  (setf count 0)
  (setf eof-flag NIL)
  (setf jfn (Dec20Open name-of-file 
	         (int2sys 2#001000000000000001000000000000000000)
	         (int2sys 2#000111000000000000010000000000100000)
	         ))
  (if (= jfn 0) (setf jfn NIL))
  (if (null jfn)
   (=> self open
       (ContinuableError
         0
         (BldMsg "Unable to Open '%w' for Input." name-of-file)
         name-of-file))
   % Else
   (setf file-name (jfn-truename jfn))
   ))

(defmethod (input-stream close) ()
  (when jfn
    (CLOSF jfn)
    (setf jfn NIL)
    (setf buffer NIL)
    (setf count 0)
    (setf ptr 0)
    (setf eof-flag T)
    ))

(defmethod (input-stream read-date) ()
  (jfn-read-date jfn))

(defmethod (input-stream write-date) ()
  (jfn-write-date jfn))

(defmethod (input-stream delete-file) ()
  (jfn-delete jfn))

(defmethod (input-stream undelete-file) ()
  (jfn-undelete jfn))

(defmethod (input-stream delete-and-expunge-file) ()
  (jfn-delete-and-expunge jfn))

(defmethod (input-stream author) ()
  (jfn-author jfn))

(defmethod (input-stream original-author) ()
  (jfn-original-author jfn))

(defmethod (input-stream file-length) ()
  (jfn-byte-count jfn))

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

(CommentOutCode (progn

(de test-buffered-input (name-of-file)
  (setf s (open-input name-of-file))
  (while (setf ch (input-stream$getc s))
    (WriteChar ch)
    )
  (=> s close)
  (Prin2 "---EOF---")
  NIL
  )

(de time-buffered-input (name-of-file)
  (setf start-time (time))
  (setf s (open-input name-of-file))
  (while (setf ch (input-stream$getc s))
    )
  (=> s close)
  (- (time) start-time)
  )

(de time-buffered-input-1 (name-of-file)
  (setf start-time (time))
  (setf s (open-input name-of-file))
  (while (setf ch (=> s getc))
    )
  (=> s close)
  (- (time) start-time)
  )

(de time-standard-input (name-of-file)
  (setf start-time (time))
  (setf chan (open name-of-file 'INPUT))
  (while (not (= (setf ch (ChannelReadChar chan)) $EOF$))
    )
  (close chan)
  (- (time) start-time)
  )

(de time-input (name-of-file)
  (list
    (time-buffered-input name-of-file)
    (time-buffered-input-1 name-of-file)
    (time-standard-input name-of-file)
    ))

)) % End CommentOutCode