From 6c9ebe75d3d57a7ee031e8737a844f0eda63b741 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 15 May 2003 05:16:44 +0000 Subject: [PATCH] r4942: Auto commit for Debian build --- strings.lisp | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/strings.lisp b/strings.lisp index 937f670..a34ec58 100644 --- a/strings.lisp +++ b/strings.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: strings.lisp,v 1.27 2003/05/14 21:31:42 kevin Exp $ +;;;; $Id: strings.lisp,v 1.28 2003/05/15 05:16:06 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -255,22 +255,22 @@ list of characters and replacement strings." (write-string separator strm))))) (defun prefixed-fixnum-string (num pchar len) - "Outputs a string of LEN chars with the initial character being -PCHAR. Leading zeros are printed." + "Outputs a string of LEN digit with an optional initial character PCHAR. +Leading zeros are present." (declare (optimize (speed 3) (safety 0) (space 0)) - (type fixnum v len)) - (let ((zero-code (char-code #\0)) + (type fixnum num len)) + (when pchar + (incf len)) + (do* ((zero-code (char-code #\0)) (result (make-string len :initial-element #\0)) - (pos (1- len))) - (declare (fixnum zero-code pos) - (simple-string result)) - (do* ((val num (floor (/ val 10))) - (mod (nth-value 1 (floor val 10)) - (nth-value 1 (floor val 10)))) - ((or (zerop val) (minusp pos))) - (declare (fixnum val mod)) - (setf (schar result pos) (code-char (+ zero-code mod))) - (decf pos)) - (when pchar - (setf (schar result 0) pchar)) - result)) + (minus? (minusp num)) + (val (if minus? (- 0 num) num) (floor (/ val 10))) + (pos (1- len) (1- pos)) + (mod (mod val 10) (mod val 10))) + ((or (zerop val) (minusp pos)) + (when pchar + (setf (schar result 0) pchar)) + (when minus? (setf (schar result (if pchar 1 0)) #\-)) + result) + (declare (fixnum val mod zero-code pos) (simple-string result)) + (setf (schar result pos) (code-char (+ zero-code mod))))) -- 2.34.1