smalltalk-tng
view experiments/oo.ss @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 ;;; OO.SS Support for object-oriented programming
3 (let ((cell (assq 'add-method: (<class> : <class> methods))))
4 (let ((oldmeth (cdr cell)))
5 (set-cdr! cell
6 (lambda (self name func)
7 (cond
8 ((assq name (self : <class> methods)) =>
9 (lambda (cell)
10 (set-cdr! cell func)
11 self))
12 (else
13 (oldmeth self name func)))))))
15 (define-method <class> (self add-class-method: name lambda)
16 (self set: <class> class-methods
17 (cons (cons name lambda)
18 (self : <class> class-methods))))
20 (define define-class-method
21 (macro (class template . body)
22 `(,class add-class-method: ',(cadr template)
23 (lambda ,(cons (car template) (cddr template))
24 ,@body))))
26 (define-class-method <class> (self new: super ivars print-name)
27 (let ((new (self new)))
28 (new set: <class> super super)
29 (new set: <class> ivars ivars)
30 (new set: <class> numivars
31 (+ (super : <class> numivars) (length ivars)))
32 (new set: <class> print-name print-name)
33 new))
35 ; (define-class name super (ivar1 ...))
37 (define define-class
38 (macro (name super ivars)
39 `(define ,name (<class> new: ,super ',ivars ',name))))
41 ; (class get-method: name)
43 (define-method <class> (self get-method: name)
44 (let ((methods (self : <class> methods)))
45 (cond
46 ((assq name methods) => cdr)
47 (else #f))))
49 ; (class get-class-method: name)
51 (define-method <class> (self get-class-method: name)
52 (let ((methods (self : <class> class-methods)))
53 (cond
54 ((assq name methods) => cdr)
55 (else #f))))
57 (define-method <class> (self write-to: port)
58 (display "#<class ")
59 (display (self : <class> print-name))
60 (display ">"))
62 (define-method <class> (self display-to: port)
63 (display "#<class ")
64 (display (self : <class> print-name))
65 (display ">"))
67 (define-method <object> (self dissect-to: port)
68 (for-each (lambda (x) (display-to port x))
69 (list
70 "An instance of class " ((self class) : <class> print-name) ".\n"
71 "Instance variables:\n"))
72 (let loop ((class (self class)))
73 (unless (or (null? class) (eq? class <object>))
74 (display-to port "--------")
75 (display-to port (class : <class> print-name))
76 (display-to port "\n")
77 (for-each (lambda (ivar)
78 (display-to port "\t")
79 (display-to port ivar)
80 (display-to port "\t\t")
81 (if (and (eq? class <class>)
82 (memq ivar '(methods class-methods)))
83 (display-to port
84 (map car
85 (self get-ivar-by-name: ivar class)))
86 (display-to port
87 (self get-ivar-by-name: ivar class)))
88 (display-to port "\n"))
89 (class : <class> ivars))
90 (loop (class : <class> super)))))
92 (define-method <object> (self dissect)
93 (self dissect-to: %%stdout))
95 (define-method <object> (self instance-of? class)
96 (let loop ((c (self class)))
97 (cond
98 ((null? c) #f)
99 ((eq? c class) #t)
100 (else
101 (loop (c : <class> super))))))