From 68c8a7d41640b4b26c0e088c752fb53703f3c548 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Tue, 5 Sep 2006 01:32:56 +0000
Subject: [PATCH] r11092: add clisp mop support; prefixed-number-string macro

---
 kmrcl.asd    |  2 +-
 mop.lisp     |  3 +++
 package.lisp |  1 +
 strings.lisp | 53 ++++++++++++++++++++++++++++++++--------------------
 tests.lisp   |  9 ++++++++-
 5 files changed, 46 insertions(+), 22 deletions(-)

diff --git a/kmrcl.asd b/kmrcl.asd
index a90e206..0fab1a0 100644
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -20,7 +20,7 @@
 (defpackage #:kmrcl-system (:use #:asdf #:cl))
 (in-package #:kmrcl-system)
 
-#+(or allegro cmu lispworks sbcl scl openmcl)
+#+(or allegro cmu clisp lispworks sbcl scl openmcl)
 (pushnew :kmr-mop cl:*features*)
 
 (defsystem kmrcl
diff --git a/mop.lisp b/mop.lisp
index 8decec5..f85912b 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -42,6 +42,7 @@
    #+kmr-cmucl-mop #:mop
    #+allegro #:mop
    #+lispworks #:clos
+   #+clisp #:clos
    #+scl #:clos
    #+openmcl #:openmcl-mop
    )
@@ -84,6 +85,8 @@
    '(excl::compute-effective-slot-definition-initargs)
    #+lispworks
    '(clos::compute-effective-slot-definition-initargs)
+   #+clisp
+   '(clos::compute-effective-slot-definition-initargs)
    #+sbcl
    '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of
      #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name
diff --git a/package.lisp b/package.lisp
index f4d42ff..a138169 100644
--- a/package.lisp
+++ b/package.lisp
@@ -49,6 +49,7 @@
    #:string-delimited-string-to-list
    #:list-to-delimited-string
    #:prefixed-fixnum-string
+   #:prefixed-integer-string
    #:integer-string
    #:fast-string-search
    #:string-substitute
diff --git a/strings.lisp b/strings.lisp
index d5bfa07..166c5fa 100644
--- a/strings.lisp
+++ b/strings.lisp
@@ -277,27 +277,40 @@ list of characters and replacement strings."
       (unless (and last-elem last-list)
 	(write-string separator strm)))))
 
-(defun prefixed-fixnum-string (num pchar len)
-  "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 num len))
-  (when pchar
-    (incf len))
-  (do* ((zero-code (char-code #\0))
-	(result (make-string len :initial-element #\0))
-	(minus? (minusp num))
-	(val (if minus? (- num) num)
-	     (nth-value 0 (floor val 10)))
-	(pos (1- len) (1- pos))
-	(mod (mod val 10) (mod val 10)))
-      ((or (zerop val) (minusp pos))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro def-prefixed-number-string (fn-name type &optional doc)
+    `(defun ,fn-name (num pchar len)
+       ,@(when (stringp doc) (list doc))
+       (declare (optimize (speed 3) (safety 0) (space 0))
+                (fixnum len)
+                (,type num))
        (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)))))
+         (incf len))
+       (do* ((zero-code (char-code #\0))
+           (result (make-string len :initial-element #\0))
+           (minus? (minusp num))
+           (val (if minus? (- num) num)
+                (nth-value 0 (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 (,type val) 
+                (fixnum mod zero-code pos)
+                (boolean minus?)
+                (simple-string result))
+       (setf (schar result pos) (code-char (the fixnum (+ zero-code mod))))))))
+
+(def-prefixed-number-string prefixed-fixnum-string fixnum
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be a fixnum.")
+
+(def-prefixed-number-string prefixed-integer-string integer
+ "Outputs a string of LEN digit with an optional initial character PCHAR.
+Leading zeros are present. LEN must be an integer.")
 
 (defun integer-string (num len)
   "Outputs a string of LEN digit with an optional initial character PCHAR.
diff --git a/tests.lisp b/tests.lisp
index d78aba3..b33befd 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -420,7 +420,14 @@
 (deftest :nwp.2
        (numbers-within-percentage 1. 1.1 11)
   t)
-  
+
+(deftest :pfs.1 (prefixed-fixnum-string 0 #\A 5) "A00000")
+
+(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001")
+
+(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021")
+	   
+(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")
 	   
  ;;; MOP Testing
 
-- 
2.34.1