;;; -*- Mode: LISP; Syntax: Common-lisp; Package: KBCLASSES; Base: 10. -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;                                                                             ;
;  Copyright (c) 1999 by the University of Southern California                ;
;  All rights reserved.                                                       ;
;                                                                             ;
;  Permission to use, copy, modify, and distribute this software and its      ;
;  documentation in source and binary forms without fee is hereby granted,    ;
;  provided that this notice be reproduced in any copy or modification        ;
;  thereof, and that any documentation, advertising materials, and other      ;
;  materials related to such distribution and use acknowledge that the        ;
;  software was developed by the University of Southern California,           ;
;  Information Sciences Institute.  The name of the University may not be     ;
;  used to endorse or promote products derived from this software without     ;
;  specific prior written permission.                                         ;
;                                                                             ;
;  THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT THE   ;
;  SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS PROVIDED   ;
;  "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,          ;
;  WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND          ;
;  FITNESS FOR A PARTICULAR PURPOSE.                                          ;
;                                                                             ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-when (compile eval load) 
  (defparameter *bit-marker-alist* nil)

  (defun calculate-bit-position (metatype marker)
    (let ((pos (position marker (cdr (assoc metatype *bit-marker-alist*)))))
      (if pos
        pos
        (error "~S is not a valid flag for ~S" marker metatype))))

  (defun calculate-bit-values (metatype markers)
    (let ((result 0))
      (declare (fixnum result))
      (loop for marker in markers
            do (setf result 
                     (the fixnum 
                       (logior 
                        result
                        (the fixnum 
                          (ash 1 (calculate-bit-position metatype marker)))))))
      result) )
  )                                     ; END EVAL-WHEN

(defmacro def-bit-flags (metatype &rest markers)
  (if (> (length markers)
         (integer-length most-positive-fixnum))
    (error "Can't fit ~D ~S markers into a fixnum" (length markers) metatype)
    `(eval-when (compile eval load) 
       (push (cons ,metatype ',(copy-list markers)) *bit-marker-alist*))) )

(defmacro set-bit-flags (location metatype &rest flags)
  `(setf ,location (the fixnum (logior (the fixnum ,location)
                                       (the fixnum ,(calculate-bit-values
                                                     metatype flags))))) )

(defmacro clear-bit-flags (location metatype &rest flags)
  `(setf ,location (the fixnum (logandc2 (the fixnum ,location)
                                         (the fixnum ,(calculate-bit-values
                                                       metatype flags))))) )
(defmacro test-bit-flags (location metatype &rest flags)
  ;; If the first of flags is :or, then do an or test, otherwise do an
  ;;    and test;
  (when (eql (first flags) :and) (pop flags))
  (cond ((eql (first flags) :or)  ;; Faster than logtest:
         `(not (= 0 (the fixnum (logand (the fixnum ,(calculate-bit-values metatype (cdr flags)))
                                        (the fixnum ,location))))))
        ((cdr flags)
         (let ((flagValue (calculate-bit-values metatype flags)))
           `(= (the fixnum (logand (the fixnum ,flagValue) (the fixnum ,location)))
               (the fixnum ,flagValue)) ))
        (t `(logbitp (the fixnum ,(calculate-bit-position metatype (car flags)))
                     (the fixnum ,location)))) )

(defun expand-bit-flags (encodedFlags metatype)
  (loop for symbol in (cdr (assoc metatype *bit-marker-alist*))
        for position upfrom 0
        when (logbitp (the fixnum position) (the fixnum encodedFlags))
        collect symbol))

#|
(def-bit-flags :instance
  :skolem :user-defined-name :incoherent :discarded :abandoned-by-merge)


;; Macroexpand to test these:
(test-bit-flags (flags instance) :instance :or :skolem :discarded)
(test-bit-flags (flags instance) :instance :skolem :discarded)

(expand-bit-flags  9 :instance)  ; => '(:skolem :discarded)
(expand-bit-flags 16 :instance)  ; => '(:abandoned-by-merge)
(expand-bit-flags 31 :instance)  
    ; => '(skolem :user-defined-name :incoherent :discarded :abandoned-by-merge)
(expand-bit-flags 32 :instance)  ; => NIL

(defvar *test* 0)

(set-bit-flags *test* :instance :incoherent :user-defined-name) ; => 6
(test-bit-flags *test* :instance :incoherent)          ; => T
(test-bit-flags *test* :instance :incoherent :skolem)  ; => NIL
(test-bit-flags *test* :instance :and :incoherent :skolem)  ; => NIL
(test-bit-flags *test* :instance :or :incoherent :skolem)   ; => T
(test-bit-flags *test* :instance :incoherent :user-defined-name) ; => T
(test-bit-flags *test* :instance :and :incoherent :user-defined-name) ; => T
(test-bit-flags *test* :instance :incoherent :user-defined-name :discarded)
               ; => NIL

|#