Add debian source format

[umlisp.git] / class-support.lisp

diff --git a/class-support.lisp b/class-support.lisp
index e4f49cbcedeb36749d18008bfc56036fbd937dc7..7892abed792da14ea9dfcb75bcccce4e51593dbf 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -7,10 +7,8 @@
 ;;;; Author:   Kevin M. Rosenberg
 ;;;; Created:  Apr 2000
 ;;;;
-;;;; $Id$
-;;;;
 ;;;; This file, part of UMLisp, is
-;;;;    Copyright (c) 2000-2006 by Kevin M. Rosenberg, M.D.
+;;;;    Copyright (c) 2000-2010 by Kevin M. Rosenberg, M.D.
 ;;;;
 ;;;; UMLisp users are granted the rights to distribute and use this software
 ;;;; as governed by the terms of the GNU General Public License.
@@ -26,10 +24,14 @@
 
 (when *has-fixnum-class*
   (defmethod fmt-cui ((c fixnum))
-    (prefixed-fixnum-string c #\C 7)))
+    (if (>= c 10000000)
+        (prefixed-fixnum-string c #\C 8)
+      (prefixed-fixnum-string c #\C 7))))
 
 (defmethod fmt-cui ((c integer))
-    (prefixed-integer-string c #\C 7))
+  (if (>= c 10000000)
+      (prefixed-fixnum-string c #\C 8)
+    (prefixed-fixnum-string c #\C 7)))
 
 (defmethod fmt-cui ((c string))
   (if (eql (aref c 0) #\C)
@@ -45,10 +47,14 @@
 
 (when *has-fixnum-class*
   (defmethod fmt-lui ((l fixnum))
-    (prefixed-fixnum-string l #\L 7)))
+    (if (>= l 10000000)
+        (prefixed-fixnum-string l #\L 8)
+      (prefixed-fixnum-string l #\L 7))))
 
 (defmethod fmt-lui ((l integer))
-  (prefixed-integer-string l #\L 7))
+  (if (>= l 10000000)
+      (prefixed-fixnum-string l #\L 8)
+    (prefixed-fixnum-string l #\L 7)))
 
 (defmethod fmt-lui ((l string))
   (if (eql (aref l 0) #\L)
@@ -61,10 +67,14 @@
 
 (when *has-fixnum-class*
   (defmethod fmt-sui ((s fixnum))
-    (prefixed-fixnum-string s #\S 7)))
-
+    (if (>= s 10000000)
+        (prefixed-fixnum-string s #\S 8)
+      (prefixed-fixnum-string s #\S 7))))
+    
 (defmethod fmt-sui ((s integer))
-  (prefixed-integer-string s #\S 7))
+  (if (>= s 10000000)
+      (prefixed-fixnum-string s #\S 8)
+    (prefixed-fixnum-string s #\S 7)))
 
 (defmethod fmt-sui ((s string))
   (if (eql (aref s 0) #\S)
@@ -150,9 +160,9 @@
 
 (defun check-ui (ui start-char len)
   (when (and (stringp ui)
-            (= (length ui) (1+ len))
-            (char-equal start-char (schar ui 0))
-            (ignore-errors (parse-integer ui :start 1)))
+             (= (length ui) (1+ len))
+             (char-equal start-char (schar ui 0))
+             (ignore-errors (parse-integer ui :start 1)))
     t))
 
 
@@ -171,23 +181,23 @@
       (or (not is-term) is-english)))
 
 (defun print-umlsclass (obj &key (stream *standard-output*)
-                       (vid :compact-text)
-                       (file-wrapper nil) (english-only t) (subobjects nil)
-                       (refvars nil) (link-printer nil))
+                        (vid :compact-text)
+                        (file-wrapper nil) (english-only t) (subobjects nil)
+                        (refvars nil) (link-printer nil))
   (view obj :stream stream :vid vid :subobjects subobjects
-       :file-wrapper file-wrapper
-       :filter (if english-only nil #'english-term-filter)
-       :link-printer link-printer
-       :refvars refvars))
+        :file-wrapper file-wrapper
+        :filter (if english-only nil #'english-term-filter)
+        :link-printer link-printer
+        :refvars refvars))
 
 (defmacro define-lookup-display (newfuncname lookup-func)
   "Defines functions for looking up and displaying objects"
   `(defun ,newfuncname  (keyval &key (stream *standard-output*) (vid :compact-text)
-                        (file-wrapper t) (english-only nil) (subobjects nil))
+                         (file-wrapper t) (english-only nil) (subobjects nil))
      (let ((obj (funcall ,lookup-func keyval)))
        (print-umlsclass obj :stream stream :vid vid
-                       :file-wrapper file-wrapper :english-only english-only
-                       :subobjects subobjects)
+                        :file-wrapper file-wrapper :english-only english-only
+                        :subobjects subobjects)
        obj)))
 
 (define-lookup-display display-con #'find-ucon-cui)
@@ -214,14 +224,14 @@
 
 (defmethod mesh-number ((ustr ustr))
   (let ((codes
-        (map-and-remove-nils
-         (lambda (sat)
-           (when (and (string-equal "MSH" (sab sat))
-                      (string-equal "MN" (atn sat)))
-             (atv sat)))
-         (s#sat ustr))))
+         (map-and-remove-nils
+          (lambda (sat)
+            (when (and (string-equal "MSH" (sab sat))
+                       (string-equal "MN" (atn sat)))
+              (atv sat)))
+          (s#sat ustr))))
     (if (= 1 (length codes))
-       (car codes)
+        (car codes)
       codes)))
 
 (defun ucon-ustrs (ucon)
@@ -229,7 +239,7 @@
   (let (res)
     (dolist (term (s#term ucon) (nreverse res))
       (dolist (str (s#str term))
-       (push str res)))))
+        (push str res)))))
 
 
 (defmethod pfstr ((uterm uterm))
@@ -318,17 +328,17 @@
     (setq stt (subseq stt 1)))
   (loop for c across stt
       collect
-       (cond
-        ((char-equal #\C c)
-         "Upper/lower case")
-        ((char-equal #\W c)
-         "Word order")
-        ((char-equal #\S c)
-         "Singular")
-        ((char-equal #\P c)
-         "Plural")
-        ((char-equal #\O c)
-         "Other"))))
+        (cond
+         ((char-equal #\C c)
+          "Upper/lower case")
+         ((char-equal #\W c)
+          "Word order")
+         ((char-equal #\S c)
+          "Singular")
+         ((char-equal #\P c)
+          "Plural")
+         ((char-equal #\O c)
+          "Other"))))
 
 (defun uso-unique-codes (usos)
   (let ((sab-codes (make-hash-table :test 'equal)))