parse-common.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          parse-common.lisp
   6 ;;;; Purpose:       Common, stable parsing routines for UMLisp
   7 ;;;; Author:        Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: parse-common.lisp,v 1.8 2003/05/06 07:44:07 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UMLisp, is
  13 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
  14 ;;;;
  15 ;;;; UMLisp users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the GNU General Public License.
  17 ;;;; *************************************************************************
  18
  19 (in-package #:umlisp)
  20
  21 (eval-when (:compile-toplevel)
  22   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
  23
  24 (defun umls-pathname (filename &optional (extension ""))
  25 "Return pathname for a umls filename"
  26   (etypecase filename
  27     (string
  28      (merge-pathnames
  29       (make-pathname :name (concatenate 'string filename extension))
  30       (case (char filename 0)
  31         ((#\M #\m)
  32          *meta-path*)
  33         ((#\L #\l)
  34          *lex-path*)
  35         ((#\S #\s)
  36          *net-path*)
  37         (t
  38          *umls-path*))))
  39     (pathname
  40       filename)))
  41
  42 (defun read-umls-line (strm &optional (eof 'eof))
  43   "Read a line from a UMLS stream, split into fields"
  44   (let ((line (read-line strm nil eof)))
  45     (if (eq line eof)
  46         eof
  47         (delimited-string-to-list line #\| t))))
  48
  49 ;;; Find field lengths for LEX and NET files
  50
  51 (defun file-field-lengths (files)
  52   (let ((lengths '()))
  53     (dolist (file files)
  54       (setq file (fil file))
  55       (let (max-field count-field num-fields (count-lines 0))
  56         (with-umls-file (fields file)
  57           (unless num-fields
  58             (setq num-fields (length fields))
  59             (setq max-field (make-array num-fields :element-type 'fixnum
  60                                         :initial-element 0))
  61             (setq count-field (make-array num-fields :element-type 'number
  62                                           :initial-element 0)))
  63           (dotimes (i (length fields))
  64             (declare (fixnum i))
  65             (let ((len (length (nth i fields))))
  66               (incf (aref count-field i) len)
  67               (when (> len (aref max-field i))
  68                 (setf (aref max-field i) len))))
  69           (incf count-lines))
  70         (dotimes (i num-fields)
  71           (setf (aref count-field i) (float (/ (aref count-field i) count-lines))))
  72         (push (list file max-field count-field) lengths)))
  73     (nreverse lengths)))
  74
  75 (defun init-field-lengths ()
  76   "Initial colstruct field lengths for files that don't have a measurement.
  77 Currently, these are the LEX and NET files."
  78   (let ((measure-files '()))
  79     (dolist (file *umls-files*)
  80       (let ((filename (fil file)))
  81         (unless (or (char= #\M (char filename 0))
  82                     (char= #\m (char filename 0)))
  83           (push file measure-files))))
  84     (let ((length-lists (file-field-lengths measure-files)))
  85       (dolist (length-list length-lists)
  86         (let* ((filename (car length-list))
  87                (max-field (cadr length-list))
  88                (av-field (caddr length-list))
  89                (file (find-ufile filename)))
  90           (when file
  91             (if (/= (length max-field) (length (fields file)))
  92                 (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S"
  93                        max-field file)
  94               (dotimes (i (max (length max-field) (length (fields file))))
  95                 (declare (fixnum i))
  96                 (let* ((field (nth i (fields file)))
  97                        (col (find-ucol field filename)))
  98                   (if col
  99                       (progn
 100                         (setf (cmax col) (aref max-field i))
 101                         (setf (av col) (aref av-field i))
 102                         (add-datatype-to-col col (datatype-for-col (col col))))
 103                   (error "can't find column ~A" field)))))))))))
 104
 105
 106
 107 ;;; UMLS column/file functions
 108
 109 (defun find-col-in-columns (colname filename cols)
 110 "Returns list of umls-col structure for a column name and a filename"
 111   (dolist (col cols)
 112     (when (and (string-equal filename (fil col))
 113                (string-equal colname (col col)))
 114       (return-from find-col-in-columns col)))
 115   nil)
 116
 117 (defun find-or-make-col-in-columns (colname filename cols)
 118   (let ((col (find-col-in-columns colname filename cols)))
 119     (if col
 120         col
 121       ;; try to find column name without a terminal digit
 122       (let* ((last-char (char colname (1- (length colname))))
 123              (digit (- (char-code last-char) (char-code #\0))))
 124         (if (and (>= digit 0) (<= digit 9))
 125             (let ((base-colname (subseq colname 0 (1- (length colname)))))
 126               (setq col (find-col-in-columns base-colname filename cols))
 127               (if col
 128                   (let ((new-col (make-instance 'ucol
 129                                   :col (copy-seq colname)
 130                                   :des (copy-seq (des col))
 131                                   :ref (copy-seq (ref col))
 132                                   :min (cmin col)
 133                                   :max (cmax col)
 134                                   :fil (copy-seq (fil col))
 135                                   :sqltype (copy-seq (sqltype col))
 136                                   :dty (copy-seq (dty col))
 137                                   :parse-fun (parse-fun col)
 138                                   :quotechar (copy-seq (quotechar col))
 139                                   :datatype (datatype col)
 140                                   :custom-value-fun (custom-value-fun col))))
 141                     (push new-col *umls-cols*)
 142                     new-col)
 143                 (error "Couldn't find a base column for col ~A in file ~A"
 144                        colname filename)))
 145           (let ((new-col (make-instance 'ucol
 146                           :col (copy-seq colname)
 147                           :des "Unknown"
 148                           :ref ""
 149                           :min nil
 150                           :max nil
 151                           :fil filename
 152                           :sqltype "VARCHAR"
 153                           :dty nil
 154                           :parse-fun #'add-sql-quotes
 155                           :quotechar "'"
 156                           :datatype nil
 157                           :custom-value-fun nil)))
 158             (push new-col *umls-cols*)
 159             new-col))))))
 160
 161 (defun find-ucol (colname filename)
 162   "Returns list of umls-col structure for a column name and a filename"
 163   (find-or-make-col-in-columns colname filename *umls-cols*))
 164
 165 (defun find-ufile (filename)
 166   "Returns umls-file structure for a filename"
 167   (find-if (lambda (f) (string-equal filename (fil f))) *umls-files*))
 168
 169 (defun ucols-for-ufile (file)
 170   "Returns list of umls-cols for a file structure"
 171   (let ((filename (fil file)))
 172     (mapcar (lambda (col) (find-ucol col filename))
 173             (fields file))))
 174
 175