1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: parse-common.lisp
6 ;;;; Purpose: Common, stable parsing routines for UMLisp
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: parse-common.lisp,v 1.6 2003/05/06 01:34:57 kevin Exp $
12 ;;;; This file, part of UMLisp, is
13 ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
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 ;;;; *************************************************************************
21 (eval-when (:compile-toplevel)
22 (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
24 (defun umls-pathname (filename &optional (extension ""))
25 "Return pathname for a umls filename"
29 (make-pathname :name (concatenate 'string filename extension))
30 (case (char filename 0)
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)))
47 (delimited-string-to-list line #\| t))))
49 ;;; Find field lengths for LEX and NET files
51 (defun file-field-lengths (files)
54 (setq file (umls-file-fil file))
55 (let (max-field count-field num-fields (count-lines 0))
56 (with-umls-file (fields file)
58 (setq num-fields (length fields))
59 (setq max-field (make-array num-fields :element-type 'fixnum
61 (setq count-field (make-array num-fields :element-type 'number
63 (dotimes (i (length fields))
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))))
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)))
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 (umls-file-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-umls-file filename)))
91 (if (/= (length max-field) (length (umls-file-fields file)))
92 (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S"
94 (dotimes (i (max (length max-field) (length (umls-file-fields file))))
96 (let* ((field (nth i (umls-file-fields file)))
97 (col (find-umls-col field filename)))
100 (setf (umls-col-max col) (aref max-field i))
101 (setf (umls-col-av col) (aref av-field i))
102 (add-datatype-to-col col (datatype-for-col (umls-col-col col))))
103 (error "can't find column ~A" field)))))))))))
107 ;;; UMLS column/file functions
109 (defun find-col-in-columns (colname filename cols)
110 "Returns list of umls-col structure for a column name and a filename"
112 (when (and (string-equal filename (umls-col-fil col))
113 (string-equal colname (umls-col-col col)))
114 (return-from find-col-in-columns col)))
117 (defun find-or-make-col-in-columns (colname filename cols)
118 (let ((col (find-col-in-columns colname filename cols)))
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))
128 (let ((new-col (make-umls-col
129 :col (copy-seq colname)
130 :des (copy-seq (umls-col-des col))
131 :ref (copy-seq (umls-col-ref col))
132 :min (umls-col-min col)
133 :max (umls-col-max col)
134 :fil (copy-seq (umls-col-fil col))
135 :sqltype (copy-seq (umls-col-sqltype col))
136 :dty (copy-seq (umls-col-dty col))
137 :parsefunc (umls-col-parsefunc col)
138 :quotechar (copy-seq (umls-col-quotechar col))
139 :datatype (umls-col-datatype col)
140 :custom-value-func (umls-col-custom-value-func col))))
141 (push new-col *umls-cols*)
143 (error "Couldn't find a base column for col ~A in file ~A"
145 (let ((new-col (make-umls-col
146 :col (copy-seq colname)
154 :parsefunc #'add-sql-quotes
157 :custom-value-func nil)))
158 (push new-col *umls-cols*)
161 (defun find-umls-col (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*))
165 (defun find-umls-file (filename)
166 "Returns umls-file structure for a filename"
167 (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*))
169 (defun umls-cols-for-umls-file (file)
170 "Returns list of umls-cols for a file structure"
171 (let ((filename (umls-file-fil file)))
172 (mapcar (lambda (col) (find-umls-col col filename))
173 (umls-file-fields file))))