/[cmucl]/src/compiler/macros.lisp
ViewVC logotype

Diff of /src/compiler/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4.1.2 by ram, Wed Jun 6 13:53:27 1990 UTC revision 1.4.1.3 by ram, Fri Jun 15 15:40:33 1990 UTC
# Line 897  Line 897 
897    
898  (deftype attributes () 'fixnum)  (deftype attributes () 'fixnum)
899    
900  (eval-when (#-new-compiler compile load eval)  (eval-when (compile load eval)
901  ;;; Compute-Attribute-Mask  --  Internal  ;;; Compute-Attribute-Mask  --  Internal
902  ;;;  ;;;
903  ;;;    Given a list of attribute names and an alist that translates them to  ;;;    Given a list of attribute names and an alist that translates them to
# Line 926  Line 926 
926    
927      NAME-attributep attributes attribute-name*      NAME-attributep attributes attribute-name*
928        Return true if one of the named attributes is present, false otherwise.        Return true if one of the named attributes is present, false otherwise.
929          When set with SETF, updates the place Attributes setting or clearing the
930          specified attributes.
931    
932      NAME-attributes attribute-name*      NAME-attributes attribute-name*
933        Return a set of the named attributes."        Return a set of the named attributes."
934    
935    (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS")))    (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
936            (test-name (symbolicate name "-ATTRIBUTEP")))
937      (collect ((alist))      (collect ((alist))
938        (do ((mask 1 (ash mask 1))        (do ((mask 1 (ash mask 1))
939             (names attribute-names (cdr names)))             (names attribute-names (cdr names)))
# Line 938  Line 941 
941          (alist (cons (car names) mask)))          (alist (cons (car names) mask)))
942    
943        `(progn        `(progn
944          (eval-when (compile load eval)           (eval-when (compile load eval)
945            (defconstant ,const-name ',(alist)))             (defconstant ,const-name ',(alist)))
946    
947          (defmacro ,(symbolicate name "-ATTRIBUTEP")           (defmacro ,test-name (attributes &rest attribute-names)
948                    (attributes &rest attribute-names)             "Automagically generated boolean attribute test function.  See
949            "Automagically generated boolean attribute test function.  See              Def-Boolean-Attribute."
950            Def-Boolean-Attribute."             `(logtest ,(compute-attribute-mask attribute-names ,const-name)
951            `(logtest ,(compute-attribute-mask attribute-names ,const-name)                       (the attributes ,attributes)))
952                      (the attributes ,attributes)))  
953             (define-setf-method ,test-name (place &rest attributes
954          (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)                                                 &environment env)
955            "Automagically generated boolean attribute creation function.  See  
956            Def-Boolean-Attribute."             "Automagically generated boolean attribute setter.  See
957            (compute-attribute-mask attribute-names ,const-name))))))              Def-Boolean-Attribute."
958               (multiple-value-bind (temps values stores set get)
959                                    (lisp::foo-get-setf-method place env)
960                 (let ((newval (gensym))
961                       (n-place (gensym))
962                       (mask (compute-attribute-mask attributes ,const-name)))
963                   (values `(,@temps ,n-place)
964                           `(,@values ,get)
965                           `(,newval)
966                           `(let ((,(first stores)
967                                   (if ,newval
968                                       (logand ,n-place ,(lognot mask))
969                                       (logior ,n-place ,mask))))
970                              ,set
971                              ,newval)
972                           `(,',test-name ,n-place ,@attributes)))))
973    
974             (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
975               "Automagically generated boolean attribute creation function.  See
976                Def-Boolean-Attribute."
977               (compute-attribute-mask attribute-names ,const-name))))))
978    
979    
980  ;;; Attributes-Union, Attributes-Intersection, Attributes=  --  Interface  ;;; Attributes-Union, Attributes-Intersection, Attributes=  --  Interface

Legend:
Removed from v.1.4.1.2  
changed lines
  Added in v.1.4.1.3

  ViewVC Help
Powered by ViewVC 1.1.5