Changeset 15306


Ignore:
Timestamp:
Apr 9, 2012, 10:37:24 AM (8 years ago)
Author:
gb
Message:

DEFINE-CONDITION arranges to validate parent types as subtypes of CONDITION.
Move some condition-types around to allow this to be bootstrapped.
Fixes ticket:928.

Location:
trunk/source
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r15039 r15306  
    690690    (:format-error . "~:{~@?~%~}")
    691691    (:program-error . "~a")
    692     (:unsure . "Nonspecific warning")))
     692    (:unsure . "Nonspecific warning")
     693    (:duplicate-binding . "Multiple bindings of ~S in ~A form")
     694    (:shadow-cl-package-definition . "Local function or macro name ~s shadows standard CL definition.")))
    693695
    694696(defun report-invalid-type-compiler-warning (condition stream)
  • trunk/source/compiler/nx.lisp

    r14421 r15306  
    232232    (:format-error . style-warning)
    233233    (:unused . style-warning)
    234     (:type-conflict . style-warning)))
     234    (:type-conflict . style-warning)
     235    (:duplicate-binding . style-warning)))
    235236
    236237
  • trunk/source/compiler/nx0.lisp

    r15127 r15306  
    11101110               (neq (nx-var-root-nsetqs target) (cadr pair)))
    11111111             (push (cons var target) *nx-punted-vars*)))))
     1112
     1113;;; Someone might be able to come up with a case where (perhaps through
     1114;;; use of (DECLAIM (IGNORE ...))) it might make some sense to bind
     1115;;; the same variable more than once in a parallel binding construct.
     1116;;; Even if that's done intentionally, there's probably some value
     1117;;; in warning about it (and it's hard to guess whether it's done
     1118;;; intentionally.
     1119;;; Something like (LET* ((X 1) (X (1+ X))) ...) is well-defined (even
     1120;;; if it's a bit unaesthetic.
     1121;;; We error if there are duplicate required args in a lambda list,
     1122;;; but let things like (LAMBDA (A &OPTIONAL A) ...) slide.  (Those
     1123;;; cases generally generate an unused-variable warning, so we don't
     1124
     1125(defun nx1-check-duplicate-bindings (syms context)
     1126  (do* ()
     1127       ((null syms))
     1128    (let* ((sym (pop syms)))
     1129      (when (member sym syms :test #'eq)
     1130        (nx1-whine :duplicate-binding (maybe-setf-name sym) context)))))
     1131             
    11121132
    11131133(defun nx1-punt-var (var initform)
     
    19331953
    19341954(defun nx1-whine (about &rest forms)
    1935   (push (make-condition (or (cdr (assq about *compiler-whining-conditions*)) 'compiler-warning)
    1936                         :function-name (list *nx-cur-func-name*)
    1937                         :source-note *nx-current-note*
    1938                         :warning-type about
    1939                         :args (or forms (list nil)))
    1940         *nx-warnings*))
     1955  ;; Don't turn STYLE-WARNINGs generated during compilation into
     1956  ;; vanilla COMPILER-WARNINGs.
     1957  (let* ((c (if (and (eq about :program-error)
     1958                     (typep (car forms) 'style-warning))
     1959              (let* ((c (car forms)))
     1960                (with-slots (source-note function-name) c
     1961                  (setq source-note *nx-current-note*
     1962                        function-name (list *nx-cur-func-name*))
     1963                  c))
     1964              (make-condition (or (cdr (assq about *compiler-whining-conditions*))
     1965                                  'compiler-warning)
     1966                              :function-name (list *nx-cur-func-name*)
     1967                              :source-note *nx-current-note*
     1968                              :warning-type about
     1969                              :args (or forms (list nil))))))
     1970
     1971    (push c *nx-warnings*)))
    19411972
    19421973(defun p2-whine (afunc about &rest forms)
  • trunk/source/compiler/nx1.lisp

    r15282 r15306  
    207207(defnx1 nx1-macrolet macrolet context (defs &body body)
    208208  (let* ((old-env *nx-lexical-environment*)
    209          (new-env (new-lexical-environment old-env)))
     209         (new-env (new-lexical-environment old-env))
     210         (names ()))
    210211    (dolist (def defs)
    211212      (destructuring-bind (name arglist &body mbody) def
     213        (push name names)
    212214        (push
    213215         (cons
     
    220222             function)))
    221223         (lexenv.functions new-env))))
     224    (nx1-check-duplicate-bindings names 'macrolet)
    222225    (let* ((*nx-lexical-environment* new-env))
    223226      (with-nx-declarations (pending)
     
    235238        (let ((env *nx-lexical-environment*)
    236239              (*nx-bound-vars* *nx-bound-vars*))
    237           (dolist (def defs)
    238             (destructuring-bind (sym expansion) def
    239               (let* ((var (nx-new-var pending sym))
    240                      (bits (nx-var-bits var)))
    241                 (when (%ilogbitp $vbitspecial bits)
    242                   (nx-error "SPECIAL declaration applies to symbol macro ~s" sym))
    243                 (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits))
    244                 (setf (var-ea var) (cons :symbol-macro expansion)))))
     240          (collect ((vars)
     241                    (symbols))
     242            (dolist (def defs)
     243              (destructuring-bind (sym expansion) def
     244                (let* ((var (nx-new-var pending sym))
     245                       (bits (nx-var-bits var)))
     246                  (symbols sym)
     247                  (when (%ilogbitp $vbitspecial bits)
     248                    (nx-error "SPECIAL declaration applies to symbol macro ~s" sym))
     249                  (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits))
     250                  (setf (var-ea var) (cons :symbol-macro expansion))
     251                  (vars var))))
     252            (nx1-check-duplicate-bindings (symbols) 'symbol-macrolet))
    245253          (nx-effect-other-decls pending env)
    246254          (nx1-env-body context body old-env))))))
     
    17731781       *nx-new-p2decls*))))
    17741782
     1783(defun maybe-warn-about-shadowing-cl-function-name (funcname)
     1784  (when (and (symbolp funcname)
     1785             (fboundp funcname)
     1786             (eq (symbol-package funcname) (find-package "CL")))
     1787    (nx1-whine :shadow-cl-package-definition funcname)
     1788    t))
     1789
    17751790(defun maybe-warn-about-nx1-alphatizer-binding (funcname)
    1776   (when (and (symbolp funcname)
    1777              (gethash funcname *nx1-alphatizers*))
    1778     (nx1-whine :special-fbinding funcname)))
     1791  (or (maybe-warn-about-shadowing-cl-function-name funcname)
     1792      (when (and (symbolp funcname)
     1793                 (gethash funcname *nx1-alphatizers*))
     1794        (nx1-whine :special-fbinding funcname))))
     1795
     1796
    17791797
    17801798(defnx1 nx1-flet flet context (defs &body forms)
     
    17881806           (pairs nil)
    17891807           (fname nil)
    1790            (name nil))
     1808           (name nil)
     1809           (fnames ()))
    17911810      (multiple-value-bind (body decls) (parse-body forms env nil)
    17921811        (nx-process-declarations pending decls)
     
    17941813          (destructuring-bind (funcname lambda-list &body flet-function-body) def
    17951814            (setq fname (nx-need-function-name funcname))
     1815            (push fname fnames)
    17961816            (maybe-warn-about-nx1-alphatizer-binding funcname)
    17971817            (multiple-value-bind (body decls)
     
    18151835                (push (setq name (make-symbol (symbol-name funcname))) names)
    18161836                (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env))))))
     1837        (nx1-check-duplicate-bindings fnames 'flet)
    18171838        (let ((vars nil)
    18181839              (rvars nil)
     
    18741895           (blockname nil)
    18751896           (fname nil)
    1876            (name nil))
     1897           (name nil)
     1898           (fnames ()))
    18771899      (multiple-value-bind (body decls) (parse-body forms env nil)
    18781900        (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
     
    18821904            (setq blockname funcname)
    18831905            (setq fname (nx-need-function-name funcname))
     1906            (push fname fnames)
    18841907            (when (consp funcname)
    18851908              (setq blockname (%cadr funcname) funcname fname))
     
    19081931        (nx-reconcile-inherited-vars funcrefs)
    19091932        (dolist (f funcrefs) (nx1-afunc-ref f))
     1933        (nx1-check-duplicate-bindings fnames 'labels)
    19101934        (make-acode
    19111935         (%nx1-operator labels)
     
    24672491  (nx1-progn-body context (if (or (memq 'eval when) (memq :execute when)) body)))
    24682492
    2469 (defnx1 nx1-misplaced (declare) context (&rest args)
    2470   (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
    2471 
     2493(defnx1 nx1-misplaced (declare) context (&whole w &rest args)
     2494  (declare (ignore args))
     2495  (nx-error "The DECLARE expression ~s is being treated as a form,
     2496possibly because it's the result of macroexpansion. DECLARE expressions
     2497can only appear in specified contexts and must be actual subexressions
     2498of the containing forms." w))
     2499
     2500
  • trunk/source/level-1/l1-error-system.lisp

    r15303 r15306  
    3030(defclass serious-condition (condition) ())
    3131(defclass error (serious-condition) ())
     32
     33(defun check-condition-superclasses (cond supers)
     34  (let* ((bad nil))
     35    (dolist (s supers)
     36      (let* ((class (find-class s nil)))
     37        (unless (and class (subtypep class 'condition))
     38          (push s bad))))
     39    (when bad
     40      (error "Parent types of condition named ~s being defined aren't known subtypes of CONDITION: ~s." cond bad))))
     41
    3242
    3343(define-condition simple-condition (condition)
     
    607617                 (format stream "Fork failed in ~s: ~a. " proc (if (eql code -1) "random lisp error" (%strerror code))))))))
    608618   
    609                          
     619
     620(define-condition simple-reader-error (reader-error simple-error) ()
     621  (:report (lambda (c output-stream)
     622             (format output-stream "Reader error ~a:~%~?"
     623                     (stream-error-context c)
     624                     (simple-condition-format-control c)
     625                     (simple-condition-format-arguments c)))))
     626
     627;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
     628;;; compiler warnings can be emitted as appropriate.
     629;;;
     630(define-condition parse-unknown-type (condition)
     631  ((specifier :reader parse-unknown-type-specifier :initarg :specifier))
     632  (:report (lambda (c s) (print-unreadable-object (c s :type t)
     633                           (format s "unknown type ~A" (parse-unknown-type-specifier c))))))
     634
    610635(defun restartp (thing)
    611636  (istruct-typep thing 'restart))
  • trunk/source/level-1/l1-typesys.lisp

    r15093 r15306  
    2222
    2323
    24 ;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
    25 ;;; compiler warnings can be emitted as appropriate.
    26 ;;;
    27 (define-condition parse-unknown-type (condition)
    28   ((specifier :reader parse-unknown-type-specifier :initarg :specifier))
    29   (:report (lambda (c s) (print-unreadable-object (c s :type t)
    30                            (format s "unknown type ~A" (parse-unknown-type-specifier c))))))
    3124
    3225(defun parse-lambda-list (list)
  • trunk/source/lib/macros.lisp

    r15302 r15306  
    22662266      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
    22672267    `(progn
    2268        (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
    2269        ,@reporter
    2270        ',name)))
     2268      ,@(when supers `((eval-when (:load-toplevel :execute)
     2269                         (check-condition-superclasses ',name ',supers))))
     2270      (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
     2271      ,@reporter
     2272      ',name)))
    22712273
    22722274(defmacro with-condition-restarts (&environment env condition restarts &body body)
  • trunk/source/lib/read.lisp

    r13591 r15306  
    2020
    2121                         
    22 (define-condition simple-reader-error (reader-error simple-error) ()
    23   (:report (lambda (c output-stream)
    24              (format output-stream "Reader error ~a:~%~?"
    25                      (stream-error-context c)
    26                      (simple-condition-format-control c)
    27                      (simple-condition-format-arguments c)))))
     22
    2823
    2924(defun signal-reader-error (input-stream format-string &rest format-args)
Note: See TracChangeset for help on using the changeset viewer.