;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: umlisp -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: parse-common.lisp ;;;; Purpose: Common, stable parsing routines for UMLisp ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; ;;;; $Id: parse-common.lisp,v 1.5 2003/05/05 23:13:28 kevin Exp $ ;;;; ;;;; This file, part of UMLisp, is ;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D. ;;;; ;;;; UMLisp users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License. ;;;; ************************************************************************* (in-package :umlisp) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))) (defun umls-pathname (filename &optional (extension "")) "Return pathname for a umls filename" (etypecase filename (string (merge-pathnames (make-pathname :name (concatenate 'string filename extension)) (case (char filename 0) ((#\M #\m) *meta-path*) ((#\L #\l) *lex-path*) ((#\S #\s) *net-path*) (t *umls-path*)))) (pathname filename))) (defun read-umls-line-new (strm) "Read a line from a UMLS stream, split into fields" (let ((line (read-line strm nil 'eof))) (if (stringp line) ;; ensure not 'eof (delimited-string-to-list line #\| t) line))) (defun read-umls-line (strm) "Read a line from a UMLS stream, split into fields" (let ((line (read-line strm nil 'eof))) (if (stringp line) ;; ensure not 'eof (delimited-string-to-list line #\| t) line))) ;;; Find field lengths for LEX and NET files (defun file-field-lengths (files) (let ((lengths '())) (dolist (file files) (setq file (umls-file-fil file)) (let (max-field count-field num-fields (count-lines 0)) (with-umls-file (fields file) (unless num-fields (setq num-fields (length fields)) (setq max-field (make-array num-fields :element-type 'fixnum :initial-element 0)) (setq count-field (make-array num-fields :element-type 'number :initial-element 0))) (dotimes (i (length fields)) (declare (fixnum i)) (let ((len (length (nth i fields)))) (incf (aref count-field i) len) (when (> len (aref max-field i)) (setf (aref max-field i) len)))) (incf count-lines)) (dotimes (i num-fields) (setf (aref count-field i) (float (/ (aref count-field i) count-lines)))) (push (list file max-field count-field) lengths))) (nreverse lengths))) (defun init-field-lengths () "Initial colstruct field lengths for files that don't have a measurement. Currently, these are the LEX and NET files." (let ((measure-files '())) (dolist (file *umls-files*) (let ((filename (umls-file-fil file))) (unless (or (char= #\M (char filename 0)) (char= #\m (char filename 0))) (push file measure-files)))) (let ((length-lists (file-field-lengths measure-files))) (dolist (length-list length-lists) (let* ((filename (car length-list)) (max-field (cadr length-list)) (av-field (caddr length-list)) (file (find-umls-file filename))) (when file (if (/= (length max-field) (length (umls-file-fields file))) (format t "Warning: Number of file fields ~A doesn't match length of fields in file structure ~S" max-field file) (dotimes (i (max (length max-field) (length (umls-file-fields file)))) (declare (fixnum i)) (let* ((field (nth i (umls-file-fields file))) (col (find-umls-col field filename))) (if col (progn (setf (umls-col-max col) (aref max-field i)) (setf (umls-col-av col) (aref av-field i)) (add-datatype-to-col col (datatype-for-col (umls-col-col col)))) (error "can't find column ~A" field))))))))))) ;;; UMLS column/file functions (defun find-col-in-columns (colname filename cols) "Returns list of umls-col structure for a column name and a filename" (dolist (col cols) (when (and (string-equal filename (umls-col-fil col)) (string-equal colname (umls-col-col col))) (return-from find-col-in-columns col))) nil) (defun find-or-make-col-in-columns (colname filename cols) (let ((col (find-col-in-columns colname filename cols))) (if col col ;; try to find column name without a terminal digit (let* ((last-char (char colname (1- (length colname)))) (digit (- (char-code last-char) (char-code #\0)))) (if (and (>= digit 0) (<= digit 9)) (let ((base-colname (subseq colname 0 (1- (length colname))))) (setq col (find-col-in-columns base-colname filename cols)) (if col (let ((new-col (make-umls-col :col (copy-seq colname) :des (copy-seq (umls-col-des col)) :ref (copy-seq (umls-col-ref col)) :min (umls-col-min col) :max (umls-col-max col) :fil (copy-seq (umls-col-fil col)) :sqltype (copy-seq (umls-col-sqltype col)) :dty (copy-seq (umls-col-dty col)) :parsefunc (umls-col-parsefunc col) :quotechar (copy-seq (umls-col-quotechar col)) :datatype (umls-col-datatype col) :custom-value-func (umls-col-custom-value-func col)))) (push new-col *umls-cols*) new-col) (error "Couldn't find a base column for col ~A in file ~A" colname filename))) (let ((new-col (make-umls-col :col (copy-seq colname) :des "Unknown" :ref "" :min nil :max nil :fil filename :sqltype "VARCHAR" :dty nil :parsefunc #'add-sql-quotes :quotechar "'" :datatype nil :custom-value-func nil))) (push new-col *umls-cols*) new-col)))))) (defun find-umls-col (colname filename) "Returns list of umls-col structure for a column name and a filename" (find-or-make-col-in-columns colname filename *umls-cols*)) (defun find-umls-file (filename) "Returns umls-file structure for a filename" (find-if (lambda (f) (string-equal filename (umls-file-fil f))) *umls-files*)) (defun umls-cols-for-umls-file (file) "Returns list of umls-cols for a file structure" (let ((filename (umls-file-fil file))) (mapcar (lambda (col) (find-umls-col col filename)) (umls-file-fields file))))