From: Kevin M. Rosenberg Date: Mon, 9 Dec 2002 14:11:09 +0000 (+0000) Subject: r3591: *** empty log message *** X-Git-Tag: v2006ac.2~282 X-Git-Url: http://git.kpe.io/?p=umlisp.git;a=commitdiff_plain;h=baef3e3eba503d04fe6d19ac3087bf9d3dbc37b9 r3591: *** empty log message *** --- diff --git a/classes.lisp b/classes.lisp index 7f88827..0ae8ad0 100644 --- a/classes.lisp +++ b/classes.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: classes.lisp,v 1.21 2002/12/05 19:12:05 kevin Exp $ +;;;; $Id: classes.lisp,v 1.22 2002/12/09 14:11:09 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -30,7 +30,7 @@ (srl :type fixnum :initarg :srl :reader srl)) (:metaclass hyperobject-class) (:default-initargs :sab nil :srl nil) - (:title "Source Restriction Level") + (:user-name "Source Restriction Level") (:print-slots sab srl) (:description "Custom Table: Source Restriction Level")) @@ -42,7 +42,7 @@ (supres :type string :initarg :supres :reader supres)) (:metaclass hyperobject-class) (:default-initargs :rank nil :sab nil :tty nil :supres nil) - (:title "Rank") + (:user-name "Rank") (:print-slots rank sab tty supres)) (defclass udef (umlsclass) @@ -50,7 +50,7 @@ (sab :type string :initarg :sab :reader sab :hyperlink find-usab-rsab)) (:metaclass hyperobject-class) (:default-initargs :def nil :sab nil) - (:title "Definition") + (:user-name "Definition") (:print-slots sab def)) (defclass usat (umlsclass) @@ -60,7 +60,7 @@ (atv :type cdata :initarg :atv :reader atv)) (:metaclass hyperobject-class) (:default-initargs :sab nil :code nil :atn nil :atv nil) - (:title "Simple Attribute") + (:user-name "Simple Attribute") (:print-slots sab code atn atv)) (defclass usab (umlsclass) @@ -93,7 +93,7 @@ :slc nil :scc nil :srl nil :tfr nil :cfr nil :cxty nil :ttyl nil :atnl nil :lat nil :cenc nil :curver nil :sabin nil) - (:title "Source Abbreviation") + (:user-name "Source Abbreviation") (:print-slots vcui rcui vsab rsab son sf sver mstart mend imeta rmeta slc scc srl tfr cfr cxty ttyl atnl lat cenc curver sabin)) @@ -105,7 +105,7 @@ (srl :type fixnum :initarg :srl :reader srl)) (:metaclass hyperobject-class) (:default-initargs :sab nil :code nil :tty nil :srl nil) - (:title "Source") + (:user-name "Source") (:print-slots sab code tty srl)) (defclass ucxt (umlsclass) @@ -123,7 +123,7 @@ (:metaclass hyperobject-class) (:default-initargs :sab nil :code nil :rnk nil :cxn nil :cxl nil :cxs nil :cui2 nil :hcd nil :rela nil :xc nil) - (:title "Context") + (:user-name "Context") (:print-slots sab code rnk cxn cxl hcd rela xc cui2 cxs)) (defclass ustr (umlsclass) @@ -137,13 +137,13 @@ (str :type cdata :initarg :str :reader str) (lrl :type fixnum :initarg :lrl :reader lrl) (stt :type string :initarg :stt :reader stt) - (s#sat :reader s#sat :subobject t) - (s#so :reader s#so :subobject t) - (s#cxt :reader s#cxt :subobject t)) + (s#sat :reader s#sat :subobject (find-usat-ui cui lui sui)) + (s#so :reader s#so :subobject (find-uso-cuisui cui sui)) + (s#cxt :reader s#cxt :subobject (find-ucxt-cuisui cui sui))) (:metaclass hyperobject-class) (:default-initargs :sui nil :cui nil :lui nil :cuisui nil :str nil :lrl nil :stt nil) - (:title "String") + (:user-name "String") (:print-slots sui stt lrl str)) (defclass ulo (umlsclass) @@ -155,7 +155,7 @@ (soui :type string :initarg :soui :reader soui)) (:metaclass hyperobject-class) (:default-initargs :isn nil :fr nil :un nil :sui nil :sna nil :soui nil) - (:title "Locator") + (:user-name "Locator") (:print-slots isn fr un sna soui sui)) (defclass uterm (umlsclass) @@ -166,11 +166,11 @@ (lat :type string :initarg :lat :reader lat) (ts :type string :initarg :ts :reader ts) (lrl :type fixnum :initarg :lrl :reader lrl) - (s#str :reader s#str :subobject t) - (s#sat :reader s#sat :subobject t)) + (s#str :reader s#str :subobject (find-ustr-cuilui cui lui)) + (s#sat :reader s#sat :subobject (find-usat-ui cui lui))) (:metaclass hyperobject-class) (:default-initargs :lui nil :cui nil :lat nil :ts nil :lrl nil) - (:title "Term") + (:user-name "Term") (:print-slots lui lat ts lrl)) (defclass usty (umlsclass) @@ -179,7 +179,7 @@ (sty :type string :initarg :sty :reader sty)) (:metaclass hyperobject-class) (:default-initargs :tui nil :sty nil) - (:title "Semantic Type") + (:user-name "Semantic Type") (:print-slots tui sty)) (defclass urel (umlsclass) @@ -195,7 +195,7 @@ (:metaclass hyperobject-class) (:default-initargs :rel nil :cui1 nil :cui2 nil :pfstr2 nil :rela nil :sab nil :sl nil :mg nil) - (:title "Relationship") + (:user-name "Relationship") (:print-slots rel rela sab sl mg cui2 pfstr2)) (defclass ucoc (umlsclass) @@ -210,7 +210,7 @@ (:metaclass hyperobject-class) (:default-initargs :cui1 nil :cui2 nil :pfstr2 nil :soc nil :cot nil :cof nil :coa nil) - (:title "Co-occuring Concept") + (:user-name "Co-occuring Concept") (:print-slots soc cot cof coa cui2 pfstr2)) @@ -220,7 +220,7 @@ (atx :type cdata :initarg :atx :reader atx)) (:metaclass hyperobject-class) (:default-initargs :sab nil :rel nil :atx nil) - (:title "Associated Expression") + (:user-name "Associated Expression") (:print-slots sab rel atx)) (defclass ucon (umlsclass) @@ -228,17 +228,17 @@ :hyperlink find-ucon-cui) (pfstr :type cdata :initarg :pfstr :reader pfstr) (lrl :type fixnum :initarg :lrl :reader lrl) - (s#term :reader s#term :subobject t) - (s#def :reader s#def :subobject t) - (s#lo :reader s#lo :subobject t) - (s#rel :reader s#rel :subobject t) - (s#coc :reader s#coc :subobject t) - (s#sat :reader s#sat :subobject t) - (s#atx :reader s#atx :subobject t) - (s#sty :reader s#sty :subobject t)) + (s#term :reader s#term :subobject (find-uterm-cui cui)) + (s#def :reader s#def :subobject (find-udef-cui cui)) + (s#lo :reader s#lo :subobject (find-ulo-cui cui)) + (s#rel :reader s#rel :subobject (find-urel-cui cui)) + (s#coc :reader s#coc :subobject (find-ucoc-cui cui)) + (s#sat :reader s#sat :subobject (find-usat-ui cui)) + (s#atx :reader s#atx :subobject (find-uatx-cui cui)) + (s#sty :reader s#sty :subobject (find-usty-cui cui))) (:metaclass hyperobject-class) (:default-initargs :cui nil :pfstr nil :lrl nil) - (:title "Concept") + (:user-name "Concept") (:print-slots cui lrl pfstr)) (defclass uxw (umlsclass) @@ -248,7 +248,7 @@ (sui :type fixnum :initform nil :initarg :sui :reader sui :print-formatter fmt-sui)) (:metaclass hyperobject-class) (:default-initargs :wd nil :cui nil :lui nil :sui nil) - (:title "XW Index") + (:user-name "XW Index") (:print-slots wd cui lui sui)) (defclass uxnw (umlsclass) @@ -257,7 +257,7 @@ (cuilist :type list :initarg :cuilist :reader uxnw-cuilist)) (:metaclass hyperobject-class) (:default-initargs :lat nil :nwd nil :cuilist nil) - (:title "XNW Index") + (:user-name "XNW Index") (:print-slots lat nwd cuilist)) (defclass uxns (umlsclass) @@ -266,7 +266,7 @@ (cuilist :type list :initarg :cuilist :reader cuilist)) (:metaclass hyperobject-class) (:default-initargs :lat nil :nstr nil :cuilist nil) - (:title "XNS Index") + (:user-name "XNS Index") (:print-slots lat nstr cuilist)) @@ -276,19 +276,19 @@ ((eui :type fixnum :initarg :eui :reader eui :print-formatter fmt-eui :hyperlink find-lexterm-eui) (wrd :type string :initarg :wrd :reader wrd) - (s#abr :reader s#abr :subobject t) - (s#agr :reader s#agr :subobject t) - (s#cmp :reader s#cmp :subobject t) - (s#mod :reader s#mod :subobject t) - (s#nom :reader s#nom :subobject t) - (s#prn :reader s#prn :subobject t) - (s#prp :reader s#prp :subobject t) - (s#spl :reader s#spl :subobject t) - (s#trm :reader s#trm :subobject t) - (s#typ :reader s#typ :subobject t)) + (s#abr :reader s#abr :subobject (find-labr-eui eui)) + (s#agr :reader s#agr :subobject (find-lagr-eui eui)) + (s#cmp :reader s#cmp :subobject (find-lcmp-eui eui)) + (s#mod :reader s#mod :subobject (find-lmod-eui eui)) + (s#nom :reader s#nom :subobject (find-lnom-eui eui)) + (s#prn :reader s#prn :subobject (find-lprn-eui eui)) + (s#prp :reader s#prp :subobject (find-lprp-eui eui)) + (s#spl :reader s#spl :subobject (find-lspl-eui eui)) + (s#trm :reader s#trm :subobject (find-ltrm-eui eui)) + (s#typ :reader s#typ :subobject (find-ltyp-eui eui))) (:metaclass hyperobject-class) (:default-initargs :eui nil :wrd nil) - (:title "Lexical Term") + (:user-name "Lexical Term") (:print-slots eui wrd)) @@ -300,7 +300,7 @@ (bas2 :type string :initarg :bas2 :reader bas2)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :abr nil :eui2 nil :bas2 nil) - (:title "Abbreviations and Acronyms") + (:user-name "Abbreviations and Acronyms") (:print-slots eui bas abr eui2 bas2)) (defclass lagr (umlsclass) @@ -312,7 +312,7 @@ (bas :type string :initarg :bas :reader bas)) (:metaclass hyperobject-class) (:default-initargs :eui nil :str nil :sca nil :agr nil :cit nil :bas nil) - (:title "Agreement and Inflection") + (:user-name "Agreement and Inflection") (:print-slots eui str sca agr cit bas)) (defclass lcmp (umlsclass) @@ -322,7 +322,7 @@ (com :type string :initarg :com :reader com)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :sca nil :com nil) - (:title "Complementation") + (:user-name "Complementation") (:print-slots eui bas sca com)) (defclass lmod (umlsclass) @@ -333,7 +333,7 @@ (fea :type string :initarg :fea :reader fea)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :sca nil :psnmod nil :fea nil) - (:title "Modifiers") + (:user-name "Modifiers") (:print-slots eui bas sca psnmod fea)) (defclass lnom (umlsclass) @@ -345,7 +345,7 @@ (sca2 :type string :initarg :sca2 :reader sca2)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :sca nil :eui2 nil :bas2 nil :sca2 nil) - (:title "Nominalizations") + (:user-name "Nominalizations") (:print-slots eui bas sca eui2 bas2 sca2)) (defclass lprn (umlsclass) @@ -360,7 +360,7 @@ (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :num nil :gnd nil :cas nil :pos nil :qnt nil :fea nil) - (:title "Pronouns") + (:user-name "Pronouns") (:print-slots eui bas num gnd cas pos qnt fea)) (defclass lprp (umlsclass) @@ -371,7 +371,7 @@ (fea :type string :initarg :fea :reader fea)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :str nil :sca nil :fea nil) - (:title "Properties") + (:user-name "Properties") (:print-slots eui bas str sca fea)) @@ -381,7 +381,7 @@ (bas :type string :initarg :bas :reader bas)) (:metaclass hyperobject-class) (:default-initargs :eui nil :spv nil :bas nil) - (:title "Spelling Variants") + (:user-name "Spelling Variants") (:print-slots eui spv bas)) @@ -391,7 +391,7 @@ (gen :type string :initarg :gen :reader gen)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :gen nil) - (:title "Trade Marks") + (:user-name "Trade Marks") (:print-slots eui bas gen)) (defclass ltyp (umlsclass) @@ -401,7 +401,7 @@ (typ :type string :initarg :typ :reader typ)) (:metaclass hyperobject-class) (:default-initargs :eui nil :bas nil :sca nil :typ nil) - (:title "Inflection Type") + (:user-name "Inflection Type") (:print-slots eui bas sca typ)) (defclass lwd (umlsclass) @@ -409,7 +409,7 @@ (euilist :type list :initarg :euilist :reader euilist)) (:metaclass hyperobject-class) (:default-initargs :wrd nil :euilist nil) - (:title "Lexical Word Index") + (:user-name "Lexical Word Index") (:print-slots wrd euilist)) ;;; Semantic NET objects @@ -429,7 +429,7 @@ (:default-initargs :rt nil :ui nil :styrl nil :stnrtn nil :def nil :ex nil :un nil :rh nil :abr nil :rin nil) - (:title "Basic information about Semantic Types and Relations") + (:user-name "Basic information about Semantic Types and Relations") (:print-slots rt ui styrl stnrtn def ex un rh abr rin)) (defclass sstr (umlsclass) @@ -439,7 +439,7 @@ (ls :type string :initarg :ls :reader ls)) (:metaclass hyperobject-class) (:default-initargs :styrl nil :rl nil :styrl2 nil :ls nil) - (:title "Structure of the Network") + (:user-name "Structure of the Network") (:print-slots styrl rl styrl2 ls)) (defclass sstre1 (umlsclass) @@ -448,7 +448,7 @@ (ui3 :type integer :initarg :ui3 :reader ui3 :print-formatter fmt-tui)) (:metaclass hyperobject-class) (:default-initargs :ui nil :ui2 nil :ui3 nil) - (:title "Fully Inherited Set of Releatons (TUI's)") + (:user-name "Fully Inherited Set of Releatons (TUI's)") (:print-slots ui ui2 ui3)) (defclass sstre2 (umlsclass) @@ -457,7 +457,7 @@ (sty2 :type string :initarg :ui3 :reader sty2)) (:metaclass hyperobject-class) (:default-initargs :sty nil :rl nil :sty2 nil) - (:title "Fully Inherited Set of Releatons (strings)") + (:user-name "Fully Inherited Set of Releatons (strings)") (:print-slots sty rl sty2)) ;;; Formatting routines diff --git a/composite.lisp b/composite.lisp index ee07f27..c9f8dc0 100644 --- a/composite.lisp +++ b/composite.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: composite.lisp,v 1.16 2002/11/25 07:45:36 kevin Exp $ +;;;; $Id: composite.lisp,v 1.17 2002/12/09 14:11:09 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -69,28 +69,28 @@ ((freq :type integer :initarg :freq :accessor freq :print-formatter fmt-comma-integer)) (:metaclass hyperobject-class) (:default-initargs :freq 0) - (:title "Frequency class") + (:user-name "Frequency class") (:print-slots freq) (:description "Base class containing frequency slot, used for multi-inherited objects")) (defclass ucon_freq (ucon freq) () (:metaclass hyperobject-class) - (:title "Concept and Count") + (:user-name "Concept and Count") (:print-slots cui freq pfstr) (:description "Composite object of ucon/freq")) (defclass ustr_freq (ustr freq) () (:metaclass hyperobject-class) - (:title "String and Count") + (:user-name "String and Count") (:print-slots sui freq stt lrl str) (:description "Composite object of ustr/freq")) (defclass usty_freq (usty freq) ((freq :type fixnum :initarg :freq :accessor freq)) (:metaclass hyperobject-class) - (:title "Semantic Type and Count") + (:user-name "Semantic Type and Count") (:print-slots tui freq sty) (:description "Composite object of usty/freq")) @@ -108,7 +108,7 @@ (defclass usrl_freq (usrl freq) () (:metaclass hyperobject-class) - (:title "Source and Count") + (:user-name "Source and Count") (:print-slots sab freq srl) (:description "Composite object of usrl/freq")) diff --git a/package.lisp b/package.lisp index 01e809d..9b1120c 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.13 2002/12/03 01:02:46 kevin Exp $ +;;;; $Id: package.lisp,v 1.14 2002/12/09 14:11:09 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -35,6 +35,8 @@ ;; From sql.lisp #:umls-sql-user! #:umls-sql-passwd! + #:umls-sql-db! + #:umls-sql-host! #:with-sql-connection #:mutex-sql-execute #:mutex-sql-query diff --git a/sql-classes.lisp b/sql-classes.lisp index 6cd2c46..b163e0b 100644 --- a/sql-classes.lisp +++ b/sql-classes.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql-classes.lisp,v 1.10 2002/11/12 18:05:00 kevin Exp $ +;;;; $Id: sql-classes.lisp,v 1.11 2002/12/09 14:11:09 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -26,44 +26,6 @@ (defun current-srl! (srl) (setq *current-srl* srl)) - -;;; Accessors (read on demand) - -;; defines a slot-unbound method for class and slot-name, fills -;; the slot by calling reader function with the slot values of -;; the instance's reader-keys -(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) - (let* ((the-slot-name (gensym)) - (the-class (gensym)) - (the-instance (gensym)) - (keys '())) - (dolist (key reader-keys) - (push (list 'slot-value the-instance (list 'quote key)) keys)) - (setq keys (nreverse keys)) - `(defmethod slot-unbound (,the-class (,the-instance ,class) - (,the-slot-name (eql ',slot-name))) - (declare (ignore ,the-class)) - (setf (slot-value ,the-instance ,the-slot-name) - (,reader ,@keys))))) - -(def-lazy-reader ucon s#term find-uterm-cui cui) -(def-lazy-reader ucon s#def find-udef-cui cui) -(def-lazy-reader ucon s#sty find-usty-cui cui) -(def-lazy-reader ucon s#rel find-urel-cui cui) -(def-lazy-reader ucon s#coc find-ucoc-cui cui) -(def-lazy-reader ucon s#lo find-ulo-cui cui) -(def-lazy-reader ucon s#atx find-uatx-cui cui) -(def-lazy-reader ucon s#sat find-usat-ui cui) - -;; For uterms -(def-lazy-reader uterm s#str find-ustr-cuilui cui lui) -(def-lazy-reader uterm s#sat find-usat-ui cui lui) - -;; For ustrs -(def-lazy-reader ustr s#sat find-usat-ui cui lui sui) -(def-lazy-reader ustr s#cxt find-ucxt-cuisui cui sui) -(def-lazy-reader ustr s#so find-uso-cuisui cui sui) - ;;; Object lookups ;;; Lookup functions for uterms,ustr in ucons @@ -102,70 +64,66 @@ (defun find-ucon-lui (lui &key (srl *current-srl*)) "Find list of ucon for lui" - (if (stringp lui) - (setq lui (parse-lui lui))) - (if lui + (when (stringp lui) (setq lui (parse-lui lui))) + (when lui (let ((ucons '()) (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where LUI=~d" lui))) (if srl (string-append ls (format nil " and KCUILRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) - ucons)) - (nreverse ucons)) - nil)) + (destructuring-bind (cui pfstr lrl) tuple + (push (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer lrl)) + ucons))) + (nreverse ucons)))) (defun find-ucon-sui (sui &key (srl *current-srl*)) "Find list of ucon for sui" - (if (stringp sui) - (setq sui (parse-sui sui))) - (if sui - (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (let ((tuples (mutex-sql-query ls))) - (dolist (tuple tuples) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) - ucons))) - (nreverse ucons)) - nil)) + (when (stringp sui) (setq sui (parse-sui sui))) + (when sui + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where SUI=~d" sui))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (let ((tuples (mutex-sql-query ls))) + (dolist (tuple tuples) + (destructuring-bind (cui pfstr lrl) tuple + (push (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer lrl)) + ucons)))) + (nreverse ucons)))) (defun find-ucon-cuisui (cui sui &key (srl *current-srl*)) "Find ucon for cui/sui" - (if (stringp cui) - (setq cui (parse-cui cui))) - (if (stringp sui) - (setq sui (parse-sui sui))) - (if (and cui sui) - (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" - (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and KCUILRL <= ~d" srl))) - (kmrcl:aif (car (mutex-sql-query ls)) - (make-instance 'ucon :cui (ensure-integer (nth 0 kmrcl::it)) - :pfstr (nth 1 kmrcl::it) - :lrl (ensure-integer (nth 2 kmrcl::it))) - nil)) - nil)) + (when (stringp cui) (setq cui (parse-cui cui))) + (when (stringp sui) (setq sui (parse-sui sui))) + (when (and cui sui) + (let ((ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where KCUISUI=~d" + (make-cuisui cui sui)))) + (when srl + (string-append ls (format nil " and KCUILRL <= ~d" srl))) + (awhen (car (mutex-sql-query ls)) + (destructuring-bind (cui pfstr lrl) it + (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer lrl))))))) (defun find-ucon-str (str &key (srl *current-srl*)) "Find ucon that are exact match for str" - (if str - (let ((ucons '()) - (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) - (when srl - (string-append ls " and KCUILRL <= ~d" srl)) - (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucon :cui (ensure-integer (nth 0 tuple)) - :pfstr (nth 1 tuple) - :lrl (ensure-integer (nth 2 tuple))) ucons)) - (nreverse ucons)) - nil)) + (when str + (let ((ucons '()) + (ls (format nil "select distinct CUI,KPFSTR,KCUILRL from MRCON where STR='~a'" str))) + (when srl + (string-append ls " and KCUILRL <= ~d" srl)) + (dolist (tuple (mutex-sql-query ls)) + (destructuring-bind (cui pfstr lrl) tuple + (push (make-instance 'ucon :cui (ensure-integer cui) + :pfstr pfstr + :lrl (ensure-integer lrl)) + ucons))) + (nreverse ucons)))) (defun find-ucon-all (&key (srl *current-srl*)) "Return list of all ucon's" @@ -208,7 +166,8 @@ (when srl (string-append ls (format nil " and KSRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'udef :sab (car tuple) :def (cadr tuple)) udefs)) + (destructuring-bind (sab def) tuple + (push (make-instance 'udef :sab sab :def def) udefs))) (nreverse udefs))) (defun find-usty-cui (cui &key (srl *current-srl*)) @@ -218,7 +177,8 @@ (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + (destructuring-bind (tui sty) tuple + (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys))) ustys)) (defun find-usty-word (word &key (srl *current-srl*)) @@ -228,7 +188,8 @@ (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usty :tui (ensure-integer (car tuple)) :sty (cadr tuple)) ustys)) + (destructuring-bind (tui sty) tuple + (push (make-instance 'usty :tui (ensure-integer tui) :sty sty) ustys))) ustys)) (defun find-urel-cui (cui &key (srl *current-srl*)) @@ -238,16 +199,17 @@ (when srl (string-append ls (format nil " and KSRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'urel - :cui1 cui - :rel (nth 0 tuple) - :cui2 (ensure-integer (nth 1 tuple)) - :rela (nth 2 tuple) - :sab (nth 3 tuple) - :sl (nth 4 tuple) - :mg (nth 5 tuple) - :pfstr2 (nth 6 tuple)) - urels)) + (destructuring-bind (rel cui2 rela sab sl mg pfstr2) tuple + (push (make-instance 'urel + :cui1 cui + :rel rel + :cui2 (ensure-integer cui2) + :rela rela + :sab sab + :sl sl + :mg mg + :pfstr2 pfstr2) + urels))) (nreverse urels))) (defun find-urel-cui2 (cui2 &key (srl *current-srl*)) @@ -257,16 +219,17 @@ (when srl (string-append ls (format nil " and SRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'urel - :cui2 cui2 - :rel (nth 0 tuple) - :cui1 (ensure-integer (nth 1 tuple)) - :rela (nth 2 tuple) - :sab (nth 3 tuple) - :sl (nth 4 tuple) - :mg (nth 5 tuple) - :pfstr2 (nth 6 tuple)) - urels)) + (destructuring-bind (rel cui1 rela sab sl mg pfstr2) tuple + (push (make-instance 'urel + :cui2 cui2 + :rel rel + :cui1 (ensure-integer cui1) + :rela rela + :sab sab + :sl sl + :mg mg + :pfstr2 pfstr2) + urels))) (nreverse urels))) (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*)) @@ -282,16 +245,16 @@ (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by COF asc") (dolist (tuple (mutex-sql-query ls)) - (let ((cui2 (ensure-integer (nth 0 tuple)))) - (when (zerop cui2) - (setq cui2 nil)) + (destructuring-bind (cui2 soc cot cof coa pfstr2) tuple + (setq cui2 (ensure-integer cui2)) + (when (zerop cui2) (setq cui2 nil)) (push (make-instance 'ucoc :cui1 cui :cui2 cui2 - :soc (nth 1 tuple) - :cot (nth 2 tuple) - :cof (ensure-integer (nth 3 tuple)) - :coa (nth 4 tuple) - :pfstr2 (nth 5 tuple)) + :soc soc + :cot cot + :cof (ensure-integer cof) + :coa coa + :pfstr2 pfstr2) ucocs))) ucocs)) ;; akready ordered by SQL select @@ -303,14 +266,15 @@ (string-append ls (format nil " and KSRL <= ~d" srl))) (string-append ls " order by COF asc") (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucoc :cui1 (ensure-integer (nth 0 tuple)) - :cui2 cui2 - :soc (nth 1 tuple) - :cot (nth 2 tuple) - :cof (ensure-integer (nth 3 tuple)) - :coa (nth 4 tuple) - :pfstr2 (nth 5 tuple)) - ucocs)) + (destructuring-bind (cui1 soc cot cof coa pfstr2) tuple + (push (make-instance 'ucoc :cui1 (ensure-integer cui1) + :cui2 cui2 + :soc soc + :cot cot + :cof (ensure-integer cof) + :coa coa + :pfstr2 pfstr2) + ucocs))) ucocs)) ;; already ordered by SQL select (defun find-ucon-coc-cui2 (cui2 &key (srl *current-srl*)) @@ -326,13 +290,14 @@ (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ulo :isn (nth 0 tuple) - :fr (ensure-integer (nth 1 tuple)) - :un (nth 2 tuple) - :sui (ensure-integer (nth 3 tuple)) - :sna (nth 4 tuple) - :soui (nth 5 tuple)) - ulos)) + (destructuring-bind (isn fr un sui sna soui) tuple + (push (make-instance 'ulo :isn isn + :fr (ensure-integer fr) + :un un + :sui (ensure-integer sui) + :sna sna + :soui soui) + ulos))) (nreverse ulos))) (defgeneric suistr (lo)) @@ -347,10 +312,8 @@ (when srl (string-append ls (format nil " and KSRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uatx :sab (nth 0 tuple) - :rel (nth 1 tuple) - :atx (nth 2 tuple)) - uatxs)) + (destructuring-bind (sab rel atx) tuple + (push (make-instance 'uatx :sab sab :rel rel :atx atx) uatxs))) (nreverse uatxs))) @@ -361,12 +324,10 @@ (when srl (string-append ls (format nil " and KLUILRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uterm :lui (ensure-integer (nth 0 tuple)) - :cui cui - :lat (nth 1 tuple) - :ts (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))) - uterms)) + (destructuring-bind (lui lat ts lrl) tuple + (push (make-instance 'uterm :lui (ensure-integer lui) :cui cui + :lat lat :ts ts :lrl (ensure-integer lrl)) + uterms))) (nreverse uterms))) (defun find-uterm-lui (lui &key (srl *current-srl*)) @@ -378,61 +339,47 @@ (when srl (string-append ls (format nil " and KLUILRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uterm :cui (ensure-integer (nth 0 tuple)) - :lui lui - :lat (nth 1 tuple) - :ts (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))) - uterms)) + (destructuring-bind (cui lat ts lrl) tuple + (push (make-instance 'uterm :cui (ensure-integer cui) :lui lui + :lat lat :ts ts :lrl (ensure-integer lrl)) + uterms))) (nreverse uterms))) (defun find-uterm-cuilui (cui lui &key (srl *current-srl*)) "Return single uterm for cui/lui" (let ((ls (format nil "select LAT,TS,KLUILRL from MRCON where KCUILUI=~d limit 1" (make-cuilui cui lui)))) - (when srl - (string-append ls (format nil " and KLUILRL <= ~d" srl))) - (kmrcl:aif (car (mutex-sql-query ls)) - (make-instance 'uterm :cui cui - :lui lui - :lat (nth 0 kmrcl::it) - :ts (nth 1 kmrcl::it) - :lrl (ensure-integer (nth 2 kmrcl::it))) - nil))) + (when srl (string-append ls (format nil " and KLUILRL <= ~d" srl))) + (awhen (car (mutex-sql-query ls)) + (destructuring-bind (lat ts lrl) it + (make-instance 'uterm :cui cui :lui lui :lat lat :ts ts + :lrl (ensure-integer lrl)))))) (defun find-ustr-cuilui (cui lui &key (srl *current-srl*)) "Return a list of ustr for cui/lui" (declare (fixnum cui lui)) (let ((ustrs '()) (ls (format nil "select SUI,STT,STR,LRL from MRCON where KCUILUI=~d" (make-cuilui cui lui)))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) + (when srl (string-append ls (format nil " and LRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (let* ((sui (ensure-integer (car tuple))) - (ustr (make-instance 'ustr :sui sui - :cui cui - :cuisui (make-cuisui cui sui) - :lui lui - :stt (nth 1 tuple) - :str (nth 2 tuple) - :lrl (ensure-integer (nth 3 tuple))))) - (push ustr ustrs))) + (destructuring-bind (sui stt str lrl) tuple + (push + (make-instance 'ustr :sui (ensure-integer sui) :cui cui :lui lui + :cuisui (make-cuisui cui sui) :stt stt :str str + :lrl (ensure-integer lrl)) + ustrs))) (nreverse ustrs))) (defun find-ustr-cuisui (cui sui &key (srl *current-srl*)) "Return the single ustr for cuisui" (let ((ls (format nil "select LUI,STT,STR,LRL from MRCON where KCUISUI=~d" (make-cuisui cui sui)))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) - (kmrcl:aif (car (mutex-sql-query ls)) - (make-instance 'ustr :sui sui - :cui cui - :cuisui (make-cuisui cui sui) - :lui (ensure-integer (nth 0 kmrcl::it)) - :stt (nth 1 kmrcl::it) - :str (nth 2 kmrcl::it) - :lrl (ensure-integer (nth 3 kmrcl::it))) - nil))) + (when srl (string-append ls (format nil " and LRL <= ~d" srl))) + (awhen (car (mutex-sql-query ls)) + (destructuring-bind (lui stt str lrl) it + (make-instance 'ustr :sui sui :cui cui + :cuisui (make-cuisui cui sui) + :lui (ensure-integer lui) :stt stt :str str + :lrl (ensure-integer lrl)))))) (defun find-ustr-sui (sui &key (srl *current-srl*)) "Return the list of ustr for sui" @@ -440,18 +387,15 @@ (setq sui (parse-sui sui))) (let ((ustrs '()) (ls (format nil "select CUI,LUI,STT,STR,LRL from MRCON where SUI=~d" sui))) - (when srl - (string-append ls (format nil " and LRL <= ~d" srl))) + (when srl (string-append ls (format nil " and LRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (let ((cui (ensure-integer (car tuple)))) - (push (make-instance 'ustr :sui sui - :cui cui + (destructuring-bind (cui lui stt str lrl) tuple + (setq cui (ensure-integer cui)) + (push (make-instance 'ustr :sui sui :cui cui :stt stt :str str :cuisui (make-cuisui cui sui) - :lui (ensure-integer (nth 1 tuple)) - :stt (nth 2 tuple) - :str (nth 3 tuple) - :lrl (ensure-integer (nth 4 tuple))) - ustrs))) + :lui (ensure-integer lui) + :lrl (ensure-integer lrl)) + ustrs))) (nreverse ustrs))) (defun find-ustr-sab (sab &key (srl *current-srl*)) @@ -509,9 +453,9 @@ (when srl (string-append ls (format nil " and SRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'uso :sab (nth 0 tuple) :code (nth 1 tuple) - :srl (nth 2 tuple) :tty (nth 3 tuple)) - usos)) + (destructuring-bind (sab code srl tty) tuple + (push (make-instance 'uso :sab sab :code code :srl srl :tty tty) + usos))) (nreverse usos))) (defun find-ucxt-cuisui (cui sui &key (srl *current-srl*)) @@ -522,17 +466,14 @@ (when srl (string-append ls (format nil " and KSRL <= ~d" srl))) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'ucxt :sab (nth 0 tuple) - :code (nth 1 tuple) - :cxn (ensure-integer (nth 2 tuple)) - :cxl (nth 3 tuple) - :rnk (ensure-integer (nth 4 tuple)) - :cxs (nth 5 tuple) - :cui2 (ensure-integer (nth 6 tuple)) - :hcd (nth 7 tuple) - :rela (nth 8 tuple) - :xc (nth 9 tuple)) - ucxts)) + (destructuring-bind (sab code cxn cxl rnk cxs cui2 hcd rela xc) tuple + (push (make-instance 'ucxt :sab sab :code + :cxn (ensure-integer cxn) + :cxl cxl :cxs cxs :hcd hcd :rela rela :xc xc + :code code + :rnk (ensure-integer rnk) + :cui2 (ensure-integer cui2)) + ucxts))) (nreverse ucxts))) (defun find-usat-ui (cui &optional (lui nil) (sui nil) &key (srl *current-srl*)) @@ -545,11 +486,9 @@ (string-append ls (format nil " and KSRL <= ~d" srl))) (let ((usats '())) (dolist (tuple (mutex-sql-query ls)) - (push (make-instance 'usat :code (nth 0 tuple) - :atn (nth 1 tuple) - :sab (nth 2 tuple) - :atv (nth 3 tuple)) - usats)) + (destructuring-bind (code atn sab atv) tuple + (push (make-instance 'usat :code code :atn atn :sab sab :atv atv) + usats))) (nreverse usats)))) @@ -559,17 +498,15 @@ (defun find-usty-tui (tui) "Find usty for tui" (setq tui (parse-tui tui)) - (kmrcl:aif (car (mutex-sql-query + (awhen (car (mutex-sql-query (format nil "select STY from MRSTY where TUI=~d limit 1" tui))) - (make-instance 'usty :tui tui :sty (nth 0 kmrcl::it)) - nil)) + (make-instance 'usty :tui tui :sty (car it)))) (defun find-usty-sty (sty) "Find usty for a sty" - (kmrcl:aif (car (mutex-sql-query - (format nil "select TUI from MRSTY where STY='~a' limit 1" sty))) - (make-instance 'usty :tui (ensure-integer (nth 0 kmrcl::it)) :sty sty) - nil)) + (awhen (car (mutex-sql-query + (format nil "select TUI from MRSTY where STY='~a' limit 1" sty))) + (make-instance 'usty :tui (ensure-integer (car it)) :sty sty))) (defun find-usty-all () "Return list of usty's for all semantic types" @@ -627,12 +564,10 @@ (defun find-ucon-tui (tui &key (srl *current-srl*)) "Find list of ucon for tui" - (when (stringp tui) - (setq tui (parse-tui tui))) + (when (stringp tui) (setq tui (parse-tui tui))) (let ((ucons '()) (ls (format nil "select CUI from MRSTY where TUI=~d" tui))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by cui desc") (dolist (tuple (mutex-sql-query ls)) (push (find-ucon-cui (ensure-integer (car tuple)) :srl srl) ucons)) @@ -644,8 +579,7 @@ (ls (format nil "select distinct cui from MRXW_ENG where wd~A'~A'" (if like " LIKE " "=") word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by cui desc") (dolist (tuple (mutex-sql-query ls)) (push (find-ucon-cui (car tuple) :srl srl) ucons)) @@ -657,8 +591,7 @@ (ls (format nil "select distinct cui from MRXNW_ENG where nwd~A'~A'" (if like " LIKE " "=") word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by cui desc") (dolist (tuple (mutex-sql-query ls)) (push (find-ucon-cui (car tuple) :srl srl) ucons)) @@ -668,12 +601,13 @@ "Return list of ustrs that match word" (let ((ustrs '()) (ls (format nil "select cui,sui from MRXW_ENG where wd='~a'" word))) - (when srl - (string-append ls (format nil " and KLRL <= ~d" srl))) + (when srl (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by cui desc,sui desc") (dolist (tuple (mutex-sql-query ls)) - (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) - ustrs)) + (destructuring-bind (cui sui) tuple + (push (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) + :srl srl) + ustrs))) ustrs)) (defun find-ustr-normalized-word (word &key (srl *current-srl*)) @@ -684,8 +618,10 @@ (string-append ls (format nil " and KLRL <= ~d" srl))) (string-append ls " order by cui desc,sui desc") (dolist (tuple (mutex-sql-query ls)) - (push (find-ustr-cuisui (ensure-integer (car tuple)) (ensure-integer (cadr tuple)) :srl srl) - ustrs)) + (destructuring-bind (cui sui) tuple + (push (find-ustr-cuisui (ensure-integer cui) (ensure-integer sui) + :srl srl) + ustrs))) ustrs)) ;; Special tables @@ -694,8 +630,8 @@ (let ((usrls '()) (tuples (mutex-sql-query "select SAB,SRL from USRL order by SAB desc"))) (dolist (tuple tuples) - (push (make-instance 'usrl :sab (nth 0 tuple) - :srl (ensure-integer (nth 1 tuple))) usrls)) + (destructuring-bind (sab srl) tuple + (push (make-instance 'usrl :sab sab :srl (ensure-integer srl)) usrls))) usrls)) ;;; Multiword lookup and score functions @@ -771,287 +707,219 @@ ;;; LEX SQL functions (defun find-lexterm-eui (eui) - (kmrcl:awhen (car (mutex-sql-query - (format nil "select WRD from LRWD where EUI=~d" eui))) - (make-instance 'lexterm :eui eui :wrd (nth 0 kmrcl:it)))) + (awhen (car (mutex-sql-query + (format nil "select WRD from LRWD where EUI=~d" eui))) + (make-instance 'lexterm :eui eui :wrd (car it)))) (defun find-lexterm-word (wrd) - (kmrcl:awhen (mutex-sql-query - (format nil "select EUI from LRWD where WRD='~a'" wrd)) - (let ((terms '())) - (dolist (tuple kmrcl:it) - (let ((eui (ensure-integer (nth 0 tuple)))) - (push - (make-instance 'lexterm :eui eui :wrd (copy-seq wrd)) - terms))) - (nreverse terms)))) - -;; LEXTERM accessors, read on demand - -(def-lazy-reader lexterm s#abr find-labr-eui eui) -(def-lazy-reader lexterm s#agr find-lagr-eui eui) -(def-lazy-reader lexterm s#cmp find-lcmp-eui eui) -(def-lazy-reader lexterm s#mod find-lmod-eui eui) -(def-lazy-reader lexterm s#nom find-lnom-eui eui) -(def-lazy-reader lexterm s#prn find-lprn-eui eui) -(def-lazy-reader lexterm s#prp find-lprp-eui eui) -(def-lazy-reader lexterm s#spl find-lspl-eui eui) -(def-lazy-reader lexterm s#trm find-ltrm-eui eui) -(def-lazy-reader lexterm s#typ find-ltyp-eui eui) + (let ((tuples (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd))) + (terms '())) + (dolist (tuple tuples) + (push (make-instance 'lexterm :eui (ensure-integer (car tuple)) + :wrd (copy-seq wrd)) + terms)) + (nreverse terms))) ;; LEX SQL Read functions (defun find-labr-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'labr :eui eui - :bas (nth 0 tuple) - :abr (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil "select BAS,ABR,EUI2,BAS2 from LRABR where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas abr eui2 bas2) tuple + (push (make-instance 'labr :eui eui :bas bas :abr abr :bas2 bas2 + :eui2 (ensure-integer eui2)) + results))) + (nreverse results))) (defun find-labr-bas (bas) - (kmrcl:awhen (mutex-sql-query - (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" bas)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'labr :eui (ensure-integer (nth 0 tuple)) - :bas (copy-seq bas) - :abr (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil "select EUI,ABR,EUI2,BAS2 from LRABR where BAS='~a'" + bas))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (eui abr eui2 bas2) tuple + (push + (make-instance 'labr :eui (ensure-integer eui) :abr abr :bas2 bas2 + :bas (copy-seq bas) :eui2 (ensure-integer eui2)) + results))) + (nreverse results))) (defun find-lagr-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lagr - :eui eui - :str (nth 0 tuple) - :sca (nth 1 tuple) - :agr (nth 2 tuple) - :cit (nth 3 tuple) - :bas (nth 4 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil "select STR,SCA,AGR,CIT,BAS from LRAGR where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (str sca agr cit bas) tuple + (push (make-instance 'lagr :eui eui :str str :sca sca :agr agr : + cit cit :bas bas) + results))) + (nreverse results))) (defun find-lcmp-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lcmp - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :com (nth 2 tuple)) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select BAS,SCA,COM from LRCMP where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas sca com) tuple + (push (make-instance 'lcmp :eui eui :bas bas :sca sca :com com) + results))) + (nreverse results))) (defun find-lmod-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lmod - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :psnmod (nth 2 tuple) - :fea (nth 3 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil + "select BAS,SCA,PSN_MOD,FEA from LRMOD where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas sca psnmod fea) tuple + (push (make-instance 'lmod :eui eui :bas bas :sca sca :psnmod psnmod + :fea fea) + results))) + (nreverse results))) (defun find-lnom-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lnom - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :eui2 (ensure-integer (nth 2 tuple)) - :bas2 (nth 3 tuple) - :sca2 (nth 4 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format + nil "select BAS,SCA,EUI2,BAS2,SCA2 from LRNOM where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas sca eui2 bas2 sca2) tuple + (push + (make-instance 'lnom :eui eui :bas bas :sca sca :bas2 bas2 :sca2 sca2 + :eui2 (ensure-integer eui2)) + results))) + (nreverse results))) (defun find-lprn-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lprn - :eui eui - :bas (nth 0 tuple) - :num (nth 1 tuple) - :gnd (nth 2 tuple) - :cas (nth 3 tuple) - :pos (nth 4 tuple) - :qnt (nth 5 tuple) - :fea (nth 6 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format + nil + "select BAS,NUM,GND,CAS,POS,QNT,FEA from LRPRN where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas num gnd cas pos qnt fea) tuple + (push (make-instance 'lprn :eui eui :bas bas :num num :gnd gnd + :cas cas :pos pos :qnt qnt :fea fea) + results))) + (nreverse results))) (defun find-lprp-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lprp - :eui eui - :bas (nth 0 tuple) - :str (nth 1 tuple) - :sca (nth 2 tuple) - :fea (nth 3 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil "select BAS,STR,SCA,FEA from LRPRP where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas str sca fea) tuple + (push + (make-instance 'lprp :eui eui :bas bas :str str :sca sca :fea fea) + results))) + (nreverse results))) (defun find-lspl-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select SPV,BAS from LRSPL where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'lspl - :eui eui - :spv (nth 0 tuple) - :bas (nth 1 tuple)) - results)) - (nreverse results)))) - + (let ((tuples (mutex-sql-query + (format nil "select SPV,BAS from LRSPL where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (spv bas) tuple + (push (make-instance 'lspl :eui eui :spv spv :bas bas) results))) + (nreverse results))) (defun find-ltrm-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,GEN from LRTRM where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'ltrm - :eui eui - :bas (nth 0 tuple) - :gen (nth 1 tuple)) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select BAS,GEN from LRTRM where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas gen) tuple + (push (make-instance 'ltrm :eui eui :bas bas :gen gen) results))) + (nreverse results))) (defun find-ltyp-eui (eui) - (kmrcl:awhen (mutex-sql-query - (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'ltyp - :eui eui - :bas (nth 0 tuple) - :sca (nth 1 tuple) - :typ (nth 2 tuple)) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select BAS,SCA,TYP from LRTYP where EUI=~d" eui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (bas sca typ) tuple + (push (make-instance 'ltyp :eui eui :bas bas :sca sca :typ typ) + results))) + (nreverse results))) (defun find-lwd-wrd (wrd) - (kmrcl:awhen (mutex-sql-query - (format nil "select EUI from LRWD where WRD='~a'" wrd)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push (ensure-integer (nth 0 tuple)) results)) - (make-instance 'lwd :wrd wrd - :euilist (nreverse results))))) + (let ((tuples (mutex-sql-query + (format nil "select EUI from LRWD where WRD='~a'" wrd))) + (results '())) + (dolist (tuple tuples) + (push (ensure-integer (car tuple)) results)) + (make-instance 'lwd :wrd wrd :euilist (nreverse results)))) ;;; Semantic Network SQL access functions (defun find-sdef-ui (ui) - (kmrcl:awhen (car (mutex-sql-query + (awhen (car (mutex-sql-query (format nil "select RT,STY_RL,STN_RTN,DEF,EX,UN,RH,ABR,RIN from SRDEF where UI=~d" ui))) - (make-instance 'sdef :rt (nth 0 kmrcl::it) - :ui ui - :styrl (nth 1 kmrcl::it) - :stnrtn (nth 2 kmrcl::it) - :def (nth 3 kmrcl::it) - :ex (nth 4 kmrcl::it) - :un (nth 5 kmrcl::it) - :rh (nth 6 kmrcl::it) - :abr (nth 7 kmrcl::it) - :rin (nth 8 kmrcl::it)))) + (destructuring-bind (rt styrl stnrtn def ex un rh abr rin) it + (make-instance 'sdef :rt rt :ui ui :styrl styrl :stnrtn stnrtn + :def def :ex ex :un un :rh rh :abr abr :rin rin)))) (defun find-sstre1-ui (ui) - (kmrcl:awhen (mutex-sql-query - (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'sstre1 :ui ui - :ui2 (ensure-integer (nth 0 tuple)) - :ui3 (ensure-integer (nth 1 tuple))) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select UI2,UI3 from SRSTRE1 where UI=~d" ui))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (ui2 ui3) tuple + (push (make-instance 'sstre1 :ui ui :ui2 (ensure-integer ui2) + :ui3 (ensure-integer ui3)) + results))) + (nreverse results))) (defun find-sstre1-ui2 (ui2) - (kmrcl:awhen (mutex-sql-query - (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'sstre1 :ui (ensure-integer (nth 0 tuple)) - :ui2 ui2 - :ui3 (ensure-integer (nth 1 tuple))) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select UI,UI3 from SRSTRE1 where UI2=~d" ui2))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (ui ui3) tuple + (push (make-instance 'sstre1 :ui (ensure-integer ui) :ui2 ui2 + :ui3 (ensure-integer ui3)) + results))) + (nreverse results))) (defun find-sstr-rl (rl) - (kmrcl:awhen (mutex-sql-query - (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'sstr - :rl rl - :styrl (nth 0 tuple) - :styrl2 (nth 1 tuple) - :ls (nth 2 tuple)) - results)) - (nreverse results)))) + (let ((tuples + (mutex-sql-query + (format nil "select STY_RL,STY_RL2,LS from SRSTRE where RL='~a'" rl))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (styrl styrl2 ls) tuple + (push (make-instance 'sstr :rl rl :styrl styrl :styrl2 styrl2 :ls ls) + results))) + (nreverse results))) (defun find-sstre2-sty (sty) - (kmrcl:awhen (mutex-sql-query - (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'sstre2 - :sty (copy-seq sty) - :rl (nth 0 tuple) - :sty2 (nth 1 tuple)) - results)) - (nreverse results)))) + (let ((tuples (mutex-sql-query + (format nil "select RL,STY2 from SRSTRE2 where STY='~a'" sty))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (rl sty2) tuple + (push (make-instance 'sstre2 :sty (copy-seq sty) :rl rl :sty2 sty2) + results))) + (nreverse results))) (defun find-sstr-styrl (styrl) - (kmrcl:awhen (mutex-sql-query - (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl)) - (let ((results '())) - (dolist (tuple kmrcl::it) - (push - (make-instance 'sstr :styrl styrl - :rl (nth 0 tuple) - :styrl2 (nth 1 tuple) - :ls (nth 2 tuple)) - results)) - (nreverse results)))) - - + (let ((tuples + (mutex-sql-query + (format nil "select RL,STY_RL2,LS from SRSTR where RL='~a'" styrl))) + (results '())) + (dolist (tuple tuples) + (destructuring-bind (rl styrl2 ls) tuple + (push (make-instance 'sstr :styrl styrl :rl rl :styrl2 styrl2 :ls ls) + results))) + (nreverse results))) diff --git a/sql.lisp b/sql.lisp index f93dcfc..60db706 100644 --- a/sql.lisp +++ b/sql.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: sql.lisp,v 1.8 2002/11/11 07:15:48 kevin Exp $ +;;;; $Id: sql.lisp,v 1.9 2002/12/09 14:11:09 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. @@ -20,12 +20,12 @@ (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) -(defvar *umls-sql-dsn* "KUMLS2002AD") -(defun umls-sql-dsn () - *umls-sql-dsn*) -(defun umls-sql-dsn! (dbname) +(defvar *umls-sql-db* "KUMLS2002AD") +(defun umls-sql-db () + *umls-sql-db*) +(defun umls-sql-db! (dbname) (sql-disconnect-pooled) - (setq *umls-sql-dsn* dbname)) + (setq *umls-sql-db* dbname)) (defvar *umls-sql-user* "secret") (defun umls-sql-user () @@ -57,7 +57,7 @@ (defun sql-connect () "Connect to UMLS database, automatically used pooled connections" - (clsql:connect `(,(umls-sql-host) ,(umls-sql-dsn) ,(umls-sql-user) ,(umls-sql-passwd)) + (clsql:connect `(,(umls-sql-host) ,(umls-sql-db) ,(umls-sql-user) ,(umls-sql-passwd)) :database-type *umls-sql-type* :pool t)) (defun sql-disconnect (conn)