;;;; Author: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: parse-common.lisp,v 1.9 2003/05/07 21:57:06 kevin Exp $
+;;;; $Id: parse-common.lisp,v 1.10 2003/05/07 22:53:36 kevin Exp $
;;;;
;;;; This file, part of UMLisp, is
;;;; Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
: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
+ (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)))
+ :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)
+ (warn "call in make-empty-ucol")
(make-ucol (copy-seq colname) "Unknown" "" nil nil nil filename nil))
(defun find-ucol (colname filename)
(multiple-value-bind (value found) (gethash col 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)))
+ (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))
ufile))