From eb0082fd83014b037763627e70e77228e57ffa2f Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 11 Dec 2011 16:00:11 +0100 Subject: [PATCH] DEFCLASS now expands in terms of LOAD-DEFCLASS, saving some bytes. --- src/c/symbols_list.h | 1 + src/c/symbols_list2.h | 1 + src/clos/defclass.lsp | 84 ++++++++++++++++++++++----------------- src/cmp/proclamations.lsp | 3 ++ src/cmp/sysfun.lsp | 3 ++ src/h/external.h | 3 ++ 6 files changed, 59 insertions(+), 36 deletions(-) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 8cd78b84d..8b85807f0 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1719,6 +1719,7 @@ cl_symbols[] = { {CLOS_ "WRITER-METHOD-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "CLEAR-GFUN-HASH", SI_ORDINARY, si_clear_gfun_hash, 1, OBJNULL}, {CLOS_ "NEED-TO-MAKE-LOAD-FORM-P", CLOS_ORDINARY, ECL_NAME(clos_need_to_make_load_form_p), 1, OBJNULL}, +{CLOS_ "LOAD-DEFCLASS", CLOS_ORDINARY, ECL_NAME(clos_load_defclass), 4, OBJNULL}, #endif {SYS_ "CL-FIXNUM-BITS", SI_CONSTANT, NULL, -1, MAKE_FIXNUM(FIXNUM_BITS)}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 45736f162..bbd8a9f74 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1719,6 +1719,7 @@ cl_symbols[] = { {CLOS_ "WRITER-METHOD-CLASS",NULL}, {SYS_ "CLEAR-GFUN-HASH","si_clear_gfun_hash"}, {CLOS_ "NEED-TO-MAKE-LOAD-FORM-P","ECL_NAME(clos_need_to_make_load_form_p)"}, +{CLOS_ "LOAD-DEFCLASS","ECL_NAME(clos_load_defclass)"}, #endif {SYS_ "CL-FIXNUM-BITS",NULL}, diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp index a42f10b34..21bcddadb 100644 --- a/src/clos/defclass.lsp +++ b/src/clos/defclass.lsp @@ -32,39 +32,50 @@ output-list)))) (defmacro defclass (&whole form &rest args) - (let* (name superclasses slots options - metaclass-name default-initargs documentation - (processed-options '())) - (unless (>= (length args) 3) - (si::simple-program-error "Illegal defclass form: the class name, the superclasses and the slots should always be provided")) - (setq name (first args) - superclasses (second args) - slots (third args) - args (cdddr args)) + (unless (>= (length args) 3) + (si::simple-program-error "Illegal defclass form: the class name, the superclasses and the slots should always be provided")) + (let* ((name (pop args)) + (superclasses (pop args)) + (slots (pop args)) + (options args)) (unless (and (listp superclasses) (listp slots)) (si::simple-program-error "Illegal defclass form: superclasses and slots should be lists")) (unless (and (symbolp name) (every #'symbolp superclasses)) (si::simple-program-error "Illegal defclass form: superclasses and class name are not valid")) - ;; - ;; Here we compose the final form. The slots list, and the default initargs - ;; may contain object that need to be evaluated. Hence, it cannot be always - ;; quoted. - ;; - (do ((l (setf slots (parse-slots slots)) (rest l))) - ((endp l) - (setf slots - (if (every #'constantp slots) - (ext:maybe-quote (mapcar #'ext:maybe-unquote slots)) - `(list ,@slots)))) - (let* ((slotd (first l)) - (initfun (getf slotd :initfunction nil))) - (if initfun - (progn - (remf slotd :initfunction) - (setf slotd (list* 'list :initfunction initfun (mapcar #'ext:maybe-quote slotd)))) - (setf slotd (ext:maybe-quote slotd))) - (setf (first l) slotd))) - (dolist (option args) + `(eval-when (compile load eval) + ,(ext:register-with-pde + form + `(load-defclass ',name ',superclasses + ,(compress-slot-forms slots) + ,(process-class-options options)))))) + +(defun compress-slot-forms (slot-definitions) + (declare (si::c-local)) + ;; Here we compose the final form. The slots list, and the default initargs + ;; may contain object that need to be evaluated. Hence, it cannot be always + ;; quoted. + (let ((const '()) + (output '()) + (non-const nil)) + (dolist (slotd (parse-slots slot-definitions)) + (let* ((initfun (getf slotd :initfunction nil))) + (cond (initfun + (let ((copy (copy-list slotd))) + (remf copy :initfunction) + (push `(list* :initfunction ,initfun ,(ext:maybe-quote copy)) + output) + (setf non-const t))) + (t + (push slotd const) + (push (ext:maybe-quote slotd) output))))) + (if non-const + `(list ,@(nreverse output)) + (ext:maybe-quote const)))) + +(defun process-class-options (class-args) + (let ((options '()) + (processed-options '())) + (dolist (option class-args) (let ((option-name (first option)) option-value) (if (member option-name processed-options) @@ -80,13 +91,14 @@ (setf option-name :direct-default-initargs) (parse-default-initargs (rest option))) (otherwise - (ext:maybe-quote (rest option))))) - (setf options (list* (ext:maybe-quote option-name) option-value options)))) - `(eval-when (compile load eval) - ,(ext:register-with-pde form - `(ensure-class ',name :direct-superclasses - ',superclasses - :direct-slots ,slots ,@options))))) + (ext:maybe-quote (rest option)))) + options (list* (ext:maybe-quote option-name) + option-value options)))) + (and options `(list ,@options)))) + +(defun load-defclass (name superclasses slot-definitions options) + (apply #'ensure-class name :direct-superclasses superclasses + :direct-slots slot-definitions options)) ;;; ---------------------------------------------------------------------- ;;; ENSURE-CLASS diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 01da90242..d6c741913 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -1326,6 +1326,9 @@ #+clos (proclamation clos::need-to-make-load-form-p (t) gen-bool :pure) +#+clos +(proclamation clos::load-defclass (t t t t) t) + ;;; ;;; A. FFI ;;; diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 004e0bf8e..efca031cd 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -914,6 +914,8 @@ slot-value slot-exists-p need-to-make-load-form-p + ;; defclass + clos:load-defclass ) ;; cdr-5 @@ -972,6 +974,7 @@ #+clos ,@'(;; defclass.lsp clos::ensure-class + clos::load-defclass ;; combin.lsp clos::simple-code-walker ;; standard.lsp diff --git a/src/h/external.h b/src/h/external.h index dca03e752..91908920b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -2069,6 +2069,9 @@ extern ECL_API cl_object cl_slot_exists_p(cl_object object, cl_object slot); /* print.lsp */ extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o); +/* defclass.lsp */ +extern ECL_API cl_object clos_load_defclass(cl_object name, cl_object superclasses, cl_object slots, cl_object options); + #if 0 /* defclass.lsp */ extern ECL_API cl_object clos_ensure_class _ARGS((cl_narg narg, cl_object V1, ...));