1 ! Copyright (C) 2004, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays byte-arrays generic hashtables
4 hashtables.private io kernel math math.order namespaces make
5 parser sequences strings vectors words quotations assocs layouts
6 classes classes.builtin classes.tuple classes.tuple.private
7 kernel.private vocabs vocabs.loader source-files definitions
8 slots classes.union classes.intersection classes.predicate
9 compiler.units bootstrap.image.private io.files accessors
11 IN: bootstrap.primitives
13 "Creating primitives and basic runtime structures..." print flush
17 H{ } clone sub-primitives set
19 "resource:core/bootstrap/syntax.factor" parse-file
21 "resource:basis/cpu/" architecture get {
24 { "linux-ppc" "ppc/linux" }
25 { "macosx-ppc" "ppc/macosx" }
27 } at "/bootstrap.factor" 3append parse-file
29 "resource:core/bootstrap/layouts/layouts.factor" parse-file
31 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
33 ! Bring up a bare cross-compiling vocabulary.
34 "syntax" vocab vocab-words bootstrap-syntax set
35 H{ } clone dictionary set
36 H{ } clone new-classes set
37 H{ } clone changed-definitions set
38 H{ } clone changed-generics set
39 H{ } clone forgotten-definitions set
40 H{ } clone root-cache set
41 H{ } clone source-files set
42 H{ } clone update-map set
43 H{ } clone implementors-map set
46 ! Vocabulary for slot accessors
47 "accessors" create-vocab drop
49 ! Trivial recompile hook. We don't want to touch the code heap
50 ! during stage1 bootstrap, it would just waste time.
51 [ drop { } ] recompile-hook set
57 ! After we execute bootstrap/layouts
58 num-types get f <array> builtins set
62 ! Create some empty vocabs where the below primitives and
72 "classes.tuple.private"
75 "continuations.private"
101 "tools.profiler.private"
106 } [ create-vocab drop ] each
109 : define-builtin-predicate ( class -- )
110 dup class>type [ builtin-instance? ] curry define-predicate ;
112 : lookup-type-number ( word -- n )
113 global [ target-word ] bind type-number ;
115 : register-builtin ( class -- )
116 [ dup lookup-type-number "type" set-word-prop ]
117 [ dup "type" word-prop builtins get set-nth ]
118 [ f f f builtin-class define-class ]
121 : prepare-slots ( slots -- slots' )
122 [ [ dup pair? [ first2 create ] when ] map ] map ;
124 : define-builtin-slots ( class slots -- )
125 prepare-slots make-slots 1 finalize-slots
126 [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
128 : define-builtin ( symbol slotspec -- )
129 >r [ define-builtin-predicate ] keep
130 r> define-builtin-slots ;
132 "fixnum" "math" create register-builtin
133 "bignum" "math" create register-builtin
134 "tuple" "kernel" create register-builtin
135 "ratio" "math" create register-builtin
136 "float" "math" create register-builtin
137 "complex" "math" create register-builtin
138 "f" "syntax" lookup register-builtin
139 "array" "arrays" create register-builtin
140 "wrapper" "kernel" create register-builtin
141 "callstack" "kernel" create register-builtin
142 "string" "strings" create register-builtin
143 "quotation" "quotations" create register-builtin
144 "dll" "alien" create register-builtin
145 "alien" "alien" create register-builtin
146 "word" "words" create register-builtin
147 "byte-array" "byte-arrays" create register-builtin
148 "tuple-layout" "classes.tuple.private" create register-builtin
150 ! For predicate classes
151 "predicate-instance?" "classes.predicate" create drop
153 ! We need this before defining c-ptr below
154 "f" "syntax" lookup { } define-builtin
156 "f" "syntax" create [ not ] "predicate" set-word-prop
157 "f?" "syntax" vocab-words delete-at
160 "integer" "math" create
161 "fixnum" "math" lookup
162 "bignum" "math" lookup
166 "rational" "math" create
167 "integer" "math" lookup
168 "ratio" "math" lookup
173 "rational" "math" lookup
174 "float" "math" lookup
178 "c-ptr" "alien" create [
179 "alien" "alien" lookup ,
180 "f" "syntax" lookup ,
181 "byte-array" "byte-arrays" lookup ,
182 ] { } make define-union-class
184 ! A predicate class used for declarations
185 "array-capacity" "sequences.private" create
186 "fixnum" "math" lookup
187 0 bootstrap-max-array-capacity <fake-bignum> [ between? ] 2curry
188 define-predicate-class
190 ! Catch-all class for providing a default method.
191 "object" "kernel" create
192 [ f f { } intersection-class define-class ]
193 [ [ drop t ] "predicate" set-word-prop ]
196 "object?" "kernel" vocab-words delete-at
198 ! Class of objects with object tag
199 "hi-tag" "kernel.private" create
200 builtins get num-tags get tail define-union-class
202 ! Empty class with no instances
203 "null" "kernel" create
204 [ f { } f union-class define-class ]
205 [ [ drop f ] "predicate" set-word-prop ]
208 "null?" "kernel" vocab-words delete-at
210 "fixnum" "math" create { } define-builtin
211 "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
213 "bignum" "math" create { } define-builtin
214 "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
216 "ratio" "math" create {
217 { "numerator" { "integer" "math" } read-only }
218 { "denominator" { "integer" "math" } read-only }
221 "float" "math" create { } define-builtin
222 "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
224 "complex" "math" create {
225 { "real" { "real" "math" } read-only }
226 { "imaginary" { "real" "math" } read-only }
229 "array" "arrays" create {
230 { "length" { "array-capacity" "sequences.private" } read-only }
233 "wrapper" "kernel" create {
234 { "wrapped" read-only }
237 "string" "strings" create {
238 { "length" { "array-capacity" "sequences.private" } read-only }
242 "quotation" "quotations" create {
243 { "array" { "array" "arrays" } read-only }
244 { "compiled" read-only }
247 "dll" "alien" create {
248 { "path" { "byte-array" "byte-arrays" } read-only }
251 "alien" "alien" create {
252 { "underlying" { "c-ptr" "alien" } read-only }
256 "word" "words" create {
257 { "hashcode" { "fixnum" "math" } }
260 { "def" { "quotation" "quotations" } initial: [ ] }
262 { "compiled" read-only }
263 { "counter" { "fixnum" "math" } }
264 { "sub-primitive" read-only }
267 "byte-array" "byte-arrays" create {
268 { "length" { "array-capacity" "sequences.private" } read-only }
271 "callstack" "kernel" create { } define-builtin
273 "tuple-layout" "classes.tuple.private" create {
274 { "hashcode" { "fixnum" "math" } read-only }
275 { "class" { "word" "words" } initial: t read-only }
276 { "size" { "fixnum" "math" } read-only }
277 { "superclasses" { "array" "arrays" } initial: { } read-only }
278 { "echelon" { "fixnum" "math" } read-only }
281 "tuple" "kernel" create
282 [ { } define-builtin ]
283 [ define-tuple-layout ]
286 ! Create special tombstone values
287 "tombstone" "hashtables.private" create
289 { "state" } define-tuple-class
291 "((empty))" "hashtables.private" create
292 "tombstone" "hashtables.private" lookup f
293 2array >tuple 1quotation define-inline
295 "((tombstone))" "hashtables.private" create
296 "tombstone" "hashtables.private" lookup t
297 2array >tuple 1quotation define-inline
300 "curry" "kernel" create
305 } prepare-slots define-tuple-class
307 "curry" "kernel" lookup
309 [ f "inline" set-word-prop ]
312 [ tuple-layout [ <tuple-boa> ] curry ]
314 (( obj quot -- curry )) define-declared
316 "compose" "kernel" create
319 { "first" read-only }
320 { "second" read-only }
321 } prepare-slots define-tuple-class
323 "compose" "kernel" lookup
325 [ f "inline" set-word-prop ]
328 [ tuple-layout [ <tuple-boa> ] curry ]
330 (( quot1 quot2 -- compose )) define-declared
332 ! Sub-primitive words
333 : make-sub-primitive ( word vocab -- )
336 dup 1quotation define ;
339 { "(execute)" "words.private" }
340 { "(call)" "kernel.private" }
341 { "fixnum+fast" "math.private" }
342 { "fixnum-fast" "math.private" }
343 { "fixnum*fast" "math.private" }
344 { "fixnum-bitand" "math.private" }
345 { "fixnum-bitor" "math.private" }
346 { "fixnum-bitxor" "math.private" }
347 { "fixnum-bitnot" "math.private" }
348 { "fixnum<" "math.private" }
349 { "fixnum<=" "math.private" }
350 { "fixnum>" "math.private" }
351 { "fixnum>=" "math.private" }
371 { "tag" "kernel.private" }
372 { "slot" "slots.private" }
373 } [ make-sub-primitive ] assoc-each
376 : make-primitive ( word vocab n -- )
377 >r create dup reset-word r>
378 [ do-primitive ] curry [ ] like define ;
381 { "bignum>fixnum" "math.private" }
382 { "float>fixnum" "math.private" }
383 { "fixnum>bignum" "math.private" }
384 { "float>bignum" "math.private" }
385 { "fixnum>float" "math.private" }
386 { "bignum>float" "math.private" }
387 { "<ratio>" "math.private" }
388 { "string>float" "math.private" }
389 { "float>string" "math.private" }
390 { "float>bits" "math" }
391 { "double>bits" "math" }
392 { "bits>float" "math" }
393 { "bits>double" "math" }
394 { "<complex>" "math.private" }
395 { "fixnum+" "math.private" }
396 { "fixnum-" "math.private" }
397 { "fixnum*" "math.private" }
398 { "fixnum/i" "math.private" }
399 { "fixnum-mod" "math.private" }
400 { "fixnum/mod" "math.private" }
401 { "fixnum-shift" "math.private" }
402 { "fixnum-shift-fast" "math.private" }
403 { "bignum=" "math.private" }
404 { "bignum+" "math.private" }
405 { "bignum-" "math.private" }
406 { "bignum*" "math.private" }
407 { "bignum/i" "math.private" }
408 { "bignum-mod" "math.private" }
409 { "bignum/mod" "math.private" }
410 { "bignum-bitand" "math.private" }
411 { "bignum-bitor" "math.private" }
412 { "bignum-bitxor" "math.private" }
413 { "bignum-bitnot" "math.private" }
414 { "bignum-shift" "math.private" }
415 { "bignum<" "math.private" }
416 { "bignum<=" "math.private" }
417 { "bignum>" "math.private" }
418 { "bignum>=" "math.private" }
419 { "bignum-bit?" "math.private" }
420 { "bignum-log2" "math.private" }
421 { "byte-array>bignum" "math" }
422 { "float=" "math.private" }
423 { "float+" "math.private" }
424 { "float-" "math.private" }
425 { "float*" "math.private" }
426 { "float/f" "math.private" }
427 { "float-mod" "math.private" }
428 { "float<" "math.private" }
429 { "float<=" "math.private" }
430 { "float>" "math.private" }
431 { "float>=" "math.private" }
433 { "word-xt" "words" }
434 { "getenv" "kernel.private" }
435 { "setenv" "kernel.private" }
436 { "(exists?)" "io.files.private" }
437 { "(directory)" "io.files.private" }
439 { "gc-stats" "memory" }
440 { "save-image" "memory" }
441 { "save-image-and-exit" "memory" }
442 { "datastack" "kernel" }
443 { "retainstack" "kernel" }
444 { "callstack" "kernel" }
445 { "set-datastack" "kernel" }
446 { "set-retainstack" "kernel" }
447 { "set-callstack" "kernel" }
449 { "data-room" "memory" }
450 { "code-room" "memory" }
451 { "os-env" "system" }
452 { "millis" "system" }
453 { "modify-code-heap" "compiler.units" }
456 { "dlclose" "alien" }
457 { "<byte-array>" "byte-arrays" }
458 { "<displaced-alien>" "alien" }
459 { "alien-signed-cell" "alien.accessors" }
460 { "set-alien-signed-cell" "alien.accessors" }
461 { "alien-unsigned-cell" "alien.accessors" }
462 { "set-alien-unsigned-cell" "alien.accessors" }
463 { "alien-signed-8" "alien.accessors" }
464 { "set-alien-signed-8" "alien.accessors" }
465 { "alien-unsigned-8" "alien.accessors" }
466 { "set-alien-unsigned-8" "alien.accessors" }
467 { "alien-signed-4" "alien.accessors" }
468 { "set-alien-signed-4" "alien.accessors" }
469 { "alien-unsigned-4" "alien.accessors" }
470 { "set-alien-unsigned-4" "alien.accessors" }
471 { "alien-signed-2" "alien.accessors" }
472 { "set-alien-signed-2" "alien.accessors" }
473 { "alien-unsigned-2" "alien.accessors" }
474 { "set-alien-unsigned-2" "alien.accessors" }
475 { "alien-signed-1" "alien.accessors" }
476 { "set-alien-signed-1" "alien.accessors" }
477 { "alien-unsigned-1" "alien.accessors" }
478 { "set-alien-unsigned-1" "alien.accessors" }
479 { "alien-float" "alien.accessors" }
480 { "set-alien-float" "alien.accessors" }
481 { "alien-double" "alien.accessors" }
482 { "set-alien-double" "alien.accessors" }
483 { "alien-cell" "alien.accessors" }
484 { "set-alien-cell" "alien.accessors" }
485 { "(throw)" "kernel.private" }
486 { "alien-address" "alien" }
487 { "set-slot" "slots.private" }
488 { "string-nth" "strings.private" }
489 { "set-string-nth" "strings.private" }
490 { "resize-array" "arrays" }
491 { "resize-string" "strings" }
492 { "<array>" "arrays" }
493 { "begin-scan" "memory" }
494 { "next-object" "memory" }
495 { "end-scan" "memory" }
498 { "fopen" "io.streams.c" }
499 { "fgetc" "io.streams.c" }
500 { "fread" "io.streams.c" }
501 { "fputc" "io.streams.c" }
502 { "fwrite" "io.streams.c" }
503 { "fflush" "io.streams.c" }
504 { "fclose" "io.streams.c" }
505 { "<wrapper>" "kernel" }
506 { "(clone)" "kernel" }
507 { "<string>" "strings" }
508 { "array>quotation" "quotations.private" }
509 { "quotation-xt" "quotations" }
510 { "<tuple>" "classes.tuple.private" }
511 { "<tuple-layout>" "classes.tuple.private" }
512 { "profiling" "tools.profiler.private" }
513 { "become" "kernel.private" }
514 { "(sleep)" "threads.private" }
515 { "<tuple-boa>" "classes.tuple.private" }
516 { "callstack>array" "kernel" }
517 { "innermost-frame-quot" "kernel.private" }
518 { "innermost-frame-scan" "kernel.private" }
519 { "set-innermost-frame-quot" "kernel.private" }
520 { "call-clear" "kernel" }
521 { "(os-envs)" "system.private" }
522 { "set-os-env" "system" }
523 { "unset-os-env" "system" }
524 { "(set-os-envs)" "system.private" }
525 { "resize-byte-array" "byte-arrays" }
526 { "dll-valid?" "alien" }
527 { "unimplemented" "kernel.private" }
528 { "gc-reset" "memory" }
530 [ >r first2 r> make-primitive ] each-index
533 "build" "kernel" create build 1+ 1quotation define