factor/core/bootstrap/primitives.factor

! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs bootstrap.image.primitives
bootstrap.image.private classes classes.builtin classes.intersection
classes.predicate classes.private classes.singleton classes.tuple
classes.tuple.private classes.union combinators compiler.units io
kernel kernel.private layouts make math math.private namespaces parser
quotations sequences slots source-files splitting vocabs vocabs.loader
words ;
IN: bootstrap.primitives

"* Creating primitives and basic runtime structures..." print flush

H{ } clone sub-primitives set

"vocab:bootstrap/syntax.factor" parse-file

: asm-file ( arch -- file )
    "-" split reverse "." join
    "vocab:bootstrap/assembler/" ".factor" surround ;

architecture get asm-file parse-file

"vocab:bootstrap/layouts.factor" parse-file

! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack

! Bring up a bare cross-compiling vocabulary.
"syntax" lookup-vocab vocab-words-assoc bootstrap-syntax set

H{ } clone dictionary set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
H{ } clone implementors-map set

init-caches

bootstrapping? on

call( -- ) ! layouts quot
call( -- ) ! arch quot

! Vocabulary for slot accessors
"accessors" create-vocab drop

! After we execute bootstrap/layouts
num-types get f <array> builtins set

[

call( -- ) ! syntax-quot

! create-word some empty vocabs where the below primitives and
! classes will go
{
    "alien"
    "alien.accessors"
    "alien.libraries"
    "alien.private"
    "arrays"
    "byte-arrays"
    "classes.private"
    "classes.tuple"
    "classes.tuple.private"
    "classes.predicate"
    "compiler.units"
    "continuations.private"
    "generic.single"
    "generic.single.private"
    "growable"
    "hashtables"
    "hashtables.private"
    "io"
    "io.files"
    "io.files.private"
    "io.streams.c"
    "locals.backend"
    "kernel"
    "kernel.private"
    "math"
    "math.parser.private"
    "math.private"
    "memory"
    "memory.private"
    "quotations"
    "quotations.private"
    "sbufs"
    "sbufs.private"
    "scratchpad"
    "sequences"
    "sequences.private"
    "slots.private"
    "strings"
    "strings.private"
    "system"
    "system.private"
    "threads.private"
    "tools.dispatch.private"
    "tools.memory.private"
    "tools.profiler.sampling.private"
    "words"
    "words.private"
    "vectors"
    "vectors.private"
    "vm"
} [ create-vocab drop ] each

! Builtin classes
: lookup-type-number ( word -- n )
    [ target-word ] with-global type-number ;

: register-builtin ( class -- )
    [ dup lookup-type-number "type" set-word-prop ]
    [ dup "type" word-prop builtins get set-nth ]
    [ f f f builtin-class define-class ]
    tri ;

: prepare-slots ( slots -- slots' )
    [ [ dup pair? [ first2 create-word ] when ] map ] map ;

: define-builtin-slots ( class slots -- )
    prepare-slots make-slots 1 finalize-slots
    [ "slots" set-word-prop ] [ define-accessors ] 2bi ;

: define-builtin-predicate ( class -- )
    dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;

: define-builtin ( symbol slotspec -- )
    [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;

{
    { "alien" "alien" }
    { "array" "arrays" }
    { "bignum" "math" }
    { "byte-array" "byte-arrays" }
    { "callstack" "kernel" }
    { "dll" "alien" }
    { "fixnum" "math" }
    { "float" "math" }
    { "quotation" "quotations" }
    { "string" "strings" }
    { "tuple" "kernel" }
    { "word" "words" }
    { "wrapper" "kernel" }
} [ create-word register-builtin ] assoc-each

"f" "syntax" lookup-word register-builtin

! We need this before defining c-ptr below
"f" "syntax" lookup-word { } define-builtin

"f" "syntax" create-word [ not ] "predicate" set-word-prop
"f?" "syntax" vocab-words-assoc delete-at

"t" "syntax" lookup-word define-singleton-class

! Some unions
"c-ptr" "alien" create-word [
    "alien" "alien" lookup-word ,
    "f" "syntax" lookup-word ,
    "byte-array" "byte-arrays" lookup-word ,
] { } make define-union-class

"integer" "math" create-word
"fixnum" "math" lookup-word "bignum" "math" lookup-word 2array
define-union-class

! Two predicate classes used for declarations.
"array-capacity" "sequences.private" create-word
"fixnum" "math" lookup-word
[
    [ dup 0 fixnum>= ] %
    bootstrap-max-array-capacity <fake-bignum> [ fixnum<= ] curry ,
    [ [ drop f ] if ] %
] [ ] make
define-predicate-class

"array-capacity" "sequences.private" lookup-word
[ >fixnum ] bootstrap-max-array-capacity <fake-bignum> [ fixnum-bitand ] curry append
"coercer" set-word-prop

"integer-array-capacity" "sequences.private" create-word
"integer" "math" lookup-word
[
    [ dup 0 >= ] %
    bootstrap-max-array-capacity <fake-bignum> [ <= ] curry ,
    [ [ drop f ] if ] %
] [ ] make
define-predicate-class

! Catch-all class for providing a default method.
"object" "kernel" create-word
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi

"object?" "kernel" vocab-words-assoc delete-at

! Empty class with no instances
"null" "kernel" create-word
[ f { } f union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi

"null?" "kernel" vocab-words-assoc delete-at

"fixnum" "math" create-word { } define-builtin
"fixnum" "math" create-word "integer>fixnum-strict" "math" create-word 1quotation "coercer" set-word-prop

"bignum" "math" create-word { } define-builtin
"bignum" "math" create-word ">bignum" "math" create-word 1quotation "coercer" set-word-prop

"float" "math" create-word { } define-builtin
"float" "math" create-word ">float" "math" create-word 1quotation "coercer" set-word-prop

"array" "arrays" create-word {
    { "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin

"wrapper" "kernel" create-word {
    { "wrapped" read-only }
} define-builtin

"string" "strings" create-word {
    { "length" { "array-capacity" "sequences.private" } read-only }
    "aux"
} define-builtin

"quotation" "quotations" create-word {
    { "array" { "array" "arrays" } read-only }
    "cached-effect"
    "cache-counter"
} define-builtin

"dll" "alien" create-word {
    { "path" { "byte-array" "byte-arrays" } read-only }
} define-builtin

"alien" "alien" create-word {
    { "underlying" { "c-ptr" "alien" } read-only }
    "expired"
} define-builtin

"word" "words" create-word {
    { "hashcode" { "fixnum" "math" } }
    "name"
    "vocabulary"
    { "def" { "quotation" "quotations" } initial: [ ] }
    "props"
    "pic-def"
    "pic-tail-def"
    { "sub-primitive" read-only }
} define-builtin

"byte-array" "byte-arrays" create-word {
    { "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin

"callstack" "kernel" create-word { } define-builtin

"tuple" "kernel" create-word
[ { } define-builtin ]
[ define-tuple-layout ]
bi

! create-word special tombstone values
"tombstone" "hashtables.private" create-word
tuple
{ "state" } define-tuple-class

"+empty+" "hashtables.private" create-word
{ f } "tombstone" "hashtables.private" lookup-word
slots>tuple 1quotation ( -- value ) define-inline

"+tombstone+" "hashtables.private" create-word
{ t } "tombstone" "hashtables.private" lookup-word
slots>tuple 1quotation ( -- value ) define-inline

! Some tuple classes

"curried" "kernel" create-word
tuple
{
    { "obj" read-only }
    { "quot" read-only }
} prepare-slots define-tuple-class

"curry" "kernel" create-word
{
    [ f "inline" set-word-prop ]
    [ make-flushable ]
} cleave

"curry" "kernel" lookup-word
[
    callable instance-check-quot %
    "curried" "kernel" lookup-word tuple-layout ,
    \ <tuple-boa> ,
] [ ] make
( obj quot -- curry ) define-declared

"composed" "kernel" create-word
tuple
{
    { "first" read-only }
    { "second" read-only }
} prepare-slots define-tuple-class

"compose" "kernel" create-word
{
    [ f "inline" set-word-prop ]
    [ make-flushable ]
} cleave

"compose" "kernel" lookup-word
[
    callable instance-check-quot [ dip ] curry %
    callable instance-check-quot %
    "composed" "kernel" lookup-word tuple-layout ,
    \ <tuple-boa> ,
] [ ] make
( quot1 quot2 -- compose ) define-declared

"* Declaring primitives..." print flush
all-primitives create-primitives

! Bump build number
"build" "kernel" create-word build 1 + [ ] curry ( -- n ) define-declared

] with-compilation-unit