compiles to bytecode, fails to load

1 files changed, 50 insertions, 1 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 8ac2325..2e9f9d2 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -10,7 +10,7 @@
   #:export (set ref make-p <p> <py> <pf> <pyf> <property>
                 call with copy fset fcall put put!
                 pcall pcall! get fset-x pyclass?                
-                def-p-class   mk-p-class   make-p-class
+                def-p-class   mk-p-class   make-p-class mk-p-class2
                 define-python-class define-python-class-noname
 		get-type py-class
                 object-method class-method static-method
@@ -856,6 +856,55 @@ explicitly tell it to not update etc.
 	    (name-object name)
 	    name))))))
 
+(define-syntax mk-p-class2
+  (lambda (x)
+    (syntax-case x ()
+      ((_ name parents ((ddef dname dval) ...) body)
+       #'(mk-p-class name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
+       (with-syntax (((ddname ...)
+		      (map (lambda (dn)
+			     (datum->syntax
+			      #'name
+			      (string->symbol
+			       (string-append
+				(symbol->string
+				 (syntax->datum #'name))
+				"-"
+				(symbol->string
+				 (syntax->datum dn))))))
+			   #'(dname ...)))
+		     (nname (datum->syntax
+			     #'name
+			     (string->symbol
+			      (string-append
+			       (symbol->string
+				(syntax->datum #'name))
+			       "-goops-class")))))
+	 (%add-to-warn-list (syntax->datum #'nname))
+         (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
+              #'(ddname ...))
+	#'(let ()
+	    (define name 
+	      (letruc ((dname (make-up dval)) ...)
+                     body
+		     (make-p-class 'name doc
+				    parents
+				    (lambda (dict)
+				      (pylist-set! dict 'dname dname)
+				      ...
+				      (values)))))
+
+	    (begin
+	      (module-define! (current-module) 'ddname (ref name 'dname))
+	      (name-object ddname))
+	    ...
+
+	    (module-define! (current-module) 'nname (ref name '__goops__))
+	    (name-object nname)
+	    (name-object name)
+	    name))))))
+
 (define-syntax mk-p-class-noname
   (lambda (x)
     (syntax-case x ()