;;;; 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.
(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)
(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)
(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)
(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))
(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)
(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)
(let (res)
(dolist (term (s#term ucon) (nreverse res))
(dolist (str (s#str term))
- (push str res)))))
+ (push str res)))))
(defmethod pfstr ((uterm uterm))
(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)))