modules/oop/pf-objects.scm

   1 (define-module (oop pf-objects)
   2   #:use-module (oop goops)
   3   #:use-module (ice-9 vlist)
   4   #:use-module (ice-9 match)
   5   #:use-module (system base message)
   6   #:use-module (language python guilemod)
   7   #:use-module (ice-9 pretty-print)
   8   #:use-module (logic guile-log persistance)
   9   #:replace (equal?)
  10   #:export (set ref make-p <p> <py> <pf> <pyf> <property>
  11                 call with copy fset fcall put put!
  12                 pcall pcall! get fset-x pyclass?
  13                 def-p-class   mk-p-class   make-p-class
  14                 define-python-class define-python-class-noname
  15                 get-type py-class
  16                 object-method class-method static-method
  17                 py-super-mac py-super py-equal?
  18                 *class* *self* pyobject? pytype?
  19                 type object pylist-set! pylist-ref tr
  20                 resolve-method-g rawref rawset
  21                 ))
  22
  23 #|
  24 Python object system is basically syntactic suger otop of a hashmap and one
  25 this project is inspired by the python object system and what it measn when
  26 one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
  27 with assocs or tree like functional hashmaps in stead.
  28
  29 The hashmap works like an assoc e.g. we will define new values by 'consing' a
  30 new binding on the list and when the assoc take up too much space it will be
  31 reshaped and all extra bindings will be removed.
  32
  33 The datastructure is functional but the objects mutate. So one need to
  34 explicitly tell it to not update etc.
  35 |#
  36
  37 (define fail (cons 'fail '()))
  38
  39 (define-syntax-rule (kif it p x y)
  40   (let ((it p))
  41     (if (eq? it fail)
  42         y
  43         x)))
  44
  45 (define-method (pylist-set! (o <hashtable>) key val)
  46   (hash-set! o key val))
  47
  48 (define-method (pylist-ref (o <hashtable>) key)
  49   (kif it (hash-ref o key fail)
  50        it
  51        (error "IndexError")))
  52
  53 (define (is-acl? a b) (member a (cons b (class-subclasses b))))
  54
  55 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
  56 (define-class <p>  (<applicable-struct> <object>) h)
  57 (define-class <pf> (<p>) size n)         ; the pf object consist of a functional
  58                                          ; hashmap it's size and number of live
  59                                          ; object
  60 (define-class <py>  (<p>))
  61 (define-class <pyf> (<pf>))
  62
  63 (define-class <property> () get set del)
  64
  65 (name-object <p>)
  66 (name-object <pf>)
  67 (name-object <py>)
  68 (name-object <pyf>)
  69 (name-object <property>)
  70
  71 (define-method (ref (o <procedure>) key . l)
  72   (aif it (procedure-property o key)
  73        it
  74        (if (pair? l)
  75            (car l)
  76            #f)))
  77
  78 (define-method (rawref (o <procedure>) key . l)
  79   (aif it (procedure-property o key)
  80        it
  81        (if (pair? l)
  82            (car l)
  83            #f)))
  84
  85 (define-method (set (o <procedure>) key val)
  86   (set-procedure-property! o key val))
  87
  88 (define-method (rawset (o <procedure>) key val)
  89   (set-procedure-property! o key val))
  90
  91 (define (mk-getter-object f)
  92   (lambda (obj cls)
  93     (if (eq? obj cls)
  94         (lambda x (apply f x))
  95         (lambda x (apply f obj x)))))
  96
  97 (define (mk-getter-class f)
  98   (lambda (obj cls)
  99     (if (eq? obj cls)
 100         (lambda x (apply f x))
 101         (lambda x (apply f cls x)))))
 102
 103 (define (class-method f)
 104   (set f '__get__ (mk-getter-class f)))
 105
 106 (define (object-method f)
 107   (set f '__get__ (mk-getter-object f)))
 108
 109 (define (static-method f)
 110   (set f '__get__ #f))
 111
 112
 113 (define (resolve-method-g g pattern)
 114   (define (mmatch p pp)
 115     (if (eq? pp '_)
 116         '()
 117         (match (cons p pp)
 118           (((p . ps) . (pp . pps))
 119            (if (eq? pp '_)
 120                (mmatch ps pps)
 121                (if (or (eq? p pp) (is-a? p pp))
 122                    (cons p (mmatch ps pps))
 123                    #f)))
 124           ((() . ())
 125            '())
 126           (_
 127            #f))))
 128
 129   (define (q< x y)
 130     (let lp ((x x) (y y))
 131       (match (cons x y)
 132         (((x . xs) . (y . ys))
 133          (and (is-a? x y)
 134               (lp xs ys)))
 135         (_ #t))))
 136
 137   (let ((l
 138          (let lp ((ms (generic-function-methods g)))
 139            (if (pair? ms)
 140                (let* ((m (car ms))
 141                       (p (method-specializers m))
 142                       (f (method-generic-function m)))
 143                  (aif it (mmatch p pattern)
 144                      (cons (cons it f) (lp (cdr ms)))
 145                      (lp (cdr ms))))
 146                '()))))
 147
 148
 149     (cdr (car (sort l q<)))))
 150
 151 (define (resolve-method-o o pattern)
 152   (resolve-method-g (class-of o) pattern))
 153
 154 (define (get-dict self name parents)
 155   (aif it (ref self '__prepare__)
 156        (it self name parents)
 157        (make-hash-table)))
 158
 159 (define (hashforeach a b) (values))
 160
 161 (define (new-class meta name parents dict kw)
 162   (aif it (ref meta '__new__)
 163        (apply it name parents dict kw)
 164        (let* ((goops (pylist-ref dict '__goops__))
 165               (p     (kwclass->class kw meta))
 166               (class (make-p p)))
 167          (slot-set! class 'procedure
 168                     (lambda x
 169                       (create-object class meta goops x)))
 170          (if (hash-table? dict)
 171              (hash-for-each
 172               (lambda (k v) k (set class k v))
 173               dict)
 174              (hashforeach
 175               (lambda (k v) k (set class k v))
 176               dict))
 177          (let((mro (ref class '__mro__)))
 178            (if (pair? mro)
 179                (let ((p (car mro)))
 180                  (aif it (ref p '__init_subclass__)
 181                       (apply it class #f kw)
 182                       #f))))
 183          (set class '__mro__ (cons class (ref class '__mro__)))
 184          class)))
 185
 186 (define (type- meta name parents dict keys)
 187   (let ((class (new-class meta name parents dict keys)))
 188     (aif it (ref meta '__init__)
 189          (it name parents dict keys)
 190          #f)
 191     class))
 192
 193 (define (create-class meta name parents gen-methods . keys)
 194   (let ((dict (gen-methods (get-dict meta name keys))))
 195     (aif it (ref meta '__class__)
 196          (aif it (find-in-class (ref meta '__class__) '__call__ #f)
 197               (apply (it meta 'class) name parents dict keys)
 198               (type- meta name parents dict keys))
 199          (type- meta name parents dict keys))))
 200
 201 (define (create-object class meta goops x)
 202   (with-fluids ((*make-class* #t))
 203     (aif it #f ;(ref meta '__call__)
 204        (apply it x)
 205        (let ((obj (aif it (find-in-class class '__new__ #f)
 206                        ((it class 'object))
 207                        (make-object class meta goops))))
 208          (aif it (ref obj '__init__)
 209               (apply it x)
 210               #f)
 211          (slot-set! obj 'procedure
 212                     (lambda x
 213                       (aif it (ref obj '__call__)
 214                            (apply it x)
 215                            (error "not a callable object"))))
 216          obj))))
 217
 218 (define (make-object class meta goops)
 219   (let ((obj (make-p goops)))
 220     (set obj '__class__ class)
 221     obj))
 222
 223 ;; Make an empty pf object
 224 (define (make-p <x>)
 225   (let ((r (make <x>)))
 226     (cond
 227      ((is-a? r <pf>)
 228       (slot-set! r 'h vlist-null)
 229       (slot-set! r 'size 0)
 230       (slot-set! r 'n 0))
 231      ((is-a? r <p>)
 232       (slot-set! r 'h (make-hash-table)))
 233      (else
 234       (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
 235              r)))
 236     r))
 237
 238
 239 (define-syntax-rule (hif it (k h) x y)
 240   (let ((a (vhash-assq k h)))
 241     (if (pair? a)
 242         (let ((it (cdr a)))
 243           x)
 244         y)))
 245
 246 (define-syntax-rule (cif (it h) (k cl) x y)
 247   (let* ((h (slot-ref cl 'h))
 248          (a (vhash-assq k h)))
 249     (if (pair? a)
 250         (let ((it (cdr a)))
 251           x)
 252         y)))
 253
 254 (define-inlinable (gox obj it)
 255   (let ((class (fluid-ref *location*)))
 256     (aif it (rawref it '__get__)
 257          (it obj class)
 258          it)))
 259
 260 (define *location* (make-fluid #f))
 261 (define-syntax-rule (mrefx x key l)
 262   (let ()
 263     (define (end)
 264       (if (null? l)
 265           #f
 266           (car l)))
 267
 268     (define (parents li)
 269       (let lp ((li li))
 270         (if (pair? li)
 271             (let ((p (car li)))
 272               (cif (it h) (key p)
 273                    (begin (fluid-set! *location* p) it)
 274                    (lp (cdr li))))
 275             fail)))
 276
 277     (cif (it h) (key x)
 278          (begin (fluid-set! *location* x) it)
 279          (hif cl ('__class__ h)
 280               (cif (it h) (key cl)
 281                    (begin (fluid-set! *location* cl) it)
 282                    (hif p ('__mro__ h)
 283                         (let ((r (parents p)))
 284                           (if (eq? r fail)
 285                               (end)
 286                               r))
 287                         (end)))
 288               (end)))))
 289
 290 (define-method (find-in-class (klass <p>) key fail)
 291   (hash-ref (slot-ref klass 'h) key fail))
 292
 293 (define-method (find-in-class (klass <pf>) key fail)
 294   (let ((r (vhash-assoc key (slot-ref klass 'h))))
 295     (if r
 296         (cdr r)
 297         fail)))
 298
 299 (define-syntax-rule (find-in-class-and-parents klass key fail)
 300   (kif r (find-in-class klass key fail)
 301        (begin (fluid-set! *location* klass) r)
 302        (aif parents (find-in-class klass '__mro__ #f)
 303             (let lp ((parents parents))
 304               (if (pair? parents)
 305                   (kif r (find-in-class (car parents) key fail)
 306                        (begin (fluid-set! *location* (car parents)) r)
 307                        (lp (cdr parents)))
 308                   fail))
 309             fail)))
 310
 311 (define-syntax-rule (mrefx klass key l)
 312   (let ()
 313     (define (end) (if (pair? l) (car l) #f))
 314     (fluid-set! *location* klass)
 315     (kif it (find-in-class klass key fail)
 316          it
 317          (begin
 318            (aif klass (find-in-class klass '__class__ #f)
 319                 (kif it (find-in-class-and-parents klass key fail)
 320                      it
 321                      (end))
 322                 (end))))))
 323
 324 (define not-implemented (cons 'not 'implemeneted))
 325
 326 (define-syntax-rule (prop-ref xx x)
 327   (let ((y xx)
 328         (r x))
 329       (if (and (is-a? r <property>) (not (pyclass? y)))
 330           ((slot-ref r 'get) y)
 331           r)))
 332
 333 (define-syntax-rule (mrefx-py x key l)
 334   (let ((xx x))
 335     (prop-ref
 336      xx
 337      (let* ((g (mrefx xx '__fget__ '(#t)))
 338             (f (if g
 339                    (if (eq? g #t)
 340                        (aif it (mrefx xx '__getattribute__ '())
 341                             (let ((f (gox xx it)))
 342                               (rawset xx '__fget__ it)
 343                               f)
 344                             (begin
 345                               (if (mc?)
 346                                   (rawset xx '__fget__ #f))
 347                               #f))
 348                        g)
 349                    #f)))
 350        (if (or (not f) (eq? f not-implemented))
 351            (gox xx (mrefx xx key l))
 352            (catch #t
 353                   (lambda ()
 354                     (f key))
 355                   (lambda x
 356                     (gox xx (mrefx xx key l)))))))))
 357
 358
 359 (define-syntax-rule (mref x key l)
 360   (let ((xx x))
 361     (mrefx xx key l)))
 362
 363 (define-syntax-rule (mref-py x key l)
 364   (let ((xx x))
 365     (let ((res (mrefx-py xx key l)))
 366       res)))
 367
 368 (define-method (ref x key . l) (if (pair? l) (car l) #f))
 369 (define-method (ref (x <pf> )  key . l) (mref     x key l))
 370 (define-method (ref (x <p>  )  key . l) (mref     x key l))
 371 (define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
 372 (define-method (ref (x <py> )  key . l) (mref-py  x key l))
 373
 374 (define-method (rawref x key . l) (if (pair? l) (car l) #f))
 375 (define-method (rawref (x <pf> )  key . l) (mref     x key l))
 376 (define-method (rawref (x <p>  )  key . l) (mref     x key l))
 377
 378
 379 (define-method (set (f <procedure>) key val)
 380   (set-procedure-property! f key val))
 381
 382 (define-method (ref (f <procedure>) key . l)
 383   (aif it (assoc key (procedure-properties f))
 384        (cdr it)
 385        (if (pair? l) (car l) #f)))
 386
 387
 388 ;; the reshape function that will create a fresh new pf object with less size
 389 ;; this is an expensive operation and will only be done when we now there is
 390 ;; a lot to gain essentially tho complexity is as in the number of set
 391 (define (reshape x)
 392   (let ((h (slot-ref x 'h))
 393         (m (make-hash-table))
 394         (n 0))
 395     (define h2 (vhash-fold (lambda (k v s)
 396                              (if (hash-ref m k #f)
 397                                  s
 398                                  (begin
 399                                    (hash-set! m k #t)
 400                                    (set! n (+ n 1))
 401                                    (vhash-consq k v s))))
 402                            vlist-null
 403                            h))
 404     (slot-set! x 'h h2)
 405     (slot-set! x 'size n)
 406     (slot-set! x 'n    n)
 407     (values)))
 408
 409 ;; on object x add a binding that key -> val
 410 (define-method (mset (x <pf>) key val)
 411   (let ((h (slot-ref x 'h))
 412         (s (slot-ref x 'size))
 413         (n (slot-ref x 'n)))
 414     (slot-set! x 'size (+ 1 s))
 415     (let ((r (vhash-assoc key h)))
 416       (when (not r)
 417         (slot-set! x 'n (+ n 1)))
 418       (slot-set! x 'h (vhash-cons key val h))
 419       (when (> s (* 2 n))
 420         (reshape x))
 421       (values))))
 422
 423 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
 424
 425 (define-method (mset (x <p>) key val)
 426   (begin
 427     (hash-set! (slot-ref x 'h) key val)
 428     (values)))
 429
 430 (define *make-class* (make-fluid #f))
 431 (define (mc?) (not (fluid-ref *make-class*)))
 432
 433 (define-syntax-rule (mset-py x key val)
 434   (let* ((xx x)
 435          (v  (mref xx key (list fail))))
 436     (if (or (eq? v fail)
 437             (not (and (is-a? v <property>)
 438                       (not (pyclass? xx)))))
 439         (let* ((g (mrefx xx '__fset__ '(#t)))
 440                (f (if g
 441                       (if (eq? g #t)
 442                           (aif it (rawref xx '__setattr__)
 443                                (begin
 444                                  (rawset xx '__fset__ it)
 445                                  it)
 446                                (begin
 447                                  (if (mc?)
 448                                      (rawset xx '__fset__ it))
 449                                  #f))
 450                           g)
 451                       #f)))
 452           (if (or (eq? f not-implemented) (not f))
 453               (mset xx key val)
 454               (catch #t
 455                 (lambda () (f key val))
 456                 (lambda q  (mset xx key val)))))
 457         ((slot-ref v 'set) xx val))))
 458
 459 (define-syntax-rule (mklam (mset a ...) val)
 460   (mset a ... val))
 461
 462 (define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
 463 (define-method (set (x <p>)   key val) (mklam (mset     x key) val))
 464 (define-method (set (x <pyf>) key val) (mklam (mset-py  x key) val))
 465 (define-method (set (x <py>)  key val) (mklam (mset-py  x key) val))
 466
 467 (define-method (rawset (x <pf>)  key val) (mklam (mset     x key) val))
 468 (define-method (rawset (x <p>)   key val) (mklam (mset     x key) val))
 469
 470 ;; mref will reference the value of the key in the object x, an extra default
 471 ;; parameter will tell what the fail object is else #f if fail
 472 ;; if there is no found binding in the object search the class and
 473 ;; the super classes for a binding
 474
 475 ;; call a function as a value of key in x with the object otself as a first
 476 ;; parameter, this is pythonic object semantics
 477 (define-syntax-rule (mk-call mcall mref)
 478   (define-syntax-rule (mcall x key l)
 479     (apply (mref x key '()) l)))
 480
 481 (mk-call mcall     mref)
 482 (mk-call mcall-py  mref-py)
 483
 484 (define-method (call (x <pf>)  key . l) (mcall     x key l))
 485 (define-method (call (x <p>)   key . l) (mcall     x key l))
 486 (define-method (call (x <pyf>) key . l) (mcall-py  x key l))
 487 (define-method (call (x <py>)  key . l) (mcall-py  x key l))
 488
 489
 490 ;; make a copy of a pf object
 491 (define-syntax-rule (mcopy x)
 492   (let ((r (make-p (ref x '__goops__))))
 493     (slot-set! r 'h (slot-ref x 'h))
 494     (slot-set! r 'size (slot-ref x 'size))
 495     (slot-set! r 'n (slot-ref x 'n))
 496     r))
 497
 498 (define-syntax-rule (mcopy- x)
 499   (let* ((r (make-p (ref x '__goops__)))
 500          (h (slot-ref r 'h)))
 501     (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
 502     r))
 503
 504 (define-method (copy (x <pf>)) (mcopy  x))
 505 (define-method (copy (x <p> )) (mcopy- x))
 506
 507 ;; make a copy of a pf object
 508 (define-syntax-rule (mtr r x)
 509   (begin
 510     (slot-set! r 'h    (slot-ref x 'h   ))
 511     (slot-set! r 'size (slot-ref x 'size))
 512     (slot-set! r 'n    (slot-ref x 'n   ))
 513     (values)))
 514
 515 (define-syntax-rule (mtr- r x)
 516   (begin
 517     (slot-set! r 'h (slot-ref x 'h))
 518     (values)))
 519
 520
 521 (define-method (tr (r <pf>) (x <pf>)) (mtr  r x))
 522 (define-method (tr (r <p> ) (x <p> )) (mtr- r x))
 523
 524
 525 ;; with will execute thunk and restor x to it's initial state after it has
 526 ;; finished note that this is a cheap operatoin because we use a functional
 527 ;; datastructure
 528 (define-syntax-rule (mwith x thunk)
 529   (let ((old (mcopy x)))
 530     (let ((r (thunk)))
 531       (slot-set! x 'h    (slot-ref old 'h))
 532       (slot-set! x 'size (slot-ref old 'size))
 533       (slot-set! x 'n    (slot-ref old 'n))
 534       r)))
 535
 536 (define-syntax-rule (mwith- x thunk)
 537   (let ((old (mcopy- x)))
 538     (let ((r (thunk)))
 539       (slot-set! x 'h    (slot-ref old 'h))
 540       r)))
 541
 542
 543
 544 ;; a functional set will return a new object with the added binding and keep
 545 ;; x untouched
 546 (define-method (fset (x <pf>) key val)
 547   (let ((x (mcopy x)))
 548     (mset x key val val)
 549     x))
 550
 551 (define-method (fset (x <p>) key val)
 552   (let ((x (mcopy- x)))
 553     (mset x key val val)
 554     x))
 555
 556 (define (fset-x obj l val)
 557   (let lp ((obj obj) (l l) (r '()))
 558     (match l
 559       (()
 560        (let lp ((v val) (r r))
 561          (if (pair? r)
 562              (lp (fset (caar r) (cdar r) v) (cdr r))
 563              v)))
 564       ((k . l)
 565        (lp (ref obj k #f) l (cons (cons obj k) r))))))
 566
 567
 568
 569
 570
 571 ;; a functional call will keep x untouched and return (values fknval newx)
 572 ;; e.g. we get both the value of the call and the new version of x with
 573 ;; perhaps new bindings added
 574 (define-method (fcall (x <pf>) key . l)
 575   (let* ((y (mcopy x))
 576          (r (mcall y key l)))
 577     (if (eq? (slot-ref x 'h) (slot-ref y 'h))
 578         (values r x)
 579         (values r y))))
 580
 581 (define-method (fcall (x <p>) key . l)
 582   (let ((x (mcopy x)))
 583     (values (mcall x key l)
 584             x)))
 585
 586 ;; this shows how we can override addition in a pythonic way
 587
 588 ;; lets define get put pcall etc so that we can refer to an object like
 589 ;; e.g. (put x.y.z 1) (pcall x.y 1)
 590
 591 (define-syntax-rule (cross x k f set)
 592   (call-with-values (lambda () f)
 593     (lambda (r y)
 594       (if (eq? x y)
 595           (values r x)
 596           (values r (set x k y))))))
 597
 598 (define-syntax-rule (cross! x k f _) f)
 599
 600 (define-syntax mku
 601   (syntax-rules ()
 602     ((_ cross set setx f (key) (val ...))
 603      (setx f key val ...))
 604     ((_ cross set setx f (k . l) val)
 605      (cross f k (mku cross set setx (ref f k) l val) set))))
 606
 607 (define-syntax-rule (mkk pset setx set cross)
 608   (define-syntax pset
 609     (lambda (x)
 610       (syntax-case x ()
 611         ((_ f val (... ...))
 612          (let* ((to (lambda (x)
 613                       (datum->syntax #'f  (string->symbol x))))
 614                 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
 615            (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
 616                                              (cdr l)))
 617                          (h       (to (car l))))
 618              #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
 619
 620 (mkk put    fset  fset cross)
 621 (mkk put!   set   set  cross!)
 622 (mkk pcall! call  fset cross!)
 623 (mkk pcall  fcall fset cross)
 624 (mkk get    ref   fset cross!)
 625
 626 ;; it's good to have a null object so we don't need to construct it all the
 627 ;; time because it is functional we can get away with this.
 628 (define null (make-p <pf>))
 629
 630 (define (filter-parents l)
 631   (let lp ((l l))
 632     (if (pair? l)
 633         (if (is-a? (car l) <p>)
 634             (cons (car l) (lp (cdr l)))
 635             (lp (cdr l)))
 636         '())))
 637
 638 (define (kw->class kw meta)
 639   (if (memq #:functional kw)
 640       (if (memq #:fast kw)
 641           <pf>
 642           (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
 643               <pyf>
 644               <pf>))
 645       (if (memq #:fast kw)
 646           (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
 647               <pf>
 648               <p>)
 649           (cond
 650            ((is-a? meta <pyf>)
 651             <pyf>)
 652            ((is-a? meta <py>)
 653             <py>)
 654            ((is-a? meta <pf>)
 655             <pf>)
 656            ((is-a? meta <p>)
 657             <p>)
 658            (else
 659             <py>)))))
 660
 661
 662 (define (defaulter d)
 663   (if d
 664       (cond
 665        ((is-a? d <pyf>)
 666         <pyf>)
 667        ((is-a? d <py>)
 668         <py>)
 669        ((is-a? d <pf>)
 670         <pf>)
 671        ((is-a? d <p>)
 672         <p>)
 673        (else
 674         d))
 675       <py>))
 676
 677 (define (kwclass->class kw default)
 678   (if (memq #:functionalClass kw)
 679       (if (memq #:fastClass kw)
 680           <pf>
 681           (if (memq #:pyClass kw)
 682               <pyf>
 683               (if (or (is-a? default <py>) (is-a? default <pyf>))
 684                   <pyf>
 685                   <pf>)))
 686       (if (memq #:mutatingClass kw)
 687           (if (memq #:fastClass kw)
 688               <p>
 689               (if (memq #:pyClass kw)
 690                   <py>
 691                   (if (or (is-a? default <py>) (is-a? default <pyf>))
 692                       <py>
 693                       <p>)))
 694           (if (memq #:fastClass kw)
 695               (if (or (is-a? default <pf>) (is-a? default <pyf>))
 696                   <pf>
 697                   <p>)
 698               (if (memq #:pyClass kw)
 699                   (if (or (is-a? default <pf>) (is-a? default <pyf>))
 700                       <pyf>
 701                       <py>)
 702                   (defaulter default))))))
 703
 704 (define object #f)
 705 (define (make-p-class name supers.kw methods)
 706   (define kw      (cdr supers.kw))
 707   (define supers  (car supers.kw))
 708   (define goopses (map (lambda (sups)
 709                          (aif it (ref sups '__goops__ #f)
 710                               it
 711                               sups))
 712                        supers))
 713   (define parents (let ((p (filter-parents supers)))
 714                     (if (null? p)
 715                         (if object
 716                             (list object)
 717                             '())
 718                         p)))
 719
 720   (define meta (aif it (memq #:metaclass kw)
 721                     (car it)
 722                     (if (null? parents)
 723                         type
 724                         (let* ((p   (car parents))
 725                                (m   (ref p '__class__))
 726                                (mro (reverse (ref m '__mro__))))
 727                           (let lp ((l   (cdr parents))
 728                                    (max mro)
 729                                    (min mro))
 730                             (if (pair? l)
 731                                 (let* ((p    (car l))
 732                                        (meta (ref p '__class__))
 733                                        (mro  (ref meta '__mro__)))
 734                                   (let lp2 ((max max) (mr (reverse mro)))
 735                                     (if (and (pair? max) (pair? mr))
 736                                         (if (eq? (car max) (car mr))
 737                                             (lp2 (cdr max) (cdr mr))
 738                                             (error
 739                                              "need a common lead for meta"))
 740                                         (if (pair? max)
 741                                             (if (< (length mro) (length min))
 742                                                 (lp (cdr l) max mro)
 743                                                 (lp (cdr l) max min))
 744                                             (lp (cdr l) mro min)))))
 745                                 (car (reverse min))))))))
 746
 747   (define goops (make-class (append goopses (list (kw->class kw meta)))
 748                             '() #:name name))
 749
 750   (define (gen-methods dict)
 751     (methods dict)
 752     (pylist-set! dict '__goops__   goops)
 753     (pylist-set! dict '__class__   meta)
 754     (pylist-set! dict '__fget__    #t)
 755     (pylist-set! dict '__fset__    #t)
 756     (pylist-set! dict '__name__    name)
 757     (pylist-set! dict '__parents__ parents)
 758     (pylist-set! dict '__class__   meta)
 759     (pylist-set! dict '__mro__     (get-mro parents))
 760     dict)
 761
 762   (with-fluids ((*make-class* #t))
 763     (create-class meta name parents gen-methods kw)))
 764
 765
 766 ;; Let's make an object essentially just move a reference
 767
 768 ;; the make class and defclass syntactic sugar
 769 (define-syntax mk-p-class
 770   (lambda (x)
 771     (syntax-case x ()
 772       ((_ name parents (ddef dname dval) ...)
 773        (with-syntax (((ddname ...)
 774                       (map (lambda (dn)
 775                              (datum->syntax
 776                               #'name
 777                               (string->symbol
 778                                (string-append
 779                                 (symbol->string
 780                                  (syntax->datum #'name))
 781                                 "-"
 782                                 (symbol->string
 783                                  (syntax->datum dn))))))
 784                            #'(dname ...)))
 785                      (nname (datum->syntax
 786                              #'name
 787                              (string->symbol
 788                               (string-append
 789                                (symbol->string
 790                                 (syntax->datum #'name))
 791                                "-goops-class")))))
 792          (%add-to-warn-list (syntax->datum #'nname))
 793          (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
 794               #'(ddname ...))
 795         #'(let ()
 796             (define name
 797               (letruc ((dname dval) ...)
 798                       (make-p-class 'name
 799                                     parents
 800                                     (lambda (dict)
 801                                       (pylist-set! dict 'dname dname)
 802                                       ...
 803                                       (values)))))
 804
 805             (begin
 806               (module-define! (current-module) 'ddname (ref name 'dname))
 807               (name-object ddname))
 808             ...
 809
 810             (module-define! (current-module) 'nname (ref name '__goops__))
 811             (name-object nname)
 812             (name-object name)
 813             name))))))
 814
 815 (define-syntax mk-p-class-noname
 816   (lambda (x)
 817     (syntax-case x ()
 818       ((_ name parents (ddef dname dval) ...)
 819        #'(let ()
 820            (define name
 821              (letruc ((dname dval) ...)
 822                      (make-p-class 'name
 823                                    parents
 824                                    (lambda (dict)
 825                                      (pylist-set! dict 'dname dname)
 826                                      ...
 827                                      (values)))))
 828            name)))))
 829
 830 (define-syntax-rule (def-p-class name . l)
 831   (define name (mk-p-class name . l)))
 832
 833 (define (get-class o)
 834   (cond
 835    ((is-a? o <p>)
 836     o)
 837    (else
 838     (error "not a pyclass"))))
 839
 840 (define (get-type o)
 841   (cond
 842    ((is-a? o <pyf>)
 843     'pyf)
 844    ((is-a? o <py>)
 845     'py)
 846    ((is-a? o <pf>)
 847     'pf)
 848    ((is-a? o <p>)
 849     'p)
 850    (else
 851     'none)))
 852
 853 (define (print o l)
 854   (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
 855   (define port (if (pair? l) (car l) #t))
 856   (format port "~a"
 857           (aif it (if (pyclass? o)
 858                       #f
 859                       (if (pyobject? o)
 860                           (ref o '__repr__)
 861                           #f))
 862                (format
 863                 #f "~a(~a)<~a>"
 864                 p (get-type o) (it))
 865                (format
 866                 #f "~a(~a)<~a>"
 867                 p (get-type o) (ref o '__name__ 'Annonymous)))))
 868
 869 (define-method (write   (o <p>) . l) (print o l))
 870 (define-method (display (o <p>) . l) (print o l))
 871
 872 (define (arglist->pkw l)
 873   (let lp ((l l) (r '()))
 874     (if (pair? l)
 875         (let ((x (car l)))
 876           (if (keyword? x)
 877               (cons (reverse r) l)
 878               (lp (cdr l) (cons x r))))
 879         (cons (reverse r) '()))))
 880
 881 (define-syntax-rule (define-python-class name (parents ...) code ...)
 882   (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))
 883
 884 (define-syntax-rule (define-pythonc-lass-noname name (parents ...) code ...)
 885   (define name (mk-p-class-noname name (arglist->pkw (list parents ...))
 886                                   code ...)))
 887
 888
 889 (define-syntax make-python-class
 890   (lambda (x)
 891     (syntax-case x ()
 892       ((_ name (parents ...) code ...)
 893        #'(let* ((cl  (mk-p-class name
 894                                  (arglist->pkw (list parents ...))
 895                                  code ...)))
 896            cl)))))
 897
 898
 899 (define (kind x)
 900   (and (is-a? x <p>)
 901        (aif it (find-in-class x '__goops__ #f)
 902             (if (is-a? (make it) (ref type '__goops__))
 903                 'type
 904                 'class)
 905             'object)))
 906
 907 (define (pyobject? x) (eq? (kind x) 'object))
 908 (define (pyclass?  x) (eq? (kind x) 'class))
 909 (define (pytype?   x) (eq? (kind x) 'type))
 910
 911 (define (mark-fkn tag f)
 912   (set-procedure-property! f 'py-special tag)
 913   f)
 914
 915 (define-syntax-parameter
 916   *class* (lambda (x) (error "*class* not parameterized")))
 917 (define-syntax-parameter
 918   *self* (lambda (x) (error "*class* not parameterized")))
 919
 920 (define *super* (list 'super))
 921
 922 (define (not-a-super) 'not-a-super)
 923 (define (py-super class obj)
 924   (define (make cl parents)
 925     (let ((c (make-p <p>))
 926           (o (make-p <p>)))
 927       (set c '__super__        #t)
 928       (set c '__mro__       parents)
 929       (set c '__getattribute__  (lambda (self key . l)
 930                                   (aif it (ref c key)
 931                                        (if (procedure? it)
 932                                            (if (eq? (procedure-property
 933                                                      it
 934                                                      'py-special)
 935                                                     'class)
 936                                                (it cl)
 937                                                (it obj))
 938                                            it)
 939                                        (error "no attribute"))))
 940       (set o '__class__ c)
 941       o))
 942
 943   (call-with-values
 944       (lambda ()
 945         (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
 946           (if (pair? l)
 947               (if (eq? class (car l))
 948                   (let ((r (cdr l)))
 949                     (if (pair? r)
 950                         (values (car r) r)
 951                         (values #f      #f)))
 952                   (lp (cdr l)))
 953               (values #f #f))))
 954     make))
 955
 956
 957
 958 (define-syntax py-super-mac
 959   (syntax-rules ()
 960     ((_)
 961      (py-super *class* *self*))
 962     ((_ class self)
 963      (py-super class self))))
 964
 965 (define (pp x)
 966   (pretty-print (syntax->datum x))
 967   x)
 968
 969 (define-syntax letruc
 970   (lambda (x)
 971     (syntax-case x ()
 972       ((_ ((x v) ...) code ...)
 973        (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
 974          (if (pair? a)
 975              (let* ((x (car a))
 976                     (s (syntax->datum x)))
 977                (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
 978                          (r (list (car b))))
 979                  (if (pair? a2)
 980                      (if (eq? (syntax->datum a2) s)
 981                          (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
 982                          (lp2 (cdr a2) (cdr b2)
 983                               (cons (car a2) a3)
 984                               (cons (car b2) b3)
 985                               r))
 986                      (lp (reverse a3) (reverse b3)
 987                          (cons
 988                           (list x #`(let* #,(map (lambda (v) (list x v))
 989                                                  (reverse r)) #,x))
 990                           u)))))
 991              #`(letrec #,(reverse u) code ...)))))))
 992
 993
 994
 995
 996 (define-method (py-init (o <p>) . l)
 997   (apply (ref o '__init__) l))
 998
 999 (define mk-tree
1000   (case-lambda
1001    ((root)
1002     (vector root '()))
1003    ((root hist) (vector root hist))))
1004
1005 (define (geth t) (vector-ref t 1))
1006 (define (getr t) (vector-ref t 0))
1007 (define (tree-ref t) (car (getr t)))
1008
1009 (define (nxt tree)
1010   (define (dive r h)
1011     (let ((x (car r)))
1012       (if (pair? x)
1013           (dive (car r) (cons (cdr r) h))
1014           (mk-tree r h))))
1015
1016   (define (up r h)
1017     (if (null? r)
1018         (if (pair? h)
1019             (up (car h) (cdr h))
1020             #f)
1021         (let ((x (car r)))
1022           (if (pair? x)
1023               (dive r h)
1024               (mk-tree r h)))))
1025
1026   (let ((r (getr tree)) (h (geth tree)))
1027     (cond
1028      ((pair? r)
1029       (let ((r (cdr r)))
1030         (if (pair? r)
1031             (let ((x (car r)))
1032               (if (pair? x)
1033                   (dive x (cons (cdr r) h))
1034                   (mk-tree r h)))
1035             (if (pair? h)
1036                 (up (car h) (cdr h))
1037                 #f))))
1038      (else
1039       (if (pair? h)
1040           (up (car h) (cdr h))
1041           #f)))))
1042
1043 (define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
1044
1045 (define (find-tree o tree)
1046   (if tree
1047       (let ((x (tree-ref tree)))
1048         (if (eq? o x)
1049             #t
1050             (find-tree o (nxt tree))))
1051       #f))
1052
1053 (define (get-mro parents)
1054   (if (null? parents)
1055       parents
1056       (get-mro0 parents)))
1057
1058 (define (get-mro0 parents)
1059   (define tree (mk-tree parents))
1060   (let lp ((tree tree) (r '()))
1061     (if tree
1062         (let ((x (tree-ref tree))
1063               (n (nxt tree)))
1064           (if (find-tree x n)
1065               (lp n r)
1066               (lp n (cons x r))))
1067         (reverse r))))
1068
1069 (define-method (py-equal? (x <p>)  y)
1070   (aif it (ref x '__eq__)
1071        (it y)
1072        (next-method)))
1073
1074 (define-method (py-equal? y (x <p>))
1075   (aif it (ref x '__eq__)
1076        (it y)
1077        (next-method)))
1078
1079 (define-method (py-equal? x y) ((@ (guile) equal?) x y))
1080
1081 (define (equal? x y) (or (eq? x y) (py-equal? x y)))
1082
1083 (define type #f)
1084 (set! type
1085       (make-python-class type ()
1086         (define __call__
1087           (case-lambda
1088             ((meta obj)
1089              (ref obj '__class__ 'None))
1090             ((meta name bases dict . keys)
1091              (type- meta name bases dict keys))))))
1092 (set type '__class__ type)
1093
1094 (set! object (make-python-class object ()))
1095
1096 (name-object type)
1097 (name-object object)