X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=44b51bb758c2858cdbbd32e9a6f7f6a1f63de1d5;hb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;hp=4025d9b3ca98662dc3881e12ca738c88ba4e0564;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 4025d9b..44b51bb 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -23,8 +23,10 @@ ;;;; 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 @@ -37,65 +39,52 @@ ;; information around, I'm not sure. -- WHN 2000-12-30 %variable-rebinding)) -(defmacro name-get-fdefinition (name) - (sb-int:once-only ((name name)) - `(if (symbolp ,name) ; take care of "setf "'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 "'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) - `(name-set-fdefinition ',name - (constantly ,constant-expr)))) - (def-constantly-fun constantly-t t) - (def-constantly-fun constantly-nil nil) - (def-constantly-fun constantly-0 0)) +(/show "done with DECLAIM DECLARATION") ;;; 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) + declarations + form) (when (and (stringp (car body)) - (cdr 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))))) + (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))) + (and declarations `((declare ,.(nreverse declarations)))) + body))) ) ; EVAL-WHEN +(/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS") + (defun get-declaration (name declarations &optional default) (dolist (d declarations default) (dolist (form (cdr d)) (when (and (consp form) (eq (car form) name)) (return-from get-declaration (cdr form)))))) +(/show "pcl/macros.lisp 85") + (defmacro collecting-once (&key initial-value) `(let* ((head ,initial-value) (tail ,(and initial-value `(last head)))) @@ -107,6 +96,8 @@ (cdr (rplacd tail (list value))))))) #'(lambda nil head)))) +(/show "pcl/macros.lisp 98") + (defmacro doplist ((key val) plist &body body &environment env) (multiple-value-bind (doc decls bod) (extract-declarations body env) @@ -120,6 +111,8 @@ (setq ,val (pop .plist-tail.)) (progn ,@bod))))) +(/show "pcl/macros.lisp 113") + (defmacro dolist-carefully ((var list improper-list-handler) &body body) `(let ((,var nil) (.dolist-carefully. ,list)) @@ -136,6 +129,8 @@ ;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from ;;;; PCL:FIND-CLASS, alas. +(/show "pcl/macros.lisp 132") + (defvar *find-class* (make-hash-table :test 'eq)) (defmacro find-class-cell-class (cell) @@ -158,6 +153,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)) @@ -200,6 +197,8 @@ ;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*)) (defvar *boot-state* nil) +(/show "pcl/macros.lisp 199") + ;;; Note that in SBCL as in CMU CL, ;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS. ;;; (Yes, this is a KLUDGE!) @@ -230,16 +229,19 @@ (eq *boot-state* 'braid)) (when (and new-value (class-wrapper new-value)) (setf (find-class-cell-predicate cell) - (name-get-fdefinition (class-predicate-name new-value)))) + (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)) + (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)))) new-value) (error "~S is not a legal class name." symbol))) +(/show "pcl/macros.lisp 242") + (defun (setf find-class-predicate) (new-value symbol) (if (legal-class-name-p symbol) @@ -267,8 +269,10 @@ 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 +(/show "pcl/macros.lisp 271") + +;;; 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)) @@ -291,9 +295,12 @@ (defmacro function-apply (form &rest args) `(apply (the function ,form) ,@args)) - -(defun get-setf-function-name (name) +(/show "pcl/macros.lisp 299") + +(defun get-setf-fun-name (name) `(setf ,name)) (defsetf slot-value set-slot-value) + +(/show "finished with pcl/macros.lisp")