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 parser
5 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 forgotten-definitions set
39 H{ } clone root-cache set
40 H{ } clone source-files set
41 H{ } clone update-map set
42 H{ } clone implementors-map set
45 ! Vocabulary for slot accessors
46 "accessors" create-vocab drop
48 ! Trivial recompile hook. We don't want to touch the code heap
49 ! during stage1 bootstrap, it would just waste time.
50 [ drop { } ] recompile-hook set
56 ! After we execute bootstrap/layouts
57 num-types get f <array> builtins set
61 ! Create some empty vocabs where the below primitives and
71 "classes.tuple.private"
74 "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 ]
285 { "delegate" } make-slots
286 [ drop ] [ finalize-tuple-slots ] 2bi
287 [ "slots" set-word-prop ]
292 ! Create special tombstone values
293 "tombstone" "hashtables.private" create
295 { } define-tuple-class
297 "((empty))" "hashtables.private" create
298 "tombstone" "hashtables.private" lookup f
299 2array >tuple 1quotation define-inline
301 "((tombstone))" "hashtables.private" create
302 "tombstone" "hashtables.private" lookup t
303 2array >tuple 1quotation define-inline
306 "curry" "kernel" create
311 } prepare-slots define-tuple-class
313 "curry" "kernel" lookup
315 [ f "inline" set-word-prop ]
318 [ tuple-layout [ <tuple-boa> ] curry ]
320 (( obj quot -- curry )) define-declared
322 "compose" "kernel" create
325 { "first" read-only }
326 { "second" read-only }
327 } prepare-slots define-tuple-class
329 "compose" "kernel" lookup
331 [ f "inline" set-word-prop ]
334 [ tuple-layout [ <tuple-boa> ] curry ]
336 (( quot1 quot2 -- compose )) define-declared
338 ! Sub-primitive words
339 : make-sub-primitive ( word vocab -- )
342 dup 1quotation define ;
345 { "(execute)" "words.private" }
346 { "(call)" "kernel.private" }
347 { "fixnum+fast" "math.private" }
348 { "fixnum-fast" "math.private" }
349 { "fixnum*fast" "math.private" }
350 { "fixnum-bitand" "math.private" }
351 { "fixnum-bitor" "math.private" }
352 { "fixnum-bitxor" "math.private" }
353 { "fixnum-bitnot" "math.private" }
354 { "fixnum<" "math.private" }
355 { "fixnum<=" "math.private" }
356 { "fixnum>" "math.private" }
357 { "fixnum>=" "math.private" }
377 { "tag" "kernel.private" }
378 { "slot" "slots.private" }
379 } [ make-sub-primitive ] assoc-each
382 : make-primitive ( word vocab n -- )
383 >r create dup reset-word r>
384 [ do-primitive ] curry [ ] like define ;
387 { "bignum>fixnum" "math.private" }
388 { "float>fixnum" "math.private" }
389 { "fixnum>bignum" "math.private" }
390 { "float>bignum" "math.private" }
391 { "fixnum>float" "math.private" }
392 { "bignum>float" "math.private" }
393 { "<ratio>" "math.private" }
394 { "string>float" "math.private" }
395 { "float>string" "math.private" }
396 { "float>bits" "math" }
397 { "double>bits" "math" }
398 { "bits>float" "math" }
399 { "bits>double" "math" }
400 { "<complex>" "math.private" }
401 { "fixnum+" "math.private" }
402 { "fixnum-" "math.private" }
403 { "fixnum*" "math.private" }
404 { "fixnum/i" "math.private" }
405 { "fixnum-mod" "math.private" }
406 { "fixnum/mod" "math.private" }
407 { "fixnum-shift" "math.private" }
408 { "fixnum-shift-fast" "math.private" }
409 { "bignum=" "math.private" }
410 { "bignum+" "math.private" }
411 { "bignum-" "math.private" }
412 { "bignum*" "math.private" }
413 { "bignum/i" "math.private" }
414 { "bignum-mod" "math.private" }
415 { "bignum/mod" "math.private" }
416 { "bignum-bitand" "math.private" }
417 { "bignum-bitor" "math.private" }
418 { "bignum-bitxor" "math.private" }
419 { "bignum-bitnot" "math.private" }
420 { "bignum-shift" "math.private" }
421 { "bignum<" "math.private" }
422 { "bignum<=" "math.private" }
423 { "bignum>" "math.private" }
424 { "bignum>=" "math.private" }
425 { "bignum-bit?" "math.private" }
426 { "bignum-log2" "math.private" }
427 { "byte-array>bignum" "math" }
428 { "float=" "math.private" }
429 { "float+" "math.private" }
430 { "float-" "math.private" }
431 { "float*" "math.private" }
432 { "float/f" "math.private" }
433 { "float-mod" "math.private" }
434 { "float<" "math.private" }
435 { "float<=" "math.private" }
436 { "float>" "math.private" }
437 { "float>=" "math.private" }
439 { "word-xt" "words" }
440 { "getenv" "kernel.private" }
441 { "setenv" "kernel.private" }
442 { "(exists?)" "io.files.private" }
443 { "(directory)" "io.files.private" }
445 { "gc-stats" "memory" }
446 { "save-image" "memory" }
447 { "save-image-and-exit" "memory" }
448 { "datastack" "kernel" }
449 { "retainstack" "kernel" }
450 { "callstack" "kernel" }
451 { "set-datastack" "kernel" }
452 { "set-retainstack" "kernel" }
453 { "set-callstack" "kernel" }
455 { "data-room" "memory" }
456 { "code-room" "memory" }
457 { "os-env" "system" }
458 { "millis" "system" }
459 { "modify-code-heap" "compiler.units" }
462 { "dlclose" "alien" }
463 { "<byte-array>" "byte-arrays" }
464 { "<displaced-alien>" "alien" }
465 { "alien-signed-cell" "alien.accessors" }
466 { "set-alien-signed-cell" "alien.accessors" }
467 { "alien-unsigned-cell" "alien.accessors" }
468 { "set-alien-unsigned-cell" "alien.accessors" }
469 { "alien-signed-8" "alien.accessors" }
470 { "set-alien-signed-8" "alien.accessors" }
471 { "alien-unsigned-8" "alien.accessors" }
472 { "set-alien-unsigned-8" "alien.accessors" }
473 { "alien-signed-4" "alien.accessors" }
474 { "set-alien-signed-4" "alien.accessors" }
475 { "alien-unsigned-4" "alien.accessors" }
476 { "set-alien-unsigned-4" "alien.accessors" }
477 { "alien-signed-2" "alien.accessors" }
478 { "set-alien-signed-2" "alien.accessors" }
479 { "alien-unsigned-2" "alien.accessors" }
480 { "set-alien-unsigned-2" "alien.accessors" }
481 { "alien-signed-1" "alien.accessors" }
482 { "set-alien-signed-1" "alien.accessors" }
483 { "alien-unsigned-1" "alien.accessors" }
484 { "set-alien-unsigned-1" "alien.accessors" }
485 { "alien-float" "alien.accessors" }
486 { "set-alien-float" "alien.accessors" }
487 { "alien-double" "alien.accessors" }
488 { "set-alien-double" "alien.accessors" }
489 { "alien-cell" "alien.accessors" }
490 { "set-alien-cell" "alien.accessors" }
491 { "(throw)" "kernel.private" }
492 { "alien-address" "alien" }
493 { "set-slot" "slots.private" }
494 { "string-nth" "strings.private" }
495 { "set-string-nth" "strings.private" }
496 { "resize-array" "arrays" }
497 { "resize-string" "strings" }
498 { "<array>" "arrays" }
499 { "begin-scan" "memory" }
500 { "next-object" "memory" }
501 { "end-scan" "memory" }
504 { "fopen" "io.streams.c" }
505 { "fgetc" "io.streams.c" }
506 { "fread" "io.streams.c" }
507 { "fputc" "io.streams.c" }
508 { "fwrite" "io.streams.c" }
509 { "fflush" "io.streams.c" }
510 { "fclose" "io.streams.c" }
511 { "<wrapper>" "kernel" }
512 { "(clone)" "kernel" }
513 { "<string>" "strings" }
514 { "array>quotation" "quotations.private" }
515 { "quotation-xt" "quotations" }
516 { "<tuple>" "classes.tuple.private" }
517 { "<tuple-layout>" "classes.tuple.private" }
518 { "profiling" "tools.profiler.private" }
519 { "become" "kernel.private" }
520 { "(sleep)" "threads.private" }
521 { "<tuple-boa>" "classes.tuple.private" }
522 { "callstack>array" "kernel" }
523 { "innermost-frame-quot" "kernel.private" }
524 { "innermost-frame-scan" "kernel.private" }
525 { "set-innermost-frame-quot" "kernel.private" }
526 { "call-clear" "kernel" }
527 { "(os-envs)" "system.private" }
528 { "set-os-env" "system" }
529 { "unset-os-env" "system" }
530 { "(set-os-envs)" "system.private" }
531 { "resize-byte-array" "byte-arrays" }
532 { "dll-valid?" "alien" }
533 { "unimplemented" "kernel.private" }
534 { "gc-reset" "memory" }
536 [ >r first2 r> make-primitive ] each-index
539 "build" "kernel" create build 1+ 1quotation define