r11156: fix trans extension for sbcl, fix index for mrrel

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 9d6852b8cca7bcebda125394e74023f02b7b6631..1187d5931bd9bc52a0791c43752dbaa434b2e865 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -37,10 +37,12 @@
         (%%where (when where-name
                    (format nil " where ~:@(~A~)~A" where-name
                          (if like " like " ""))))
         (%%where (when where-name
                    (format nil " where ~:@(~A~)~A" where-name
                          (if like " like " ""))))

-         (%%limit (gensym "LIMIT-"))
-         (%%filter (gensym "FILTER-")))
-    `(let ((%%limit ,limit)
-           (%%filter ,filter))
+         (%filter (gensym "FILTER-"))
+         (%single (gensym "SINGLE-"))
+         (%limit (gensym "LIMIT-")))
+    `(let ((,%limit ,limit)
+           (,%single ,single)
+           (,%filter ,filter))

        (concatenate
         'string
         ,%%fields
        (concatenate
         'string
         ,%%fields


@@ -56,20 +58,20 @@
                  " is null")
                 (t
                  (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))
                  " is null")
                 (t
                  (format nil ,(if like "'%~A%'" "='~A'") ,where-value)))))

-        (if ##filter (concatenate 'string " AND " ##filter) "")
+        (if ,%filter (concatenate 'string
+                                  ,(if %%where " AND " " WHERE ")
+                                  ,%filter) "")

         (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
         ,@(when %%order (list %%order))
         (if ,srl (concatenate 'string ,%%lrl (write-to-string ,srl)) "")
         ,@(when %%order (list %%order))

-        (if (or ,single ##limit)
-            (cond
-             ((and ,single (> ##limit 1))
-              (error "Can't set single and limit > 1."))
-             (,single
-              " LIMIT 1")
-             (##limit
-              (format nil " LIMIT ~D" ##limit))
-             (t
-              ""))
-          "")))))
+        (cond
+         ((and ,%single ,%limit)
+          (error "Can't set single and limit"))
+         (,%single
+          " LIMIT 1")
+         (,%limit
+          (format nil " LIMIT ~D" ,%limit))
+         (t
+          ""))))))

 
 (defun query-string-eval (table fields &optional srl where-name where-value
                          &key (lrl "KCUILRL") single distinct order like limit filter)
 
 (defun query-string-eval (table fields &optional srl where-name where-value
                          &key (lrl "KCUILRL") single distinct order like limit filter)


@@ -102,17 +104,17 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
   `(,query-cmd
     (query-string ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like

-     :filter filter :limit ,limit)))
+     :filter ,filter :limit ,limit)))

 
 (defmacro umlisp-query-eval (table fields srl where-name where-value
 
 (defmacro umlisp-query-eval (table fields srl where-name where-value

-                    &key (lrl "KCUILRL") single distinct order like 
+                    &key (lrl "KCUILRL") single distinct order like

                      filter limit)
   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(mutex-sql-query
     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like
                      filter limit)
   "Query the UMLisp database. Return a list of umlisp objects whose name
 is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   `(mutex-sql-query
     (query-string-eval ,table ,fields ,srl ,where-name ,where-value
      :lrl ,lrl :single ,single :distinct ,distinct :order ,order :like ,like

-     :filter filter :limit ,limit)))
+     :filter ,filter :limit ,limit)))

 
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value
 
 ;; only WHERE-VALUE and SRL are evaluated
 (defmacro collect-umlisp-query ((table fields srl where-name where-value


@@ -202,6 +204,16 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (setq ,sui (parse-sui ,sui))
     ,sui))
 
     (setq ,sui (parse-sui ,sui))
     ,sui))
 

+(defmacro ensure-aui-integer (aui)
+  `(if (stringp ,aui)
+    (setq ,aui (parse-aui ,aui))
+    ,aui))
+
+(defmacro ensure-rui-integer (rui)
+  `(if (stringp ,rui)
+    (setq ,rui (parse-rui ,rui))
+    ,rui))
+

 (defmacro ensure-tui-integer (tui)
   `(if (stringp ,tui)
     (setq ,tui (parse-tui ,tui))
 (defmacro ensure-tui-integer (tui)
   `(if (stringp ,tui)
     (setq ,tui (parse-tui ,tui))


@@ -217,7 +229,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (ensure-cui-integer cui)
   (unless cui (return-from find-ucon-cui nil))
 
   (ensure-cui-integer cui)
   (unless cui (return-from find-ucon-cui nil))
 

-  (let ((tuple (car (mutex-sql-query 
+  (let ((tuple (car (mutex-sql-query

                      (format nil
                              "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D AND KPFENG=1~A"
                              cui (if srl (format nil " AND SRL<=~D" srl) ""))))))
                      (format nil
                              "SELECT kcuilrl,str FROM MRCONSO WHERE CUI=~D AND KPFENG=1~A"
                              cui (if srl (format nil " AND SRL<=~D" srl) ""))))))


@@ -242,10 +254,12 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
   (or
   "Find preferred string for a cui"
   (ensure-cui-integer cui)
   (or

-   (collect-umlisp-query (mrconso (kpfstr) srl cui cui :distinct t 
-                                  :filter " KPFENG=1" :single t))
-   (collect-umlisp-query (mrconso (kpfstr) srl cui cui :distinct t 
-                                  :single t))))
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
+                                  :filter " KPFENG=1" :single t)
+      str)
+   (collect-umlisp-query (mrconso (str) srl cui cui :distinct t
+                                  :single t)
+      str)))

 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"
 
 (defun find-ucon-lui (lui &key (srl *current-srl*))
   "Find list of ucon for lui"


@@ -270,7 +284,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 
 (defun find-ucon-aui (aui &key (srl *current-srl*))
   "Find list of ucon for aui"
 
 (defun find-ucon-aui (aui &key (srl *current-srl*))
   "Find list of ucon for aui"

-  (ensure-sui-integer aui)
+  (ensure-aui-integer aui)

   (collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t)
     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
                   :lrl (ensure-integer kcuilrl))))
   (collect-umlisp-query (mrconso (cui kcuilrl) srl aui aui :distinct t)
     (make-instance 'ucon :cui (ensure-integer cui) :pfstr (find-pfstr-cui cui)
                   :lrl (ensure-integer kcuilrl))))


@@ -344,24 +358,21 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-udoc-key (key)
   "Return list of abbreviation documentation for a key"
   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)
 (defun find-udoc-key (key)
   "Return list of abbreviation documentation for a key"
   (collect-umlisp-query (mrdoc (value type expl) nil dockey key)

-    (make-instance 'udoc :key key :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey key :dvalue value :dtype type :expl expl)))

 
 (defun find-udoc-value (value)
   "Return abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)
 
 (defun find-udoc-value (value)
   "Return abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey type expl) nil value value)

-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 

-(defun find-udoc-key-value (key value)
-  (let ((tuple (car (mutex-sql-query
-                    (format nil "SELECT TYPE,EXPL FROM MRDOC WHERE DOCKEY='~A' AND VALUE='~A'"
-                            key value)))))
-    (when tuple
-      (make-instance 'udoc :key key :value value :type (first tuple) :expl (second tuple)))))
+(defun find-udoc-key-value (dockey value)
+  (collect-umlisp-query (mrdoc (type expl) nil dockey dockey :filter (format nil "VALUE='~A'" value))
+      (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 (defun find-udoc-all ()
   "Return all abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)
 
 (defun find-udoc-all ()
   "Return all abbreviation documentation"
   (collect-umlisp-query (mrdoc (dockey value type expl) nil nil nil)

-    (make-instance 'udoc :key dockey :value value :type type :expl expl)))
+    (make-instance 'udoc :dockey dockey :dvalue value :dtype type :expl expl)))

 
 (defun find-usty-cui (cui &key (srl *current-srl*))
   "Return a list of usty for cui"
 
 (defun find-usty-cui (cui &key (srl *current-srl*))
   "Return a list of usty for cui"


@@ -382,7 +393,17 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                               srl cui1 cui :lrl "KSRL")
     (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
                   :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
                               srl cui1 cui :lrl "KSRL")
     (make-instance 'urel :cui1 cui :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
                   :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2

-                  :rui rui :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
+                  :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir
+                  :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
+
+(defun find-urel-rui (rui &key (srl *current-srl*))
+  "Return the urel for a rui"
+  (ensure-rui-integer rui)
+  (collect-umlisp-query (mrrel (aui1 rel stype1 cui1 cui2 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
+                              srl rui rui :lrl "KSRL" :single t)
+    (make-instance 'urel :cui1 cui1 :aui1 (ensure-integer aui1) :stype1 stype1 :rel rel
+                  :cui2 (ensure-integer cui2) :aui2 (ensure-integer aui2) :stype2 stype2
+                  :rui (ensure-integer rui) :srui srui :rela rela :sab sab :sl sl :rg rg :dir dir

                   :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
 
 (defun find-cui2-urel-cui (cui &key (srl *current-srl*))
                   :suppress suppress :cvf cvf :pfstr2 (find-pfstr-cui cui2))))
 
 (defun find-cui2-urel-cui (cui &key (srl *current-srl*))


@@ -397,8 +418,10 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
   (ensure-cui-integer cui2)
   (collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
                               srl cui2 cui2 :lrl "KSRL")
   (ensure-cui-integer cui2)
   (collect-umlisp-query (mrrel (rel cui1 aui1 stype1 aui2 stype2 rela rui srui sab sl rg dir suppress cvf)
                               srl cui2 cui2 :lrl "KSRL")

-    (make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2) :stype2 stype2 :rui rui :srui srui
-                  :stype1 stype1 :cui1 (ensure-integer cui1) :aui1 (ensure-integer aui1)
+    (make-instance 'urel :cui2 cui2 :rel rel :aui2 (ensure-integer aui2)
+                   :stype2 stype2 :rui (ensure-integer rui) :srui srui
+                  :stype1 stype1 :cui1 (ensure-integer cui1)
+                   :aui1 (ensure-integer aui1)

                   :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
                   :pfstr2 (find-pfstr-cui cui2))))
 
                   :rela rela :sab sab :sl sl :rg rg :dir dir :suppress suppress :cvf cvf
                   :pfstr2 (find-pfstr-cui cui2))))
 


@@ -532,15 +555,15 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
   (ensure-sui-integer sui)
   (ensure-cui-integer cui)
 (defun find-uso-cuisui (cui sui &key (srl *current-srl*))
   (ensure-sui-integer sui)
   (ensure-cui-integer cui)

-  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str) srl kcuisui
-                          (make-cuisui cui sui) :lrl srl)
+  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str)
+                                 srl kcuisui (make-cuisui cui sui) :lrl srl)

     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
                   :cui cui :sui sui :saui saui :sdui sdui :scui scui
                    :lat lat :str str)))
 
 (defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
   (ensure-cui-integer cui)
     (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
                   :cui cui :sui sui :saui saui :sdui sdui :scui scui
                    :lat lat :str str)))
 
 (defun find-uso-cui (cui &key (srl *current-srl*) (english-only nil) limit)
   (ensure-cui-integer cui)

-  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str) 
+  (collect-umlisp-query (mrconso (aui sab code srl tty saui sdui scui lat str sui)

                                  srl cui cui :lrl srl :limit limit
                                  :filter (when english-only "LAT='ENG'"))
      (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty
                                  srl cui cui :lrl srl :limit limit
                                  :filter (when english-only "LAT='ENG'"))
      (make-instance 'uso :aui aui :sab sab :code code :srl srl :tty tty


@@ -620,7 +643,7 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (find-usty-tui tui)))
 
 (defun find-usab-all ()
     (find-usty-tui tui)))
 
 (defun find-usab-all ()

-  "Find usab for a key"
+  "Return all usab objects"

   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
                                  rmeta slc scc srl tfr cfr cxty ttyl atnl lat
                                  cenc curver sabin ssn scit) nil nil nil)
   (collect-umlisp-query (mrsab (vcui rcui vsab rsab son sf sver vstart vend imeta
                                  rmeta slc scc srl tfr cfr cxty ttyl atnl lat
                                  cenc curver sabin ssn scit) nil nil nil)