+(defvar *cache-table-queries-default* nil
+ "Specifies the default behaivour for caching of attribute
+ types. Meaningful values are t, nil and :flush as described for
+ the action argument to CACHE-TABLE-QUERIES.")
+
+(defun cache-table-queries (table &key (action nil) (database *default-database*))
+ "Controls the caching of attribute type information on the
+table specified by TABLE in DATABASE which defaults to
+*DEFAULT-DATABASE*. ACTION specifies the caching behaviour to
+adopt. If its value is t then attribute type information is
+cached whereas if its value is nil then attribute type
+information is not cached. If ACTION is :flush then all existing
+type information in the cache for TABLE is removed, but caching
+is still enabled. TABLE may be a string representing a table for
+which the caching action is to be taken while the caching action
+is applied to all tables if TABLE is t. Alternativly, when TABLE
+is :default, the default caching action specified by
+*CACHE-TABLE-QUERIES-DEFAULT* is applied to all table for which a
+caching action has not been explicitly set."
+ (with-slots (attribute-cache) database
+ (cond
+ ((stringp table)
+ (multiple-value-bind (val found) (gethash table attribute-cache)
+ (cond
+ ((and found (eq action :flush))
+ (setf (gethash table attribute-cache) (list t nil)))
+ ((and found (eq action t))
+ (setf (gethash table attribute-cache) (list t (second val))))
+ ((and found (null action))
+ (setf (gethash table attribute-cache) (list nil nil)))
+ ((not found)
+ (setf (gethash table attribute-cache) (list action nil))))))
+ ((eq table t)
+ (maphash (lambda (k v)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v))))))
+ attribute-cache))
+ ((eq table :default)
+ (maphash (lambda (k v)
+ (when (eq (first v) :unspecified)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v)))))))
+ attribute-cache))))
+ (values))
+
+