X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=parse-common.lisp;h=b8439fab6fffe9eeeecf91dfb69a25cf5ab97aed;hb=aeade16272b79115d3f307906c7a3e9597137e97;hp=d4f7922c8b6db814cd8baf86d8375a55779fdfa3;hpb=3199369942d2e5ab4f5b060c2c6b655caf505944;p=umlisp.git diff --git a/parse-common.lisp b/parse-common.lisp index d4f7922..b8439fa 100644 --- a/parse-common.lisp +++ b/parse-common.lisp @@ -2,15 +2,15 @@ ;;;; ************************************************************************* ;;;; 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. @@ -18,10 +18,7 @@ (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) @@ -72,7 +69,7 @@ Currently, these are the LEX and NET files." (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" @@ -90,8 +87,8 @@ Currently, these are the LEX and NET files." (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)) @@ -101,6 +98,7 @@ Currently, these are the LEX and NET files." (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 @@ -159,18 +157,34 @@ Currently, these are the LEX and NET files." :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) @@ -181,10 +195,10 @@ Currently, these are the LEX and NET files." "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 @@ -192,21 +206,19 @@ append a unique number (starting at 2) onto a column name that is repeated in th (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)