Skip to content

Commit

Permalink
0.8alpha.0.28:
Browse files Browse the repository at this point in the history 
	Fix bug 47d (DEFGENERIC must signal PROGRAM-ERROR when
	attempting to create a generic function with the same name as a
	special operator).
	... sounds easy, huh?  No.
	... make COMPILER-ERROR not inherit from ERROR any more, so that
		user handlers don't (wrongly) claim to handle it;
	... establish a handler for COMPILER-ERROR around the evaluator
		that delegates to the compiler handlers if present, but
		handles them itself if not...
	... by signalling an error from a new internal restart, to allow
		user handlers for ERROR and friends a chance to run.
  • Loading branch information
@csrhodes
csrhodes committed May 13, 2003
1 parent ac85367 commit 6f095a4
Show file tree
Hide file tree
Showing 8 changed files with 261 additions and 198 deletions.
18 changes: 0 additions & 18 deletions BUGS
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -258,24 +258,6 @@ WORKAROUND:
not a binary input stream, but instead cheerfully reads from not a binary input stream, but instead cheerfully reads from
character streams, e.g. (MAKE-STRING-INPUT-STREAM "abc"). character streams, e.g. (MAKE-STRING-INPUT-STREAM "abc").


47:
DEFCLASS bugs reported by Peter Van Eynde July 25, 2000:
d: (DEFGENERIC IF (X)) should signal a PROGRAM-ERROR, but instead
causes a COMPILER-ERROR.

51:
miscellaneous errors reported by Peter Van Eynde July 25, 2000:
a: (PROGN
(DEFGENERIC FOO02 (X))
(DEFMETHOD FOO02 ((X NUMBER)) T)
(LET ((M (FIND-METHOD (FUNCTION FOO02)
NIL
(LIST (FIND-CLASS (QUOTE NUMBER))))))
(REMOVE-METHOD (FUNCTION FOO02) M)
(DEFGENERIC FOO03 (X))
(ADD-METHOD (FUNCTION FOO03) M)))
should give an error, but SBCL allows it.

60: 60:
The debugger LIST-LOCATIONS command doesn't work properly. The debugger LIST-LOCATIONS command doesn't work properly.


Expand Down
3 changes: 3 additions & 0 deletions NEWS
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -1722,6 +1722,9 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
SB-MOP:EFFECTIVE-SLOT-DEFINITION-CLASS now have the SB-MOP:EFFECTIVE-SLOT-DEFINITION-CLASS now have the
specified-by-AMOP lambda list of (CLASS &REST INITARGS). specified-by-AMOP lambda list of (CLASS &REST INITARGS).
* compiler checks for duplicated variables in macro lambda lists. * compiler checks for duplicated variables in macro lambda lists.
* fixed bug 47.d: (DEFGENERIC IF (X)) now signals a PROGRAM-ERROR,
not a COMPILER-ERROR (followed by some other strange error on
choosing the CONTINUE restart).
* fixed some bugs revealed by Paul Dietz' test suite: * fixed some bugs revealed by Paul Dietz' test suite:
** the GENERIC-FUNCTION type is no longer disjoint from FUNCTION ** the GENERIC-FUNCTION type is no longer disjoint from FUNCTION
types. types.
Expand Down
343 changes: 185 additions & 158 deletions src/code/eval.lisp
View file
Original file line number Original file line Diff line number Diff line change
Expand Up @@ -14,11 +14,17 @@
;;; general case of EVAL (except in that it can't handle toplevel ;;; general case of EVAL (except in that it can't handle toplevel
;;; EVAL-WHEN magic properly): Delegate to #'COMPILE. ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
(defun %eval (expr lexenv) (defun %eval (expr lexenv)
(funcall (sb!c:compile-in-lexenv ;; FIXME: It might be nice to quieten the toplevel by muffling
(gensym "EVAL-TMPFUN-") ;; warnings generated by this compilation (since we're about to
`(lambda () ;; execute the results irrespective of the warnings). We might want
,expr) ;; to be careful about not muffling warnings arising from inner
lexenv))) ;; evaluations/compilations, though [e.g. the ignored variable in
;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13
(let ((fun (sb!c:compile-in-lexenv (gensym "EVAL-TMPFUN-")
`(lambda ()
,expr)
lexenv)))
(funcall fun)))


;;; Handle PROGN and implicit PROGN. ;;; Handle PROGN and implicit PROGN.
(defun eval-progn-body (progn-body lexenv) (defun eval-progn-body (progn-body lexenv)
Expand Down Expand Up @@ -52,159 +58,180 @@
(defun eval-in-lexenv (original-exp lexenv) (defun eval-in-lexenv (original-exp lexenv)
(declare (optimize (safety 1))) (declare (optimize (safety 1)))
;; (aver (lexenv-simple-p lexenv)) ;; (aver (lexenv-simple-p lexenv))
(let ((exp (macroexpand original-exp lexenv))) (handler-bind
(typecase exp ((sb!c:compiler-error
(symbol (lambda (c)
(ecase (info :variable :kind exp) (if (boundp 'sb!c::*compiler-error-bailout*)
(:constant ;; if we're in the compiler, delegate either to a higher
(values (info :variable :constant-value exp))) ;; authority or, if that's us, back down to the
((:special :global) ;; outermost compiler handler...
(symbol-value exp)) (progn
;; FIXME: This special case here is a symptom of non-ANSI (signal c)
;; weirdness in SBCL's ALIEN implementation, which could nil)
;; cause problems for e.g. code walkers. It'd probably be ;; ... if we're not in the compiler, better signal a
;; good to ANSIfy it by making alien variable accessors into ;; program error straight away.
;; ordinary forms, e.g. (SB-UNIX:ENV) and (SETF SB-UNIX:ENV), (invoke-restart 'sb!c::signal-program-error)))))
;; instead of magical symbols, e.g. plain SB-UNIX:ENV. Then (let ((exp (macroexpand original-exp lexenv)))
;; if the old magical-symbol syntax is to be retained for (typecase exp
;; compatibility, it can be implemented with (symbol
;; DEFINE-SYMBOL-MACRO, keeping the code walkers happy. (ecase (info :variable :kind exp)
(:alien (:constant
(%eval original-exp lexenv)))) (values (info :variable :constant-value exp)))
(list ((:special :global)
(let ((name (first exp)) (symbol-value exp))
(n-args (1- (length exp)))) ;; FIXME: This special case here is a symptom of non-ANSI
(case name ;; weirdness in SBCL's ALIEN implementation, which could
((function) ;; cause problems for e.g. code walkers. It'd probably be
(unless (= n-args 1) ;; good to ANSIfy it by making alien variable accessors
(error "wrong number of args to FUNCTION:~% ~S" exp)) ;; into ordinary forms, e.g. (SB-UNIX:ENV) and (SETF
(let ((name (second exp))) ;; SB-UNIX:ENV), instead of magical symbols, e.g. plain
(if (and (legal-fun-name-p name) ;; SB-UNIX:ENV. Then if the old magical-symbol syntax is to
(not (consp (let ((sb!c:*lexenv* lexenv)) ;; be retained for compatibility, it can be implemented
(sb!c:lexenv-find name funs))))) ;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
(fdefinition name) ;; happy.
(%eval original-exp lexenv)))) (:alien
((quote) (%eval original-exp lexenv))))
(unless (= n-args 1) (list
(error "wrong number of args to QUOTE:~% ~S" exp)) (let ((name (first exp))
(second exp)) (n-args (1- (length exp))))
(setq (case name
(unless (evenp n-args) ((function)
(error "odd number of args to SETQ:~% ~S" exp)) (unless (= n-args 1)
(unless (zerop n-args) (error "wrong number of args to FUNCTION:~% ~S" exp))
(do ((name (cdr exp) (cddr name))) (let ((name (second exp)))
((null name) (if (and (legal-fun-name-p name)
(do ((args (cdr exp) (cddr args))) (not (consp (let ((sb!c:*lexenv* lexenv))
((null (cddr args)) (sb!c:lexenv-find name funs)))))
;; We duplicate the call to SET so that the (fdefinition name)
;; correct value gets returned. (%eval original-exp lexenv))))
(set (first args) (eval (second args)))) ((quote)
(set (first args) (eval (second args))))) (unless (= n-args 1)
(let ((symbol (first name))) (error "wrong number of args to QUOTE:~% ~S" exp))
(case (info :variable :kind symbol) (second exp))
;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE* (setq
;; test here, and removed the *TOPLEVEL-AUTO-DECLARE* (unless (evenp n-args)
;; variable; the code should now act as though that (error "odd number of args to SETQ:~% ~S" exp))
;; variable is NIL. This should be tested.. (unless (zerop n-args)
(:special) (do ((name (cdr exp) (cddr name)))
(t (return (%eval original-exp lexenv)))))))) ((null name)
((progn) (do ((args (cdr exp) (cddr args)))
(eval-progn-body (rest exp) lexenv)) ((null (cddr args))
((eval-when) ;; We duplicate the call to SET so that the
;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR ;; correct value gets returned.
;; instead of PROGRAM-ERROR when there's something wrong (set (first args) (eval (second args))))
;; with the syntax here (e.g. missing SITUATIONS). This (set (first args) (eval (second args)))))
;; could be fixed by hand-crafting clauses to catch and (let ((symbol (first name)))
;; report each possibility, but it would probably be (case (info :variable :kind symbol)
;; cleaner to write a new macro ;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE*
;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does ;; test here, and removed the
;; DESTRUCTURING-BIND and promotes any mismatch to ;; *TOPLEVEL-AUTO-DECLARE* variable; the code
;; PROGRAM-ERROR, then to use it here and in (probably ;; should now act as though that variable is
;; dozens of) other places where the same problem arises. ;; NIL. This should be tested..
(destructuring-bind (eval-when situations &rest body) exp (:special)
(declare (ignore eval-when)) (t (return (%eval original-exp lexenv))))))))
(multiple-value-bind (ct lt e) ((progn)
(sb!c:parse-eval-when-situations situations) (eval-progn-body (rest exp) lexenv))
;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of ((eval-when)
;; the situation :EXECUTE (or EVAL) controls whether ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
;; evaluation occurs for other EVAL-WHEN forms; that ;; instead of PROGRAM-ERROR when there's something wrong
;; is, those that are not top level forms, or those in ;; with the syntax here (e.g. missing SITUATIONS). This
;; code processed by EVAL or COMPILE. If the :EXECUTE ;; could be fixed by hand-crafting clauses to catch and
;; situation is specified in such a form, then the ;; report each possibility, but it would probably be
;; body forms are processed as an implicit PROGN; ;; cleaner to write a new macro
;; otherwise, the EVAL-WHEN form returns NIL. ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
(declare (ignore ct lt)) ;; DESTRUCTURING-BIND and promotes any mismatch to
(when e ;; PROGRAM-ERROR, then to use it here and in (probably
(eval-progn-body body lexenv))))) ;; dozens of) other places where the same problem
((locally) ;; arises.
(multiple-value-bind (body decls) (parse-body (rest exp) nil) (destructuring-bind (eval-when situations &rest body) exp
(let ((lexenv (declare (ignore eval-when))
;; KLUDGE: Uh, yeah. I'm not anticipating (multiple-value-bind (ct lt e)
;; winning any prizes for this code, which was (sb!c:parse-eval-when-situations situations)
;; written on a "let's get it to work" basis. ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
;; These seem to be the variables that need ;; the situation :EXECUTE (or EVAL) controls whether
;; bindings for PROCESS-DECLS to work ;; evaluation occurs for other EVAL-WHEN forms; that
;; (*FREE-FUNS* and *FREE-VARS* so that ;; is, those that are not top level forms, or those
;; references to free functions and variables in ;; in code processed by EVAL or COMPILE. If the
;; the declarations can be noted; ;; :EXECUTE situation is specified in such a form,
;; *UNDEFINED-WARNINGS* so that warnings about ;; then the body forms are processed as an implicit
;; undefined things can be accumulated [and then ;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
;; thrown away, as it happens]). -- CSR, 2002-10-24 (declare (ignore ct lt))
(let ((sb!c:*lexenv* lexenv) (when e
(sb!c::*free-funs* (make-hash-table :test 'equal)) (eval-progn-body body lexenv)))))
(sb!c::*free-vars* (make-hash-table :test 'eq)) ((locally)
(sb!c::*undefined-warnings* nil)) (multiple-value-bind (body decls) (parse-body (rest exp) nil)
(sb!c::process-decls decls (let ((lexenv
nil nil ;; KLUDGE: Uh, yeah. I'm not anticipating
(sb!c::make-continuation) ;; winning any prizes for this code, which was
lexenv)))) ;; written on a "let's get it to work" basis.
(eval-progn-body body lexenv)))) ;; These seem to be the variables that need
((macrolet) ;; bindings for PROCESS-DECLS to work
(destructuring-bind (definitions &rest body) ;; (*FREE-FUNS* and *FREE-VARS* so that
(rest exp) ;; references to free functions and variables
;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV ;; in the declarations can be noted;
(declare (type list definitions)) ;; *UNDEFINED-WARNINGS* so that warnings about
(unless (= (length definitions) ;; undefined things can be accumulated [and
(length (remove-duplicates definitions :key #'first))) ;; then thrown away, as it happens]). -- CSR,
(style-warn "duplicate definitions in ~S" definitions)) ;; 2002-10-24
(let ((lexenv (let ((sb!c:*lexenv* lexenv)
(sb!c::make-lexenv (sb!c::*free-funs* (make-hash-table :test 'equal))
:default lexenv (sb!c::*free-vars* (make-hash-table :test 'eq))
:funs (mapcar (sb!c::*undefined-warnings* nil))
(sb!c::macrolet-definitionize-fun (sb!c::process-decls decls
:eval nil nil
;; I'm not sure that this is the correct (sb!c::make-continuation)
;; LEXENV to be compiling local macros lexenv))))
;; in... (eval-progn-body body lexenv))))
lexenv) ((macrolet)
definitions)))) (destructuring-bind (definitions &rest body)
(eval-in-lexenv `(locally ,@body) lexenv)))) (rest exp)
((symbol-macrolet) ;; FIXME: shared code with
(destructuring-bind (definitions &rest body) ;; FUNCALL-IN-FOOMACROLET-LEXENV
(rest exp) (declare (type list definitions))
;; FIXME: shared code with FUNCALL-IN-FOOMACROLET-LEXENV (unless (= (length definitions)
(declare (type list definitions)) (length (remove-duplicates definitions
(unless (= (length definitions) :key #'first)))
(length (remove-duplicates definitions :key #'first))) (style-warn "duplicate definitions in ~S" definitions))
(style-warn "duplicate definitions in ~S" definitions)) (let ((lexenv
(let ((lexenv (sb!c::make-lexenv
(sb!c::make-lexenv :default lexenv
:default lexenv :funs (mapcar
:vars (mapcar (sb!c::macrolet-definitionize-fun
(sb!c::symbol-macrolet-definitionize-fun :eval
:eval) ;; I'm not sure that this is the
definitions)))) ;; correct LEXENV to be compiling
(eval-in-lexenv `(locally ,@body) lexenv)))) ;; local macros in...
(t lexenv)
(if (and (symbolp name) definitions))))
(eq (info :function :kind name) :function)) (eval-in-lexenv `(locally ,@body) lexenv))))
(collect ((args)) ((symbol-macrolet)
(dolist (arg (rest exp)) (destructuring-bind (definitions &rest body)
(args (eval-in-lexenv arg lexenv))) (rest exp)
(apply (symbol-function name) (args))) ;; FIXME: shared code with
(%eval exp lexenv)))))) ;; FUNCALL-IN-FOOMACROLET-LEXENV
(t (declare (type list definitions))
exp)))) (unless (= (length definitions)
(length (remove-duplicates definitions
:key #'first)))
(style-warn "duplicate definitions in ~S" definitions))
(let ((lexenv
(sb!c::make-lexenv
:default lexenv
:vars (mapcar
(sb!c::symbol-macrolet-definitionize-fun
:eval)
definitions))))
(eval-in-lexenv `(locally ,@body) lexenv))))
(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 ;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler ;;; ordinarily handled magically by the compiler
Expand Down
Loading

0 comments on commit 6f095a4

Please sign in to comment.