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