/[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.5 by ram, Wed Jun 6 13:54:09 1990 UTC revision 1.5.1.1 by ram, Fri Jun 15 15:57:17 1990 UTC
# Line 53  Line 53 
53    
54  ;;;; The Policy macro:  ;;;; The Policy macro:
55    
56  (proclaim '(special *current-cookie* *default-cookie*))  (proclaim '(special *lexical-environment*))
57    
58  (eval-when (#-new-compiler compile load eval)  (eval-when (#-new-compiler compile load eval)
59  (defconstant policy-parameter-slots  (defconstant policy-parameter-slots
# Line 93  Line 93 
93    and *current-cookie*.  This option is only well defined during IR1    and *current-cookie*.  This option is only well defined during IR1
94    conversion."    conversion."
95    (let* ((form `(and ,@conditions))    (let* ((form `(and ,@conditions))
96           (n-current (gensym))           (n-cookie (gensym))
          (n-default (gensym))  
97           (binds (mapcar           (binds (mapcar
98                   #'(lambda (name)                   #'(lambda (name)
99                       (let ((slot (cdr (assoc name policy-parameter-slots))))                       (let ((slot (cdr (assoc name policy-parameter-slots))))
100                         `(,name (or (,slot ,n-current) (,slot ,n-default)))))                         `(,name (,slot ,n-cookie))))
101                   (find-used-parameters form))))                   (find-used-parameters form))))
102      (if node      `(let* ((,n-cookie (lexenv-cookie
103          (let ((n-node (gensym)))                          ,(if node
104            `(let* ((,n-node ,node)                               `(node-lexenv ,node)
105                    (,n-default (node-default-cookie ,n-node))                               *lexical-environment*)))
106                    (,n-current (node-cookie ,n-node))              ,@binds)
107                    ,@binds)         ,form)))
              ,form))  
         `(let* ((,n-default *default-cookie*)  
                 (,n-current *current-cookie*)  
                 ,@binds)  
            ,form))))  
108    
109    
110  ;;;; Source-hacking defining forms:  ;;;; Source-hacking defining forms:
# Line 159  Line 153 
153        `(progn        `(progn
154           (proclaim '(function ,fn-name (continuation continuation t) void))           (proclaim '(function ,fn-name (continuation continuation t) void))
155           (defun ,fn-name (,start-var ,cont-var ,n-form)           (defun ,fn-name (,start-var ,cont-var ,n-form)
156             (let ((,n-env *fenv*))             (let ((,n-env *lexical-environment*))
157               ,@decls               ,@decls
158               (macrolet ((error (&rest args)               (macrolet ((error (&rest args)
159                                 `(compiler-error ,@args)))                                 `(compiler-error ,@args)))
# Line 199  Line 193 
193                                                 :environment n-env)                                                 :environment n-env)
194        `(progn        `(progn
195           (defun ,fn-name (,n-form)           (defun ,fn-name (,n-form)
196             (let ((,n-env *fenv*))             (let ((,n-env *lexical-environment*))
197               ,@decls               ,@decls
198               (macrolet ((error (&rest stuff)               (macrolet ((error (&rest stuff)
199                                 (declare (ignore stuff))                                 (declare (ignore stuff))
# Line 222  Line 216 
216                            :environment n-env)                            :environment n-env)
217        `(progn        `(progn
218           (defun ,fn-name (,n-form)           (defun ,fn-name (,n-form)
219             (let ((,n-env *fenv*))             (let ((,n-env *lexical-environment*))
220               ,@decls               ,@decls
221               (macrolet ((error (&rest args)               (macrolet ((error (&rest args)
222                                 `(compiler-error ,@args)))                                 `(compiler-error ,@args)))
# Line 757  Line 751 
751  (defmacro with-ir1-environment (node &rest forms)  (defmacro with-ir1-environment (node &rest forms)
752    "With-IR1-Environment Node Form*    "With-IR1-Environment Node Form*
753    Bind the IR1 context variables so that IR1 conversion can be done after the    Bind the IR1 context variables so that IR1 conversion can be done after the
754    main conversion pass has finished.    main conversion pass has finished."
   
   Care must be taken to ensure that blocks have the correct cleanup.  New  
   blocks will initially be created with the End-Cleanup of Node's block.  This  
   is not an issue if newly created blocks are inside a new function -- it is  
   only a problem if IR1 convert or Make-Block is called directly, and not if  
   IR1-Convert-Lambda is called."  
755    (let ((n-node (gensym))    (let ((n-node (gensym))
756          (n-block (gensym))          (n-block (gensym))
757          (n-cont (gensym))          (n-cont (gensym))
758          (n-component (gensym)))          (n-component (gensym)))
759      `(let* ((,n-node ,node)      `(let* ((,n-node ,node)
760              (,n-cont (node-prev ,n-node))              (,n-component (block-component (node-block ,n-node)))
761              (,n-block (continuation-block ,n-cont))              (*lexical-environment* (node-lexenv ,n-node))
762              (,n-component (block-component ,n-block))              (*current-path* (node-source-path ,n-node)))
             (*current-cleanup* (block-end-cleanup ,n-block))  
             (*current-cookie* (node-cookie ,n-node))  
             (*default-cookie* (node-default-cookie ,n-node))  
             (*current-lambda* (block-lambda ,n-block))  
             (*current-component* ,n-component)  
             (*current-path* (node-source-path ,n-node))  
             (*current-form* nil)  
             (*fenv* ())  
             (*inlines* ())  
             (*type-restrictions* ())  
             (*venv* ())  
             (*benv* ())  
             (*tenv* ()))  
763         ,@forms)))         ,@forms)))
764    
765    
# Line 800  Line 775 
775           (*source-paths* (make-hash-table :test #'eq)))           (*source-paths* (make-hash-table :test #'eq)))
776       ,@forms))       ,@forms))
777    
778    
779    ;;; LEXENV-FIND  --  Interface
780    ;;;
781    (defmacro lexenv-find (name slot &key test)
782      "LEXENV-FIND Name Slot {Key Value}*
783      Look up Name in the lexical environment namespace designated by Slot,
784      returning the <value, T>, or <NIL, NIL> if no entry.  The :TEST keyword
785      may be used to determine the name equality predicate."
786      (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot)
787                                        *lexical-environment*)
788                                 ,@(when test `(:test ,test)))))
789        `(if ,n-res
790             (values (car ,n-res) t)
791             (values nil nil))))
792    
793    
794  ;;;; The Defprinter macro:  ;;;; The Defprinter macro:
795    
# Line 907  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 936  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 948  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.5  
changed lines
  Added in v.1.5.1.1

  ViewVC Help
Powered by ViewVC 1.1.5