[Sbcl-commits] CVS: sbcl/src/code cross-misc.lisp,1.23,1.24 early-fasl.lisp,1.63,1.64 early-package.lisp,1.4,1.5 error.lisp,1.25,1.26 eval.lisp,1.34,1.35

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18945/src/code

Modified Files:
	cross-misc.lisp early-fasl.lisp early-package.lisp error.lisp 
	eval.lisp 
Log Message:
0.9.11.35: better package locking and more cleaning up after .31
 * package lock violations from lexical operations always cause
    runtime PROGRAM-ERRORs
 * better EXTRA_CFLAGS handling in SB-GROVEL


Index: cross-misc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- cross-misc.lisp	9 Sep 2005 14:16:18 -0000	1.23
+++ cross-misc.lisp	14 Apr 2006 08:18:20 -0000	1.24
@@ -155,8 +155,8 @@
   (declare (ignore kind thing format))
   `(progn ,@body))
 
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
-  (declare (ignore control))
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
+  (declare (ignore context control))
   symbol)
 
 (defun assert-package-unlocked (package &optional control &rest args)

Index: early-fasl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-fasl.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- early-fasl.lisp	4 Mar 2006 19:58:26 -0000	1.63
+++ early-fasl.lisp	14 Apr 2006 08:18:20 -0000	1.64
@@ -76,7 +76,7 @@
 ;;; versions which break binary compatibility. But it certainly should
 ;;; be incremented for release versions which break binary
 ;;; compatibility.
-(def!constant +fasl-file-version+ 64)
+(def!constant +fasl-file-version+ 65)
 ;;; (record of versions before 2003 deleted in 2003-04-26/0.pre8.107 or so)
 ;;; 38: (2003-01-05) changed names of internal SORT machinery
 ;;; 39: (2003-02-20) in 0.7.12.1 a slot was added to
@@ -134,6 +134,7 @@
 ;;;     trap information size on RISCy platforms.
 ;;; 64: (2006-03-24) New calling convention for unknown-values on x86 and
 ;;;     x86-64.  Also (belatedly) PPC/gencgc, including :gencgc on FPAFF.
+;;; 65: (2006-04-11) Package locking interface changed.
 
 ;;; the conventional file extension for our fasl files
 (declaim (type simple-string *fasl-file-type*))

Index: early-package.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-package.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- early-package.lisp	14 Jul 2005 16:30:32 -0000	1.4
+++ early-package.lisp	14 Apr 2006 08:18:20 -0000	1.5
@@ -53,18 +53,20 @@
            (when ,topmost
              (setf *ignored-package-locks* :invalid)))))))
 
-(defun compiler-assert-symbol-home-package-unlocked (symbol control)
+(defun program-assert-symbol-home-package-unlocked (context symbol control)
   #!-sb-package-locks
-  (declare (ignore symbol control))
+  (declare (ignore context symbol control))
   #!+sb-package-locks
-  (flet ((resignal (condition)
-           ;; Signal the condition to give user defined handlers a chance,
-           ;; if they decline convert to compiler-error.
-           (signal condition)
-           (sb!c:compiler-error condition)))
-    (handler-bind ((package-lock-violation #'resignal))
-      (with-single-package-locked-error ()
-        (assert-symbol-home-package-unlocked symbol control)))))
+  (handler-bind ((package-lock-violation
+                  (lambda (condition)
+                    (ecase context
+                      (:compile
+                       (warn "Compile-time package lock violation:~%  ~A"
+                             condition)
+                       (sb!c:compiler-error condition))
+                      (:eval
+                       (eval-error condition))))))
+    (with-single-package-locked-error (:symbol symbol control))))
 
 (defmacro without-package-locks (&body body)
   #!+sb-doc

Index: error.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/error.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- error.lisp	14 Jul 2005 16:30:33 -0000	1.25
+++ error.lisp	14 Apr 2006 08:18:20 -0000	1.26
@@ -77,10 +77,21 @@
   (:report (lambda (condition stream)
              (format stream "Execution of a form compiled with errors.~%~
                              Form:~%  ~A~%~
-                             Compile-time-error:~%  ~A"
+                             Compile-time error:~%  ~A"
                        (program-error-source condition)
                        (program-error-message condition)))))
 
+(define-condition interpreted-program-error
+    (program-error encapsulated-condition)
+  ;; Unlike COMPILED-PROGRAM-ERROR, we don't need to dump these, so
+  ;; storing the original condition and form is OK.
+  ((form :initarg :form :reader program-error-form))
+  (:report (lambda (condition stream)
+             (format stream "~&Evaluation of~%  ~S~%~
+                             caused error:~%  ~A~%"
+                     (program-error-form condition)
+                     (encapsulated-condition condition)))))
+
 (define-condition simple-control-error (simple-condition control-error) ())
 (define-condition simple-file-error    (simple-condition file-error)    ())
 (define-condition simple-program-error (simple-condition program-error) ())

Index: eval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/eval.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- eval.lisp	14 Jul 2005 16:30:33 -0000	1.34
+++ eval.lisp	14 Apr 2006 08:18:20 -0000	1.35
@@ -70,7 +70,8 @@
              (sb!c::process-decls decls
                                   vars
                                   nil
-                                  :lexenv lexenv))))
+                                  :lexenv lexenv
+                                  :context :eval))))
       (eval-progn-body body lexenv))))
 
 (defun eval (original-exp)
@@ -79,6 +80,16 @@
   result or results."
   (eval-in-lexenv original-exp (make-null-lexenv)))
 
+;;;; EVAL-ERROR
+;;;;
+;;;; Analogous to COMPILER-ERROR, but simpler.
+
+(define-condition eval-error (encapsulated-condition) ())
+
+(defun eval-error (condition)
+  (signal 'eval-error :condition condition)
+  (bug "Unhandled EVAL-ERROR"))
+
 ;;; Pick off a few easy cases, and the various top level EVAL-WHEN
 ;;; magical cases, and call %EVAL for the rest.
 (defun eval-in-lexenv (original-exp lexenv)
@@ -98,125 +109,132 @@
               ;; error straight away.
               (invoke-restart 'sb!c::signal-error)))))
     (let ((exp (macroexpand original-exp lexenv)))
-      (typecase exp
-        (symbol
-         (ecase (info :variable :kind exp)
-           (:constant
-            (values (info :variable :constant-value exp)))
-           ((:special :global)
-            (symbol-value exp))
-           ;; FIXME: This special case here is a symptom of non-ANSI
-           ;; weirdness in SBCL's ALIEN implementation, which could
-           ;; cause problems for e.g. code walkers. It'd probably be
-           ;; good to ANSIfy it by making alien variable accessors
-           ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
-           ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
-           ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
-           ;; be retained for compatibility, it can be implemented
-           ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
-           ;; happy.
-           (:alien
-            (%eval original-exp lexenv))))
-        (list
-         (let ((name (first exp))
-               (n-args (1- (length exp))))
-           (case name
-             ((function)
-              (unless (= n-args 1)
-                (error "wrong number of args to FUNCTION:~% ~S" exp))
-              (let ((name (second exp)))
-                (if (and (legal-fun-name-p name)
-                         (not (consp (let ((sb!c:*lexenv* lexenv))
-                                       (sb!c:lexenv-find name funs)))))
-                    (%coerce-name-to-fun name)
-                    (%eval original-exp lexenv))))
-             ((quote)
-              (unless (= n-args 1)
-                (error "wrong number of args to QUOTE:~% ~S" exp))
-              (second exp))
-             (setq
-              (unless (evenp n-args)
-                (error "odd number of args to SETQ:~% ~S" exp))
-              (unless (zerop n-args)
-                (do ((name (cdr exp) (cddr name)))
-                    ((null name)
-                     (do ((args (cdr exp) (cddr args)))
-                         ((null (cddr args))
-                          ;; We duplicate the call to SET so that the
-                          ;; correct value gets returned.
-                          (set (first args) (eval-in-lexenv (second args) lexenv)))
-                       (set (first args) (eval-in-lexenv (second args) lexenv))))
-                  (let ((symbol (first name)))
-                    (case (info :variable :kind symbol)
-                      (:special)
-                      (t (return (%eval original-exp lexenv))))
-                    (unless (type= (info :variable :type symbol)
-                                   *universal-type*)
-                      ;; let the compiler deal with type checking
-                      (return (%eval original-exp lexenv)))))))
-             ((progn)
-              (eval-progn-body (rest exp) lexenv))
-             ((eval-when)
-              ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
-              ;; instead of PROGRAM-ERROR when there's something wrong
-              ;; with the syntax here (e.g. missing SITUATIONS). This
-              ;; could be fixed by hand-crafting clauses to catch and
-              ;; report each possibility, but it would probably be
-              ;; cleaner to write a new macro
-              ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
-              ;; DESTRUCTURING-BIND and promotes any mismatch to
-              ;; PROGRAM-ERROR, then to use it here and in (probably
-              ;; dozens of) other places where the same problem
-              ;; arises.
-              (destructuring-bind (eval-when situations &rest body) exp
-                (declare (ignore eval-when))
-                (multiple-value-bind (ct lt e)
-                    (sb!c:parse-eval-when-situations situations)
-                  ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
-                  ;; the situation :EXECUTE (or EVAL) controls whether
-                  ;; evaluation occurs for other EVAL-WHEN forms; that
-                  ;; is, those that are not top level forms, or those
-                  ;; in code processed by EVAL or COMPILE. If the
-                  ;; :EXECUTE situation is specified in such a form,
-                  ;; then the body forms are processed as an implicit
-                  ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
-                  (declare (ignore ct lt))
-                  (when e
-                    (eval-progn-body body lexenv)))))
-             ((locally)
-              (eval-locally exp lexenv))
-             ((macrolet)
-              (destructuring-bind (definitions &rest body)
-                  (rest exp)
-                (let ((lexenv
-                       (let ((sb!c:*lexenv* lexenv))
-                         (sb!c::funcall-in-macrolet-lexenv
-                          definitions
-                          (lambda (&key funs)
-                            (declare (ignore funs))
-                            sb!c:*lexenv*)
-                          :eval))))
-                  (eval-locally `(locally ,@body) lexenv))))
-             ((symbol-macrolet)
-              (destructuring-bind (definitions &rest body) (rest exp)
-                (multiple-value-bind (lexenv vars)
-                    (let ((sb!c:*lexenv* lexenv))
-                      (sb!c::funcall-in-symbol-macrolet-lexenv
-                       definitions
-                       (lambda (&key vars)
-                         (values sb!c:*lexenv* vars))
-                       :eval))
-                  (eval-locally `(locally ,@body) lexenv :vars vars))))
-             (t
-              (if (and (symbolp name)
-                       (eq (info :function :kind name) :function))
-                  (collect ((args))
-                    (dolist (arg (rest exp))
-                      (args (eval-in-lexenv arg lexenv)))
-                    (apply (symbol-function name) (args)))
-                  (%eval exp lexenv))))))
-        (t
-         exp)))))
+      (handler-bind ((eval-error
+                      (lambda (condition)
+                        (error 'interpreted-program-error
+                               :condition (encapsulated-condition condition)
+                               :form exp))))
+        (typecase exp
+          (symbol
+           (ecase (info :variable :kind exp)
+             (:constant
+              (values (info :variable :constant-value exp)))
+             ((:special :global)
+              (symbol-value exp))
+             ;; FIXME: This special case here is a symptom of non-ANSI
+             ;; weirdness in SBCL's ALIEN implementation, which could
+             ;; cause problems for e.g. code walkers. It'd probably be
+             ;; good to ANSIfy it by making alien variable accessors
+             ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
+             ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
+             ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
+             ;; be retained for compatibility, it can be implemented
+             ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
+             ;; happy.
+             (:alien
+              (%eval original-exp lexenv))))
+          (list
+           (let ((name (first exp))
+                 (n-args (1- (length exp))))
+             (case name
+               ((function)
+                (unless (= n-args 1)
+                  (error "wrong number of args to FUNCTION:~% ~S" exp))
+                (let ((name (second exp)))
+                  (if (and (legal-fun-name-p name)
+                           (not (consp (let ((sb!c:*lexenv* lexenv))
+                                         (sb!c:lexenv-find name funs)))))
+                      (%coerce-name-to-fun name)
+                      (%eval original-exp lexenv))))
+               ((quote)
+                (unless (= n-args 1)
+                  (error "wrong number of args to QUOTE:~% ~S" exp))
+                (second exp))
+               (setq
+                (unless (evenp n-args)
+                  (error "odd number of args to SETQ:~% ~S" exp))
+                (unless (zerop n-args)
+                  (do ((name (cdr exp) (cddr name)))
+                      ((null name)
+                       (do ((args (cdr exp) (cddr args)))
+                           ((null (cddr args))
+                            ;; We duplicate the call to SET so that the
+                            ;; correct value gets returned.
+                            (set (first args)
+                                 (eval-in-lexenv (second args) lexenv)))
+                         (set (first args)
+                              (eval-in-lexenv (second args) lexenv))))
+                    (let ((symbol (first name)))
+                      (case (info :variable :kind symbol)
+                        (:special)
+                        (t (return (%eval original-exp lexenv))))
+                      (unless (type= (info :variable :type symbol)
+                                     *universal-type*)
+                        ;; let the compiler deal with type checking
+                        (return (%eval original-exp lexenv)))))))
+               ((progn)
+                (eval-progn-body (rest exp) lexenv))
+               ((eval-when)
+                ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
+                ;; instead of PROGRAM-ERROR when there's something wrong
+                ;; with the syntax here (e.g. missing SITUATIONS). This
+                ;; could be fixed by hand-crafting clauses to catch and
+                ;; report each possibility, but it would probably be
+                ;; cleaner to write a new macro
+                ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
+                ;; DESTRUCTURING-BIND and promotes any mismatch to
+                ;; PROGRAM-ERROR, then to use it here and in (probably
+                ;; dozens of) other places where the same problem
+                ;; arises.
+                (destructuring-bind (eval-when situations &rest body) exp
+                  (declare (ignore eval-when))
+                  (multiple-value-bind (ct lt e)
+                      (sb!c:parse-eval-when-situations situations)
+                    ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
+                    ;; the situation :EXECUTE (or EVAL) controls whether
+                    ;; evaluation occurs for other EVAL-WHEN forms; that
+                    ;; is, those that are not top level forms, or those
+                    ;; in code processed by EVAL or COMPILE. If the
+                    ;; :EXECUTE situation is specified in such a form,
+                    ;; then the body forms are processed as an implicit
+                    ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
+                    (declare (ignore ct lt))
+                    (when e
+                      (eval-progn-body body lexenv)))))
+               ((locally)
+                (eval-locally exp lexenv))
+               ((macrolet)
+                (destructuring-bind (definitions &rest body)
+                    (rest exp)
+                  (let ((lexenv
+                         (let ((sb!c:*lexenv* lexenv))
+                           (sb!c::funcall-in-macrolet-lexenv
+                            definitions
+                            (lambda (&key funs)
+                              (declare (ignore funs))
+                              sb!c:*lexenv*)
+                            :eval))))
+                    (eval-locally `(locally ,@body) lexenv))))
+               ((symbol-macrolet)
+                (destructuring-bind (definitions &rest body) (rest exp)
+                  (multiple-value-bind (lexenv vars)
+                      (let ((sb!c:*lexenv* lexenv))
+                        (sb!c::funcall-in-symbol-macrolet-lexenv
+                         definitions
+                         (lambda (&key vars)
+                           (values sb!c:*lexenv* vars))
+                         :eval))
+                    (eval-locally `(locally ,@body) lexenv :vars vars))))
+               (t
+                (if (and (symbolp name)
+                         (eq (info :function :kind name) :function))
+                    (collect ((args))
+                      (dolist (arg (rest exp))
+                        (args (eval-in-lexenv arg lexenv)))
+                      (apply (symbol-function name) (args)))
+                    (%eval exp lexenv))))))
+          (t
+           exp))))))
 
 ;;; miscellaneous full function definitions of things which are
 ;;; ordinarily handled magically by the compiler