source: project/tinyclos/tinyclos.scm @ 4421

Last change on this file since 4421 was 4421, checked in by felix winkelmann, 13 years ago

removed use of :optional in tinyclos

File size: 2.7 KB
Line 
1;;;; tinyclos.scm
2
3
4
5(cond-expand (hygienic-macros
6
7(define-syntax define-class
8  (syntax-rules ()
9    [(_ name () slots)
10     (define-class name (<object>) slots) ]
11    [(_ name supers slots)
12     (define-class name supers slots <class>) ]
13    [(_ name () slots meta)
14     (define-class name (<object>) slots meta) ]
15    [(_ cname (supers ...) (slots ...) meta)
16     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )
17
18(define-syntax define-generic
19  (syntax-rules () 
20    [(_ n class) (define n (make class 'name 'n))]
21    [(_ n) (define n (make-generic 'n))] ) )
22
23(define-macro (define-method head . body)
24  (##sys#check-syntax 'define-method head '(symbol . _))
25  (##sys#check-syntax 'define-method body '#(_ 1))
26  (let gather ([args (##sys#slot head 1)]
27               [specs '()]
28               [vars '()] )
29    (if (or (not (pair? args)) 
30            (memq (car args) '(#!optional #!key #!rest)) )
31        (let ([name (##sys#slot head 0)])
32          `(add-method
33            ,name
34            (make-method
35             (list ,@(reverse specs))
36             (lambda (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) )
37        (let ([arg (##sys#slot args 0)])
38          (gather (##sys#slot args 1)
39                  (cons (if (pair? arg) (cadr arg) '<top>) specs)
40                  (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) )
41
42)(else
43
44(define-macro (define-class name supers slots . meta)
45  (##sys#check-syntax 'define-class name 'symbol)
46  (##sys#check-syntax 'define-class supers '#(_ 0))
47  (##sys#check-syntax 'define-class slots '#(_ 0))
48  (##sys#check-syntax 'define-class meta '#(_ 0 1))
49  `(##core#set! ,name
50     (make ,(if (pair? meta) (##sys#slot meta 0) '<class>)
51       'name ',name
52       'direct-supers (list ,@(if (null? supers) '(<object>) supers))
53       'direct-slots (list ,@(map (lambda (s) `',s) slots)) ) ) )
54
55(define-macro (define-generic name . class)
56  (let ((class (if (pair? class) (car class) '<generic>)))
57    (##sys#check-syntax 'define-generic name 'symbol)
58    `(define ,name (make ,class 'name ',name)) ) )
59
60(define-macro (define-method head . body)
61  (##sys#check-syntax 'define-method head '(symbol . _))
62  (##sys#check-syntax 'define-method body '#(_ 1))
63  (let gather ([args (##sys#slot head 1)]
64               [specs '()]
65               [vars '()] )
66    (if (or (not (pair? args)) 
67            (memq (car args) '(#!optional #!key #!rest)) )
68        (let ([name (##sys#slot head 0)])
69          `(##core#set! ,name
70                        (##tinyclos#add-global-method
71                         (##core#global-ref ,name)
72                         ',name
73                         (list ,@(reverse specs))
74                         (##core#named-lambda ,name (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) )
75        (let ([arg (##sys#slot args 0)])
76          (gather (##sys#slot args 1)
77                  (cons (if (pair? arg) (cadr arg) '<top>) specs)
78                  (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) )
79
80))
Note: See TracBrowser for help on using the repository browser.