fix that :export even more
Thu May 29 05:42:10 PDT 2008 attila.lendvai@gmail.com
* fix that :export even more
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.
diff -rN -u old-defclass-star/defclass-star.lisp new-defclass-star/defclass-star.lisp
--- old-defclass-star/defclass-star.lisp 2014-07-23 23:30:47.000000000 -0700
+++ new-defclass-star/defclass-star.lisp 2014-07-23 23:30:47.000000000 -0700
@@ -183,7 +183,11 @@
:slot-definition-transformer *slot-definition-transformer*)))
(values binding-names binding-values (nreverse clean-options))))
-(defun build-defclass-like-expansion (name supers slots options expansion-builder)
+(defun build-defclass-like-expansion (name supers slots options expansion-builder
+ &key
+ (export-class-name *export-class-name-p*)
+ (export-accessor-names *export-accessor-names-p*)
+ (export-slot-names *export-slot-names-p*))
(declare (ignore supers))
(unless (eq (symbol-package name) *package*)
(style-warn "defclass* for ~A while its home package is not *package* (~A)"
@@ -195,9 +199,12 @@
(multiple-value-bind (binding-names binding-values clean-options)
(extract-options-into-bindings options)
(progv binding-names (mapcar #'eval binding-values)
- (let ((result (funcall expansion-builder
- (mapcar 'process-slot-definition slots)
- clean-options)))
+ (let* ((*export-class-name-p* export-class-name)
+ (*export-accessor-names-p* export-accessor-names)
+ (*export-slot-names-p* export-slot-names)
+ (result (funcall expansion-builder
+ (mapcar 'process-slot-definition slots)
+ clean-options)))
(if (or *symbols-to-export*
*export-class-name-p*
*export-accessor-names-p*
diff -rN -u old-defclass-star/integration/cl-def-integration.lisp new-defclass-star/integration/cl-def-integration.lisp
--- old-defclass-star/integration/cl-def-integration.lisp 2014-07-23 23:30:47.000000000 -0700
+++ new-defclass-star/integration/cl-def-integration.lisp 2014-07-23 23:30:47.000000000 -0700
@@ -9,43 +9,14 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cl-def :defclass-star))
-;; TODO this is too similar to build-defclass-like-expansion, factor out
-(defun build-defclass-like-cl-def-expansion (name supers slots class-options -options-
- expansion-builder)
- (declare (ignore supers))
- (unless (eq (symbol-package name) *package*)
- (style-warn "def class* for ~A while its home package is not *package* (~A)"
- (let ((*package* (find-package "KEYWORD")))
- (format nil "~S" name)) *package*))
- (let ((*accessor-names* nil)
- (*slot-names* nil))
- (multiple-value-bind (binding-names binding-values clean-class-options)
- (extract-options-into-bindings class-options)
- (progv binding-names (mapcar #'eval binding-values)
- (let* ((*export-class-name-p* (getf -options- :export
- *export-class-name-p*))
- (*export-accessor-names-p* (getf -options- :export-accessor-names
- *export-accessor-names-p*))
- (*export-slot-names-p* (getf -options- :export-slot-names
- *export-slot-names-p*))
- (result (funcall expansion-builder
- (mapcar 'process-slot-definition slots)
- clean-class-options)))
- (if (or *export-class-name-p*
- *export-accessor-names-p*
- *export-slot-names-p*)
- `(progn
- ,result
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(,@(append (when *export-class-name-p*
- (list name))
- (when *export-accessor-names-p*
- (nreverse *accessor-names*))
- (when *export-slot-names-p*
- (nreverse *slot-names*))))
- ,(package-name *package*)))
- (find-class ',name nil))
- result))))))
+(defun build-defclass-like-cl-def-expansion (name supers slots class-options -options- expansion-builder)
+ (build-defclass-like-expansion name supers slots class-options expansion-builder
+ :export-class-name (getf -options- :export
+ *export-class-name-p*)
+ :export-accessor-names (getf -options- :export-accessor-names
+ *export-accessor-names-p*)
+ :export-slot-names (getf -options- :export-slot-names
+ *export-slot-names-p*)))
(def (definer :available-flags "eas") class* (name supers slots &rest class-options)
(build-defclass-like-cl-def-expansion
@@ -69,6 +40,6 @@
#|
(def (class* eas) foo (super)
- ((slot1 42)))
+ ((slot1 42 :export :slot)))
|#