UNION: simple-c-ptr
simple-alien POSTPONE: f byte-array bit-array float-array ;
-UNION: c-ptr
-alien POSTPONE: f byte-array bit-array float-array ;
-
DEFER: pinned-c-ptr?
PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
wrap probe
namestack*
+} compile-uncompiled
+
+"." write flush
+{
bitand bitor bitxor bitnot
} compile-uncompiled
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
-hashtables.private io kernel math namespaces parser sequences
-strings vectors words quotations assocs layouts classes
-classes.builtin classes.tuple classes.tuple.private
+hashtables.private io kernel math math.order namespaces parser
+sequences strings vectors words quotations assocs layouts
+classes classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union classes.intersection
-compiler.units bootstrap.image.private io.files accessors
-combinators ;
+slots classes.union classes.intersection classes.predicate
+compiler.units bootstrap.image.private io.files accessors combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
} [ create-vocab drop ] each
! Builtin classes
-: lo-tag-eq-quot ( n -- quot )
- [ \ tag , , \ eq? , ] [ ] make ;
-
-: hi-tag-eq-quot ( n -- quot )
- [
- [ dup tag ] % \ hi-tag tag-number , \ eq? ,
- [ [ hi-tag ] % , \ eq? , ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: builtin-predicate-quot ( class -- quot )
- "type" word-prop
- dup tag-mask get <
- [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
-
: define-builtin-predicate ( class -- )
- dup builtin-predicate-quot define-predicate ;
+ dup class>type [ builtin-instance? ] curry define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
"byte-array" "byte-arrays" create register-builtin
"tuple-layout" "classes.tuple.private" create register-builtin
+! We need this before defining c-ptr below
+"f" "syntax" lookup { } define-builtin
+
+"f" "syntax" create [ not ] "predicate" set-word-prop
+"f?" "syntax" vocab-words delete-at
+
+! Some unions
+"integer" "math" create
+"fixnum" "math" lookup
+"bignum" "math" lookup
+2array
+define-union-class
+
+"rational" "math" create
+"integer" "math" lookup
+"ratio" "math" lookup
+2array
+define-union-class
+
+"real" "math" create
+"rational" "math" lookup
+"float" "math" lookup
+2array
+define-union-class
+
+"c-ptr" "alien" create [
+ "alien" "alien" lookup ,
+ "f" "syntax" lookup ,
+ "byte-array" "byte-arrays" lookup ,
+ "bit-array" "bit-arrays" lookup ,
+ "float-array" "float-arrays" lookup ,
+] { } make define-union-class
+
+! A predicate class used for declarations
+"array-capacity" "sequences.private" create
+"fixnum" "math" lookup
+0 bootstrap-max-array-capacity [ between? ] 2curry
+define-predicate-class
+
! Catch-all class for providing a default method.
"object" "kernel" create
[ f f { } intersection-class define-class ]
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
"ratio" "math" create {
- {
- "numerator"
- { "integer" "math" }
- read-only: t
- }
- {
- "denominator"
- { "integer" "math" }
- read-only: t
- }
+ { "numerator" { "integer" "math" } read-only: t }
+ { "denominator" { "integer" "math" } read-only: t }
} define-builtin
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
"complex" "math" create {
- {
- "real"
- { "real" "math" }
- read-only: t
- }
- {
- "imaginary"
- { "real" "math" }
- read-only: t
- }
+ { "real" { "real" "math" } read-only: t }
+ { "imaginary" { "real" "math" } read-only: t }
} define-builtin
-"f" "syntax" lookup { } define-builtin
-
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
- {
- "wrapped"
- { "object" "kernel" }
- read-only: t
- }
+ { "wrapped" read-only: t }
} define-builtin
"string" "strings" create {
- {
- "length"
- { "array-capacity" "sequences.private" }
- read-only: t
- } {
- "aux"
- { "object" "kernel" }
- }
+ { "length" { "array-capacity" "sequences.private" } read-only: t }
+ "aux"
} define-builtin
"quotation" "quotations" create {
- {
- "array"
- { "object" "kernel" }
- read-only: t
- }
- {
- "compiled"
- { "object" "kernel" }
- read-only: t
- }
+ { "array" { "array" "arrays" } read-only: t }
+ { "compiled" read-only: t }
} define-builtin
"dll" "alien" create {
- {
- "path"
- { "byte-array" "byte-arrays" }
- read-only: t
- }
+ { "path" { "byte-array" "byte-arrays" } read-only: t }
}
define-builtin
"alien" "alien" create {
- {
- "underlying"
- { "c-ptr" "alien" }
- read-only: t
- } {
- "expired?"
- { "object" "kernel" }
- read-only: t
- }
+ { "underlying" { "c-ptr" "alien" } read-only: t }
+ { "expired?" read-only: t }
}
define-builtin
"word" "words" create {
- {
- "hashcode"
- { "fixnum" "math" }
- }
- {
- "name"
- { "object" "kernel" }
- }
- {
- "vocabulary"
- { "object" "kernel" }
- }
- {
- "def"
- { "quotation" "quotations" }
- }
- {
- "props"
- { "object" "kernel" }
- }
- {
- "compiled"
- { "object" "kernel" }
- read-only: t
- }
- {
- "counter"
- { "fixnum" "math" }
- }
+ { "hashcode" { "fixnum" "math" } }
+ "name"
+ "vocabulary"
+ { "def" { "quotation" "quotations" } }
+ "props"
+ { "compiled" read-only: t }
+ { "counter" { "fixnum" "math" } }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
"callstack" "kernel" create { } define-builtin
"tuple-layout" "classes.tuple.private" create {
- {
- "hashcode"
- { "fixnum" "math" }
- read-only: t
- }
- {
- "class"
- { "word" "words" }
- read-only: t
- }
- {
- "size"
- { "fixnum" "math" }
- read-only: t
- }
- {
- "superclasses"
- { "array" "arrays" }
- read-only: t
- }
- {
- "echelon"
- { "fixnum" "math" }
- read-only: t
- }
+ { "hashcode" { "fixnum" "math" } read-only: t }
+ { "class" { "word" "words" } read-only: t }
+ { "size" { "fixnum" "math" } read-only: t }
+ { "superclasses" { "array" "arrays" } read-only: t }
+ { "echelon" { "fixnum" "math" } read-only: t }
} define-builtin
"tuple" "kernel" create {
[ { "delegate" } "slot-names" set-word-prop ]
[ define-tuple-layout ]
[
- {
- {
- "delegate"
- { "object" "kernel" }
- }
- } prepare-slots
+ { "delegate" }
[ drop ] [ generate-tuple-slots ] 2bi
[ "slots" set-word-prop ]
[ define-accessors ]
]
} cleave
-"f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" vocab-words delete-at
-
! Create special tombstone values
"tombstone" "hashtables.private" create
tuple
"curry" "kernel" create
tuple
{
- {
- "obj"
- { "object" "kernel" }
- read-only: t
- } {
- "quot"
- { "object" "kernel" }
- read-only: t
- }
+ { "obj" read-only: t }
+ { "quot" read-only: t }
} prepare-slots define-tuple-class
"curry" "kernel" lookup
"compose" "kernel" create
tuple
{
- {
- "first"
- { "object" "kernel" }
- read-only: t
- } {
- "second"
- { "object" "kernel" }
- read-only: t
- }
+ { "first" read-only: t }
+ { "second" read-only: t }
} prepare-slots define-tuple-class
"compose" "kernel" lookup
--- /dev/null
+IN: classes.builtin.tests
+USING: tools.test words sequences kernel memory accessors ;
+
+[ f ] [
+ [ word? ] instances
+ [
+ [ name>> "f?" = ]
+ [ vocabulary>> "syntax" = ] bi and
+ ] contains?
+] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes words kernel kernel.private namespaces
-sequences ;
+sequences math ;
IN: classes.builtin
SYMBOL: builtins
: type>class ( n -- class ) builtins get-global nth ;
+: class>type ( class -- n ) "type" word-prop ; foldable
+
: bootstrap-type>class ( n -- class ) builtins get nth ;
M: hi-tag class hi-tag type>class ;
M: object class tag type>class ;
M: builtin-class rank-class drop 0 ;
+
+: builtin-instance? ( object n -- ? )
+ #! 7 == tag-mask get
+ #! 3 == hi-tag tag-number
+ dup 7 <= [ swap tag eq? ] [
+ swap dup tag 3 eq?
+ [ hi-tag eq? ] [ 2drop f ] if
+ ] if ; inline
+
+M: builtin-class instance?
+ class>type builtin-instance? ;
] each ;
M: class forget* ( class -- )
- [ forget-class ] [ call-next-method ] bi ;
+ [ call-next-method ] [ forget-class ] bi ;
GENERIC: class ( object -- class )
-: instance? ( obj class -- ? )
- "predicate" word-prop call ;
+GENERIC: instance? ( object class -- ? )
2bi ;
M: intersection-class rank-class drop 2 ;
+
+M: intersection-class instance?
+ "participants" word-prop [ instance? ] with all? ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel namespaces words ;
+USING: classes kernel namespaces words sequences quotations
+arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
+DEFER: predicate-instance? ( object class -- ? )
+
+: update-predicate-instance ( -- )
+ \ predicate-instance? bootstrap-word
+ classes [ predicate-class? ] filter [
+ [ literalize ]
+ [
+ [ superclass 1array [ declare ] curry ]
+ [ "predicate-definition" word-prop ]
+ bi compose
+ ]
+ bi
+ ] { } map>assoc [ case ] curry
+ define ;
+
: predicate-quot ( class -- quot )
[
\ dup ,
[ dup predicate-quot define-predicate ]
[ update-classes ]
bi
- ] 3tri ;
+ ]
+ 3tri
+ update-predicate-instance ;
M: predicate-class reset-class
[ call-next-method ]
bi ;
M: predicate-class rank-class drop 1 ;
+
+M: predicate-class instance?
+ 2dup superclass instance?
+ [ predicate-instance? ] [ 2drop f ] if ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.predicate kernel sequences words ;
+USING: classes classes.predicate kernel sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
: define-singleton-class ( word -- )
\ word over [ eq? ] curry define-predicate-class ;
+
+M: singleton-class instance? eq? ;
[ error>> unexpected-eof? ]
must-fail-with
+[ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { \"slot\" alien } ;" eval ]
+[ error>> no-initial-value? ]
+must-fail-with
+
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { \"slot\" array initial: 5 } ;" eval ]
+[ error>> bad-initial-value? ]
+must-fail-with
+
[ ] [
[
{ test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
: tuple-layout ( class -- layout )
check-tuple-class "layout" word-prop ;
+: layout-of ( tuple -- layout )
+ 1 slot { tuple-layout } declare ; inline
+
: tuple-size ( tuple -- size )
- 1 slot size>> ; inline
+ layout-of size>> ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
- check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ;
+ check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
: copy-tuple-slots ( n tuple -- array )
[ array-nth ] curry map ;
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop
- [ dup array? [ second ] when ] map ;
+ "slot-names" word-prop ;
: all-slot-names ( class -- slots )
superclasses [ slot-names ] map concat \ class prefix ;
<PRIVATE
: tuple= ( tuple1 tuple2 -- ? )
- 2dup [ 1 slot ] bi@ eq? [
+ 2dup [ layout-of ] bi@ eq? [
[ drop tuple-size ]
[ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
2bi all-integers?
] [
2drop f
- ] if ;
-
-! Predicate generation. We optimize at the expense of simplicity
+ ] if ; inline
-: (tuple-predicate-quot) ( class -- quot )
- #! 4 slot == layout-superclasses
- #! 5 slot == layout-echelon
- [
- [ 1 slot dup 5 slot ] %
- dup tuple-layout echelon>> ,
- [ fixnum>= ] %
+: tuple-instance? ( object class -- ? )
+ over tuple? [
[
- dup tuple-layout echelon>> ,
- [ swap 4 slot array-nth ] %
- literalize ,
- [ eq? ] %
- ] [ ] make ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
-
-: tuple-predicate-quot ( class -- quot )
- [
- [ dup tuple? ] %
- (tuple-predicate-quot) ,
- [ drop f ] ,
- \ if ,
- ] [ ] make ;
+ [ layout-of superclasses>> ]
+ [ tuple-layout echelon>> ] bi*
+ swap ?nth
+ ] keep eq?
+ ] [ 2drop f ] if ; inline
: define-tuple-predicate ( class -- )
- dup tuple-predicate-quot define-predicate ;
+ dup [ tuple-instance? ] curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
M: tuple-class rank-class drop 0 ;
+M: tuple-class instance?
+ tuple-instance? ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
[ (define-union-class) ] [ drop update-classes ] 2bi ;
M: union-class rank-class drop 2 ;
+
+M: union-class instance?
+ "members" word-prop [ instance? ] with contains? ;
USING: alien strings kernel math tools.test io prettyprint
-namespaces combinators words classes sequences ;
+namespaces combinators words classes sequences accessors
+math.functions ;
IN: combinators.tests
! Compiled
: do-not-call "do not call" throw ;
-: test-case-6
+: test-case-6 ( obj -- value )
{
{ \ do-not-call [ "do-not-call" ] }
{ 3 [ "three" ] }
} case ;
+\ test-case-6 must-infer
+
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 def>> call ] unit-test
-[ 1 3 t ] [ { 1 3 2 } contiguous-range? ] unit-test
-[ f ] [ { 1 2 2 4 } contiguous-range? 2nip ] unit-test
-[ f ] [ { + 3 2 } contiguous-range? 2nip ] unit-test
-[ f ] [ { 1 0 7 } contiguous-range? 2nip ] unit-test
-[ f ] [ { 1 1 3 7 } contiguous-range? 2nip ] unit-test
-[ 4 8 t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
+[ t ] [ { 1 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
+[ f ] [ { + 3 2 } contiguous-range? ] unit-test
+[ f ] [ { 1 0 7 } contiguous-range? ] unit-test
+[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
+[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
+
+: test-case-7 ( obj -- str )
+ {
+ { \ + [ "plus" ] }
+ { \ - [ "minus" ] }
+ { \ * [ "times" ] }
+ { \ / [ "divide" ] }
+ { \ ^ [ "power" ] }
+ { \ [ [ "obama" ] }
+ { \ ] [ "KFC" ] }
+ } case ;
+
+\ test-case-7 must-infer
+
+[ "plus" ] [ \ + test-case-7 ] unit-test
hashtables sorting words sets math.order ;
IN: combinators
+! cleave
: cleave ( x seq -- )
[ call ] with each ;
: cleave>quot ( seq -- quot )
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
+! 2cleave
: 2cleave ( x seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
+! 3cleave
: 3cleave ( x seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )
[ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
+! spread
: spread>quot ( seq -- quot )
[ length [ >r ] <repetition> concat ]
[ [ [ r> ] prepend ] map concat ] bi
: spread ( objs... seq -- )
spread>quot call ;
+! cond
ERROR: no-cond ;
: cond ( assoc -- )
[ dup callable? [ call ] [ second call ] if ]
[ no-cond ] if* ;
+: alist>quot ( default assoc -- quot )
+ [ rot \ if 3array append [ ] like ] assoc-each ;
+
+: cond>quot ( assoc -- quot )
+ [ dup callable? [ [ t ] swap 2array ] when ] map
+ reverse [ no-cond ] swap alist>quot ;
+
+! case
ERROR: no-case ;
+
: case-find ( obj assoc -- obj' )
[
dup array? [
{ [ dup not ] [ no-case ] }
} cond ;
-: with-datastack ( stack quot -- newstack )
- datastack >r
- >r >array set-datastack r> call
- datastack r> swap suffix set-datastack 2nip ; inline
-
-: recursive-hashcode ( n obj quot -- code )
- pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
-
-! These go here, not in sequences and hashtables, since those
-! two depend on combinators
-M: sequence hashcode*
- [ sequence-hashcode ] recursive-hashcode ;
-
-M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
-
-M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
-
-M: hashtable hashcode*
- [
- dup assoc-size 1 number=
- [ assoc-hashcode ] [ nip assoc-size ] if
- ] recursive-hashcode ;
-
-: alist>quot ( default assoc -- quot )
- [ rot \ if 3array append [ ] like ] assoc-each ;
-
-: cond>quot ( assoc -- quot )
- [ dup callable? [ [ t ] swap 2array ] when ] map
- reverse [ no-cond ] swap alist>quot ;
-
: linear-case-quot ( default assoc -- quot )
[
[ 1quotation \ dup prefix \ = suffix ]
: hash-case-table ( default assoc -- array )
V{ } [ 1array ] distribute-buckets
- [ linear-case-quot ] with map ;
+ [ [ >r literalize r> ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] prepend ;
-: contiguous-range? ( keys -- from to ? )
+: contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [
dup all-unique? [
- dup infimum over supremum
- [ - swap prune length + 1 = ] 2keep rot
- ] [
- drop f f f
- ] if
- ] [
- drop f f f
- ] if ;
+ [ prune length ]
+ [ [ supremum ] [ infimum ] bi - ]
+ bi - 1 =
+ ] [ drop f ] if
+ ] [ drop f ] if ;
: dispatch-case ( value from to default array -- )
>r >r 3dup between? [
2drop r> call r> drop
] if ; inline
-: dispatch-case-quot ( default assoc from to -- quot )
- -roll -roll sort-keys values [ >quotation ] map
+: dispatch-case-quot ( default assoc -- quot )
+ [ nip keys [ infimum ] [ supremum ] bi ] 2keep
+ sort-keys values [ >quotation ] map
[ dispatch-case ] 2curry 2curry ;
: case>quot ( default assoc -- quot )
- dup empty? [
- drop
- ] [
- dup length 4 <=
- over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
- [
- linear-case-quot
- ] [
- dup keys contiguous-range? [
- dispatch-case-quot
- ] [
- 2drop hash-case-quot
- ] if
- ] if
- ] if ;
+ dup keys {
+ { [ dup empty? ] [ 2drop ] }
+ { [ dup [ length 4 <= ] [ [ word? ] contains? ] bi or ] [ drop linear-case-quot ] }
+ { [ dup contiguous-range? ] [ drop dispatch-case-quot ] }
+ { [ dup [ wrapper? ] contains? not ] [ drop hash-case-quot ] }
+ { [ dup [ wrapper? ] all? ] [ drop [ >r wrapped>> r> ] assoc-map hash-case-quot ] }
+ [ drop linear-case-quot ]
+ } cond ;
+
+! with-datastack
+: with-datastack ( stack quot -- newstack )
+ datastack >r
+ >r >array set-datastack r> call
+ datastack r> swap suffix set-datastack 2nip ; inline
+
+! recursive-hashcode
+: recursive-hashcode ( n obj quot -- code )
+ pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
+
+! These go here, not in sequences and hashtables, since those
+! two cannot depend on us
+M: sequence hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: hashtable hashcode*
+ [
+ dup assoc-size 1 number=
+ [ assoc-hashcode ] [ nip assoc-size ] if
+ ] recursive-hashcode ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic hashtables inspector io kernel
-math namespaces prettyprint prettyprint.config sequences assocs
-sequences.private strings io.styles vectors words system
+USING: slots arrays definitions generic hashtables inspector io
+kernel math namespaces prettyprint prettyprint.config sequences
+assocs sequences.private strings io.styles vectors words system
splitting math.parser classes.tuple continuations
-continuations.private combinators generic.math
-classes.builtin classes compiler.units generic.standard vocabs
-threads threads.private init kernel.private libc io.encodings
-mirrors accessors math.order destructors ;
+continuations.private combinators generic.math classes.builtin
+classes compiler.units generic.standard vocabs threads
+threads.private init kernel.private libc io.encodings mirrors
+accessors math.order destructors ;
IN: debugger
GENERIC: error. ( error -- )
M: no-method error.
"Generic word " write
- dup no-method-generic pprint
+ dup generic>> pprint
" does not define a method for the " write
- dup no-method-object class pprint
+ dup object>> class pprint
" class." print
- "Allowed classes: " write dup no-method-generic order .
- "Dispatching on object: " write no-method-object short. ;
+ "Dispatching on object: " write object>> short. ;
+
+M: bad-slot-value error.
+ "Bad store to specialized slot" print
+ dup [ index>> 2 - ] [ object>> class all-slots ] bi nth
+ standard-table-style [
+ [
+ [ "Object" write ] with-cell
+ [ over object>> short. ] with-cell
+ ] with-row
+ [
+ [ "Slot" write ] with-cell
+ [ dup name>> short. ] with-cell
+ ] with-row
+ [
+ [ "Slot class" write ] with-cell
+ [ dup class>> short. ] with-cell
+ ] with-row
+ [
+ [ "Value" write ] with-cell
+ [ over value>> short. ] with-cell
+ ] with-row
+ [
+ [ "Value class" write ] with-cell
+ [ over value>> class short. ] with-cell
+ ] with-row
+ ] tabular-output
+ 2drop ;
M: no-math-method summary
drop "No suitable arithmetic method" ;
M: no-such-slot summary drop "No such slot" ;
-M: immutable-slot summary drop "Slot is immutable" ;
+M: read-only-slot summary drop "Slot is declared read-only" ;
M: bad-create summary drop "Bad parameters to create" ;
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: specific-method ( class word -- class )
- order min-class ;
+: specific-method ( class generic -- method/f )
+ tuck order min-class dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( ... generic -- method )
: next-method ( class generic -- class/f )
[ next-method-class ] keep method ;
-GENERIC: next-method-quot* ( class generic -- quot )
+GENERIC: next-method-quot* ( class generic combination -- quot )
: next-method-quot ( class generic -- quot )
dup "combination" word-prop next-method-quot* ;
[
2dup next-method
[ 2nip 1quotation ]
- [ [ no-next-method ] 2curry ] if* ,
+ [ [ no-next-method ] 2curry [ ] like ] if* ,
]
[ [ inconsistent-next-method ] 2curry , ]
2tri
] [
2dup capacity > [ 2dup expand ] when
] if
- swap >fixnum >>length drop ;
+ (>>length) ;
: new-size ( old -- new ) 1+ 3 * ; inline
2dup length >= [
2dup capacity >= [ over new-size over expand ] when
>r >fixnum r>
- 2dup swap 1 fixnum+fast >>length drop
+ over 1 fixnum+fast over (>>length)
] [
>r >fixnum r>
] if ; inline
M: growable lengthen ( n seq -- )
2dup length > [
2dup capacity > [ over new-size over expand ] when
- 2dup swap >fixnum >>length drop
+ 2dup (>>length)
] when 2drop ;
INSTANCE: growable sequence
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial accessors
-optimizer.inlining math.order ;
+optimizer.inlining math.order hashtables classes ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
\ detect-integer inlined?
] unit-test
+[ t ] [
+ [ hashtable new ] \ new inlined?
+] unit-test
+
+[ t ] [
+ [ dup hashtable eq? [ new ] when ] \ new inlined?
+] unit-test
+
+[ t ] [
+ [ hashtable instance? ] \ instance? inlined?
+] unit-test
+
+TUPLE: declared-fixnum { "x" fixnum } ;
+
+[ t ] [
+ [ { declared-fixnum } declare [ 1 + ] change-x ]
+ { + fixnum+ >fixnum } inlined?
+] unit-test
+
! Later
! [ t ] [
\ define-tuple-class must-infer
\ define-union-class must-infer
\ define-predicate-class must-infer
+\ instance? must-infer
+\ next-method-quot must-infer
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
] if
] 1 define-transform
-\ new [
- 1 ensure-values
- peek-d value? [
- pop-literal dup tuple-class? [
- dup +inlined+ depends-on
- tuple-layout [ <tuple> ] curry
- swap infer-quot
- ] [
- \ not-a-tuple-class boa time-bomb drop
- ] if
- ] [
- \ new (( class -- tuple )) make-call-node
- ] if
-] "infer" set-word-prop
-
-\ instance? [
- [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
-] 1 define-transform
-
\ (call-next-method) [
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
] 2 define-transform
{ $subsection max-array-capacity } ;
ARTICLE: "layouts-bootstrap" "Bootstrap support"
-"Bootstrap support:"
+"Processor cell size for the target architecture:"
{ $subsection bootstrap-cell }
{ $subsection bootstrap-cells }
{ $subsection bootstrap-cell-bits }
+"Range of integers representable by " { $link fixnum } "s of the target architecture:"
{ $subsection bootstrap-most-negative-fixnum }
-{ $subsection bootstrap-most-positive-fixnum } ;
+{ $subsection bootstrap-most-positive-fixnum }
+"Maximum array size for the target architecture:"
+{ $subsection bootstrap-max-array-capacity } ;
ARTICLE: "layouts" "VM memory layouts"
"The words documented in this section do not ever need to be called by user code. They are documented for the benefit of those wishing to explore the internals of Factor's implementation."
\r
[ t ] [ cell integer? ] unit-test\r
[ t ] [ bootstrap-cell integer? ] unit-test\r
+\r
+! Smoke test\r
+[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test\r
: most-negative-fixnum ( -- n )
first-bignum neg ;
+: (max-array-capacity) ( b -- n )
+ 5 - 2^ 1- ;
+
+: max-array-capacity ( -- n )
+ cell-bits (max-array-capacity) ;
+
: bootstrap-first-bignum ( -- n )
bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ;
+: bootstrap-max-array-capacity ( -- n )
+ bootstrap-cell-bits (max-array-capacity) ;
+
M: bignum >integer
dup most-negative-fixnum most-positive-fixnum between?
[ >fixnum ] when ;
-USING: mirrors tools.test assocs kernel arrays accessors ;
+USING: mirrors tools.test assocs kernel arrays accessors words
+namespaces math slots ;
IN: mirrors.tests
TUPLE: foo bar baz ;
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
-[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
- [ no-such-slot? ]
- [ name>> "hi" = ]
- [ object>> foo? ] tri and and
-] must-fail-with
-
-[ 3 "numerator" 1/2 <mirror> set-at ] [
- [ immutable-slot? ]
- [ name>> "numerator" = ]
- [ object>> 1/2 = ] tri and and
-] must-fail-with
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] must-fail
+
+[ 3 "numerator" 1/2 <mirror> set-at ] must-fail
+
+[ "foo" ] [
+ gensym [
+ <mirror> [
+ "foo" "name" set
+ ] bind
+ ] [ name>> ] bi
+] unit-test
+
+[ gensym <mirror> [ "compiled" off ] bind ] must-fail
+
+TUPLE: declared-mirror-test
+{ "a" integer initial: 0 } ;
+
+[ 5 ] [
+ 3 declared-mirror-test boa <mirror> [
+ 5 "a" set
+ "a" get
+ ] bind
+] unit-test
+
+[ 3 declared-mirror-test boa <mirror> [ t "a" set ] bind ] must-fail
+
+TUPLE: color
+{ "red" integer }
+{ "green" integer }
+{ "blue" integer } ;
+
+[ T{ color f 0 0 0 } ] [
+ 1 2 3 color boa [ <mirror> clear-assoc ] keep
+] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple math vectors
-quotations accessors ;
+quotations accessors combinators ;
IN: mirrors
: all-slots ( class -- slots )
: <mirror> ( object -- mirror )
dup object-slots mirror boa ;
-ERROR: no-such-slot object name ;
-
-ERROR: immutable-slot object name ;
-
M: mirror at*
[ nip object>> ] [ slots>> slot-named ] 2bi
dup [ offset>> slot t ] [ 2drop f f ] if ;
+: check-set-slot ( val slot -- val offset )
+ {
+ { [ dup not ] [ "No such slot" throw ] }
+ { [ dup read-only>> ] [ "Read only slot" throw ] }
+ { [ 2dup class>> instance? not ] [ "Bad store to specialized slot" throw ] }
+ [ offset>> ]
+ } cond ; inline
+
M: mirror set-at ( val key mirror -- )
- [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
- dup read-only>> [
- drop immutable-slot
- ] [
- nip offset>> set-slot
- ] if
- ] [
- drop no-such-slot
- ] if ;
+ [ slots>> slot-named check-set-slot ] [ object>> ] bi
+ swap set-slot ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
+M: mirror clear-assoc ( mirror -- )
+ [ object>> ] [ slots>> ] bi [
+ [ initial>> ] [ offset>> ] bi swapd set-slot
+ ] with each ;
+
M: mirror >alist ( mirror -- alist )
[ slots>> [ name>> ] map ]
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+USING: accessors inference inference.dataflow optimizer
+optimizer.def-use namespaces assocs kernel sequences math
+tools.test words sets ;
IN: optimizer.def-use.tests
-USING: inference inference.dataflow optimizer optimizer.def-use
-namespaces assocs kernel sequences math tools.test words sets ;
[ 3 { 1 1 1 } ] [
[ 1 2 3 ] dataflow compute-def-use drop
IN: optimizer.inlining.tests
-USING: tools.test optimizer.inlining ;
+USING: tools.test optimizer.inlining generic arrays math
+sequences growable sbufs vectors sequences.private accessors kernel ;
\ word-flat-length must-infer
-
\ inlining-math-method must-infer
-
\ optimistic-inline? must-infer
-
\ find-identity must-infer
+\ dispatching-class must-infer
+
+! Make sure we have sane heuristics
+: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
+
+[ t ] [ \ fixnum \ shift should-inline? ] unit-test
+[ f ] [ \ array \ equal? should-inline? ] unit-test
+[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
+[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
+[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
+[ t ] [ \ growable \ set-nth-unsafe should-inline? ] unit-test
+[ t ] [ \ vector \ (>>length) should-inline? ] unit-test
! heuristic: { ... } declare comes up in method bodies
! and we don't care about it
{ [ dup \ declare eq? ] [ drop -2 ] }
- ! recursive
- { [ dup get ] [ drop 1 ] }
! not inline
{ [ dup inline? not ] [ drop 1 ] }
+ ! recursive and inline
+ { [ dup get ] [ drop 1 ] }
! inline
[ dup dup set def>> (flat-length) ]
} cond ;
} cond
] map sum ;
-: flat-length ( seq -- n )
+: flat-length ( word -- n )
[ def>> (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
-: node-class# ( node n -- class )
- over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
- [ dispatch# node-class# ] keep specific-method ;
-
-: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup
- [ swap method 1quotation f splice-quot ] [ 3drop t ] if ;
+: dispatching-class ( node generic -- method/f )
+ tuck dispatch# over in-d>> <reversed> ?nth 2dup node-literal?
+ [ node-literal swap single-effective-method ]
+ [ node-class swap specific-method ]
+ if ;
+
+: inline-standard-method ( node generic -- node )
+ dupd dispatching-class dup
+ [ 1quotation f splice-quot ] [ 2drop t ] if ;
! Partial dispatch of math-generic words
: normalize-math-class ( class -- class' )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.known-words
-USING: accessors alien arrays generic hashtables inference.dataflow
-inference.class kernel assocs math math.order math.private
-kernel.private sequences words parser vectors strings sbufs io
-namespaces assocs quotations sequences.private io.binary
-io.streams.string layouts splitting math.intervals
-math.floats.private classes.tuple classes.tuple.private classes
-classes.algebra optimizer.def-use optimizer.backend
-optimizer.pattern-match optimizer.inlining float-arrays
-sequences.private combinators byte-arrays byte-vectors ;
+USING: accessors alien arrays generic hashtables definitions
+inference.dataflow inference.state inference.class kernel assocs
+math math.order math.private kernel.private sequences words
+parser vectors strings sbufs io namespaces assocs quotations
+sequences.private io.binary io.streams.string layouts splitting
+math.intervals math.floats.private classes.tuple classes.predicate
+classes.tuple.private classes classes.algebra optimizer.def-use
+optimizer.backend optimizer.pattern-match optimizer.inlining
+float-arrays sequences.private combinators byte-arrays
+byte-vectors ;
{ <tuple> <tuple-boa> } [
[
] if
] "constraints" set-word-prop
+! if the input to new is a literal tuple class, we can expand it
+: literal-new? ( #call -- ? )
+ dup in-d>> first node-literal tuple-class? ;
+
+: expand-new ( #call -- node )
+ dup dup in-d>> first node-literal
+ [ +inlined+ depends-on ] [ tuple-layout [ nip <tuple> ] curry ] bi
+ f splice-quot ;
+
+\ new {
+ { [ dup literal-new? ] [ expand-new ] }
+} define-optimizers
+
+! open-code instance? checks on predicate classes
+: literal-predicate-class? ( #call -- ? )
+ dup in-d>> second node-literal predicate-class? ;
+
+: expand-predicate-instance ( #call -- node )
+ dup dup in-d>> second node-literal
+ [ +inlined+ depends-on ]
+ [ "predicate-definition" word-prop [ drop ] prepose ] bi
+ f splice-quot ;
+
+\ predicate-instance? {
+ { [ dup literal-predicate-class? ] [ expand-predicate-instance ] }
+} define-optimizers
+
! eq? on the same object is always t
{ eq? = } {
{ { @ @ } [ 2drop t ] }
-USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer generator prettyprint sequences
-sbufs strings tools.test vectors words sequences.private
-quotations optimizer.backend classes classes.algebra
-inference.dataflow classes.tuple.private continuations growable
-optimizer.inlining namespaces hints ;
+USING: accessors arrays compiler.units generic hashtables
+inference kernel kernel.private math optimizer generator
+prettyprint sequences sbufs strings tools.test vectors words
+sequences.private quotations optimizer.backend classes
+classes.algebra inference.dataflow classes.tuple.private
+continuations growable optimizer.inlining namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
M: integer foozul ;
M: slice foozul ;
-[ reversed ] [ reversed \ foozul specific-method ] unit-test
+[ t ] [
+ reversed \ foozul specific-method
+ reversed \ foozul method
+ eq?
+] unit-test
! regression
: constant-fold-2 f ; foldable
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
-! Make sure we have sane heuristics
-: should-inline? ( generic class -- ? ) method flat-length 10 <= ;
-
-[ t ] [ \ fixnum \ shift should-inline? ] unit-test
-[ f ] [ \ array \ equal? should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test
-
! Regression
: lift-throw-tail-regression ( obj -- obj str )
dup integer? [ "an integer" ] [
[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
+
+! Infinite expansion
+TUPLE: cons car cdr ;
+
+UNION: improper-list cons POSTPONE: f ;
+
+PREDICATE: list < improper-list
+ [ cdr>> list instance? ] [ t ] if* ;
+
+[ t ] [
+ T{ cons f 1 T{ cons f 2 T{ cons f 3 f } } }
+ [ list instance? ] compile-call
+] unit-test
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
- slot-names [ text ] each
+ slot-names [ dup string? [ text ] [ pprint* ] if ] each
pprint-; block> ;
M: word see-class* drop ;
USING: arrays bit-arrays help.markup help.syntax math
-sequences.private vectors strings sbufs kernel math.order ;
+sequences.private vectors strings sbufs kernel math.order
+layouts ;
IN: sequences
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
HELP: array-capacity
{ $values { "array" "an array" } { "n" "a non-negative fixnum" } }
+{ $class-description "A predicate class whose instances are valid array sizes for the current architecture. The minimum value is zero and the maximum value is " { $link max-array-capacity } "." }
{ $description "Low-level array length accessor." }
{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is unsafe. It does not check types, so improper use can corrupt memory." } ;
<PRIVATE
-: max-array-capacity ( -- n )
- #! A bit of a pain; can't call cell-bits here
- 7 getenv 8 * 5 - 2^ 1- ; foldable
-
-PREDICATE: array-capacity < fixnum
- 0 max-array-capacity between? ;
-
: array-capacity ( array -- n )
1 slot { array-capacity } declare ; inline
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel kernel.private math namespaces
-sequences strings words effects generic generic.standard
-classes slots.private combinators accessors words ;
+USING: arrays bit-arrays byte-arrays float-arrays kernel
+kernel.private math namespaces sequences strings words effects
+generic generic.standard classes classes.algebra slots.private
+combinators accessors words ;
IN: slots
TUPLE: slot-spec name offset class initial read-only reader writer ;
ERROR: bad-slot-value value object index ;
+: writer-quot/object ( decl -- )
+ drop \ set-slot , ;
+
+: writer-quot/coerce ( decl -- )
+ [ rot ] % "coercer" word-prop % [ -rot set-slot ] % ;
+
+: writer-quot/check ( decl -- )
+ \ pick ,
+ "predicate" word-prop %
+ [ [ set-slot ] [ bad-slot-value ] if ] % ;
+
+: writer-quot/fixnum ( decl -- )
+ [ rot >fixnum -rot ] % writer-quot/check ;
+
: writer-quot ( decl -- quot )
[
- dup object bootstrap-word eq?
- [ drop \ set-slot , ] [
- \ pick ,
- "predicate" word-prop %
- [ [ set-slot ] [ bad-slot-value ] if ] %
- ] if
+ {
+ { [ dup object bootstrap-word eq? ] [ writer-quot/object ] }
+ { [ dup "coercer" word-prop ] [ writer-quot/coerce ] }
+ { [ dup fixnum class<= ] [ writer-quot/fixnum ] }
+ [ writer-quot/check ]
+ } cond
] [ ] make ;
: define-writer ( class slot-spec -- )
[ changer-word drop ]
} cleave ;
+ERROR: no-initial-value class ;
+
+: initial-value ( class -- object )
+ {
+ { [ \ f over class<= ] [ f ] }
+ { [ fixnum over class<= ] [ 0 ] }
+ { [ float over class<= ] [ 0.0 ] }
+ { [ array over class<= ] [ { } ] }
+ { [ bit-array over class<= ] [ ?{ } ] }
+ { [ byte-array over class<= ] [ B{ } ] }
+ { [ float-array over class<= ] [ F{ } ] }
+ [ no-initial-value ]
+ } cond nip ;
+
GENERIC: make-slot ( desc -- slot-spec )
M: string make-slot
: peel-off-class ( slot-spec array -- slot-spec array )
dup empty? [
- ! We'd use class? here, but during bootstrap, we sometimes
- ! create slots whose class hasn't been defined yet.
- dup first name>> ":" tail? not [
+ dup first class? [
[ first >>class ] [ rest ] bi
] when
] unless ;
+ERROR: bad-slot-attribute key ;
+
: peel-off-attributes ( slot-spec array -- slot-spec array )
dup empty? [
unclip {
{ initial: [ [ first >>initial ] [ rest ] bi ] }
{ read-only: [ [ first >>read-only ] [ rest ] bi ] }
+ [ bad-slot-attribute ]
} case
] unless ;
+ERROR: bad-initial-value name ;
+
+: check-initial-value ( slot-spec -- slot-spec )
+ dup initial>> [
+ dup [ initial>> ] [ class>> ] bi instance?
+ [ name>> bad-initial-value ] unless
+ ] [
+ dup class>> initial-value >>initial
+ ] if ;
+
M: array make-slot
<slot-spec>
swap
peel-off-name
peel-off-class
- [ dup empty? not ] [ peel-off-attributes ] [ ] while drop ;
+ [ dup empty? not ] [ peel-off-attributes ] [ ] while drop
+ check-initial-value ;
: make-slots ( slots base -- specs )
over length [ + ] with map
HELP: SLOT:
{ $syntax "SLOT: name" }
{ $values { "name" "a slot name" } }
-{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." }
-{ $notes
- "Protocol slots are used where the implementation of a superclass needs to assume that each subclass defines certain slots, however the slots of each subclass are potentially declared with different class specializers, thus preventing the slots from being defined in the superclass."
-} ;
+{ $description "Defines a protocol slot; that is, defines the accessor words for a slot named " { $snippet "slot" } " without associating it with any specific tuple." } ;
HELP: ERROR:
{ $syntax "ERROR: class slots... ;" }
projects / factor.git / commitdiff