DEFCLASS now expands in terms of LOAD-DEFCLASS, saving some bytes.

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)},

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},

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

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
 ;;;

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

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, ...));