+;;; Source transforms / compiler macros for INFO functions.
+;;;
+;;; When building the XC, we give it a source transform, so that it can
+;;; compile INFO calls in the target efficiently; we also give it a compiler
+;;; macro, so that at least those INFO calls compiled after this file can be
+;;; efficient. (Host compiler-macros do not fire when compiling the target,
+;;; and source transforms don't fire when building the XC, so we need both.)
+;;;
+;;; Target needs just one, since there compiler macros and source-transforms
+;;; are equivalent.
+(macrolet ((def (name lambda-list form)
+ (aver (member 'class lambda-list))
+ (aver (member 'type lambda-list))
+ `(progn
+ #+sb-xc-host
+ (define-source-transform ,name ,lambda-list
+ (if (and (keywordp class) (keywordp type))
+ ,form
+ (values nil t)))
+ (define-compiler-macro ,name ,(append '(&whole .whole.) lambda-list)
+ (if (and (keywordp class) (keywordp type))
+ ,form
+ .whole.)))))
+
+ (def info (class type name &optional (env-list nil env-list-p))
+ (let (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type)))
+ (with-unique-names (value foundp)
+ `(multiple-value-bind (,value ,foundp)
+ (get-info-value ,name
+ ,(type-info-number info)
+ ,@(when env-list-p (list env-list)))
+ (declare (type ,(type-info-type info) ,value))
+ (values ,value ,foundp)))))
+
+ (def (setf info) (new-value class type name &optional (env-list nil env-list-p))
+ (let* (#+sb-xc-host (sb!xc:*gensym-counter* sb!xc:*gensym-counter*)
+ (info (type-info-or-lose class type))
+ (tin (type-info-number info))
+ (validate (type-info-validate-function info)))
+ (with-unique-names (new check)
+ `(let ((,new ,new-value)
+ ,@(when validate
+ `((,check (type-info-validate-function (svref *info-types* ,tin))))))
+ ,@(when validate
+ `((funcall ,check ',name ,new)))
+ (set-info-value ,name
+ ,tin
+ ,new
+ ,@(when env-list-p
+ (list `(get-write-info-env ,env-list))))))))
+
+ (def clear-info (class type name)
+ (let ((info (type-info-or-lose class type)))
+ `(clear-info-value ,name ,(type-info-number info)))))
+\f