Index: /trunk/source/compiler/nx-basic.lisp =================================================================== --- /trunk/source/compiler/nx-basic.lisp (revision 15313) +++ /trunk/source/compiler/nx-basic.lisp (revision 15314) @@ -690,5 +690,7 @@ (:format-error . "~:{~@?~%~}") (:program-error . "~a") - (:unsure . "Nonspecific warning"))) + (:unsure . "Nonspecific warning") + (:duplicate-binding . "Multiple bindings of ~S in ~A form") + (:shadow-cl-package-definition . "Local function or macro name ~s shadows standard CL definition."))) (defun report-invalid-type-compiler-warning (condition stream) Index: /trunk/source/compiler/nx0.lisp =================================================================== --- /trunk/source/compiler/nx0.lisp (revision 15313) +++ /trunk/source/compiler/nx0.lisp (revision 15314) @@ -1110,4 +1110,24 @@ (neq (nx-var-root-nsetqs target) (cadr pair))) (push (cons var target) *nx-punted-vars*))))) + +;;; Someone might be able to come up with a case where (perhaps through +;;; use of (DECLAIM (IGNORE ...))) it might make some sense to bind +;;; the same variable more than once in a parallel binding construct. +;;; Even if that's done intentionally, there's probably some value +;;; in warning about it (and it's hard to guess whether it's done +;;; intentionally. +;;; Something like (LET* ((X 1) (X (1+ X))) ...) is well-defined (even +;;; if it's a bit unaesthetic. +;;; We error if there are duplicate required args in a lambda list, +;;; but let things like (LAMBDA (A &OPTIONAL A) ...) slide. (Those +;;; cases generally generate an unused-variable warning, so we don't + +(defun nx1-check-duplicate-bindings (syms context) + (do* () + ((null syms)) + (let* ((sym (pop syms))) + (when (member sym syms :test #'eq) + (nx1-whine :duplicate-binding (maybe-setf-name sym) context))))) + (defun nx1-punt-var (var initform) @@ -1933,10 +1953,21 @@ (defun nx1-whine (about &rest forms) - (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning) - :function-name (list *nx-cur-func-name*) - :source-note *nx-current-note* - :warning-type about - :args (or forms (list nil))) - *nx-warnings*)) + ;; Don't turn STYLE-WARNINGs generated during compilation into + ;; vanilla COMPILER-WARNINGs. + (let* ((c (if (and (eq about :program-error) + (typep (car forms) 'style-warning)) + (let* ((c (car forms))) + (with-slots (source-note function-name) c + (setq source-note *nx-current-note* + function-name (list *nx-cur-func-name*)) + c)) + (make-condition (or (cdr (assq about *compiler-whining-conditions*)) + 'compiler-warning) + :function-name (list *nx-cur-func-name*) + :source-note *nx-current-note* + :warning-type about + :args (or forms (list nil)))))) + + (push c *nx-warnings*))) (defun p2-whine (afunc about &rest forms) Index: /trunk/source/compiler/nx1.lisp =================================================================== --- /trunk/source/compiler/nx1.lisp (revision 15313) +++ /trunk/source/compiler/nx1.lisp (revision 15314) @@ -207,7 +207,9 @@ (defnx1 nx1-macrolet macrolet context (defs &body body) (let* ((old-env *nx-lexical-environment*) - (new-env (new-lexical-environment old-env))) + (new-env (new-lexical-environment old-env)) + (names ())) (dolist (def defs) (destructuring-bind (name arglist &body mbody) def + (push name names) (push (cons @@ -220,4 +222,5 @@ function))) (lexenv.functions new-env)))) + (nx1-check-duplicate-bindings names 'macrolet) (let* ((*nx-lexical-environment* new-env)) (with-nx-declarations (pending) @@ -235,12 +238,17 @@ (let ((env *nx-lexical-environment*) (*nx-bound-vars* *nx-bound-vars*)) - (dolist (def defs) - (destructuring-bind (sym expansion) def - (let* ((var (nx-new-var pending sym)) - (bits (nx-var-bits var))) - (when (%ilogbitp $vbitspecial bits) - (nx-error "SPECIAL declaration applies to symbol macro ~s" sym)) - (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits)) - (setf (var-ea var) (cons :symbol-macro expansion))))) + (collect ((vars) + (symbols)) + (dolist (def defs) + (destructuring-bind (sym expansion) def + (let* ((var (nx-new-var pending sym)) + (bits (nx-var-bits var))) + (symbols sym) + (when (%ilogbitp $vbitspecial bits) + (nx-error "SPECIAL declaration applies to symbol macro ~s" sym)) + (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits)) + (setf (var-ea var) (cons :symbol-macro expansion)) + (vars var)))) + (nx1-check-duplicate-bindings (symbols) 'symbol-macrolet)) (nx-effect-other-decls pending env) (nx1-env-body context body old-env)))))) @@ -1773,8 +1781,18 @@ *nx-new-p2decls*)))) +(defun maybe-warn-about-shadowing-cl-function-name (funcname) + (when (and (symbolp funcname) + (fboundp funcname) + (eq (symbol-package funcname) (find-package "CL"))) + (nx1-whine :shadow-cl-package-definition funcname) + t)) + (defun maybe-warn-about-nx1-alphatizer-binding (funcname) - (when (and (symbolp funcname) - (gethash funcname *nx1-alphatizers*)) - (nx1-whine :special-fbinding funcname))) + (or (maybe-warn-about-shadowing-cl-function-name funcname) + (when (and (symbolp funcname) + (gethash funcname *nx1-alphatizers*)) + (nx1-whine :special-fbinding funcname)))) + + (defnx1 nx1-flet flet context (defs &body forms) @@ -1788,5 +1806,6 @@ (pairs nil) (fname nil) - (name nil)) + (name nil) + (fnames ())) (multiple-value-bind (body decls) (parse-body forms env nil) (nx-process-declarations pending decls) @@ -1794,4 +1813,5 @@ (destructuring-bind (funcname lambda-list &body flet-function-body) def (setq fname (nx-need-function-name funcname)) + (push fname fnames) (maybe-warn-about-nx1-alphatizer-binding funcname) (multiple-value-bind (body decls) @@ -1815,4 +1835,5 @@ (push (setq name (make-symbol (symbol-name funcname))) names) (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env)))))) + (nx1-check-duplicate-bindings fnames 'flet) (let ((vars nil) (rvars nil) @@ -1874,5 +1895,6 @@ (blockname nil) (fname nil) - (name nil)) + (name nil) + (fnames ())) (multiple-value-bind (body decls) (parse-body forms env nil) (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies))) @@ -1882,4 +1904,5 @@ (setq blockname funcname) (setq fname (nx-need-function-name funcname)) + (push fname fnames) (when (consp funcname) (setq blockname (%cadr funcname) funcname fname)) @@ -1908,4 +1931,5 @@ (nx-reconcile-inherited-vars funcrefs) (dolist (f funcrefs) (nx1-afunc-ref f)) + (nx1-check-duplicate-bindings fnames 'labels) (make-acode (%nx1-operator labels) @@ -2467,5 +2491,10 @@ (nx1-progn-body context (if (or (memq 'eval when) (memq :execute when)) body))) -(defnx1 nx1-misplaced (declare) context (&rest args) - (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args))) - +(defnx1 nx1-misplaced (declare) context (&whole w &rest args) + (declare (ignore args)) + (nx-error "The DECLARE expression ~s is being treated as a form, +possibly because it's the result of macroexpansion. DECLARE expressions +can only appear in specified contexts and must be actual subexressions +of the containing forms." w)) + +