basis/bootstrap/primitives.factor

   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
   9 words ;
  10 IN: bootstrap.primitives
  11
  12 "* Creating primitives and basic runtime structures..." print flush
  13
  14 H{ } clone sub-primitives set
  15
  16 "resource:basis/bootstrap/syntax.factor" parse-file
  17
  18 : asm-file ( arch -- file )
  19     "-" split reverse "." join
  20     "resource:basis/bootstrap/assembler/" ".factor" surround ;
  21
  22 architecture get asm-file parse-file
  23
  24 "resource:basis/bootstrap/layouts.factor" parse-file
  25
  26 ! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
  27
  28 ! Bring up a bare cross-compiling vocabulary.
  29 "syntax" lookup-vocab vocab-words-assoc bootstrap-syntax set
  30
  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
  36
  37 init-caches
  38
  39 bootstrapping? on
  40
  41 call( -- ) ! layouts quot
  42 call( -- ) ! arch quot
  43
  44 ! Vocabulary for slot accessors
  45 "accessors" create-vocab drop
  46
  47 ! After we execute bootstrap/layouts
  48 num-types get f <array> builtins set
  49
  50 [
  51
  52 call( -- ) ! syntax-quot
  53
  54 ! create-word some empty vocabs where the below primitives and
  55 ! classes will go
  56 {
  57     "alien"
  58     "alien.accessors"
  59     "alien.libraries"
  60     "alien.private"
  61     "arrays"
  62     "byte-arrays"
  63     "classes.private"
  64     "classes.tuple"
  65     "classes.tuple.private"
  66     "classes.predicate"
  67     "compiler.units"
  68     "continuations.private"
  69     "generic.single"
  70     "generic.single.private"
  71     "growable"
  72     "hashtables"
  73     "hashtables.private"
  74     "io"
  75     "io.files"
  76     "io.files.private"
  77     "io.streams.c"
  78     "locals.backend"
  79     "kernel"
  80     "kernel.private"
  81     "math"
  82     "math.parser.private"
  83     "math.private"
  84     "memory"
  85     "memory.private"
  86     "quotations"
  87     "quotations.private"
  88     "sbufs"
  89     "sbufs.private"
  90     "scratchpad"
  91     "sequences"
  92     "sequences.private"
  93     "slots.private"
  94     "strings"
  95     "strings.private"
  96     "system"
  97     "system.private"
  98     "threads.private"
  99     "tools.dispatch.private"
 100     "tools.memory.private"
 101     "tools.profiler.sampling.private"
 102     "words"
 103     "words.private"
 104     "vectors"
 105     "vectors.private"
 106     "vm"
 107 } [ create-vocab drop ] each
 108
 109 ! Builtin classes
 110 : lookup-type-number ( word -- n )
 111     [ target-word ] with-global type-number ;
 112
 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 ]
 117     tri ;
 118
 119 : prepare-slots ( slots -- slots' )
 120     [ [ dup pair? [ first2 create-word ] when ] map ] map ;
 121
 122 : define-builtin-slots ( class slots -- )
 123     prepare-slots make-slots 1 finalize-slots
 124     [ "slots" set-word-prop ] [ define-accessors ] 2bi ;
 125
 126 : define-builtin-predicate ( class -- )
 127     dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
 128
 129 : define-builtin ( symbol slotspec -- )
 130     [ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
 131
 132 {
 133     { "alien" "alien" }
 134     { "array" "arrays" }
 135     { "bignum" "math" }
 136     { "byte-array" "byte-arrays" }
 137     { "callstack" "kernel" }
 138     { "dll" "alien" }
 139     { "fixnum" "math" }
 140     { "float" "math" }
 141     { "quotation" "quotations" }
 142     { "string" "strings" }
 143     { "tuple" "kernel" }
 144     { "word" "words" }
 145     { "wrapper" "kernel" }
 146 } [ create-word register-builtin ] assoc-each
 147
 148 "f" "syntax" lookup-word register-builtin
 149
 150 ! We need this before defining c-ptr below
 151 "f" "syntax" lookup-word { } define-builtin
 152
 153 "f" "syntax" create-word [ not ] "predicate" set-word-prop
 154 "f?" "syntax" vocab-words-assoc delete-at
 155
 156 "t" "syntax" lookup-word define-singleton-class
 157
 158 ! Some unions
 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
 164
 165 "integer" "math" create-word
 166 "fixnum" "math" lookup-word "bignum" "math" lookup-word 2array
 167 define-union-class
 168
 169 ! Two predicate classes used for declarations.
 170 "array-capacity" "sequences.private" create-word
 171 "fixnum" "math" lookup-word
 172 [
 173     [ dup 0 fixnum>= ] %
 174     bootstrap-max-array-capacity <fake-bignum> [ fixnum<= ] curry ,
 175     [ [ drop f ] if ] %
 176 ] [ ] make
 177 define-predicate-class
 178
 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
 182
 183 "integer-array-capacity" "sequences.private" create-word
 184 "integer" "math" lookup-word
 185 [
 186     [ dup 0 >= ] %
 187     bootstrap-max-array-capacity <fake-bignum> [ <= ] curry ,
 188     [ [ drop f ] if ] %
 189 ] [ ] make
 190 define-predicate-class
 191
 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 ]
 196 bi
 197
 198 "object?" "kernel" vocab-words-assoc delete-at
 199
 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 ]
 204 bi
 205
 206 "null?" "kernel" vocab-words-assoc delete-at
 207
 208 "fixnum" "math" create-word { } define-builtin
 209 "fixnum" "math" create-word "integer>fixnum-strict" "math" create-word 1quotation "coercer" set-word-prop
 210
 211 "bignum" "math" create-word { } define-builtin
 212 "bignum" "math" create-word ">bignum" "math" create-word 1quotation "coercer" set-word-prop
 213
 214 "float" "math" create-word { } define-builtin
 215 "float" "math" create-word ">float" "math" create-word 1quotation "coercer" set-word-prop
 216
 217 "array" "arrays" create-word {
 218     { "length" { "array-capacity" "sequences.private" } read-only }
 219 } define-builtin
 220
 221 "wrapper" "kernel" create-word {
 222     { "wrapped" read-only }
 223 } define-builtin
 224
 225 "string" "strings" create-word {
 226     { "length" { "array-capacity" "sequences.private" } read-only }
 227     "aux"
 228 } define-builtin
 229
 230 "quotation" "quotations" create-word {
 231     { "array" { "array" "arrays" } read-only }
 232     "cached-effect"
 233     "cache-counter"
 234 } define-builtin
 235
 236 "dll" "alien" create-word {
 237     { "path" { "byte-array" "byte-arrays" } read-only }
 238 } define-builtin
 239
 240 "alien" "alien" create-word {
 241     { "underlying" { "c-ptr" "alien" } read-only }
 242     "expired"
 243 } define-builtin
 244
 245 "word" "words" create-word {
 246     { "hashcode" { "fixnum" "math" } }
 247     "name"
 248     "vocabulary"
 249     { "def" { "quotation" "quotations" } initial: [ ] }
 250     "props"
 251     "pic-def"
 252     "pic-tail-def"
 253     { "sub-primitive" read-only }
 254 } define-builtin
 255
 256 "byte-array" "byte-arrays" create-word {
 257     { "length" { "array-capacity" "sequences.private" } read-only }
 258 } define-builtin
 259
 260 "callstack" "kernel" create-word { } define-builtin
 261
 262 "tuple" "kernel" create-word
 263 [ { } define-builtin ]
 264 [ define-tuple-layout ]
 265 bi
 266
 267 ! create-word special tombstone values
 268 "tombstone" "hashtables.private" create-word
 269 tuple
 270 { "state" } define-tuple-class
 271
 272 "+empty+" "hashtables.private" create-word
 273 { f } "tombstone" "hashtables.private" lookup-word
 274 slots>tuple 1quotation ( -- value ) define-inline
 275
 276 "+tombstone+" "hashtables.private" create-word
 277 { t } "tombstone" "hashtables.private" lookup-word
 278 slots>tuple 1quotation ( -- value ) define-inline
 279
 280 ! Some tuple classes
 281
 282 "curried" "kernel" create-word
 283 tuple
 284 {
 285     { "obj" read-only }
 286     { "quot" read-only }
 287 } prepare-slots define-tuple-class
 288
 289 "curry" "kernel" create-word
 290 {
 291     [ f "inline" set-word-prop ]
 292     [ make-flushable ]
 293 } cleave
 294
 295 "curry" "kernel" lookup-word
 296 [
 297     callable instance-check-quot %
 298     "curried" "kernel" lookup-word tuple-layout ,
 299     \ <tuple-boa> ,
 300 ] [ ] make
 301 ( obj quot -- curry ) define-declared
 302
 303 "composed" "kernel" create-word
 304 tuple
 305 {
 306     { "first" read-only }
 307     { "second" read-only }
 308 } prepare-slots define-tuple-class
 309
 310 "compose" "kernel" create-word
 311 {
 312     [ f "inline" set-word-prop ]
 313     [ make-flushable ]
 314 } cleave
 315
 316 "compose" "kernel" lookup-word
 317 [
 318     callable instance-check-quot [ dip ] curry %
 319     callable instance-check-quot %
 320     "composed" "kernel" lookup-word tuple-layout ,
 321     \ <tuple-boa> ,
 322 ] [ ] make
 323 ( quot1 quot2 -- compose ) define-declared
 324
 325 "* Declaring primitives..." print flush
 326 all-primitives create-primitives
 327
 328 ! Bump build number
 329 "build" "kernel" create-word build 1 + [ ] curry ( -- n ) define-declared
 330
 331 ] with-compilation-unit