;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: parse-common.lisp
-;;;; Purpose: Common, stable parsing routines for UMLisp
-;;;; Author: Kevin M. Rosenberg
-;;;; Date Started: Apr 2000
+;;;; Name: parse-common.lisp
+;;;; Purpose: Common, stable parsing routines for UMLisp
+;;;; Author: Kevin M. Rosenberg
+;;;; Created: Apr 2000
;;;;
-;;;; $Id: parse-common.lisp,v 1.9 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id$
;;;;
;;;; This file, part of UMLisp, is
-;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
+;;;; Copyright (c) 2000-2004 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)
-(eval-when (:compile-toplevel)
- (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
-
-(defun ensure-init-umls (&optional (alwaysclear nil))
+(defun ensure-ucols+ufiles (&optional (alwaysclear nil))
"Initialize all UMLS file and column structures if not already initialized"
(when (or alwaysclear (null *umls-files*))
(gen-ucols)
(string
(merge-pathnames
(make-pathname :name (concatenate 'string filename extension))
- (case (char filename 0)
+ (case (schar filename 0)
((#\M #\m)
*meta-path*)
((#\L #\l)
(destructuring-bind (filename fields-max fields-av) length-list
(let ((file (find-ufile filename)))
(unless file
- (error "Can't find ~A filename in ufiles"))
+ (error "Can't find ~A filename in ufiles" filename))
(unless (= (length fields-max) (length (fields file)))
(error
"Number of file fields ~A not equal to field count in ufile ~S"
(defun ufiles-to-measure ()
"Returns a list of ufiles to measure"
(loop for ufile in *umls-files*
- unless (or (char= #\M (char (fil ufile) 0))
- (char= #\m (char (fil ufile) 0)))
+ unless (or (char= #\M (schar (fil ufile) 0))
+ (char= #\m (schar (fil ufile) 0)))
collect ufile))
(defun file-field-lengths (filename)
"Returns a list of FILENAME MAX AV"
+ (declare (optimize (speed 3) (safety 0)))
(let (fields-max fields-av num-fields (count-lines 0))
(with-umls-file (line filename)
(unless num-fields
(defun make-ucol-for-column (colname filename ucols)
;; try to find column name without a terminal digit
(let* ((len (length colname))
- (last-digit? (digit-char-p (char colname (1- len))))
+ (last-digit? (digit-char-p (schar colname (1- len))))
(base-colname (if last-digit?
(subseq colname 0 (1- len))
colname))
: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
+ (null
+ nil)
+ (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)))
+ :col col :des des :ref ref :min min :av av
+ :max (if (eql max 0) 1 max) ;; ensure at least one char wide
+ :fil fil
+ :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)
+ ;;(format "call in make-empty-ucol: ~A/~A" colname filename)
(make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil))
(defun find-ucol (colname filename)
"Returns umls-file structure for a filename"
(find-if #'(lambda (f) (string-equal filename (fil f))) *umls-files*))
-(defun find-ucols-for-filename (filename)
+(defun find-ucols-for-ufile (ufile)
"Returns list of umls-cols for a file structure"
- (loop for colname in (fields (find-ufile filename))
- collect (find-ucol colname filename)))
+ (loop for colname in (fields ufile)
+ collect (find-ucol colname (fil ufile))))
(defun umls-field-string-to-list (fmt)
"Converts a comma delimited list of fields into a list of field names. Will
(let ((col-counts (make-hash-table :test 'equal)))
(loop for colname in (delimited-string-to-list (escape-column-name fmt) #\,)
collect
- (multiple-value-bind (value found) (gethash col col-counts)
+ (multiple-value-bind (value found) (gethash colname 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)))
- (setf (ucols ufile) (find-ucols-for-filename fil))
+ (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-ufile ufile))
ufile))
(defun datatype-for-colname (colname)
(when (and (cmax col) (av col))
(if (> (cmax col) 255)
(setf (sqltype col) "TEXT")
- (if (< (- (cmax col) (av col)) 4)
- (setf (sqltype col) "CHAR") ; if average bytes wasted < 4
- (setf (sqltype col) "VARCHAR")))))))
+ (setf (sqltype col) "VARCHAR"))))))
(defun escape-column-name (name)
(substitute #\_ #\/ name))