- ;; FIXME: Since none of these are supported in SBCL, the
- ;; declarations using them are just noise now that this is
- ;; not a portable package any more, and could be deleted.
- values ; I use this so that Zwei can remind
- ; me what values a function returns.
- arglist ; Tells me what the pretty arglist
- ; of something (which probably takes
- ; &REST args) is.
- indentation ; Tells ZWEI how to indent things
- ; like DEFCLASS.
- class
- variable-rebinding
- pcl-fast-call
- method-name
- method-lambda-list))
-
-;;; 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. 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 SBCL 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)))
-
-;;; Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0
-;;; and boost them up to SB-INT.
-(defun true (&rest ignore) (declare (ignore ignore)) t)
-(defun false (&rest ignore) (declare (ignore ignore)) nil)
-(defun zero (&rest ignore) (declare (ignore ignore)) 0)
-
-;;; 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 CMU CL, and there's one
-;;; in SB-EXT already (presently to go in SB-INT). 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
-
-;;; FIXME: This seems to only be used to get 'METHOD-NAME and
-;;; METHOD-LAMBDA-LIST declarations. They aren't ANSI. Are they important?