improving python parser and compiler
[software/python-on-guile.git] / modules / oop / pf-objects.scm
index 792a89a25f25e11e4988dd2b172a88c15e094c23..8ac2325a60b6119f3bd8c96bfb7a2a3971b9ddc3 100644 (file)
@@ -700,88 +700,93 @@ explicitly tell it to not update etc.
 
 (define type   #f)
 (define object #f)
 
 (define type   #f)
 (define object #f)
-(define (make-p-class name supers.kw methods)
-  (define kw      (cdr supers.kw))
-  (define supers  (car supers.kw))
-  (define goopses (map (lambda (sups)
-                         (aif it (ref sups '__goops__ #f)
-                              it
-                              sups))
-                       supers))
-  (define parents (let ((p (filter-parents supers)))
-                    (if (null? p)
-                        (if object
-                            (list object)
-                            '())
-                        p)))
-  
-  (define meta (aif it (memq #:metaclass kw)
-                    (cadr it)
-                    (if (null? parents)
-                        type
-                        (let* ((p   (car parents))
-                               (m   (ref p '__class__))
-                               (mro (reverse (ref m '__mro__ '()))))
-                          (let lp ((l   (cdr parents))
-                                   (max mro)
-                                   (min mro))
-                            (if (pair? l)
-                                (let* ((p    (car l))
-                                       (meta (ref p '__class__))
-                                       (mro  (ref meta '__mro__ '())))
-                                  (let lp2 ((max max) (mr (reverse mro)))
-                                    (if (and (pair? max) (pair? mr))
-                                        (if (eq? (car max) (car mr))
-                                            (lp2 (cdr max) (cdr mr))
-                                            (error
-                                             "need a common lead for meta"))
-                                        (if (pair? max)
-                                            (if (< (length mro) (length min))
-                                                (lp (cdr l) max mro)
-                                                (lp (cdr l) max min))
-                                            (lp (cdr l) mro min)))))
-                                (car (reverse min))))))))
+(define make-p-class
+  (case-lambda
+   ((name supers.kw methods)
+    (make-p-class name "" supers.kw methods))
+   ((name doc supers.kw methods)
+    (define kw      (cdr supers.kw))
+    (define supers  (car supers.kw))
+    (define goopses (map (lambda (sups)
+                          (aif it (ref sups '__goops__ #f)
+                               it
+                               sups))
+                        supers))
+    (define parents (let ((p (filter-parents supers)))
+                     (if (null? p)
+                         (if object
+                             (list object)
+                             '())
+                         p)))
+    
+    (define meta (aif it (memq #:metaclass kw)
+                     (cadr it)
+                     (if (null? parents)
+                         type
+                         (let* ((p   (car parents))
+                                (m   (ref p '__class__))
+                                (mro (reverse (ref m '__mro__ '()))))
+                           (let lp ((l   (cdr parents))
+                                    (max mro)
+                                    (min mro))
+                             (if (pair? l)
+                                 (let* ((p    (car l))
+                                        (meta (ref p '__class__))
+                                        (mro  (ref meta '__mro__ '())))
+                                   (let lp2 ((max max) (mr (reverse mro)))
+                                     (if (and (pair? max) (pair? mr))
+                                         (if (eq? (car max) (car mr))
+                                             (lp2 (cdr max) (cdr mr))
+                                             (error
+                                              "need a common lead for meta"))
+                                         (if (pair? max)
+                                             (if (< (length mro) (length min))
+                                                 (lp (cdr l) max mro)
+                                                 (lp (cdr l) max min))
+                                             (lp (cdr l) mro min)))))
+                                 (car (reverse min))))))))
   
   
-  (define goops (make-class (append goopses (list (kw->class kw meta)))
-                            '() #:name name))
-
-  (define (make-module)
-    (let ((l (module-name (current-module))))
-      (if (and (>= (length l) 3)
-              (equal? (list-ref l 0) 'language)
-              (equal? (list-ref l 1) 'python)
-              (equal? (list-ref l 2) 'module))
-         (string-join
-          (map symbol->string (cdddr l))
-          ".")
-         l)))
+    (define goops (make-class (append goopses (list (kw->class kw meta)))
+                             '() #:name name))
+
+    (define (make-module)
+      (let ((l (module-name (current-module))))
+       (if (and (>= (length l) 3)
+                (equal? (list-ref l 0) 'language)
+                (equal? (list-ref l 1) 'python)
+                (equal? (list-ref l 2) 'module))
+           (string-join
+            (map symbol->string (cdddr l))
+            ".")
+           l)))
   
   
-  (define (gen-methods dict)
-    (methods dict)
-    (pylist-set! dict '__goops__    goops)
-    (pylist-set! dict '__class__    meta)
-    (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
-    (pylist-set! dict '__module__   (make-module))
-    (pylist-set! dict '__bases__    parents)
-    (pylist-set! dict '__fget__     #t)
-    (pylist-set! dict '__fset__     #t)
-    (pylist-set! dict '__name__     name)
-    (pylist-set! dict '__qualname__ name)
-    (pylist-set! dict '__class__    meta)
-    (pylist-set! dict '__mro__      (get-mro parents))
-    dict)
-
-  (let ((cl (with-fluids ((*make-class* #t))
-                        (create-class meta name parents gen-methods kw))))
-    (aif it (ref meta '__init_subclass__)
-        (let lp ((ps parents))
-          (if (pair? ps)
-              (let ((super (car ps)))
-                (it cl super)
-                (lp (cdr ps)))))
-        #f)
+    (define (gen-methods dict)
+      (methods dict)
+      (pylist-set! dict '__goops__    goops)
+      (pylist-set! dict '__class__    meta)
+      (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
+      (pylist-set! dict '__module__   (make-module))
+      (pylist-set! dict '__bases__    parents)
+      (pylist-set! dict '__fget__     #t)
+      (pylist-set! dict '__fset__     #t)
+      (pylist-set! dict '__name__     name)
+      (pylist-set! dict '__qualname__ name)
+      (pylist-set! dict '__class__    meta)
+      (pylist-set! dict '__mro__      (get-mro parents))
+      (pylist-set! dict '__doc__      doc)
+      dict)
+
+    (let ((cl (with-fluids ((*make-class* #t))
+                          (create-class meta name parents gen-methods kw))))
+      (aif it (ref meta '__init_subclass__)
+          (let lp ((ps parents))
+            (if (pair? ps)
+                (let ((super (car ps)))
+                  (it cl super)
+                  (lp (cdr ps)))))
+          #f)
     
     
-    cl))
+      cl))))
                    
 
 
                    
 
 
@@ -807,6 +812,8 @@ explicitly tell it to not update etc.
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
+       #'(mk-p-class name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
        (with-syntax (((ddname ...)
                      (map (lambda (dn)
                             (datum->syntax
        (with-syntax (((ddname ...)
                      (map (lambda (dn)
                             (datum->syntax
@@ -832,7 +839,7 @@ explicitly tell it to not update etc.
        #'(let ()
            (define name 
              (letruc ((dname (make-up dval)) ...)
        #'(let ()
            (define name 
              (letruc ((dname (make-up dval)) ...)
-                    (make-p-class 'name
+                    (make-p-class 'name doc
                                    parents
                                    (lambda (dict)
                                      (pylist-set! dict 'dname dname)
                                    parents
                                    (lambda (dict)
                                      (pylist-set! dict 'dname dname)
@@ -853,10 +860,12 @@ explicitly tell it to not update etc.
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
   (lambda (x)
     (syntax-case x ()
       ((_ name parents (ddef dname dval) ...)
+       #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
        #'(let ()
           (define name 
             (letruc ((dname dval) ...)
        #'(let ()
           (define name 
             (letruc ((dname dval) ...)
-                    (make-p-class 'name
+                    (make-p-class 'name doc
                                   parents
                                   (lambda (dict)
                                     (pylist-set! dict 'dname dname)
                                   parents
                                   (lambda (dict)
                                     (pylist-set! dict 'dname dname)