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