;;;; boolean attributes utilities

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

;;;; boolean attribute utilities
;;;;
;;;; We need to maintain various sets of boolean attributes for known
;;;; functions and VOPs. To save space and allow for quick set
;;;; operations, we represent the attributes as bits in a fixnum.

;;; FIXME: Find or make a new package for this stuff.
(in-package "ESB-UTILS")

(deftype attributes () 'fixnum)

(eval-when (:compile-toplevel :load-toplevel :execute)

;;; Given a list of attribute names, return an alist that translates
;;; them to masks.
(defun compute-attribute-mask-list (attribute-names)
  (loop for name in attribute-names
	for mask = 1 then (ash mask 1)
	collect (cons name mask)))

;;; Given a list of attribute names and an alist that translates them
;;; to masks, return the OR of the masks.
#|
(defun compute-attribute-mask (names alist)
  (collect ((res 0 logior))
    (dolist (name names)
      (let ((mask (cdr (assoc name alist))))
        (unless mask
          (error "unknown attribute name: ~S" name))
        (res mask)))
    (res)))
|#
(defun compute-attribute-mask (names alist)
  (apply #'logior
	 (mapcar (lambda (name)
		   (or (cdr (assoc name alist))
		       (error "unknown attribute name: ~S" name)))
		 names)))

) ; EVAL-WHEN

;;; Define a new class of boolean attributes, with the attributes
;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
;;; class, which is used to generate some macros to manipulate sets of
;;; the attributes:
;;;
;;;    NAME-attributep attributes attribute-name*
;;;      Return true if one of the named attributes is present, false
;;;      otherwise. When set with SETF, updates the place Attributes
;;;      setting or clearing the specified attributes.
;;;
;;;    NAME-attributes attribute-name*
;;;      Return a set of the named attributes.

(defmacro def-boolean-attribute (name &rest attribute-names)

  (let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
	(test-name (symbolicate name "-ATTRIBUTEP"))
	(decoder-name (symbolicate "DECODE-" name "-ATTRIBUTES"))
	(alist (compute-attribute-mask-list attribute-names)))

      `(progn
	(eval-when (:compile-toplevel :load-toplevel :execute)
	  (defparameter ,translations-name ',alist))
	(defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
	  "Automagically generated boolean attribute creation function.
  See DEF-BOOLEAN-ATTRIBUTE."
	  (compute-attribute-mask attribute-names ,translations-name))
	(defmacro ,test-name (attributes &rest attribute-names)
	  "Automagically generated boolean attribute test function.
  See DEF-BOOLEAN-ATTRIBUTE."
	  `(logtest ,(compute-attribute-mask attribute-names
					     ,translations-name)
	    (the attributes ,attributes)))

	;; This definition transforms strangely under UNCROSS, in a
	;; way that DEF!MACRO doesn't understand, so we delegate it
	;; to a submacro then define the submacro differently when
	;; building the xc and when building the target compiler.
	
	;; I'd re-inline this now that I don't care about UNCROSS,
	;; but it's sufficiently hairy that I'm happy with it where
	;; it is.
	,(def-boolean-attribute-setter test-name translations-name)

	(defun ,decoder-name (attributes)
	  (loop for (name . mask) in ,translations-name
		when (logtest mask attributes)
		collect name)))))

;; It seems to be difficult to express in DEF!MACRO machinery what
;; to do with target-vs-host GET-SETF-EXPANSION in here, so we just
;; hack it by hand, passing a different GET-SETF-EXPANSION-FUN-NAME
;; in the host DEFMACRO and target DEFMACRO-MUNDANELY cases.
(defun def-boolean-attribute-setter (test-name
				     translations-name)
  `(define-setf-expander ,test-name (place &rest attributes
				     &environment env)
    "Automagically generated boolean attribute setter.
 See DEF-BOOLEAN-ATTRIBUTE."
    (multiple-value-bind (temps values stores set get)
	(get-setf-expansion place env)
      (when (cdr stores)
	(error "multiple store variables for ~S" place))
      (let ((newval (gensym))
	    (n-place (gensym))
	    (mask (compute-attribute-mask attributes ,translations-name)))
	(values `(,@temps ,n-place)
		`(,@values ,get)
		`(,newval)
		`(let ((,(first stores)
			(if ,newval
			    (logior ,n-place ,mask)
			    (logand ,n-place ,(lognot mask)))))
		  ,set
		  ,newval)
		`(,',test-name ,n-place ,@attributes))))))

;;; And now for some gratuitous pseudo-abstraction...

(defmacro attributes-union (&rest attributes)
  "Return the union of all the sets of boolean attributes ATTRIBUTES."
  `(the attributes
        (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))

(defmacro attributes-intersection (&rest attributes)
  "Return the union of all the sets of boolean attributes ATTRIBUTES."
  `(the attributes
        (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes))))

(declaim (ftype (function (attributes attributes) boolean) attributes=))
(defun attributes= (attr1 attr2)
  "Return T if ATTR1 and ATTR2 both contain the same set of attributes."
  (eql attr1 attr2))

;;; EOF
