1 ! Copyright (C) 2004, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays assocs bootstrap.image.primitives
4 bootstrap.image.private classes classes.builtin classes.intersection
5 classes.predicate classes.private classes.singleton classes.tuple
6 classes.tuple.private classes.union combinators compiler.units io
7 kernel kernel.private layouts make math math.private namespaces parser
8 quotations sequences slots source-files splitting vocabs vocabs.loader
10 IN: bootstrap.primitives
12 "* Creating primitives and basic runtime structures..." print flush
14 H{ } clone sub-primitives set
16 "resource:basis/bootstrap/syntax.factor" parse-file
18 : asm-file ( arch -- file )
19 "-" split reverse "." join
20 "resource:basis/bootstrap/assembler/" ".factor" surround ;
22 architecture get asm-file parse-file
24 "resource:basis/bootstrap/layouts.factor" parse-file
26 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
28 ! Bring up a bare cross-compiling vocabulary.
29 "syntax" lookup-vocab vocab-words-assoc bootstrap-syntax set
31 H{ } clone dictionary set
32 H{ } clone root-cache set
33 H{ } clone source-files set
34 H{ } clone update-map set
35 H{ } clone implementors-map set
41 call( -- ) ! layouts quot
42 call( -- ) ! arch quot
44 ! Vocabulary for slot accessors
45 "accessors" create-vocab drop
47 ! After we execute bootstrap/layouts
48 num-types get f <array> builtins set
52 call( -- ) ! syntax-quot
54 ! create-word some empty vocabs where the below primitives and
65 "classes.tuple.private"
68 "continuations.private"
70 "generic.single.private"
99 "tools.dispatch.private"
100 "tools.memory.private"
101 "tools.profiler.sampling.private"
107 } [ create-vocab drop ] each
110 : lookup-type-number ( word -- n )
111 [ target-word ] with-global type-number ;
113 : register-builtin ( class -- )
114 [ dup lookup-type-number "type" set-word-prop ]
115 [ dup "type" word-prop builtins get set-nth ]
116 [ f f f builtin-class define-class ]
119 : prepare-slots ( slots -- slots' )
120 [ [ dup pair? [ first2 create-word ] when ] map ] map ;
122 : define-builtin-slots ( class slots -- )
123 prepare-slots make-slots 1 finalize-slots
124 [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
126 : define-builtin-predicate ( class -- )
127 dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
129 : define-builtin ( symbol slotspec -- )
130 [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
136 { "byte-array" "byte-arrays" }
137 { "callstack" "kernel" }
141 { "quotation" "quotations" }
142 { "string" "strings" }
145 { "wrapper" "kernel" }
146 } [ create-word register-builtin ] assoc-each
148 "f" "syntax" lookup-word register-builtin
150 ! We need this before defining c-ptr below
151 "f" "syntax" lookup-word { } define-builtin
153 "f" "syntax" create-word [ not ] "predicate" set-word-prop
154 "f?" "syntax" vocab-words-assoc delete-at
156 "t" "syntax" lookup-word define-singleton-class
159 "c-ptr" "alien" create-word [
160 "alien" "alien" lookup-word ,
161 "f" "syntax" lookup-word ,
162 "byte-array" "byte-arrays" lookup-word ,
163 ] { } make define-union-class
165 "integer" "math" create-word
166 "fixnum" "math" lookup-word "bignum" "math" lookup-word 2array
169 ! Two predicate classes used for declarations.
170 "array-capacity" "sequences.private" create-word
171 "fixnum" "math" lookup-word
174 bootstrap-max-array-capacity <fake-bignum> [ fixnum<= ] curry ,
177 define-predicate-class
179 "array-capacity" "sequences.private" lookup-word
180 [ integer>fixnum-strict ] bootstrap-max-array-capacity <fake-bignum> [ fixnum-bitand ] curry append
181 "coercer" set-word-prop
183 "integer-array-capacity" "sequences.private" create-word
184 "integer" "math" lookup-word
187 bootstrap-max-array-capacity <fake-bignum> [ <= ] curry ,
190 define-predicate-class
192 ! Catch-all class for providing a default method.
193 "object" "kernel" create-word
194 [ f f { } intersection-class define-class ]
195 [ [ drop t ] "predicate" set-word-prop ]
198 "object?" "kernel" vocab-words-assoc delete-at
200 ! Empty class with no instances
201 "null" "kernel" create-word
202 [ f { } f union-class define-class ]
203 [ [ drop f ] "predicate" set-word-prop ]
206 "null?" "kernel" vocab-words-assoc delete-at
208 "fixnum" "math" create-word { } define-builtin
209 "fixnum" "math" create-word "integer>fixnum-strict" "math" create-word 1quotation "coercer" set-word-prop
211 "bignum" "math" create-word { } define-builtin
212 "bignum" "math" create-word ">bignum" "math" create-word 1quotation "coercer" set-word-prop
214 "float" "math" create-word { } define-builtin
215 "float" "math" create-word ">float" "math" create-word 1quotation "coercer" set-word-prop
217 "array" "arrays" create-word {
218 { "length" { "array-capacity" "sequences.private" } read-only }
221 "wrapper" "kernel" create-word {
222 { "wrapped" read-only }
225 "string" "strings" create-word {
226 { "length" { "array-capacity" "sequences.private" } read-only }
230 "quotation" "quotations" create-word {
231 { "array" { "array" "arrays" } read-only }
236 "dll" "alien" create-word {
237 { "path" { "byte-array" "byte-arrays" } read-only }
240 "alien" "alien" create-word {
241 { "underlying" { "c-ptr" "alien" } read-only }
245 "word" "words" create-word {
246 { "hashcode" { "fixnum" "math" } }
249 { "def" { "quotation" "quotations" } initial: [ ] }
253 { "sub-primitive" read-only }
256 "byte-array" "byte-arrays" create-word {
257 { "length" { "array-capacity" "sequences.private" } read-only }
260 "callstack" "kernel" create-word { } define-builtin
262 "tuple" "kernel" create-word
263 [ { } define-builtin ]
264 [ define-tuple-layout ]
267 ! create-word special tombstone values
268 "tombstone" "hashtables.private" create-word
270 { "state" } define-tuple-class
272 "+empty+" "hashtables.private" create-word
273 { f } "tombstone" "hashtables.private" lookup-word
274 slots>tuple 1quotation ( -- value ) define-inline
276 "+tombstone+" "hashtables.private" create-word
277 { t } "tombstone" "hashtables.private" lookup-word
278 slots>tuple 1quotation ( -- value ) define-inline
282 "curried" "kernel" create-word
287 } prepare-slots define-tuple-class
289 "curry" "kernel" create-word
291 [ f "inline" set-word-prop ]
295 "curry" "kernel" lookup-word
297 callable instance-check-quot %
298 "curried" "kernel" lookup-word tuple-layout ,
301 ( obj quot -- curry ) define-declared
303 "composed" "kernel" create-word
306 { "first" read-only }
307 { "second" read-only }
308 } prepare-slots define-tuple-class
310 "compose" "kernel" create-word
312 [ f "inline" set-word-prop ]
316 "compose" "kernel" lookup-word
318 callable instance-check-quot [ dip ] curry %
319 callable instance-check-quot %
320 "composed" "kernel" lookup-word tuple-layout ,
323 ( quot1 quot2 -- compose ) define-declared
325 "* Declaring primitives..." print flush
326 all-primitives create-primitives
329 "build" "kernel" create-word build 1 + [ ] curry ( -- n ) define-declared
331 ] with-compilation-unit