r11478: generate custom columns by dynamically finding position of dependant columns...

[umlisp.git] / parse-common.lisp

diff --git a/parse-common.lisp b/parse-common.lisp
index ba7aef61c816e8b8d4bf6897254dcfefabe9efc1..a0c7c2afce6afea1c94dbc0c132041be7d42238d 100644 (file)
--- a/parse-common.lisp
+++ b/parse-common.lisp
@@ -23,12 +23,14 @@
   (handler-case
       (when (or alwaysclear (null *umls-files*))
         (setf *umls-cols* nil *umls-files* nil)
-        (gen-ucols)
         (gen-ufiles)
+        (gen-ucols)
+        (set-ucols-for-ufiles *umls-files*)
         (ensure-field-lengths))
-    (error (e)
-      (setf *umls-cols* nil *umls-files* nil)
-      (error e)))
+      (error (e)
+             (warn "Error reading ucols+ufiles: ~A." e)
+             (setf *umls-cols* nil *umls-files* nil)
+             nil))
   t)
 
 
@@ -45,10 +47,16 @@
 (defun ufile-pathname (ufile &optional (extension ""))
   "Return pathname for a umls filename with an optional extension"
   (assert (typep ufile 'ufile))
-  (let ((dirs (append (list (dir ufile))
-                     (awhen (subdir ufile) (list it)))))
+  (let* ((dirs (append (list (dir ufile))
+                       (awhen (subdir ufile) (list it))))
+         (name-list (delimited-string-to-list (fil ufile) #\.))
+         (name (if (second name-list)
+                   (first name-list)
+                   (concatenate 'string (first name-list) (or extension ""))))
+         (type (when (second name-list)
+                 (concatenate 'string (second name-list) (or extension "")))))
      (merge-pathnames
-      (make-pathname :name (concatenate 'string (fil ufile) extension)
+      (make-pathname :name name :type type
                     :directory (cons :relative dirs))
       *umls-path*)))
 
@@ -56,17 +64,23 @@
 "Return pathname for a umls filename with an optional extension"
   (etypecase filename
     (string
+     (let* ((name-list (delimited-string-to-list filename #\.))
+            (name (if (second name-list)
+                      (first name-list)
+                      (concatenate 'string (first name-list) (or extension ""))))
+            (type (when (second name-list)
+                    (concatenate 'string (second name-list) (or extension "")))))
      (merge-pathnames
-      (make-pathname :name (concatenate 'string filename extension))
+      (make-pathname :name name :type type)
       (case (schar filename 0)
-       ((#\M #\m)
-        *meta-path*)
-       ((#\L #\l)
-        *lex-path*)
-       ((#\S #\s)
-        *net-path*)
-       (t
-        *umls-path*))))
+        ((#\M #\m)
+         *meta-path*)
+        ((#\L #\l)
+         *lex-path*)
+        ((#\S #\s)
+         *net-path*)
+        (t
+         *umls-path*)))))
     (pathname
      filename)))
 
@@ -111,12 +125,13 @@ Currently, these are the LEX and NET files."
   "Returns a list of FILENAME MAX AV"
   (declare (optimize (speed 3) (safety 0)))
   (let (fields-max fields-av num-fields (count-lines 0))
+    (declare (fixnum count-lines))
     (with-umls-ufile (line ufile)
       (unless num-fields
        (setq num-fields (length line))
        (setq fields-max (make-array num-fields :element-type 'fixnum
                                     :initial-element 0))
-       (setq fields-av (make-array num-fields :element-type 'number
+       (setq fields-av (make-array num-fields :element-type '(or integer float)
                                    :initial-element 0)))
       (dotimes (i num-fields)
        (declare (fixnum i))
@@ -126,6 +141,8 @@ Currently, these are the LEX and NET files."
                             (if *octet-sql-storage*
                                 (ext:convert-string-to-bytes str charset:utf-8)
                               str))))
+          #-(and clisp unicode) (declare (string str))
+          (declare (type (integer 0 10000000) len))
          (incf (aref fields-av i) len)
          (when (> len (aref fields-max i))
            (setf (aref fields-max i) len))))
@@ -211,7 +228,27 @@ Currently, these are the LEX and NET files."
 
 (defun find-ufile (filename)
   "Returns umls-file structure for a filename"
-  (find-if #'(lambda (f) (string-equal filename (fil f))) *umls-files*))
+  (find-if #'(lambda (f) (string= filename (fil f))) *umls-files*))
+
+(defvar *position-hash* (make-hash-table :test 'equal))
+
+(defun position-field-file (filename fieldname)
+  "Returns the position of a field in a file"
+  (let ((key (cons filename fieldname)))
+    (multiple-value-bind (pos found) (gethash key *position-hash*)
+      (if found
+          (return-from position-field-file pos)))
+
+    (let ((ufile (find-ufile filename)))
+      (unless ufile
+        (warn "Unable to find ufile for filename ~A." filename)
+        (return-from position-field-file nil))
+      (let ((pos (position fieldname (fields ufile) :test #'string=)))
+        (unless pos
+          (warn "Unable to find field ~A in ufile ~S." fieldname ufile)
+          (return-from position-field-file nil))
+        (setf (gethash key *position-hash*) pos)
+        pos))))
 
 (defun find-ucols-for-ufile (ufile)
   "Returns list of umls-cols for a file structure"
@@ -256,15 +293,24 @@ append a unique number (starting at 2) onto a column name that is repeated in th
                                :des des :cls cls
                                :rws rws :bts bts :fields fields
                                :table (filename-to-tablename file))))
-      (setf (ucols ufile) (find-ucols-for-ufile ufile))
       ufile)))
 
+(defun set-ucols-for-ufiles (ufiles)
+  (dolist (ufile ufiles)
+    (setf (ucols ufile) (find-ucols-for-ufile ufile))))
+
 (defun datatype-for-colname (colname)
 "Return datatype for column name"
   (second (find colname +col-datatypes+ :key #'car :test #'string-equal)))
 
 (defun canonicalize-column-type (type)
   (cond
+   ((string-equal type "TINYINT")
+    (case *umls-sql-type*
+      (:mysql "TINYINT")
+      ((:postgresql :postgresql-socket) "INT1")
+      (:oracle "NUMBER(3,0)")
+      (t "INTEGER")))
    ((string-equal type "SMALLINT")
     (case *umls-sql-type*
       (:mysql "SMALLINT")
@@ -320,6 +366,9 @@ append a unique number (starting at 2) onto a column name that is repeated in th
     (sql-i (setf (sqltype col)  (canonicalize-column-type "INTEGER")
                 (parse-fun col) #'parse-integer
                 (quote-str col) ""))
+    (sql-t (setf (sqltype col)  (canonicalize-column-type "TINYINT")
+                (parse-fun col) #'parse-integer
+                (quote-str col) ""))
     (sql-f (setf (sqltype col)  (canonicalize-column-type "NUMERIC")
                 (parse-fun col) #'read-from-string
                 (quote-str col) ""))