improving python parser and compiler

1 files changed, 90 insertions, 81 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index 792a89a..8ac2325 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -700,88 +700,93 @@ explicitly tell it to not update etc.
 
 (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) ...)
+       #'(mk-p-class name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef dname dval) ...)
        (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)) ...)
-		     (make-p-class 'name
+		     (make-p-class 'name doc
 				    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) ...)
+       #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
+      ((_ name parents doc (ddef 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)