r4871: *** empty log message ***

diff --git a/class-support.lisp b/class-support.lisp
index f78ed7e02e84822bb0f2d97de7435796cf8ea74c..8f97dd150001680086fac9885689c2350441bb0d 100644 (file)
--- a/class-support.lisp
+++ b/class-support.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:       Kevin M. Rosenberg
 ;;;; Date Started: Apr 2000
 ;;;;
-;;;; $Id: class-support.lisp,v 1.4 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id: class-support.lisp,v 1.5 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -121,6 +121,11 @@
   "Returns T if UCON has a semantic type of TUI."
   (some #'(lambda (usty) (= tui (tui usty))) (s#sty ucon)))
 
+(defgeneric suistr (lo))
+(defmethod suistr ((lo ulo))
+  "Return the string for a ulo object"
+  (find-string-sui (sui lo)))
+
 #+(or scl cmu)
 (dolist (c '(urank udef usat uso ucxt ustr ulo uterm usty urel ucoc uatx ucon uxw uxnw uxns lexterm labr lagr lcmp lmod lnom lprn lprp lspl ltrm ltyp lwd sdef sstr sstre1 sstre2 usrl))
     #+cmu

diff --git a/create-sql.lisp b/create-sql.lisp
index e81440d1c51be43f40025f82598bdd06c9830ade..a6f8ad390f4f0aecfa9ae10fbcf186923e203c3e 100644 (file)
--- a/create-sql.lisp
+++ b/create-sql.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: create-sql.lisp,v 1.1 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id: create-sql.lisp,v 1.2 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -49,8 +49,9 @@
   "Return sql insert command for a row of values"  
   (let ((insert-func
         (lambda (col value)
-          (let ((q (quotechar col)))
-            (concatenate 'string q (insert-col-value col value) q)))))
+          (concatenate 'string (quote-str col)
+                       (insert-col-value col value)
+                       (quote-str col)))))
     (format
      nil "INSERT INTO ~a (~{~a~^,~}) VALUES (~A)"
      (table file)
@@ -65,8 +66,9 @@
   (let ((custom-value (funcall (custom-value-fun col) values)))
     (if custom-value
        (if doquote
-           (let ((q (quotechar col)))
-             (concatenate 'string q (escape-backslashes custom-value) q))
+           (concatenate 'string (quote-str col)
+                        (escape-backslashes custom-value)
+                        (quote-str col))
            (escape-backslashes custom-value))
        "")))
 

diff --git a/parse-common.lisp b/parse-common.lisp
index d4f7922c8b6db814cd8baf86d8375a55779fdfa3..198041445fcf9baf870f8ac45a28af19436dc64c 100644 (file)
--- a/parse-common.lisp
+++ b/parse-common.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: parse-common.lisp,v 1.9 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id: parse-common.lisp,v 1.10 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -159,18 +159,30 @@ Currently, these are the LEX and NET files."
        :datatype (datatype ucol) :custom-value-fun (custom-value-fun ucol))
       (make-empty-ucol colname filename)))
 
+(defun ensure-compiled-fun (fun)
+  "Ensure that a function is compiled"
+  (etypecase fun
+    (function
+     (if (compiled-function-p fun)
+        fun
+        (compile nil fun)))
+    (list
+     (compile nil fun))))
+
 (defun make-ucol (col des ref min av max fil dty
                  &key (sqltype "VARCHAR") (parse-fun #'add-sql-quotes)
                  (quote-str "'") (custom-value-fun))
   (let ((ucol (make-instance
               'ucol
               :col col :des des :ref ref :min min :av av :max max :fil fil
-              :dty dty :sqltype sqltype :parse-fun parse-fun
-              :quote-str quote-str :custom-value-fun custom-value-fun)))
+              :dty dty :sqltype sqltype :quote-str quote-str
+              :parse-fun (ensure-compiled-fun parse-fun)
+              :custom-value-fun (ensure-compiled-fun custom-value-fun))))
     (ensure-ucol-datatype ucol (datatype-for-colname col))
     ucol))
 
 (defun make-empty-ucol (colname filename)
+  (warn "call in make-empty-ucol")
   (make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil))
 
 (defun find-ucol (colname filename)
@@ -195,17 +207,15 @@ append a unique number (starting at 2) onto a column name that is repeated in th
          (multiple-value-bind (value found) (gethash col col-counts)
            (cond
              (found
-               (incf (gethash col col-counts))
+               (incf (gethash colname col-counts))
                (concatenate 'string colname (write-to-string (1+ value))))
              (t
-              (setf (gethash col col-counts) 1)
+              (setf (gethash colname col-counts) 1)
               colname))))))
 
 (defun make-ufile (fil des table cls rws bts fields)
-  (let ((ufile
-        (make-instance
-         'ufile :fil fil :des des :table table :cls cls :rws rws :bts bts
-         :fields fields)))
+  (let ((ufile (make-instance 'ufile :fil fil :des des :table table :cls cls
+                             :rws rws :bts bts :fields fields)))
     (setf (ucols ufile) (find-ucols-for-filename fil))
     ufile))
 

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 608c463ad6a7e44020c5bd3be8cac675b13d9411..9e71b0f7b09972c0dcc41a68fce99b222e31857a 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql-classes.lisp,v 1.74 2003/05/06 21:52:34 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.75 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -270,9 +270,9 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                   :mg mg :pfstr2 kpfstr2)))
 
 (defun find-ucon-rel-cui2 (cui2 &key (srl *current-srl*))
-  (mapcar 
-   #'(lambda (cui) (find-ucon-cui cui :srl srl))
-   (remove-duplicates (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))))
+  (loop for cui in (remove-duplicates
+                   (mapcar #'cui1 (find-urel-cui2 cui2 :srl srl)))
+       collect (find-ucon-cui cui :srl srl)))
 
 (defun find-ucoc-cui (cui &key (srl *current-srl*))
   "Return a list of ucoc for cui"
@@ -307,11 +307,6 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
     (make-instance 'ulo :isn isn :fr (ensure-integer fr) :un un
                   :sui (ensure-integer sui) :sna sna :soui soui)))
 
-(defgeneric suistr (lo))
-(defmethod suistr ((lo ulo))
-  "Return the string for a ulo object"
-  (find-string-sui (sui lo)))
-
 (defun find-uatx-cui (cui &key (srl *current-srl*))
   "Return a list of uatx for cui"
   (with-umlisp-query (mratx (sab rel atx) srl cui (parse-cui cui) :lrl ksrl)

diff --git a/tests.lisp b/tests.lisp
index c12f21c7e6ac63b680f83f3cc3be4a9aedb7ef90..1a6487d512c79e17219155adfea3ca9573e9fb66 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  May 2003
 ;;;;
-;;;; $Id: tests.lisp,v 1.6 2003/05/06 02:36:58 kevin Exp $
+;;;; $Id: tests.lisp,v 1.7 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -17,7 +17,7 @@
 ;;;; *************************************************************************
 
 (defpackage #:umlisp-tests
-  (:use #:umlisp #:cl #:rtest))
+  (:use #:umlisp #:cl #:rtest #:kmrcl))
 (in-package #:umlisp-tests)
 
 (setf rtest::*catch-errors* nil)
@@ -105,5 +105,5 @@
         (make-instance 'ucon :cui (ensure-integer cui)
                        :pfstr pfstr
                        :lrl (ensure-integer cuilrl)))
-     (query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil)
+     (umlisp::query-string 'mrcon '(cui kpfstr kcuilrl) srl nil nil)
      :database db)))

diff --git a/umlisp.asd b/umlisp.asd
index 2d81e582de48d8b919ab989feae2ac18def35d47..cccf49e0f79f3dd4fd6851d6076832d9fcfc1124 100644 (file)
--- a/umlisp.asd
+++ b/umlisp.asd
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: umlisp.asd,v 1.17 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id: umlisp.asd,v 1.18 2003/05/07 22:53:36 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -24,15 +24,15 @@
     :components 
   ((:file "package")
    (:file "data-structures" :depends-on ("package"))
-   (:file "sql" :depends-on ("data-structures"))
    (:file "utils" :depends-on ("data-structures"))
+   (:file "sql" :depends-on ("utils"))
    (:file "parse-macros"  :depends-on ("sql"))
    (:file "parse-2002"  :depends-on ("parse-macros"))
    (:file "parse-common"  :depends-on ("parse-2002"))
    (:file "create-sql" :depends-on ("parse-common"))
-   (:file "classes" :depends-on ("utils"))
+   (:file "sql-classes" :depends-on ("sql"))
+   (:file "classes" :depends-on ("sql-classes"))
    (:file "class-support" :depends-on ("classes"))
-   (:file "sql-classes" :depends-on ("class-support" "sql"))
    (:file "composite" :depends-on ("sql-classes")))
   :depends-on (:clsql :clsql-mysql :kmrcl :hyperobject))