Changeset 9165


Ignore:
Timestamp:
Apr 15, 2008, 7:58:45 PM (11 years ago)
Author:
gz
Message:

Propagate r9163/r9164 to here from trunk

Location:
branches/working-0711/ccl
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/PPC/ppc2.lisp

    r9117 r9165  
    20252025                          (eql (hard-regspec-value unscaled-idx) ppc::arg_y)
    20262026                          (eql (hard-regspec-value val-reg) ppc::arg_z))
    2027                (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
     2027               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
    20282028             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
    20292029            (is-node
     
    51025102                (! unbind-interrupt-level-inline)
    51035103                (! unbind-interrupt-level)))
    5104             (nx-error "unknown payback token ~s" r)))))))
     5104            (compiler-bug "unknown payback token ~s" r)))))))
    51055105
    51065106(defun ppc2-spread-lambda-list (seg listform whole req opt rest keys
  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r9117 r9165  
    22592259                          (eql (hard-regspec-value unscaled-idx) x8664::arg_y)
    22602260                          (eql (hard-regspec-value val-reg) x8664::arg_z))
    2261                (nx-error "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
     2261               (compiler-bug "Bug: invalid register targeting for gvset: ~s" (list src unscaled-idx val-reg)))
    22622262             (! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) src unscaled-idx val-reg))
    22632263            (is-node
     
    51805180                  (! unbind-interrupt-level-inline))
    51815181                (! unbind-interrupt-level)))
    5182             (nx-error "unknown payback token ~s" r)))))))
     5182            (compiler-bug "unknown payback token ~s" r)))))))
    51835183
    51845184(defun x862-spread-lambda-list (seg listform whole req opt rest keys
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r8938 r9165  
    487487            (ecase (compiler-warning-warning-type condition)       
    488488              (:global-mismatch "the current global definition of ~s")
    489               (:environment-mismatch "the definition of ~s visible in the current compilation unit")
     489              (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
    490490              (:lexical-mismatch "the lexically visible definition of ~s"))
    491491            callee)))
     
    494494  '((:special . "Undeclared free variable ~S")
    495495    (:unused . "Unused lexical variable ~S")
    496     (:ignore . "Variable ~S not ignored")
     496    (:ignore . "Variable ~S not ignored.")
    497497    (:undefined-function . "Undefined function ~S")
    498498    (:unknown-declaration . "Unknown declaration ~S")
    499499    (:unknown-type-declaration . "Unknown type ~S")
    500     (:macro-used-before-definition . "Macro function ~S was used before it was defined")
     500    (:macro-used-before-definition . "Macro function ~S was used before it was defined.")
    501501    (:unsettable . "Shouldn't assign to variable ~S")
    502502    (:global-mismatch . report-compile-time-argument-mismatch)
     
    505505    (:type . "Type declarations violated in ~S.")
    506506    (:type-conflict . "Conflicting type declarations for ~S")
    507     (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined")
     507    (:special-fbinding . "Attempt to bind compiler special name: ~s. Result undefined.")
    508508    (:lambda . "Suspicious lambda-list: ~s")
    509     (:result-ignored . "Function result ignored in call to ~s")))
     509    (:result-ignored . "Function result ignored in call to ~s")
     510    (:program-error . "~a")))
     511
    510512
    511513(defun report-compiler-warning (condition stream)
     
    518520      (apply #'format stream format-string (compiler-warning-args condition))
    519521      (funcall format-string condition stream))
    520     (format stream ".")
     522    ;(format stream ".")
    521523    (let ((nrefs (compiler-warning-nrefs condition)))
    522524      (when (and nrefs (neq nrefs 1))
  • branches/working-0711/ccl/compiler/nx0.lisp

    r9117 r9165  
    12751275  "Mapping between nx1-forms source locations.")
    12761276
     1277;; Home-baked handler-case replacement.  About 10 times as fast as full handler-case.
     1278;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
     1279;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM X (INCF S))))))) took 57,485
     1280;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))) took 168,947
     1281(defmacro with-program-error-handler (handler &body body)
     1282  (let ((tag (gensym)))
     1283    `(block ,tag
     1284       (,handler (catch 'program-error-handler (return-from ,tag (progn ,@body)))))))
     1285
    12771286(defun nx1-compile-lambda (name lambda-form &optional
    12781287                                 (p (make-afunc))
     
    13321341    (if (%non-empty-environment-p *nx-lexical-environment*)
    13331342      (setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (afunc-bits p)))))
    1334     (multiple-value-bind (body decls)
    1335                          (parse-body (%cddr lambda-form) *nx-lexical-environment* t)
    1336       (setf (afunc-lambdaform p) lambda-form)
    1337       (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
    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)))
     1343
     1344    (setf (afunc-lambdaform p) lambda-form)
     1345    (with-program-error-handler
     1346        (lambda (c)
     1347          (setf (afunc-acode p) (nx1-lambda () `((error ',c)) nil)))
     1348      (handler-bind ((warning (lambda (c)
     1349                                (nx1-whine :program-error c)
     1350                                (muffle-warning c)))
     1351                     (program-error (lambda (c)
     1352                                      (when (typep c 'compile-time-program-error)
     1353                                        (setq c (make-condition 'simple-program-error
     1354                                                  :format-control (simple-condition-format-control c)
     1355                                                  :format-arguments (simple-condition-format-arguments c))))
     1356                                      (nx1-whine :program-error c)
     1357                                      (throw 'program-error-handler c))))
     1358        (multiple-value-bind (body decls)
     1359            (with-program-error-handler (lambda (c) `(error ',c))
     1360              (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
     1361          (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
     1362
     1363    (nx1-transitively-punt-bindings *nx-punted-vars*)
     1364    (setf (afunc-blocks p) *nx-blocks*)
     1365    (setf (afunc-tags p) *nx-tags*)
     1366    (setf (afunc-inner-functions p) *nx-inner-functions*)
     1367    (setf (afunc-all-vars p) *nx-all-vars*)
     1368    (setf (afunc-vcells p) *nx1-vcells*)
     1369    (setf (afunc-fcells p) *nx1-fcells*)
     1370    (let* ((warnings (merge-compiler-warnings *nx-warnings*))
     1371           (name *nx-cur-func-name*))       
     1372      (dolist (inner *nx-inner-functions*)
     1373        (dolist (w (afunc-warnings inner))
     1374          (push name (compiler-warning-function-name w))
     1375          (push w warnings)))
     1376      (setf (afunc-warnings p) warnings))
     1377    p))
    13531378
    13541379(defun method-lambda-p (form)
     
    17281753
    17291754(defun nx1-typed-form (original env)
    1730   (nx1-transformed-form (nx-transform original env) env original))
     1755  (let ((form (with-program-error-handler
     1756                  (lambda (c)
     1757                    (nx-transform `(error ',c) env))
     1758                (nx-transform original env))))
     1759    (nx1-transformed-form form env original)))
    17311760
    17321761(defun nx1-transformed-form (form env &optional original)
     
    19601989
    19611990(defun nx1-typed-call (sym args)
    1962   (let ((type (nx1-call-result-type sym args))
    1963         (form (nx1-call sym args)))
    1964     (if (eq type t)
    1965       form
    1966       (list (%nx1-operator typed-form) type form))))
     1991  (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
     1992    (let ((form (nx1-call sym args nil nil errors-p)))
     1993      (if (eq type t)
     1994        form
     1995        (list (%nx1-operator typed-form) type form)))))
    19671996
    19681997; Wimpy.
     
    19722001         (lexenv-def nil)
    19732002         (defenv-def nil)
    1974          (somedef nil))
     2003         (somedef nil)
     2004         (whined nil))
    19752005    (when (and sym
    19762006               (symbolp sym)
     
    19822012      (if args-p
    19832013        (nx1-whine :undefined-function sym args spread-p)
    1984         (nx1-whine :undefined-function sym)))
     2014        (nx1-whine :undefined-function sym))
     2015      (setq whined t))
    19852016    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
    19862017      (multiple-value-bind (deftype reason)
    19872018          (nx1-check-call-args somedef args spread-p)
    19882019        (when deftype
    1989           (nx1-whine deftype sym reason args spread-p))))
    1990     (nx-target-type *nx-form-type*)))
     2020          (nx1-whine deftype sym reason args spread-p)
     2021          (setq whined t))))
     2022    (values (nx-target-type *nx-form-type*) whined)))
    19912023
    19922024(defun find-ftype-decl (sym env)
     
    21022134;;; If "sym" is an expression (not a symbol which names a function),
    21032135;;; the caller has already alphatized it.
    2104 (defun nx1-call (sym args &optional spread-p global-only)
     2136(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
    21052137  (nx1-verify-length args 0 nil)
    21062138  (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
     
    21132145        (make-acode (%nx1-operator self-call) (nx1-arglist args args-in-regs) spread-p))
    21142146      (multiple-value-bind (lambda-form containing-env token) (nx-inline-expansion sym *nx-lexical-environment* global-only)
    2115         (or (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*)
     2147        (or (and (not inhibit-inline)
     2148                 (nx1-expand-inline-call lambda-form containing-env token args spread-p *nx-lexical-environment*))
    21162149            (multiple-value-bind (info afunc) (if (and  (symbolp sym) (not global-only)) (nx-lexical-finfo sym))
    21172150              (when (eq 'macro (car info))
     
    21372170  (if (and (or (null spread-p) (eq (length args) 1)))
    21382171    (if (and token (not (memq token *nx-inline-expansions*)))
    2139       (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
    2140              (lambda-list (cadr lambda-form))
    2141              (body (cddr lambda-form))
    2142              (new-env (new-lexical-environment env)))
    2143         (setf (lexenv.mdecls new-env)
     2172      (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
     2173        (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
     2174               (lambda-list (cadr lambda-form))
     2175               (body (cddr lambda-form))
     2176               (new-env (new-lexical-environment env)))
     2177          (setf (lexenv.mdecls new-env)
    21442178                `((speed . ,(speed-optimize-quantity old-env))
    2145                            (space . ,(space-optimize-quantity old-env))
    2146                            (safety . ,(space-optimize-quantity old-env))
    2147                            (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
    2148                            (debug . ,(debug-optimize-quantity old-env))))
    2149         (if spread-p
    2150           (nx1-destructure lambda-list (car args) nil nil body new-env)
    2151           (nx1-lambda-bind lambda-list args body new-env))))))
     2179                  (space . ,(space-optimize-quantity old-env))
     2180                  (safety . ,(space-optimize-quantity old-env))
     2181                  (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
     2182                  (debug . ,(debug-optimize-quantity old-env))))
     2183          (if spread-p
     2184            (nx1-destructure lambda-list (car args) nil nil body new-env)
     2185            (nx1-lambda-bind lambda-list args body new-env)))))))
    21522186             
    21532187; note that regforms are reversed: arg_z is always in the car
  • branches/working-0711/ccl/lib/compile-ccl.lisp

    r9154 r9165  
    601601         (cwd ,wd)))))
    602602
    603 (defun ensure-tests-loaded (&key force full)
     603(defun ensure-tests-loaded (&key force update)
    604604  (unless (and (find-package "REGRESSION-TEST") (not force))
    605605    (if (probe-file "ccl:tests;ansi-tests;")
    606       (when full
     606      (when update
    607607        (cwd "ccl:tests;")
    608608        (run-program "svn" '("update")))
     
    651651      (load "ccl:tests;ansi-tests;ccl.lsp"))))
    652652
    653 (defun test-ccl (&key force full verbose (catch-errors t))
     653(defun test-ccl (&key force (update t) verbose (catch-errors t))
    654654  (with-preserved-working-directory ()
    655     (ensure-tests-loaded :force force :full full)
     655    (ensure-tests-loaded :force force :update update)
    656656    (cwd "ccl:tests;ansi-tests;")
    657657    (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
  • branches/working-0711/ccl/lib/macros.lisp

    r9117 r9165  
    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)))
     
    871871         otherwise-seen-p)
    872872    (flet ((bad-clause (c)
    873              (error "Invalid clause ~S in ~S form." c construct)))
     873             (signal-program-error "Invalid clause ~S in ~S form." c construct)))
    874874      (dolist (clause clauses)
    875875        (if (atom clause)
    876876            (bad-clause clause))
    877877        (if otherwise-seen-p
    878             (error "OTHERWISE must be final clause in ~S form." construct))
     878            (signal-program-error "OTHERWISE must be final clause in ~S form." construct))
    879879        (destructuring-bind (typespec &body consequents) clause
    880880          (when (eq construct 'typecase)
     
    996996       (when (nth-value 1 (macroexpand-1 sym env))
    997997         (return `(psetf ,@pairs))))
    998      (error "Uneven number of args in the call ~S" call))))
     998     (signal-program-error "Uneven number of args in the call ~S" call))))
    999999
    10001000; generates body for psetq.
     
    16791679(defun with-specs-aux (name spec-list original-body)
    16801680  (multiple-value-bind (body decls) (parse-body original-body nil)
    1681     (when decls (error "declarations not allowed in ~s" original-body))
     1681    (when decls (signal-program-error "declarations not allowed in ~s" original-body))
    16821682    (setq body (cons 'progn body))
    16831683    (dolist (spec (reverse spec-list))
     
    20882088      (unless (and (consp option)
    20892089                   (consp (%cdr option)))
    2090         (error "Invalid option ~s ." option))
     2090        (signal-program-error "Invalid option ~s ." option))
    20912091      (ecase (%car option)
    20922092        (:default-initargs
     
    20982098        (:documentation
    20992099         (unless (null (%cddr option))
    2100            (error "Invalid option ~s ." option))
     2100           (signal-program-error "Invalid option ~s ." option))
    21012101         (if docp
    21022102           (setq duplicate t)
     
    21042104        (:report
    21052105         (unless (null (%cddr option))
    2106            (error "Invalid option ~s ." option))
     2106           (signal-program-error "Invalid option ~s ." option))
    21072107         (if reporter
    21082108           (setq duplicate t)
     
    21132113               (if (stringp reporter)
    21142114                 (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s))))
    2115                  (error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
     2115                 (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option))))
    21162116             (setq reporter `((defmethod report-condition ((c ,name) s)
    21172117                                (funcall ,reporter c s))))))))
    2118       (if duplicate (error "Duplicate option ~s ." option)))
     2118      (if duplicate (signal-program-error "Duplicate option ~s ." option)))
    21192119    `(progn
    21202120       (defclass ,name ,(or supers '(condition)) ,slots ,@classopts)
     
    27512751                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27522752             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2753             (t (error "Malformed slot-entry: ~a to with-slot-values.~@
    2754                        Should be a symbol or a list of two symbols."
    2755                       slot-entry)))
     2753            (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@
     2754                                      Should be a symbol or a list of two symbols."
     2755                                     slot-entry)))
    27562756      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27572757    `(let ((,instance ,instance-form))
     
    27722772                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27732773             (setq var (car slot-entry) slot-name (cadr slot-entry)))
    2774             (t (error "Malformed slot-entry: ~a to with-slots.~@
    2775                        Should be a symbol or a list of two symbols."
    2776                       slot-entry)))
     2774            (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@
     2775                                      Should be a symbol or a list of two symbols."
     2776                                     slot-entry)))
    27772777      (push `(,var (slot-value ,instance ',slot-name)) bindings))
    27782778    `(let ((,instance ,instance-form))
     
    27932793                  (symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
    27942794             (setq var (car slot-entry) reader (cadr slot-entry)))
    2795             (t (error "Malformed slot-entry: ~a to with-accessors.~@
    2796                        Should be a list of two symbols."
    2797                       slot-entry)))
     2795            (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@
     2796                                     Should be a list of two symbols."
     2797                                     slot-entry)))
    27982798      (push `(,var (,reader ,instance)) bindings))
    27992799    `(let ((,instance ,instance-form))
     
    29312931                           `((setf ,(%foreign-access-form name ftype 0 nil)
    29322932                              ,(car inits)))))
    2933               (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2934                      inits record-name))))))))
     2933              (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2934                                    inits record-name))))))))
    29352935
    29362936(defun %foreign-record-field-forms (ptr record-type record-name inits)
    29372937  (unless (evenp (length inits))
    2938     (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
    2939                      inits record-name))
     2938    (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s"
     2939                          inits record-name))
    29402940  (let* ((result ()))
    29412941    (do* ()
     
    29682968         (bytes (if bits
    29692969                  (ceiling bits 8)
    2970                   (error "Unknown size for foreign type ~S."
    2971                          (unparse-foreign-type ftype))))
     2970                  (signal-program-error "Unknown size for foreign type ~S."
     2971                                        (unparse-foreign-type ftype))))
    29722972         (p (gensym))
    29732973         (bzero (read-from-string "#_bzero")))   
     
    31463146          (%symbol-binding-address ',place)
    31473147          (%atomic-incf-node ,delta ,base ,offset)))
    3148       (error "~S is not a special variable"  place))))
     3148      (signal-program-error "~S is not a special variable"  place))))
    31493149   
    31503150(defmacro atomic-incf (place)
     
    31653165    (unless (and (listp x)
    31663166                 (= (length x) 2))
    3167       (error "Malformed iterate variable spec: ~S." x)))
     3167      (signal-program-error "Malformed iterate variable spec: ~S." x)))
    31683168
    31693169  `(labels ((,name ,(mapcar #'first binds) ,@body))
     
    32033203      (let ((spec (first specs)))
    32043204        (when (/= (length spec) 2)
    3205           (error "Malformed Once-Only binding spec: ~S." spec))
     3205          (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec))
    32063206        (let ((name (first spec))
    32073207              (exp-temp (gensym)))
     
    32643264    (dolist (spec collections)
    32653265      (unless (<= 1 (length spec) 3)
    3266         (error "Malformed collection specifier: ~S." spec))
     3266        (signal-program-error "Malformed collection specifier: ~S." spec))
    32673267      (let ((n-value (gensym))
    32683268            (name (first spec))
     
    33253325                 (if (and (consp (%cdr p)) (null (%cddr p)))
    33263326                   (values (require-global-symbol (%car p) env) (%cadr p))
    3327                    (error "Invalid variable initialization form : ~s")))))
     3327                   (signal-program-error "Invalid variable initialization form : ~s")))))
    33283328        (declare (inline pair-name-value))
    33293329        (dolist (v vars)
     
    33623362          (ccl::%symbol-binding-address ',place)
    33633363          (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value)))
    3364       (error "~s is not a special variable ." place))
     3364      (signal-program-error "~s is not a special variable ." place))
    33653365    (let* ((sym (car place))
    33663366           (struct-transform (or (ccl::environment-structref-info sym env)
     
    33743374            (ccl::store-gvector-conditional ,(caddr place)
    33753375             ,v ,old-value ,new-value)))
    3376         (error "Don't know how to do conditional store to ~s" place)))))
     3376        (signal-program-error "Don't know how to do conditional store to ~s" place)))))
    33773377
    33783378(defmacro step (form)
Note: See TracChangeset for help on using the changeset viewer.