;;; This is a Spice -*-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.
;;; Spice Lisp is currently incomplete and under active development.
;;; 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. Try compiling DEFSTREAM before compiling this
;;; file.
(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")
(defvar funny-symbol-char-table ()
"Table of boolean values indexed by charcode. The table is loaded
at run time from funny-symbol-char-list by the PRINT-INIT function (q.v.)")
(defvar funny-symbol-char-list
'(#\( #\) #\# #\: #\, #\; #\' #\` #\\ #\" #\space #\tab #\return #\linefeed)
"List of characters which when found in a symbol's name must be
slashed if the symbol is printed by PRIN1 or PRINT.")
;; This variable contains the current definition of one of three symbol
;; printers. This variable is set by the various print function (PRINT,
;; PRINC, and PRIN1).
(defvar internal-symbol-output-function ())
;; Initialized by Print Init.
(defvar print-string-stream ()
"Holds the string stream for the x-TO-STRING functions.")
;; Part of the floating point printing code
(defvar *digit-string* () "Array of digits generated by FLONUM-TO-STRING")
;; Imported from reader
(declare (special *read-default-float-format*))
;; From the package system
(declare (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)))
;;; Print-Init. The printer initialization funtion.
;;; This function loads up the print table FUNNY-SYMBOL-CHAR-TABLE
;;; with either T or NIL, depending on whether or not the character in
;;; question requires a slash if it is printed by PRIN1 (or PRINT) and
;;; occurs in a symbol. Any other printer initialization should go here.
;;; This function is called at system startup time. Because the cold
;;; load can't do arbitrary Lispy things, this function is used to
;;; cons up the funny symbol char table and to cons up a printer
;;; string stream.
(defun print-init ()
(setq *digit-string*
(make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t))
(setq funny-symbol-char-table
(make-vector char-code-limit :initial-element nil)
print-string-stream
(make-string-output-stream))
;; Load up the table with the special syntax characters in FUNNY-SYMBOL-CHAR-LIST.
(mapcar #'(lambda (char)
(setf (svref funny-symbol-char-table (char-code char)) T))
funny-symbol-char-list)
;; Also, any lowercase characters in symbols are consider funny.
(do ((index (char-code #\a) (1+ index)))
((> index (char-code #\z)))
(setf (svref funny-symbol-char-table index) T)))
(Declare (inline setup-printer-state))
;; This function sets the internal global symbol
;; "internal-symbol-output-function" to the right function depending on
;; the value of *print-case*. See the manual for details. The print buffer
;; stream is also reset.
(defun setup-printer-state ()
(unless (eq *standard-output* print-string-stream)
(unless (eq *print-case* previous-case)
(setq previous-case *print-case*)
(setq internal-symbol-output-function
(case *print-case*
(:upcase #'output-uppercase-symbol)
(:downcase #'output-lowercase-symbol)
(:capitalize #'output-capitalize-symbol)
(T (let ((bad-case *print-case*))
(setq *print-case* :upcase)
(Error "Invalid *print-case* value: ~s" bad-case))))))))
;;; Toplevel print functions
(defun write (object &rest keywords)
"Outputs OBJECT to the specified stream, defaulting to *standard-output*"
(setup-printer-state)
(with-keywords keywords
((:stream *standard-output* *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*)
(:array *print-array* *print-array*))
(output-object object)))
(defun prin1 (object &optional (*standard-output* *standard-output*))
"Outputs a mostly READable printed representation of OBJECT on the specified
stream."
(setup-printer-state)
(let ((*print-escape* T))
(if *print-pretty*
(output-pretty-object object)
(output-object object)))
object)
(defun princ (object &optional (*standard-output* *standard-output*))
"Outputs an asthetic but not READable printed representation of OBJECT on the
specified stream."
(setup-printer-state)
(let ((*print-escape* NIL))
(if *print-pretty*
(output-pretty-object object)
(output-object object)))
object)
(defun print (object &optional (*standard-output* *standard-output*))
"Outputs a terpri, the mostly READable printed represenation of OBJECT, and
space to the stream."
(terpri)
(prin1 object)
(write-char #\space *standard-output*)
object)
;; STRINGIFY-OBJECT is an internal printer function produces the printed
;; representation of an object as a string. It is called by various x-TO-STRING
;; functions below.
(defun stringify-object (object &optional (*print-escape* ()))
(let ((*standard-output* print-string-stream))
(setup-printer-state)
(output-object object 0)
(get-output-stream-string *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 &rest keywords)
"Returns the printed representation of OBJECT as a string."
(with-keywords keywords
((:stream *standard-output* *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*)
(:array *print-array* *print-array*))
(stringify-object object *print-escape*)))
(defun prin1-to-string (object)
"Returns the printed representation of OBJECT as a string with
slashification on."
(stringify-object object t))
(defun princ-to-string (object)
"Returns the printed representation of OBJECT as a string with
slashification off."
(stringify-object object nil))
;;; Central print functions.
;;; OUTPUT-OBJECT takes an object and outputs its printed representation to
;;; *STANDARD-OUTPUT*, which is typically bound the the internal print stream.
;;; This function is called recursively by the sub-functions which know how
;;; to print structures which can contain other lisp objects.
(defun output-object (object &optional (currlevel 0))
"Outputs a string which is the printed representation of the given object."
;; First check and make sure we aren't too deep
(cond ((and (not (null *print-level*))
(>= currlevel *print-level*))
(write-char #\#))
(T (typecase object
(symbol
(let ((package (symbol-package object)))
(cond
;; If the symbol is in the keyword package, output a colon.
((eq package *keyword-package*)
(write-char #\:))
;; If the symbol is in the current package, output nothing.
((eq package *package*))
;; Uninterned symbols print with a leading #:.
((null package)
(write-string "#:"))
(t
(let* ((uses (package-use-list *package*))
(it (car (memq package uses))))
(cond
;; If the symbol is in a package used by *package*, but
;; it is not external, qualify it.
(it
(when (eql (gethash (symbol-name object)
(package-external-symbols it)
0)
0)
(write-string (package-name package))
(write-string "::")))
;; If the symbol is external, :, else ::.
(t
(write-string (package-name package))
(if (gethash (symbol-name object)
(package-external-symbols package))
(write-char #\:)
(write-string "::"))))))))
(funcall internal-symbol-output-function object))
;; If a list, go through element by element, being careful
;; about not running over the printlength
(list
(output-list object (1+ currlevel)))
(string
(if *print-escape*
(quote-string object)
(write-string object)))
(integer
(output-integer object))
(float
(output-float object))
(ratio
(output-ratio object))
(structure
(output-structure object currlevel))
(character
(output-character object))
(vector
(output-vector object))
(array
(output-array object (1+ currlevel)))
(t (output-random object)))))
'T)
;;; Symbol Printing Subfunctions
(declare (inline funny-symbol-char-p))
(defun funny-symbol-char-p (char)
"Determines whether or not the character should be proceded by a slash when
outputing the printed representation of a symbol containing it."
;; Should really look at readtable, not quite ready for such
;; a feat so use optimized table lookup hack
(svref funny-symbol-char-table (char-code char)))
;; This function is hooked into the variable internal-symbol-output-function
;; when the value of *print-case* is :upcase. If *print-escape* is NIL, just
;; output the symbol as is (just the way the reader set the print-name).
;; Otherwise just add slashes before the lowercase characters and any other
;; strange characters.
(defun output-uppercase-symbol (symbol)
(if *print-escape*
(quote-symbol-uppercase (symbol-name symbol))
(write-string (symbol-name symbol))))
;; This function is hooked into the variable internal-symbol-output-function
;; when the value of *print-case* is :downcase. If *print-escape* is NIL,
;; lowercase all the characters and output the symbol. If it is T, make sure
;; every character is lowercase, and slash those letters that already are.
(defun output-lowercase-symbol (symbol)
(if *print-escape*
(quote-symbol-lowercase (symbol-name symbol))
(write-string (string-downcase (symbol-name symbol)))))
;; This function is hooked into the variable internal-symbol-output-function
;; when the value of *print-case* is :capitalize. If *print-escape* is NIL,
;; lowercase all the characters (except the first, leave that alone) and
;; output the symbol. If it is T, make sure every character is
;; lowercase (except the first), and slash those letters that already are.
(defun output-capitalize-symbol (symbol)
(if *print-escape*
(quote-symbol-capitalize (symbol-name symbol))
(if (upper-case-p (char (symbol-name symbol) 0))
(write-string (string-capitalize (symbol-name symbol)))
(write-string (string-downcase (symbol-name symbol))))))
(defmacro symbol-quote-char-p (char)
"Determines whether or not the character is a symbol quoter."
;; Should really look at readtable, not ready yet for that.
`(or (char= ,char #\\)
(char= ,char #\|)))
;;;
;;; This function takes the pname of a symbol and adds slashes and/or
;;; vertical bars to it to make it readable again.
;;; Special quoting characters are currently vertical bar and slash who's
;;; role in life are to specially quote symbols. Funny symbol characters
;;; are those who need special slashification when they are to be printed
;;; so they can be read in again. These currently include such characters
;;; as hash signs, colons of various sorts, etc.
;;; Now there are three different version: UPPERCASE, lowercase and Captialize.
;;; Check out the manual under the entry for *print-case* for details.
(defun quote-symbol-uppercase (pname)
(declare (simple-string pname))
(let ((vertical-bar-flag
(or
(not (null (find-if #'funny-symbol-char-p pname)))
(do ((index 0 (1+ index))
(length (length pname)))
((= index length) t)
(if (not (digit-char-p (char pname index) *print-base*))
(return ()))))))
;;If we will be using vertical bars to quote instead slashes
(if vertical-bar-flag (write-char #\|))
(dostring (char pname)
;;If it needs slashing, do it.
(if (symbol-quote-char-p char)
(write-char #\\))
(write-char char))
(if vertical-bar-flag (write-char #\|))))
;; See documentation for quote-symbol-uppercase (above).
(defun quote-symbol-lowercase (pname)
(declare (simple-string pname))
(let ((vertical-bar-flag
(or
(not (null (find-if #'funny-symbol-char-p pname)))
(do ((index 0 (1+ index))
(length (length pname)))
((= index length) t)
(if (not (digit-char-p (char pname index) *print-base*))
(return ()))))))
;;If we will be using vertical bars to quote instead slashes
(if vertical-bar-flag (write-char #\|))
(dostring (char pname)
;;If it needs slashing, do it.
(if (symbol-quote-char-p char)
(write-char #\\))
(write-char (char-downcase char)))
(if vertical-bar-flag (write-char #\|))))
;; See documentation for quote-symbol-uppercase (above).
(defun quote-symbol-capitalize (pname)
(declare (simple-string pname))
(let ((vertical-bar-flag
(or
(not (null (find-if #'funny-symbol-char-p pname)))
(do ((index 0 (1+ index))
(length (length pname)))
((= index length) t)
(if (not (digit-char-p (char pname index) *print-base*))
(return ()))))))
;;If we will be using vertical bars to quote instead slashes
(if vertical-bar-flag (write-char #\|))
(do ((index 0 (1+ index))
(pname-length (length (the string pname))))
((= index pname-length))
(let ((char (char pname index)))
;;If it needs slashing, do it.
(if (symbol-quote-char-p char)
(write-char #\\))
(write-char (if (= index 0) char (char-downcase char)))))
(if vertical-bar-flag (write-char #\|))))
;;; Recurisve Datatype Printing Subfunctions
(defun output-list (list &optional (currlevel 0))
"Outputs the printed representation of a list."
(write-char #\()
(do ((list list (cdr list))
(currlength 0 (1+ currlength)))
;; Terminate when we've gotten to the end of the list, or we've printed
;; too much (according to *print-length*).
((or (null list)
(and (not (null *print-length*))
(>= currlength *print-length*)))
;; If we've terminated but had more to print
;; we notify with ellipses
(if (not (null list)) (write-string "..."))
(write-char #\)))
;;If we are not printing the first object, we should space first.
(if (> currlength 0) (write-char #\space))
;;Print whatever the car of the list is, at this level.
(output-object (car list) currlevel)
;; Check for the non-null terminated list. If present, print
;; " . <non-null-terminator>)" and terminate printing of list.
(cond ((not (or (consp (cdr list))
(null (cdr list))))
(write-string " . ")
(output-object (cdr list) currlevel)
(write-char #\))
(return ())))))
(defun output-vector (vector &optional (currlevel 0))
"Outputs the printed representation of a 1-D array."
(cond ((not *print-array*)
(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 ((not *print-array*)
(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 #\#)
(output-integer rank)
(write-char #\A)
(sub-output-array-guts (%primitive header-ref array %array-data-slot)
(array-dimensions array)
currlevel 0))
;; Some Ideas stolen from Skef Wholey.
;; Helping function for above.
(defun sub-output-array-guts (array dimensions currlevel index)
(cond ((null dimensions)
(output-object (%sp-svref 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))
))))
;; Used to output the #< form of any array.
(defun output-terse-array (array rank)
(write-string "#<")
(cond ((vectorp array)
(if (bit-vector-p array)
(write-string "Bit-vector")
(write-string "Vector")))
(T
(write-string "Array, rank ")
(output-integer rank)))
(finish-random array))
;;; Structure Printing.
;; *** For Spice Lisp Only ***
;;Returns code which fetches the name of a structure. If it is a vector
;;structure, the name is in slot zero. Otherwise it must be an
;;array structure, so look in slot six.
(defmacro access-structure-name (structure)
`(if (vectorp ,structure)
(%sp-svref ,structure 0)
(%sp-svref ,structure 6)))
(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(")
(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)
(output-object (car (rassoc index slot-names)) currlevel)
(write-char #\space)
(output-object (aref structure index) currlevel))))))
;; Helping functions for printing strings.
(defmacro funny-string-char-p (char)
"Determines whether or not the character needs quoting in a string."
;; Should maybe look at readtable, not quite ready for such feat so
;; use hack.
`(or (char= ,char #\\)
(char= ,char #\")))
;;;
;;; This function takes a string and slashifies it sufficiently so
;;; that if so that it may be read in again.
;;; Strategy: Put slash before all and only those characters which are
;;; either double-quote or backslash.
;;;
(defun quote-string (string)
"Quotes a string so that if printed, it could be read back in again."
(write-char #\")
(dostring (char string)
(if (funny-string-char-p char) (write-char #\\))
(write-char char))
(write-char #\"))
(defun whitespace-char-p (char)
"Determines whether or not the character is considered whitespace."
(or (char= char #\space)
(char= char #\tab)
(char= char #\return)
(char= char #\linefeed)))
;;; Numerical Printer Functions.
;; Helping function for above that actually outputs the individual digits.
(defun output-integer (integer)
"This function outputs the printed representation of any integer"
(cond ((not (and (fixnump *print-base*) (> *print-base* 1)))
(let ((obase *print-base*))
(setq *print-base* 10.)
(error "~A is not a reasonable value for *Print-Base*." obase)))
;; Otherwise print the base
(T (cond ((and (not (= *print-base* 10.))
*print-radix*)
;; First print leading base information, if any.
(write-char #\#)
(write-char (case *print-base*
(2. #\b)
(8. #\o)
(16. #\x)
(T (let ((fixbase *print-base*)
(*print-base* 10.)
(*print-radix* ()))
(sub-output-integer fixbase))
#\r)))))
;; Then output a minus sign if the number is negative, then output
;; the absolute value of the number.
(cond ((bignump integer) (print-bignum integer))
((< integer 0)
(write-char #\-)
(sub-output-integer (- integer)))
(T (sub-output-integer integer)))
;; Print any trailing base information, if any.
(if (and (= *print-base* 10.) *print-radix*) (write-char #\.)))))
(defun sub-output-integer (integer)
(let ((quotient)
(remainder))
;; Recurse until you have all the digits pushed on the stack.
(if (not (zerop (multiple-value-setq (quotient remainder)
(truncate integer *print-base*))))
(sub-output-integer quotient))
;; Then as each recursive call unwinds, turn the digit (in remainder)
;; into a character and output the character.
(write-char (int-char (if (and (> remainder 9.)
(> *print-base* 10.))
(+ (char-int #\A) (- remainder 10.))
(+ (char-int #\0) remainder))))))
;;; Outputs the printed representation of a ratio.
(defun output-ratio (ratio)
(output-integer (numerator ratio))
(write-char #\/)
(output-integer (denominator ratio)))
;;; Bignum printing
;;;
;;; Written by Steven Handerson
;;; (based on Skef's idea)
;;;
;;; Uses the bignum-fixnum-divide-inplace function in spnum to do the
;;; division without consing a new bignum.
;;; We compute as large a possible base power for the in-place division.
;;; We need to copy the bignum anyway, so we either negate (hence copy)
;;; or copy. The auxiliary function uses fixnum printing.
;;;
(declare (special *%base-power* *%base-power-1*))
(defun print-bignum (big)
(let* ((copy (cond ((minusp big) (write-char #\-) (- big))
(t (copy-xnum big))))
(*%base-power* (do ((newbase (* *print-base* *print-base*)
(* newbase *print-base*)))
((> (integer-length newbase) 19)
(/ newbase *print-base*))))
(*%base-power-1* (/ *%base-power* *print-base*)))
(bignum-print-aux copy)
big))
;;; The *%base-power-1* is needed to assure the printing of leading zeros
;;; in the parts of the bignum.
(defun bignum-print-aux (big)
(multiple-value-bind (newbig fix)
(bignum-fixnum-divide-inplace big *%base-power*)
(if (fixnump newbig) (sub-output-integer newbig)
(bignum-print-aux newbig))
(do ((frob (logior *print-base* fix) (* frob *print-base*))) ;For zero.
((> frob *%base-power-1*) (sub-output-integer fix))
(write-char #\0))))
;;;; 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")
;;; The initialization of *digit-string* must be done in PRINT-INIT due
;;; to cold-loader lossage.
;(defvar *digit-string*
; (make-array 50 :element-type 'string-char :fill-pointer 0 :adjustable t))
(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))
(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)
;;; Nuke contstant properties on long float constants so Genesis doesn't
;;; choke.
(eval-when (compile)
(remprop '%long-float-ten '%constant)
(remprop '%long-float-one-tenth '%constant)
(remprop 'long-log10-of-2 '%constant))
(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 (%sp-l-float 0) (%sp-l-float 1) %long-float-ten
%long-float-one-tenth 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)
(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)))))))))
;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
;;; etc. The argument is printed free-format, in either exponential or
;;; non-exponential notation, depending on its magnitude.
;;;
;;; NOTE: When a number is to be printed in exponential format, it is scaled
;;; in floating point. Since precision may be lost in this process, the
;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The
;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
;;; integers of similar magnitude to that of the number being printed. For
;;; large exponents, the bignums really get out of hand. When we switch to
;;; IEEE format for long floats, this will significantly restrict the magnitude
;;; of the largest allowable float. This combined with microcoded bignum
;;; arithmetic might make it attractive to handle exponential notation with
;;; the same accuracy as non-exponential notation, using the method described
;;; in the Steele and White paper.
(eval-when (compile)
(remprop '%long-float1l-3 '%constant)
(remprop '%long-float1l7 '%constant))
(defun output-float (x)
(if (typep x 'short-float)
(output-float-aux x 1.0s-3 1.0s7)
(output-float-aux x %long-float1l-3 %long-float1l7)))
(defun output-float-aux (x e-min e-max)
(cond ((zerop x) (write-string "0.0")
(if (not (typep x *read-default-float-format*))
(write-string (if (typep x 'short-float) "s0" "L0"))))
(t (when (minusp x)
(write-char #\-)
(setq x (- x)))
(if (and (>= x e-min) (< x e-max))
;;free format
(multiple-value-bind (str len lpoint tpoint)
(flonum-to-string x)
(when lpoint (write-char #\0))
(write-string str)
(when tpoint (write-char #\0))
(if (not (typep x *read-default-float-format*))
(write-string (if (typep x 'short-float) "s0" "L0"))))
;;exponential format
(multiple-value-bind (f e)
(scale-exponent x)
(multiple-value-bind (str len lpoint tpoint)
(flonum-to-string f nil nil 1)
(when lpoint (write-char #\0))
(write-string str)
(when tpoint (write-char #\0))
(write-char (if (typep x *read-default-float-format*)
#\E
(if (typep x 'short-float) #\S #\L)))
;;must subtract 1 from exponent here, due to
;;the scale factor of 1 in call to FLONUM-TO-STRING
(unless (minusp (1- e)) (write-char #\+))
(output-integer (1- e))))))))
;;; Character Printing Subfunctions.
(defun if-bit (char name)
(if (char-bit char name)
(concatenate 'simple-string (the simple-string (symbol-name name)) "-")
""))
;; NAME-BITS produces a string naming the bits on in the given character.
(defun name-bits (char)
(concatenate 'simple-string (if-bit char :CONTROL) (if-bit char :META)
(if-bit char :HYPER) (if-bit char :SUPER)))
;; FUNNY-CHARACTER-CHAR-P returns a predicate which determines whether a
;; character must be slashified when being output.
(defmacro funny-character-char-p (char)
`(and *print-escape*
(not (zerop (char-bits ,char)))
(or (funny-symbol-char-p ,char)
(lower-case-p ,char))))
(defun output-character (char)
"Outputs the printed represenation of the given character."
(cond ((not *print-escape*)
(write-char char))
(T
;; If we are PRIN1ing output a hash prefix for character
;; with proper slash...
(write-string "#\\")
;; Write out the names of any bits this guy has...
(write-string (name-bits char))
(let* ((char (code-char (char-code char)))
(name (char-name char)))
;; If he's got a name, print that.
(cond (name (write-string name))
;; Otherwise print the character maybe slashifying.
(t (if (funny-character-char-p char)
(write-char #\\))
(write-char char)))))))
;;; Random and Misc. Print Subfunctions
;;For Spice Lisp Only! Change these functions for other implementations
;; [access-subr-name, misc-type?, misc-type-code]
;; Returns the name of a subr as a string.
(defmacro access-subr-name (object)
`(symbol-name (%primitive header-ref ,object %function-name-slot)))
;; Produces code which returns T iff the argument is of misc type
(defmacro misc-type? (object)
`(= (%sp-type ,object) %misc-type))
;; Returns the name of the subtype of a misc-typed object.
(defun misc-type-code (object)
(declare (ignore object))
"Type 0 object")
;;; OUTPUT-FUNCTION-OBJECT outputs the main part of the printed
;;; representation of function objects. It is called from OUTPUT-RANDOM
;;; below.
(defun output-function-object (subr)
(write-string "Function ")
(write-string (access-subr-name subr)))
;;; FINISH-RANDOM is a helping function for OUTPUT-RANDOM below.
;;; It outputs the numerical value of the low 28 bits of
;;; RANDOM-OBJECT, enclosed in braces, followed by the closing
;;; angle-bracket (">") random objects have at the end. This
;;; is used to distringuish random objects of the same type.
(defun finish-random (random-object)
(write-string " {")
(output-integer (%sp-make-fixnum random-object))
(write-string "}>"))
;;; Functions Objects and other implmentation specific objects
;;; are output here.
(defun output-random (object)
(write-string "#<")
(cond ((functionp object)
(output-function-object object))
((misc-type? object)
(write-string (misc-type-code object)))
(t (write-string "Pointer into Hell, level ")
(output-integer (%sp-type object))))
(finish-random object))