forked from mighty-gerbils/gerbil
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathmetaclass.ss
68 lines (67 loc) · 3.13 KB
/
metaclass.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
;;; -*- Gerbil -*-
;;; © vyzo
;;; support for defining metaclasses
(import :gerbil/runtime/mop
(for-syntax (only-in :gerbil/runtime/mop class::t.id)))
(export class)
;; this is the class metaclass expander meta type
;; to allow simple creation of new metaclasses
(defsyntax class
(make-class-type-info
id: class::t.id
name: 'class
super: []
slots: '(id name super flags fields
precedence-list slot-vector slot-table properties constructor methods)
struct?: #t
type-descriptor: (quote-syntax class::t)
constructor: (quote-syntax make-class-type)
predicate: (quote-syntax class-type?)
accessors:
[['id :: (quote-syntax class-type-id)]
['name :: (quote-syntax class-type-name)]
['super :: (quote-syntax class-type-super)]
['flags :: (quote-syntax class-type-flags)]
['fields :: (quote-syntax class-type-fields)]
['precedence-list :: (quote-syntax class-type-precedence-list)]
['slot-vector :: (quote-syntax class-type-slot-vector)]
['slot-table :: (quote-syntax class-type-slot-table)]
['properties :: (quote-syntax class-type-properties)]
['constructor :: (quote-syntax class-type-constructor)]
['methods :: (quote-syntax class-type-methods)]]
mutators:
[['id :: (quote-syntax class-type-id-set!)]
['name :: (quote-syntax class-type-name-set!)]
['super :: (quote-syntax class-type-super-set!)]
['flags :: (quote-syntax class-type-flags-set!)]
['fields :: (quote-syntax class-type-fields-set!)]
['precedence-list :: (quote-syntax class-type-precedence-list-set!)]
['slot-vector :: (quote-syntax class-type-slot-vector-set!)]
['slot-table :: (quote-syntax class-type-slot-table-set!)]
['properties :: (quote-syntax class-type-properties-set!)]
['constructor :: (quote-syntax class-type-constructor-set!)]
['methods :: (quote-syntax class-type-methods-set!)]]
unchecked-accessors:
[['id :: (quote-syntax &class-type-id)]
['name :: (quote-syntax &class-type-name)]
['super :: (quote-syntax &class-type-super)]
['flags :: (quote-syntax &class-type-flags)]
['fields :: (quote-syntax &class-type-fields)]
['precedence-list :: (quote-syntax &class-type-precedence-list)]
['slot-vector :: (quote-syntax &class-type-slot-vector)]
['slot-table :: (quote-syntax &class-type-slot-table)]
['properties :: (quote-syntax &class-type-properties)]
['constructor :: (quote-syntax &class-type-constructor)]
['methods :: (quote-syntax class-type-methods-set!)]]
unchecked-mutators:
[['id :: (quote-syntax &class-type-id-set!)]
['name :: (quote-syntax &class-type-name-set!)]
['super :: (quote-syntax &class-type-super-set!)]
['flags :: (quote-syntax &class-type-flags-set!)]
['fields :: (quote-syntax &class-type-fields!)]
['precedence-list :: (quote-syntax &class-type-precedence-list-set!)]
['slot-vector :: (quote-syntax &class-type-slot-vector-set!)]
['slot-table :: (quote-syntax &class-type-slot-table-set!)]
['properties :: (quote-syntax &class-type-properties-set!)]
['constructor :: (quote-syntax &class-type-constructor-set!)]
['methods :: (quote-syntax &class-type-methods-set!)]]))