X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fmacros.lisp;h=156d1e428dccacc03e6b3467e0f83d8e103c7135;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=e2fc870b75824c306607dc71883b85caa1c09b19;hpb=f5133ab2ffcddbcdb330cbbceff3af8d66673ce8;p=sbcl.git diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index e2fc870..156d1e4 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -44,42 +44,6 @@ (/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) - (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 EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS") - (defun get-declaration (name declarations &optional default) (dolist (d declarations default) (dolist (form (cdr d)) @@ -88,18 +52,14 @@ (/show "pcl/macros.lisp 85") -(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))))) +(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") @@ -115,9 +75,7 @@ ;;;; 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") @@ -129,9 +87,6 @@ (defmacro find-class-cell-predicate (cell) `(cadr ,cell)) -(defmacro find-class-cell-make-instance-function-keys (cell) - `(cddr ,cell)) - (defmacro make-find-class-cell (class-name) (declare (ignore class-name)) '(list* nil #'constantly-nil nil)) @@ -150,8 +105,8 @@ (defun find-class-from-cell (symbol cell &optional (errorp t)) (or (find-class-cell-class cell) (and *create-classes-from-internal-structure-definitions-p* - (structure-type-p symbol) - (find-structure-class symbol)) + (or (structure-type-p symbol) (condition-type-p symbol)) + (ensure-non-standard-class symbol)) (cond ((null errorp) nil) ((legal-class-name-p symbol) (error "There is no class named ~S." symbol)) @@ -164,8 +119,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)) @@ -189,9 +143,6 @@ (/show "pcl/macros.lisp 187") -;;; Note that in SBCL as in CMU CL, -;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS. -;;; (Yes, this is a KLUDGE!) (define-compiler-macro find-class (&whole form symbol &optional (errorp t) environment) (declare (ignore environment)) @@ -206,29 +157,30 @@ (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 (classoid-cell-classoid + ',(find-classoid-cell symbol)) (find-class-from-cell ',symbol ,class-cell nil)))))) form)) -(defun (setf find-class) (new-value symbol) - (if (legal-class-name-p symbol) - (let ((cell (find-class-cell symbol))) - (setf (find-class-cell-class cell) new-value) - (when (or (eq *boot-state* 'complete) - (eq *boot-state* 'braid)) - (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)))) - new-value) - (error "~S is not a legal class name." symbol))) +(defun (setf find-class) (new-value name &optional errorp environment) + (declare (ignore errorp environment)) + (cond ((legal-class-name-p name) + (with-single-package-locked-error + (:symbol name "using ~A as the class-name argument in ~ + (SETF FIND-CLASS)")) + (let ((cell (find-class-cell name))) + (setf (find-class-cell-class cell) new-value) + (when (and (eq *boot-state* 'complete) (null new-value)) + (setf (find-classoid name) nil)) + (when (or (eq *boot-state* 'complete) + (eq *boot-state* 'braid)) + (when (and new-value (class-wrapper new-value)) + (setf (find-class-cell-predicate cell) + (fdefinition (class-predicate-name new-value)))) + (update-ctors 'setf-find-class :class new-value :name name)) + new-value)) + (t + (error "~S is not a legal class name." name)))) (/show "pcl/macros.lisp 230") @@ -256,66 +208,4 @@ (defsetf slot-value set-slot-value) -(defun misplaced-lambda-list-keyword (lambda-list keyword) - (error "Lambda list keyword ~S is misplaced in ~S." keyword lambda-list)) - -(defmacro process-lambda-list (lambda-list &rest clauses) - ;; (process-lambda-list '(a b &optional (c 1)) - ;; (&required) - ;; ((&optional (print "Started processing optional arguments")) - ;; (format "Optional argument: ~S~%" it)) - ;; (&rest (print "Rest"))) - (let ((clauses (loop for clause in clauses - collect - (cond ((symbolp (car clause)) - `(,(car clause) nil . ,(cdr clause))) - ((consp (car clause)) - `(,(caar clause) ,(cdar clause) . ,(cdr clause))) - (t (error "Invalid clause format: ~S." clause))))) - (ll (gensym "LL")) - (state (gensym "STATE")) - (restp (gensym "RESTP")) - (check-state (gensym "CHECK-STATE"))) - `(let ((,ll ,lambda-list) - (,state '&required) - (,restp nil)) - (dolist (it ,ll) - (flet ((,check-state (possible) - (unless (memq ,state possible) - (misplaced-lambda-list-keyword ,ll it)))) - (cond ((memq it lambda-list-keywords) - (case it - (&optional (,check-state '(&required)) - ,@(cadr (assoc '&optional clauses))) - (&rest (,check-state '(&required &optional)) - ,@(cadr (assoc '&rest clauses))) - (&key (,check-state '(&required &optional &rest)) - (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll)) - ,@(cadr (assoc '&key clauses))) - (&allow-other-keys (,check-state '(&key)) - ,@(cadr (assoc '&allow-other-keys clauses))) - (&aux (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll)) - ,@(cadr (assoc '&aux clauses))) - (t (error "Unsupported lambda list keyword ~S in ~S." - it ,ll))) - (setq ,state it)) - (t (case ,state - (&required ,@(cddr (assoc '&required clauses))) - (&optional ,@(cddr (assoc '&optional clauses))) - (&rest (when ,restp - (error "Too many variables after &REST in ~S." ,ll)) - (setq ,restp t) - ,@(cddr (assoc '&rest clauses))) - (&key ,@(cddr (assoc '&key clauses))) - (&allow-other-keys (error "Variable ~S after &ALLOW-OTHER-KEY in ~S." - it ,ll)) - (&aux ,@(cddr (assoc '&aux clauses)))))))) - (when (and (eq ,state '&rest) - (not ,restp)) - (error "Omitted &REST variable in ~S." ,ll))))) - (/show "finished with pcl/macros.lisp")