[Openmcl-cvs-notifications] r9163 - in /trunk/source: compiler/PPC/ppc2.lisp compiler/X86/x862.lisp compiler/nx-basic.lisp compiler/nx0.lisp lib/compile-ccl.lisp lib/macros.lisp
gz at clozure.com
gz at clozure.com
Tue Apr 15 14:46:46 EDT 2008
Author: gz
Date: Tue Apr 15 14:46:46 2008
New Revision: 9163
Log:
- 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.
Modified:
trunk/source/compiler/PPC/ppc2.lisp
trunk/source/compiler/X86/x862.lisp
trunk/source/compiler/nx-basic.lisp
trunk/source/compiler/nx0.lisp
trunk/source/lib/compile-ccl.lisp
trunk/source/lib/macros.lisp
Modified: trunk/source/compiler/PPC/ppc2.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/PPC/ppc2.lisp (original)
+++ trunk/source/compiler/PPC/ppc2.lisp Tue Apr 15 14:46:46 2008
@@ -2018,7 +2018,7 @@
(unless (and (eql (hard-regspec-value src) ppc::arg_x)
(eql (hard-regspec-value unscaled-idx) ppc::arg_=
y)
(eql (hard-regspec-value val-reg) ppc::arg_z))
- (nx-error "Bug: invalid register targeting for gvset: ~s" (=
list src unscaled-idx val-reg)))
+ (compiler-bug "Bug: invalid register targeting for gvset: ~=
s" (list src unscaled-idx val-reg)))
(! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) sr=
c unscaled-idx val-reg))
(is-node
(if (and index-known-fixnum (<=3D index-known-fixnum
@@ -5002,7 +5002,7 @@
(if *ppc2-open-code-inline*
(! unbind-interrupt-level-inline)
(! unbind-interrupt-level)))
- (nx-error "unknown payback token ~s" r)))))))
+ (compiler-bug "unknown payback token ~s" r)))))))
=
(defun ppc2-spread-lambda-list (seg listform whole req opt rest keys =
&optional enclosing-ea cdr-p)
Modified: trunk/source/compiler/X86/x862.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/X86/x862.lisp (original)
+++ trunk/source/compiler/X86/x862.lisp Tue Apr 15 14:46:46 2008
@@ -2166,7 +2166,7 @@
(unless (and (eql (hard-regspec-value src) x8664::arg_x)
(eql (hard-regspec-value unscaled-idx) x8664::ar=
g_y)
(eql (hard-regspec-value val-reg) x8664::arg_z))
- (nx-error "Bug: invalid register targeting for gvset: ~s" (=
list src unscaled-idx val-reg)))
+ (compiler-bug "Bug: invalid register targeting for gvset: ~=
s" (list src unscaled-idx val-reg)))
(! call-subprim-3 val-reg (subprim-name->offset '.SPgvset) sr=
c unscaled-idx val-reg))
(is-node
(if (and index-known-fixnum (<=3D index-known-fixnum
@@ -5027,7 +5027,7 @@
(let* ((*available-backend-node-temps* (bitclr x8664::arg_=
z (bitclr x8664::rcx *available-backend-node-temps*))))
(! unbind-interrupt-level-inline))
(! unbind-interrupt-level)))
- (nx-error "unknown payback token ~s" r)))))))
+ (compiler-bug "unknown payback token ~s" r)))))))
=
(defun x862-spread-lambda-list (seg listform whole req opt rest keys =
&optional enclosing-ea cdr-p)
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 Tue Apr 15 14:46:46 2008
@@ -486,28 +486,29 @@
(format stream
(ecase (compiler-warning-warning-type condition) =
(:global-mismatch "the current global definition of ~s")
- (:environment-mismatch "the definition of ~s visible in the =
current compilation unit")
+ (:environment-mismatch "the definition of ~s visible in the =
current compilation unit.")
(:lexical-mismatch "the lexically visible definition of ~s"))
callee)))
-
=
(defparameter *compiler-warning-formats*
'((:special . "Undeclared free variable ~S")
(:unused . "Unused lexical variable ~S")
- (:ignore . "Variable ~S not ignored")
+ (:ignore . "Variable ~S not ignored.")
(:undefined-function . "Undefined function ~S")
(:unknown-declaration . "Unknown declaration ~S")
(:unknown-type-declaration . "Unknown type ~S")
- (:macro-used-before-definition . "Macro function ~S was used before it=
was defined")
+ (:macro-used-before-definition . "Macro function ~S was used before it=
was defined.")
(:unsettable . "Shouldn't assign to variable ~S")
(:global-mismatch . report-compile-time-argument-mismatch)
(:environment-mismatch . report-compile-time-argument-mismatch)
(:lexical-mismatch . report-compile-time-argument-mismatch) =
(:type . "Type declarations violated in ~S")
(:type-conflict . "Conflicting type declarations for ~S")
- (:special-fbinding . "Attempt to bind compiler special name: ~s. Resul=
t undefined")
+ (:special-fbinding . "Attempt to bind compiler special name: ~s. Resul=
t undefined.")
(:lambda . "Suspicious lambda-list: ~s")
- (:result-ignored . "Function result ignored in call to ~s")))
+ (:result-ignored . "Function result ignored in call to ~s")
+ (:program-error . "~a")))
+
=
(defun report-compiler-warning (condition stream)
(let* ((warning-type (compiler-warning-warning-type condition))
@@ -518,7 +519,7 @@
(if (typep format-string 'string)
(apply #'format stream format-string (compiler-warning-args conditio=
n))
(funcall format-string condition stream))
- (format stream ".")
+ ;(format stream ".")
(let ((nrefs (compiler-warning-nrefs condition)))
(when (and nrefs (neq nrefs 1))
(format stream " (~D references)" nrefs)))))
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 Tue Apr 15 14:46:46 2008
@@ -1254,6 +1254,15 @@
(%ilogand $vrefmask
(%i+ (%i- boundtocount 1) varcount)))))))))
=
+;; Home-baked handler-case replacement. About 10 times as fast as full ha=
ndler-case.
+;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
+;;(LET ((S 0)) (DOTIMES (I 1000000) (BLOCK X (ERROR (CATCH 'X (RETURN-FROM=
X (INCF S))))))) took 57,485
+;;(LET ((S 0)) (DOTIMES (I 1000000) (HANDLER-CASE (INCF S) (ERROR (C) C)))=
) took 168,947
+(defmacro with-program-error-handler (handler &body body)
+ (let ((tag (gensym)))
+ `(block ,tag
+ (,handler (catch 'program-error-handler (return-from ,tag (progn ,@=
body)))))))
+
(defun nx1-compile-lambda (name lambda-form &optional
(p (make-afunc))
q
@@ -1306,25 +1315,41 @@
(*nx-cur-func-name* name))
(if (%non-empty-environment-p *nx-lexical-environment*)
(setf (afunc-bits p) (logior (ash 1 $fbitnonnullenv) (the fixnum (af=
unc-bits p)))))
- (multiple-value-bind (body decls)
- (parse-body (%cddr lambda-form) *nx-lexical-envir=
onment* t)
- (setf (afunc-lambdaform p) lambda-form)
- (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
- (nx1-transitively-punt-bindings *nx-punted-vars*)
- (setf (afunc-blocks p) *nx-blocks*)
- (setf (afunc-tags p) *nx-tags*)
- (setf (afunc-inner-functions p) *nx-inner-functions*)
- (setf (afunc-all-vars p) *nx-all-vars*)
- (setf (afunc-vcells p) *nx1-vcells*)
- (setf (afunc-fcells p) *nx1-fcells*)
- (let* ((warnings (merge-compiler-warnings *nx-warnings*))
- (name *nx-cur-func-name*)) =
- (dolist (inner *nx-inner-functions*)
- (dolist (w (afunc-warnings inner))
- (push name (compiler-warning-function-name w))
- (push w warnings)))
- (setf (afunc-warnings p) warnings))
- p)))
+
+ (setf (afunc-lambdaform p) lambda-form)
+ (with-program-error-handler
+ (lambda (c)
+ (setf (afunc-acode p) (nx1-lambda () `((error ',c)) nil)))
+ (handler-bind ((warning (lambda (c)
+ (nx1-whine :program-error c)
+ (muffle-warning c)))
+ (program-error (lambda (c)
+ (when (typep c 'compile-time-program-error)
+ (setq c (make-condition 'simple-program-error
+ :format-control (simple-condition-format-control c)
+ :format-arguments (simple-condition-format-arguments c))))
+ (nx1-whine :program-error c)
+ (throw 'program-error-handler c))))
+ (multiple-value-bind (body decls)
+ (with-program-error-handler (lambda (c) `(error ',c))
+ (parse-body (%cddr lambda-form) *nx-lexical-environment* t))
+ (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls)))))
+
+ (nx1-transitively-punt-bindings *nx-punted-vars*)
+ (setf (afunc-blocks p) *nx-blocks*)
+ (setf (afunc-tags p) *nx-tags*)
+ (setf (afunc-inner-functions p) *nx-inner-functions*)
+ (setf (afunc-all-vars p) *nx-all-vars*)
+ (setf (afunc-vcells p) *nx1-vcells*)
+ (setf (afunc-fcells p) *nx1-fcells*)
+ (let* ((warnings (merge-compiler-warnings *nx-warnings*))
+ (name *nx-cur-func-name*)) =
+ (dolist (inner *nx-inner-functions*)
+ (dolist (w (afunc-warnings inner))
+ (push name (compiler-warning-function-name w))
+ (push w warnings)))
+ (setf (afunc-warnings p) warnings))
+ p))
=
(defun method-lambda-p (form)
(and (consp form)
@@ -1590,7 +1615,11 @@
(nx1-typed-form form *nx-lexical-environment*))))
=
(defun nx1-typed-form (original env)
- (nx1-transformed-form (nx-transform original env) env))
+ (let ((form (with-program-error-handler
+ (lambda (c)
+ (nx-transform `(error ',c) env))
+ (nx-transform original env))))
+ (nx1-transformed-form form env)))
=
(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
(if (consp form)
@@ -1800,11 +1829,11 @@
(nx1-typed-call (car args) (%cdr args)))
=
(defun nx1-typed-call (sym args)
- (let ((type (nx1-call-result-type sym args))
- (form (nx1-call sym args)))
- (if (eq type t)
- form
- (list (%nx1-operator typed-form) type form))))
+ (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
+ (let ((form (nx1-call sym args nil nil errors-p)))
+ (if (eq type t)
+ form
+ (list (%nx1-operator typed-form) type form)))))
=
;;; Wimpy.
(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p)
@@ -1812,7 +1841,8 @@
(global-def nil)
(lexenv-def nil)
(defenv-def nil)
- (somedef nil))
+ (somedef nil)
+ (whined nil))
(when (and sym =
(symbolp sym)
(not (find-ftype-decl sym env))
@@ -1822,13 +1852,15 @@
(not (functionp (setq global-def (fboundp sym)))))
(if args-p
(nx1-whine :undefined-function sym args spread-p)
- (nx1-whine :undefined-function sym)))
+ (nx1-whine :undefined-function sym))
+ (setq whined t))
(when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
(multiple-value-bind (deftype reason)
(nx1-check-call-args somedef args spread-p)
(when deftype
- (nx1-whine deftype sym reason args spread-p))))
- (nx-target-type *nx-form-type*)))
+ (nx1-whine deftype sym reason args spread-p)
+ (setq whined t))))
+ (values (nx-target-type *nx-form-type*) whined)))
=
(defun find-ftype-decl (sym env)
(setq sym (maybe-setf-function-name sym))
@@ -1942,7 +1974,7 @@
=
;;; If "sym" is an expression (not a symbol which names a function),
;;; the caller has already alphatized it.
-(defun nx1-call (sym args &optional spread-p global-only)
+(defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
(nx1-verify-length args 0 nil)
(let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend=
*))))
(if (nx-self-call-p sym global-only)
@@ -1953,7 +1985,8 @@
(nx1-whine deftype sym reason args spread-p))
(make-acode (%nx1-operator self-call) (nx1-arglist args args-in-re=
gs) spread-p))
(multiple-value-bind (lambda-form containing-env token) (nx-inline-e=
xpansion sym *nx-lexical-environment* global-only)
- (or (nx1-expand-inline-call lambda-form containing-env token args =
spread-p *nx-lexical-environment*)
+ (or (and (not inhibit-inline)
+ (nx1-expand-inline-call lambda-form containing-env token args spread-p =
*nx-lexical-environment*))
(multiple-value-bind (info afunc) (if (and (symbolp sym) (not=
global-only)) (nx-lexical-finfo sym))
(when (eq 'macro (car info))
(nx-error "Can't call macro function ~s" sym))
@@ -1977,19 +2010,20 @@
(defun nx1-expand-inline-call (lambda-form env token args spread-p old-env)
(if (and (or (null spread-p) (eq (length args) 1)))
(if (and token (not (memq token *nx-inline-expansions*)))
- (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
- (lambda-list (cadr lambda-form))
- (body (cddr lambda-form))
- (new-env (new-lexical-environment env)))
- (setf (lexenv.mdecls new-env)
+ (with-program-error-handler (lambda (c) (declare (ignore c)) nil)
+ (let* ((*nx-inline-expansions* (cons token *nx-inline-expansions*))
+ (lambda-list (cadr lambda-form))
+ (body (cddr lambda-form))
+ (new-env (new-lexical-environment env)))
+ (setf (lexenv.mdecls new-env)
`((speed . ,(speed-optimize-quantity old-env))
- (space . ,(space-optimize-quantity old-env))
- (safety . ,(space-optimize-quantity old-env))
- (compilation-speed . ,(compilation-speed-optimi=
ze-quantity old-env))
- (debug . ,(debug-optimize-quantity old-env))))
- (if spread-p
- (nx1-destructure lambda-list (car args) nil nil body new-env)
- (nx1-lambda-bind lambda-list args body new-env))))))
+ (space . ,(space-optimize-quantity old-env))
+ (safety . ,(space-optimize-quantity old-env))
+ (compilation-speed . ,(compilation-speed-optimize-quantity old-env))
+ (debug . ,(debug-optimize-quantity old-env))))
+ (if spread-p
+ (nx1-destructure lambda-list (car args) nil nil body new-env)
+ (nx1-lambda-bind lambda-list args body new-env)))))))
=
; note that regforms are reversed: arg_z is always in the car
(defun nx1-arglist (args &optional (nregargs (backend-num-arg-regs *target=
-backend*)))
Modified: trunk/source/lib/compile-ccl.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/lib/compile-ccl.lisp (original)
+++ trunk/source/lib/compile-ccl.lisp Tue Apr 15 14:46:46 2008
@@ -602,7 +602,7 @@
(defun ensure-tests-loaded (&key force full)
(unless (and (find-package "REGRESSION-TEST") (not force))
(if (probe-file "ccl:tests;ansi-tests;")
- (when full
+ (when update
(cwd "ccl:tests;")
(run-program "svn" '("update")))
(let* ((svn (probe-file "ccl:.svn;entries"))
@@ -646,9 +646,9 @@
;; And our own tests
(load "ccl:tests;ansi-tests;ccl.lsp"))))
=
-(defun test-ccl (&key force full verbose (catch-errors t))
+(defun test-ccl (&key force (update t) verbose (catch-errors t))
(with-preserved-working-directory ()
- (ensure-tests-loaded :force force :full full)
+ (ensure-tests-loaded :force force :update update)
(cwd "ccl:tests;ansi-tests;")
(let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST"))
(*suppress-compiler-warnings* t)
Modified: trunk/source/lib/macros.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/lib/macros.lisp (original)
+++ trunk/source/lib/macros.lisp Tue Apr 15 14:46:46 2008
@@ -542,7 +542,7 @@
`(setf ,res ,value)
(default-setf form value env))))))))))
((oddp temp)
- (error "Odd number of args to SETF : ~s." args))
+ (signal-program-error "Odd number of args to SETF : ~s." args))
(t (do* ((a args (cddr a)) (l nil))
((null a) `(progn ,@(nreverse l)))
(push `(setf ,(car a) ,(cadr a)) l))))))
@@ -868,12 +868,12 @@
(body ())
otherwise-seen-p)
(flet ((bad-clause (c) =
- (error "Invalid clause ~S in ~S form." c construct)))
+ (signal-program-error "Invalid clause ~S in ~S form." c const=
ruct)))
(dolist (clause clauses)
(if (atom clause)
(bad-clause clause))
(if otherwise-seen-p
- (error "OTHERWISE must be final clause in ~S form." construct))
+ (signal-program-error "OTHERWISE must be final clause in ~S fo=
rm." construct))
(destructuring-bind (typespec &body consequents) clause
(when (eq construct 'typecase)
(if (eq typespec 'otherwise)
@@ -993,7 +993,7 @@
(unless (symbolp sym) (report-bad-arg sym 'symbol))
(when (nth-value 1 (macroexpand-1 sym env))
(return `(psetf , at pairs))))
- (error "Uneven number of args in the call ~S" call))))
+ (signal-program-error "Uneven number of args in the call ~S" call))))
=
; generates body for psetq.
; "pairs" is a proper list whose length is not odd.
@@ -1676,7 +1676,7 @@
=
(defun with-specs-aux (name spec-list original-body)
(multiple-value-bind (body decls) (parse-body original-body nil)
- (when decls (error "declarations not allowed in ~s" original-body))
+ (when decls (signal-program-error "declarations not allowed in ~s" ori=
ginal-body))
(setq body (cons 'progn body))
(dolist (spec (reverse spec-list))
(setq body (list name spec body)))
@@ -2097,7 +2097,7 @@
(dolist (option options)
(unless (and (consp option)
(consp (%cdr option)))
- (error "Invalid option ~s ." option))
+ (signal-program-error "Invalid option ~s ." option))
(ecase (%car option)
(:default-initargs =
(unless (plistp (cdr option)) =
@@ -2107,13 +2107,13 @@
(push (setq default-initargs-p option) classopts))) =
(:documentation =
(unless (null (%cddr option)) =
- (error "Invalid option ~s ." option)) =
+ (signal-program-error "Invalid option ~s ." option)) =
(if docp
(setq duplicate t)
(push (setq docp option) classopts)))
(:report =
(unless (null (%cddr option)) =
- (error "Invalid option ~s ." option)) =
+ (signal-program-error "Invalid option ~s ." option)) =
(if reporter
(setq duplicate t)
(progn
@@ -2122,10 +2122,10 @@
(setq reporter `(function ,reporter))
(if (stringp reporter)
(setq reporter `(function (lambda (c s) (declare (ignore =
c)) (write-string ,reporter s))))
- (error "~a expression is not a string, symbol, or lambda =
expression ." (%car option))))
+ (signal-program-error "~a expression is not a string, sym=
bol, or lambda expression ." (%car option))))
(setq reporter `((defmethod report-condition ((c ,name) s)
(funcall ,reporter c s))))))))
- (if duplicate (error "Duplicate option ~s ." option)))
+ (if duplicate (signal-program-error "Duplicate option ~s ." option)))
`(progn
(defclass ,name ,(or supers '(condition)) ,slots , at classopts)
, at reporter
@@ -2758,9 +2758,9 @@
((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-ent=
ry))
(symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
(setq var (car slot-entry) slot-name (cadr slot-entry)))
- (t (error "Malformed slot-entry: ~a to with-slot-values.~@
- Should be a symbol or a list of two symbols."
- slot-entry)))
+ (t (signal-program-error "Malformed slot-entry: ~a to with-slo=
t-values.~@
+ Should be a symbol or a list of two =
symbols."
+ slot-entry)))
(push `(,var (slot-value ,instance ',slot-name)) bindings))
`(let ((,instance ,instance-form))
(let ,(nreverse bindings)
@@ -2779,9 +2779,9 @@
((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-ent=
ry))
(symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
(setq var (car slot-entry) slot-name (cadr slot-entry)))
- (t (error "Malformed slot-entry: ~a to with-slots.~@
- Should be a symbol or a list of two symbols."
- slot-entry)))
+ (t (signal-program-error "Malformed slot-entry: ~a to with-slo=
ts.~@
+ Should be a symbol or a list of two =
symbols."
+ slot-entry)))
(push `(,var (slot-value ,instance ',slot-name)) bindings))
`(let ((,instance ,instance-form))
,@(if bindings =
@@ -2800,9 +2800,9 @@
(cond ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-ent=
ry))
(symbolp (car slot-entry)) (symbolp (cadr slot-entry)))
(setq var (car slot-entry) reader (cadr slot-entry)))
- (t (error "Malformed slot-entry: ~a to with-accessors.~@
- Should be a list of two symbols."
- slot-entry)))
+ (t (signal-program-error "Malformed slot-entry: ~a to with-acc=
essors.~@
+ Should be a list of two symbols."
+ slot-entry)))
(push `(,var (,reader ,instance)) bindings))
`(let ((,instance ,instance-form))
,@(if bindings =
@@ -2938,13 +2938,13 @@
(nconc result
`((setf ,(%foreign-access-form name ftype 0 nil)
,(car inits)))))
- (error "Unexpected or malformed initialization forms: ~s in =
field type: ~s"
- inits record-name))))))))
+ (signal-program-error "Unexpected or malformed initializatio=
n forms: ~s in field type: ~s"
+ inits record-name))))))))
=
(defun %foreign-record-field-forms (ptr record-type record-name inits)
(unless (evenp (length inits))
- (error "Unexpected or malformed initialization forms: ~s in field type=
: ~s"
- inits record-name))
+ (signal-program-error "Unexpected or malformed initialization forms: ~=
s in field type: ~s"
+ inits record-name))
(let* ((result ()))
(do* ()
((null inits)
@@ -2975,8 +2975,8 @@
(bits (ensure-foreign-type-bits ftype))
(bytes (if bits
(ceiling bits 8)
- (error "Unknown size for foreign type ~S."
- (unparse-foreign-type ftype))))
+ (signal-program-error "Unknown size for foreign type ~S."
+ (unparse-foreign-type ftype))))
(p (gensym))
(bzero (read-from-string "#_bzero"))) =
`(let* ((,p (,allocator ,bytes)))
@@ -3153,7 +3153,7 @@
`(multiple-value-bind (,base ,offset)
(%symbol-binding-address ',place)
(%atomic-incf-node ,delta ,base ,offset)))
- (error "~S is not a special variable" place))))
+ (signal-program-error "~S is not a special variable" place))))
=
(defmacro atomic-incf (place)
`(atomic-incf-decf ,place 1))
@@ -3172,7 +3172,7 @@
(dolist (x binds)
(unless (and (listp x)
(=3D (length x) 2))
- (error "Malformed iterate variable spec: ~S." x)))
+ (signal-program-error "Malformed iterate variable spec: ~S." x)))
=
`(labels ((,name ,(mapcar #'first binds) , at body))
(,name ,@(mapcar #'second binds))))
@@ -3210,7 +3210,7 @@
`(progn , at body)
(let ((spec (first specs)))
(when (/=3D (length spec) 2)
- (error "Malformed Once-Only binding spec: ~S." spec))
+ (signal-program-error "Malformed ~s binding spec: ~S." 'once-onl=
y spec))
(let ((name (first spec))
(exp-temp (gensym)))
`(let ((,exp-temp ,(second spec))
@@ -3271,7 +3271,7 @@
(binds ()))
(dolist (spec collections)
(unless (<=3D 1 (length spec) 3)
- (error "Malformed collection specifier: ~S." spec))
+ (signal-program-error "Malformed collection specifier: ~S." spec))
(let ((n-value (gensym))
(name (first spec))
(default (second spec))
@@ -3332,7 +3332,7 @@
(values (require-global-symbol p env) nil)
(if (and (consp (%cdr p)) (null (%cddr p)))
(values (require-global-symbol (%car p) env) (%cadr p))
- (error "Invalid variable initialization form : ~s")))))
+ (signal-program-error "Invalid variable initialization =
form : ~s")))))
(declare (inline pair-name-value))
(dolist (v vars)
(let* ((oldval (gensym))
@@ -3369,7 +3369,7 @@
`(multiple-value-bind (,base ,offset)
(ccl::%symbol-binding-address ',place)
(ccl::%store-node-conditional ,offset ,base ,old-value ,new-valu=
e)))
- (error "~s is not a special variable ." place))
+ (signal-program-error "~s is not a special variable ." place))
(let* ((sym (car place))
(struct-transform (or (ccl::environment-structref-info sym env)
(gethash sym ccl::%structure-refs%))))
@@ -3381,7 +3381,7 @@
`(let* ((,v ,(cadr place)))
(ccl::store-gvector-conditional ,(caddr place)
,v ,old-value ,new-value)))
- (error "Don't know how to do conditional store to ~s" place)))))
+ (signal-program-error "Don't know how to do conditional store to ~=
s" place)))))
=
(defmacro step (form)
"The form is evaluated with single stepping enabled. Function calls
More information about the Openmcl-cvs-notifications
mailing list