reduce-historical/psl-1983/emode/input-stream.sl

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

(BothTimes (load objects jsys))

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

%(CompileTime (setq *pgwd t))

(CompileTime (setq 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 function
% handles errors.  The 'SIN' JSYS will report an error on end-of-file if errors
% are being handled.

(CompileTime (put 'sin 'OpenCode '((jsys 42) (move (reg 1) (reg 3)))))
(CompileTime (put 'closf 'OpenCode '((jsys 18) (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.

    % Note: returns NIL on end of file.

    (if (WLessP ptr count)
        (let ((ch (prog1
		    (igets buffer ptr)
		    (setf ptr (wplus2 ptr 1))
		    )))
	  % Ignore CR's
	  (if (WNEq ch (char CR)) ch (input-stream$getc self))
	  )
	(input-stream$fill-buffer-and-getc self)
	))

% The above function was coded to produce good compiled code
% using the current PSL compiler.  Here's the output.  Note
% that no stack variables are used.  The main path uses 16
% instructions.  There is room for improvement.

%               (*ENTRY INPUT-STREAM$GETC EXPR 1)
% G0002         (MOVE (REG 4) (REG 1))
%               (MOVE (REG T1) (INDEXED (REG 1) 6))
%               (CAMG (REG T1) (INDEXED (REG 1) 5))
%               (JRST G0004)
%               (MOVE (REG 2) (INDEXED (REG 1) 5))
%               (MOVE (REG 1) (INDEXED (REG 1) 4))
%               (AOS (REG 1))
%               (ADJBP (REG 2) "L0010")
%               (LDB (REG 1) (REG 2))
%               (MOVE (REG 3) (REG 1))
%               (MOVE (REG 1) (INDEXED (REG 4) 5))
%               (AOS (REG 1))
%               (MOVEM (REG 1) (INDEXED (REG 4) 5))
%               (MOVE (REG 1) (REG 3))
%               (CAIE (REG 1) 13)
%               (JRST G0001)
%               (MOVE (REG 1) (REG 4))
%               (JRST G0002)
% G0004         (JRST (ENTRY INPUT-STREAM$FILL-BUFFER-AND-GETC))
% G0001         (POPJ (REG ST) 0)
% L0010         (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7))

(defmethod (input-stream fill-buffer-and-getc) ()

  % Implementation note: Removing all of this code from GETC improves the
  % quality of the compiled code for GETC.  In particular, the compiler is able
  % to keep SELF in a register, instead of saving it in a stack variable and
  % (excessively) reloading it every time it is needed.  Making this change
  % increased the performance of buffered input from 4X to 6.6X the standard
  % unbuffered input.

  (if eof-flag
      NIL
      (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE))))
        (if (not (WEQ n 0)) (setf eof-flag T))
        (setf count (WPlus2 #.FILE-BUFFER-SIZE n))
        (setf ptr 0)
        (input-stream$getc self))))

(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 (WLessP ptr count)
        (prog1
	 (igets buffer ptr)
	 (setf ptr (wplus2 ptr 1))
	 )
	(input-stream$fill-buffer-and-getc-image self)
	))

(defmethod (input-stream fill-buffer-and-getc-image) ()

  (if eof-flag
      NIL
      (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE))))
        (if (not (WEQ n 0)) (setf eof-flag T))
        (setf count (WPlus2 #.FILE-BUFFER-SIZE n))
        (setf ptr 0)
        (input-stream$getc-image self))))

(defmethod (input-stream empty?) ()
  (null (input-stream$peekc self)))

(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.

    (if (WLessP ptr count)
        (let ((ch (igets buffer ptr)))
	  % Ignore CR's
	  (if (WNEq ch (char CR))
	      ch
	      (setf ptr (wplus2 ptr 1))
	      (input-stream$peekc self))
	  )
	(input-stream$fill-buffer-and-peekc self)
	))

(defmethod (input-stream fill-buffer-and-peekc) ()

  (if eof-flag
      NIL
      (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE))))
        (if (not (WEQ n 0)) (setf eof-flag T))
        (setf count (WPlus2 #.FILE-BUFFER-SIZE n))
        (setf ptr 0)
        (input-stream$peekc self))))

(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 (input-stream$close self))
  (setf buffer (MkString #.FILE-BUFFER-SIZE (char space)))
  (setf ptr 0)
  (setf count 0)
  (setf eof-flag NIL)
  (setf jfn (Dec20Open name-of-file 
	         (int2sys 2#001000000000000001000000000000000000)
	         (int2sys 2#000111000000000000010000000000000000)
	         ))
  (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))
   (setf file-name (MkString 200 (char space)))
   (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 #.(get 'jsJFNS 'NewNam))
   (setf file-name (recopystringtonull file-name))
   ))

(defmethod (input-stream close) ()
  (if jfn (progn
	    (closf jfn)
	    (setf jfn NIL)
	    (setf buffer NIL)
	    (setf count 0)
	    (setf ptr 0)
	    (setf eof-flag T)
	    )))


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

(CommentOutCode (progn

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

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

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

(de time-standard-input (name-of-file)
  (setq start-time (time))
  (setq chan (open name-of-file 'INPUT))
  (while (not (= (setq ch (ChannelReadChar chan)) (char 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