-(defmacro name-get-fdefinition (name)
- (sb-int:once-only ((name name))
- `(if (symbolp ,name) ; take care of "setf <fun>"'s
- (symbol-function ,name)
- (fdefinition ,name))))
-
-(defmacro name-set-fdefinition (name new-definition)
- (sb-int:once-only ((name name))
- `(if (symbolp ,name) ; take care of "setf <fun>"'s
- (setf (symbol-function ,name) ,new-definition)
- (setf (fdefinition ,name) ,new-definition))))
-
-;;; FIXME: CONSTANTLY-FOO should be boosted up to SB-INT too.
-(macrolet ((def-constantly-fun (name constant-expr)
- `(setf (symbol-function ',name)
- (constantly ,constant-expr))))
- (def-constantly-fun constantly-t t)
- (def-constantly-fun constantly-nil nil)
- (def-constantly-fun constantly-0 0))
-
-;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun extract-declarations (body &optional environment)
- ;;(declare (values documentation declarations body))
- (let (documentation
- declarations
- form)
- (when (and (stringp (car body))
- (cdr body))
- (setq documentation (pop body)))
- (block outer
- (loop
- (when (null body) (return-from outer nil))
- (setq form (car body))
- (when (block inner
- (loop (cond ((not (listp form))
- (return-from outer nil))
- ((eq (car form) 'declare)
- (return-from inner 't))
- (t
- (multiple-value-bind (newform macrop)
- (macroexpand-1 form environment)
- (if (or (not (eq newform form)) macrop)
- (setq form newform)
- (return-from outer nil)))))))
- (pop body)
- (dolist (declaration (cdr form))
- (push declaration declarations)))))
- (values documentation
- (and declarations `((declare ,.(nreverse declarations))))
- body)))
-) ; EVAL-WHEN