2 USING: kernel io parser words namespaces quotations arrays assocs sequences
3 splitting math shuffle ;
7 ! class { name slots methods class-methods }
9 : class-name ( class -- name ) dup symbol? [ get ] when first ;
11 : class-slots ( class -- slots ) dup symbol? [ get ] when second ;
13 : class-methods ( class -- methods ) dup symbol? [ get ] when third ;
15 : class-class-methods ( class -- methods ) dup symbol? [ get ] when fourth ;
17 : class? ( thing -- ? )
19 [ dup length 4 = [ first symbol? ] [ drop f ] if ]
23 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
25 : add-method ( class name quot -- )
26 rot get class-methods peek swapd set-at ;
28 : add-class-method ( class name quot -- )
29 rot get class-class-methods peek swapd set-at ;
31 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
33 ! object { class values }
35 : object-class ( object -- class ) first ;
37 : object-values ( object -- values ) second ;
39 : object? ( thing -- ? )
41 [ dup length 2 = [ first class? ] [ drop f ] if ]
45 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
47 : is? ( object class -- ? ) swap object-class class-name = ;
49 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
51 USE: inference.transforms
53 ! : narray ( n -- array ) [ drop ] map reverse ;
55 : [narray] ( n -- quot ) [ [ drop ] map reverse ] curry ;
57 : narray ( n -- array ) [narray] call ;
59 \ narray [ [narray] ] 1 define-transform
61 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
63 : new ( class -- object )
64 get dup >r class-slots length narray r> swap 2array ;
66 : new-empty ( class -- object )
67 get dup >r class-slots length f <array> r> swap 2array ;
69 ! : new* ( class -- object ) new-empty <- init ;
71 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
73 : slot-value ( object slot -- value )
74 over object-class class-slots index swap object-values nth ;
76 : set-slot-value ( object slot value -- object )
77 swap pick object-class class-slots index pick object-values set-nth ;
79 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
81 ! : send-message ( object message -- )
82 ! over object-class class-methods assoc-stack call ;
84 : send-message ( object message -- )
85 2dup swap object-class class-methods assoc-stack dup
87 ! [ drop nip "message not understood: " write print flush ]
88 [ drop "message not understood: " write print drop ]
91 : <- scan parsed \ send-message parsed ; parsing
93 ! : send-message* ( message n -- )
94 ! 1+ npick object-class class-methods assoc-stack call ;
96 : send-message* ( message n -- )
97 1+ npick dupd object-class class-methods assoc-stack dup
99 [ drop "message not understood: " write print flush ]
102 : <-- scan parsed 2 parsed \ send-message* parsed ; parsing
104 : <--- scan parsed 3 parsed \ send-message* parsed ; parsing
106 : <---- scan parsed 4 parsed \ send-message* parsed ; parsing
108 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
110 : send-message-to-class ( class message -- )
111 over class-class-methods assoc-stack call ;
113 : <<- scan parsed \ send-message-to-class parsed ; parsing
115 : send-message-to-class* ( message n -- )
116 1+ npick class-class-methods assoc-stack call ;
118 : <<-- scan parsed 2 parsed \ send-message-to-class* parsed ; parsing
120 : <<--- scan parsed 3 parsed \ send-message-to-class* parsed ; parsing
122 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
124 : send-message-next ( object message -- )
125 over object-class class-methods 1 head* assoc-stack call ;
127 : <-~ scan parsed \ send-message-next parsed ; parsing
129 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
131 : new* ( class -- object ) <<- create ;
133 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
139 : generate-slot-getter ( name -- )
140 "$" over append "slot-accessors" create swap [ slot-value ] curry
143 : generate-slot-setter ( name -- )
144 ">>" over append "slot-accessors" create swap [ swap set-slot-value ] curry
147 : generate-slot-accessors ( name -- )
150 generate-slot-setter ;
152 : accessors ( seq -- seq ) dup peek [ generate-slot-accessors ] each ; parsing
155 ! ";" parse-tokens dup [ generate-slot-accessors ] each parsed ; parsing
157 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
159 ! : <symbol> ( string -- symbol ) in get create dup define-symbol ;
161 : empty-method-table ( -- array ) H{ } clone 1array ;
163 ! : define-simple-class ( name parent slots -- )
165 ! r> dup class-slots r> append
166 ! swap dup class-methods empty-method-table append
167 ! swap class-class-methods empty-method-table append
168 ! 4array dup first set-global ;
170 : define-simple-class ( name parent slots -- )
171 >r dup class-slots r> append
172 swap dup class-methods empty-method-table append
173 swap class-class-methods empty-method-table append
174 4array dup first set-global ;
176 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
178 : define-independent-class ( name slots -- )
179 empty-method-table empty-method-table 4array dup first set-global ;
181 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
183 : add-methods ( class seq -- ) 2 group [ first2 add-method ] curry* each ;
185 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
187 : !( ")" parse-tokens drop ; parsing