r11092: add clisp mop support; prefixed-number-string macro

diff --git a/kmrcl.asd b/kmrcl.asd
index a90e20690be985fdb7ab77b18eb4076d7cdc2ec9..0fab1a0f6f15f57dd5c3a01d339c114a47d1765a 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -20,7 +20,7 @@
 (defpackage #:kmrcl-system (:use #:asdf #:cl))
 (in-package #:kmrcl-system)
 
 (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
 (pushnew :kmr-mop cl:*features*)
 
 (defsystem kmrcl

diff --git a/mop.lisp b/mop.lisp
index 8decec559d7ec7330ac0e79202d4817b53da800c..f85912b88e7c97410544a356c054dbc03d5a0beb 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -42,6 +42,7 @@
    #+kmr-cmucl-mop #:mop
    #+allegro #:mop
    #+lispworks #:clos
    #+kmr-cmucl-mop #:mop
    #+allegro #:mop
    #+lispworks #:clos

+   #+clisp #:clos

    #+scl #:clos
    #+openmcl #:openmcl-mop
    )
    #+scl #:clos
    #+openmcl #:openmcl-mop
    )


@@ -84,6 +85,8 @@
    '(excl::compute-effective-slot-definition-initargs)
    #+lispworks
    '(clos::compute-effective-slot-definition-initargs)
    '(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
    #+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 f4d42ff5f4c21b1fbc334bc0502fb3fae0ce9b97..a1381690380df9d6f8d949f89d7b83c8ff67c329 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -49,6 +49,7 @@
    #:string-delimited-string-to-list
    #:list-to-delimited-string
    #:prefixed-fixnum-string
    #:string-delimited-string-to-list
    #:list-to-delimited-string
    #:prefixed-fixnum-string

+   #:prefixed-integer-string

    #:integer-string
    #:fast-string-search
    #:string-substitute
    #:integer-string
    #:fast-string-search
    #:string-substitute

diff --git a/strings.lisp b/strings.lisp
index d5bfa07a4b7c35e2baa47d3f513666c8d8dfe492..166c5fa28bec6e30ff68dd0083f8ab583f6bc8ec 100644 (file)
--- 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)))))
 
       (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
        (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.
 
 (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 d78aba3f890c5fbbe445f61e86bb075a73cae23f..b33befd2bb140d1a3fc51bd086e2eb48f9869c96 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -420,7 +420,14 @@
 (deftest :nwp.2
        (numbers-within-percentage 1. 1.1 11)
   t)
 (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
 
           
  ;;; MOP Testing