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)
,terminate-form)
(setq ,variable (char ,init-form index))
,@body)))
;;; 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)))
object)
(defun prin1 (object &optional (stream *standard-output*))
"Outputs a mostly READable printed representation of OBJECT on the specified
stream."
(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)))
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)))
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))))
(terpri)
(prin1 object)
(write-char #\space *standard-output*))
object)
;;; 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)
string)
(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)
string)
(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))
(T
(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)
not-bit-vector-p)
(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
form."
(let ((rank (array-rank array)))
(cond ;20; ((not *print-array*)
;20; (output-terse-array array rank))
(T
(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
%array-displacement-slot)))
;; 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)
(T
(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 #\)))
index)
(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*)
nil))
(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))
currlevel)
(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:
;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
;;; 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>tradix.press.
;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING
;;; THE PAPER!
(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))
(t
(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
;;respectively.
(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))))
(width
;;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)))))
*digit-string*)
(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)))))))))