! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init command-line namespaces words debugger io
+USING: accessors init command-line namespaces words debugger io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
[ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
- all-words swap filter length number>string write ;
+ all-words swap count number>string write ;
: print-report ( time -- )
1000 /i
"Bootstrap completed in " write number>string write
" minutes and " write number>string write " seconds." print
- [ compiled? ] count-words " compiled words" print
+ [ compiled>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions hashtables kernel
-kernel.private math namespaces sequences sequences.private
-strings vectors words quotations memory combinators generic
-classes classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors assocs ;
+USING: arrays definitions hashtables kernel kernel.private math
+namespaces sequences sequences.private strings vectors words
+quotations memory combinators generic classes classes.algebra
+classes.private slots.deprecated slots.private slots
+compiler.units math.private accessors assocs effects ;
IN: classes.tuple
M: tuple class 1 slot 2 slot { word } declare ;
: check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline
-ERROR: not-a-tuple-class class ;
-
-: check-tuple-class ( class -- class )
- dup tuple-class? [ not-a-tuple-class ] unless ; inline
-
<PRIVATE
+: (tuple) ( layout -- tuple )
+ #! In non-optimized code, this word simply calls the
+ #! <tuple> primitive. In optimized code, an intrinsic
+ #! is generated which allocates a tuple but does not set
+ #! any of its slots. This means that any code that uses
+ #! (tuple) must fill in the slots before the next
+ #! call to GC.
+ #!
+ #! This word is only used in the expansion of <tuple-boa>,
+ #! where this invariant is guaranteed to hold.
+ <tuple> ;
+
: tuple-layout ( class -- layout )
- check-tuple-class "layout" word-prop ;
+ "layout" word-prop ;
+
+: layout-of ( tuple -- layout )
+ 1 slot { tuple-layout } declare ; inline
: tuple-size ( tuple -- size )
- 1 slot layout-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 ;
: tuple>array ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
- layout-class prefix ;
+ class>> prefix ;
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
-: slots>tuple ( tuple class -- array )
+: all-slots ( class -- slots )
+ superclasses [ "slots" word-prop ] map concat ;
+
+: check-slots ( seq class -- seq class )
+ [ ] [
+ 2dup all-slots [
+ class>> 2dup instance?
+ [ 2drop ] [ bad-slot-value ] if
+ ] 2each
+ ] if-bootstrapping ; inline
+
+GENERIC: slots>tuple ( seq class -- tuple )
+
+M: tuple-class slots>tuple
+ check-slots
tuple-layout <tuple> [
- [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
+ [ tuple-size ]
+ [ [ set-array-nth ] curry ]
+ bi 2each
] keep ;
-: >tuple ( tuple -- seq )
+: >tuple ( seq -- tuple )
unclip slots>tuple ;
: slot-names ( class -- seq )
- "slot-names" word-prop
- [ dup array? [ second ] when ] map ;
-
-: all-slot-names ( class -- slots )
- superclasses [ slot-names ] map concat \ class prefix ;
+ "slot-names" word-prop ;
ERROR: bad-superclass class ;
<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 ;
+ ] if ; inline
-! Predicate generation. We optimize at the expense of simplicity
-
-: (tuple-predicate-quot) ( class -- quot )
- #! 4 slot == layout-superclasses
- #! 5 slot == layout-echelon
- [
- [ 1 slot dup 5 slot ] %
- dup tuple-layout layout-echelon ,
- [ fixnum>= ] %
- [
- dup tuple-layout 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 ;
+: tuple-instance? ( object class echelon -- ? )
+ #! 4 slot == superclasses>>
+ rot dup tuple? [
+ layout-of 4 slot
+ 2dup array-capacity fixnum<
+ [ array-nth eq? ] [ 3drop f ] if
+ ] [ 3drop f ] if ; inline
: define-tuple-predicate ( class -- )
- dup tuple-predicate-quot define-predicate ;
+ dup dup tuple-layout echelon>>
+ [ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n )
superclasses but-last-slice
- [ slot-names length ] map sum ;
+ [ slot-names length ] sigma ;
+: (instance-check-quot) ( class -- quot )
+ [
+ \ dup ,
+ [ "predicate" word-prop % ]
+ [ [ bad-slot-value ] curry , ] bi
+ \ unless ,
+ ] [ ] make ;
+
+: (fixnum-check-quot) ( class -- quot )
+ (instance-check-quot) fixnum "coercer" word-prop prepend ;
+
+: instance-check-quot ( class -- quot )
+ {
+ { [ dup object bootstrap-word eq? ] [ drop [ ] ] }
+ { [ dup "coercer" word-prop ] [ "coercer" word-prop ] }
+ { [ dup \ fixnum class<= ] [ (fixnum-check-quot) ] }
+ [ (instance-check-quot) ]
+ } cond ;
+
+: boa-check-quot ( class -- quot )
+ all-slots 1 tail [ class>> instance-check-quot ] map spread>quot ;
+
+: define-boa-check ( class -- )
+ dup boa-check-quot "boa-check" set-word-prop ;
+
+: tuple-prototype ( class -- prototype )
+ [ all-slots [ initial>> ] map ] keep slots>tuple ;
+
+: define-tuple-prototype ( class -- )
+ dup tuple-prototype "prototype" set-word-prop ;
+
: generate-tuple-slots ( class slots -- slot-specs )
- over superclass-size 2 + simple-slots ;
+ over superclass-size 2 + make-slots deprecated-slots ;
: define-tuple-slots ( class -- )
dup dup "slot-names" word-prop generate-tuple-slots
: define-tuple-layout ( class -- )
dup make-tuple-layout "layout" set-word-prop ;
-: compute-slot-permutation ( class old-slot-names -- permutation )
- >r all-slot-names r> [ index ] curry map ;
+: compute-slot-permutation ( new-slots old-slots -- triples )
+ [ [ [ name>> ] map ] bi@ [ index ] curry map ]
+ [ drop [ class>> ] map ]
+ [ drop [ initial>> ] map ]
+ 2tri 3array flip ;
+
+: update-slot ( old-values n class initial -- value )
+ pick [
+ >r >r swap nth dup r> instance?
+ [ r> drop ] [ drop r> ] if
+ ] [ >r 3drop r> ] if ;
-: apply-slot-permutation ( old-values permutation -- new-values )
- [ [ swap ?nth ] [ drop f ] if* ] with map ;
+: apply-slot-permutation ( old-values triples -- new-values )
+ [ first3 update-slot ] with map ;
-: permute-slots ( old-values -- new-values )
- dup first dup outdated-tuples get at
+: permute-slots ( old-values layout -- new-values )
+ [ class>> all-slots ] [ outdated-tuples get at ] bi
compute-slot-permutation
apply-slot-permutation ;
-: change-tuple ( tuple quot -- newtuple )
- >r tuple>array r> call >tuple ; inline
-
: update-tuple ( tuple -- newtuple )
- [ permute-slots ] change-tuple ;
+ [ tuple-slots ] [ layout-of ] bi
+ [ permute-slots ] [ class>> ] bi
+ slots>tuple ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [ >r class r> key? ] curry instances
+ [
+ over tuple?
+ [ >r layout-of r> key? ] [ 2drop f ] if
+ ] curry instances
dup [ update-tuple ] map become
] if ;
[ update-tuples ] update-tuples-hook set-global
: update-tuples-after ( class -- )
- outdated-tuples get [ all-slot-names ] cache drop ;
+ [ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
M: tuple-class update-class
- [ define-tuple-layout ]
- [ define-tuple-slots ]
- [ define-tuple-predicate ]
- tri ;
+ {
+ [ define-tuple-layout ]
+ [ define-tuple-slots ]
+ [ define-tuple-predicate ]
+ [ define-tuple-prototype ]
+ [ define-boa-check ]
+ } cleave ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f f tuple-class define-class ]
define-new-tuple-class ;
M: tuple-class define-tuple-class
+ over check-superclass
3dup tuple-class-unchanged?
- [ over check-superclass 3dup redefine-tuple-class ] unless
- 3drop ;
+ [ 3drop ] [ redefine-tuple-class ] if ;
+
+: thrower-effect ( slots -- effect )
+ [ dup array? [ first ] when ] map f <effect> t >>terminated? ;
: define-error-class ( class superclass slots -- )
- [ define-tuple-class ] [ 2drop ] 3bi
- dup [ boa throw ] curry define ;
+ [ define-tuple-class ]
+ [ [ dup [ boa throw ] curry ] [ drop ] [ thrower-effect ] tri* ] 3bi
+ define-declared ;
M: tuple-class reset-class
[
- dup "slot-names" word-prop [
+ dup "slots" word-prop [
+ name>>
[ reader-word method forget ]
[ writer-word method forget ] 2bi
] with each
] [
[ call-next-method ]
- [ { "layout" "slots" } reset-props ]
- bi
+ [
+ {
+ "layout" "slots" "slot-names" "boa-check" "prototype"
+ } reset-props
+ ] bi
] bi ;
M: tuple-class rank-class drop 0 ;
+M: tuple-class instance?
+ dup tuple-layout echelon>> tuple-instance? ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
] 2curry each
] recursive-hashcode ;
+M: tuple-class new
+ "prototype" word-prop (clone) ;
+
+M: tuple-class boa
+ [ "boa-check" word-prop call ]
+ [ tuple-layout ]
+ bi <tuple-boa> ;
+
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic assocs inference inference.class
+USING: accessors arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
combinators classes classes.algebra generic.math
! 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 word-def (flat-length) ]
+ [ dup dup set def>> (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
{ [ dup word? ] [ word-flat-length ] }
[ drop 1 ]
} cond
- ] map sum ;
+ ] sigma ;
-: flat-length ( seq -- n )
- [ word-def (flat-length) ] with-scope ;
+: 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 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 ;
-: dispatching-class ( node word -- class )
- [ dispatch# node-class# ] keep specific-method ;
+: dispatching-class ( node generic -- method/f )
+ tuck dispatch# over in-d>> <reversed> ?nth
+ node-class swap specific-method ;
-: inline-standard-method ( node word -- node )
- 2dup dispatching-class dup
- [ swap method 1quotation f splice-quot ] [ 3drop t ] 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' )
[ 2drop t ]
} cond ;
-! Resolve type checks at compile time where possible
-: comparable? ( actual testing -- ? )
- #! If actual is a subset of testing or if the two classes
- #! are disjoint, return t.
- 2dup class<= >r classes-intersect? not r> or ;
-
-: optimize-predicate? ( #call -- ? )
- dup node-param "predicating" word-prop dup [
- >r node-class-first r> comparable?
- ] [
- 2drop f
- ] if ;
-
: literal-quot ( node literals -- quot )
#! Outputs a quotation which drops the node's inputs, and
#! pushes some literals.
#! Make #shuffle -> #push -> #return -> successor
dupd literal-quot f splice-quot ;
-: evaluate-predicate ( #call -- ? )
- dup node-param "predicating" word-prop >r
- node-class-first r> class<= ;
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+ #! If actual is a subset of testing or if the two classes
+ #! are disjoint, return t.
+ 2dup class<= >r classes-intersect? not r> or ;
+
+: optimize-check? ( #call value class -- ? )
+ >r node-class r> comparable? ;
-: optimize-predicate ( #call -- node )
+: evaluate-check ( node value class -- ? )
+ >r node-class r> class<= ;
+
+: optimize-check ( #call value class -- node )
#! If the predicate is followed by a branch we fold it
#! immediately
- dup evaluate-predicate swap
- dup node-successor #if? [
+ [ evaluate-check ] [ 2drop ] 3bi
+ dup successor>> #if? [
dup drop-inputs >r
- node-successor swap 0 1 ? fold-branch
- r> [ set-node-successor ] keep
+ successor>> swap 0 1 ? fold-branch
+ r> swap >>successor
] [
swap 1array inline-literals
] if ;
-: optimizer-hooks ( node -- conditions )
- node-param "optimizer-hooks" word-prop ;
+: (optimize-predicate) ( #call -- #call value class )
+ [ ] [ in-d>> first ] [ param>> "predicating" word-prop ] tri ;
-: optimizer-hook ( node -- pair/f )
- dup optimizer-hooks [ first call ] find 2nip ;
-
-: optimize-hook ( node -- )
- dup optimizer-hook second call ;
+: optimize-predicate? ( #call -- ? )
+ dup param>> "predicating" word-prop [
+ (optimize-predicate) optimize-check?
+ ] [ drop f ] if ;
-: define-optimizers ( word optimizers -- )
- "optimizer-hooks" set-word-prop ;
+: optimize-predicate ( #call -- node )
+ (optimize-predicate) optimize-check ;
: flush-eval? ( #call -- ? )
dup node-param "flushable" word-prop [
: splice-word-def ( #call word -- node )
dup +inlined+ depends-on
- dup word-def swap 1array splice-quot ;
+ dup def>> swap 1array splice-quot ;
: optimistic-inline ( #call -- node )
dup node-param over node-history memq? [
-USING: arrays bit-arrays help.markup help.syntax math
-sequences.private vectors strings quotations sbufs kernel math.order ;
+USING: arrays help.markup help.syntax math
- sequences.private vectors strings sbufs kernel math.order
- layouts ;
++sequences.private vectors strings kernel math.order ;
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." } ;
"The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
{ $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
} ;
+
+ HELP: sigma
+ { $values { "seq" sequence } { "quot" quotation } { "n" number } }
+ { $description "Like map sum, but without creating an intermediate sequence." }
+ { $example
+ "! Find the sum of the squares [0,99]"
+ "USING: math math.ranges sequences.lib prettyprint ;"
+ "100 [1,b] [ sq ] sigma ."
+ "338350"
+ } ;
+
+ HELP: count
+ { $values { "seq" sequence } { "quot" quotation } { "n" integer } }
+ { $description "Efficiently returns the number of elements that the predicate quotation matches." }
+ { $example
+ "USING: math math.ranges sequences.lib prettyprint ;"
+ "100 [1,b] [ even? ] count ."
+ "50"
+ } ;
+
USING: arrays kernel math namespaces sequences kernel.private
-sequences.private strings sbufs tools.test vectors bit-arrays
+sequences.private strings sbufs tools.test vectors
generic vocabs.loader ;
IN: sequences.tests
[ f ] [ f V{ } like f V{ } like eq? ] unit-test
-[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
-
[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
[ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+
+ [ 328350 ] [ 100 [ sq ] sigma ] unit-test
+
+ [ 50 ] [ 100 [ even? ] count ] unit-test
+ [ 50 ] [ 100 [ odd? ] count ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private slots.private math math.private
-math.order ;
+USING: accessors kernel kernel.private slots.private math
+math.private math.order ;
IN: sequences
MIXIN: sequence
<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
INSTANCE: virtual-sequence sequence
! A reversal of an underlying sequence.
-TUPLE: reversed seq ;
+TUPLE: reversed { seq read-only } ;
C: <reversed> reversed
-M: reversed virtual-seq reversed-seq ;
+M: reversed virtual-seq seq>> ;
-M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
-M: reversed length reversed-seq length ;
+M: reversed length seq>> length ;
INSTANCE: reversed virtual-sequence
: reverse ( seq -- newseq ) [ <reversed> ] [ like ] bi ;
! A slice of another sequence.
-TUPLE: slice from to seq ;
+TUPLE: slice
+{ from read-only }
+{ to read-only }
+{ seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq )
- dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
+ [ from>> ] [ seq>> ] bi >r tuck + >r + r> r> ; inline
ERROR: slice-error reason ;
check-slice
slice boa ; inline
-M: slice virtual-seq slice-seq ;
+M: slice virtual-seq seq>> ;
-M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ;
+M: slice virtual@ [ from>> + ] [ seq>> ] bi ;
-M: slice length dup slice-to swap slice-from - ;
+M: slice length [ to>> ] [ from>> ] bi - ;
: short ( seq n -- seq n' ) over length min ; inline
INSTANCE: slice virtual-sequence
! One element repeated many times
-TUPLE: repetition len elt ;
+TUPLE: repetition { len read-only } { elt read-only } ;
C: <repetition> repetition
-M: repetition length repetition-len ;
-M: repetition nth-unsafe nip repetition-elt ;
+M: repetition length len>> ;
+M: repetition nth-unsafe nip elt>> ;
INSTANCE: repetition immutable-sequence
dup [ length ] map infimum
swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
+
+ : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
+
+ : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+
! Eduardo Cavazos, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib kernel sequences math namespaces assocs
-random sequences.private shuffle math.functions mirrors
+random sequences.private shuffle math.functions
arrays math.parser math.private sorting strings ascii macros
assocs.lib quotations hashtables math.order locals ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- : sigma ( seq quot -- n )
- [ + ] compose 0 swap reduce ; inline
-
- : count ( seq quot -- n )
- [ 1 0 ? ] compose sigma ; inline
-
- ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: map-reduce ( seq map-quot reduce-quot -- result )
>r [ unclip ] dip [ call ] keep r> compose reduce ; inline
projects / factor.git / commitdiff