[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
] must-fail
+
+[ t ] [ { t f t } >c-bool-array { 1 0 1 } >c-int-array = ] unit-test
swap dup length memcpy ;
: (define-nth) ( word type quot -- )
- >r heap-size [ rot * ] swap prefix r> append define-inline ;
+ [
+ \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
+ ] [ ] make define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
<c-type>
[ alien-unsigned-4 zero? not ] >>getter
- [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
"box_boolean" >>boxer
<c-type>
[ alien-float ] >>getter
- [ >r >r >float r> r> set-alien-float ] >>setter
+ [ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
"box_float" >>boxer
<c-type>
[ alien-double ] >>getter
- [ >r >r >float r> r> set-alien-double ] >>setter
+ [ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
8 >>align
"box_double" >>boxer
{ $subsection set-at }
{ $subsection delete-at }
{ $subsection clear-assoc }
-"The following two words are optional:"
+"The following three words are optional:"
+{ $subsection value-at* }
{ $subsection new-assoc }
{ $subsection assoc-like }
-"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode } " generic words. Two utility words will help with the implementation of the last two:"
+"Assocs should also implement methods on the " { $link clone } ", " { $link equal? } " and " { $link hashcode* } " generic words. Two utility words will help with the implementation of the last two:"
{ $subsection assoc= }
{ $subsection assoc-hashcode }
"Finally, assoc classes should define a word for converting other types of assocs; conventionally, such words are named " { $snippet ">" { $emphasis "class" } } " where " { $snippet { $emphasis "class" } } " is the class name. Such a word can be implemented using a utility:"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection key? }
{ $subsection at }
-{ $subsection value-at }
{ $subsection assoc-empty? }
{ $subsection keys }
{ $subsection values }
{ $subsection assoc-stack }
{ $see-also at* assoc-size } ;
+ARTICLE: "assocs-values" "Transposed assoc operations"
+"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
+{ $subsection value-at }
+{ $subsection value-at* }
+{ $subsection value? }
+"With most assoc implementations, these words runs in linear time, proportional to the number of entries in the assoc. For fast value lookups, use " { $vocab-link "biassocs" } "." ;
+
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection assoc-subset? }
{ $subsection "assocs-protocol" }
"A large set of utility words work on any object whose class implements the associative mapping protocol."
{ $subsection "assocs-lookup" }
+{ $subsection "assocs-values" }
{ $subsection "assocs-mutation" }
{ $subsection "assocs-combinators" }
{ $subsection "assocs-sets" } ;
{ $description "Searches for the key in successive elements of the sequence, starting from the end. If an assoc containing the key is found, the associated value is output. If no assoc contains the key, outputs " { $link f } "." }
{ $notes "This word is used to implement abstractions such as nested scopes; if the sequence is a stack represented by a vector, then the most recently pushed assoc -- the innermost scope -- will be searched first." } ;
+HELP: value-at*
+{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } { "?" "a boolean" } }
+{ $description "Looks up the key associated with a value. The boolean flag can decide beteen the case of a missing key, and a key of " { $link f } "." } ;
+
HELP: value-at
{ $values { "value" "an object" } { "assoc" assoc } { "key/f" "the key associated to the value, or " { $link f } } }
-{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." }
-{ $notes "This word runs in linear time, proportional to the number of entries in the assoc." } ;
+{ $description "Looks up the key associated with a value. No distinction is made between a missing key and a key set to " { $link f } "." } ;
+
+HELP: value?
+{ $values { "value" "an object" } { "assoc" assoc } { "?" "a boolean" } }
+{ $description "Tests if an assoc contains at least one key with the given value." } ;
HELP: delete-at*
{ $values { "key" "a key" } { "assoc" assoc } { "old" "the previous value or " { $link f } } { "?" "a boolean" } }
: extract-keys ( seq assoc -- subassoc )
[ [ dupd at ] curry ] keep map>assoc ;
-! M: assoc >alist [ 2array ] { } assoc>map ;
+GENERIC: value-at* ( value assoc -- key/f ? )
-: value-at ( value assoc -- key/f )
- swap [ = nip ] curry assoc-find 2drop ;
+M: assoc value-at* swap [ = nip ] curry assoc-find nip ;
+
+: value-at ( value assoc -- key/f ) value-at* drop ;
+
+: value? ( value assoc -- ? ) value-at* nip ;
: push-at ( value key assoc -- )
[ ?push ] change-at ;
: 1-offset 8 ; inline
: -1-offset 9 ; inline
+SYMBOL: sub-primitives
+
+: make-jit ( quot rc rt offset -- quad )
+ { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+
: jit-define ( quot rc rt offset name -- )
- >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
+ >r make-jit r> set ; inline
+
+: define-sub-primitive ( quot rc rt offset word -- )
+ >r make-jit r> sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
SYMBOL: jit-word-jump
SYMBOL: jit-word-call
SYMBOL: jit-push-literal
+SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-jump
SYMBOL: jit-dispatch-word
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
-SYMBOL: jit-tag
-SYMBOL: jit-tag-word
-SYMBOL: jit-eq?
-SYMBOL: jit-eq?-word
-SYMBOL: jit-slot
-SYMBOL: jit-slot-word
SYMBOL: jit-declare-word
-SYMBOL: jit-drop
-SYMBOL: jit-drop-word
-SYMBOL: jit-dup
-SYMBOL: jit-dup-word
-SYMBOL: jit->r
-SYMBOL: jit->r-word
-SYMBOL: jit-r>
-SYMBOL: jit-r>-word
-SYMBOL: jit-swap
-SYMBOL: jit-swap-word
-SYMBOL: jit-over
-SYMBOL: jit-over-word
-SYMBOL: jit-fixnum-fast
-SYMBOL: jit-fixnum-fast-word
-SYMBOL: jit-fixnum>=
-SYMBOL: jit-fixnum>=-word
! Default definition for undefined words
SYMBOL: undefined-quot
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
- { jit-tag 36 }
- { jit-tag-word 37 }
- { jit-eq? 38 }
- { jit-eq?-word 39 }
- { jit-slot 40 }
- { jit-slot-word 41 }
+ { jit-push-immediate 36 }
{ jit-declare-word 42 }
- { jit-drop 43 }
- { jit-drop-word 44 }
- { jit-dup 45 }
- { jit-dup-word 46 }
- { jit->r 47 }
- { jit->r-word 48 }
- { jit-r> 49 }
- { jit-r>-word 50 }
- { jit-swap 51 }
- { jit-swap-word 52 }
- { jit-over 53 }
- { jit-over-word 54 }
- { jit-fixnum-fast 55 }
- { jit-fixnum-fast-word 56 }
- { jit-fixnum>= 57 }
- { jit-fixnum>=-word 58 }
{ undefined-quot 60 }
} at header-size + ;
! Words
+: word-sub-primitive ( word -- obj )
+ global [ target-word ] bind sub-primitives get at ;
+
: emit-word ( word -- )
[
[ subwords [ emit-word ] each ]
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
+ [ drop f , ]
+ [ drop 0 , ] ! count
+ [ word-sub-primitive , ]
+ [ drop 0 , ] ! xt
+ [ drop 0 , ] ! code
+ [ drop 0 , ] ! profiling
} cleave
- f ,
- 0 , ! count
- 0 , ! xt
- 0 , ! code
- 0 , ! profiling
] { } make [ ' ] map
] bi
\ word type-number object tag-number
\ if jit-if-word set
\ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
- \ tag jit-tag-word set
- \ eq? jit-eq?-word set
- \ slot jit-slot-word set
\ declare jit-declare-word set
- \ drop jit-drop-word set
- \ dup jit-dup-word set
- \ >r jit->r-word set
- \ r> jit-r>-word set
- \ swap jit-swap-word set
- \ over jit-over-word set
- \ fixnum-fast jit-fixnum-fast-word set
- \ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set
{
jit-code-format
jit-word-jump
jit-word-call
jit-push-literal
+ jit-push-immediate
jit-if-word
jit-if-jump
jit-dispatch-word
jit-epilog
jit-return
jit-profiling
- jit-tag
- jit-tag-word
- jit-eq?
- jit-eq?-word
- jit-slot
- jit-slot-word
jit-declare-word
- jit-drop
- jit-drop-word
- jit-dup
- jit-dup-word
- jit->r
- jit->r-word
- jit-r>
- jit-r>-word
- jit-swap
- jit-swap-word
- jit-over
- jit-over-word
- jit-fixnum-fast
- jit-fixnum-fast-word
- jit-fixnum>=
- jit-fixnum>=-word
undefined-quot
} [ emit-userenv ] each ;
crossref off
+H{ } clone sub-primitives set
+
"resource:core/bootstrap/syntax.factor" parse-file
"resource:core/cpu/" architecture get {
[ [ dup pair? [ first2 create ] when ] map ] map ;
: define-builtin-slots ( class slots -- )
- prepare-slots 1 make-slots
+ prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
: define-builtin ( symbol slotspec -- )
"props"
{ "compiled" read-only }
{ "counter" { "fixnum" "math" } }
+ { "sub-primitive" read-only }
} define-builtin
"byte-array" "byte-arrays" create { } define-builtin
{ "echelon" { "fixnum" "math" } read-only }
} define-builtin
-"tuple" "kernel" create {
- [ { } define-builtin ]
- [ { "delegate" } "slot-names" set-word-prop ]
- [ define-tuple-layout ]
- [
- { "delegate" }
- [ drop ] [ generate-tuple-slots ] 2bi
- [ "slots" set-word-prop ]
- [ define-accessors ]
- 2bi
- ]
-} cleave
+"tuple" "kernel" create
+[ { } define-builtin ]
+[ define-tuple-layout ]
+[
+ { "delegate" } make-slots
+ [ drop ] [ finalize-tuple-slots ] 2bi
+ [ "slots" set-word-prop ]
+ [ define-accessors ]
+ 2bi
+] tri
! Create special tombstone values
"tombstone" "hashtables.private" create
[ tuple-layout [ <tuple-boa> ] curry ] tri
(( quot1 quot2 -- compose )) define-declared
+! Sub-primitive words
+: make-sub-primitive ( word vocab -- )
+ create
+ dup reset-word
+ dup 1quotation define ;
+
+{
+ { "(execute)" "words.private" }
+ { "(call)" "kernel.private" }
+ { "fixnum+fast" "math.private" }
+ { "fixnum-fast" "math.private" }
+ { "fixnum*fast" "math.private" }
+ { "fixnum-bitand" "math.private" }
+ { "fixnum-bitor" "math.private" }
+ { "fixnum-bitxor" "math.private" }
+ { "fixnum-bitnot" "math.private" }
+ { "fixnum<" "math.private" }
+ { "fixnum<=" "math.private" }
+ { "fixnum>" "math.private" }
+ { "fixnum>=" "math.private" }
+ { "drop" "kernel" }
+ { "2drop" "kernel" }
+ { "3drop" "kernel" }
+ { "dup" "kernel" }
+ { "2dup" "kernel" }
+ { "3dup" "kernel" }
+ { "rot" "kernel" }
+ { "-rot" "kernel" }
+ { "dupd" "kernel" }
+ { "swapd" "kernel" }
+ { "nip" "kernel" }
+ { "2nip" "kernel" }
+ { "tuck" "kernel" }
+ { "over" "kernel" }
+ { "pick" "kernel" }
+ { "swap" "kernel" }
+ { ">r" "kernel" }
+ { "r>" "kernel" }
+ { "eq?" "kernel" }
+ { "tag" "kernel.private" }
+ { "slot" "slots.private" }
+} [ make-sub-primitive ] assoc-each
+
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
[ do-primitive ] curry [ ] like define ;
{
- { "(execute)" "words.private" }
- { "(call)" "kernel.private" }
{ "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" }
{ "bits>double" "math" }
{ "<complex>" "math.private" }
{ "fixnum+" "math.private" }
- { "fixnum+fast" "math.private" }
{ "fixnum-" "math.private" }
- { "fixnum-fast" "math.private" }
{ "fixnum*" "math.private" }
- { "fixnum*fast" "math.private" }
{ "fixnum/i" "math.private" }
{ "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" }
- { "fixnum-bitand" "math.private" }
- { "fixnum-bitor" "math.private" }
- { "fixnum-bitxor" "math.private" }
- { "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" }
{ "fixnum-shift-fast" "math.private" }
- { "fixnum<" "math.private" }
- { "fixnum<=" "math.private" }
- { "fixnum>" "math.private" }
- { "fixnum>=" "math.private" }
{ "bignum=" "math.private" }
{ "bignum+" "math.private" }
{ "bignum-" "math.private" }
{ "float>=" "math.private" }
{ "<word>" "words" }
{ "word-xt" "words" }
- { "drop" "kernel" }
- { "2drop" "kernel" }
- { "3drop" "kernel" }
- { "dup" "kernel" }
- { "2dup" "kernel" }
- { "3dup" "kernel" }
- { "rot" "kernel" }
- { "-rot" "kernel" }
- { "dupd" "kernel" }
- { "swapd" "kernel" }
- { "nip" "kernel" }
- { "2nip" "kernel" }
- { "tuck" "kernel" }
- { "over" "kernel" }
- { "pick" "kernel" }
- { "swap" "kernel" }
- { ">r" "kernel" }
- { "r>" "kernel" }
- { "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" }
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
- { "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "dlsym" "alien" }
{ "set-alien-cell" "alien.accessors" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
- { "slot" "slots.private" }
{ "set-slot" "slots.private" }
{ "string-nth" "strings.private" }
{ "set-string-nth" "strings.private" }
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
\r
[ ] [ object flatten-builtin-class drop ] unit-test\r
+\r
+SINGLETON: sa\r
+SINGLETON: sb\r
+SINGLETON: sc\r
+\r
+[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.predicate kernel sequences words ;
+USING: classes classes.algebra classes.predicate kernel
+sequences words ;
IN: classes.singleton
PREDICATE: singleton-class < predicate-class
\ word over [ eq? ] curry define-predicate-class ;
M: singleton-class instance? eq? ;
+
+M: singleton-class (classes-intersect?)
+ over singleton-class? [ eq? ] [ call-next-method ] if ;
IN: classes.tuple.parser.tests
USING: accessors classes.tuple.parser lexer words classes
-sequences math kernel slots tools.test parser compiler.units ;
+sequences math kernel slots tools.test parser compiler.units
+arrays classes.tuple ;
TUPLE: test-1 ;
-[ t ] [ test-1 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-1 "slots" word-prop empty? ] unit-test
TUPLE: test-2 < test-1 ;
-[ t ] [ test-2 "slot-names" word-prop empty? ] unit-test
+[ t ] [ test-2 "slots" word-prop empty? ] unit-test
[ test-1 ] [ test-2 superclass ] unit-test
TUPLE: test-3 a ;
-[ { "a" } ] [ test-3 "slot-names" word-prop ] unit-test
+[ { "a" } ] [ test-3 "slots" word-prop [ name>> ] map ] unit-test
[ object ] [ "a" test-3 "slots" word-prop slot-named class>> ] unit-test
TUPLE: test-4 < test-3 b ;
-[ { "b" } ] [ test-4 "slot-names" word-prop ] unit-test
+[ { "b" } ] [ test-4 "slots" word-prop [ name>> ] map ] unit-test
TUPLE: test-5 { a integer } ;
-[ { { "a" integer } } ] [ test-5 "slot-names" word-prop ] unit-test
+[ { { "a" integer } } ]
+[
+ test-5 "slots" word-prop
+ [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
TUPLE: test-6 < test-5 { b integer } ;
[ integer ] [ "b" test-6 "slots" word-prop slot-named class>> ] unit-test
-[ { { "b" integer } } ] [ test-6 "slot-names" word-prop ] unit-test
+[ { { "b" integer } } ]
+[
+ test-6 "slots" word-prop
+ [ [ name>> ] [ class>> ] bi 2array ] map
+] unit-test
TUPLE: test-7 { b integer initial: 3 } ;
[ t ] [ "b" test-8 "slots" word-prop slot-named read-only>> ] unit-test
+DEFER: foo
+
[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
[ error>> invalid-slot-name? ]
must-fail-with
[ error>> unexpected-eof? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests USE: generic.standard TUPLE: foo { slot no-method } ;" eval ]
-[ error>> no-initial-value? ]
-must-fail-with
+2 [
+ [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
+ [ error>> no-initial-value? ]
+ must-fail-with
+
+ [ f ] [ \ foo tuple-class? ] unit-test
+] times
-[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
-[ error>> bad-initial-value? ]
+2 [
+ [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
+ [ error>> bad-initial-value? ]
+ must-fail-with
+
+ [ f ] [ \ foo tuple-class? ] unit-test
+] times
+
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
+[ error>> duplicate-slot-names? ]
must-fail-with
+[ f ] [ \ foo tuple-class? ] unit-test
+
[ ] [
[
- { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 }
+ { test-1 test-2 test-3 test-4 test-5 test-6 test-7 test-8 foo }
[ dup class? [ forget-class ] [ drop ] if ] each
] with-compilation-unit
] unit-test
+
+
lexer combinators words classes.parser classes.tuple arrays ;
IN: classes.tuple.parser
+: slot-names ( slots -- seq )
+ [ dup array? [ first ] when ] map ;
+
: shadowed-slots ( superclass slots -- shadowed )
- [ all-slots [ name>> ] map ]
- [ [ dup array? [ first ] when ] map ]
- bi* intersect ;
+ [ all-slots [ name>> ] map ] [ slot-names ] bi* intersect ;
: check-slot-shadowing ( class superclass slots -- )
shadowed-slots [
] "" make note.
] with each ;
+ERROR: duplicate-slot-names names ;
+
+M: duplicate-slot-names summary
+ drop "Duplicate slot names" ;
+
+: check-duplicate-slots ( slots -- )
+ slot-names duplicates
+ dup empty? [ drop ] [ duplicate-slot-names ] if ;
+
ERROR: invalid-slot-name name ;
M: invalid-slot-name summary
- drop
- "Invalid slot name" ;
+ drop "Invalid slot name" ;
: parse-long-slot-name ( -- )
[ scan , \ } parse-until % ] { } make ;
#! : ...
{
{ [ dup not ] [ unexpected-eof ] }
- { [ dup { ":" "(" "<" "\"" } member? ] [ invalid-slot-name ] }
+ { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
{ [ dup ";" = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
} cond ;
{ ";" [ tuple f ] }
{ "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
- } case 3dup check-slot-shadowing ;
+ } case
+ dup check-duplicate-slots
+ 3dup check-slot-shadowing ;
"For example, compare the definitions of the " { $link sbuf } " class,"
{ $code
"TUPLE: sbuf"
- "{ \"underlying\" string }"
- "{ \"length\" array-capacity } ;"
+ "{ underlying string }"
+ "{ length array-capacity } ;"
""
"INSTANCE: sbuf growable"
}
"with that of the " { $link vector } " class:"
{ $code
"TUPLE: vector"
- "{ \"underlying\" array }"
- "{ \"length\" array-capacity } ;"
+ "{ underlying array }"
+ "{ length array-capacity } ;"
""
"INSTANCE: vector growable"
} ;
$nl
"Tuple classes have additional word properties:"
{ $list
- { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
{ { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
{ { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
- { { $snippet "\"tuple-size\"" } " - the number of slots" }
+ { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
} } ;
HELP: define-tuple-predicate
! Hardcore unit tests
USE: threads
-\ thread slot-names "slot-names" set
+\ thread "slots" word-prop "slots" set
[ ] [
[
- \ thread tuple { "xxx" } "slot-names" get append
+ \ thread tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
- \ thread tuple "slot-names" get
+ \ thread tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
USE: vocabs
-\ vocab slot-names "slot-names" set
+\ vocab "slots" word-prop "slots" set
[ ] [
[
- \ vocab tuple { "xxx" } "slot-names" get append
+ \ vocab tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
- \ vocab tuple "slot-names" get
+ \ vocab tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
<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 )
"layout" word-prop ;
: >tuple ( seq -- tuple )
unclip slots>tuple ;
-: slot-names ( class -- seq )
- "slot-names" word-prop ;
-
ERROR: bad-superclass class ;
<PRIVATE
: superclass-size ( class -- n )
superclasses but-last-slice
- [ slot-names length ] sigma ;
+ [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot )
[
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
-: generate-tuple-slots ( class slots -- slot-specs )
- over superclass-size 2 + make-slots deprecated-slots ;
+: finalize-tuple-slots ( class slots -- slots )
+ over superclass-size 2 + finalize-slots deprecated-slots ;
: define-tuple-slots ( class -- )
- dup dup "slot-names" word-prop generate-tuple-slots
- [ "slots" set-word-prop ]
+ dup dup "slots" word-prop finalize-tuple-slots
[ define-accessors ] ! new
[ define-slots ] ! old
- 2tri ;
+ 2bi ;
: make-tuple-layout ( class -- layout )
[ ]
- [ [ superclass-size ] [ slot-names length ] bi + ]
+ [ [ superclass-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri
<tuple-layout> ;
} cleave ;
: define-new-tuple-class ( class superclass slots -- )
+ make-slots
[ drop f f tuple-class define-class ]
- [ nip "slot-names" set-word-prop ]
+ [ nip "slots" set-word-prop ]
[ 2drop update-classes ]
3tri ;
3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? )
- rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+ rot tuck [ superclass = ] [ "slots" word-prop = ] 2bi* and ;
: valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ;
[ call-next-method ]
[
{
- "layout" "slots" "slot-names" "boa-check" "prototype"
+ "layout" "slots" "boa-check" "prototype"
} reset-props
] bi
] bi ;
[ tuple-layout ]
bi <tuple-boa> ;
+M: tuple-class initial-value* new ;
+
! Deprecated
M: object get-slots ( obj slots -- ... )
[ execute ] with each ;
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ;
PREDICATE: small-tagged < integer v>operand small-enough? ;
-PREDICATE: inline-array < integer 32 < ;
-
: if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and
[ nip r> call r> drop ] [ r> drop r> call ] if ;
! Copyright (C) 2007, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: bootstrap.image.private kernel namespaces system\r
-cpu.ppc.assembler generator.fixup compiler.units\r
-compiler.constants math layouts words vocabs ;\r
+USING: bootstrap.image.private kernel kernel.private namespaces\r
+system cpu.ppc.assembler generator.fixup compiler.units\r
+compiler.constants math math.private layouts words words.private\r
+vocabs slots.private ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
4 jit-code-format set\r
\r
: ds-reg 14 ;\r
-: quot-reg 3 ;\r
-: temp-reg 6 ;\r
-: aux-reg 11 ;\r
+: rs-reg 15 ;\r
\r
: factor-area-size 4 bootstrap-cells ;\r
\r
: xt-save stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- ! Load word\r
- 0 temp-reg LOAD32\r
- temp-reg dup 0 LWZ\r
- ! Bump profiling counter\r
- aux-reg temp-reg profile-count-offset LWZ\r
- aux-reg dup 1 tag-fixnum ADDI\r
- aux-reg temp-reg profile-count-offset STW\r
- ! Load word->code\r
- aux-reg temp-reg word-code-offset LWZ\r
- ! Compute word XT\r
- aux-reg dup compiled-header-size ADDI\r
- ! Jump to XT\r
- aux-reg MTCTR\r
+ 0 6 LOAD32\r
+ 6 dup 0 LWZ\r
+ 11 6 profile-count-offset LWZ\r
+ 11 11 1 tag-fixnum ADDI\r
+ 11 6 profile-count-offset STW\r
+ 11 6 word-code-offset LWZ\r
+ 11 11 compiled-header-size ADDI\r
+ 11 MTCTR\r
BCTR\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-profiling jit-define\r
\r
[\r
- 0 temp-reg LOAD32 ! load XT\r
- 0 MFLR ! load return address\r
- 1 1 stack-frame neg ADDI ! create stack frame\r
- temp-reg 1 xt-save STW ! save XT\r
- stack-frame temp-reg LI ! load frame size\r
- temp-reg 1 next-save STW ! save frame size\r
- 0 1 lr-save stack-frame + STW ! save return address\r
+ 0 6 LOAD32\r
+ 0 MFLR\r
+ 1 1 stack-frame SUBI\r
+ 6 1 xt-save STW\r
+ stack-frame 6 LI\r
+ 6 1 next-save STW\r
+ 0 1 lr-save stack-frame + STW\r
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define\r
\r
[\r
- 0 temp-reg LOAD32 ! load literal\r
- temp-reg dup 0 LWZ ! indirection\r
- temp-reg ds-reg 4 STWU ! push literal\r
+ 0 6 LOAD32\r
+ 6 dup 0 LWZ\r
+ 6 ds-reg 4 STWU\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-push-literal jit-define\r
\r
[\r
- 0 temp-reg LOAD32 ! load primitive address\r
- 4 1 MR ! pass stack pointer to primitive\r
- temp-reg MTCTR ! jump to primitive\r
+ 0 6 LOAD32\r
+ 6 ds-reg 4 STWU\r
+] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
+\r
+[\r
+ 0 6 LOAD32\r
+ 4 1 MR\r
+ 6 MTCTR\r
BCTR\r
] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
\r
-[\r
- 0 BL\r
-] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
+[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
\r
-[\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
+[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
\r
: jit-call-quot ( -- )\r
- temp-reg quot-reg quot-xt-offset LWZ ! load quotation-xt\r
- temp-reg MTCTR ! jump to quotation-xt\r
+ 4 3 quot-xt-offset LWZ\r
+ 4 MTCTR\r
BCTR ;\r
\r
[\r
- 0 quot-reg LOAD32 ! point quot-reg at false branch\r
- temp-reg ds-reg 0 LWZ ! load boolean\r
- 0 temp-reg \ f tag-number CMPI ! compare it with f\r
- 2 BNE ! skip next insn if its not f\r
- quot-reg dup 4 ADDI ! point quot-reg at true branch\r
- quot-reg dup 0 LWZ ! load the branch\r
- ds-reg dup 4 SUBI ! pop boolean\r
+ 0 3 LOAD32\r
+ 6 ds-reg 0 LWZ\r
+ 0 6 \ f tag-number CMPI\r
+ 2 BNE\r
+ 3 3 4 ADDI\r
+ 3 3 0 LWZ\r
+ ds-reg dup 4 SUBI\r
jit-call-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-if-jump jit-define\r
\r
[\r
- 0 quot-reg LOAD32 ! load dispatch array\r
- quot-reg dup 0 LWZ ! indirection\r
- temp-reg ds-reg 0 LWZ ! load index\r
- temp-reg dup 1 SRAWI ! turn it into an array offset\r
- quot-reg dup temp-reg ADD ! compute quotation location\r
- quot-reg dup array-start-offset LWZ ! load quotation\r
- ds-reg dup 4 SUBI ! pop index\r
+ 0 3 LOAD32\r
+ 3 3 0 LWZ\r
+ 6 ds-reg 0 LWZ\r
+ 6 6 1 SRAWI\r
+ 3 3 6 ADD\r
+ 3 3 array-start-offset LWZ\r
+ ds-reg dup 4 SUBI\r
jit-call-quot\r
] rc-absolute-ppc-2/2 rt-literal 1 jit-dispatch jit-define\r
\r
[\r
- 0 1 lr-save stack-frame + LWZ ! load return address\r
- 1 1 stack-frame ADDI ! pop stack frame\r
- 0 MTLR ! get ready to return\r
+ 0 1 lr-save stack-frame + LWZ\r
+ 1 1 stack-frame ADDI\r
+ 0 MTLR\r
] f f f jit-epilog jit-define\r
\r
[ BLR ] f f f jit-return jit-define\r
\r
+! Sub-primitives\r
+\r
+! Quotations and words\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ jit-call-quot\r
+] f f f \ (call) define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 3 word-xt-offset LWZ\r
+ 4 MTCTR\r
+ BCTR\r
+] f f f \ (execute) define-sub-primitive\r
+\r
+! Objects\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 tag-mask get ANDI\r
+ 3 3 tag-bits get SLWI\r
+ 3 ds-reg 0 STW\r
+] f f f \ tag define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ 3 3 1 SRAWI\r
+ 4 4 0 0 31 tag-bits get - RLWINM\r
+ 4 3 3 LWZX\r
+ 3 ds-reg 0 STW\r
+] f f f \ slot define-sub-primitive\r
+\r
+! Shufflers\r
+[\r
+ ds-reg dup 4 SUBI\r
+] f f f \ drop define-sub-primitive\r
+\r
+[\r
+ ds-reg dup 8 SUBI\r
+] f f f \ 2drop define-sub-primitive\r
+\r
+[\r
+ ds-reg dup 12 SUBI\r
+] f f f \ 3drop define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 ds-reg 4 STWU\r
+] f f f \ dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg dup 8 ADDI\r
+ 3 ds-reg 0 STW\r
+ 4 ds-reg -4 STW\r
+] f f f \ 2dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ ds-reg dup 12 ADDI\r
+ 3 ds-reg 0 STW\r
+ 4 ds-reg -4 STW\r
+ 5 ds-reg -8 STW\r
+] f f f \ 3dup define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 3 ds-reg 0 STW\r
+] f f f \ nip define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 8 SUBI\r
+ 3 ds-reg 0 STW\r
+] f f f \ 2nip define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -4 LWZ\r
+ 3 ds-reg 4 STWU\r
+] f f f \ over define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -8 LWZ\r
+ 3 ds-reg 4 STWU\r
+] f f f \ pick define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 4 ds-reg 0 STW\r
+ 3 ds-reg 4 STWU\r
+] f f f \ dupd define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 3 ds-reg 4 STWU\r
+ 4 ds-reg -4 STW\r
+ 3 ds-reg -8 STW\r
+] f f f \ tuck define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 3 ds-reg -4 STW\r
+ 4 ds-reg 0 STW\r
+] f f f \ swap define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg -4 LWZ\r
+ 4 ds-reg -8 LWZ\r
+ 3 ds-reg -8 STW\r
+ 4 ds-reg -4 STW\r
+] f f f \ swapd define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ 4 ds-reg -8 STW\r
+ 3 ds-reg -4 STW\r
+ 5 ds-reg 0 STW\r
+] f f f \ rot define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZ\r
+ 5 ds-reg -8 LWZ\r
+ 3 ds-reg -8 STW\r
+ 5 ds-reg -4 STW\r
+ 4 ds-reg 0 STW\r
+] f f f \ -rot define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 3 rs-reg 4 STWU\r
+] f f f \ >r define-sub-primitive\r
+\r
+[\r
+ 3 rs-reg 0 LWZ\r
+ rs-reg dup 4 SUBI\r
+ 3 ds-reg 4 STWU\r
+] f f f \ r> define-sub-primitive\r
+\r
+! Comparisons\r
+: jit-compare ( insn -- )\r
+ 0 3 LOAD32\r
+ 3 3 0 LWZ\r
+ 4 ds-reg 0 LWZ\r
+ 5 ds-reg -4 LWZU\r
+ 5 0 4 CMP\r
+ 2 swap execute ! magic number\r
+ \ f tag-number 3 LI\r
+ 3 ds-reg 0 STW ;\r
+\r
+: define-jit-compare ( insn word -- )\r
+ [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-literal 1 ] dip\r
+ define-sub-primitive ;\r
+\r
+\ BEQ \ eq? define-jit-compare\r
+\ BGE \ fixnum>= define-jit-compare\r
+\ BLE \ fixnum<= define-jit-compare\r
+\ BGT \ fixnum> define-jit-compare\r
+\ BLT \ fixnum< define-jit-compare\r
+\r
+! Math\r
+: jit-math ( insn -- )\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ [ 5 3 4 ] dip execute\r
+ 5 ds-reg 0 STW ;\r
+\r
+[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
+\r
+[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 4 ds-reg -4 LWZU\r
+ 4 4 tag-bits get SRAWI\r
+ 5 3 4 MULLW\r
+ 5 ds-reg 0 STW\r
+] f f f \ fixnum*fast define-sub-primitive\r
+\r
+[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive\r
+\r
+[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive\r
+\r
+[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive\r
+\r
+[\r
+ 3 ds-reg 0 LWZ\r
+ 3 3 NOT\r
+ 3 3 tag-mask get XORI\r
+ 3 ds-reg 0 STW\r
+] f f f \ fixnum-bitnot define-sub-primitive\r
+\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler
-cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
-kernel.private math math.private namespaces sequences words
-generic quotations byte-arrays hashtables hashtables.private
-generator generator.registers generator.fixup sequences.private
-sbufs vectors system layouts math.floats.private
-classes classes.tuple classes.tuple.private sbufs.private
-vectors.private strings.private slots.private combinators
-compiler.constants ;
+USING: accessors alien alien.accessors alien.c-types arrays
+cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
+cpu.architecture kernel kernel.private math math.private
+namespaces sequences words generic quotations byte-arrays
+hashtables hashtables.private generator generator.registers
+generator.fixup sequences.private sbufs vectors system layouts
+math.floats.private classes slots.private combinators
+compiler.constants optimizer.allot ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
- { +input+ { { [ tuple-layout? ] "layout" } } }
+ { +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic
-\ <array> [
+\ (array) [
array "n" get 2 + cells %allot
! Store length
"n" operand 12 LI
12 11 cell STW
- ! Store initial element
- "n" get [ "initial" operand 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
-\ <byte-array> [
+\ (byte-array) [
byte-array "n" get 2 cells + %allot
! Store length
"n" operand 12 LI
12 11 cell STW
- ! Store initial element
- 0 12 LI
- "n" get cell align cell /i [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] H{
- { +input+ { { [ inline-array? ] "n" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler layouts compiler.units math generator.fixup
-compiler.constants vocabs ;
+USING: bootstrap.image.private kernel kernel.private namespaces
+system cpu.x86.assembler layouts compiler.units math math.private
+generator.fixup compiler.constants vocabs slots.private words
+words.private ;
IN: bootstrap.x86
big-endian off
ds-reg [] arg0 MOV ! store literal on datastack
] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
+[
+ arg0 0 MOV ! load literal
+ ds-reg bootstrap-cell ADD ! increment datastack pointer
+ ds-reg [] arg0 MOV ! store literal on datastack
+] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+
[
arg0 0 MOV ! load XT
arg1 stack-reg MOV ! pass callstack pointer as arg 2
arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
+[
+ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
+] f f f jit-epilog jit-define
+
+[ 0 RET ] f f f jit-return jit-define
+
+! Sub-primitives
+
+! Quotations and words
+[
+ arg0 ds-reg [] MOV ! load from stack
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg0 quot-xt-offset [+] JMP ! call quotation
+] f f f \ (call) define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load from stack
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg0 word-xt-offset [+] JMP ! execute word
+] f f f \ (execute) define-sub-primitive
+
+! Objects
[
arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack
-] f f f jit-tag jit-define
-
-: jit-compare ( -- )
- arg1 0 MOV ! load t
- arg1 dup [] MOV
- temp-reg \ f tag-number MOV ! load f
- arg0 ds-reg [] MOV ! load first value
- ds-reg bootstrap-cell SUB ! adjust stack pointer
- ds-reg [] arg0 CMP ! compare with second value
- ;
-
-[
- jit-compare
- arg1 temp-reg CMOVNE ! not equal?
- ds-reg [] arg1 MOV ! store
-] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
+] f f f \ tag define-sub-primitive
[
arg0 ds-reg [] MOV ! load slot number
arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack
-] f f f jit-slot jit-define
+] f f f \ slot define-sub-primitive
+! Shufflers
[
ds-reg bootstrap-cell SUB
-] f f f jit-drop jit-define
+] f f f \ drop define-sub-primitive
+
+[
+ ds-reg 2 bootstrap-cells SUB
+] f f f \ 2drop define-sub-primitive
+
+[
+ ds-reg 3 bootstrap-cells SUB
+] f f f \ 3drop define-sub-primitive
[
arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
-] f f f jit-dup jit-define
+] f f f \ dup define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg bootstrap-cell neg [+] MOV
+ ds-reg 2 bootstrap-cells ADD
+ ds-reg [] arg0 MOV
+ ds-reg bootstrap-cell neg [+] arg1 MOV
+] f f f \ 2dup define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg 3 bootstrap-cells ADD
+ ds-reg [] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] temp-reg MOV
+] f f f \ 3dup define-sub-primitive
[
- rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
- rs-reg [] arg0 MOV
-] f f f jit->r jit-define
+ ds-reg [] arg0 MOV
+] f f f \ nip define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ ds-reg 2 bootstrap-cells SUB
+ ds-reg [] arg0 MOV
+] f f f \ 2nip define-sub-primitive
[
+ arg0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
- arg0 rs-reg [] MOV
- rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
-] f f f jit-r> jit-define
+] f f f \ over define-sub-primitive
+
+[
+ arg0 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+] f f f \ pick define-sub-primitive
[
arg0 ds-reg [] MOV
- arg1 ds-reg bootstrap-cell neg [+] MOV
- ds-reg bootstrap-cell neg [+] arg0 MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg [] arg1 MOV
-] f f f jit-swap jit-define
+ ds-reg bootstrap-cell ADD
+ ds-reg [] arg0 MOV
+] f f f \ dupd define-sub-primitive
[
- arg0 ds-reg bootstrap-cell neg [+] MOV
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
-] f f f jit-over jit-define
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+] f f f \ tuck define-sub-primitive
[
arg0 ds-reg [] MOV
- ds-reg bootstrap-cell SUB
- arg1 ds-reg [] MOV
- arg1 arg0 SUB
+ arg1 ds-reg bootstrap-cell neg [+] MOV
+ ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV
-] f f f jit-fixnum-fast jit-define
+] f f f \ swap define-sub-primitive
+
+[
+ arg0 ds-reg -1 bootstrap-cells [+] MOV
+ arg1 ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] arg1 MOV
+] f f f \ swapd define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg1 MOV
+ ds-reg -1 bootstrap-cells [+] arg0 MOV
+ ds-reg [] temp-reg MOV
+] f f f \ rot define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV
+ arg1 ds-reg -1 bootstrap-cells [+] MOV
+ temp-reg ds-reg -2 bootstrap-cells [+] MOV
+ ds-reg -2 bootstrap-cells [+] arg0 MOV
+ ds-reg -1 bootstrap-cells [+] temp-reg MOV
+ ds-reg [] arg1 MOV
+] f f f \ -rot define-sub-primitive
+
+[
+ rs-reg bootstrap-cell ADD
+ arg0 ds-reg [] MOV
+ ds-reg bootstrap-cell SUB
+ rs-reg [] arg0 MOV
+] f f f \ >r define-sub-primitive
[
- jit-compare
- arg1 temp-reg CMOVL ! not equal?
+ ds-reg bootstrap-cell ADD
+ arg0 rs-reg [] MOV
+ rs-reg bootstrap-cell SUB
+ ds-reg [] arg0 MOV
+] f f f \ r> define-sub-primitive
+
+! Comparisons
+: jit-compare ( insn -- )
+ arg1 0 MOV ! load t
+ arg1 dup [] MOV
+ temp-reg \ f tag-number MOV ! load f
+ arg0 ds-reg [] MOV ! load first value
+ ds-reg bootstrap-cell SUB ! adjust stack pointer
+ ds-reg [] arg0 CMP ! compare with second value
+ [ arg1 temp-reg ] dip execute ! move t if true
ds-reg [] arg1 MOV ! store
-] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
+ ;
+
+: define-jit-compare ( insn word -- )
+ [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
+ define-sub-primitive ;
+
+\ CMOVNE \ eq? define-jit-compare
+\ CMOVL \ fixnum>= define-jit-compare
+\ CMOVG \ fixnum<= define-jit-compare
+\ CMOVLE \ fixnum> define-jit-compare
+\ CMOVGE \ fixnum< define-jit-compare
+
+! Math
+: jit-math ( insn -- )
+ arg0 ds-reg [] MOV ! load second input
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg1 ds-reg [] MOV ! load first input
+ [ arg1 arg0 ] dip execute ! compute result
+ ds-reg [] arg1 MOV ! push result
+ ;
+
+[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+
+[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
[
- stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
-] f f f jit-epilog jit-define
+ arg0 ds-reg [] MOV ! load second input
+ ds-reg bootstrap-cell SUB ! pop stack
+ arg1 ds-reg [] MOV ! load first input
+ arg0 tag-bits get SAR ! untag second input
+ arg0 arg1 IMUL2 ! multiply
+ ds-reg [] arg1 MOV ! push result
+] f f f \ fixnum*fast define-sub-primitive
-[ 0 RET ] f f f jit-return jit-define
+[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+
+[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+
+[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+
+[
+ arg0 ds-reg [] MOV ! load input input
+ arg0 NOT ! complement
+ arg0 tag-mask get XOR ! clear tag bits
+ ds-reg [] arg0 MOV ! save
+] f f f \ fixnum-bitnot define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system
-classes.tuple.private strings.private slots.private
-compiler.constants ;
+strings.private slots.private compiler.constants optimizer.allot ;
IN: cpu.x86.intrinsics
! Type checks
"tuple" get tuple %store-tagged
] %allot
] H{
- { +input+ { { [ tuple-layout? ] "layout" } } }
+ { +input+ { { [ ] "layout" } } }
{ +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } }
} define-intrinsic
-\ <array> [
+\ (array) [
array "n" get 2 + cells [
! Store length
1 object@ "n" operand MOV
- ! Zero out the rest of the tuple
- "n" get [ 2 + object@ "initial" operand MOV ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] H{
- { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
-\ <byte-array> [
+\ (byte-array) [
byte-array "n" get 2 cells + [
! Store length
1 object@ "n" operand MOV
- ! Store initial element
- "n" get cell align cell /i [ 2 + object@ 0 MOV ] each
! Store tagged ptr in reg
"array" get object %store-tagged
] %allot
] H{
- { +input+ { { [ inline-array? ] "n" } } }
+ { +input+ { { [ ] "n" } } }
{ +scratch+ { { f "array" } } }
{ +output+ { "array" } }
} define-intrinsic
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
+M: no-initial-value summary
+ drop "Initial value must be provided for slots specialized to this class" ;
+
+M: bad-initial-value summary
+ drop "Incompatible initial value" ;
+
M: no-cond summary
drop "Fall-through in cond" ;
: rt-xt 4 ;
: rt-here 5 ;
: rt-label 6 ;
+: rt-immediate 7 ;
TUPLE: label-fixup label class ;
IN: grouping
ARTICLE: "grouping" "Groups and clumps"
+"Splitting a sequence into disjoint, fixed-length subsequences:"
+{ $subsection group }
"A virtual sequence for splitting a sequence into disjoint, fixed-length subsequences:"
{ $subsection groups }
{ $subsection <groups> }
{ $subsection <sliced-groups> }
+"Splitting a sequence into overlapping, fixed-length subsequences:"
+{ $subsection clump }
"A virtual sequence for splitting a sequence into overlapping, fixed-length subsequences:"
{ $subsection clumps }
{ $subsection <clumps> }
2dup (>>length)
] when 2drop ;
+M: growable shorten ( n seq -- )
+ growable-check
+ 2dup length < [
+ 2dup contract
+ 2dup (>>length)
+ ] when 2drop ;
+
INSTANCE: growable sequence
{ $description "Called to increment the deleted entry counter when an entry is removed with " { $link delete-at } }
{ $side-effects "hash" } ;
-HELP: (set-hash)
-{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
-{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
-{ $side-effects "hash" } ;
-
HELP: grow-hash
{ $values { "hash" hashtable } }
{ $description "Enlarges the capacity of a hashtable. User code does not need to call this word directly." }
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
+
+! We want this to work
+[ ] [ hashtable new "h" set ] unit-test
+
+[ 0 ] [ "h" get assoc-size ] unit-test
+
+[ f f ] [ "goo" "h" get at* ] unit-test
+
+[ ] [ 1 2 "h" get set-at ] unit-test
+
+[ 1 ] [ "h" get assoc-size ] unit-test
+
+[ 1 ] [ 2 "h" get at ] unit-test
: probe ( array i -- array i )
2 fixnum+fast over wrap ; inline
-: (key@) ( key keys i -- array n ? )
+: no-key ( key array -- array n ? ) nip f f ; inline
+
+: (key@) ( key array i -- array n ? )
3dup swap array-nth
dup ((empty)) eq?
- [ 3drop nip f f ] [
+ [ 3drop no-key ] [
= [ rot drop t ] [ probe (key@) ] if
] if ; inline
: key@ ( key hash -- array n ? )
- array>> 2dup hash@ (key@) ; inline
+ array>> dup array-capacity 0 eq?
+ [ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
1+ next-power-of-2 4 * ((empty)) <array> ; inline
: hash-deleted+ ( hash -- )
[ 1+ ] change-deleted drop ; inline
-: (set-hash) ( value key hash -- new? )
- 2dup new-key@
- [ rot hash-count+ set-nth-pair t ]
- [ rot drop set-nth-pair f ] if ; inline
-
: (rehash) ( hash alist -- )
- swap [ swapd (set-hash) drop ] curry assoc-each ;
+ swap [ swapd set-at ] curry assoc-each ; inline
: hash-large? ( hash -- ? )
- [ count>> 3 fixnum*fast ]
- [ array>> array-capacity ] bi > ;
+ [ count>> 3 fixnum*fast 1 fixnum+fast ]
+ [ array>> array-capacity ] bi fixnum> ; inline
: hash-stale? ( hash -- ? )
- [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ;
+ [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- )
[ dup >alist swap assoc-size 1+ ] keep
[ reset-hash ] keep
- swap (rehash) ;
+ swap (rehash) ; inline
: ?grow-hash ( hash -- )
dup hash-large? [
r> (rehash) ;
M: hashtable set-at ( value key hash -- )
- dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
+ dup ?grow-hash
+ 2dup new-key@
+ [ rot hash-count+ set-nth-pair ]
+ [ rot drop set-nth-pair ] if ;
: associate ( value key -- hash )
2 <hashtable> [ set-at ] keep ;
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
system layouts vectors optimizer.math.partial
-optimizer.inlining optimizer.backend math.order
-accessors hashtables classes assocs ;
+optimizer.inlining optimizer.backend math.order math.functions
+accessors hashtables classes assocs io.encodings.utf8
+io.encodings.ascii io.encodings ;
[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
[ t ] [
- [ { string sbuf } declare push-all ] \ push-all inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
] unit-test
[ t ] [
- [ { string sbuf } declare push-all ] \ + inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
] unit-test
[ t ] [
- [ { string sbuf } declare push-all ] \ fixnum+ inlined?
-] unit-test
-
-[ t ] [
- [ { string sbuf } declare push-all ] \ >fixnum inlined?
+ [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
] unit-test
[ t ] [
{ slot } inlined?
] unit-test
+[ t ] [
+ [
+ { array } declare length
+ 1 + dup 100 fixnum> [ 1 fixnum+ ] when
+ ] \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+ [ [ resize-array ] keep length ] \ length inlined?
+] unit-test
+
+[ t ] [
+ [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
+] unit-test
+
+[ t ] [
+ [ { utf8 } declare decode-char ] \ decode-char inlined?
+] unit-test
+
+[ t ] [
+ [ { ascii } declare decode-char ] \ decode-char inlined?
+] unit-test
+
! Later
! [ t ] [
GENERIC: infer-classes-around ( node -- )
+GENERIC: infer-classes-after ( node -- )
+
M: node infer-classes-before drop ;
+M: node infer-classes-after drop ;
+
M: node child-constraints
children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
[ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
-M: #call infer-classes-before
- [ compute-constraints ] keep
- [ output-classes ] [ out-d>> ] bi
+: intersect-values ( classes intervals values -- )
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+M: #call infer-classes-before
+ [ compute-constraints ]
+ [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+
+: input-classes ( #call -- classes )
+ param>> "input-classes" word-prop ;
+
+M: #call infer-classes-after
+ [ input-classes ] [ in-d>> ] bi intersect-classes ;
+
M: #push infer-classes-before
out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
{
[ infer-classes-before ]
[ annotate-node ]
+ [ infer-classes-after ]
[ infer-children ]
[ merge-children ]
} cleave ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel generic sequences prettyprint io words arrays
+summary effects debugger assocs accessors inference.backend
+inference.dataflow ;
IN: inference.errors
-USING: inference.backend inference.dataflow kernel generic
-sequences prettyprint io words arrays summary effects debugger
-assocs accessors ;
M: inference-error error-help error>> error-help ;
] if
] "infer" set-word-prop
+\ execute t "no-compile" set-word-prop
+
\ if [
3 ensure-values
2 d-tail [ special? ] contains? [
[ #dispatch ] infer-branches
] "infer" set-word-prop
+\ dispatch t "no-compile" set-word-prop
+
\ curry [
2 ensure-values
pop-d pop-d swap <curried> push-d
] "infer" set-word-prop
: set-primitive-effect ( word effect -- )
- 2dup effect-out "default-output-classes" set-word-prop
- dupd [ make-call-node ] 2curry "infer" set-word-prop ;
+ [ in>> "input-classes" set-word-prop ]
+ [ out>> "default-output-classes" set-word-prop ]
+ [ dupd [ make-call-node ] 2curry "infer" set-word-prop ]
+ 2tri ;
! Stack effects for all primitives
\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
-\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
-\ (tuple) make-flushable
-
\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
\ <tuple-layout> make-foldable
: write-value ( mirror key -- )
<value-ref> write-slot-editor ;
-: describe-row ( obj key n -- )
+: describe-row ( mirror key n -- )
[
+number-rows+ get [ pprint-cell ] [ drop ] if
- 2dup write-key write-value
+ [ write-key ] [ write-value ] 2bi
] with-row ;
: summary. ( obj -- ) [ summary ] keep write-object nl ;
sort-keys values
] [ keys ] if ;
-: describe* ( obj flags -- )
- clone [
- dup summary.
- make-mirror dup sorted-keys dup empty? [
- 2drop
- ] [
- dup enum? [ +sequence+ on ] when
- standard-table-style [
- dup length
- rot [ -rot describe-row ] curry 2each
- ] tabular-output
- ] if
- ] bind ;
+: describe* ( obj mirror keys -- )
+ rot summary.
+ dup empty? [
+ 2drop
+ ] [
+ dup enum? [ +sequence+ on ] when
+ standard-table-style [
+ swap [ -rot describe-row ] curry each-index
+ ] tabular-output
+ ] if ;
-: describe ( obj -- ) H{ } describe* ;
+: describe ( obj -- )
+ dup make-mirror dup sorted-keys describe* ;
M: tuple error. describe ;
SYMBOL: inspector-hook
-[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
+[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
SYMBOL: inspector-stack
SYMBOL: me
: reinspect ( obj -- )
- dup me set
- dup make-mirror dup mirror set keys \ keys set
- inspector-hook get call ;
+ [ me set ]
+ [
+ dup make-mirror dup mirror set dup sorted-keys dup \ keys set
+ inspector-hook get call
+ ] bi ;
: (inspect) ( obj -- )
- dup inspector-stack get push reinspect ;
+ [ inspector-stack get push ] [ reinspect ] bi ;
: key@ ( n -- key ) \ keys get nth ;
"&add ( value key -- ) add new slot" print
"&delete ( n -- ) remove a slot" print
"&rename ( key n -- ) change a slot's key" print
+ "&globals ( -- ) inspect global namespace" print
"&help -- display this message" print
nl ;
: inspect ( obj -- )
inspector-stack get [ (inspect) ] [ inspector ] if ;
+
+: &globals ( -- ) global inspect ;
[ >r drop "" like r> ]
[ pick push ((read-until)) ] if ; inline
-: (read-until) ( seps stream -- string/f sep/f )
- SBUF" " clone -rot >decoder<
+: (read-until) ( quot -- string/f sep/f )
+ 100 <sbuf> swap ((read-until)) ; inline
+
+: decoder-read-until ( seps stream encoding -- string/f sep/f )
[ decode-char dup [ dup rot member? ] [ 2drop f t ] if ] 3curry
- ((read-until)) ; inline
+ (read-until) ;
+
+M: decoder stream-read-until >decoder< decoder-read-until ;
-M: decoder stream-read-until (read-until) ;
+: decoder-readln ( stream encoding -- string/f sep/f )
+ [ decode-char dup [ dup "\r\n" member? ] [ drop f t ] if ] 2curry
+ (read-until) ;
-M: decoder stream-readln "\r\n" over (read-until) handle-readln ;
+M: decoder stream-readln dup >decoder< decoder-readln handle-readln ;
M: decoder dispose stream>> dispose ;
M: encoder stream-write1
>encoder< encode-char ;
+: decoder-write ( string stream encoding -- )
+ [ encode-char ] 2curry each ;
+
M: encoder stream-write
- >encoder< [ encode-char ] 2curry each ;
+ >encoder< decoder-write ;
M: encoder dispose encoder-stream dispose ;
<PRIVATE
: starts-2? ( char -- ? )
- dup [ -6 shift BIN: 10 number= ] when ;
+ dup [ -6 shift BIN: 10 number= ] when ; inline
: append-nums ( stream byte -- stream char )
over stream-read1 dup starts-2?
[ swap 6 shift swap BIN: 111111 bitand bitor ]
- [ 2drop replacement-char ] if ;
+ [ 2drop replacement-char ] if ; inline
: double ( stream byte -- stream char )
- BIN: 11111 bitand append-nums ;
+ BIN: 11111 bitand append-nums ; inline
: triple ( stream byte -- stream char )
- BIN: 1111 bitand append-nums append-nums ;
+ BIN: 1111 bitand append-nums append-nums ; inline
: quad ( stream byte -- stream char )
- BIN: 111 bitand append-nums append-nums append-nums ;
+ BIN: 111 bitand append-nums append-nums append-nums ; inline
: begin-utf8 ( stream byte -- stream char )
{
{ [ dup -4 shift BIN: 1110 number= ] [ triple ] }
{ [ dup -3 shift BIN: 11110 number= ] [ quad ] }
[ drop replacement-char ]
- } cond ;
+ } cond ; inline
: decode-utf8 ( stream -- char/f )
- dup stream-read1 dup [ begin-utf8 ] when nip ;
+ dup stream-read1 dup [ begin-utf8 ] when nip ; inline
M: utf8 decode-char
drop decode-utf8 ;
[ total-failure-1 ] must-fail
-: total-failure-2 [ ] (call) unimplemented ;
-
-[ total-failure-2 ] must-fail
-
! From combinators.lib
[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences sequences.private classes.tuple
+classes.tuple.private kernel effects words quotations namespaces
+definitions math math.order layouts alien.accessors
+slots.private arrays byte-arrays inference.dataflow
+inference.known-words inference.state optimizer.inlining
+optimizer.backend ;
+IN: optimizer.allot
+
+! Expand memory allocation primitives into simpler constructs
+! to simplify the backend.
+
+: first-input ( #call -- obj ) dup in-d>> first node-literal ;
+
+: (tuple) ( layout -- tuple ) "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } <effect> set-primitive-effect
+\ (tuple) make-flushable
+
+! if the input to new is a literal tuple class, we can expand it
+: literal-new? ( #call -- ? )
+ first-input tuple-class? ;
+
+: new-quot ( class -- quot )
+ dup all-slots 1 tail ! delegate slot
+ [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
+
+: expand-new ( #call -- node )
+ dup first-input
+ [ +inlined+ depends-on ] [ new-quot ] bi
+ f splice-quot ;
+
+\ new {
+ { [ dup literal-new? ] [ expand-new ] }
+} define-optimizers
+
+: tuple-boa-quot ( layout -- quot )
+ [
+ dup ,
+ [ nip (tuple) ] %
+ size>> 1 - [ 3 + ] map <reversed>
+ [ [ set-slot ] curry [ keep ] curry % ] each
+ [ f over 2 set-slot ] %
+ ] [ ] make ;
+
+: expand-tuple-boa ( #call -- node )
+ dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
+
+\ <tuple-boa> {
+ { [ t ] [ expand-tuple-boa ] }
+} define-optimizers
+
+: (array) ( n -- array ) "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } <effect> set-primitive-effect
+\ (array) make-flushable
+
+: <array>-quot ( n -- quot )
+ [
+ dup ,
+ [ (array) ] %
+ [ \ 2dup , , [ swap set-array-nth ] % ] each
+ \ 2nip ,
+ ] [ ] make ;
+
+: literal-<array>? ( #call -- ? )
+ first-input dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: expand-<array> ( #call -- node )
+ dup first-input <array>-quot f splice-quot ;
+
+\ <array> {
+ { [ dup literal-<array>? ] [ expand-<array> ] }
+} define-optimizers
+
+: (byte-array) ( n -- byte-array ) "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } <effect> set-primitive-effect
+\ (byte-array) make-flushable
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+: <byte-array>-quot ( n -- quot )
+ [
+ dup ,
+ [ nip (byte-array) ] %
+ bytes>cells [ cell * ] map
+ [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
+ ] [ ] make ;
+
+: literal-<byte-array>? ( #call -- ? )
+ first-input dup integer? [ 0 128 between? ] [ drop f ] if ;
+
+: expand-<byte-array> ( #call -- node )
+ dup first-input <byte-array>-quot f splice-quot ;
+
+\ <byte-array> {
+ { [ dup literal-<byte-array>? ] [ expand-<byte-array> ] }
+} define-optimizers
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences inference.dataflow
-inference.backend kernel generic assocs classes vectors
-accessors combinators ;
+USING: namespaces assocs sequences kernel generic assocs classes
+vectors accessors combinators inference.dataflow inference.backend ;
IN: optimizer.def-use
SYMBOL: def-use
\ optimistic-inline? must-infer
\ find-identity must-infer
\ dispatching-class must-infer
-
-! Make sure we have sane heuristics
-[ t ] [ \ fixnum \ shift method should-inline? ] unit-test
-[ f ] [ \ array \ equal? method should-inline? ] unit-test
-[ f ] [ \ sequence \ hashcode* method should-inline? ] unit-test
-[ t ] [ \ array \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ sbuf \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth-unsafe method should-inline? ] unit-test
-[ t ] [ \ growable \ set-nth method should-inline? ] unit-test
-[ t ] [ \ vector \ (>>length) method should-inline? ] unit-test
! See http://factorcode.org/license.txt for BSD license.
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
-optimizer.math.partial continuations optimizer.def-use
-optimizer.backend generic.standard optimizer.specializers
-optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control kernel.private definitions sets ;
+math math.order namespaces sequences vectors words quotations
+hashtables combinators effects classes classes.union
+classes.algebra generic.math optimizer.math.partial
+continuations optimizer.def-use optimizer.backend
+generic.standard optimizer.specializers optimizer.def-use
+optimizer.pattern-match generic.standard optimizer.control
+kernel.private definitions sets summary ;
IN: optimizer.inlining
: remember-inlining ( node history -- )
: word-flat-length ( word -- n )
{
! not inline
- { [ dup inline? not ] [ drop 0 ] }
+ { [ dup inline? not ] [ drop 1 ] }
! recursive and inline
- { [ dup recursive-calls get key? ] [ drop 4 ] }
+ { [ dup recursive-calls get key? ] [ drop 10 ] }
! inline
[ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
} cond ;
: (flat-length) ( seq -- n )
[
{
- { [ dup quotation? ] [ (flat-length) 1+ ] }
+ { [ dup quotation? ] [ (flat-length) 2 + ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
[ drop 0 ]
: flat-length ( word -- n )
H{ } clone recursive-calls [
[ recursive-calls get conjoin ]
- [ def>> (flat-length) ]
+ [ def>> (flat-length) 5 /i ]
bi
] with-variable ;
[ f splice-quot ] [ 2drop t ] if ;
: inline-method ( #call -- node )
- dup node-param {
+ dup param>> {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
{ [ dup math-partial? ] [ inline-math-partial ] }
(optimize-predicate) optimize-check ;
: flush-eval? ( #call -- ? )
- dup node-param "flushable" word-prop [
- node-out-d [ unused? ] all?
- ] [
- drop f
- ] if ;
+ dup node-param "flushable" word-prop
+ [ node-out-d [ unused? ] all? ] [ drop f ] if ;
+
+ERROR: flushed-eval-error word ;
+
+M: flushed-eval-error summary
+ drop "Flushed evaluation of word would have thrown an error" ;
+
+: flushed-eval-quot ( #call -- quot )
+ #! A quotation to replace flushed evaluations with. We can't
+ #! just remove the code altogether, because if the optimizer
+ #! knows the input types of a word, it assumes the inputs are
+ #! of this type after the word returns, since presumably
+ #! the word would have checked input types itself. However,
+ #! if the word gets flushed, then it won't do this checking;
+ #! so we have to do it here.
+ [
+ dup param>> "input-classes" word-prop [
+ make-specializer %
+ [ dup param>> literalize , \ flushed-eval-error , ] [ ] make ,
+ \ unless ,
+ ] when*
+ dup in-d>> length [ \ drop , ] times
+ out-d>> length [ f , ] times
+ ] [ ] make ;
: flush-eval ( #call -- node )
- dup node-param +inlined+ depends-on
- dup node-out-d length f <repetition> inline-literals ;
+ dup param>> +inlined+ depends-on
+ dup flushed-eval-quot f splice-quot ;
: partial-eval? ( #call -- ? )
dup node-param "foldable" word-prop [
[ drop +inlined+ depends-on ] [ swap 1array ] 2bi
splice-quot ;
+: classes-known? ( #call -- ? )
+ node-input-classes [
+ [ class-types length 1 = ]
+ [ union-class? not ]
+ bi and
+ ] contains? ;
+
+: inlining-rank ( #call -- n )
+ {
+ [ param>> flat-length 24 swap [-] 4 /i ]
+ [ param>> "default" word-prop -4 0 ? ]
+ [ param>> "specializer" word-prop 1 0 ? ]
+ [ param>> method-body? 1 0 ? ]
+ [ classes-known? 2 0 ? ]
+ } cleave + + + + ;
+
+: should-inline? ( #call -- ? )
+ inlining-rank 5 >= ;
+
: optimistic-inline? ( #call -- ? )
- dup node-param "specializer" word-prop dup [
- >r node-input-classes r> specialized-length tail*
- [ class-types length 1 = ] all?
- ] [
- 2drop f
- ] if ;
+ dup param>> "specializer" word-prop
+ [ should-inline? ] [ drop f ] if ;
: already-inlined? ( #call -- ? )
[ param>> ] [ history>> ] bi memq? ;
dup param>> dup def>> splice-word-def
] if ;
-: should-inline? ( word -- ? )
- flat-length 11 <= ;
-
: method-body-inline? ( #call -- ? )
- param>> dup [ method-body? ] [ "default" word-prop not ] bi and
+ dup param>> method-body?
[ should-inline? ] [ drop f ] if ;
M: #call optimize-node*
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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
-sequences.private combinators byte-arrays byte-vectors
-slots.private ;
+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 sequences.private combinators byte-arrays
+byte-vectors slots.private inference.dataflow inference.state
+inference.class optimizer.def-use optimizer.backend
+optimizer.pattern-match optimizer.inlining optimizer.allot ;
IN: optimizer.known-words
{ <tuple> <tuple-boa> (tuple) } [
dup class? [ drop tuple ] unless 1array f
] "output-classes" 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? ;
-
-: new-quot ( class -- quot )
- dup all-slots 1 tail ! delegate slot
- [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make ;
-
-: expand-new ( #call -- node )
- dup dup in-d>> first node-literal
- [ +inlined+ depends-on ] [ new-quot ] bi
- f splice-quot ;
-
-\ new {
- { [ dup literal-new? ] [ expand-new ] }
-} define-optimizers
-
-: tuple-boa-quot ( layout -- quot )
- [ (tuple) ]
- swap size>> 1 - [ 3 + ] map <reversed>
- [ [ set-slot ] curry [ keep ] curry ] map concat
- [ f over 2 set-slot ]
- 3append ;
-
-: expand-tuple-boa ( #call -- node )
- dup in-d>> peek value-literal tuple-boa-quot f splice-quot ;
-
-\ <tuple-boa> {
- { [ t ] [ expand-tuple-boa ] }
-} define-optimizers
-
! the output of clone has the same type as the input
{ clone (clone) } [
[
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: effects alien alien.accessors arrays generic hashtables
+kernel assocs math math.libm math.private kernel.private
+sequences words parser vectors strings sbufs io namespaces
+assocs quotations math.intervals sequences.private combinators
+splitting layouts math.parser classes classes.algebra
+generic.math inference.class inference.dataflow
+optimizer.pattern-match optimizer.backend optimizer.def-use
+optimizer.inlining optimizer.math.partial generic.standard
+system accessors ;
IN: optimizer.math
-USING: alien alien.accessors arrays generic hashtables kernel
-assocs math math.private kernel.private sequences words parser
-inference.class inference.dataflow vectors strings sbufs io
-namespaces assocs quotations math.intervals sequences.private
-combinators splitting layouts math.parser classes
-classes.algebra generic.math optimizer.pattern-match
-optimizer.backend optimizer.def-use optimizer.inlining
-optimizer.math.partial generic.standard system accessors ;
: define-math-identities ( word identities -- )
>r all-derived-ops r> define-identities ;
] 2curry each-derived-op
] each
+: math-output-class/interval-2-fast ( node word -- classes intervals )
+ math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
+
+[
+ { + interval+ }
+ { - interval- }
+ { * interval* }
+ { shift interval-shift-safe }
+] [
+ first2 [
+ [
+ math-output-class/interval-2-fast
+ ] curry "output-classes" set-word-prop
+ ] curry each-fast-derived-op
+] each
+
: real-value? ( value -- n ? )
dup value? [ value-literal dup real? ] [ drop f f ] if ;
: convert-mod-to-and ( #call -- node )
dup
- dup node-in-d second node-literal 1-
+ dup in-d>> second node-literal 1-
[ nip bitand ] curry f splice-quot ;
\ mod [
[ fixnumify-bitand ]
}
} define-optimizers
+
+: convert-*-to-shift? ( #call -- ? )
+ dup in-d>> second node-literal
+ dup integer? [ power-of-2? ] [ drop f ] if ;
+
+: convert-*-to-shift ( #call -- ? )
+ dup dup in-d>> second node-literal log2
+ [ nip fixnum-shift-fast ] curry
+ f splice-quot ;
+
+\ fixnum*fast {
+ { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
+} define-optimizers
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i mod /mod }
+[ { rational rational } "input-classes" set-word-prop ] each
+
+{ bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+{
+ fcosh
+ flog
+ fsinh
+ fexp
+ fasin
+ facosh
+ fasinh
+ ftanh
+ fatanh
+ facos
+ fpow
+ fatan
+ fatan2
+ fcos
+ ftan
+ fsin
+ fsqrt
+} [
+ dup stack-effect
+ [ in>> length real <repetition> "input-classes" set-word-prop ]
+ [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+ 2bi
+] each
: each-derived-op ( word quot -- )
>r derived-ops r> each ; inline
+
+: each-fast-derived-op ( word quot -- )
+ >r fast-derived-ops r> each ; inline
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
[ 1 4 ] [ 1 interval-inference-bug ] unit-test
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
+
+: aggressive-flush-regression ( a -- b )
+ f over >r <array> drop r> 1 + ;
+
+[ 1.0 aggressive-flush-regression drop ] must-fail
+
+[ 1 [ "hi" + drop ] compile-call ] must-fail
+
+[ "hi" f [ <array> drop ] compile-call ] must-fail
+
+TUPLE: some-tuple x ;
+
+: allot-regression ( a -- b )
+ [ ] curry some-tuple boa ;
+
+[ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
-optimizer.known-words optimizer.math optimizer.control
-optimizer.collect optimizer.inlining inference.class ;
+optimizer.known-words optimizer.math optimizer.allot
+optimizer.control optimizer.collect optimizer.inlining
+inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences namespaces generic
+combinators classes classes.algebra
+inference inference.dataflow ;
IN: optimizer.pattern-match
-USING: kernel sequences inference namespaces generic
-combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching
SYMBOL: @
f <inset unclip text pprint-elements block>
\ } pprint-word block> ;
+: unparse-slot ( slot-spec -- array )
+ [
+ dup name>> ,
+ dup class>> object eq? [
+ dup class>> ,
+ initial: ,
+ dup initial>> ,
+ ] unless
+ dup read-only>> [
+ read-only ,
+ ] when
+ drop
+ ] { } make ;
+
+: pprint-slot ( slot-spec -- )
+ unparse-slot
+ dup length 1 = [ first ] when
+ pprint-slot-name ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
- <block slot-names [ pprint-slot-name ] each block>
+ <block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ;
M: word see-class* drop ;
{ $subsection each }
{ $subsection reduce }
{ $subsection interleave }
-{ $subsection 2each }
-{ $subsection 2reduce }
"Mapping:"
{ $subsection map }
-{ $subsection 2map }
+{ $subsection map-as }
{ $subsection accumulate }
{ $subsection produce }
"Filtering:"
{ $subsection push-if }
-{ $subsection filter } ;
+{ $subsection filter }
+"Testing if a sequence contains elements satisfying a predicate:"
+{ $subsection contains? }
+{ $subsection all? }
+"Testing how elements are related:"
+{ $subsection monotonic? }
+{ $subsection "sequence-2combinators" } ;
+
+ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators"
+"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined."
+{ $subsection 2each }
+{ $subsection 2reduce }
+{ $subsection 2map }
+{ $subsection 2map-as }
+{ $subsection 2all? } ;
ARTICLE: "sequences-tests" "Testing sequences"
"Testing for an empty sequence:"
{ $subsection head? }
{ $subsection tail? }
{ $subsection subseq? }
-"Testing if a sequence contains elements satisfying a predicate:"
-{ $subsection contains? }
-{ $subsection all? }
-{ $subsection 2all? }
"Testing how elements are related:"
-{ $subsection monotonic? }
{ $subsection all-eq? }
{ $subsection all-equal? } ;
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } }
{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as the input sequence." } ;
+HELP: map-as
+{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $description "Applies the quotation to each element of the sequence in order. The new elements are collected into a sequence of the same class as " { $snippet "exemplar" } "." }
+{ $examples
+ "The following example converts a string into an array of one-element strings:"
+ { $example "USING: prettyprint strings sequences ;" "\"Hello\" [ 1string ] { } map-as ." "{ \"H\" \"e\" \"l\" \"l\" \"o\" }" }
+ "Note that " { $link map } " could not be used here, because it would create another string to hold results, and one-element strings cannot themselves be elements of strings."
+} ;
+
HELP: change-nth
{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } }
{ $description "Applies the quotation to the " { $snippet "i" } "th element of the sequence, storing the result back into the sequence." }
HELP: 2each
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- )" } } }
-{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: 2reduce
{ $values { "seq1" sequence }
{ "quot" "a quotation with stack effect "
{ $snippet "( prev elt1 elt2 -- next )" } }
{ "result" "the final result" } }
-{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." }
-{ $notes "If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Combines successive pairs of elements from the two sequences using a ternary operation. The first input value at each iteration except the first one is the result of the previous iteration. The first input value at the first iteration is " { $snippet "identity" } "." } ;
HELP: 2map
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } }
-{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ;
+
+HELP: 2map-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } }
+{ $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ;
HELP: 2all?
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt1 elt2 -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
-{ $notes "If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." } ;
+{ $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ;
HELP: find
{ $values { "seq" sequence }
M: sequence like drop ;
GENERIC: lengthen ( n seq -- )
+GENERIC: shorten ( n seq -- )
M: sequence lengthen 2dup length > [ set-length ] [ 2drop ] if ;
+M: sequence shorten 2dup length < [ set-length ] [ 2drop ] if ;
+
: empty? ( seq -- ? ) length zero? ; inline
: delete-all ( seq -- ) 0 swap set-length ;
: 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline
-: 2map ( seq1 seq2 quot -- newseq )
- pick >r (2each) over r>
+: 2map-as ( seq1 seq2 quot exemplar -- newseq )
+ >r (2each) over r>
[ [ collect ] keep ] new-like ; inline
+: 2map ( seq1 seq2 quot -- newseq )
+ pick 2map-as ; inline
+
: 2all? ( seq1 seq2 quot -- ? )
(2each) all-integers? ; inline
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
-: pop* ( seq -- ) [ length 1- ] [ set-length ] bi ;
+: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
: move-backward ( shift from to seq -- )
2over number= [
copy ;
: pop ( seq -- elt )
- [ length 1- ] [ [ nth ] [ set-length ] 2bi ] bi ;
+ [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: all-equal? ( seq -- ? ) [ = ] monotonic? ;
{ $subsection prune }
"Test for duplicates:"
{ $subsection all-unique? }
+{ $subsection duplicates }
"Set operations on sequences:"
{ $subsection diff }
{ $subsection intersect }
}
{ $side-effects "seq" } ;
+HELP: conjoin
+{ $values { "elt" object } { "assoc" "an assoc" } }
+{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
+{ $examples
+ { $example
+ "USING: kernel prettyprint sets ;"
+ "H{ } clone 1 over conjoin ."
+ "H{ { 1 1 } }"
+ }
+}
+{ $side-effects "assoc" } ;
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
} ;
+HELP: duplicates
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence consisting of elements which occur more than once in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 1 2 1 } duplicates ." "{ 1 2 1 }" }
+} ;
+
HELP: all-unique?
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
[ ] [ length <hashtable> ] [ length <vector> ] tri
[ [ (prune) ] 2curry each ] keep ;
+: duplicates ( seq -- newseq )
+ H{ } clone [ [ key? ] [ conjoin ] 2bi ] curry filter ;
+
: gather ( seq quot -- newseq )
map concat prune ; inline
"All other classes are handled with one of two cases:"
{ $list
{ "If the class is a union or mixin class which " { $emphasis "contains" } " one of the above known classes, then the initial value of the class is that of the known class, with preference given to classes earlier in the list. For example, if the slot is declared " { $link object } " (this is the default), the initial value is " { $link f } ". Similarly for " { $link sequence } " and " { $link assoc } "." }
+ { "If the class is a tuple class, the initial value of the slot is a new, shared instance of the class created with " { $link new } "." }
{ "Otherwise, a " { $link no-initial-value } " error is thrown. In this case, an initial value must be specified explicitly using " { $link initial: } "." }
}
"A word can be used to check if a class has an initial value or not:"
ERROR: no-initial-value class ;
+GENERIC: initial-value* ( class -- object )
+
+M: class initial-value* no-initial-value ;
+
: initial-value ( class -- object )
{
{ [ \ f bootstrap-word over class<= ] [ f ] }
{ [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
- [ no-initial-value ]
+ [ dup initial-value* ]
} cond nip ;
GENERIC: make-slot ( desc -- slot-spec )
[ dup empty? not ] [ peel-off-attributes ] [ ] while drop
check-initial-value ;
-: make-slots ( slots base -- specs )
- over length [ + ] with map
- [ [ make-slot ] dip >>offset ] 2map ;
+M: slot-spec make-slot
+ check-initial-value ;
+
+: make-slots ( slots -- specs )
+ [ make-slot ] map ;
+
+: finalize-slots ( specs base -- specs )
+ over length [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
- [ slot-spec-name = ] with find nip ;
+ [ name>> = ] with find nip ;
{ { $snippet "\"constructor\"" } { $link "tuple-constructors" } }
- { { $snippet "\"slot-names\"" } { $link "tuples" } }
-
{ { $snippet "\"type\"" } { $link "builtin-classes" } }
{ { { $snippet "\"superclass\"" } ", " { $snippet "\"predicate-definition\"" } } { $link "predicates" } }
M: symbol definition drop f ;
PREDICATE: primitive < word ( obj -- ? )
- def>> [ do-primitive ] tail? ;
+ [ def>> [ do-primitive ] tail? ]
+ [ sub-primitive>> >boolean ]
+ bi or ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
USING: arrays assocs kernel vectors sequences namespaces
-random math.parser math fry ;
-IN: assocs.lib
-
-: ref-at ( table key -- value ) swap at ;
+ random math.parser math fry ;
-: put-at* ( table key value -- ) swap rot set-at ;
-
-: put-at ( table key value -- table ) swap pick set-at ;
+IN: assocs.lib
: set-assoc-stack ( value key seq -- )
dupd [ key? ] with find-last nip set-at ;
USING: kernel math math.parser random arrays hashtables assocs sequences
- vars ;
+ grouping vars ;
IN: automata
! step-wrapped-line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 3nth ( n seq -- slice ) >r dup 3 + r> <slice> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map3-i ( seq -- i ) length 2 - ;
-
-: map3-quot ( seq quot -- quot ) >r [ 3nth ] curry r> compose ; inline
-
-: map3 ( seq quot -- seq ) >r dup map3-i swap r> map3-quot map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
dup peek 1array swap dup first 1array append append ;
-: step-line ( line -- new-line ) [ >array pattern>state ] map3 ;
-
-: step-capped-line ( line -- new-line ) cap-line step-line ;
+: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
+: step-capped-line ( line -- new-line ) cap-line step-line ;
: step-wrapped-line ( line -- new-line ) wrap-line step-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ui.gadgets.packs
ui.gadgets.grids
ui.gadgets.theme
+ accessors
+ qualified
namespaces.lib assocs.lib vars
- rewrite-closures automata ;
+ rewrite-closures automata math.geometry.rect newfx ;
IN: automata.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+QUALIFIED: ui.gadgets.grids
+
+: grid-add ( grid child i j -- grid )
+ >r >r dupd swap r> r> ui.gadgets.grids:grid-add ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
: draw-point ( y x value -- ) 1 = [ swap glVertex2i ] [ 2drop ] if ;
: draw-line ( y line -- ) 0 swap [ >r 2dup r> draw-point 1+ ] each 2drop ;
DEFER: automata-window
-: automata-window* ( -- ) init-rule set-interesting <frame>
-
-{
-[ "1 - Center" [ start-center ] view-button ]
-[ "2 - Random" [ start-random ] view-button ]
-[ "3 - Continue" [ run-rule ] view-button ]
-[ "5 - Random Rule" [ random-rule ] view-button ]
-[ "n - New" [ automata-window ] view-button ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-shelf over @top grid-add
-
-[ display ] closed-quot <slate> { 400 400 } over set-slate-dim dup >slate
-over @center grid-add
-
-{
-{ T{ key-down f f "1" } [ [ start-center ] view-action ] }
-{ T{ key-down f f "2" } [ [ start-random ] view-action ] }
-{ T{ key-down f f "3" } [ [ run-rule ] view-action ] }
-{ T{ key-down f f "5" } [ [ random-rule ] view-action ] }
-{ T{ key-down f f "n" } [ [ automata-window ] view-action ] }
-} [ make* ] map >hashtable <handler> tuck set-gadget-delegate
-"Automata" open-window ;
+: automata-window* ( -- )
+ init-rule
+ set-interesting
+
+ <frame>
+
+ <shelf>
+
+ "1 - Center" [ start-center ] view-button add-gadget
+ "2 - Random" [ start-random ] view-button add-gadget
+ "3 - Continue" [ run-rule ] view-button add-gadget
+ "5 - Random Rule" [ random-rule ] view-button add-gadget
+ "n - New" [ automata-window ] view-button add-gadget
+
+ @top grid-add
+
+ C[ display ] <slate>
+ { 400 400 } >>dim
+ dup >slate
+
+ @center grid-add
+
+ H{ }
+ T{ key-down f f "1" } [ start-center ] view-action is
+ T{ key-down f f "2" } [ start-random ] view-action is
+ T{ key-down f f "3" } [ run-rule ] view-action is
+ T{ key-down f f "5" } [ random-rule ] view-action is
+ T{ key-down f f "n" } [ automata-window ] view-action is
+
+ <handler>
+
+ tuck set-gadget-delegate
+
+ "Automata" open-window ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.ranges math.parser math.vectors sets sequences
+kernel io ;
+IN: benchmark.beust1
+
+: count-numbers ( max -- n )
+ 1 [a,b] [ number>string all-unique? ] count ; inline
+
+: beust ( -- )
+ 10000000 count-numbers
+ number>string " unique numbers." append print ;
+
+MAIN: beust
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.ranges math.parser sequences kernel io locals ;
+IN: benchmark.beust2
+
+! http://crazybob.org/BeustSequence.java.html
+
+:: (count-numbers) ( remaining first value used max listener -- ? )
+ 10 first - [| i |
+ [let* | digit [ i first + ]
+ mask [ digit 2^ ]
+ value' [ i value + ] |
+ used mask bitand zero? [
+ value max > [ t ] [
+ remaining 1 <= [
+ listener call f
+ ] [
+ remaining 1-
+ 0
+ value' 10 *
+ used mask bitor
+ max
+ listener
+ (count-numbers)
+ ] if
+ ] if
+ ] [ f ] if
+ ]
+ ] contains? ; inline
+
+:: count-numbers ( max listener -- )
+ 10 [ 1+ 1 1 0 max listener (count-numbers) ] contains? drop ;
+ inline
+
+:: beust ( -- )
+ [let | i! [ 0 ] |
+ 10000000000 [ i 1+ i! ] count-numbers
+ i number>string " unique numbers." append print
+ ] ;
+
+MAIN: beust
--- /dev/null
+USING: kernel sequences math math.functions vectors ;
+IN: benchmark.stack
+
+: stack-loop ( vec -- )
+ 1000 [
+ 10000 [
+ dup pop dup ! dup 10 > [ sqrt dup 1 + ] [ dup 2 * ] if
+ pick push
+ over push
+ ] times
+ 10000 [ dup pop* ] times
+ ] times
+ drop ;
+
+: stack-benchmark ( -- )
+ V{ 123456 } clone stack-loop
+ 20000 <vector> 123456 over set-first stack-loop ;
+
+MAIN: stack-benchmark
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: biassocs
+USING: help.markup help.syntax assocs kernel ;
+
+HELP: biassoc
+{ $class-description "The class of bidirectional assocs. Bidirectional assoc are implemented by combining two assocs, with one the transpose of the other." } ;
+
+HELP: <biassoc>
+{ $values { "exemplar" assoc } { "biassoc" biassoc } }
+{ $description "Creates a new biassoc using a new assoc of the same type as " { $snippet "exemplar" } " for underlying storage." } ;
+
+HELP: <bihash>
+{ $values { "biassoc" biassoc } }
+{ $description "Creates a new biassoc using a pair of hashtables for underlying storage." } ;
+
+HELP: once-at
+{ $values { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
+
+ARTICLE: "biassocs" "Bidirectional assocs"
+"A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time."
+$nl
+"Bidirectional assocs implement the entire assoc protocol with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with."
+{ $subsection biassoc }
+{ $subsection biassoc? }
+{ $subsection <biassoc> }
+{ $subsection <bihash> } ;
+
+ABOUT: "biassocs"
--- /dev/null
+IN: biassocs.tests
+USING: biassocs assocs namespaces tools.test ;
+
+<bihash> "h" set
+
+[ 0 ] [ "h" get assoc-size ] unit-test
+
+[ ] [ 1 2 "h" get set-at ] unit-test
+
+[ 1 ] [ 2 "h" get at ] unit-test
+
+[ 2 ] [ 1 "h" get value-at ] unit-test
+
+[ 1 ] [ "h" get assoc-size ] unit-test
+
+[ ] [ 1 3 "h" get set-at ] unit-test
+
+[ 1 ] [ 3 "h" get at ] unit-test
+
+[ 2 ] [ 1 "h" get value-at ] unit-test
+
+[ 2 ] [ "h" get assoc-size ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs accessors ;
+IN: biassocs
+
+TUPLE: biassoc from to ;
+
+: <biassoc> ( exemplar -- biassoc )
+ [ clone ] [ clone ] bi biassoc boa ;
+
+: <bihash> ( -- biassoc )
+ H{ } <biassoc> ;
+
+M: biassoc assoc-size from>> assoc-size ;
+
+M: biassoc at* from>> at* ;
+
+M: biassoc value-at* to>> at* ;
+
+: once-at ( value key assoc -- )
+ 2dup key? [ 3drop ] [ set-at ] if ;
+
+M: biassoc set-at
+ [ from>> set-at ] [ swapd to>> once-at ] 3bi ;
+
+M: biassoc delete-at
+ "biassocs do not support deletion" throw ;
+
+M: biassoc >alist
+ from>> >alist ;
+
+M: biassoc clear-assoc
+ [ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
+
+INSTANCE: biassoc assoc
--- /dev/null
+Bidirectional assocs
--- /dev/null
+collections
n zero? [ 0 <bit-array> ] [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
[ n' zero? not ] [
- n' out underlying>> i 255 bitand set-alien-unsigned-1
+ n' out underlying>> i set-alien-unsigned-1
n' -8 shift n'!
i 1+ i!
] [ ] while
math.order
math.vectors
math.trig
+ math.physics.pos
+ math.physics.vel
combinators arrays sequences random vars
- combinators.lib ;
+ combinators.lib
+ accessors ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: boid pos vel ;
+TUPLE: boid < vel ;
C: <boid> boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
+: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
: relative-angle ( self other -- angle )
-over boid-vel -rot relative-position angle-between ;
+over vel>> -rot relative-position angle-between ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
-: average-position ( boids -- pos ) [ boid-pos ] map vaverage ;
+: average-position ( boids -- pos ) [ pos>> ] map vaverage ;
-: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ;
+: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
dup cohesion-neighborhood
dup empty?
[ 2drop { 0 0 } ]
- [ average-position swap boid-pos v- normalize* cohesion-weight> v*n ]
+ [ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
dup separation-neighborhood
dup empty?
[ 2drop { 0 0 } ]
- [ average-position swap boid-pos swap v- normalize* separation-weight> v*n ]
+ [ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ;
+: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
: new-vel ( boid -- vel )
- [ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
+ [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;
ui.gadgets.packs
ui.gadgets.grids
ui.gestures
- assocs.lib vars rewrite-closures boids ;
+ assocs.lib vars rewrite-closures boids accessors
+ math.geometry.rect
+ newfx ;
IN: boids.ui
! draw-boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: point-a ( boid -- a ) boid-pos ;
+: point-a ( boid -- a ) pos>> ;
-: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ;
+: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ;
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;
<frame>
+ <shelf>
+
{
[ "ESC - Pause" [ drop toggle-loop ] button* ]
[ "1 - Randomize" [ drop randomize ] button* ]
[ <pile> 1 over set-pack-fill
- population-label> over add-gadget
- "3 - Add 10" [ drop add-10-boids ] button* over add-gadget
- "2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ]
+ population-label> add-gadget
+ "3 - Add 10" [ drop add-10-boids ] button* add-gadget
+ "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
[ <pile> 1 over set-pack-fill
- cohesion-label> over add-gadget
- "q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget
- "a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ]
+ cohesion-label> add-gadget
+ "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
+ "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill
- alignment-label> over add-gadget
- "w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget
- "s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ]
+ alignment-label> add-gadget
+ "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
+ "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill
- separation-label> over add-gadget
- "e - +0.1" [ drop inc-separation-weight ] button* over add-gadget
- "d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ]
+ separation-label> add-gadget
+ "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
+ "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
- } [ call ] map [ [ gadget, ] each ] make-shelf
+ } [ call ] map [ add-gadget ] each
1 over set-pack-fill
over @top grid-add
slate> over @center grid-add
H{ } clone
- T{ key-down f f "1" } C[ drop randomize ] put-at
- T{ key-down f f "2" } C[ drop sub-10-boids ] put-at
- T{ key-down f f "3" } C[ drop add-10-boids ] put-at
+ T{ key-down f f "1" } C[ drop randomize ] is
+ T{ key-down f f "2" } C[ drop sub-10-boids ] is
+ T{ key-down f f "3" } C[ drop add-10-boids ] is
- T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at
- T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at
+ T{ key-down f f "q" } C[ drop inc-cohesion-weight ] is
+ T{ key-down f f "a" } C[ drop dec-cohesion-weight ] is
- T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at
- T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at
+ T{ key-down f f "w" } C[ drop inc-alignment-weight ] is
+ T{ key-down f f "s" } C[ drop dec-alignment-weight ] is
- T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at
- T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at
+ T{ key-down f f "e" } C[ drop inc-separation-weight ] is
+ T{ key-down f f "d" } C[ drop dec-separation-weight ] is
- T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at
+ T{ key-down f f "ESC" } C[ drop toggle-loop ] is
<handler> tuck set-gadget-delegate "Boids" open-window ;
: boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ;
-USING: alien alien.c-types arrays sequences math math.vectors
-math.matrices math.parser io io.files kernel opengl opengl.gl
-opengl.glu shuffle http.client vectors namespaces ui.gadgets
-ui.gadgets.canvas ui.render ui splitting combinators
-system combinators.lib float-arrays continuations
-opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
-bunny.cel-shaded bunny.outlined bunny.model accessors destructors ;
+USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
+bunny.model bunny.outlined destructors kernel math opengl.demo-support
+opengl.gl sequences ui ui.gadgets ui.gestures ui.render words ;
IN: bunny
-TUPLE: bunny-gadget model geom draw-seq draw-n ;
+TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
: <bunny-gadget> ( -- bunny-gadget )
- 0.0 0.0 0.375 <demo-gadget>
- maybe-download read-model {
- set-delegate
- (>>model)
- } bunny-gadget construct ;
+ 0.0 0.0 0.375 bunny-gadget new-demo-gadget
+ maybe-download read-model >>model-triangles ;
: bunny-gadget-draw ( gadget -- draw )
- { draw-n>> draw-seq>> }
- get-slots nth ;
+ [ draw-n>> ] [ draw-seq>> ] bi nth ;
: bunny-gadget-next-draw ( gadget -- )
- dup { draw-seq>> draw-n>> }
- get-slots
+ dup [ draw-seq>> ] [ draw-n>> ] bi
1+ swap length mod
>>draw-n relayout-1 ;
M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
- dup model>> <bunny-geom> >>geom
+ dup model-triangles>> <bunny-geom> >>geom
dup
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- { geom>> bunny-gadget-draw } get-slots
- draw-bunny
+ [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
] if ;
M: bunny-gadget pref-dim* ( gadget -- dim )
-USING: alien alien.c-types arrays sequences math math.vectors
-math.matrices math.parser io io.files kernel opengl opengl.gl
-opengl.glu io.encodings.ascii opengl.capabilities shuffle
-http.client vectors splitting system combinators
-float-arrays continuations destructors namespaces sequences.lib
-accessors ;
+USING: accessors alien.c-types arrays combinators destructors http.client
+io io.encodings.ascii io.files kernel math math.matrices math.parser
+math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
+splitting vectors words ;
IN: bunny.model
: numbers ( str -- seq )
{
[
[ first concat ] [ second concat ] bi
- append >c-double-array
+ append >c-float-array
GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
]
[
M: bunny-buffers bunny-geom
dup { array>> element-array>> } get-slots [
{ GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
- GL_DOUBLE 0 0 buffer-offset glNormalPointer
+ GL_FLOAT 0 0 buffer-offset glNormalPointer
[
- nv>> "double" heap-size * buffer-offset
- 3 GL_DOUBLE 0 roll glVertexPointer
+ nv>> "float" heap-size * buffer-offset
+ 3 GL_FLOAT 0 roll glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
] [ drop ] if ;
: remake-framebuffer-if-needed ( draw -- )
- dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi
- over =
- [ 2drop ] [
- [ dup dispose-framebuffer dup ] dip {
+ dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
+ [ drop ] [
+ [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
[
GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
[ >>color-texture drop ] keep
[ >>depth-texture drop ] keep
]
} 2cleave
- (make-framebuffer) >>framebuffer drop
+ [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
+ drop
] if ;
: clear-framebuffer ( -- )
USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
-ui.gadgets.sliders ui.render ;
+ui.gadgets.sliders ui.render math.geometry.rect ;
IN: color-picker
! Simple example demonstrating the use of models.
: <color-preview> ( model -- gadget )
color-preview new-gadget
- { 100 100 } over set-rect-dim ;
+ swap >>model
+ { 100 100 } >>dim ;
M: color-preview model-changed
swap model-value over set-gadget-interior relayout-1 ;
: <color-sliders> ( -- model gadget )
3 [ 0 0 0 255 <range> ] replicate
dup [ range-model ] map <compose>
- swap [ [ <color-slider> gadget, ] each ] make-filled-pile ;
+ swap
+ <filled-pile>
+ swap
+ [ <color-slider> add-gadget ] each ;
: <color-picker> ( -- gadget )
[
-USING: help.syntax help.markup kernel prettyprint sequences strings ;
+USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
IN: ctags
ARTICLE: "ctags" "Ctags file"
{ $subsection ctags }
{ $subsection ctags-write }
{ $subsection ctag-strings }
-{ $subsection ctag } ;
+{ $subsection ctag }
+{ $subsection ctag-word }
+{ $subsection ctag-path }
+{ $subsection ctag-lineno } ;
HELP: ctags ( path -- )
{ $values { "path" "a pathname string" } }
}
} ;
+HELP: ctag-lineno ( ctag -- n )
+{ $values { "ctag" sequence }
+ { "n" integer } }
+{ $description "Provides de line number " { $snippet "n" } " from a sequence in ctag format " }
+{ $examples
+ { $example
+ "USING: kernel ctags prettyprint ;"
+ "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-lineno ."
+ "91"
+ }
+} ;
+
+HELP: ctag-path ( ctag -- path )
+{ $values { "ctag" sequence }
+ { "path" string } }
+{ $description "Provides a path string " { $snippet "path" } " from a sequence in ctag format" }
+{ $examples
+ { $example
+ "USING: kernel ctags prettyprint ;"
+ "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-path ."
+ "\"resource:extra/unix/unix.factor\""
+ }
+} ;
+
+HELP: ctag-word ( ctag -- word )
+{ $values { "ctag" sequence }
+ { "word" word } }
+{ $description "Provides the " { $snippet "word" } " from a sequence in ctag format " }
+{ $examples
+ { $example
+ "USING: kernel ctags prettyprint ;"
+ "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag-word ."
+ "if"
+ }
+} ;
+
+
ABOUT: "ctags"
\ No newline at end of file
USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
IN: ctags.tests
+[ t ] [
+ 91
+ { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-lineno =
+] unit-test
+
+[ t ] [
+ "resource:extra/unix/unix.factor"
+ { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-path =
+] unit-test
+
+[ t ] [
+ if
+ { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-word =
+] unit-test
+
[ t ] [
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
{ if { "resource:extra/unix/unix.factor" 91 } } ctag =
[ t ] [
"if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
{ { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
-] unit-test
\ No newline at end of file
+] unit-test
+
namespaces words sorting ;
IN: ctags
+: ctag-word ( ctag -- word )
+ first ;
+
+: ctag-path ( ctag -- path )
+ second first ;
+
+: ctag-lineno ( ctag -- n )
+ second second ;
+
: ctag ( seq -- str )
[
- dup first ?word-name %
+ dup ctag-word ?word-name %
"\t" %
- second dup first normalize-path %
+ dup ctag-path normalize-path %
"\t" %
- second number>string %
+ ctag-lineno number>string %
] "" make ;
: ctag-strings ( seq1 -- seq2 )
- { } swap [ ctag suffix ] each ;
+ [ ctag ] map ;
: ctags-write ( seq path -- )
[ ctag-strings ] dip ascii set-file-lines ;
: (ctags) ( -- seq )
- { } all-words [
+ all-words [
dup where [
- 2array suffix
- ] [
- drop
- ] if*
- ] each ;
+ 2array
+ ] when*
+ ] map [ sequence? ] filter ;
: ctags ( path -- )
(ctags) sort-keys swap ctags-write ;
\ No newline at end of file
--- /dev/null
+Alfredo Beaumont
--- /dev/null
+USING: help.syntax help.markup kernel prettyprint sequences strings words math ;
+IN: ctags.etags
+
+ARTICLE: "etags" "Etags file"
+{ $emphasis "Etags" } " generates a index file of every factor word in etags format as supported by emacs and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags#Etags_2" } "."
+{ $subsection etags }
+{ $subsection etags-write }
+{ $subsection etag-strings }
+{ $subsection etag-header }
+
+HELP: etags ( path -- )
+{ $values { "path" string } }
+{ $description "Generates a index file in etags format and stores in " { $snippet "path" } "." }
+{ $examples
+ { $unchecked-example
+ "USING: ctags.etags ;"
+ "\"ETAGS\" etags"
+ ""
+ }
+} ;
+
+HELP: etags-write ( alist path -- )
+{ $values { "alist" sequence }
+ { "path" string } }
+{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with etags format: its key must be a resource path and its value a vector, containing pairs of words and lines" }
+{ $examples
+ { $unchecked-example
+ "USING: kernel etags.ctags ;"
+ "{ { \"resource:extra/unix/unix.factor\" V{ { dup2 91 } } } } \"ETAGS\" etags-write"
+ ""
+ }
+} ;
+
+HELP: etag-strings ( alist -- seq )
+{ $values { "alist" sequence }
+ { "seq" sequence } }
+{ $description "Converts an " { $snippet "alist" } " with etag format (a path as key and a vector containing word/line pairs) in a " { $snippet "seq" } " of strings." } ;
+
+ABOUT: "etags" ;
\ No newline at end of file
--- /dev/null
+USING: kernel ctags ctags.etags tools.test io.backend sequences arrays prettyprint hashtables assocs ;
+IN: ctags.etags.tests
+
+! etag-at
+[ t ]
+[
+ V{ }
+ "path" H{ } clone etag-at =
+] unit-test
+
+[ t ]
+[
+ V{ if { "path" 1 } }
+ "path" H{ { "path" V{ if { "path" 1 } } } } etag-at =
+] unit-test
+
+! etag-vector
+[ t ]
+[
+ V{ }
+ { if { "path" 1 } } H{ } clone etag-vector =
+] unit-test
+
+[ t ]
+[
+ V{ if { "path" 1 } }
+ { if { "path" 1 } }
+ { { "path" V{ if { "path" 1 } } } } >hashtable
+ etag-vector =
+] unit-test
+
+! etag-pair
+[ t ]
+[
+ { if 28 }
+ { if { "resource:core/kernel/kernel.factor" 28 } } etag-pair =
+] unit-test
+
+! etag-add
+[ t ]
+[
+ H{ { "path" V{ { if 1 } } } }
+ { if { "path" 1 } } H{ } clone [ etag-add ] keep =
+] unit-test
+
+! etag-hash
+[ t ]
+[
+ H{ { "path" V{ { if 1 } } } }
+ { { if { "path" 1 } } } etag-hash =
+] unit-test
+
+! line-bytes (note that for each line implicit \n is counted)
+[ t ]
+[
+ 17
+ { "1234567890" "12345" } 2 lines>bytes =
+] unit-test
+
+! etag
+[ t ]
+[
+ "if\7f2,11"
+ { "1234567890" "12345" } { if 2 } etag =
+] unit-test
+
+! etag-length
+[ t ]
+[
+ 14
+ V{ "if\7f2,11" "if\7f2,11" } etag-length =
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Alfredo Beaumont
+! See http://factorcode.org/license.txt for BSD license.
+
+! Emacs Etags generator
+! Alfredo Beaumont <alfredo.beaumont@gmail.com>
+USING: kernel sequences sorting assocs words prettyprint ctags
+io.encodings.ascii io.files math math.parser namespaces strings locals
+shuffle io.backend arrays ;
+IN: ctags.etags
+
+: etag-at ( key hash -- vector )
+ at [ V{ } clone ] unless* ;
+
+: etag-vector ( alist hash -- vector )
+ [ ctag-path ] dip etag-at ;
+
+: etag-pair ( ctag -- seq )
+ dup [
+ first ,
+ second second ,
+ ] { } make ;
+
+: etag-add ( ctag hash -- )
+ [ etag-vector ] 2keep [
+ [ etag-pair ] [ ctag-path ] bi [ suffix ] dip
+ ] dip set-at ;
+
+: etag-hash ( seq -- hash )
+ H{ } clone swap [ swap [ etag-add ] keep ] each ;
+
+: lines>bytes ( seq n -- bytes )
+ head 0 [ length 1+ + ] reduce ;
+
+: file>lines ( path -- lines )
+ ascii file-lines ;
+
+: etag ( lines seq -- str )
+ [
+ dup first ?word-name %
+ 1 HEX: 7f <string> %
+ second dup number>string %
+ 1 CHAR: , <string> %
+ 1- lines>bytes number>string %
+ ] "" make ;
+
+: etag-length ( vector -- n )
+ 0 [ length + ] reduce ;
+
+: (etag-header) ( n path -- str )
+ [
+ %
+ 1 CHAR: , <string> %
+ number>string %
+ ] "" make ;
+
+: etag-header ( vec1 n resource -- vec2 )
+ normalize-path (etag-header) prefix
+ 1 HEX: 0c <string> prefix ;
+
+: etag-strings ( alist -- seq )
+ { } swap [
+ [
+ [ first file>lines ]
+ [ second ] bi
+ [ etag ] with map
+ dup etag-length
+ ] keep first
+ etag-header append
+ ] each ;
+
+: etags-write ( alist path -- )
+ [ etag-strings ] dip ascii set-file-lines ;
+
+: etags ( path -- )
+ [ (ctags) sort-values etag-hash >alist ] dip etags-write ;
\ No newline at end of file
--- /dev/null
+Etags generator
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
-<PRIVATE
-
-: floats>bytes 8 * ; inline
-
-: float-array@ underlying>> swap >fixnum floats>bytes ; inline
-
-PRIVATE>
-
: <float-array> ( n -- float-array )
- dup floats>bytes <byte-array> float-array boa ; inline
+ dup "double" <c-array> float-array boa ; inline
M: float-array clone
[ length>> ] [ underlying>> clone ] bi float-array boa ;
M: float-array length length>> ;
M: float-array nth-unsafe
- float-array@ alien-double ;
+ underlying>> double-nth ;
M: float-array set-nth-unsafe
- [ >float ] 2dip float-array@ set-alien-double ;
+ [ >float ] 2dip underlying>> set-double-nth ;
: >float-array ( seq -- float-array )
- T{ float-array f 0 B{ } } clone-like ; inline
+ T{ float-array } clone-like ; inline
M: float-array like
drop dup float-array? [ >float-array ] unless ;
M: float-array resize
[ drop ] [
- [ floats>bytes ] [ underlying>> ] bi*
+ [ "double" heap-size * ] [ underlying>> ] bi*
resize-byte-array
] 2bi
float-array boa ;
1 <float-array> [ set-first ] keep ; flushable
: 2float-array ( x y -- array )
- T{ float-array f 0 B{ } } 2sequence ; flushable
+ T{ float-array } 2sequence ; flushable
: 3float-array ( x y z -- array )
- T{ float-array f 0 B{ } } 3sequence ; flushable
+ T{ float-array } 3sequence ; flushable
: 4float-array ( w x y z -- array )
- T{ float-array f 0 B{ } } 4sequence ; flushable
+ T{ float-array } 4sequence ; flushable
: F{ ( parsed -- parsed )
\ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ;
M: float-array >pprint-sequence ;
+
+USING: hints math.vectors arrays ;
+
+HINTS: vneg { float-array } { array } ;
+HINTS: v*n { float-array object } { array object } ;
+HINTS: v/n { float-array object } { array object } ;
+HINTS: n/v { object float-array } { object array } ;
+HINTS: v+ { float-array float-array } { array array } ;
+HINTS: v- { float-array float-array } { array array } ;
+HINTS: v* { float-array float-array } { array array } ;
+HINTS: v/ { float-array float-array } { array array } ;
+HINTS: vmax { float-array float-array } { array array } ;
+HINTS: vmin { float-array float-array } { array array } ;
+HINTS: v. { float-array float-array } { array array } ;
+HINTS: norm-sq { float-array } { array } ;
+HINTS: norm { float-array } { array } ;
+HINTS: normalize { float-array } { array } ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
USING: help.syntax help.markup kernel sequences quotations\r
-math ;\r
+math arrays ;\r
IN: generalizations\r
\r
+HELP: narray\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link 1array } ", "\r
+{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "\r
+"that constructs an array from the top " { $snippet "n" } " elements of the stack."\r
+} ;\r
+\r
+HELP: firstn\r
+{ $values { "n" integer } }\r
+{ $description "A generalization of " { $link first } ", "\r
+{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "\r
+"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."\r
+} ;\r
+\r
HELP: npick\r
{ $values { "n" integer } }\r
{ $description "A generalization of " { $link dup } ", "\r
"macros where the arity of the input quotations depends on an "\r
"input parameter."\r
{ $subsection narray }\r
+{ $subsection firstn }\r
{ $subsection ndup }\r
{ $subsection npick }\r
{ $subsection nrot }\r
[ [ dup 2^ 2array ] 5 napply ] must-infer\r
\r
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
+\r
+[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test\r
+[ ] [ { } 0 firstn ] unit-test\r
+[ "a" ] [ { "a" } 1 firstn ] unit-test\r
-! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.\r
+! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo\r
+! Cavazos, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences sequences.private namespaces math math.ranges\r
-combinators macros quotations fry locals arrays ;\r
+USING: kernel sequences sequences.private namespaces math\r
+math.ranges combinators macros quotations fry arrays ;\r
IN: generalizations\r
\r
MACRO: narray ( n -- quot )\r
- dup [ f <array> ] curry\r
- swap <reversed> [\r
- [ swap [ set-nth-unsafe ] keep ] curry\r
- ] map concat append ;\r
+ [ <reversed> ] [ '[ , f <array> ] ] bi\r
+ [ '[ @ [ , swap set-nth-unsafe ] keep ] ] reduce ;\r
+\r
+MACRO: firstn ( n -- )\r
+ dup zero? [ drop [ drop ] ] [\r
+ [ [ '[ , _ nth-unsafe ] ] map ]\r
+ [ 1- '[ , _ bounds-check 2drop ] ]\r
+ bi prefix '[ , cleave ]\r
+ ] if ;\r
\r
MACRO: npick ( n -- )\r
1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;\r
2 + [ dupd -nrot ] curry ;\r
\r
MACRO: nrev ( n -- quot )\r
- 1 [a,b] [ '[ , -nrot ] ] map concat ;\r
+ 1 [a,b] [ ] [ '[ @ , -nrot ] ] reduce ;\r
\r
MACRO: ndip ( quot n -- )\r
dup saver -rot restorer 3append ;\r
[ ] [ 1+ ] [ ] tri\r
'[ [ , ndup ] dip , -nrot , nslip ] ;\r
\r
-MACRO: ncurry ( n -- ) [ curry ] n*quot ;\r
+MACRO: ncurry ( n -- )\r
+ [ curry ] n*quot ;\r
\r
-MACRO:: nwith ( quot n -- )\r
- [let | n' [ n 1+ ] |\r
- [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ;\r
+MACRO: nwith ( n -- )\r
+ [ with ] n*quot ;\r
\r
MACRO: napply ( n -- )\r
2 [a,b]\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences io.files io.launcher io.encodings.ascii
-io.streams.string http.client sequences.lib combinators
+io.streams.string http.client generalizations combinators
math.parser math.vectors math.intervals interval-maps memoize
csv accessors assocs strings math splitting grouping arrays ;
IN: geo-ip
accessors ;
IN: gesture-logger
-TUPLE: gesture-logger stream ;
+TUPLE: gesture-logger < gadget stream ;
: <gesture-logger> ( stream -- gadget )
- \ gesture-logger construct-gadget
+ \ gesture-logger new-gadget
swap >>stream
{ 100 100 } >>dim
black solid-interior ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words definitions kernel ;
IN: hints
-USING: parser words ;
-: HINTS:
- scan-word parse-definition "specializer" set-word-prop ;
+: HINTS:
+ scan-word
+ [ +inlined+ changed-definition ]
+ [ parse-definition "specializer" set-word-prop ] bi ;
parsing
[ size>> ] [ fill>> ] bi - ; inline
: buffer-empty? ( buffer -- ? )
- fill>> zero? ;
+ fill>> zero? ; inline
: buffer-consume ( n buffer -- )
[ + ] change-pos
: <port> ( handle class -- port )
new swap >>handle ; inline
-TUPLE: buffered-port < port buffer ;
+TUPLE: buffered-port < port { buffer buffer } ;
: <buffered-port> ( handle class -- port )
<port>
: wait-to-read ( port -- eof? )
dup buffer>> buffer-empty? [
dup (wait-to-read) buffer>> buffer-empty?
- ] [ drop f ] if ;
+ ] [ drop f ] if ; inline
M: input-port stream-read1
dup check-disposed
] with-destructors ;
M: buffered-port dispose*
- [ call-next-method ]
- [ [ [ dispose ] when* f ] change-buffer drop ]
- bi ;
+ [ call-next-method ] [ buffer>> dispose ] bi ;
M: port cancel-operation handle>> cancel-operation ;
[ handle>> shutdown ]
bi
] with-destructors ;
+
+! Fast-path optimization
+USING: hints strings io.encodings.utf8 io.encodings.ascii
+io.encodings.private ;
+
+HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
+
+HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
+
+HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
<scrolling-pane>\r
[ <pane-stream> swap display ] keep ;\r
\r
-TUPLE: irc-editor outstream listener client ;\r
+TUPLE: irc-editor < editor outstream listener client ;\r
\r
: <irc-editor> ( pane listener client -- editor )\r
- [ <editor> irc-editor construct-editor\r
+ [ irc-editor new-editor\r
swap >>listener swap <pane-stream> >>outstream\r
] dip client>> >>client ;\r
\r
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl
+jamshred.player jamshred.log kernel math math.constants namespaces
+sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
+ui.gestures ui.render math.vectors math.geometry.rect ;
IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
-cons
-lists
-sequences
+collections
self pos ori turtle opengl.camera
lsys.tortoise lsys.tortoise.graphics
lsys.strings.rewrite lsys.strings.interpret
- combinators.short-circuit ;
+ combinators.short-circuit accessors ;
! lsys.strings
! lsys.strings.rewrite
: lsys-controller ( -- )
+<pile>
+
{
[ "Load" <label> reverse-video-theme ]
[ pos> norm reset-turtle 45 turn-left 45 pitch-up step-turtle 180 turn-left ]
camera-action <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system control" open-window ;
+}
+
+[ call add-gadget ] each
+1 >>fill
+"L-system control" open-window ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: model-chooser ( -- )
-
+<pile>
{
[ "abop-1" <label> [ drop abop-1 build-model ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2 build-model ] closed-quot <bevel-button> ]
[ "airhorse" <label> [ drop airhorse build-model ] closed-quot <bevel-button> ]
[ "spiral-0" <label> [ drop spiral-0 build-model ] closed-quot <bevel-button> ]
[ "koch" <label> [ drop koch build-model ] closed-quot <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system models" open-window ;
+}
+[ call add-gadget ] each
+1 >>fill
+"L-system models" open-window ;
: scene-chooser ( -- )
+<pile>
{
[ "abop-1" <label> [ drop abop-1-scene ] closed-quot <bevel-button> ]
[ "abop-2" <label> [ drop abop-2-scene ] closed-quot <bevel-button> ]
[ "tree-5" <label> [ drop tree-5-scene ] closed-quot <bevel-button> ]
-} make*
-[ [ gadget, ] curry ] map concat ! Hack
-make-pile 1 over set-pack-fill "L-system scenes" open-window ;
+}
+[ call add-gadget ] each
+1 >>fill
+"L-system scenes" open-window ;
: lsys-window* ( -- )
[ lsys-controller lsys-viewer ] with-ui ;
--- /dev/null
+USING: help.markup help.syntax ;
+
+IN: math.geometry.rect
+
+HELP: rect
+{ $class-description "A rectangle with the following slots:"
+ { $list
+ { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
+ { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
+ }
+ "Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
+} ;
+
+HELP: <rect> ( loc dim -- rect )
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
+{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
+
+{ <zero-rect> <rect> <extent-rect> } related-words
+
+HELP: set-rect-dim ( dim rect -- )
+{ $values { "dim" "a pair of integers" } { "rect" rect } }
+{ $description "Modifies the dimensions of a rectangle." }
+{ $side-effects "rect" } ;
+
+HELP: rect-bounds
+{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
+{ $description "Outputs the location and dimensions of a rectangle." } ;
+
+{ rect-bounds rect-extent } related-words
+
+HELP: <extent-rect> ( loc ext -- rect )
+{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
+{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
+
+HELP: rect-extent
+{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
+{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
+
+HELP: offset-rect
+{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
+{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
+
+HELP: rect-intersect
+{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
+{ $description "Computes the intersection of two rectangles." } ;
+
+HELP: intersects?
+{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
+{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
+
+HELP: <zero-rect>
+{ $values { "rect" "a new " { $link rect } } }
+{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
+
--- /dev/null
+
+USING: tools.test math.geometry.rect ;
+
+IN: math.geometry.rect.tests
+
+[ T{ rect f { 10 10 } { 20 20 } } ]
+[
+ T{ rect f { 10 10 } { 50 50 } }
+ T{ rect f { -10 -10 } { 40 40 } }
+ rect-intersect
+] unit-test
+
+[ T{ rect f { 200 200 } { 0 0 } } ]
+[
+ T{ rect f { 100 100 } { 50 50 } }
+ T{ rect f { 200 200 } { 40 40 } }
+ rect-intersect
+] unit-test
+
+[ f ] [
+ T{ rect f { 100 100 } { 50 50 } }
+ T{ rect f { 200 200 } { 40 40 } }
+ intersects?
+] unit-test
+
+[ t ] [
+ T{ rect f { 100 100 } { 50 50 } }
+ T{ rect f { 120 120 } { 40 40 } }
+ intersects?
+] unit-test
+
+[ f ] [
+ T{ rect f { 1000 100 } { 50 50 } }
+ T{ rect f { 120 120 } { 40 40 } }
+ intersects?
+] unit-test
+
--- /dev/null
+
+USING: kernel arrays math.vectors ;
+
+IN: math.geometry.rect
+
+TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
+
+: <zero-rect> ( -- rect ) rect new ;
+
+C: <rect> rect
+
+M: array rect-loc ;
+
+M: array rect-dim drop { 0 0 } ;
+
+: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
+
+: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
+
+: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
+ [ rect-extent ] bi@ swapd ;
+
+: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
+
+: offset-rect ( rect loc -- newrect )
+ over rect-loc v+ swap rect-dim <rect> ;
+
+: (rect-intersect) ( rect rect -- array array )
+ 2rect-extent vmin >r vmax r> ;
+
+: rect-intersect ( rect1 rect2 -- newrect )
+ (rect-intersect) <extent-rect> ;
+
+: intersects? ( rect/point rect -- ? )
+ (rect-intersect) [v-] { 0 0 } = ;
+
+: (rect-union) ( rect rect -- array array )
+ 2rect-extent vmax >r vmin r> ;
+
+: rect-union ( rect1 rect2 -- newrect )
+ (rect-union) <extent-rect> ;
+
--- /dev/null
+
+USING: kernel sequences multi-methods accessors math.vectors ;
+
+IN: math.physics.pos
+
+TUPLE: pos pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: distance ( a b -- c )
+
+METHOD: distance { sequence sequence } v- norm ;
+
+METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: math.physics.pos ;
+
+IN: math.physics.vel
+
+TUPLE: vel < pos vel ;
+
ARTICLE: "ranges" "Ranges"
- "A " { $emphasis "range" } " is a virtual sequence with elements "
- "ranging from a to b by step."
+ "A " { $emphasis "range" } " is a virtual sequence with real elements "
+ "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
$nl
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order ;
+math.order math.geometry.rect ;
IN: maze
: line-width 8 ;
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
{ $subsection activate-model }
{ $subsection deactivate-model }
-{ $subsection "models-impl" } ;
+{ $subsection "models-impl" }
+{ $subsection "models-filter" }
+{ $subsection "models-compose" }
+{ $subsection "models-history" }
+{ $subsection "models-range" }
+{ $subsection "models-delay" } ;
ARTICLE: "models-impl" "Implementing models"
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
! USING: kernel quotations namespaces sequences assocs.lib ;
USING: kernel namespaces namespaces.private quotations sequences
- assocs.lib math.parser math sequences.lib locals mirrors ;
+ assocs.lib math.parser math generalizations locals mirrors ;
IN: namespaces.lib
ui.gadgets ui.render ;
IN: nehe.2
-TUPLE: nehe2-gadget ;
+TUPLE: nehe2-gadget < gadget ;
: width 256 ;
: height 256 ;
: <nehe2-gadget> ( -- gadget )
- nehe2-gadget construct-gadget ;
+ nehe2-gadget new-gadget ;
M: nehe2-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
ui.gadgets ui.render ;
IN: nehe.3
-TUPLE: nehe3-gadget ;
+TUPLE: nehe3-gadget < gadget ;
: width 256 ;
: height 256 ;
: <nehe3-gadget> ( -- gadget )
- nehe3-gadget construct-gadget ;
+ nehe3-gadget new-gadget ;
M: nehe3-gadget pref-dim* ( gadget -- dim )
drop width height 2array ;
ui.gadgets ui.render threads ;
IN: nehe.4
-TUPLE: nehe4-gadget rtri rquad thread quit? ;
+TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
: width 256 ;
: height 256 ;
: redraw-interval 10 ;
: <nehe4-gadget> ( -- gadget )
- nehe4-gadget construct-gadget
+ nehe4-gadget new-gadget
0.0 over set-nehe4-gadget-rtri
0.0 over set-nehe4-gadget-rquad ;
ui.gadgets ui.render threads ;\r
IN: nehe.5\r
\r
-TUPLE: nehe5-gadget rtri rquad thread quit? ;\r
+TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;\r
: width 256 ;\r
: height 256 ;\r
: redraw-interval 10 ;\r
\r
: <nehe5-gadget> ( -- gadget )\r
- nehe5-gadget construct-gadget\r
+ nehe5-gadget new-gadget\r
0.0 over set-nehe5-gadget-rtri\r
0.0 over set-nehe5-gadget-rquad ;\r
\r
: nehe-window ( -- )
[
- [
- "Nehe 2" [ drop run2 ] <bevel-button> gadget,
- "Nehe 3" [ drop run3 ] <bevel-button> gadget,
- "Nehe 4" [ drop run4 ] <bevel-button> gadget,
- "Nehe 5" [ drop run5 ] <bevel-button> gadget,
- ] make-filled-pile "Nehe examples" open-window
+ <filled-pile>
+ "Nehe 2" [ drop run2 ] <bevel-button> add-gadget
+ "Nehe 3" [ drop run3 ] <bevel-button> add-gadget
+ "Nehe 4" [ drop run4 ] <bevel-button> add-gadget
+ "Nehe 5" [ drop run5 ] <bevel-button> add-gadget
+ "Nehe examples" open-window
] with-ui ;
MAIN: nehe-window
SYMBOL: last-drag-loc
-TUPLE: demo-gadget yaw pitch distance ;
+TUPLE: demo-gadget < gadget yaw pitch distance ;
-: <demo-gadget> ( yaw pitch distance -- gadget )
- demo-gadget construct-gadget
+: new-demo-gadget ( yaw pitch distance class -- gadget )
+ new-gadget
swap >>distance
swap >>pitch
swap >>yaw ;
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
: yaw-demo-gadget ( yaw gadget -- )
- [ [ demo-gadget-yaw + ] keep set-demo-gadget-yaw ] keep relayout-1 ;
+ [ + ] with change-yaw relayout-1 ;
: pitch-demo-gadget ( pitch gadget -- )
- [ [ demo-gadget-pitch + ] keep set-demo-gadget-pitch ] keep relayout-1 ;
+ [ + ] with change-pitch relayout-1 ;
: zoom-demo-gadget ( distance gadget -- )
- [ [ demo-gadget-distance + ] keep set-demo-gadget-distance ] keep relayout-1 ;
+ [ + ] with change-distance relayout-1 ;
M: demo-gadget pref-dim* ( gadget -- dim )
drop { 640 480 } ;
: -+ ( x -- -x x )
- dup neg swap ;
+ [ neg ] keep ;
: demo-gadget-frustum ( gadget -- -x x -y y near far )
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes inference inference.dataflow io kernel
-kernel.private math.parser namespaces optimizer prettyprint
-prettyprint.backend sequences words arrays match macros
-assocs sequences.private optimizer.specializers generic
-combinators sorting math quotations accessors ;
+USING: classes io kernel kernel.private math.parser namespaces
+optimizer prettyprint prettyprint.backend sequences words arrays
+match macros assocs sequences.private generic combinators
+sorting math quotations accessors inference inference.dataflow
+optimizer.specializers ;
IN: optimizer.debugger
! A simple tool for turning dataflow IR into quotations, for
: pretty-shuffle ( in out -- word/f )
2array {
- { { { ?a } { } } drop }
- { { { ?a ?b } { } } 2drop }
- { { { ?a ?b ?c } { } } 3drop }
- { { { ?a } { ?a ?a } } dup }
- { { { ?a ?b } { ?a ?b ?a ?b } } 2dup }
- { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } 3dup }
- { { { ?a ?b } { ?a ?b ?a } } over }
- { { { ?b ?a } { ?a ?b } } swap }
- { { { ?a ?b ?c } { ?a ?b ?c ?a } } pick }
- { { { ?a ?b ?c } { ?c ?a ?b } } -rot }
- { { { ?a ?b ?c } { ?b ?c ?a } } rot }
- { { { ?a ?b } { ?b } } nip }
+ { { { ?a } { ?a } } [ ] }
+ { { { ?a ?b } { ?a ?b } } [ ] }
+ { { { ?a ?b ?c } { ?a ?b ?c } } [ ] }
+ { { { ?a } { } } [ drop ] }
+ { { { ?a ?b } { } } [ 2drop ] }
+ { { { ?a ?b ?c } { } } [ 3drop ] }
+ { { { ?a } { ?a ?a } } [ dup ] }
+ { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] }
+ { { { ?a ?b } { ?a ?b ?a } } [ over ] }
+ { { { ?b ?a } { ?a ?b } } [ swap ] }
+ { { { ?a ?b } { ?b ?a ?b } } [ tuck ] }
+ { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] }
+ { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] }
+ { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
+ { { { ?a ?b } { ?b } } [ nip ] }
+ { { { ?a ?b ?c } { ?c } } [ 2nip ] }
{ _ f }
} match-choose ;
M: #shuffle node>quot
dup [ in-d>> ] [ out-d>> ] bi pretty-shuffle
- [ , ] [ >r drop t r> ] if*
+ [ % ] [ >r drop t r> ] if*
dup effect-str "#shuffle: " prepend comment, ;
: pushed-literals ( node -- seq )
! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
- vectors arrays math.parser math.order vectors combinators combinators.lib
+ vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ;
combinators.cleave
rewrite-closures fry accessors newfx
processing.color
- processing.gadget ;
+ processing.gadget math.geometry.rect ;
IN: processing
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
-[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
-
-[ ] [ { } 0 firstn ] unit-test
-[ "a" ] [ { "a" } 1 firstn ] unit-test
-
[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
-MACRO: firstn ( n -- )
- [ [ swap nth ] curry [ keep ] curry ] map
- concat >quotation
- [ drop ] compose ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: each-percent ( seq quot -- )
}
;
-TUPLE: spheres-gadget
+TUPLE: spheres-gadget < demo-gadget
plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer
reflection-texture ;
: <spheres-gadget> ( -- gadget )
- 20.0 10.0 20.0 <demo-gadget>
- { set-delegate } spheres-gadget construct ;
+ 20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
M: spheres-gadget near-plane ( gadget -- z )
drop 1.0 ;
USING: kernel combinators sequences arrays math math.vectors
- generalizations vars ;
+ generalizations vars accessors math.physics.vel ;
IN: springies
! node
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-TUPLE: node mass elas pos vel force ;
+TUPLE: node < vel mass elas force ;
C: <node> node
-: >>pos ( node pos -- node ) over set-node-pos ;
+: node-vel ( node -- vel ) vel>> ;
-: >>vel ( node vel -- node ) over set-node-vel ;
+: set-node-vel ( vel node -- ) swap >>vel drop ;
-: pos-x ( node -- x ) node-pos first ;
-: pos-y ( node -- y ) node-pos second ;
-: vel-x ( node -- y ) node-vel first ;
-: vel-y ( node -- y ) node-vel second ;
+: pos-x ( node -- x ) pos>> first ;
+: pos-y ( node -- y ) pos>> second ;
+: vel-x ( node -- y ) vel>> first ;
+: vel-y ( node -- y ) vel>> second ;
-: >>pos-x ( node x -- node ) over node-pos set-first ;
-: >>pos-y ( node y -- node ) over node-pos set-second ;
-: >>vel-x ( node x -- node ) over node-vel set-first ;
-: >>vel-y ( node y -- node ) over node-vel set-second ;
+: >>pos-x ( node x -- node ) over pos>> set-first ;
+: >>pos-y ( node y -- node ) over pos>> set-second ;
+: >>vel-x ( node x -- node ) over vel>> set-first ;
+: >>vel-y ( node y -- node ) over vel>> set-second ;
-: apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
+: apply-force ( node vec -- ) over force>> v+ >>force drop ;
-: reset-force ( node -- ) 0 0 2array swap set-node-force ;
+: reset-force ( node -- node ) 0 0 2array >>force ;
: node-id ( id -- node ) 1- nodes> nth ;
C: <spring> spring
: end-points ( spring -- b-pos a-pos )
- [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ;
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi ;
: spring-length ( spring -- length ) end-points v- norm ;
: stretch-length ( spring -- length )
- [ spring-length ] [ spring-rest-length ] bi - ;
+ [ spring-length ] [ rest-length>> ] bi - ;
: dir ( spring -- vec ) end-points v- normalize ;
!
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ;
+: hooke-force-mag ( spring -- mag ) [ k>> ] [ stretch-length ] bi * ;
: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ;
: hooke-forces ( spring -- a b ) hooke-force dup vneg ;
: act-on-nodes-hooke ( spring -- )
- [ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd
+ [ node-a>> ] [ node-b>> ] [ ] tri hooke-forces swapd
apply-force
apply-force ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-velocity-a ( spring -- vel )
- [ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ;
+ [ node-a>> vel>> ] [ node-b>> vel>> ] bi v- ;
: unit-vec-b->a ( spring -- vec )
- [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ;
+ [ node-a>> pos>> ] [ node-b>> pos>> ] bi v- ;
: relative-velocity-along-spring-a ( spring -- vel )
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
: damping-force-a ( spring -- vec )
- [ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ;
+ [ relative-velocity-along-spring-a ] [ damp>> ] bi v*n vneg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-velocity-b ( spring -- vel )
- [ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ;
+ [ node-b>> vel>> ] [ node-a>> vel>> ] bi v- ;
: unit-vec-a->b ( spring -- vec )
- [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ;
+ [ node-b>> pos>> ] [ node-a>> pos>> ] bi v- ;
: relative-velocity-along-spring-b ( spring -- vel )
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
: damping-force-b ( spring -- vec )
- [ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ;
+ [ relative-velocity-along-spring-b ] [ damp>> ] bi v*n vneg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: act-on-nodes-damping ( spring -- )
dup
- [ spring-node-a ] [ damping-force-a ] bi apply-force
- [ spring-node-b ] [ damping-force-b ] bi apply-force ;
+ [ node-a>> ] [ damping-force-a ] bi apply-force
+ [ node-b>> ] [ damping-force-b ] bi apply-force ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bounce-top ( node -- )
world-height 1- >>pos-y
- dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
drop ;
: bounce-bottom ( node -- )
0 >>pos-y
- dup [ vel-y ] [ node-elas ] bi * neg >>vel-y
+ dup [ vel-y ] [ elas>> ] bi * neg >>vel-y
drop ;
: bounce-left ( node -- )
0 >>pos-x
- dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
drop ;
: bounce-right ( node -- )
world-width 1- >>pos-x
- dup [ vel-x ] [ node-elas ] bi * neg >>vel-x
+ dup [ vel-x ] [ elas>> ] bi * neg >>vel-x
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! F = ma
-: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
+: calc-acceleration ( node -- vec ) [ force>> ] [ mass>> ] bi v/n ;
: new-vel ( node -- vel )
- [ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ;
+ [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
-: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ;
+: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
: iterate-node ( node -- )
dup new-pos >>pos
dup new-vel >>vel
- dup reset-force
+ reset-force
handle-bounce ;
: iterate-nodes ( -- ) nodes> [ iterate-node ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mass ( id x y x-vel y-vel mass elas -- )
- 7 nrot drop
- 6 nrot 6 nrot 2array
- 5 nrot 5 nrot 2array
- 0 0 2array <node>
- nodes> swap suffix >nodes ;
+ node new
+ swap >>elas
+ swap >>mass
+ -rot 2array >>vel
+ -rot 2array >>pos
+ 0 0 2array >>force
+ nodes> swap suffix >nodes
+ drop ;
: spng ( id id-a id-b k damp rest-length -- )
- 6 nrot drop
- -rot
- 5 nrot node-id
- 5 nrot node-id
- <spring>
- springs> swap suffix >springs ;
+ spring new
+ swap >>rest-length
+ swap >>damp
+ swap >>k
+ swap node-id >>node-b
+ swap node-id >>node-a
+ springs> swap suffix >springs
+ drop ;
\ No newline at end of file
USING: kernel namespaces threads sequences math math.vectors
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
- fry rewrite-closures vars springies ;
+ fry rewrite-closures vars springies accessors math.geometry.rect ;
IN: springies.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
+: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
: draw-spring ( spring -- )
- [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ;
+ [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ;
: draw-nodes ( -- ) nodes> [ draw-node ] each ;
! See http://factorcode.org/license.txt for BSD license.
USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
-tetris.game tetris.gl sequences system math math.parser namespaces ;
+tetris.game tetris.gl sequences system math math.parser namespaces
+math.geometry.rect ;
IN: tetris
TUPLE: tetris-gadget tetris alarm ;
"if-intrinsics"
"infer"
"inferred-effect"
+ "input-classes"
"interval"
"intrinsics"
"loc"
C: <foo> foo
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
-[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
+[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting grouping classes.tuple classes math kernel
-sequences arrays ;
+sequences arrays accessors ;
IN: tuple-arrays
-TUPLE: tuple-array example ;
-
-: prepare-example ( tuple -- seq n )
- dup class over delegate [ 1array ] [ f 2array ] if
- swap tuple>array length over length - ;
+TUPLE: tuple-array seq class ;
: <tuple-array> ( length example -- tuple-array )
- prepare-example [ rot * { } new-sequence ] keep
- <sliced-groups> tuple-array construct-delegate
- [ set-tuple-array-example ] keep ;
-
-: reconstruct ( seq example -- tuple )
- prepend >tuple ;
+ [ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
+ [ class ] bi tuple-array boa ;
M: tuple-array nth
- [ delegate nth ] keep
- tuple-array-example reconstruct ;
+ [ seq>> nth ] [ class>> ] bi prefix >tuple ;
-: deconstruct ( tuple example -- seq )
- >r tuple>array r> length tail-slice ;
+: deconstruct ( tuple -- seq )
+ tuple>array 1 tail ;
M: tuple-array set-nth ( elt n seq -- )
- tuck >r >r tuple-array-example deconstruct r> r>
- delegate set-nth ;
+ >r >r deconstruct r> r> seq>> set-nth ;
-M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
+M: tuple-array new-sequence
+ class>> new <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq )
dup empty? [
M: tuple-array like
drop dup tuple-array? [ >tuple-array ] unless ;
+M: tuple-array length seq>> length ;
+
INSTANCE: tuple-array sequence
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
-ui.cocoa.views core-foundation threads ;
+ui.cocoa.views core-foundation threads math.geometry.rect ;
IN: ui.cocoa
TUPLE: handle view window ;
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-core-foundation threads combinators ;
+core-foundation threads combinators math.geometry.rect ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences models ui.gadgets ;
+USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
IN: ui.gadgets.books
TUPLE: book < gadget ;
: new-book ( pages model class -- book )
new-gadget
swap >>model
- [ add-gadgets ] keep ; inline
+ [ swap add-gadgets drop ] keep ; inline
: <book> ( pages model -- book )
book new-book ;
IN: ui.gadgets.borders.tests
USING: tools.test accessors namespaces kernel
-ui.gadgets ui.gadgets.borders ;
+ui.gadgets ui.gadgets.borders math.geometry.rect ;
[ { 110 210 } ] [ <gadget> { 100 200 } >>dim 5 <border> pref-dim ] unit-test
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gadgets kernel math
-namespaces vectors sequences math.vectors ;
+namespaces vectors sequences math.vectors math.geometry.rect ;
IN: ui.gadgets.borders
TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border )
- new-gadget [ add-gadget ] keep ; inline
+ new-gadget [ swap add-gadget drop ] keep ; inline
: <border> ( child gap -- border )
swap border new-border
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;
: border-loc ( border dim -- loc )
- [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip v- v* v+ ;
+ [ [ size>> ] [ align>> ] [ border-major-dim ] tri ] dip
+ v- v* v+ [ >fixnum ] map ;
: border-child-rect ( border -- rect )
dup border-dim [ border-loc ] keep <rect> ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
-strings quotations assocs combinators classes colors
-classes.tuple opengl math.vectors
-ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.labels ui.gadgets.theme
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-ui.render ;
+ strings quotations assocs combinators classes colors
+ classes.tuple opengl math.vectors
+ ui.commands ui.gadgets ui.gadgets.borders
+ ui.gadgets.labels ui.gadgets.theme
+ ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ ui.render math.geometry.rect ;
+
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
over set-button-selected?
relayout-1 ;
-: <radio-controls> ( model assoc quot -- )
- #! quot has stack effect ( value model label -- )
- swapd [ swapd call gadget, ] 2curry assoc-each ; inline
+: <radio-controls> ( parent model assoc quot -- parent )
+ #! quot has stack effect ( value model label -- )
+ swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
{ 5 5 } >>gap drop ;
: <radio-buttons> ( model assoc -- gadget )
- [ [ <radio-button> ] <radio-controls> ] make-filled-pile
- dup radio-buttons-theme ;
+ <filled-pile>
+ -rot
+ [ <radio-button> ] <radio-controls>
+ dup radio-buttons-theme ;
: <toggle-button> ( value model label -- gadget )
<radio-control> bevel-button-theme ;
: <toggle-buttons> ( model assoc -- gadget )
- [ [ <toggle-button> ] <radio-controls> ] make-shelf ;
+ <shelf>
+ -rot
+ [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
<bevel-button> ;
: <toolbar> ( target -- toolbar )
- [
- "toolbar" over class command-map commands>> swap
- [ -rot <command-button> gadget, ] curry assoc-each
- ] make-shelf ;
+ <shelf>
+ swap
+ "toolbar" over class command-map commands>> swap
+ [ -rot <command-button> add-gadget ] curry assoc-each ;
: toolbar, ( -- ) g <toolbar> f track, ;
math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
-ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ;
+ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
+math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
USING: kernel alien.c-types combinators sequences splitting grouping
opengl.gl ui.gadgets ui.render
- math math.vectors accessors ;
+ math math.vectors accessors math.geometry.rect ;
IN: ui.gadgets.frame-buffer
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
-splitting grouping math.vectors ui.gadgets.grids ui.gadgets ;
+splitting grouping math.vectors ui.gadgets.grids ui.gadgets
+math.geometry.rect ;
IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center
USING: help.markup help.syntax opengl kernel strings
-classes.tuple classes quotations models ;
+ classes.tuple classes quotations models math.geometry.rect ;
IN: ui.gadgets
-HELP: rect
-{ $class-description "A rectangle with the following slots:"
- { $list
- { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
- { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
- }
- "Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
-} ;
-
-HELP: <rect> ( loc dim -- rect )
-{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
-{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
-
-{ <zero-rect> <rect> <extent-rect> } related-words
-
-HELP: set-rect-dim ( dim rect -- )
-{ $values { "dim" "a pair of integers" } { "rect" rect } }
-{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." }
-{ $side-effects "rect" } ;
-
-HELP: rect-bounds
-{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
-{ $description "Outputs the location and dimensions of a rectangle." } ;
-
-{ rect-bounds rect-extent } related-words
-
-HELP: <extent-rect> ( loc ext -- rect )
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
-{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
-
-HELP: rect-extent
-{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
-
-HELP: offset-rect
-{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
-{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
-
-HELP: rect-intersect
-{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
-{ $description "Computes the intersection of two rectangles." } ;
-
-HELP: intersects?
-{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
-{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
-
HELP: gadget-child
{ $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." }
{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
-HELP: <zero-rect>
-{ $values { "rect" "a new " { $link rect } } }
-{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
-
HELP: <gadget>
{ $values { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new gadget." } ;
{ $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the child of the gadget which would prefer to receive keyboard focus." } ;
-HELP: gadget,
-{ $values { "gadget" gadget } }
-{ $description "Adds a new child to the gadget being constructed. This word can only be used from a quotation passed to " { $link make-gadget } "." } ;
-
HELP: make-gadget
{ $values { "gadget" gadget } { "quot" quotation } }
{ $description "Calls the quotation in a new scope with the gadget stored in the " { $link gadget } " variable." } ;
USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
tools.test namespaces models kernel dlists dequeues math sets
math.parser ui sequences hashtables assocs io arrays prettyprint
-io.streams.string ;
-
-[ T{ rect f { 10 10 } { 20 20 } } ]
-[
- T{ rect f { 10 10 } { 50 50 } }
- T{ rect f { -10 -10 } { 40 40 } }
- rect-intersect
-] unit-test
-
-[ T{ rect f { 200 200 } { 0 0 } } ]
-[
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 200 200 } { 40 40 } }
- rect-intersect
-] unit-test
-
-[ f ] [
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 200 200 } { 40 40 } }
- intersects?
-] unit-test
-
-[ t ] [
- T{ rect f { 100 100 } { 50 50 } }
- T{ rect f { 120 120 } { 40 40 } }
- intersects?
-] unit-test
-
-[ f ] [
- T{ rect f { 1000 100 } { 50 50 } }
- T{ rect f { 120 120 } { 40 40 } }
- intersects?
-] unit-test
+io.streams.string math.geometry.rect ;
[ { 300 300 } ]
[
! c contains b contains a
<gadget> "a" set
<gadget> "b" set
- "a" get "b" get add-gadget
+ "a" get "b" get swap add-gadget drop
<gadget> "c" set
- "b" get "c" get add-gadget
+ "b" get "c" get swap add-gadget drop
! position a and b
{ 100 200 } "a" get set-rect-loc
<gadget> "g3" set
{ 100 200 } "g3" get set-rect-dim
-"g1" get "g2" get add-gadget
-"g2" get "g3" get add-gadget
+"g1" get "g2" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
<gadget> "g1" set
{ 300 300 } "g1" get set-rect-dim
<gadget> "g2" set
-"g2" get "g1" get add-gadget
+"g2" get "g1" get swap add-gadget drop
{ 20 20 } "g2" get set-rect-loc
{ 20 20 } "g2" get set-rect-dim
<gadget> "g3" set
-"g3" get "g1" get add-gadget
+"g3" get "g1" get swap add-gadget drop
{ 100 100 } "g3" get set-rect-loc
{ 20 20 } "g3" get set-rect-dim
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set
-"g4" get "g2" get add-gadget
+"g4" get "g2" get swap add-gadget drop
{ 5 5 } "g4" get set-rect-loc
{ 1 1 } "g4" get set-rect-dim
: add-some-children
3 [
<mock-gadget> over <model> over set-gadget-model
- dup "g" get add-gadget
+ dup "g" get swap add-gadget drop
swap 1+ number>string set
] each ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables kernel models math namespaces
-sequences quotations math.vectors combinators sorting vectors
-dlists dequeues models threads concurrency.flags math.order ;
+ sequences quotations math.vectors combinators sorting vectors
+ dlists dequeues models threads concurrency.flags
+ math.order math.geometry.rect ;
+
IN: ui.gadgets
SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
-TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
-
-: <zero-rect> ( -- rect ) rect new ;
-
-C: <rect> rect
-
-M: array rect-loc ;
-
-M: array rect-dim drop { 0 0 } ;
-
-: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
-
-: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
-
-: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
- [ rect-extent ] bi@ swapd ;
-
-: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
-
-: offset-rect ( rect loc -- newrect )
- over rect-loc v+ swap rect-dim <rect> ;
-
-: (rect-intersect) ( rect rect -- array array )
- 2rect-extent vmin >r vmax r> ;
-
-: rect-intersect ( rect1 rect2 -- newrect )
- (rect-intersect) <extent-rect> ;
-
-: intersects? ( rect/point rect -- ? )
- (rect-intersect) [v-] { 0 0 } = ;
-
-: (rect-union) ( rect rect -- array array )
- 2rect-extent vmax >r vmin r> ;
-
-: rect-union ( rect1 rect2 -- newrect )
- (rect-union) <extent-rect> ;
-
TUPLE: gadget < rect
-pref-dim parent children orientation focus
-visible? root? clipped? layout-state graft-state graft-node
-interior boundary
-model ;
+ pref-dim parent children orientation focus
+ visible? root? clipped? layout-state graft-state graft-node
+ interior boundary
+ model ;
M: gadget equal? 2drop f ;
M: gadget model-changed 2drop ;
-: gadget-child ( gadget -- child ) gadget-children first ;
+: gadget-child ( gadget -- child ) children>> first ;
-: nth-gadget ( n gadget -- child ) gadget-children nth ;
+: nth-gadget ( n gadget -- child ) children>> nth ;
: new-gadget ( class -- gadget )
new
gadget new-gadget ;
: activate-control ( gadget -- )
- dup gadget-model dup [
+ dup model>> dup [
2dup add-connection
swap model-changed
] [
] if ;
: deactivate-control ( gadget -- )
- dup gadget-model dup [ 2dup remove-connection ] when 2drop ;
+ dup model>> dup [ 2dup remove-connection ] when 2drop ;
: control-value ( control -- value )
- gadget-model model-value ;
+ model>> model-value ;
: set-control-value ( value control -- )
- gadget-model set-model ;
+ model>> set-model ;
: relative-loc ( fromgadget togadget -- loc )
2dup eq? [
2drop { 0 0 }
] [
over rect-loc >r
- >r gadget-parent r> relative-loc
+ >r parent>> r> relative-loc
r> v+
] if ;
GENERIC: children-on ( rect/point gadget -- seq )
-M: gadget children-on nip gadget-children ;
+M: gadget children-on nip children>> ;
: (fast-children-on) ( dim axis gadgets -- i )
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
: fast-children-on ( rect axis children -- from to )
- 3dup
- >r >r dup rect-loc swap rect-dim v+
- r> r> (fast-children-on) ?1+
- >r
- >r >r rect-loc
- r> r> (fast-children-on) 0 or
- r> ;
+ [ >r >r rect-loc r> r> (fast-children-on) 0 or ]
+ [ >r >r dup rect-loc swap rect-dim v+ r> r> (fast-children-on) ?1+ ]
+ 3bi ;
: inside? ( bounds gadget -- ? )
- dup gadget-visible? [ intersects? ] [ 2drop f ] if ;
+ dup visible?>> [ intersects? ] [ 2drop f ] if ;
: (pick-up) ( point gadget -- gadget )
dupd children-on [ inside? ] with find-last nip ;
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
: orient ( gadget seq1 seq2 -- seq )
- >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
+ >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
: each-child ( gadget quot -- )
- >r gadget-children r> each ; inline
+ >r children>> r> each ; inline
! Selection protocol
GENERIC: gadget-selection? ( gadget -- ? )
GENERIC: gadget-text-separator ( gadget -- str )
M: gadget gadget-text-separator
- gadget-orientation { 0 1 } = "\n" "" ? ;
+ orientation>> { 0 1 } = "\n" "" ? ;
: gadget-seq-text ( seq gadget -- )
gadget-text-separator swap
[ dup % ] [ gadget-text* ] interleave drop ;
M: gadget gadget-text*
- dup gadget-children swap gadget-seq-text ;
+ dup children>> swap gadget-seq-text ;
M: array gadget-text*
[ gadget-text* ] each ;
: gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
: invalidate ( gadget -- )
- \ invalidate swap set-gadget-layout-state ;
+ \ invalidate swap (>>layout-state) ;
-: forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
+: forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
: layout-queue ( -- queue ) \ layout-queue get ;
DEFER: relayout
: invalidate* ( gadget -- )
- \ invalidate* over set-gadget-layout-state
+ \ invalidate* over (>>layout-state)
dup forget-pref-dim
dup gadget-root?
- [ layout-later ] [ gadget-parent [ relayout ] when* ] if ;
+ [ layout-later ] [ parent>> [ relayout ] when* ] if ;
: relayout ( gadget -- )
- dup gadget-layout-state \ invalidate* eq?
+ dup layout-state>> \ invalidate* eq?
[ drop ] [ invalidate* ] if ;
: relayout-1 ( gadget -- )
- dup gadget-layout-state
+ dup layout-state>>
[ drop ] [ dup invalidate layout-later ] if ;
-: show-gadget ( gadget -- ) t swap set-gadget-visible? ;
+: show-gadget ( gadget -- ) t swap (>>visible?) ;
-: hide-gadget ( gadget -- ) f swap set-gadget-visible? ;
+: hide-gadget ( gadget -- ) f swap (>>visible?) ;
: (set-rect-dim) ( dim gadget quot -- )
>r 2dup rect-dim =
GENERIC: pref-dim* ( gadget -- dim )
: ?set-gadget-pref-dim ( dim gadget -- )
- dup gadget-layout-state
- [ 2drop ] [ set-gadget-pref-dim ] if ;
+ dup layout-state>>
+ [ 2drop ] [ (>>pref-dim) ] if ;
: pref-dim ( gadget -- dim )
- dup gadget-pref-dim [ ] [
+ dup pref-dim>> [ ] [
[ pref-dim* dup ] keep ?set-gadget-pref-dim
] ?if ;
: prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
-: validate ( gadget -- ) f swap set-gadget-layout-state ;
+: validate ( gadget -- ) f swap (>>layout-state) ;
: layout ( gadget -- )
- dup gadget-layout-state [
+ dup layout-state>> [
dup validate
dup layout*
dup [ layout ] each-child
{ t f } (queue-graft) ;
: graft-later ( gadget -- )
- dup gadget-graft-state {
+ dup graft-state>> {
{ { f t } [ drop ] }
{ { t t } [ drop ] }
{ { t f } [ unqueue-graft ] }
} case ;
: ungraft-later ( gadget -- )
- dup gadget-graft-state {
+ dup graft-state>> {
{ { f f } [ drop ] }
{ { t f } [ drop ] }
{ { f t } [ unqueue-graft ] }
: (unparent) ( gadget -- )
dup ungraft
dup forget-pref-dim
- f swap set-gadget-parent ;
+ f swap (>>parent) ;
: unfocus-gadget ( child gadget -- )
- tuck gadget-focus eq?
- [ f swap set-gadget-focus ] [ drop ] if ;
+ tuck focus>> eq?
+ [ f swap (>>focus) ] [ drop ] if ;
SYMBOL: in-layout?
: unparent ( gadget -- )
not-in-layout
[
- dup gadget-parent dup [
+ dup parent>> dup [
over (unparent)
[ unfocus-gadget ] 2keep
- [ gadget-children delete ] keep
+ [ children>> delete ] keep
relayout
] [
2drop
: (clear-gadget) ( gadget -- )
dup [ (unparent) ] each-child
- f over set-gadget-focus
- f swap set-gadget-children ;
+ f over (>>focus)
+ f swap (>>children) ;
: clear-gadget ( gadget -- )
not-in-layout
dup (clear-gadget) relayout ;
-: ((add-gadget)) ( gadget box -- )
- [ gadget-children ?push ] keep set-gadget-children ;
+: ((add-gadget)) ( parent child -- parent )
+ over children>> ?push >>children ;
-: (add-gadget) ( gadget box -- )
- over unparent
- dup pick set-gadget-parent
- [ ((add-gadget)) ] 2keep
- gadget-graft-state second [ graft ] [ drop ] if ;
+: (add-gadget) ( parent child -- parent )
+ dup unparent
+ over >>parent
+ tuck ((add-gadget))
+ tuck graft-state>> second
+ [ graft ]
+ [ drop ]
+ if ;
-: add-gadget ( gadget parent -- )
+: add-gadget ( parent child -- parent )
not-in-layout
- [ (add-gadget) ] keep relayout ;
-
-: add-gadgets ( seq parent -- )
+ (add-gadget)
+ dup relayout ;
+
+: add-gadgets ( parent children -- parent )
not-in-layout
- swap [ over (add-gadget) ] each relayout ;
+ [ (add-gadget) ] each
+ dup relayout ;
: parents ( gadget -- seq )
- [ gadget-parent ] follow ;
+ [ parent>> ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
parents { 0 0 } [ rect-loc v+ ] reduce ;
: (screen-rect) ( gadget -- loc ext )
- dup gadget-parent [
+ dup parent>> [
>r rect-extent r> (screen-rect)
>r tuck v+ r> vmin >r v+ r>
] [
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup not ] [ 2drop f ] }
- [ gadget-parent child? ]
+ [ parent>> child? ]
} cond ;
GENERIC: focusable-child* ( gadget -- child/t )
GENERIC: request-focus-on ( child gadget -- )
-M: gadget request-focus-on gadget-parent request-focus-on ;
+M: gadget request-focus-on parent>> request-focus-on ;
M: f request-focus-on 2drop ;
[ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq )
- [ gadget-focus ] follow ;
-
-: gadget, ( gadget -- ) gadget get add-gadget ;
+ [ focus>> ] follow ;
: g ( -- gadget ) gadget get ;
! Deprecated
: set-gadget-delegate ( gadget tuple -- )
over [
- dup pick [ set-gadget-parent ] with each-child
+ dup pick [ (>>parent) ] with each-child
] when set-delegate ;
: construct-gadget ( class -- tuple )
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces opengl opengl.gl sequences
-math.vectors ui.gadgets ui.gadgets.grids ui.render ;
+math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
IN: ui.gadgets.grid-lines
TUPLE: grid-lines color ;
USING: ui.gadgets ui.gadgets.grids tools.test kernel arrays
-namespaces ;
+namespaces math.geometry.rect ;
IN: ui.gadgets.grids.tests
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets columns accessors ;
+io.streams.string math.vectors ui.gadgets columns accessors
+math.geometry.rect ;
IN: ui.gadgets.grids
TUPLE: grid < gadget
: new-grid ( children class -- grid )
new-gadget
- [ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ;
+ [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
inline
: <grid> ( children -- grid )
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- )
- >r >r 2dup add-gadget r> r>
+ >r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ;
: grid-remove ( grid i j -- )
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces math.vectors ui.gadgets
-ui.gadgets.packs accessors ;
+ui.gadgets.packs accessors math.geometry.rect ;
IN: ui.gadgets.incremental
! Incremental layout allows adding lines to panes to be O(1).
: add-incremental ( gadget incremental -- )
not-in-layout
- 2dup (add-gadget)
+ 2dup swap (add-gadget) drop
over prefer-incremental
over layout-later
2dup incremental-loc
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors classes.tuple ;
+math.vectors classes.tuple math.geometry.rect ;
IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ;
M: list model-changed
nip
dup clear-gadget
- dup <list-items> over add-gadgets
+ dup <list-items> over swap add-gadgets drop
bound-index ;
: selected-rect ( list -- rect )
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
ui.gadgets.worlds ui.gestures generic hashtables kernel math
models namespaces opengl sequences math.vectors
-ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ;
+ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
+math.geometry.rect ;
IN: ui.gadgets.menus
: menu-loc ( world menu -- loc )
: <menu-glass> ( menu world -- glass )
menu-glass new-gadget
>r over menu-loc over set-rect-loc r>
- [ add-gadget ] keep ;
+ [ swap add-gadget drop ] keep ;
M: menu-glass layout* gadget-child prefer ;
: show-glass ( gadget world -- )
over hand-clicked set-global
[ hide-glass ] keep
- [ add-gadget ] 2keep
+ [ swap add-gadget drop ] 2keep
set-world-glass ;
: show-menu ( gadget owner -- )
faint-boundary ;
: <commands-menu> ( hook target commands -- gadget )
- [
- [ >r 2dup r> <menu-item> gadget, ] each 2drop
- ] make-filled-pile 5 <border> menu-theme ;
+ <filled-pile>
+ -roll
+ [ <menu-item> add-gadget ] with with each
+ 5 <border> menu-theme ;
{ $subsection make-pile }
{ $subsection make-filled-pile }
{ $subsection make-shelf }
-{ $subsection gadget, }
+
"For more control, custom layouts can reuse portions of pack layout logic:"
{ $subsection pack-pref-dim }
{ $subsection pack-layout } ;
HELP: make-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically. The quotation can add children by calling the gadget, word." } ;
HELP: make-filled-pile
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets vertically, such that all gadgets have the same width. The quotation can add children by calling the gadget, word." } ;
HELP: make-shelf
{ $values { "quot" quotation } { "pack" "a new " { $link pack } } }
-{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the " { $link gadget, } " word." } ;
+{ $description "Creates a new " { $link pack } " which lays out a sequence of gadgets horizontally. The quotation can add children by calling the gadget, word." } ;
ABOUT: "ui-pack-layout"
IN: ui.gadgets.packs.tests
USING: ui.gadgets.packs ui.gadgets.labels ui.gadgets ui.render
-kernel namespaces tools.test math.parser sequences ;
+kernel namespaces tools.test math.parser sequences math.geometry.rect ;
[ t ] [
{ 0 0 } { 100 100 } <rect> clip set
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets kernel math math.functions
-math.vectors namespaces math.order accessors ;
+math.vectors namespaces math.order accessors math.geometry.rect ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations
-destructors accessors ;
+destructors accessors math.geometry.rect ;
IN: ui.gadgets.panes
TUPLE: pane < pack
drop ;
: add-output ( current pane -- )
- [ set-pane-output ] [ add-gadget ] 2bi ;
+ [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
: add-current ( current pane -- )
- [ set-pane-current ] [ add-gadget ] 2bi ;
+ [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
: prepare-line ( pane -- )
[ clear-selection ]
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget
- pane-stream-pane pane-current add-gadget ;
+ pane-stream-pane pane-current swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
: gadget-write ( string gadget -- )
over empty?
- [ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
+ [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- )
- >r " " <word-break-gadget> style-label r> add-gadget ;
+ >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
M: paragraph stream-write
swap " " split
: gadget-format ( string style stream -- )
pick empty?
- [ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ;
+ [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
M: pack stream-format
gadget-format ;
! Copyright (C) 2005, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
-namespaces sequences math.order ;
+namespaces sequences math.order math.geometry.rect ;
IN: ui.gadgets.paragraphs
! A word break gadget
USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
-ui.gadgets.sliders ;
+ui.gadgets.sliders math.geometry.rect ;
IN: ui.gadgets.scrollers
HELP: scroller
kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences
-tools.test.ui ;
+tools.test.ui math.geometry.rect ;
[ ] [
<gadget> "g" set
<gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" set
-"g2" get "g1" get add-gadget
+"g2" get "g1" get swap add-gadget drop
"g1" get <scroller>
{ 300 300 } over set-rect-dim
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose
-combinators math.vectors classes.tuple ;
+combinators math.vectors classes.tuple math.geometry.rect ;
IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models models.range math.vectors math.functions
-quotations colors ;
+quotations colors math.geometry.rect ;
IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ;
: elevator, ( orientation -- )
dup <elevator> g-> set-slider-elevator
- swap <thumb> g-> set-slider-thumb over add-gadget
+ swap <thumb> g-> set-slider-thumb add-gadget
@center frame, ;
: <left-button> ( -- button )
[ [ gadget-parent '[ , , , (del-page) ] "X" swap\r
<bevel-button> @right frame, ] 3keep \r
[ swapd <toggle-button> @center frame, ] dip ] make-frame\r
- swap add-gadget ;\r
+ add-gadget drop ;\r
\r
: redo-toggler ( tabbed -- )\r
[ names>> ] [ model>> ] [ toggler>> ] tri\r
[ [ model>> swap ]\r
[ names>> length 1 - swap ]\r
[ toggler>> ] tri add-toggle ]\r
- [ content>> add-gadget ]\r
+ [ content>> swap add-gadget drop ]\r
[ refresh-book ] tri ;\r
\r
: del-page ( name tabbed -- )\r
tabbed new-frame\r
[ g 0 <model> >>model\r
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add\r
- [ keys g swap >>names ]\r
+ [ keys >vector g swap >>names ]\r
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi\r
g redo-toggler g ] with-gadget ;\r
-USING: kernel ui.gadgets ui.gadgets.tracks tools.test ;
+USING: kernel ui.gadgets ui.gadgets.tracks tools.test math.geometry.rect ;
IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces
-sequences words math.vectors ui.gadgets ui.gadgets.packs ;
+sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ;
IN: ui.gadgets.tracks
TUPLE: track < pack sizes ;
rot gadget-orientation set-axis ;
: track-add ( gadget track constraint -- )
- over track-sizes push add-gadget ;
+ over track-sizes push swap add-gadget drop ;
+
+: track-add* ( track gadget constraint -- track )
+ pick sizes>> push
+ add-gadget ;
: track, ( gadget constraint -- )
gadget get swap track-add ;
! See http://factorcode.org/license.txt for BSD license.
IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders
-kernel math namespaces sequences models math.vectors ;
+kernel math namespaces sequences models math.vectors math.geometry.rect ;
: viewport-gap { 3 3 } ; inline
viewport new-gadget
swap >>model
t >>clipped?
- [ add-gadget ] keep ;
+ [ swap add-gadget drop ] keep ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-
<gadget> "g1" set
<gadget> "g2" set
-"g1" get "g2" get add-gadget
+"g1" get "g2" get swap add-gadget drop
[ ] [
"g2" get <test-world> "w" set
<gadget> "g1" set
<gadget> "g2" set
<gadget> "g3" set
-"g1" get "g3" get add-gadget
-"g2" get "g3" get add-gadget
+"g1" get "g3" get swap add-gadget drop
+"g2" get "g3" get swap add-gadget drop
[ ] [
"g3" get <test-world> "w" set
: <focus-test>
focus-test new-gadget
- <focusing> over add-gadget ;
+ <focusing> over swap add-gadget drop ;
M: focus-test focusable-child* gadget-child ;
USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators math.vectors
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-debugger ;
+debugger math.geometry.rect ;
IN: ui.gadgets.worlds
TUPLE: world < track
: new-wrapper ( child class -- wrapper )
new-gadget
- [ add-gadget ] keep ; inline
+ [ swap add-gadget drop ] keep ; inline
: <wrapper> ( child -- border )
wrapper new-wrapper ;
USING: ui.gadgets ui.gestures help.markup help.syntax
-kernel classes strings opengl.gl models ;
+kernel classes strings opengl.gl models math.geometry.rect ;
IN: ui.render
HELP: gadget
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays hashtables io kernel math namespaces opengl
opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors math.order ;
+combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect ;
IN: ui.render
SYMBOL: clip
"handbook" >link <history> >>history drop ;
: <browser-gadget> ( -- gadget )
- { 0 1 } browser-gadget new-track
+ { 0 1 } browser-gadget new-track
dup init-history
- [
- toolbar,
- g <help-pane> g-> set-browser-gadget-pane
- <scroller> 1 track,
- ] make-gadget ;
+ dup <toolbar> f track-add*
+ dup <help-pane> >>pane
+ dup pane>> <scroller> 1 track-add* ;
M: browser-gadget call-tool* show-help ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
-ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
-ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
-ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
-models namespaces sequences sequences words continuations
-debugger prettyprint ui.tools.traceback help editors ;
+ ui.gadgets.worlds ui.gadgets.packs ui.gadgets.buttons
+ ui.gadgets.labels ui.gadgets.panes ui.gadgets.presentations
+ ui.gadgets.viewports ui.gadgets.lists ui.gadgets.tracks
+ ui.gadgets.scrollers ui.gadgets.panes hashtables io kernel math
+ models namespaces sequences sequences words continuations
+ debugger prettyprint ui.tools.traceback help editors ;
+
IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
TUPLE: debugger < track restarts ;
: <debugger-display> ( restart-list error -- gadget )
- [
- <pane> [ [ print-error ] with-pane ] keep gadget,
- gadget,
- ] make-filled-pile ;
+ <filled-pile>
+ <pane>
+ swapd tuck [ print-error ] with-pane
+ add-gadget
+
+ swap add-gadget ;
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
- [
- toolbar,
- <restart-list> g-> set-debugger-restarts
- swap <debugger-display> <scroller> 1 track,
- ] make-gadget ;
+ dup <toolbar> f track-add*
+ -rot <restart-list> >>restarts
+ dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
M: debugger focusable-child* debugger-restarts ;
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.gadgets colors kernel ui.render namespaces
-models models.mapping sequences ui.gadgets.buttons
-ui.gadgets.packs ui.gadgets.labels tools.deploy.config
-namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
-ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system accessors ;
+ models models.mapping sequences ui.gadgets.buttons
+ ui.gadgets.packs ui.gadgets.labels tools.deploy.config
+ namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+ ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
+ tools.deploy vocabs ui.tools.workspace system accessors ;
+
IN: ui.tools.deploy
TUPLE: deploy-gadget < pack vocab settings ;
-: bundle-name ( -- )
+: bundle-name ( parent -- parent )
deploy-name get <field>
- "Executable name:" label-on-left gadget, ;
+ "Executable name:" label-on-left add-gadget ;
-: deploy-ui ( -- )
+: deploy-ui ( parent -- parent )
deploy-ui? get
- "Include user interface framework" <checkbox> gadget, ;
+ "Include user interface framework" <checkbox> add-gadget ;
-: exit-when-windows-closed ( -- )
+: exit-when-windows-closed ( parent -- parent )
"stop-after-last-window?" get
- "Exit when last UI window closed" <checkbox> gadget, ;
-
-: io-settings ( -- )
- "Input/output support:" <label> gadget,
- deploy-io get deploy-io-options <radio-buttons> gadget, ;
-
-: reflection-settings ( -- )
- "Reflection support:" <label> gadget,
- deploy-reflection get deploy-reflection-options <radio-buttons> gadget, ;
-
-: advanced-settings ( -- )
- "Advanced:" <label> gadget,
- deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
- deploy-math? get "Rational and complex number support" <checkbox> gadget,
- deploy-threads? get "Threading support" <checkbox> gadget,
- deploy-random? get "Random number generator support" <checkbox> gadget,
- deploy-word-props? get "Retain all word properties" <checkbox> gadget,
- deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
- deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
-
-: deploy-settings-theme ( gadget -- )
- { 10 10 } >>gap
- 1 >>fill
- drop ;
+ "Exit when last UI window closed" <checkbox> add-gadget ;
+
+: io-settings ( parent -- parent )
+ "Input/output support:" <label> add-gadget
+ deploy-io get deploy-io-options <radio-buttons> add-gadget ;
+
+: reflection-settings ( parent -- parent )
+ "Reflection support:" <label> add-gadget
+ deploy-reflection get deploy-reflection-options <radio-buttons> add-gadget ;
+
+: advanced-settings ( parent -- parent )
+ "Advanced:" <label> add-gadget
+ deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
+ deploy-math? get "Rational and complex number support" <checkbox> add-gadget
+ deploy-threads? get "Threading support" <checkbox> add-gadget
+ deploy-random? get "Random number generator support" <checkbox> add-gadget
+ deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
+ deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
+ deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
+
+: deploy-settings-theme ( gadget -- gadget )
+ { 10 10 } >>gap
+ 1 >>fill ;
: <deploy-settings> ( vocab -- control )
- default-config [ <model> ] assoc-map [
+ default-config [ <model> ] assoc-map
[
+ <pile>
bundle-name
deploy-ui
os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
- ] make-pile dup deploy-settings-theme
- namespace <mapping> over set-gadget-model
- ] bind ;
+
+ deploy-settings-theme
+ namespace <mapping> over set-gadget-model
+ ]
+ bind ;
: find-deploy-gadget ( gadget -- deploy-gadget )
[ deploy-gadget? ] find-parent ;
{ T{ key-down f f "RET" } com-deploy }
} define-command-map
-: buttons, ( -- )
- g <toolbar> { 10 10 } over set-pack-gap gadget, ;
-
: <deploy-gadget> ( vocab -- gadget )
deploy-gadget new-gadget
- swap >>vocab
- { 0 1 } >>orientation
- [
- g vocab>> <deploy-settings>
- g-> set-deploy-gadget-settings gadget,
- buttons,
- ] make-gadget
- dup deploy-settings-theme
+ over >>vocab
+ { 0 1 } >>orientation
+ swap <deploy-settings> >>settings
+ dup settings>> add-gadget
+ dup <toolbar> { 10 10 } >>gap add-gadget
+ deploy-settings-theme
dup com-revert ;
-
+
: deploy-tool ( vocab -- )
vocab-name dup <deploy-gadget> 10 <border>
"Deploying \"" rot "\"" 3append open-window ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.workspace inspector kernel ui.commands
+USING: accessors ui.tools.workspace inspector kernel ui.commands
ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.slots ui.gadgets.tracks ui.gestures
ui.gadgets.buttons namespaces ;
TUPLE: inspector-gadget < track object pane ;
: refresh ( inspector -- )
- dup inspector-gadget-object swap inspector-gadget-pane [
- H{ { +editable+ t } { +number-rows+ t } } describe*
+ [ object>> ] [ pane>> ] bi [
+ +editable+ on
+ +number-rows+ on
+ describe
] with-pane ;
: <inspector-gadget> ( -- gadget )
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
] make-gadget ;
-: inspect-object ( obj inspector -- )
- [ set-inspector-gadget-object ] keep refresh ;
+: inspect-object ( obj mirror keys inspector -- )
+ 2nip swap >>object refresh ;
\ &push H{ { +nullary+ t } { +listener+ t } } define-command
\ &back H{ { +nullary+ t } { +listener+ t } } define-command
-: globals ( -- ) global inspect ;
-
-\ globals H{ { +nullary+ t } { +listener+ t } } define-command
+\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
: inspector-help ( -- ) "ui-inspector" help-window ;
{ T{ update-object } refresh }
{ f &push }
{ f &back }
- { f globals }
+ { f &globals }
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures
-: <search-model> ( producer -- model )
- >r g live-search-field gadget-model
+: <search-model> ( live-search producer -- live-search filter )
+ >r dup field>> model>> ! live-search model :: producer
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
-: <search-list> ( seq limited? presenter -- gadget )
+: <search-list> ( live-search seq limited? presenter -- live-search list )
>r
[ limited-completions ] [ completions ] ? curry
<search-model>
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- { 0 1 } live-search new-track
- [
- <search-field> g-> set-live-search-field f track,
- <search-list> g-> set-live-search-list
- <scroller> 1 track,
- ] make-gadget
- [ live-search-field set-editor-string ] keep
- [ live-search-field end-of-document ] keep ;
+ { 0 1 } live-search new-track
+ <search-field> >>field
+ dup field>> f track-add*
+ -roll <search-list> >>list
+ dup list>> <scroller> 1 track-add*
+
+ swap
+ over field>> set-editor-string
+ dup field>> end-of-document ;
M: live-search focusable-child* live-search-field ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations kernel models namespaces
-prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
-ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
-ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
-hashtables inspector ;
+ prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
+ ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
+ hashtables inspector ;
+
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
M: traceback-gadget pref-dim* drop { 550 600 } ;
: <traceback-gadget> ( model -- gadget )
- { 0 1 } traceback-gadget new-track
- swap >>model
- [
- g model>>
- [
- [
- [ <datastack-display> 1/2 track, ]
- [ <retainstack-display> 1/2 track, ]
- bi
- ] { 1 0 } make-track 1/3 track,
- ]
- [ <callstack-display> 2/3 track, ] bi
- toolbar,
- ] make-gadget ;
+ { 0 1 } traceback-gadget new-track
+ swap >>model
+
+ dup model>>
+ { 1 0 } <track>
+ over <datastack-display> 1/2 track-add*
+ swap <retainstack-display> 1/2 track-add*
+ 1/3 track-add*
+
+ dup model>> <callstack-display> 2/3 track-add*
+
+ dup <toolbar> f track-add* ;
: <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ]
swap >>continuation
swap >>status
dup continuation>> <traceback-gadget> >>traceback
- [
- toolbar,
- g status>> self <thread-status> f track,
- g traceback>> 1 track,
- ] make-gadget ;
+ dup <toolbar> f track-add*
+ dup status>> self <thread-status> f track-add*
+ dup traceback>> 1 track-add* ;
+
: walker-help ( -- ) "ui-walker" help-window ;
\ walker-help H{ { +nullary+ t } } define-command
USING: help.markup help.syntax strings quotations debugger
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
-ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ;
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
IN: ui
HELP: windows
$nl
"Gadget construction combinators whose names are prefixed with " { $snippet "make-" } " construct new gadgets and push them on the stack. The primitive combinator used to define all combinators of this form:"
{ $subsection make-gadget }
-"Words such as " { $link gadget, } " and " { $link track, } " access the gadget through the " { $link gadget } " variable."
+"Words such as " { $link track, } " access the gadget through the " { $link gadget } " variable."
$nl
"A combinator which stores a gadget in the " { $link gadget } " variable:"
{ $subsection with-gadget }
windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations
command-line shuffle opengl ui.render unicode.case ascii
-math.bitfields locals symbols accessors ;
+math.bitfields locals symbols accessors math.geometry.rect ;
IN: ui.windows
SINGLETON: windows-ui-backend
x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified
-math.vectors classes.tuple opengl.gl threads ;
+math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
QUALIFIED: system
IN: ui.x11
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files io.encodings.ascii sequences sequences.lib
+USING: io.files io.encodings.ascii sequences generalizations
math.parser combinators kernel memoize csv symbols summary
words accessors math.order sorting ;
IN: usa-cities
TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
+TYPEDEF: REFGUID LPGUID
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
return (CELL)get_rel_symbol(rel,literals_start);
case RT_LITERAL:
return CREF(literals_start,REL_ARGUMENT(rel));
+ case RT_IMMEDIATE:
+ return get(CREF(literals_start,REL_ARGUMENT(rel)));
case RT_XT:
return (CELL)untag_word(get(CREF(literals_start,REL_ARGUMENT(rel))))->xt;
case RT_HERE:
/* current offset */
RT_HERE,
/* a local label */
- RT_LABEL
+ RT_LABEL,
+ /* immeditae literal */
+ RT_IMMEDIATE
} F_RELTYPE;
typedef enum {
EPILOGUE
blr
-/* We must pass the XT to the quotation in r11. */
-DEF(void,primitive_call,(void)):
- lwz r3,0(r14) /* load quotation from data stack */
- subi r14,r14,4 /* pop quotation from data stack */
- JUMP_QUOT
-
-/* We must preserve r4 here in case we're calling a primitive */
-DEF(void,primitive_execute,(void)):
- lwz r3,0(r14) /* load word from data stack */
- lwz r11,29(r3) /* load word-xt slot */
- mtctr r11 /* prepare to call XT */
- subi r14,r14,4 /* pop word from data stack */
- bctr /* go */
-
/* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
limitation which would otherwise require us to do a bizzaro PC-relative
trampoline to retrieve the function address */
#define ARG0 %eax
#define ARG1 %edx
-#define XT_REG %ecx
#define STACK_REG %esp
#define DS_REG %esi
#define RETURN_REG %eax
pop %ebx
#define QUOT_XT_OFFSET 9
-#define PROFILING_OFFSET 25
-#define WORD_DEF_OFFSET 13
-#define WORD_XT_OFFSET 29
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
#define ARG0 %rdi
#define ARG1 %rsi
-#define XT_REG %rcx
#define STACK_REG %rsp
#define DS_REG %r14
#define RETURN_REG %rax
pop %rbx
#define QUOT_XT_OFFSET 21
-#define PROFILING_OFFSET 53
-#define WORD_DEF_OFFSET 29
-#define WORD_XT_OFFSET 61
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
-#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0)
-
DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE
push ARG0 /* Save quot */
POP_NONVOLATILE
ret
-DEF(F_FASTCALL void,primitive_call,(void)):
- mov (DS_REG),ARG0 /* Load quotation from data stack */
- sub $CELL_SIZE,DS_REG /* Pop data stack */
- JUMP_QUOT
-
-/* Don't mess up EDX, it's the callstack top parameter to primitives. */
-DEF(F_FASTCALL void,primitive_execute,(void)):
- mov (DS_REG),ARG0 /* Load word from data stack */
- sub $CELL_SIZE,DS_REG /* Pop data stack */
- jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */
-
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG /* rewind_to */
- JUMP_QUOT
+ jmp *QUOT_XT_OFFSET(ARG0)
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
pop ARG1 /* OK to clobber ARG1 here */
pop ARG1
pop ARG1
- JUMP_QUOT /* Call the quotation */
+ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#ifdef WINDOWS
.section .drectve
CELL compiledp;
/* TAGGED call count for profiling */
CELL counter;
+ /* TAGGED machine code for sub-primitive */
+ CELL subprimitive;
/* UNTAGGED execution token: jump here to execute word */
XT xt;
/* UNTAGGED compiled code block */
F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop());
-/* The fixnum arithmetic operations defined in C are relatively slow.
-The Factor compiler has optimized assembly intrinsics for some of these
-operations. */
DEFINE_PRIMITIVE(fixnum_add)
{
POP_FIXNUMS(x,y)
box_signed_cell(x + y);
}
-DEFINE_PRIMITIVE(fixnum_add_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x + y));
-}
-
DEFINE_PRIMITIVE(fixnum_subtract)
{
POP_FIXNUMS(x,y)
box_signed_cell(x - y);
}
-DEFINE_PRIMITIVE(fixnum_subtract_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x - y));
-}
-
/* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
DEFINE_PRIMITIVE(fixnum_multiply)
}
}
-DEFINE_PRIMITIVE(fixnum_multiply_fast)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x * y));
-}
-
DEFINE_PRIMITIVE(fixnum_divint)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x % y));
}
-DEFINE_PRIMITIVE(fixnum_and)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x & y));
-}
-
-DEFINE_PRIMITIVE(fixnum_or)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x | y));
-}
-
-DEFINE_PRIMITIVE(fixnum_xor)
-{
- POP_FIXNUMS(x,y)
- dpush(tag_fixnum(x ^ y));
-}
-
/*
* Note the hairy overflow check.
* If we're shifting right by n bits, we won't overflow as long as none of the
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
}
-DEFINE_PRIMITIVE(fixnum_less)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x < y);
-}
-
-DEFINE_PRIMITIVE(fixnum_lesseq)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x <= y);
-}
-
-DEFINE_PRIMITIVE(fixnum_greater)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x > y);
-}
-
-DEFINE_PRIMITIVE(fixnum_greatereq)
-{
- POP_FIXNUMS(x,y)
- box_boolean(x >= y);
-}
-
-DEFINE_PRIMITIVE(fixnum_not)
-{
- drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
-}
-
/* Bignums */
DEFINE_PRIMITIVE(fixnum_to_bignum)
{
DECLARE_PRIMITIVE(fixnum_add);
DECLARE_PRIMITIVE(fixnum_subtract);
-DECLARE_PRIMITIVE(fixnum_add_fast);
-DECLARE_PRIMITIVE(fixnum_subtract_fast);
DECLARE_PRIMITIVE(fixnum_multiply);
-DECLARE_PRIMITIVE(fixnum_multiply_fast);
DECLARE_PRIMITIVE(fixnum_divint);
DECLARE_PRIMITIVE(fixnum_divmod);
DECLARE_PRIMITIVE(fixnum_mod);
-DECLARE_PRIMITIVE(fixnum_and);
-DECLARE_PRIMITIVE(fixnum_or);
-DECLARE_PRIMITIVE(fixnum_xor);
DECLARE_PRIMITIVE(fixnum_shift);
DECLARE_PRIMITIVE(fixnum_shift_fast);
-DECLARE_PRIMITIVE(fixnum_less);
-DECLARE_PRIMITIVE(fixnum_lesseq);
-DECLARE_PRIMITIVE(fixnum_greater);
-DECLARE_PRIMITIVE(fixnum_greatereq);
-DECLARE_PRIMITIVE(fixnum_not);
CELL bignum_zero;
CELL bignum_pos_one;
#include "master.h"
void *primitives[] = {
- primitive_execute,
- primitive_call,
primitive_bignum_to_fixnum,
primitive_float_to_fixnum,
primitive_fixnum_to_bignum,
primitive_bits_double,
primitive_from_rect,
primitive_fixnum_add,
- primitive_fixnum_add_fast,
primitive_fixnum_subtract,
- primitive_fixnum_subtract_fast,
primitive_fixnum_multiply,
- primitive_fixnum_multiply_fast,
primitive_fixnum_divint,
primitive_fixnum_mod,
primitive_fixnum_divmod,
- primitive_fixnum_and,
- primitive_fixnum_or,
- primitive_fixnum_xor,
- primitive_fixnum_not,
primitive_fixnum_shift,
primitive_fixnum_shift_fast,
- primitive_fixnum_less,
- primitive_fixnum_lesseq,
- primitive_fixnum_greater,
- primitive_fixnum_greatereq,
primitive_bignum_eq,
primitive_bignum_add,
primitive_bignum_subtract,
primitive_float_greatereq,
primitive_word,
primitive_word_xt,
- primitive_drop,
- primitive_2drop,
- primitive_3drop,
- primitive_dup,
- primitive_2dup,
- primitive_3dup,
- primitive_rot,
- primitive__rot,
- primitive_dupd,
- primitive_swapd,
- primitive_nip,
- primitive_2nip,
- primitive_tuck,
- primitive_over,
- primitive_pick,
- primitive_swap,
- primitive_to_r,
- primitive_from_r,
- primitive_eq,
primitive_getenv,
primitive_setenv,
primitive_existsp,
primitive_code_room,
primitive_os_env,
primitive_millis,
- primitive_tag,
primitive_modify_code_heap,
primitive_dlopen,
primitive_dlsym,
primitive_set_alien_cell,
primitive_throw,
primitive_alien_address,
- primitive_slot,
primitive_set_slot,
primitive_string_nth,
primitive_set_string_nth,
#include "master.h"
-/* Simple JIT compiler. This is one of the two compilers implementing Factor;
-the second one is written in Factor and performs a lot of optimizations.
-See core/compiler/compiler.factor */
+/* Simple non-optimizing compiler.
+
+This is one of the two compilers implementing Factor; the second one is written
+in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+
+The non-optimizing compiler compiles a quotation at a time by concatenating
+machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
+code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+
+It actually does do a little bit of very simple optimization:
+
+1) Tail call optimization.
+
+2) If a quotation is determined to not call any other words (except for a few
+special words which are open-coded, see below), then no prolog/epilog is
+generated.
+
+3) When in tail position and immediately preceded by literal arguments, the
+'if' and 'dispatch' conditionals are generated inline, instead of as a call to
+the 'if' word.
+
+4) When preceded by an array, calls to the 'declare' word are optimized out
+entirely. This word is only used by the optimizing compiler, and with the
+non-optimizing compiler it would otherwise just decrease performance to have to
+push the array and immediately drop it after.
+
+5) Sub-primitives are primitive words which are implemented in assembly and not
+in the VM. They are open-coded and no subroutine call is generated. This
+includes stack shufflers, some fixnum arithmetic words, and words such as tag,
+slot and eq?. A primitive call is relatively expensive (two subroutine calls)
+so this results in a big speedup for relatively little effort. */
+
bool jit_primitive_call_p(F_ARRAY *array, CELL i)
{
return (i + 2) == array_capacity(array)
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
}
-F_ARRAY *code_to_emit(CELL name)
+F_ARRAY *code_to_emit(CELL code)
{
- return untag_object(array_nth(untag_object(userenv[name]),0));
+ return untag_object(array_nth(untag_object(code),0));
}
-F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
+F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
CELL rel_argument, bool *rel_p)
{
- F_ARRAY *quadruple = untag_object(userenv[name]);
+ F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3);
CELL obj = array_nth(array,i);
if(type_of(obj) == WORD_TYPE)
{
- if(obj != userenv[JIT_TAG_WORD]
- && obj != userenv[JIT_EQP_WORD]
- && obj != userenv[JIT_SLOT_WORD]
- && obj != userenv[JIT_DROP_WORD]
- && obj != userenv[JIT_DUP_WORD]
- && obj != userenv[JIT_TO_R_WORD]
- && obj != userenv[JIT_FROM_R_WORD]
- && obj != userenv[JIT_SWAP_WORD]
- && obj != userenv[JIT_OVER_WORD]
- && obj != userenv[JIT_FIXNUM_MINUS_WORD]
- && obj != userenv[JIT_FIXNUM_GE_WORD])
- {
+ F_WORD *word = untag_object(obj);
+ if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
return true;
- }
}
}
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- EMIT(JIT_PROLOG,0);
+ EMIT(userenv[JIT_PROLOG],0);
CELL i;
CELL length = array_capacity(untag_object(array));
switch(type_of(obj))
{
case WORD_TYPE:
+ word = untag_object(obj);
+
/* Intrinsics */
- if(obj == userenv[JIT_TAG_WORD])
+ if(word->subprimitive != F)
{
- EMIT(JIT_TAG,0);
- }
- else if(obj == userenv[JIT_EQP_WORD])
- {
- GROWABLE_ARRAY_ADD(literals,T);
- EMIT(JIT_EQP,literals_count - 1);
- }
- else if(obj == userenv[JIT_SLOT_WORD])
- {
- EMIT(JIT_SLOT,0);
- }
- else if(obj == userenv[JIT_DROP_WORD])
- {
- EMIT(JIT_DROP,0);
- }
- else if(obj == userenv[JIT_DUP_WORD])
- {
- EMIT(JIT_DUP,0);
- }
- else if(obj == userenv[JIT_TO_R_WORD])
- {
- EMIT(JIT_TO_R,0);
- }
- else if(obj == userenv[JIT_FROM_R_WORD])
- {
- EMIT(JIT_FROM_R,0);
- }
- else if(obj == userenv[JIT_SWAP_WORD])
- {
- EMIT(JIT_SWAP,0);
- }
- else if(obj == userenv[JIT_OVER_WORD])
- {
- EMIT(JIT_OVER,0);
- }
- else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
- {
- EMIT(JIT_FIXNUM_MINUS,0);
- }
- else if(obj == userenv[JIT_FIXNUM_GE_WORD])
- {
- GROWABLE_ARRAY_ADD(literals,T);
- EMIT(JIT_FIXNUM_GE,literals_count - 1);
+ if(array_nth(untag_object(word->subprimitive),1) != F)
+ {
+ GROWABLE_ARRAY_ADD(literals,T);
+ }
+
+ EMIT(word->subprimitive,literals_count - 1);
}
else
{
- /* Emit the epilog before the primitive call gate
- so that we save the C stack pointer minus the
- current stack frame. */
- word = untag_object(obj);
-
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1)
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
- EMIT(JIT_WORD_JUMP,literals_count - 1);
+ EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
tail_call = true;
}
else
- EMIT(JIT_WORD_CALL,literals_count - 1);
+ EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(JIT_PUSH_LITERAL,literals_count - 1);
+ EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- EMIT(JIT_PRIMITIVE,to_fixnum(obj));
+ EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++;
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(JIT_IF_JUMP,literals_count - 2);
+ EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
i += 2;
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(JIT_DISPATCH,literals_count - 1);
+ EMIT(userenv[JIT_DISPATCH],literals_count - 1);
i++;
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(JIT_PUSH_LITERAL,literals_count - 1);
+ EMIT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],literals_count - 1);
break;
}
}
if(!tail_call)
{
if(stack_frame)
- EMIT(JIT_EPILOG,0);
+ EMIT(userenv[JIT_EPILOG],0);
- EMIT(JIT_RETURN,0);
+ EMIT(userenv[JIT_RETURN],0);
}
GROWABLE_ARRAY_TRIM(code);
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
- COUNT(JIT_PROLOG,0)
+ COUNT(userenv[JIT_PROLOG],0)
CELL i;
CELL length = array_capacity(untag_object(array));
for(i = 0; i < length; i++)
{
CELL obj = array_nth(untag_object(array),i);
+ F_WORD *word;
switch(type_of(obj))
{
case WORD_TYPE:
/* Intrinsics */
- if(obj == userenv[JIT_TAG_WORD])
- COUNT(JIT_TAG,i)
- else if(obj == userenv[JIT_EQP_WORD])
- COUNT(JIT_EQP,i)
- else if(obj == userenv[JIT_SLOT_WORD])
- COUNT(JIT_SLOT,i)
- else if(obj == userenv[JIT_DROP_WORD])
- COUNT(JIT_DROP,i)
- else if(obj == userenv[JIT_DUP_WORD])
- COUNT(JIT_DUP,i)
- else if(obj == userenv[JIT_TO_R_WORD])
- COUNT(JIT_TO_R,i)
- else if(obj == userenv[JIT_FROM_R_WORD])
- COUNT(JIT_FROM_R,i)
- else if(obj == userenv[JIT_SWAP_WORD])
- COUNT(JIT_SWAP,i)
- else if(obj == userenv[JIT_OVER_WORD])
- COUNT(JIT_OVER,i)
- else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
- COUNT(JIT_FIXNUM_MINUS,i)
- else if(obj == userenv[JIT_FIXNUM_GE_WORD])
- COUNT(JIT_FIXNUM_GE,i)
- else
+ word = untag_object(obj);
+ if(word->subprimitive != F)
+ COUNT(word->subprimitive,i)
+ else if(i == length - 1)
{
- if(i == length - 1)
- {
- if(stack_frame)
- COUNT(JIT_EPILOG,i);
-
- COUNT(JIT_WORD_JUMP,i)
-
- tail_call = true;
- }
- else
- COUNT(JIT_WORD_CALL,i)
+ if(stack_frame)
+ COUNT(userenv[JIT_EPILOG],i);
+
+ COUNT(userenv[JIT_WORD_JUMP],i)
+
+ tail_call = true;
}
+ else
+ COUNT(userenv[JIT_WORD_CALL],i)
break;
case WRAPPER_TYPE:
- COUNT(JIT_PUSH_LITERAL,i)
+ COUNT(userenv[JIT_PUSH_LITERAL],i)
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
- COUNT(JIT_PRIMITIVE,i);
+ COUNT(userenv[JIT_PRIMITIVE],i);
i++;
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
- COUNT(JIT_EPILOG,i)
+ COUNT(userenv[JIT_EPILOG],i)
i += 2;
- COUNT(JIT_IF_JUMP,i)
+ COUNT(userenv[JIT_IF_JUMP],i)
tail_call = true;
break;
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
- COUNT(JIT_EPILOG,i)
+ COUNT(userenv[JIT_EPILOG],i)
i++;
- COUNT(JIT_DISPATCH,i)
+ COUNT(userenv[JIT_DISPATCH],i)
tail_call = true;
break;
break;
}
default:
- COUNT(JIT_PUSH_LITERAL,i)
+ COUNT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],i)
break;
}
}
if(!tail_call)
{
if(stack_frame)
- COUNT(JIT_EPILOG,length)
+ COUNT(userenv[JIT_EPILOG],length)
- COUNT(JIT_RETURN,length)
+ COUNT(userenv[JIT_RETURN],length)
}
return -1;
stack_chain = NULL;
}
-DEFINE_PRIMITIVE(drop)
-{
- dpop();
-}
-
-DEFINE_PRIMITIVE(2drop)
-{
- ds -= 2 * CELLS;
-}
-
-DEFINE_PRIMITIVE(3drop)
-{
- ds -= 3 * CELLS;
-}
-
-DEFINE_PRIMITIVE(dup)
-{
- dpush(dpeek());
-}
-
-DEFINE_PRIMITIVE(2dup)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- ds += CELLS * 2;
- put(ds - CELLS,next);
- put(ds,top);
-}
-
-DEFINE_PRIMITIVE(3dup)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- ds += CELLS * 3;
- put (ds,c1);
- put (ds - CELLS,c2);
- put (ds - CELLS * 2,c3);
-}
-
-DEFINE_PRIMITIVE(rot)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- put(ds,c3);
- put(ds - CELLS,c1);
- put(ds - CELLS * 2,c2);
-}
-
-DEFINE_PRIMITIVE(_rot)
-{
- CELL c1 = dpeek();
- CELL c2 = get(ds - CELLS);
- CELL c3 = get(ds - CELLS * 2);
- put(ds,c2);
- put(ds - CELLS,c3);
- put(ds - CELLS * 2,c1);
-}
-
-DEFINE_PRIMITIVE(dupd)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,next);
- dpush(top);
-}
-
-DEFINE_PRIMITIVE(swapd)
-{
- CELL top = get(ds - CELLS);
- CELL next = get(ds - CELLS * 2);
- put(ds - CELLS,next);
- put(ds - CELLS * 2,top);
-}
-
-DEFINE_PRIMITIVE(nip)
-{
- CELL top = dpop();
- drepl(top);
-}
-
-DEFINE_PRIMITIVE(2nip)
-{
- CELL top = dpeek();
- ds -= CELLS * 2;
- drepl(top);
-}
-
-DEFINE_PRIMITIVE(tuck)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,top);
- dpush(top);
-}
-
-DEFINE_PRIMITIVE(over)
-{
- dpush(get(ds - CELLS));
-}
-
-DEFINE_PRIMITIVE(pick)
-{
- dpush(get(ds - CELLS * 2));
-}
-
-DEFINE_PRIMITIVE(swap)
-{
- CELL top = dpeek();
- CELL next = get(ds - CELLS);
- put(ds,next);
- put(ds - CELLS,top);
-}
-
-DEFINE_PRIMITIVE(to_r)
-{
- rpush(dpop());
-}
-
-DEFINE_PRIMITIVE(from_r)
-{
- dpush(rpop());
-}
-
bool stack_to_array(CELL bottom, CELL top)
{
F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(eq)
-{
- CELL lhs = dpop();
- CELL rhs = dpeek();
- drepl((lhs == rhs) ? T : F);
-}
-
DEFINE_PRIMITIVE(millis)
{
box_unsigned_8(current_millis());
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(tag)
-{
- drepl(tag_fixnum(TAG(dpeek())));
-}
-
-DEFINE_PRIMITIVE(slot)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = dpop();
- dpush(get(SLOT(obj,slot)));
-}
-
DEFINE_PRIMITIVE(set_slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
JIT_EPILOG,
JIT_RETURN,
JIT_PROFILING,
- JIT_TAG,
- JIT_TAG_WORD,
- JIT_EQP,
- JIT_EQP_WORD,
- JIT_SLOT,
- JIT_SLOT_WORD,
- JIT_DECLARE_WORD,
- JIT_DROP,
- JIT_DROP_WORD,
- JIT_DUP,
- JIT_DUP_WORD,
- JIT_TO_R,
- JIT_TO_R_WORD,
- JIT_FROM_R,
- JIT_FROM_R_WORD,
- JIT_SWAP,
- JIT_SWAP_WORD,
- JIT_OVER,
- JIT_OVER_WORD,
- JIT_FIXNUM_MINUS,
- JIT_FIXNUM_MINUS_WORD,
- JIT_FIXNUM_GE,
- JIT_FIXNUM_GE_WORD,
+ JIT_PUSH_IMMEDIATE,
+
+ JIT_DECLARE_WORD = 42,
STACK_TRACES_ENV = 59,
DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size);
-DECLARE_PRIMITIVE(drop);
-DECLARE_PRIMITIVE(2drop);
-DECLARE_PRIMITIVE(3drop);
-DECLARE_PRIMITIVE(dup);
-DECLARE_PRIMITIVE(2dup);
-DECLARE_PRIMITIVE(3dup);
-DECLARE_PRIMITIVE(rot);
-DECLARE_PRIMITIVE(_rot);
-DECLARE_PRIMITIVE(dupd);
-DECLARE_PRIMITIVE(swapd);
-DECLARE_PRIMITIVE(nip);
-DECLARE_PRIMITIVE(2nip);
-DECLARE_PRIMITIVE(tuck);
-DECLARE_PRIMITIVE(over);
-DECLARE_PRIMITIVE(pick);
-DECLARE_PRIMITIVE(swap);
-DECLARE_PRIMITIVE(to_r);
-DECLARE_PRIMITIVE(from_r);
+
DECLARE_PRIMITIVE(datastack);
DECLARE_PRIMITIVE(retainstack);
-DECLARE_PRIMITIVE(execute);
-DECLARE_PRIMITIVE(call);
DECLARE_PRIMITIVE(getenv);
DECLARE_PRIMITIVE(setenv);
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(set_os_env);
DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
-DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
bool stage2;
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
+ word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;
projects / factor.git / commitdiff