X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=e11812d84d1c21f72e68f986772ebe154dd715f0;hb=2abf77f6c4c559a3e5b7fc351a4743305381feb6;hp=c07cc9ea7b1a0e9dcaee6660b5fab5c9bc848bcc;hpb=95a6db7329b91dd90d165dd4057b9b5098d34aa2;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index c07cc9e..e11812d 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -100,9 +100,6 @@ `(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) @@ -180,19 +177,17 @@ (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)) @@ -200,105 +195,33 @@ (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 @@ -333,7 +256,7 @@ (cond ,@(nreverse clauses) ,@(if errorp - `((t (error 'sb!conditions::case-failure + `((t (error 'case-failure :name ',name :datum ,keyform-value :expected-type ',expected-type @@ -367,21 +290,21 @@ "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)) ;;;; WITH-FOO i/o-related macros