Changeset 12534


Ignore:
Timestamp:
Aug 5, 2009, 11:51:47 PM (11 years ago)
Author:
gz
Message:

Make parse-macro bind &whole/&environment vars normally, so can tell whether used or not

Location:
branches/working-0711/ccl
Files:
4 edited

Legend:

Unmodified
Added
Removed

  • branches/working-0711/ccl/compiler/nx1.lisp

    r12515 r12534  
    263263  (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2))
    264264
    265 (defnx1 nx1-logbitp ((logbitp)) (&whole w bitnum int &environment env)
     265(defnx1 nx1-logbitp ((logbitp)) (bitnum int &environment env)
    266266  (if (and (nx-form-typep bitnum
    267267                          (target-word-size-case (32 '(integer 0 29))
    … …  
    294294           body)))))
    295295
    296 (defnx1 nx1-%new-ptr (%new-ptr) (&whole whole size &optional clear-p)
     296(defnx1 nx1-%new-ptr (%new-ptr) (size &optional clear-p)
    297297  (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p)))
    298298
    … …  
    370370;;; This has to be ultra-bizarre because %schar is a macro.
    371371;;; %schar shouldn't be a macro.
    372 (defnx1 nx1-%schar ((%schar)) (&whole w arg idx &environment env)
     372(defnx1 nx1-%schar ((%schar)) (arg idx &environment env)
    373373  (let* ((arg (nx-transform arg env))
    374374         (idx (nx-transform idx env))
    … …  
    381381                 (schar ,argvar ,idxvar)) env)))
    382382       
    383 (defnx1 nx1-%scharcode ((%scharcode)) (arg idx &environment env)
     383(defnx1 nx1-%scharcode ((%scharcode)) (arg idx)
    384384  (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx)))
    385385
    … …  
    536536              (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value)))
    537537
    538 (defnx1 nx1-+ ((+-2)) (&whole whole &environment env num1 num2)
     538(defnx1 nx1-+ ((+-2)) (&environment env num1 num2)
    539539  (let* ((f1 (nx1-form num1))
    540540         (f2 (nx1-form num2)))
    … …  
    576576
    577577
    578 (defnx1 nx1-*-2 ((*-2)) (&whole whole &environment env num1 num2)
     578(defnx1 nx1-*-2 ((*-2)) (&environment env num1 num2)
    579579  (if (nx-binary-fixnum-op-p num1 num2 env)
    580580    (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env))
    … …  
    587587        (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env))))))
    588588
    589 (defnx1 nx1-%negate ((%negate)) (&whole whole num &environment env)
     589(defnx1 nx1-%negate ((%negate)) (num &environment env)
    590590  (if (nx-form-typep num 'fixnum env)
    591591    (if (subtypep *nx-form-type* 'fixnum)
    … …  
    595595
    596596       
    597 (defnx1 nx1--2 ((--2)) (&whole whole &environment env num0 num1)       
     597(defnx1 nx1--2 ((--2)) (&environment env num0 num1)       
    598598  (if (nx-binary-fixnum-op-p num0 num1 env t)
    599599    (let* ((f0 (nx1-form num0))
    … …  
    633633
    634634
    635 (defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&whole whole &environment env num1 num2)
     635(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&environment env num1 num2)
    636636  (let* ((op *nx-sfname*)
    637637         (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
    … …  
    683683                  (nx1-form num2)))))
    684684
    685 (defnx1 nx1-num= ((=-2) (/=-2)) (&whole whole &environment env num1 num2 )
     685(defnx1 nx1-num= ((=-2) (/=-2)) (&environment env num1 num2 )
    686686  (let* ((op *nx-sfname*)
    687687         (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
    … …  
    735735             
    736736
    737 (defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value &environment env)
     737(defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value)
    738738  (make-acode (%nx1-operator uvset)
    739739              (nx1-form vector)
    … …  
    741741              (nx1-form value)))
    742742
    743 (defnx1 nx1-set-schar ((set-schar)) (&whole w s i v &environment env)
     743(defnx1 nx1-set-schar ((set-schar)) (s i v)
    744744  (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v)))
    745745
    … …  
    761761              env)))
    762762
    763 (defnx1 nx1-%set-scharcode ((%set-scharcode)) (&whole w s i v)
     763(defnx1 nx1-%set-scharcode ((%set-scharcode)) (s i v)
    764764    (make-acode (%nx1-operator %set-scharcode)
    765765                (nx1-form s)
    … …  
    18121812
    18131813(defnx1 nx1-%set-float ((%set-single-float)
    1814                         (%set-double-float)) (&whole whole ptrform offset &optional (newval nil newval-p))
     1814                        (%set-double-float)) (ptrform offset &optional (newval nil newval-p))
    18151815  (unless newval-p
    18161816    (setq newval offset

  • branches/working-0711/ccl/compiler/optimizers.lisp

    r12339 r12534  
    326326      call)))
    327327
    328 (define-compiler-macro apply  (&whole call &environment env fn arg0 &rest args)
     328(define-compiler-macro apply  (&whole call fn arg0 &rest args)
    329329  ;; Special-case (apply #'make-instance 'name ...)
    330330  ;; Might be good to make this a little more general, e.g., there
    … …  
    481481
    482482
    483 (define-compiler-macro cons (&whole call &environment env x y &aux dcall ddcall)
     483(define-compiler-macro cons (&whole call x y &aux dcall ddcall)
    484484   (if (consp (setq dcall y))
    485485     (cond
    … …  
    527527        call)))
    528528
    529 (define-compiler-macro dpb (&whole call &environment env value byte integer)
     529(define-compiler-macro dpb (&whole call value byte integer)
    530530  (cond ((and (integerp byte) (> byte 0))
    531531         (if (integerp value)
    … …  
    558558      call)))
    559559
    560 (define-compiler-macro %ilsr (&whole call &environment env shift value)
     560(define-compiler-macro %ilsr (&whole call shift value)
    561561  (if (eql shift 0)
    562562    value
    … …  
    608608    `(locally ,@body)))
    609609
    610 (define-compiler-macro list* (&whole call &environment env &rest rest  &aux (n (list-length rest)) last)
     610(define-compiler-macro list* (&whole call &rest rest  &aux (n (list-length rest)) last)
    611611  (cond ((%izerop n) nil)
    612612        ((null (setq last (%car (last call))))
    … …  
    870870    call))
    871871
    872 (define-compiler-macro memq (&whole call &environment env item list)
     872(define-compiler-macro memq (item list)
    873873  ;;(memq x '(y)) => (if (eq x 'y) '(y))
    874874  ;;Would it be worth making a two elt list into an OR?  Maybe if
    … …  
    896896  (some-xx-transform call env))
    897897
    898 (define-compiler-macro nth  (&whole call &environment env count list)
     898(define-compiler-macro nth  (count list)
    899899   (if (and (fixnump count)
    900900            (%i>= count 0)
    … …  
    903903     `(car (nthcdr ,count ,list))))
    904904
    905 (define-compiler-macro nthcdr (&whole call &environment env count list)
     905(define-compiler-macro nthcdr (count list)
    906906  (if (and (fixnump count)
    907907           (%i>= count 0)
    … …  
    10251025;;; expand find-if and find-if-not
    10261026
    1027 (define-compiler-macro find-if (&whole call &environment env
    1028                                        test sequence &rest keys)
     1027(define-compiler-macro find-if (test sequence &rest keys)
    10291028  `(find ,test ,sequence
    10301029        :test #'funcall
    10311030        ,@keys))
    10321031
    1033 (define-compiler-macro find-if-not (&whole call &environment env
    1034                                            test sequence &rest keys)
     1032(define-compiler-macro find-if-not (test sequence &rest keys)
    10351033  `(find ,test ,sequence
    10361034        :test-not #'funcall
    … …  
    10771075;;; expand position-if and position-if-not
    10781076
    1079 (define-compiler-macro position-if (&whole call &environment env
    1080                                            test sequence &rest keys)
     1077(define-compiler-macro position-if (test sequence &rest keys)
    10811078  `(position ,test ,sequence
    10821079             :test #'funcall
    10831080             ,@keys))
    10841081
    1085 (define-compiler-macro position-if-not (&whole call &environment env
    1086                                                test sequence &rest keys)
     1082(define-compiler-macro position-if-not (test sequence &rest keys)
    10871083  `(position ,test ,sequence
    10881084             :test-not #'funcall
    … …  
    12141210      `(/=-2 ,n0 ,n1))))
    12151211
    1216 (define-compiler-macro + (&whole w  &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)
     1212(define-compiler-macro + (&optional (n0 nil n0p) (n1 nil n1p) &rest more)
    12171213  (if more
    12181214    `(+ (+-2 ,n0 ,n1) ,@more)
    … …  
    12231219        0))))
    12241220
    1225 (define-compiler-macro - (&whole w &environment env n0 &optional (n1 nil n1p) &rest more)
     1221(define-compiler-macro - (n0 &optional (n1 nil n1p) &rest more)
    12261222  (if more
    12271223    `(- (--2 ,n0 ,n1) ,@more)
    … …  
    18741870
    18751871
    1876 (define-compiler-macro make-sequence (&whole call &environment env typespec len &rest keys &key initial-element)
     1872(define-compiler-macro make-sequence (&whole call typespec len &rest keys &key initial-element)
    18771873  (declare (ignore typespec len keys initial-element))
    18781874  call)
    … …  
    20332029
    20342030
    2035 (define-compiler-macro sbit (&environment env &whole call v &optional sub0 &rest others)
     2031(define-compiler-macro sbit (&whole call v &optional sub0 &rest others)
    20362032  (if (and sub0 (null others))
    20372033    `(aref (the simple-bit-vector ,v) ,sub0)
    20382034    call))
    20392035
    2040 (define-compiler-macro %sbitset (&environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
     2036(define-compiler-macro %sbitset (&whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)
    20412037  (if (and newval-p (not newval-was-really-sub1) )
    20422038    `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval)
    … …  
    22962292    call))
    22972293
    2298 (define-compiler-macro instance-slots (&whole w instance &environment env)
     2294(define-compiler-macro instance-slots (instance &environment env)
    22992295  (if (and (nx-form-constant-p instance env)
    23002296           (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance)))
    … …  
    23562352        (and (integerp ,val) (not (< ,val 0)))))))
    23572353
    2358 (define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv  &environment env)
     2354(define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv)
    23592355  (if (and (consp t1)
    23602356           (consp (cdr t1))
    … …  
    23682364
    23692365
    2370 (define-compiler-macro string-equal (&whole w s1 s2 &rest keys)
     2366(define-compiler-macro string-equal (s1 s2 &rest keys)
    23712367  (if (null keys)
    23722368    `(%fixed-string-equal ,s1 ,s2)
    … …  
    24542450    w))
    24552451       
    2456 (define-compiler-macro %char-code-upcase (&whole w code &environment env)
     2452(define-compiler-macro %char-code-upcase (code)
    24572453  (if (typep code '(mod #x110000))
    24582454    (%char-code-upcase code)
    24592455    `(%char-code-case-fold ,code *lower-to-upper*)))
    24602456
    2461 (define-compiler-macro %char-code-downcase (&whole w code &environment env)
     2457(define-compiler-macro %char-code-downcase (code)
    24622458  (if (typep code '(mod #x110000))
    24632459    (%char-code-downcase code)

  • branches/working-0711/ccl/lib/level-2.lisp

    r11821 r12534  
    4949; that have been scarfed out of a macro-like lambda list.
    5050; The returned value is supposed to be suitable for splicing ...
     51#+not-used
    5152(defun hoist-special-decls (sym decls)
    5253  (when sym
    … …  
    6566    (error "Invalid lambda list ~s" arglist))
    6667  (multiple-value-bind (lambda-list whole environment)
    67                        (normalize-lambda-list arglist t t)
     68      (normalize-lambda-list arglist t t)
    6869    (multiple-value-bind (body local-decs doc)
    69                          (parse-body body env t)
    70       (unless whole (setq whole (gensym)))
    71       (unless environment (setq environment (gensym)))
    72       (multiple-value-bind (bindings binding-decls)
    73           (%destructure-lambda-list lambda-list whole nil nil
    74                                     :cdr-p t
    75                                     :whole-p nil
    76                                     :use-whole-var t
    77                                     :default-initial-value default-initial-value)
    78         (values
    79          `(lambda (,whole ,environment)
    80            (declare (ignorable ,environment))
    81            ,@(hoist-special-decls whole local-decs)
    82            ,@(hoist-special-decls environment local-decs)
    83            (block ,name
    84              (let* ,(nreverse bindings)
    85                ,@(when binding-decls `((declare ,@binding-decls)))
    86                ,@local-decs
    87                ,@body)))
    88        doc)))))
     70        (parse-body body env t)
     71      (let ((whole-var (gensym "WHOLE"))
     72            (env-var (gensym "ENVIRONMENT")))
     73        (multiple-value-bind (bindings binding-decls)
     74            (%destructure-lambda-list lambda-list whole-var nil nil
     75                                      :cdr-p t
     76                                      :whole-p nil
     77                                      :use-whole-var t
     78                                      :default-initial-value default-initial-value)
     79          (when environment
     80            (setq bindings (nconc bindings (list `(,environment ,env-var)))))
     81          (when whole
     82            (setq bindings (nconc bindings (list `(,whole ,whole-var)))))
     83          (values
     84            `(lambda (,whole-var ,env-var)
     85               (declare (ignorable ,whole-var ,env-var))
     86               (block ,name
     87                 (let* ,(nreverse bindings)
     88                   ,@(when binding-decls `((declare ,@binding-decls)))
     89                   ,@local-decs
     90                   ,@body)))
     91            doc))))))
    8992
    9093

  • branches/working-0711/ccl/lib/macros.lisp

    r12408 r12534  
    761761
    762762
    763 (defmacro defloadvar (&environment env var value &optional doc)
     763(defmacro defloadvar (var value &optional doc)
    764764  `(progn
    765765     (defstaticvar ,var ,nil ,@(if doc `(,doc)))
    … …  
    12631263           (svref ,vtemp ,itemp)))))
    12641264
    1265 (defmacro %svset (v i new &environment env)
     1265(defmacro %svset (v i new)
    12661266  (let* ((vtemp (make-symbol "VECTOR"))
    12671267         (itemp (make-symbol "INDEX"))
    … …  
    27512751
    27522752
    2753 (defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env)
     2753(defmacro with-hash-table-iterator ((mname hash-table) &body body)
    27542754  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
    27552755   provides a method of manually looping over the elements of a hash-table.
Note: See TracChangeset for help on using the changeset viewer.