--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; 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))))))
+
common-lisp.net / projects/qitab/quux-time.git / commitdiff
