X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=823994e0deb14085d5932eee6a6a47c4ebd7edd7;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=70130803c9b26703d96e5bbffd9b60987b88f791;hpb=568b75331113ecd0601449f337557cd1c1776e8d;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 7013080..823994e 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -23,52 +23,26 @@ ;;;; This software is made available AS IS, and Xerox Corporation makes no ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. - + (in-package "SB-PCL") + +(/show "starting pcl/macros.lisp") (declaim (declaration - ;; These three nonstandard declarations seem to be used - ;; privately within PCL itself to pass information around, - ;; so we can't just delete them. - %class + ;; As of sbcl-0.7.0.6, SBCL actively uses this declaration + ;; to propagate information needed to set up nice debug + ;; names (as seen e.g. in BACKTRACE) for method functions. %method-name + ;; These nonstandard declarations seem to be used privately + ;; within PCL itself to pass information around, so we can't + ;; just delete them. + %class %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)) -;;; 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 +(/show "done with DECLAIM DECLARATION") (defun get-declaration (name declarations &optional default) (dolist (d declarations default) @@ -76,29 +50,18 @@ (when (and (consp form) (eq (car form) name)) (return-from get-declaration (cdr form)))))) -(defmacro collecting-once (&key initial-value) - `(let* ((head ,initial-value) - (tail ,(and initial-value `(last head)))) - (values #'(lambda (value) - (if (null head) - (setq head (setq tail (list value))) - (unless (memq value head) - (setq tail - (cdr (rplacd tail (list value))))))) - #'(lambda nil head)))) - -(defmacro doplist ((key val) plist &body body &environment env) - (multiple-value-bind (doc decls bod) - (extract-declarations body env) - (declare (ignore doc)) - `(let ((.plist-tail. ,plist) ,key ,val) - ,@decls - (loop (when (null .plist-tail.) (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "malformed plist, odd number of elements")) - (setq ,val (pop .plist-tail.)) - (progn ,@bod))))) +(/show "pcl/macros.lisp 85") + +(defmacro doplist ((key val) plist &body body) + `(let ((.plist-tail. ,plist) ,key ,val) + (loop (when (null .plist-tail.) (return nil)) + (setq ,key (pop .plist-tail.)) + (when (null .plist-tail.) + (error "malformed plist, odd number of elements")) + (setq ,val (pop .plist-tail.)) + (progn ,@body)))) + +(/show "pcl/macros.lisp 101") (defmacro dolist-carefully ((var list improper-list-handler) &body body) `(let ((,var nil) @@ -112,9 +75,9 @@ ;;;; FIND-CLASS ;;;; -;;;; This is documented in the CLOS specification. FIXME: Except that -;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from -;;;; PCL:FIND-CLASS, alas. +;;;; This is documented in the CLOS specification. + +(/show "pcl/macros.lisp 119") (defvar *find-class* (make-hash-table :test 'eq)) @@ -138,6 +101,8 @@ (error "~S is not a legal class name." symbol)) (setf (gethash symbol *find-class*) (make-find-class-cell symbol))))) +(/show "pcl/macros.lisp 157") + (defvar *create-classes-from-internal-structure-definitions-p* t) (defun find-class-from-cell (symbol cell &optional (errorp t)) @@ -157,8 +122,7 @@ (find-class-cell-predicate cell)) (defun legal-class-name-p (x) - (and (symbolp x) - (not (keywordp x)))) + (symbolp x)) (defun find-class (symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -180,9 +144,8 @@ ;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*)) (defvar *boot-state* nil) -;;; Note that in SBCL as in CMU CL, -;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS. -;;; (Yes, this is a KLUDGE!) +(/show "pcl/macros.lisp 187") + (define-compiler-macro find-class (&whole form symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -197,8 +160,8 @@ (or (find-class-cell-class ,class-cell) ,(if errorp `(find-class-from-cell ',symbol ,class-cell t) - `(and (sb-kernel:class-cell-class - ',(sb-kernel:find-class-cell symbol)) + `(and (sb-kernel:classoid-cell-classoid + ',(sb-kernel:find-classoid-cell symbol)) (find-class-from-cell ',symbol ,class-cell nil)))))) form)) @@ -211,16 +174,12 @@ (when (and new-value (class-wrapper new-value)) (setf (find-class-cell-predicate cell) (fdefinition (class-predicate-name new-value)))) - (when (and new-value (not (forward-referenced-class-p new-value))) - - (dolist (keys+aok (find-class-cell-make-instance-function-keys - cell)) - (update-initialize-info-internal - (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) - 'make-instance-function)))) + (update-ctors 'setf-find-class :class new-value :name symbol)) new-value) (error "~S is not a legal class name." symbol))) +(/show "pcl/macros.lisp 230") + (defun (setf find-class-predicate) (new-value symbol) (if (legal-class-name-p symbol) @@ -230,51 +189,19 @@ (defun find-wrapper (symbol) (class-wrapper (find-class symbol))) -(defmacro gathering1 (gatherer &body body) - `(gathering ((.gathering1. ,gatherer)) - (macrolet ((gather1 (x) `(gather ,x .gathering1.))) - ,@body))) - -(defmacro vectorizing (&key (size 0)) - `(let* ((limit ,size) - (result (make-array limit)) - (index 0)) - (values #'(lambda (value) - (if (= index limit) - (error "vectorizing more elements than promised") - (progn - (setf (svref result index) value) - (incf index) - value))) - #'(lambda () result)))) - -;;; These are augmented definitions of LIST-ELEMENTS and LIST-TAILS from -;;; iterate.lisp. These versions provide the extra :BY keyword which can -;;; be used to specify the step function through the list. -(defmacro *list-elements (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (if (endp tail) - (funcall finish) - (prog1 (car tail) - (setq tail (funcall ,by tail))))))) - -(defmacro *list-tails (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - tail) - (setq tail (funcall ,by tail)))))) +(/show "pcl/macros.lisp 241") (defmacro function-funcall (form &rest args) `(funcall (the function ,form) ,@args)) (defmacro function-apply (form &rest args) `(apply (the function ,form) ,@args)) - -(defun get-setf-function-name (name) +(/show "pcl/macros.lisp 249") + +(defun get-setf-fun-name (name) `(setf ,name)) (defsetf slot-value set-slot-value) + +(/show "finished with pcl/macros.lisp")