+
+;;; 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))))))))
+