Changeset 15307

Timestamp:

Apr 9, 2012, 3:41:52 AM (13 years ago)

Author:

Gary Byers

Message:

Revert to previous versions (these files were checked in accidentally
in r15306.)

Location:

trunk/source/compiler

Files:

• nx-basic.lisp (modified) (1 diff)
• nx.lisp (modified) (1 diff)
• nx0.lisp (modified) (2 diffs)
• nx1.lisp (modified) (11 diffs)

trunk/source/compiler/nx-basic.lisp

@@ -690 +690 @@
     (:format-error . "~:{~@?~%~}")
     (:program-error . "~a")
-    (: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.")))
+    (:unsure . "Nonspecific warning")))
 
 (defun report-invalid-type-compiler-warning (condition stream)

trunk/source/compiler/nx.lisp

@@ -232 +232 @@
     (:format-error . style-warning)
     (:unused . style-warning)
-    (:type-conflict . style-warning)
-    (:duplicate-binding . style-warning)))
+    (:type-conflict . style-warning)))
 
 

trunk/source/compiler/nx0.lisp

@@ -1110 +1110 @@
                (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)
@@ -1953 +1933 @@
 
 (defun nx1-whine (about &rest forms)
-  ;; 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*)))
+  (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*))
 
 (defun p2-whine (afunc about &rest forms)

trunk/source/compiler/nx1.lisp

@@ -207 +207 @@
 (defnx1 nx1-macrolet macrolet context (defs &body body)
   (let* ((old-env *nx-lexical-environment*)
-         (new-env (new-lexical-environment old-env))
-         (names ()))
+         (new-env (new-lexical-environment old-env)))
     (dolist (def defs)
       (destructuring-bind (name arglist &body mbody) def
-        (push name names)
         (push 
          (cons 
@@ -222 +220 @@
              function)))
          (lexenv.functions new-env))))
-    (nx1-check-duplicate-bindings names 'macrolet)
     (let* ((*nx-lexical-environment* new-env))
       (with-nx-declarations (pending)
@@ -238 +235 @@
         (let ((env *nx-lexical-environment*)
               (*nx-bound-vars* *nx-bound-vars*))
-          (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))
+          (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)))))
           (nx-effect-other-decls pending env)
           (nx1-env-body context body old-env))))))
@@ -1781 +1773 @@
        *nx-new-p2decls*))))
 
-(defun maybe-warn-about-shadowing-cl-function-name (funcname)
+(defun maybe-warn-about-nx1-alphatizer-binding (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)
-  (or (maybe-warn-about-shadowing-cl-function-name funcname)
-      (when (and (symbolp funcname)
-                 (gethash funcname *nx1-alphatizers*))
-        (nx1-whine :special-fbinding funcname))))
-
-
+             (gethash funcname *nx1-alphatizers*))
+    (nx1-whine :special-fbinding funcname)))
 
 (defnx1 nx1-flet flet context (defs &body forms)
@@ -1806 +1788 @@
            (pairs nil)
            (fname nil)
-           (name nil)
-           (fnames ()))
+           (name nil))
       (multiple-value-bind (body decls) (parse-body forms env nil)
         (nx-process-declarations pending decls)
@@ -1813 +1794 @@
           (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)
@@ -1835 +1815 @@
                 (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)
@@ -1895 +1874 @@
            (blockname nil)
            (fname nil)
-           (name nil)
-           (fnames ()))
+           (name nil))
       (multiple-value-bind (body decls) (parse-body forms env nil)
         (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
@@ -1904 +1882 @@
             (setq blockname funcname)
             (setq fname (nx-need-function-name funcname))
-            (push fname fnames)
             (when (consp funcname)
               (setq blockname (%cadr funcname) funcname fname))
@@ -1931 +1908 @@
         (nx-reconcile-inherited-vars funcrefs)
         (dolist (f funcrefs) (nx1-afunc-ref f))
-        (nx1-check-duplicate-bindings fnames 'labels)
         (make-acode
          (%nx1-operator labels)
@@ -2491 +2467 @@
   (nx1-progn-body context (if (or (memq 'eval when) (memq :execute when)) body)))
 
-(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))
-
-
+(defnx1 nx1-misplaced (declare) context (&rest args)
+  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
+