source: project/tinyclos/trunk/tinyclos.scm @ 5549

Last change on this file since 5549 was 5549, checked in by Kon Lovett, 13 years ago

Using canonical directory structure.

File size: 3.9 KB
Line 
1;;;; tinyclos.scm
2
3(cond-expand (hygienic-macros
4
5; From '@' by Dan Muresan
6(define-syntax slot@
7  (syntax-rules (=)
8    ((_ o) o)
9    ((_ o slot = v) (slot-set! o 'slot v))
10    ((_ o slot . slots) (slot@ (slot-ref o 'slot) . slots))))
11
12(define-syntax define-class
13  (syntax-rules ()
14    [(_ name () slots)
15     (define-class name (<object>) slots) ]
16    [(_ name supers slots)
17     (define-class name supers slots <class>) ]
18    [(_ name () slots meta)
19     (define-class name (<object>) slots meta) ]
20    [(_ cname (supers ...) (slots ...) meta)
21     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )
22
23(define-syntax define-generic
24  (syntax-rules ()
25    [(_ n class) (define n (make class 'name 'n))]
26    [(_ n) (define n (make-generic 'n))] ) )
27
28(define-macro (define-method head . body)
29  (##sys#check-syntax 'define-method head '(symbol . _))
30  (##sys#check-syntax 'define-method body '#(_ 1))
31  (let gather ([args (##sys#slot head 1)]
32               [specs '()]
33               [vars '()] )
34    (if (or (not (pair? args))
35            (memq (car args) '(#!optional #!key #!rest)) )
36        (let ([name (##sys#slot head 0)])
37          `(add-method
38            ,name
39            (make-method
40             (list ,@(reverse specs))
41             (lambda (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) )
42        (let ([arg (##sys#slot args 0)])
43          (gather (##sys#slot args 1)
44                  (cons (if (pair? arg) (cadr arg) '<top>) specs)
45                  (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) )
46
47)(else
48
49; From '@' by Dan Muresan
50(define-macro (slot@ o . rest)
51  (match rest
52    [() o]
53    [(slot '= v) `(slot-set! ,o ',slot ,v)]
54    [(slot . slots) `(slot@ (slot-ref ,o ',slot) ,@slots)]) )
55
56(define-macro (define-class name supers slots . meta)
57  (##sys#check-syntax 'define-class name 'symbol)
58  (##sys#check-syntax 'define-class supers '#(_ 0))
59  (##sys#check-syntax 'define-class slots '#(_ 0))
60  (##sys#check-syntax 'define-class meta '#(_ 0 1))
61  `(##core#set! ,name
62     (make ,(if (pair? meta) (##sys#slot meta 0) '<class>)
63       'name ',name
64       'direct-supers (list ,@(if (null? supers) '(<object>) supers))
65       'direct-slots (list ,@(map (lambda (s) `',s) slots)) ) ) )
66
67(define-macro (define-generic name . class)
68  (let ((class (if (pair? class) (car class) '<generic>)))
69    (##sys#check-syntax 'define-generic name 'symbol)
70    `(define ,name (make ,class 'name ',name)) ) )
71
72(define-macro (define-method head . body)
73  (##sys#check-syntax 'define-method head '(symbol . _))
74  (##sys#check-syntax 'define-method body '#(_ 1))
75  (let gather ([args (##sys#slot head 1)]
76               [specs '()]
77               [vars '()] )
78    (if (or (not (pair? args))
79            (memq (car args) '(#!optional #!key #!rest)) )
80        (let ([name (##sys#slot head 0)])
81          `(##core#set! ,name
82                        (##tinyclos#add-global-method
83                         (##core#global-ref ,name)
84                         ',name
85                         (list ,@(reverse specs))
86                         (##core#named-lambda ,name (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) )
87        (let ([arg (##sys#slot args 0)])
88          (gather (##sys#slot args 1)
89                  (cons (if (pair? arg) (cadr arg) '<top>) specs)
90                  (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) )
91
92))
93
94;; For system use in extending the set of "builtin" classes.
95
96(define-for-syntax (##tinyclos#make-classname-symbol str)
97  (string->symbol (string-append "<" str ">")) )
98
99(define-macro (define-primitive-class name pred . sclasses)
100  `(define ,(##tinyclos#make-classname-symbol name)
101     (##tinyclos#new-primitive-class ,name ,pred ,@sclasses)) )
102
103(define-macro (define-structure-class name tag)
104  `(define ,(##tinyclos#make-classname-symbol name)
105     (##tinyclos#new-structure-class name ',tag)) )
106
107(define-macro (define-tagged-pointer-class name tag)
108  `(define ,(##tinyclos#make-classname-symbol name)
109     (##tinyclos#new-tagged-pointer-class name ',tag)) )
110
111(define-macro (define-extended-procedure-class name pred)
112  `(define ,(##tinyclos#make-classname-symbol name)
113     (##tinyclos#new-extended-procedure-class name pred)) )
Note: See TracBrowser for help on using the repository browser.