projects
/
umlisp.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r10735:
[umlisp.git]
/
class-support.lisp
diff --git
a/class-support.lisp
b/class-support.lisp
index a085828956576010adfb476ebf66fd5a30da0af6..c14291d7607e9552f1a878a046e5bd95bb21ec19 100644
(file)
--- a/
class-support.lisp
+++ b/
class-support.lisp
@@
-2,15
+2,15
@@
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name:
classes-support.lisp
-;;;; Purpose:
Support for UMLisp classes
-;;;; Author:
Kevin M. Rosenberg
-;;;;
Date Started:
Apr 2000
+;;;; Name: classes-support.lisp
+;;;; Purpose: Support for UMLisp classes
+;;;; Author: Kevin M. Rosenberg
+;;;;
Created:
Apr 2000
;;;;
;;;;
-;;;; $Id
: class-support.lisp,v 1.19 2003/07/21 08:41:44 kevin Exp
$
+;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
;;;;
;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-200
3
by Kevin M. Rosenberg, M.D.
+;;;; Copyright (c) 2000-200
4
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.
;;;;
;;;; UMLisp users are granted the rights to distribute and use this software
;;;; as governed by the terms of the GNU General Public License.
@@
-18,7
+18,6
@@
(in-package #:umlisp)
(in-package #:umlisp)
-
;;; Formatting routines
(defgeneric fmt-cui (c))
;;; Formatting routines
(defgeneric fmt-cui (c))
@@
-67,7
+66,16
@@
(defmethod fmt-tui ((tui string))
(if (eql (aref tui 0) #\T)
tui
(defmethod fmt-tui ((tui string))
(if (eql (aref tui 0) #\T)
tui
- (fmt-tui (parse-integer tui))))
+ (fmt-tui (parse-integer tui))))
+
+(defgeneric fmt-aui (aui))
+(defmethod fmt-aui ((aui fixnum))
+ (prefixed-fixnum-string aui #\A 7))
+
+(defmethod fmt-aui ((aui string))
+ (if (eql (aref aui 0) #\A)
+ aui
+ (fmt-aui (parse-integer aui))))
(defgeneric fmt-eui (e))
(defmethod fmt-eui ((e fixnum))
(defgeneric fmt-eui (e))
(defmethod fmt-eui ((e fixnum))
@@
-170,11
+178,12
@@
(defmethod mesh-number ((ustr ustr))
(let ((codes
(defmethod mesh-number ((ustr ustr))
(let ((codes
- (filter (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)
codes)))
(if (= 1 (length codes))
(car codes)
codes)))
@@
-233,21
+242,23
@@
(defvar +language-abbreviations+
(defvar +language-abbreviations+
- '(("BAQ" . "Basque")
- ("DAN" . "Danish")
- ("DUT" . "Dutch")
- ("ENG" . "English")
- ("FIN" . "Finnish")
- ("FRE" . "French")
- ("GER" . "German")
- ("HEB" . "Hebrew")
- ("HUN" . "Hungarian")
- ("ITA" . "Italian")
- ("NOR" . "Norwegian")
- ("POR" . "Portuguese")
- ("RUS" . "Russian")
- ("SPA" . "Spanish")
- ("SWE" . "Swedish")))
+ '(("BAQ" . "Basque")
+ ("CZE" . "Chech")
+ ("DAN" . "Danish")
+ ("DUT" . "Dutch")
+ ("ENG" . "English")
+ ("FIN" . "Finnish")
+ ("FRE" . "French")
+ ("GER" . "German")
+ ("HEB" . "Hebrew")
+ ("HUN" . "Hungarian")
+ ("ITA" . "Italian")
+ ("JPN" . "Japanese")
+ ("NOR" . "Norwegian")
+ ("POR" . "Portuguese")
+ ("RUS" . "Russian")
+ ("SPA" . "Spanish")
+ ("SWE" . "Swedish")))
(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
(defvar *is-lat-table-init* nil)
(defvar *lat-info-table* (make-hash-table :size 30 :test 'equal))
(defvar *is-lat-table-init* nil)
@@
-258,7
+269,10
@@
(setq *is-lat-table-init* t))
(defun lat-abbr-info (lat)
(setq *is-lat-table-init* t))
(defun lat-abbr-info (lat)
- (nth-value 0 (gethash (string-downcase lat) *lat-info-table*)))
+ (aif (nth-value 0 (gethash (string-downcase lat) *lat-info-table*))
+ it
+ lat))
+
(defun stt-abbr-info (stt)
(defun stt-abbr-info (stt)
@@
-323,7
+337,7
@@
(let* ((anc-this-cxn (remove-if-not
(lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
(push
(let* ((anc-this-cxn (remove-if-not
(lambda (cxt) (= (1+ i) (cxn cxt))) anc)))
(push
- (sort anc-this-cxn (lambda (a b) (< (r
nk a) (r
nk b))))
+ (sort anc-this-cxn (lambda (a b) (< (r
ank a) (ra
nk b))))
anc-lists)))))
anc-lists)))))