From dff3199405205cf99782dd3abf9d9dde187f5494 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 7 May 2003 22:53:36 +0000 Subject: [PATCH] r4871: *** empty log message *** --- class-support.lisp | 7 ++++++- create-sql.lisp | 12 +++++++----- parse-common.lisp | 28 +++++++++++++++++++--------- sql-classes.lisp | 13 ++++--------- tests.lisp | 6 +++--- umlisp.asd | 8 ++++---- 6 files changed, 43 insertions(+), 31 deletions(-) diff --git a/class-support.lisp b/class-support.lisp index f78ed7e..8f97dd1 100644 --- 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 e81440d..a6f8ad3 100644 --- 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 d4f7922..1980414 100644 --- 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 608c463..9e71b0f 100644 --- 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 c12f21c..1a6487d 100644 --- 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 2d81e58..cccf49e 100644 --- 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)) -- 2.34.1