Changeset 9163


Ignore:
Timestamp:
Apr 15, 2008, 6:46:46 PM (12 years ago)
Author:
gz
Message:
  • Catch PROGRAM-ERROR's and WARNING's signalled during compilation, and

turn them into compiler warnings. In view of this, use compiler-bug instead
of nx-error in more places, and make more macros use signal-program-error
rather than just error.

  • Do not inline local function if something in the function seems wrong.
  • make CCL:TEST-CCL svn up the tests by default, use :update nil to disable.
Location:
trunk/source
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/PPC/ppc2.lisp

    r9104 r9163  
    20192019                          (eql (hard-regspec-value unscaled-idx) ppc::arg_y)
    20202020                          (eql (hard-regspec-value val-reg) ppc::arg_z))
    2021                (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
     2021               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
    20222022             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
    20232023            (is-node
     
    50035003                (! unbind-interrupt-level-inline)
    50045004                (! unbind-interrupt-level)))
    5005             (nx-error "unknown payback token ~s" r)))))))
     5005            (compiler-bug "unknown payback token ~s" r)))))))
    50065006
    50075007(defun ppc2-spread-lambda-list (seg listform whole req opt rest keys
  • trunk/source/compiler/X86/x862.lisp

    r9103 r9163  
    21672167                          (eql (hard-regspec-value unscaled-idx) x8664::arg_y)
    21682168                          (eql (hard-regspec-value val-reg) x8664::arg_z))
    2169                (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
     2169               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
    21702170             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
    21712171            (is-node
     
    50285028                  (! unbind-interrupt-level-inline))
    50295029                (! unbind-interrupt-level)))
    5030             (nx-error "unknown payback token ~s" r)))))))
     5030            (compiler-bug "unknown payback token ~s" r)))))))
    50315031
    50325032(defun x862-spread-lambda-list (seg listform whole req opt rest keys
  • trunk/source/compiler/nx-basic.lisp

    r8861 r9163  
    488488            (ecase (compiler-warning-warning-type condition)       
    489489              (:global-mismatch "the current global definition of ~s")
    490               (:environment-mismatch "the definition of ~s visible in the current compilation unit")
     490              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
    491491              (:lexical-mismatch "the lexically visible definition of ~s"))
    492492            callee)))
    493 
    494493
    495494(defparameter *compiler-warning-formats*
    496495  '((:special . "Undeclared free variable ~S")
    497496    (:unused . "Unused lexical variable ~S")
    498     (:ignore . "Variable ~S not ignored")
     497    (:ignore . "Variable ~S not ignored.")
    499498    (:undefined-function . "Undefined function ~S")
    500499    (:unknown-declaration . "Unknown declaration ~S")
    501500    (:unknown-type-declaration . "Unknown type ~S")
    502     (:macro-used-before-definition . "Macro function ~S was used before it was defined")
     501    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
    503502    (:unsettable . "Shouldn't assign to variable ~S")
    504503    (:global-mismatch . report-compile-time-argument-mismatch)
     
    507506    (:type . "Type declarations violated in ~S")
    508507    (:type-conflict . "Conflicting type declarations for ~S")
    509     (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined")
     508    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    510509    (:lambda . "Suspicious lambda-list: ~s")
    511     (:result-ignored . "Function result ignored in call to ~s")))
     510    (:result-ignored . "Function result ignored in call to ~s")
     511    (:program-error . "~a")))
     512
    512513
    513514(defun report-compiler-warning (condition stream)
     
    520521      (apply #'format stream format-string (compiler-warning-args condition))
    521522      (funcall format-string condition stream))
    522     (format stream ".")
     523    ;(format stream ".")
    523524    (let ((nrefs (compiler-warning-nrefs condition)))
    524525      (when (and nrefs (neq nrefs 1))
  • trunk/source/compiler/nx0.lisp

    r9059 r9163  
    12551255                                (%i+ (%i- boundtocount 1) varcount)))))))))
    12561256
     1257;; Home-baked handler-case replacement.  About 10 times as fast as full handler-case.
     1258;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
     1259;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM X (INCF S))))))) took 57,485
     1260;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))) took 168,947
     1261(defmacro with-program-error-handler (handler &body body)
     1262  (let ((tag (gensym)))
     1263    `(block ,tag
     1264       (,handler (catch 'program-error-handler (return-from ,tag (progn ,@body)))))))
     1265
    12571266(defun nx1-compile-lambda (name lambda-form &optional
    12581267                                 (p (make-afunc))
     
    13071316    (if (%non-empty-environment-p *nx-lexical-environment*)
    13081317      (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p)))))
    1309     (multiple-value-bind (body decls)
    1310                          (parse-body (%cddr lambda-form) *nx-lexical-environment* t)
    1311       (setf (afunc-lambdaform p) lambda-form)
    1312       (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
    1313       (nx1-transitively-punt-bindings *nx-punted-vars*)
    1314       (setf (afunc-blocks p) *nx-blocks*)
    1315       (setf (afunc-tags p) *nx-tags*)
    1316       (setf (afunc-inner-functions p) *nx-inner-functions*)
    1317       (setf (afunc-all-vars p) *nx-all-vars*)
    1318       (setf (afunc-vcells p) *nx1-vcells*)
    1319       (setf (afunc-fcells p) *nx1-fcells*)
    1320       (let* ((warnings (merge-compiler-warnings *nx-warnings*))
    1321              (name *nx-cur-func-name*))       
    1322         (dolist (inner *nx-inner-functions*)
    1323           (dolist (w (afunc-warnings inner))
    1324             (push name (compiler-warning-function-name w))
    1325             (push w warnings)))
    1326         (setf (afunc-warnings p) warnings))
    1327       p)))
     1318
     1319    (setf (afunc-lambdaform p) lambda-form)
     1320    (with-program-error-handler
     1321        (lambda (c)
     1322          (setf (afunc-acode p) (nx1-lambda () `((error ',c)) nil)))
     1323      (handler-bind ((warning (lambda (c)
     1324                                (nx1-whine :program-error c)
     1325                                (muffle-warning c)))
     1326                     (program-error (lambda (c)
     1327                                      (when (typep c 'compile-time-program-error)
     1328                                        (setq c (make-condition 'simple-program-error
     1329                                                  :format-control (simple-condition-format-control c)
     1330                                                  :format-arguments (simple-condition-format-arguments c))))
     1331                                      (nx1-whine :program-error c)
     1332                                      (throw 'program-error-handler c))))
     1333        (multiple-value-bind (body decls)
     1334            (with-program-error-handler (lambda (c) `(error ',c))
     1335              (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
     1336          (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
     1337
     1338    (nx1-transitively-punt-bindings *nx-punted-vars*)
     1339    (setf (afunc-blocks p) *nx-blocks*)
     1340    (setf (afunc-tags p) *nx-tags*)
     1341    (setf (afunc-inner-functions p) *nx-inner-functions*)
     1342    (setf (afunc-all-vars p) *nx-all-vars*)
     1343    (setf (afunc-vcells p) *nx1-vcells*)
     1344    (setf (afunc-fcells p) *nx1-fcells*)
     1345    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
     1346           (name *nx-cur-func-name*))       
     1347      (dolist (inner *nx-inner-functions*)
     1348        (dolist (w (afunc-warnings inner))
     1349          (push name (compiler-warning-function-name w))
     1350          (push w warnings)))
     1351      (setf (afunc-warnings p) warnings))
     1352    p))
    13281353
    13291354(defun method-lambda-p (form)
     
    15911616
    15921617(defun nx1-typed-form (original env)
    1593   (nx1-transformed-form (nx-transform original env) env))
     1618  (let ((form (with-program-error-handler
     1619                  (lambda (c)
     1620                    (nx-transform `(error ',c) env))
     1621                (nx-transform original env))))
     1622    (nx1-transformed-form form env)))
    15941623
    15951624(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
     
    18011830
    18021831(defun nx1-typed-call (sym args)
    1803   (let ((type (nx1-call-result-type sym args))
    1804         (form (nx1-call sym args)))
    1805     (if (eq type t)
    1806       form
    1807       (list (%nx1-operator typed-form) type form))))
     1832  (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
     1833    (let ((form (nx1-call sym args nil nil errors-p)))
     1834      (if (eq type t)
     1835        form
     1836        (list (%nx1-operator typed-form) type form)))))
    18081837
    18091838;;; Wimpy.
     
    18131842         (lexenv-def nil)
    18141843         (defenv-def nil)
    1815          (somedef nil))
     1844         (somedef nil)
     1845         (whined nil))
    18161846    (when (and sym
    18171847               (symbolp sym)
     
    18231853      (if args-p
    18241854        (nx1-whine :undefined-function sym args spread-p)
    1825         (nx1-whine :undefined-function sym)))
     1855        (nx1-whine :undefined-function sym))
     1856      (setq whined t))
    18261857    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
    18271858      (multiple-value-bind (deftype  reason)
    18281859          (nx1-check-call-args somedef args spread-p)
    18291860        (when deftype
    1830           (nx1-whine deftype sym reason args spread-p))))
    1831     (nx-target-type *nx-form-type*)))
     1861          (nx1-whine deftype sym reason args spread-p)
     1862          (setq whined t))))
     1863    (values (nx-target-type *nx-form-type*) whined)))
    18321864
    18331865(defun find-ftype-decl (sym env)
     
    19431975;;; If "sym" is an expression (not a symbol which names a function),
    19441976;;; the caller has already alphatized it.
    1945 (defun nx1-call (sym args &optional spread-p global-only)
     1977(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
    19461978  (nx1-verify-length args 0 nil)
    19471979  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
     
    19541986        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
    19551987      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
    1956         (or (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*)
     1988        (or (and (not inhibit-inline)
     1989                 (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
    19571990            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
    19581991              (when (eq 'macro (car info))
     
    19782011  (if (and (or (null spread-p) (eq (length args) 1)))
    19792012    (if (and token (not (memq token *nx-inline-expansions*)))
    1980       (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
    1981              (lambda-list (cadr lambda-form))
    1982              (body (cddr lambda-form))
    1983              (new-env (new-lexical-environment env)))
    1984         (setf (lexenv.mdecls new-env)
     2013      (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
     2014        (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
     2015               (lambda-list (cadr lambda-form))
     2016               (body (cddr lambda-form))
     2017               (new-env (new-lexical-environment env)))
     2018          (setf (lexenv.mdecls new-env)
    19852019                `((speed . ,(speed-optimize-quantity old-env))
    1986                            (space . ,(space-optimize-quantity old-env))
    1987                            (safety . ,(space-optimize-quantity old-env))
    1988                            (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
    1989                            (debug . ,(debug-optimize-quantity old-env))))
    1990         (if spread-p
    1991           (nx1-destructure lambda-list (car args) nil nil body new-env)
    1992           (nx1-lambda-bind lambda-list args body new-env))))))
     2020                  (space . ,(space-optimize-quantity old-env))
     2021                  (safety . ,(space-optimize-quantity old-env))
     2022                  (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
     2023                  (debug . ,(debug-optimize-quantity old-env))))
     2024          (if spread-p
     2025            (nx1-destructure lambda-list (car args) nil nil body new-env)
     2026            (nx1-lambda-bind lambda-list args body new-env)))))))
    19932027             
    19942028; note that regforms are reversed: arg_z is always in the car
  • trunk/source/lib/compile-ccl.lisp

    r9155 r9163  
    603603  (unless (and (find-package "REGRESSION-TEST") (not force))
    604604    (if (probe-file "ccl:tests;ansi-tests;")
    605       (when full
     605      (when update
    606606        (cwd "ccl:tests;")
    607607        (run-program "svn" '("update")))
     
    647647      (load "ccl:tests;ansi-tests;ccl.lsp"))))
    648648
    649 (defun test-ccl (&key force full verbose (catch-errors t))
     649(defun test-ccl (&key force (update t) verbose (catch-errors t))
    650650  (with-preserved-working-directory ()
    651     (ensure-tests-loaded :force force :full full)
     651    (ensure-tests-loaded :force force :update update)
    652652    (cwd "ccl:tests;ansi-tests;")
    653653    (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
  • trunk/source/lib/macros.lisp

    r9049 r9163  
    543543                         (default-setf form value env))))))))))
    544544          ((oddp temp)
    545            (error "Odd number of args to SETF : ~s." args))
     545           (signal-program-error "Odd number of args to SETF : ~s." args))
    546546          (t (do* ((a args (cddr a)) (l nil))
    547547                  ((null a) `(progn ,@(nreverse l)))
     
    869869         otherwise-seen-p)
    870870    (flet ((bad-clause (c)
    871              (error "Invalid clause ~S in ~S form." c construct)))
     871             (signal-program-error "Invalid clause ~S in ~S form." c construct)))
    872872      (dolist (clause clauses)
    873873        (if (atom clause)
    874874            (bad-clause clause))
    875875        (if otherwise-seen-p
    876             (error "OTHERWISE must be final clause in ~S form." construct))
     876            (signal-program-error "OTHERWISE must be final clause in ~S form." construct))
    877877        (destructuring-bind (typespec &body consequents) clause
    878878          (when (eq construct 'typecase)
     
    994994       (when (nth-value 1 (macroexpand-1 sym env))
    995995         (return `(psetf ,@pairs))))
    996      (error "Uneven number of args in the call ~S" call))))
     996     (signal-program-error "Uneven number of args in the call ~S" call))))
    997997
    998998; generates body for psetq.
     
    16771677(defun with-specs-aux (name spec-list original-body)
    16781678  (multiple-value-bind (body decls) (parse-body original-body nil)
    1679     (when decls (error "declarations not allowed in ~s" original-body))
     1679    (when decls (signal-program-error "declarations not allowed in ~s" original-body))
    16801680    (setq body (cons 'progn body))
    16811681    (dolist (spec (reverse spec-list))
     
    20982098      (unless (and (consp option)
    20992099                   (consp (%cdr option)))
    2100         (error "Invalid option ~s ." option))
     2100        (signal-program-error "Invalid option ~s ." option))
    21012101      (ecase (%car option)
    21022102        (:default-initargs
     
    21082108        (:documentation
    21092109         (unless (null (%cddr option))
    2110            (error "Invalid option ~s ." option))
     2110           (signal-program-error "Invalid option ~s ." option))
    21112111         (if docp
    21122112           (setq duplicate t)
     
    21142114        (:report
    21152115         (unless (null (%cddr option))
    2116            (error "Invalid option ~s ." option))
     2116           (signal-program-error "Invalid option ~s ." option))
    21172117         (if reporter
    21182118           (setq duplicate t)
     
    21232123               (if (stringp reporter)
    21242124                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
    2125                  (error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
     2125                 (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
    21262126             (setq reporter `((defmethod report-condition ((c ,name) s)
    21272127                                (funcall ,reporter c s))))))))
    2128       (if duplicate (error "Duplicate option ~s ." option)))
     2128      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
    21292129    `(progn
    21302130       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
     
    27592759                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27602760             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2761             (t (error "Malformed slot-entry: ~a to with-slot-values.~@
    2762                        Should be a symbol or a list of two symbols."
    2763                       slot-entry)))
     2761            (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@
     2762                                      Should be a symbol or a list of two symbols."
     2763                                     slot-entry)))
    27642764      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27652765    `(let ((,instance ,instance-form))
     
    27802780                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27812781             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2782             (t (error "Malformed slot-entry: ~a to with-slots.~@
    2783                        Should be a symbol or a list of two symbols."
    2784                       slot-entry)))
     2782            (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@
     2783                                      Should be a symbol or a list of two symbols."
     2784                                     slot-entry)))
    27852785      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27862786    `(let ((,instance ,instance-form))
     
    28012801                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    28022802             (setq var (car slot-entry) reader (cadr slot-entry)))
    2803             (t (error "Malformed slot-entry: ~a to with-accessors.~@
    2804                        Should be a list of two symbols."
    2805                       slot-entry)))
     2803            (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@
     2804                                     Should be a list of two symbols."
     2805                                     slot-entry)))
    28062806      (push `(,var (,reader ,instance)) bindings))
    28072807    `(let ((,instance ,instance-form))
     
    29392939                           `((setf ,(%foreign-access-form name ftype 0 nil)
    29402940                              ,(car inits)))))
    2941               (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2942                      inits record-name))))))))
     2941              (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2942                                    inits record-name))))))))
    29432943
    29442944(defun %foreign-record-field-forms (ptr record-type record-name inits)
    29452945  (unless (evenp (length inits))
    2946     (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2947                      inits record-name))
     2946    (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2947                          inits record-name))
    29482948  (let* ((result ()))
    29492949    (do* ()
     
    29762976         (bytes (if bits
    29772977                  (ceiling bits 8)
    2978                   (error "Unknown size for foreign type ~S."
    2979                          (unparse-foreign-type ftype))))
     2978                  (signal-program-error "Unknown size for foreign type ~S."
     2979                                        (unparse-foreign-type ftype))))
    29802980         (p (gensym))
    29812981         (bzero (read-from-string "#_bzero")))   
     
    31543154          (%symbol-binding-address ',place)
    31553155          (%atomic-incf-node ,delta ,base ,offset)))
    3156       (error "~S is not a special variable"  place))))
     3156      (signal-program-error "~S is not a special variable"  place))))
    31573157   
    31583158(defmacro atomic-incf (place)
     
    31733173    (unless (and (listp x)
    31743174                 (= (length x) 2))
    3175       (error "Malformed iterate variable spec: ~S." x)))
     3175      (signal-program-error "Malformed iterate variable spec: ~S." x)))
    31763176
    31773177  `(labels ((,name ,(mapcar #'first binds) ,@body))
     
    32113211      (let ((spec (first specs)))
    32123212        (when (/= (length spec) 2)
    3213           (error "Malformed Once-Only binding spec: ~S." spec))
     3213          (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec))
    32143214        (let ((name (first spec))
    32153215              (exp-temp (gensym)))
     
    32723272    (dolist (spec collections)
    32733273      (unless (<= 1 (length spec) 3)
    3274         (error "Malformed collection specifier: ~S." spec))
     3274        (signal-program-error "Malformed collection specifier: ~S." spec))
    32753275      (let ((n-value (gensym))
    32763276            (name (first spec))
     
    33333333                 (if (and (consp (%cdr p)) (null (%cddr p)))
    33343334                   (values (require-global-symbol (%car p) env) (%cadr p))
    3335                    (error "Invalid variable initialization form : ~s")))))
     3335                   (signal-program-error "Invalid variable initialization form : ~s")))))
    33363336        (declare (inline pair-name-value))
    33373337        (dolist (v vars)
     
    33703370          (ccl::%symbol-binding-address ',place)
    33713371          (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value)))
    3372       (error "~s is not a special variable ." place))
     3372      (signal-program-error "~s is not a special variable ." place))
    33733373    (let* ((sym (car place))
    33743374           (struct-transform (or (ccl::environment-structref-info sym env)
     
    33823382            (ccl::store-gvector-conditional ,(caddr place)
    33833383             ,v ,old-value ,new-value)))
    3384         (error "Don't know how to do conditional store to ~s" place)))))
     3384        (signal-program-error "Don't know how to do conditional store to ~s" place)))))
    33853385
    33863386(defmacro step (form)
Note: See TracChangeset for help on using the changeset viewer.