Change default SQL server host

[umlisp.git] / class-support.lisp

diff --git a/class-support.lisp b/class-support.lisp
index 5de221198d17be93ccdf74e51607b4ad5861ee66..47463dd194610fb454fc6a7b5a37ff484bf58cb5 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)
@@ -273,8 +283,21 @@
 (defun rel-abbr-info (rel)
   (nth-value 0 (gethash (string-downcase rel) *rel-info-table*)))
 
-(defun filter-urels-by-rel (urels rel)
-  (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels))
+(defun filter-urels-by-rel (urels rel &key (remove-duplicate-pfstr2 t) (sort :pfstr2))
+  (let ((f (remove-if-not (lambda (urel) (string-equal rel (rel urel))) urels)))
+    (when remove-duplicate-pfstr2
+      (setq f (remove-duplicates f :test 'equal :key 'u::pfstr2)))
+    (if sort
+        (sort (copy-seq f) 'string-lessp :key 'u::pfstr2)
+        f)))
+
+#+mrcoc
+(defun filter-ucocs (ucocs &key (remove-duplicate-pfstr2 t) (sort :pfstr2))
+  (when remove-duplicate-pfstr2
+    (setq ucocs (remove-duplicates ucocs :test 'equal :key 'u::pfstr2)))
+    (if sort
+        (sort (copy-seq ucocs) 'string-lessp :key 'u::pfstr2)
+        ucocs))
 
 
 (defvar +language-abbreviations+
@@ -342,8 +365,8 @@
 
 
 #+scl
-(dolist (c '(urank udef usat uso ucxt ustr uterm usty urel ucoc uatx uconso uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
+(dolist (c '(urank udef usat uso ucxt ustr uterm usty urel
+             #+mrcoc ucoc
+             uatx uconso uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
     (let ((cl (find-class c)))
       (clos:finalize-inheritance cl)))
-
-