Artifact 88bbd855f1b5f1ab16a1db7bcf091691b72186f77e61b61e3bf557053f7cb0c8:

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

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% PSL-Output-Stream.SL - File Output Stream Objects (Portable PSL Version)
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        10 December 1982
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

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

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

(defflavor output-stream ((chn NIL)	% PSL "channel"
			  file-name	% file name given to open
			  )
  ()
  (gettable-instance-variables file-name)
  )

(defmethod (output-stream putc) (ch)

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

  (ChannelWriteChar chn ch)
  )

(defmethod (output-stream put-newline) ()
  % Output a line terminator.
  (ChannelWriteChar chn #\EOL)
  )

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

(defmethod (output-stream puts) (str)
  (for (from i 0 (string-upper-bound str))
       (do (=> self putc (string-fetch str i)))
       ))

(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 chn (=> self close))
  (setf chn (open name-of-file 'output))
  (setf file-name (copystring name-of-file))
  )

(defmethod (output-stream open-append) (name-of-file)
  (=> self open name-of-file))

(defmethod (output-stream close) ()
  (when chn
    (close chn)
    (setf chn NIL)
    ))

(defmethod (output-stream flush) ()
  )