[Openmcl-cvs-notifications] r15307 - in /trunk/source/compiler: nx-basic.lisp nx.lisp nx0.lisp nx1.lisp
gb at clozure.com
gb at clozure.com
Mon Apr 9 05:41:53 CDT 2012
Author: gb
Date: Mon Apr 9 05:41:52 2012
New Revision: 15307
Log:
Revert to previous versions (these files were checked in accidentally
in r15306.)
Modified:
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx.lisp
trunk/source/compiler/nx0.lisp
trunk/source/compiler/nx1.lisp
Modified: trunk/source/compiler/nx-basic.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx-basic.lisp (original)
+++ trunk/source/compiler/nx-basic.lisp Mon Apr 9 05:41:52 2012
@@ -688,9 +688,7 @@
(:duplicate-definition . report-compile-time-duplicate-definition)
(: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 shad=
ows standard CL definition.")))
+ (:unsure . "Nonspecific warning")))
=
(defun report-invalid-type-compiler-warning (condition stream)
(destructuring-bind (type &optional why) (compiler-warning-args conditio=
n)
Modified: trunk/source/compiler/nx.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx.lisp (original)
+++ trunk/source/compiler/nx.lisp Mon Apr 9 05:41:52 2012
@@ -231,8 +231,7 @@
(:lambda . style-warning)
(:format-error . style-warning)
(:unused . style-warning)
- (:type-conflict . style-warning)
- (:duplicate-binding . style-warning)))
+ (:type-conflict . style-warning)))
=
=
=
Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Mon Apr 9 05:41:52 2012
@@ -1109,26 +1109,6 @@
target-bits)) =
(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)
(let* ((bits (nx-var-bits var))
@@ -1952,23 +1932,12 @@
=
=
(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-condi=
tions*))
- '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)
(let* ((warning (make-condition (or (cdr (assq about *compiler-whining-c=
onditions*)) 'compiler-warning)
Modified: trunk/source/compiler/nx1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx1.lisp (original)
+++ trunk/source/compiler/nx1.lisp Mon Apr 9 05:41:52 2012
@@ -206,11 +206,9 @@
;;; vice null environment. May be meaningless ...
(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 =
name
@@ -221,7 +219,6 @@
(setq *nx-warnings* (append *nx-warnings* warnings))
function)))
(lexenv.functions new-env))))
- (nx1-check-duplicate-bindings names 'macrolet)
(let* ((*nx-lexical-environment* new-env))
(with-nx-declarations (pending)
(multiple-value-bind (body decls) (parse-body body new-env)
@@ -237,19 +234,14 @@
(nx-process-declarations pending decls)
(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))))))
=
@@ -1780,20 +1772,10 @@
(nx1-env-body context body old-env)
*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)
(with-nx-declarations (pending)
@@ -1805,14 +1787,12 @@
(funcs nil)
(pairs nil)
(fname nil)
- (name nil)
- (fnames ()))
+ (name nil))
(multiple-value-bind (body decls) (parse-body forms env nil)
(nx-process-declarations pending decls)
(dolist (def defs (setq names (nreverse names) funcs (nreverse fun=
cs)))
(destructuring-bind (funcname lambda-list &body flet-function-bo=
dy) def
(setq fname (nx-need-function-name funcname))
- (push fname fnames)
(maybe-warn-about-nx1-alphatizer-binding funcname)
(multiple-value-bind (body decls)
(parse-body flet-function-body env)
@@ -1834,7 +1814,6 @@
(setq funcname fname))
(push (setq name (make-symbol (symbol-name funcname))) nam=
es)
(push (cons funcname (cons 'function (cons func name))) (l=
exenv.functions new-env))))))
- (nx1-check-duplicate-bindings fnames 'flet)
(let ((vars nil)
(rvars nil)
(rfuncs nil))
@@ -1894,8 +1873,7 @@
(vars nil)
(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 bo=
dies)))
(destructuring-bind (funcname lambda-list &body labels-function-=
body) def
@@ -1903,7 +1881,6 @@
(push (setq func (make-afunc)) funcs)
(setq blockname funcname)
(setq fname (nx-need-function-name funcname))
- (push fname fnames)
(when (consp funcname)
(setq blockname (%cadr funcname) funcname fname))
(let ((var (nx-new-var pending (setq name (make-symbol (symbol=
-name funcname))))))
@@ -1930,7 +1907,6 @@
(setq body (nx1-env-body context body old-env))
(nx-reconcile-inherited-vars funcrefs)
(dolist (f funcrefs) (nx1-afunc-ref f))
- (nx1-check-duplicate-bindings fnames 'labels)
(make-acode
(%nx1-operator labels)
(nreverse vars)
@@ -2490,11 +2466,6 @@
(defnx1 nx1-eval-when eval-when context (when &body body)
(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)))
+
More information about the Openmcl-cvs-notifications
mailing list