- ;; These three nonstandard declarations seem to be used
- ;; privately within PCL itself to pass information around,
- ;; so we can't just delete them.
- %class
- %method-name
- %method-lambda-list
- ;; This declaration may also be used within PCL to pass
- ;; information around, I'm not sure. -- WHN 2000-12-30
- %variable-rebinding))
-
-;;; comment from CMU CL PCL:
-;;; These are age-old functions which CommonLisp cleaned-up away. They
-;;; probably exist in other packages in all CommonLisp
-;;; implementations, but I will leave it to the compiler to optimize
-;;; into calls to them.
-;;;
-;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we
-;;; should use those definitions. POSQ and NEQ aren't defined in SBCL,
-;;; and are used too often in PCL to make it appealing to hand expand
-;;; all uses and then delete the macros, so they should be boosted up
-;;; to SB-INT to stand by MEMQ, ASSQ, and DELQ.
-(defmacro memq (item list) `(member ,item ,list :test #'eq))
-(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
-(defmacro delq (item list) `(delete ,item ,list :test #'eq))
-(defmacro posq (item list) `(position ,item ,list :test #'eq))
-(defmacro neq (x y) `(not (eq ,x ,y)))
-;;; 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))
-
-;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as
-;;; it does in zetalisp. I should have just lifted it from there but I
-;;; am honest. Not only that but this one is written in Common Lisp. I
-;;; feel a lot like bootstrapping, or maybe more like rebuilding Rome.
-;;;
-;;; FIXME: We should only need one ONCE-ONLY in SBCL, and there's one
-;;; in SB-INT already. Can we use only one of these in both places?
-(defmacro once-only (vars &body body)
- (let ((gensym-var (gensym))
- (run-time-vars (gensym))
- (run-time-vals (gensym))
- (expand-time-val-forms ()))
- (dolist (var vars)
- (push `(if (or (symbolp ,var)
- (numberp ,var)
- (and (listp ,var)
- (member (car ,var) '(quote function))))
- ,var
- (let ((,gensym-var (gensym)))
- (push ,gensym-var ,run-time-vars)
- (push ,var ,run-time-vals)
- ,gensym-var))
- expand-time-val-forms))
- `(let* (,run-time-vars
- ,run-time-vals
- (wrapped-body
- (let ,(mapcar #'list vars (reverse expand-time-val-forms))
- ,@body)))
- `(let ,(mapcar #'list (reverse ,run-time-vars)
- (reverse ,run-time-vals))
- ,wrapped-body))))
-
-;;; 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