(defmacro-mundanely defconstant (name value &optional documentation)
#!+sb-doc
- "For defining global constants. The DEFCONSTANT says that the value
- is constant and may be compiled into code. If the variable already has
+ "For defining global constants. DEFCONSTANT says that the value is
+ constant and may be compiled into code. If the variable already has
a value, and this is not EQL to the init, the code is not portable
(undefined behavior). The third argument is an optional documentation
string for the variable."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(sb!c::%defconstant ',name ,value ',documentation)))
-;;; (to avoid "undefined function" warnings when cross-compiling)
-(sb!xc:proclaim '(ftype function sb!c::%defconstant))
-
;;; the guts of DEFCONSTANT
(defun sb!c::%defconstant (name value doc)
- (/show "doing %DEFCONSTANT" name value doc)
(unless (symbolp name)
(error "constant name not a symbol: ~S" name))
(about-to-modify name)
(let ((kind (info :variable :kind name)))
(case kind
(:constant
- ;; Note 1: This behavior (discouraging any non-EQL
- ;; modification) is unpopular, but it is specified by ANSI
- ;; (i.e. ANSI says a non-EQL change has undefined
- ;; consequences). If people really want bindings which are
- ;; constant in some sense other than EQL, I suggest either just
- ;; using DEFVAR (which is usually appropriate, despite the
- ;; un-mnemonic name), or defining something like
- ;; SB-INT:DEFCONSTANT-EQX (which is occasionally more
- ;; appropriate). -- WHN 2000-11-03
+ ;; Note: This behavior (discouraging any non-EQL modification)
+ ;; is unpopular, but it is specified by ANSI (i.e. ANSI says a
+ ;; non-EQL change has undefined consequences). If people really
+ ;; want bindings which are constant in some sense other than
+ ;; EQL, I suggest either just using DEFVAR (which is usually
+ ;; appropriate, despite the un-mnemonic name), or defining
+ ;; something like SB-INT:DEFCONSTANT-EQX (which is occasionally
+ ;; more appropriate). -- WHN 2000-11-03
(unless (eql value
(info :variable :constant-value name))
(cerror "Go ahead and change the value."
(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; CASE-BODY (interface)
-;;;
-;;; CASE-BODY returns code for all the standard "case" macros. Name is
-;;; the macro name, and keyform is the thing to case on. Multi-p
+;;; CASE-BODY returns code for all the standard "case" macros. NAME is
+;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
;;; indicates whether a branch may fire off a list of keys; otherwise,
;;; a key that is a list is interpreted in some way as a single key.
-;;; When multi-p, test is applied to the value of keyform and each key
-;;; for a given branch; otherwise, test is applied to the value of
-;;; keyform and the entire first element, instead of each part, of the
-;;; case branch. When errorp, no t or otherwise branch is permitted,
-;;; and an ERROR form is generated. When proceedp, it is an error to
-;;; omit errorp, and the ERROR form generated is executed within a
-;;; RESTART-CASE allowing keyform to be set and retested.
+;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
+;;; for a given branch; otherwise, TEST is applied to the value of
+;;; KEYFORM and the entire first element, instead of each part, of the
+;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted,
+;;; and an ERROR form is generated. When PROCEEDP, it is an error to
+;;; omit ERRORP, and the ERROR form generated is executed within a
+;;; RESTART-CASE allowing KEYFORM to be set and retested.
(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
(unless (or cases (not needcasesp))
(warn "no clauses in ~S" name))
(clauses ())
(keys ()))
(dolist (case cases)
- (cond ((atom case)
- (error "~S -- Bad clause in ~S." case name))
- ((memq (car case) '(t otherwise))
- (if errorp
- (error 'simple-program-error
- :format-control "No default clause is allowed in ~S: ~S"
- :format-arguments (list name case))
- (push `(t nil ,@(rest case)) clauses)))
- ((and multi-p (listp (first case)))
- (setf keys (append (first case) keys))
- (push `((or ,@(mapcar #'(lambda (key)
+ (unless (list-of-length-at-least-p case 1)
+ (error "~S -- bad clause in ~S" case name))
+ (destructuring-bind (keyoid &rest forms) case
+ (cond ((memq keyoid '(t otherwise))
+ (if errorp
+ (error 'simple-program-error
+ :format-control
+ "No default clause is allowed in ~S: ~S"
+ :format-arguments (list name case))
+ (push `(t nil ,@forms) clauses)))
+ ((and multi-p (listp keyoid))
+ (setf keys (append keyoid keys))
+ (push `((or ,@(mapcar (lambda (key)
`(,test ,keyform-value ',key))
- (first case)))
- nil ,@(rest case))
- clauses))
- (t
- (push (first case) keys)
- (push `((,test ,keyform-value
- ',(first case)) nil ,@(rest case)) clauses))))
+ keyoid))
+ nil
+ ,@forms)
+ clauses))
+ (t
+ (push keyoid keys)
+ (push `((,test ,keyform-value ',keyoid)
+ nil
+ ,@forms)
+ clauses)))))
(case-body-aux name keyform keyform-value clauses keys errorp proceedp
`(,(if multi-p 'member 'or) ,@keys))))
-
-;;; MNA: typecase-implicit-declarations patch
-
-;;; TYPECASE-BODY (interface)
-;;;
-;;; TYPECASE-BODY returns code for all the standard "typecase" macros.
-;;; Name is the macro name, and keyform is the thing to case on.
-;;; test is applied to the value of keyform and the entire first element,
-;;; instead of each part, of the case branch.
-;;; When errorp, no t or otherwise branch is permitted,
-;;; and an ERROR form is generated. When proceedp, it is an error to
-;;; omit errorp, and the ERROR form generated is executed within a
-;;; RESTART-CASE allowing keyform to be set and retested.
-(defun typecase-body (name keyform cases test errorp proceedp needcasesp)
- (unless (or cases (not needcasesp))
- (warn "no clauses in ~S" name))
- (let* ((keyform-symbol-p (symbolp keyform))
- (keyform-value (unless keyform-symbol-p
- (gensym)))
- (clauses ())
- (keys ()))
- (dolist (case cases)
- (cond ((atom case)
- (error "~S -- Bad clause in ~S." case name))
- ((memq (car case) '(t otherwise))
- (if errorp
- (error 'simple-program-error
- :format-control "No default clause is allowed in ~S: ~S"
- :format-arguments (list name case))
- (push `(t nil ,@(rest case)) clauses)))
- (t
- (push (first case) keys)
- (push (if keyform-symbol-p
- `((,test ,keyform ',(first case)) nil
- (locally
- ;; this will cause a compiler-warning ... disabled
- ;; for now.
- ;; (declare (type ,(first case) ,keyform))
- ,@(rest case)))
- `((,test ,keyform-value ',(first case)) nil
- ,@(rest case)))
- clauses))))
- (if keyform-symbol-p
- (typecase-symbol-body-aux name keyform clauses keys errorp proceedp
- (cons 'or keys))
- (case-body-aux name keyform keyform-value clauses keys errorp proceedp
- (cons 'or keys)))))
-
-;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled
-;;; all the cases, iff keyform is a symbol.
-(defun typecase-symbol-body-aux (name keyform clauses keys
- errorp proceedp expected-type)
- (if proceedp
- (let ((block (gensym))
- (again (gensym)))
- `(block ,block
- (tagbody
- ,again
- (return-from
- ,block
- (cond ,@(nreverse clauses)
- (t
- (setf ,keyform
- (case-body-error
- ',name ',keyform ,keyform
- ',expected-type ',keys)))
- (go ,again))))))
- `(progn
- (cond
- ,@(nreverse clauses)
- ,@(if errorp
- `((t (error 'sb!conditions::case-failure
- :name ',name
- :datum ,keyform
- :expected-type ',expected-type
- :possibilities ',keys))))))))
-
;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
;;; all the cases. Note: it is not necessary that the resulting code
;;; signal case-failure conditions, but that's what KMP's prototype
(cond
,@(nreverse clauses)
,@(if errorp
- `((t (error 'sb!conditions::case-failure
+ `((t (error 'case-failure
:name ',name
:datum ,keyform-value
:expected-type ',expected-type
"TYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true."
- (typecase-body 'typecase keyform cases 'typep nil nil nil))
+ (case-body 'typecase keyform cases nil 'typep nil nil nil))
(defmacro-mundanely ctypecase (keyform &body cases)
#!+sb-doc
"CTYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then a correctable error is signalled."
- (typecase-body 'ctypecase keyform cases 'typep t t t))
+ (case-body 'ctypecase keyform cases nil 'typep t t t))
(defmacro-mundanely etypecase (keyform &body cases)
#!+sb-doc
"ETYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then an error is signalled."
- (typecase-body 'etypecase keyform cases 'typep t nil t))
+ (case-body 'etypecase keyform cases nil 'typep t nil t))
\f
;;;; WITH-FOO i/o-related macros
projects / sbcl.git / blobdiff