diff options
Diffstat (limited to 'modules/oop/pf-objects.scm')
| -rw-r--r-- | modules/oop/pf-objects.scm | 171 |
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) |