;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;; Free Software under MIT-Style license. See file LICENSE.         ;;;
;;;                                                                  ;;;
;;; Copyright (c) 2005-2008 ITA Software, Inc.  All rights reserved. ;;;
;;;                                                                  ;;;
;;; Original author: Scott McKay, Francois-Rene Rideau               ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Note: these should all be moved to their own library.

#+xcvb (module (:depends-on ("pkgdcl")))

(in-package :quux-time)

;; We used to have a DEFINE-CONSTANT that tried to do the right thing with respect to
;; multiple evaluations of DEFCONSTANT (which always happens when you COMPILE-FILE
;; then LOAD a file where it is used). But there was no way to define DEFINE-CONSTANT
;; such that it would always STYLE-WARN when we're redefining a constant into
;; something different yet remain silent when we run a same form that isn't
;; EQL-constant in a (LOAD ...) right after having (COMPILE-FILE ...)'ed it in the
;; same image. And that's because DEFINE-CONSTANT was fighting the symptom.  The real
;; problem is that DEFINE-CONSTANT provided no way to define what it means for a
;; constant to be constant. And so I declared DEFINE-CONSTANT deceased, and we should
;; now use DEFCONSTANT-EQX as taken from SBCL internals, and its variants hereby
;; defined.  They have the advantage of being explicit as to what equality predicate
;; is to be preserved by the "constantness" of the constant. Good practice.
;; --fare
;;
;; Use DEFCONSTANT for numbers and keywords (DEFCONSTANT-EQL is semantically the same, but safer).
;; Use DEFCONSTANT-EQUAL for lists and strings.
;; Use DEFCONSTANT-EQUALP for arrays and structures.
;; Use DEFCONSTANT-UNEQUAL for special tags such as '(#:eof).
;;
;; "One man's constant is another man's variable." -- Alan Perlis
;;
(defmacro defconstant-eql (symbol expr &optional doc)
  `(defconstant-eqx ,symbol ,expr #'eql ,@(when doc (list doc))))

(defmacro defconstant-equal (symbol expr &optional doc)
  `(defconstant-eqx ,symbol ,expr #'equal ,@(when doc (list doc))))

(defmacro defconstant-equalp (symbol expr &optional doc)
  `(defconstant-eqx ,symbol ,expr #'equalp ,@(when doc (list doc))))

(defmacro defconstant-unequal (symbol expr &optional doc)
  `(defconstant-eqx ,symbol ,expr (constantly t) ,@(when doc (list doc))))

(defmacro defconstant-eqx (symbol expr eqx &optional doc)
  `(defconstant ,symbol
     (%defconstant-eqx-value ',symbol ,expr ,eqx)
     ,@(when doc (list doc))))

(defun %defconstant-eqx-value (symbol expr eqx)
  (declare (type function eqx))
  (flet ((bummer (explanation)
           (cerror "Attempt to change value anyway"
                   "~@<bad DEFCONSTANT-EQX ~S ~2I~_~S: ~2I~_~A ~S~:>"
                   symbol expr explanation (symbol-value symbol))))
    (cond ((not (boundp symbol))
           expr)
          ((not (constantp symbol))
           (bummer "already bound as a non-constant")
           expr)
          ((not (funcall eqx (symbol-value symbol) expr))
           (bummer "already bound as a different constant value")
           expr)
          (t
           (symbol-value symbol)))))

#+asdf-dependency-grovel
(progn
  (asdf-dependency-grovel:define-symbol-alias defconstant-eqx defconstant)
  (asdf-dependency-grovel:define-symbol-alias defconstant-eql defconstant)
  (asdf-dependency-grovel:define-symbol-alias defconstant-equal defconstant)
  (asdf-dependency-grovel:define-symbol-alias defconstant-equalp defconstant)
  (asdf-dependency-grovel:define-symbol-alias defconstant-unequal defconstant))


(defmacro defun-inline (name arglist &body body)
  `(progn
     (declaim (inline ,name))
     (defun ,name ,arglist ,@body)))


;;; Faster integer primitives

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defconstant $fixnum-max-bit-index #.(1- (integer-length most-positive-fixnum))
               "The maximum amount that a fixnum can be shifted.")
  
)       ;eval-when

(defmacro i+ (&rest fixnums)

  "A version of the + function that can only be used on fixnums."

  `(the fixnum (+ ,@(loop for n in fixnums collect `(the fixnum ,n)))))

(defmacro i- (number &rest fixnums)

  "A version of the - function that can only be used on fixnums."

  `(the fixnum (- (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))

(defmacro i* (&rest fixnums)

  "A version of the * function that can only be used on fixnums."

  `(the fixnum (* ,@(loop for n in fixnums collect `(the fixnum ,n)))))

(defmacro i/ (x y)

  "A version of the / function that can only be used on fixnums."

  `(the fixnum (floor (the fixnum ,x) (the fixnum ,y))))

(defmacro i= (&rest fixnums)

  "A version of the = function that can only be used on fixnums."

  `(= ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro i/= (&rest fixnums)

    "A version of the /= function that can only be used on fixnums."

      `(/= ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro i< (&rest fixnums)

    "A version of the < function that can only be used on fixnums."

    `(< ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro i<= (&rest fixnums)

  "A version of the <= function that can only be used on fixnums."

  `(<= ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro i> (&rest fixnums)

  "A version of the > function that can only be used on fixnums."

  `(> ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro i>= (&rest fixnums)

  "A version of the >= function that can only be used on fixnums."

  `(>= ,@(loop for n in fixnums collect `(the fixnum ,n))))

(defmacro imax (number &rest fixnums)

  "A version of the max function that can only be used on fixnums."

  `(the fixnum (max (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))

(defmacro imin (number &rest fixnums)

  "A version of the min function that can only be used on fixnums."

  `(the fixnum (min (the fixnum ,number) ,@(loop for n in fixnums collect `(the fixnum ,n)))))

(defmacro imod (x y)

  "A version of the mod function that can only be used on fixnums."

  `(the fixnum (mod (the fixnum ,x) (the fixnum ,y))))

(defmacro irem (x y)

  "A version of the rem function that can only be used on fixnums."

  `(the fixnum (rem (the fixnum ,x) (the fixnum ,y))))

(defmacro ifloor (x y)

  "A version of the floor function that can only be used on fixnums."

  `(the fixnum (floor (the fixnum ,x) (the fixnum ,y))))

(defmacro ifloor+ (x y)

  "A version of the floor+ function that can only be used on fixnums."

  `(the fixnum (truncate (the fixnum ,x) (the fixnum ,y))))
(defmacro itruncate (x y)

  "A version of the truncate function that can only be used on fixnums."

  `(the fixnum (truncate (the fixnum ,x) (the fixnum ,y))))

(defmacro iceiling (x y)

  "A version of the ceiling function that can only be used on fixnums."

  `(the fixnum (ceiling (the fixnum ,x) (the fixnum ,y))))

(defmacro iceiling+ (x y)

  "A version of the ceiling+ function that can only be used on fixnums."

  `(the fixnum (ceiling (the (integer 0 ,most-positive-fixnum) ,x)
                        (the (integer 0 ,most-positive-fixnum) ,y))))

(defmacro i1+ (x)

  "A version of the 1+ function that can only be used on fixnums."

  `(the fixnum (1+ (the fixnum ,x))))

(defmacro i1- (x)

  "A version of the 1- function that can only be used on fixnums."

  `(the fixnum (1- (the fixnum ,x))))

(defmacro izerop (x)

  "A version of the zerop function that can only be used on fixnums."

  `(zerop (the fixnum ,x)))

(defmacro iplusp (x)

  "A version of the plusp function that can only be used on fixnums."

  `(plusp (the fixnum ,x)))

(defmacro iminusp (x)

  "A version of the minusp function that can only be used on fixnums."

  `(minusp (the fixnum ,x)))

(defmacro iash (value count)

  "A version of the ash function that can only be used on fixnums."

  `(the fixnum (ash (the fixnum ,value) (the fixnum ,count))))

(defmacro ilogior (&rest fixnums)

  "A version of the logior function that can only be used on fixnums."

  (if (cdr fixnums)
      `(the fixnum (logior (the fixnum ,(car fixnums))
                           ,(if (cddr fixnums)
                                `(ilogior ,@(cdr fixnums))
                                `(the fixnum ,(cadr fixnums)))))
      `(the fixnum ,(car fixnums))))

(defmacro ilogand (&rest fixnums)

  "A version of the logand function that can only be used on fixnums."

  (if (cdr fixnums)
      `(the fixnum (logand (the fixnum ,(car fixnums))
                           ,(if (cddr fixnums)
                                `(ilogand ,@(cdr fixnums))
                                `(the fixnum ,(cadr fixnums)))))
      `(the fixnum ,(car fixnums))))

(defmacro ilogxor (&rest fixnums)

  "A version of the logxor function that can only be used on fixnums."

  (if (cdr fixnums)
      `(the fixnum (logxor (the fixnum ,(car fixnums))
                           ,(if (cddr fixnums)
                                `(ilogxor ,@(cdr fixnums))
                                `(the fixnum ,(cadr fixnums)))))
      `(the fixnum ,(car fixnums))))

(defmacro ilogeqv (&rest fixnums)

  "A version of the logeqv function that can only be used on fixnums."

  (if (cdr fixnums)
      `(the fixnum (logeqv (the fixnum ,(car fixnums))
                           ,(if (cddr fixnums)
                                `(ilogeqv ,@(cdr fixnums))
                                `(the fixnum ,(cadr fixnums)))))
      `(the fixnum ,(car fixnums))))

(defmacro ilogandc2 (x y)

  "A version of the logandc2 function that can only be used on fixnums."

  `(the fixnum (logandc2 (the fixnum ,x) (the fixnum ,y))))

(defmacro ilognot (x)

  "A version of the lognot function that can only be used on fixnums."

  `(the fixnum (lognot (the fixnum ,x))))

(defmacro ilogtest (x y)

  "A version of the logtest function that can only be used on fixnums."

  `(logtest (the fixnum ,x) (the fixnum ,y)))

(defmacro ilogbitp (index integer)

  "A version of the logbitp function that can only be used on fixnums."

  `(logbitp (the fixnum ,index) (the fixnum ,integer)))

(defmacro ilogcount (number)

  "A version of the logcount function that can only be used on fixnums."

  `(the fixnum (logcount (the fixnum ,number))))

(defun-inline ilogbit-set (integer index)

  "Given a fixnum and an index, return the fixnum with the index'ed bit set to one."

  (ilogior (the fixnum integer) (iash 1 (the (integer 0 #.$fixnum-max-bit-index) index))))

(defun-inline ilogbit-unset (integer index)

  "Given a fixnum and an index, return the fixnum with the index'ed bit set to zero."

  (ilogandc2 (the fixnum integer) (iash 1 (the (integer 0 #.$fixnum-max-bit-index) index))))

(defun-inline ilogsubsetp (n1 n2)

  "Given two fixnums, return true if the bits set in n1 are a subset
   of the bits set in n2."

  (i= n1 (ilogand n1 n2)))

(defmacro ildb (bytespec value)

  "A version of the ldb function that can only be used on fixnums."

  `(ldb ,bytespec (the fixnum ,value)))

(defmacro idpb (newvalue bytespec value)

  "A version of the dpb function that can only be used on fixnums."

  `(dpb (the fixnum ,newvalue) ,bytespec (the fixnum ,value)))

(define-modify-macro iincf (&optional (delta 1)) i+
                     "Set place to + of place and argument, for fixnums only.")
(define-modify-macro idecf (&optional (delta 1)) i-
                     "Set place to - of place and argument, for fixnums only.")

(define-modify-macro minf (x &rest xs) min
                     "Set place to min of place and argument.")
(define-modify-macro maxf (x &rest xs) max
                     "Set place to max of place and argument.")

(define-modify-macro iminf (x &rest xs) imin
                     "Set place to min of place and argument, for fixnums only.")
(define-modify-macro imaxf (x &rest xs) imax
                     "Set place to max of place and argument, for fixnums only.")

(defmacro check-types (&rest clauses)

  "Each clause looks like (type form1 form2 ..).
   For each clause, assert that all the forms are of that type.
   Example: (check-types (integer x y) (string z) ...)."

  `(progn
     ,@(loop :for (type . vars) :in clauses :nconc
         (loop :for var :in vars :collect
           `(check-type ,var ,type)))))

;;; Bring values a little bit further forward in the language.

;; These are completely compatible with let and let*, and provide
;; for value lists.
(defmacro multiple-value-let (decls &body body)

  "MULTIPLE-VALUE-LET ({(Varlist [Multiple-Value]) | (Var [Value]) | Var}*) Declaration* Form*
  During evaluation of the Forms, Bind the Vars to the result of evaluating the
  Value forms.  If a list of variables is given, they are bound to each of the
  VALUES returned by the expression, in order.  The variables are bound in
  parallel after all of the Values are evaluated."

  (labels ((m-v-l-helper-1 (vars vals body)
             (if (null vars)
                 body
                 (m-v-l-helper-1 (rest vars) (rest vals)
                                 (if (listp (first vars))
                                     `((multiple-value-bind ,(first vars) (values ,@(first vals))
                                         ,@body))
                                     `((let ((,(first vars) ,(first vals)))
                                         ,@body))))))
           (m-v-l-helper (decls body vars vals)
             (if (null decls)
                 ;; m-v-l-helper-1 returns a body, but we know it's a single multiple-value-bind
                 ;; because we filtered out the null decls in the main body of multiple-value-let
                 (first (m-v-l-helper-1 vars vals body))
                 (let ((var-list (car decls))
                       val-expr
                       (rest-decls (cdr decls)))
                   (unless (symbolp var-list)
                     (assert (= (length var-list) 2) ()
                             "Bad initialization form: ~S" var-list)
                     (setq val-expr (cdr var-list)
                           var-list (car var-list)))
                   (cond
                     ;; Simple let case
                     ((symbolp var-list)
                      (let ((renamed-var (gensym (symbol-name var-list))))
                        `(let ((,renamed-var ,@val-expr))
                           ,(m-v-l-helper rest-decls body (cons var-list vars) (cons renamed-var vals)))))
                     ;; Multiple-value case
                     ((every #'symbolp var-list)
                      (let ((renamed-vars (map 'list
                                               #'(lambda (s) (gensym (symbol-name s)))
                                               var-list)))
                        `(multiple-value-bind ,renamed-vars ,@val-expr
                           ,(m-v-l-helper rest-decls body (cons var-list vars) (cons renamed-vars vals)))))
                     (t (error "badly formed variable list for multiple-value-let")))))))
    (cond ((null decls)
           ;; Get correct declaration context for body
           `(let () ,@body))
          ((and (consp decls) (consp (car decls)) (listp (caar decls)) (null (rest decls)))
           ;; If there's just a single set of bindings, just make a multiple-value-bind
           (destructuring-bind ((var-list val-expr)) decls
             `(multiple-value-bind ,var-list ,val-expr ,@body)))
          ((null (rest decls))
           ;; If there's just one, and it isn't a multiple-value thing, pass it on to
           ;; let, it knows what to do.
           `(let ,decls ,@body))
          (t
           (m-v-l-helper decls body nil nil)))))

(defmacro multiple-value-let* ((decl &rest decls) &body body)

  "MULTIPLE-VALUE-LET* ({(Varlist [Multiple-Value]) | (Var [Value]) | Var}*) Declaration* Form*
  During evaluation of the Forms, Bind the Vars to the result of evaluating the
  Value forms.  If a list of variables is given, they are bound to each of the
  VALUES returned by the expression, in order.  The variables are bound in
  series, so any declaration may refer to any earlier one."

  ;; Conceptually you might want to define this in terms
  ;; of 'multiple-value-let', but this is more efficient
  (append (cond
            ((and (consp decl) (listp (car decl)))
             (assert (= (length decl) 2) ()
                     "Bad initialization form: ~S" decl)
             `(multiple-value-bind ,@decl))
            (t `(let (,decl))))
          (if decls
              `((multiple-value-let* ,decls ,@body))
              body)))

(defun-inline ascii-digit-p (ch)

  "If the character is an ASCII digit, return the value of the digit."

  ;; Should replace 'digit-char-p' everywhere in QRes to make it work
  ;; compatibly independently of the CL implementation.
  ;; return the digit value if it's a digit, to be compatible with digit-char-p (base is always 10)
  (let ((d (- (char-code ch) (char-code #\0)))) ;--- assumes ASCII
    (if (<= 0 d 9) d nil)))

(defun-inline upper-case-ascii-letter-p (ch)

  "Return true if the character is an ASCII uppercase character."

  (char<= #\A ch #\Z))

(defun-inline lower-case-ascii-letter-p (ch)

  "Return true if the character is an ASCII lowercase character."

  (char<= #\a ch #\z))          ;--- assumes ASCII

(defun ascii-letter-p (ch)

  "Return true if the character is an ASCII alphabetic character."

  ;; Should replace 'alpha-char-p' everywhere in QRes to make it work
  ;; compatibly independently of the CL implementation.
  (or (upper-case-ascii-letter-p ch)
      (lower-case-ascii-letter-p ch)))

(defmethod ends-with ((string string) (suffix string) &key (end (length string)))
  (and (i>= end (length suffix))
       (string-equal string suffix :start1 (i- end (length suffix)) :end1 end)
       suffix))

(defmethod ends-with ((string string) (suffix character) &key (end (length string)))
  (and (>= (length string) end 1)
       (char-equal (char string (1- end)) suffix)
       (string suffix)))

(defmethod ends-with ((string string) (suffixes list) &key (end (length string)))
  (loop for suffix in suffixes
        as result = (ends-with string suffix :end end)
        when result
        return result))

;; Creates gensyms for use in a macro expansion.
;;--- This is a less brittle version of the CLiki 'with-unique-names' proposal
(eval-when (:compile-toplevel :load-toplevel :execute)

  (defmacro with-gensyms ((&rest bindings) &body body)

    "BINDINGS is a list of clauses.  The canonical clause looks like
    (VARIABLE PREFIX) where VARIABLE is a Lisp variable, and PREFIX
    is a string (or anything acceptable to the STRING) function.
    Each VARIABLE is bound to a gensym, made with the PREFIX, and
    the body is run inside those bindings.  A clause of the form
    (VARIABLE) or VARIABLE is treated as (VARIABLE VARIABLE).
    This is available at compile-time, so macro bodies can use it."

    `(let ,(mapcar #'(lambda (binding)
                       (multiple-value-bind (var prefix)
                           (if (consp binding)
                               (values (first binding) (or (second binding) (first binding)))
                               (values binding binding))
                         `(,var (gensym ,(string prefix)))))
                   bindings)
       ,@body))

)       ;eval-when

;; Allows and ignores trailing whitespace (for database values, etc)
;; Keys are as for 'parse-integer' (start, end, radix -- but not junk-allowed)
(defun string-to-integer (object &rest keys)
  (declare (dynamic-extent keys))
  (etypecase object
    (integer object)
    (string
     (flet ((parse-it (string)
              (apply #'parse-integer string :junk-allowed t keys)))
       (declare (dynamic-extent #'parse-it))
       (apply #'parse-right-trimming-whitespace #'parse-it 'integer object keys)))))

(defun parse-right-trimming-whitespace (parser type string
                                        &rest keys &key end &allow-other-keys)
  (declare (ignore keys))
  (multiple-value-bind (value index)
      (funcall parser string)
    (if (and (typep value type)
             (let ((end (or end (length string))))
               (or (i= index end)
                   (loop for i fixnum from index below end
                         as char = (char string i)
                         always (or (eql char #\space)
                                    (eql char #\tab)
                                    (eql char #\linefeed)
                                    (eql char #\return))))))
        value)))

;;; Fast, cons-free fixnum output

(defvar *unpadded-integer-strings*
  (let ((vector (make-array 10000)))
    (loop for i fixnum from 0 below 10000
          do (setf (svref vector i) (format nil "~D" i)))
    vector)
  "A 1000-element vector of the printed representation of each integer
   without any padding.")

(defvar *zero-padded-integer-strings-2*
  (apply #'vector (loop for i fixnum from 0 below 100
                        collecting (format nil "~2,'0D" i)))
  "A 100-element vector of the printed representation of each integer
   zero-padded to two characters.")

(defvar *zero-padded-integer-strings-4*
  (let ((vector (make-array 10000)))
    (loop for i fixnum from 0 below 10000
          do (setf (svref vector i) (format nil "~4,'0D" i)))
    vector)
  "A 10000-element vector of the printed representation of each integer
    zero-padded to two characters.")

(defun write-integer (integer stream &key width (padding #\space))

  "Write the integer to the stream.  If it's a fixnum and width
   is provided, pad it to that width with the padding character."

  (if (typep integer 'fixnum)
    (if width
      (write-padded-fixnum integer stream width padding)
      (or (write-unpadded-fixnum integer stream)
          (write integer :stream stream)))
    (write integer :stream stream)))

(defun write-unpadded-fixnum (fixnum stream)

  "Write the fixnum to the stream.  This is more efficient
   than using the regular Lisp printer."

  (let ((n-written 0))
    (when (i< fixnum 0)
      (when (i= fixnum most-negative-fixnum)
	(let ((s #.(format nil "~D" most-negative-fixnum)))
	  (write-string s stream)
	  (return-from write-unpadded-fixnum (length s))))
      (write-char #\- stream)
      (iincf n-written)
      (setf fixnum (i- fixnum)))
    (cond ((i< fixnum 10000)
	   (let ((s (svref *unpadded-integer-strings* fixnum)))
	     (write-string s stream)
	     (iincf n-written (length s))))
	  ((i< fixnum 100000000)
	   (let ((s (svref *unpadded-integer-strings* (ifloor fixnum 10000))))
	     (write-string s stream) (iincf n-written (length s)))
	   (let ((s (svref *zero-padded-integer-strings-4* (imod fixnum 10000))))
	     (write-string s stream) (iincf n-written (length s))))
          #.(if (typep 100000000000 'fixnum)
                ;; Only for 64-bit lisps
                '((i< fixnum 100000000000)
                  (let ((s (svref *unpadded-integer-strings* (ifloor fixnum 100000000))))
                    (write-string s stream) (iincf n-written (length s)))
                  (let ((s (svref *zero-padded-integer-strings-4* (imod (ifloor fixnum 10000) 10000))))
                    (write-string s stream) (iincf n-written (length s)))
                  (let ((s (svref *zero-padded-integer-strings-4* (imod fixnum 10000))))
                    (write-string s stream) (iincf n-written (length s))))
                '(nil nil))
          ;; Give up if it's this big ...
          (t
           (return-from write-unpadded-fixnum nil)))
    n-written))

(defun write-padded-fixnum (fixnum stream width pad-char)

  "Write the fixnum to the stream, with the given width and padding."

  (cond ((or (null width) (i< width 0))
	 (return-from write-padded-fixnum (write-unpadded-fixnum fixnum stream)))
	((i= width 0) 0)
	((i< fixnum 0)
	 (write-padded-fixnum-internal fixnum (i- fixnum) width stream pad-char))
	((i= fixnum 0)
	 (dotimes (i (i1- width))
	   (write-char pad-char stream))
	 (write-char #\0 stream)
	 (imax width 1))
	((and (i= width 2) (eql pad-char #\0))
	 (write-string (svref *zero-padded-integer-strings-2*
			      (if (i< fixnum 100) fixnum (imod fixnum 100)))
		       stream)
	 2)
	((and (i= width 4) (eql pad-char #\0))
	 (write-string (svref *zero-padded-integer-strings-4*
			      (if (i< fixnum 10000) fixnum (imod fixnum 10000)))
		       stream)
	 4)
	(t
	 (write-padded-fixnum-internal fixnum fixnum width stream pad-char))))

(defun write-padded-fixnum-internal (fixnum absolute-value width stream pad-char)
  (cond ((i= width 0) 0)
	((i> absolute-value 0)
	 (let ((n (write-padded-fixnum-internal fixnum (floor absolute-value 10)
						(1- width) stream pad-char)))
	   (write-char (code-char (i+ (char-code #\0) (mod absolute-value 10))) stream)
	   (i1+ n)))
	(t
	 (dotimes (i (i1- width))
	   (write-char pad-char stream))
	 (write-char (if (i< fixnum 0) #\- pad-char) stream)
	 (imax width 1))))


(defun pad-string-to-width (str width pad-char)

  "Pad the string on the left until it is as long as width.
   If it is already longer than that, signal an exception."

  (cond
    ((i> (length str) width) (error "Longer than limit already"))
    ((i= (length str) width) str)
    (t
     ;; apparently strings are immutable, so I couldn't do anything fancy with setf (aref
     (with-output-to-string (stream)
       (loop repeat (i- width (length str)) doing
	 (write-char pad-char stream))
       (write-string str stream)))))



(defun write-integer-to-string (integer &key width (padding #\space))

  "Convenience function for int to string conversion.
   Is actually a lot cheaper than prin1-to-string (1/3 the time and consing)"

  (with-output-to-string (stream)
    (write-integer integer stream :width width :padding padding)))

(defun integer-number-of-digits (i)

  "Return the number of digits in the printed representation
   of I, which must be a non-negative integer."

  (cond ((< i 10) 1)
        ((< i 100) 2)
        ((< i 1000) 3)
        ((< i 10000) 4)
        (t
         (do ((j i (floor j 10))
              (x 0 (1+ x)))
             ((< j 10000)
                (+ x 4))))))