Artifact 3262adc69b6f05f1bff46a762bc75be4799f594116249252136f7dd935497c8e:

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

• File psl-1983/nmode/reader.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: 13844) [annotate] [blame] [check-ins using]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Reader.SL - NMODE Command Reader
% 
% Author:      Alan Snyder
%              Hewlett-Packard/CRC
% Date:        23 August 1982
% Revised:     16 February 1983
%
% 16-Feb-83 Alan Snyder
%  Declare -> Declare-Flavor.
% 3-Dec-82 Alan Snyder
%  GC calls cleanup-buffers before reclaiming.
% 21-Dec-82 Alan Snyder
%  Use generic arithmetic on processor times (overflowed on 9836).
%  Add declaration for NMODE-TIMER-OUTPUT-STREAM.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(CompileTime (load objects extended-char fast-int pathnames))

% External variables used here:

(fluid '(nmode-allow-refresh-breakout))

% Global variables defined here:

(fluid '(
	 nmode-command-argument		% Numeric C-U argument (default: 1)
	 nmode-command-argument-given	% T if C-U used for this command
	 nmode-command-number-given	% T if an explicit number given
	 nmode-previous-command-killed	% T if previous command KILLED text
	 nmode-current-command		% Current command (char or list)
	 nmode-previous-command		% Previous command (char or list)
	 nmode-current-command-function	% Function for current command
	 nmode-previous-command-function% Function for previous command
	 nmode-autoarg-mode		% T => digits start command argument
	 nmode-temporary-autoarg	% T while reading command argument
	 nmode-command-killed		% Commands set this if they KILL text
	 nmode-command-set-argument	% Commands like C-U set this
	 nmode-reader-exit-flag		% Internal flag: causes reader to exit
	 nmode-gc-check-level		% number of free words causing GC
	 nmode-timing?			% T => time command execution
	 nmode-display-times?		% T => display times after each command
	 nmode-timer-output-stream	% optional stream to write times to

	 % The following variables are set when timing is on:

	 nmode-timed-step-count		% number of reader steps timed
	 nmode-refresh-time		% time used for last refresh
	 nmode-read-time		% time used for last read command
	 nmode-command-execution-time	% time to execute last command
	 nmode-total-refresh-time	% sum of nmode-refresh-time
	 nmode-total-read-time		% sum of nmode-read-time
	 nmode-total-command-execution-time% sum of nmode-command-execution-time
	 nmode-gc-start-count		% GCKnt when timing starts
	 nmode-gc-reported-count	% GCKnt when last reported
	 nmode-total-cons-count		% total words allocated (except GC)
	 ))

(setf nmode-timing? NIL)
(setf nmode-display-times? NIL)

(declare-flavor output-stream nmode-timer-output-stream)

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

(fluid '(nmode-exit-on-abort))
(de nmode-reader (nmode-exit-on-abort)

  % Execute refresh/read/dispatch loop.  The loop can terminate in the following
  % ways: (1) A command can cause the reader to exit by either calling
  % EXIT-NMODE-READER or by throwing 'EXIT-NMODE.  In this case, the reader
  % terminates and returns NIL.  (2) A command can throw 'ABORT.  If
  % NMODE-EXIT-ON-ABORT is non-NIL, then the reader will terminate and return
  % 'ABORT; otherwise, it will ring the bell and continue.  (3) A command can
  % throw '$BREAK$ or 'RESET; this throw is relayed.  Other errors and throws
  % within a command are caught, messages are printed, and execution resumes.

  (let* ((nmode-reader-exit-flag NIL)		% FLUID variable
	 (nmode-previous-command-killed NIL)   	% FLUID variable
	 (nmode-command-killed NIL)		% FLUID variable
	 (nmode-command-argument 1)		% FLUID variable
	 (nmode-command-argument-given NIL)	% FLUID variable
	 (nmode-command-number-given NIL)	% FLUID variable
	 (nmode-current-command NIL)		% FLUID variable
	 (nmode-previous-command NIL)		% FLUID variable
	 (nmode-current-command-function NIL)	% FLUID variable
	 (nmode-previous-command-function NIL)	% FLUID variable
	 (nmode-command-set-argument NIL)	% FLUID variable 
	 (nmode-timing? NIL)			% FLUID variable
	 (*MsgP T)				% FLUID variable
	 (*BackTrace T)				% FLUID variable
	 )

    (while (not nmode-reader-exit-flag)
      (catch-all
        #'(lambda (tag result)
	    (cond
	     ((eq tag 'abort)
	      (if nmode-exit-on-abort (exit 'abort) (Ding)))
	     ((or (eq tag '$Break$) (eq tag 'RESET))
	      (nmode-select-buffer-channel)
	      (throw tag NIL))
	     ((eq tag '$error$) (Ding))
	     ((eq tag 'exit-nmode) (exit NIL))
	     (t (Printf "*****Unhandled THROW of %p" tag) (Ding))
	     ))
	(nmode-reader-step)
	))))

(de nmode-reader-step ()
  (cond ((not nmode-timing?)
	 (nmode-refresh)
	 (nmode-gc-check)
	 (nmode-read-command)
	 (nmode-execute-current-command)
	 )
	(t (nmode-timed-reader-step))
	))

(de nmode-read-command ()
  % Read one command and set the appropriate global variables.

  (when (not nmode-command-set-argument) % starting a new command
    (setf nmode-previous-command-killed nmode-command-killed)
    (setf nmode-previous-command nmode-current-command)
    (setf nmode-previous-command-function nmode-current-command-function)
    (setf nmode-command-argument 1)
    (setf nmode-command-argument-given NIL)
    (setf nmode-command-number-given NIL)
    (setf nmode-command-killed NIL)
    (setf nmode-temporary-autoarg NIL)
    (nmode-set-delayed-prompt "")
    )
  (setf nmode-current-command (input-command))
  (setf nmode-current-command-function
    (dispatch-table-lookup nmode-current-command))
  )

(de nmode-execute-current-command ()
  (setf nmode-command-set-argument NIL)
  (if nmode-current-command-function
    (apply nmode-current-command-function NIL)
    (nmode-undefined-command nmode-current-command)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Timing Support
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de start-timing-command ()
  (let ((fn (prompt-for-file-name
	     "Timing output to file:"
	     (namestring (make-pathname 'name "timing" 'type "txt"))
	     )))
    (cond ((not (setf nmode-timer-output-stream (attempt-to-open-output fn)))
	   (write-prompt "Unable to open file.")
	   (Ding)
	   )
	  (t
	   (reclaim)
	   (nmode-start-timing))
	  )))

(de stop-timing-command ()
  (cond (nmode-timing?
	 (nmode-stop-timing)
	 (if nmode-timer-output-stream (=> nmode-timer-output-stream close))
	 (setf nmode-timer-output-stream nil)
	 )))

(de nmode-start-timing ()
  (setf nmode-timing? T)
  (setf nmode-total-refresh-time 0)
  (setf nmode-total-read-time 0)
  (setf nmode-total-command-execution-time 0)
  (setf nmode-timed-step-count 0)
  (setf nmode-gc-start-count GCknt*)
  (setf nmode-gc-reported-count nmode-gc-start-count)
  (setf nmode-total-cons-count 0)
  )

(de nmode-stop-timing ()
  (cond (nmode-timing?
	 (setf nmode-timing? NIL)
	 (nmode-timing-message
	  (BldMsg "Total times: Refresh=%d Read=%d Execute=%d Cons=%d #GC=%d"
		  nmode-total-refresh-time
		  nmode-total-read-time
		  nmode-total-command-execution-time
		  nmode-total-cons-count
		  (- GCknt* nmode-gc-start-count)
		  ))
	 (nmode-timing-message
	  (BldMsg "Number of reader steps: %d" nmode-timed-step-count))
	 (if (> nmode-timed-step-count 0)
	   (nmode-timing-message
	    (BldMsg "Averages: Refresh=%d Read=%d Execute=%d Cons=%d"
		    (/ nmode-total-refresh-time nmode-timed-step-count)
		    (/ nmode-total-read-time nmode-timed-step-count)
		    (/ nmode-total-command-execution-time nmode-timed-step-count)
		    (/ nmode-total-cons-count nmode-timed-step-count)
		    ))))))

(de nmode-timed-reader-step ()
  (let ((heapx (GtHeap NIL))
	gc-happened
	)
    (nmode-timed-refresh)
    (nmode-gc-check)
    (nmode-timed-read-command)
    (nmode-timed-execute-current-command)
    (setf heapx (- heapx (GtHeap NIL)))
    (setf gc-happened (> GCknt* nmode-gc-reported-count))
    (setf nmode-gc-reported-count GCknt*)

    (cond ((not gc-happened)
	   (setf nmode-timed-step-count (+ nmode-timed-step-count 1))
	   (setf nmode-total-refresh-time
	     (+ nmode-total-refresh-time nmode-refresh-time))
	   (setf nmode-total-read-time
	     (+ nmode-total-read-time nmode-read-time))
	   (setf nmode-total-command-execution-time
	     (+ nmode-total-command-execution-time
		nmode-command-execution-time))
	   (setf nmode-total-cons-count
	     (+ nmode-total-cons-count heapx))
	   ))

    (nmode-timing-message
     (BldMsg "%w Refresh=%d Read=%d Execute=%d %w"
	     (string-pad-left (command-name nmode-current-command) 20)
	     nmode-refresh-time
	     nmode-read-time
	     nmode-command-execution-time
	     (if gc-happened
	       (BldMsg "#GC=%d" nmode-gc-reported-count)
	       (BldMsg "Cons=%d" heapx)
	       )
	     ))))

(de nmode-timed-refresh ()
  (let ((ptime (processor-time)))
    (nmode-refresh)
    (setf nmode-refresh-time (difference (processor-time) ptime))
    ))

(de nmode-timed-read-command ()
  (let ((ptime (processor-time)))
    (nmode-read-command)
    (setf nmode-read-time (difference (processor-time) ptime))
    ))

(de nmode-timed-execute-current-command ()
  (let ((ptime (processor-time)))
    (nmode-execute-current-command)
    (setf nmode-command-execution-time (difference (processor-time) ptime))
    ))

(de nmode-timing-message (s)
  (cond (nmode-display-times? (write-message s))
	(nmode-timer-output-stream
	 (=> nmode-timer-output-stream putl s))
	))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Garbage Collection
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de nmode-gc-check ()
  % Check to see if a garbage collection is needed (because we are low on
  % space).  If so, display a message and invoke the garbage collector.  (If a
  % garbage collection happens "by itself", no message will be displayed.)

  (if (not nmode-gc-check-level) (setf nmode-gc-check-level 1000))
  (when (< (GtHeap NIL) nmode-gc-check-level)
    (nmode-gc)
    ))

(de nmode-gc ()
  % Perform garbage collection while displaying a message.
  (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable
    (write-prompt "Garbage Collecting!")
    (cleanup-buffers)
    (reclaim)
    (write-prompt
     (BldMsg "Garbage Collection Done: Free Space = %d words" (GtHeap NIL)))
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Miscellaneous Functions
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de exit-nmode-reader ()
  % Set flag to cause exit from NMODE reader loop.
  (setf nmode-reader-exit-flag T)
  )

(de nmode-undefined-command (command)
  (nmode-error (BldMsg "Undefined command: %w" (command-name command)))
  )

(de nmode-error (s)
  (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable
    (write-prompt s)
    (Ding)
    ))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Numeric Argument Command Functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de argument-digit ()
  % This procedure must be attached only to extended characters whose base
  % characters are digits.
  (let* ((command nmode-current-command)
	 (base-ch (if (FixP command) (X-base command)))
	 (n (if (and base-ch (digitp base-ch)) (char-digit base-ch)))
	 )
    (if (null n)
      (Ding)
      (argument-digit-number n)
      )))

(de negative-argument ()
  (if (not nmode-command-number-given)
    % make "C-U -" do the right thing
    (cond ((> nmode-command-argument 0) (setf nmode-command-argument 1))
	  ((< nmode-command-argument 0) (setf nmode-command-argument -1))
	  ))
  (setf nmode-command-argument (- nmode-command-argument))
  (setf nmode-command-argument-given T)
  (setf nmode-command-set-argument T)
  (nmode-set-delayed-prompt
   (cond
    ((= nmode-command-argument 1) "C-U ")
    ((= nmode-command-argument -1) "C-U -")
    (t (BldMsg "C-U %d" nmode-command-argument))
    )))

(de universal-argument ()
  (setf nmode-command-argument (* nmode-command-argument 4))
  (setf nmode-command-argument-given T)
  (setf nmode-command-set-argument T)
  (setf nmode-temporary-autoarg T)
  (cond
   (nmode-command-number-given
    (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument))
    )
   (t (nmode-append-separated-prompt "C-U"))
   ))

(de argument-or-insert-command ()
  % This command interprets digits and leading hyphens as argument
  % prefix characters if NMODE-AUTOARG-MODE or NMODE-TEMPORARY-AUTOARG
  % is non-NIL; otherwise, it self-inserts.

  (let ((base-ch
	 (if (FixP nmode-current-command) (X-base nmode-current-command)))
	)
    (cond
     ((and (digitp base-ch) (or nmode-temporary-autoarg nmode-autoarg-mode))
      (argument-digit (char-digit base-ch)))
     ((and (= base-ch #/-)
	   (or nmode-temporary-autoarg nmode-autoarg-mode)
	   (not nmode-command-number-given))
      (negative-argument))
     (t (insert-self-command))
     )))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Numeric Argument Support Functions:
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

(de argument-digit-number (n)
  (cond
   (nmode-command-number-given % this is not the first digit
    (setf nmode-command-argument
      (+ (* nmode-command-argument 10)
	 (if (>= nmode-command-argument 0) n (- n))))
    )
   (t % this is the first digit
    (if (> nmode-command-argument 0)
      (setf nmode-command-argument n)
      (setf nmode-command-argument (- n))
      )))
  (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument))
  (setf nmode-command-argument-given T)
  (setf nmode-command-number-given T)
  (setf nmode-command-set-argument T)
  )

% Convert from character code to digit.
(de char-digit (c)
  (cond ((digitp c) (difference (char-int c) (char-int #/0)))))

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

(undeclare-flavor nmode-timer-output-stream)