Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/print.clisp
There are no other files named print.clisp in the archive.
;;; This is a -*-Lisp-*- file.

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;; Spice Lisp printer.
;;; Written by Neal Feinberg, Spice Lisp Group.
;;; Currently maintained by Skef Wholey.
;;; *******************************************************************
;;; You cannot compile this file properly without having the defstruct for
;;; STREAM compiled first.

(in-package 'lisp)

(export '(*print-escape* *print-pretty* *print-circle* *print-base*
	  *print-radix* *print-case* *print-level* *print-length* *print-array*
	  write prin1 princ print write-to-string write-string write-line))

(defvar *print-escape* T
  "Flag which indicates that slashification is on.  See the manual.")
(defvar *print-pretty* ()
  "Flag which indicates that pretty printing is to be used.")
(defvar *print-base* 10.
  "The output base for integers and rationals.")
(defvar *print-radix* ()
  "This flag requests to verify base when printing rationals.")
(defvar *print-level* ()
  "How many levels deep to print.  Unlimited if null.")
(defvar *print-length* ()
  "How many elements to print on each level.  Unlimited if null.")
(defvar *print-circle* ()
  "Whether to worry about circular list structures. See the manual.")
(defvar *print-case* ':upcase
  "What kind of case the printer should use by default.")
(defvar previous-case ()
  "What the previous case selection the printer was set to.")
(defvar *print-array* ()
  "Whether the array should print it's guts out.")

;; Imported from reader
(proclaim '(special *read-default-float-format*))

;; From the package system
(proclaim '(special *package* *keyword-package*))

;; This macro returns code which maps over a string, binding VARIABLE to each
;; successive character in the string INIT-FORM, and executing BODY with
;; the variable so bound.  This function used to be part of Common Lisp, but
;; is no more.  It lives on in the printer, though.

(defmacro dostring (varform &rest body)
  ;; Varform looks like (variable init-form terminate-form)
  (let ((variable (car varform))
	(init-form (cadr varform))
	(terminate-form (caddr varform)))
    `(do ((,variable)
	  (index 0 (1+ index))
	  (terminate-index (length (the string ,init-form))))
	 ((= index terminate-index)
       (setq ,variable (char ,init-form index))

;;; Toplevel print functions

(defun write (object &key
		     ((:stream  stream)   *standard-output*)
		     ((:escape  *print-escape*)      *print-escape*)
		     ((:radix   *print-radix*)       *print-radix*)
		     ((:base    *print-base*)        *print-base*)
		     ((:circle  *print-circle*)      *print-circle*)
		     ((:pretty  *print-pretty*)      *print-pretty*)
		     ((:level   *print-level*)       *print-level*)
		     ((:length  *print-length*)      *print-length*)
		     ((:case    *print-case*)        *print-case*)
		     ((:gensym  *print-gensym*)      *print-gensym*)
		     ((:array   *print-array*)       *print-array*))
  "Outputs OBJECT to the specified stream, defaulting to *standard-output*"
  (let ((*standard-output* (case stream ((t) *terminal-io*)
				        ((nil) *standard-output*)
					(t stream))))
    (if (or *print-pretty* *print-circle*)
	(output-pretty-object object)
	(output-object object)))

(defun prin1 (object &optional (stream *standard-output*))
  "Outputs a mostly READable printed representation of OBJECT on the specified
  (let ((*print-escape* T)
	(*standard-output* (case stream ((t) *terminal-io*)
				        ((nil) *standard-output*)
					(t stream))))
    (if (or *print-pretty* *print-circle*)
	(output-pretty-object object)
	(output-object object)))

(defun princ (object &optional (stream *standard-output*))
  "Outputs an asthetic but not READable printed representation of OBJECT on the
   specified stream."
  (let ((*print-escape* NIL)
	(*standard-output* (case stream ((t) *terminal-io*)
				        ((nil) *standard-output*)
					(t stream))))
    (if (or *print-pretty* *print-circle*)
	(output-pretty-object object)
	(output-object object)))

(defun print (object &optional (stream *standard-output*))
  "Outputs a terpri, the mostly READable printed represenation of OBJECT, and 
   space to the stream."
  (let ((*standard-output* (case stream ((t) *terminal-io*)
				        ((nil) *standard-output*)
					(t stream))))
    (prin1 object)
    (write-char #\space *standard-output*))

;;; Top-level x-TO=STRING functions.  These functions all take an object
;;; and return that object's printed representation as a string. 

(defun write-to-string (object &key
			       ((:escape  *print-escape*)    *print-escape*)
			       ((:radix   *print-radix*)     *print-radix*)
			       ((:base    *print-base*)      *print-base*)
			       ((:circle  *print-circle*)    *print-circle*)
			       ((:pretty  *print-pretty*)    *print-pretty*)
			       ((:level   *print-level*)     *print-level*)
			       ((:length  *print-length*)    *print-length*)
			       ((:case    *print-case*)      *print-case*)
			       ((:gensym  *print-gensym*)    *print-gensym*)
			       ((:array   *print-array*)     *print-array*))
  "Returns the printed representation of OBJECT as a string."
  (stringify-object object *print-escape*))
;20; things that are in stream.slisp

(defun write-string (string &optional (stream *standard-output*)
			    &key start end)
  "Outputs the String to the given Stream."
  (setq stream (case stream ((t) *terminal-io*)
		     ((nil) *standard-output*)
		     (t stream)))
  (%sp-write-string string stream start end)

(defun write-line (string &optional (stream *standard-output*)
			    &key start end)
  "Outputs the String to the given Stream, followed by a newline character."
  (setq stream (case stream ((t) *terminal-io*)
		     ((nil) *standard-output*)
		     (t stream)))
  (%sp-write-string string stream start end)
  (terpri stream)
(defun output-vector (vector &optional (currlevel 0))
  "Outputs the printed representation of a 1-D array."
  (cond ;20; ((not *print-array*)
	;20;  (output-terse-array vector currlevel))
	 (if (bit-vector-p vector)
	     (write-string "#*")
	     (write-string "#("))
	 (do ((currlength 0 (1+ currlength))
	      (vlength (length (the vector vector)))
	      (not-bit-vector-p (not (bit-vector-p vector))))
	     ;;Terminate at end, or when too much has been output
	     ((or (and (not (null *print-length*))
		       (>= currlength *print-length*))
		  (= currlength vlength))
	      (if (not (= currlength vlength)) (write-string "..."))
	      (if not-bit-vector-p
		  (write-char #\))))
	 ;;Put a space before every element except the first
	 ;; and not in bit vectors.
	 (if (and (> currlength 0)
	     (write-char #\space))
	 ;;Output an element of the vector
	 (output-object (aref vector currlength) currlevel)))))

(defun output-array (array &optional (currlevel 0))
  "Outputs the printed representation of any array in either the #< or #A
  (let ((rank (array-rank array)))
    (cond ;20; ((not *print-array*)
	  ;20;  (output-terse-array array rank))
	   (output-array-guts array rank currlevel)))))

;; Master function for outputing the #A form of an array

(defun output-array-guts (array rank currlevel)
  (write-char #\#)
  (write rank :base 10)
  (write-char #\A)
  (sub-output-array-guts (header-ref array %array-data-slot)
			 (array-dimensions array)
			 currlevel (header-ref array

;; Some Ideas stolen from Skef Wholey.
;; Helping function for above.
(defun sub-output-array-guts (array dimensions currlevel index)
  (cond ((null dimensions)
	 (output-object (aref array index) currlevel)
	 (1+ index))
	((and (not (null *print-level*))
	      (>= currlevel *print-level*))
	 (write-char #\#) index)
	 (write-char #\()
	 (do ((index index)
	      (times 0 (1+ times))
	      (limit (pop dimensions)))
	     ((or (= times limit)
		  (and (not (null *print-length*))
		       (= times *print-length*)))
	      (if (not (= times limit))
		  (write-string "...)")
		  (write-char #\)))
	   (if (not (zerop times)) (write-char #\space))
	   (setq index
		 (sub-output-array-guts array dimensions (1+ currlevel) index))

;;; Structure Printing.

;; *** For Dec-20 Common Lisp Only ***
;;Returns code which fetches the name of a structure.  For a vector
;;structure, the name is in slot zero.

(defmacro access-structure-name (structure)
  `(%sp-svref ,structure 0))
(defun output-structure (structure currlevel)
  (let* ((structure-name (access-structure-name structure))
	 (print-function (get structure-name 'structure-print))
	 (slot-names (defstruct-description-slot-numbers
		       (get structure-name 'defstruct-description))))
    ;;See if it likes printing it's own guts itself.
    ;;If it does, let it.
    (cond ((not (null print-function))
	   (funcall print-function structure *standard-output* currlevel))
	  ((vectorp structure)
	   ;;Otherwise if a print function is not defined.
	   (write-string "#S(")
	   (if (or *print-pretty* *print-circle*)
	       (output-pretty-object structure-name currlevel)
	       (output-object structure-name currlevel))
	   (do ((index (if (simple-vector-p structure) 1 0)
		       (1+ index))
		(structure-length (length structure)))
	       ((or (= index structure-length)
		    (if (not (null *print-length*))
			(= index *print-length*)
		(if (not (= index structure-length))
		    (write-string " ...)")
		    (write-string ")")))
	     (write-char #\space)
	     (if (or *print-pretty* *print-circle*)
		 (output-pretty-object (car (rassoc index slot-names))
		 (output-object (car (rassoc index slot-names)) currlevel))
	     (write-char #\space)
	     (if (or *print-pretty* *print-circle*)
		 (output-pretty-object (aref structure index) currlevel)
		 (output-object (aref structure index) currlevel)))))))
;;; Bignum printing
;;; 20; This bugnum code not used in the Dec-20 version but we do use some
;;;   of these functions (eg. FLONUM-TO-STRING).

;;;; Floating Point printing
;;;  Written by Bill Maddox
;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of 
;;; the work for all printing of floating point numbers in the printer and in
;;; FORMAT.  It converts a floating point number to a string in a free or 
;;; fixed format with no exponent.  The interpretation of the arguments is as 
;;; follows:
;;;     X        - The floating point number to convert, which must not be
;;;                negative.
;;;     WIDTH    - The preferred field width, used to determine the number
;;;                of fraction digits to produce if the FDIGITS parameter
;;;                is unspecified or NIL.  If the non-fraction digits and the
;;;                decimal point alone exceed this width, no fraction digits
;;;                will be produced unless a non-NIL value of FDIGITS has been
;;;                specified.  Field overflow is not considerd an error at this
;;;                level.
;;;     FDIGITS  - The number of fractional digits to produce. Insignificant
;;;                trailing zeroes may be introduced as needed.  May be
;;;                unspecified or NIL, in which case as many digits as possible
;;;                are generated, subject to the constraint that there are no
;;;                trailing zeroes.
;;;     SCALE    - If this parameter is specified or non-NIL, then the number
;;;                printed is (* x (expt 10 scale)).  This scaling is exact,
;;;                and cannot lose precision.
;;;     FMIN     - This parameter, if specified or non-NIL, is the minimum
;;;                number of fraction digits which will be produced, regardless
;;;                of the value of WIDTH or FDIGITS.  This feature is used by
;;;                the ~E format directive to prevent complete loss of
;;;                significance in the printed value due to a bogus choice of
;;;                scale factor.
;;; Most of the optional arguments are for the benefit for FORMAT and are not
;;; used by the printer.
;;; Returns:
;;; where the results have the following interpretation:
;;;     DIGIT-STRING    - The decimal representation of X, with decimal point.
;;;     DIGIT-LENGTH    - The length of the string DIGIT-STRING.
;;;     LEADING-POINT   - True if the first character of DIGIT-STRING is the
;;;                       decimal point.
;;;     TRAILING-POINT  - True if the last character of DIGIT-STRING is the
;;;                       decimal point.
;;;     POINT-POS       - The position of the digit preceding the decimal
;;;                       point.  Zero indicates point before first digit.
;;; WARNING: For efficiency, there is a single string object *digit-string*
;;; which is modified destructively and returned as the value of
;;; FLONUM-TO-STRING.  Thus the returned value is not valid across multiple 
;;; calls.
;;; NOTE:  FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
;;; Specifically, the decimal number printed is the closest possible 
;;; approximation to the true value of the binary number to be printed from 
;;; among all decimal representations  with the same number of digits.  In
;;; free-format output, i.e. with the number of digits unconstrained, it is 
;;; guaranteed that all the information is preserved, so that a properly-
;;; rounding reader can reconstruct the original binary number, bit-for-bit, 
;;; from its printed decimal representation. Furthermore, only as many digits
;;; as necessary to satisfy this condition will be printed.
;;; FLOAT-STRING actually generates the digits for positive numbers.  The
;;; algorithm is essentially that of algorithm Dragon4 in "How to Print 
;;; Floating-Point Numbers Accurately" by Steele and White.  The current 
;;; (draft) version of this paper may be found in [CMUC]<steele>
(defvar *digits* "0123456789")

(defvar *digit-string*
  (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t)
  "Array of digits generated by FLONUM-TO-STRING.")

(defun flonum-to-string (x &optional width fdigits scale fmin)
  (cond ((zerop x)
	 ;;zero is a special case which float-string cannot handle
	 (values "." 1 t t 0))
	  (setf (fill-pointer *digit-string*) 0)
	  (multiple-value-bind (sig exp)
			       (integer-decode-float x)
	    (if (typep x 'short-float)
		;;20 and 53 are the number of bits of information in the
		;;significand, less sign, of a short float and a long float
		(float-string sig exp 20 width fdigits scale fmin)
		(float-string sig exp 53 width fdigits scale fmin))))))
(defun float-string (fraction exponent precision width fdigits scale fmin)
  (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
	(digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high)
    ;;Represent fraction as r/s, error bounds as m+/s and m-/s.
    ;;Rational arithmetic avoids loss of precision in subsequent calculations.
    (cond ((> exponent 0)
	   (setq r (ash fraction exponent))
	   (setq m- (ash 1 exponent))	   
	   (setq m+ m-))                   
	  ((< exponent 0)
	   (setq s (ash 1 (- exponent)))))
    ;;adjust the error bounds m+ and m- for unequal gaps
    (when (= fraction (ash 1 precision))
      (setq m+ (ash m+ 1))
      (setq r (ash r 1))
      (setq s (ash s 1)))
    ;;scale value by requested amount, and update error bounds
    (when scale
      (if (minusp scale)
	  (let ((scale-factor (expt 10 (- scale))))
	    (setq s (* s scale-factor)))
	  (let ((scale-factor (expt 10 scale)))
	    (setq r (* r scale-factor))
	    (setq m+ (* m+ scale-factor))
	    (setq m- (* m- scale-factor)))))
    ;;scale r and s and compute initial k, the base 10 logarithm of r
    (do ()
        ((>= r (ceiling s 10)))
      (decf k)
      (setq r (* r 10))
      (setq m- (* m- 10))
      (setq m+ (* m+ 10)))
    (do ()(nil)
      (do ()
	  ((< (+ (ash r 1) m+) (ash s 1)))
	(setq s (* s 10))
	(incf k))
      ;;determine number of fraction digits to generate
      (cond (fdigits
	     ;;use specified number of fraction digits
	     (setq cutoff (- fdigits))
	     ;;don't allow less than fmin fraction digits
	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
	     ;;use as many fraction digits as width will permit
             ;;but force at least fmin digits even if width will be exceeded
	     (if (< k 0)
		 (setq cutoff (- 1 width))
		 (setq cutoff (1+ (- k width))))
	     (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
      ;;If we decided to cut off digit generation before precision has
      ;;been exhausted, rounding the last digit may cause a carry propagation.
      ;;We can prevent this, preserving left-to-right digit generation, with
      ;;a few magical adjustments to m- and m+.  Of course, correct rounding
      ;;is also preserved.
      (when (or fdigits width)
	(let ((a (- cutoff k))
	      (y s))
	  (if (>= a 0)
	      (dotimes (i a) (setq y (* y 10)))
	      (dotimes (i (- a)) (setq y (ceiling y 10))))
	  (setq m- (max y m-))
	  (setq m+ (max y m+))
	  (when (= m+ y) (setq roundup t))))
      (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
    ;;zero-fill before fraction if no integer part
    (when (< k 0)
      (setq decpnt digits)
      (vector-push-extend #\. *digit-string*)
      (dotimes (i (- k))
	(incf digits) (vector-push-extend #\0 *digit-string*)))
    ;;generate the significant digits
    (do ()(nil)
      (decf k)
      (when (= k -1)
	(vector-push-extend #\. *digit-string*)
	(setq decpnt digits))
      (multiple-value-setq (u r) (truncate (* r 10) s))
      (setq m- (* m- 10))
      (setq m+ (* m+ 10))
      (setq low (< (ash r 1) m-))
      (if roundup
	  (setq high (>= (ash r 1) (- (ash s 1) m+)))
	  (setq high (> (ash r 1) (- (ash s 1) m+))))
      ;;stop when either precision is exhausted or we have printed as many
      ;;fraction digits as permitted
      (when (or low high (and cutoff (<= k cutoff))) (return))
      (vector-push-extend (char *digits* u) *digit-string*)
      (incf digits))
    ;;if cutoff occured before first digit, then no digits generated at all
    (when (or (not cutoff) (>= k cutoff))
      ;;last digit may need rounding
      (vector-push-extend (char *digits*
				(cond ((and low (not high)) u)
				      ((and high (not low)) (1+ u))
				      (t (if (<= (ash r 1) s) u (1+ u)))))
      (incf digits))
    ;;zero-fill after integer part if no fraction
    (when (>= k 0)
      (dotimes (i k) (incf digits) (vector-push-extend #\0 *digit-string*))
      (vector-push-extend #\. *digit-string*)
      (setq decpnt digits))
    ;;add trailing zeroes to pad fraction if fdigits specified
    (when fdigits
      (dotimes (i (- fdigits (- digits decpnt)))
	(incf digits)
	(vector-push-extend #\0 *digit-string*)))
    ;;all done
    (values *digit-string* (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
;;; Given a non-negative floating point number, SCALE-EXPONENT returns a
;;; new floating point number Z in the range (0.1, 1.0] and and exponent
;;; E such that Z * 10^E is (approximately) equal to the original number.
;;; There may be some loss of precision due the floating point representation.

(defconstant short-log10-of-2 0.30103s0)

;20; look this up sometime.  I had Fortran compute this:
; don't compile this, as the compiler will change a low-order bit
; and loading the compiled code will cause an error

(eval-when (eval)
  (defconstant long-log10-of-2 0.30102999508380889893d0)

(defun scale-exponent (x)
  (if (typep x 'short-float)
      (scale-expt-aux x 0.0s0 1.0s0 1.0s1 1.0s-1 short-log10-of-2)
      (scale-expt-aux x 0.0d0 1.0d0 10.0d0 1.0d-1 long-log10-of-2)))

(defun scale-expt-aux (x zero one ten one-tenth log10-of-2)
  (multiple-value-bind (sig exponent)
		       (decode-float x)
    (declare (ignore sig))
    (if (= x zero)
	(values zero 1)
	(let* ((e (round (* exponent log10-of-2)))
	       (x (if (minusp e)		;For the end ranges.
		      (* x ten (expt ten (- -1 e)))
		      (/ x ten (expt ten (1- e))))))
	  (do ((d ten (* d ten))
	       (y x (/ x d))
	       (e e (1+ e)))
	      ((< y one)
	       (do ((m ten (* m ten))
		    (z y (* z m))
		    (e e (1- e)))
		   ((>= z one-tenth) (values z e)))))))))