vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
+ vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
vm/debug.o \
vm/dispatch.o \
vm/errors.o \
vm/factor.o \
+ vm/free_list.o \
vm/full_collector.o \
vm/gc.o \
- vm/heap.o \
vm/image.o \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/math.o \
vm/nursery_collector.o \
- vm/old_space.o \
+ vm/object_start_map.o \
+ vm/objects.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
M: f byte-length drop 0 ; inline
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
+
MIXIN: value-type
: c-getter ( name -- quot )
"c-type" word-prop c-type-name? ;
M: string typedef ( old new -- ) c-types get set-at ;
+
M: word typedef ( old new -- )
{
[ nip define-symbol ]
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
- [ dup c-setter '[ _ heap-size <byte-array> [ 0 @ ] keep ] ] bi
+ [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
(( value -- c-ptr )) define-inline ;
: define-primitive-type ( c-type name -- )
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
- 8 >>align
+ cpu x86.32? os windows? not and 4 8 ? >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
\ longlong define-primitive-type
[ alien-unsigned-8 ] >>getter
[ set-alien-unsigned-8 ] >>setter
8 >>size
- 8 >>align
+ cpu x86.32? os windows? not and 4 8 ? >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
\ ulonglong define-primitive-type
"to_cell" >>unboxer
\ uchar define-primitive-type
- <c-type>
- [ alien-unsigned-1 0 = not ] >>getter
- [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
- 1 >>size
- 1 >>align
- "box_boolean" >>boxer
- "to_boolean" >>unboxer
- \ bool define-primitive-type
+ cpu ppc? [
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ ] [
+ <c-type>
+ [ alien-unsigned-1 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ \ bool define-primitive-type
+ ] if
<c-type>
math:float >>class
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
- 8 >>align
+ cpu x86.32? os windows? not and 4 8 ? >>align
"box_double" >>boxer
"to_double" >>unboxer
double-rep >>rep
[ >float ] >>unboxer-quot
\ double define-primitive-type
- \ long c-type \ ptrdiff_t typedef
- \ long c-type \ intptr_t typedef
- \ ulong c-type \ uintptr_t typedef
- \ ulong c-type \ size_t typedef
+ cpu x86.64? os windows? and [
+ \ longlong c-type \ ptrdiff_t typedef
+ \ longlong c-type \ intptr_t typedef
+ \ ulonglong c-type \ uintptr_t typedef
+ \ ulonglong c-type \ size_t typedef
+ ] [
+ \ long c-type \ ptrdiff_t typedef
+ \ long c-type \ intptr_t typedef
+ \ ulong c-type \ uintptr_t typedef
+ \ ulong c-type \ size_t typedef
+ ] if
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;
: c-type-interval ( c-type -- from to )
{
- { [ dup { float double } memq? ] [ drop -1/0. 1/0. ] }
- { [ dup { char short int long longlong } memq? ] [ signed-interval ] }
- { [ dup { uchar ushort uint ulong ulonglong } memq? ] [ unsigned-interval ] }
+ { [ dup { float double } member-eq? ] [ drop -1/0. 1/0. ] }
+ { [ dup { char short int long longlong } member-eq? ] [ signed-interval ] }
+ { [ dup { uchar ushort uint ulong ulonglong } member-eq? ] [ unsigned-interval ] }
} cond ; foldable
: c-type-clamp ( value c-type -- value' ) c-type-interval clamp ; inline
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ; inline
-: >c-bool ( ? -- int ) 1 0 ? ; inline
-
-: c-bool> ( int -- ? ) 0 = not ; inline
-
M: value-type c-type-rep drop int-rep ;
M: value-type c-type-getter
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
-
-
M: real-type (fortran-ret-type>c-type)
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
-: suffix! ( seq elt -- seq ) over push ; inline
-: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
-
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
: args?dims ( type quot -- main-quot added-quot )
] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
- return parameters fortran-sig>c-sig :> c-parameters :> c-return
+ return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke
type-name current-vocab create :> type-word
type-word [ reset-generic ] [ reset-c-type ] bi
void* type-word typedef
- parameters return parse-arglist :> callback-effect :> types
+ parameters return parse-arglist :> ( types callback-effect )
type-word callback-effect "callback-effect" set-word-prop
type-word lib "callback-library" set-word-prop
type-word return types lib library-abi callback-quot (( quot -- alien )) ;
fry vocabs.parser words.constant alien.libraries ;
IN: alien.syntax
-SYNTAX: DLL" lexer get skip-blank parse-string dlopen parsed ;
+SYNTAX: DLL" lexer get skip-blank parse-string dlopen suffix! ;
-SYNTAX: ALIEN: 16 scan-base <alien> parsed ;
+SYNTAX: ALIEN: 16 scan-base <alien> suffix! ;
-SYNTAX: BAD-ALIEN <bad-alien> parsed ;
+SYNTAX: BAD-ALIEN <bad-alien> suffix! ;
SYNTAX: LIBRARY: scan "c-library" set ;
2dup load-library dlsym [ 2nip ] [ no-such-symbol ] if* ;
SYNTAX: &:
- scan "c-library" get '[ _ _ address-of ] over push-all ;
+ scan "c-library" get '[ _ _ address-of ] append! ;
: global-quot ( type word -- quot )
name>> "c-library" get '[ _ _ address-of 0 ]
{ member? sorted-member? } related-words
-HELP: sorted-memq?
+HELP: sorted-member-eq?
{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
{ $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
-{ memq? sorted-memq? } related-words
+{ member-eq? sorted-member-eq? } related-words
ARTICLE: "binary-search" "Binary search"
"The " { $emphasis "binary search" } " algorithm allows elements to be located in sorted sequence in " { $snippet "O(log n)" } " time."
{ $subsections
sorted-index
sorted-member?
- sorted-memq?
+ sorted-member-eq?
}
{ $see-also "order-specifiers" "sequences-sorting" } ;
: sorted-member? ( obj seq -- ? )
dupd natural-search nip = ;
-: sorted-memq? ( obj seq -- ? )
+: sorted-member-eq? ( obj seq -- ? )
dupd natural-search nip eq? ;
{ $values { "bit-array" bit-array } }
{ $description "Sets all elements of the bit array to " { $link f } "." }
{ $notes "Calling this word is more efficient than the following:"
- { $code "[ drop f ] change-each" }
+ { $code "[ drop f ] map! drop" }
}
{ $side-effects "bit-array" } ;
{ $values { "bit-array" bit-array } }
{ $description "Sets all elements of the bit array to " { $link t } "." }
{ $notes "Calling this word is more efficient than the following:"
- { $code "[ drop t ] change-each" }
+ { $code "[ drop t ] map! drop" }
}
{ $side-effects "bit-array" } ;
[
{ t f t } { f t f }
] [
- { t f t } >bit-array dup clone dup [ not ] change-each
+ { t f t } >bit-array dup clone [ not ] map!
[ >array ] bi@
] unit-test
M:: lsb0-bit-writer poke ( value n bs -- )
value n <widthed> :> widthed
widthed
- bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+ bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
neg shift n bits ;
:: adjust-bits ( n bs -- )
- n 8 /mod :> #bits :> #bytes
+ n 8 /mod :> ( #bytes #bits )
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
8 - bs (>>bit-pos)
{
not ?
- 2over roll -roll
+ 2over
array? hashtable? vector?
tuple? sbuf? tombstone?
"." write flush
{
- memq? split harvest sift cut cut-slice start index clone
+ member-eq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
like clone-like
} compile-unoptimized
" done" print flush
-] unless
\ No newline at end of file
+] unless
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays generic hashtables hashtables.private
-io io.binary io.files io.encodings.binary io.pathnames kernel
-kernel.private math namespaces make parser prettyprint sequences
-strings sbufs vectors words quotations assocs system layouts splitting
-grouping growable classes classes.builtin classes.tuple
-classes.tuple.private vocabs vocabs.loader source-files definitions
-debugger quotations.private combinators math.order math.private
-accessors slots.private generic.single.private compiler.units
-compiler.constants fry bootstrap.image.syntax ;
+USING: alien arrays byte-arrays generic hashtables
+hashtables.private io io.binary io.files io.encodings.binary
+io.pathnames kernel kernel.private math namespaces make parser
+prettyprint sequences strings sbufs vectors words quotations
+assocs system layouts splitting grouping growable classes
+classes.builtin classes.tuple classes.tuple.private vocabs
+vocabs.loader source-files definitions debugger
+quotations.private combinators combinators.short-circuit
+math.order math.private accessors slots.private
+generic.single.private compiler.units compiler.constants fry
+bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
! Object cache; we only consider numbers equal if they have the
! same type
-TUPLE: eql-wrapper obj ;
+TUPLE: eql-wrapper { obj read-only } ;
C: <eql-wrapper> eql-wrapper
GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? )
- [ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
+ { [ [ class ] bi@ = ] [ (eql?) ] } 2&& ;
-M: integer (eql?) = ;
+M: fixnum (eql?) eq? ;
-M: float (eql?)
- over float? [ fp-bitwise= ] [ 2drop f ] if ;
+M: bignum (eql?) = ;
-M: sequence (eql?)
- over sequence? [
- 2dup [ length ] bi@ =
- [ [ eql? ] 2all? ] [ 2drop f ] if
- ] [ 2drop f ] if ;
+M: float (eql?) fp-bitwise= ;
+
+M: sequence (eql?) 2dup [ length ] bi@ = [ [ eql? ] 2all? ] [ 2drop f ] if ;
M: object (eql?) = ;
M: eql-wrapper equal?
over eql-wrapper? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
-TUPLE: eq-wrapper obj ;
+TUPLE: eq-wrapper { obj read-only } ;
C: <eq-wrapper> eq-wrapper
! PIC stubs
USERENV: pic-load 47
USERENV: pic-tag 48
-USERENV: pic-hi-tag 49
-USERENV: pic-tuple 50
-USERENV: pic-hi-tag-tuple 51
-USERENV: pic-check-tag 52
-USERENV: pic-check 53
-USERENV: pic-hit 54
-USERENV: pic-miss-word 55
-USERENV: pic-miss-tail-word 56
+USERENV: pic-tuple 49
+USERENV: pic-check-tag 50
+USERENV: pic-check-tuple 51
+USERENV: pic-hit 52
+USERENV: pic-miss-word 53
+USERENV: pic-miss-tail-word 54
! Megamorphic dispatch
USERENV: mega-lookup 57
: here-as ( tag -- pointer ) here bitor ;
+: (align-here) ( alignment -- )
+ [ here neg ] dip rem
+ [ bootstrap-cell /i [ 0 emit ] times ] unless-zero ;
+
: align-here ( -- )
- here 8 mod 4 = [ 0 emit ] when ;
+ data-alignment get (align-here) ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
: emit-object ( class quot -- addr )
- over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
+ [ type-number ] dip over here-as
+ [ swap tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
M: float '
[
float [
- align-here double>bits emit-64
+ 8 (align-here) double>bits emit-64
] emit-object
] cache-eql-object ;
M: f '
#! f is #define F RETAG(0,F_TYPE)
- drop \ f tag-number ;
+ drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
[ ] [ "Not in image: " word-error ] ?if ;
: fixup-words ( -- )
- image get [ dup word? [ fixup-word ] when ] change-each ;
+ image get [ dup word? [ fixup-word ] when ] map! drop ;
M: word ' ;
[
byte-array [
dup length emit-fixnum
+ bootstrap-cell 4 = [ 0 emit 0 emit ] when
pad-bytes emit-bytes
] emit-object
] cache-eq-object ;
"tools.deploy"
"tools.destructors"
"tools.disassembler"
+ "tools.dispatch"
"tools.memory"
"tools.profiler"
"tools.test"
"}" parse-tokens "" join
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
- parsed ;
+ suffix! ;
:: easter-month-day ( year -- month day )
year 19 mod :> a
- year 100 /mod :> c :> b
- b 4 /mod :> e :> d
+ year 100 /mod :> ( b c )
+ b 4 /mod :> ( d e )
b 8 + 25 /i :> f
b f - 1 + 3 /i :> g
19 a * b + d - g - 15 + 30 mod :> h
- c 4 /mod :> k :> i
+ c 4 /mod :> ( i k )
32 2 e * + 2 i * + h - k - 7 mod :> l
a 11 h * + 22 l * + 451 /i :> m
- h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
+ h l + 7 m * - 114 + 31 /mod 1 + :> ( month day )
month day ;
M: integer easter ( year -- timestamp )
] 3keep filter ;
:: (sieve) ( prime c -- )
- [let | p [ c from ]
- newc [ <channel> ] |
- p prime to
- [ newc p c filter ] "Filter" spawn drop
- prime newc (sieve)
- ] ;
+ c from :> p
+ <channel> :> newc
+ p prime to
+ [ newc p c filter ] "Filter" spawn drop
+ prime newc (sieve) ;
: sieve ( prime -- )
#! Send prime numbers to 'prime' channel
" to be accessed remotely. " { $link publish } " returns an id which a remote node "
"needs to know to access the channel."
$nl
-{ $snippet "channel [ from . ] spawn drop dup publish" }
+{ $snippet "<channel> dup [ from . flush ] curry \"test\" spawn drop publish" }
$nl
-"Given the id from the snippet above, a remote node can put items in the channel."
+"Given the id from the snippet above, a remote node can put items in the channel (where 123456 is the id):"
$nl
-{ $snippet "\"myhost.com\" 9001 <node> \"ID123456\" <remote-channel>\n\"hello\" over to" }
+{ $snippet "\"myhost.com\" 9001 <node> 123456 <remote-channel>\n\"hello\" over to" }
;
ABOUT: { "remote-channels" "remote-channels" }
! See http://factorcode.org/license.txt for BSD license.
!
! Remote Channels
-USING: kernel init namespaces make assocs arrays random
+USING: kernel init namespaces assocs arrays random
sequences channels match concurrency.messaging
concurrency.distributed threads accessors ;
IN: channels.remote
MATCH-VARS: ?from ?tag ?id ?value ;
SYMBOL: no-channel
+TUPLE: to-message id value ;
+TUPLE: from-message id ;
-: channel-process ( -- )
+: channel-thread ( -- )
[
{
- { { to ?id ?value }
+ { T{ to-message f ?id ?value }
[ ?value ?id get-channel dup [ to f ] [ 2drop no-channel ] if ] }
- { { from ?id }
+ { T{ from-message f ?id }
[ ?id get-channel [ from ] [ no-channel ] if* ] }
} match-cond
] handle-synchronous ;
-PRIVATE>
-
: start-channel-node ( -- )
- "remote-channels" get-process [
- "remote-channels"
- [ channel-process t ] "Remote channels" spawn-server
- register-process
+ "remote-channels" get-remote-thread [
+ [ channel-thread t ] "Remote channels" spawn-server
+ "remote-channels" register-remote-thread
] unless ;
+PRIVATE>
+
TUPLE: remote-channel node id ;
C: <remote-channel> remote-channel
+<PRIVATE
+
+: send-message ( message remote-channel -- value )
+ node>> "remote-channels" <remote-thread>
+ send-synchronous dup no-channel = [ no-channel throw ] when* ;
+
+PRIVATE>
+
M: remote-channel to ( value remote-channel -- )
- [ [ \ to , id>> , , ] { } make ] keep
- node>> "remote-channels" <remote-process>
- send-synchronous no-channel = [ no-channel throw ] when ;
+ [ id>> swap to-message boa ] keep send-message drop ;
M: remote-channel from ( remote-channel -- value )
- [ [ \ from , id>> , ] { } make ] keep
- node>> "remote-channels" <remote-process>
- send-synchronous dup no-channel = [ no-channel throw ] when* ;
+ [ id>> from-message boa ] keep send-message ;
[
H{ } clone \ remote-channels set-global
:: hmac-stream ( stream key checksum -- value )
checksum initialize-checksum-state :> checksum-state
- checksum key checksum-state init-key :> Ki :> Ko
+ checksum key checksum-state init-key :> ( Ko Ki )
checksum-state Ki add-checksum-bytes
stream add-checksum-stream get-checksum
checksum initialize-checksum-state
M: circular virtual@ circular-wrap seq>> ;
-M: circular virtual-seq seq>> ;
+M: circular virtual-exemplar seq>> ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
[ 2^ 1 - ] bi@ swap bitnot bitand ;
:: manipulate-bits ( offset bits step-quot -- quot shift-amount offset' bits' )
- offset 8 /mod :> start-bit :> i
+ offset 8 /mod :> ( i start-bit )
start-bit bits + 8 min :> end-bit
start-bit end-bit ones-between :> mask
end-bit start-bit - :> used-bits
: parse-struct-slots ( slots -- slots' more? )
scan {
{ ";" [ f ] }
- { "{" [ parse-struct-slot over push t ] }
+ { "{" [ parse-struct-slot suffix! t ] }
{ f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
parse-struct-definition define-union-struct-class ;
SYNTAX: S{
- scan-word dup struct-slots parse-tuple-literal-slots parsed ;
+ scan-word dup struct-slots parse-tuple-literal-slots suffix! ;
SYNTAX: S@
- scan-word scan-object swap memory>struct parsed ;
+ scan-word scan-object swap memory>struct suffix! ;
! functor support
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until
- [ <struct-slot-spec> over push ] 3curry over push-all ;
+ [ <struct-slot-spec> suffix! ] 3curry append! ;
: parse-struct-slots` ( accum -- accum more? )
scan {
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
- scan-param parsed
- [ 8 <vector> ] over push-all
+ scan-param suffix!
+ [ 8 <vector> ] append!
[ parse-struct-slots` ] [ ] while
- [ >array define-struct-class ] over push-all ;
+ [ >array define-struct-class ] append! ;
USING: vocabs vocabs.loader ;
: remember-send ( selector -- )
sent-messages (remember-send) ;
-SYNTAX: -> scan dup remember-send parsed \ send parsed ;
+SYNTAX: -> scan dup remember-send suffix! \ send suffix! ;
SYMBOL: super-sent-messages
: remember-super-send ( selector -- )
super-sent-messages (remember-send) ;
-SYNTAX: SUPER-> scan dup remember-super-send parsed \ super-send parsed ;
+SYNTAX: SUPER-> scan dup remember-super-send suffix! \ super-send suffix! ;
SYMBOL: frameworks
: named-color ( name -- color )
dup colors at [ ] [ no-such-color ] ?if ;
-SYNTAX: COLOR: scan named-color parsed ;
\ No newline at end of file
+SYNTAX: COLOR: scan named-color suffix! ;
{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
+[ ] [ "seq" get 1 <column> [ sq ] map! drop ] unit-test
[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
C: <column> column
-M: column virtual-seq seq>> ;
+M: column virtual-exemplar seq>> ;
M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
M: column length seq>> length ;
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
+
+{ 2 3 } [ [ + ] preserving ] must-infer-as
+
+{ 2 0 } [ [ + ] nullary ] must-infer-as
+
+{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
MACRO: preserving ( quot -- )
[ infer in>> length ] keep '[ _ ndup @ ] ;
+MACRO: nullary ( quot -- quot' )
+ dup infer out>> length '[ @ _ ndrop ] ;
+
MACRO: smart-if ( pred true false -- )
'[ _ preserving _ _ if ] ; inline
M: ##compare analyze-aliases*
call-next-method
dup useless-compare? [
- dst>> \ f tag-number \ ##load-immediate new-insn
+ dst>> \ f type-number \ ##load-immediate new-insn
analyze-aliases*
] when ;
{
byte-array
- simple-alien
alien
POSTPONE: f
} [| class |
: count-insns ( quot insn-check -- ? )
[ test-mr [ instructions>> ] map ] dip
- '[ _ count ] sigma ; inline
+ '[ _ count ] map-sum ; inline
: contains-insn? ( quot insn-check -- ? )
count-insns 0 > ; inline
] unit-test
[ f t ] [
- [ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
+ [ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
[ [ ##unbox-alien? ] contains-insn? ] bi
] unit-test
] unit-test
[ f t ] [
- [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+ [ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##allot? ] contains-insn? ] bi
] unit-test
and ;
: emit-trivial-if ( -- )
- ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+ ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
: trivial-not-if? ( #if -- ? )
children>> first2
and ;
: emit-trivial-not-if ( -- )
- ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+ ds-pop \ f type-number cc= ^^compare-imm ds-push ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
ERROR: bad-successors ;
: check-successors ( bb -- )
- dup successors>> [ predecessors>> memq? ] with all?
+ dup successors>> [ predecessors>> member-eq? ] with all?
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
{ cc/> { +lt+ +eq+ +unordered+ } }
{ cc/<> { +eq+ +unordered+ } }
{ cc/<>= { +unordered+ } }
- } at memq? ;
+ } at member-eq? ;
copies get dup assoc-empty? [ 2drop ] [
renamings set
[
- instructions>> [ update-insn ] filter-here
+ instructions>> [ update-insn ] filter! drop
] each-basic-block
] if ;
dup
[ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
[ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
- [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
+ [ [ instructions>> [ live-insn? ] filter! drop ] each-basic-block ]
tri ;
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
+M: insn defs-vreg drop f ;
+M: insn temp-vregs drop { } ;
+M: insn uses-vregs drop { } ;
+
M: ##phi uses-vregs inputs>> values ;
<PRIVATE
} case ;
: define-defs-vreg-method ( insn -- )
- [ \ defs-vreg create-method ]
- [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
- define ;
+ dup insn-def-slot dup [
+ [ \ defs-vreg create-method ]
+ [ name>> reader-word 1quotation ] bi*
+ define
+ ] [ 2drop ] if ;
: define-uses-vregs-method ( insn -- )
- [ \ uses-vregs create-method ]
- [ insn-use-slots [ name>> ] map slot-array-quot ] bi
- define ;
+ dup insn-use-slots [ drop ] [
+ [ \ uses-vregs create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
+ define
+ ] if-empty ;
: define-temp-vregs-method ( insn -- )
- [ \ temp-vregs create-method ]
- [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
- define ;
+ dup insn-temp-slots [ drop ] [
+ [ \ temp-vregs create-method ]
+ [ [ name>> ] map slot-array-quot ] bi*
+ define
+ ] if-empty ;
PRIVATE>
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry
-cpu.architecture layouts
+USING: accessors kernel sequences assocs fry math
+cpu.architecture layouts namespaces
compiler.cfg.rpo
compiler.cfg.registers
compiler.cfg.instructions
M: ##allot allocation-size* size>> ;
-M: ##box-alien allocation-size* drop 4 cells ;
+M: ##box-alien allocation-size* drop 5 cells ;
-M: ##box-displaced-alien allocation-size* drop 4 cells ;
+M: ##box-displaced-alien allocation-size* drop 5 cells ;
: allocation-size ( bb -- n )
- instructions>> [ ##allocation? ] filter [ allocation-size* ] sigma ;
+ instructions>>
+ [ ##allocation? ] filter
+ [ allocation-size* data-alignment get align ] map-sum ;
: insert-gc-check ( bb -- )
dup dup '[
dup blocks-with-gc [
over compute-uninitialized-sets
[ insert-gc-check ] each
- ] unless-empty ;
\ No newline at end of file
+ ] unless-empty ;
: hat-effect ( insn -- effect )
"insn-slots" word-prop
- [ type>> { def temp } memq? not ] filter [ name>> ] map
+ [ type>> { def temp } member-eq? not ] filter [ name>> ] map
{ "vreg" } <effect> ;
: define-hat ( insn -- )
: ^^load-literal ( obj -- dst )
[ next-vreg dup ] dip {
- { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+ { [ dup not ] [ drop \ f type-number ##load-immediate ] }
{ [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
{ [ dup float? ] [ ##load-constant ] }
[ ##load-reference ]
} cond ;
: ^^offset>slot ( slot -- vreg' )
- cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
+ cell 4 = 2 1 ? ^^shr-imm ;
: ^^tag-fixnum ( src -- dst )
tag-bits get ^^shl-imm ;
use: src
literal: rep ;
-PURE-INSN: ##horizontal-shl-vector
+PURE-INSN: ##horizontal-shl-vector-imm
def: dst
use: src1
literal: src2 rep ;
-PURE-INSN: ##horizontal-shr-vector
+PURE-INSN: ##horizontal-shr-vector-imm
def: dst
use: src1
literal: src2 rep ;
use: src
literal: rep ;
+PURE-INSN: ##shl-vector-imm
+def: dst
+use: src1
+literal: src2 rep ;
+
+PURE-INSN: ##shr-vector-imm
+def: dst
+use: src1
+literal: src2 rep ;
+
PURE-INSN: ##shl-vector
def: dst
use: src1 src2/int-scalar-rep
PURE-INSN: ##box-displaced-alien
def: dst/int-rep
use: displacement/int-rep base/int-rep
-temp: temp1/int-rep temp2/int-rep
+temp: temp/int-rep
literal: base-class ;
PURE-INSN: ##unbox-any-c-ptr
def: dst/int-rep
-use: src/int-rep
-temp: temp/int-rep ;
+use: src/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
def: dst/int-rep
use: src/int-rep ;
-: ##unbox-c-ptr ( dst src class temp -- )
+: ##unbox-c-ptr ( dst src class -- )
{
- { [ over \ f class<= ] [ 2drop ##unbox-f ] }
- { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
- { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
- [ nip ##unbox-any-c-ptr ]
+ { [ dup \ f class<= ] [ drop ##unbox-f ] }
+ { [ dup alien class<= ] [ drop ##unbox-alien ] }
+ { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+ [ drop ##unbox-any-c-ptr ]
} cond ;
! Alien accessors
[
vreg-insn
insn-classes get [
- "insn-slots" word-prop [ type>> { def use temp } memq? ] any?
+ "insn-slots" word-prop [ type>> { def use temp } member-eq? ] any?
] filter
define-union-class
] with-compilation-unit
] [ emit-primitive ] if ;
:: inline-alien ( node quot test -- )
- [let | infos [ node node-input-infos ] |
- infos test call
- [ infos quot call ]
- [ node emit-primitive ]
- if
- ] ; inline
+ node node-input-infos :> infos
+ infos test call
+ [ infos quot call ]
+ [ node emit-primitive ] if ; inline
: inline-alien-getter? ( infos -- ? )
[ first class>> c-ptr class<= ]
bi and ;
: ^^unbox-c-ptr ( src class -- dst )
- [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
+ [ next-vreg dup ] 2dip ##unbox-c-ptr ;
: prepare-alien-accessor ( info -- ptr-vreg offset )
class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
- '[ _ swap 1 + _ tag-number ##set-slot-imm ] each-index ;
+ '[ _ swap 1 + _ type-number ##set-slot-imm ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
] [ drop emit-primitive ] if ;
: store-length ( len reg class -- )
- [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
+ [ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm ;
:: store-initial-element ( len reg elt class -- )
- len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
+ len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
2 + cells array ^^allot ;
:: emit-<array> ( node -- )
- [let | len [ node node-input-infos first literal>> ] |
- len expand-<array>? [
- [let | elt [ ds-pop ]
- reg [ len ^^allot-array ] |
- ds-drop
- len reg array store-length
- len reg elt array store-initial-element
- reg ds-push
- ]
- ] [ node emit-primitive ] if
- ] ;
+ node node-input-infos first literal>> :> len
+ len expand-<array>? [
+ ds-pop :> elt
+ len ^^allot-array :> reg
+ ds-drop
+ len reg array store-length
+ len reg elt array store-initial-element
+ reg ds-push
+ ] [ node emit-primitive ] if ;
: expand-(byte-array)? ( obj -- ? )
dup integer? [ 0 1024 between? ] [ drop f ] if ;
: bytes>cells ( m -- n ) cell align cell /i ;
: ^^allot-byte-array ( n -- dst )
- 2 cells + byte-array ^^allot ;
+ 16 + byte-array ^^allot ;
: emit-allot-byte-array ( len -- dst )
ds-drop
ds-push ;
: tag-literal ( n -- tagged )
- literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+ literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
: emit-fixnum-op ( insn -- )
[ 2inputs ] dip call ds-push ; inline
{ math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
- { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
+ { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
+ { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
{ math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
: [unary/param] ( quot -- quot' )
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
-: emit-horizontal-shift ( node quot -- )
+: emit-shift-vector-imm-op ( node quot -- )
[unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ; inline
+:: emit-shift-vector-op ( node imm-quot var-quot -- )
+ node node-input-infos 2 tail-slice* first literal>> integer?
+ [ node imm-quot emit-shift-vector-imm-op ]
+ [ node var-quot emit-binary-vector-op ] if ; inline
+
: emit-gather-vector-2 ( node -- )
[ ^^gather-vector-2 ] emit-binary-vector-op ;
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
- {cc,swap} first2 :> swap? :> cc
+ {cc,swap} first2 :> ( cc swap? )
swap?
[ src2 src1 rep cc ^^compare-vector ]
[ src1 src2 rep cc ^^compare-vector ] if ;
:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
- rep orig-cc %compare-vector-ccs :> not? :> ccs
+ rep orig-cc %compare-vector-ccs :> ( ccs not? )
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
- ccs unclip :> first-cc :> rest-ccs
+ ccs unclip :> ( rest-ccs first-cc )
src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst
src zero rep ^^merge-vector-head
]
}
+ {
+ [ rep widen-vector-rep %shr-vector-imm-reps member? ]
+ [
+ src src rep ^^merge-vector-head
+ rep rep-component-type
+ heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
+ ]
+ }
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign
src zero rep ^^merge-vector-tail
]
}
+ {
+ [ rep widen-vector-rep %shr-vector-imm-reps member? ]
+ [
+ src src rep ^^merge-vector-tail
+ rep rep-component-type
+ heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
+ ]
+ }
[
rep ^^zero-vector :> zero
zero src rep cc> ^^compare-vector :> sign
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
-: value-tag ( info -- n ) class>> class-tag ; inline
+: value-tag ( info -- n ) class>> class-type ; inline
: ^^tag-offset>slot ( slot tag -- vreg' )
[ ^^offset>slot ] dip ^^sub-imm ;
first class>> immediate class<= not ;
:: (emit-set-slot) ( infos -- )
- 3inputs :> slot :> obj :> src
+ 3inputs :> ( src obj slot )
slot infos second value-tag ^^tag-offset>slot :> slot
:: (emit-set-slot-imm) ( infos -- )
ds-drop
- 2inputs :> obj :> src
+ 2inputs :> ( src obj )
infos third literal>> :> slot
infos second value-tag :> tag
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
- '[ [ _ spill-at-sync-point ] filter-here ] each ;
+ '[ [ _ spill-at-sync-point ] filter! drop ] each ;
:: handle-progress ( n sync? -- )
n {
: trim-before-ranges ( live-interval -- )
[ ranges>> ] [ uses>> last 1 + ] bi
- [ '[ from>> _ <= ] filter-here ]
+ [ '[ from>> _ <= ] filter! drop ]
[ swap last (>>to) ]
2bi ;
: trim-after-ranges ( live-interval -- )
[ ranges>> ] [ uses>> first ] bi
- [ '[ to>> _ >= ] filter-here ]
+ [ '[ to>> _ >= ] filter! drop ]
[ swap first (>>from) ]
2bi ;
! most one) are split and spilled and removed from the inactive
! set.
new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
- '[ _ delete-nth new start>> spill ] [ 2drop ] if ;
+ '[ _ remove-nth! drop new start>> spill ] [ 2drop ] if ;
:: spill-intersecting-inactive ( new reg -- )
! Any inactive intervals using 'reg' are split and spilled
new start>> spill f
] [ drop t ] if
] [ drop t ] if
- ] filter-here ;
+ ] filter! drop ;
: spill-intersecting ( new reg -- )
! Split and spill all active and inactive intervals
{ [ 2dup spill-new? ] [ spill-new ] }
{ [ 2dup register-available? ] [ spill-available ] }
[ spill-partially-available ]
- } cond ;
\ No newline at end of file
+ } cond ;
dup vreg>> active-intervals-for push ;
: delete-active ( live-interval -- )
- dup vreg>> active-intervals-for delq ;
+ dup vreg>> active-intervals-for remove-eq! drop ;
: assign-free-register ( new registers -- )
pop >>reg add-active ;
dup vreg>> inactive-intervals-for push ;
: delete-inactive ( live-interval -- )
- dup vreg>> inactive-intervals-for delq ;
+ dup vreg>> inactive-intervals-for remove-eq! drop ;
! Vector of handled live intervals
SYMBOL: handled-intervals
! Moving intervals between active and inactive sets
: process-intervals ( n symbol quots -- )
! symbol stores an alist mapping register classes to vectors
- [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+ [ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline
: deactivate-intervals ( n -- )
! Any active intervals which have ended are moved to handled
! to reverse some sequences, and compute the start and end.
values dup [
{
- [ ranges>> reverse-here ]
- [ uses>> reverse-here ]
+ [ ranges>> reverse! drop ]
+ [ uses>> reverse! drop ]
[ compute-start/end ]
[ check-start ]
} cleave
} cond ;
: intervals-intersect? ( interval1 interval2 -- ? )
- relevant-ranges intersect-live-ranges >boolean ; inline
\ No newline at end of file
+ relevant-ranges intersect-live-ranges >boolean ; inline
: update-phi ( bb ##phi -- )
[
swap predecessors>>
- '[ drop _ memq? ] assoc-filter
+ '[ drop _ member-eq? ] assoc-filter
] change-inputs drop ;
: update-phis ( bb -- )
: needs-predecessors ( cfg -- cfg' )
dup predecessors-valid?>>
- [ compute-predecessors t >>predecessors-valid? ] unless ;
\ No newline at end of file
+ [ compute-predecessors t >>predecessors-valid? ] unless ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel parser assocs ;
+USING: accessors namespaces kernel parser assocs sequences ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs, are just integers
TUPLE: rs-loc < loc ;
C: <rs-loc> rs-loc
-SYNTAX: D scan-word <ds-loc> parsed ;
-SYNTAX: R scan-word <rs-loc> parsed ;
+SYNTAX: D scan-word <ds-loc> suffix! ;
+SYNTAX: R scan-word <rs-loc> suffix! ;
GENERIC: rename-insn-defs ( insn -- )
-insn-classes get [
+M: insn rename-insn-defs drop ;
+
+insn-classes get [ insn-def-slot ] filter [
[ \ rename-insn-defs create-method-in ]
- [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+ [ insn-def-slot name>> 1array DEF-QUOT slot-change-quot ] bi
define
] each
GENERIC: rename-insn-uses ( insn -- )
-insn-classes get { ##phi } diff [
+M: insn rename-insn-uses drop ;
+
+insn-classes get { ##phi } diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
GENERIC: rename-insn-temps ( insn -- )
-insn-classes get [
+M: insn rename-insn-temps drop ;
+
+insn-classes get [ insn-temp-slots empty? not ] filter [
[ \ rename-insn-temps create-method-in ]
[ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
define
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
+M: insn defs-vreg-rep drop f ;
+M: insn temp-vreg-reps drop { } ;
+M: insn uses-vreg-reps drop { } ;
+
<PRIVATE
: rep-getter-quot ( rep -- quot )
} case ;
: define-defs-vreg-rep-method ( insn -- )
- [ \ defs-vreg-rep create-method ]
- [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
- bi define ;
+ dup insn-def-slot dup [
+ [ \ defs-vreg-rep create-method ]
+ [ rep>> rep-getter-quot ]
+ bi* define
+ ] [ 2drop ] if ;
: reps-getter-quot ( reps -- quot )
- dup [ rep>> { f scalar-rep } memq? not ] all? [
+ dup [ rep>> { f scalar-rep } member-eq? not ] all? [
[ rep>> ] map [ drop ] swap suffix
] [
[ rep>> rep-getter-quot ] map dup length {
] if ;
: define-uses-vreg-reps-method ( insn -- )
- [ \ uses-vreg-reps create-method ]
- [ insn-use-slots reps-getter-quot ]
- bi define ;
+ dup insn-use-slots [ drop ] [
+ [ \ uses-vreg-reps create-method ]
+ [ reps-getter-quot ]
+ bi* define
+ ] if-empty ;
: define-temp-vreg-reps-method ( insn -- )
- [ \ temp-vreg-reps create-method ]
- [ insn-temp-slots reps-getter-quot ]
- bi define ;
+ dup insn-temp-slots [ drop ] [
+ [ \ temp-vreg-reps create-method ]
+ [ reps-getter-quot ]
+ bi* define
+ ] if-empty ;
PRIVATE>
int-rep next-vreg-rep :> temp
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
temp 16 tag-fixnum ##load-immediate
- temp dst 1 byte-array tag-number ##set-slot-imm
+ temp dst 1 byte-array type-number ##set-slot-imm
dst byte-array-offset src rep ##set-alien-vector ;
M: vector-rep emit-unbox
: perform-renaming ( insn -- )
needs-renaming? get [
- renaming-set get reverse-here
+ renaming-set get reverse! drop
[ convert-insn-uses ] [ convert-insn-defs ] bi
renaming-set get length 0 assert=
] [ drop ] if ;
[ rename-insn-defs ]
[ rename-insn-uses ]
[ [ useless-copy? ] [ ##phi? ] bi or not ] tri
- ] filter-here
+ ] filter! drop
] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
dup compute-live-ranges
dup prepare-coalescing
process-copies
- dup perform-renaming ;
\ No newline at end of file
+ dup perform-renaming ;
PRIVATE>
:: live-out? ( vreg node -- ? )
- [let | def [ vreg def-of ] |
- {
- { [ node def eq? ] [ vreg uses-of def only? not ] }
- { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
- [ f ]
- } cond
- ] ;
+ vreg def-of :> def
+ {
+ { [ node def eq? ] [ vreg uses-of def only? not ] }
+ { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
+ [ f ]
+ } cond ;
##compare-imm-branch
##compare-float-ordered-branch
##compare-float-unordered-branch
- } memq?
+ } member-eq?
]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
:: insert-basic-block ( froms to bb -- )
bb froms V{ } like >>predecessors drop
bb to 1vector >>successors drop
- to predecessors>> [ dup froms memq? [ drop bb ] when ] change-each
- froms [ successors>> [ dup to eq? [ drop bb ] when ] change-each ] each ;
+ to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
+ froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
: add-instructions ( bb quot -- )
[ instructions>> building ] dip '[
<<
: input-values ( slot-specs -- slot-specs' )
- [ type>> { use literal constant } memq? ] filter ;
+ [ type>> { use literal constant } member-eq? ] filter ;
: expr-class ( insn -- expr )
name>> "##" ?head drop "-expr" append create-class-in ;
dup ##compare-imm-branch? [
{
[ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ]
+ [ src2>> \ f type-number eq? ]
} 1&&
] [ drop f ] if ; inline
: rewrite-redundant-comparison? ( insn -- ? )
{
[ src1>> vreg>expr general-compare-expr? ]
- [ src2>> \ f tag-number = ]
- [ cc>> { cc= cc/= } memq? ]
+ [ src2>> \ f type-number = ]
+ [ cc>> { cc= cc/= } member-eq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
: (rewrite-self-compare) ( insn -- ? )
- cc>> { cc= cc<= cc>= } memq? ;
+ cc>> { cc= cc<= cc>= } member-eq? ;
: rewrite-self-compare-branch ( insn -- insn' )
(rewrite-self-compare) fold-branch ;
[ dst>> ] dip
{
{ t [ t \ ##load-constant new-insn ] }
- { f [ \ f tag-number \ ##load-immediate new-insn ] }
+ { f [ \ f type-number \ ##load-immediate new-insn ] }
} case ;
: rewrite-self-compare ( insn -- insn' )
##sub-imm
##mul
##mul-imm
- } memq? ;
+ } member-eq? ;
: immediate? ( value op -- ? )
arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
:: rewrite-unbox-displaced-alien ( insn expr -- insns )
[
next-vreg :> temp
- temp expr base>> vn>vreg expr base-class>> insn temp>> ##unbox-c-ptr
+ temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
insn dst>> temp expr displacement>> vn>vreg ##add
] { } make ;
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc> }
- T{ ##compare-imm f 6 4 5 cc/= }
+ T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
- T{ ##compare-imm f 6 4 5 cc= }
+ T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
T{ ##replace f 6 D 0 }
} value-numbering-step trim-temps
] unit-test
T{ ##peek f 8 D 0 }
T{ ##peek f 9 D -1 }
T{ ##compare-float-unordered f 12 8 9 cc< }
- T{ ##compare-imm f 14 12 5 cc= }
+ T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
] unit-test
T{ ##peek f 29 D -1 }
T{ ##peek f 30 D -2 }
T{ ##compare f 33 29 30 cc<= }
- T{ ##compare-imm-branch f 33 5 cc/= }
+ T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
} value-numbering-step trim-temps
] unit-test
{
T{ ##peek f 1 D -1 }
T{ ##test-vector f 2 1 f float-4-rep vcc-any }
- T{ ##compare-imm-branch f 2 5 cc/= }
+ T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
} value-numbering-step trim-temps
] unit-test
! Branch folding
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-immediate f 3 5 }
+ T{ ##load-immediate f 1 10 }
+ T{ ##load-immediate f 2 20 }
+ T{ ##load-immediate f 3 $[ \ f type-number ] }
}
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 1 10 }
+ T{ ##load-immediate f 2 20 }
T{ ##compare f 3 1 2 cc= }
} value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
- T{ ##load-immediate f 3 5 }
+ T{ ##load-immediate f 1 10 }
+ T{ ##load-immediate f 2 20 }
+ T{ ##load-immediate f 3 $[ \ f type-number ] }
}
] [
{
- T{ ##load-immediate f 1 1 }
- T{ ##load-immediate f 2 2 }
+ T{ ##load-immediate f 1 10 }
+ T{ ##load-immediate f 2 20 }
T{ ##compare f 3 2 1 cc< }
} value-numbering-step
] unit-test
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
[
{
T{ ##peek f 0 D 0 }
- T{ ##load-immediate f 1 5 }
+ T{ ##load-immediate f 1 $[ \ f type-number ] }
}
] [
{
{
T{ ##peek f 0 D 0 }
T{ ##compare f 1 0 0 cc<= }
- T{ ##compare-imm-branch f 1 5 cc/= }
+ T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
} test-branch-folding
] unit-test
T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
T{ ##compare-imm-branch
{ src1 21 }
- { src2 5 }
+ { src2 $[ \ f type-number ] }
{ cc cc/= }
}
} 1 test-bb
: write-barriers-step ( bb -- )
H{ } clone fresh-allocations set
H{ } clone mutated-objects set
- instructions>> [ eliminate-write-barrier ] filter-here ;
+ instructions>> [ eliminate-write-barrier ] filter! drop ;
: eliminate-write-barriers ( cfg -- cfg' )
dup [ write-barriers-step ] each-basic-block ;
CODEGEN: ##sqrt-vector %sqrt-vector
CODEGEN: ##horizontal-add-vector %horizontal-add-vector
CODEGEN: ##horizontal-sub-vector %horizontal-sub-vector
-CODEGEN: ##horizontal-shl-vector %horizontal-shl-vector
-CODEGEN: ##horizontal-shr-vector %horizontal-shr-vector
+CODEGEN: ##horizontal-shl-vector-imm %horizontal-shl-vector-imm
+CODEGEN: ##horizontal-shr-vector-imm %horizontal-shr-vector-imm
CODEGEN: ##abs-vector %abs-vector
CODEGEN: ##and-vector %and-vector
CODEGEN: ##andn-vector %andn-vector
CODEGEN: ##or-vector %or-vector
CODEGEN: ##xor-vector %xor-vector
CODEGEN: ##not-vector %not-vector
+CODEGEN: ##shl-vector-imm %shl-vector-imm
+CODEGEN: ##shr-vector-imm %shr-vector-imm
CODEGEN: ##shl-vector %shl-vector
CODEGEN: ##shr-vector %shr-vector
CODEGEN: ##integer>scalar %integer>scalar
generic.single combinators deques search-deques macros
source-files.errors combinators.short-circuit
-stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+stack-checker stack-checker.dependencies stack-checker.inlining
+stack-checker.errors
compiler.errors compiler.units compiler.utilities
compiler.tree.builder
compiler.tree.optimizer
+compiler.crossref
+
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
M: word no-compile?
- {
- [ macro? ]
- [ inline? ]
- [ "special" word-prop ]
- [ "no-compile" word-prop ]
- } 1|| ;
+ { [ macro? ] [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| ;
+
+GENERIC: combinator? ( word -- ? )
+
+M: method-body combinator? "method-generic" word-prop combinator? ;
+
+M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
+
+M: word combinator? inline? ;
: ignore-error? ( word error -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
- [ no-compile? ] [ { [ do-not-compile? ] [ literal-expected? ] } 1|| ] bi* and ;
+ {
+ [ drop no-compile? ]
+ [ [ combinator? ] [ unknown-macro-input? ] bi* and ]
+ } 2|| ;
: finish ( word -- )
#! Recompile callers if the word's stack effect changed, then
] with-scope
"--- compile done" compiler-message ;
+M: optimizing-compiler to-recompile ( -- words )
+ changed-definitions get compiled-usages
+ changed-generics get compiled-generic-usages
+ append assoc-combine keys ;
+
+M: optimizing-compiler process-forgotten-words
+ [ delete-compiled-xref ] each ;
+
: with-optimizer ( quot -- )
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
! These constants must match vm/layouts.h
: slot-offset ( slot tag -- n ) [ bootstrap-cells ] dip - ; inline
-: header-offset ( -- n ) 0 object tag-number slot-offset ; inline
-: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 string tag-number slot-offset ; inline
-: string-aux-offset ( -- n ) 2 string tag-number slot-offset ; inline
-: profile-count-offset ( -- n ) 8 \ word tag-number slot-offset ; inline
-: byte-array-offset ( -- n ) 2 byte-array tag-number slot-offset ; inline
-: alien-offset ( -- n ) 3 alien tag-number slot-offset ; inline
-: underlying-alien-offset ( -- n ) 1 alien tag-number slot-offset ; inline
-: tuple-class-offset ( -- n ) 1 tuple tag-number slot-offset ; inline
-: word-xt-offset ( -- n ) 10 \ word tag-number slot-offset ; inline
-: quot-xt-offset ( -- n ) 4 quotation tag-number slot-offset ; inline
-: word-code-offset ( -- n ) 11 \ word tag-number slot-offset ; inline
-: array-start-offset ( -- n ) 2 array tag-number slot-offset ; inline
+: float-offset ( -- n ) 8 float type-number - ; inline
+: string-offset ( -- n ) 4 string type-number slot-offset ; inline
+: string-aux-offset ( -- n ) 2 string type-number slot-offset ; inline
+: profile-count-offset ( -- n ) 8 \ word type-number slot-offset ; inline
+: byte-array-offset ( -- n ) 16 byte-array type-number - ; inline
+: alien-offset ( -- n ) 4 alien type-number slot-offset ; inline
+: underlying-alien-offset ( -- n ) 1 alien type-number slot-offset ; inline
+: tuple-class-offset ( -- n ) 1 tuple type-number slot-offset ; inline
+: word-xt-offset ( -- n ) 10 \ word type-number slot-offset ; inline
+: quot-xt-offset ( -- n ) 4 quotation type-number slot-offset ; inline
+: word-code-offset ( -- n ) 11 \ word type-number slot-offset ; inline
+: array-start-offset ( -- n ) 2 array type-number slot-offset ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.algebra compiler.units definitions graphs
+grouping kernel namespaces sequences words
+stack-checker.dependencies ;
+IN: compiler.crossref
+
+SYMBOL: compiled-crossref
+
+compiled-crossref [ H{ } clone ] initialize
+
+SYMBOL: compiled-generic-crossref
+
+compiled-generic-crossref [ H{ } clone ] initialize
+
+: compiled-usage ( word -- assoc )
+ compiled-crossref get at ;
+
+: (compiled-usages) ( word -- assoc )
+ #! If the word is not flushable anymore, we have to recompile
+ #! all words which flushable away a call (presumably when the
+ #! word was still flushable). If the word is flushable, we
+ #! don't have to recompile words that folded this away.
+ [ compiled-usage ]
+ [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
+ [ dependency>= nip ] curry assoc-filter ;
+
+: compiled-usages ( seq -- assocs )
+ [ drop word? ] assoc-filter
+ [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+
+: compiled-generic-usage ( word -- assoc )
+ compiled-generic-crossref get at ;
+
+: (compiled-generic-usages) ( generic class -- assoc )
+ [ compiled-generic-usage ] dip
+ [
+ 2dup [ valid-class? ] both?
+ [ classes-intersect? ] [ 2drop f ] if nip
+ ] curry assoc-filter ;
+
+: compiled-generic-usages ( assoc -- assocs )
+ [ (compiled-generic-usages) ] { } assoc>map ;
+
+: (compiled-xref) ( word dependencies word-prop variable -- )
+ [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+
+: compiled-xref ( word dependencies generic-dependencies -- )
+ [ [ drop crossref? ] { } assoc-filter-as ] bi@
+ [ "compiled-uses" compiled-crossref (compiled-xref) ]
+ [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
+ bi-curry* bi ;
+
+: (compiled-unxref) ( word word-prop variable -- )
+ [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
+ [ drop [ remove-word-prop ] curry ]
+ 2bi bi ;
+
+: compiled-unxref ( word -- )
+ [ "compiled-uses" compiled-crossref (compiled-unxref) ]
+ [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
+ bi ;
+
+: delete-compiled-xref ( word -- )
+ [ compiled-unxref ]
+ [ compiled-crossref get delete-at ]
+ [ compiled-generic-crossref get delete-at ]
+ tri ;
<<
: libfactor-ffi-tests-path ( -- string )
- "resource:" (normalize-path)
+ "resource:" absolute-path
{
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
-[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with
-
+[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
] compile-call
] unit-test
-[ 1 t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- [ 0 alien-unsigned-1 ] keep hi-tag
- ] compile-call byte-array type-number =
-] unit-test
-
-[ t ] [
- B{ 1 2 3 4 } [
- { c-ptr } declare
- 0 alien-cell hi-tag
- ] compile-call alien type-number =
-] unit-test
-
[ 2 1 ] [
2 1
[ 2dup fixnum< [ [ die ] dip ] when ] compile-call
[ 2 1 3 ] [ 1 2 3 [ swapd ] compile-call ] unit-test
[ 2 ] [ 1 2 [ nip ] compile-call ] unit-test
[ 3 ] [ 1 2 3 [ 2nip ] compile-call ] unit-test
-[ 2 1 2 ] [ 1 2 [ tuck ] compile-call ] unit-test
[ 1 2 1 ] [ 1 2 [ over ] compile-call ] unit-test
[ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-call ] unit-test
[ 2 1 ] [ 1 2 [ swap ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -8000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
+[ HEX: 8000000 ] [ HEX: -7ffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
-[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+[ t ] [ 1 26 fixnum-shift dup [ fixnum+ ] compile-call 1 27 fixnum-shift = ] unit-test
+[ -134217729 ] [ 1 27 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ -351382792 ] [ -43922849 [ 3 fixnum-shift ] compile-call ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
-[ 268435456 0 ] [ -268435456 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
+[ 134217728 0 ] [ -134217728 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ t ] [ f [ f eq? ] compile-call ] unit-test
! 64-bit overflow
cell 8 = [
- [ t ] [ 1 59 fixnum-shift dup [ fixnum+ ] compile-call 1 60 fixnum-shift = ] unit-test
- [ -1152921504606846977 ] [ 1 60 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+ [ t ] [ 1 58 fixnum-shift dup [ fixnum+ ] compile-call 1 59 fixnum-shift = ] unit-test
+ [ -576460752303423489 ] [ 1 59 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
[ t ] [ 1 40 shift 1 40 shift [ fixnum* ] compile-call 1 80 shift = ] unit-test
[ t ] [ 1 40 shift neg 1 40 shift [ fixnum* ] compile-call 1 80 shift neg = ] unit-test
[ -18446744073709551616 ] [ -1 [ 64 fixnum-shift ] compile-call ] unit-test
[ -18446744073709551616 ] [ -1 [ 32 fixnum-shift 32 fixnum-shift ] compile-call ] unit-test
- [ 1152921504606846976 ] [ -1152921504606846976 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
+ [ 576460752303423488 ] [ -576460752303423488 >fixnum -1 [ fixnum/i ] compile-call ] unit-test
- [ 1152921504606846976 0 ] [ -1152921504606846976 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
+ [ 576460752303423488 0 ] [ -576460752303423488 >fixnum -1 [ fixnum/mod ] compile-call ] unit-test
[ -268435457 ] [ 28 2^ [ fixnum-bitnot ] compile-call ] unit-test
] when
! Some randomized tests
: compiled-fixnum* ( a b -- c ) fixnum* ;
+ERROR: bug-in-fixnum* x y a b ;
+
[ ] [
10000 [
- 32 random-bits >fixnum 32 random-bits >fixnum
- 2dup
- [ fixnum* ] 2keep compiled-fixnum* =
- [ 2drop ] [ "Oops" throw ] if
+ 32 random-bits >fixnum
+ 32 random-bits >fixnum
+ 2dup [ fixnum* ] [ compiled-fixnum* ] 2bi 2dup =
+ [ 2drop 2drop ] [ bug-in-fixnum* ] if
] times
] unit-test
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-call ] unit-test
- [ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
+ [ 3 ] [ "b" get 2 [ { alien fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ ] [ "b" get free ] unit-test
! loading immediates
[ f ] [
V{
- T{ ##load-immediate f 0 5 }
+ T{ ##load-immediate f 0 $[ \ f type-number ] }
} compile-test-bb
] unit-test
! one of the sources
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##slot f 0 0 1 }
} compile-test-bb
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##slot-imm f 0 0 2 $[ array tag-number ] }
+ T{ ##slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
] unit-test
[ t ] [
V{
- T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
+ T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
T{ ##load-reference f 0 { t f t } }
T{ ##set-slot f 0 0 1 }
} compile-test-bb
[ t ] [
V{
T{ ##load-reference f 0 { t f t } }
- T{ ##set-slot-imm f 0 0 2 $[ array tag-number ] }
+ T{ ##set-slot-imm f 0 0 2 $[ array type-number ] }
} compile-test-bb
dup first eq?
] unit-test
-[ 8 ] [
+[ 4 ] [
V{
T{ ##load-immediate f 0 4 }
T{ ##shl f 0 0 0 }
[ 4 ] [
V{
T{ ##load-immediate f 0 4 }
- T{ ##shl-imm f 0 0 3 }
+ T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 31 ] [
V{
T{ ##load-reference f 1 B{ 31 67 52 } }
- T{ ##unbox-any-c-ptr f 0 1 2 }
+ T{ ##unbox-any-c-ptr f 0 1 }
T{ ##alien-unsigned-1 f 0 0 0 }
- T{ ##shl-imm f 0 0 3 }
+ T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
T{ ##load-reference f 0 "hello world" }
T{ ##load-immediate f 1 3 }
T{ ##string-nth f 0 0 1 2 }
- T{ ##shl-imm f 0 0 3 }
+ T{ ##shl-imm f 0 0 4 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
- T{ ##load-immediate f 0 16 }
- T{ ##add-imm f 0 0 -8 }
+ T{ ##load-immediate f 0 32 }
+ T{ ##add-imm f 0 0 -16 }
} compile-test-bb
] unit-test
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler definitions generic.single ;
+compiler definitions generic.single shuffle ;
IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
dup length 1 <= [
from>>
] [
- [ midpoint swap call ] 3keep roll dup zero?
+ [ midpoint swap call ] 3keep [ rot ] dip swap dup zero?
[ drop dup from>> swap midpoint@ + ]
[ drop dup midpoint@ head-slice old-binsearch ] if
] if ; inline recursive
[ 1024 bignum ] [ 10 [ 1 >bignum swap >fixnum shift ] compile-call dup class ] unit-test
! Not sure if I want to fix this...
-! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
\ No newline at end of file
+! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval grouping ;
IN: compiler.tests.redefine3
GENERIC: sheeple ( obj -- x )
: sheeple-test ( -- string ) { } sheeple ;
+: compiled-use? ( key word -- ? )
+ "compiled-uses" word-prop 2 <groups> key? ;
+
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
-[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ t ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ f ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ t ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
-[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
+[ t ] [ object \ sheeple method \ sheeple-test compiled-use? ] unit-test
+[ f ] [ empty-mixin \ sheeple method \ sheeple-test compiled-use? ] unit-test
: bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
-: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
+: stack-trace-any? ( word -- ? ) symbolic-stack-trace member-eq? ;
[ t ] [
[ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
[
<recursive-state> recursive-state set
V{ } clone stack-visitor set
- [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+ [ [ >vector \ meta-d set ] [ length input-count set ] bi ]
[ (build-tree) ]
bi*
] with-infer nip ;
] unit-test
[ t ] [
- [ { array } declare 2 <groups> [ . . ] assoc-each ]
+ [ { array } declare 2 <sliced-groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test
USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
math.partial-dispatch math.intervals classes classes.tuple
-classes.tuple.private layouts definitions stack-checker.state
+classes.tuple.private layouts definitions stack-checker.dependencies
stack-checker.branches
compiler.utilities
compiler.tree
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node
- dup label>> calls>> [ node>> eq? not ] with filter-here ;
+ dup label>> calls>> [ node>> eq? not ] with filter! drop ;
M: #return-recursive delete-node
label>> f >>return drop ;
compiler.tree.recursive compiler.tree.normalization
compiler.tree.checker tools.test kernel math stack-checker.state
accessors combinators io prettyprint words sequences.deep
-sequences.private arrays classes kernel.private ;
+sequences.private arrays classes kernel.private shuffle ;
IN: compiler.tree.dead-code.tests
: count-live-values ( quot -- n )
2bi ;
:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
- [let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
- live-outputs [ outputs filter-live ] |
- new-live-outputs
- live-outputs
- live-outputs
- new-live-outputs
- drop-values
- ] ;
+ inputs outputs filter-corresponding make-values :> new-live-outputs
+ outputs filter-live :> live-outputs
+ new-live-outputs
+ live-outputs
+ live-outputs
+ new-live-outputs
+ drop-values ;
: drop-call-recursive-outputs ( node -- #shuffle )
dup [ label>> return>> in-d>> ] [ out-d>> ] bi
tri 3array ;
:: drop-recursive-inputs ( node -- shuffle )
- [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
- new-outputs [ shuffle out-d>> ] |
- node new-outputs
- [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
- shuffle
- ] ;
+ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs :> shuffle
+ shuffle out-d>> :> new-outputs
+ node new-outputs
+ [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+ shuffle ;
:: drop-recursive-outputs ( node -- shuffle )
- [let* | return [ node label>> return>> ]
- new-inputs [ return in-d>> filter-live ]
- new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
- return
- [ new-inputs >>in-d new-outputs >>out-d drop ]
- [ drop-dead-outputs ]
- bi
- ] ;
+ node label>> return>> :> return
+ return in-d>> filter-live :> new-inputs
+ return [ in-d>> ] [ out-d>> ] bi filter-corresponding :> new-outputs
+ return
+ [ new-inputs >>in-d new-outputs >>out-d drop ]
+ [ drop-dead-outputs ]
+ bi ;
M: #recursive remove-dead-code* ( node -- nodes )
[ drop-recursive-inputs ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
fry locals definitions classes classes.algebra generic
-stack-checker.state
+stack-checker.dependencies
stack-checker.backend
compiler.tree
compiler.tree.propagation.info
filter-corresponding zip #data-shuffle ; inline
:: drop-dead-values ( outputs -- #shuffle )
- [let* | new-outputs [ outputs make-values ]
- live-outputs [ outputs filter-live ] |
- new-outputs
- live-outputs
- outputs
- new-outputs
- drop-values
- ] ;
+ outputs make-values :> new-outputs
+ outputs filter-live :> live-outputs
+ new-outputs
+ live-outputs
+ outputs
+ new-outputs
+ drop-values ;
: drop-dead-outputs ( node -- #shuffle )
dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
{ { { ?b ?a } { ?a ?b } } [ swap ] }
{ { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] }
{ { { ?a ?b } { ?a ?a ?b } } [ dupd ] }
- { { { ?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 ] }
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
: modular-word? ( #call -- ? )
- dup word>> { shift fixnum-shift bignum-shift } memq?
+ dup word>> { shift fixnum-shift bignum-shift } member-eq?
[ node-input-infos second interval>> small-shift? ]
[ word>> "modular-arithmetic" word-prop ]
if ;
] when ;
: like->fixnum? ( #call -- ? )
- word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
+ word>> { >fixnum bignum>fixnum float>fixnum } member-eq? ;
: like->integer? ( #call -- ? )
- word>> { >integer >bignum fixnum>bignum } memq? ;
+ word>> { >integer >bignum fixnum>bignum } member-eq? ;
M: #call optimize-modular-arithmetic*
{
! Method body inlining
SYMBOL: history
-: already-inlined? ( obj -- ? ) history get memq? ;
+: already-inlined? ( obj -- ? ) history get member-eq? ;
: add-to-history ( obj -- ) history [ swap suffix ] change ;
] if ;
: always-inline-word? ( word -- ? )
- { curry compose } memq? ;
+ { curry compose } member-eq? ;
: never-inline-word? ( word -- ? )
{ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] } 1|| ;
classes.tuple alien.accessors classes.tuple.private
slots.private definitions strings.private vectors hashtables
generic quotations alien
-stack-checker.state
+stack-checker.dependencies
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
:: (comparison-constraints) ( in1 in2 op -- constraint )
- [let | i1 [ in1 value-info interval>> ]
- i2 [ in2 value-info interval>> ] |
- in1 i1 i2 op assumption is-in-interval
- in2 i2 i1 op swap-comparison assumption is-in-interval
- /\
- ] ;
+ in1 value-info interval>> :> i1
+ in2 value-info interval>> :> i2
+ in1 i1 i2 op assumption is-in-interval
+ in2 i2 i1 op swap-comparison assumption is-in-interval
+ /\ ;
:: comparison-constraints ( in1 in2 out op -- constraint )
in1 in2 op (comparison-constraints) out t-->
] each
\ alien-cell [
- 2drop simple-alien \ f class-or <class-info>
+ 2drop alien \ f class-or <class-info>
] "outputs" set-word-prop
{ <tuple> <tuple-boa> } [
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
-[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
-[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
+[ t ] [ [ { 1 2 3 } member-eq? ] { member-eq? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap member-eq? ] { member-eq? } inlined? ] unit-test
[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
[ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
] unit-test
-! alien-cell outputs a simple-alien or f
+! alien-cell outputs a alien or f
[ t ] [
[ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
- first simple-alien class=
+ first alien class=
] unit-test
! Don't crash if bad literal inputs are passed to unsafe words
] unit-test
[ t ] [
+ T{ interval f { -268435456 t } { 268435455 t } }
T{ interval f { 1 t } { 268435455 t } }
- T{ interval f { -268435456 t } { 268435455 t } } tuck
+ over
integer generalize-counter-interval =
] unit-test
[ t ] [
+ T{ interval f { -268435456 t } { 268435455 t } }
T{ interval f { 1 t } { 268435455 t } }
- T{ interval f { -268435456 t } { 268435455 t } } tuck
+ over
fixnum generalize-counter-interval =
] unit-test
words namespaces classes.algebra combinators
combinators.short-circuit classes classes.tuple
classes.tuple.private continuations arrays alien.c-types math
-math.private slots generic definitions stack-checker.state
+math.private slots generic definitions stack-checker.dependencies
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? )
- { <array> <byte-array> (byte-array) <string> } memq? ;
+ { <array> <byte-array> (byte-array) <string> } member-eq? ;
: constructor-output-class ( word -- class )
{
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences words fry generic accessors
classes.tuple classes classes.algebra definitions
-stack-checker.state quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals
+stack-checker.dependencies quotations classes.tuple.private math
+math.partial-dispatch math.private math.intervals sets.private
math.floats.private math.integers.private layouts math.order
vectors hashtables combinators effects generalizations assocs
sets combinators.short-circuit sequences.private locals
] [ drop f ] if
] 1 define-partial-eval
-: memq-quot ( seq -- newquot )
+: member-eq-quot ( seq -- newquot )
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
[ drop f ] suffix [ cond ] curry ;
-\ memq? [
- dup sequence? [ memq-quot ] [ drop f ] if
+\ member-eq? [
+ dup sequence? [ member-eq-quot ] [ drop f ] if
] 1 define-partial-eval
! Membership testing
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval
+
+: diff-quot ( seq -- quot: ( seq' -- seq'' ) )
+ tester '[ [ @ not ] filter ] ;
+
+\ diff [ diff-quot ] 1 define-partial-eval
+
+: intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
+ tester '[ _ filter ] ;
+
+\ intersect [ intersect-quot ] 1 define-partial-eval
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
:: compress-path ( source assoc -- destination )
- [let | destination [ source assoc at ] |
- source destination = [ source ] [
- [let | destination' [ destination assoc compress-path ] |
- destination' destination = [
- destination' source assoc set-at
- ] unless
- destination'
- ]
- ] if
- ] ;
+ source assoc at :> destination
+ source destination = [ source ] [
+ destination assoc compress-path :> destination'
+ destination' destination = [
+ destination' source assoc set-at
+ ] unless
+ destination'
+ ] if ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators grouping kernel locals math
-math.matrices math.order multiline sequence-parser sequences
+math.matrices math.order multiline sequences.parser sequences
tools.continuations ;
IN: compression.run-length
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline\r
\r
: future-values ( futures -- futures )\r
- dup [ ?future ] change-each ; inline\r
+ [ ?future ] map! ; inline\r
\r
PRIVATE>\r
\r
{ $values { "port" "a port number between 0 and 65535" } }
{ $description "Starts a node server for receiving messages from remote Factor instances." } ;
+ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"
+"For a Factor instance to be able to send and receive distributed "
+"concurrency messages it must first have " { $link start-node } " called."
+$nl
+"In one factor instance call " { $link start-node } " with the port 9000, "
+"and in another with the port 9001."
+$nl
+"In this example the Factor instance associated with port 9000 will run "
+"a thread that sits receiving messages and printing the received message "
+"in the listener. The code to start the thread is: "
+{ $examples
+ { $unchecked-example
+ ": log-message ( -- ) receive . flush log-message ;"
+ "[ log-message ] \"logger\" spawn dup name>> register-remote-thread"
+ }
+}
+"This spawns a thread waits for the messages. It registers that thread as a "
+"able to be accessed remotely using " { $link register-remote-thread } "."
+$nl
+"The second Factor instance, the one associated with port 9001, can send "
+"messages to the 'logger' thread by name:"
+{ $examples
+ { $unchecked-example
+ "USING: io.sockets concurrency.messaging concurrency.distributed ;"
+ "\"hello\" \"127.0.0.1\" 9000 <inet4> \"logger\" <remote-thread> send"
+ }
+}
+"The " { $link send } " word is used to send messages to other threads. If an "
+"instance of " { $link remote-thread } " is provided instead of a thread then "
+"the message is marshalled to the named thread on the given machine using the "
+{ $vocab-link "serialize" } " vocabulary."
+$nl
+"Running this code should show the message \"hello\" in the first Factor "
+"instance."
+$nl
+"It is also possible to use " { $link send-synchronous } " to receive a "
+"response to a distributed message. When an instance of " { $link thread } " "
+"is marshalled it is converted into an instance of " { $link remote-thread }
+". The receiver of this can use it as the target of a " { $link send }
+" or " { $link reply } " call." ;
+
ARTICLE: "concurrency.distributed" "Distributed message passing"
"The " { $vocab-link "concurrency.distributed" } " implements transparent distributed message passing, inspired by Erlang and Termite."
{ $subsections start-node }
-"Instances of " { $link thread } " can be sent to remote processes, at which point they are converted to objects holding the thread ID and the current node's host name:"
-{ $subsections remote-process }
-"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket." ;
+"Instances of " { $link thread } " can be sent to remote threads, at which point they are converted to objects holding the thread ID and the current node's host name:"
+{ $subsections remote-thread }
+"The " { $vocab-link "serialize" } " vocabulary is used to convert Factor objects to byte arrays for transfer over a socket."
+{ $subsections "concurrency.distributed.example" } ;
+
ABOUT: "concurrency.distributed"
[ ] [
[
receive first2 [ 3 + ] dip send
- "thread-a" unregister-process
+ "thread-a" unregister-remote-thread
] "Thread A" spawn
- "thread-a" swap register-process
+ "thread-a" register-remote-thread
] unit-test
[ 8 ] [
5 self 2array
- "thread-a" test-node <remote-process> send
+ test-node "thread-a" <remote-thread> send
receive
] unit-test
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
-io.servers.connection io.encodings.binary
+io.servers.connection io.encodings.binary assocs init
arrays namespaces kernel accessors ;
FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed
+<PRIVATE
+
+: registered-remote-threads ( -- hash )
+ \ registered-remote-threads get-global ;
+
+PRIVATE>
+
+: register-remote-thread ( thread name -- )
+ registered-remote-threads set-at ;
+
+: unregister-remote-thread ( name -- )
+ registered-remote-threads delete-at ;
+
+: get-remote-thread ( name -- thread )
+ dup registered-remote-threads at [ ] [ thread ] ?if ;
+
SYMBOL: local-node
: handle-node-client ( -- )
deserialize
- [ first2 get-process send ] [ stop-this-server ] if* ;
+ [ first2 get-remote-thread send ] [ stop-this-server ] if* ;
: <node-server> ( addrspec -- threaded-server )
binary <threaded-server>
: start-node ( port -- )
host-name over <inet> (start-node) ;
-TUPLE: remote-process id node ;
+TUPLE: remote-thread node id ;
-C: <remote-process> remote-process
+C: <remote-thread> remote-thread
: send-remote-message ( message node -- )
binary [ serialize ] with-client ;
-M: remote-process send ( message thread -- )
+M: remote-thread send ( message thread -- )
[ id>> 2array ] [ node>> ] bi
send-remote-message ;
M: thread (serialize) ( obj -- )
- id>> local-node get-global <remote-process>
+ id>> [ local-node get-global ] dip <remote-thread>
(serialize) ;
: stop-node ( node -- )
f swap send-remote-message ;
+
+[
+ H{ } clone \ registered-remote-threads set-global
+] "remote-thread-registry" add-init-hook
+
+
IN: concurrency.exchangers.tests\r
\r
:: exchanger-test ( -- string )\r
- [let |\r
- ex [ <exchanger> ]\r
- c [ 2 <count-down> ]\r
- v1! [ f ]\r
- v2! [ f ]\r
- pr [ <promise> ] |\r
+ <exchanger> :> ex\r
+ 2 <count-down> :> c\r
+ f :> v1!\r
+ f :> v2!\r
+ <promise> :> pr\r
\r
- [\r
- c await\r
- v1 ", " v2 3append pr fulfill\r
- ] "Awaiter" spawn drop\r
+ [\r
+ c await\r
+ v1 ", " v2 3append pr fulfill\r
+ ] "Awaiter" spawn drop\r
\r
- [\r
- "Goodbye world" ex exchange v1! c count-down\r
- ] "Exchanger 1" spawn drop\r
+ [\r
+ "Goodbye world" ex exchange v1! c count-down\r
+ ] "Exchanger 1" spawn drop\r
\r
- [\r
- "Hello world" ex exchange v2! c count-down\r
- ] "Exchanger 2" spawn drop\r
+ [\r
+ "Hello world" ex exchange v2! c count-down\r
+ ] "Exchanger 2" spawn drop\r
\r
- pr ?promise\r
- ] ;\r
+ pr ?promise ;\r
\r
[ "Hello world, Goodbye world" ] [ exchanger-test ] unit-test\r
IN: concurrency.flags.tests\r
\r
:: flag-test-1 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
:: flag-test-2 ( -- ? )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f lower-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f lower-flag\r
+ f value>> ;\r
\r
[ f ] [ flag-test-2 ] unit-test\r
\r
:: flag-test-3 ( -- val )\r
- [let | f [ <flag> ] |\r
- f raise-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ f raise-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-3 ] unit-test\r
\r
:: flag-test-4 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-4 ] unit-test\r
\r
:: flag-test-5 ( -- val )\r
- [let | f [ <flag> ] |\r
- [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
- f wait-for-flag\r
- f value>>\r
- ] ;\r
+ <flag> :> f\r
+ [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
+ f wait-for-flag\r
+ f value>> ;\r
\r
[ t ] [ flag-test-5 ] unit-test\r
\r
IN: concurrency.locks.tests\r
\r
:: lock-test-0 ( -- v )\r
- [let | v [ V{ } clone ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
:: lock-test-1 ( -- v )\r
- [let | v [ V{ } clone ]\r
- l [ <lock> ]\r
- c [ 2 <count-down> ] |\r
-\r
- [\r
- l [\r
- yield\r
- 1 v push\r
- yield\r
- 2 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 1" spawn drop\r
-\r
- [\r
- l [\r
- yield\r
- 3 v push\r
- yield\r
- 4 v push\r
- ] with-lock\r
- c count-down\r
- ] "Lock test 2" spawn drop\r
-\r
- c await\r
- v\r
- ] ;\r
+ V{ } clone :> v\r
+ <lock> :> l\r
+ 2 <count-down> :> c\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 1 v push\r
+ yield\r
+ 2 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 1" spawn drop\r
+\r
+ [\r
+ l [\r
+ yield\r
+ 3 v push\r
+ yield\r
+ 4 v push\r
+ ] with-lock\r
+ c count-down\r
+ ] "Lock test 2" spawn drop\r
+\r
+ c await\r
+ v ;\r
\r
[ V{ 1 3 2 4 } ] [ lock-test-0 ] unit-test\r
[ V{ 1 2 3 4 } ] [ lock-test-1 ] unit-test\r
[ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test\r
\r
:: rw-lock-test-1 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 1 <count-down> ]\r
- c'' [ 4 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- yield\r
- 3 v push\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 4 v push\r
- 1 seconds sleep\r
- 5 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 2 v push\r
- c' count-down\r
- ] with-read-lock\r
- c'' count-down\r
- ] "R/W lock test 4" spawn drop\r
-\r
- [\r
- c' await\r
- l [\r
- 6 v push\r
- ] with-write-lock\r
- c'' count-down\r
- ] "R/W lock test 5" spawn drop\r
-\r
- c'' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 1 <count-down> :> c'\r
+ 4 <count-down> :> c''\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ yield\r
+ 3 v push\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 4 v push\r
+ 1 seconds sleep\r
+ 5 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 2 v push\r
+ c' count-down\r
+ ] with-read-lock\r
+ c'' count-down\r
+ ] "R/W lock test 4" spawn drop\r
+\r
+ [\r
+ c' await\r
+ l [\r
+ 6 v push\r
+ ] with-write-lock\r
+ c'' count-down\r
+ ] "R/W lock test 5" spawn drop\r
+\r
+ c'' await\r
+ v ;\r
\r
[ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test\r
\r
:: rw-lock-test-2 ( -- v )\r
- [let | l [ <rw-lock> ]\r
- c [ 1 <count-down> ]\r
- c' [ 2 <count-down> ]\r
- v [ V{ } clone ] |\r
-\r
- [\r
- l [\r
- 1 v push\r
- c count-down\r
- 1 seconds sleep\r
- 2 v push\r
- ] with-write-lock\r
- c' count-down\r
- ] "R/W lock test 1" spawn drop\r
-\r
- [\r
- c await\r
- l [\r
- 3 v push\r
- ] with-read-lock\r
- c' count-down\r
- ] "R/W lock test 2" spawn drop\r
-\r
- c' await\r
- v\r
- ] ;\r
+ <rw-lock> :> l\r
+ 1 <count-down> :> c\r
+ 2 <count-down> :> c'\r
+ V{ } clone :> v\r
+\r
+ [\r
+ l [\r
+ 1 v push\r
+ c count-down\r
+ 1 seconds sleep\r
+ 2 v push\r
+ ] with-write-lock\r
+ c' count-down\r
+ ] "R/W lock test 1" spawn drop\r
+\r
+ [\r
+ c await\r
+ l [\r
+ 3 v push\r
+ ] with-read-lock\r
+ c' count-down\r
+ ] "R/W lock test 2" spawn drop\r
+\r
+ c' await\r
+ v ;\r
\r
[ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test\r
\r
! Test lock timeouts\r
:: lock-timeout-test ( -- v )\r
- [let | l [ <lock> ] |\r
- [\r
- l [ 1 seconds sleep ] with-lock\r
- ] "Lock holder" spawn drop\r
+ <lock> :> l\r
\r
- [\r
- l 1/10 seconds [ ] with-lock-timeout\r
- ] "Lock timeout-er" spawn-linked drop\r
+ [\r
+ l [ 1 seconds sleep ] with-lock\r
+ ] "Lock holder" spawn drop\r
+\r
+ [\r
+ l 1/10 seconds [ ] with-lock-timeout\r
+ ] "Lock timeout-er" spawn-linked drop\r
\r
- receive\r
- ] ;\r
+ receive ;\r
\r
[ lock-timeout-test ] [\r
thread>> name>> "Lock timeout-er" =\r
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup concurrency.messaging.private
+USING: help.syntax help.markup
threads kernel arrays quotations strings ;
IN: concurrency.messaging
receive [\r
data>> swap call\r
] keep reply-synchronous ; inline\r
-\r
-<PRIVATE\r
-\r
-: registered-processes ( -- hash )\r
- \ registered-processes get-global ;\r
-\r
-PRIVATE>\r
-\r
-: register-process ( name process -- )\r
- swap registered-processes set-at ;\r
-\r
-: unregister-process ( name -- )\r
- registered-processes delete-at ;\r
-\r
-: get-process ( name -- process )\r
- dup registered-processes at [ ] [ thread ] ?if ;\r
-\r
-\ registered-processes [ H{ } clone ] initialize\r
M: simple-cord length
[ first>> length ] [ second>> length ] bi + ; inline
-M: simple-cord virtual-seq first>> ; inline
+M: simple-cord virtual-exemplar first>> ; inline
M: simple-cord virtual@
2dup first>> length <
seqs>> [ first <=> ] with search nip
[ first - ] [ second ] bi ; inline
-M: multi-cord virtual-seq
+M: multi-cord virtual-exemplar
seqs>> [ f ] [ first second ] if-empty ; inline
: <cord> ( seqs -- cord )
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test core-text core-text.fonts core-foundation
core-foundation.dictionaries destructors arrays kernel generalizations
-math accessors core-foundation.utilities combinators hashtables colors
+locals math accessors core-foundation.utilities combinators hashtables colors
colors.constants ;
IN: core-text.tests
] with-destructors
] unit-test
-: test-typographic-bounds ( string font -- ? )
+:: test-typographic-bounds ( string font -- ? )
[
- test-font &CFRelease tuck COLOR: white <CTLine> &CFRelease
- compute-line-metrics {
+ font test-font &CFRelease :> ctfont
+ string ctfont COLOR: white <CTLine> &CFRelease :> ctline
+ ctfont ctline compute-line-metrics {
[ width>> float? ]
[ ascent>> float? ]
[ descent>> float? ]
[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
-[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
\ No newline at end of file
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
[
line new-disposable
- [let* | open-font [ font cache-font ]
- line [ string open-font font foreground>> <CTLine> |CFRelease ]
-
- rect [ line line-rect ]
- (loc) [ rect origin>> CGPoint>loc ]
- (dim) [ rect size>> CGSize>dim ]
- (ext) [ (loc) (dim) v+ ]
- loc [ (loc) [ floor ] map ]
- ext [ (loc) (dim) [ + ceiling ] 2map ]
- dim [ ext loc [ - >integer 1 max ] 2map ]
- metrics [ open-font line compute-line-metrics ] |
-
- line >>line
-
- metrics >>metrics
-
- dim [
- {
- [ font dim fill-background ]
- [ loc dim line string fill-selection-background ]
- [ loc set-text-position ]
- [ [ line ] dip CTLineDraw ]
- } cleave
- ] make-bitmap-image >>image
-
- metrics loc dim line-loc >>loc
-
- metrics metrics>dim >>dim
- ]
+ font cache-font :> open-font
+ string open-font font foreground>> <CTLine> |CFRelease :> line
+
+ line line-rect :> rect
+ rect origin>> CGPoint>loc :> (loc)
+ rect size>> CGSize>dim :> (dim)
+ (loc) (dim) v+ :> (ext)
+ (loc) [ floor ] map :> loc
+ (loc) (dim) [ + ceiling ] 2map :> ext
+ ext loc [ - >integer 1 max ] 2map :> dim
+ open-font line compute-line-metrics :> metrics
+
+ line >>line
+
+ metrics >>metrics
+
+ dim [
+ {
+ [ font dim fill-background ]
+ [ loc dim line string fill-selection-background ]
+ [ loc set-text-position ]
+ [ [ line ] dip CTLineDraw ]
+ } cleave
+ ] make-bitmap-image >>image
+
+ metrics loc dim line-loc >>loc
+
+ metrics metrics>dim >>dim
] with-destructors ;
M: line dispose* line>> CFRelease ;
{ ulonglong-scalar-rep longlong-scalar-rep }
} ?at drop ;
+: widen-vector-rep ( rep -- rep' )
+ {
+ { char-16-rep short-8-rep }
+ { short-8-rep int-4-rep }
+ { int-4-rep longlong-2-rep }
+ { uchar-16-rep ushort-8-rep }
+ { ushort-8-rep uint-4-rep }
+ { uint-4-rep ulonglong-2-rep }
+ } at ;
+
! Register classes
SINGLETONS: int-regs float-regs ;
HOOK: %not-vector cpu ( dst src rep -- )
HOOK: %shl-vector cpu ( dst src1 src2 rep -- )
HOOK: %shr-vector cpu ( dst src1 src2 rep -- )
-HOOK: %horizontal-shl-vector cpu ( dst src1 src2 rep -- )
-HOOK: %horizontal-shr-vector cpu ( dst src1 src2 rep -- )
+HOOK: %shl-vector-imm cpu ( dst src1 src2 rep -- )
+HOOK: %shr-vector-imm cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shl-vector-imm cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-shr-vector-imm cpu ( dst src1 src2 rep -- )
HOOK: %integer>scalar cpu ( dst src rep -- )
HOOK: %scalar>integer cpu ( dst src rep -- )
HOOK: %not-vector-reps cpu ( -- reps )
HOOK: %shl-vector-reps cpu ( -- reps )
HOOK: %shr-vector-reps cpu ( -- reps )
-HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
-HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
+HOOK: %shl-vector-imm-reps cpu ( -- reps )
+HOOK: %shr-vector-imm-reps cpu ( -- reps )
+HOOK: %horizontal-shl-vector-imm-reps cpu ( -- reps )
+HOOK: %horizontal-shr-vector-imm-reps cpu ( -- reps )
M: object %zero-vector-reps { } ;
M: object %fill-vector-reps { } ;
M: object %not-vector-reps { } ;
M: object %shl-vector-reps { } ;
M: object %shr-vector-reps { } ;
-M: object %horizontal-shl-vector-reps { } ;
-M: object %horizontal-shr-vector-reps { } ;
+M: object %shl-vector-imm-reps { } ;
+M: object %shr-vector-imm-reps { } ;
+M: object %horizontal-shl-vector-imm-reps { } ;
+M: object %horizontal-shr-vector-imm-reps { } ;
HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 0 3 \ f tag-number CMPI\r
+ 0 3 \ f type-number CMPI\r
2 BEQ\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
0 B rc-relative-ppc-3 rt-xt jit-rel\r
\r
[ load-tag ] pic-tag jit-define\r
\r
-! Hi-tag\r
-[\r
- 3 4 MR\r
- load-tag\r
- 0 4 object tag-number tag-fixnum CMPI\r
- 2 BNE\r
- 4 3 object tag-number neg LWZ\r
-] pic-hi-tag jit-define\r
-\r
! Tuple\r
[\r
3 4 MR\r
load-tag\r
- 0 4 tuple tag-number tag-fixnum CMPI\r
+ 0 4 tuple type-number tag-fixnum CMPI\r
2 BNE\r
- 4 3 tuple tag-number neg bootstrap-cell + LWZ\r
+ 4 3 tuple type-number neg bootstrap-cell + LWZ\r
] pic-tuple jit-define\r
\r
-! Hi-tag and tuple\r
-[\r
- 3 4 MR\r
- load-tag\r
- ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
- 0 4 BIN: 110 tag-fixnum CMPI\r
- 5 BLT\r
- ! Untag r3\r
- 3 3 0 0 31 tag-bits get - RLWINM\r
- ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
- 4 4 1 tag-fixnum ANDI\r
- 4 4 1 SRAWI\r
- ! Load header cell or tuple layout cell\r
- 4 4 3 LWZX\r
-] pic-hi-tag-tuple jit-define\r
-\r
[\r
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
] pic-check-tag jit-define\r
[\r
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
4 0 5 CMP\r
-] pic-check jit-define\r
+] pic-check-tuple jit-define\r
\r
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
\r
[\r
! cache = ...\r
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
- ! key = class\r
- 5 4 MR\r
+ ! key = hashcode(class)\r
+ 5 4 3 SRAWI\r
+ 6 4 8 SRAWI\r
+ 5 5 6 ADD\r
+ 6 4 13 SRAWI\r
+ 5 5 6 ADD\r
+ 5 5 3 SLWI\r
! key &= cache.length - 1\r
5 5 mega-cache-size get 1 - bootstrap-cell * ANDI\r
! cache += array-start-offset\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- 3 3 1 SRAWI\r
+ 3 3 2 SRAWI\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
3 ds-reg 4 STWU\r
] \ 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
-] \ tuck define-sub-primitive\r
-\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
2 swap execute( offset -- ) ! magic number\r
- \ f tag-number 3 LI\r
+ \ f type-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
4 ds-reg 0 LWZ\r
3 3 4 OR\r
3 3 tag-mask get ANDI\r
- \ f tag-number 4 LI\r
+ \ f type-number 4 LI\r
0 3 0 CMPI\r
2 BNE\r
1 tag-fixnum 4 LI\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser layouts system kernel ;
+USING: parser layouts system kernel sequences ;
IN: bootstrap.ppc
: c-area-size ( -- n ) 10 bootstrap-cells ;
: lr-save ( -- n ) bootstrap-cell ;
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
call
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser layouts system kernel ;
+USING: parser layouts system kernel sequences ;
IN: bootstrap.ppc
: c-area-size ( -- n ) 14 bootstrap-cells ;
: lr-save ( -- n ) 2 bootstrap-cells ;
-<< "vocab:cpu/ppc/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/ppc/bootstrap.factor" parse-file suffix! >>
call
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
- 0 scratch-reg \ f tag-number CMPI
+ 0 scratch-reg \ f type-number CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
"end" resolve-label
] with-scope ;
-: alien@ ( n -- n' ) cells object tag-number - ;
-
-:: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- temp \ f tag-number %load-immediate
- ! Store underlying-alien slot
- base dst 1 alien@ STW
- ! Store expired slot
- temp dst 2 alien@ STW
- ! Store offset
- displacement dst 3 alien@ STW ;
+: alien@ ( n -- n' ) cells alien type-number - ;
M:: ppc %box-alien ( dst src temp -- )
[
"f" define-label
- dst \ f tag-number %load-immediate
+ dst %load-immediate
0 src 0 CMPI
"f" get BEQ
- dst src temp temp %allot-alien
+ dst 5 cells alien temp %allot
+ temp \ f type-number %load-immediate
+ temp dst 1 alien@ STW
+ temp dst 2 alien@ STW
+ displacement dst 3 alien@ STW
+ displacement dst 4 alien@ STW
"f" resolve-label
] with-scope ;
displacement' :> temp
dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it
- 0 base \ f tag-number CMPI
+ 0 base \ f type-number CMPI
"simple-case" get BEQ
temp base header-offset LWZ
0 temp alien type-number tag-fixnum CMPI
! Store offset
displacement' dst 3 alien@ STW
! Store expired slot (its ok to clobber displacement')
- temp \ f tag-number %load-immediate
+ temp \ f type-number %load-immediate
temp dst 2 alien@ STW
"end" resolve-label
] with-scope ;
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
- scratch-reg allot-ptr n 8 align ADDI
+ scratch-reg allot-ptr n data-alignment get align ADDI
scratch-reg nursery-ptr 0 STW ;
:: store-header ( dst class -- )
scratch-reg dst 0 STW ;
: store-tagged ( dst tag -- )
- dupd tag-number ORI ;
+ dupd type-number ORI ;
M:: ppc %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
- dst \ f tag-number %load-immediate
+ dst \ f type-number %load-immediate
"end" get branch1 execute( label -- )
branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
- src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
+ src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
dst temp branch1 branch2 (%boolean) ;
:: %branch ( label cc -- )
branch2 [ label branch2 execute( label -- ) ] when ; inline
M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
- src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
+ src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> ( branch1 branch2 )
label branch1 branch2 (%branch) ;
: load-from-frame ( dst n rep -- )
} cond
"complex-double" c-type t >>return-in-registers? drop
-
-[
- <c-type>
- [ alien-unsigned-4 c-bool> ] >>getter
- [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
- 4 >>size
- 4 >>align
- "box_boolean" >>boxer
- "to_boolean" >>unboxer
- bool define-primitive-type
-] with-compilation-unit
cpu.architecture ;
IN: cpu.x86.32
-! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned.
-
M: x86.32 machine-registers
{
{ int-regs { EAX ECX EDX EBP EBX } }
! Dreadful
M: object flatten-value-type (flatten-int-type) ;
-os windows? [
- cell longlong c-type (>>align)
- cell ulonglong c-type (>>align)
- 4 double c-type (>>align)
-] unless
-
check-sse
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler cpu.x86.assembler.operands layouts
-vocabs parser compiler.constants ;
+vocabs parser compiler.constants sequences ;
IN: bootstrap.x86
4 \ cell set
: stack-reg ( -- reg ) ESP ;
: ds-reg ( -- reg ) ESI ;
: rs-reg ( -- reg ) EDI ;
-: fixnum>slot@ ( -- ) temp0 1 SAR ;
+: fixnum>slot@ ( -- ) temp0 2 SAR ;
: rex-length ( -- n ) 0 ;
[
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
-<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
layouts vocabs parser compiler.constants math
-cpu.x86.assembler cpu.x86.assembler.operands ;
+cpu.x86.assembler cpu.x86.assembler.operands sequences ;
IN: bootstrap.x86
8 \ cell set
: stack-reg ( -- reg ) RSP ;
: ds-reg ( -- reg ) R14 ;
: rs-reg ( -- reg ) R15 ;
-: fixnum>slot@ ( -- ) ;
+: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
[
temp1 JMP
] jit-primitive jit-define
-<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
call
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.private kernel namespaces system
-cpu.x86.assembler cpu.x86.assembler.operands layouts vocabs parser ;
+USING: bootstrap.image.private cpu.x86.assembler
+cpu.x86.assembler.operands kernel layouts namespaces parser
+sequences system vocabs ;
IN: bootstrap.x86
: stack-frame-size ( -- n ) 4 bootstrap-cells ;
: arg1 ( -- reg ) RDI ;
: arg2 ( -- reg ) RSI ;
-<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
call
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
-layouts vocabs parser cpu.x86.assembler
+layouts vocabs parser sequences cpu.x86.assembler parser
cpu.x86.assembler.operands ;
IN: bootstrap.x86
: arg1 ( -- reg ) RCX ;
: arg2 ( -- reg ) RDX ;
-<< "vocab:cpu/x86/64/bootstrap.factor" parse-file parsed >>
+<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
call
M: x86.64 temp-reg RAX ;
-<<
-longlong ptrdiff_t typedef
-longlong intptr_t typedef
-int c-type long define-primitive-type
-uint c-type ulong define-primitive-type
->>
ERROR: bad-index indirect ;
: check-ESP ( indirect -- indirect )
- dup index>> { ESP RSP } memq? [ bad-index ] when ;
+ dup index>> { ESP RSP } member-eq? [ bad-index ] when ;
: canonicalize ( indirect -- indirect )
#! Modify the indirect to work around certain addressing mode
C: <byte> byte
: extended-8-bit-register? ( register -- ? )
- { SPL BPL SIL DIL } memq? ;
+ { SPL BPL SIL DIL } member-eq? ;
: n-bit-version-of ( register n -- register' )
! Certain 8-bit registers don't exist in 32-bit mode...
: 16-bit-version-of ( register -- register' ) 16 n-bit-version-of ;
: 32-bit-version-of ( register -- register' ) 32 n-bit-version-of ;
: 64-bit-version-of ( register -- register' ) 64 n-bit-version-of ;
-: native-version-of ( register -- register' ) cell-bits n-bit-version-of ;
\ No newline at end of file
+: native-version-of ( register -- register' ) cell-bits n-bit-version-of ;
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: bootstrap.image.private kernel kernel.private namespaces system
-layouts compiler.units math math.private compiler.constants vocabs
-slots.private words locals.backend make sequences combinators arrays
- cpu.x86.assembler cpu.x86.assembler.operands ;
+USING: bootstrap.image.private compiler.constants
+compiler.units cpu.x86.assembler cpu.x86.assembler.operands
+kernel kernel.private layouts locals.backend make math
+math.private namespaces sequences slots.private vocabs ;
IN: bootstrap.x86
big-endian off
! pop boolean
ds-reg bootstrap-cell SUB
! compare boolean with f
- temp0 \ f tag-number CMP
+ temp0 \ f type-number CMP
! jump to true branch if not equal
0 JNE rc-relative rt-xt jit-rel
! jump to false branch if equal
! ! ! Polymorphic inline caches
-! The PIC and megamorphic code stubs are not permitted to touch temp3.
+! The PIC stubs are not permitted to touch temp3.
! Load a value from a stack position
[
! The 'make' trick lets us compute the jump distance for the
! conditional branches there
-! Hi-tag
-[
- temp0 temp1 MOV
- load-tag
- temp1 object tag-number tag-fixnum CMP
- [ temp1 temp0 object tag-number neg [+] MOV ] { } make
- [ length JNE ] [ % ] bi
-] pic-hi-tag jit-define
-
! Tuple
[
temp0 temp1 MOV
load-tag
- temp1 tuple tag-number tag-fixnum CMP
- [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+ temp1 tuple type-number tag-fixnum CMP
+ [ temp1 temp0 tuple type-number neg bootstrap-cell + [+] MOV ] { } make
[ length JNE ] [ % ] bi
] pic-tuple jit-define
-! Hi-tag and tuple
-[
- temp0 temp1 MOV
- load-tag
- ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
- temp1 BIN: 110 tag-fixnum CMP
- [
- ! Untag temp0
- temp0 tag-mask get bitnot AND
- ! Set temp1 to 0 for objects, and bootstrap-cell for tuples
- temp1 1 tag-fixnum AND
- bootstrap-cell 4 = [ temp1 1 SHR ] when
- ! Load header cell or tuple layout cell
- temp1 temp0 temp1 [+] MOV
- ] [ ] make [ length JL ] [ % ] bi
-] pic-hi-tag-tuple jit-define
-
[
temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
] pic-check-tag jit-define
[
temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
temp1 temp2 CMP
-] pic-check jit-define
+] pic-check-tuple jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
[
! cache = ...
temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
- ! key = class
+ ! key = hashcode(class)
temp2 temp1 MOV
- bootstrap-cell 8 = [ temp2 1 SHL ] when
+ bootstrap-cell 4 = [ temp2 1 SHR ] when
! key &= cache.length - 1
temp2 mega-cache-size get 1 - bootstrap-cell * AND
! cache += array-start-offset
ds-reg [] temp0 MOV
] \ dupd define-sub-primitive
-[
- temp0 ds-reg [] MOV
- temp1 ds-reg -1 bootstrap-cells [+] MOV
- ds-reg bootstrap-cell ADD
- ds-reg [] temp0 MOV
- ds-reg -1 bootstrap-cells [+] temp1 MOV
- ds-reg -2 bootstrap-cells [+] temp0 MOV
-] \ tuck define-sub-primitive
-
[
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
t jit-literal
temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
- temp1 \ f tag-number MOV
+ temp1 \ f type-number MOV
! load first value
temp0 ds-reg [] MOV
! adjust stack pointer
ds-reg bootstrap-cell SUB
temp0 ds-reg [] OR
temp0 tag-mask get AND
- temp0 \ f tag-number MOV
+ temp0 \ f type-number MOV
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.x86.features cpu.x86.features.private cpu.architecture kernel
kernel.private math memory namespaces make sequences words system
-layouts combinators math.order fry locals compiler.constants
+layouts combinators math.order math.vectors fry locals compiler.constants
byte-arrays io macros quotations compiler compiler.units init vm
compiler.cfg.registers
compiler.cfg.instructions
: incr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-: align-stack ( n -- n' )
- os macosx? cpu x86.64? or [ 16 align ] when ;
+: align-stack ( n -- n' ) 16 align ;
M: x86 stack-frame-size ( stack-frame -- i )
[ (stack-frame-size) ]
M: x86 %neg int-rep one-operand NEG ;
M: x86 %log2 BSR ;
+! A bit of logic to avoid using MOVSS/MOVSD for reg-reg moves
+! since this induces partial register stalls
GENERIC: copy-register* ( dst src rep -- )
+GENERIC: copy-memory* ( dst src rep -- )
M: int-rep copy-register* drop MOV ;
M: tagged-rep copy-register* drop MOV ;
-M: float-rep copy-register* drop MOVSS ;
-M: double-rep copy-register* drop MOVSD ;
-M: float-4-rep copy-register* drop MOVUPS ;
-M: double-2-rep copy-register* drop MOVUPD ;
-M: vector-rep copy-register* drop MOVDQU ;
+M: float-rep copy-register* drop MOVAPS ;
+M: double-rep copy-register* drop MOVAPS ;
+M: float-4-rep copy-register* drop MOVAPS ;
+M: double-2-rep copy-register* drop MOVAPS ;
+M: vector-rep copy-register* drop MOVDQA ;
+
+M: object copy-memory* copy-register* ;
+M: float-rep copy-memory* drop MOVSS ;
+M: double-rep copy-memory* drop MOVSD ;
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
- copy-register*
+ 2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %fixnum-add ( label dst src1 src2 -- )
M: x86 %unbox-alien ( dst src -- )
alien-offset [+] MOV ;
-M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+M:: x86 %unbox-any-c-ptr ( dst src -- )
[
- { "is-byte-array" "end" "start" } [ define-label ] each
- dst 0 MOV
- temp src MOV
- ! We come back here with displaced aliens
- "start" resolve-label
+ "end" define-label
+ dst dst XOR
! Is the object f?
- temp \ f tag-number CMP
+ src \ f type-number CMP
"end" get JE
+ ! Compute tag in dst register
+ dst src MOV
+ dst tag-mask get AND
! Is the object an alien?
- temp header-offset [+] alien type-number tag-fixnum CMP
- "is-byte-array" get JNE
- ! If so, load the offset and add it to the address
- dst temp alien-offset [+] ADD
- ! Now recurse on the underlying alien
- temp temp underlying-alien-offset [+] MOV
- "start" get JMP
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- dst temp ADD
+ dst alien type-number CMP
! Add an offset to start of byte array's data
- dst byte-array-offset ADD
+ dst src byte-array-offset [+] LEA
+ "end" get JNE
+ ! If so, load the offset and add it to the address
+ dst src alien-offset [+] MOV
"end" resolve-label
] with-scope ;
-: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
-
-:: %allot-alien ( dst displacement base temp -- )
- dst 4 cells alien temp %allot
- dst 1 alien@ base MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement MOV ! displacement
- ;
+: alien@ ( reg n -- op ) cells alien type-number - [+] ;
M:: x86 %box-alien ( dst src temp -- )
[
"end" define-label
- dst \ f tag-number MOV
- src 0 CMP
+ dst \ f type-number MOV
+ src src TEST
"end" get JE
- dst src \ f tag-number temp %allot-alien
+ dst 5 cells alien temp %allot
+ dst 1 alien@ \ f type-number MOV ! base
+ dst 2 alien@ \ f type-number MOV ! expired
+ dst 3 alien@ src MOV ! displacement
+ dst 4 alien@ src MOV ! address
"end" resolve-label
] with-scope ;
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
+ ! This is ridiculous
[
"end" define-label
- "ok" define-label
+ "not-f" define-label
+ "not-alien" define-label
+
! If displacement is zero, return the base
dst base MOV
- displacement 0 CMP
+ displacement displacement TEST
"end" get JE
- ! Quickly use displacement' before its needed for real, as allot temporary
- dst 4 cells alien displacement' %allot
- ! If base is already a displaced alien, unpack it
- base' base MOV
- displacement' displacement MOV
- base \ f tag-number CMP
- "ok" get JE
- base header-offset [+] alien type-number tag-fixnum CMP
- "ok" get JNE
- ! displacement += base.displacement
- displacement' base 3 alien@ ADD
- ! base = base.base
- base' base 1 alien@ MOV
- "ok" resolve-label
- dst 1 alien@ base' MOV ! alien
- dst 2 alien@ \ f tag-number MOV ! expired
- dst 3 alien@ displacement' MOV ! displacement
+
+ ! Displacement is non-zero, we're going to be allocating a new
+ ! object
+ dst 5 cells alien temp %allot
+
+ ! Set expired to f
+ dst 2 alien@ \ f type-number MOV
+
+ ! Is base f?
+ base \ f type-number CMP
+ "not-f" get JNE
+
+ ! Yes, it is f. Fill in new object
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ dst 4 alien@ displacement MOV
+
+ "end" get JMP
+
+ "not-f" resolve-label
+
+ ! Check base type
+ temp base MOV
+ temp tag-mask get AND
+
+ ! Is base an alien?
+ temp alien type-number CMP
+ "not-alien" get JNE
+
+ ! Yes, it is an alien. Set new alien's base to base.base
+ temp base 1 alien@ MOV
+ dst 1 alien@ temp MOV
+
+ ! Compute displacement
+ temp base 3 alien@ MOV
+ temp displacement ADD
+ dst 3 alien@ temp MOV
+
+ ! Compute address
+ temp base 4 alien@ MOV
+ temp displacement ADD
+ dst 4 alien@ temp MOV
+
+ ! We are done
+ "end" get JMP
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ dst 1 alien@ base MOV
+ dst 3 alien@ displacement MOV
+ temp base MOV
+ temp byte-array-offset ADD
+ temp displacement ADD
+ dst 4 alien@ temp MOV
+
"end" resolve-label
] with-scope ;
M: x86.32 has-small-reg?
{
- { 8 [ have-byte-regs memq? ] }
+ { 8 [ have-byte-regs member-eq? ] }
{ 16 [ drop t ] }
{ 32 [ drop t ] }
} case ;
: small-reg-that-isn't ( exclude -- reg' )
[ have-byte-regs ] dip
[ native-version-of ] map
- '[ _ memq? not ] find nip ;
+ '[ _ member-eq? not ] find nip ;
: with-save/restore ( reg quot -- )
[ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
M: x86 %set-alien-double [ [+] ] dip MOVSD ;
M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
-: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
+: shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
:: emit-shift ( dst src quot -- )
src shift-count? [
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
- [ [] ] dip 8 align ADD ;
+ [ [] ] dip data-alignment get align ADD ;
: store-header ( temp class -- )
[ [] ] [ type-number tag-fixnum ] bi* MOV ;
: store-tagged ( dst tag -- )
- tag-number OR ;
+ type-number OR ;
M:: x86 %allot ( dst size class nursery-ptr -- )
nursery-ptr dst load-allot-ptr
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
:: %boolean ( dst temp word -- )
- dst \ f tag-number MOV
+ dst \ f type-number MOV
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
M: x86 %max-float double-rep two-operand MAXSD ;
M: x86 %sqrt SQRTSD ;
-M: x86 %single>double-float CVTSS2SD ;
-M: x86 %double>single-float CVTSD2SS ;
+: %clear-unless-in-place ( dst src -- )
+ over = [ drop ] [ dup XORPS ] if ;
-M: x86 %integer>float CVTSI2SD ;
+M: x86 %single>double-float [ %clear-unless-in-place ] [ CVTSS2SD ] 2bi ;
+M: x86 %double>single-float [ %clear-unless-in-place ] [ CVTSD2SS ] 2bi ;
+
+M: x86 %integer>float [ drop dup XORPS ] [ CVTSI2SD ] 2bi ;
M: x86 %float>integer CVTTSD2SI ;
: %cmov-float= ( dst src -- )
M: x86 %zero-vector
{
- { double-2-rep [ dup XORPD ] }
+ { double-2-rep [ dup XORPS ] }
{ float-4-rep [ dup XORPS ] }
[ drop dup PXOR ]
} case ;
M: x86 %fill-vector
{
- { double-2-rep [ dup [ XORPD ] [ CMPEQPD ] 2bi ] }
+ { double-2-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
{ float-4-rep [ dup [ XORPS ] [ CMPEQPS ] 2bi ] }
[ drop dup PCMPEQB ]
} case ;
rep unsign-rep {
{ double-2-rep [
dst src1 double-2-rep %copy
- dst src2 UNPCKLPD
+ dst src2 MOVLHPS
] }
{ longlong-2-rep [
dst src1 longlong-2-rep %copy
{ sse2? { double-2-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
-: double-2-shuffle ( dst shuffle -- )
- {
- { { 0 1 } [ drop ] }
- { { 0 0 } [ dup UNPCKLPD ] }
- { { 1 1 } [ dup UNPCKHPD ] }
- [ dupd SHUFPD ]
- } case ;
-
: sse1-float-4-shuffle ( dst shuffle -- )
{
{ { 0 1 2 3 } [ drop ] }
: longlong-2-shuffle ( dst shuffle -- )
first2 [ 2 * dup 1 + ] bi@ 4array int-4-shuffle ;
+: >float-4-shuffle ( double-2-shuffle -- float-4-shuffle )
+ [ 2 * { 0 1 } n+v ] map concat ;
+
M:: x86 %shuffle-vector-imm ( dst src shuffle rep -- )
dst src rep %copy
dst shuffle rep unsign-rep {
- { double-2-rep [ double-2-shuffle ] }
+ { double-2-rep [ >float-4-shuffle float-4-shuffle ] }
{ float-4-rep [ float-4-shuffle ] }
{ int-4-rep [ int-4-shuffle ] }
{ longlong-2-rep [ longlong-2-shuffle ] }
M: x86 %merge-vector-head
[ two-operand ] keep
unsign-rep {
- { double-2-rep [ UNPCKLPD ] }
+ { double-2-rep [ MOVLHPS ] }
{ float-4-rep [ UNPCKLPS ] }
{ longlong-2-rep [ PUNPCKLQDQ ] }
{ int-4-rep [ PUNPCKLDQ ] }
M: x86 %tail>head-vector ( dst src rep -- )
dup {
- { float-4-rep [ drop MOVHLPS ] }
- { double-2-rep [ [ %copy ] [ drop UNPCKHPD ] 3bi ] }
+ { float-4-rep [ drop UNPCKHPD ] }
+ { double-2-rep [ drop UNPCKHPD ] }
[ drop [ %copy ] [ drop PUNPCKHQDQ ] 3bi ]
} case ;
M: x86 %compare-vector-reps
{
- { [ dup { cc= cc/= cc/<>= cc<>= } memq? ] [ drop %compare-vector-eq-reps ] }
+ { [ dup { cc= cc/= cc/<>= cc<>= } member-eq? ] [ drop %compare-vector-eq-reps ] }
[ drop %compare-vector-ord-reps ]
} cond ;
: %move-vector-mask ( dst src rep -- mask )
{
- { double-2-rep [ MOVMSKPD HEX: 3 ] }
+ { double-2-rep [ MOVMSKPS HEX: f ] }
{ float-4-rep [ MOVMSKPS HEX: f ] }
[ drop PMOVMSKB HEX: ffff ]
} case ;
{ sse3? { float-4-rep double-2-rep } }
} available-reps ;
-M: x86 %horizontal-shl-vector ( dst src1 src2 rep -- )
+M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
two-operand PSLLDQ ;
-M: x86 %horizontal-shl-vector-reps
+M: x86 %horizontal-shl-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
-M: x86 %horizontal-shr-vector ( dst src1 src2 rep -- )
+M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
two-operand PSRLDQ ;
-M: x86 %horizontal-shr-vector-reps
+M: x86 %horizontal-shr-vector-imm-reps
{
{ sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
} available-reps ;
[ two-operand ] keep
{
{ float-4-rep [ ANDPS ] }
- { double-2-rep [ ANDPD ] }
+ { double-2-rep [ ANDPS ] }
[ drop PAND ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ ANDNPS ] }
- { double-2-rep [ ANDNPD ] }
+ { double-2-rep [ ANDNPS ] }
[ drop PANDN ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ ORPS ] }
- { double-2-rep [ ORPD ] }
+ { double-2-rep [ ORPS ] }
[ drop POR ]
} case ;
[ two-operand ] keep
{
{ float-4-rep [ XORPS ] }
- { double-2-rep [ XORPD ] }
+ { double-2-rep [ XORPS ] }
[ drop PXOR ]
} case ;
{ sse2? { short-8-rep ushort-8-rep int-4-rep uint-4-rep ulonglong-2-rep } }
} available-reps ;
+M: x86 %shl-vector-imm %shl-vector ;
+M: x86 %shl-vector-imm-reps %shl-vector-reps ;
+M: x86 %shr-vector-imm %shr-vector ;
+M: x86 %shr-vector-imm-reps %shr-vector-reps ;
+
: scalar-sized-reg ( reg rep -- reg' )
rep-size 8 * n-bit-version-of ;
"can write csv too!"
[ "foo1,bar1\nfoo2,bar2\n" ]
-[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> tuck write-csv >string ] named-unit-test
+[ { { "foo1" "bar1" } { "foo2" "bar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test
+
"escapes quotes commas and newlines when writing"
[ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ]
-[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> tuck write-csv >string ] named-unit-test ! "
+[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } <string-writer> [ write-csv ] keep >string ] named-unit-test ! "
[ { { "writing" "some" "csv" "tests" } } ]
[
io.files kernel math math.parser namespaces prettyprint fry
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
-math.intervals io nmake accessors vectors math.ranges random
+math.intervals io locals nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
io.streams.string make db.private sequences.deep
db.errors.sqlite ;
nip [ key>> ] [ value>> ] [ type>> ] tri
<sqlite-low-level-binding> ;
-M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
- tuck
- [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
- rot set-slot-named
- [ [ key>> ] [ type>> ] bi ] dip
- swap <sqlite-low-level-binding> ;
+M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ generate-bind generator-singleton>> eval-generator :> obj
+ generate-bind slot-name>> :> name
+ obj name tuple set-slot-named
+ generate-bind key>> obj generate-bind type>> <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
HELP: ffi-error.
{ $error-description "Thrown by " { $link dlopen } " and " { $link dlsym } " if a problem occurs while loading a native library or looking up a symbol. See " { $link "alien" } "." } ;
-HELP: heap-scan-error.
-{ $error-description "Thrown if " { $link next-object } " is called outside of a " { $link begin-scan } "/" { $link end-scan } " pair." } ;
-
HELP: undefined-symbol-error.
{ $error-description "Thrown if a previously-compiled " { $link alien-invoke } " call refers to a native library symbol which no longer exists." } ;
GENERIC: error. ( error -- )
-M: object error. . ;
+M: object error. short. ;
M: string error. print ;
+: traceback-link. ( continuation -- )
+ "[" write [ "Traceback" ] dip write-object "]" print ;
+
: :s ( -- )
error-continuation get data>> stack. ;
: ffi-error. ( obj -- )
"FFI error" print drop ;
-: heap-scan-error. ( obj -- )
- "Cannot do next-object outside begin/end-scan" print drop ;
-
: undefined-symbol-error. ( obj -- )
"The image refers to a library or symbol that was not found at load time"
print drop ;
{ 6 [ array-size-error. ] }
{ 7 [ c-string-error. ] }
{ 8 [ ffi-error. ] }
- { 9 [ heap-scan-error. ] }
- { 10 [ undefined-symbol-error. ] }
- { 11 [ datastack-underflow. ] }
- { 12 [ datastack-overflow. ] }
- { 13 [ retainstack-underflow. ] }
- { 14 [ retainstack-overflow. ] }
- { 15 [ memory-error. ] }
- { 16 [ fp-trap-error. ] }
+ { 9 [ undefined-symbol-error. ] }
+ { 10 [ datastack-underflow. ] }
+ { 11 [ datastack-overflow. ] }
+ { 12 [ retainstack-underflow. ] }
+ { 13 [ retainstack-overflow. ] }
+ { 14 [ memory-error. ] }
+ { 15 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
: add-loc ( loc document -- ) locs>> push ;
-: remove-loc ( loc document -- ) locs>> delete ;
+: remove-loc ( loc document -- ) locs>> remove! drop ;
: update-locs ( loc document -- )
locs>> [ set-model ] with each ;
require ;
: edit-location ( file line -- )
- [ (normalize-path) ] dip edit-hook get-global
+ [ absolute-path ] dip edit-hook get-global
[ call( file line -- ) ] [ no-edit-hook edit-location ] if* ;
ERROR: cannot-find-source definition ;
:: (take-until) ( state delimiter accum -- string/f state' )
state empty? [ accum "\n" join f ] [
- state unclip-slice :> first :> rest
- first delimiter split1 :> after :> before
+ state unclip-slice :> ( rest first )
+ first delimiter split1 :> ( before after )
before accum push
after [
accum "\n" join
IN: fry\r
\r
HELP: _\r
-{ $description "Fry specifier. Inserts a literal value into the fried quotation." } ;\r
+{ $description "Fry specifier. Inserts a literal value into the fried quotation." }\r
+{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
HELP: @\r
-{ $description "Fry specifier. Splices a quotation into the fried quotation." } ;\r
+{ $description "Fry specifier. Splices a quotation into the fried quotation." }\r
+{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
HELP: fry\r
{ $values { "quot" quotation } { "quot'" quotation } }\r
{ $description "Outputs a quotation that when called, fries " { $snippet "quot" } " by taking values from the stack and substituting them in." }\r
{ $notes "This word is used to implement " { $link POSTPONE: '[ } "; the following two lines are equivalent:"\r
{ $code "[ X ] fry call" "'[ X ]" }\r
-} ;\r
+}\r
+{ $examples "See " { $link "fry.examples" } "." } ;\r
\r
HELP: '[\r
{ $syntax "'[ code... ]" }\r
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }\r
{ { $link curry } { $snippet ": curry '[ _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
- { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
"'[ [ _ key? ] all? ] filter"\r
"[ [ key? ] curry all? ] curry filter"\r
}\r
-"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a “let” form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a " { $snippet "[| | ]" } " form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"\r
{ $code\r
"'[ 3 _ + 4 _ / ]"\r
- "[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"\r
+ "[| a b | 3 a + 4 b / ]"\r
} ;\r
\r
ARTICLE: "fry" "Fried quotations"\r
+! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license
USING: fry tools.test math prettyprint kernel io arrays
sequences eval accessors ;
IN: fry.tests
+SYMBOLS: a b c d e f g h ;
+
+[ [ 1 ] ] [ 1 '[ _ ] ] unit-test
+[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test
+[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test
+
+[ [ 1 2 a ] ] [ 1 2 '[ _ _ a ] ] unit-test
+[ [ 1 2 ] ] [ 1 2 '[ _ _ ] ] unit-test
+[ [ a 1 2 ] ] [ 1 2 '[ a _ _ ] ] unit-test
+[ [ 1 2 a ] ] [ [ 1 ] [ 2 ] '[ @ @ a ] ] unit-test
+[ [ 1 a 2 b ] ] [ 1 2 '[ _ a _ b ] ] unit-test
+[ [ 1 a 2 b ] ] [ 1 [ 2 ] '[ _ a @ b ] ] unit-test
+[ [ a 1 b ] ] [ 1 '[ a _ b ] ] unit-test
+
+[ [ a 1 b ] ] [ [ 1 ] '[ a @ b ] ] unit-test
+[ [ a 1 2 ] ] [ [ 1 ] [ 2 ] '[ a @ @ ] ] unit-test
+
+[ [ a [ 1 ] b ] ] [ 1 '[ a [ _ ] b ] ] unit-test
+[ [ a 1 b [ c 2 d ] e 3 f ] ] [ 1 2 3 '[ a _ b [ c _ d ] e _ f ] ] unit-test
+[ [ a 1 b [ c 2 d [ e 3 f ] ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ c _ d [ e _ f ] ] g _ h ] ] unit-test
+[ [ a 1 b [ [ c 2 d ] e 3 f ] g 4 h ] ] [ 1 2 3 4 '[ a _ b [ [ c _ d ] e _ f ] g _ h ] ] unit-test
+
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
-[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
+[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
-[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
+[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
-[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
+[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
-[ [ "a" "b" [ write ] dip print ] ]
+[ [ "a" write "b" print ] ]
[ "a" "b" '[ _ write _ print ] ] unit-test
[ 1/2 ] [
-! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences combinators parser splitting math
-quotations arrays make words locals.backend summary sets ;
+! (c)2009 Slava Pestov, Eduardo Cavazos, Joe Groff bsd license
+USING: accessors combinators kernel locals.backend math parser
+quotations sequences sets splitting words ;
IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
ERROR: >r/r>-in-fry-error ;
-<PRIVATE
-
-: [ncurry] ( n -- quot )
- {
- { 0 [ [ ] ] }
- { 1 [ [ curry ] ] }
- { 2 [ [ 2curry ] ] }
- { 3 [ [ 3curry ] ] }
- [ \ curry <repetition> ]
- } case ;
+GENERIC: fry ( quot -- quot' )
-M: >r/r>-in-fry-error summary
- drop
- "Explicit retain stack manipulation is not permitted in fried quotations" ;
+<PRIVATE
: check-fry ( quot -- quot )
dup { load-local load-locals get-local drop-locals } intersect
[ >r/r>-in-fry-error ] unless-empty ;
-PREDICATE: fry-specifier < word { _ @ } memq? ;
+PREDICATE: fry-specifier < word { _ @ } member-eq? ;
GENERIC: count-inputs ( quot -- n )
-M: callable count-inputs [ count-inputs ] sigma ;
+M: callable count-inputs [ count-inputs ] map-sum ;
M: fry-specifier count-inputs drop 1 ;
M: object count-inputs drop 0 ;
-GENERIC: deep-fry ( obj -- )
+MIXIN: fried
+PREDICATE: fried-callable < callable
+ count-inputs 0 > ;
+INSTANCE: fried-callable fried
-: shallow-fry ( quot -- quot' curry# )
- check-fry
- [ [ deep-fry ] each ] [ ] make
- [ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
- { _ } split [ spread>quot ] [ length 1 - ] bi ;
+: (ncurry) ( quot n -- quot )
+ {
+ { 0 [ ] }
+ { 1 [ \ curry suffix! ] }
+ { 2 [ \ 2curry suffix! ] }
+ { 3 [ \ 3curry suffix! ] }
+ [ [ \ 3curry suffix! ] dip 3 - (ncurry) ]
+ } case ;
-PRIVATE>
+: wrap-non-callable ( obj -- quot )
+ dup callable? [ ] [ [ call ] curry ] if ; inline
-: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
+: [ncurry] ( n -- quot )
+ [ V{ } clone ] dip (ncurry) >quotation ;
-M: callable deep-fry
- [ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
+: [ndip] ( quot n -- quot' )
+ {
+ { 0 [ wrap-non-callable ] }
+ { 1 [ \ dip [ ] 2sequence ] }
+ { 2 [ \ 2dip [ ] 2sequence ] }
+ { 3 [ \ 3dip [ ] 2sequence ] }
+ [ [ \ 3dip [ ] 2sequence ] dip 3 - [ndip] ]
+ } case ;
+
+: (make-curry) ( tail quot -- quot' )
+ swap [ncurry] curry [ compose ] compose ;
+
+: make-compose ( consecutive quot -- consecutive quot' )
+ [
+ [ [ ] ]
+ [ [ncurry] ] if-zero
+ ] [
+ [ [ compose ] ]
+ [ [ compose compose ] curry ] if-empty
+ ] bi* compose
+ 0 swap ;
+
+: make-curry ( consecutive quot -- consecutive' quot' )
+ [ 1 + ] dip
+ [ [ ] ] [ (make-curry) 0 swap ] if-empty ;
+
+: convert-curry ( consecutive quot -- consecutive' quot' )
+ [ [ ] make-curry ] [
+ dup first \ @ =
+ [ rest >quotation make-compose ]
+ [ >quotation make-curry ] if
+ ] if-empty ;
+
+: prune-curries ( seq -- seq' )
+ dup [ empty? not ] find
+ [ [ 1 + tail ] dip but-last prefix ]
+ [ 2drop { } ] if* ;
+
+: convert-curries ( seq -- tail seq' )
+ unclip-slice [ 0 swap [ convert-curry ] map ] dip
+ [ prune-curries ]
+ [ >quotation 1quotation prefix ] if-empty ;
+
+: mark-composes ( quot -- quot' )
+ [ dup \ @ = [ drop [ _ @ ] ] [ 1quotation ] if ] map concat ; inline
+
+: shallow-fry ( quot -- quot' )
+ check-fry mark-composes
+ { _ } split convert-curries
+ [ [ [ ] ] [ [ ] (make-curry) but-last ] if-zero ]
+ [ spread>quot swap [ [ ] (make-curry) compose ] unless-zero ] if-empty ;
+
+DEFER: dredge-fry
+
+TUPLE: dredge-fry-state
+ { in-quot read-only }
+ { prequot read-only }
+ { quot read-only } ;
+
+: <dredge-fry> ( quot -- dredge-fry )
+ V{ } clone V{ } clone dredge-fry-state boa ; inline
+
+: in-quot-slices ( n i state -- head tail )
+ in-quot>>
+ [ <slice> ]
+ [ [ drop ] 2dip swap 1 + tail-slice ] 3bi ; inline
+
+: push-head-slice ( head state -- )
+ quot>> [ push-all ] [ \ _ swap push ] bi ; inline
+
+: push-subquot ( tail elt state -- )
+ [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
+
+: (dredge-fry-subquot) ( n state i elt -- )
+ rot {
+ [ nip in-quot-slices ] ! head tail i elt state
+ [ [ 2drop swap ] dip push-head-slice ]
+ [ [ drop ] 2dip push-subquot ]
+ [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
+ } 3cleave ; inline recursive
+
+: (dredge-fry-simple) ( n state -- )
+ [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
+
+: dredge-fry ( n dredge-fry -- )
+ 2dup in-quot>> [ fried? ] find-from
+ [ (dredge-fry-subquot) ]
+ [ drop (dredge-fry-simple) ] if* ; inline recursive
+
+PRIVATE>
-M: object deep-fry , ;
+M: callable fry ( quot -- quot' )
+ 0 swap <dredge-fry>
+ [ dredge-fry ] [
+ [ prequot>> >quotation ]
+ [ quot>> >quotation shallow-fry ] bi append
+ ] bi ;
-SYNTAX: '[ parse-quotation fry over push-all ;
+SYNTAX: '[ parse-quotation fry append! ;
USING: calendar ftp.server io.encodings.ascii io.files
io.files.unique namespaces threads tools.test kernel
io.servers.connection ftp.client accessors urls
-io.pathnames io.directories sequences fry ;
+io.pathnames io.directories sequences fry io.backend ;
FROM: ftp.client => ftp-get ;
IN: ftp.server.tests
: create-test-file ( -- path )
test-file-contents
"ftp.server" "test" make-unique-file
- [ ascii set-file-contents ] keep canonicalize-path ;
+ [ ascii set-file-contents ] [ normalize-path ] bi ;
: test-ftp-server ( quot -- )
'[
send-response ;
: serving? ( path -- ? )
- canonicalize-path server get serving-directory>> head? ;
+ normalize-path server get serving-directory>> head? ;
: can-serve-directory? ( path -- ? )
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
: <ftp-server> ( directory port -- server )
latin1 ftp-server new-threaded-server
swap >>insecure
- swap canonicalize-path >>serving-directory
+ swap normalize-path >>serving-directory
"ftp.server" >>name
5 minutes >>timeout ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser
+USING: accessors arrays assocs classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
combinators effects.parser fry functors.backend generic
generic.parser interpolate io.streams.string kernel lexer
M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
- parse-definition >fake-quotations parsed
- [ fake-quotations> first ] over push-all ;
+ parse-definition >fake-quotations suffix!
+ [ fake-quotations> first ] append! ;
: parse-declared* ( accum -- accum )
complete-effect
[ parse-definition* ] dip
- parsed ;
+ suffix! ;
FUNCTOR-SYNTAX: TUPLE:
- scan-param parsed
+ scan-param suffix!
scan {
- { ";" [ tuple parsed f parsed ] }
- { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
+ { ";" [ tuple suffix! f suffix! ] }
+ { "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
[
- [ tuple parsed ] dip
+ [ tuple suffix! ] dip
[ parse-slot-name [ parse-tuple-slots ] when ] { }
- make parsed
+ make suffix!
]
} case
- \ define-tuple-class parsed ;
+ \ define-tuple-class suffix! ;
FUNCTOR-SYNTAX: SINGLETON:
- scan-param parsed
- \ define-singleton-class parsed ;
+ scan-param suffix!
+ \ define-singleton-class suffix! ;
FUNCTOR-SYNTAX: MIXIN:
- scan-param parsed
- \ define-mixin-class parsed ;
+ scan-param suffix!
+ \ define-mixin-class suffix! ;
FUNCTOR-SYNTAX: M:
- scan-param parsed
- scan-param parsed
- [ create-method-in dup method-body set ] over push-all
+ scan-param suffix!
+ scan-param suffix!
+ [ create-method-in dup method-body set ] append!
parse-definition*
- \ define* parsed ;
+ \ define* suffix! ;
FUNCTOR-SYNTAX: C:
- scan-param parsed
- scan-param parsed
+ scan-param suffix!
+ scan-param suffix!
complete-effect
- [ [ [ boa ] curry ] over push-all ] dip parsed
- \ define-declared* parsed ;
+ [ [ [ boa ] curry ] append! ] dip suffix!
+ \ define-declared* suffix! ;
FUNCTOR-SYNTAX: :
- scan-param parsed
+ scan-param suffix!
parse-declared*
- \ define-declared* parsed ;
+ \ define-declared* suffix! ;
FUNCTOR-SYNTAX: SYMBOL:
- scan-param parsed
- \ define-symbol parsed ;
+ scan-param suffix!
+ \ define-symbol suffix! ;
FUNCTOR-SYNTAX: SYNTAX:
- scan-param parsed
+ scan-param suffix!
parse-definition*
- \ define-syntax parsed ;
+ \ define-syntax suffix! ;
FUNCTOR-SYNTAX: INSTANCE:
- scan-param parsed
- scan-param parsed
- \ add-mixin-instance parsed ;
+ scan-param suffix!
+ scan-param suffix!
+ \ add-mixin-instance suffix! ;
FUNCTOR-SYNTAX: GENERIC:
- scan-param parsed
- complete-effect parsed
- \ define-simple-generic* parsed ;
+ scan-param suffix!
+ complete-effect suffix!
+ \ define-simple-generic* suffix! ;
FUNCTOR-SYNTAX: MACRO:
- scan-param parsed
+ scan-param suffix!
parse-declared*
- \ define-macro parsed ;
+ \ define-macro suffix! ;
-FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
+FUNCTOR-SYNTAX: inline [ word make-inline ] append! ;
-FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
+FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
- '[ _ with-string-writer @ ] parsed ;
+ '[ _ with-string-writer @ ] suffix! ;
PRIVATE>
: pop-functor-words ( -- )
functor-words unuse-words ;
+: (parse-bindings) ( end -- )
+ dup parse-binding dup [
+ first2 [ make-local ] dip 2array ,
+ (parse-bindings)
+ ] [ 2drop ] if ;
+
+: with-bindings ( quot -- words assoc )
+ '[
+ in-lambda? on
+ _ H{ } make-assoc
+ ] { } make swap ; inline
+
+: parse-bindings ( end -- words assoc )
+ [
+ namespace use-words
+ (parse-bindings)
+ namespace unuse-words
+ ] with-bindings ;
+
: parse-functor-body ( -- form )
push-functor-words
- "WHERE" parse-bindings*
- [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
+ "WHERE" parse-bindings
+ [ [ swap <def> suffix ] { } assoc>map concat ]
+ [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
+ [ ] append-as
pop-functor-words ;
: (FUNCTOR:) ( -- word def effect )
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user email>> length 0 > [\r
- user email>> email = [\r
- user\r
- 256 random-bits >hex >>ticket\r
- dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user email>> length 0 > [\r
+ user email>> email = [\r
+ user\r
+ 256 random-bits >hex >>ticket\r
+ dup provider update-user\r
] [ f ] if\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
:: claim-ticket ( ticket username provider -- user/f )\r
- [let | user [ username provider get-user ] |\r
- user [\r
- user ticket>> ticket = [\r
- user f >>ticket dup provider update-user\r
- ] [ f ] if\r
+ username provider get-user :> user\r
+ user [\r
+ user ticket>> ticket = [\r
+ user f >>ticket dup provider update-user\r
] [ f ] if\r
- ] ;\r
+ ] [ f ] if ;\r
\r
! For configuration\r
\r
USING: sequences sequences.private math
-accessors alien.data ;
+accessors alien.c-types ;
IN: game.input.dinput.keys-array
TUPLE: keys-array
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
get-controllers [
- tuck
[ product-id = ]
- [ instance-id = ] 2bi* and
+ [ instance-id = ] bi-curry bi* and
] with with find nip ;
TUPLE: keyboard-state keys ;
} ;\r
\r
HELP: napply\r
-{ $values { "n" integer } }\r
+{ $values { "quot" quotation } { "n" integer } }\r
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."\r
} \r
{ $examples\r
\r
{ nappend nappend-as } related-words\r
\r
-HELP: ntuck\r
-{ $values\r
- { "n" integer }\r
-}\r
-{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;\r
-\r
-HELP: nspin\r
-{ $values\r
- { "n" integer }\r
-}\r
-{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;\r
-\r
ARTICLE: "sequence-generalizations" "Generalized sequence operations"\r
{ $subsections\r
narray\r
-nrot\r
nnip\r
ndrop\r
- ntuck\r
- nspin\r
mnswap\r
nweave\r
} ;\r
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test\r
[ [ 1 ] 5 ndip ] must-infer\r
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
-[ 5 nspin ] must-infer\r
-[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test\r
\r
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
[ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer\r
MACRO: nnip ( n -- )
'[ [ _ ndrop ] dip ] ;
-MACRO: ntuck ( n -- )
- 2 + '[ dup _ -nrot ] ;
-
MACRO: ndip ( n -- )
[ [ dip ] curry ] n*quot [ call ] compose ;
[ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
if-zero ;
-MACRO: napply ( n -- )
- [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
+: napply ( quot n -- )
+ [ dupn ] [ spread* ] bi ; inline
: apply-curry ( ...a quot n -- )
[ [curry] ] dip napply ; inline
: nappend ( n -- seq ) narray concat ; inline
-MACRO: nspin ( n -- )
- [ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
-
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
- "9 >array 3 <groups> dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
+ "9 >array 3 <groups> reverse! concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
{ $example
"USING: kernel prettyprint sequences grouping ;"
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 <sliced-groups>"
- "dup [ reverse-here ] each concat >array ."
+ "dup [ reverse! drop ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}
{ $example
--- /dev/null
+USING: accessors alien.c-types alien.syntax half-floats kernel
+math tools.test specialized-arrays alien.data classes.struct ;
+SPECIALIZED-ARRAY: half
+IN: half-floats.tests
+
+[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
+[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
+[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
+[ HEX: be00 ] [ -1.5 half>bits ] unit-test
+[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
+[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
+[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
+
+! too-big floats overflow to infinity
+[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
+[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
+
+! too-small floats flush to zero
+[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
+[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
+
+[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
+[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
+[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
+[ -1.5 ] [ HEX: be00 bits>half ] unit-test
+[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
+[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+
+STRUCT: halves
+ { tom half }
+ { dick half }
+ { harry half }
+ { harry-jr half } ;
+
+[ 8 ] [ halves heap-size ] unit-test
+
+[ 3.0 ] [
+ halves <struct>
+ 3.0 >>dick
+ dick>>
+] unit-test
+
+[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
+[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.accessors alien.c-types alien.data
+alien.syntax kernel math math.order ;
+FROM: math => float ;
+IN: half-floats
+
+: half>bits ( float -- bits )
+ float>bits
+ [ -31 shift 15 shift ] [
+ HEX: 7fffffff bitand
+ dup zero? [
+ dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
+ -13 shift
+ 112 10 shift -
+ 0 HEX: 7c00 clamp
+ ] if
+ ] unless
+ ] bi bitor ;
+
+: bits>half ( bits -- float )
+ [ -15 shift 31 shift ] [
+ HEX: 7fff bitand
+ dup zero? [
+ dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
+ 13 shift
+ 112 23 shift +
+ ] if
+ ] unless
+ ] bi bitor bits>float ;
+
+SYMBOL: half
+
+<<
+
+<c-type>
+ float >>class
+ float >>boxed-class
+ [ alien-unsigned-2 bits>half ] >>getter
+ [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ [ >float ] >>unboxer-quot
+\ half define-primitive-type
+
+>>
--- /dev/null
+Half-precision float support for FFI
ARTICLE: "conventions" "Conventions"
"Various conventions are used throughout the Factor documentation and source code."
+{ $heading "Glossary of terms" }
+"Common terminology and abbreviations used throughout Factor and its documentation:"
+{ $table
+ { "Term" "Definition" }
+ { "alist" { "an association list; see " { $link "alists" } } }
+ { "assoc" { "an associative mapping; see " { $link "assocs" } } }
+ { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
+ { "boolean" { { $link t } " or " { $link f } } }
+ { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
+ { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
+ { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
+ { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
+ { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
+ { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
+ { "object" { "any datum which can be identified" } }
+ { "ordering specifier" { "see " { $link "order-specifiers" } } }
+ { "pathname string" { "an OS-specific pathname which identifies a file" } }
+ { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
+ { "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
+ { "slot" { "a component of an object which can store a value" } }
+ { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
+ { "true value" { "any object not equal to " { $link f } } }
+ { { "vocabulary " { $strong "or" } " vocab" } { "a named set of words. See " { $link "vocabularies" } } }
+ { "vocabulary specifier" { "a " { $link vocab } ", " { $link vocab-link } " or a string naming a vocabulary" } }
+ { "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
+}
{ $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl
+"The browser, completion popups and other tools use a common set of " { $link "definitions.icons" } "."
+$nl
"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
$nl
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
{ $heading "Vocabulary naming conventions" }
-"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
-$nl
-"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
+"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation details, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } "). You should avoid using private words from the Factor library unless absolutely necessary. Similarly, your own code can place words in private vocabularies using " { $link POSTPONE: <PRIVATE } " if you do not want other people using them without good reason."
{ $heading "Word naming conventions" }
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
{ $table
}
{ $heading "Stack effect conventions" }
"Stack effect conventions are documented in " { $link "effects" } "."
-{ $heading "Glossary of terms" }
-"Common terminology and abbreviations used throughout Factor and its documentation:"
-{ $table
- { "Term" "Definition" }
- { "alist" { "an association list; see " { $link "alists" } } }
- { "assoc" { "an associative mapping; see " { $link "assocs" } } }
- { "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
- { "boolean" { { $link t } " or " { $link f } } }
- { "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
- { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
- { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
- { "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
- { "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
- { "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
- { "object" { "any datum which can be identified" } }
- { "ordering specifier" { "see " { $link "order-specifiers" } } }
- { "pathname string" { "an OS-specific pathname which identifies a file" } }
- { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
- { "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
- { "slot" { "a component of an object which can store a value" } }
- { "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
- { "true value" { "any object not equal to " { $link f } } }
- { "vocabulary" { "a named set of words. See " { $link "vocabularies" } } }
- { "vocabulary specifier" { "a " { $link vocab } ", " { $link vocab-link } " or a string naming a vocabulary" } }
- { "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
-} ;
+;
ARTICLE: "tail-call-opt" "Tail-call optimization"
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
ARTICLE: "handbook" "Factor handbook"
-{ $heading "Getting Started" }
+{ $heading "Getting started" }
{ $subsections
"cookbook"
"first-program"
"alien"
"handbook-library-reference"
}
-{ $heading "Explore loaded libraries" }
+{ $heading "Index" }
{ $subsections
- "article-index"
- "primitive-index"
- "error-index"
- "class-index"
+ "vocab-index"
+ "article-index"
+ "primitive-index"
+ "error-index"
+ "class-index"
}
-{ $heading "Explore the code base" }
-{ $subsections "vocab-index" } ;
+;
ABOUT: "handbook"
USING: help.markup help.syntax ;
ARTICLE: "help.home" "Factor documentation"
-"If this is your first time with Factor, you can start by writing " { $link "first-program" } "."
+{ $heading "Getting started" }
+{ $subsections
+ "cookbook"
+ "first-program"
+}
+{ $heading "User interface" }
+{ $subsections
+ "listener"
+ "ui-tools"
+}
{ $heading "Reference" }
-{ $list
- { $link "handbook" }
- { $link "vocab-index" }
- { $link "ui-tools" }
- { $link "ui-listener" }
+{ $subsections
+ "handbook"
+ "vocab-index"
+ "article-index"
+ "primitive-index"
+ "error-index"
+ "class-index"
}
-{ $heading "Recently visited" }
+{ $heading "Searches" }
+"Use the search field in the top-right of the " { $link "ui-browser" } " window to search for words, vocabularies, and help articles."
+{ $recent-searches }
+{ $heading "Recently visited pages" }
{ $table
{ "Words" "Articles" "Vocabs" }
{ { $recent recent-words } { $recent recent-articles } { $recent recent-vocabs } }
}
-"The browser, completion popups and other tools use a common set of " { $link "definitions.icons" } "."
-{ $heading "Recent searches" }
-{ $recent-searches }
-"Use the search field in the top-right of the " { $link "ui-browser" } " window to search for words, vocabularies and help articles." ;
+;
-ABOUT: "help.home"
\ No newline at end of file
+ABOUT: "help.home"
: contains-funky-elements? ( element -- ? )
{
$shuffle
+ $complex-shuffle
$values-x/y
$predicate
$class-description
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes colors colors.constants
-combinators definitions definitions.icons effects fry generic
-hashtables help.stylesheet help.topics io io.styles kernel make
-math namespaces parser present prettyprint
+combinators combinators.smart definitions definitions.icons effects
+fry generic hashtables help.stylesheet help.topics io io.styles
+kernel make math namespaces parser present prettyprint
prettyprint.stylesheet quotations see sequences sets slots
sorting splitting strings vectors vocabs vocabs.loader words
words.symbol ;
: $shuffle ( element -- )
drop
- "Shuffle word. Re-arranges the stack according to the stack effect pattern." $description ;
+ "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description ;
+
+: $complex-shuffle ( element -- )
+ drop
+ "Shuffle word. Rearranges the top of the datastack as indicated in the stack effect pattern." $description
+ { "The data flow represented by this shuffle word can be more clearly expressed using " { $link "locals" } "." } $deprecated ;
: $low-level-note ( children -- )
drop
icons get >alist sort-keys
[ [ <$link> ] [ definition-icon-path <$image> ] bi* swap ] assoc-map
{ "" "Definition class" } prefix
- $table ;
\ No newline at end of file
+ $table ;
TUPLE: tip < identity-tuple content loc ;
-M: tip forget* tips get delq ;
+M: tip forget* tips get remove-eq! drop ;
M: tip where loc>> ;
: $tips-of-the-day ( element -- )
drop tips get [ nl nl ] [ content>> print-element ] interleave ;
-INSTANCE: tip definition
\ No newline at end of file
+INSTANCE: tip definition
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
-{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
+{ $values { "defspec" "a word or method" } { "hints..." "a list of sequences of classes or literals" } }
{ $description "Defines specialization hints for a word or a method."
$nl
"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
"M: assoc count-occurrences"
" swap [ = nip ] curry assoc-filter assoc-size ;"
""
- "HINTS: { sequence count-occurrences } { object array } ;"
- "HINTS: { assoc count-occurrences } { object hashtable } ;"
+ "HINTS: M\ sequence count-occurrences { object array } ;"
+ "HINTS: M\ assoc count-occurrences { object hashtable } ;"
}
} ;
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.parser namespaces parser sbufs
-sequences splitting splitting.private strings vectors words ;
+kernel.private math math.integers.private math.parser math.parser.private
+namespaces parser sbufs sequences splitting splitting.private strings
+vectors words ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
[ parse-definition { } like "specializer" set-word-prop ] tri ;
! Default specializers
-{ first first2 first3 first4 }
-[ { array } "specializer" set-word-prop ] each
-
{ last pop* pop } [
{ vector } "specializer" set-word-prop
] each
{ { fixnum fixnum string } { fixnum fixnum array } }
"specializer" set-word-prop
-\ reverse-here
+\ reverse!
{ { string } { array } }
"specializer" set-word-prop
\ split, { string string } "specializer" set-word-prop
-\ memq? { array } "specializer" set-word-prop
+\ member-eq? { array } "specializer" set-word-prop
\ member? { array } "specializer" set-word-prop
M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
+
+\ dec>float { string } "specializer" set-word-prop
+
+\ hex>float { string } "specializer" set-word-prop
+
+\ string>integer { string fixnum } "specializer" set-word-prop
+
+\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop
: found-<% ( accum lexer col -- accum )
[
over line-text>>
- [ column>> ] 2dip subseq parsed
- \ write parsed
+ [ column>> ] 2dip subseq suffix!
+ \ write suffix!
] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
[ line-text>> ] [ column>> ] bi tail
- parsed \ print parsed
+ suffix! \ print suffix!
] keep next-line ;
: parse-%> ( accum lexer -- accum )
[ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
: delete-cookie ( request/response name -- )
- over cookies>> [ get-cookie ] dip delete ;
+ over cookies>> [ get-cookie ] dip remove! drop ;
: put-cookie ( request/response cookie -- request/response )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images
+grouping compression.huffman images fry
images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
block dup length>> sqrt >fixnum group flip
dup matrix-dim coord-matrix flip
[
- [ first2 spin nth nth ]
+ [ '[ _ [ second ] [ first ] bi ] dip nth nth ]
[ x,y v+ color-id jpeg-image draw-color ] bi
] with each^2 ;
binary [
[
{ HEX: FF } read-until
- read1 tuck HEX: 00 = and
+ read1 [ HEX: 00 = and ] keep swap
]
[ drop ] produce
swap >marker { EOI } assert=
[ decode-macroblock 2array ] accumulator
[ all-macroblocks ] dip
jpeg> setup-bitmap draw-macroblocks
- jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+ jpeg> bitmap>> 3 <groups> [ color-transform ] map! drop
jpeg> [ >byte-array ] change-bitmap drop ;
ERROR: not-a-jpeg-image ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel images ;
+IN: images.normalization
+
+HELP: normalize-image
+{ $values
+ { "image" image }
+ { "image" image }
+}
+{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
+
+HELP: reorder-components
+{ $values
+ { "image" image } { "component-order" component-order }
+ { "image" image }
+}
+{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
+{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
+$nl
+"You cannot use this word to reorder " { $link DEPTH } ", " { $link DEPTH-STENCIL } " or " { $link INTENSITY } " component orders." } ;
+
+ARTICLE: "images.normalization" "Image normalization"
+"The " { $vocab-link "images.normalization" } " vocab can be used to convert between " { $link image } " representations."
+$nl
+"You can normalize any image to a RGBA with ubyte-components representation:"
+{ $subsections normalize-image }
+"Convert an image's pixel layout to match an arbitrary " { $link component-order } ":"
+{ $subsections reorder-components } ;
+
+ABOUT: "images.normalization"
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images images.normalization images.normalization.private
+sequences tools.test ;
+IN: images.normalization.tests
+
+! 1>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 } A L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 } A RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 } A BGR permute ] unit-test
+
+[ B{ 0 255 255 255 1 255 255 255 } ]
+[ B{ 0 1 } A ABGR permute ] unit-test
+
+! 2>x
+
+[ B{ 0 2 } ]
+[ B{ 0 1 2 3 } LA L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 2 3 } LA RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 2 3 } LA BGR permute ] unit-test
+
+[ B{ 1 255 255 255 3 255 255 255 } ]
+[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
+
+! 3>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
+
+[ B{ 0 1 3 4 } ]
+[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
+
+[ B{ 2 1 0 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
+
+[ B{ 255 2 1 0 255 5 4 3 } ]
+[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
+
+! 4>x
+
+[ B{ 255 255 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
+
+[ B{ 0 1 4 5 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
+
+[ B{ 2 1 0 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
+
+[ B{ 3 2 1 0 7 6 5 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
+
+! Edge cases
+
+[ B{ 0 4 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
+
+[ B{ 255 0 1 2 255 4 5 6 } ]
+[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
+
+[ B{ 1 2 3 255 5 6 7 255 } ]
+[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 255 255 } ]
+[ B{ 0 1 } L RGBA permute ] unit-test
+
+! Invalid inputs
+
+[
+ T{ image f { 1 1 } DEPTH ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } DEPTH-STENCIL ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } INTENSITY ubyte-components f B{ 0 } }
+ RGB reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ DEPTH reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ DEPTH-STENCIL reorder-components
+] must-fail
+
+[
+ T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
+ INTENSITY reorder-components
+] must-fail
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Keith Lazuka
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays combinators fry
+grouping images kernel locals math math.vectors
+sequences specialized-arrays half-floats ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: half
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: ushort
+IN: images.normalization
+
+<PRIVATE
+
+CONSTANT: don't-care 127
+CONSTANT: fill-value 255
+
+: permutation ( src dst -- seq )
+ swap '[ _ index [ don't-care ] unless* ] { } map-as
+ 4 don't-care pad-tail ;
+
+: pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
+
+: shuffle ( seq permutation -- newseq )
+ swap '[
+ dup 4 >= [ drop fill-value ] [ _ nth ] if
+ ] B{ } map-as ;
+
+:: permute ( bytes src-order dst-order -- new-bytes )
+ src-order name>> :> src
+ dst-order name>> :> dst
+ bytes src length group
+ [ pad4 src dst permutation shuffle dst length head ]
+ map concat ;
+
+: (reorder-components) ( image src-order dest-order -- image )
+ [ permute ] 2curry change-bitmap ;
+
+GENERIC: normalize-component-type* ( image component-type -- image )
+
+: normalize-floats ( float-array -- byte-array )
+ [ 255.0 * >integer ] B{ } map-as ;
+
+M: float-components normalize-component-type*
+ drop byte-array>float-array normalize-floats ;
+
+M: half-components normalize-component-type*
+ drop byte-array>half-array normalize-floats ;
+
+: ushorts>ubytes ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: ushort-components normalize-component-type*
+ drop ushorts>ubytes ;
+
+M: ubyte-components normalize-component-type*
+ drop ;
+
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
+
+: validate-request ( src-order dst-order -- src-order dst-order )
+ [
+ [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
+ or [ "Invalid component-order" throw ] when
+ ] 2keep ;
+
+PRIVATE>
+
+: reorder-components ( image component-order -- image )
+ [
+ dup component-type>> '[ _ normalize-component-type* ] change-bitmap
+ dup component-order>>
+ ] dip
+ validate-request [ (reorder-components) ] keep >>component-order ;
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ RGBA reorder-components
+ normalize-scan-line-order ;
+
: validate-truecolor-alpha ( loading-png -- loading-png )
{ 8 16 } validate-bit-depth ;
+: pad-bitmap ( image -- image )
+ dup dim>> first 4 divisor? [
+ dup [ bytes-per-pixel ]
+ [ dim>> first * ]
+ [ dim>> first 4 mod ] tri
+ '[ _ group [ _ 0 <array> append ] map B{ } concat-as ] change-bitmap
+ ] unless ;
+
: loading-png>bitmap ( loading-png -- bytes component-order )
dup color-type>> {
{ greyscale [
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
[ png-component >>component-type ]
- } cleave ;
+ } cleave pad-bitmap ;
: load-png ( stream -- loading-png )
[
+++ /dev/null
- PNGSUITE
-----------------
-
- testset for PNG-(de)coders
- created by Willem van Schaik
-------------------------------------
-
-This is a collection of graphics images created to test the png applications
-like viewers, converters and editors. All (as far as that is possible)
-formats supported by the PNG standard are represented.
-
-
-1. INTRODUCTION
---------------------
-
-1.1 PNG capabilities
-------------------------
-
-Supported color-types are:
-
- - grayscale
- - grayscale + alpha-channel
- - color palettes
- - rgb
- - rgb + alpha-channel
-
-Allowed bitdepths are depending on the color-type, but are in the range
-of 1-bit (grayscale, which is b&w) upto 16-bits.
-
-Special features are:
-
- - interlacing (Adam-7)
- - gamma-support
- - transparency (a poor-man's alpha solution)
-
-
-1.2 File naming
--------------------
-
-Where possible, the testfiles are 32x32 bits icons. This results in a still
-reasonable size of the suite even with a large number of tests. The name
-of each test-file reflects thetype in the following way:
-
- g04i2c08.png
- || |||+---- bit-depth
- || ||+----- color-type (descriptive)
- || |+------ color-type (numerical)
- || +------- interlaced or non-interlaced
- |+--------- parameter of test (in this case gamma-value)
- +---------- test feature (in this case gamma)
-
-
-1.3 PNG formats
--------------------
-
-color-type:
- 0g - grayscale
- 2c - rgb color
- 3p - paletted
- 4a - grayscale + alpha channel
- 6a - rgb color + alpha channel
-
-bit-depth:
- 01 - with color-type 0, 3
- 02 - with color-type 0, 3
- 04 - with color-type 0, 3
- 08 - with color-type 0, 2, 3, 4, 6
- 16 - with color-type 0, 2, 4, 6
-
-interlacing:
- n - non-interlaced
- i - interlaced
-
-
-2. THE TESTS
------------------
-
-2.1 Sizes
--------------
-
-These tests are there to check if your software handles pictures well, with
-picture sizes that are not a multiple of 8. This is particularly important
-with Adam-7 type interlacing. In the same way these tests check if pictures
-size 1x1 and similar are ok.
-
- s01 - 1x1 pixel picture
- s02 - 2x2 pixel picture
- s03 - 3x3 pixel picture
- s04 - 4x4 pixel picture
- s05 - 5x5 pixel picture
- s06 - 6x6 pixel picture
- s07 - 7x7 pixel picture
- s08 - 8x8 pixel picture
- s09 - 9x9 pixel picture
- s32 - 32x32 pixel picture
- s33 - 33x33 pixel picture
- s34 - 34x34 pixel picture
- s35 - 35x35 pixel picture
- s36 - 36x36 pixel picture
- s37 - 37x37 pixel picture
- s38 - 38x38 pixel picture
- s39 - 39x39 pixel picture
- s40 - 40x40 pixel picture
-
-
-2.2 Background
-------------------
-
-When the PNG file contains a background chunck, this should be used for
-pictures with alpha-channel or pictures with a transparency chunck. For
-pictures without this background-chunk, but with alpha, this testset
-assumes a black background.
-
-For the images in this test, the left-side should be 100% the background
-color, where moving to the right the color should gradually become the
-image pattern.
-
- bga - alpha + no background
- bgw - alpha + white background
- bgg - alpha + gray background
- bgb - alpha + black background
- bgy - alpha + yellow background
-
-
-2.3 Transparency
---------------------
-
-Transparency should be used together with a background chunk. To test the
-combination of the two the latter 4 tests are there. How to handle pictures
-with transparancy, but without a background, opinions can differ. Here we
-use black, but especially in the case of paletted images, the normal color
-would maybe even be better.
-
- tp0 - not transparent for reference
- tp1 - transparent, but no background chunk
- tbw - transparent + white background
- tbg - transparent + gray background
- tbb - transparent + black background
- tby - transparent + yellow background
-
-
-2.4 Gamma
--------------
-
-To test if your viewer handles gamma-correction, 6 testfiles are available.
-They contain corrected color-ramps and a corresponding gamma-chunk with the
-file-gamma value. These are created in such a way that when the viewer does
-the gamma correction right, all 6 should be displayed identical.
-
-If they are different, probably the gamma correction is omitted. In that
-case, have a look at the two right coloumns in the 6 pictures. The image
-where those two look the same (when looked from far) reflects the gamma of
-your system. However, because of the limited size of the image, you should
-do more elaborate tests to determine your display gamma.
-
- g03 - file-gamma = 0.35, for display with gamma = 2.8
- g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC)
- g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac)
- g07 - file-gamma = 0.70, for display with gamma = 1.4
- g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT)
- g25 - file-gamma = 2.50, for display with gamma = 0.4
-
-
-2.5 Filtering
------------------
-
-PNG uses file-filtering, for optimal compression. Normally the type is of
-filtering is adjusted to the contents of the picture, but here each file
-has the same picture, with a different filtering.
-
- f0 - no filtering
- f1 - sub filtering
- f2 - up filtering
- f3 - average filtering
- f4 - paeth filtering
-
-
-2.6 Additional palettes
----------------------------
-
-Besides the normal use of paletted images, palette chunks can in combination
-with true-color (and other) images also be used to select color lookup-tables
-when the video system is of limited capabilities. The suggested palette chunk
-is specially created for this purpose.
-
- pp - normal palette chunk
- ps - suggested palette chunk
-
-
-2.7 Ancillary chunks (under construction)
-------------------------
-
-To test the correct decoding of ancillary chunks, these test-files contain
-one or more examples of these chunkcs. Depending on the type of chunk, a
-number of typical values are selected to test. Unluckily, the testset can
-not contain all combinations, because that would be an endless set.
-
-The significant bits are used in files with the next higher bit-depth. They
-indicate howmany bits are valid.
-
- cs3 - 3 significant bits
- cs5 - 5 significant bits
- cs8 - 8 significant bits (reference)
- cs3 - 13 significant bits
-
-For the physical pixel dimensions, the result of each decoding should be
-a sqare picture. The first (cdf) image is an example of flat (horizontal)
-pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take
-care of the correction. The second is just the other way round. The last
-example uses the unit specifier, for 1000 pixels per meter. This should
-result in a picture of 3.2 cm square.
-
- cdf - physical pixel dimensions, 8x32 flat pixels
- cdh - physical pixel dimensions, 32x8 high pixels
- cds - physical pixel dimensions, 8x8 square pixels
- cdu - physical pixel dimensions, with unit-specifier
-
- ccw - primary chromaticities and white point
-
- ch1 - histogram 15 colors
- ch2 - histogram 256 colors
-
- cm7 - modification time, 01-jan-1970
- cm9 - modification time, 31-dec-1999
- cm0 - modification time, 01-jan-2000
-
-In the textual chunk, a number of the standard, and some non-standard
-text items are included.
-
- ct0 - no textual data
- ct1 - with textual data
- ctz - with compressed textual data
-
-
-2.8 Chunk ordering (still under construction)
-----------------------
-
-These testfiles will test the obligatory ordering relations between various
-chunk types (not yet) as well as the number of data chunks used for the image.
-
- oi1 - mother image with 1 idat-chunk
- oi2 - image with 2 idat-chunks
- oi4 - image with 4 unequal sized idat-chunks
- oi9 - all idat-chunks of length one
-
-
-2.9 Compression level
--------------------------
-
-Here you will find a set of images compressed by zlib, ranging from level 0
-for no compression at maximum speed upto level 9 for maximum compression.
-
- z00 - zlib compression level 0 - none
- z03 - zlib compression level 3
- z06 - zlib compression level 6 - default
- z09 - zlib compression level 9 - maximum
-
-
-2.10 Corrupted files (under construction)
------------------------
-
-All these files are illegal. When decoding they should generate appropriate
-error-messages.
-
- x00 - empty IDAT chunk
- xcr - added cr bytes
- xlf - added lf bytes
- xc0 - color type 0
- xc9 - color type 9
- xd0 - bit-depth 0
- xd3 - bit-depth 3
- xd9 - bit-depth 99
- xcs - incorrect IDAT checksum
-
-
-3. TEST FILES
-------------------
-
-For each of the tests listed above, one or more test-files are created. A
-selection is made (for each test) for the color-type and bitdepth to be used
-for the tests. Further for a number of tests, both a non-interlaced as well
-as an interlaced version is available.
-
-
-3.1 Basic format test files (non-interlaced)
-------------------------------------------------
-
- basn0g01 - black & white
- basn0g02 - 2 bit (4 level) grayscale
- basn0g04 - 4 bit (16 level) grayscale
- basn0g08 - 8 bit (256 level) grayscale
- basn0g16 - 16 bit (64k level) grayscale
- basn2c08 - 3x8 bits rgb color
- basn2c16 - 3x16 bits rgb color
- basn3p01 - 1 bit (2 color) paletted
- basn3p02 - 2 bit (4 color) paletted
- basn3p04 - 4 bit (16 color) paletted
- basn3p08 - 8 bit (256 color) paletted
- basn4a08 - 8 bit grayscale + 8 bit alpha-channel
- basn4a16 - 16 bit grayscale + 16 bit alpha-channel
- basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel
- basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel
-
-
-3.2 Basic format test files (Adam-7 interlaced)
----------------------------------------------------
-
- basi0g01 - black & white
- basi0g02 - 2 bit (4 level) grayscale
- basi0g04 - 4 bit (16 level) grayscale
- basi0g08 - 8 bit (256 level) grayscale
- basi0g16 - 16 bit (64k level) grayscale
- basi2c08 - 3x8 bits rgb color
- basi2c16 - 3x16 bits rgb color
- basi3p01 - 1 bit (2 color) paletted
- basi3p02 - 2 bit (4 color) paletted
- basi3p04 - 4 bit (16 color) paletted
- basi3p08 - 8 bit (256 color) paletted
- basi4a08 - 8 bit grayscale + 8 bit alpha-channel
- basi4a16 - 16 bit grayscale + 16 bit alpha-channel
- basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel
- basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel
-
-
-3.3 Sizes test files
------------------------
-
- s01n3p01 - 1x1 paletted file, no interlacing
- s02n3p01 - 2x2 paletted file, no interlacing
- s03n3p01 - 3x3 paletted file, no interlacing
- s04n3p01 - 4x4 paletted file, no interlacing
- s05n3p02 - 5x5 paletted file, no interlacing
- s06n3p02 - 6x6 paletted file, no interlacing
- s07n3p02 - 7x7 paletted file, no interlacing
- s08n3p02 - 8x8 paletted file, no interlacing
- s09n3p02 - 9x9 paletted file, no interlacing
- s32n3p04 - 32x32 paletted file, no interlacing
- s33n3p04 - 33x33 paletted file, no interlacing
- s34n3p04 - 34x34 paletted file, no interlacing
- s35n3p04 - 35x35 paletted file, no interlacing
- s36n3p04 - 36x36 paletted file, no interlacing
- s37n3p04 - 37x37 paletted file, no interlacing
- s38n3p04 - 38x38 paletted file, no interlacing
- s39n3p04 - 39x39 paletted file, no interlacing
- s40n3p04 - 40x40 paletted file, no interlacing
-
- s01i3p01 - 1x1 paletted file, interlaced
- s02i3p01 - 2x2 paletted file, interlaced
- s03i3p01 - 3x3 paletted file, interlaced
- s04i3p01 - 4x4 paletted file, interlaced
- s05i3p02 - 5x5 paletted file, interlaced
- s06i3p02 - 6x6 paletted file, interlaced
- s07i3p02 - 7x7 paletted file, interlaced
- s08i3p02 - 8x8 paletted file, interlaced
- s09i3p02 - 9x9 paletted file, interlaced
- s32i3p04 - 32x32 paletted file, interlaced
- s33i3p04 - 33x33 paletted file, interlaced
- s34i3p04 - 34x34 paletted file, interlaced
- s35i3p04 - 35x35 paletted file, interlaced
- s36i3p04 - 36x36 paletted file, interlaced
- s37i3p04 - 37x37 paletted file, interlaced
- s38i3p04 - 38x38 paletted file, interlaced
- s39i3p04 - 39x39 paletted file, interlaced
- s40i3p04 - 40x40 paletted file, interlaced
-
-
-3.4 Background test files (with alpha)
-------------------------------------------
-
- bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced
- bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced
- bgan6a08 - 3x8 bits rgb color, alpha, no background chunk
- bgan6a16 - 3x16 bits rgb color, alpha, no background chunk
-
- bgbn4a08 - 8 bit grayscale, alpha, black background chunk
- bggn4a16 - 16 bit grayscale, alpha, gray background chunk
- bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk
- bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk
-
-
-3.5 Transparency (and background) test files
-------------------------------------------------
-
- tp0n1g08 - not transparent for reference (logo on gray)
- tbbn1g04 - transparent, black background chunk
- tbwn1g16 - transparent, white background chunk
- tp0n2c08 - not transparent for reference (logo on gray)
- tbrn2c08 - transparent, red background chunk
- tbgn2c16 - transparent, green background chunk
- tbbn2c16 - transparent, blue background chunk
- tp0n3p08 - not transparent for reference (logo on gray)
- tp1n3p08 - transparent, but no background chunk
- tbbn3p08 - transparent, black background chunk
- tbgn3p08 - transparent, light-gray background chunk
- tbwn3p08 - transparent, white background chunk
- tbyn3p08 - transparent, yellow background chunk
-
-
-3.6 Gamma test files
-------------------------
-
- g03n0g16 - grayscale, file-gamma = 0.35
- g04n0g16 - grayscale, file-gamma = 0.45
- g05n0g16 - grayscale, file-gamma = 0.55
- g07n0g16 - grayscale, file-gamma = 0.70
- g10n0g16 - grayscale, file-gamma = 1.00
- g25n0g16 - grayscale, file-gamma = 2.50
- g03n2c08 - color, file-gamma = 0.35
- g04n2c08 - color, file-gamma = 0.45
- g05n2c08 - color, file-gamma = 0.55
- g07n2c08 - color, file-gamma = 0.70
- g10n2c08 - color, file-gamma = 1.00
- g25n2c08 - color, file-gamma = 2.50
- g03n3p04 - paletted, file-gamma = 0.35
- g04n3p04 - paletted, file-gamma = 0.45
- g05n3p04 - paletted, file-gamma = 0.55
- g07n3p04 - paletted, file-gamma = 0.70
- g10n3p04 - paletted, file-gamma = 1.00
- g25n3p04 - paletted, file-gamma = 2.50
-
-
-3.7 Filtering test files
-----------------------------
-
- f00n0g08 - grayscale, no interlacing, filter-type 0
- f01n0g08 - grayscale, no interlacing, filter-type 1
- f02n0g08 - grayscale, no interlacing, filter-type 2
- f03n0g08 - grayscale, no interlacing, filter-type 3
- f04n0g08 - grayscale, no interlacing, filter-type 4
- f00n2c08 - color, no interlacing, filter-type 0
- f01n2c08 - color, no interlacing, filter-type 1
- f02n2c08 - color, no interlacing, filter-type 2
- f03n2c08 - color, no interlacing, filter-type 3
- f04n2c08 - color, no interlacing, filter-type 4
-
-
-3.8 Additional palette chunk test files
--------------------------------------------
-
- pp0n2c16 - six-cube palette-chunk in true-color image
- pp0n6a08 - six-cube palette-chunk in true-color+alpha image
- ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image
- ps1n2c16 - six-cube suggested palette (1 byte) in true-color image
- ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image
- ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image
-
-
-3.9 Ancillary chunks test files
------------------------------------
-
- cs5n2c08 - color, 5 significant bits
- cs8n2c08 - color, 8 significant bits (reference)
- cs3n2c16 - color, 13 significant bits
- cs3n3p08 - paletted, 3 significant bits
- cs5n3p08 - paletted, 5 significant bits
- cs8n3p08 - paletted, 8 significant bits (reference)
-
- cdfn2c08 - physical pixel dimensions, 8x32 flat pixels
- cdhn2c08 - physical pixel dimensions, 32x8 high pixels
- cdsn2c08 - physical pixel dimensions, 8x8 square pixels
- cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter
-
- ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
- ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
-
- ch1n3p04 - histogram 15 colors
- ch2n3p08 - histogram 256 colors
-
- cm7n0g04 - modification time, 01-jan-1970 00:00:00
- cm9n0g04 - modification time, 31-dec-1999 23:59:59
- cm0n0g04 - modification time, 01-jan-2000 12:34:56
-
- ct0n0g04 - no textual data
- ct1n0g04 - with textual data
- ctzn0g04 - with compressed textual data
-
-
-
-3.10 Chunk ordering
-----------------------
-
- oi1n0g16 - grayscale mother image with 1 idat-chunk
- oi2n0g16 - grayscale image with 2 idat-chunks
- oi4n0g16 - grayscale image with 4 unequal sized idat-chunks
- oi9n0g16 - grayscale image with all idat-chunks length one
- oi1n2c16 - color mother image with 1 idat-chunk
- oi2n2c16 - color image with 2 idat-chunks
- oi4n2c16 - color image with 4 unequal sized idat-chunks
- oi9n2c16 - color image with all idat-chunks length one
-
-
-
-3.11 Compression level
--------------------------
-
- z00n2c08 - color, no interlacing, compression level 0 (none)
- z03n2c08 - color, no interlacing, compression level 3
- z06n2c08 - color, no interlacing, compression level 6 (default)
- z09n2c08 - color, no interlacing, compression level 9 (maximum)
-
-
-
-3.12 Currupted files
------------------------
-
- x00n0g01 - empty 0x0 grayscale file
- xcrn0g04 - added cr bytes
- xlfn0g04 - added lf bytes
- xc0n0c08 - color type 0
- xc9n0c08 - color type 9
- xd0n2c00 - bit-depth 0
- xd3n2c03 - bit-depth 3
- xd9n2c99 - bit-depth 99
- xcsn2c08 - incorrect IDAT checksum
-
-
---------
- (c) Willem van Schaik
- willem@schaik.com
- Singapore, October 1996
+++ /dev/null
-\89PNG
-
-
-\1a
-
-
-IHDR \ 4\93áÈ)ÈIDATx\9c]ÑÁ
-Â0\f\ 5P\1f*@\bð\b\1d¡#°
-
-#TâÈ\ 51\ 1\e0\ 2lPF`\ 3Ø F=\95\ 2\9fÄIQâ\1c*çÅuí\94`\16%qk\81
-H\9eñ\9a\88©ñ´\80m\ 2÷\7fÍ\büµàß\9f Ñ\8d=,\14¸fìOK
-
-ç\a Ðt\8eÀ(Èï\ 5ä\92×\1e¦íF\v;èPº\80¯¾{xpç]\ 39\87/\ap\8f*$(ì*éyìÕ\83 ×þ\1eÚéçè@÷C¼ \12 cÔq\16\9e\8bNÛU#\84)11·.\8d\81\15r\10äðf\ 3\17ä0°\81ägh(¥\81tý\1eÙÂEøÿ\89kIEND®B`\82
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax images images.viewer kernel
-quotations strings ;
-IN: images.testing
-
-HELP: decode-test
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image decoder. The image is decoded and compared against its corresponding " { $link { "images" "testing" "reference" } } "." } ;
-
-HELP: encode-test
-{ $values
- { "path" "a pathname string" } { "image-class" object }
-}
-{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." }
-{ $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ;
-
-HELP: images.
-{ $values
- { "dirpath" "a pathname string" } { "extension" string }
-}
-{ $description "Renders each image at " { $snippet "dirpath" } " directly to the Listener tool." } ;
-{ images. image. } related-words
-
-HELP: load-reference-image
-{ $values
- { "path" "a pathname string" }
- { "image" image }
-}
-{ $description "Loads the " { $link { "images" "testing" "reference" } } " that corresponds to the original image at " { $snippet "path" } " into memory." } ;
-
-HELP: ls
-{ $values
- { "dirpath" "a pathname string" } { "extension" object }
-}
-{ $description "Prints out the name of each file surrounded in double quotes so that you can easily copy and paste into your unit test." } ;
-
-HELP: save-all-as-reference-images
-{ $values
- { "dirpath" "a pathname string" } { "extension" object }
-}
-{ $description "Saves a " { $link { "images" "testing" "reference" } } " for each image in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." }
-{ $warning "You should only call this word after you have manually verified that every image in " { $snippet "dirpath" } " decodes and renders correctly!" } ;
-
-HELP: save-as-reference-image
-{ $values
- { "path" "a pathname string" }
-}
-{ $description "Saves a " { $link { "images" "testing" "reference" } } " for the image at " { $snippet "path" } "." }
-{ $warning "You should only call this word after you have manually verified that the image at " { $snippet "path" } " decodes and renders correctly!" } ;
-
-HELP: with-matching-files
-{ $values
- { "dirpath" "a pathname string" } { "extension" string } { "quot" quotation }
-}
-{ $description "Perform an operation on each file in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } ;
-
-ARTICLE: { "images" "testing" "reference" } "Reference image"
-"For the purposes of the " { $vocab-link "images.testing" } " vocab, a reference image is an " { $link image } " which has been serialized to disk by the " { $vocab-link "serialize" } " vocab. The file on disk has a " { $snippet ".fig" } " extension."
-$nl
-"Reference images are used by " { $link decode-test } " to compare the decoder's output against a saved image that is known to be correct."
-$nl
-"You can create your own reference image after you verify that the image has been correctly decoded:"
-{ $subsections
- save-as-reference-image
- save-all-as-reference-images
-}
-"A reference image can be loaded by the path of the original image:"
-{ $subsections load-reference-image }
-;
-
-ARTICLE: "images.testing" "Testing image encoders and decoders"
-"The " { $vocab-link "images.testing" } " vocab facilitates writing unit tests for image encoders and decoders by providing common functionality"
-$nl
-"Creating a unit test:"
-{ $subsections
- decode-test
- encode-test
-}
-"Establishing a " { $link { "images" "testing" "reference" } } ":"
-{ $subsections save-as-reference-image }
-"You should only create a reference image after you manually verify that your decoder is generating a valid " { $link image } " object and that it renders correctly to the screen. The following words are useful for manual verification:"
-{ $subsections
- image.
- images.
-}
-"Helpful words for writing potentially tedious unit tests for each image file under test:"
-{ $subsections
- save-all-as-reference-images
- ls
- with-matching-files
-}
-{ $notes "This vocabulary is only intended for implementors of image encoders and image decoders. If you are an end-user, you are in the wrong place :-)" }
-;
-
-ABOUT: "images.testing"
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry images.loader images.normalization images.viewer io
-io.directories io.encodings.binary io.files io.pathnames
-io.streams.byte-array kernel locals namespaces quotations
-sequences serialize tools.test ;
-IN: images.testing
-
-<PRIVATE
-
-: fig-name ( path -- newpath )
- [ parent-directory canonicalize-path ]
- [ file-stem ".fig" append ] bi
- append-path ;
-
-PRIVATE>
-
-:: with-matching-files ( dirpath extension quot -- )
- dirpath [
- [
- dup file-extension extension = quot [ drop ] if
- ] each
- ] with-directory-files ; inline
-
-: images. ( dirpath extension -- )
- [ image. ] with-matching-files ;
-
-: ls ( dirpath extension -- )
- [ "\"" dup surround print ] with-matching-files ;
-
-: save-as-reference-image ( path -- )
- [ load-image ] [ fig-name ] bi
- binary [ serialize ] with-file-writer ;
-
-: save-all-as-reference-images ( dirpath extension -- )
- [ save-as-reference-image ] with-matching-files ;
-
-: load-reference-image ( path -- image )
- fig-name binary [ deserialize ] with-file-reader ;
-
-:: encode-test ( path image-class -- )
- f verbose-tests? [
- path load-image dup clone normalize-image 1quotation swap
- '[
- binary [ _ image-class image>stream ] with-byte-writer
- image-class load-image* normalize-image
- ] unit-test
- ] with-variable ;
-
-: decode-test ( path -- )
- f verbose-tests? [
- [ load-image 1quotation ]
- [ '[ _ load-reference-image ] ] bi
- unit-test
- ] with-variable ;
] unit-test
[ "Oops, I accidentally the whole economy..." ] [
- [let | noun [ "economy" ] |
+ [let
+ "economy" :> noun
[ I[ Oops, I accidentally the whole ${noun}...]I ] with-string-writer
]
] unit-test
SYNTAX: I[
"]I" parse-multiline-string
- interpolate-locals over push-all ;
+ interpolate-locals append! ;
[
dup flattenable? [
def>>
- [ visited get memq? [ no-recursive-inverse ] when ]
+ [ visited get member-eq? [ no-recursive-inverse ] when ]
[ flatten ]
bi
] [ 1quotation ] if
\ 2dup [ over =/fail over =/fail ] define-inverse
\ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
\ pick [ [ pick ] dip =/fail ] define-inverse
-\ tuck [ swapd [ =/fail ] keep ] define-inverse
\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
\ not define-involution
-\ >boolean [ dup { t f } memq? assure ] define-inverse
+\ >boolean [ dup { t f } member-eq? assure ] define-inverse
\ tuple>array \ >tuple define-dual
\ reverse define-involution
} cond
] with-timeout ;
-:: wait-for-overlapped ( us -- bytes-transferred overlapped error? )
+:: wait-for-overlapped ( usec -- bytes-transferred overlapped error? )
master-completion-port get-global
- 0 <int> [ ! bytes
- f <void*> ! key
- f <void*> [ ! overlapped
- us [ 1000 /i ] [ INFINITE ] if* ! timeout
- GetQueuedCompletionStatus zero?
- ] keep
- *void* dup [ OVERLAPPED memory>struct ] when
- ] keep *int spin ;
+ 0 <int> :> bytes
+ f <void*> :> key
+ f <void*> :> overlapped
+ usec [ 1000 /i ] [ INFINITE ] if* :> timeout
+ bytes key overlapped timeout GetQueuedCompletionStatus zero? :> error?
+
+ bytes *int
+ overlapped *void* dup [ OVERLAPPED memory>struct ] when
+ error? ;
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
[ length ] dip buffer-reset ;
: string>buffer ( string -- buffer )
- dup length <buffer> tuck buffer-set ;
+ dup length <buffer> [ buffer-set ] keep ;
: buffer-read-all ( buffer -- byte-array )
[ [ pos>> ] [ ptr>> ] bi <displaced-alien> ]
TUPLE: buffer
{ size fixnum }
-{ ptr simple-alien }
+{ ptr alien }
{ fill fixnum }
{ pos fixnum }
disposed ;
bi ; inline
: search-buffer-until ( pos fill ptr separators -- n )
- [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
+ [ [ swap alien-unsigned-1 ] dip member-eq? ] 2curry find-from drop ; inline
: finish-buffer-until ( buffer n -- byte-array separator )
[
with-directory
}
"This variable is independent of the operating system notion of “current working directory”. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
-{ $subsections (normalize-path) }
+{ $subsections absolute-path }
"The second is to change the working directory of the current process:"
{ $subsections
cd
IN: io.directories
: set-current-directory ( path -- )
- (normalize-path) current-directory set ;
+ absolute-path current-directory set ;
: with-directory ( path quot -- )
- [ (normalize-path) current-directory ] dip with-variable ; inline
+ [ absolute-path current-directory ] dip with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
IN: io.directories.search
: qualified-directory-entries ( path -- seq )
- (normalize-path)
+ absolute-path
dup directory-entries [ [ append-path ] change-name ] with map ;
: qualified-directory-files ( path -- seq )
- (normalize-path)
+ absolute-path
dup directory-files [ append-path ] with map ;
: with-qualified-directory-files ( path quot -- )
{ "latin9" "ISO-8859-15" "8859-15" }
{ "latin10" "ISO-8859-16" "8859-16" }
{ "koi8-r" "KOI8-R" "KOI8-R" }
+ { "windows-1250" "windows-1250" "CP1250" }
{ "windows-1252" "windows-1252" "CP1252" }
{ "ebcdic" "IBM037" "CP037" }
{ "mac-roman" "macintosh" "ROMAN" }
--- /dev/null
+#
+# Name: cp1250 to Unicode table
+# Unicode version: 2.0
+# Table version: 2.01
+# Table format: Format A
+# Date: 04/15/98
+#
+# Contact: Shawn.Steele@microsoft.com
+#
+# General notes: none
+#
+# Format: Three tab-separated columns
+# Column #1 is the cp1250 code (in hex)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 is the Unicode name (follows a comment sign, '#')
+#
+# The entries are in cp1250 order
+#
+0x00 0x0000 #NULL
+0x01 0x0001 #START OF HEADING
+0x02 0x0002 #START OF TEXT
+0x03 0x0003 #END OF TEXT
+0x04 0x0004 #END OF TRANSMISSION
+0x05 0x0005 #ENQUIRY
+0x06 0x0006 #ACKNOWLEDGE
+0x07 0x0007 #BELL
+0x08 0x0008 #BACKSPACE
+0x09 0x0009 #HORIZONTAL TABULATION
+0x0A 0x000A #LINE FEED
+0x0B 0x000B #VERTICAL TABULATION
+0x0C 0x000C #FORM FEED
+0x0D 0x000D #CARRIAGE RETURN
+0x0E 0x000E #SHIFT OUT
+0x0F 0x000F #SHIFT IN
+0x10 0x0010 #DATA LINK ESCAPE
+0x11 0x0011 #DEVICE CONTROL ONE
+0x12 0x0012 #DEVICE CONTROL TWO
+0x13 0x0013 #DEVICE CONTROL THREE
+0x14 0x0014 #DEVICE CONTROL FOUR
+0x15 0x0015 #NEGATIVE ACKNOWLEDGE
+0x16 0x0016 #SYNCHRONOUS IDLE
+0x17 0x0017 #END OF TRANSMISSION BLOCK
+0x18 0x0018 #CANCEL
+0x19 0x0019 #END OF MEDIUM
+0x1A 0x001A #SUBSTITUTE
+0x1B 0x001B #ESCAPE
+0x1C 0x001C #FILE SEPARATOR
+0x1D 0x001D #GROUP SEPARATOR
+0x1E 0x001E #RECORD SEPARATOR
+0x1F 0x001F #UNIT SEPARATOR
+0x20 0x0020 #SPACE
+0x21 0x0021 #EXCLAMATION MARK
+0x22 0x0022 #QUOTATION MARK
+0x23 0x0023 #NUMBER SIGN
+0x24 0x0024 #DOLLAR SIGN
+0x25 0x0025 #PERCENT SIGN
+0x26 0x0026 #AMPERSAND
+0x27 0x0027 #APOSTROPHE
+0x28 0x0028 #LEFT PARENTHESIS
+0x29 0x0029 #RIGHT PARENTHESIS
+0x2A 0x002A #ASTERISK
+0x2B 0x002B #PLUS SIGN
+0x2C 0x002C #COMMA
+0x2D 0x002D #HYPHEN-MINUS
+0x2E 0x002E #FULL STOP
+0x2F 0x002F #SOLIDUS
+0x30 0x0030 #DIGIT ZERO
+0x31 0x0031 #DIGIT ONE
+0x32 0x0032 #DIGIT TWO
+0x33 0x0033 #DIGIT THREE
+0x34 0x0034 #DIGIT FOUR
+0x35 0x0035 #DIGIT FIVE
+0x36 0x0036 #DIGIT SIX
+0x37 0x0037 #DIGIT SEVEN
+0x38 0x0038 #DIGIT EIGHT
+0x39 0x0039 #DIGIT NINE
+0x3A 0x003A #COLON
+0x3B 0x003B #SEMICOLON
+0x3C 0x003C #LESS-THAN SIGN
+0x3D 0x003D #EQUALS SIGN
+0x3E 0x003E #GREATER-THAN SIGN
+0x3F 0x003F #QUESTION MARK
+0x40 0x0040 #COMMERCIAL AT
+0x41 0x0041 #LATIN CAPITAL LETTER A
+0x42 0x0042 #LATIN CAPITAL LETTER B
+0x43 0x0043 #LATIN CAPITAL LETTER C
+0x44 0x0044 #LATIN CAPITAL LETTER D
+0x45 0x0045 #LATIN CAPITAL LETTER E
+0x46 0x0046 #LATIN CAPITAL LETTER F
+0x47 0x0047 #LATIN CAPITAL LETTER G
+0x48 0x0048 #LATIN CAPITAL LETTER H
+0x49 0x0049 #LATIN CAPITAL LETTER I
+0x4A 0x004A #LATIN CAPITAL LETTER J
+0x4B 0x004B #LATIN CAPITAL LETTER K
+0x4C 0x004C #LATIN CAPITAL LETTER L
+0x4D 0x004D #LATIN CAPITAL LETTER M
+0x4E 0x004E #LATIN CAPITAL LETTER N
+0x4F 0x004F #LATIN CAPITAL LETTER O
+0x50 0x0050 #LATIN CAPITAL LETTER P
+0x51 0x0051 #LATIN CAPITAL LETTER Q
+0x52 0x0052 #LATIN CAPITAL LETTER R
+0x53 0x0053 #LATIN CAPITAL LETTER S
+0x54 0x0054 #LATIN CAPITAL LETTER T
+0x55 0x0055 #LATIN CAPITAL LETTER U
+0x56 0x0056 #LATIN CAPITAL LETTER V
+0x57 0x0057 #LATIN CAPITAL LETTER W
+0x58 0x0058 #LATIN CAPITAL LETTER X
+0x59 0x0059 #LATIN CAPITAL LETTER Y
+0x5A 0x005A #LATIN CAPITAL LETTER Z
+0x5B 0x005B #LEFT SQUARE BRACKET
+0x5C 0x005C #REVERSE SOLIDUS
+0x5D 0x005D #RIGHT SQUARE BRACKET
+0x5E 0x005E #CIRCUMFLEX ACCENT
+0x5F 0x005F #LOW LINE
+0x60 0x0060 #GRAVE ACCENT
+0x61 0x0061 #LATIN SMALL LETTER A
+0x62 0x0062 #LATIN SMALL LETTER B
+0x63 0x0063 #LATIN SMALL LETTER C
+0x64 0x0064 #LATIN SMALL LETTER D
+0x65 0x0065 #LATIN SMALL LETTER E
+0x66 0x0066 #LATIN SMALL LETTER F
+0x67 0x0067 #LATIN SMALL LETTER G
+0x68 0x0068 #LATIN SMALL LETTER H
+0x69 0x0069 #LATIN SMALL LETTER I
+0x6A 0x006A #LATIN SMALL LETTER J
+0x6B 0x006B #LATIN SMALL LETTER K
+0x6C 0x006C #LATIN SMALL LETTER L
+0x6D 0x006D #LATIN SMALL LETTER M
+0x6E 0x006E #LATIN SMALL LETTER N
+0x6F 0x006F #LATIN SMALL LETTER O
+0x70 0x0070 #LATIN SMALL LETTER P
+0x71 0x0071 #LATIN SMALL LETTER Q
+0x72 0x0072 #LATIN SMALL LETTER R
+0x73 0x0073 #LATIN SMALL LETTER S
+0x74 0x0074 #LATIN SMALL LETTER T
+0x75 0x0075 #LATIN SMALL LETTER U
+0x76 0x0076 #LATIN SMALL LETTER V
+0x77 0x0077 #LATIN SMALL LETTER W
+0x78 0x0078 #LATIN SMALL LETTER X
+0x79 0x0079 #LATIN SMALL LETTER Y
+0x7A 0x007A #LATIN SMALL LETTER Z
+0x7B 0x007B #LEFT CURLY BRACKET
+0x7C 0x007C #VERTICAL LINE
+0x7D 0x007D #RIGHT CURLY BRACKET
+0x7E 0x007E #TILDE
+0x7F 0x007F #DELETE
+0x80 0x20AC #EURO SIGN
+0x81 #UNDEFINED
+0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
+0x83 #UNDEFINED
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 #UNDEFINED
+0x89 0x2030 #PER MILLE SIGN
+0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x015A #LATIN CAPITAL LETTER S WITH ACUTE
+0x8D 0x0164 #LATIN CAPITAL LETTER T WITH CARON
+0x8E 0x017D #LATIN CAPITAL LETTER Z WITH CARON
+0x8F 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE
+0x90 #UNDEFINED
+0x91 0x2018 #LEFT SINGLE QUOTATION MARK
+0x92 0x2019 #RIGHT SINGLE QUOTATION MARK
+0x93 0x201C #LEFT DOUBLE QUOTATION MARK
+0x94 0x201D #RIGHT DOUBLE QUOTATION MARK
+0x95 0x2022 #BULLET
+0x96 0x2013 #EN DASH
+0x97 0x2014 #EM DASH
+0x98 #UNDEFINED
+0x99 0x2122 #TRADE MARK SIGN
+0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x015B #LATIN SMALL LETTER S WITH ACUTE
+0x9D 0x0165 #LATIN SMALL LETTER T WITH CARON
+0x9E 0x017E #LATIN SMALL LETTER Z WITH CARON
+0x9F 0x017A #LATIN SMALL LETTER Z WITH ACUTE
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x02C7 #CARON
+0xA2 0x02D8 #BREVE
+0xA3 0x0141 #LATIN CAPITAL LETTER L WITH STROKE
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x02DB #OGONEK
+0xB3 0x0142 #LATIN SMALL LETTER L WITH STROKE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x0105 #LATIN SMALL LETTER A WITH OGONEK
+0xBA 0x015F #LATIN SMALL LETTER S WITH CEDILLA
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x013D #LATIN CAPITAL LETTER L WITH CARON
+0xBD 0x02DD #DOUBLE ACUTE ACCENT
+0xBE 0x013E #LATIN SMALL LETTER L WITH CARON
+0xBF 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE
+0xC0 0x0154 #LATIN CAPITAL LETTER R WITH ACUTE
+0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x0102 #LATIN CAPITAL LETTER A WITH BREVE
+0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x0139 #LATIN CAPITAL LETTER L WITH ACUTE
+0xC6 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE
+0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK
+0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x011A #LATIN CAPITAL LETTER E WITH CARON
+0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x010E #LATIN CAPITAL LETTER D WITH CARON
+0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE
+0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE
+0xD2 0x0147 #LATIN CAPITAL LETTER N WITH CARON
+0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x0150 #LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
+0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x0158 #LATIN CAPITAL LETTER R WITH CARON
+0xD9 0x016E #LATIN CAPITAL LETTER U WITH RING ABOVE
+0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x0170 #LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
+0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x0162 #LATIN CAPITAL LETTER T WITH CEDILLA
+0xDF 0x00DF #LATIN SMALL LETTER SHARP S
+0xE0 0x0155 #LATIN SMALL LETTER R WITH ACUTE
+0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x0103 #LATIN SMALL LETTER A WITH BREVE
+0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x013A #LATIN SMALL LETTER L WITH ACUTE
+0xE6 0x0107 #LATIN SMALL LETTER C WITH ACUTE
+0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x010D #LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x0119 #LATIN SMALL LETTER E WITH OGONEK
+0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x011B #LATIN SMALL LETTER E WITH CARON
+0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x010F #LATIN SMALL LETTER D WITH CARON
+0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE
+0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE
+0xF2 0x0148 #LATIN SMALL LETTER N WITH CARON
+0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x0151 #LATIN SMALL LETTER O WITH DOUBLE ACUTE
+0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x0159 #LATIN SMALL LETTER R WITH CARON
+0xF9 0x016F #LATIN SMALL LETTER U WITH RING ABOVE
+0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x0171 #LATIN SMALL LETTER U WITH DOUBLE ACUTE
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD #LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x0163 #LATIN SMALL LETTER T WITH CEDILLA
+0xFF 0x02D9 #DOT ABOVE
] dip set-at ;
: xml>gb-data ( stream -- mapping ranges )
- [let | mapping [ H{ } clone ] ranges [ V{ } clone ] |
+ [let
+ H{ } clone :> mapping V{ } clone :> ranges
[
dup contained? [
dup name>> main>> {
[ 2drop ]
} case
] [ drop ] if
- ] each-element mapping ranges
+ ] each-element mapping ranges
] ;
: unlinear ( num -- bytes )
126 /mod HEX: 81 + swap
10 /mod HEX: 30 + swap
HEX: 81 +
- 4byte-array dup reverse-here ;
+ 4byte-array reverse! ;
: >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
'[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
M: iso2022 <decoder>
make-iso-coder <decoder> ;
-<< SYNTAX: ESC HEX: 16 parsed ; >>
+<< SYNTAX: ESC HEX: 16 suffix! ; >>
CONSTANT: switch-ascii B{ ESC CHAR: ( CHAR: B }
CONSTANT: switch-jis201 B{ ESC CHAR: ( CHAR: J }
] if ;
: find-mount-point ( path -- mtab-entry )
- canonicalize-path
+ resolve-symlinks
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ;
M: winnt file-system-info ( path -- file-system-info )
normalize-path root-directory (file-system-info) ;
-: volume>paths ( string -- array )
- 16384 <ushort-array> tuck dup length
- 0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
- win32-error-string throw
+:: volume>paths ( string -- array )
+ 16384 :> names-buf-length
+ names-buf-length <ushort-array> :> names
+ 0 <uint> :> names-length
+
+ string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret
+ ret 0 = [
+ ret win32-error-string throw
] [
- *uint "ushort" heap-size * head
+ names names-length *uint "ushort" heap-size * head
utf16n alien>string CHAR: \0 split
] if ;
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
-: find-next-volume ( handle -- string/f )
- MAX_PATH 1 + [ <ushort-array> tuck ] keep
- FindNextVolume 0 = [
+:: find-next-volume ( handle -- string/f )
+ MAX_PATH 1 + :> buf-length
+ buf-length <ushort-array> :> buf
+
+ handle buf buf-length FindNextVolume :> ret
+ ret 0 = [
GetLastError ERROR_NO_MORE_FILES =
- [ drop f ] [ win32-error-string throw ] if
+ [ f ] [ win32-error-string throw ] if
] [
- utf16n alien>string
+ buf utf16n alien>string
] if ;
: find-volumes ( -- array )
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
-M: unix canonicalize-path ( path -- path' )
+M: unix resolve-symlinks ( path -- path' )
path-components "/"
[ append-path dup exists? [ follow-links ] when ] reduce ;
TR: normalize-separators "/" "\\" ;
M: winnt normalize-path ( string -- string' )
- (normalize-path)
+ absolute-path
normalize-separators
prepend-prefix ;
! Killed processes were exiting with code 0 on FreeBSD
[ f ] [
- [let | p [ <promise> ]
- s [ <promise> ] |
- [
- "sleep 1000" run-detached
- [ p fulfill ] [ wait-for-process s fulfill ] bi
- ] in-thread
-
- p ?promise handle>> 9 kill drop
- s ?promise 0 =
+ [let
+ <promise> :> p
+ <promise> :> s
+ [
+ "sleep 1000" run-detached
+ [ p fulfill ] [ wait-for-process s fulfill ] bi
+ ] in-thread
+
+ p ?promise handle>> 9 kill drop
+ s ?promise 0 =
]
] unit-test
: spawn-process ( process -- * )
[ setup-priority ] [ 250 _exit ] recover
[ setup-redirection ] [ 251 _exit ] recover
- [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
+ [ current-directory get absolute-path cd ] [ 252 _exit ] recover
[ setup-environment ] [ 253 _exit ] recover
[ get-arguments exec-args-with-path ] [ 254 _exit ] recover
255 _exit ;
M: windows run-process* ( process -- handle )
[
- current-directory get (normalize-path) cd
+ current-directory get absolute-path cd
dup make-CreateProcess-args
- tuck fill-redirection
+ [ fill-redirection ] keep
dup call-CreateProcess
lpProcessInformation>>
] with-destructors ;
""
"\"mydata.dat\" char ["
" 4 <sliced-groups>"
- " [ reverse-here ] change-each"
+ " [ reverse! drop ] map! drop"
"] with-mapped-array"
}
"Normalize a file containing packed quadrupes of floats:"
"SPECIALIZED-ARRAY: float-4"
""
"\"mydata.dat\" float-4 ["
- " [ normalize ] change-each"
+ " [ normalize ] map! drop"
"] with-mapped-array"
} ;
MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
- [let | lo [ length 32 bits ]
- hi [ length -32 shift 32 bits ] |
- { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
- path access-mode create-mode 0 open-file |dispose
- dup handle>> f protect hi lo f create-file-mapping |dispose
- dup handle>> access 0 0 0 map-view-of-file
- ] with-privileges
- ] ;
+ length 32 bits :> lo
+ length -32 shift 32 bits :> hi
+ { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
+ path access-mode create-mode 0 open-file |dispose
+ dup handle>> f protect hi lo f create-file-mapping |dispose
+ dup handle>> access 0 0 0 map-view-of-file
+ ] with-privileges ;
TUPLE: win32-mapped-file file mapping ;
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
: add-watch ( path mask mailbox -- monitor )
- [ [ (normalize-path) ] dip [ (add-watch) ] [ drop ] 2bi ] dip
+ [ [ absolute-path ] dip [ (add-watch) ] [ drop ] 2bi ] dip
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
: check-inotify ( -- )
'[ first { +modify-file+ } _ queue-change ] each ;
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
- [let | path [ path normalize-path ] |
- path mailbox macosx-monitor new-monitor
- dup [ enqueue-notifications ] curry
- path 1array 0 0 <event-stream> >>handle
- ] ;
+ path normalize-path :> path
+ path mailbox macosx-monitor new-monitor
+ dup [ enqueue-notifications ] curry
+ path 1array 0 0 <event-stream> >>handle ;
M: macosx-monitor dispose* handle>> dispose ;
ready>> ?promise ?linked drop ;
: <recursive-monitor> ( path mailbox -- monitor )
- [ (normalize-path) ] dip
+ [ absolute-path ] dip
recursive-monitor new-monitor
H{ } clone >>children
<promise> >>ready
: read-loop ( count port accum -- )
pick over length - dup 0 > [
pick read-step dup [
- over push-all read-loop
+ append! read-loop
] [
2drop 2drop
] if
: read-until-loop ( seps port buf -- separator/f )
2over read-until-step over [
- [ over push-all ] dip dup [
+ [ append! ] dip dup [
[ 3drop ] dip
] [
drop read-until-loop
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: concurrency.combinators destructors fry
-io.sockets kernel logging ;
-IN: io.servers.packet
-
-<PRIVATE
-
-LOG: received-datagram NOTICE
-
-: datagram-loop ( quot datagram -- )
- [
- [ receive dup received-datagram [ swap call ] dip ] keep
- pick [ send ] [ 3drop ] if
- ] 2keep datagram-loop ; inline
-
-: spawn-datagrams ( quot addrspec -- )
- <datagram> [ datagram-loop ] with-disposal ; inline
-
-\ spawn-datagrams NOTICE add-input-logging
-
-PRIVATE>
-
-: with-datagrams ( seq service quot -- )
- '[ [ [ _ ] dip spawn-datagrams ] parallel-each ] with-logging ; inline
+++ /dev/null
-Multi-threaded UDP/IP servers
: load-certificate-chain ( ctx -- )
dup config>> key-file>> [
- [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
+ [ handle>> ] [ config>> key-file>> absolute-path ] bi
SSL_CTX_use_certificate_chain_file
ssl-error
] [ drop ] if ;
[| buf size rwflag password! |
password [ B{ 0 } password! ] unless
- [let | len [ password strlen ] |
- buf password len 1 + size min memcpy
- len
- ]
+ password strlen :> len
+ buf password len 1 + size min memcpy
+ len
] alien-callback ;
: default-pasword ( ctx -- alien )
: use-private-key-file ( ctx -- )
dup config>> key-file>> [
- [ handle>> ] [ config>> key-file>> (normalize-path) ] bi
+ [ handle>> ] [ config>> key-file>> absolute-path ] bi
SSL_FILETYPE_PEM SSL_CTX_use_PrivateKey_file
ssl-error
] [ drop ] if ;
[ handle>> ]
[
config>>
- [ ca-file>> dup [ (normalize-path) ] when ]
- [ ca-path>> dup [ (normalize-path) ] when ] bi
+ [ ca-file>> dup [ absolute-path ] when ]
+ [ ca-path>> dup [ absolute-path ] when ] bi
] bi
SSL_CTX_load_verify_locations
] [ handle>> SSL_CTX_set_default_verify_paths ] if ssl-error ;
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size :> len :> sockaddr
+ port addr>> empty-sockaddr/size :> ( sockaddr len )
port handle>> handle-fd ! s
receive-buffer get-global ! buf
packet-size ! nbytes
M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr
- path>> (normalize-path)
+ path>> absolute-path
dup length 1 + max-un-path > [ "Path too long" throw ] when
sockaddr-un <struct>
AF_UNIX >>family
<PRIVATE
: (read-until) ( stream seps buf -- stream seps buf sep/f )
- 3dup [ [ stream-read1 dup ] dip memq? ] dip
+ 3dup [ [ stream-read1 dup ] dip member-eq? ] dip
swap [ drop ] [ push (read-until) ] if ;
:: limited-stream-seek ( n seek-type stream -- )
[ [ + ] curry map ] with map ;\r
\r
:: run-lcs ( old new init step -- matrix )\r
- [let | matrix [ old length 1 + new length 1 + init call ] |\r
- old length [| i |\r
- new length\r
- [| j | i j matrix old new step loop-step ] each\r
- ] each matrix ] ; inline\r
+ old length 1 + new length 1 + init call :> matrix\r
+ old length [| i |\r
+ new length\r
+ [| j | i j matrix old new step loop-step ] each\r
+ ] each matrix ; inline\r
PRIVATE>\r
\r
: levenshtein ( old new -- n )\r
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
+$nl
+"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:"
{ $subsections "listener-watch" }
"To start a nested listener:"
{ $subsections listener }
-"To exit the listener, invoke the " { $link return } " word."
+"To exit a listener, invoke the " { $link return } " word."
$nl
"Multi-line quotations can be read independently of the rest of the listener:"
{ $subsections read-quot } ;
"syntax"
"tools.annotations"
"tools.crossref"
+ "tools.deprecation"
"tools.destructors"
"tools.disassembler"
+ "tools.dispatch"
"tools.errors"
"tools.memory"
"tools.profiler"
[ [ drop ] leach ] must-infer
[ lnth ] must-infer
+[ { 1 2 3 } ] [ { 1 2 3 4 5 } >list [ 2 > ] luntil list>array ] unit-test
+
[ ] [ "resource:license.txt" utf8 <file-reader> llines list>array drop ] unit-test
[ ] [ "resource:license.txt" utf8 <file-reader> lcontents list>array drop ] unit-test
over nil? [ drop ] [ <lazy-until> ] if ;
M: lazy-until car ( lazy-until -- car )
- cons>> car ;
+ cons>> car ;
M: lazy-until cdr ( lazy-until -- cdr )
- [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
- [ 2drop nil ] [ luntil ] if ;
+ [ [ cons>> cdr ] [ quot>> ] bi ]
+ [ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ] bi
+ [ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- ? )
- drop f ;
+ drop f ;
TUPLE: lazy-while cons quot ;
over nil? [ drop ] [ <lazy-while> ] if ;
M: lazy-while car ( lazy-while -- car )
- cons>> car ;
+ cons>> car ;
M: lazy-while cdr ( lazy-while -- cdr )
- [ cons>> cdr ] keep quot>> lwhile ;
+ [ cons>> cdr ] keep quot>> lwhile ;
M: lazy-while nil? ( lazy-while -- ? )
- [ car ] keep quot>> call( elt -- ? ) not ;
+ [ car ] keep quot>> call( elt -- ? ) not ;
TUPLE: lazy-filter cons quot ;
foldl
foldr
lmap>array
- traverse
} ;
ARTICLE: { "lists" "manipulation" } "Manipulating lists"
{ $values { "list" list } { "array" array } }
{ $description "Convert a list into an array." } ;
-HELP: traverse
-{ $values { "list" list } { "pred" { $quotation "( list/elt -- ? )" } }
- { "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } }
-{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
- " returns true for with the result of applying quot to." } ;
-
HELP: list
{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ;
: list>array ( list -- array )
[ ] lmap>array ;
-:: traverse ( list pred quot: ( list/elt -- result ) -- result )
- list [| elt |
- elt dup pred call [ quot call ] when
- dup list? [ pred quot traverse ] when
- ] lmap ; inline recursive
-
INSTANCE: cons list
INSTANCE: +nil+ list
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
-ERROR: binding-form-in-literal-error ;
+ERROR: let-form-in-literal-error ;
-M: binding-form-in-literal-error summary
- drop "[let, [let* and [wlet not permitted inside literals" ;
+M: let-form-in-literal-error summary
+ drop "[let not permitted inside literals" ;
ERROR: local-writer-in-literal-error ;
ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
- drop ":> cannot be used outside of lambda expressions" ;
+ drop ":> cannot be used outside of [let, [|, or :: forms" ;
ERROR: bad-local args obj ;
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry fry.private generalizations kernel
-locals.types make sequences ;
+locals.types sequences ;
IN: locals.fry
! Support for mixing locals with fry
-M: binding-form count-inputs body>> count-inputs ;
-
+M: let count-inputs body>> count-inputs ;
M: lambda count-inputs body>> count-inputs ;
-M: lambda deep-fry
- clone [ shallow-fry swap ] change-body
- [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ;
+M: lambda fry
+ clone [ [ count-inputs ] [ fry ] bi ] change-body
+ [ [ vars>> length ] keep '[ _ _ mnswap _ call ] ]
+ [ drop [ncurry] curry [ call ] compose ] 2bi ;
+
+M: let fry
+ clone [ fry ] change-body ;
-M: binding-form deep-fry
- clone [ fry '[ @ call ] ] change-body , ;
+INSTANCE: lambda fried
+INSTANCE: let fried
HELP: [|
{ $syntax "[| bindings... | body... ]" }
-{ $description "A lambda abstraction. When called, reads stack values into the bindings from left to right; the body may then refer to these bindings." }
-{ $examples
- { $example
- "USING: kernel locals math prettyprint ;"
- "IN: scratchpad"
- ":: adder ( n -- quot ) [| m | m n + ] ;"
- "3 5 adder call ."
- "8"
- }
-} ;
+{ $description "A literal quotation with named variable bindings. When the quotation is " { $link call } "ed, it will take values off the datastack values and place them into the bindings from left to right. The body may then refer to these bindings. The quotation may also bind to named variables in an enclosing scope to create a closure." }
+{ $examples "See " { $link "locals-examples" } "." } ;
HELP: [let
-{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
-{ $examples
- { $example
- "USING: kernel locals math math.functions prettyprint sequences ;"
- "IN: scratchpad"
- ":: frobnicate ( n seq -- newseq )"
- " [let | n' [ n 6 * ] |"
- " seq [ n' gcd nip ] map ] ;"
- "6 { 36 14 } frobnicate ."
- "{ 36 2 }"
- }
-} ;
-
-HELP: [let*
-{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
-{ $examples
- { $example
- "USING: kernel locals math math.functions prettyprint sequences ;"
- "IN: scratchpad"
- ":: frobnicate ( n seq -- newseq )"
- " [let* | a [ n 3 + ]"
- " b [ a 4 * ] |"
- " seq [ b / ] map ] ;"
- "1 { 32 48 } frobnicate ."
- "{ 2 3 }"
- }
-} ;
-
-{ POSTPONE: [let POSTPONE: [let* } related-words
-
-HELP: [wlet
-{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
-{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
-{ $examples
- { $example
- "USING: locals math prettyprint sequences ;"
- "IN: scratchpad"
- ":: quuxify ( n seq -- newseq )"
- " [wlet | add-n [| m | m n + ] |"
- " seq [ add-n ] map ] ;"
- "2 { 1 2 3 } quuxify ."
- "{ 3 4 5 }"
- }
-} ;
+{ $syntax "[let code :> var code :> var code... ]" }
+{ $description "Establishes a new scope for lexical variable bindings. Variables bound with " { $link POSTPONE: :> } " within the body of the " { $snippet "[let" } " will be lexically scoped to the body of the " { $snippet "[let" } " form." }
+{ $examples "See " { $link "locals-examples" } "." } ;
HELP: :>
-{ $syntax ":> binding" }
-{ $description "Introduces a new binding, lexically scoped to the enclosing quotation or definition." }
+{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
+{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new lexical variable named " { $snippet "var" } " and scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
+$nl
+"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values off the datastack in left to right order. These two snippets have the same effect:"
+{ $code ":> c :> b :> a" }
+{ $code ":> ( a b c )" }
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), that new variable is mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
{ $notes
- "This word can only be used inside a lambda word, lambda quotation or let binding form."
- $nl
- "Lambda and let forms are really just syntax sugar for " { $link POSTPONE: :> } "."
- $nl
- "Lambdas desugar as follows:"
- { $code
- "[| a b | a b + b / ]"
- "[ :> b :> a a b + b / ]"
- }
- "Let forms desugar as follows:"
- { $code
- "[|let | x [ 10 random ] | { x x } ]"
- "10 random :> x { x x }"
- }
-}
-{ $examples
- { $code
- "USING: locals math kernel ;"
- "IN: scratchpad"
- ":: quadratic ( a b c -- x y )"
- " b sq 4 a c * * - sqrt :> disc"
- " b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;"
- }
-} ;
+ "This syntax can only be used inside a lexical scope established by a " { $link POSTPONE: :: } " definition, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: [| } " quotation. Normal quotations have their own lexical scope only if they are inside an outer scope. Definition forms such as " { $link POSTPONE: : } " do not establish a lexical scope by themselves unless documented otherwise, nor is there a lexical scope available at the top level of source files or in the listener. " { $link POSTPONE: [let } " can be used to create a lexical scope where one is not otherwise available." }
+{ $examples "See " { $link "locals-examples" } "." } ;
+
+{ POSTPONE: [let POSTPONE: :> } related-words
HELP: ::
-{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
-{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
-{ $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
+{ $syntax ":: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: : } " definitions." }
+{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: : POSTPONE: :: } related-words
HELP: MACRO::
-{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
-{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
+{ $syntax "MACRO:: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a macro with named inputs. The macro binds its input variables to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+{ $notes "The expansion of a macro cannot reference lexical variables bound in the outer scope. There are also limitations on passing arguments involving lexical variables into macros. See " { $link "locals-limitations" } " for details." }
+{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
HELP: MEMO::
-{ $syntax "MEMO:: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ;
+{ $syntax "MEMO:: word ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a memoized word with named inputs. The word binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
HELP: M::
-{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
-{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
+{ $syntax "M:: class generic ( vars... -- outputs... ) body... ;" }
+{ $description "Defines a new method on " { $snippet "generic" } " for " { $snippet "class" } " with named inputs. The method binds its input values to lexical variables from left to right, then executes the body with those bindings in scope."
+$nl
+"If any " { $snippet "var" } " name is followed by an exclamation point (" { $snippet "!" } "), the corresponding new variable is made mutable. See " { $link "locals-mutable" } " for more information on mutable lexical variables." }
+{ $notes "The names of the " { $snippet "outputs" } " do not affect the word's behavior. However, the compiler verifies that the stack effect accurately represents the number of outputs as with " { $link POSTPONE: M: } " definitions." }
+{ $examples "See " { $link "locals-examples" } "." } ;
{ POSTPONE: M: POSTPONE: M:: } related-words
+ARTICLE: "locals-examples" "Examples of lexical variables"
+{ $heading "Definitions with lexical variables" }
+"The following example demonstrates lexical variable bindings in word definitions. The " { $snippet "quadratic-roots" } " word is defined with " { $link POSTPONE: :: } ", so it takes its inputs from the top three elements of the datastack and binds them to the variables " { $snippet "a" } ", " { $snippet "b" } ", and " { $snippet "c" } ". In the body, the " { $snippet "disc" } " variable is bound using " { $link POSTPONE: :> } " and then used in the following line of code."
+{ $example """USING: locals math math.functions kernel ;
+IN: scratchpad
+:: quadratic-roots ( a b c -- x y )
+ b sq 4 a c * * - sqrt :> disc
+ b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@ ;
+1.0 1.0 -6.0 quadratic-roots [ . ] bi@"""
+"""2.0
+-3.0"""
+}
+"If you wanted to perform the quadratic formula interactively from the listener, you could use " { $link POSTPONE: [let } " to provide a scope for the variables:"
+{ $example """USING: locals math math.functions kernel ;
+IN: scratchpad
+[let 1.0 :> a 1.0 :> b -6.0 :> c
+ b sq 4 a c * * - sqrt :> disc
+ b neg disc [ + ] [ - ] 2bi [ 2 a * / ] bi@
+] [ . ] bi@"""
+"""2.0
+-3.0"""
+}
+
+$nl
+
+{ $heading "Quotations with lexical variables, and closures" }
+"These next two examples demonstrate lexical variable bindings in quotations defined with " { $link POSTPONE: [| } ". In this example, the values " { $snippet "5" } " and " { $snippet "3" } " are put on the datastack. When the quotation is called, it takes those values as inputs and binds them respectively to " { $snippet "m" } " and " { $snippet "n" } " before executing the quotation:"
+{ $example
+ "USING: kernel locals math prettyprint ;"
+ "IN: scratchpad"
+ "5 3 [| m n | m n - ] call ."
+ "2"
+}
+$nl
+
+"In this example, the " { $snippet "adder" } " word creates a quotation that closes over its argument " { $snippet "n" } ". When called, the result quotation of " { $snippet "5 adder" } " pulls " { $snippet "3" } " off the datastack and binds it to " { $snippet "m" } ", which is added to the value " { $snippet "5" } " bound to " { $snippet "n" } " in the outer scope of " { $snippet "adder" } ":"
+{ $example
+ "USING: kernel locals math prettyprint ;"
+ "IN: scratchpad"
+ ":: adder ( n -- quot ) [| m | m n + ] ;"
+ "3 5 adder call ."
+ "8"
+}
+$nl
+
+{ $heading "Mutable bindings" }
+"This next example demonstrates closures and mutable variable bindings. The " { $snippet "make-counter" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
+{ $example
+"""USING: locals kernel math ;
+IN: scratchpad
+
+TUPLE: counter adder subtractor ;
+
+:: <counter> ( -- counter )
+ 0 :> value!
+ counter new
+ [ value 1 + dup value! ] >>adder
+ [ value 1 - dup value! ] >>subtractor ;
+<counter>
+[ adder>> call . ]
+[ adder>> call . ]
+[ subtractor>> call . ] tri """
+"""1
+2
+1"""
+}
+ $nl
+ "The same variable name can be bound multiple times in the same scope. This is different from reassigning the value of a mutable variable. The most recent binding for a variable name will mask previous bindings for that name. However, the old binding referring to the previous value can still persist in closures. The following contrived example demonstrates this:"
+ { $example
+"""USING: kernel locals prettyprint ;
+IN: scratchpad
+:: rebinding-example ( -- quot1 quot2 )
+ 5 :> a [ a ]
+ 6 :> a [ a ] ;
+:: mutable-example ( -- quot1 quot2 )
+ 5 :> a! [ a ]
+ 6 a! [ a ] ;
+rebinding-example [ call . ] bi@
+mutable-example [ call . ] bi@"""
+"""5
+6
+6
+6"""
+}
+ "In " { $snippet "rebinding-example" } ", the binding of " { $snippet "a" } " to " { $snippet "5" } " is closed over in the first quotation, and the binding of " { $snippet "a" } " to " { $snippet "6" } " is closed over in the second, so calling both quotations results in " { $snippet "5" } " and " { $snippet "6" } " respectively. By contrast, in " { $snippet "mutable-example" } ", both quotations close over a single binding of " { $snippet "a" } ". Even though " { $snippet "a" } " is assigned to " { $snippet "6" } " after the first quotation is made, calling either quotation will output the new value of " { $snippet "a" } "."
+{ $heading "Lexical variables in literals" }
+"Some kinds of literals can include references to lexical variables as described in " { $link "locals-literals" } ". For example, the " { $link 3array } " word could be implemented as follows:"
+{ $example
+"""USING: locals prettyprint ;
+IN: scratchpad
+
+:: my-3array ( x y z -- array ) { x y z } ;
+1 "two" 3.0 my-3array ."""
+"""{ 1 "two" 3.0 }"""
+} ;
-ARTICLE: "locals-literals" "Locals in literals"
-"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
+ARTICLE: "locals-literals" "Lexical variables in literals"
+"Certain data type literals are permitted to contain lexical variables. Any such literals are rewritten into code which constructs an instance of the type with the values of the variables spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
$nl
"The data types which receive this special handling are the following:"
{ $list
"ordinary-word-test ordinary-word-test eq? ."
"t"
}
-"In a word with locals, literals which do not contain locals still behave in the same way:"
+"Inside a lexical scope, literals which do not contain lexical variables still behave in the same way:"
{ $example
"USE: locals"
"IN: scratchpad"
"locals-word-test locals-word-test eq? ."
"t"
}
-"However, literals with locals in them actually expand into code for constructing a new object:"
+"However, literals with lexical variables in them actually construct a new object:"
{ $example
"USING: locals splitting ;"
"IN: scratchpad"
"constructor-test constructor-test eq? ."
"f"
}
-"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
-{ $heading "Example" }
-"Here is an implementation of the " { $link 3array } " word which uses this feature:"
-{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
+"One exception to the above rule is that array instances containing free lexical variables (that is, immutable lexical variables not referenced in a closure) do retain identity. This allows macros such as " { $link cond } " to expand at compile time even when their arguments reference variables." ;
-ARTICLE: "locals-mutable" "Mutable locals"
-"In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
+ARTICLE: "locals-mutable" "Mutable lexical variables"
+"When a lexical variable is bound using " { $link POSTPONE: :> } ", " { $link POSTPONE: :: } ", or " { $link POSTPONE: [| } ", the variable may be made mutable by suffixing its name with an exclamation point (" { $snippet "!" } "). A mutable variable's value is read by giving its name without the exclamation point as usual. To write to the variable, use its name with the " { $snippet "!" } " suffix."
$nl
-"Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
-{ $code
- ":: counter ( -- )"
- " [let | value! [ 0 ] |"
- " [ value 1 + dup value! ]"
- " [ value 1 - dup value! ] ] ;"
-}
-"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell (in Factor's case, a 1-element array); reading the binding automatically dereferences the array, and writing to the binding stores into the array."
+"Mutable bindings are implemented in a manner similar to the ML language; each mutable binding is actually an immutable binding of a mutable cell. Reading the binding automatically unboxes the value from the cell, and writing to the binding stores into it."
$nl
-"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
+"Writing to mutable variables from outer lexical scopes is fully supported and has full closure semantics. See " { $link "locals-examples" } " for examples of mutable lexical variables in action." ;
-ARTICLE: "locals-fry" "Locals and fry"
-"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
+ARTICLE: "locals-fry" "Lexical variables and fry"
+"Lexical variables integrate with " { $link "fry" } " so that mixing variables with fried quotations gives intuitive results."
$nl
-"Recall that the following two code snippets are equivalent:"
+"The following two code snippets are equivalent:"
{ $code "'[ sq _ + ]" }
{ $code "[ [ sq ] dip + ] curry" }
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as “inserted” in the “hole” in the quotation's second element."
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
{ $code "3 [ - ] curry" }
{ $code "[ 3 - ]" }
-"With lambdas, " { $link curry } " behaves differently. Rather than prepending an element, it fills in named parameters from right to left. The following two snippets are equivalent:"
+"When quotations take named parameters using " { $link POSTPONE: [| } ", " { $link curry } " fills in the variable bindings from right to left. The following two snippets are equivalent:"
{ $code "3 [| a b | a b - ] curry" }
{ $code "[| a | a 3 - ]" }
-"Because of this, the behavior of fry changes when applied to a lambda, to ensure that conceptually, fry behaves as with quotations. So the following snippets are no longer equivalent:"
+"Because of this, the behavior of " { $snippet "fry" } " changes when applied to such a quotation to ensure that fry conceptually behaves the same as with normal quotations, placing the fried values “underneath” the variable bindings. Thus, the following snippets are no longer equivalent:"
{ $code "'[ [| a | _ a - ] ]" }
{ $code "'[ [| a | a - ] curry ] call" }
"Instead, the first line above expands into something like the following:"
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
-"This ensures that the fried value appears “underneath” the local variable " { $snippet "a" } " when the quotation calls."
$nl
-"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
+"The precise behavior is as follows. When frying a " { $link POSTPONE: [| } " quotation, a stack shuffle (" { $link mnswap } ") is prepended so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the quotation's " { $snippet "n" } " named input bindings." ;
-ARTICLE: "locals-limitations" "Limitations of locals"
-"There are two main limitations of the current locals implementation, and both concern macros."
+ARTICLE: "locals-limitations" "Limitations of lexical variables"
+"There are two main limitations of the current implementation, and both concern macros."
{ $heading "Macro expansions with free variables" }
-"The expansion of a macro cannot reference local variables bound in the outer scope. For example, the following macro is invalid:"
+"The expansion of a macro cannot reference lexical variables bound in the outer scope. For example, the following macro is invalid:"
{ $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" }
"The following is fine, though:"
{ $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" }
{ $heading "Static stack effect inference and macros" }
-"Recall that a macro will only expand at compile-time, and the word containing it will only get a static stack effect, if all inputs to the macro are literal. When locals are used, there is an additional restriction; the literals must immediately precede the macro call, lexically."
+"A macro will only expand at compile-time if all of its inputs are literal. Likewise, the word containing the macro will only have a static stack effect and compile successfully if the macro's inputs are literal. When lexical variables are used in a macro's literal arguments, there is an additional restriction: The literals must immediately precede the macro call lexically."
$nl
-"For example, all of the following three examples are equivalent semantically, but only the first will have a static stack effect and compile with the optimizing compiler:"
+"For example, all of the following three code snippets are superficially equivalent, but only the first will compile:"
{ $code
":: good-cond-usage ( a -- ... )"
" {"
" { [ a 0 = ] [ ... ] }"
" } cond ;"
}
-"The following two will not, and will run slower as a result:"
+"The next two snippets will not compile because the argument to " { $link cond } " does not immediately precede the call:"
{ $code
": my-cond ( alist -- ) cond ; inline"
""
" { [ a 0 = ] [ ... ] }"
" } swap swap cond ;"
}
-"The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
+"The reason is that lexical variable references are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to lexical variable transformation. However, " { $vocab-link "macros.expander" } " cannot deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
-ARTICLE: "locals" "Lexical variables and closures"
-"The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope."
-$nl
-"Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results."
-$nl
-"Applicative word definitions where the inputs are named local variables:"
+ARTICLE: "locals" "Lexical variables"
+"The " { $vocab-link "locals" } " vocabulary provides lexically scoped local variables. Full closure semantics, both downward and upward, are supported. Mutable variable bindings are also provided, supporting assignment to bindings in the current scope or in outer scopes."
+{ $subsections
+ "locals-examples"
+}
+"Word definitions where the inputs are bound to lexical variables:"
{ $subsections
POSTPONE: ::
POSTPONE: M::
POSTPONE: MEMO::
POSTPONE: MACRO::
}
-"Lexical binding forms:"
+"Lexical scoping and binding forms:"
{ $subsections
POSTPONE: [let
- POSTPONE: [let*
- POSTPONE: [wlet
+ POSTPONE: :>
}
-"Lambda abstractions:"
+"Quotation literals where the inputs are bound to lexical variables:"
{ $subsections POSTPONE: [| }
-"Lightweight binding form:"
-{ $subsections POSTPONE: :> }
"Additional topics:"
{ $subsections
"locals-literals"
"locals-fry"
"locals-limitations"
}
-"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
+"Lexical variables complement " { $link "namespaces" } "." ;
ABOUT: "locals"
[ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
:: let-test ( c -- d )
- [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
+ [let 1 :> a 2 :> b a b + c + ] ;
[ 7 ] [ 4 let-test ] unit-test
:: let-test-2 ( a -- a )
- a [let | a [ ] | [let | b [ a ] | a ] ] ;
+ a [let :> a [let a :> b a ] ] ;
[ 3 ] [ 3 let-test-2 ] unit-test
:: let-test-3 ( a -- a )
- a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
+ a [let :> a [let [ a ] :> b [let 3 :> a b ] ] ] ;
:: let-test-4 ( a -- b )
- a [let | a [ 1 ] b [ ] | a b 2array ] ;
+ a [let 1 :> a :> b a b 2array ] ;
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
:: let-test-5 ( a b -- b )
- a b [let | a [ ] b [ ] | a b 2array ] ;
+ a b [let :> a :> b a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
:: let-test-6 ( a -- b )
- a [let | a [ ] b [ 1 ] | a b 2array ] ;
+ a [let :> a 1 :> b a b 2array ] ;
[ { 2 1 } ] [ 2 let-test-6 ] unit-test
[ -1 ] [ -1 let-test-3 call ] unit-test
-[ 5 ] [
- [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
-] unit-test
-
-:: wlet-test-2 ( a b -- seq )
- [wlet | add-b [ b + ] |
- a [ add-b ] map ] ;
-
-
-[ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
-
-:: wlet-test-3 ( a -- b )
- [wlet | add-a [ a + ] | [ add-a ] ]
- [let | a [ 3 ] | a swap call ] ;
-
-[ 5 ] [ 2 wlet-test-3 ] unit-test
-
-:: wlet-test-4 ( a -- b )
- [wlet | sub-a [| b | b a - ] |
- 3 sub-a ] ;
-
-[ -7 ] [ 10 wlet-test-4 ] unit-test
-
:: write-test-1 ( n! -- q )
[| i | n i + dup n! ] ;
[ 5 ] [ 2 "q" get call ] unit-test
:: write-test-2 ( -- q )
- [let | n! [ 0 ] |
- [| i | n i + dup n! ] ] ;
+ [let 0 :> n! [| i | n i + dup n! ] ] ;
write-test-2 "q" set
[ ] [ 1 2 write-test-3 call ] unit-test
-:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
+:: write-test-4 ( x! -- q ) [ [let 0 :> y! f x! ] ] ;
[ ] [ 5 write-test-4 drop ] unit-test
-! Not really a write test; just enforcing consistency
-:: write-test-5 ( x -- y )
- [wlet | fun! [ x + ] | 5 fun! ] ;
-
-[ 9 ] [ 4 write-test-5 ] unit-test
-
-:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
+:: let-let-test ( n -- n ) [let n 3 + :> n n ] ;
[ 13 ] [ 10 let-let-test ] unit-test
[ ] [ \ lambda-generic see ] unit-test
-:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
+:: unparse-test-1 ( a -- ) [let 3 :> a! 4 :> b ] ;
-[ "[let | a! [ 3 ] | ]" ] [
+[ "[let 3 :> a! 4 :> b ]" ] [
\ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
-:: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
-
-[ "[wlet | a! [ ] | ]" ] [
- \ unparse-test-2 "lambda" word-prop body>> first unparse
-] unit-test
-
:: unparse-test-3 ( -- b ) [| a! | ] ;
[ "[| a! | ]" ] [
[ 5 ] [ 10 xyzzy ] unit-test
-:: let*-test-1 ( a -- b )
- [let* | b [ a 1 + ]
- c [ b 1 + ] |
- a b c 3array ] ;
-
-[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
-
-:: let*-test-2 ( a -- b )
- [let* | b [ a 1 + ]
- c! [ b 1 + ] |
- a b c 3array ] ;
-
-[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
-
-:: let*-test-3 ( a -- b )
- [let* | b [ a 1 + ]
- c! [ b 1 + ] |
- c 1 + c! a b c 3array ] ;
-
-[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
-
-:: let*-test-4 ( a b -- c d )
- [let | a [ b ]
- b [ a ] |
- [let* | a' [ a ]
- a'' [ a' ]
- b' [ b ]
- b'' [ b' ] |
- a'' b'' ] ] ;
-
-[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
-
GENERIC: next-method-test ( a -- b )
M: integer next-method-test 3 + ;
{ 3 0 } [| a b c | ] must-infer-as
-[ ] [ 1 [let | a [ ] | ] ] unit-test
+[ ] [ 1 [let :> a ] ] unit-test
-[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
+[ 3 ] [ 1 [let :> a 3 ] ] unit-test
-[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
+[ ] [ 1 2 [let :> a :> b ] ] unit-test
:: a-word-with-locals ( a b -- ) ;
[ t ] [ 12 &&-test ] unit-test
:: let-and-cond-test-1 ( -- a )
- [let | a [ 10 ] |
- [let | a [ 20 ] |
+ [let 10 :> a
+ [let 20 :> a
{
- { [ t ] [ [let | c [ 30 ] | a ] ] }
+ { [ t ] [ [let 30 :> c a ] ] }
} cond
]
] ;
[ 20 ] [ let-and-cond-test-1 ] unit-test
:: let-and-cond-test-2 ( -- pair )
- [let | A [ 10 ] |
- [let | B [ 20 ] |
+ [let 10 :> A
+ [let 20 :> B
{ { [ t ] [ { A B } ] } } cond
]
] ;
[ { 10 20 } ] [ 10 20 [| a b | { a b } ] call ] unit-test
[ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
-[ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
+[ { 10 20 30 } ] [ [let 10 :> a 20 :> b 30 :> c { a b c } ] ] unit-test
[ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
- "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
+ "USING: locals fry math ; 1 '[ [let 10 :> A A _ + ] ]"
eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
-:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
+:: (funny-macro-test) ( obj quot -- ? ) obj { [ quot call ] } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
\ funny-macro-test def>> must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
-! Some odd parser corner cases
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
-[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
+[ "USE: locals [| | { [let 0 :> a a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-
-[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-
-[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
-
-[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
+[ "USE: locals [| | [let 0 :> a! { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
[ 3 ] [ 2 [| | :> a! a 1 + a! a ] call ] unit-test
-:: wlet-&&-test ( a -- ? )
- [wlet | is-integer? [ a integer? ]
- is-even? [ a even? ]
- >10? [ a 10 > ] |
- { [ is-integer? ] [ is-even? ] [ >10? ] } &&
- ] ;
-
-\ wlet-&&-test def>> must-infer
-[ f ] [ 1.5 wlet-&&-test ] unit-test
-[ f ] [ 3 wlet-&&-test ] unit-test
-[ f ] [ 8 wlet-&&-test ] unit-test
-[ t ] [ 12 wlet-&&-test ] unit-test
-
: fry-locals-test-1 ( -- n )
- [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
+ [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
\ fry-locals-test-1 def>> must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
- [let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
+ [let 6 '[ [let 4 :> A A _ + ] ] call ] ;
\ fry-locals-test-2 def>> must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
] unit-test
[ 10 ] [
- [| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
+ [| | 0 '[ [let 10 :> A A _ + ] ] call ] call
] unit-test
! littledan found this problem
-[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
-[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
+[ "bar" ] [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test
+[ 10 ] [ [let 10 :> a [let a :> b b ] ] ] unit-test
-[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
+[ { \ + } ] [ [let \ + :> x { \ x } ] ] unit-test
-[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
+[ { \ + 3 } ] [ [let 3 :> a { \ + a } ] ] unit-test
-[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
+[ 3 ] [ [let \ + :> a 1 2 [ \ a execute ] ] call ] unit-test
! erg found this problem
:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
{ [ a ed's-bug ] } && ;
[ t ] [ \ ed's-test-case optimized? ] unit-test
+
+! multiple bind
+[ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test
SYNTAX: :>
scan locals get [ :>-outside-lambda-error ] unless*
- [ make-local ] bind <def> parsed ;
+ parse-def suffix! ;
-SYNTAX: [| parse-lambda over push-all ;
+SYNTAX: [| parse-lambda append! ;
-SYNTAX: [let parse-let over push-all ;
-
-SYNTAX: [let* parse-let* over push-all ;
-
-SYNTAX: [wlet parse-wlet over push-all ;
+SYNTAX: [let parse-let append! ;
SYNTAX: :: (::) define-declared ;
M: lambda expand-macros* expand-macros literal ;
-M: binding-form expand-macros
- clone
- [ [ expand-macros ] assoc-map ] change-bindings
- [ expand-macros ] change-body ;
+M: let expand-macros
+ clone [ expand-macros ] change-body ;
-M: binding-form expand-macros* expand-macros literal ;
+M: let expand-macros* expand-macros literal ;
M: lambda condomize? drop t ;
-M: lambda condomize '[ @ ] ;
\ No newline at end of file
+M: lambda condomize [ call ] curry ;
(parse-lambda) <lambda>
?rewrite-closures ;
+: parse-multi-def ( locals -- multi-def )
+ ")" parse-tokens swap [ [ make-local ] map ] bind <multi-def> ;
+
+: parse-def ( name/paren locals -- def )
+ over "(" = [ nip parse-multi-def ] [ [ make-local ] bind <def> ] if ;
+
M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ;
[ nip scan-object 2array ]
} cond ;
-: (parse-bindings) ( end -- )
- dup parse-binding dup [
- first2 [ make-local ] dip 2array ,
- (parse-bindings)
- ] [ 2drop ] if ;
-
-: with-bindings ( quot -- words assoc )
- '[
- in-lambda? on
- _ H{ } make-assoc
- ] { } make swap ; inline
-
-: parse-bindings ( end -- bindings vars )
- [ (parse-bindings) ] with-bindings ;
-
: parse-let ( -- form )
- "|" expect "|" parse-bindings
- (parse-lambda) <let> ?rewrite-closures ;
-
-: parse-bindings* ( end -- words assoc )
- [
- namespace use-words
- (parse-bindings)
- namespace unuse-words
- ] with-bindings ;
-
-: parse-let* ( -- form )
- "|" expect "|" parse-bindings*
- (parse-lambda) <let*> ?rewrite-closures ;
-
-: (parse-wbindings) ( end -- )
- dup parse-binding dup [
- first2 [ make-local-word ] keep 2array ,
- (parse-wbindings)
- ] [ 2drop ] if ;
-
-: parse-wbindings ( end -- bindings vars )
- [ (parse-wbindings) ] with-bindings ;
-
-: parse-wlet ( -- form )
- "|" expect "|" parse-wbindings
- (parse-lambda) <wlet> ?rewrite-closures ;
+ H{ } clone (parse-lambda) <let> ?rewrite-closures ;
: parse-locals ( -- effect vars assoc )
complete-effect
[
[ parse-definition ]
parse-locals-definition drop
- ] with-method-definition ;
\ No newline at end of file
+ ] with-method-definition ;
: pprint-let ( let word -- )
pprint-word
- [ body>> ] [ bindings>> ] bi
- \ | pprint-word
- t <inset
- <block
- [ <block [ pprint-var ] dip pprint* block> ] assoc-each
- block>
- \ | pprint-word
- <block pprint-elements block>
- block>
+ <block body>> pprint-elements block>
\ ] pprint-word ;
M: let pprint* \ [let pprint-let ;
-M: wlet pprint* \ [wlet pprint-let ;
-
-M: let* pprint* \ [let* pprint-let ;
-
M: def pprint*
- <block \ :> pprint-word local>> pprint-word block> ;
+ dup local>> word?
+ [ <block \ :> pprint-word local>> pprint-var block> ]
+ [ pprint-tuple ] if ;
+
+M: multi-def pprint*
+ dup locals>> [ word? ] all?
+ [ <block \ :> pprint-word "(" text locals>> [ pprint-var ] each ")" text block> ]
+ [ pprint-tuple ] if ;
words ;
IN: locals.rewrite.sugar
-! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
+! Step 1: rewrite [| into :> forms, turn
! literals with locals in them into code which constructs
! the literal after pushing locals on the stack
M: lambda rewrite-element rewrite-sugar* ;
-M: binding-form rewrite-element binding-form-in-literal-error ;
+M: let rewrite-element let-form-in-literal-error ;
M: local rewrite-element , ;
M: def rewrite-sugar* , ;
+M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
+
M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper rewrite-sugar*
rewrite-wrapper ;
M: word rewrite-sugar*
- dup { load-locals get-local drop-locals } memq?
+ dup { load-locals get-local drop-locals } member-eq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object rewrite-sugar* , ;
-: let-rewrite ( body bindings -- )
- [ quotation-rewrite % <def> , ] assoc-each
- quotation-rewrite % ;
-
M: let rewrite-sugar*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: let* rewrite-sugar*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: wlet rewrite-sugar*
- [ body>> ] [ bindings>> ] bi
- [ '[ _ ] ] assoc-map
- let-rewrite ;
+ body>> quotation-rewrite % ;
C: <lambda> lambda
-TUPLE: binding-form bindings body ;
-
-TUPLE: let < binding-form ;
+TUPLE: let body ;
C: <let> let
-TUPLE: let* < binding-form ;
-
-C: <let*> let*
-
-TUPLE: wlet < binding-form ;
-
-C: <wlet> wlet
-
TUPLE: quote local ;
C: <quote> quote
C: <def> def
+TUPLE: multi-def locals ;
+
+C: <multi-def> multi-def
+
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
SYMBOL: message-histogram\r
\r
: analyze-entry ( entry -- )\r
- dup level>> { ERROR CRITICAL } memq? [ dup errors get push ] when\r
+ dup level>> { ERROR CRITICAL } member-eq? [ dup errors get push ] when\r
dup word-name>> word-histogram get inc-at\r
dup word-name>> word-names get member? [\r
dup [ level>> ] [ word-name>> ] [ message>> ] tri 3array\r
: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
-: V+ ( x y -- x+y )
- 1.0 -rot n*V+V ; inline
-: V- ( x y -- x-y )
- -1.0 spin n*V+V ; inline
+:: V+ ( x y -- x+y )
+ 1.0 x y n*V+V ; inline
+:: V- ( x y -- x-y )
+ -1.0 y x n*V+V ; inline
: Vneg ( x -- -x )
-1.0 swap n*V ; inline
M: blas-vector-base length
length>> ;
-M: blas-vector-base virtual-seq
+M: blas-vector-base virtual-exemplar
(blas-direct-array) ;
M: blas-vector-base virtual@
[ inc>> * ] [ nip (blas-direct-array) ] 2bi ;
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
-: combination-indices ( m combo -- seq )
- [ tuck dual-index combinadic ] keep
- seq>> length 1 - swap [ - ] with map ;
+:: combination-indices ( m combo -- seq )
+ combo m combo dual-index combinadic
+ combo seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
{ $subsections log1+ log10 }
"Raising a number to a power:"
{ $subsections ^ 10^ }
+"Finding the root of a number:"
+{ $subsections nth-root }
"Converting between rectangular and polar form:"
{ $subsections
abs
{ $description "Raises " { $snippet "x" } " to the power of " { $snippet "y" } ". If " { $snippet "y" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." }
{ $errors "Throws an error if " { $snippet "x" } " and " { $snippet "y" } " are both integer 0." } ;
+HELP: nth-root
+{ $values { "n" integer } { "x" number } { "y" number } }
+{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
+
HELP: 10^
{ $values { "x" number } { "y" number } }
{ $description "Raises " { $snippet "x" } " to the power of 10. If " { $snippet "x" } " is an integer the answer is computed exactly, otherwise a floating point approximation is used." } ;
[ t ] [ e pi i* ^ real-part -1.0 = ] unit-test
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
+[ 1/0. ] [ 2.0 1024 ^ ] unit-test
+[ HEX: 1.0p-1024 ] [ 2.0 -1024 ^ ] unit-test
+
[ t ] [ 0 0 ^ fp-nan? ] unit-test
[ 0.0 ] [ 0.0 1.0 ^ ] unit-test
[ 1/0. ] [ 0 -2 ^ ] unit-test
M: complex ^n (^n) ;
: integer^ ( x y -- z )
- dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
+ dup 0 >= [ ^n ] [ [ recip ] dip neg ^n ] if ; inline
PRIVATE>
[ ^complex ]
} cond ; inline
+: nth-root ( n x -- y ) swap recip ^ ; inline
+
: gcd ( x y -- a d )
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
[ [ / floor ] [ * ] bi ] unless-zero ;
: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
-
[ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test
-[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test
+[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test
[ t ] [
0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] =
dup full-interval eq? [
drop 32 random-bits 31 2^ -
] [
- dup to>> first over from>> first tuck - random +
+ [ ] [ from>> first ] [ to>> first ] tri over - random +
2dup swap interval-contains? [
nip
] [
: interval-sq ( i1 -- i2 ) dup interval* ;
: special-interval? ( interval -- ? )
- { empty-interval full-interval } memq? ;
+ { empty-interval full-interval } member-eq? ;
: interval-singleton? ( int -- ? )
dup special-interval? [
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors math.matrices namespaces
-sequences ;
+USING: kernel locals math math.vectors math.matrices
+namespaces sequences ;
IN: math.matrices.elimination
SYMBOL: matrix
] each
] with-matrix ;
-: basis-vector ( row col# -- )
- [ clone ] dip
- [ swap nth neg recip ] 2keep
- [ 0 spin set-nth ] 2keep
- [ n*v ] dip
- matrix get set-nth ;
+:: basis-vector ( row col# -- )
+ row clone :> row'
+ col# row' nth neg recip :> a
+ 0 col# row' set-nth
+ a row n*v col# matrix get set-nth ;
: nullspace ( matrix -- seq )
echelon reduced dup empty? [
:: rotation-matrix3 ( axis theta -- matrix )
theta cos :> c
theta sin :> s
- axis first3 :> z :> y :> x
+ axis first3 :> ( x y z )
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
:: rotation-matrix4 ( axis theta -- matrix )
theta cos :> c
theta sin :> s
- axis first3 :> z :> y :> x
+ axis first3 :> ( x y z )
x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
{ 0.0 0.0 0.0 1.0 } 4array ;
:: translation-matrix4 ( offset -- matrix )
- offset first3 :> z :> y :> x
+ offset first3 :> ( x y z )
{
{ 1.0 0.0 0.0 x }
{ 0.0 1.0 0.0 y }
dup number? [ dup dup ] [ first3 ] if ;
:: scale-matrix3 ( factors -- matrix )
- factors >scale-factors :> z :> y :> x
+ factors >scale-factors :> ( x y z )
{
{ x 0.0 0.0 }
{ 0.0 y 0.0 }
} ;
:: scale-matrix4 ( factors -- matrix )
- factors >scale-factors :> z :> y :> x
+ factors >scale-factors :> ( x y z )
{
{ x 0.0 0.0 0.0 }
{ 0.0 y 0.0 0.0 }
[ recip ] map scale-matrix4 ;
:: frustum-matrix4 ( xy-dim near far -- matrix )
- xy-dim first2 :> y :> x
+ xy-dim first2 :> ( x y )
near x /f :> xf
near y /f :> yf
near far + near far - /f :> zf
[ f ] [ \ + object number math-both-known? ] unit-test
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
-[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
-[ f ] [ \ >integer \ /i derived-ops memq? ] unit-test
-[ t ] [ \ fixnum-shift \ shift derived-ops memq? ] unit-test
+[ f ] [ \ >fixnum \ shift derived-ops member-eq? ] unit-test
+[ f ] [ \ >integer \ /i derived-ops member-eq? ] unit-test
+[ t ] [ \ fixnum-shift \ shift derived-ops member-eq? ] unit-test
[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
[ 3 ] [ 1 2 +-integer-integer ] unit-test
[ 3 ] [ 1 >bignum 2 +-integer-integer ] unit-test
[ 3 ] [ 1 2 >bignum +-integer-integer ] unit-test
-[ 3 ] [ 1 >bignum 2 >bignum +-integer-integer ] unit-test
\ No newline at end of file
+[ 3 ] [ 1 >bignum 2 >bignum +-integer-integer ] unit-test
[ t ] [ 113 100 sieve marked-prime? ] unit-test
! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
-[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test
\ No newline at end of file
+[ 25997 ] [ 299999 sieve [ bit-count ] map-sum 2 + ] unit-test
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1
- n-1 factor-2s :> s :> r
+ n-1 factor-2s :> ( r s )
0 :> a!
trials [
drop
{ $code "3 10 [a,b] [ sqrt ] map" }
"Computing the factorial of 100 with a descending range:"
{ $code "100 1 [a,b] product" }
-"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link map! } "." ;
ABOUT: "math.ranges"
[ 1.0 ] [ 0.5 1/2 + ] unit-test
[ 1.0 ] [ 1/2 0.5 + ] unit-test
-[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
+[ 1/134217728 ] [ -1 -134217728 >fixnum / ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 / ] unit-test
[ 5 ]
[ "10/2" string>number ]
: <rect> ( loc dim -- rect ) rect boa ; inline
-SYNTAX: RECT: scan-object scan-object <rect> parsed ;
+SYNTAX: RECT: scan-object scan-object <rect> suffix! ;
: <zero-rect> ( -- rect ) rect new ; inline
USING: vocabs vocabs.loader ;
-"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
\ No newline at end of file
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
-USING: help.markup help.syntax debugger ;
+USING: assocs debugger hashtables help.markup help.syntax
+quotations sequences math ;
IN: math.statistics
HELP: geometric-mean
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
+{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set and minimizes the effects of extreme values." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $notes "Positive reals only." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
+{ $description "Computes the arithmetic mean of the elements in " { $snippet "seq" } "." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
+{ $description "Computes the median of " { $snippet "seq" } " by finding the middle element of the sequence using " { $link kth-smallest } ". If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is output." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } median ." "2+1/2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
-{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
+{ $description "Computes the difference of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } range ." "3" } } ;
+HELP: minmax
+{ $values { "seq" sequence } { "min" real } { "max" real } }
+{ $description "Finds the minimum and maximum elements of " { $snippet "seq" } " in one pass." }
+{ $examples
+ { $example "USING: arrays math.statistics prettyprint ;"
+ "{ 1 2 3 } minmax 2array ."
+ "{ 1 3 }"
+ }
+} ;
+
HELP: std
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
{ $description "Computes the standard deviation of " { $snippet "seq" } ", which is the square root of the variance. It measures how widely spread the values in a sequence are about the mean." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } std ." "1.0" }
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } std ." "1.290994448735806" } } ;
HELP: ste
- { $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+ { $values { "seq" sequence } { "x" "a non-negative real number"} }
{ $description "Computes the standard error of the mean for " { $snippet "seq" } ". It's defined as the standard deviation divided by the square root of the length of the sequence, and measures uncertainty associated with the estimate of the mean." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 } ste ." "2.0" }
{ $example "USING: math.statistics prettyprint ;" "{ -2 2 2 } ste ." "1.333333333333333" } } ;
HELP: var
-{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
+{ $values { "seq" sequence } { "x" "a non-negative real number"} }
{ $description "Computes the variance of " { $snippet "seq" } ". It's a measurement of the spread of values in a sequence. The larger the variance, the larger the distance of values from the mean." }
{ $notes "If the number of elements in " { $snippet "seq" } " is 1 or less, it outputs 0." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } var ." "1" }
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 4 } var ." "1+2/3" } } ;
+
+HELP: histogram
+{ $values
+ { "seq" sequence }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times an element appears in a sequence."
+ "USING: prettyprint math.statistics ;"
+ "\"aaabc\" histogram ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
+
+HELP: histogram*
+{ $values
+ { "hashtable" hashtable } { "seq" sequence }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times the elements of two sequences appear."
+ "USING: prettyprint math.statistics ;"
+ "\"aaabc\" histogram \"aaaaaabc\" histogram* ."
+ "H{ { 97 9 } { 98 2 } { 99 2 } }"
+ }
+}
+{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;
+
+HELP: sorted-histogram
+{ $values
+ { "seq" sequence }
+ { "alist" "an array of key/value pairs" }
+}
+{ $description "Outputs a " { $link histogram } " of a sequence sorted by number of occurences from lowest to highest." }
+{ $examples
+ { $example "USING: prettyprint math.statistics ;"
+ """"abababbbbbbc" sorted-histogram ."""
+ "{ { 99 1 } { 97 3 } { 98 8 } }"
+ }
+} ;
+
+HELP: sequence>assoc
+{ $values
+ { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }
+ { "assoc" assoc }
+}
+{ $examples
+ { $example "! Iterate over a sequence and increment the count at each element"
+ "USING: assocs prettyprint math.statistics ;"
+ "\"aaabc\" [ inc-at ] H{ } sequence>assoc ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
+
+HELP: sequence>assoc*
+{ $values
+ { "assoc" assoc } { "seq" sequence } { "quot" quotation }
+ { "assoc" assoc }
+}
+{ $examples
+ { $example "! Iterate over a sequence and add the counts to an existing assoc"
+ "USING: assocs prettyprint math.statistics kernel ;"
+ "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
+ "H{ { 97 5 } { 98 2 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;
+
+HELP: sequence>hashtable
+{ $values
+ { "seq" sequence } { "quot" quotation }
+ { "hashtable" hashtable }
+}
+{ $examples
+ { $example "! Count the number of times an element occurs in a sequence"
+ "USING: assocs prettyprint math.statistics ;"
+ "\"aaabc\" [ inc-at ] sequence>hashtable ."
+ "H{ { 97 3 } { 98 1 } { 99 1 } }"
+ }
+}
+{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;
+
+ARTICLE: "histogram" "Computing histograms"
+"Counting elements in a sequence:"
+{ $subsections
+ histogram
+ histogram*
+ sorted-histogram
+}
+"Combinators for implementing histogram:"
+{ $subsections
+ sequence>assoc
+ sequence>assoc*
+ sequence>hashtable
+} ;
+
+ARTICLE: "math.statistics" "Statistics"
+"Computing the mean:"
+{ $subsections mean geometric-mean harmonic-mean }
+"Computing the median:"
+{ $subsections median lower-median upper-median medians }
+"Computing the mode:"
+{ $subsections mode }
+"Computing the standard deviation, standard error, and variance:"
+{ $subsections std ste var }
+"Computing the range and minimum and maximum elements:"
+{ $subsections range minmax }
+"Computing the kth smallest element:"
+{ $subsections kth-smallest }
+"Counting the frequency of occurrence of elements:"
+{ $subsection "histogram" } ;
+
+ABOUT: "math.statistics"
[ 0 ] [ { 1 } var ] unit-test
[ 0.0 ] [ { 1 } std ] unit-test
[ 0.0 ] [ { 1 } ste ] unit-test
+
+[
+ H{
+ { 97 2 }
+ { 98 2 }
+ { 99 2 }
+ }
+] [
+ "aabbcc" histogram
+] unit-test
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel math math.analysis
-math.functions math.order sequences sorting locals
-sequences.private assocs fry ;
+USING: arrays combinators kernel math math.functions
+math.order sequences sorting locals sequences.private
+assocs fry ;
IN: math.statistics
: mean ( seq -- x )
[ length ] [ product ] bi nth-root ;
: harmonic-mean ( seq -- x )
- [ recip ] sigma recip ;
+ [ recip ] map-sum recip ;
:: kth-smallest ( seq k -- elt )
#! Wirth's method, Algorithm's + Data structues = Programs p. 84
[ i seq nth-unsafe x < ] [ i 1 + i! ] while
[ x j seq nth-unsafe < ] [ j 1 - j! ] while
i j <= [
- i j seq exchange
+ i j seq exchange-unsafe
i 1 + i!
j 1 - j!
] when
k seq nth ; inline
: lower-median ( seq -- elt )
- dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ;
+ [ ] [ ] [ length odd? ] tri
+ [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ;
: upper-median ( seq -- elt )
dup midpoint@ kth-smallest ;
[ lower-median ] [ upper-median ] bi ;
: median ( seq -- x )
- dup length odd? [ lower-median ] [ medians + 2 / ] if ;
+ [ ] [ length odd? ] bi [ lower-median ] [ medians + 2 / ] if ;
-: frequency ( seq -- hashtable )
- H{ } clone [ '[ _ inc-at ] each ] keep ;
+<PRIVATE
+
+: (sequence>assoc) ( seq quot assoc -- assoc )
+ [ swap curry each ] keep ; inline
+
+PRIVATE>
+
+: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
+ rot (sequence>assoc) ; inline
+
+: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
+ clone (sequence>assoc) ; inline
+
+: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
+ H{ } sequence>assoc ; inline
+
+: histogram* ( hashtable seq -- hashtable )
+ [ inc-at ] sequence>assoc* ;
+
+: histogram ( seq -- hashtable )
+ [ inc-at ] sequence>hashtable ;
+
+: sorted-histogram ( seq -- alist )
+ histogram >alist sort-values ;
+
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
+ '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline
: mode ( seq -- x )
- frequency >alist
+ histogram >alist
[ ] [ [ [ second ] bi@ > ] 2keep ? ] map-reduce first ;
: minmax ( seq -- min max )
dup length 1 <= [
drop 0
] [
- [ [ mean ] keep [ - sq ] with sigma ]
+ [ [ mean ] keep [ - sq ] with map-sum ]
[ length 1 - ] bi /
] if ;
<PRIVATE
: float-type? ( c-type -- ? )
- { float double } memq? ;
+ { float double } member-eq? ;
: unsigned-type? ( c-type -- ? )
- { uchar ushort uint ulonglong } memq? ;
+ { uchar ushort uint ulonglong } member-eq? ;
: check-vconvert-type ( value expected-type -- value )
2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline
PRIVATE>
MACRO:: vconvert ( from-type to-type -- )
- from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element
- to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element
+ from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length )
+ to-type new [ element-type ] [ byte-length ] bi :> ( to-element to-length )
from-element heap-size :> from-size
to-element heap-size :> to-size
[ rep alien-vector class boa ] >>getter
[ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
16 >>size
- 8 >>align
+ 16 >>align
rep >>rep
class c:typedef ;
3bi
] >>setter
32 >>size
- 8 >>align
+ 16 >>align
rep >>rep
class c:typedef ;
{ \ (simd-vnot) [ %xor-vector-reps ] }
{ \ (simd-vlshift) [ %shl-vector-reps ] }
{ \ (simd-vrshift) [ %shr-vector-reps ] }
- { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
- { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
+ { \ (simd-hlshift) [ %horizontal-shl-vector-imm-reps ] }
+ { \ (simd-hrshift) [ %horizontal-shr-vector-imm-reps ] }
{ \ (simd-vshuffle-elements) [ (%shuffle-imm-reps) ] }
{ \ (simd-vshuffle-bytes) [ %shuffle-vector-reps ] }
{ \ (simd-(vmerge-head)) [ %merge-vector-reps ] }
2dup = [ drop ] [ inconsistent-vector-test boa ] if ;
:: test-vector-tests ( vector decl -- none? any? all? )
- vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none
- vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none
+ vector decl test-vector-tests-bool :> ( bool-none bool-any bool-all )
+ vector decl test-vector-tests-branch :> ( branch-none branch-any branch-all )
bool-none branch-none ?inconsistent
bool-any branch-any ?inconsistent
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
[ compile-call ] [ call ] 3bi =
] unit-test
+
+! Spilling SIMD values -- this basically just tests that the
+! stack was aligned properly by the runtime
+
+: simd-spill-test-1 ( a b c -- v )
+ { float-4 float-4 float } declare
+ [ v+ ] dip sin v*n ;
+
+[ float-4{ 0 0 0 0 } ]
+[ float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-1 ] unit-test
+
+: simd-spill-test-2 ( a b d c -- v )
+ { float float-4 float-4 float } declare
+ [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
name>> "math.vectors.simd.instances." prepend ;
: parse-base-type ( c-type -- c-type )
- dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } memq?
+ dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } member-eq?
[ bad-base-type ] unless ;
: forget-instances ( -- )
"x" get [ 2 * ] <arrow> dup "z" set\r
[ 1 + ] <arrow> "y" set\r
[ ] [ "y" get activate-model ] unit-test\r
-[ t ] [ "z" get "x" get connections>> memq? ] unit-test\r
+[ t ] [ "z" get "x" get connections>> member-eq? ] unit-test\r
[ 7 ] [ "y" get value>> ] unit-test\r
[ ] [ 4 "x" get set-model ] unit-test\r
[ 9 ] [ "y" get value>> ] unit-test\r
[ ] [ "y" get deactivate-model ] unit-test\r
-[ f ] [ "z" get "x" get connections>> memq? ] unit-test\r
+[ f ] [ "z" get "x" get connections>> member-eq? ] unit-test\r
\r
3 <model> "x" set\r
"x" get [ sq ] <arrow> "y" set\r
dependencies>> push ;
: remove-dependency ( dep model -- )
- dependencies>> delete ;
+ dependencies>> remove! drop ;
DEFER: add-connection
connections>> push ;
: remove-connection ( observer model -- )
- [ connections>> delete ] keep
+ [ connections>> remove! drop ] keep
dup connections>> empty? [ dup deactivate-model ] when
drop ;
M: an-observer model-changed nip [ 1 + ] change-i drop ;\r
\r
[ 1 0 ] [\r
- [let* | m1 [ 1 <model> ]\r
- m2 [ 2 <model> ]\r
- c [ { m1 m2 } <product> ]\r
- o1 [ an-observer new ]\r
- o2 [ an-observer new ] |\r
+ [let\r
+ 1 <model> :> m1\r
+ 2 <model> :> m2\r
+ { m1 m2 } <product> :> c\r
+ an-observer new :> o1\r
+ an-observer new :> o2\r
\r
o1 m1 add-connection\r
o2 m2 add-connection\r
lexer get skip-blank
rest-of-line
lexer get next-line
- parse-til-line-begins parsed ;
+ parse-til-line-begins suffix! ;
SYNTAX: DELIMITED:
lexer get skip-blank
rest-of-line
lexer get next-line
- 0 (parse-multiline-string) parsed ;
+ 0 (parse-multiline-string) suffix! ;
! (c)2009 Joe Groff bsd license
-USING: accessors kernel namespaces parser tools.continuations
+USING: accessors kernel namespaces parser sequences tools.continuations
ui.backend ui.gadgets.worlds words ;
IN: opengl.debug
<< \ gl-break t "break?" set-word-prop >>
SYNTAX: GB
- \ gl-break parsed ;
+ \ gl-break suffix! ;
--- /dev/null
+USING: tools.test math opengl opengl.gl ;
+IN: opengl.tests
+
+{ 2 1 } [ { GL_TEXTURE_2D } [ + ] all-enabled ] must-infer-as
+
+{ 2 1 } [ { GL_TEXTURE_2D } [ + ] all-enabled-client-state ] must-infer-as
[ ?execute ] map ;
: (all-enabled) ( seq quot -- )
- over [ glEnable ] each dip [ glDisable ] each ; inline
+ [ dup [ glEnable ] each ] dip
+ dip
+ [ glDisable ] each ; inline
: (all-enabled-client-state) ( seq quot -- )
[ dup [ glEnableClientState ] each ] dip
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
- loc first2 :> y :> x
- dim first2 :> h :> w
+ loc first2 :> ( x y )
+ dim first2 :> ( w h )
[
x 0.5 + y 0.5 +
x w + 0.3 - y 0.5 +
rect-vertices (gl-rect) ;
:: (fill-rect-vertices) ( loc dim -- vertices )
- loc first2 :> y :> x
- dim first2 :> h :> w
+ loc first2 :> ( x y )
+ dim first2 :> ( w h )
[
x y
x w + y
] unless ;
:: tex-image ( image bitmap -- )
- image image-format :> type :> format :> internal-format
+ image image-format :> ( internal-format format type )
GL_TEXTURE_2D 0 internal-format
image dim>> adjust-texture-dim first2 0
format type bitmap glTexImage2D ;
packed-length-table at ; inline
: packed-length ( str -- n )
- [ ch>packed-length ] sigma ;
+ [ ch>packed-length ] map-sum ;
: pack-native ( seq str -- seq )
'[ _ _ pack ] with-native-endian ; inline
drop \r
] [ \r
[\r
- "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %\r
- dup length swap [\r
- dup ebnf-var? [\r
+ "FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
+ dup length [\r
+ over ebnf-var? [\r
+ " " % # " over nth :> " %\r
name>> % \r
- " [ " % # " over nth ] " %\r
] [\r
2drop\r
] if\r
] 2each\r
- " | " %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make \r
\r
M: ebnf-var build-locals ( code ast -- )\r
[\r
- "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %\r
- name>> % " [ dup ] " %\r
- " | " %\r
+ "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %\r
+ " dup :> " % name>> %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make ;\r
SYNTAX: <EBNF\r
"EBNF>"\r
reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
- parsed reset-tokenizer ;\r
+ suffix! reset-tokenizer ;\r
\r
SYNTAX: [EBNF\r
"EBNF]"\r
reset-tokenizer parse-multiline-string ebnf>quot nip \r
- parsed \ call parsed reset-tokenizer ;\r
+ suffix! \ call suffix! reset-tokenizer ;\r
\r
SYNTAX: EBNF: \r
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
<PRIVATE
: flatten-vectors ( pair -- vector )
- first2 over push-all ;
+ first2 append! ;
PRIVATE>
l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
- [let* |
- h [ m ans>> head>> ]
- |
+ m ans>> head>> :> h
h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans)
m ans>> failed? [
] if
] [
m ans>> seed>>
- ] if
- ] ; inline
+ ] if ; inline
:: recall ( r p -- memo-entry )
- [let* |
- m [ p r rule-id memo ]
- h [ p heads at ]
- |
+ p r rule-id memo :> m
+ p heads at :> h
h [
m r rule-id h involved-set>> h rule-id>> suffix member? not and [
fail p memo-entry boa
] if
] [
m
- ] if
- ] ; inline
+ ] if ; inline
:: apply-non-memo-rule ( r p -- ast )
- [let* |
- lr [ fail r rule-id f lrstack get left-recursion boa ]
- m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
- ans [ r eval-rule ]
- |
+ fail r rule-id f lrstack get left-recursion boa :> lr
+ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
+ r eval-rule :> ans
lrstack get next>> lrstack set
pos get m (>>pos)
lr head>> [
] [
ans m (>>ans)
ans
- ] if
- ] ; inline
+ ] if ; inline
: apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set
ERROR: parse-failed input word ;
SYNTAX: PEG:
- (:)
- [let | effect [ ] def [ ] word [ ] |
- [
- [
- [let | compiled-def [ def call compile ] |
+ [let
+ (:) :> ( word def effect )
+ [
[
- dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if
- ]
- word swap effect define-declared
- ]
- ] with-compilation-unit
- ] over push-all
- ] ;
+ def call compile :> compiled-def
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap effect define-declared
+ ] with-compilation-unit
+ ] append!
+ ] ;
USING: vocabs vocabs.loader ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: layouts kernel parser math ;
+USING: layouts kernel parser math sequences ;
IN: persistent.hashtables.config
-: radix-bits ( -- n ) << cell 4 = 4 5 ? parsed >> ; foldable
+: radix-bits ( -- n ) << cell 4 = 4 5 ? suffix! >> ; foldable
: radix-mask ( -- n ) radix-bits 2^ 1 - ; foldable
: full-bitmap-mask ( -- n ) radix-bits 2^ 2^ 1 - ; inline
IN: persistent.hashtables.tests
USING: persistent.hashtables persistent.assocs hashtables assocs
-tools.test kernel namespaces random math.ranges sequences fry ;
+tools.test kernel locals namespaces random math.ranges sequences fry ;
[ t ] [ PH{ } assoc-empty? ] unit-test
: random-assocs ( n -- hash phash )
[ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
- [ PH{ } clone swap [ spin new-at ] each-index ]
+ [ PH{ } clone swap [| ph elt i | i elt ph new-at ] each-index ]
bi ;
: ok? ( assoc1 assoc2 -- ? )
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel math accessors assocs fry combinators parser
-prettyprint.custom make
+prettyprint.custom locals make
persistent.assocs
persistent.hashtables.nodes
persistent.hashtables.nodes.empty
M: persistent-hash >alist [ root>> >alist% ] { } make ;
-: >persistent-hash ( assoc -- phash )
- T{ persistent-hash } swap [ spin new-at ] assoc-each ;
+:: >persistent-hash ( assoc -- phash )
+ T{ persistent-hash } assoc [| ph k v | v k ph new-at ] assoc-each ;
M: persistent-hash equal?
over persistent-hash? [ assoc= ] [ 2drop f ] if ;
: index ( bit bitmap -- n ) [ 1 - ] dip bitand bit-count ; inline
M:: bitmap-node (entry-at) ( key hashcode bitmap-node -- entry )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [ f ] [
- key hashcode
- bit bitmap index nodes nth-unsafe
- (entry-at)
- ] if
- ] ;
+ bitmap-node shift>> :> shift
+ hashcode shift bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bitmap-node nodes>> :> nodes
+ bitmap bit bitand 0 eq? [ f ] [
+ key hashcode
+ bit bitmap index nodes nth-unsafe
+ (entry-at)
+ ] if ;
M:: bitmap-node (new-at) ( shift value key hashcode bitmap-node -- node' added-leaf )
- [let* | shift [ bitmap-node shift>> ]
- bit [ hashcode shift bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- idx [ bit bitmap index ]
- nodes [ bitmap-node nodes>> ] |
- bitmap bit bitand 0 eq? [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- bitmap bit bitor
- new-leaf idx nodes insert-nth
- shift
- <bitmap-node>
- new-leaf
- ]
+ bitmap-node shift>> :> shift
+ hashcode shift bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bit bitmap index :> idx
+ bitmap-node nodes>> :> nodes
+
+ bitmap bit bitand 0 eq? [
+ value key hashcode <leaf-node> :> new-leaf
+ bitmap bit bitor
+ new-leaf idx nodes insert-nth
+ shift
+ <bitmap-node>
+ new-leaf
+ ] [
+ idx nodes nth :> n
+ shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
+ n n' eq? [
+ bitmap-node
] [
- [let | n [ idx nodes nth ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- bitmap-node
- ] [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] if
- new-leaf
- ]
- ]
+ bitmap
+ n' idx nodes new-nth
+ shift
+ <bitmap-node>
] if
- ] ;
+ new-leaf
+ ] if ;
M:: bitmap-node (pluck-at) ( key hashcode bitmap-node -- node' )
- [let | bit [ hashcode bitmap-node shift>> bitpos ]
- bitmap [ bitmap-node bitmap>> ]
- nodes [ bitmap-node nodes>> ]
- shift [ bitmap-node shift>> ] |
- bit bitmap bitand 0 eq? [ bitmap-node ] [
- [let* | idx [ bit bitmap index ]
- n [ idx nodes nth-unsafe ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- bitmap-node
- ] [
- n' [
- bitmap
- n' idx nodes new-nth
- shift
- <bitmap-node>
- ] [
- bitmap bit eq? [ f ] [
- bitmap bit bitnot bitand
- idx nodes remove-nth
- shift
- <bitmap-node>
- ] if
- ] if
+ hashcode bitmap-node shift>> bitpos :> bit
+ bitmap-node bitmap>> :> bitmap
+ bitmap-node nodes>> :> nodes
+ bitmap-node shift>> :> shift
+ bit bitmap bitand 0 eq? [ bitmap-node ] [
+ bit bitmap index :> idx
+ idx nodes nth-unsafe :> n
+ key hashcode n (pluck-at) :> n'
+ n n' eq? [
+ bitmap-node
+ ] [
+ n' [
+ bitmap
+ n' idx nodes new-nth
+ shift
+ <bitmap-node>
+ ] [
+ bitmap bit eq? [ f ] [
+ bitmap bit bitnot bitand
+ idx nodes remove-nth
+ shift
+ <bitmap-node>
] if
- ]
+ ] if
] if
- ] ;
+ ] if ;
M: bitmap-node >alist% ( node -- ) nodes>> >alist-each% ;
M:: collision-node (pluck-at) ( key hashcode collision-node -- leaf-node )
hashcode collision-node hashcode>> eq? [
- [let | idx [ key hashcode collision-node find-index drop ] |
- idx [
- idx collision-node leaves>> smash [
- collision-node hashcode>>
- <collision-node>
- ] when
- ] [ collision-node ] if
- ]
+ key hashcode collision-node find-index drop :> idx
+ idx [
+ idx collision-node leaves>> smash [
+ collision-node hashcode>>
+ <collision-node>
+ ] when
+ ] [ collision-node ] if
] [ collision-node ] if ;
M:: collision-node (new-at) ( shift value key hashcode collision-node -- node' added-leaf )
hashcode collision-node hashcode>> eq? [
- key hashcode collision-node find-index
- [let | leaf-node [ ] idx [ ] |
- idx [
- value leaf-node value>> = [
- collision-node f
- ] [
- hashcode
- value key hashcode <leaf-node>
- idx
- collision-node leaves>>
- new-nth
- <collision-node>
- f
- ] if
+ key hashcode collision-node find-index :> ( idx leaf-node )
+ idx [
+ value leaf-node value>> = [
+ collision-node f
] [
- [let | new-leaf-node [ value key hashcode <leaf-node> ] |
- hashcode
- collision-node leaves>>
- new-leaf-node
- suffix
- <collision-node>
- new-leaf-node
- ]
+ hashcode
+ value key hashcode <leaf-node>
+ idx
+ collision-node leaves>>
+ new-nth
+ <collision-node>
+ f
] if
- ]
+ ] [
+ value key hashcode <leaf-node> :> new-leaf-node
+ hashcode
+ collision-node leaves>>
+ new-leaf-node
+ suffix
+ <collision-node>
+ new-leaf-node
+ ] if
] [
shift collision-node value key hashcode make-bitmap-node
] if ;
IN: persistent.hashtables.nodes.full
M:: full-node (new-at) ( shift value key hashcode full-node -- node' added-leaf )
- [let* | nodes [ full-node nodes>> ]
- idx [ hashcode full-node shift>> mask ]
- n [ idx nodes nth-unsafe ] |
- shift radix-bits + value key hashcode n (new-at)
- [let | new-leaf [ ] n' [ ] |
- n n' eq? [
- full-node
- ] [
- n' idx nodes new-nth shift <full-node>
- ] if
- new-leaf
- ]
- ] ;
+ full-node nodes>> :> nodes
+ hashcode full-node shift>> mask :> idx
+ idx nodes nth-unsafe :> n
+
+ shift radix-bits + value key hashcode n (new-at) :> ( n' new-leaf )
+ n n' eq? [
+ full-node
+ ] [
+ n' idx nodes new-nth shift <full-node>
+ ] if
+ new-leaf ;
M:: full-node (pluck-at) ( key hashcode full-node -- node' )
- [let* | idx [ hashcode full-node shift>> mask ]
- n [ idx full-node nodes>> nth ]
- n' [ key hashcode n (pluck-at) ] |
- n n' eq? [
- full-node
+ hashcode full-node shift>> mask :> idx
+ idx full-node nodes>> nth :> n
+ key hashcode n (pluck-at) :> n'
+
+ n n' eq? [
+ full-node
+ ] [
+ n' [
+ n' idx full-node nodes>> new-nth
+ full-node shift>>
+ <full-node>
] [
- n' [
- n' idx full-node nodes>> new-nth
- full-node shift>>
- <full-node>
- ] [
- hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
- idx full-node nodes>> remove-nth
- full-node shift>>
- <bitmap-node>
- ] if
+ hashcode full-node shift>> bitpos bitnot full-bitmap-mask bitand
+ idx full-node nodes>> remove-nth
+ full-node shift>>
+ <bitmap-node>
] if
- ] ;
+ ] if ;
M:: full-node (entry-at) ( key hashcode full-node -- node' )
key hashcode
value leaf-node value>> =
[ leaf-node f ] [ value key hashcode <leaf-node> f ] if
] [
- [let | new-leaf [ value key hashcode <leaf-node> ] |
- hashcode leaf-node new-leaf 2array <collision-node>
- new-leaf
- ]
+ value key hashcode <leaf-node> :> new-leaf
+ hashcode leaf-node new-leaf 2array <collision-node>
+ new-leaf
] if
] [ shift leaf-node value key hashcode make-bitmap-node ] if ;
[ 2array ] [ drop level>> 1 + ] 2bi node boa ;
: new-child ( new-child node -- node' expansion/f )
- dup full? [ tuck level>> 1node ] [ node-add f ] if ;
+ dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ;
: new-last ( val seq -- seq' )
[ length 1 - ] keep new-nth ;
dup level>> 1 = [
new-child
] [
- tuck children>> last (ppush-new-tail)
+ [ nip ] 2keep children>> last (ppush-new-tail)
[ swap new-child ] [ swap node-set-last f ] ?if
] if ;
"~" over class name>> "~" 3append
swap present-text
] [
- over recursion-check get memq? [
+ over recursion-check get member-eq? [
drop "~circularity~" swap present-text
] [
over recursion-check get push
" scan-word \\ * assert="
" scan-word"
" scan-word \\ ] assert="
- " <rect> parsed ;"
+ " <rect> suffix! ;"
}
"An example literal might be:"
{ $code "RECT[ 100 * 200 ]" }
" {"
" { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }"
- " { [ dup pair? ] [ [ delete ] keep ] }"
+ " { [ dup pair? ] [ [ remove! drop ] keep ] }"
" } cond ;"
} ;
] with-row
] each
] tabular-output nl ;
+
+: object-table. ( obj alist -- )
+ [ [ nip first ] [ second call( obj -- str ) ] 2bi 2array ] with map
+ simple-table. ;
{ $values
{ "seq" sequence }
{ "elt" object } }
-{ $description "Deletes a random number from a sequence using " { $link delete-nth } " and returns the deleted object." } ;
+{ $description "Deletes a random number from a sequence using " { $link remove-nth! } " and returns the deleted object." } ;
ARTICLE: "random-protocol" "Random protocol"
"A random number generator must implement one of these two words:"
[ pick '[ _ random-32* 4 >le _ push-all ] times ]
[
over zero?
- [ 2drop ] [ random-32* 4 >le swap head over push-all ] if
+ [ 2drop ] [ random-32* 4 >le swap head append! ] if
] bi-curry bi* ;
M: object random-32* ( tuple -- r ) 4 swap random-bytes* le> ;
'[ _ dup random _ _ next-sample ] replicate ;
: delete-random ( seq -- elt )
- [ length random-integer ] keep [ nth ] 2keep delete-nth ;
+ [ length random-integer ] keep [ nth ] 2keep remove-nth! drop ;
: with-random ( tuple quot -- )
random-generator swap with-variable ; inline
] unless ;
: epsilon-table ( states nfa -- table )
- [ H{ } clone tuck ] dip
+ [ [ H{ } clone ] dip over ] dip
'[ _ _ t epsilon-loop ] each ;
: find-epsilon-closure ( states nfa -- dfa-state )
[ _ meaningful-integers ] keep add-out
] map ;
-: class-partitions ( classes -- assoc )
- [ integer? ] partition [
- dup powerset-partition spin add-integers
- [ [ partition>class ] keep 2array ] map
- [ first ] filter
- ] [ '[ _ singleton-partition ] map ] 2bi append ;
+:: class-partitions ( classes -- assoc )
+ classes [ integer? ] partition :> ( integers classes )
+
+ classes powerset-partition classes integers add-integers
+ [ [ partition>class ] keep 2array ] map [ first ] filter
+ integers [ classes singleton-partition ] map append ;
: new-transitions ( transitions -- assoc ) ! assoc is class, partition
values [ keys ] gather
'[ _ delete-duplicates ] change-transitions ;
: combine-state-transitions ( hash -- hash )
- H{ } clone tuck '[
+ [ H{ } clone ] dip over '[
_ [ 2array <or-class> ] change-at
] assoc-each [ swap ] assoc-map ;
epsilon nfa-table get add-transition ;
M:: star nfa-node ( node -- start end )
- node term>> nfa-node :> s1 :> s0
+ node term>> nfa-node :> ( s0 s1 )
next-state :> s2
next-state :> s3
s1 s0 epsilon-transition
: parsing-regexp ( accum end -- accum )
lexer get [ take-until ] [ parse-noblank-token ] bi
- <optioned-regexp> compile-next-match parsed ;
+ <optioned-regexp> compile-next-match suffix! ;
PRIVATE>
[ 3444 ] [ 3444 >roman roman> ] unit-test
[ 3999 ] [ 3999 >roman roman> ] unit-test
[ 0 >roman ] must-fail
-[ 4000 >roman ] must-fail
+[ 40000 >roman ] must-fail
[ "vi" ] [ "iii" "iii" roman+ ] unit-test
[ "viii" ] [ "x" "ii" roman- ] unit-test
[ "ix" ] [ "iii" "iii" roman* ] unit-test
ERROR: roman-range-error n ;
: roman-range-check ( n -- n )
- dup 1 3999 between? [ roman-range-error ] unless ;
+ dup 1 10000 between? [ roman-range-error ] unless ;
: roman-digit-index ( ch -- n )
1string roman-digits index ; inline
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
- >lower [ roman>= ] monotonic-split [ (roman>) ] sigma ;
+ >lower [ roman>= ] monotonic-split [ (roman>) ] map-sum ;
<PRIVATE
ROMAN-OP: /i
ROMAN-OP: /mod
-SYNTAX: ROMAN: scan roman> parsed ;
+SYNTAX: ROMAN: scan roman> suffix! ;
{ $values { "obj" object } { "seq" "a sequence" } }
{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
-HELP: deep-change-each
-{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } }
-{ $description "Modifies each sub-node of an object in place, in preorder." }
-{ $see-also change-each } ;
+HELP: deep-map!
+{ $values { "obj" object } { "quot" { $quotation "( elt -- newelt )" } } { "obj" object } }
+{ $description "Modifies each sub-node of an object in place, in preorder, and returns that object." }
+{ $see-also map! } ;
ARTICLE: "sequences.deep" "Deep sequence combinators"
"The combinators in the " { $vocab-link "sequences.deep" } " vocabulary are variants of standard sequence combinators which traverse nested subsequences."
deep-filter
deep-find
deep-any?
- deep-change-each
+ deep-map!
}
"A utility word to collapse nested subsequences:"
{ $subsections flatten } ;
[ "hey" 1array 1array [ change-something ] deep-map ] unit-test
[ { { "heyhello" "hihello" } } ]
-[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test
+[ "hey" 1array 1array [ change-something ] deep-map! ] unit-test
[ t ] [ "foo" [ string? ] deep-any? ] unit-test
_ swap dup branch? [ subseq? ] [ 2drop f ] if
] deep-find >boolean ;
-: deep-change-each ( obj quot: ( elt -- elt' ) -- )
+: deep-map! ( obj quot: ( elt -- elt' ) -- obj )
over branch? [
- '[ _ [ call ] keep over [ deep-change-each ] dip ] change-each
- ] [ 2drop ] if ; inline recursive
+ '[ _ [ call ] keep over [ deep-map! drop ] dip ] map!
+ ] [ drop ] if ; inline recursive
: flatten ( obj -- seq )
[ branch? not ] deep-filter ;
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: sequences.merged
+
+ARTICLE: "sequences-merge" "Merging sequences"
+"When multiple sequences are merged into one sequence, the new sequence takes an element from each input sequence in turn. For example, if we merge " { $code "{ 1 2 3 }" } "and" { $code "{ \"a\" \"b\" \"c\" }" } "we get:" { $code "{ 1 \"a\" 2 \"b\" 3 \"c\" }" } "."
+{ $subsections
+ merge
+ 2merge
+ 3merge
+ <merged>
+ <2merged>
+ <3merged>
+} ;
+
+ABOUT: "sequences-merge"
+
+HELP: merged
+{ $class-description "A virtual sequence which presents a merged view of its underlying elements. New instances are created by calling one of " { $link <merged> } ", " { $link <2merged> } ", or " { $link <3merged> } "." }
+{ $see-also merge } ;
+
+HELP: <merged> ( seqs -- merged )
+{ $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence. The length of the created virtual sequences is the minimum length of the input sequences times the number of input sequences." }
+{ $see-also <2merged> <3merged> merge } ;
+
+HELP: <2merged> ( seq1 seq2 -- merged )
+{ $values { "seq1" sequence } { "seq2" sequence } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the two input sequences." }
+{ $see-also <merged> <3merged> 2merge } ;
+
+HELP: <3merged> ( seq1 seq2 seq3 -- merged )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "merged" "a virtual sequence" } }
+{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the three input sequences." }
+{ $see-also <merged> <2merged> 3merge } ;
+
+HELP: merge ( seqs -- seq )
+{ $values { "seqs" "a sequence of sequences to merge" } { "seq" "a new sequence" } }
+{ $description "Outputs a new sequence which merges the elements of each sequence in " { $snippet "seqs" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences.merged ;" "{ { 1 2 } { 3 4 } { 5 6 } } merge ." "{ 1 3 5 2 4 6 }" }
+ { $example "USING: prettyprint sequences.merged ;" "{ \"abc\" \"def\" } merge ." "\"adbecf\"" }
+}
+{ $see-also 2merge 3merge <merged> } ;
+
+HELP: 2merge ( seq1 seq2 -- seq )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq" "a new sequence" } }
+{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of " { $snippet "seq1" } " and " { $snippet "seq2" } }
+{ $see-also merge 3merge <2merged> } ;
+
+HELP: 3merge ( seq1 seq2 seq3 -- seq )
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "seq" "a new sequence" } }
+{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of all three sequences" }
+{ $see-also merge 2merge <3merged> } ;
--- /dev/null
+USING: sequences sequences.merged tools.test ;
+IN: sequences.merged.tests
+
+[ 0 { 1 2 } ] [ 0 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 0 { 3 4 } ] [ 1 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 1 { 1 2 } ] [ 2 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
+[ 4 ] [ 3 { { 1 2 3 4 } } <merged> nth ] unit-test
+[ 4 { { 1 2 3 4 } } <merged> nth ] must-fail
+
+[ 1 ] [ 0 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 4 ] [ 1 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 2 ] [ 2 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 5 ] [ 3 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 3 ] [ 4 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+[ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
+
+[ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test
+
+[ "" ] [ "abcdefg" "" 2merge ] unit-test
+[ "a1b2" ] [ "abc" "12" <2merged> "" like ] unit-test
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math math.order sequences
+sequences.private ;
+IN: sequences.merged
+
+TUPLE: merged seqs ;
+C: <merged> merged
+
+: <2merged> ( seq1 seq2 -- merged ) 2array <merged> ;
+: <3merged> ( seq1 seq2 seq3 -- merged ) 3array <merged> ;
+
+: merge ( seqs -- seq )
+ [ <merged> ] keep first like ;
+
+: 2merge ( seq1 seq2 -- seq )
+ [ <2merged> ] 2keep drop like ;
+
+: 3merge ( seq1 seq2 seq3 -- seq )
+ [ <3merged> ] 3keep 2drop like ;
+
+M: merged length
+ seqs>> [ [ length ] [ min ] map-reduce ] [ length ] bi * ; inline
+
+M: merged virtual@ ( n seq -- n' seq' )
+ seqs>> [ length /mod ] [ nth-unsafe ] bi ; inline
+
+M: merged virtual-exemplar ( merged -- seq )
+ seqs>> [ f ] [ first ] if-empty ; inline
+
+INSTANCE: merged virtual-sequence
--- /dev/null
+A virtual sequence which merges (interleaves) other sequences.
--- /dev/null
+collections
--- /dev/null
+Daniel Ehrenberg
+Doug Coleman
--- /dev/null
+USING: tools.test sequences.parser unicode.categories kernel
+accessors ;
+IN: sequences.parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors circular combinators.short-circuit fry io
+kernel locals math math.order sequences sorting.functor
+sorting.slots unicode.categories ;
+IN: sequences.parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ growing sequence sequence= [
+ found dup length
+ growing length 1 - - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi f like ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ sequence-parser take-rest
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( sequence-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+: take-longest ( sequence-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax quotations sequences ;
+IN: sequences.product
+
+HELP: product-sequence
+{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
+{ $examples
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+""" """{
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}""" } } ;
+
+HELP: <product-sequence>
+{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
+{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
+{ $examples
+{ $example """USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
+"""{
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}""" } } ;
+
+{ product-sequence <product-sequence> } related-words
+
+HELP: product-map
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
+{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
+
+HELP: product-each
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
+{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
+
+{ product-map product-each } related-words
+
+ARTICLE: "sequences.product" "Product sequences"
+"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
+{ $subsections
+ product-sequence
+ <product-sequence>
+ product-map
+ product-each
+} ;
+
+ABOUT: "sequences.product"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel make sequences sequences.product tools.test ;
+IN: sequences.product.tests
+
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
+
+: x ( n s -- sss ) <repetition> concat ;
+
+[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
+[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
+
+[
+ {
+ { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
+ { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
+ }
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
+
+[ "a1b1c1a2b2c2" ] [
+ [
+ { { "a" "b" "c" } { "1" "2" } }
+ [ [ % ] each ] product-each
+ ] "" make
+] unit-test
+
+[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
+[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays kernel locals math sequences ;
+IN: sequences.product
+
+TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
+
+: <product-sequence> ( sequences -- product-sequence )
+ >array dup [ length ] map product-sequence boa ;
+
+INSTANCE: product-sequence sequence
+
+M: product-sequence length lengths>> product ;
+
+<PRIVATE
+
+: ns ( n lengths -- ns )
+ [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+
+: nths ( ns seqs -- nths )
+ [ nth ] { } 2map-as ;
+
+: product@ ( n product-sequence -- ns seqs )
+ [ lengths>> ns ] [ nip sequences>> ] 2bi ;
+
+:: (carry-n) ( ns lengths i -- )
+ ns length i 1 + = [
+ i ns nth i lengths nth = [
+ 0 i ns set-nth
+ i 1 + ns [ 1 + ] change-nth
+ ns lengths i 1 + (carry-n)
+ ] when
+ ] unless ;
+
+: carry-ns ( ns lengths -- )
+ 0 (carry-n) ;
+
+: product-iter ( ns lengths -- )
+ [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
+
+: start-product-iter ( sequences -- ns lengths )
+ [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+
+: end-product-iter? ( ns lengths -- ? )
+ [ 1 tail* first ] bi@ = ;
+
+PRIVATE>
+
+M: product-sequence nth
+ product@ nths ;
+
+:: product-each ( sequences quot -- )
+ sequences start-product-iter :> ( ns lengths )
+ lengths [ 0 = ] any? [
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until
+ ] unless ; inline
+
+:: product-map ( sequences quot -- sequence )
+ 0 :> i!
+ sequences [ length ] [ * ] map-reduce sequences
+ [| result |
+ sequences [ quot call i result set-nth i 1 + i! ] product-each
+ result
+ ] new-like ; inline
+
--- /dev/null
+Cartesian products of sequences
B{ 50 13 55 64 1 }
?{ t f t f f t f }
double-array{ 1.0 3.0 4.0 1.0 2.35 0.33 }
- << 1 [ 2 ] curry parsed >>
+ << 1 [ 2 ] curry suffix! >>
{ { "a" "bc" } { "de" "fg" } }
H{ { "a" "bc" } { "de" "fg" } }
}
:: (deserialize-seq) ( exemplar quot -- seq )
deserialize-cell exemplar new-sequence
[ intern-object ]
- [ dup [ drop quot call ] change-each ] bi ; inline
+ [ [ drop quot call ] map! ] bi ; inline
: deserialize-array ( -- array )
{ } [ (deserialize) ] (deserialize-seq) ;
--- /dev/null
+USING: help.markup help.syntax ;
+IN: shuffle
+
+HELP: spin $complex-shuffle ;
+HELP: roll $complex-shuffle ;
+HELP: -roll $complex-shuffle ;
+HELP: tuck $complex-shuffle ;
USING: shuffle tools.test ;
+IN: shuffle.tests
[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
+
+[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
+[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
+
] [ ] make ;
SYNTAX: shuffle(
- ")" parse-effect parsed \ shuffle-effect parsed ;
+ ")" parse-effect suffix! \ shuffle-effect suffix! ;
+
+: tuck ( x y -- y x y ) swap over ; inline deprecated
+
+: spin ( x y z -- z y x ) swap rot ; inline deprecated
+
+: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline deprecated
+
+: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline deprecated
: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
[ ushort-array{ 0 0 0 } ] [
3 ALIEN: 123 100 <direct-ushort-array> new-sequence
- dup [ drop 0 ] change-each
+ [ drop 0 ] map!
] unit-test
STRUCT: test-struct
M: A >pprint-sequence ;
SYNTAX: A{ \ } [ >A ] parse-literal ;
-SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
+SYNTAX: A@ scan-object scan-object <direct-A> suffix! ;
INSTANCE: A specialized-array
USING: stack-checker.backend tools.test kernel namespaces
-stack-checker.state sequences ;
+stack-checker.state stack-checker.values sequences assocs ;
IN: stack-checker.backend.tests
[ ] [
V{ } clone \ meta-d set
V{ } clone \ meta-r set
V{ } clone \ literals set
- 0 d-in set
+ H{ } clone known-values set
+ 0 input-count set
] unit-test
[ 0 ] [ 0 ensure-d length ] unit-test
[ 2 ] [ 2 ensure-d length ] unit-test
+
+[ t ] [ meta-d [ known-values get at input-parameter? ] all? ] unit-test
+
[ 2 ] [ meta-d length ] unit-test
[ 3 ] [ 3 ensure-d length ] unit-test
continuations assocs combinators compiler.errors accessors math.order
definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state summary ;
+stack-checker.recursive-state stack-checker.dependencies summary ;
IN: stack-checker.backend
: push-d ( obj -- ) meta-d push ;
+: introduce-values ( values -- )
+ [ [ [ input-parameter ] dip set-known ] each ]
+ [ length input-count +@ ]
+ [ #introduce, ]
+ tri ;
+
: pop-d ( -- obj )
- meta-d [
- <value> dup 1array #introduce, d-in inc
- ] [ pop ] if-empty ;
+ meta-d [ <value> dup 1array introduce-values ] [ pop ] if-empty ;
: peek-d ( -- obj ) pop-d dup push-d ;
meta-d 2dup length > [
2dup
[ nip >array ] [ length - make-values ] [ nip delete-all ] 2tri
- [ length d-in +@ ] [ #introduce, ] [ meta-d push-all ] tri
+ [ introduce-values ] [ meta-d push-all ] bi
meta-d push-all
] when swap tail* ;
SYMBOLS: +bottom+ +top+ ;
-: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
+: unify-inputs ( max-input-count input-count meta-d -- new-meta-d )
! Introduced values can be anything, and don't unify with
! literals.
dup [ [ - +top+ <repetition> ] dip append ] [ 3drop f ] if ;
'[ _ +bottom+ pad-head ] map
] unless ;
-: phi-inputs ( max-d-in pairs -- newseq )
+: phi-inputs ( max-input-count pairs -- newseq )
dup empty? [ nip ] [
swap '[ [ _ ] dip first2 unify-inputs ] map
pad-with-bottom
branch-variable ;
: datastack-phi ( seq -- phi-in phi-out )
- [ d-in branch-variable ] [ \ meta-d active-variable ] bi
+ [ input-count branch-variable ] [ \ meta-d active-variable ] bi
unify-branches
- [ d-in set ] [ ] [ dup >vector \ meta-d set ] tri* ;
+ [ input-count set ] [ ] [ dup >vector \ meta-d set ] tri* ;
: terminated-phi ( seq -- terminated )
terminated? branch-variable ;
: copy-inference ( -- )
\ meta-d [ clone ] change
literals [ clone ] change
- d-in [ ] change ;
+ input-count [ ] change ;
GENERIC: infer-branch ( literal -- namespace )
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: stack-checker.dependencies.tests
+USING: tools.test stack-checker.dependencies words kernel namespaces
+definitions ;
+
+: computing-dependencies ( quot -- dependencies )
+ H{ } clone [ dependencies rot with-variable ] keep ;
+ inline
+
+SYMBOL: a
+SYMBOL: b
+
+[ ] [ a called-dependency depends-on ] unit-test
+
+[ H{ { a called-dependency } } ] [
+ [ a called-dependency depends-on ] computing-dependencies
+] unit-test
+
+[ H{ { a called-dependency } { b inlined-dependency } } ] [
+ [
+ a called-dependency depends-on b inlined-dependency depends-on
+ ] computing-dependencies
+] unit-test
+
+[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
+ [
+ a inlined-dependency depends-on
+ a called-dependency depends-on
+ b inlined-dependency depends-on
+ ] computing-dependencies
+] unit-test
+
+[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
+[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
+[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
+[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
+[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
+[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.algebra fry kernel math namespaces
+sequences words ;
+IN: stack-checker.dependencies
+
+! Words that the current quotation depends on
+SYMBOL: dependencies
+
+SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
+
+: index>= ( obj1 obj2 seq -- ? )
+ [ index ] curry bi@ >= ;
+
+: dependency>= ( how1 how2 -- ? )
+ { called-dependency flushed-dependency inlined-dependency }
+ index>= ;
+
+: strongest-dependency ( how1 how2 -- how )
+ [ called-dependency or ] bi@ [ dependency>= ] most ;
+
+: depends-on ( word how -- )
+ over primitive? [ 2drop ] [
+ dependencies get dup [
+ swap '[ _ strongest-dependency ] change-at
+ ] [ 3drop ] if
+ ] if ;
+
+! Generic words that the current quotation depends on
+SYMBOL: generic-dependencies
+
+: ?class-or ( class/f class -- class' )
+ swap [ class-or ] when* ;
+
+: depends-on-generic ( generic class -- )
+ generic-dependencies get dup
+ [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
}
} ;
-HELP: literal-expected
-{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
+HELP: unknown-macro-input
+{ $error-description "Thrown when inference encounters a combinator or macro being applied to an input parameter of a non-" { $link POSTPONE: inline } " word. The word needs to be declared " { $link POSTPONE: inline } " before its callers can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
{ $examples
- "In this example, the words being defined cannot be called, because they fail to compile with a " { $link literal-expected } " error:"
+ "In this example, the words being defined cannot be called, because they fail to compile with a " { $link unknown-macro-input } " error:"
{ $code
": bad-example ( quot -- )"
" [ call ] [ call ] bi ;"
}
} ;
+HELP: bad-macro-input
+{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known at compile time. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
+{ $examples
+ "In this example, the words being defined cannot be called, because they fail to compile with a " { $link bad-macro-input } " error:"
+ { $code
+ ": bad-example ( quot -- )"
+ " [ . ] append call ; inline"
+ ""
+ ": usage ( -- )"
+ " 2 2 [ + ] bad-example ;"
+ }
+ "One fix is to use " { $link compose } " instead of " { $link append } ":"
+ { $code
+ ": good-example ( quot -- )"
+ " [ . ] compose call ; inline"
+ ""
+ ": usage ( -- )"
+ " 2 2 [ + ] good-example ;"
+ }
+} ;
+
HELP: unbalanced-branches-error
{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
{ $description "Throws an " { $link unbalanced-branches-error } "." }
"Errors thrown when insufficient information is available to calculate the stack effect of a call to a combinator or macro (see " { $link "inference-combinators" } "):"
{ $subsections
do-not-compile
- literal-expected
+ unknown-macro-input
+ bad-macro-input
}
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
{ $subsections effect-error }
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel stack-checker.values ;
IN: stack-checker.errors
TUPLE: inference-error ;
ERROR: do-not-compile < inference-error word ;
-ERROR: literal-expected < inference-error what ;
+ERROR: bad-macro-input < inference-error macro ;
+
+ERROR: unknown-macro-input < inference-error macro ;
ERROR: unbalanced-branches-error < inference-error branches quots ;
ERROR: unknown-primitive-error < inference-error ;
-ERROR: transform-expansion-error < inference-error word error ;
-
-ERROR: bad-declaration-error < inference-error declaration ;
+ERROR: transform-expansion-error < inference-error error continuation word ;
-M: object (literal) "literal value" literal-expected ;
\ No newline at end of file
+ERROR: bad-declaration-error < inference-error declaration ;
\ No newline at end of file
sequences assocs stack-checker.errors summary effects ;
IN: stack-checker.errors.prettyprint
-M: literal-expected summary
- what>> "Got a computed value where a " " was expected" surround ;
+M: unknown-macro-input summary
+ macro>> name>> "Cannot apply “" "” to an input parameter of a non-inline word" surround ;
-M: literal-expected error. summary print ;
+M: bad-macro-input summary
+ macro>> name>> "Cannot apply “" "” to a run-time computed value" surround ;
M: unbalanced-branches-error summary
drop "Unbalanced branches" ;
word>> name>> "Macro expansion of " " threw an error" surround ;
M: transform-expansion-error error.
- [ summary print ] [ error>> error. ] bi ;
+ [ summary print ]
+ [ nl "The error was:" print error>> error. nl ]
+ [ continuation>> traceback-link. ]
+ tri ;
M: do-not-compile summary
word>> name>> "Cannot compile call to " prepend ;
\ No newline at end of file
stack-checker.backend
stack-checker.branches
stack-checker.known-words
+stack-checker.dependencies
stack-checker.recursive-state ;
IN: stack-checker.inlining
bi ;
: recursive-word-inputs ( label -- n )
- entry-stack-height d-in get + ;
+ entry-stack-height input-count get + ;
: (inline-recursive-word) ( word -- label in out visitor terminated? )
dup prepare-stack
system.private combinators combinators.short-circuit locals
locals.backend locals.types combinators.private
stack-checker.values generic.single generic.single.private
-alien.libraries
+alien.libraries tools.dispatch.private tools.profiler.private
stack-checker.alien
stack-checker.state
stack-checker.errors
stack-checker.backend
stack-checker.branches
stack-checker.transforms
+stack-checker.dependencies
stack-checker.recursive-state ;
IN: stack-checker.known-words
{ swapd (( x y z -- y x z )) }
{ nip (( x y -- y )) }
{ 2nip (( x y z -- z )) }
- { tuck (( x y -- y x y )) }
{ over (( x y -- x y x )) }
{ pick (( x y z -- x y z x )) }
{ swap (( x y -- y x )) }
1 infer->r infer-call
terminated? get [ 1 infer-r> infer-call ] unless ;
-M: object infer-call*
- "literal quotation" literal-expected ;
+M: input-parameter infer-call* \ call unknown-macro-input ;
+M: object infer-call* \ call bad-macro-input ;
: infer-ndip ( word n -- )
[ literals get ] 2dip
\ load-local [ infer-load-local ] "special" set-word-prop
-: infer-get-local ( -- )
- [let* | n [ pop-literal nip 1 swap - ]
- in-r [ n consume-r ]
- out-d [ in-r first copy-value 1array ]
- out-r [ in-r copy-values ] |
- out-d output-d
- out-r output-r
- f out-d in-r out-r
- out-r in-r zip out-d first in-r first 2array suffix
- #shuffle,
- ] ;
+:: infer-get-local ( -- )
+ pop-literal nip 1 swap - :> n
+ n consume-r :> in-r
+ in-r first copy-value 1array :> out-d
+ in-r copy-values :> out-r
+
+ out-d output-d
+ out-r output-r
+ f out-d in-r out-r
+ out-r in-r zip out-d first in-r first 2array suffix
+ #shuffle, ;
\ get-local [ infer-get-local ] "special" set-word-prop
\ alien-callback [ infer-alien-callback ] "special" set-word-prop
: infer-special ( word -- )
- "special" word-prop call( -- ) ;
+ [ current-word set ] [ "special" word-prop call( -- ) ] bi ;
: infer-local-reader ( word -- )
(( -- value )) apply-word/effect ;
\ compact-gc { } { } define-primitive
-\ gc-stats { } { array } define-primitive
-
\ (save-image) { byte-array } { } define-primitive
\ (save-image-and-exit) { byte-array } { } define-primitive
-\ data-room { } { integer integer array } define-primitive
+\ data-room { } { byte-array } define-primitive
\ data-room make-flushable
-\ code-room { } { integer integer integer integer } define-primitive
+\ code-room { } { byte-array } define-primitive
\ code-room make-flushable
\ micros { } { integer } define-primitive
\ set-alien-double { float c-ptr integer } { } define-primitive
-\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
+\ alien-cell { c-ptr integer } { pinned-c-ptr } define-primitive
\ alien-cell make-flushable
\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
\ <array> { integer object } { array } define-primitive
\ <array> make-flushable
-\ begin-scan { } { } define-primitive
-
-\ next-object { } { object } define-primitive
-
-\ end-scan { } { } define-primitive
+\ all-instances { } { array } define-primitive
\ size { object } { fixnum } define-primitive
\ size make-flushable
\ unimplemented { } { } define-primitive
-\ gc-reset { } { } define-primitive
-
-\ gc-stats { } { array } define-primitive
-
\ jit-compile { quotation } { } define-primitive
\ lookup-method { object array } { word } define-primitive
\ reset-dispatch-stats { } { } define-primitive
-\ dispatch-stats { } { array } define-primitive
-\ reset-inline-cache-stats { } { } define-primitive
-\ inline-cache-stats { } { array } define-primitive
+\ dispatch-stats { } { byte-array } define-primitive
\ optimized? { word } { object } define-primitive
\ strip-stack-traces { } { } define-primitive
\ <callback> { word } { alien } define-primitive
+
+\ enable-gc-events { } { } define-primitive
+\ disable-gc-events { } { object } define-primitive
+
+\ profiling { object } { } define-primitive
{ $example "[ 2 + ] infer." "( object -- object )" } ;
ARTICLE: "inference-combinators" "Combinator stack effects"
-"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:"
+"If a word calls a combinator, one of the following two conditions must hold for the stack checker to succeed:"
{ $list
- { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." }
- { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." }
+ { "The combinator must be called with a quotation that is either literal or built from literal quotations, " { $link curry } ", and " { $link compose } ". (Note that quotations that use " { $vocab-link "fry" } " or " { $vocab-link "locals" } " use " { $link curry } " and " { $link compose } " from the perspective of the stack checker.)" }
+ { "If the word is declared " { $link POSTPONE: inline } ", the combinator may additionally be called on one of the word's input parameters or with quotations built from the word's input parameters, literal quotations, " { $link curry } ", and " { $link compose } ". When inline, a word is itself considered to be a combinator, and its callers must in turn satisfy these conditions." }
}
-"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
+"If neither condition holds, the stack checker throws a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error. To make the code compile, a runtime checking combinator such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by " { $link curry } "ing the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
{ $heading "Examples" }
{ $subheading "Calling a combinator" }
"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
-{ $example "[ [ + ] curry map ] infer." "( object object -- object )" }
+{ $example "USING: math sequences ;" "[ [ + ] curry map ] infer." "( object object -- object )" }
+"The equivalent code using " { $vocab-link "fry" } " and " { $vocab-link "locals" } " likewise passes the stack checker:"
+{ $example "USING: fry math sequences ;" "[ '[ _ + ] map ] infer." "( object object -- object )" }
+{ $example "USING: locals math sequences ;" "[| a | [ a + ] map ] infer." "( object object -- object )" }
{ $subheading "Defining an inline combinator" }
"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:"
{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" }
{ $heading "Explanation" }
-"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
+"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link unknown-macro-input } " or " { $link bad-macro-input } " error is raised."
$nl
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point."
{ $heading "Limitations" }
-"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
+"The stack checker cannot guarantee that a literal quotation is still literal if it is passed on the data stack to an inlined recursive combinator such as " { $link each } " or " { $link map } ". For example, the following will not infer:"
{ $example
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected"
}
-"To make this work, pass the quotation on the retain stack instead:"
+"To make this work, use " { $link dip } " to pass the quotation instead:"
{ $example
"[ [ reverse ] [ [ reverse ] map ] dip call ] infer." "( object -- object )"
} ;
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval locals.backend
-system compiler.units ;
+system compiler.units shuffle ;
IN: stack-checker.tests
[ 1234 infer ] must-fail
{ 1 2 } [ dup ] must-infer-as
{ 1 2 } [ [ dup ] call ] must-infer-as
-[ [ call ] infer ] must-fail
+[ [ call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+[ [ curry call ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+[ [ { } >quotation call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with
+[ [ append curry call ] infer ] [ T{ bad-macro-input f call } = ] must-fail-with
{ 2 4 } [ 2dup ] must-infer-as
{ 1 0 } [ [ ] [ ] if ] must-infer-as
-[ [ if ] infer ] must-fail
-[ [ [ ] if ] infer ] must-fail
-[ [ [ 2 ] [ ] if ] infer ] must-fail
+[ [ if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with
+[ [ { } >quotation { } >quotation if ] infer ] [ T{ bad-macro-input f if } = ] must-fail-with
+[ [ [ ] if ] infer ] [ T{ unknown-macro-input f if } = ] must-fail-with
+[ [ [ 2 ] [ ] if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as
{ 4 3 } [
[
[ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer
-] must-fail
+] [ T{ bad-macro-input f call } = ] must-fail-with
! Test inference of termination of control flow
: termination-test-1 ( -- * ) "foo" throw ;
! This used to hang
[ [ [ dup call ] dup call ] infer ]
-[ inference-error? ] must-fail-with
+[ recursive-quotation-error? ] must-fail-with
: m ( q -- ) dup call ; inline
-[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with
+[ [ [ m ] m ] infer ] [ recursive-quotation-error? ] must-fail-with
: m' ( quot -- ) dup curry call ; inline
-[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with
+[ [ [ m' ] m' ] infer ] [ recursive-quotation-error? ] must-fail-with
: m'' ( -- q ) [ dup curry ] ; inline
: m''' ( -- ) m'' call call ; inline
-[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with
+[ [ [ m''' ] m''' ] infer ] [ recursive-quotation-error? ] must-fail-with
-: m-if ( a b c -- ) t over if ; inline
+: m-if ( a b c -- ) t over when ; inline
-[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with
+[ [ [ m-if ] m-if ] infer ] [ recursive-quotation-error? ] must-fail-with
! This doesn't hang but it's also an example of the
! undedicable case
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
-[ inference-error? ] must-fail-with
+[ recursive-quotation-error? ] must-fail-with
-[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
+[ [ 1 drop-locals ] infer ] [ too-many-r>? ] must-fail-with
! Regression
-[ [ cleave ] infer ] [ inference-error? ] must-fail-with
+[ [ cleave ] infer ] [ T{ unknown-macro-input f cleave } = ] must-fail-with
! Test some curry stuff
{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as
{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as
-[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
+[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] [ unbalanced-branches-error? ] must-fail-with
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
] unit-test
! Regression
-[ [ 1 load-locals ] infer ] must-fail
+[ [ 1 load-locals ] infer ] [ too-many->r? ] must-fail-with
! Corner case
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
[ [ bad-recursion-3 ] infer ] must-fail
FORGET: bad-recursion-3
-: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
+: bad-recursion-4 ( -- ) 4 [ dup call [ rot ] dip swap ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
: bad-recursion-5 ( obj quot: ( -- ) -- ) dup call swap bad-recursion-5 ; inline recursive
dup bad-recursion-6 call ; inline recursive
[ [ [ drop f ] bad-recursion-6 ] infer ] must-fail
+[ ] [ [ \ bad-recursion-6 forget ] with-compilation-unit ] unit-test
+
{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
[ [ eee' ] infer ] [ inference-error? ] must-fail-with
+[ ] [ [ \ ddd' forget ] with-compilation-unit ] unit-test
+[ ] [ [ \ eee' forget ] with-compilation-unit ] unit-test
+
: bogus-error ( x -- )
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
[ forget-test ] must-infer
-[ [ cond ] infer ] must-fail
-[ [ bi ] infer ] must-fail
-[ at ] must-infer
+[ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
+[ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
{ 3 1 } [ call( a b -- c ) ] must-infer-as
{ 3 1 } [ execute( a b -- c ) ] must-infer-as
-[ [ call-effect ] infer ] must-fail
-[ [ execute-effect ] infer ] must-fail
+[ [ call-effect ] infer ] [ T{ unknown-macro-input f call-effect } = ] must-fail-with
+[ [ execute-effect ] infer ] [ T{ unknown-macro-input f execute-effect } = ] must-fail-with
+++ /dev/null
-IN: stack-checker.state.tests
-USING: tools.test stack-checker.state words kernel namespaces
-definitions ;
-
-: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep ;
- inline
-
-SYMBOL: a
-SYMBOL: b
-
-[ ] [ a called-dependency depends-on ] unit-test
-
-[ H{ { a called-dependency } } ] [
- [ a called-dependency depends-on ] computing-dependencies
-] unit-test
-
-[ H{ { a called-dependency } { b inlined-dependency } } ] [
- [
- a called-dependency depends-on b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
-
-[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
- [
- a inlined-dependency depends-on
- a called-dependency depends-on
- b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: assocs arrays namespaces sequences kernel definitions
math effects accessors words fry classes.algebra
-compiler.units stack-checker.values stack-checker.visitor ;
+compiler.units stack-checker.values stack-checker.visitor
+stack-checker.errors ;
IN: stack-checker.state
! Did the current control-flow path throw an error?
SYMBOL: terminated?
! Number of inputs current word expects from the stack
-SYMBOL: d-in
+SYMBOL: input-count
DEFER: commit-literals
[ [ (push-literal) ] each ] [ delete-all ] bi
] unless-empty ;
-: current-stack-height ( -- n ) meta-d length d-in get - ;
+: current-stack-height ( -- n ) meta-d length input-count get - ;
: current-effect ( -- effect )
- d-in get meta-d length terminated? get effect boa ;
+ input-count get meta-d length terminated? get effect boa ;
: init-inference ( -- )
terminated? off
V{ } clone \ meta-d set
V{ } clone literals set
- 0 d-in set ;
-
-! Words that the current quotation depends on
-SYMBOL: dependencies
-
-: depends-on ( word how -- )
- over primitive? [ 2drop ] [
- dependencies get dup [
- swap '[ _ strongest-dependency ] change-at
- ] [ 3drop ] if
- ] if ;
-
-! Generic words that the current quotation depends on
-SYMBOL: generic-dependencies
-
-: ?class-or ( class/f class -- class' )
- swap [ class-or ] when* ;
-
-: depends-on-generic ( generic class -- )
- generic-dependencies get dup
- [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
+ 0 input-count set ;
IN: stack-checker.transforms.tests
USING: sequences stack-checker.transforms tools.test math kernel
-quotations stack-checker stack-checker.errors accessors combinators words arrays
-classes classes.tuple ;
+quotations stack-checker stack-checker.errors accessors
+combinators words arrays classes classes.tuple macros ;
-: compose-n ( quot n -- ) "OOPS" throw ;
-
-<<
-: compose-n-quot ( n word -- quot' ) <repetition> >quotation ;
-\ compose-n [ compose-n-quot ] 2 define-transform
-\ compose-n t "no-compile" set-word-prop
->>
+MACRO: compose-n ( n word -- quot' ) <repetition> >quotation ;
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer
! Caveat found by Doug
-DEFER: curry-folding-test ( quot -- )
-
-\ curry-folding-test [ length \ drop <repetition> >quotation ] 1 define-transform
+MACRO: curry-folding-test ( quot -- )
+ length \ drop <repetition> >quotation ;
{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as
{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as
{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as
+[ [ curry curry-folding-test ] infer ]
+[ T{ unknown-macro-input f curry-folding-test } = ] must-fail-with
+
: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
[ f ] [ 1.0 member?-test ] unit-test
\ bad-macro [ "OOPS" throw ] 0 define-transform
-[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with
\ No newline at end of file
+[ [ bad-macro ] infer ] [ f >>continuation T{ transform-expansion-error f "OOPS" f bad-macro } = ] must-fail-with
+
+MACRO: two-params ( a b -- c ) + 1quotation ;
+
+[ [ 3 two-params ] infer ] [ T{ unknown-macro-input f two-params } = ] must-fail-with
\ No newline at end of file
definitions generic.standard slots.private continuations locals
sequences.private generalizations stack-checker.backend
stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.values stack-checker.recursive-state ;
+stack-checker.values stack-checker.recursive-state
+stack-checker.dependencies ;
IN: stack-checker.transforms
-: call-transformer ( word stack quot -- newquot )
- '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
- [ transform-expansion-error ]
+: call-transformer ( stack quot -- newquot )
+ '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi ]
+ [ error-continuation get current-word get transform-expansion-error ]
recover ;
-:: ((apply-transform)) ( word quot values stack rstate -- )
- rstate recursive-state
- [ word stack quot call-transformer ] with-variable
- [
- values [ length meta-d shorten-by ] [ #drop, ] bi
- rstate infer-quot
- ] [ word infer-word ] if* ;
-
-: literals? ( values -- ? ) [ literal-value? ] all? ;
-
-: (apply-transform) ( word quot n -- )
- ensure-d dup literals? [
- dup empty? [ dup recursive-state get ] [
- [ ]
- [ [ literal value>> ] map ]
- [ first literal recursion>> ] tri
- ] if
- ((apply-transform))
- ] [ 2drop infer-word ] if ;
+:: ((apply-transform)) ( quot values stack rstate -- )
+ rstate recursive-state [ stack quot call-transformer ] with-variable
+ values [ length meta-d shorten-by ] [ #drop, ] bi
+ rstate infer-quot ;
+
+: literal-values? ( values -- ? ) [ literal-value? ] all? ;
+
+: input-values? ( values -- ? )
+ [ { [ literal-value? ] [ input-value? ] } 1|| ] all? ;
+
+: (apply-transform) ( quot n -- )
+ ensure-d {
+ { [ dup literal-values? ] [
+ dup empty? [ dup recursive-state get ] [
+ [ ]
+ [ [ literal value>> ] map ]
+ [ first literal recursion>> ] tri
+ ] if
+ ((apply-transform))
+ ] }
+ { [ dup input-values? ] [ drop current-word get unknown-macro-input ] }
+ [ drop current-word get bad-macro-input ]
+ } cond ;
: apply-transform ( word -- )
- [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
+ [ current-word set ]
+ [ "transform-quot" word-prop ]
+ [ "transform-n" word-prop ] tri
(apply-transform) ;
: apply-macro ( word -- )
- [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
+ [ current-word set ]
+ [ "macro" word-prop ]
+ [ "declared-effect" word-prop in>> length ] tri
(apply-transform) ;
: define-transform ( word quot n -- )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel assocs sequences
-stack-checker.recursive-state ;
+stack-checker.recursive-state stack-checker.errors ;
IN: stack-checker.values
! Values
GENERIC: (literal-value?) ( value -- ? )
-M: object (literal-value?) drop f ;
+: literal-value? ( value -- ? ) known (literal-value?) ;
+
+GENERIC: (input-value?) ( value -- ? )
+
+: input-value? ( value -- ? ) known (input-value?) ;
-GENERIC: (literal) ( value -- literal )
+GENERIC: (literal) ( known -- literal )
! Literal value
TUPLE: literal < identity-tuple value recursion hashcode ;
: literal ( value -- literal ) known (literal) ;
-: literal-value? ( value -- ? ) known (literal-value?) ;
-
M: literal hashcode* nip hashcode>> ;
: <literal> ( obj -- value )
recursive-state get over hashcode \ literal boa ;
+M: literal (input-value?) drop f ;
+
M: literal (literal-value?) drop t ;
M: literal (literal) ;
: >curried< ( curried -- obj quot )
[ obj>> ] [ quot>> ] bi ; inline
+M: curried (input-value?) >curried< [ input-value? ] either? ;
+
M: curried (literal-value?) >curried< [ literal-value? ] both? ;
+
M: curried (literal) >curried< [ curry ] curried/composed-literal ;
! Result of compose
: >composed< ( composed -- quot1 quot2 )
[ quot1>> ] [ quot2>> ] bi ; inline
+M: composed (input-value?)
+ [ quot1>> input-value? ] [ quot2>> input-value? ] bi or ;
+
M: composed (literal-value?) >composed< [ literal-value? ] both? ;
-M: composed (literal) >composed< [ compose ] curried/composed-literal ;
\ No newline at end of file
+
+M: composed (literal) >composed< [ compose ] curried/composed-literal ;
+
+! Input parameters
+SINGLETON: input-parameter
+
+SYMBOL: current-word
+
+M: input-parameter (input-value?) drop t ;
+
+M: input-parameter (literal-value?) drop f ;
+
+M: input-parameter (literal) current-word get unknown-macro-input ;
+
+! Computed values
+M: f (input-value?) drop f ;
+
+M: f (literal-value?) drop f ;
+
+M: f (literal) current-word get bad-macro-input ;
\ No newline at end of file
: <funky-slice> ( from/f to/f seq -- slice )
[
- tuck
- [ drop 0 or ] [ length or ] 2bi*
+ [ drop 0 or ] [ length or ] bi-curry bi*
[ min ] keep
] keep <slice> ; inline
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
:: spawn-namespace-test ( -- ? )
- [let | p [ <promise> ] g [ gensym ] |
- [
- g "x" set
- [ "x" get p fulfill ] "B" spawn drop
- ] with-scope
- p ?promise g eq?
- ] ;
+ <promise> :> p gensym :> g
+ [
+ g "x" set
+ [ "x" get p fulfill ] "B" spawn drop
+ ] with-scope
+ p ?promise g eq? ;
[ t ] [ spawn-namespace-test ] unit-test
[ quot-uses ] curry each ;
: seq-uses ( seq assoc -- )
- over visited get memq? [ 2drop ] [
+ over visited get member-eq? [ 2drop ] [
over visited get push
(seq-uses)
] if ;
: assoc-uses ( assoc' assoc -- )
- over visited get memq? [ 2drop ] [
+ over visited get member-eq? [ 2drop ] [
over visited get push
[ >alist ] dip (seq-uses)
] if ;
[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
-PRIVATE>
\ No newline at end of file
+PRIVATE>
generic.single tools.deploy.config combinators classes
classes.builtin slots.private grouping command-line ;
QUALIFIED: bootstrap.stage2
+QUALIFIED: compiler.crossref
QUALIFIED: compiler.errors
QUALIFIED: continuations
QUALIFIED: definitions
! otherwise do nothing
[ 2drop ]
} cond
- ] change-each ;
+ ] map! drop ;
: strip-default-method ( generic new-default -- )
[
implementors-map
update-map
main-vocab-hook
- compiled-crossref
- compiled-generic-crossref
+ compiler.crossref:compiled-crossref
+ compiler.crossref:compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
lexer-factory
next-method ;
: calls-next-method? ( method -- ? )
- def>> flatten \ (call-next-method) swap memq? ;
+ def>> flatten \ (call-next-method) swap member-eq? ;
: compute-next-methods ( -- )
[ standard-generic? ] instances [
{ $description "Prints all deprecation notes." } ;
ARTICLE: "tools.deprecation" "Deprecation tracking"
-"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words."
+"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. Notes are collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words."
{ $subsections
POSTPONE: deprecated
:deprecations
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: tools.dispatch
+USING: help.markup help.syntax vm quotations ;
+
+HELP: last-dispatch-stats
+{ $var-description "A " { $link dispatch-statistics } " instance, set by " { $link collect-dispatch-stats } "." } ;
+
+HELP: dispatch-stats.
+{ $description "Prints method dispatch statistics from the last call to " { $link collect-dispatch-stats } "." } ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces prettyprint classes.struct
+vm tools.dispatch.private ;
+IN: tools.dispatch
+
+SYMBOL: last-dispatch-stats
+
+: dispatch-stats. ( -- )
+ last-dispatch-stats get {
+ { "Megamorphic hits" [ megamorphic-cache-hits>> ] }
+ { "Megamorphic misses" [ megamorphic-cache-misses>> ] }
+ { "Cold to monomorphic" [ cold-call-to-ic-transitions>> ] }
+ { "Mono to polymorphic" [ ic-to-pic-transitions>> ] }
+ { "Poly to megamorphic" [ pic-to-mega-transitions>> ] }
+ { "Tag check count" [ pic-tag-count>> ] }
+ { "Tuple check count" [ pic-tuple-count>> ] }
+ } object-table. ;
+
+: collect-dispatch-stats ( quot -- )
+ reset-dispatch-stats
+ call
+ dispatch-stats dispatch-statistics memory>struct
+ last-dispatch-stats set ; inline
-USING: help.markup help.syntax memory sequences ;
+USING: help.markup help.syntax memory sequences vm ;
IN: tools.memory
ARTICLE: "tools.memory" "Object memory tools"
data-room
code-room
}
-"There are a pair of combinators, analogous to " { $link each } " and " { $link filter } ", which operate on the entire collection of objects in the object heap:"
-{ $subsections
- each-object
- instances
-}
+"A combinator to get objects from the heap:"
+{ $subsections instances }
"You can check an object's the heap memory usage:"
{ $subsections size }
"The garbage collector can be invoked manually:"
{ $description "For each class, prints the number of instances and total memory consumed by those instances." } ;
{ heap-stats heap-stats. } related-words
+
+HELP: gc-events.
+{ $description "Prints all garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-stats.
+{ $description "Prints a breakdown of different garbage collection events that took place during the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-summary.
+{ $description "Prints aggregate garbage collection statistics from the last call to " { $link collect-gc-events } "." } ;
+
+HELP: gc-events
+{ $var-description "A sequence of " { $link gc-event } " instances, set by " { $link collect-gc-events } ". Can be inspected directly, or with the " { $link gc-events. } ", " { $link gc-stats. } " and " { $link gc-summary. } " words." } ;
-USING: tools.test tools.memory ;
+USING: tools.test tools.memory memory ;
IN: tools.memory.tests
[ ] [ room. ] unit-test
[ ] [ heap-stats. ] unit-test
+[ ] [ [ gc gc ] collect-gc-events ] unit-test
+[ ] [ gc-events. ] unit-test
+[ ] [ gc-stats. ] unit-test
+[ ] [ gc-summary. ] unit-test
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays generic assocs io math
-namespaces parser prettyprint strings io.styles words
-system sorting splitting grouping math.parser classes memory
-combinators fry ;
+USING: accessors arrays assocs classes classes.struct
+combinators combinators.smart continuations fry generalizations
+generic grouping io io.styles kernel make math math.parser
+math.statistics memory namespaces parser prettyprint sequences
+sorting specialized-arrays splitting strings system vm words ;
+SPECIALIZED-ARRAY: gc-event
IN: tools.memory
<PRIVATE
-: write-size ( n -- )
- number>string
- dup length 4 > [ 3 cut* "," glue ] when
- " KB" append write-cell ;
+: commas ( n -- str )
+ dup 0 < [ neg commas "-" prepend ] [
+ number>string
+ reverse 3 group "," join reverse
+ ] if ;
-: write-total/used/free ( free total str -- )
- [
- write-cell
- dup write-size
- over - write-size
- write-size
- ] with-row ;
+: kilobytes ( n -- str )
+ 1024 /i commas " KB" append ;
-: write-total ( n str -- )
- [
- write-cell
- write-size
- [ ] with-cell
- [ ] with-cell
- ] with-row ;
-
-: write-headings ( seq -- )
- [ [ write-cell ] each ] with-row ;
-
-: (data-room.) ( -- )
- data-room 2 <groups> [
- [ first2 ] [ number>string "Generation " prepend ] bi*
- write-total/used/free
- ] each-index
- "Decks" write-total
- "Cards" write-total ;
-
-: write-labeled-size ( n string -- )
- [ write-cell write-size ] with-row ;
-
-: (code-room.) ( -- )
- code-room {
- [ "Size:" write-labeled-size ]
- [ "Used:" write-labeled-size ]
- [ "Total free space:" write-labeled-size ]
- [ "Largest free block:" write-labeled-size ]
- } spread ;
+: micros>string ( n -- str )
+ commas " µs" append ;
+
+: copying-room. ( copying-sizes -- )
+ {
+ { "Size:" [ size>> kilobytes ] }
+ { "Occupied:" [ occupied>> kilobytes ] }
+ { "Free:" [ free>> kilobytes ] }
+ } object-table. ;
+
+: nursery-room. ( data-room -- )
+ "- Nursery space" print nursery>> copying-room. ;
+
+: aging-room. ( data-room -- )
+ "- Aging space" print aging>> copying-room. ;
+
+: mark-sweep-table. ( mark-sweep-sizes -- )
+ {
+ { "Size:" [ size>> kilobytes ] }
+ { "Occupied:" [ occupied>> kilobytes ] }
+ { "Total free:" [ total-free>> kilobytes ] }
+ { "Contiguous free:" [ contiguous-free>> kilobytes ] }
+ { "Free block count:" [ free-block-count>> number>string ] }
+ } object-table. ;
+
+: tenured-room. ( data-room -- )
+ "- Tenured space" print tenured>> mark-sweep-table. ;
+
+: misc-room. ( data-room -- )
+ "- Miscellaneous buffers" print
+ {
+ { "Card array:" [ cards>> kilobytes ] }
+ { "Deck array:" [ decks>> kilobytes ] }
+ { "Mark stack:" [ mark-stack>> kilobytes ] }
+ } object-table. ;
+
+: data-room. ( -- )
+ "== Data heap ==" print nl
+ data-room data-heap-room memory>struct {
+ [ nursery-room. nl ]
+ [ aging-room. nl ]
+ [ tenured-room. nl ]
+ [ misc-room. ]
+ } cleave ;
+
+: code-room. ( -- )
+ "== Code heap ==" print nl
+ code-room mark-sweep-sizes memory>struct mark-sweep-table. ;
+
+PRIVATE>
+
+: room. ( -- ) data-room. nl code-room. ;
+
+<PRIVATE
: heap-stat-step ( obj counts sizes -- )
[ [ class ] dip inc-at ]
PRIVATE>
-: room. ( -- )
- "==== DATA HEAP" print
- standard-table-style [
- { "" "Total" "Used" "Free" } write-headings
- (data-room.)
- ] tabular-output
- nl nl
- "==== CODE HEAP" print
- standard-table-style [
- (code-room.)
- ] tabular-output
- nl ;
-
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
[ '[ _ _ heap-stat-step ] each ] 2keep ;
: heap-stats. ( -- )
heap-stats dup keys natural-sort standard-table-style [
- { "Class" "Bytes" "Instances" } write-headings
+ [ { "Class" "Bytes" "Instances" } [ write-cell ] each ] with-row
[
[
dup pprint-cell
] with-row
] each 2drop
] tabular-output nl ;
+
+SYMBOL: gc-events
+
+: collect-gc-events ( quot -- )
+ enable-gc-events
+ [ ] [ disable-gc-events drop ] cleanup
+ disable-gc-events byte-array>gc-event-array gc-events set ; inline
+
+<PRIVATE
+
+: gc-op-string ( op -- string )
+ {
+ { collect-nursery-op [ "Copying from nursery" ] }
+ { collect-aging-op [ "Copying from aging" ] }
+ { collect-to-tenured-op [ "Copying to tenured" ] }
+ { collect-full-op [ "Mark and sweep" ] }
+ { collect-compact-op [ "Mark and compact" ] }
+ { collect-growing-heap-op [ "Grow heap" ] }
+ } case ;
+
+: (space-occupied) ( data-heap-room code-heap-room -- n )
+ [
+ [ [ nursery>> ] [ aging>> ] [ tenured>> ] tri [ occupied>> ] tri@ ]
+ [ occupied>> ]
+ bi*
+ ] sum-outputs ;
+
+: space-occupied-before ( event -- bytes )
+ [ data-heap-before>> ] [ code-heap-before>> ] bi (space-occupied) ;
+
+: space-occupied-after ( event -- bytes )
+ [ data-heap-after>> ] [ code-heap-after>> ] bi (space-occupied) ;
+
+: space-reclaimed ( event -- bytes )
+ [ space-occupied-before ] [ space-occupied-after ] bi - ;
+
+TUPLE: gc-stats collections times ;
+
+: <gc-stats> ( -- stats )
+ gc-stats new
+ 0 >>collections
+ V{ } clone >>times ; inline
+
+: compute-gc-stats ( events -- stats )
+ V{ } clone [
+ '[
+ dup op>> _ [ drop <gc-stats> ] cache
+ [ 1 + ] change-collections
+ [ total-time>> ] dip times>> push
+ ] each
+ ] keep sort-keys ;
+
+: gc-stats-table-row ( pair -- row )
+ [
+ [ first gc-op-string ] [
+ second
+ [ collections>> ]
+ [
+ times>> {
+ [ sum micros>string ]
+ [ mean >integer micros>string ]
+ [ median >integer micros>string ]
+ [ infimum micros>string ]
+ [ supremum micros>string ]
+ } cleave
+ ] bi
+ ] bi
+ ] output>array ;
+
+: gc-stats-table ( stats -- table )
+ [ gc-stats-table-row ] map
+ { "" "Number" "Total" "Mean" "Median" "Min" "Max" } prefix ;
+
+PRIVATE>
+
+: gc-event. ( event -- )
+ {
+ { "Event type:" [ op>> gc-op-string ] }
+ { "Total time:" [ total-time>> micros>string ] }
+ { "Space reclaimed:" [ space-reclaimed kilobytes ] }
+ } object-table. ;
+
+: gc-events. ( -- )
+ gc-events get [ gc-event. nl ] each ;
+
+: gc-stats. ( -- )
+ gc-events get compute-gc-stats gc-stats-table simple-table. ;
+
+: gc-summary. ( -- )
+ gc-events get {
+ { "Collections:" [ length commas ] }
+ { "Cards scanned:" [ [ cards-scanned>> ] map-sum commas ] }
+ { "Decks scanned:" [ [ decks-scanned>> ] map-sum commas ] }
+ { "Code blocks scanned:" [ [ code-blocks-scanned>> ] map-sum commas ] }
+ { "Total time:" [ [ total-time>> ] map-sum micros>string ] }
+ { "Card scan time:" [ [ card-scan-time>> ] map-sum micros>string ] }
+ { "Code block scan time:" [ [ code-scan-time>> ] map-sum micros>string ] }
+ { "Data heap sweep time:" [ [ data-sweep-time>> ] map-sum micros>string ] }
+ { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum micros>string ] }
+ { "Compaction time:" [ [ compaction-time>> ] map-sum micros>string ] }
+ } object-table. ;
method-profile.
"profiler-limitations"
}
-{ $see-also "ui.tools.profiler" } ;
+{ $see-also "ui.tools.profiler" "tools.annotations" "timing" } ;
ABOUT: "profiling"
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors words sequences math prettyprint kernel arrays io
-io.styles namespaces assocs kernel.private strings combinators
-sorting math.parser vocabs definitions tools.profiler.private
-tools.crossref continuations generic compiler.units sets classes fry ;
+USING: accessors words sequences math prettyprint kernel arrays
+io io.styles namespaces assocs kernel.private strings
+combinators sorting math.parser vocabs definitions
+tools.profiler.private tools.crossref continuations generic
+compiler.units compiler.crossref sets classes fry ;
IN: tools.profiler
: profile ( quot -- )
[ dup counter>> ] map-counters ;
: cumulative-counters ( obj quot -- alist )
- '[ dup @ [ counter>> ] sigma ] map-counters ; inline
+ '[ dup @ [ counter>> ] map-sum ] map-counters ; inline
: vocab-counters ( -- alist )
vocabs [ words [ predicate? not ] filter ] cumulative-counters ;
[ main-file-string ] dip utf8 set-file-contents ;
: scaffold-main ( vocab-root vocab -- )
- tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
+ [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [
set-scaffold-main-file
] [
2drop
] [ drop ] if ; inline
: parse-test ( accum word -- accum )
- literalize parsed
- lexer get line>> parsed
- \ experiment parsed ; inline
+ literalize suffix!
+ lexer get line>> suffix!
+ \ experiment suffix! ; inline
<<
vocab-tests [ run-test-file ] each
] [ drop ] if ;
-: traceback-button. ( failure -- )
- "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-
PRIVATE>
TEST: unit-test
[ error-location print nl ]
[ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
- [ traceback-button. ]
+ [ continuation>> traceback-link. ]
} cleave ;
: :test-failures ( -- ) test-failures get errors. ;
-USING: help.markup help.syntax memory system ;
+USING: help.markup help.syntax memory system tools.dispatch
+tools.memory quotations vm ;
IN: tools.time
-ARTICLE: "timing" "Timing code"
+ARTICLE: "timing" "Timing code and collecting statistics"
"You can time the execution of a quotation in the listener:"
{ $subsections time }
+"This word also collects statistics about method dispatch and garbage collection:"
+{ $subsections dispatch-stats. gc-events. gc-stats. gc-summary. }
"A lower-level word puts timings on the stack, intead of printing:"
{ $subsections benchmark }
-"You can also read the system clock and garbage collection statistics directly:"
-{ $subsections
- micros
- gc-stats
-}
-{ $see-also "profiling" } ;
+"You can also read the system clock directly:"
+{ $subsections micros }
+{ $see-also "profiling" "calendar" } ;
ABOUT: "timing"
HELP: benchmark
-{ $values { "quot" "a quotation" }
+{ $values { "quot" quotation }
{ "runtime" "the runtime in microseconds" } }
{ $description "Runs a quotation, measuring the total wall clock time." }
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
HELP: time
-{ $values { "quot" "a quotation" } }
-{ $description "Runs a quotation and then prints the total run time and some garbage collection statistics." } ;
+{ $values { "quot" quotation } }
+{ $description "Runs a quotation, gathering statistics about method dispatch and garbage collection, and then prints the total run time." } ;
{ benchmark micros time } related-words
+
+HELP: collect-gc-events
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation, storing an array of " { $link gc-event } " instances in the " { $link gc-events } " variable." }
+{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
+
+HELP: collect-dispatch-stats
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation, collecting method dispatch statistics and storing them in the " { $link last-dispatch-stats } " variable. " }
+{ $notes "The " { $link time } " combinator automatically calls this combinator." } ;
--- /dev/null
+IN: tools.time.tests
+USING: tools.time tools.test compiler ;
+
+[ ] [ [ [ ] time ] compile-call ] unit-test
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math memory io io.styles prettyprint
-namespaces system sequences splitting grouping assocs strings
-generic.single combinators ;
+USING: system kernel math io prettyprint tools.memory
+tools.dispatch ;
IN: tools.time
: benchmark ( quot -- runtime )
micros [ call micros ] dip - ; inline
: time. ( time -- )
- "== Running time ==" print nl 1000000 /f pprint " seconds" print ;
+ "Running time: " write 1000000 /f pprint " seconds" print ;
-: gc-stats. ( stats -- )
- 5 cut*
- "== Garbage collection ==" print nl
- "Times are in microseconds." print nl
- [
- 6 group
- {
- "GC count:"
- "Total GC time:"
- "Longest GC pause:"
- "Average GC pause:"
- "Objects copied:"
- "Bytes copied:"
- } prefix
- flip
- { "" "Nursery" "Aging" "Tenured" } prefix
- simple-table.
- ]
- [
- nl
- {
- "Total GC time:"
- "Cards scanned:"
- "Decks scanned:"
- "Card scan time:"
- "Code heap literal scans:"
- } swap zip simple-table.
- ] bi* ;
-
-: dispatch-stats. ( stats -- )
- "== Megamorphic caches ==" print nl
- { "Hits" "Misses" } swap zip simple-table. ;
-
-: inline-cache-stats. ( stats -- )
- nl "== Polymorphic inline caches ==" print nl
- 3 cut
- [
- "Transitions:" print
- { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
- simple-table. nl
- ] [
- "Type check stubs:" print
- { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
- simple-table.
- ] bi* ;
+: time-banner. ( -- )
+ "Additional information was collected." print
+ "dispatch-stats. - Print method dispatch statistics" print
+ "gc-events. - Print all garbage collection events" print
+ "gc-stats. - Print breakdown of different garbage collection events" print
+ "gc-summary. - Print aggregate garbage collection statistics" print ;
: time ( quot -- )
- gc-reset
- reset-dispatch-stats
- reset-inline-cache-stats
- benchmark gc-stats dispatch-stats inline-cache-stats
- H{ { table-gap { 20 20 } } } [
- [
- [ [ time. ] 3dip ] with-cell
- [ ] with-cell
- ] with-row
- [
- [ [ gc-stats. ] 2dip ] with-cell
- [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
- ] with-row
- ] tabular-output nl ; inline
+ [ [ benchmark ] collect-dispatch-stats ] collect-gc-events
+ time. nl time-banner. ; inline
IN: tools.walker.debug
:: test-walker ( quot -- data )
- [let | p [ <promise> ] |
- [
- H{ } clone >n
+ <promise> :> p
+ [
+ H{ } clone >n
- [
- p promise-fulfilled?
- [ drop ] [ p fulfill ] if
- 2drop
- ] show-walker-hook set
+ [
+ p promise-fulfilled?
+ [ drop ] [ p fulfill ] if
+ 2drop
+ ] show-walker-hook set
- break
+ break
- quot call
- ] "Walker test" spawn drop
+ quot call
+ ] "Walker test" spawn drop
- step-into-all
- p ?promise
- send-synchronous drop
+ step-into-all
+ p ?promise
+ send-synchronous drop
- p ?promise
- variables>> walker-continuation swap at
- value>> data>>
- ] ;
+ p ?promise
+ variables>> walker-continuation swap at
+ value>> data>> ;
! For convenience
IN: syntax
-SYNTAX: B \ break parsed ;
+SYNTAX: B \ break suffix! ;
tr-quot (( seq -- translated )) define-declared ;
: fast-tr-quot ( mapping -- quot )
- '[ [ _ tr-nth ] change-each ] ;
+ '[ [ _ tr-nth ] map! drop ] ;
: define-fast-tr ( word mapping -- )
fast-tr-quot (( seq -- )) define-declared ;
-USING: accessors effects eval kernel layouts math quotations tools.test typed words ;
+USING: accessors effects eval kernel layouts math namespaces
+quotations tools.test typed words ;
IN: typed.tests
TYPED: f+ ( a: float b: float -- c: float )
T{ unboxable f 12 3 4.0 } unboxy xy>>
""" eval( -- xy )
] unit-test
+
+TYPED: no-inputs ( -- out: integer )
+ 1 ;
+
+[ 1 ] [ no-inputs ] unit-test
+
+TUPLE: unboxable3
+ { x read-only } ;
+
+TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
+ T{ unboxable3 } ;
+
+[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
+
+SYMBOL: buh
+
+TYPED: no-outputs ( x: integer -- )
+ buh set ;
+
+[ 2 ] [ 2 no-outputs buh get ] unit-test
+
+TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
+ buh set ;
+
+[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
combinators.short-circuit definitions effects fry hints
math kernel kernel.private namespaces parser quotations
sequences slots words locals
-locals.parser macros stack-checker.state ;
+locals.parser macros stack-checker.dependencies ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
[ drop [ ] ] if ;
: make-boxer ( types -- quot )
- [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ;
+ [ [ ] ]
+ [ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ] if-empty ;
! defining typed words
M:: cocoa-ui-backend (open-window) ( world -- )
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
- world window-controls>> textured-background swap memq?
+ world window-controls>> textured-background swap member-eq?
[ view make-context-transparent ] when
view world [ world>NSRect ] [ world>styleMask ] bi <ViewWindow> :> window
view -> release
: handle-wm-ncbutton ( hWnd uMsg wParam lParam -- )
2drop nip
message>button nc-buttons get
- swap [ push ] [ delete ] if ;
+ swap [ push ] [ remove! drop ] if ;
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
[
over set-capture
- dup message>button drop nc-buttons get delete
+ dup message>button drop nc-buttons get remove! drop
] 2dip prepare-mouse send-button-down ;
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
mouse-captured get [ release-capture ] when
pick message>button drop dup nc-buttons get member? [
- nc-buttons get delete 4drop
+ nc-buttons get remove! drop 4drop
] [
drop prepare-mouse send-button-up
] if ;
COLOR_BTNFACE GetSysColor RGB>color ;
: ?make-glass ( world hwnd -- )
- over window-controls>> textured-background swap memq? [
+ over window-controls>> textured-background swap member-eq? [
composition-enabled? [
full-window-margins DwmExtendFrameIntoClientArea drop
T{ rgba f 0.0 0.0 0.0 0.0 }
: join-lines ( string -- string' )
"\n" split
- [ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
- [ but-last-slice [ [ blank? ] trim-tail-slice ] change-each ]
+ [ rest-slice [ [ blank? ] trim-head-slice ] map! drop ]
+ [ but-last-slice [ [ blank? ] trim-tail-slice ] map! drop ]
[ " " join ]
tri ;
[ remove-gadget ] [
over (unparent)
[ unfocus-gadget ]
- [ children>> delete ]
+ [ children>> remove! drop ]
[ nip relayout ]
2tri
] 2bi
PRIVATE>
: ?string-lines ( string -- string/array )
- CHAR: \n over memq? [ string-lines ] when ;
+ CHAR: \n over member-eq? [ string-lines ] when ;
ERROR: not-a-string object ;
dup wrap-words [ <line> ] map ;
: line-width ( wrapped-line -- n )
- [ break?>> ] trim-tail-slice [ width>> ] sigma ;
+ [ break?>> ] trim-tail-slice [ width>> ] map-sum ;
: max-line-width ( wrapped-paragraph -- x )
[ words>> line-width ] [ max ] map-reduce ;
: sum-line-heights ( wrapped-paragraph -- y )
- [ height>> ] sigma ;
+ [ height>> ] map-sum ;
M: paragraph pref-dim*
wrap-paragraph [ max-line-width ] [ sum-line-heights ] bi 2array ;
M: paragraph cap-height pack-cap-height ;
-PRIVATE>
\ No newline at end of file
+PRIVATE>
pick sizes>> push add-gadget ;
M: track remove-gadget
- [ [ children>> index ] [ sizes>> ] bi delete-nth ]
+ [ [ children>> index ] [ sizes>> ] bi remove-nth! drop ]
[ call-next-method ] 2bi ;
: clear-track ( track -- ) [ sizes>> delete-all ] [ clear-gadget ] bi ;
V{ } clone >>window-resources ;
: initial-background-color ( attributes -- color )
- window-controls>> textured-background swap memq?
+ window-controls>> textured-background swap member-eq?
[ T{ rgba f 0.0 0.0 0.0 0.0 } ]
[ T{ rgba f 1.0 1.0 1.0 1.0 } ] if ;
M: world children-on nip children>> ;
M: world remove-gadget
- 2dup layers>> memq?
- [ layers>> delq ] [ call-next-method ] if ;
+ 2dup layers>> member-eq?
+ [ layers>> remove-eq! drop ] [ call-next-method ] if ;
SYMBOL: flush-layout-cache-hook
: send-button-up ( gesture loc world -- )
move-hand
- dup #>> hand-buttons get-global delete
+ dup #>> hand-buttons get-global remove! drop
stop-drag-timer
button-gesture ;
TUPLE: browser-gadget < tool history scroller search-field popup ;
-{ 650 400 } browser-gadget set-tool-dim
+{ 650 700 } browser-gadget set-tool-dim
M: browser-gadget history-value
[ control-value ] [ scroller>> scroll-position ]
: browser-help ( -- ) "ui-browser" com-browse ;
+: glossary ( -- ) "conventions" com-browse ;
+
\ browser-help H{ { +nullary+ t } } define-command
+\ glossary H{ { +nullary+ t } } define-command
browser-gadget "toolbar" f {
{ T{ key-down f { A+ } "LEFT" } com-back }
{ T{ key-down f { A+ } "RIGHT" } com-forward }
{ T{ key-down f { A+ } "H" } com-home }
{ T{ key-down f f "F1" } browser-help }
+ { T{ key-down f { A+ } "F1" } glossary }
} define-command-map
: ?show-help ( link browser -- )
M: word-completion row-color
[ vocabulary>> ] [ manifest>> ] bi* {
{ [ dup not ] [ COLOR: black ] }
- { [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
+ { [ 2dup search-vocabs>> member-eq? ] [ COLOR: black ] }
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
[ COLOR: dark-gray ]
} cond 2nip ;
M: completion-popup handle-gesture ( gesture completion -- ? )
2dup completion-gesture dup [
[ nip hide-glass ] [ invoke-command ] 2bi* f
- ] [ 2drop call-next-method ] if ;
\ No newline at end of file
+ ] [ 2drop call-next-method ] if ;
"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
ARTICLE: "ui-listener" "UI listener"
-"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds an input history, and word and vocabulary completion."
+"The graphical listener adds input history and word and vocabulary completion. See " { $link "listener" } " for general information on the listener."
{ $command-map listener-gadget "toolbar" }
{ $command-map interactor "completion" }
{ $command-map interactor "interactor" }
TIP: "Press " { $command tool "common" refresh-all } " or run " { $link refresh-all } " to reload changed source files from disk. " ;
-ABOUT: "ui-listener"
\ No newline at end of file
+ABOUT: "ui-listener"
{ T{ key-down f { C+ } "r" } history-completion-popup }
} define-command-map
+: introduction. ( -- )
+ tip-of-the-day. nl
+ { $strong "Press " { $snippet "F1" } " at any time for help." } print-content nl nl ;
+
: listener-thread ( listener -- )
dup listener-streams [
[ com-browse ] help-hook set
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
error-summary? off
- tip-of-the-day. nl
+ introduction.
listener
nl
"The listener has exited. To start it again, click “Restart Listener”." print
: method-matches? ( method generic class -- ? )
[ first ] 2dip
{
- [ drop dup [ subwords memq? ] [ 2drop t ] if ]
+ [ drop dup [ subwords member-eq? ] [ 2drop t ] if ]
[ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
} 3&& ;
] [
[
[ children>> swap first head-slice % ]
- [ tuck traverse-step traverse-to-path ]
- 2bi
+ [ nip ]
+ [ traverse-step traverse-to-path ]
+ 2tri
] make-node
] if
] if ;
] [
[
[ traverse-step traverse-from-path ]
- [ tuck children>> swap first 1 + tail-slice % ] 2bi
+ [ nip ]
+ [ children>> swap first 1 + tail-slice % ]
+ 2tri
] make-node
] if
] if ;
: raised-window ( world -- )
windows get-global
[ [ second eq? ] with find drop ] keep
- [ nth ] [ delete-nth ] [ nip ] 2tri push ;
+ [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
: focus-gestures ( new old -- )
drop-prefix <reversed>
drop [ 0 ] unless* tail-slice ;\r
\r
:: ?combine ( char slice i -- ? )\r
- [let | str [ i slice nth char suffix ] |\r
- str ducet key? dup\r
- [ str i slice set-nth ] when\r
- ] ;\r
+ i slice nth char suffix :> str\r
+ str ducet key? dup\r
+ [ str i slice set-nth ] when ;\r
\r
: add ( char -- )\r
dup blocked? [ 1string , ] [\r
gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
- \ unix:group <struct> tuck 4096
+ [ \ unix:group <struct> ] dip over 4096
[ <byte-array> ] keep f <void*> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
ERROR: unix-system-call-error args errno message word ;
MACRO:: unix-system-call ( quot -- )
- [let | n [ quot infer in>> ]
- word [ quot first ] |
- [
- n ndup quot call dup 0 < [
- drop
- n narray
- errno dup strerror
- word unix-system-call-error
- ] [
- n nnip
- ] if
- ]
+ quot infer in>> :> n
+ quot first :> word
+ [
+ n ndup quot call dup 0 < [
+ drop
+ n narray
+ errno dup strerror
+ word unix-system-call-error
+ ] [
+ n nnip
+ ] if
] ;
HOOK: open-file os ( path flags mode -- fd )
clone dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
-SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
+SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
USING: vocabs vocabs.loader ;
>lower "on" = ;
: v-default ( str def -- str/def )
- over empty? spin ? ;
+ [ nip empty? ] 2keep ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
def>> first (>>obj) ;
SYNTAX: to:
- scan-word literalize parsed
- \ set-value parsed ;
+ scan-word literalize suffix!
+ \ set-value suffix! ;
: get-value ( word -- value )
def>> first obj>> ;
USING: classes.struct alien.c-types alien.syntax ;
IN: vm
-TYPEDEF: void* cell
+TYPEDEF: uintptr_t cell
C-TYPE: context
STRUCT: zone
- { start cell }
- { here cell }
- { size cell }
- { end cell } ;
+{ start cell }
+{ here cell }
+{ size cell }
+{ end cell } ;
STRUCT: vm
- { stack_chain context* }
- { nursery zone }
- { cards_offset cell }
- { decks_offset cell }
- { userenv cell[70] } ;
+{ stack_chain context* }
+{ nursery zone }
+{ cards_offset cell }
+{ decks_offset cell }
+{ userenv cell[70] } ;
: vm-field-offset ( field -- offset ) vm offset-of ; inline
+
+C-ENUM:
+collect-nursery-op
+collect-aging-op
+collect-to-tenured-op
+collect-full-op
+collect-compact-op
+collect-growing-heap-op ;
+
+STRUCT: copying-sizes
+{ size cell }
+{ occupied cell }
+{ free cell } ;
+
+STRUCT: mark-sweep-sizes
+{ size cell }
+{ occupied cell }
+{ total-free cell }
+{ contiguous-free cell }
+{ free-block-count cell } ;
+
+STRUCT: data-heap-room
+{ nursery copying-sizes }
+{ aging copying-sizes }
+{ tenured mark-sweep-sizes }
+{ cards cell }
+{ decks cell }
+{ mark-stack cell } ;
+
+STRUCT: gc-event
+{ op uint }
+{ data-heap-before data-heap-room }
+{ code-heap-before mark-sweep-sizes }
+{ data-heap-after data-heap-room }
+{ code-heap-after mark-sweep-sizes }
+{ cards-scanned cell }
+{ decks-scanned cell }
+{ code-blocks-scanned cell }
+{ start-time ulonglong }
+{ total-time cell }
+{ card-scan-time cell }
+{ code-scan-time cell }
+{ data-sweep-time cell }
+{ code-sweep-time cell }
+{ compaction-time cell }
+{ temp-time cell } ;
+
+STRUCT: dispatch-statistics
+{ megamorphic-cache-hits cell }
+{ megamorphic-cache-misses cell }
+
+{ cold-call-to-ic-transitions cell }
+{ ic-to-pic-transitions cell }
+{ pic-to-mega-transitions cell }
+
+{ pic-tag-count cell }
+{ pic-tuple-count cell } ;
[ >>x drop ] ! IInherited::setX
} }
{ IUnrelated {
- [ swap x>> + ] ! IUnrelated::xPlus
- [ spin x>> * + ] ! IUnrelated::xMulAdd
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus
+ [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrelated::xMulAdd
} }
} <com-wrapper>
dup +test-wrapper+ set [
dup save-com-interface-definition
define-words-for-com-interface ;
-SYNTAX: GUID: scan string>guid parsed ;
+SYNTAX: GUID: scan string>guid suffix! ;
USING: vocabs vocabs.loader ;
[ >>x drop ] ! IInherited::setX\r
} }\r
{ "IUnrelated" {\r
- [ swap x>> + ] ! IUnrelated::xPlus\r
- [ spin x>> * + ] ! IUnrealted::xMulAdd\r
+ [ [ x>> ] [ + ] bi* ] ! IUnrelated::xPlus\r
+ [ [ x>> ] [ * ] [ + ] tri* ] ! IUnrealted::xMulAdd\r
} }\r
} <com-wrapper>""" } ;\r
\r
M: com-wrapper dispose*
[ [ free ] each f ] change-vtbls
- +live-wrappers+ get-global delete ;
+ +live-wrappers+ get-global remove! drop ;
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi
DIOBJECTDATAFORMAT <struct-boa> ;
:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
- array [| args i |
- struct args <DIOBJECTDATAFORMAT>
- i alien set-nth
- ] each-index
- alien
- ] ;
+ array length malloc-DIOBJECTDATAFORMAT-array :> alien
+ array [| args i |
+ struct args <DIOBJECTDATAFORMAT>
+ i alien set-nth
+ ] each-index
+ alien ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
ALIAS: ShellExecute ShellExecuteW
: open-in-explorer ( dir -- )
- [ f "open" ] dip (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
+ [ f "open" ] dip absolute-path f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
f >>alist drop ;
M: attrs delete-at
[ nip ] [ attr@ drop ] 2bi
- [ swap alist>> delete-nth ] [ drop ] if* ;
+ [ swap alist>> remove-nth! drop ] [ drop ] if* ;
M: attrs clone
alist>> clone <attrs> ;
"Here is an example of the locals version:"
{ $example
"""USING: locals urls xml.syntax xml.writer ;
-[let |
- number [ 3 ]
- false [ f ]
- url [ URL" http://factorcode.org/" ]
- string [ "hello" ]
- word [ \\ drop ] |
+[let
+ 3 :> number
+ f :> false
+ URL" http://factorcode.org/" :> url
+ "hello" :> string
+ \\ drop :> word
<XML
<x
number=<-number->
y
<foo/>
</x>""" ] [
- [let* | a [ "one" ] c [ "two" ] x [ "y" ]
- d [ [XML <-x-> <foo/> XML] ] |
+ [let "one" :> a "two" :> c "y" :> x [XML <-x-> <foo/> XML] :> d
<XML
<x> <-a-> <b val=<-c->/> <-d-> </x>
XML> pprint-xml>string
: collect ( accum variables -- accum ? )
{
{ [ dup empty? ] [ drop f ] } ! Just a literal
- { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals
- { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry
+ { [ dup [ ] all? ] [ >search-hash suffix! t ] } ! locals
+ { [ dup [ not ] all? ] [ length suffix! \ nenum suffix! t ] } ! fry
[ drop "XML interpolation contains both fry and locals" throw ] ! mixed
} cond ;
: parse-def ( accum delimiter quot -- accum )
[ parse-multiline-string [ blank? ] trim ] dip call
[ extract-variables collect ] keep swap
- [ number<-> parsed ] dip
- [ \ interpolate-xml parsed ] when ; inline
+ [ number<-> suffix! ] dip
+ [ \ interpolate-xml suffix! ] when ; inline
PRIVATE>
: get-rule-set ( name -- rule-sets rules )
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
- dup -roll at* [ nip ] [ drop no-such-rule-set ] if ;
+ [ at* [ nip ] [ drop no-such-rule-set ] if ] keep swap ;
DEFER: finalize-rule-set
dup [ glob-matches? ] [ 2drop f ] if ;
: suitable-mode? ( file-name first-line mode -- ? )
- tuck first-line-glob>> ?glob-matches
+ [ nip ] 2keep first-line-glob>> ?glob-matches
[ 2drop t ] [ file-name-glob>> ?glob-matches ] if ;
: find-mode ( file-name first-line -- mode )
[ >string ] dip first-match dup [ to>> ] when ;
: rule-start-matches? ( rule -- match-count/f )
- dup start>> tuck swap can-match-here? [
+ [ start>> dup ] keep can-match-here? [
rest-of-line swap text>> text-matches?
] [
drop f
dup mark-following-rule? [
dup start>> swap can-match-here? 0 and
] [
- dup end>> tuck swap can-match-here? [
+ [ end>> dup ] keep can-match-here? [
rest-of-line
swap text>> context get end>> or
text-matches?
?end-rule
mark-token
add-remaining-token
- tuck body-token>> next-token,
+ [ body-token>> next-token, ] keep
delegate>> [ push-context ] when* ;
UNION: abstract-span-rule span-rule eol-span-rule ;
?end-rule
mark-token
add-remaining-token
- tuck rule-match-token* next-token,
+ [ rule-match-token* next-token, ] keep
! ... end subst ...
dup context get (>>in-rule)
delegate>> push-context ;
M: mark-following-rule handle-rule-start
?end-rule
mark-token add-remaining-token
- tuck rule-match-token* next-token,
+ [ rule-match-token* next-token, ] keep
f context get (>>end)
context get (>>in-rule) ;
: ?push-all ( seq1 seq2 -- seq1+seq2 )
[
- over [ [ V{ } like ] dip over push-all ] [ nip ] if
+ over [ [ V{ } like ] dip append! ] [ nip ] if
] when* ;
: rule-set-no-word-sep* ( ruleset -- str )
kernel.private byte-arrays arrays init ;
IN: alien
-! Some predicate classes used by the compiler for optimization
-! purposes
-PREDICATE: simple-alien < alien underlying>> not ;
+PREDICATE: pinned-alien < alien underlying>> not ;
-UNION: simple-c-ptr
-simple-alien POSTPONE: f byte-array ;
-
-DEFER: pinned-c-ptr?
-
-PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
-
-UNION: pinned-c-ptr
- pinned-alien POSTPONE: f ;
+UNION: pinned-c-ptr pinned-alien POSTPONE: f ;
GENERIC: >c-ptr ( obj -- c-ptr )
M: f expired? drop t ;
: <alien> ( address -- alien )
- f <displaced-alien> { simple-c-ptr } declare ; inline
+ f <displaced-alien> { pinned-c-ptr } declare ; inline
: <bad-alien> ( -- alien )
-1 <alien> t >>expired ; inline
2drop f
] if ;
-M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+M: pinned-alien hashcode*
+ nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
ERROR: alien-callback-error ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
- 0 over memq? [ invalid-c-string ] [ drop ] if ;
+ 0 over member-eq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
HELP: enum
{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+"Enumerations are mutable; note that deleting a key calls " { $link remove-nth! } ", which results in all subsequent elements being shifted down." } ;
HELP: <enum>
{ $values { "seq" sequence } { "enum" enum } }
update
assoc-union
assoc-diff
- remove-all
substitute
- substitute-here
extract-keys
}
{ $see-also key? assoc-any? assoc-all? "sets" } ;
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." }
;
-HELP: remove-all
-{ $values { "assoc" assoc } { "seq" "a sequence" } { "subseq" "a new sequence" } }
-{ $description "Constructs a sequence consisting of all elements in " { $snippet "seq" } " which do not appear as keys in " { $snippet "assoc" } "." }
-{ $notes "The values of the keys in the assoc are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." }
-{ $side-effects "assoc" } ;
-
-HELP: substitute-here
-{ $values { "seq" "a mutable sequence" } { "assoc" assoc } }
-{ $description "Replaces elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " with the corresponding values, acting as the identity on all other elements." }
-{ $errors "Throws an error if " { $snippet "assoc" } " contains values whose types are not permissible in " { $snippet "seq" } "." }
-{ $side-effects "seq" } ;
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
-[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
-
[ H{ { "hi" 2 } { 3 4 } } ]
[ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
unit-test
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;
-: remove-all ( assoc seq -- subseq )
- swap [ key? not ] curry filter ;
-
-: substitute-here ( seq assoc -- )
- substituter change-each ;
-
: substitute ( seq assoc -- newseq )
substituter map ;
M: sequence delete-at
[ nip ] [ search-alist nip ] 2bi
- [ swap delete-nth ] [ drop ] if* ;
+ [ swap remove-nth! drop ] [ drop ] if* ;
M: sequence assoc-size length ; inline
M: sequence >alist ; inline
! Override sequence => assoc instance for f
+M: f at* 2drop f f ; inline
+
+M: f assoc-size drop 0 ; inline
+
M: f clear-assoc drop ; inline
M: f assoc-like drop dup assoc-empty? [ drop f ] when ; inline
M: enum set-at seq>> set-nth ; inline
-M: enum delete-at seq>> delete-nth ; inline
+M: enum delete-at seq>> remove-nth! drop ; inline
M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ; inline
quotations assocs layouts classes.tuple.private
kernel.private ;
-BIN: 111 tag-mask set
-8 num-tags set
-3 tag-bits set
+16 data-alignment set
-15 num-types set
+BIN: 1111 tag-mask set
+4 tag-bits set
+
+14 num-types set
32 mega-cache-size set
H{
- { fixnum BIN: 000 }
- { bignum BIN: 001 }
- { array BIN: 010 }
- { float BIN: 011 }
- { quotation BIN: 100 }
- { POSTPONE: f BIN: 101 }
- { object BIN: 110 }
- { hi-tag BIN: 110 }
- { tuple BIN: 111 }
-} tag-numbers set
-
-tag-numbers get H{
+ { fixnum 0 }
+ { POSTPONE: f 1 }
+ { array 2 }
+ { float 3 }
+ { quotation 4 }
+ { bignum 5 }
+ { alien 6 }
+ { tuple 7 }
{ wrapper 8 }
{ byte-array 9 }
{ callstack 10 }
{ string 11 }
{ word 12 }
{ dll 13 }
- { alien 14 }
-} assoc-union type-numbers set
+} type-numbers set
"system"
"system.private"
"threads.private"
+ "tools.dispatch.private"
"tools.profiler.private"
"words"
"words.private"
"object?" "kernel" vocab-words delete-at
-! Class of objects with object tag
-"hi-tag" "kernel.private" create
-builtins get num-tags get tail define-union-class
-
! Empty class with no instances
"null" "kernel" create
[ f { } f union-class define-class ]
{ "swapd" "kernel" (( x y z -- y x z )) }
{ "nip" "kernel" (( x y -- y )) }
{ "2nip" "kernel" (( x y z -- z )) }
- { "tuck" "kernel" (( x y -- y x y )) }
{ "over" "kernel" (( x y -- x y x )) }
{ "pick" "kernel" (( x y z -- x y z x )) }
{ "swap" "kernel" (( x y -- y x )) }
{ "minor-gc" "memory" (( -- )) }
{ "gc" "memory" (( -- )) }
{ "compact-gc" "memory" (( -- )) }
- { "gc-stats" "memory" f }
{ "(save-image)" "memory.private" (( path -- )) }
{ "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "set-retainstack" "kernel" (( rs -- )) }
{ "set-callstack" "kernel" (( cs -- )) }
{ "exit" "system" (( n -- )) }
- { "data-room" "memory" (( -- cards decks generations )) }
- { "code-room" "memory" (( -- code-total code-used code-free largest-free-block )) }
+ { "data-room" "memory" (( -- data-room )) }
+ { "code-room" "memory" (( -- code-room )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
{ "(dlopen)" "alien.libraries" (( path -- dll )) }
{ "resize-array" "arrays" (( n array -- newarray )) }
{ "resize-string" "strings" (( n str -- newstr )) }
{ "<array>" "arrays" (( n elt -- array )) }
- { "begin-scan" "memory" (( -- )) }
- { "next-object" "memory" (( -- obj )) }
- { "end-scan" "memory" (( -- )) }
+ { "all-instances" "memory" (( -- array )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
{ "(fopen)" "io.streams.c" (( path mode -- alien )) }
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
{ "dll-valid?" "alien.libraries" (( dll -- ? )) }
{ "unimplemented" "kernel.private" (( -- * )) }
- { "gc-reset" "memory" (( -- )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
{ "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) }
{ "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
{ "lookup-method" "generic.single.private" (( object methods -- method )) }
- { "reset-dispatch-stats" "generic.single" (( -- )) }
- { "dispatch-stats" "generic.single" (( -- stats )) }
- { "reset-inline-cache-stats" "generic.single" (( -- )) }
- { "inline-cache-stats" "generic.single" (( -- stats )) }
+ { "reset-dispatch-stats" "tools.dispatch.private" (( -- )) }
+ { "dispatch-stats" "tools.dispatch.private" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
{ "quot-compiled?" "quotations" (( quot -- ? )) }
{ "vm-ptr" "vm" (( -- ptr )) }
{ "strip-stack-traces" "kernel.private" (( -- )) }
{ "<callback>" "alien" (( word -- alien )) }
+ { "enable-gc-events" "memory" (( -- )) }
+ { "disable-gc-events" "memory" (( -- events )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
! Create a boot quotation for the target
[
[
- ! Rehash hashtables, since bootstrap.image creates them
- ! using the host image's hashing algorithms. We don't
- ! use each-object here since the catch stack isn't yet
- ! set up.
- gc
- begin-scan
- [ hashtable? ] pusher [ (each-object) ] dip
- end-scan
- [ rehash ] each
+ ! Rehash hashtables first, since bootstrap.image creates
+ ! them using the host image's hashing algorithms.
+ [ hashtable? ] instances [ rehash ] each
boot
] %
"math.integers" require
"math.floats" require
"memory" require
-
+
"io.streams.c" require
"vocabs.loader" require
-
+
"syntax" require
"bootstrap.layouts" require
flatten-class\r
flatten-builtin-class\r
class-types\r
- class-tags\r
} ;\r
\r
ARTICLE: "class-linearization" "Class linearization"\r
\r
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
\r
-[ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
-\r
[ t ] [\r
growable tuple sequence class-and class<=\r
] unit-test\r
: sort-classes ( seq -- newseq )\r
[ name>> ] sort-with >vector\r
[ dup empty? not ]\r
- [ dup largest-class [ over delete-nth ] dip ]\r
+ [ dup largest-class [ over remove-nth! drop ] dip ]\r
produce nip ;\r
\r
: smallest-class ( classes -- class/f )\r
flatten-builtin-class keys\r
[ "type" word-prop ] map natural-sort ;\r
\r
-: class-tags ( class -- seq )\r
- class-types [\r
- dup num-tags get >=\r
- [ drop \ hi-tag tag-number ] when\r
- ] map prune ;\r
-\r
-: class-tag ( class -- tag/f )\r
- class-tags dup length 1 = [ first ] [ drop f ] if ;\r
+: class-type ( class -- tag/f )\r
+ class-types dup length 1 = [ first ] [ drop f ] if ;\r
: class>type ( class -- n ) "type" word-prop ; foldable
-PREDICATE: lo-tag-class < builtin-class class>type 7 <= ;
-
-PREDICATE: hi-tag-class < builtin-class class>type 7 > ;
-
: type>class ( n -- class ) builtins get-global nth ;
: bootstrap-type>class ( n -- class ) builtins get nth ;
-M: hi-tag class hi-tag type>class ; inline
-
M: object class tag type>class ; inline
M: builtin-class rank-class drop 0 ;
GENERIC: define-builtin-predicate ( class -- )
-M: lo-tag-class define-builtin-predicate
+M: builtin-class define-builtin-predicate
dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-M: hi-tag-class define-builtin-predicate
- dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
- [ dup tag 6 eq? ] [ [ drop f ] if ] surround
- define-predicate ;
-
-M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
-
-M: hi-tag-class instance?
- over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
+M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;
[ f ] [ 3 float instance? ] unit-test
[ t ] [ 3 number instance? ] unit-test
[ f ] [ 3 null instance? ] unit-test
-[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Regression
GENERIC: method-forget-test ( obj -- obj )
] unless ;
: if-mixin-member? ( class mixin true false -- )
- [ check-mixin-class 2dup members memq? ] 2dip if ; inline
+ [ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
: change-mixin-class ( class mixin quot -- )
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
[ t ] [ \ yo-momma class? ] unit-test
[ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
- [ f ] [ \ yo-momma update-map get values memq? ] unit-test
+ [ f ] [ \ yo-momma update-map get values member-eq? ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
} case define-predicate ;
: class-size ( class -- n )
- superclasses [ "slots" word-prop length ] sigma ;
+ superclasses [ "slots" word-prop length ] map-sum ;
: (instance-check-quot) ( class -- quot )
[
effects words ;
IN: combinators
-ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
-"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
-{ $code
- ": keep [ ] bi ;"
- ": 2keep [ ] 2bi ;"
- ": 3keep [ ] 3bi ;"
- ""
- ": dup [ ] [ ] bi ;"
- ": 2dup [ ] [ ] 2bi ;"
- ": 3dup [ ] [ ] 3bi ;"
- ""
- ": tuck [ nip ] [ ] 2bi ;"
- ": swap [ nip ] [ drop ] 2bi ;"
- ""
- ": over [ ] [ drop ] 2bi ;"
- ": pick [ ] [ 2drop ] 3bi ;"
- ": 2over [ ] [ drop ] 3bi ;"
-} ;
-
ARTICLE: "cleave-combinators" "Cleave combinators"
-"The cleave combinators apply multiple quotations to a single value."
+"The cleave combinators apply multiple quotations to a single value or set of values."
$nl
"Two quotations:"
{ $subsections
2cleave
3cleave
}
-$nl
-"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
+"Cleave combinators provide a more readable alternative to repeated applications of the " { $link keep } " combinators. The following example using " { $link keep } ":"
{ $code
- "! First alternative; uses keep"
"[ 1 + ] keep"
"[ 1 - ] keep"
"2 *"
- "! Second alternative: uses tri"
+}
+"can be more clearly written using " { $link tri } ":"
+{ $code
"[ 1 + ]"
"[ 1 - ]"
"[ 2 * ] tri"
-}
-"The latter is more aesthetically pleasing than the former."
-$nl
-{ $subsections "cleave-shuffle-equivalence" } ;
-
-ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
-"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
-{ $code
- ": dip [ ] bi* ;"
- ": 2dip [ ] [ ] tri* ;"
- ""
- ": nip [ drop ] [ ] bi* ;"
- ": 2nip [ drop ] [ drop ] [ ] tri* ;"
- ""
- ": rot"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": -rot"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": spin"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
} ;
ARTICLE: "spread-combinators" "Spread combinators"
-"The spread combinators apply multiple quotations to multiple values. In this case, " { $snippet "*" } " suffix signify spreading."
+"The spread combinators apply multiple quotations to multiple values. The asterisk (" { $snippet "*" } ") suffixed to these words' names signifies that they are spread combinators."
$nl
"Two quotations:"
{ $subsections bi* 2bi* }
{ $subsections tri* 2tri* }
"An array of quotations:"
{ $subsections spread }
-"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
+"Spread combinators provide a more readable alternative to repeated applications of the " { $link dip } " combinators. The following example using " { $link dip } ":"
{ $code
- "! First alternative; uses dip"
"[ [ 1 + ] dip 1 - ] dip 2 *"
- "! Second alternative: uses tri*"
+}
+"can be more clearly written using " { $link tri* } ":"
+{ $code
"[ 1 + ] [ 1 - ] [ 2 * ] tri*"
}
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-$nl
-{ $subsections "spread-shuffle-equivalence" } ;
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ;
ARTICLE: "apply-combinators" "Apply combinators"
-"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
+"The apply combinators apply a single quotation to multiple values. The asterisk (" { $snippet "*" } ") suffixed to these words' names signifies that they are apply combinators."
$nl
"Two quotations:"
{ $subsections bi@ 2bi@ }
"Three quotations:"
{ $subsections tri@ 2tri@ }
-"A pair of utility words built from " { $link bi@ } ":"
-{ $subsections both? either? } ;
+"A pair of condition words built from " { $link bi@ } " to test two values:"
+{ $subsections both? either? }
+"All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;
-ARTICLE: "retainstack-combinators" "Retain stack combinators"
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
-$nl
-"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
+ARTICLE: "dip-keep-combinators" "Preserving combinators"
+"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:"
{ $subsections dip 2dip 3dip 4dip }
-"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
+"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:"
{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "dataflow-combinators" "Data flow combinators"
-"Data flow combinators pass values between quotations:"
+"Data flow combinators express common dataflow patterns such as performing a operation while preserving its inputs, applying multiple operations to a single value, applying a set of operations to a set of values, or applying a single operation to multiple values."
{ $subsections
- "retainstack-combinators"
+ "dip-keep-combinators"
"cleave-combinators"
"spread-combinators"
"apply-combinators"
}
-{ $see-also "curried-dataflow" } ;
+"More intricate data flow can be constructed by composing " { $link "curried-dataflow" } "." ;
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsections call-effect-unsafe execute-effect-unsafe } ;
ARTICLE: "call" "Fundamental combinators"
-"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
-$nl
-"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
+"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of these fundamental combinators. They differ in whether the compiler is expected to determine the stack effect of the expression at compile time or the stack effect is declared and verified at run time."
$nl
-"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
+{ $heading "Compile-time checked combinators" }
+"With these combinators, the compiler attempts to determine the stack effect of the expression at compile time, rejecting the program if the effect cannot be determined. See " { $link "inference-combinators" } "."
{ $subsections call execute }
-"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
+{ $heading "Run-time checked combinators" }
+"With these combinators, the stack effect of the expression is checked at run time."
{ $subsections POSTPONE: call( POSTPONE: execute( }
-"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
+"Note that the opening parenthesis is actually part of the word name for " { $snippet "call(" } " and " { $snippet "execute(" } "; they are parsing words, and they read a stack effect until the corresponding closing parenthesis. The underlying words are a bit more verbose, but they can be given non-constant stack effects:"
{ $subsections call-effect execute-effect }
-"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
+{ $heading "Unchecked combinators" }
{ $subsections "call-unsafe" }
{ $see-also "effects" "inference" } ;
{ $values { "objs..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
{ $description "Applies each quotation to the object in turn." }
{ $examples
- "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to series of retain stack manipulations:"
+ "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to a nested series of " { $link dip } "s:"
{ $code
"! Equivalent"
"{ [ p ] [ q ] [ r ] [ s ] } spread"
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
-[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
-[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
-[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
-[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
-
! Non-optimizing compiler bugs
[ 1 1 ] [
"A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
HOOK: recompile compiler-impl ( words -- alist )
+HOOK: to-recompile compiler-impl ( -- words )
+
+HOOK: process-forgotten-words compiler-impl ( words -- )
+
! Non-optimizing compiler
-M: f recompile [ dup def>> ] { } map>assoc ;
+M: f recompile
+ [ dup def>> ] { } map>assoc ;
+
+M: f to-recompile
+ changed-definitions get [ drop word? ] assoc-filter
+ changed-generics get assoc-union keys ;
+
+M: f process-forgotten-words drop ;
: without-optimizer ( quot -- )
[ f compiler-impl ] dip with-variable ; inline
! during stage1 bootstrap, it would just waste time.
SINGLETON: dummy-compiler
+M: dummy-compiler to-recompile f ;
+
M: dummy-compiler recompile drop { } ;
+M: dummy-compiler process-forgotten-words drop ;
+
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
definition-observers get push ;
: remove-definition-observer ( obj -- )
- definition-observers get delq ;
+ definition-observers get remove-eq! drop ;
: notify-definition-observers ( assoc -- )
definition-observers get
: compile ( words -- ) recompile modify-code-heap ;
-: index>= ( obj1 obj2 seq -- ? )
- [ index ] curry bi@ >= ;
-
-: dependency>= ( how1 how2 -- ? )
- { called-dependency flushed-dependency inlined-dependency }
- index>= ;
-
-: strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@ [ dependency>= ] most ;
-
-: weakest-dependency ( how1 how2 -- how )
- [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
-
-: compiled-usage ( word -- assoc )
- compiled-crossref get at ;
-
-: (compiled-usages) ( word -- assoc )
- #! If the word is not flushable anymore, we have to recompile
- #! all words which flushable away a call (presumably when the
- #! word was still flushable). If the word is flushable, we
- #! don't have to recompile words that folded this away.
- [ compiled-usage ]
- [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
- [ dependency>= nip ] curry assoc-filter ;
-
-: compiled-usages ( assoc -- assocs )
- [ drop word? ] assoc-filter
- [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
-
-: compiled-generic-usage ( word -- assoc )
- compiled-generic-crossref get at ;
-
-: (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
-
-: compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
-
-: words-only ( assoc -- assoc' )
- [ drop word? ] assoc-filter ;
-
-: to-recompile ( -- seq )
- changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
- append assoc-combine keys ;
-
: process-forgotten-definitions ( -- )
forgotten-definitions get keys
- [ [ word? ] filter [ delete-compiled-xref ] each ]
+ [ [ word? ] filter process-forgotten-words ]
[ [ delete-definition-errors ] each ]
bi ;
{ $see-also "see" } ;
ARTICLE: "definition-checking" "Definition sanity checking"
-"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
+"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } "."
$nl
"The parser also catches forward references when reloading source files. This is best illustrated with an example. Suppose we load a source file " { $snippet "a.factor" } ":"
{ $code
ERROR: no-compilation-unit definition ;
-SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
-
: set-in-unit ( value key assoc -- )
[ set-at ] [ no-compilation-unit ] if* ;
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
- inlined-dependency swap changed-definitions get set-in-unit ;
+ dup changed-definitions get set-in-unit ;
SYMBOL: changed-effects
"(" expect ")" parse-effect ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect ] dip 2array over push-all ;
+ [ ")" parse-effect ] dip 2array append! ;
definitions eval generic generic.math generic.standard
hashtables io io.streams.string kernel layouts math math.order
namespaces parser prettyprint quotations sequences sorting
-strings tools.test vectors words generic.single ;
+strings tools.test vectors words generic.single
+compiler.crossref ;
IN: generic.tests
GENERIC: foobar ( x -- y )
C: <predicate-engine> predicate-engine
-: push-method ( method specializer atomic assoc -- )
+: push-method ( method class atomic assoc -- )
dupd [
[ ] [ H{ } clone <predicate-engine> ] ?if
[ methods>> set-at ] keep
] change-at ;
-: flatten-method ( class method assoc -- )
- [ [ flatten-class keys ] keep ] 2dip [
- [ spin ] dip push-method
- ] 3curry each ;
+: flatten-method ( method class assoc -- )
+ over flatten-class keys
+ [ swap push-method ] with with with each ;
: flatten-methods ( assoc -- assoc' )
- H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+ H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
! 2. Convert methods
: split-methods ( assoc class -- first second )
tuple bootstrap-word
\ <tuple-dispatch-engine> convert-methods ;
-! 2.2 Convert hi-tag methods
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
! 3 Tag methods
TUPLE: tag-dispatch-engine methods ;
: <engine> ( assoc -- engine )
flatten-methods
convert-tuple-methods
- convert-hi-tag-methods
<tag-dispatch-engine> ;
! ! ! Compile engine ! ! !
: direct-dispatch-table ( assoc n -- table )
default get <array> [ <enum> swap update ] keep ;
-: lo-tag-number ( class -- n )
- "type" word-prop dup num-tags get iota member?
- [ drop object tag-number ] unless ;
+: tag-number ( class -- n ) "type" word-prop ;
M: tag-dispatch-engine compile-engine
methods>> compile-engines*
- [ [ lo-tag-number ] dip ] assoc-map
- num-tags get direct-dispatch-table ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n ) "type" word-prop ;
-
-M: hi-tag-dispatch-engine compile-engine
- methods>> compile-engines*
- [ [ hi-tag-number num-tags get - ] dip ] assoc-map
- num-hi-tags direct-dispatch-table ;
+ [ [ tag-number ] dip ] assoc-map
+ num-types get direct-dispatch-table ;
: build-fast-hash ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
M: growable contract ( len seq -- )
[ length ] keep
[ [ 0 ] 2dip set-nth-unsafe ] curry
- (each-integer) ;
+ (each-integer) ; inline
: growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline
] { } make
] unit-test
-[ { "one" "two" 3 } ] [
- { 1 2 3 } clone dup
- H{ { 1 "one" } { 2 "two" } } substitute-here
-] unit-test
-
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
M: hashtable clear-assoc ( hash -- )
- [ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
+ [ init-hash ] [ array>> [ drop ((empty)) ] map! drop ] bi ;
M: hashtable delete-at ( key hash -- )
[ nip ] [ key@ ] 2bi [
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
: >le ( x n -- byte-array ) iota [ nth-byte ] with B{ } map-as ;
-: >be ( x n -- byte-array ) >le dup reverse-here ;
+: >be ( x n -- byte-array ) >le reverse! ;
: d>w/w ( d -- w1 w2 )
[ HEX: ffffffff bitand ]
}
} ;
-HELP: (normalize-path)
+HELP: absolute-path
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " prefix, if present." }
-{ $notes "On Windows NT platforms, this word does not prepend the Unicode path prefix." } ;
+{ $notes "This word is exaclty the same as " { $link normalize-path } ", except on Windows NT platforms, where it does not prepend the Unicode path prefix. Most code should call " { $link normalize-path } " instead." } ;
-HELP: canonicalize-path
+HELP: resolve-symlinks
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
{ $description "Outputs a path where none of the path components are symlinks. This word is useful for determining the actual path on disk where a file is stored; the root of this absolute path is a mount point in the file-system." }
{ $notes "Most code should not need to call this word except in very special circumstances. One use case is finding the actual file-system on which a file is stored." } ;
}
"Literal pathnames:"
{ $subsections POSTPONE: P" }
-"Low-level words:"
-{ $subsections
- normalize-path
- (normalize-path)
- canonicalize-path
-} ;
+"Normalizing pathnames for use with native APIs:"
+{ $subsections normalize-path }
+"Outputting an absolute path from a path:"
+{ $subsection absolute-path }
+"Removing symlinks from a path:"
+{ $subsections resolve-symlinks } ;
ABOUT: "io.pathnames"
"." current-directory set
".." "resource-path" set
[ "../core/bootstrap/stage2.factor" ]
- [ "resource:core/bootstrap/stage2.factor" (normalize-path) ]
+ [ "resource:core/bootstrap/stage2.factor" absolute-path ]
unit-test
] with-scope
: path-components ( path -- seq )
normalize-path path-separator split harvest ;
-HOOK: canonicalize-path os ( path -- path' )
+HOOK: resolve-symlinks os ( path -- path' )
-M: object canonicalize-path normalize-path ;
+M: object resolve-symlinks normalize-path ;
: resource-path ( path -- newpath )
"resource-path" get prepend-path ;
GENERIC: vocab-path ( path -- newpath )
-GENERIC: (normalize-path) ( path -- path' )
+GENERIC: absolute-path ( path -- path' )
-M: string (normalize-path)
+M: string absolute-path
"resource:" ?head [
trim-head-separators resource-path
- (normalize-path)
+ absolute-path
] [
"vocab:" ?head [
trim-head-separators vocab-path
- (normalize-path)
+ absolute-path
] [
current-directory get prepend-path
] if
] if ;
M: object normalize-path ( path -- path' )
- (normalize-path) ;
+ absolute-path ;
TUPLE: pathname string ;
C: <pathname> pathname
-M: pathname (normalize-path) string>> (normalize-path) ;
+M: pathname absolute-path string>> absolute-path ;
M: pathname <=> [ string>> ] compare ;
: read-until-loop ( stream delim -- ch )
over stream-read1 dup [
- dup pick memq? [ 2nip ] [ , read-until-loop ] if
+ dup pick member-eq? [ 2nip ] [ , read-until-loop ] if
] [
2nip
] if ;
: find-sep ( seps stream -- sep/f n )
swap [ >sequence-stream< swap tail-slice ] dip
- [ memq? ] curry find swap ; inline
+ [ member-eq? ] curry find swap ; inline
: sequence-read-until ( separators stream -- seq sep/f )
[ find-sep ] keep
HELP: dup ( x -- x x ) $shuffle ;
HELP: 2dup ( x y -- x y x y ) $shuffle ;
HELP: 3dup ( x y z -- x y z x y z ) $shuffle ;
-HELP: rot ( x y z -- y z x ) $shuffle ;
-HELP: -rot ( x y z -- z x y ) $shuffle ;
-HELP: dupd ( x y -- x x y ) $shuffle ;
-HELP: swapd ( x y z -- y x z ) $shuffle ;
HELP: nip ( x y -- y ) $shuffle ;
HELP: 2nip ( x y z -- z ) $shuffle ;
-HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ;
HELP: 2over $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ;
-HELP: spin $shuffle ;
-HELP: roll $shuffle ;
-HELP: -roll $shuffle ;
+
+HELP: rot ( x y z -- y z x ) $complex-shuffle ;
+HELP: -rot ( x y z -- z x y ) $complex-shuffle ;
+HELP: dupd ( x y -- x x y ) $complex-shuffle ;
+HELP: swapd ( x y z -- y x z ) $complex-shuffle ;
HELP: datastack ( -- ds )
{ $values { "ds" array } }
"[ p ] [ q ] 3bi"
"3dup p q"
}
- "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
- { $code
- "[ p ] [ q ] 3bi"
- "3dup p -roll q"
- }
"In general, the following two lines are equivalent:"
{ $code
"[ p ] [ q ] 3bi"
HELP: tag ( object -- n )
{ $values { "object" object } { "n" "a tag number" } }
-{ $description "Outputs an object's tag number, between zero and one less than " { $link num-tags } ". This is implementation detail and user code should call " { $link class } " instead." } ;
+{ $description "Outputs an object's tag number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
HELP: getenv ( n -- obj )
{ $values { "n" "a non-negative integer" } { "obj" object } }
{ $values { "a" object } { "b" object } }
{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
-ARTICLE: "shuffle-words" "Shuffle words"
-"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
+ARTICLE: "shuffle-words-complex" "Complex shuffle words"
+"These shuffle words tend to make code difficult to read and to reason about. Code that uses them should almost always be rewritten using " { $link "locals" } " or " { $link "dataflow-combinators" } "."
$nl
-"The " { $link "cleave-combinators" } ", " { $link "spread-combinators" } " and " { $link "apply-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
+"Duplicating stack elements deep in the stack:"
+{ $subsections
+ dupd
+}
+"Permuting stack elements deep in the stack:"
+{ $subsections
+ swapd
+ rot
+ -rot
+} ;
+
+ARTICLE: "shuffle-words" "Shuffle words"
+"Shuffle words rearrange items at the top of the data stack as indicated by their stack effects. They provide simple data flow control between words. More complex data flow control is available with the " { $link "dataflow-combinators" } " and with " { $link "locals" } "."
$nl
"Removing stack elements:"
{ $subsections
dup
2dup
3dup
- dupd
over
2over
pick
- tuck
}
"Permuting stack elements:"
{ $subsections
swap
- swapd
- rot
- -rot
- spin
- roll
- -roll
+}
+"There are additional, more complex stack shuffling words whose use is not recommended."
+{ $subsections
+ "shuffle-words-complex"
} ;
ARTICLE: "equality" "Equality"
[ ] [ 10000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
! Make sure we report the correct error on stack underflow
-[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with
+[ clear drop ] [ { "kernel-error" 10 f f } = ] must-fail-with
[ ] [ :c ] unit-test
-[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 13 f f } = ] must-fail-with
+[ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ t "no-compile" set-word-prop ] each
>>
-[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
+[ overflow-d ] [ { "kernel-error" 11 f f } = ] must-fail-with
[ ] [ :c ] unit-test
-[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
+[ overflow-d-alt ] [ { "kernel-error" 11 f f } = ] must-fail-with
[ ] [ [ :c ] with-string-writer drop ] unit-test
-[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
+[ overflow-r ] [ { "kernel-error" 13 f f } = ] must-fail-with
[ ] [ :c ] unit-test
[ -7 <byte-array> ] must-fail
-[ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test
-[ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test
-
[ 3 ] [ t 3 and ] unit-test
[ f ] [ f 3 and ] unit-test
[ f ] [ 3 f and ] unit-test
< [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj -- )
- H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
+ H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ;
[ loop ] must-fail
DEFER: 3dip
! Stack stuff
-: spin ( x y z -- z y x ) swap rot ; inline
-
-: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline
-
-: -roll ( x y z t -- t x y z ) swap [ -rot ] dip ; inline
-
: 2over ( x y z -- x y z x y ) pick pick ; inline
: clear ( -- ) { } set-datastack ;
: dip ( x quot -- x ) swap [ call ] dip ;
-: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ;
+: 2dip ( x y quot -- x y ) swap [ dip ] dip ;
-: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ;
+: 3dip ( x y z quot -- x y z ) swap [ 2dip ] dip ;
: 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
: declare ( spec -- ) drop ;
-: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
-
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
{ $var-description "Number of least significant bits reserved for a type tag in a tagged pointer." }
{ $see-also tag } ;
-HELP: num-tags
-{ $var-description "Number of distinct pointer tags. This is one more than the maximum value from the " { $link tag } " primitive." } ;
-
HELP: tag-mask
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
-
-HELP: tag-number
-{ $values { "class" class } { "n" "an integer or " { $link f } } }
-{ $description "Outputs the pointer tag for pointers to instances of " { $link class } ". Will output " { $link f } " if instances of this class are not identified by a distinct pointer tag." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link tag } " primitive." } ;
HELP: type-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsections hi-tag }
+{ $subsections tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsections
type>class
ARTICLE: "layouts-tags" "Tagged pointers"
"Every pointer stored on the stack or in the heap has a " { $emphasis "tag" } ", which is a small integer identifying the type of the pointer. If the tag is not equal to one of the two special tags, the remaining bits contain the memory address of a heap-allocated object. The two special tags are the " { $link fixnum } " tag and the " { $link f } " tag."
$nl
-"Getting the tag of an object:"
-{ $link tag }
"Words for working with tagged pointers:"
{ $subsections
tag-bits
- num-tags
tag-mask
- tag-number
}
"The Factor VM does not actually expose any words for working with tagged pointers directly. The above words operate on integers; they are used in the bootstrap image generator and the optimizing compiler." ;
math.order kernel.private ;
IN: layouts
-SYMBOL: tag-mask
+SYMBOL: data-alignment
-SYMBOL: num-tags
+SYMBOL: tag-mask
SYMBOL: tag-bits
SYMBOL: num-types
-SYMBOL: tag-numbers
-
SYMBOL: type-numbers
SYMBOL: mega-cache-size
: type-number ( class -- n )
type-numbers get at ;
-: tag-number ( class -- n )
- type-number dup num-tags get >= [ drop object tag-number ] when ;
-
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
first-bignum neg >fixnum ; inline
: (max-array-capacity) ( b -- n )
- 5 - 2^ 1 - ; inline
+ 6 - 2^ 1 - ; inline
: max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline
ARTICLE: "integers" "Integers"
{ $subsections integer }
"Integers come in two varieties -- fixnums and bignums. Fixnums fit in a machine word and are faster to manipulate; if the result of a fixnum operation is too large to fit in a fixnum, the result is upgraded to a bignum. Here is an example where two fixnums are multiplied yielding a bignum:"
-{ $example "USE: classes" "134217728 class ." "fixnum" }
+{ $example "USE: classes" "67108864 class ." "fixnum" }
{ $example "USE: classes" "128 class ." "fixnum" }
{ $example "134217728 128 * ." "17179869184" }
{ $example "USE: classes" "1 128 shift class ." "bignum" }
[ -1 ] [ 1 neg ] unit-test
[ -1 ] [ 1 >bignum neg ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 * ] unit-test
-[ 268435456 ] [ -268435456 >fixnum neg ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 * ] unit-test
+[ 134217728 ] [ -134217728 >fixnum neg ] unit-test
[ 9 3 ] [ 93 10 /mod ] unit-test
[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
[ 16 ] [ 13 next-power-of-2 ] unit-test
[ 16 ] [ 16 next-power-of-2 ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
-[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
-[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 134217728 ] [ -134217728 >fixnum -1 /i ] unit-test
+[ 134217728 0 ] [ -134217728 >fixnum -1 /mod ] unit-test
+[ 0 ] [ -1 -134217728 >fixnum /i ] unit-test
[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
-[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
-[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
+[ 0 -1 ] [ -1 -134217728 >fixnum /mod ] unit-test
+[ 0 -1 ] [ -1 -134217728 >bignum /mod ] unit-test
[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
[ f ] [ 30 zero? ] unit-test
[ t ] [ 0 >bignum zero? ] unit-test
-[ 4294967280 ] [ 268435455 >fixnum 16 fixnum* ] unit-test
+[ 2147483632 ] [ 134217727 >fixnum 16 fixnum* ] unit-test
[ 23603949310011464311086123800853779733506160743636399259558684142844552151041 ]
[
[ 4294967296 ] [ 1 32 shift ] unit-test
[ 1267650600228229401496703205376 ] [ 1 100 shift ] unit-test
-[ t ] [ 1 27 shift fixnum? ] unit-test
+[ t ] [ 1 26 shift fixnum? ] unit-test
[ t ] [
t
[ >float / ] [ /f ] 2bi 0.1 ~
] all?
] unit-test
+
+! Ensure that /f is accurate for fixnums > 2^53 on 64-bit platforms
+[ HEX: 1.758bec11492f9p-54 ] [ 1 12345678901234567 /f ] unit-test
+[ HEX: -1.758bec11492f9p-54 ] [ 1 -12345678901234567 /f ] unit-test
M: fixnum - fixnum- ; inline
M: fixnum * fixnum* ; inline
M: fixnum /i fixnum/i ; inline
-M: fixnum /f [ >float ] dip >float float/f ; inline
+
+DEFER: bignum/f
+CONSTANT: bignum/f-threshold HEX: 20,0000,0000,0000
+
+: fixnum/f ( m n -- m/n )
+ [ >float ] bi@ float/f ; inline
+
+M: fixnum /f
+ 2dup [ abs bignum/f-threshold >= ] either?
+ [ bignum/f ] [ fixnum/f ] if ; inline
M: fixnum mod fixnum-mod ; inline
] if-zero
] if ; inline
-M: bignum /f ( m n -- f )
+: bignum/f ( m n -- f )
[ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;
+
+M: bignum /f ( m n -- f )
+ bignum/f ;
: (find-integer) ( i n quot: ( i -- ? ) -- i )
[
- iterate-step roll
- [ 2drop ] [ iterate-next (find-integer) ] if
+ iterate-step
+ [ [ ] ] 2dip
+ [ iterate-next (find-integer) ] 2curry bi-curry if
] [ 3drop f ] if-iterate? ; inline recursive
: (all-integers?) ( i n quot: ( i -- ? ) -- ? )
[
- iterate-step roll
- [ iterate-next (all-integers?) ] [ 3drop f ] if
+ iterate-step
+ [ iterate-next (all-integers?) ] 3curry
+ [ f ] if
] [ 3drop t ] if-iterate? ; inline recursive
: each-integer ( n quot -- )
0 over push B{ } like (string>float) ;
: hex>float-parts ( str -- neg? mantissa-str expt )
- "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
+ "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; inline
: make-mantissa ( str -- bits )
- 16 base> dup log2 52 swap - shift ;
+ 16 base> dup log2 52 swap - shift ; inline
: combine-hex-float-parts ( neg? mantissa expt -- float )
dup 2046 > [ 2drop -1/0. 1/0. ? ] [
[ 52 2^ 1 - bitand ]
[ 52 shift ] tri* bitor bitor
bits>double
- ] if ;
+ ] if ; inline
: hex>float ( str -- n/f )
hex>float-parts
: positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when
[ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
- dup reverse-here ; inline
-
-PRIVATE>
+ reverse! ; inline
GENERIC# >base 1 ( n radix -- str )
quotations math ;
IN: memory
-HELP: begin-scan ( -- )
-{ $description "Disables the garbage collector and resets the heap scan pointer to point at the first object in the heap. The " { $link next-object } " word can then be called to advance the heap scan pointer and return successive objects."
-$nl
-"This word must always be paired with a call to " { $link end-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: next-object ( -- obj )
-{ $values { "obj" object } }
-{ $description "Outputs the object at the heap scan pointer, and then advances the heap scan pointer. If the end of the heap has been reached, outputs " { $link f } ". This is unambiguous since the " { $link f } " object is tagged immediate and not actually stored in the heap." }
-{ $errors "Throws a " { $link heap-scan-error. } " if called outside a " { $link begin-scan } "/" { $link end-scan } " pair." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: end-scan ( -- )
-{ $description "Finishes a heap iteration by re-enabling the garbage collector. This word must always be paired with a call to " { $link begin-scan } "." }
-{ $notes "This is a low-level facility and can be dangerous. Use the " { $link each-object } " combinator instead." } ;
-
-HELP: each-object
-{ $values { "quot" { $quotation "( obj -- )" } } }
-{ $description "Applies a quotation to each object in the heap. The garbage collector is switched off while this combinator runs, so the given quotation must not allocate too much memory." }
-{ $notes "This word is the low-level facility used to implement the " { $link instances } " word." } ;
-
HELP: instances
{ $values { "quot" { $quotation "( obj -- ? )" } } { "seq" "a fresh sequence" } }
-{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
-{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
+{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." } ;
HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: data-room ( -- cards decks generations )
-{ $values { "cards" "number of kilobytes reserved for card marking" } { "decks" "number of kilobytes reserved for decks of cards" } { "generations" "array of free/total kilobytes pairs" } }
-{ $description "Queries the runtime for memory usage information." } ;
+HELP: data-room ( -- data-room )
+{ $values { "data-room" data-room } }
+{ $description "Queries the VM for memory usage information." } ;
-HELP: code-room ( -- code-total code-used code-free largest-free-block )
-{ $values { "code-total" "total kilobytes in the code heap" } { "code-used" "kilobytes used in the code heap" } { "code-free" "kilobytes free in the code heap" } { "largest-free-block" "size of largest free block" } }
-{ $description "Queries the runtime for memory usage information." } ;
+HELP: code-room ( -- code-room )
+{ $values { "code-room" code-room } }
+{ $description "Queries the VM for memory usage information." } ;
HELP: size ( obj -- n )
{ $values { "obj" "an object" } { "n" "a size in bytes" } }
HELP: save
{ $description "Saves a snapshot of the heap to the current image file." } ;
-HELP: count-instances
-{ $values
- { "quot" quotation }
- { "n" integer } }
-{ $description "Applies the predicate quotation to each object in the heap and returns the number of objects that match. Since this word uses " { $link each-object } " with the garbage collector switched off, avoid allocating too much memory in the quotation." }
-{ $examples { $unchecked-example
- "USING: memory words prettyprint ;"
- "[ word? ] count-instances ."
- "24210"
-} } ;
-
ARTICLE: "images" "Images"
"Factor has the ability to save the entire state of the system into an " { $emphasis "image file" } ". The image contains a complete dump of all data and code in the current Factor instance."
{ $subsections
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences vectors arrays system math
+USING: kernel continuations sequences system
io.backend alien.strings memory.private ;
IN: memory
-: (each-object) ( quot: ( obj -- ) -- )
- next-object dup [
- swap [ call ] keep (each-object)
- ] [ 2drop ] if ; inline recursive
-
-: each-object ( quot -- )
- gc begin-scan [ (each-object) ] [ end-scan ] [ ] cleanup ; inline
-
-: count-instances ( quot -- n )
- 0 swap [ 1 0 ? + ] compose each-object ; inline
-
: instances ( quot -- seq )
- #! To ensure we don't need to grow the vector while scanning
- #! the heap, we do two scans, the first one just counts the
- #! number of objects that satisfy the predicate.
- [ count-instances 100 + <vector> ] keep swap
- [ [ push-if ] 2curry each-object ] keep >array ; inline
+ [ all-instances ] dip filter ; inline
: save-image ( path -- )
normalize-path native-string>alien (save-image) ;
ndrop
} ;
-ARTICLE: "namespaces" "Dynamic variables and namespaces"
-"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
+ARTICLE: "namespaces" "Dynamic variables"
+"The " { $vocab-link "namespaces" } " vocabulary implements dynamically-scoped variables."
$nl
-"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")."
+"A dynamic variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assocs, any object can be used as a variable. By convention, variables are keyed by " { $link "words.symbol" } "."
$nl
-"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches up the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope."
+"The " { $link get } " and " { $link set } " words read and write variable values. The " { $link get } " word searches the chain of nested namespaces, while " { $link set } " always sets variable values in the current namespace only. Namespaces are dynamically scoped; when a quotation is called from a nested scope, any words called by the quotation also execute in that scope."
{ $subsections
get
set
}
-"Various utility words abstract away common variable access patterns:"
+"Various utility words provide common variable access patterns:"
{ $subsections
"namespaces-change"
"namespaces-combinators"
}
"Implementation details your code probably does not care about:"
{ $subsections "namespaces.private" }
-"An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ;
+"Dynamic variables complement " { $link "locals" } "." ;
ABOUT: "namespaces"
$nl
"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can."
$nl
-"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later."
+"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link suffix! } " to add the data to the parse tree so that it can be evaluated later."
$nl
"Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:"
{ $subsections staging-violation }
{ parse-tokens (parse-until) parse-until } related-words
-HELP: parsed
-{ $values { "accum" vector } { "obj" object } }
-{ $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." }
-$parsing-note ;
-
HELP: (parse-lines)
{ $values { "lexer" lexer } { "quot" "a new " { $link quotation } } }
{ $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." }
{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
-{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
+{ $description "Forgets removed definitions." } ;
HELP: finish-parsing
{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } }
] unit-test
[ t ] [
- array "smudge-me" "parser.tests" lookup order memq?
+ array "smudge-me" "parser.tests" lookup order member-eq?
] unit-test
[ t ] [
- integer "smudge-me" "parser.tests" lookup order memq?
+ integer "smudge-me" "parser.tests" lookup order member-eq?
] unit-test
[ f ] [
- string "smudge-me" "parser.tests" lookup order memq?
+ string "smudge-me" "parser.tests" lookup order member-eq?
] unit-test
[ ] [
M: f parse-quotation \ ] parse-until >quotation ;
-: parsed ( accum obj -- accum ) over push ;
-
: (parse-lines) ( lexer -- quot )
[ f parse-until >quotation ] with-lexer ;
lexer-factory get call( lines -- lexer ) (parse-lines) ;
: parse-literal ( accum end quot -- accum )
- [ parse-until ] dip call parsed ; inline
+ [ parse-until ] dip call suffix! ; inline
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
scan swap base> [ bad-number ] unless* ;
: parse-base ( parsed base -- parsed )
- scan-base parsed ;
+ scan-base suffix! ;
SYMBOL: bootstrap-syntax
IN: quotations
ARTICLE: "quotations" "Quotations"
-"Conceptually, a quotation is an anonymous function (a value denoting a snippet of code) which can be passed around and called."
+"A quotation is an anonymous function (a value denoting a snippet of code) which can be used as a value and called. Quotations are delimited by square brackets (" { $snippet "[ ]" } "); see " { $link "syntax-quots" } " for details on their syntax."
$nl
-"Concretely, a quotation is an immutable sequence of objects, some of which may be words, together with a block of machine code which may be executed to achieve the effect of evaluating the quotation. The machine code is generated by a fast non-optimizing quotation compiler which is always running and is transparent to the developer."
-$nl
-"Quotations form a class of objects, however in most cases, methods should dispatch on " { $link callable } " instead, so that " { $link curry } " and " { $link compose } " values can participate."
+"Quotations form a class of objects:"
{ $subsections
quotation
quotation?
}
-"Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } "."
-$nl
-"Quotation literal syntax is documented in " { $link "syntax-quots" } "."
-$nl
+"A more general class is provided for methods to dispatch on that includes quotations, " { $link curry } ", and " { $link compose } " objects:"
+{ $subsections
+ callable
+}
+"Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } ". Words can be placed in wrappers to suppress execution:"
+{ $subsections "wrappers" }
"Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:"
{ $subsections
>quotation
1quotation
}
-"Wrappers:"
-{ $subsections "wrappers" } ;
+"Although quotations can be treated as sequences, the compiler will be unable to reason about quotations manipulated as sequences at runtime. " { $link "compositional-combinators" } " are provided for runtime partial application and composition of quotations." ;
ARTICLE: "wrappers" "Wrappers"
-"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
+"Wrappers evaluate to the object being wrapped when encountered in code. They are are used to suppress the execution of " { $link "words" } " so that they can be used as values."
{ $subsections
wrapper
literalize
M: compose length
[ first>> length ] [ second>> length ] bi + ;
-M: compose virtual-seq first>> ;
+M: compose virtual-exemplar first>> ;
M: compose virtual@
2dup first>> length < [
{ $values
{ "indices" sequence } { "seq" sequence }
{ "seq'" sequence } }
-{ $description "Ouptuts a sequence of elements from the input sequence indexed by the indices." }
+{ $description "Outputs a sequence of elements from the input sequence indexed by the indices." }
{ $examples
{ $example "USING: prettyprint sequences ;"
"{ 0 2 } { \"a\" \"b\" \"c\" } nths ."
{ $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate . ." "{ 0 2 4 6 8 }\n10" }
} ;
+HELP: accumulate!
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "seq" sequence } }
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs the original sequence of intermediate results, together with the final result."
+$nl
+"The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
+$nl
+"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
+{ $examples
+ { $example "USING: math prettyprint sequences ;" "{ 2 2 2 2 2 } 0 [ + ] accumulate! . ." "{ 0 2 4 6 8 }\n10" }
+} ;
+
HELP: map
{ $values { "seq" sequence } { "quot" { $quotation "( 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." } ;
{ $errors "Throws an error if the sequence is immutable, if the index is out of bounds, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
-HELP: change-each
-{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } }
-{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence." }
+HELP: map!
+{ $values { "seq" "a mutable sequence" } { "quot" { $quotation "( old -- new )" } } { "seq" "a mutable sequence" } }
+{ $description "Applies the quotation to each element yielding a new element, storing the new elements back in the original sequence. Returns the original sequence." }
{ $errors "Throws an error if the sequence is immutable, or the sequence cannot hold elements of the type output by " { $snippet "quot" } "." }
{ $side-effects "seq" } ;
{ $values { "seq" sequence } { "quot" { $quotation "( elt -- ? )" } } { "exemplar" sequence } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence of the same type as " { $snippet "exemplar" } " containing the elements of the original sequence for which the quotation output a true value." } ;
-HELP: filter-here
-{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } }
+HELP: filter!
+{ $values { "seq" "a resizable mutable sequence" } { "quot" { $quotation "( elt -- ? )" } } { "seq" "a resizable mutable sequence" } }
{ $description "Applies the quotation to each element in turn, and removes elements for which the quotation outputs a false value." }
{ $side-effects "seq" } ;
{ $description "Tests if the sequence contains an element equal to the object." }
{ $notes "This word uses equality comparison (" { $link = } ")." } ;
-HELP: memq?
+HELP: member-eq?
{ $values { "elt" object } { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests if the sequence contains the object." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
{ $description "Outputs a new sequence containing all elements of the input sequence except for given element." }
{ $notes "This word uses equality comparison (" { $link = } ")." } ;
-HELP: remq
+HELP: remove-eq
{ $values { "elt" object } { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except those equal to the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." } ;
{ $description "Sets the element with index " { $snippet "m" } " to the element with index " { $snippet "n" } "." }
{ $side-effects "seq" } ;
-HELP: delete
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
-{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } "." }
+HELP: remove!
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "elt" object } }
+{ $description "Removes all elements equal to " { $snippet "elt" } " from " { $snippet "seq" } " and returns " { $snippet "seq" } "." }
{ $notes "This word uses equality comparison (" { $link = } ")." }
{ $side-effects "seq" } ;
-HELP: delq
-{ $values { "elt" object } { "seq" "a resizable mutable sequence" } }
+HELP: remove-eq!
+{ $values { "elt" object } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
{ $description "Outputs a new sequence containing all elements of the input sequence except the given element." }
{ $notes "This word uses identity comparison (" { $link eq? } ")." }
{ $side-effects "seq" } ;
-HELP: delete-nth
-{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } }
+HELP: remove-nth!
+{ $values { "n" "a non-negative integer" } { "seq" "a resizable mutable sequence" } { "seq" "a resizable mutable sequence" } }
{ $description "Removes the " { $snippet "n" } "th element from the sequence, shifting all other elements down and reducing its length by one." }
{ $side-effects "seq" } ;
{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
} ;
+HELP: suffix!
+{ $values { "seq" sequence } { "elt" object } { "seq" sequence } }
+{ $description "Modifiers a sequence in-place by adding " { $snippet "elt" } " to the end of " { $snippet "seq" } ". Outputs " { $snippet "seq" } "." }
+{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences ;" "V{ 1 2 3 } 4 suffix! ." "V{ 1 2 3 4 }" }
+} ;
+
+HELP: append!
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq1" sequence } }
+{ $description "Modifiers " { $snippet "seq1" } " in-place by adding the elements from " { $snippet "seq2" } " to the end and outputs " { $snippet "seq1" } "." }
+{ $examples
+ { $example "USING: prettyprint sequences ;" "V{ 1 2 3 } { 4 5 6 } append! ." "V{ 1 2 3 4 5 6 }" }
+} ;
+
HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $values { "m" "a non-negative integer" } { "n" "a non-negative integer" } { "seq" "a mutable sequence" } }
{ $description "Exchanges the " { $snippet "m" } "th and " { $snippet "n" } "th elements of " { $snippet "seq" } "." } ;
-HELP: reverse-here
+HELP: reverse!
{ $values { "seq" "a mutable sequence" } }
-{ $description "Reverses a sequence in-place." }
+{ $description "Reverses a sequence in-place and outputs that sequence." }
{ $side-effects "seq" } ;
HELP: padding
{ $values { "seq" sequence } { "newseq" "a new sequence" } }
{ $description "Outputs a new sequence having the same elements as " { $snippet "seq" } " but in reverse order." } ;
-{ reverse <reversed> reverse-here } related-words
+{ reverse <reversed> reverse! } related-words
HELP: <reversed>
{ $values { "seq" sequence } { "reversed" "a new sequence" } }
{ $values { "seq" sequence } { "end" sequence } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq" } " ends with " { $snippet "end" } ". If " { $snippet "end" } " is longer than " { $snippet "seq" } ", this word outputs " { $link f } "." } ;
-{ remove remove-nth remq delq delete delete-nth } related-words
+{ remove remove-nth remove-eq remove-eq! remove! remove-nth! } related-words
HELP: cut-slice
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "before-slice" sequence } { "after-slice" "a slice" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
{ $examples "See " { $link produce } " for examples." } ;
-HELP: sigma
+HELP: map-sum
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
{ $example
- "! Find the sum of the squares [0,99]"
"USING: math math.ranges sequences prettyprint ;"
- "100 [1,b] [ sq ] sigma ."
+ "100 [1,b] [ sq ] map-sum ."
"338350"
} ;
}
} ;
-{ filter filter-here sift harvest } related-words
+{ filter filter! sift harvest } related-words
HELP: set-first
{ $values
}
} ;
-HELP: virtual-seq
+HELP: virtual-exemplar
{ $values
{ "seq" sequence }
{ "seq'" sequence } }
-{ $description "Part of the virtual sequence protocol, this word is used to return an underlying array from which to look up a value at an index given by " { $link virtual@ } "." } ;
+{ $description "Part of the virtual sequence protocol, this word is used to return an exemplar of the underlying storage. This is used in words like " { $link new-sequence } "." } ;
HELP: virtual@
{ $values
{ "n" integer } { "seq" sequence }
{ "n'" integer } { "seq'" sequence } }
-{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index into the underlying storage returned by " { $link virtual-seq } "." } ;
+{ $description "Part of the sequence protocol, this word translates the input index " { $snippet "n" } " into an index and the underlying storage this index points into." } ;
HELP: 2map-reduce
{ $values
ARTICLE: "virtual-sequences-protocol" "Virtual sequence protocol"
"Virtual sequences must know their length:"
{ $subsections length }
-"The underlying sequence to look up a value in:"
-{ $subsections virtual-seq }
-"The index of the value in the underlying sequence:"
+"An exemplar of the underlying storage:"
+{ $subsections virtual-exemplar }
+"The index and the underlying storage where the value is located:"
{ $subsections virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
"Adding elements:"
{ $subsections prefix suffix insert-nth }
"Removing elements:"
-{ $subsections remove remq remove-nth } ;
+{ $subsections remove remove-eq remove-nth } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
map-reduce
accumulate
accumulate-as
+ accumulate!
produce
produce-as
}
"Testing indices:"
{ $subsections bounds-check? }
"Testing if a sequence contains an object:"
-{ $subsections member? memq? }
+{ $subsections member? member-eq? }
"Testing if a sequence contains a subsequence:"
{ $subsections head? tail? subseq? } ;
{ $subsections trim-slice trim-head-slice trim-tail-slice } ;
ARTICLE: "sequences-destructive-discussion" "When to use destructive operations"
-"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more re-usable and easier to reason about. There are two main reasons to use destructive operations:"
+"Constructive (non-destructive) operations should be preferred where possible because code without side-effects is usually more reusable and easier to reason about. There are two main reasons to use destructive operations:"
{ $list
"For the side-effect. Some code is simpler to express with destructive operations; constructive operations return new objects, and sometimes ``threading'' the objects through the program manually complicates stack shuffling."
- { "As an optimization. Some code can be written to use constructive operations, however would suffer from worse performance. An example is a loop which adds an element to a sequence on each iteration; one could use either " { $link suffix } " or " { $link push } ", however the former copies the entire sequence first, which would cause the loop to run in quadratic time." }
+ { "As an optimization. Some code written to use constructive operations suffers from worse performance. An example is a loop which adds an element to a sequence on each iteration. Either " { $link suffix } " or " { $link suffix! } " could be used; however, the former copies the entire sequence each time, which would cause the loop to run in quadratic time." }
}
"The second reason is much weaker than the first one. In particular, many combinators (see " { $link map } ", " { $link produce } " and " { $link "namespaces-make" } ") as well as more advanced data structures (such as " { $vocab-link "persistent.vectors" } ") alleviate the need for explicit use of side effects." ;
ARTICLE: "sequences-destructive" "Destructive operations"
+"Many operations have constructive and destructive variants:"
+{ $table
+ { "Constructive" "Destructive" }
+ { { $link suffix } { $link suffix! } }
+ { { $link remove } { $link remove! } }
+ { { $link remove-eq } { $link remove-eq! } }
+ { { $link remove-nth } { $link remove-nth! } }
+ { { $link reverse } { $link reverse! } }
+ { { $link append } { $link append! } }
+ { { $link map } { $link map! } }
+ { { $link filter } { $link filter! } }
+}
"Changing elements:"
-{ $subsections change-each change-nth }
+{ $subsections map! change-nth }
"Deleting elements:"
{ $subsections
- delete
- delq
- delete-nth
+ remove!
+ remove-eq!
+ remove-nth!
delete-slice
delete-all
- filter-here
+ filter!
}
"Other destructive words:"
{ $subsections
- reverse-here
- push-all
+ reverse!
+ append!
move
exchange
copy
}
-"Many operations have constructive and destructive variants:"
-{ $table
- { "Constructive" "Destructive" }
- { { $link suffix } { $link push } }
- { { $link but-last } { $link pop* } }
- { { $link unclip-last } { $link pop } }
- { { $link remove } { $link delete } }
- { { $link remq } { $link delq } }
- { { $link remove-nth } { $link delete-nth } }
- { { $link reverse } { $link reverse-here } }
- { { $link append } { $link push-all } }
- { { $link map } { $link change-each } }
- { { $link filter } { $link filter-here } }
-}
{ $heading "Related Articles" }
{ $subsections
"sequences-destructive-discussion"
"sequences-stacks"
}
-{ $see-also set-nth push pop } ;
+{ $see-also set-nth push push-all pop pop* } ;
ARTICLE: "sequences-stacks" "Treating sequences as stacks"
"The classical stack operations, modifying a sequence in place:"
-{ $subsections push pop pop* }
+{ $subsections push push-all pop pop* }
{ $see-also empty? } ;
ARTICLE: "sequences-comparing" "Comparing sequences"
[ 5040 { 1 1 2 6 24 120 720 } ]
[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate ] unit-test
+[ 5040 { 1 1 2 6 24 120 720 } ]
+[ { 1 2 3 4 5 6 7 } 1 [ * ] accumulate! ] unit-test
+
+[ t ]
+[ { 1 2 3 4 5 6 7 } dup 1 [ * ] accumulate! nip eq? ] unit-test
+
[ f f ] [ [ ] [ ] find ] unit-test
[ 0 1 ] [ [ 1 ] [ ] find ] unit-test
[ 1 "world" ] [ [ "hello" "world" ] [ "world" = ] find ] unit-test
[ t ] [ 2 [ 1 2 ] member? ] unit-test
[ t ]
-[ [ "hello" "world" ] [ second ] keep memq? ] unit-test
+[ [ "hello" "world" ] [ second ] keep member-eq? ] unit-test
[ 4 ] [ CHAR: x "tuvwxyz" >vector index ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 [ swap < ] curry filter ] unit-test
-[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 4 < ] filter-here ] keep ] unit-test
-[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ [ 2 mod 0 = ] filter-here ] keep ] unit-test
+[ V{ 1 2 3 } ] [ V{ 1 4 2 5 3 6 } clone [ 4 < ] filter! ] unit-test
+[ V{ 4 2 6 } ] [ V{ 1 4 2 5 3 6 } clone [ 2 mod 0 = ] filter! ] unit-test
-[ V{ 3 } ] [ V{ 1 2 3 } clone [ 2 [ swap < ] curry filter-here ] keep ] unit-test
+[ V{ 3 } ] [ V{ 1 2 3 } clone 2 [ swap < ] curry filter! ] unit-test
[ "hello world how are you" ]
[ { "hello" "world" "how" "are" "you" } " " join ]
[ 4 [ CHAR: a <string> ] map ]
unit-test
-[ V{ } ] [ "f" V{ } clone [ delete ] keep ] unit-test
-[ V{ } ] [ "f" V{ "f" } clone [ delete ] keep ] unit-test
-[ V{ } ] [ "f" V{ "f" "f" } clone [ delete ] keep ] unit-test
-[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone [ delete ] keep ] unit-test
-[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone [ delete ] keep ] unit-test
+[ V{ } ] [ "f" V{ } clone remove! ] unit-test
+[ V{ } ] [ "f" V{ "f" } clone remove! ] unit-test
+[ V{ } ] [ "f" V{ "f" "f" } clone remove! ] unit-test
+[ V{ "x" } ] [ "f" V{ "f" "x" "f" } clone remove! ] unit-test
+[ V{ "y" "x" } ] [ "f" V{ "y" "f" "x" "f" } clone remove! ] unit-test
[ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test
{ "a" } 0 2 { 1 2 3 } replace-slice
] unit-test
-[ { 1 4 9 } ] [ { 1 2 3 } clone dup [ sq ] change-each ] unit-test
+[ { 1 4 9 } ] [ { 1 2 3 } clone [ sq ] map! ] unit-test
[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
[ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test
[ 10 "hi" "bye" copy ] must-fail
[ V{ 1 2 3 5 6 } ] [
- 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep
+ 3 V{ 1 2 3 4 5 6 } clone remove-nth!
] unit-test
! erg's random tester found this one
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
-[ -1/0. 0 delete-nth ] must-fail
+[ -1/0. 0 remove-nth! ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-head ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-tail ] unit-test
-[ 328350 ] [ 100 [ sq ] sigma ] unit-test
+[ 328350 ] [ 100 [ sq ] map-sum ] unit-test
[ 50 ] [ 100 [ even? ] count ] unit-test
[ 50 ] [ 100 [ odd? ] count ] unit-test
4 swap [ (4sequence) ] new-like ; inline
: first2 ( seq -- first second )
- 1 swap bounds-check nip first2-unsafe ; flushable
+ 1 swap bounds-check nip first2-unsafe ; inline
: first3 ( seq -- first second third )
- 2 swap bounds-check nip first3-unsafe ; flushable
+ 2 swap bounds-check nip first3-unsafe ; inline
: first4 ( seq -- first second third fourth )
- 3 swap bounds-check nip first4-unsafe ; flushable
+ 3 swap bounds-check nip first4-unsafe ; inline
: ?nth ( n seq -- elt/f )
2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
MIXIN: virtual-sequence
-GENERIC: virtual-seq ( seq -- seq' )
+GENERIC: virtual-exemplar ( seq -- seq' )
GENERIC: virtual@ ( n seq -- n' seq' )
M: virtual-sequence nth virtual@ nth ; inline
M: virtual-sequence set-nth virtual@ set-nth ; inline
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ; inline
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ; inline
-M: virtual-sequence like virtual-seq like ; inline
-M: virtual-sequence new-sequence virtual-seq new-sequence ; inline
+M: virtual-sequence like virtual-exemplar like ; inline
+M: virtual-sequence new-sequence virtual-exemplar new-sequence ; inline
INSTANCE: virtual-sequence sequence
C: <reversed> reversed
-M: reversed virtual-seq seq>> ; inline
+M: reversed virtual-exemplar seq>> ; inline
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ; inline
M: reversed length seq>> length ; inline
check-slice
slice boa ; inline
-M: slice virtual-seq seq>> ; inline
+M: slice virtual-exemplar seq>> ; inline
M: slice virtual@ [ from>> + ] [ seq>> ] bi ; inline
ERROR: integer-length-expected obj ;
: check-length ( n -- n )
- #! Ricing.
dup integer? [ integer-length-expected ] unless ; inline
-: ((copy)) ( dst i src j n -- dst i src j n )
- dup -roll [
- + swap nth-unsafe -roll [
- + swap set-nth-unsafe
- ] 3keep drop
- ] 3keep ; inline
+TUPLE: copy-state
+ { src-i read-only }
+ { src read-only }
+ { dst-i read-only }
+ { dst read-only } ;
-: (copy) ( dst i src j n -- dst )
- dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
+C: <copy> copy-state
+
+: ((copy)) ( n copy -- )
+ [ [ src-i>> + ] [ src>> ] bi nth-unsafe ]
+ [ [ dst-i>> + ] [ dst>> ] bi set-nth-unsafe ] 2bi ; inline
+
+: (copy) ( n copy -- dst )
+ over 0 <= [ nip dst>> ] [ [ 1 - ] dip [ ((copy)) ] [ (copy) ] 2bi ] if ;
inline recursive
-: prepare-subseq ( from to seq -- dst i src j n )
- #! The check-length call forces partial dispatch
- [ [ swap - ] dip new-sequence dup 0 ] 3keep
- -rot drop roll length check-length ; inline
+: subseq>copy ( from to seq -- n copy )
+ [ over - check-length swap ] dip
+ 3dup nip new-sequence 0 swap <copy> ; inline
-: check-copy ( src n dst -- )
- over 0 < [ bounds-error ] when
+: check-copy ( src n dst -- src n dst )
+ 3dup over 0 < [ bounds-error ] when
[ swap length + ] dip lengthen ; inline
PRIVATE>
: subseq ( from to seq -- subseq )
- [ check-slice prepare-subseq (copy) ] keep like ;
+ [ check-slice subseq>copy (copy) ] keep like ;
: head ( seq n -- headseq ) (head) subseq ;
: copy ( src i dst -- )
#! The check-length call forces partial dispatch
- pick length check-length [ 3dup check-copy spin 0 ] dip
- (copy) drop ; inline
+ [ [ length check-length 0 ] keep ] 2dip
+ check-copy <copy> (copy) drop ; inline
M: sequence clone-like
[ dup length ] dip new-sequence [ 0 swap copy ] keep ; inline
: replicate-as ( seq quot exemplar -- newseq )
[ [ drop ] prepose ] dip map-as ; inline
-: change-each ( seq quot -- )
- over map-into ; inline
+: map! ( seq quot -- seq )
+ over [ map-into ] keep ; inline
+
+: (accumulate) ( seq identity quot -- seq identity quot )
+ [ swap ] dip [ curry keep ] curry ; inline
: accumulate-as ( seq identity quot exemplar -- final newseq )
- [ [ swap ] dip [ curry keep ] curry ] dip map-as ; inline
+ [ (accumulate) ] dip map-as ; inline
: accumulate ( seq identity quot -- final newseq )
{ } accumulate-as ; inline
+: accumulate! ( seq identity quot -- final seq )
+ (accumulate) map! ; inline
+
: 2each ( seq1 seq2 quot -- )
(2each) each-integer ; inline
: member? ( elt seq -- ? )
[ = ] with any? ;
-: memq? ( elt seq -- ? )
+: member-eq? ( elt seq -- ? )
[ eq? ] with any? ;
: remove ( elt seq -- newseq )
[ = not ] with filter ;
-: remq ( elt seq -- newseq )
+: remove-eq ( elt seq -- newseq )
[ eq? not ] with filter ;
: sift ( seq -- newseq )
<PRIVATE
-: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
+: (filter!) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [
[ move ] 3keep
[ nth-unsafe pick call [ 1 + ] when ] 2keep
[ 1 + ] dip
- (filter-here)
+ (filter!)
] [ nip set-length drop ] if ; inline recursive
PRIVATE>
-: filter-here ( seq quot -- )
- swap [ 0 0 ] dip (filter-here) ; inline
+: filter! ( seq quot -- seq )
+ swap [ [ 0 0 ] dip (filter!) ] keep ; inline
-: delete ( elt seq -- )
- [ = not ] with filter-here ;
+: remove! ( elt seq -- seq )
+ [ = not ] with filter! ;
-: delq ( elt seq -- )
- [ eq? not ] with filter-here ;
+: remove-eq! ( elt seq -- seq )
+ [ eq? not ] with filter! ;
: prefix ( seq elt -- newseq )
over [ over length 1 + ] dip [
[ 0 swap copy ] keep
] new-like ;
+: suffix! ( seq elt -- seq ) over push ;
+
+: append! ( seq1 seq2 -- seq1 ) over push-all ;
+
: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ;
: delete-slice ( from to seq -- )
check-slice [ over [ - ] dip ] dip open-slice ;
-: delete-nth ( n seq -- )
- [ dup 1 + ] dip delete-slice ;
+: remove-nth! ( n seq -- seq )
+ [ [ dup 1 + ] dip delete-slice ] keep ;
: snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline
[ exchange-unsafe ]
3tri ;
-: reverse-here ( seq -- )
- [ length 2/ iota ] [ length ] [ ] tri
- [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
+: reverse! ( seq -- seq )
+ [
+ [ length 2/ iota ] [ length ] [ ] tri
+ [ [ over - 1 - ] dip exchange-unsafe ] 2curry each
+ ] keep ;
: reverse ( seq -- newseq )
[
dup [ length ] keep new-sequence
- [ 0 swap copy ] keep
- [ reverse-here ] keep
+ [ 0 swap copy ] keep reverse!
] keep like ;
: sum-lengths ( seq -- n )
: concat-as ( seq exemplar -- newseq )
swap [ { } ] [
[ sum-lengths over new-resizable ] keep
- [ over push-all ] each
+ [ append! ] each
] if-empty swap like ;
: concat ( seq -- newseq )
: supremum ( seq -- n ) [ ] [ max ] map-reduce ;
-: sigma ( seq quot -- n )
+: map-sum ( seq quot -- n )
[ 0 ] 2dip [ dip + ] curry [ swap ] prepose each ; inline
-: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+: count ( seq quot -- n ) [ 1 0 ? ] compose map-sum ; inline
! We hand-optimize flip to such a degree because type hints
! cannot express that an array is an array of arrays yet, and
conjoin
conjoin-at
}
-{ $see-also member? memq? any? all? "assocs-sets" } ;
+{ $see-also member? member-eq? any? all? "assocs-sets" } ;
ABOUT: "sets"
USING: assocs hashtables kernel sequences vectors ;
IN: sets
-: adjoin ( elt seq -- ) [ delete ] [ push ] 2bi ;
+: adjoin ( elt seq -- ) [ remove! drop ] [ push ] 2bi ;
: conjoin ( elt assoc -- ) dupd set-at ;
{ { { $link float } } { $snippet "0.0" } }
{ { { $link string } } { $snippet "\"\"" } }
{ { { $link byte-array } } { $snippet "B{ }" } }
- { { { $link simple-alien } } { $snippet "BAD-ALIEN" } }
+ { { { $link pinned-alien } } { $snippet "BAD-ALIEN" } }
}
"All other classes are handled with one of two cases:"
{ $list
{ [ string bootstrap-word over class<= ] [ "" ] }
{ [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
- { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
+ { [ pinned-alien bootstrap-word over class<= ] [ <bad-alien> ] }
{ [ quotation bootstrap-word over class<= ] [ [ ] ] }
[ dup initial-value* ]
} cond nip ;
: add-error-observer ( observer -- ) error-observers get push ;
-: remove-error-observer ( observer -- ) error-observers get delq ;
+: remove-error-observer ( observer -- ) error-observers get remove-eq! drop ;
: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
[
[ swap file>> = ] [ swap error-type = ]
bi-curry* bi and not
- ] 2curry filter-here
+ ] 2curry filter! drop
notify-error-observers ;
: delete-definition-errors ( definition -- )
error-types get [
second forget-quot>> dup
[ call( definition -- ) ] [ 2drop ] if
- ] with each ;
\ No newline at end of file
+ ] with each ;
USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words quotations io io.files
io.pathnames combinators sorting splitting math.parser effects
-continuations checksums checksums.crc32 vocabs hashtables graphs
+continuations checksums checksums.crc32 vocabs hashtables
compiler.units io.encodings.utf8 accessors source-files.errors ;
IN: source-files
split1-last
split1-last-slice
split
+ split-when
}
"Splitting a string into lines:"
{ $subsections string-lines } ;
{ split1 split1-slice split1-last split1-last-slice } related-words
+HELP: split-when
+{ $values { "seq" "a sequence" } { "quot" { $quotation "( elt -- ? )" } } { "pieces" "a new array" } }
+{ $description "Splits " { $snippet "seq" } " at each occurrence of an element for which " { $snippet "quot" } " gives a true output and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
+{ $examples { $example "USING: ascii kernel prettyprint splitting ;" "\"hello,world-how.are:you\" [ letter? not ] split-when ." "{ \"hello\" \"world\" \"how\" \"are\" \"you\" }" } } ;
+
HELP: split
{ $values { "seq" "a sequence" } { "separators" "a sequence" } { "pieces" "a new array" } }
-{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } ", and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
+{ $description "Splits " { $snippet "seq" } " at each occurrence of an element of " { $snippet "separators" } " and outputs an array of pieces. The pieces do not include the elements along which the sequence was split." }
{ $examples { $example "USING: prettyprint splitting ;" "\"hello world-how are you?\" \" -\" split ." "{ \"hello\" \"world\" \"how\" \"are\" \"you?\" }" } } ;
HELP: ?head
-USING: splitting tools.test kernel sequences arrays strings ;
+USING: splitting tools.test kernel sequences arrays strings ascii ;
IN: splitting.tests
[ "hello" "world ." ] [ "hello world ." " " split1 ] unit-test
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
+
+[ { "hey" "world" "what's" "happening" } ]
+[ "heyAworldBwhat'sChappening" [ LETTER? ] split-when ] unit-test
<PRIVATE
-: (split) ( separators n seq -- )
- 3dup rot [ member? ] curry find-from drop
- [ [ swap subseq , ] 2keep 1 + swap (split) ]
- [ swap [ tail ] unless-zero , drop ] if* ; inline recursive
+: (split) ( n seq quot: ( elt -- ? ) -- )
+ [ find-from drop ]
+ [ [ [ 3dup swapd subseq , ] dip [ drop 1 + ] 2dip (split) ] 3curry ]
+ [ drop [ swap [ tail ] unless-zero , ] 2curry ]
+ 3tri if* ; inline recursive
-: split, ( seq separators -- ) 0 rot (split) ;
+: split, ( seq quot -- ) [ 0 ] 2dip (split) ; inline
PRIVATE>
: split ( seq separators -- pieces )
- [ split, ] { } make ;
+ [ [ member? ] curry split, ] { } make ;
+
+: split-when ( seq quot -- pieces )
+ [ split, ] { } make ; inline
GENERIC: string-lines ( str -- seq )
] unit-test
! Make sure we clear aux vector when storing octets
-[ "\u123456hi" ] [ "ih\u123456" clone dup reverse-here ] unit-test
+[ "\u123456hi" ] [ "ih\u123456" clone reverse! ] unit-test
! Make sure aux vector is not shared
[ "\udeadbe" ] [
} ;
ARTICLE: "syntax-words" "Word syntax"
-"A word occurring inside a quotation is executed when the quotation is called. Sometimes a word needs to be pushed on the data stack instead. The canonical use-case for this is passing the word to the " { $link execute } " combinator, or alternatively, reflectively accessing word properties (" { $link "word-props" } ")."
+"A word occurring inside a quotation is executed when the quotation is called. Sometimes a word needs to be pushed on the data stack instead. The canonical use case for this is passing the word to the " { $link execute } " combinator, or alternatively, reflectively accessing word properties (" { $link "word-props" } ")."
{ $subsections
POSTPONE: \
POSTPONE: POSTPONE:
"OCT:" [ 8 parse-base ] define-core-syntax
"BIN:" [ 2 parse-base ] define-core-syntax
- "NAN:" [ 16 scan-base <fp-nan> parsed ] define-core-syntax
+ "NAN:" [ 16 scan-base <fp-nan> suffix! ] define-core-syntax
- "f" [ f parsed ] define-core-syntax
+ "f" [ f suffix! ] define-core-syntax
"t" "syntax" lookup define-singleton-class
"CHAR:" [
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape >string "" assert= ] }
[ name>char-hook get call( name -- char ) ]
- } cond parsed
+ } cond suffix!
] define-core-syntax
- "\"" [ parse-multiline-string parsed ] define-core-syntax
+ "\"" [ parse-multiline-string suffix! ] define-core-syntax
"SBUF\"" [
- lexer get skip-blank parse-string >sbuf parsed
+ lexer get skip-blank parse-string >sbuf suffix!
] define-core-syntax
"P\"" [
- lexer get skip-blank parse-string <pathname> parsed
+ lexer get skip-blank parse-string <pathname> suffix!
] define-core-syntax
- "[" [ parse-quotation parsed ] define-core-syntax
+ "[" [ parse-quotation suffix! ] define-core-syntax
"{" [ \ } [ >array ] parse-literal ] define-core-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
"BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
- "T{" [ parse-tuple-literal parsed ] define-core-syntax
+ "T{" [ parse-tuple-literal suffix! ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
- "POSTPONE:" [ scan-word parsed ] define-core-syntax
- "\\" [ scan-word <wrapper> parsed ] define-core-syntax
- "M\\" [ scan-word scan-word method <wrapper> parsed ] define-core-syntax
+ "POSTPONE:" [ scan-word suffix! ] define-core-syntax
+ "\\" [ scan-word <wrapper> suffix! ] define-core-syntax
+ "M\\" [ scan-word scan-word method <wrapper> suffix! ] define-core-syntax
"inline" [ word make-inline ] define-core-syntax
"recursive" [ word make-recursive ] define-core-syntax
"foldable" [ word make-foldable ] define-core-syntax
] define-core-syntax
"((" [
- "))" parse-effect parsed
+ "))" parse-effect suffix!
] define-core-syntax
"MAIN:" [ scan-word current-vocab (>>main) ] define-core-syntax
"call-next-method" [
current-method get [
- literalize parsed
- \ (call-next-method) parsed
+ literalize suffix!
+ \ (call-next-method) suffix!
] [
not-in-a-method-error
] if*
HELP: reload
{ $values { "name" "a vocabulary name" } }
-{ $description "Loads it's source code and documentation." }
+{ $description "Reloads the source code and documentation for a vocabulary." }
{ $errors "Throws a " { $link no-vocab } " error if the vocabulary does not exist on disk." } ;
HELP: require
: unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
- [ [ load-vocab ] dip search-vocabs>> delq ]
+ [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
2bi
] [ drop ] if ;
: use-words ( assoc -- ) (use-words) push ;
-: unuse-words ( assoc -- ) (use-words) delete ;
+: unuse-words ( assoc -- ) (use-words) remove! drop ;
TUPLE: ambiguous-use-error words ;
IN: vocabs
ARTICLE: "vocabularies" "Vocabularies"
-"A " { $emphasis "vocabulary" } " is a named collection of words. Vocabularies are defined in the " { $vocab-link "vocabs" } " vocabulary."
+"A " { $emphasis "vocabulary" } " is a named collection of " { $link "words" } ". Vocabularies are defined in the " { $vocab-link "vocabs" } " vocabulary."
$nl
"Vocabularies are stored in a global hashtable:"
{ $subsections dictionary }
{ $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;
HELP: runnable-vocab
-{ $class-description "The class of vocabularies with a " { $slot "main" } " word." } ;
\ No newline at end of file
+{ $class-description "The class of vocabularies with a " { $slot "main" } " word." } ;
vocab-observers get push ;
: remove-vocab-observer ( obj -- )
- vocab-observers get delq ;
+ vocab-observers get remove-eq! drop ;
: notify-vocab-observers ( -- )
vocab-observers get [ vocabs-changed ] each ;
PREDICATE: runnable-vocab < vocab
vocab-main >boolean ;
-INSTANCE: vocab-spec definition
\ No newline at end of file
+INSTANCE: vocab-spec definition
} ;
ARTICLE: "colon-definition" "Colon definitions"
-"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition."
+"All words have associated definition " { $link "quotations" } ". A word's definition quotation is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition."
$nl
"Defining words at parse time:"
{ $subsections
} ;
ARTICLE: "words" "Words"
-"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation."
+"Words are the Factor equivalent of functions or procedures in other languages. Words are essentially named " { $link "quotations" } "."
$nl
"There are two ways of creating word definitions:"
{ $list
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
vocabs continuations classes.tuple compiler.units
-io.streams.string accessors eval words.symbol ;
+io.streams.string accessors eval words.symbol grouping ;
IN: words.tests
[ 4 ] [
[ { } ]
[
all-words [
- "compiled-uses" word-prop
+ "compiled-uses" word-prop 2 <groups>
keys [ "forgotten" word-prop ] filter
] map harvest
] unit-test
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions graphs kernel
-kernel.private slots.private math namespaces sequences
-strings vectors sbufs quotations assocs hashtables sorting vocabs
-math.order sets words.private ;
+USING: accessors arrays definitions kernel kernel.private
+slots.private math namespaces sequences strings vectors sbufs
+quotations assocs hashtables sorting vocabs math.order sets
+words.private ;
IN: words
: word ( -- word ) \ word get-global ;
M: word crossref?
dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
-SYMBOL: compiled-crossref
-
-compiled-crossref [ H{ } clone ] initialize
-
-SYMBOL: compiled-generic-crossref
-
-compiled-generic-crossref [ H{ } clone ] initialize
-
-: (compiled-xref) ( word dependencies word-prop variable -- )
- [ [ set-word-prop ] curry ]
- [ [ get add-vertex* ] curry ]
- bi* 2bi ;
-
-: compiled-xref ( word dependencies generic-dependencies -- )
- [ [ drop crossref? ] { } assoc-filter-as f like ] bi@
- [ "compiled-uses" compiled-crossref (compiled-xref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
- bi-curry* bi ;
-
-: (compiled-unxref) ( word word-prop variable -- )
- [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]
- [ drop [ remove-word-prop ] curry ]
- 2bi bi ;
-
-: compiled-unxref ( word -- )
- [ "compiled-uses" compiled-crossref (compiled-unxref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
- bi ;
-
-: delete-compiled-xref ( word -- )
- [ compiled-unxref ]
- [ compiled-crossref get delete-at ]
- [ compiled-generic-crossref get delete-at ]
- tri ;
-
: inline? ( word -- ? ) "inline" word-prop ; inline
GENERIC: subwords ( word -- seq )
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations strings ;
-IN: 4DNav
-
-
-HELP: menu-3D
-{ $values
- { "gadget" "gadget" }
-}
-{ $description "The menu dedicated to 3D movements of the camera" } ;
-
-HELP: menu-4D
-{ $values
-
- { "gadget" "gadget" }
-}
-{ $description "The menu dedicated to 4D movements of space" } ;
-
-HELP: menu-bar
-{ $values
-
- { "gadget" "gadget" }
-}
-{ $description "return gadget containing menu buttons" } ;
-
-HELP: model-projection
-{ $values
- { "x" "interger" }
- { "space" "space" }
-}
-{ $description "Project space following coordinate x" } ;
-
-HELP: mvt-3D-1
-{ $values
-
- { "quot" "quotation" }
-}
-{ $description "return a quotation to orientate space to see it from first point of view" } ;
-
-HELP: mvt-3D-2
-{ $values
-
- { "quot" "quotation" }
-}
-{ $description "return a quotation to orientate space to see it from second point of view" } ;
-
-HELP: mvt-3D-3
-{ $values
-
- { "quot" "quotation" }
-}
-{ $description "return a quotation to orientate space to see it from third point of view" } ;
-
-HELP: mvt-3D-4
-{ $values
-
- { "quot" "quotation" }
-}
-{ $description "return a quotation to orientate space to see it from first point of view" } ;
-
-HELP: load-model-file
-{ $description "load space from file" } ;
-
-HELP: rotation-4D
-{ $values
- { "m" "a rotation matrix" }
-}
-{ $description "Apply a 4D rotation matrix" } ;
-
-HELP: translation-4D
-{ $values
- { "v" "vector" }
-}
-{ $description "Apply a 4D translation" } ;
-
-
-ARTICLE: "implementation details" "How 4DNav is done"
-"4DNav is build using :"
-
-{ $subsections
- "4DNav.camera"
- "adsoda-main-page"
-}
-;
-
-ARTICLE: "Space file" "Create a new space file"
-"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
-
-$nl
-"An example is:"
-{ $code """
-<model>
-<space>
- <dimension>4</dimension>
- <solid>
- <name>4cube1</name>
- <dimension>4</dimension>
- <face>1,0,0,0,100</face>
- <face>-1,0,0,0,-150</face>
- <face>0,1,0,0,100</face>
- <face>0,-1,0,0,-150</face>
- <face>0,0,1,0,100</face>
- <face>0,0,-1,0,-150</face>
- <face>0,0,0,1,100</face>
- <face>0,0,0,-1,-150</face>
- <color>1,0,0</color>
- </solid>
- <solid>
- <name>4triancube</name>
- <dimension>4</dimension>
- <face>1,0,0,0,160</face>
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
- <face>0,0,1,0,140</face>
- <face>0,0,-1,0,-180</face>
- <face>0,0,0,1,110</face>
- <face>0,0,0,-1,-180</face>
- <color>0,1,0</color>
- </solid>
- <solid>
- <name>triangone</name>
- <dimension>4</dimension>
- <face>1,0,0,0,60</face>
- <face>0.5,0.8660254037844386,0,0,60</face>
- <face>-0.5,0.8660254037844387,0,0,-20</face>
- <face>-1.0,0,0,0,-100</face>
- <face>-0.5,-0.8660254037844384,0,0,-100</face>
- <face>0.5,-0.8660254037844387,0,0,-20</face>
- <face>0,0,1,0,120</face>
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
- <color>0,1,1</color>
- </solid>
- <light>
- <direction>1,1,1,1</direction>
- <color>0.2,0.2,0.6</color>
- </light>
- <color>0.8,0.9,0.9</color>
-</space>
-</model>""" } ;
-
-ARTICLE: "TODO" "Todo"
-{ $list
- "A vocab to initialize parameters"
- "an editor mode"
- { $list "add a face to a solid"
- "add a solid to the space"
- "move a face"
- "move a solid"
- "select a solid in a list"
- "select a face"
- "display selected face"
- "edit a solid color"
- "add a light"
- "edit a light color"
- "move a light"
- }
- "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
- "decorrelate 3D camera and activate them with select buttons"
-
-} ;
-
-
-ARTICLE: "4DNav" "The 4DNav app"
-{ $vocab-link "4DNav" }
-$nl
-{ $heading "4D Navigator" }
-"4DNav is a simple tool to visualize 4 dimensionnal objects."
-$nl
-"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
-$nl
-"It will display:"
-{ $list
- { "a menu window" }
- { "4 visualization windows" }
-}
-"Each visualization window represents the projection of the 4D space on a particular 3D space."
-
-{ $heading "Start" }
-"type:" { $code "\"4DNav\" run" }
-
-{ $heading "Navigation" }
-"Menu window is divided in 4 areas"
-{ $list
- { "a space-file chooser to select the file to display" }
- { "a parametrization area to select the projection mode" }
- { "4D submenu to translate and rotate the 4D space" }
- { "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
- }
-
-{ $heading "Links" }
-{ $subsections
- "Space file"
- "TODO"
- "implementation details"
-}
-
-;
-
-ABOUT: "4DNav"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-namespaces\r
-accessors\r
-assocs\r
-make\r
-math\r
-math.functions\r
-math.trig\r
-math.parser\r
-hashtables\r
-sequences\r
-combinators\r
-continuations\r
-colors\r
-colors.constants\r
-prettyprint\r
-vars\r
-quotations\r
-io\r
-io.directories\r
-io.pathnames\r
-help.markup\r
-io.files\r
-ui.gadgets.panes\r
- ui\r
- ui.gadgets\r
- ui.traverse\r
- ui.gadgets.borders\r
- ui.gadgets.frames\r
- ui.gadgets.tracks\r
- ui.gadgets.labels\r
- ui.gadgets.labeled \r
- ui.gadgets.lists\r
- ui.gadgets.buttons\r
- ui.gadgets.packs\r
- ui.gadgets.grids\r
- ui.gadgets.corners\r
- ui.gestures\r
- ui.gadgets.scrollers\r
-splitting\r
-vectors\r
-math.vectors\r
-values\r
-4DNav.turtle\r
-4DNav.window3D\r
-4DNav.deep\r
-4DNav.space-file-decoder\r
-models\r
-fry\r
-adsoda\r
-adsoda.tools\r
-;\r
-QUALIFIED-WITH: ui.pens.solid s\r
-QUALIFIED-WITH: ui.gadgets.wrappers w\r
-\r
-\r
-IN: 4DNav\r
-VALUE: selected-file\r
-VALUE: translation-step\r
-VALUE: rotation-step\r
-\r
-3 to: translation-step \r
-5 to: rotation-step\r
-\r
-VAR: selected-file-model\r
-VAR: observer3d \r
-VAR: view1 \r
-VAR: view2\r
-VAR: view3\r
-VAR: view4\r
-VAR: present-space\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-! namespace utilities\r
-\r
-: closed-quot ( quot -- quot )\r
- namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! waiting for deep-cleave-quots\r
-\r
-: 4D-Rxy ( angle -- Rx ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , dup cos , dup sin neg ,\r
- 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxz ( angle -- Ry ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , 0.0 , dup sin neg ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rxw ( angle -- Rz ) deg>rad\r
-[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
- 0.0 , dup cos , dup sin neg , 0.0 ,\r
- 0.0 , dup sin , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryz ( angle -- Rx ) deg>rad\r
-[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
-\r
-: 4D-Ryw ( angle -- Ry ) deg>rad\r
-[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
- 0.0 , 1.0 , 0.0 , 0.0 ,\r
- dup sin , 0.0 , dup cos , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-: 4D-Rzw ( angle -- Rz ) deg>rad\r
-[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
- dup sin , dup cos , 0.0 , 0.0 ,\r
- 0.0 , 0.0 , 1.0 , 0.0 ,\r
- 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! UI\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: button* ( string quot -- button ) \r
- closed-quot <repeat-button> ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: model-projection-chooser ( -- gadget )\r
- observer3d> projection-mode>>\r
- { { 1 "perspective" } { 0 "orthogonal" } } \r
- <radio-buttons> ;\r
-\r
-: collision-detection-chooser ( -- gadget )\r
- observer3d> collision-mode>>\r
- { { t "on" } { f "off" } } <radio-buttons> ;\r
-\r
-: model-projection ( x -- space ) \r
- present-space> swap space-project ;\r
-\r
-: update-observer-projections ( -- )\r
- view1> relayout-1 \r
- view2> relayout-1 \r
- view3> relayout-1 \r
- view4> relayout-1 ;\r
-\r
-: update-model-projections ( -- )\r
- 0 model-projection <model> view1> (>>model)\r
- 1 model-projection <model> view2> (>>model)\r
- 2 model-projection <model> view3> (>>model)\r
- 3 model-projection <model> view4> (>>model) ;\r
-\r
-: camera-action ( quot -- quot ) \r
- '[ drop _ observer3d> \r
- with-self update-observer-projections ] \r
- closed-quot ;\r
-\r
-: win3D ( text gadget -- ) \r
- "navigateur 4D : " rot append open-window ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! 4D object manipulation\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: (mvt-4D) ( quot -- ) \r
- present-space> \r
- swap call space-ensure-solids \r
- >present-space \r
- update-model-projections \r
- update-observer-projections ; inline\r
-\r
-: rotation-4D ( m -- ) \r
- '[ _ [ [ middle-of-space dup vneg ] keep \r
- swap space-translate ] dip\r
- space-transform \r
- swap space-translate\r
- ] (mvt-4D) ;\r
-\r
-: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! menu\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: menu-rotations-4D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
- button* add-gadget\r
- "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
- button* add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
- button* add-gadget\r
- "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
- button* add-gadget \r
- @top grid-add \r
- <pile> 1 >>fill\r
- "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
- button* add-gadget\r
- "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
- button* add-gadget \r
- @center grid-add\r
- <pile> 1 >>fill\r
- "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
- button* add-gadget\r
- "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
- button* add-gadget \r
- @top-right grid-add \r
- <pile> 1 >>fill\r
- "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
- button* add-gadget\r
- "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
- button* add-gadget \r
- @right grid-add \r
- <pile> 1 >>fill\r
- "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
- button* add-gadget\r
- "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
- button* add-gadget \r
- @bottom-right grid-add \r
-;\r
-\r
-: menu-translations-4D ( -- gadget )\r
- 3 3 <frame> \r
- { 1 1 } >>filled-cell\r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill \r
- "X+" [ drop { 1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "X-" [ drop { -1 0 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "YZW" <label> add-gadget\r
- @bottom-right grid-add\r
- <pile> 1 >>fill\r
- "XZW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- @top-right grid-add\r
- <pile> 1 >>fill\r
- "XYW" <label> add-gadget\r
- <shelf> 1 >>fill\r
- "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget \r
- @top-left grid-add \r
- <pile> 1 >>fill\r
- <shelf> 1 >>fill\r
- "W+" [ drop { 0 0 0 1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget\r
- "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
- translation-4D ] \r
- button* add-gadget \r
- add-gadget\r
- "XYZ" <label> add-gadget\r
- @bottom-left grid-add \r
- "X" <label> @center grid-add\r
-;\r
-\r
-: menu-4D ( -- gadget ) \r
- <shelf> \r
- "rotations" <label> add-gadget\r
- menu-rotations-4D add-gadget\r
- "translations" <label> add-gadget\r
- menu-translations-4D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
-;\r
-\r
-\r
-! ------------------------------------------------------\r
-\r
-: redraw-model ( space -- )\r
- >present-space \r
- update-model-projections \r
- update-observer-projections ;\r
-\r
-: load-model-file ( -- )\r
- selected-file dup selected-file-model> set-model \r
- read-model-file \r
- redraw-model ;\r
-\r
-: mvt-3D-X ( turn pitch -- quot )\r
- '[ turtle-pos> norm neg reset-turtle \r
- _ turn-left \r
- _ pitch-up \r
- step-turtle ] ;\r
-\r
-: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
-: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
-: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
-: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
-\r
-: camera-button ( string quot -- button ) \r
- [ <label> ] dip camera-action <repeat-button> ;\r
-\r
-! ----------------------------------------------------------\r
-! file chooser\r
-! ----------------------------------------------------------\r
-: <run-file-button> ( file-name -- button )\r
- dup '[ drop _ \ selected-file set-value load-model-file \r
- ] \r
- closed-quot <roll-button> { 0 0 } >>align ;\r
-\r
-: <list-runner> ( -- gadget )\r
- "resource:extra/4DNav" \r
- <pile> 1 >>fill \r
- over dup directory-files \r
- [ ".xml" tail? ] filter \r
- [ append-path ] with map\r
- [ <run-file-button> add-gadget ] each\r
- swap <labeled-gadget> ;\r
-\r
-! -----------------------------------------------------\r
-\r
-: menu-rotations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "Turn\n left" [ rotation-step turn-left ] \r
- camera-button @left grid-add \r
- "Turn\n right" [ rotation-step turn-right ] \r
- camera-button @right grid-add \r
- "Pitch down" [ rotation-step pitch-down ] \r
- camera-button @bottom grid-add \r
- "Pitch up" [ rotation-step pitch-up ] \r
- camera-button @top grid-add \r
- <shelf> 1 >>fill\r
- "Roll left\n (ctl)" [ rotation-step roll-left ] \r
- camera-button add-gadget \r
- "Roll right\n(ctl)" [ rotation-step roll-right ] \r
- camera-button add-gadget \r
- @center grid-add \r
-;\r
-\r
-: menu-translations-3D ( -- gadget )\r
- 3 3 <frame>\r
- { 1 1 } >>filled-cell\r
- "left\n(alt)" [ translation-step strafe-left ]\r
- camera-button @left grid-add \r
- "right\n(alt)" [ translation-step strafe-right ]\r
- camera-button @right grid-add \r
- "Strafe up \n (alt)" [ translation-step strafe-up ] \r
- camera-button @top grid-add\r
- "Strafe down\n (alt)" [ translation-step strafe-down ]\r
- camera-button @bottom grid-add \r
- <pile> 1 >>fill\r
- "Forward (ctl)" [ translation-step step-turtle ] \r
- camera-button add-gadget\r
- "Backward (ctl)" \r
- [ translation-step neg step-turtle ] \r
- camera-button add-gadget\r
- @center grid-add\r
-;\r
-\r
-: menu-quick-views ( -- gadget )\r
- <shelf>\r
- "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
- "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
- "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
- "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
-;\r
-\r
-: menu-3D ( -- gadget ) \r
- <pile>\r
- <shelf> \r
- menu-rotations-3D add-gadget\r
- menu-translations-3D add-gadget\r
- 0.5 >>align\r
- { 0 10 } >>gap\r
- add-gadget\r
- menu-quick-views add-gadget ; \r
-\r
-TUPLE: handler < w:wrapper table ;\r
-\r
-: <handler> ( child -- handler ) handler w:new-wrapper ;\r
-\r
-M: handler handle-gesture ( gesture gadget -- ? )\r
- tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;\r
-\r
-: add-keyboard-delegate ( obj -- obj )\r
- <handler>\r
-H{\r
- { T{ key-down f f "LEFT" } \r
- [ [ rotation-step turn-left ] camera-action ] }\r
- { T{ key-down f f "RIGHT" } \r
- [ [ rotation-step turn-right ] camera-action ] }\r
- { T{ key-down f f "UP" } \r
- [ [ rotation-step pitch-down ] camera-action ] }\r
- { T{ key-down f f "DOWN" } \r
- [ [ rotation-step pitch-up ] camera-action ] }\r
-\r
- { T{ key-down f { C+ } "UP" } \r
- [ [ translation-step step-turtle ] camera-action ] }\r
- { T{ key-down f { C+ } "DOWN" } \r
- [ [ translation-step neg step-turtle ] \r
- camera-action ] }\r
- { T{ key-down f { C+ } "LEFT" } \r
- [ [ rotation-step roll-left ] camera-action ] }\r
- { T{ key-down f { C+ } "RIGHT" } \r
- [ [ rotation-step roll-right ] camera-action ] }\r
-\r
- { T{ key-down f { A+ } "LEFT" } \r
- [ [ translation-step strafe-left ] camera-action ] }\r
- { T{ key-down f { A+ } "RIGHT" } \r
- [ [ translation-step strafe-right ] camera-action ] }\r
- { T{ key-down f { A+ } "UP" } \r
- [ [ translation-step strafe-up ] camera-action ] }\r
- { T{ key-down f { A+ } "DOWN" } \r
- [ [ translation-step strafe-down ] camera-action ] }\r
-\r
-\r
- { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
- { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
- { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
- { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
-\r
- } >>table\r
- ; \r
-\r
-! --------------------------------------------\r
-! print elements \r
-! --------------------------------------------\r
-! print-content\r
-\r
-GENERIC: adsoda-display-model ( x -- ) \r
-\r
-M: light adsoda-display-model \r
-"\n light : " .\r
- { \r
- [ direction>> "direction : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- } cleave\r
- ;\r
-\r
-M: face adsoda-display-model \r
- {\r
- [ halfspace>> "halfspace : " pprint . ] \r
- [ touching-corners>> "touching corners : " pprint . ]\r
- } cleave\r
- ;\r
-M: solid adsoda-display-model \r
- {\r
- [ name>> "solid called : " pprint . ] \r
- [ color>> "color : " pprint . ]\r
- [ dimension>> "dimension : " pprint . ]\r
- [ faces>> "composed of faces : " pprint \r
- [ adsoda-display-model ] each ]\r
- } cleave\r
- ;\r
-M: space adsoda-display-model \r
- {\r
- [ dimension>> "dimension : " pprint . ] \r
- [ ambient-color>> "ambient-color : " pprint . ]\r
- [ solids>> "composed of solids : " pprint \r
- [ adsoda-display-model ] each ]\r
- [ lights>> "composed of lights : " pprint \r
- [ adsoda-display-model ] each ] \r
- } cleave\r
- ;\r
-\r
-! ----------------------------------------------\r
-: menu-bar ( -- gadget )\r
- <shelf>\r
- "reinit" [ drop load-model-file ] button* add-gadget\r
- selected-file-model> <label-control> add-gadget\r
- ;\r
-\r
-\r
-: controller-window* ( -- gadget )\r
- { 0 1 } <track>\r
- menu-bar f track-add\r
- <list-runner> \r
- <scroller>\r
- f track-add\r
- <shelf>\r
- "Projection mode : " <label> add-gadget\r
- model-projection-chooser add-gadget\r
- f track-add\r
- <shelf>\r
- "Collision detection (slow and buggy ) : " \r
- <label> add-gadget\r
- collision-detection-chooser add-gadget\r
- f track-add\r
- <pile>\r
- 0.5 >>align \r
- menu-4D add-gadget \r
- COLOR: purple s:<solid> >>interior\r
- "4D movements" <labeled-gadget>\r
- f track-add\r
- <pile>\r
- 0.5 >>align\r
- { 2 2 } >>gap\r
- menu-3D add-gadget\r
- COLOR: purple s:<solid> >>interior\r
- "Camera 3D" <labeled-gadget>\r
- f track-add \r
- COLOR: gray s:<solid> >>interior\r
- ;\r
- \r
-: viewer-windows* ( -- )\r
- "YZW" view1> win3D \r
- "XZW" view2> win3D \r
- "XYW" view3> win3D \r
- "XYZ" view4> win3D \r
-;\r
-\r
-: navigator-window* ( -- )\r
- controller-window*\r
- viewer-windows* \r
- add-keyboard-delegate\r
- "navigateur 4D" open-window\r
-;\r
-\r
-: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
-\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-: init-variables ( -- )\r
- "choose a file" <model> >selected-file-model \r
- <observer> >observer3d\r
- [ observer3d> >self\r
- reset-turtle \r
- 45 turn-left \r
- 45 pitch-up \r
- -300 step-turtle \r
- ] with-scope\r
- \r
-;\r
-\r
-\r
-: init-models ( -- )\r
- 0 model-projection observer3d> <window3D> >view1\r
- 1 model-projection observer3d> <window3D> >view2\r
- 2 model-projection observer3d> <window3D> >view3\r
- 3 model-projection observer3d> <window3D> >view4\r
-;\r
-\r
-: 4DNav ( -- ) \r
- init-variables\r
- selected-file read-model-file >present-space\r
- init-models\r
- windows\r
-;\r
-\r
-MAIN: 4DNav\r
-\r
-\r
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-Adam Wendt
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.camera
-
-HELP: camera-eye
-{ $values
-
- { "point" "position" }
-}
-{ $description "return the position of the camera" } ;
-
-HELP: camera-focus
-{ $values
-
- { "point" "position" }
-}
-{ $description "return the point the camera looks at" } ;
-
-HELP: camera-up
-{ $values
-
- { "dirvec" "upside direction" }
-}
-{ $description "In order to precise the roling position of camera give an upward vector" } ;
-
-HELP: do-look-at
-{ $values
- { "camera" "direction" }
-}
-{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
-
-ARTICLE: "4DNav.camera" "Camera"
-{ $vocab-link "4DNav.camera" }
-$nl
-"A camera is defined by:"
-{ $list
-{ "a position (" { $link camera-eye } ")" }
-{ "a focus direction (" { $link camera-focus } ")" }
-{ "an attitude information (" { $link camera-up } ")" }
-}
-"Use " { $link do-look-at } " in opengl statement in placement of gl-look-at"
-$nl
-"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
-{ $list
-{ "To define a camera"
-{
- $unchecked-example
-
-"VAR: my-camera"
-": init-my-camera ( -- )"
-" <turtle> >my-camera"
-" [ my-camera> >self"
-" reset-turtle "
-" ] with-scope ;"
-} }
-{ "To move it"
-{
- $unchecked-example
-
-" [ my-camera> >self"
-" 45 pitch-up "
-" 5 step-turtle"
-" ] with-scope "
-} }
-{ "or"
-{
- $unchecked-example
-
-" [ my-camera> >self"
-" 5 strafe-left"
-" ] with-scope "
-}
-}
-{
-"to use it in an opengl statement"
-{
- $unchecked-example
- "my-camera> do-look-at"
-
-}
-}
-}
-
-
-;
-
-ABOUT: "4DNav.camera"
+++ /dev/null
-USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
-
-IN: 4DNav.camera
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: camera-eye ( -- point ) turtle-pos> ;
-
-: camera-focus ( -- point )
- [ 1 step-turtle turtle-pos> ] save-self ;
-
-: camera-up ( -- dirvec )
-[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ]
- save-self ;
-
-: do-look-at ( camera -- )
-[ >self camera-eye camera-focus camera-up gl-look-at ]
- with-scope ;
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations sequences ;
-IN: 4DNav.deep
-
-! HELP: deep-cleave-quots
-! { $values
-! { "seq" sequence }
-! { "quot" quotation }
-! }
-! { $description "A word to build a soquence from a sequence of quotation" }
-!
-! { $examples
-! "It is useful to build matrix"
-! { $example "USING: math math.trig ; "
-! " 30 deg>rad "
-! " { { [ cos ] [ sin neg ] 0 } "
-! " { [ sin ] [ cos ] 0 } "
-! " { 0 0 1 } "
-! " } deep-cleave-quots "
-! " "
-!
-!
-! } }
-! ;
-
-ARTICLE: "4DNav.deep" "Deep"
-{ $vocab-link "4DNav.deep" }
-;
-
-ABOUT: "4DNav.deep"
+++ /dev/null
-USING: macros quotations math math.functions math.trig \r
-sequences.deep kernel make fry combinators grouping ;\r
-IN: 4DNav.deep\r
-\r
-! USING: bake ;\r
-! MACRO: deep-cleave-quots ( seq -- quot )\r
-! [ [ quotation? ] deep-filter ]\r
-! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
-! bi '[ _ cleave _ bake ] ;\r
-\r
-: make-matrix ( quot width -- matrix ) \r
- [ { } make ] dip group ; inline\r
-\r
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-c-types? t }
- { deploy-word-props? t }
- { deploy-name "4DNav" }
- { deploy-ui? t }
- { deploy-math? t }
- { deploy-threads? t }
- { deploy-reflection 3 }
- { deploy-unicode? t }
- { deploy-io 3 }
- { "stop-after-last-window?" t }
- { deploy-word-defs? t }
-}
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING:\r
-kernel\r
-io.files\r
-io.backend\r
-io.directories\r
-io.files.info\r
-io.pathnames\r
-sequences\r
-models\r
-strings\r
-ui\r
-ui.operations\r
-ui.commands\r
-ui.gestures\r
-ui.gadgets\r
-ui.gadgets.buttons\r
-ui.gadgets.lists\r
-ui.gadgets.labels\r
-ui.gadgets.tracks\r
-ui.gadgets.packs\r
-ui.gadgets.panes\r
-ui.gadgets.scrollers\r
-prettyprint\r
-combinators\r
-accessors\r
-values\r
-tools.walker\r
-fry\r
-;\r
-IN: 4DNav.file-chooser\r
-\r
-TUPLE: file-chooser < track \r
- path\r
- extension \r
- selected-file\r
- presenter\r
- hook \r
- list\r
- ;\r
-\r
-: find-file-list ( gadget -- list )\r
- [ file-chooser? ] find-parent list>> ;\r
-\r
-file-chooser H{\r
- { T{ key-down f f "UP" } \r
- [ find-file-list select-previous ] }\r
- { T{ key-down f f "DOWN" } \r
- [ find-file-list select-next ] }\r
- { T{ key-down f f "PAGE_UP" } \r
- [ find-file-list list-page-up ] }\r
- { T{ key-down f f "PAGE_DOWN" } \r
- [ find-file-list list-page-down ] }\r
- { T{ key-down f f "RET" } \r
- [ find-file-list invoke-value-action ] }\r
- { T{ button-down } \r
- request-focus }\r
- { T{ button-down f 1 } \r
- [ find-file-list invoke-value-action ] }\r
-} set-gestures\r
-\r
-: list-of-files ( file-chooser -- seq )\r
- [ path>> value>> directory-entries ] [ extension>> ] bi\r
- '[ [ name>> _ [ tail? ] with any? ] \r
- [ directory? ] bi or ] filter\r
-;\r
-\r
-: update-filelist-model ( file-chooser -- )\r
- [ list-of-files ] [ model>> ] bi set-model ;\r
-\r
-: init-filelist-model ( file-chooser -- file-chooser )\r
- dup list-of-files <model> >>model ; \r
-\r
-: (fc-go) ( file-chooser button quot -- )\r
- [ [ file-chooser? ] find-parent dup path>> ] dip\r
- call\r
- normalize-path swap set-model\r
- update-filelist-model\r
- drop ; inline\r
-\r
-: fc-go-parent ( file-chooser button -- )\r
- [ dup value>> parent-directory ] (fc-go) ;\r
-\r
-: fc-go-home ( file-chooser button -- )\r
- [ home ] (fc-go) ;\r
-\r
-: fc-change-directory ( file-chooser file -- )\r
- dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
- append-path over path>> set-model \r
- update-filelist-model\r
-;\r
-\r
-: fc-load-file ( file-chooser file -- )\r
- over [ name>> ] [ selected-file>> ] bi* set-model \r
- [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
- call( path -- )\r
-; inline\r
-\r
-! : fc-ok-action ( file-chooser -- quot )\r
-! dup selected-file>> value>> "" =\r
-! [ drop [ drop ] ] [ \r
-! [ path>> value>> ] \r
-! [ selected-file>> value>> append ] \r
-! [ hook>> prefix ] tri\r
-! [ drop ] prepend\r
-! ] if ; \r
-\r
-: line-selected-action ( file-chooser -- )\r
- dup list>> list-value\r
- dup directory? \r
- [ fc-change-directory ] [ fc-load-file ] if ;\r
-\r
-: present-dir-element ( element -- string )\r
- [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
-\r
-: <file-list> ( file-chooser -- list )\r
- dup [ nip line-selected-action ] curry \r
- [ present-dir-element ] rot model>> <list> ;\r
-\r
-: <file-chooser> ( hook path extension -- gadget )\r
- { 0 1 } file-chooser new-track\r
- swap >>extension\r
- swap <model> >>path\r
- "" <model> >>selected-file\r
- swap >>hook\r
- init-filelist-model\r
- dup <file-list> >>list\r
- "choose a file in directory " <label> f track-add\r
- dup path>> <label-control> f track-add\r
- dup extension>> ", " join "limited to : " prepend \r
- <label> f track-add\r
- <shelf> \r
- "selected file : " <label> add-gadget\r
- over selected-file>> <label-control> add-gadget\r
- f track-add\r
- <shelf> \r
- over [ swap fc-go-parent ] curry "go up" \r
- swap <border-button> add-gadget\r
- over [ swap fc-go-home ] curry "go home" \r
- swap <border-button> add-gadget\r
- ! over [ swap fc-ok-action ] curry "OK" \r
- ! swap <bevel-button> add-gadget\r
- ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
- f track-add\r
- dup list>> <scroller> 1 track-add\r
-;\r
-\r
-M: file-chooser pref-dim* drop { 400 200 } ;\r
-\r
-: file-chooser-window ( -- )\r
- [ . ] home { "xml" "txt" } <file-chooser> \r
- "Choose a file" open-window ;\r
-\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>hypercube</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>1,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,0,0,0</direction>\r
- <color>0,0,0,0.6</color>\r
- </light>\r
- <light>\r
- <direction>0,1,0,0</direction>\r
- <color>0,0.6,0,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,1,0</direction>\r
- <color>0,0,0.6,0</color>\r
- </light>\r
- <light>\r
- <direction>0,0,0,1</direction>\r
- <color>0.6,0.6,0.6</color>\r
- </light>\r
- <color>0.99,0.99,0.99</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>multi solids</name>\r
- <dimension>4</dimension>\r
- <solid>\r
- <name>4cube1</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,100</face>\r
- <face>-1,0,0,0,-150</face>\r
- <face>0,1,0,0,100</face>\r
- <face>0,-1,0,0,-150</face>\r
- <face>0,0,1,0,100</face>\r
- <face>0,0,-1,0,-150</face>\r
- <face>0,0,0,1,100</face>\r
- <face>0,0,0,-1,-150</face>\r
- <color>1,0,0</color>\r
- </solid>\r
- <solid>\r
- <name>4triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-<model>\r
-<space>\r
- <name>Prismetragone</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triangone</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,60</face>\r
- <face>0.5,0.8660254037844386,0,0,60</face>\r
- <face>-0.5,0.8660254037844387,0,0,-20</face>\r
- <face>-1.0,0,0,0,-100</face>\r
- <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
- <face>0.5,-0.8660254037844387,0,0,-20</face>\r
- <face>0,0,1,0,120</face>\r
- <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
- <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
- <color>0,1,1</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.space-file-decoder
-
-
-
-HELP: read-model-file
-{ $values
-
- { "path" "path to the file to read" }
- { "x" "value" }
-}
-{ $description "Read a file containing the xml description of the model" } ;
-
-ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
-{ $vocab-link "4DNav.space-file-decoder" }
-;
-
-ABOUT: "4DNav.space-file-decoder"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: adsoda xml xml.traversal xml.syntax accessors \r
-combinators sequences math.parser kernel splitting values \r
-continuations ;\r
-IN: 4DNav.space-file-decoder\r
-\r
-: decode-number-array ( x -- y ) \r
- "," split [ string>number ] map ;\r
-\r
-TAGS: adsoda-read-model ( tag -- model )\r
-\r
-TAG: dimension adsoda-read-model \r
- children>> first string>number ;\r
-TAG: direction adsoda-read-model \r
- children>> first decode-number-array ;\r
-TAG: color adsoda-read-model \r
- children>> first decode-number-array ;\r
-TAG: name adsoda-read-model \r
- children>> first ;\r
-TAG: face adsoda-read-model \r
- children>> first decode-number-array ;\r
-\r
-TAG: solid adsoda-read-model \r
- <solid> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ]\r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named adsoda-read-model >>color ] \r
- [ "face" \r
- tags-named [ adsoda-read-model cut-solid ] each ] \r
- } cleave\r
- ensure-adjacencies\r
-;\r
-\r
-TAG: light adsoda-read-model \r
- <light> swap \r
- { \r
- [ "direction" tag-named adsoda-read-model >>direction ]\r
- [ "color" tag-named adsoda-read-model >>color ] \r
- } cleave\r
-;\r
-\r
-TAG: space adsoda-read-model \r
- <space> swap \r
- { \r
- [ "dimension" tag-named adsoda-read-model >>dimension ]\r
- [ "name" tag-named adsoda-read-model >>name ] \r
- [ "color" tag-named \r
- adsoda-read-model >>ambient-color ] \r
- [ "solid" tags-named \r
- [ adsoda-read-model suffix-solids ] each ] \r
- [ "light" tags-named \r
- [ adsoda-read-model suffix-lights ] each ]\r
- } cleave\r
-;\r
-\r
-: read-model-file ( path -- x )\r
- [\r
- [ file>xml "space" tag-named adsoda-read-model ] \r
- [ 2drop <space> ] recover \r
- ] [ <space> ] if*\r
-;\r
-\r
+++ /dev/null
-Simple tool to navigate through a 4D space with projections on 4 3D spaces
+++ /dev/null
-4D viewer
\ No newline at end of file
+++ /dev/null
-<model>\r
-<space>\r
- <name>triancube</name> \r
- <dimension>4</dimension>\r
- <solid>\r
- <name>triancube</name>\r
- <dimension>4</dimension>\r
- <face>1,0,0,0,160</face>\r
- <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
- <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
- <face>0,0,1,0,140</face>\r
- <face>0,0,-1,0,-180</face>\r
- <face>0,0,0,1,110</face>\r
- <face>0,0,0,-1,-180</face>\r
- <color>0,1,0</color>\r
- </solid>\r
- <light>\r
- <direction>1,1,1,1</direction>\r
- <color>0.2,0.2,0.6</color>\r
- </light>\r
- <color>0.8,0.9,0.9</color>\r
-</space>\r
-</model>\r
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: 4DNav.turtle
-
-
-ARTICLE: "4DNav.turtle" "Turtle"
-{ $vocab-link "4DNav.turtle" }
-;
-
-ABOUT: "4DNav.turtle"
+++ /dev/null
-USING: kernel math arrays math.vectors math.matrices namespaces make
-math.constants math.functions splitting grouping math.trig sequences
-accessors 4DNav.deep models vars ;
-IN: 4DNav.turtle
-
-! replacement of self
-
-VAR: self
-
-: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
-
-: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: turtle pos ori ;
-
-: <turtle> ( -- turtle )
- turtle new
- { 0 0 0 } clone >>pos
- 3 identity-matrix >>ori
-;
-
-
-TUPLE: observer < turtle projection-mode collision-mode ;
-
-: <observer> ( -- object )
- observer new
- 0 <model> >>projection-mode
- f <model> >>collision-mode
- ;
-
-
-: turtle-pos> ( -- val ) self> pos>> ;
-: >turtle-pos ( val -- ) self> (>>pos) ;
-
-: turtle-ori> ( -- val ) self> ori>> ;
-: >turtle-ori ( val -- ) self> (>>ori) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! These rotation matrices are from
-! `Computer Graphics: Principles and Practice'
-
-
-! waiting for deep-cleave-quots
-
-! : Rz ( angle -- Rx ) deg>rad
-! { { [ cos ] [ sin neg ] 0 }
-! { [ sin ] [ cos ] 0 }
-! { 0 0 1 }
-! } deep-cleave-quots ;
-
-! : Ry ( angle -- Ry ) deg>rad
-! { { [ cos ] 0 [ sin ] }
-! { 0 1 0 }
-! { [ sin neg ] 0 [ cos ] }
-! } deep-cleave-quots ;
-
-! : Rx ( angle -- Rz ) deg>rad
-! { { 1 0 0 }
-! { 0 [ cos ] [ sin neg ] }
-! { 0 [ sin ] [ cos ] }
-! } deep-cleave-quots ;
-
-: Rz ( angle -- Rx ) deg>rad
-[ dup cos , dup sin neg , 0 ,
- dup sin , dup cos , 0 ,
- 0 , 0 , 1 , ] 3 make-matrix nip ;
-
-: Ry ( angle -- Ry ) deg>rad
-[ dup cos , 0 , dup sin ,
- 0 , 1 , 0 ,
- dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
-
-: Rx ( angle -- Rz ) deg>rad
-[ 1 , 0 , 0 ,
- 0 , dup cos , dup sin neg ,
- 0 , dup sin , dup cos , ] 3 make-matrix nip ;
-
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: apply-rotation ( rotation -- )
- turtle-ori> swap m. >turtle-ori ;
-: rotate-x ( angle -- ) Rx apply-rotation ;
-: rotate-y ( angle -- ) Ry apply-rotation ;
-: rotate-z ( angle -- ) Rz apply-rotation ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pitch-up ( angle -- ) neg rotate-x ;
-: pitch-down ( angle -- ) rotate-x ;
-
-: turn-left ( angle -- ) rotate-y ;
-: turn-right ( angle -- ) neg rotate-y ;
-
-: roll-left ( angle -- ) neg rotate-z ;
-: roll-right ( angle -- ) rotate-z ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! roll-until-horizontal
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: V ( -- V ) { 0 1 0 } ;
-
-: X ( -- 3array ) turtle-ori> [ first ] map ;
-: Y ( -- 3array ) turtle-ori> [ second ] map ;
-: Z ( -- 3array ) turtle-ori> [ third ] map ;
-
-: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
-: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
-: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
-
-: roll-until-horizontal ( -- )
- V Z cross normalize set-X
- Z X cross normalize set-Y ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: distance ( turtle turtle -- n )
- pos>> swap pos>> v- [ sq ] map sum sqrt ;
-
-: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-turtle ( -- )
- { 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: step-vector ( length -- array ) { 0 0 1 } n*v ;
-
-: step-turtle ( length -- )
- step-vector turtle-ori> swap m.v
- turtle-pos> v+ >turtle-pos ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: strafe-up ( length -- )
- 90 pitch-up
- step-turtle
- 90 pitch-down ;
-
-: strafe-down ( length -- )
- 90 pitch-down
- step-turtle
- 90 pitch-up ;
-
-: strafe-left ( length -- )
- 90 turn-left
- step-turtle
- 90 turn-right ;
-
-: strafe-right ( length -- )
- 90 turn-right
- step-turtle
- 90 turn-left ;
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jean-François Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
-IN: 4DNav.window3D
-
-
-
-ARTICLE: "4DNav.window3D" "Window3D"
-{ $vocab-link "4DNav.window3D" }
-;
-
-ABOUT: "4DNav.window3D"
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel \r
-ui.gadgets\r
-ui.render\r
-opengl\r
-opengl.gl\r
-opengl.glu\r
-4DNav.camera\r
-4DNav.turtle\r
-math\r
-values\r
-alien.c-types\r
-accessors\r
-namespaces\r
-adsoda \r
-models\r
-prettyprint\r
-;\r
-\r
-IN: 4DNav.window3D\r
-\r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-! drawing functions \r
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
-\r
-TUPLE: window3D < gadget observer ; \r
-\r
-: <window3D> ( model observer -- gadget )\r
- window3D new\r
- swap 2dup \r
- projection-mode>> add-connection\r
- 2dup \r
- collision-mode>> add-connection\r
- >>observer \r
- swap <model> >>model \r
- t >>root?\r
-;\r
-\r
-M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
-\r
-M: window3D draw-gadget* ( gadget -- )\r
-\r
- GL_PROJECTION glMatrixMode\r
- glLoadIdentity\r
- 0.6 0.6 0.6 .9 glClearColor\r
- dup observer>> projection-mode>> value>> 1 = \r
- [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
- [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
- dup observer>> collision-mode>> value>> \r
- \ remove-hidden-solids? \r
- set-value\r
- dup observer>> do-look-at\r
- GL_MODELVIEW glMatrixMode\r
- glLoadIdentity \r
- 0.9 0.9 0.9 1.0 glClearColor\r
- 1.0 glClearDepth\r
- GL_LINE_SMOOTH glEnable\r
- GL_BLEND glEnable\r
- GL_DEPTH_TEST glEnable \r
- GL_LEQUAL glDepthFunc\r
- GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
- GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
- 1.25 glLineWidth\r
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor \r
- glClear\r
- glLoadIdentity\r
- GL_LIGHTING glEnable\r
- GL_LIGHT0 glEnable\r
- GL_COLOR_MATERIAL glEnable\r
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
- ! *************************\r
- \r
- model>> value>> \r
- [ space->GL ] when*\r
-\r
- ! *************************\r
-;\r
-\r
-M: window3D graft* drop ;\r
-\r
-M: window3D model-changed nip relayout ; \r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax ;\r
-IN: adsoda\r
-\r
-! --------------------------------------------------------------\r
-! faces\r
-! --------------------------------------------------------------\r
-ARTICLE: "face-page" "Face in ADSODA"\r
-"explanation of faces"\r
-$nl\r
-"link to functions" $nl\r
-"what is an halfspace" $nl\r
-"halfspace touching-corners adjacent-faces" $nl\r
-"touching-corners list of pointers to the corners which touch this face" $nl\r
-"adjacent-faces list of pointers to the faces which touch this face"\r
-{ $subsections\r
- face\r
- <face>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-or-on-face?\r
- point-inside-face?\r
-}\r
-"handling face"\r
-{ $subsections\r
- flip-face\r
- face-translate\r
- face-transform\r
-}\r
-\r
-;\r
-\r
-HELP: face\r
-{ $class-description "a face is defined by"\r
-{ $list "halfspace equation" }\r
-{ $list "list of touching corners" }\r
-{ $list "list of adjacent faces" }\r
-$nl\r
-"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
-}\r
-\r
-\r
-;\r
-HELP: <face> \r
-{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
-HELP: flip-face \r
-{ $values { "face" "a face" } { "face" "flipped face" } }\r
-{ $description "change the orientation of a face" }\r
-;\r
-\r
-HELP: face-translate \r
-{ $values { "face" "a face" } { "v" "a vector" } }\r
-{ $description \r
-"translate a face following a vector"\r
-$nl\r
-"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
-\r
- \r
- ;\r
-HELP: face-transform \r
-{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
-{ $description "compute the transformation of a face using a transformation matrix" }\r
- \r
- ;\r
-! --------------------------------\r
-! solid\r
-! --------------------------------------------------------------\r
-ARTICLE: "solid-page" "Solid in ADSODA"\r
-"explanation of solids"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- solid\r
- <solid>\r
-}\r
-"test relative position"\r
-{ $subsections\r
- point-inside-solid?\r
- point-inside-or-on-solid?\r
-}\r
-"playing with faces and solids"\r
-{ $subsections\r
- add-face\r
- cut-solid\r
- slice-solid\r
-}\r
-"solid handling"\r
-{ $subsections\r
- solid-project\r
- solid-translate\r
- solid-transform\r
- subtract\r
- get-silhouette \r
- solid=\r
-}\r
-;\r
-\r
-HELP: solid \r
-{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
-}\r
-;\r
-\r
-HELP: add-face \r
-{ $values { "solid" "a solid" } { "face" "a face" } }\r
-{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
-\r
-HELP: cut-solid\r
-{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
-{ $description "like add-face but just with halfspace equation" } ;\r
-\r
-HELP: slice-solid\r
-{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
-{ $description "cut a solid into two parts. The face acts like a knife"\r
-} ;\r
-\r
-\r
-HELP: solid-project\r
-{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
-{ $description "Project the solid using pv vector" \r
-$nl\r
-"TODO: explain how to use lights"\r
-} ;\r
-\r
-HELP: solid-translate \r
-{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
-{ $description "Translate a solid using a vector" \r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: solid-transform \r
-{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
-{ $description "Transform a solid using a matrix"\r
-$nl\r
-"v and solid must have the same dimension "\r
-} ;\r
-\r
-HELP: subtract \r
-{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
-{ $description "Substract solid2 from solid1" } ;\r
-\r
-\r
-! --------------------------------------------------------------\r
-! space \r
-! --------------------------------------------------------------\r
-ARTICLE: "space-page" "Space in ADSODA"\r
-"A space is a collection of solids and lights."\r
-$nl\r
-"link to functions"\r
-$nl\r
-"Defining words"\r
-{ $subsections\r
- space\r
- <space>\r
- suffix-solids \r
- suffix-lights\r
- clear-space-solids \r
- describe-space\r
-}\r
-\r
-\r
-"Handling space"\r
-{ $subsections\r
- space-ensure-solids\r
- eliminate-empty-solids\r
- space-transform\r
- space-translate\r
- remove-hidden-solids\r
- space-project\r
-}\r
-\r
-\r
-;\r
-\r
-HELP: space \r
-{ $class-description \r
-"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
-}\r
-;\r
-\r
-HELP: suffix-solids \r
-"( space solid -- space )"\r
-{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
-{ $description "Add solid to space definition" } ;\r
-\r
-HELP: suffix-lights \r
-"( space light -- space ) "\r
-{ $values { "space" "a space" } { "light" "a light to add" } }\r
-{ $description "Add a light to space definition" } ;\r
-\r
-HELP: clear-space-solids \r
-"( space -- space )" \r
-{ $values { "space" "a space" } }\r
-{ $description "remove all solids in space" } ;\r
-\r
-HELP: space-ensure-solids \r
-{ $values { "space" "a space" } }\r
-{ $description "rebuild corners of all solids in space" } ;\r
-\r
-\r
-\r
-HELP: space-transform \r
-" ( space m -- space )" \r
-{ $values { "space" "a space" } { "m" "a matrix" } }\r
-{ $description "Transform a space using a matrix" } ;\r
-\r
-HELP: space-translate \r
-{ $values { "space" "a space" } { "v" "a vector" } }\r
-{ $description "Translate a space following a vector" } ;\r
-\r
-HELP: describe-space " ( space -- )"\r
-{ $values { "space" "a space" } }\r
-{ $description "return a description of space" } ;\r
-\r
-HELP: space-project \r
-{ $values { "space" "a space" } { "i" "an integer" } }\r
-{ $description "Project a space along ith coordinate" } ;\r
-\r
-! --------------------------------------------------------------\r
-! 3D rendering\r
-! --------------------------------------------------------------\r
-ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
-"explanation of 3D rendering"\r
-$nl\r
-"link to functions"\r
-{ $subsections\r
- face->GL\r
- solid->GL\r
- space->GL\r
-}\r
-\r
-;\r
-\r
-HELP: face->GL \r
-{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
-{ $description "display a face" } ;\r
-\r
-HELP: solid->GL \r
-{ $values { "solid" "a solid" } }\r
-{ $description "display a solid" } ;\r
-\r
-HELP: space->GL \r
-{ $values { "space" "a space" } }\r
-{ $description "display a space" } ;\r
-\r
-! --------------------------------------------------------------\r
-! light\r
-! --------------------------------------------------------------\r
-\r
-ARTICLE: "light-page" "Light in ADSODA"\r
-"explanation of light"\r
-$nl\r
-"link to functions"\r
-;\r
-\r
-ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
-{ $code """\r
-! HELP: light position color\r
-! <light> ( -- tuple ) light new ;\r
-! light est un vecteur avec 3 variables pour les couleurs\n\r
- void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n\r
- { \n\r
- // Dot the light direction with the normalized normal of Face.\r
- register double intensity = -(normal * (*this));\r
- // Face is a backface, from light's perspective\r
- if (intensity < 0)\r
- return;\r
- \r
- // Add the intensity componentwise\r
- cRed += red * intensity;\r
- cGreen += green * intensity;\r
- cBlue += blue * intensity;\r
- // Clip to unit range\r
- if (cRed > 1.0) cRed = 1.0;\r
- if (cGreen > 1.0) cGreen = 1.0;\r
- if (cBlue > 1.0) cBlue = 1.0;\r
-""" }\r
-;\r
-\r
-\r
-\r
-ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
-" defined by the concatenation of the normal vector and a constant" \r
- ;\r
-\r
-\r
-\r
-ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
-"multidimensional handler :" \r
-$nl\r
-"design a solid using face delimitations. Only works on convex shapes"\r
-$nl\r
-{ $emphasis "written in C++ by Greg Ferrar" }\r
-$nl\r
-"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
-$nl\r
-"Useful words are describe on the following pages: "\r
-{ $subsections\r
- "face-page"\r
- "solid-page"\r
- "space-page"\r
- "light-page"\r
- "3D-rendering-page"\r
-} ;\r
-\r
-ABOUT: "adsoda-main-page"\r
+++ /dev/null
-USING: adsoda\r
-kernel\r
-math\r
-accessors\r
-sequences\r
- adsoda.solution2\r
- fry\r
- tools.test \r
- arrays ;\r
-\r
-IN: adsoda.tests\r
-\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
-\r
-\r
-! {\r
-! { 1 0 0 0 }\r
-! { 0 1 0 0 }\r
-! { 0 0 0.984807753012208 -0.1736481776669303 }\r
-! { 0 0 0.1736481776669303 0.984807753012208 }\r
-! }\r
-\r
-! ------------------------------------------------------------\r
-! constant+\r
-[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! translate\r
-[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! transform\r
-[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 }\r
- } transform \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-! compare-nleft-to-identity-matrix\r
-[ t ] [ \r
- { \r
- { 1 0 0 1232 } \r
- { 0 1 0 0 321 } \r
- { 0 0 1 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
- 3 compare-nleft-to-identity-matrix \r
-] unit-test\r
-! ------------------------------------------------------------\r
-[ t ] [ \r
- { { 1 0 0 }\r
- { 0 1 0 }\r
- { 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 } } 3 valid-solution? \r
-] unit-test\r
-\r
-[ f ] [ \r
- { { 1 0 0 1 }\r
- { 0 0 0 1 }\r
- { 0 0 1 0 } } 2 valid-solution? \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-[ 3 ] [ { 1 2 3 } last ] unit-test \r
-\r
-[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
-\r
-! ------------------------------------------------------------\r
-! position-point \r
-[ 0 ] [ \r
- { 1 -1 -5 } { 2 7 } position-point \r
-] unit-test\r
-\r
-! ------------------------------------------------------------\r
-\r
-! transform\r
-! TODO construire un exemple\r
-\r
-\r
-! ------------------------------------------------------------\r
-! slice-solid \r
-\r
-! ------------------------------------------------------------\r
-! solve-equation \r
-! deux cas de tests, avec solution et sans solution\r
-\r
-[ { 2 7 } ] \r
-[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-[ f ] \r
-[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
-unit-test\r
-\r
-! ------------------------------------------------------------\r
-! point-inside-halfspace\r
-[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
-unit-test\r
-[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
-unit-test\r
-[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
-unit-test\r
-\r
-\r
-! ------------------------------\r
-! order solid\r
-\r
-[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
-[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
-[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
-\r
-\r
-! clip-solid\r
-[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
- [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-\r
-solid1 corners>> '[ _ ]\r
- [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
-solid2 corners>> '[ _ ]\r
- [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
-\r
-!\r
-[\r
- {\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
- }\r
-] [ 0 >pv solid2 solid3 2array \r
- solid1 (solids-silhouette-subtract) \r
- [ corners>> ] map\r
- ] unit-test\r
-\r
-\r
-[\r
-{\r
- { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
- { { 13 15 } { 15 13 } { 13 13 } }\r
- { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
- { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
-}\r
-] [ \r
- 0 >pv <space> solid1 suffix-solids \r
- solid2 suffix-solids \r
- solid3 suffix-solids\r
- remove-hidden-solids\r
- solids>> [ corners>> ] map\r
-] unit-test\r
-\r
-! { }\r
-! { }\r
-! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
-! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
-! suffix \r
-! { 0.1 0.1 0.1 } suffix ! ambient color\r
-! { 0.23 0.32 0.17 } suffix ! solid color\r
-! solid3 faces>> first \r
-\r
-! enlight-projection\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors\r
-arrays \r
-assocs\r
-combinators\r
-kernel \r
-fry\r
-math \r
-math.constants\r
-math.functions\r
-math.libm\r
-math.order\r
-math.vectors \r
-math.matrices \r
-math.parser\r
-namespaces\r
-prettyprint\r
-sequences\r
-sequences.deep\r
-sets\r
-slots\r
-sorting\r
-tools.time\r
-vars\r
-continuations\r
-words\r
-opengl\r
-opengl.gl\r
-colors\r
-adsoda.solution2\r
-adsoda.combinators\r
-opengl.demo-support\r
-values\r
-tools.walker\r
-;\r
-\r
-IN: adsoda\r
-\r
-DEFER: combinations\r
-VAR: pv\r
-\r
-\r
-! -------------------------------------------------------------\r
-! global values\r
-VALUE: remove-hidden-solids?\r
-VALUE: VERY-SMALL-NUM\r
-VALUE: ZERO-VALUE\r
-VALUE: MAX-FACE-PER-CORNER\r
-\r
-t to: remove-hidden-solids?\r
-0.0000001 to: VERY-SMALL-NUM\r
-0.0000001 to: ZERO-VALUE\r
-4 to: MAX-FACE-PER-CORNER\r
-! -------------------------------------------------------------\r
-! sequence complement\r
-\r
-: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
-\r
-: dimension ( array -- x ) length 1 - ; inline \r
-: change-last ( seq quot -- ) \r
- [ [ dimension ] keep ] dip change-nth ; inline\r
-\r
-! -------------------------------------------------------------\r
-! light\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: light name { direction array } color ;\r
-: <light> ( -- tuple ) light new ;\r
-\r
-! -------------------------------------------------------------\r
-! halfspace manipulation\r
-! -------------------------------------------------------------\r
-\r
-: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
-: translate ( u v -- w ) dupd v* sum constant+ ; \r
-\r
-: transform ( u matrix -- w )\r
- [ swap m.v ] 2keep ! compute new normal vector \r
- [\r
- [ [ abs ZERO-VALUE > ] find ] keep \r
- ! find a point on the frontier\r
- ! be sure it's not null vector\r
- last ! get constant\r
- swap /f neg swap ! intercept value\r
- ] dip \r
- flip \r
- nth\r
- [ * ] with map ! apply intercep value\r
- over v*\r
- sum neg\r
- suffix ! add value as constant at the end of equation\r
-;\r
-\r
-: position-point ( halfspace v -- x ) \r
- -1 suffix v* sum ; inline\r
-: point-inside-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM > ; \r
-: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
- position-point VERY-SMALL-NUM neg > ;\r
-: project-vector ( seq -- seq ) \r
- pv> [ head ] [ 1 + tail ] 2bi append ; \r
-: get-intersection ( matrice -- seq ) \r
- [ 1 tail* ] map flip first ;\r
-\r
-: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
-\r
-: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
- [ [ head ] curry map ] keep identity-matrix m- \r
- flatten\r
- [ abs ZERO-VALUE < ] all?\r
-;\r
-\r
-: valid-solution? ( matrice n -- ? )\r
- islenght=?\r
- [ compare-nleft-to-identity-matrix ] \r
- [ 2drop f ] if ; inline\r
-\r
-: intersect-hyperplanes ( matrice -- seq )\r
- [ solution dup ] [ first dimension ] bi\r
- valid-solution? [ get-intersection ] [ drop f ] if ;\r
-\r
-! -------------------------------------------------------------\r
-! faces\r
-! -------------------------------------------------------------\r
-\r
-TUPLE: face { halfspace array } \r
- touching-corners adjacent-faces ;\r
-: <face> ( v -- tuple ) face new swap >>halfspace ;\r
-: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
-: erase-face-touching-corners ( face -- face ) \r
- f >>touching-corners ;\r
-: erase-face-adjacent-faces ( face -- face ) \r
- f >>adjacent-faces ;\r
-: faces-intersection ( faces -- v ) \r
- [ halfspace>> ] map intersect-hyperplanes ;\r
-: face-translate ( face v -- face ) \r
- [ translate ] curry change-halfspace ; inline\r
-: face-transform ( face m -- face )\r
- [ transform ] curry change-halfspace ; inline\r
-: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
-: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
-: pv-factor ( face -- f face ) \r
- halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
-: suffix-touching-corner ( face corner -- face ) \r
- [ suffix ] curry change-touching-corners ; inline\r
-: real-face? ( face -- ? )\r
- [ touching-corners>> length ] \r
- [ halfspace>> dimension ] bi >= ;\r
-\r
-: (add-to-adjacent-faces) ( face face -- face )\r
- over adjacent-faces>> 2dup member?\r
- [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
-\r
-: add-to-adjacent-faces ( face face -- face )\r
- 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
-\r
-: update-adjacent-faces ( faces corner -- )\r
- '[ [ _ suffix-touching-corner drop ] each ] keep \r
- 2 among [ \r
- [ first ] keep second \r
- [ add-to-adjacent-faces drop ] 2keep \r
- swap add-to-adjacent-faces drop \r
- ] each ; inline\r
-\r
-: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
-\r
-: apply-light ( color light normal -- u )\r
- over direction>> v. \r
- neg dup 0 > \r
- [ \r
- [ color>> swap ] dip \r
- [ * ] curry map v+ \r
- [ 1 min ] map \r
- ] \r
- [ 2drop ] \r
- if\r
-;\r
-\r
-: enlight-projection ( array face -- color )\r
- ! array = lights + ambient color\r
- [ [ third ] [ second ] [ first ] tri ]\r
- [ halfspace>> project-vector normalize ] bi*\r
- [ apply-light ] curry each\r
- v*\r
-;\r
-\r
-: (intersection-into-face) ( face-init face-adja quot -- face )\r
- [\r
- [ [ pv-factor ] bi@ \r
- roll \r
- [ map ] 2bi@\r
- v-\r
- ] 2keep\r
- [ touching-corners>> ] bi@\r
- [ swap [ = ] curry find nip f = ] curry find nip\r
- ] dip over\r
- [\r
- call\r
- dupd\r
- point-inside-halfspace? [ vneg ] unless \r
- <face> \r
- ] [ 3drop f ] if \r
- ; inline\r
-\r
-: intersection-into-face ( face-init face-adja -- face )\r
- [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
-\r
-: intersection-into-silhouette-face ( face-init face-adja -- face )\r
- [ ] (intersection-into-face) ;\r
-\r
-: intersections-into-faces ( face -- faces )\r
- clone dup \r
- adjacent-faces>> [ intersection-into-face ] with map \r
- [ ] filter ;\r
-\r
-: (face-silhouette) ( face -- faces )\r
- clone dup adjacent-faces>>\r
- [ backface?\r
- [ intersection-into-silhouette-face ] [ 2drop f ] if \r
- ] with map \r
- [ ] filter\r
-; inline\r
-\r
-: face-silhouette ( face -- faces ) \r
- backface? [ drop f ] [ (face-silhouette) ] if ;\r
-\r
-! --------------------------------\r
-! solid\r
-! -------------------------------------------------------------\r
-TUPLE: solid dimension silhouettes \r
- faces corners adjacencies-valid color name ;\r
-\r
-: <solid> ( -- tuple ) solid new ;\r
-\r
-: suffix-silhouettes ( solid silhouette -- solid ) \r
- [ suffix ] curry change-silhouettes ;\r
-\r
-: suffix-face ( solid face -- solid ) \r
- [ suffix ] curry change-faces ;\r
-: suffix-corner ( solid corner -- solid ) \r
- [ suffix ] curry change-corners ; \r
-: erase-solid-corners ( solid -- solid ) f >>corners ;\r
-\r
-: erase-silhouettes ( solid -- solid ) \r
- dup dimension>> f <array> >>silhouettes ;\r
-: filter-real-faces ( solid -- solid ) \r
- [ [ real-face? ] filter ] change-faces ;\r
-: initiate-solid-from-face ( face -- solid ) \r
- face-project-dim <solid> swap >>dimension ;\r
-\r
-: erase-old-adjacencies ( solid -- solid )\r
- erase-solid-corners\r
- [ dup [ erase-face-touching-corners \r
- erase-face-adjacent-faces drop ] each ]\r
- change-faces ;\r
-\r
-: point-inside-or-on-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
-\r
-: point-inside-face? ( face v -- ? ) \r
- [ halfspace>> ] dip point-inside-halfspace? ;\r
-\r
-: point-inside-solid? ( solid point -- ? )\r
- [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
-\r
-: point-inside-or-on-solid? ( solid point -- ? )\r
- [ faces>> ] dip \r
- [ point-inside-or-on-face? ] curry all? ; inline\r
-\r
-: unvalid-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies f >>adjacencies-valid \r
- erase-silhouettes ;\r
-\r
-: add-face ( solid face -- solid ) \r
- suffix-face unvalid-adjacencies ; \r
-\r
-: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
-\r
-: slice-solid ( solid face -- solid1 solid2 )\r
- [ [ clone ] bi@ flip-face add-face \r
- [ "/outer/" append ] change-name ] 2keep\r
- add-face [ "/inner/" append ] change-name ;\r
-\r
-! -------------\r
-\r
-\r
-: add-silhouette ( solid -- solid )\r
- dup \r
- ! find-adjacencies \r
- faces>> { } \r
- [ face-silhouette append ] reduce\r
- [ ] filter \r
- <solid> \r
- swap >>faces\r
- over dimension>> >>dimension \r
- over name>> " silhouette " append \r
- pv> number>string append \r
- >>name\r
- ! ensure-adjacencies\r
- suffix-silhouettes ; inline\r
-\r
-: find-silhouettes ( solid -- solid )\r
- { } >>silhouettes \r
- dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
-\r
-: ensure-silhouettes ( solid -- solid )\r
- dup silhouettes>> [ f = ] all?\r
- [ find-silhouettes ] when ; \r
-\r
-! ------------\r
-\r
-: corner-added? ( solid corner -- ? ) \r
- ! add corner to solid if it is inside solid\r
- [ ] \r
- [ point-inside-or-on-solid? ] \r
- [ swap corners>> member? not ] \r
- 2tri and\r
- [ suffix-corner drop t ] [ 2drop f ] if ;\r
-\r
-: process-corner ( solid faces corner -- )\r
- swapd \r
- [ corner-added? ] keep swap ! test if corner is inside solid\r
- [ update-adjacent-faces ] \r
- [ 2drop ]\r
- if ;\r
-\r
-: compute-intersection ( solid faces -- )\r
- dup faces-intersection\r
- dup f = [ 3drop ] [ process-corner ] if ;\r
-\r
-: test-faces-combinaisons ( solid n -- )\r
- [ dup faces>> ] dip among \r
- [ compute-intersection ] with each ;\r
-\r
-: compute-adjacencies ( solid -- solid )\r
- dup dimension>> [ >= ] curry \r
- [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
- [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
-\r
-: find-adjacencies ( solid -- solid ) \r
- erase-old-adjacencies \r
- compute-adjacencies\r
- filter-real-faces \r
- t >>adjacencies-valid ;\r
-\r
-: ensure-adjacencies ( solid -- solid ) \r
- dup adjacencies-valid>> \r
- [ find-adjacencies ] unless \r
- ensure-silhouettes\r
- ;\r
-\r
-: (non-empty-solid?) ( solid -- ? ) \r
- [ dimension>> ] [ corners>> length ] bi < ;\r
-: non-empty-solid? ( solid -- ? ) \r
- ensure-adjacencies (non-empty-solid?) ;\r
-\r
-: compare-corners-roughly ( corner corner -- ? )\r
- 2drop t ;\r
-! : remove-inner-faces ( -- ) ;\r
-: face-project ( array face -- seq )\r
- backface? \r
- [ 2drop f ]\r
- [ [ enlight-projection ] \r
- [ initiate-solid-from-face ]\r
- [ intersections-into-faces ] tri\r
- >>faces\r
- swap >>color \r
- ] if ;\r
-\r
-: solid-project ( lights ambient solid -- solids )\r
- ensure-adjacencies\r
- [ color>> ] [ faces>> ] bi [ 3array ] dip\r
- [ face-project ] with map \r
- [ ] filter \r
- [ ensure-adjacencies ] map\r
-;\r
-\r
-: (solid-move) ( solid v move -- solid ) \r
- curry [ map ] curry \r
- [ dup faces>> ] dip call drop \r
- unvalid-adjacencies ; inline\r
-\r
-: solid-translate ( solid v -- solid ) \r
- [ face-translate ] (solid-move) ; \r
-: solid-transform ( solid m -- solid ) \r
- [ face-transform ] (solid-move) ; \r
-\r
-: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
- pv> swap silhouettes>> nth \r
- swap corners>>\r
- [ point-inside-solid? ] with find swap ;\r
-\r
-: valid-face-for-order ( solid point -- face )\r
- [ point-inside-face? not ] \r
- [ drop face-orientation 0 = not ] 2bi and ;\r
-\r
-: check-orientation ( s1 s2 pt -- int )\r
- [ nip faces>> ] dip\r
- [ valid-face-for-order ] curry find swap\r
- [ face-orientation ] [ drop f ] if ;\r
-\r
-: (order-solid) ( s1 s2 -- int )\r
- 2dup find-corner-in-silhouette\r
- [ check-orientation ] [ 3drop f ] if ;\r
-\r
-: order-solid ( solid solid -- i ) \r
- 2dup (order-solid)\r
- [ 2nip ]\r
- [ swap (order-solid)\r
- [ neg ] [ f ] if*\r
- ] if* ;\r
-\r
-: subtract ( solid1 solid2 -- solids )\r
- faces>> swap clone ensure-adjacencies ensure-silhouettes \r
- [ swap slice-solid drop ] curry map\r
- [ non-empty-solid? ] filter\r
- [ ensure-adjacencies ] map\r
-; inline\r
-\r
-! -------------------------------------------------------------\r
-! space \r
-! -------------------------------------------------------------\r
-TUPLE: space name dimension solids ambient-color lights ;\r
-: <space> ( -- space ) space new ;\r
-: suffix-solids ( space solid -- space ) \r
- [ suffix ] curry change-solids ; inline\r
-: suffix-lights ( space light -- space ) \r
- [ suffix ] curry change-lights ; inline\r
-: clear-space-solids ( space -- space ) f >>solids ;\r
-\r
-: space-ensure-solids ( space -- space ) \r
- [ [ ensure-adjacencies ] map ] change-solids ;\r
-: eliminate-empty-solids ( space -- space ) \r
- [ [ non-empty-solid? ] filter ] change-solids ;\r
-\r
-: projected-space ( space solids -- space ) \r
- swap dimension>> 1 - <space> \r
- swap >>dimension swap >>solids ;\r
-\r
-: get-silhouette ( solid -- silhouette ) \r
- silhouettes>> pv> swap nth ;\r
-: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
-\r
-: space-apply ( space m quot -- space ) \r
- curry [ map ] curry [ dup solids>> ] dip\r
- [ call ] [ 2drop ] recover drop ; inline\r
-: space-transform ( space m -- space ) \r
- [ solid-transform ] space-apply ;\r
-: space-translate ( space v -- space ) \r
- [ solid-translate ] space-apply ; \r
-\r
-: describe-space ( space -- ) \r
- solids>> \r
- [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
-\r
-: clip-solid ( solid solid -- solids )\r
- [ ]\r
- [ solid= not ]\r
- [ order-solid -1 = ] 2tri \r
- and\r
- [ get-silhouette subtract ] \r
- [ drop 1array ] \r
- if \r
- \r
- ;\r
-\r
-: (solids-silhouette-subtract) ( solids solid -- solids ) \r
- [ clip-solid append ] curry { } -rot each ; inline\r
-\r
-: solids-silhouette-subtract ( solids i solid -- solids )\r
-! solids is an array of 1 solid arrays\r
- [ (solids-silhouette-subtract) ] curry map-but \r
-; inline \r
-\r
-: remove-hidden-solids ( space -- space ) \r
-! We must include each solid in a sequence because \r
-! during substration \r
-! a solid can be divided in more than on solid\r
- [ \r
- [ [ 1array ] map ] \r
- [ length ] \r
- [ ] \r
- tri \r
- [ solids-silhouette-subtract ] 2each\r
- { } [ append ] reduce \r
- ] change-solids\r
- eliminate-empty-solids ! TODO include into change-solids\r
-;\r
-\r
-: space-project ( space i -- space )\r
- [\r
- [ clone \r
- remove-hidden-solids? [ remove-hidden-solids ] when\r
- dup \r
- [ solids>> ] \r
- [ lights>> ] \r
- [ ambient-color>> ] tri \r
- [ rot solid-project ] 2curry \r
- map \r
- [ append ] { } -rot each \r
- ! TODO project lights\r
- projected-space \r
- ! remove-inner-faces \r
- ! \r
- eliminate-empty-solids\r
- ] with-pv \r
- ] [ 3drop <space> ] recover\r
- ; inline\r
-\r
-: middle-of-space ( space -- point )\r
- solids>> [ corners>> ] map concat\r
- [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
-;\r
-\r
-! -------------------------------------------------------------\r
-! 3D rendering\r
-! -------------------------------------------------------------\r
-\r
-: face-reference ( face -- halfspace point vect )\r
- [ halfspace>> ] \r
- [ touching-corners>> first ] \r
- [ touching-corners>> second ] tri \r
- over v-\r
-;\r
-\r
-: theta ( v halfspace point vect -- v x )\r
- [ [ over ] dip v- ] dip \r
- [ cross dup norm >float ]\r
- [ v. >float ] \r
- 2bi \r
- fatan2\r
- -rot v. \r
- 0 < [ neg ] when\r
-;\r
-\r
-: ordered-face-points ( face -- corners ) \r
- [ touching-corners>> 1 head ] \r
- [ touching-corners>> 1 tail ] \r
- [ face-reference [ theta ] 3curry ] tri\r
- { } map>assoc sort-values keys \r
- append\r
- ; inline\r
-\r
-: point->GL ( point -- ) gl-vertex ;\r
-: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
-\r
-: face->GL ( face color -- )\r
- [ ordered-face-points ] dip\r
- [ first3 1.0 glColor4d GL_POLYGON \r
- [ [ point->GL ] each ] do-state ] curry\r
- [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
- [ [ point->GL ] each ] do-state ]\r
- bi\r
- ; inline\r
-\r
-: solid->GL ( solid -- ) \r
- [ faces>> ] \r
- [ color>> ] bi\r
- [ face->GL ] curry each ; inline\r
-\r
-: space->GL ( space -- )\r
- solids>>\r
- [ solid->GL ] each ;\r
-\r
-\r
-\r
-\r
-\r
+++ /dev/null
-! : init-4D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 4 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
- { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-! : init-3D-demo ( -- space )\r
-! OK\r
-! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
-<space> \r
- 3 >>dimension\r
- { 0.3 0.3 0.3 } >>ambient-color\r
- { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
- ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
- <light>\r
- { -100 -100 -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-! ;\r
-\r
-\r
-: s1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "s1" >>name\r
- { 1 1 1 } >>color\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-: solid1 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid1" >>name\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-: solid2 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid2" >>name\r
- { -1 1 -10 } cut-solid \r
- { -1 -1 -28 } cut-solid \r
- { 1 0 13 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid3 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid3" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 16 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ! { 1 2 16 } cut-solid\r
- ensure-adjacencies\r
- \r
-\r
-;\r
-\r
-: solid4 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid4" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 21 } cut-solid \r
- { -1 0 -36 } cut-solid \r
- { 0 1 1 } cut-solid \r
- { 0 -1 -17 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid5 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid5" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 6 } cut-solid \r
- { -1 0 -17 } cut-solid \r
- { 0 1 17 } cut-solid \r
- { 0 -1 -19 } cut-solid \r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid7 ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- "solid7" >>name\r
- { 1 1 1 } >>color\r
- { 1 0 38 } cut-solid \r
- { 1 -5 -66 } cut-solid \r
- { -2 1 -75 } cut-solid\r
- ensure-adjacencies\r
- \r
-;\r
-\r
-: solid6s ( -- seq )\r
- solid3 clone solid2 clone subtract\r
-;\r
-\r
-: space1 ( -- space )\r
- <space>\r
- 2 >>dimension\r
- ! solid3 suffix-solids\r
- solid1 suffix-solids\r
- solid2 suffix-solids\r
- ! solid6s [ suffix-solids ] each \r
- solid4 suffix-solids\r
- ! solid5 suffix-solids\r
- solid7 suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-;\r
-\r
-: space2 ( -- space )\r
- <space>\r
- 4 >>dimension\r
- ! 4cube suffix-solids\r
- { 1 1 1 } >>ambient-color\r
- <light>\r
- { -100 -100 } >>position\r
- { 0.2 0.7 0.1 } >>color\r
- suffix-lights\r
-\r
- ;\r
-\r
+++ /dev/null
-Jeff Bigot\r
-Greg Ferrar
\ No newline at end of file
+++ /dev/null
-JF Bigot, after Greg Ferrar
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.combinators
-
-HELP: among
-{ $values
- { "array" array } { "n" "number of value to select" }
- { "array" array }
-}
-{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
-
-HELP: columnize
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "flip a sequence into a sequence of 1 element sequences" } ;
-
-HELP: concat-nth
-{ $values
- { "seq1" sequence } { "seq2" sequence }
- { "seq" sequence }
-}
-{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
-
-HELP: do-cycle
-{ $values
- { "array" array }
- { "array" array }
-}
-{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
-
-
-ARTICLE: "adsoda.combinators" "Combinators"
-{ $vocab-link "adsoda.combinators" }
-;
-
-ABOUT: "adsoda.combinators"
+++ /dev/null
-USING: adsoda.combinators\r
-sequences\r
- tools.test \r
- ;\r
-\r
-IN: adsoda.combinators.tests\r
-\r
-\r
-[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
- unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel arrays sequences fry math combinators ;\r
-\r
-IN: adsoda.combinators\r
-\r
-! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
-\r
-! : prefix-each [ prefix ] curry map ; inline\r
-\r
-! : combinations ( seq n -- seqs )\r
-! {\r
-! { [ dup 0 = ] [ 2drop { { } } ] }\r
-! { [ over empty? ] [ 2drop { } ] }\r
-! { [ t ] [ \r
-! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
-! [ (combinations) ] 2bi append\r
-! ] }\r
-! } cond ;\r
-\r
-: columnize ( array -- array ) [ 1array ] map ; inline\r
-\r
-: among ( array n -- array )\r
- 2dup swap length \r
- {\r
- { [ over 1 = ] [ 3drop columnize ] }\r
- { [ over 0 = ] [ 2drop 2drop { } ] }\r
- { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
- [ 1 - among [ append ] with map ] \r
- [ among append ] 2bi\r
- ] }\r
- { [ 2dup = ] [ 3drop 1array ] }\r
- { [ 2dup > ] [ 2drop 2drop { } ] } \r
- } cond\r
-;\r
-\r
-: concat-nth ( seq1 seq2 -- seq ) \r
- [ nth append ] curry map-index ;\r
-\r
-: do-cycle ( array -- array ) dup first suffix ;\r
-\r
-: map-but ( seq i quot -- seq )\r
- ! quot : ( seq x -- seq )\r
- '[ _ = [ @ ] unless ] map-index ; inline\r
-\r
+++ /dev/null
-USING: kernel\r
-sequences\r
-namespaces\r
-\r
-math\r
-math.vectors\r
-math.matrices\r
-;\r
-IN: adsoda.solution2\r
-\r
-! -------------------\r
-! correctif solution\r
-! ---------------\r
-SYMBOL: matrix\r
-: MIN-VAL-adsoda ( -- x ) 0.00000001\r
-! 0.000000000001 \r
-;\r
-\r
-: zero? ( x -- ? ) \r
- abs MIN-VAL-adsoda <\r
-;\r
-\r
-! [ number>string string>number ] map \r
-\r
-: with-matrix ( matrix quot -- )\r
- [ swap matrix set call matrix get ] with-scope ; inline\r
-\r
-: nth-row ( row# -- seq ) matrix get nth ;\r
-\r
-: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
- matrix get swap change-nth ; inline\r
-\r
-: exchange-rows ( row# row# -- ) matrix get exchange ;\r
-\r
-: rows ( -- n ) matrix get length ;\r
-\r
-: cols ( -- n ) 0 nth-row length ;\r
-\r
-: skip ( i seq quot -- n )\r
- over [ find-from drop ] dip length or ; inline\r
-\r
-: first-col ( row# -- n )\r
- #! First non-zero column\r
- 0 swap nth-row [ zero? not ] skip ;\r
-\r
-: clear-scale ( col# pivot-row i-row -- n )\r
- [ over ] dip nth dup zero? [\r
- 3drop 0\r
- ] [\r
- [ nth dup zero? ] dip swap [\r
- 2drop 0\r
- ] [\r
- swap / neg\r
- ] if\r
- ] if ;\r
-\r
-: (clear-col) ( col# pivot-row i -- )\r
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
-\r
-: rows-from ( row# -- slice )\r
- rows dup <slice> ;\r
-\r
-: clear-col ( col# row# rows -- )\r
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
-\r
-: do-row ( exchange-with row# -- )\r
- [ exchange-rows ] keep\r
- [ first-col ] keep\r
- dup 1 + rows-from clear-col ;\r
-\r
-: find-row ( row# quot -- i elt )\r
- [ rows-from ] dip find ; inline\r
-\r
-: pivot-row ( col# row# -- n )\r
- [ dupd nth-row nth zero? not ] find-row 2nip ;\r
-\r
-: (echelon) ( col# row# -- )\r
- over cols < over rows < and [\r
- 2dup pivot-row [ over do-row 1 + ] when*\r
- [ 1 + ] dip (echelon)\r
- ] [\r
- 2drop\r
- ] if ;\r
-\r
-: echelon ( matrix -- matrix' )\r
- [ 0 0 (echelon) ] with-matrix ;\r
-\r
-: nonzero-rows ( matrix -- matrix' )\r
- [ [ zero? ] all? not ] filter ;\r
-\r
-: null/rank ( matrix -- null rank )\r
- echelon dup length swap nonzero-rows length [ - ] keep ;\r
-\r
-: leading ( seq -- n elt ) [ zero? not ] find ;\r
-\r
-: reduced ( matrix' -- matrix'' )\r
- [\r
- rows <reversed> [\r
- dup nth-row leading drop\r
- dup [ swap dup clear-col ] [ 2drop ] if\r
- ] each\r
- ] with-matrix ;\r
-\r
-: basis-vector ( row col# -- )\r
- [ clone ] dip\r
- [ swap nth neg recip ] 2keep\r
- [ 0 spin set-nth ] 2keep\r
- [ n*v ] dip\r
- matrix get set-nth ;\r
-\r
-: nullspace ( matrix -- seq )\r
- echelon reduced dup empty? [\r
- dup first length identity-matrix [\r
- [\r
- dup leading drop\r
- dup [ basis-vector ] [ 2drop ] if\r
- ] each\r
- ] with-matrix flip nonzero-rows\r
- ] unless ;\r
-\r
-: 1-pivots ( matrix -- matrix )\r
- [ dup leading nip [ recip v*n ] when* ] map ;\r
-\r
-: solution ( matrix -- matrix )\r
- echelon nonzero-rows reduced 1-pivots ;\r
-\r
+++ /dev/null
-A modification of solution to approximate solutions
\ No newline at end of file
+++ /dev/null
-ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
+++ /dev/null
-adsoda 4D viewer
\ No newline at end of file
+++ /dev/null
-Jeff Bigot
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays help.markup help.syntax kernel sequences ;
-IN: adsoda.tools
-
-HELP: 3cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax"
-"returns a 3D solid with given limits"
-} ;
-
-HELP: 4cube
-{ $values
- { "array" "array" } { "name" "name" }
- { "solid" "solid" }
-}
-{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
-"returns a 4D solid with given limits"
-} ;
-
-
-HELP: equation-system-for-normal
-{ $values
- { "points" "a list of n points" }
- { "matrix" "matrix" }
-}
-{ $description "From a list of points, return the matrix"
-"to solve in order to find the vector normal to the plan defined by the points" }
-;
-
-HELP: normal-vector
-{ $values
- { "points" "a list of n points" }
- { "v" "a vector" }
-}
-{ $description "From a list of points, returns the vector normal to the plan defined by the points"
-"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
-"returns { f } if a normal vector can not be found" }
-;
-
-HELP: points-to-hyperplane
-{ $values
- { "points" "a list of n points" }
- { "hyperplane" "an hyperplane equation" }
-}
-{ $description "From a list of points, returns the equation of the hyperplan"
-"Finds a normal vector and then translate it so that it includes one of the points"
-
-}
-;
-
-ARTICLE: "adsoda.tools" "Tools"
-{ $vocab-link "adsoda.tools" }
-"Tools to help in building an " { $vocab-link "adsoda" } "-space"
-;
-
-ABOUT: "adsoda.tools"
-
-
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-adsoda.tools\r
-tools.test\r
-;\r
-\r
-IN: adsoda.tools.tests\r
-\r
-\r
- [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
- [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
-\r
- [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Jeff Bigot\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: \r
-kernel\r
-sequences\r
-math\r
-accessors\r
-adsoda\r
-math.vectors \r
-math.matrices\r
-bunny.model\r
-io.encodings.ascii\r
-io.files\r
-sequences.deep\r
-combinators\r
-adsoda.combinators\r
-fry\r
-io.files.temp\r
-grouping\r
-;\r
-\r
-IN: adsoda.tools\r
-\r
-\r
-\r
-\r
-\r
-! ---------------------------------\r
-: coord-min ( x array -- array ) swap suffix ;\r
-: coord-max ( x array -- array ) swap neg suffix ;\r
-\r
-: 4cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 4 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
- [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
- [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
- [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-: 3cube ( array name -- solid )\r
-! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
- <solid> \r
- 3 >>dimension\r
- swap >>name\r
- swap\r
- { \r
- [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
- [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
- [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
- }\r
- [ curry call ] 2map \r
- [ cut-solid ] each \r
- ensure-adjacencies\r
- \r
-; inline\r
-\r
-\r
-: equation-system-for-normal ( points -- matrix )\r
- unclip [ v- 0 suffix ] curry map\r
- dup first [ drop 1 ] map suffix\r
-;\r
-\r
-: normal-vector ( points -- v ) \r
- equation-system-for-normal\r
- intersect-hyperplanes ;\r
-\r
-: points-to-hyperplane ( points -- hyperplane )\r
- [ normal-vector 0 suffix ] [ first ] bi\r
- translate ;\r
-\r
-: refs-to-points ( points faces -- faces )\r
- [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
- with map\r
-;\r
-! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
-! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
-\r
-: ply-model-path ( -- path )\r
-\r
-! "bun_zipper.ply" \r
-"screw2.ply"\r
-temp-file \r
-;\r
-\r
-: read-bunny-model ( -- v )\r
-ply-model-path ascii [ parse-model ] with-file-reader\r
-\r
-refs-to-points\r
-;\r
-\r
-: 3points-to-normal ( seq -- v )\r
- unclip [ v- ] curry map first2 cross normalize\r
-;\r
-: 2-faces-to-prism ( seq seq -- seq )\r
- 2dup\r
- [ do-cycle 2 clump ] bi@ concat-nth \r
- ! 3 faces rectangulaires\r
- swap prefix\r
- swap prefix\r
-; \r
-\r
-: Xpoints-to-prisme ( seq height -- cube )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube of height "height"\r
- ! and of based on the three points\r
- ! a face is a group of 3 or mode points. \r
- [ dup dup 3points-to-normal ] dip \r
- v*n [ v+ ] curry map ! 2 eme face triangulaire \r
- 2-faces-to-prism \r
-\r
-! [ dup number? [ 1 + ] when ] deep-map\r
-! dup keep \r
-;\r
-\r
-\r
-: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
- ! from 3 points gives a list of faces representing \r
- ! a cube in 4th dim\r
- ! from x to y (height = y-x)\r
- ! and of based on the X points\r
- ! a face is a group of 3 or mode points. \r
- '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
- 2-faces-to-prism\r
-;\r
-\r
-: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
- [ 1 Xpoints-to-prisme [ 100 \r
- 110 Xpoints-to-plane4D ] map concat ] map \r
-\r
-;\r
-\r
-: test-figure ( -- solid )\r
- <solid> \r
- 2 >>dimension\r
- { 1 -1 -5 } cut-solid \r
- { -1 -1 -21 } cut-solid \r
- { -1 0 -12 } cut-solid \r
- { 1 2 16 } cut-solid\r
-;\r
-\r
: parse-data-map-effect ( accum -- accum )
")" parse-effect
- [ in>> [ (parse-c-type) ] map parsed ]
- [ out>> [ (parse-c-type) ] map parsed ] bi ;
+ [ in>> [ (parse-c-type) ] map suffix! ]
+ [ out>> [ (parse-c-type) ] map suffix! ] bi ;
PRIVATE>
SYNTAX: data-map(
- parse-data-map-effect \ data-map parsed ;
+ parse-data-map-effect \ data-map suffix! ;
SYNTAX: data-map!(
- parse-data-map-effect \ data-map! parsed ;
+ parse-data-map-effect \ data-map! suffix! ;
} 1&&
] unit-test
-[ { four three } ] [ BROKENs natural-sort ] unit-test
-[ { five } ] [ TODOs ] unit-test
+[ t ] [
+ BROKENs { [ \ four swap member? ] [ \ three swap member? ] } 1&&
+] unit-test
+
+[ t ] [ TODOs \ five swap member? ] unit-test
<<
: (parse-annotation) ( accum -- accum )
- lexer get [ line-text>> parsed ] [ next-line ] bi ;
+ lexer get [ line-text>> suffix! ] [ next-line ] bi ;
: (non-annotation-usage) ( word -- usages )
smart-usage
WHERE
: (NAME) ( str -- ) drop ; inline
-SYNTAX: !NAME (parse-annotation) \ (NAME) parsed ;
+SYNTAX: !NAME (parse-annotation) \ (NAME) suffix! ;
: NAMEs ( -- usages )
\ (NAME) (non-annotation-usage) ;
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ;
+ [ [ dupd process-day ] ] 2dip swap each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
1 10 [a,b] [| d |
a b c d 24-from-4
] count
- ] sigma
- ] sigma
- ] sigma ;
+ ] map-sum
+ ] map-sum
+ ] map-sum ;
CONSTANT: words { 24-from-1 24-from-2 24-from-3 24-from-4 }
:: (count-numbers) ( remaining first value used max listener: ( -- ) -- ? )
10 first - iota [| 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
+ i first + :> digit
+ digit 2^ :> mask
+ i value + :> 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
- ] [ f ] if
- ]
+ ] if
+ ] [ f ] if
] any? ; inline recursive
:: count-numbers ( max listener -- )
inline
:: beust ( -- )
- [let | i! [ 0 ] |
- 5000000000 [ i 1 + i! ] count-numbers
- i number>string " unique numbers." append print
- ] ;
+ 0 :> i!
+ 5000000000 [ i 1 + i! ] count-numbers
+ i number>string " unique numbers." append print ;
MAIN: beust
IN: benchmark.e-ratios
: calculate-e-ratios ( n -- e )
- iota [ factorial recip ] sigma ;
+ iota [ factorial recip ] map-sum ;
: calculate-e-ratios-benchmark ( -- )
5 [ 300 calculate-e-ratios drop ] times ;
: count-flips ( perm -- flip# )
'[
_ dup first dup 1 =
- [ 2drop f ] [ head-slice reverse-here t ] if
+ [ 2drop f ] [ head-slice reverse! drop t ] if
] count ; inline
: write-permutation ( perm -- )
[ make-random-fasta ] 2curry split-lines ; inline
:: make-repeat-fasta ( k len alu -- k' )
- [let | kn [ alu length ] |
- len [ k + kn mod alu nth-unsafe ] "" map-as print
- k len +
- ] ; inline
+ alu length :> kn
+ len [ k + kn mod alu nth-unsafe ] "" map-as print
+ k len + ; inline
: write-repeat-fasta ( n alu desc id -- )
write-description
- [let | k! [ 0 ] alu [ ] |
+ [let
+ :> alu
+ 0 :> k!
[| len | k len alu make-repeat-fasta k! ] split-lines
] ; inline
: fasta ( n out -- )
homo-sapiens make-cumulative
IUB make-cumulative
- [let | homo-sapiens-floats [ ]
- homo-sapiens-chars [ ]
- IUB-floats [ ]
- IUB-chars [ ]
- out [ ]
- n [ ]
- seed [ initial-seed ] |
+ [let
+ :> ( n out IUB-chars IUB-floats homo-sapiens-chars homo-sapiens-floats )
+ initial-seed :> seed
out ascii [
n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
initial-seed
- n 3 * homo-sapiens-chars homo-sapiens-floats "IUB ambiguity codes" "TWO" write-random-fasta
- n 5 * IUB-chars IUB-floats "Homo sapiens frequency" "THREE" write-random-fasta
+ n 3 * homo-sapiens-chars homo-sapiens-floats
+ "IUB ambiguity codes" "TWO" write-random-fasta
+ n 5 * IUB-chars IUB-floats
+ "Homo sapiens frequency" "THREE" write-random-fasta
drop
] with-file-writer
-
] ;
: run-fasta ( -- ) 2500000 reverse-complement-in fasta ;
-USING: kernel io io.files splitting strings io.encodings.ascii
+USING: kernel locals io io.files splitting strings io.encodings.ascii
hashtables sequences assocs math namespaces prettyprint
math.parser combinators arrays sorting unicode.case ;
CHAR: \n swap remove >upper ;
: tally ( x exemplar -- b )
- clone tuck
- [
- [ [ 1 + ] [ 1 ] if* ] change-at
- ] curry each ;
+ clone [ [ inc-at ] curry each ] keep ;
: small-groups ( x n -- b )
swap
] each
drop ;
-: handle-n ( inputs x -- )
- tuck length
- small-groups H{ } tally
- at [ 0 ] unless*
+:: handle-n ( inputs x -- )
+ inputs x length small-groups :> groups
+ groups H{ } tally :> b
+ x b at [ 0 ] unless*
number>string 8 CHAR: \s pad-tail write ;
: process-input ( input -- )
] if ; inline recursive
: nsieve ( m -- count )
- 0 2 rot 1 + <byte-array> dup [ drop 1 ] change-each (nsieve) ;
+ 0 2 rot 1 + <byte-array> [ drop 1 ] map! (nsieve) ;
: nsieve. ( m -- )
[ "Primes up to " % dup # " " % nsieve # ] "" make print ;
TR: trans-map ch>upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ;
: translate-seq ( seq -- str )
- concat dup reverse-here dup trans-map-fast ;
+ concat reverse! dup trans-map-fast ;
: show-seq ( seq -- )
translate-seq 60 <groups> [ print ] each ;
: do-line ( seq line -- seq )
- dup first ">;" memq?
+ dup first ">;" member-eq?
[ over show-seq print dup delete-all ] [ over push ] if ;
HINTS: do-line vector string ;
iota [ <point> ] float-4-array{ } map-as ; inline
: normalize-points ( points -- )
- [ normalize ] change-each ; inline
+ [ normalize ] map! drop ; inline
: max-points ( points -- point )
[ ] [ vmax ] map-reduce ; inline
[ 1 + ] change-x
[ 1 - ] change-y
[ 1 + 2 / ] change-z
- ] map [ z>> ] sigma
- ] sigma . ;
+ ] map [ z>> ] map-sum
+ ] map-sum . ;
MAIN: tuple-array-benchmark
{ v void* } ;
:: fake-data ( -- rgb yuv )
- [let* | w [ 1600 ]
- h [ 1200 ]
- buffer [ yuv_buffer <struct> ]
- rgb [ w h * 3 * <byte-array> ] |
- rgb buffer
- w >>y_width
- h >>y_height
- h >>uv_height
- w >>y_stride
- w >>uv_stride
- w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
- w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
- w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
- ] ;
+ 1600 :> w
+ 1200 :> h
+ yuv_buffer <struct> :> buffer
+ w h * 3 * <byte-array> :> rgb
+ rgb buffer
+ w >>y_width
+ h >>y_height
+ h >>uv_height
+ w >>y_stride
+ w >>uv_stride
+ w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
+ w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
+ w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v ;
: clamp ( n -- n )
255 min 0 max ; inline
USING: accessors alien.c-types arrays combinators destructors
http.client io io.encodings.ascii io.files io.files.temp kernel
-math math.matrices math.parser math.vectors opengl
+locals math math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
splitting vectors words specialized-arrays ;
QUALIFIED-WITH: alien.c-types c
over download-to
] unless ;
-: (draw-triangle) ( ns vs triple -- )
- [ dup roll nth gl-normal swap nth gl-vertex ] with with each ;
+:: (draw-triangle) ( ns vs triple -- )
+ triple [| elt |
+ elt ns nth gl-normal
+ elt vs nth gl-vertex
+ ] each ;
: draw-triangles ( ns vs is -- )
GL_TRIANGLES [ [ (draw-triangle) ] with with each ] do-state ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors c.lexer kernel sequence-parser tools.test ;
+USING: accessors c.lexer kernel sequences.parser tools.test ;
IN: c.lexer.tests
[ 36 ]
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit
generalizations kernel locals math.order math.ranges
-sequence-parser sequences sorting.functor sorting.slots
+sequences.parser sequences sorting.functor sorting.slots
unicode.categories ;
IN: c.lexer
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequence-parser io io.encodings.utf8 io.files
+USING: sequences.parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-: handle-define ( preprocessor-state sequence-parser -- )
- [ take-define-identifier ]
- [ skip-whitespace/comments take-rest ] bi
- "\\" ?tail [ readlns append ] when
- spin symbol-table>> set-at ;
+:: handle-define ( preprocessor-state sequence-parser -- )
+ sequence-parser take-define-identifier :> ident
+ sequence-parser skip-whitespace/comments take-rest :> def
+ def "\\" ?tail [ readlns append ] when :> def
+ def ident preprocessor-state symbol-table>> set-at ;
: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
! Selective Binding
: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ;
-SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ;
+SYNTAX: C[ | parse-until parse-quotation delayed-bind-with append! ;
! Common ones
-SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ;
+SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with append! ;
! Namespace Binding
: bind-to-namespace ( quot -- quot' ) '[ namespace [ _ bind ] curry ] ;
-SYNTAX: NS[ parse-quotation bind-to-namespace over push-all ;
\ No newline at end of file
+SYNTAX: NS[ parse-quotation bind-to-namespace append! ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations debugger hashtables http
http.client io io.encodings.string io.encodings.utf8 json.reader
-json.writer kernel make math math.parser namespaces sequences strings
-urls urls.encoding vectors ;
+json.writer kernel locals make math math.parser namespaces sequences
+strings urls urls.encoding vectors ;
IN: couchdb
! NOTE: This code only works with the latest couchdb (0.9.*), because old
: attachments> ( assoc -- attachments ) "_attachments" swap at ;
: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
-: copy-key ( to from to-key from-key -- )
- rot at spin set-at ;
+:: copy-key ( to from to-key from-key -- )
+ from-key from at
+ to-key to set-at ;
: copy-id ( to from -- )
"_id" "id" copy-key ;
bitor bitor bitor 32 bits ;
:: set-t ( T i -- )
- [let* |
- a1 [ i sbox nth ]
- a2 [ a1 xtime ]
- a3 [ a1 a2 bitxor ] |
- a2 a1 a1 a3 ui32 i T set-nth
- a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
- a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
- a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth
- ] ;
+ i sbox nth :> a1
+ a1 xtime :> a2
+ a1 a2 bitxor :> a3
+ a2 a1 a1 a3 ui32 i T set-nth
+ a3 a2 a1 a1 ui32 i HEX: 100 + T set-nth
+ a1 a3 a2 a1 ui32 i HEX: 200 + T set-nth
+ a1 a1 a3 a2 ui32 i HEX: 300 + T set-nth ;
MEMO:: t-table ( -- array )
1024 0 <array>
dup 256 [ set-t ] with each ;
:: set-d ( D i -- )
- [let* |
- a1 [ i inv-sbox nth ]
- a2 [ a1 xtime ]
- a4 [ a2 xtime ]
- a8 [ a4 xtime ]
- a9 [ a8 a1 bitxor ]
- ab [ a9 a2 bitxor ]
- ad [ a9 a4 bitxor ]
- ae [ a8 a4 a2 bitxor bitxor ]
- |
- ae a9 ad ab ui32 i D set-nth
- ab ae a9 ad ui32 i HEX: 100 + D set-nth
- ad ab ae a9 ui32 i HEX: 200 + D set-nth
- a9 ad ab ae ui32 i HEX: 300 + D set-nth
- ] ;
+ i inv-sbox nth :> a1
+ a1 xtime :> a2
+ a2 xtime :> a4
+ a4 xtime :> a8
+ a8 a1 bitxor :> a9
+ a9 a2 bitxor :> ab
+ a9 a4 bitxor :> ad
+ a8 a4 a2 bitxor bitxor :> ae
+
+ ae a9 ad ab ui32 i D set-nth
+ ab ae a9 ad ui32 i HEX: 100 + D set-nth
+ ad ab ae a9 ui32 i HEX: 200 + D set-nth
+ a9 ad ab ae ui32 i HEX: 300 + D set-nth ;
MEMO:: d-table ( -- array )
1024 0 <array>
PRIVATE>
:: passwd-md5 ( magic salt password -- bytes )
- [let* | final! [ password magic salt 3append
- salt password tuck 3append md5 checksum-bytes
- password length
- [ 16 / ceiling swap <repetition> concat ] keep
- head-slice append
- password [ length make-bits ] [ first ] bi
- '[ CHAR: \0 _ ? ] "" map-as append
- md5 checksum-bytes ] |
- 1000 [
- "" swap
- {
- [ 0 bit? password final ? append ]
- [ 3 mod 0 > [ salt append ] when ]
- [ 7 mod 0 > [ password append ] when ]
- [ 0 bit? final password ? append ]
- } cleave md5 checksum-bytes final!
- ] each
+ password magic salt 3append
+ salt password dup surround md5 checksum-bytes
+ password length
+ [ 16 / ceiling swap <repetition> concat ] keep
+ head-slice append
+ password [ length make-bits ] [ first ] bi
+ '[ CHAR: \0 _ ? ] "" map-as append
+ md5 checksum-bytes :> final!
- magic salt "$" 3append
- { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
- [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
- 11 final nth 2 to64 3append ] ;
+ 1000 iota [
+ "" swap
+ {
+ [ 0 bit? password final ? append ]
+ [ 3 mod 0 > [ salt append ] when ]
+ [ 7 mod 0 > [ password append ] when ]
+ [ 0 bit? final password ? append ]
+ } cleave md5 checksum-bytes final!
+ ] each
+
+ magic salt "$" 3append
+ { 12 0 6 13 1 7 14 2 8 15 3 9 5 4 10 } final nths 3 group
+ [ first3 [ 16 shift ] [ 8 shift ] bi* + + 4 to64 ] map concat
+ 11 final nth 2 to64 3append ;
: parse-shadow-password ( string -- magic salt password )
- "$" split harvest first3 [ "$" tuck 3append ] 2dip ;
+ "$" split harvest first3 [ "$" dup surround ] 2dip ;
: authenticate-password ( shadow password -- ? )
'[ parse-shadow-password drop _ passwd-md5 ] keep = ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings assocs byte-arrays
combinators continuations destructors fry io.encodings.8-bit
-io io.encodings.string io.encodings.utf8 kernel math
+io io.encodings.string io.encodings.utf8 kernel locals math
namespaces prettyprint sequences classes.struct
strings threads curses.ffi ;
IN: curses
: curses-writef ( window string -- )
[ window-ptr dup ] dip (curses-wprint) (curses-window-refresh) ;
-: (curses-read) ( window-ptr n encoding -- string )
- [ [ <byte-array> tuck ] keep wgetnstr curses-error ] dip alien>string ;
+:: (curses-read) ( window-ptr n encoding -- string )
+ n <byte-array> :> buf
+ window-ptr buf n wgetnstr curses-error
+ buf encoding alien>string ;
: curses-read ( window n -- string )
utf8 [ window-ptr ] 2dip (curses-read) ;
[ >>username ]
[ [ f ] [ ] if-empty >>password ]
[ >>database ]
- } spread parsed ;
+ } spread suffix! ;
-SYNTAX: get-sqlite-info get-info first <sqlite-db> parsed ;
\ No newline at end of file
+SYNTAX: get-sqlite-info get-info first <sqlite-db> suffix! ;
: parse-decimal ( -- decimal ) scan string>decimal ;
-SYNTAX: D: parse-decimal parsed ;
+SYNTAX: D: parse-decimal suffix! ;
: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
] 2bi ;
: scale-decimals ( D1 D2 -- D1' D2' )
- scale-mantissas tuck [ <decimal> ] 2dip <decimal> ;
+ scale-mantissas [ <decimal> ] curry bi@ ;
ERROR: decimal-types-expected d1 d2 ;
:: D/ ( D1 D2 a -- D3 )
D1 D2 guard-decimals 2drop
- D1 >decimal< :> e1 :> m1
- D2 >decimal< :> e2 :> m2
+ D1 >decimal< :> ( m1 e1 )
+ D2 >decimal< :> ( m2 e2 )
m1 a 10^ *
m2 /i
: @edges ( from to digraph -- to edges ) swapd at edges>> ;
: add-edge ( from to digraph -- ) @edges push ;
-: delete-edge ( from to digraph -- ) @edges delete ;
+: delete-edge ( from to digraph -- ) @edges remove! drop ;
: delete-to-edges ( to digraph -- )
- [ nip dupd edges>> delete ] assoc-each drop ;
+ [ nip dupd edges>> remove! drop ] assoc-each drop ;
: delete-vertex ( key digraph -- )
2dup delete-at delete-to-edges ;
] if ;
: topological-sort ( digraph -- seq )
- dup clone V{ } clone spin
+ [ V{ } clone ] dip [ clone ] keep
[ drop (topological-sort) ] assoc-each drop reverse ;
: topological-sorted-values ( digraph -- seq )
+++ /dev/null
-
-USING: kernel assocs locals combinators
- math math.functions system unicode.case ;
-
-IN: dns.cache.nx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: nx-cache ( -- table ) H{ } ;
-
-: nx-cache-at ( name -- time ) >lower nx-cache at ;
-: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
-: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-:: non-existent-name? ( NAME -- ? )
- [let | TIME [ NAME nx-cache-at ] |
- {
- { [ TIME f = ] [ f ] }
- { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
- { [ t ] [ t ] }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-non-existent-name ( NAME TTL -- )
- [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel sequences assocs sets locals combinators
- accessors system math math.functions unicode.case prettyprint
- combinators.smart dns ;
-
-IN: dns.cache.rr
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: <entry> time data ;
-
-: now ( -- seconds ) millis 1000.0 / round >integer ;
-
-: expired? ( <entry> -- ? ) time>> now <= ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-cache-key ( obj -- key )
- [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cache ( -- table ) H{ } ;
-
-: cache-at ( obj -- ent ) make-cache-key cache at ;
-: cache-delete ( obj -- ) make-cache-key cache delete-at ;
-: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-get ( OBJ -- rrs/f )
- [let | ENT [ OBJ cache-at ] |
- {
- { [ ENT f = ] [ f ] }
- { [ ENT expired? ] [ OBJ cache-delete f ] }
- {
- [ t ]
- [
- [let | NAME [ OBJ name>> ]
- TYPE [ OBJ type>> ]
- CLASS [ OBJ class>> ]
- TTL [ ENT time>> now - ] |
- ENT data>>
- [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
- map
- ]
- ]
- }
- }
- cond
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: cache-add ( RR -- )
- [let | ENT [ RR cache-at ]
- TIME [ RR ttl>> now + ]
- RDATA [ RR rdata>> ] |
- {
- { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
- { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
- { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
- }
- cond
- ] ;
\ No newline at end of file
+++ /dev/null
-
-USING: kernel byte-arrays combinators strings arrays sequences splitting
- grouping
- math math.functions math.parser random
- destructors
- io io.binary io.sockets io.encodings.binary
- accessors
- combinators.smart
- assocs
- ;
-
-IN: dns
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: query name type class ;
-
-TUPLE: rr name type class ttl rdata ;
-
-TUPLE: hinfo cpu os ;
-
-TUPLE: mx preference exchange ;
-
-TUPLE: soa mname rname serial refresh retry expire minimum ;
-
-TUPLE: message
- id qr opcode aa tc rd ra z rcode
- question-section
- answer-section
- authority-section
- additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: random-id ( -- id ) 2 16 ^ random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TYPE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
-
-: type-table ( -- table )
- {
- { A 1 }
- { NS 2 }
- { MD 3 }
- { MF 4 }
- { CNAME 5 }
- { SOA 6 }
- { MB 7 }
- { MG 8 }
- { MR 9 }
- { NULL 10 }
- { WKS 11 }
- { PTR 12 }
- { HINFO 13 }
- { MINFO 14 }
- { MX 15 }
- { TXT 16 }
- { AAAA 28 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! CLASS
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: IN CS CH HS ;
-
-: class-table ( -- table )
- {
- { IN 1 }
- { CS 2 }
- { CH 3 }
- { HS 4 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! OPCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: QUERY IQUERY STATUS ;
-
-: opcode-table ( -- table )
- {
- { QUERY 0 }
- { IQUERY 1 }
- { STATUS 2 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! RCODE
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
- REFUSED ;
-
-: rcode-table ( -- table )
- {
- { NO-ERROR 0 }
- { FORMAT-ERROR 1 }
- { SERVER-FAILURE 2 }
- { NAME-ERROR 3 }
- { NOT-IMPLEMENTED 4 }
- { REFUSED 5 }
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: <message> ( -- message )
- message new
- random-id >>id
- 0 >>qr
- QUERY >>opcode
- 0 >>aa
- 0 >>tc
- 1 >>rd
- 0 >>ra
- 0 >>z
- NO-ERROR >>rcode
- { } >>question-section
- { } >>answer-section
- { } >>authority-section
- { } >>additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
-
-: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
-
-: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: uint8->ba ( n -- ba ) 1 >be ;
-: uint16->ba ( n -- ba ) 2 >be ;
-: uint32->ba ( n -- ba ) 4 >be ;
-: uint64->ba ( n -- ba ) 8 >be ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: query->ba ( query -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: hinfo->ba ( rdata -- ba )
- [ cpu>> label->ba ]
- [ os>> label->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: mx->ba ( rdata -- ba )
- [ preference>> uint16->ba ]
- [ exchange>> dn->ba ]
- bi append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: soa->ba ( rdata -- ba )
- [
- {
- [ mname>> dn->ba ]
- [ rname>> dn->ba ]
- [ serial>> uint32->ba ]
- [ refresh>> uint32->ba ]
- [ retry>> uint32->ba ]
- [ expire>> uint32->ba ]
- [ minimum>> uint32->ba ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rdata->ba ( type rdata -- ba )
- swap
- {
- { CNAME [ dn->ba ] }
- { HINFO [ hinfo->ba ] }
- { MX [ mx->ba ] }
- { NS [ dn->ba ] }
- { PTR [ dn->ba ] }
- { SOA [ soa->ba ] }
- { A [ ip->ba ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->ba ( rr -- ba )
- [
- {
- [ name>> dn->ba ]
- [ type>> type-table at uint16->ba ]
- [ class>> class-table at uint16->ba ]
- [ ttl>> uint32->ba ]
- [
- [ type>> ] [ rdata>> ] bi rdata->ba
- [ length uint16->ba ] [ ] bi append
- ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: header-bits-ba ( message -- ba )
- [
- {
- [ qr>> 15 shift ]
- [ opcode>> opcode-table at 11 shift ]
- [ aa>> 10 shift ]
- [ tc>> 9 shift ]
- [ rd>> 8 shift ]
- [ ra>> 7 shift ]
- [ z>> 4 shift ]
- [ rcode>> rcode-table at 0 shift ]
- } cleave
- ] sum-outputs uint16->ba ;
-
-: message->ba ( message -- ba )
- [
- {
- [ id>> uint16->ba ]
- [ header-bits-ba ]
- [ question-section>> length uint16->ba ]
- [ answer-section>> length uint16->ba ]
- [ authority-section>> length uint16->ba ]
- [ additional-section>> length uint16->ba ]
- [ question-section>> [ query->ba ] map concat ]
- [ answer-section>> [ rr->ba ] map concat ]
- [ authority-section>> [ rr->ba ] map concat ]
- [ additional-section>> [ rr->ba ] map concat ]
- } cleave
- ] output>array concat ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-single ( ba i -- n ) at ;
-: get-double ( ba i -- n ) dup 2 + subseq be> ;
-: get-quad ( ba i -- n ) dup 4 + subseq be> ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: label-length ( ba i -- length ) get-single ;
-
-: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
-
-: null-label? ( ba i -- ? ) get-single 0 = ;
-
-: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bit-test ( a b -- ? ) bitand 0 = not ;
-
-: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
-
-: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: skip-name ( ba i -- ba i )
- {
- { [ 2dup null-label? ] [ 1 + ] }
- { [ 2dup pointer? ] [ 2 + ] }
- { [ t ] [ skip-label skip-name ] }
- }
- cond ;
-
-: get-name ( ba i -- name )
- {
- { [ 2dup null-label? ] [ 2drop "" ] }
- { [ 2dup pointer? ] [ dupd pointer get-name ] }
- {
- [ t ]
- [
- [ get-label ]
- [ skip-label get-name ]
- 2bi
- "." glue
- ]
- }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-query ( ba i -- query )
- [ get-name ]
- [
- skip-name
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- 2bi
- ]
- 2bi query boa ;
-
-: skip-query ( ba i -- ba i ) skip-name 4 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-soa ( ba i -- soa )
- {
- [ get-name ]
- [ skip-name get-name ]
- [
- skip-name
- skip-name
- {
- [ 0 + get-quad ]
- [ 4 + get-quad ]
- [ 8 + get-quad ]
- [ 12 + get-quad ]
- [ 16 + get-quad ]
- }
- 2cleave
- ]
- }
- 2cleave soa boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-ipv6 ( ba i -- ip )
- dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rdata ( ba i type -- rdata )
- {
- { CNAME [ get-name ] }
- { NS [ get-name ] }
- { PTR [ get-name ] }
- { MX [ get-mx ] }
- { SOA [ get-soa ] }
- { A [ get-ip ] }
- { AAAA [ get-ipv6 ] }
- }
- case ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr ( ba i -- rr )
- [ get-name ]
- [
- skip-name
- {
- [ 0 + get-double type-table value-at ]
- [ 2 + get-double class-table value-at ]
- [ 4 + get-quad ]
- [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
- }
- 2cleave
- ]
- 2bi rr boa ;
-
-: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-question-section ( ba i count -- seq ba i )
- [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: get-rr-section ( ba i count -- seq ba i )
- [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >> ( x n -- y ) neg shift ;
-
-: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
- get-double
- {
- [ 15 >> BIN: 1 bitand ]
- [ 11 >> BIN: 111 bitand opcode-table value-at ]
- [ 10 >> BIN: 1 bitand ]
- [ 9 >> BIN: 1 bitand ]
- [ 8 >> BIN: 1 bitand ]
- [ 7 >> BIN: 1 bitand ]
- [ 4 >> BIN: 111 bitand ]
- [ BIN: 1111 bitand rcode-table value-at ]
- }
- cleave ;
-
-: parse-message ( ba -- message )
- 0
- {
- [ get-double ]
- [ 2 + get-header-bits ]
- [
- 4 +
- {
- [ 8 + ]
- [ 0 + get-double ]
- [ 2 + get-double ]
- [ 4 + get-double ]
- [ 6 + get-double ]
- }
- 2cleave
- {
- [ get-question-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- [ get-rr-section ]
- } spread
- 2drop
- ]
- }
- 2cleave message boa ;
-
-: ba->message ( ba -- message ) parse-message ;
-
-: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-udp ( ba server -- ba )
- f 0 <inet4> <datagram>
- [
- [ send ] [ receive drop ] bi
- ]
- with-disposal ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: send-receive-tcp ( ba server -- ba )
- [ dup length 2 >be prepend ] [ ] bi*
- binary
- [
- write flush
- 2 read be> read
- ]
- with-client ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >dns-inet4 ( obj -- inet4 )
- dup string?
- [ 53 <inet4> ]
- [ ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ask-server ( message server -- message )
- [ message->ba ] [ >dns-inet4 ] bi*
- 2dup
- send-receive-udp parse-message
- dup tc>> 1 =
- [ drop send-receive-tcp parse-message ]
- [ nip nip ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq ) V{ } ;
-
-: dns-server ( -- server ) dns-servers random ;
-
-: ask ( message -- message ) dns-server ask-server ;
-
-: query->message ( query -- message ) <message> swap 1array >>question-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-query ( message -- query ) question-section>> first ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ERROR: name-error name ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name )
- {
- { [ dup empty? ] [ "." append ] }
- { [ dup last CHAR: . = ] [ ] }
- { [ t ] [ "." append ] }
- }
- cond ;
+++ /dev/null
-
-USING: kernel sequences combinators accessors locals random
- combinators.short-circuit
- io.sockets
- dns dns.util dns.cache.rr dns.cache.nx
- dns.resolver ;
-
-IN: dns.forwarding
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: query->rrs ( QUERY -- rrs/f )
- [let | RRS [ QUERY cache-get ] |
- RRS
- [ RRS ]
- [
- [let | NAME [ QUERY name>> ]
- TYPE [ QUERY type>> ]
- CLASS [ QUERY class>> ] |
-
- [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
-
- RRS/CNAME f =
- [ f ]
- [
- [let | RR/CNAME [ RRS/CNAME first ] |
-
- [let | REAL-NAME [ RR/CNAME rdata>> ] |
-
- [let | RRS [
- T{ query f REAL-NAME TYPE CLASS } query->rrs
- ] |
-
- RRS
- [ RRS/CNAME RRS append ]
- [ f ]
- if
- ] ] ]
- ]
- if
- ] ]
- ]
- if
- ] ;
-
-:: answer-from-cache ( MSG -- msg/f )
- [let | QUERY [ MSG message-query ] |
-
- [let | NX [ QUERY name>> non-existent-name? ]
- RRS [ QUERY query->rrs ] |
-
- {
- { [ NX ] [ MSG NAME-ERROR >>rcode ] }
- { [ RRS ] [ MSG RRS >>answer-section ] }
- { [ t ] [ f ] }
- }
- cond
- ]
- ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: message-soa ( message -- rr/soa )
- authority-section>> [ type>> SOA = ] filter first ;
-
-! :: cache-message ( MSG -- msg )
-! MSG rcode>> NAME-ERROR =
-! [
-! [let | NAME [ MSG message-query name>> ]
-! TTL [ MSG message-soa ttl>> ] |
-! NAME TTL cache-non-existent-name
-! ]
-! ]
-! when
-! MSG answer-section>> [ cache-add ] each
-! MSG authority-section>> [ cache-add ] each
-! MSG additional-section>> [ cache-add ] each
-! MSG ;
-
-:: cache-message ( MSG -- msg )
- MSG rcode>> NAME-ERROR =
- [
- [let | RR/SOA [ MSG
- authority-section>>
- [ type>> SOA = ] filter
- dup empty? [ drop f ] [ first ] if ] |
- RR/SOA
- [
- [let | NAME [ MSG message-query name>> ]
- TTL [ MSG message-soa ttl>> ] |
- NAME TTL cache-non-existent-name
- ]
- ]
- when
- ]
- ]
- when
- MSG answer-section>> [ cache-add ] each
- MSG authority-section>> [ cache-add ] each
- MSG additional-section>> [ cache-add ] each
- MSG ;
-
-! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
-
-: answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
-
-:: find-answer ( MSG SERVERS -- msg )
- { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: start-server ( ADDR-SPEC SERVERS -- )
-
- [let | SOCKET [ ADDR-SPEC <datagram> ] |
-
- [
- SOCKET receive-packet
- [ parse-message SERVERS find-answer message->ba ]
- change-data
- respond
- ]
- forever
-
- ] ;
+++ /dev/null
-
-USING: kernel combinators sequences splitting math
- io.files io.encodings.utf8 random dns.util ;
-
-IN: dns.misc
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: resolv-conf-servers ( -- seq )
- "/etc/resolv.conf" utf8 file-lines
- [ " " split ] map
- [ first "nameserver" = ] filter
- [ second ] map ;
-
-: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: domain-has-name? ( domain name -- ? )
- {
- { [ 2dup = ] [ 2drop t ] }
- { [ 2dup longer? ] [ 2drop f ] }
- { [ t ] [ cdr-name domain-has-name? ] }
- }
- cond ;
-
-: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel accessors namespaces continuations
- io io.sockets io.binary io.timeouts io.encodings.binary
- destructors
- locals strings sequences random prettyprint calendar dns dns.misc ;
-
-IN: dns.resolver
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: send-receive-udp ( BA SERVER -- ba )
- T{ inet4 f f 0 } <datagram>
- T{ duration { second 3 } } over set-timeout
- [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
- with-disposal ;
-
-:: send-receive-tcp ( BA SERVER -- ba )
- [let | BA [ BA length 2 >be BA append ] |
- SERVER binary
- [
- T{ duration { second 3 } } input-stream get set-timeout
- BA write flush 2 read be> read
- ]
- with-client ] ;
-
-:: send-receive-server ( BA SERVER -- msg )
- [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
- RESULT tc>> 1 =
- [ BA SERVER send-receive-tcp parse-message ]
- [ RESULT ]
- if ] ;
-
-: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
-
-:: send-receive-servers ( BA SERVERS -- msg )
- SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
- [let | SERVER [ SERVERS random >dns-inet4 ] |
- ! if this throws an error ...
- [ BA SERVER send-receive-server ]
- ! we try with the other servers...
- [ drop BA SERVER SERVERS remove send-receive-servers ]
- recover ] ;
-
-:: ask-servers ( MSG SERVERS -- msg )
- MSG message->ba SERVERS send-receive-servers ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-servers ( -- seq )
- \ dns-servers get
- [ ]
- [ resolv-conf-servers \ dns-servers set dns-servers ]
- if* ;
-
-! : dns-server ( -- server ) dns-servers random ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: dns-ip4 ( name -- ips )
- fully-qualified
- [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
- MSG rcode>> NO-ERROR =
- [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
- [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
- if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+++ /dev/null
-
-USING: kernel combinators sequences sets math threads namespaces continuations
- debugger io io.sockets unicode.case accessors destructors
- combinators.short-circuit combinators.smart
- fry arrays
- dns dns.util dns.misc ;
-
-IN: dns.server
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: records-var
-
-: records ( -- records ) records-var get ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {name-type-class} ( obj -- array )
- [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
-
-: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! zones
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
-: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
-
-: delegated-zones ( -- names ) zones my-zones diff ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! name->zone
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->zone ( name -- zone/f )
- zones sort-largest-first [ name-in-domain? ] with find nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! name->authority
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! extract-names
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rr->rdata-names ( rr -- names/f )
- {
- { [ dup type>> NS = ] [ rdata>> 1array ] }
- { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
- { [ dup type>> CNAME = ] [ rdata>> 1array ] }
- { [ t ] [ drop f ] }
- }
- cond ;
-
-: extract-rdata-names ( message -- names )
- [ answer-section>> ] [ authority-section>> ] bi append
- [ rr->rdata-names ] map concat ;
-
-: extract-names ( message -- names )
- [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! fill-authority
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: fill-authority ( message -- message )
- dup
- extract-names [ name->authority ] map concat prune
- over answer-section>> diff
- >>authority-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! fill-additional
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
-
-: fill-additional ( message -- message )
- dup
- extract-rdata-names [ name->rrs-a ] map concat prune
- over answer-section>> diff
- >>additional-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! query->rrs
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: query->rrs
-
-: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
-
-: matching-cname? ( query -- rrs/f )
- [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
- [ empty? not ]
- [ first swap clone over rdata>> >>name query->rrs swap prefix ]
- [ 2drop f ]
- 1if ;
-
-: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! have-answers
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: have-answers ( message -- message/f )
- dup message-query query->rrs
- [ empty? ]
- [ 2drop f ]
- [ >>answer-section fill-authority fill-additional ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! have-delegates?
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
-
-: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
-
-: have-ns? ( name -- rrs/f )
- NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
-
-: name->delegates ( name -- rrs-ns )
- {
- [ "" = { } and ]
- [ is-soa? { } and ]
- [ have-ns? ]
- [ cdr-name name->delegates ]
- }
- 1|| ;
-
-: have-delegates ( message -- message/f )
- dup message-query name>> name->delegates ! message rrs-ns
- [ empty? ]
- [ 2drop f ]
- [
- dup [ rdata>> A IN query boa matching-rrs ] map concat
- ! message rrs-ns rrs-a
- [ >>authority-section ]
- [ >>additional-section ]
- bi*
- ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! outsize-zones
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: outside-zones ( message -- message/f )
- dup message-query name>> name->zone f =
- [ ]
- [ drop f ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! is-nx
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: is-nx ( message -- message/f )
- [ message-query name>> records [ name>> = ] with filter empty? ]
- [
- NAME-ERROR >>rcode
- dup
- message-query name>> name->zone SOA IN query boa matching-rrs
- >>authority-section
- ]
- [ drop f ]
- 1if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: none-of-type ( message -- message )
- dup
- message-query name>> name->zone SOA IN query boa matching-rrs
- >>authority-section ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: find-answer ( message -- message )
- {
- [ have-answers ]
- [ have-delegates ]
- [ outside-zones ]
- [ is-nx ]
- [ none-of-type ]
- }
- 1|| ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (handle-request) ( packet -- )
- [ [ find-answer ] with-message-bytes ] change-data respond ;
-
-: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
-
-: receive-loop ( socket -- )
- [ receive-packet handle-request ] [ receive-loop ] bi ;
-
-: loop ( addr-spec -- )
- [ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
-
+++ /dev/null
-
-USING: kernel sequences random accessors dns ;
-
-IN: dns.stub
-
-! Stub resolver
-!
-! Generally useful, but particularly when running a forwarding,
-! caching, nameserver on localhost with multiple Factor instances
-! querying it.
-
-: name->ip ( name -- ip )
- A IN query boa
- query->message
- ask
- dup rcode>> NAME-ERROR =
- [ message-query name>> name-error ]
- [ answer-section>> [ type>> A = ] filter random rdata>> ]
- if ;
-
+++ /dev/null
-
-USING: kernel sequences sorting math math.order macros fry ;
-
-IN: dns.util
-
-: tri-chain ( obj p q r -- x y z )
- [ [ call dup ] dip call dup ] dip call ; inline
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer? ( seq seq -- ? ) [ length ] bi@ > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: io.sockets accessors ;
-
-TUPLE: packet data addr socket ;
-
-: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
-
-: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
: get-private-key ( -- bin/f )
ec-key-handle EC_KEY_get0_private_key
- dup [ dup BN_num_bits bits>bytes <byte-array> tuck BN_bn2bin drop ] when ;
+ dup [ dup BN_num_bits bits>bytes <byte-array> [ BN_bn2bin drop ] keep ] when ;
:: get-public-key ( -- bin/f )
ec-key-handle :> KEY
[ [ italic = ] find nip [ >>italic? ] install ]
[ [ bold = ] find nip [ >>bold? ] install ]
[ [ fontname? ] find nip [ >>name* ] install ]
-} cleave 4array concat '[ dup font>> @ drop ] over push-all ;
+} cleave 4array concat '[ dup font>> @ drop ] append! ;
USING: arrays vectors combinators effects kernel math sequences splitting
strings.parser parser fry sequences.extras ;
+
+! a b c glue => acb
+! c b a [ append ] dip prepend
+
IN: fries
: str-fry ( str on -- quot ) split
- [ unclip-last [ [ spin glue ] reduce-r ] 2curry ]
+ [ unclip-last [ [ [ append ] [ prepend ] bi* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
: gen-fry ( str on -- quot ) split
- [ unclip-last [ [ spin 1array glue ] reduce-r ] 2curry ]
+ [ unclip-last [ [ [ 1array ] [ append ] [ prepend ] tri* ] reduce-r ] 2curry ]
[ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
-SYNTAX: i" parse-string rest "_" str-fry over push-all ;
-SYNTAX: i{ \ } parse-until >array { _ } gen-fry over push-all ;
-SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry over push-all ;
+SYNTAX: i" parse-string rest "_" str-fry append! ;
+SYNTAX: i{ \ } parse-until >array { _ } gen-fry append! ;
+SYNTAX: iV{ \ } parse-until >vector V{ _ } gen-fry append! ;
: fuel-scaffold-vocab ( root name devname -- )
[ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
- dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
+ dup require vocab-source-path absolute-path fuel-eval-set-result ;
: fuel-scaffold-help ( name devname -- )
[ fuel-scaffold-name dup require dup scaffold-help ] with-scope
- vocab-docs-path (normalize-path) fuel-eval-set-result ;
+ vocab-docs-path absolute-path fuel-eval-set-result ;
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
<PRIVATE
: normalize-loc ( seq -- path line )
- [ dup length 0 > [ first (normalize-path) ] [ drop f ] if ]
+ [ dup length 0 > [ first absolute-path ] [ drop f ] if ]
[ dup length 1 > [ second ] [ drop 1 ] if ] bi ;
: get-loc ( object -- loc ) normalize-loc 2array ;
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
: download-db ( -- path )
db-path dup exists? [
db-url over ".gz" append download-to
- { "gunzip" } over ".gz" append (normalize-path) suffix try-process
+ { "gunzip" } over ".gz" append absolute-path suffix try-process
] unless ;
TUPLE: ip-entry from to registry assigned city cntry country ;
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
quot call
- target glUnmapBuffer ; inline
+ target glUnmapBuffer drop ; inline
:: with-bound-buffer ( buffer target quot: ( -- ) -- )
target gl-target buffer glBindBuffer
[
numbers {
{ [ dup length 5 = ] [ <bunny-vertex> pick push ] }
- { [ dup first 3 = ] [ rest over push-all ] }
+ { [ dup first 3 = ] [ rest append! ] }
[ drop ]
} cond
] each-line-tokens ; inline
[ swap depth-attachment>> [ swap call ] [ drop ] if* ]
[ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
-: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
- [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
- [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ]
- [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+:: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
+ framebuffer color-attachments>>
+ [| attachment n | n GL_COLOR_ATTACHMENT0 + attachment quot call ] each-index
+ framebuffer depth-attachment>>
+ [| attachment | GL_DEPTH_ATTACHMENT attachment quot call ] when*
+ framebuffer stencil-attachment>>
+ [| attachment | GL_STENCIL_ATTACHMENT attachment quot call ] when* ; inline
GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )
] [
{ [ ] }
name "." append 1array
- ] if* :> name-prefixes :> quot-prefixes
+ ] if* :> ( quot-prefixes name-prefixes )
type all-uniform-tuple-slots :> uniforms
texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
uniforms name-prefix [bind-uniform-tuple]
quot-prefix prepend
- ] 2map :> value-cleave :> texture-unit'
+ ] 2map :> ( texture-unit' value-cleave )
texture-unit'
value>>-quot { value-cleave 2cleave } append ;
} cond ;
:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
- texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
+ texture-unit uniforms [ prefix [bind-uniform] ] map :> ( texture-unit' uniforms-cleave )
texture-unit'
{ uniforms-cleave 2cleave } >quotation ;
: wasd-p-matrix ( world -- matrix )
p-matrix>> ;
+: <mvp-uniforms> ( world -- uniforms )
+ [ wasd-mv-matrix ] [ wasd-p-matrix ] bi mvp-uniforms boa ;
+
CONSTANT: fov 0.7
:: generate-p-matrix ( world -- matrix )
:: wasd-keyboard-input ( world -- )
read-keyboard keys>> :> keys
- key-w keys nth key-, keys nth or [ world walk-forward ] when
- key-s keys nth key-o keys nth or [ world walk-backward ] when
- key-a keys nth [ world walk-leftward ] when
- key-d keys nth key-e keys nth or [ world walk-rightward ] when
+ key-w keys nth [ world walk-forward ] when
+ key-s keys nth [ world walk-backward ] when
+ key-a keys nth [ world walk-leftward ] when
+ key-d keys nth [ world walk-rightward ] when
key-space keys nth [ world walk-upward ] when
- key-c keys nth key-j keys nth or [ world walk-downward ] when
+ key-c keys nth [ world walk-downward ] when
key-escape keys nth [ world close-window ] when ;
: wasd-mouse-input ( world -- )
+++ /dev/null
-USING: accessors alien.c-types alien.syntax half-floats kernel
-math tools.test specialized-arrays alien.data classes.struct ;
-SPECIALIZED-ARRAY: half
-IN: half-floats.tests
-
-[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
-[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
-[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
-[ HEX: be00 ] [ -1.5 half>bits ] unit-test
-[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
-[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
-[ HEX: 7eaa ] [ NAN: aaaaaaaaaaaaa half>bits ] unit-test
-
-! too-big floats overflow to infinity
-[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
-[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
-[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
-
-! too-small floats flush to zero
-[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
-[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
-
-[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
-[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
-[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
-[ -1.5 ] [ HEX: be00 bits>half ] unit-test
-[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
-[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
-[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
-[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
-
-STRUCT: halves
- { tom half }
- { dick half }
- { harry half }
- { harry-jr half } ;
-
-[ 8 ] [ halves heap-size ] unit-test
-
-[ 3.0 ] [
- halves <struct>
- 3.0 >>dick
- dick>>
-] unit-test
-
-[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
-[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
-
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors alien.accessors alien.c-types alien.data
-alien.syntax kernel math math.order ;
-FROM: math => float ;
-IN: half-floats
-
-: half>bits ( float -- bits )
- float>bits
- [ -31 shift 15 shift ] [
- HEX: 7fffffff bitand
- dup zero? [
- dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
- -13 shift
- 112 10 shift -
- 0 HEX: 7c00 clamp
- ] if
- ] unless
- ] bi bitor ;
-
-: bits>half ( bits -- float )
- [ -15 shift 31 shift ] [
- HEX: 7fff bitand
- dup zero? [
- dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
- 13 shift
- 112 23 shift +
- ] if
- ] unless
- ] bi bitor bits>float ;
-
-SYMBOL: half
-
-<<
-
-<c-type>
- float >>class
- float >>boxed-class
- [ alien-unsigned-2 bits>half ] >>getter
- [ [ >float half>bits ] 2dip set-alien-unsigned-2 ] >>setter
- 2 >>size
- 2 >>align
- [ >float ] >>unboxer-quot
-\ half define-primitive-type
-
->>
+++ /dev/null
-Half-precision float support for FFI
+++ /dev/null
-IN: histogram\r
-USING: help.markup help.syntax sequences hashtables quotations assocs ;\r
-\r
-HELP: histogram\r
-{ $values\r
- { "seq" sequence }\r
- { "hashtable" hashtable }\r
-}\r
-{ $examples \r
- { $example "! Count the number of times an element appears in a sequence."\r
- "USING: prettyprint histogram ;"\r
- "\"aaabc\" histogram ."\r
- "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
- }\r
-}\r
-{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;\r
-\r
-HELP: histogram*\r
-{ $values\r
- { "hashtable" hashtable } { "seq" sequence }\r
- { "hashtable" hashtable }\r
-}\r
-{ $examples \r
- { $example "! Count the number of times the elements of two sequences appear."\r
- "USING: prettyprint histogram ;"\r
- "\"aaabc\" histogram \"aaaaaabc\" histogram* ."\r
- "H{ { 97 9 } { 98 2 } { 99 2 } }"\r
- }\r
-}\r
-{ $description "Takes an existing hashtable and uses " { $link histogram } " to continue counting the number of occurences of each element." } ;\r
-\r
-HELP: sequence>assoc\r
-{ $values\r
- { "seq" sequence } { "quot" quotation } { "exemplar" "an exemplar assoc" }\r
- { "assoc" assoc }\r
-}\r
-{ $examples \r
- { $example "! Iterate over a sequence and increment the count at each element"\r
- "USING: assocs prettyprint histogram ;"\r
- "\"aaabc\" [ inc-at ] H{ } sequence>assoc ."\r
- "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
- }\r
-}\r
-{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;\r
-\r
-HELP: sequence>assoc*\r
-{ $values\r
- { "assoc" assoc } { "seq" sequence } { "quot" quotation }\r
- { "assoc" assoc }\r
-}\r
-{ $examples \r
- { $example "! Iterate over a sequence and add the counts to an existing assoc"\r
- "USING: assocs prettyprint histogram kernel ;"\r
- "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."\r
- "H{ { 97 5 } { 98 2 } { 99 1 } }"\r
- }\r
-}\r
-{ $description "Iterates over a sequence, allowing elements of the sequence to be added to an existing " { $snippet "assoc" } " according to the passed quotation." } ;\r
-\r
-HELP: sequence>hashtable\r
-{ $values\r
- { "seq" sequence } { "quot" quotation }\r
- { "hashtable" hashtable }\r
-}\r
-{ $examples \r
- { $example "! Count the number of times an element occurs in a sequence"\r
- "USING: assocs prettyprint histogram ;"\r
- "\"aaabc\" [ inc-at ] sequence>hashtable ."\r
- "H{ { 97 3 } { 98 1 } { 99 1 } }"\r
- }\r
-}\r
-{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a hashtable according to the passed quotation." } ;\r
-\r
-ARTICLE: "histogram" "Computing histograms"\r
-"Counting elements in a sequence:"\r
-{ $subsections\r
- histogram\r
- histogram*\r
-}\r
-"Combinators for implementing histogram:"\r
-{ $subsections\r
- sequence>assoc\r
- sequence>assoc*\r
- sequence>hashtable\r
-} ;\r
-\r
-ABOUT: "histogram"\r
+++ /dev/null
-IN: histogram.tests\r
-USING: help.markup help.syntax tools.test histogram ;\r
-\r
-[\r
- H{\r
- { 97 2 }\r
- { 98 2 }\r
- { 99 2 }\r
- }\r
-] [\r
- "aabbcc" histogram\r
-] unit-test\r
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences assocs fry ;\r
-IN: histogram\r
-\r
-<PRIVATE\r
-\r
-: (sequence>assoc) ( seq quot assoc -- assoc )\r
- [ swap curry each ] keep ; inline\r
-\r
-PRIVATE>\r
-\r
-: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )\r
- rot (sequence>assoc) ; inline\r
-\r
-: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )\r
- clone (sequence>assoc) ; inline\r
-\r
-: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )\r
- H{ } sequence>assoc ; inline\r
-\r
-: histogram* ( hashtable seq -- hashtable )\r
- [ inc-at ] sequence>assoc* ;\r
-\r
-: histogram ( seq -- hashtable )\r
- [ inc-at ] sequence>hashtable ;\r
-\r
-: collect-values ( seq quot: ( obj hashtable -- ) -- hash )\r
- '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables sequence-parser
+USING: accessors arrays hashtables sequences.parser
html.parser.utils kernel namespaces sequences math
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel images ;
-IN: images.normalization
-
-HELP: normalize-image
-{ $values
- { "image" image }
- { "image" image }
-}
-{ $description "Converts the image to RGBA with ubyte-components. If the image is upside-down, it will be flipped right side up such that the 1st byte in the bitmap slot's byte array corresponds to the first color component of the pixel in the upper-left corner of the image." } ;
-
-HELP: reorder-components
-{ $values
- { "image" image } { "component-order" component-order }
- { "image" image }
-}
-{ $description "Convert the bitmap in " { $snippet "image" } " such that the pixel sample layout corresponds to " { $snippet "component-order" } ". If the destination layout cannot find a corresponding value from the source layout, the value " { $snippet "255" } " will be substituted for that byte." }
-{ $warning "The image's " { $snippet "component-type" } " will be changed to " { $snippet "ubyte-components" } " if it is not already in that format."
-$nl
-"You cannot use this word to reorder " { $link DEPTH } ", " { $link DEPTH-STENCIL } " or " { $link INTENSITY } " component orders." } ;
-
-ARTICLE: "images.normalization" "Image normalization"
-"The " { $vocab-link "images.normalization" } " vocab can be used to convert between " { $link image } " representations."
-$nl
-"You can normalize any image to a RGBA with ubyte-components representation:"
-{ $subsections normalize-image }
-"Convert an image's pixel layout to match an arbitrary " { $link component-order } ":"
-{ $subsections reorder-components } ;
-
-ABOUT: "images.normalization"
+++ /dev/null
-! Copyright (C) 2009 Keith Lazuka.
-! See http://factorcode.org/license.txt for BSD license.
-USING: images images.normalization images.normalization.private
-sequences tools.test ;
-IN: images.normalization.tests
-
-! 1>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 } A L permute ] unit-test
-
-[ B{ 255 255 255 255 } ]
-[ B{ 0 1 } A RG permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 } A BGR permute ] unit-test
-
-[ B{ 0 255 255 255 1 255 255 255 } ]
-[ B{ 0 1 } A ABGR permute ] unit-test
-
-! 2>x
-
-[ B{ 0 2 } ]
-[ B{ 0 1 2 3 } LA L permute ] unit-test
-
-[ B{ 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA RG permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA BGR permute ] unit-test
-
-[ B{ 1 255 255 255 3 255 255 255 } ]
-[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
-
-! 3>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
-
-[ B{ 0 1 3 4 } ]
-[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
-
-[ B{ 2 1 0 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
-
-[ B{ 255 2 1 0 255 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
-
-! 4>x
-
-[ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
-
-[ B{ 0 1 4 5 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
-
-[ B{ 2 1 0 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
-
-[ B{ 3 2 1 0 7 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
-
-! Edge cases
-
-[ B{ 0 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
-
-[ B{ 255 0 1 2 255 4 5 6 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
-
-[ B{ 1 2 3 255 5 6 7 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
-
-[ B{ 255 255 255 255 255 255 255 255 } ]
-[ B{ 0 1 } L RGBA permute ] unit-test
-
-! Invalid inputs
-
-[
- T{ image f { 1 1 } DEPTH ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } DEPTH-STENCIL ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } INTENSITY ubyte-components f B{ 0 } }
- RGB reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- DEPTH reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- DEPTH-STENCIL reorder-components
-] must-fail
-
-[
- T{ image f { 1 1 } RGB ubyte-components f B{ 0 0 0 } }
- INTENSITY reorder-components
-] must-fail
-
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman, Keith Lazuka
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types byte-arrays combinators fry
-grouping images kernel locals math math.vectors
-sequences specialized-arrays half-floats ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: half
-SPECIALIZED-ARRAY: float
-SPECIALIZED-ARRAY: ushort
-IN: images.normalization
-
-<PRIVATE
-
-CONSTANT: don't-care 127
-CONSTANT: fill-value 255
-
-: permutation ( src dst -- seq )
- swap '[ _ index [ don't-care ] unless* ] { } map-as
- 4 don't-care pad-tail ;
-
-: pad4 ( seq -- newseq ) 4 fill-value pad-tail ;
-
-: shuffle ( seq permutation -- newseq )
- swap '[
- dup 4 >= [ drop fill-value ] [ _ nth ] if
- ] B{ } map-as ;
-
-:: permute ( bytes src-order dst-order -- new-bytes )
- [let | src [ src-order name>> ]
- dst [ dst-order name>> ] |
- bytes src length group
- [ pad4 src dst permutation shuffle dst length head ]
- map concat ] ;
-
-: (reorder-components) ( image src-order dest-order -- image )
- [ permute ] 2curry change-bitmap ;
-
-GENERIC: normalize-component-type* ( image component-type -- image )
-
-: normalize-floats ( float-array -- byte-array )
- [ 255.0 * >integer ] B{ } map-as ;
-
-M: float-components normalize-component-type*
- drop byte-array>float-array normalize-floats ;
-
-M: half-components normalize-component-type*
- drop byte-array>half-array normalize-floats ;
-
-: ushorts>ubytes ( bitmap -- bitmap' )
- byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: ushort-components normalize-component-type*
- drop ushorts>ubytes ;
-
-M: ubyte-components normalize-component-type*
- drop ;
-
-: normalize-scan-line-order ( image -- image )
- dup upside-down?>> [
- dup dim>> first 4 * '[
- _ <groups> reverse concat
- ] change-bitmap
- f >>upside-down?
- ] when ;
-
-: validate-request ( src-order dst-order -- src-order dst-order )
- [
- [ { DEPTH DEPTH-STENCIL INTENSITY } member? ] bi@
- or [ "Invalid component-order" throw ] when
- ] 2keep ;
-
-PRIVATE>
-
-: reorder-components ( image component-order -- image )
- [
- dup component-type>> '[ _ normalize-component-type* ] change-bitmap
- dup component-order>>
- ] dip
- validate-request [ (reorder-components) ] keep >>component-order ;
-
-: normalize-image ( image -- image )
- [ >byte-array ] change-bitmap
- RGBA reorder-components
- normalize-scan-line-order ;
-
--- /dev/null
+ PNGSUITE
+----------------
+
+ testset for PNG-(de)coders
+ created by Willem van Schaik
+------------------------------------
+
+This is a collection of graphics images created to test the png applications
+like viewers, converters and editors. All (as far as that is possible)
+formats supported by the PNG standard are represented.
+
+
+1. INTRODUCTION
+--------------------
+
+1.1 PNG capabilities
+------------------------
+
+Supported color-types are:
+
+ - grayscale
+ - grayscale + alpha-channel
+ - color palettes
+ - rgb
+ - rgb + alpha-channel
+
+Allowed bitdepths are depending on the color-type, but are in the range
+of 1-bit (grayscale, which is b&w) upto 16-bits.
+
+Special features are:
+
+ - interlacing (Adam-7)
+ - gamma-support
+ - transparency (a poor-man's alpha solution)
+
+
+1.2 File naming
+-------------------
+
+Where possible, the testfiles are 32x32 bits icons. This results in a still
+reasonable size of the suite even with a large number of tests. The name
+of each test-file reflects thetype in the following way:
+
+ g04i2c08.png
+ || |||+---- bit-depth
+ || ||+----- color-type (descriptive)
+ || |+------ color-type (numerical)
+ || +------- interlaced or non-interlaced
+ |+--------- parameter of test (in this case gamma-value)
+ +---------- test feature (in this case gamma)
+
+
+1.3 PNG formats
+-------------------
+
+color-type:
+ 0g - grayscale
+ 2c - rgb color
+ 3p - paletted
+ 4a - grayscale + alpha channel
+ 6a - rgb color + alpha channel
+
+bit-depth:
+ 01 - with color-type 0, 3
+ 02 - with color-type 0, 3
+ 04 - with color-type 0, 3
+ 08 - with color-type 0, 2, 3, 4, 6
+ 16 - with color-type 0, 2, 4, 6
+
+interlacing:
+ n - non-interlaced
+ i - interlaced
+
+
+2. THE TESTS
+-----------------
+
+2.1 Sizes
+-------------
+
+These tests are there to check if your software handles pictures well, with
+picture sizes that are not a multiple of 8. This is particularly important
+with Adam-7 type interlacing. In the same way these tests check if pictures
+size 1x1 and similar are ok.
+
+ s01 - 1x1 pixel picture
+ s02 - 2x2 pixel picture
+ s03 - 3x3 pixel picture
+ s04 - 4x4 pixel picture
+ s05 - 5x5 pixel picture
+ s06 - 6x6 pixel picture
+ s07 - 7x7 pixel picture
+ s08 - 8x8 pixel picture
+ s09 - 9x9 pixel picture
+ s32 - 32x32 pixel picture
+ s33 - 33x33 pixel picture
+ s34 - 34x34 pixel picture
+ s35 - 35x35 pixel picture
+ s36 - 36x36 pixel picture
+ s37 - 37x37 pixel picture
+ s38 - 38x38 pixel picture
+ s39 - 39x39 pixel picture
+ s40 - 40x40 pixel picture
+
+
+2.2 Background
+------------------
+
+When the PNG file contains a background chunck, this should be used for
+pictures with alpha-channel or pictures with a transparency chunck. For
+pictures without this background-chunk, but with alpha, this testset
+assumes a black background.
+
+For the images in this test, the left-side should be 100% the background
+color, where moving to the right the color should gradually become the
+image pattern.
+
+ bga - alpha + no background
+ bgw - alpha + white background
+ bgg - alpha + gray background
+ bgb - alpha + black background
+ bgy - alpha + yellow background
+
+
+2.3 Transparency
+--------------------
+
+Transparency should be used together with a background chunk. To test the
+combination of the two the latter 4 tests are there. How to handle pictures
+with transparancy, but without a background, opinions can differ. Here we
+use black, but especially in the case of paletted images, the normal color
+would maybe even be better.
+
+ tp0 - not transparent for reference
+ tp1 - transparent, but no background chunk
+ tbw - transparent + white background
+ tbg - transparent + gray background
+ tbb - transparent + black background
+ tby - transparent + yellow background
+
+
+2.4 Gamma
+-------------
+
+To test if your viewer handles gamma-correction, 6 testfiles are available.
+They contain corrected color-ramps and a corresponding gamma-chunk with the
+file-gamma value. These are created in such a way that when the viewer does
+the gamma correction right, all 6 should be displayed identical.
+
+If they are different, probably the gamma correction is omitted. In that
+case, have a look at the two right coloumns in the 6 pictures. The image
+where those two look the same (when looked from far) reflects the gamma of
+your system. However, because of the limited size of the image, you should
+do more elaborate tests to determine your display gamma.
+
+ g03 - file-gamma = 0.35, for display with gamma = 2.8
+ g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC)
+ g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac)
+ g07 - file-gamma = 0.70, for display with gamma = 1.4
+ g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT)
+ g25 - file-gamma = 2.50, for display with gamma = 0.4
+
+
+2.5 Filtering
+-----------------
+
+PNG uses file-filtering, for optimal compression. Normally the type is of
+filtering is adjusted to the contents of the picture, but here each file
+has the same picture, with a different filtering.
+
+ f0 - no filtering
+ f1 - sub filtering
+ f2 - up filtering
+ f3 - average filtering
+ f4 - paeth filtering
+
+
+2.6 Additional palettes
+---------------------------
+
+Besides the normal use of paletted images, palette chunks can in combination
+with true-color (and other) images also be used to select color lookup-tables
+when the video system is of limited capabilities. The suggested palette chunk
+is specially created for this purpose.
+
+ pp - normal palette chunk
+ ps - suggested palette chunk
+
+
+2.7 Ancillary chunks (under construction)
+------------------------
+
+To test the correct decoding of ancillary chunks, these test-files contain
+one or more examples of these chunkcs. Depending on the type of chunk, a
+number of typical values are selected to test. Unluckily, the testset can
+not contain all combinations, because that would be an endless set.
+
+The significant bits are used in files with the next higher bit-depth. They
+indicate howmany bits are valid.
+
+ cs3 - 3 significant bits
+ cs5 - 5 significant bits
+ cs8 - 8 significant bits (reference)
+ cs3 - 13 significant bits
+
+For the physical pixel dimensions, the result of each decoding should be
+a sqare picture. The first (cdf) image is an example of flat (horizontal)
+pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take
+care of the correction. The second is just the other way round. The last
+example uses the unit specifier, for 1000 pixels per meter. This should
+result in a picture of 3.2 cm square.
+
+ cdf - physical pixel dimensions, 8x32 flat pixels
+ cdh - physical pixel dimensions, 32x8 high pixels
+ cds - physical pixel dimensions, 8x8 square pixels
+ cdu - physical pixel dimensions, with unit-specifier
+
+ ccw - primary chromaticities and white point
+
+ ch1 - histogram 15 colors
+ ch2 - histogram 256 colors
+
+ cm7 - modification time, 01-jan-1970
+ cm9 - modification time, 31-dec-1999
+ cm0 - modification time, 01-jan-2000
+
+In the textual chunk, a number of the standard, and some non-standard
+text items are included.
+
+ ct0 - no textual data
+ ct1 - with textual data
+ ctz - with compressed textual data
+
+
+2.8 Chunk ordering (still under construction)
+----------------------
+
+These testfiles will test the obligatory ordering relations between various
+chunk types (not yet) as well as the number of data chunks used for the image.
+
+ oi1 - mother image with 1 idat-chunk
+ oi2 - image with 2 idat-chunks
+ oi4 - image with 4 unequal sized idat-chunks
+ oi9 - all idat-chunks of length one
+
+
+2.9 Compression level
+-------------------------
+
+Here you will find a set of images compressed by zlib, ranging from level 0
+for no compression at maximum speed upto level 9 for maximum compression.
+
+ z00 - zlib compression level 0 - none
+ z03 - zlib compression level 3
+ z06 - zlib compression level 6 - default
+ z09 - zlib compression level 9 - maximum
+
+
+2.10 Corrupted files (under construction)
+-----------------------
+
+All these files are illegal. When decoding they should generate appropriate
+error-messages.
+
+ x00 - empty IDAT chunk
+ xcr - added cr bytes
+ xlf - added lf bytes
+ xc0 - color type 0
+ xc9 - color type 9
+ xd0 - bit-depth 0
+ xd3 - bit-depth 3
+ xd9 - bit-depth 99
+ xcs - incorrect IDAT checksum
+
+
+3. TEST FILES
+------------------
+
+For each of the tests listed above, one or more test-files are created. A
+selection is made (for each test) for the color-type and bitdepth to be used
+for the tests. Further for a number of tests, both a non-interlaced as well
+as an interlaced version is available.
+
+
+3.1 Basic format test files (non-interlaced)
+------------------------------------------------
+
+ basn0g01 - black & white
+ basn0g02 - 2 bit (4 level) grayscale
+ basn0g04 - 4 bit (16 level) grayscale
+ basn0g08 - 8 bit (256 level) grayscale
+ basn0g16 - 16 bit (64k level) grayscale
+ basn2c08 - 3x8 bits rgb color
+ basn2c16 - 3x16 bits rgb color
+ basn3p01 - 1 bit (2 color) paletted
+ basn3p02 - 2 bit (4 color) paletted
+ basn3p04 - 4 bit (16 color) paletted
+ basn3p08 - 8 bit (256 color) paletted
+ basn4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basn4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.2 Basic format test files (Adam-7 interlaced)
+---------------------------------------------------
+
+ basi0g01 - black & white
+ basi0g02 - 2 bit (4 level) grayscale
+ basi0g04 - 4 bit (16 level) grayscale
+ basi0g08 - 8 bit (256 level) grayscale
+ basi0g16 - 16 bit (64k level) grayscale
+ basi2c08 - 3x8 bits rgb color
+ basi2c16 - 3x16 bits rgb color
+ basi3p01 - 1 bit (2 color) paletted
+ basi3p02 - 2 bit (4 color) paletted
+ basi3p04 - 4 bit (16 color) paletted
+ basi3p08 - 8 bit (256 color) paletted
+ basi4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basi4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.3 Sizes test files
+-----------------------
+
+ s01n3p01 - 1x1 paletted file, no interlacing
+ s02n3p01 - 2x2 paletted file, no interlacing
+ s03n3p01 - 3x3 paletted file, no interlacing
+ s04n3p01 - 4x4 paletted file, no interlacing
+ s05n3p02 - 5x5 paletted file, no interlacing
+ s06n3p02 - 6x6 paletted file, no interlacing
+ s07n3p02 - 7x7 paletted file, no interlacing
+ s08n3p02 - 8x8 paletted file, no interlacing
+ s09n3p02 - 9x9 paletted file, no interlacing
+ s32n3p04 - 32x32 paletted file, no interlacing
+ s33n3p04 - 33x33 paletted file, no interlacing
+ s34n3p04 - 34x34 paletted file, no interlacing
+ s35n3p04 - 35x35 paletted file, no interlacing
+ s36n3p04 - 36x36 paletted file, no interlacing
+ s37n3p04 - 37x37 paletted file, no interlacing
+ s38n3p04 - 38x38 paletted file, no interlacing
+ s39n3p04 - 39x39 paletted file, no interlacing
+ s40n3p04 - 40x40 paletted file, no interlacing
+
+ s01i3p01 - 1x1 paletted file, interlaced
+ s02i3p01 - 2x2 paletted file, interlaced
+ s03i3p01 - 3x3 paletted file, interlaced
+ s04i3p01 - 4x4 paletted file, interlaced
+ s05i3p02 - 5x5 paletted file, interlaced
+ s06i3p02 - 6x6 paletted file, interlaced
+ s07i3p02 - 7x7 paletted file, interlaced
+ s08i3p02 - 8x8 paletted file, interlaced
+ s09i3p02 - 9x9 paletted file, interlaced
+ s32i3p04 - 32x32 paletted file, interlaced
+ s33i3p04 - 33x33 paletted file, interlaced
+ s34i3p04 - 34x34 paletted file, interlaced
+ s35i3p04 - 35x35 paletted file, interlaced
+ s36i3p04 - 36x36 paletted file, interlaced
+ s37i3p04 - 37x37 paletted file, interlaced
+ s38i3p04 - 38x38 paletted file, interlaced
+ s39i3p04 - 39x39 paletted file, interlaced
+ s40i3p04 - 40x40 paletted file, interlaced
+
+
+3.4 Background test files (with alpha)
+------------------------------------------
+
+ bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced
+ bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced
+ bgan6a08 - 3x8 bits rgb color, alpha, no background chunk
+ bgan6a16 - 3x16 bits rgb color, alpha, no background chunk
+
+ bgbn4a08 - 8 bit grayscale, alpha, black background chunk
+ bggn4a16 - 16 bit grayscale, alpha, gray background chunk
+ bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk
+ bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk
+
+
+3.5 Transparency (and background) test files
+------------------------------------------------
+
+ tp0n1g08 - not transparent for reference (logo on gray)
+ tbbn1g04 - transparent, black background chunk
+ tbwn1g16 - transparent, white background chunk
+ tp0n2c08 - not transparent for reference (logo on gray)
+ tbrn2c08 - transparent, red background chunk
+ tbgn2c16 - transparent, green background chunk
+ tbbn2c16 - transparent, blue background chunk
+ tp0n3p08 - not transparent for reference (logo on gray)
+ tp1n3p08 - transparent, but no background chunk
+ tbbn3p08 - transparent, black background chunk
+ tbgn3p08 - transparent, light-gray background chunk
+ tbwn3p08 - transparent, white background chunk
+ tbyn3p08 - transparent, yellow background chunk
+
+
+3.6 Gamma test files
+------------------------
+
+ g03n0g16 - grayscale, file-gamma = 0.35
+ g04n0g16 - grayscale, file-gamma = 0.45
+ g05n0g16 - grayscale, file-gamma = 0.55
+ g07n0g16 - grayscale, file-gamma = 0.70
+ g10n0g16 - grayscale, file-gamma = 1.00
+ g25n0g16 - grayscale, file-gamma = 2.50
+ g03n2c08 - color, file-gamma = 0.35
+ g04n2c08 - color, file-gamma = 0.45
+ g05n2c08 - color, file-gamma = 0.55
+ g07n2c08 - color, file-gamma = 0.70
+ g10n2c08 - color, file-gamma = 1.00
+ g25n2c08 - color, file-gamma = 2.50
+ g03n3p04 - paletted, file-gamma = 0.35
+ g04n3p04 - paletted, file-gamma = 0.45
+ g05n3p04 - paletted, file-gamma = 0.55
+ g07n3p04 - paletted, file-gamma = 0.70
+ g10n3p04 - paletted, file-gamma = 1.00
+ g25n3p04 - paletted, file-gamma = 2.50
+
+
+3.7 Filtering test files
+----------------------------
+
+ f00n0g08 - grayscale, no interlacing, filter-type 0
+ f01n0g08 - grayscale, no interlacing, filter-type 1
+ f02n0g08 - grayscale, no interlacing, filter-type 2
+ f03n0g08 - grayscale, no interlacing, filter-type 3
+ f04n0g08 - grayscale, no interlacing, filter-type 4
+ f00n2c08 - color, no interlacing, filter-type 0
+ f01n2c08 - color, no interlacing, filter-type 1
+ f02n2c08 - color, no interlacing, filter-type 2
+ f03n2c08 - color, no interlacing, filter-type 3
+ f04n2c08 - color, no interlacing, filter-type 4
+
+
+3.8 Additional palette chunk test files
+-------------------------------------------
+
+ pp0n2c16 - six-cube palette-chunk in true-color image
+ pp0n6a08 - six-cube palette-chunk in true-color+alpha image
+ ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image
+ ps1n2c16 - six-cube suggested palette (1 byte) in true-color image
+ ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image
+ ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image
+
+
+3.9 Ancillary chunks test files
+-----------------------------------
+
+ cs5n2c08 - color, 5 significant bits
+ cs8n2c08 - color, 8 significant bits (reference)
+ cs3n2c16 - color, 13 significant bits
+ cs3n3p08 - paletted, 3 significant bits
+ cs5n3p08 - paletted, 5 significant bits
+ cs8n3p08 - paletted, 8 significant bits (reference)
+
+ cdfn2c08 - physical pixel dimensions, 8x32 flat pixels
+ cdhn2c08 - physical pixel dimensions, 32x8 high pixels
+ cdsn2c08 - physical pixel dimensions, 8x8 square pixels
+ cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter
+
+ ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+ ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+
+ ch1n3p04 - histogram 15 colors
+ ch2n3p08 - histogram 256 colors
+
+ cm7n0g04 - modification time, 01-jan-1970 00:00:00
+ cm9n0g04 - modification time, 31-dec-1999 23:59:59
+ cm0n0g04 - modification time, 01-jan-2000 12:34:56
+
+ ct0n0g04 - no textual data
+ ct1n0g04 - with textual data
+ ctzn0g04 - with compressed textual data
+
+
+
+3.10 Chunk ordering
+----------------------
+
+ oi1n0g16 - grayscale mother image with 1 idat-chunk
+ oi2n0g16 - grayscale image with 2 idat-chunks
+ oi4n0g16 - grayscale image with 4 unequal sized idat-chunks
+ oi9n0g16 - grayscale image with all idat-chunks length one
+ oi1n2c16 - color mother image with 1 idat-chunk
+ oi2n2c16 - color image with 2 idat-chunks
+ oi4n2c16 - color image with 4 unequal sized idat-chunks
+ oi9n2c16 - color image with all idat-chunks length one
+
+
+
+3.11 Compression level
+-------------------------
+
+ z00n2c08 - color, no interlacing, compression level 0 (none)
+ z03n2c08 - color, no interlacing, compression level 3
+ z06n2c08 - color, no interlacing, compression level 6 (default)
+ z09n2c08 - color, no interlacing, compression level 9 (maximum)
+
+
+
+3.12 Currupted files
+-----------------------
+
+ x00n0g01 - empty 0x0 grayscale file
+ xcrn0g04 - added cr bytes
+ xlfn0g04 - added lf bytes
+ xc0n0c08 - color type 0
+ xc9n0c08 - color type 9
+ xd0n2c00 - bit-depth 0
+ xd3n2c03 - bit-depth 3
+ xd9n2c99 - bit-depth 99
+ xcsn2c08 - incorrect IDAT checksum
+
+
+--------
+ (c) Willem van Schaik
+ willem@schaik.com
+ Singapore, October 1996
--- /dev/null
+\89PNG
+
+
+\1a
+
+
+IHDR \ 4\93áÈ)ÈIDATx\9c]ÑÁ
+Â0\f\ 5P\1f*@\bð\b\1d¡#°
+
+#TâÈ\ 51\ 1\e0\ 2lPF`\ 3Ø F=\95\ 2\9fÄIQâ\1c*çÅuí\94`\16%qk\81
+H\9eñ\9a\88©ñ´\80m\ 2÷\7fÍ\büµàß\9f Ñ\8d=,\14¸fìOK
+
+ç\a Ðt\8eÀ(Èï\ 5ä\92×\1e¦íF\v;èPº\80¯¾{xpç]\ 39\87/\ap\8f*$(ì*éyìÕ\83 ×þ\1eÚéçè@÷C¼ \12 cÔq\16\9e\8bNÛU#\84)11·.\8d\81\15r\10äðf\ 3\17ä0°\81ägh(¥\81tý\1eÙÂEøÿ\89kIEND®B`\82
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax images images.viewer kernel
+quotations strings ;
+IN: images.testing
+
+HELP: decode-test
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image decoder. The image is decoded and compared against its corresponding " { $link { "images" "testing" "reference" } } "." } ;
+
+HELP: encode-test
+{ $values
+ { "path" "a pathname string" } { "image-class" object }
+}
+{ $description "Runs a unit-test on the image at " { $snippet "path" } " to test the image encoder. The image is decoded, encoded, and then decoded again to verify that the final decoded output matches the original decoded output. Before comparison for equality, the images are normalized in order to accomodate differences in representation between the two potential encoders." }
+{ $warning "This test assumes that the image decoder is working correctly. If the image fails both the " { $link decode-test } " and the " { $link encode-test } ", then you should first debug the decoder. Once the decoder is working correctly, proceed with testing the encoder." } ;
+
+HELP: images.
+{ $values
+ { "dirpath" "a pathname string" } { "extension" string }
+}
+{ $description "Renders each image at " { $snippet "dirpath" } " directly to the Listener tool." } ;
+{ images. image. } related-words
+
+HELP: load-reference-image
+{ $values
+ { "path" "a pathname string" }
+ { "image" image }
+}
+{ $description "Loads the " { $link { "images" "testing" "reference" } } " that corresponds to the original image at " { $snippet "path" } " into memory." } ;
+
+HELP: ls
+{ $values
+ { "dirpath" "a pathname string" } { "extension" object }
+}
+{ $description "Prints out the name of each file surrounded in double quotes so that you can easily copy and paste into your unit test." } ;
+
+HELP: save-all-as-reference-images
+{ $values
+ { "dirpath" "a pathname string" } { "extension" object }
+}
+{ $description "Saves a " { $link { "images" "testing" "reference" } } " for each image in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." }
+{ $warning "You should only call this word after you have manually verified that every image in " { $snippet "dirpath" } " decodes and renders correctly!" } ;
+
+HELP: save-as-reference-image
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "Saves a " { $link { "images" "testing" "reference" } } " for the image at " { $snippet "path" } "." }
+{ $warning "You should only call this word after you have manually verified that the image at " { $snippet "path" } " decodes and renders correctly!" } ;
+
+HELP: with-matching-files
+{ $values
+ { "dirpath" "a pathname string" } { "extension" string } { "quot" quotation }
+}
+{ $description "Perform an operation on each file in " { $snippet "dirpath" } " with file extension " { $snippet "extension" } "." } ;
+
+ARTICLE: { "images" "testing" "reference" } "Reference image"
+"For the purposes of the " { $vocab-link "images.testing" } " vocab, a reference image is an " { $link image } " which has been serialized to disk by the " { $vocab-link "serialize" } " vocab. The file on disk has a " { $snippet ".fig" } " extension."
+$nl
+"Reference images are used by " { $link decode-test } " to compare the decoder's output against a saved image that is known to be correct."
+$nl
+"You can create your own reference image after you verify that the image has been correctly decoded:"
+{ $subsections
+ save-as-reference-image
+ save-all-as-reference-images
+}
+"A reference image can be loaded by the path of the original image:"
+{ $subsections load-reference-image }
+;
+
+ARTICLE: "images.testing" "Testing image encoders and decoders"
+"The " { $vocab-link "images.testing" } " vocab facilitates writing unit tests for image encoders and decoders by providing common functionality"
+$nl
+"Creating a unit test:"
+{ $subsections
+ decode-test
+ encode-test
+}
+"Establishing a " { $link { "images" "testing" "reference" } } ":"
+{ $subsections save-as-reference-image }
+"You should only create a reference image after you manually verify that your decoder is generating a valid " { $link image } " object and that it renders correctly to the screen. The following words are useful for manual verification:"
+{ $subsections
+ image.
+ images.
+}
+"Helpful words for writing potentially tedious unit tests for each image file under test:"
+{ $subsections
+ save-all-as-reference-images
+ ls
+ with-matching-files
+}
+{ $notes "This vocabulary is only intended for implementors of image encoders and image decoders. If you are an end-user, you are in the wrong place :-)" }
+;
+
+ABOUT: "images.testing"
--- /dev/null
+! Copyright (C) 2009 Keith Lazuka.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry images.loader images.normalization images.viewer io
+io.directories io.encodings.binary io.files io.pathnames
+io.streams.byte-array kernel locals namespaces quotations
+sequences serialize tools.test io.backend ;
+IN: images.testing
+
+<PRIVATE
+
+: fig-name ( path -- newpath )
+ [ parent-directory normalize-path ]
+ [ file-stem ".fig" append ] bi
+ append-path ;
+
+PRIVATE>
+
+:: with-matching-files ( dirpath extension quot -- )
+ dirpath [
+ [
+ dup file-extension extension = quot [ drop ] if
+ ] each
+ ] with-directory-files ; inline
+
+: images. ( dirpath extension -- )
+ [ image. ] with-matching-files ;
+
+: ls ( dirpath extension -- )
+ [ "\"" dup surround print ] with-matching-files ;
+
+: save-as-reference-image ( path -- )
+ [ load-image ] [ fig-name ] bi
+ binary [ serialize ] with-file-writer ;
+
+: save-all-as-reference-images ( dirpath extension -- )
+ [ save-as-reference-image ] with-matching-files ;
+
+: load-reference-image ( path -- image )
+ fig-name binary [ deserialize ] with-file-reader ;
+
+:: encode-test ( path image-class -- )
+ f verbose-tests? [
+ path load-image dup clone normalize-image 1quotation swap
+ '[
+ binary [ _ image-class image>stream ] with-byte-writer
+ image-class load-image* normalize-image
+ ] unit-test
+ ] with-variable ;
+
+: decode-test ( path -- )
+ f verbose-tests? [
+ [ load-image 1quotation ]
+ [ '[ _ load-reference-image ] ] bi
+ unit-test
+ ] with-variable ;
}
} ;
-HELP: [infix|
-{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
-{ $examples
- { $example
- "USING: infix prettyprint ;"
- "IN: scratchpad"
- "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
- "452.16"
- }
-} ;
-
-{ POSTPONE: [infix POSTPONE: [infix| } related-words
-
ARTICLE: "infix" "Infix notation"
"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code."
{ $subsections
POSTPONE: [infix
- POSTPONE: [infix|
}
$nl
"The usual infix math operators are supported:"
$nl
"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
{ $example
- "USING: arrays infix ;"
- "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ."
+ "USING: arrays locals infix ;"
+ "[let { 1 2 3 4 } :> myarr [infix myarr[4/2]*3 infix] ] ."
"9"
}
"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
-5*
0 infix] ] unit-test
-[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
- r*r*pi infix] ] unit-test
-[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
-[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
-[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
-
-[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
-[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
-[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
-[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
-
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
[ t ] [ 5 \ stupid_function check-word ] unit-test
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
-[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test
+[ -1 ] [ [let 1 :> a [infix -a infix] ] ] unit-test
PRIVATE>
SYNTAX: [infix
- "infix]" [infix-parse parsed \ call parsed ;
-
-<PRIVATE
-
-: parse-infix-locals ( assoc end -- quot )
- '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
-
-PRIVATE>
-
-SYNTAX: [infix|
- "|" parse-bindings "infix]" parse-infix-locals <let>
- ?rewrite-closures over push-all ;
+ "infix]" [infix-parse suffix! \ call suffix! ;
: get-comm-state ( duplex -- dcb )
in>> handle>>
- DCB <struct> tuck
- GetCommState win32-error=0/f ;
+ DCB <struct> [ GetCommState win32-error=0/f ] keep ;
: set-comm-state ( duplex dcb -- )
[ in>> handle>> ] dip
USING: accessors alien.c-types jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays ;
+opengl.demo-support sequences specialized-arrays locals ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
IN: jamshred.gl
over color>> gl-color segment-vertex-and-normal
gl-normal gl-vertex ;
-: draw-vertex-pair ( theta next-segment segment -- )
- rot tuck draw-segment-vertex draw-segment-vertex ;
+:: draw-vertex-pair ( theta next-segment segment -- )
+ segment theta draw-segment-vertex
+ next-segment theta draw-segment-vertex ;
: draw-segment ( next-segment segment -- )
GL_QUAD_STRIP [
: scalar-projection ( v1 v2 -- n )
#! the scalar projection of v1 onto v2
- tuck v. swap norm / ;
+ [ v. ] [ norm ] bi / ;
: proj-perp ( u v -- w )
dupd proj v- ;
: perpendicular-distance ( oint oint -- distance )
- tuck distance-vector swap 2dup left>> scalar-projection abs
+ [ distance-vector ] keep 2dup left>> scalar-projection abs
-rot up>> scalar-projection abs + ;
:: reflect ( v n -- v' )
forward-pivot ;
: to-tunnel-start ( player -- )
- [ tunnel>> first dup location>> ]
- [ tuck (>>location) (>>nearest-segment) ] bi ;
+ dup tunnel>> first
+ [ >>nearest-segment ]
+ [ location>> >>location ] bi drop ;
: play-in-tunnel ( player segments -- )
>>tunnel to-tunnel-start ;
-: update-nearest-segment ( player -- )
- [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
- [ (>>nearest-segment) ] tri ;
-
: update-time ( player -- seconds-passed )
millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
] if ;
:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- [let* | d-to-move [ d-left distance min ]
- move-v [ d-to-move heading n*v ] |
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ] ;
+ d-left distance min :> d-to-move
+ d-to-move heading n*v :> move-v
+
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ;
: distance-to-move-freely ( player -- distance )
[ almost-to-collision ]
SPECIALIZED-ARRAY: float
IN: jamshred.tunnel.tests
-[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
- T{ segment f { 1 1 1 } f f f 1 }
- T{ oint f { 0 0 0.25 } }
- nearer-segment number>> ] unit-test
-
-[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
-
-[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
-
-[ float-array{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
-
: test-segment-oint ( -- oint )
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
#! valid values
[ '[ _ clamp-length ] bi@ ] keep <slice> ;
-: nearer-segment ( segment segment oint -- segment )
- #! return whichever of the two segments is nearer to the oint
- [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
-
-: (find-nearest-segment) ( nearest next oint -- nearest ? )
- #! find the nearest of 'next' and 'nearest' to 'oint', and return
- #! t if the nearest hasn't changed
- pick [ nearer-segment dup ] dip = ;
-
-: find-nearest-segment ( oint segments -- segment )
- dup first swap rest-slice rot [ (find-nearest-segment) ] curry
- find 2drop ;
-
-: nearest-segment-forward ( segments oint start -- segment )
- rot dup length swap <slice> find-nearest-segment ;
-
-: nearest-segment-backward ( segments oint start -- segment )
- swapd 1 + 0 spin <slice> <reversed> find-nearest-segment ;
-
-: nearest-segment ( segments oint start-segment -- segment )
- #! find the segment nearest to 'oint', and return it.
- #! start looking at segment 'start-segment'
- number>> over [
- [ nearest-segment-forward ] 3keep nearest-segment-backward
- ] dip nearer-segment ;
-
: get-segment ( segments n -- segment )
over clamp-length swap nth ;
} case ;
:: distance-to-next-segment ( current next location heading -- distance )
- [let | cf [ current forward>> ] |
- cf next location>> v. cf location v. - cf heading v. / ] ;
+ current forward>> :> cf
+ cf next location>> v. cf location v. - cf heading v. / ;
:: distance-to-next-segment-area ( current next location heading -- distance )
- [let | cf [ current forward>> ]
- h [ next current half-way-between-oints ] |
- cf h v. cf location v. - cf heading v. / ] ;
+ current forward>> :> cf
+ next current half-way-between-oints :> h
+ cf h v. cf location v. - cf heading v. / ;
: vector-to-centre ( seg loc -- v )
over location>> swap v- swap forward>> proj-perp ;
v norm 0 = [
distant
] [
- [let* | a [ v dup v. ]
- b [ v w v. 2 * ]
- c [ w dup v. r sq - ] |
- c b a quadratic max-real ]
+ v dup v. :> a
+ v w v. 2 * :> b
+ w dup v. r sq - :> c
+ c b a quadratic max-real
] if ;
: sideways-heading ( oint segment -- v )
[ [ 0.0 ] unless* ] tri@
[ (xy>loc) ] dip (z>loc) ;
-: move-axis ( gadget x y z -- )
- (xyz>loc) rot tuck
- [ indicator>> (>>loc) ]
- [ z-indicator>> (>>loc) ] 2bi* ;
+:: move-axis ( gadget x y z -- )
+ x y z (xyz>loc) :> ( xy z )
+ xy gadget indicator>> (>>loc)
+ z gadget z-indicator>> (>>loc) ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
[ >>controller ] [ product-string <label> add-gadget ] bi ;
: add-axis-gadget ( gadget shelf -- gadget shelf )
- <axis-gadget> tuck [ >>axis ] [ add-gadget-with-border ] 2bi* ;
+ <axis-gadget> [ >>axis ] [ add-gadget-with-border ] bi-curry bi* ;
: add-raxis-gadget ( gadget shelf -- gadget shelf )
- <axis-gadget> tuck [ >>raxis ] [ add-gadget-with-border ] 2bi* ;
+ <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi-curry bi* ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
: <keys> ( gadget -- key-handler ) key-handler new-border { 0 0 } >>size ;
M: key-handler handle-gesture
- tuck handlers>> at [ call( gadget -- ) f ] [ drop t ] if* ;
\ No newline at end of file
+ [ handlers>> at ] keep swap [ call( gadget -- ) f ] [ drop t ] if* ;
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables assocs io kernel math
+USING: accessors arrays hashtables assocs io kernel locals math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
splitting sorting shuffle sets math.order ;
[ ?nth ?nth ] 3keep [ [ 2 + ] dip 1 - ] dip ?nth ?nth
dim-im/ker-d ;
-: bigraded-ker/im-d ( bigraded-basis -- seq )
- dup length [
- over first length [
- [ 2dup ] dip spin (bigraded-ker/im-d)
- ] map 2nip
- ] with map ;
+:: bigraded-ker/im-d ( basis -- seq )
+ basis length iota [| z |
+ basis first length iota [| u |
+ u z basis (bigraded-ker/im-d)
+ ] map
+ ] map ;
: bigraded-betti ( u-generators z-generators -- seq )
[ basis graded ] bi@ tensor bigraded-ker/im-d
: laplacian-betti ( basis1 basis2 basis3 -- n )
laplacian-matrix null/rank drop ;
-: laplacian-kernel ( basis1 basis2 basis3 -- basis )
- [ tuck ] dip
- laplacian-matrix dup empty-matrix? [
- 2drop f
- ] [
- nullspace [
- [ [ wedge (alt+) ] 2each ] with-terms
- ] with map
+:: laplacian-kernel ( basis1 basis2 basis3 -- basis )
+ basis1 basis2 basis3 laplacian-matrix :> lap
+ lap empty-matrix? [ f ] [
+ lap nullspace [| x |
+ basis2 x [ [ wedge (alt+) ] 2each ] with-terms
+ ] map
] if ;
: graded-triple ( seq n -- triple )
3tri
3array ;
-: bigraded-triples ( grid -- triples )
- dup length [
- over first length [
- [ 2dup ] dip spin bigraded-triple
- ] map 2nip
- ] with map ;
+:: bigraded-triples ( grid -- triples )
+ grid length [| z |
+ grid first length [| u |
+ u z grid bigraded-triple
+ ] map
+ ] map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
[ [ basis graded ] bi@ tensor bigraded-triples ] dip
;EBNF
-SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;
\ No newline at end of file
+SYNTAX: TYPE: ";" parse-multiline-string parse-type suffix! ;
M: windows really-delete-tree
#! Workaround: Cygwin GIT creates read-only files for
#! some reason.
- [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix short-running-process ]
+ [ { "chmod" "ug+rw" "-R" } swap absolute-path suffix short-running-process ]
[ delete-tree ]
bi ;
'[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- )
- [let* | temp [ remote ".incomplete" append ]
- scp-remote [ { username "@" host ":" temp } concat ]
- scp [ scp-command get ]
- ssh [ ssh-command get ] |
- 5 [ { scp local scp-remote } short-running-process ] retry
- 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
- ] ;
+ remote ".incomplete" append :> temp
+ { username "@" host ":" temp } concat :> scp-remote
+ scp-command get :> scp
+ ssh-command get :> ssh
+ 5 [ { scp local scp-remote } short-running-process ] retry
+ 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ;
: eval-file ( file -- obj )
dup utf8 file-lines parse-fresh
[ [ y>> second ] [ x>> second neg ] bi 2array ]
[ [ y>> first neg ] [ x>> first ] bi 2array ]
[ |a| ] tri
- tuck [ v/n ] 2bi@ ;
+ [ v/n ] curry bi@ ;
: inverse-axes ( a -- a^-1 )
(inverted-axes) { 0.0 0.0 } <affine-transform> ;
{ $values { "x" number } { "gamma[x]" number } }
{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ;
-HELP: nth-root
-{ $values { "n" integer } { "x" number } { "y" number } }
-{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
-
HELP: exp-int
{ $values { "x" number } { "y" number } }
{ $description "Exponential integral function." }
[ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
-: nth-root ( n x -- y )
- swap recip ^ ;
-
! Forth Scientific Library Algorithm #1
!
! Evaluates the Real Exponential Integral,
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: sequences kernel arrays vectors accessors assocs sorting math math.functions ;
+USING: sequences kernel arrays vectors accessors assocs shuffle sorting locals math math.functions ;
IN: math.binpack
[ [ values sum ] map ] keep
zip sort-keys values first push ;
-: binpack ( assoc n -- bins )
- [ sort-values <reversed> dup length ] dip
- tuck / ceiling <array> [ <vector> ] map
- tuck [ (binpack) ] curry each ;
+:: binpack ( assoc n -- bins )
+ assoc sort-values <reversed> :> values
+ values length :> #values
+ n #values n / ceiling <array> [ <vector> ] map :> bins
+ values [ bins (binpack) ] each
+ bins ;
: binpack* ( items n -- bins )
[ dup zip ] dip binpack [ keys ] map ;
<PRIVATE
: weighted ( x y a -- z )
- tuck [ * ] [ 1 - neg * ] 2bi* + ;
+ [ * ] [ 1 - neg * ] bi-curry bi* + ;
: a ( n -- a )
1 + 2 swap / ;
<PRIVATE
: columns ( a -- a1 a2 a3 a4 )
- columns>> 4 firstn ; inline
+ columns>> first4 ; inline
:: set-columns ( c1 c2 c3 c4 c -- c )
c columns>> :> columns
:: 2map-columns ( a b quot -- c )
[
- a columns :> a4 :> a3 :> a2 :> a1
- b columns :> b4 :> b3 :> b2 :> b1
+ a columns :> ( a1 a2 a3 a4 )
+ b columns :> ( b1 b2 b3 b4 )
a1 b1 quot call
a2 b2 quot call
TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
[
- a columns :> a4 :> a3 :> a2 :> a1
- b columns :> b4 :> b3 :> b2 :> b1
+ a columns :> ( a1 a2 a3 a4 )
+ b columns :> ( b1 b2 b3 b4 )
b1 first a1 n*v :> c1a
b2 first a1 n*v :> c2a
] make-matrix4 ;
TYPED:: m4.v ( m: matrix4 v: float-4 -- v': float-4 )
- m columns :> m4 :> m3 :> m2 :> m1
+ m columns :> ( m1 m2 m3 m4 )
v first m1 n*v
v second m2 n*v v+
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions ;
+USING: kernel locals math math.functions ;
IN: math.quadratic
-: monic ( c b a -- c' b' ) tuck [ / ] 2bi@ ;
+: monic ( c b a -- c' b' ) [ / ] curry bi@ ;
-: discriminant ( c b -- b d ) tuck sq 4 / swap - sqrt ;
+: discriminant ( c b -- b d ) [ nip ] [ sq 4 / swap - sqrt ] 2bi ;
: critical ( b d -- -b/2 d ) [ -2 / ] dip ;
: +- ( x y -- x+y x-y ) [ + ] [ - ] 2bi ;
: quadratic ( c b a -- alpha beta )
- #! Solve a quadratic equation ax^2 + bx + c = 0
monic discriminant critical +- ;
-: qeval ( x c b a -- y )
- #! Evaluate ax^2 + bx + c
- [ pick * ] dip roll sq * + + ;
+:: qeval ( x c b a -- y )
+ c b x * + a x sq * + ;
USING: accessors arrays kernel models models.product monads
-sequences sequences.extras ;
+sequences sequences.extras shuffle ;
FROM: syntax => >> ;
IN: models.combinators
: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
USE: models.combinators.templates
-<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
] keep length
10^ / + swap [ neg ] when ;
-SYNTAX: DECIMAL: scan parse-decimal parsed ;
+SYNTAX: DECIMAL: scan parse-decimal suffix! ;
PRIVATE>
:: verify-nodes ( mdb -- )
- [ [let* | acc [ V{ } clone ]
- node1 [ mdb dup master-node [ check-node ] keep ]
- node2 [ mdb node1 remote>>
- [ [ check-node ] keep ]
- [ drop f ] if* ]
- | node1 [ acc push ] when*
- node2 [ acc push ] when*
- mdb acc nodelist>table >>nodes drop
- ]
+ [
+ V{ } clone :> acc
+ mdb dup master-node [ check-node ] keep :> node1
+ mdb node1 remote>>
+ [ [ check-node ] keep ]
+ [ drop f ] if* :> node2
+
+ node1 [ acc push ] when*
+ node2 [ acc push ] when*
+ mdb acc nodelist>table >>nodes drop
] with-destructors ;
: mdb-open ( mdb -- mdb-connection )
[ dispose f ] change-handle drop ;
M: mdb-connection dispose
- mdb-close ;
\ No newline at end of file
+ mdb-close ;
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
- [let* | instance [ mdb-instance ]
- instance-name [ instance name>> ] |
+ [let
+ mdb-instance :> instance
+ instance name>> :> instance-name
dup mdb-collection? [ name>> ] when
"." split1 over instance-name =
[ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi
[ instance (ensure-collection) ] unless
- [ instance-name ] dip "." glue ] ;
+ [ instance-name ] dip "." glue
+ ] ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline
M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
[ mdb-insert-msg new ] 2dip
[ >>collection ] dip
- V{ } clone tuck push
+ [ V{ } clone ] dip suffix!
>>objects OP_Insert >>opcode ;
! [ dump-to-file ] keep
write flush ; inline
-: build-query-object ( query -- selector )
- [let | selector [ H{ } clone ] |
- { [ orderby>> [ "orderby" selector set-at ] when* ]
- [ explain>> [ "$explain" selector set-at ] when* ]
- [ hint>> [ "$hint" selector set-at ] when* ]
- [ query>> "query" selector set-at ]
- } cleave
- selector
- ] ;
+:: build-query-object ( query -- selector )
+ H{ } clone :> selector
+ query { [ orderby>> [ "orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave
+ selector ;
PRIVATE>
: slot-option? ( tuple slot option -- ? )
[ swap mdb-slot-map at ] dip
- '[ _ swap memq? ] [ f ] if* ;
+ '[ _ swap member-eq? ] [ f ] if* ;
PRIVATE>
CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
-: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
+: write-mdb-persistent ( value quot -- value' )
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
- [ tuple-collection name>> ] [ id>> ] bi <objref> ; inline
+ [ tuple-collection name>> ] [ id>> ] bi <objref> ;
-: write-field ( value quot: ( tuple -- assoc ) -- value' )
+: write-field ( value quot -- value' )
<cond-value> {
{ [ dup value>> mdb-special-value? ] [ value>> ] }
{ [ dup value>> mdb-persistent? ]
{ [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
[ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
[ value>> ]
- } cond ; inline recursive
+ } cond ;
: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
swap ! m t q q a
PRIVATE>
: <tuple-info> ( tuple -- tuple-info )
- class V{ } clone tuck
+ class [ V{ } clone ] dip over
[ [ name>> ] dip push ]
[ [ vocabulary>> ] dip push ] 2bi ; inline
: morse> ( morse -- plain )
replace-underscores morse>sentence ;
-SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> suffix! ;
<PRIVATE
: topological-sort ( seq quot -- newseq )
[ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
+ [ dupd maximal-element [ over remove-nth! drop ] dip ] curry
produce nip ; inline
: classes< ( seq1 seq2 -- lt/eq/gt )
:: (eval-bases) ( curve t interval values order -- values' )
order 2 - curve (knot-constants)>> nth :> all-knot-constants
- interval order interval + all-knot-constants clip-range :> to :> from
+ interval order interval + all-knot-constants clip-range :> ( from to )
from to all-knot-constants subseq :> knot-constants
values { 0.0 } { 0.0 } surround 2 <clumps> :> bases
USING: arrays kernel parser sequences ;
IN: pair-rocket
-SYNTAX: => dup pop scan-object 2array parsed ;
+SYNTAX: => dup pop scan-object 2array suffix! ;
! Copyright (C) 2004 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: lists lists.lazy promises kernel sequences strings math
-arrays splitting quotations combinators namespaces
+arrays splitting quotations combinators namespaces locals
unicode.case unicode.categories sequences.deep accessors ;
IN: parser-combinators
: case-insensitive-token ( string -- parser ) t <token-parser> ;
-M: token-parser parse ( input parser -- list )
- [ string>> ] [ ignore-case?>> ] bi
- [ tuck ] dip ?string-head
+M:: token-parser parse ( input parser -- list )
+ parser string>> :> str
+ parser ignore-case?>> :> case?
+
+ str input str case? ?string-head
[ <parse-results> ] [ 2drop nil ] if ;
: 1token ( n -- parser ) 1string token ;
<& &> ;
: nonempty-list-of ( items separator -- parser )
- [ over &> <*> <&:> ] keep <?> tuck pack ;
+ [ over &> <*> <&:> ] keep <?> [ nip ] 2keep pack ;
: list-of ( items separator -- parser )
#! Given a parser for the separator and for the
: remove-tuples ( tuple -- ) [ delete-tuples ] w/db ;
TUPLE: pattern value ; C: <pattern> pattern
-SYNTAX: %" parse-string <pattern> parsed ;
+SYNTAX: %" parse-string <pattern> suffix! ;
M: pattern where value>> over column-name>> 0% " LIKE " 0% bind# ;
V{ 0 } clone 1 rot (fib-upto) ;
: euler002 ( -- answer )
- 4000000 fib-upto [ even? ] filter sum ;
+ 4,000,000 fib-upto [ even? ] filter sum ;
! [ euler002 ] 100 ave-time
! 0 ms ave run time - 0.22 SD (100 trials)
! -------------------
: fib-upto* ( n -- seq )
- 0 1 [ pick over >= ] [ tuck + dup ] produce [ 3drop ] dip
+ 0 1 [ pick over >= ] [ [ nip ] 2keep + dup ] produce [ 3drop ] dip
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
- 4000000 fib-upto* [ even? ] filter sum ;
+ 4,000,000 fib-upto* [ even? ] filter sum ;
! [ euler002a ] 100 ave-time
! 0 ms ave run time - 0.2 SD (100 trials)
<PRIVATE
: next-fibs ( x y -- y x+y )
- tuck + ;
+ [ nip ] [ + ] 2bi ;
: ?retotal ( total fib- fib+ -- retotal fib- fib+ )
dup even? [ [ nip + ] 2keep ] when ;
! --------
: euler017 ( -- answer )
- 1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
+ 1000 [1,b] SBUF" " clone [ number>text append! ] reduce [ Letter? ] count ;
! [ euler017 ] 100 ave-time
! 15 ms ave run time - 1.71 SD (100 trials)
{ [ = not ] [ sum-proper-divisors = ] } 2&& ;
: euler021 ( -- answer )
- 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
+ 10000 [1,b] [ dup amicable? [ drop 0 ] unless ] map-sum ;
! [ euler021 ] 100 ave-time
! 335 ms ave run time - 18.63 SD (100 trials)
dup 1 = [ [ sq 4 * ] [ 6 * ] bi - 6 + ] unless ;
: sum-diags ( n -- sum )
- 1 swap 2 <range> [ sum-corners ] sigma ;
+ 1 swap 2 <range> [ sum-corners ] map-sum ;
PRIVATE>
<PRIVATE
: sum-fifth-powers ( n -- sum )
- number>digits [ 5 ^ ] sigma ;
+ number>digits [ 5 ^ ] map-sum ;
PRIVATE>
{ 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
: factorion? ( n -- ? )
- dup number>digits [ digit-factorial ] sigma = ;
+ dup number>digits [ digit-factorial ] map-sum = ;
PRIVATE>
pick length 8 > [
2drop 10 digits>integer
] [
- [ * number>digits over push-all ] 2keep 1 + (concat-product)
+ [ * number>digits append! ] 2keep 1 + (concat-product)
] if ;
: concat-product ( n -- m )
: (concat-upto) ( n limit str -- str )
2dup length > [
- pick number>string over push-all rot 1 + -rot (concat-upto)
+ pick number>string append! [ 1 + ] 2dip (concat-upto)
] [
2nip
] if ;
PRIVATE>
: euler043a ( -- answer )
- interesting-pandigitals [ 10 digits>integer ] sigma ;
+ interesting-pandigitals [ 10 digits>integer ] map-sum ;
! [ euler043a ] 100 ave-time
! 10 ms ave run time - 1.37 SD (100 trials)
! --------
: euler048 ( -- answer )
- 1000 [1,b] [ dup ^ ] sigma 10 10^ mod ;
+ 1000 [1,b] [ dup ^ ] map-sum 10 10^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
! --------
: euler053 ( -- answer )
- 23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
+ 23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] map-sum ;
! [ euler053 ] 100 ave-time
! 52 ms ave run time - 4.44 SD (100 trials)
! Round down since we already know that particular value of n is no good.
: euler063 ( -- answer )
- 9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ;
+ 9 [1,b] [ log [ 10 log dup ] dip - /i ] map-sum ;
! [ euler063 ] 100 ave-time
! 0 ms ave run time - 0.0 SD (100 trials)
! The answer can be found by adding totient(n) for 2 ≤ n ≤ 1e6
: euler072 ( -- answer )
- 2 1000000 [a,b] [ totient ] sigma ;
+ 2 1000000 [a,b] [ totient ] map-sum ;
! [ euler072 ] 100 ave-time
! 5274 ms ave run time - 102.7 SD (100 trials)
<PRIVATE
:: (euler073) ( counter limit lo hi -- counter' )
- [let | m [ lo hi mediant ] |
- m denominator limit <= [
- counter 1 +
- limit lo m (euler073)
- limit m hi (euler073)
- ] [ counter ] if
- ] ;
+ lo hi mediant :> m
+ m denominator limit <= [
+ counter 1 +
+ limit lo m (euler073)
+ limit m hi (euler073)
+ ] [ counter ] if ;
PRIVATE>
{ 1 1 2 6 24 120 720 5040 40320 362880 } nth ;
: digits-factorial-sum ( n -- n )
- number>digits [ digit-factorial ] sigma ;
+ number>digits [ digit-factorial ] map-sum ;
: chain-length ( n -- n )
61 <hashtable>
--- /dev/null
+USING: project-euler.089 tools.test ;
+IN: project-euler.089.tests
+
+[ 743 ] [ euler089 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.ascii io.files kernel math
+project-euler.common roman sequences ;
+IN: project-euler.089
+
+! http://projecteuler.net/index.php?section=problems&id=089
+
+! DESCRIPTION
+! -----------
+
+! The rules for writing Roman numerals allow for many ways of writing
+! each number (see FAQ: Roman Numerals). However, there is always a
+! "best" way of writing a particular number.
+
+! For example, the following represent all of the legitimate ways of
+! writing the number sixteen:
+
+! IIIIIIIIIIIIIIII
+! VIIIIIIIIIII
+! VVIIIIII
+! XIIIIII
+! VVVI
+! XVI
+
+! The last example being considered the most efficient, as it uses
+! the least number of numerals.
+
+! The 11K text file, roman.txt (right click and 'Save Link/Target As...'),
+! contains one thousand numbers written in valid, but not necessarily
+! minimal, Roman numerals; that is, they are arranged in descending units
+! and obey the subtractive pair rule (see FAQ for the definitive rules
+! for this problem).
+
+! Find the number of characters saved by writing each of these in their minimal form.
+
+! SOLUTION
+! --------
+
+: euler089 ( -- n )
+ "resource:extra/project-euler/089/roman.txt" ascii file-lines
+ [ ] [ [ roman> >roman ] map ] bi
+ [ [ length ] map-sum ] bi@ - ;
+
+! [ euler089 ] 100 ave-time
+! 14 ms ave run time - 0.27 SD (100 trials)
+
+SOLUTION: euler089
--- /dev/null
+Doug Coleman
--- /dev/null
+MMMMDCLXXII\r
+MMDCCCLXXXIII\r
+MMMDLXVIIII\r
+MMMMDXCV\r
+DCCCLXXII\r
+MMCCCVI\r
+MMMCDLXXXVII\r
+MMMMCCXXI\r
+MMMCCXX\r
+MMMMDCCCLXXIII\r
+MMMCCXXXVII\r
+MMCCCLXXXXIX\r
+MDCCCXXIIII\r
+MMCXCVI\r
+CCXCVIII\r
+MMMCCCXXXII\r
+MDCCXXX\r
+MMMDCCCL\r
+MMMMCCLXXXVI\r
+MMDCCCXCVI\r
+MMMDCII\r
+MMMCCXII\r
+MMMMDCCCCI\r
+MMDCCCXCII\r
+MDCXX\r
+CMLXXXVII\r
+MMMXXI\r
+MMMMCCCXIV\r
+MLXXII\r
+MCCLXXVIIII\r
+MMMMCCXXXXI\r
+MMDCCCLXXII\r
+MMMMXXXI\r
+MMMDCCLXXX\r
+MMDCCCLXXIX\r
+MMMMLXXXV\r
+MCXXI\r
+MDCCCXXXVII\r
+MMCCCLXVII\r
+MCDXXXV\r
+CCXXXIII\r
+CMXX\r
+MMMCLXIV\r
+MCCCLXXXVI\r
+DCCCXCVIII\r
+MMMDCCCCXXXIV\r
+CDXVIIII\r
+MMCCXXXV\r
+MDCCCXXXII\r
+MMMMD\r
+MMDCCLXIX\r
+MMMMCCCLXXXXVI\r
+MMDCCXLII\r
+MMMDCCCVIIII\r
+DCCLXXXIIII\r
+MDCCCCXXXII\r
+MMCXXVII\r
+DCCCXXX\r
+CCLXIX\r
+MMMXI\r
+MMMMCMLXXXXVIII\r
+MMMMDLXXXVII\r
+MMMMDCCCLX\r
+MMCCLIV\r
+CMIX\r
+MMDCCCLXXXIIII\r
+CLXXXII\r
+MMCCCCXXXXV\r
+MMMMDLXXXVIIII\r
+MMMDCCCXXI\r
+MMDCCCCLXXVI\r
+MCCCCLXX\r
+MMCDLVIIII\r
+MMMDCCCLIX\r
+MMMMCCCCXIX\r
+MMMDCCCLXXV\r
+XXXI\r
+CDLXXXIII\r
+MMMCXV\r
+MMDCCLXIII\r
+MMDXXX\r
+MMMMCCCLVII\r
+MMMDCI\r
+MMMMCDLXXXIIII\r
+MMMMCCCXVI\r
+CCCLXXXVIII\r
+MMMMCML\r
+MMMMXXIV\r
+MMMCCCCXXX\r
+DCCX\r
+MMMCCLX\r
+MMDXXXIII\r
+CCCLXIII\r
+MMDCCXIII\r
+MMMCCCXLIV\r
+CLXXXXI\r
+CXVI\r
+MMMMCXXXIII\r
+CLXX\r
+DCCCXVIII\r
+MLXVII\r
+DLXXXX\r
+MMDXXI\r
+MMMMDLXXXXVIII\r
+MXXII\r
+LXI\r
+DCCCCXLIII\r
+MMMMDV\r
+MMMMXXXIV\r
+MDCCCLVIII\r
+MMMCCLXXII\r
+MMMMDCCXXXVI\r
+MMMMLXXXIX\r
+MDCCCLXXXI\r
+MMMMDCCCXV\r
+MMMMCCCCXI\r
+MMMMCCCLIII\r
+MDCCCLXXI\r
+MMCCCCXI\r
+MLXV\r
+MMCDLXII\r
+MMMMDXXXXII\r
+MMMMDCCCXL\r
+MMMMCMLVI\r
+CCLXXXIV\r
+MMMDCCLXXXVI\r
+MMCLII\r
+MMMCCCCXV\r
+MMLXXXIII\r
+MMMV\r
+MMMV\r
+DCCLXII\r
+MMDCCCCXVI\r
+MMDCXLVIII\r
+CCLIIII\r
+CCCXXV\r
+MMDCCLXXXVIIII\r
+MMMMDCLXXVIII\r
+MMMMDCCCXCI\r
+MMMMCCCXX\r
+MMCCXLV\r
+MMMDCCCLXIX\r
+MMCCLXIIII\r
+MMMDCCCXLIX\r
+MMMMCCCLXIX\r
+CMLXXXXI\r
+MCMLXXXIX\r
+MMCDLXI\r
+MMDCLXXVIII\r
+MMMMDCCLXI\r
+MCDXXV\r
+DL\r
+CCCLXXII\r
+MXVIIII\r
+MCCCCLXVIII\r
+CIII\r
+MMMDCCLXXIIII\r
+MMMDVIII\r
+MMMMCCCLXXXXVII\r
+MMDXXVII\r
+MMDCCLXXXXV\r
+MMMMCXLVI\r
+MMMDCCLXXXII\r
+MMMDXXXVI\r
+MCXXII\r
+CLI\r
+DCLXXXIX\r
+MMMCLI\r
+MDCLXIII\r
+MMMMDCCXCVII\r
+MMCCCLXXXV\r
+MMMDCXXVIII\r
+MMMCDLX\r
+MMMCMLII\r
+MMMIV\r
+MMMMDCCCLVIII\r
+MMMDLXXXVIII\r
+MCXXIV\r
+MMMMLXXVI\r
+CLXXIX\r
+MMMCCCCXXVIIII\r
+DCCLXXXV\r
+MMMDCCCVI\r
+LI\r
+CLXXXVI\r
+MMMMCCCLXXVI\r
+MCCCLXVI\r
+CCXXXIX\r
+MMDXXXXI\r
+MMDCCCXLI\r
+DCCCLXXXVIII\r
+MMMMDCCCIV\r
+MDCCCCXV\r
+MMCMVI\r
+MMMMCMLXXXXV\r
+MMDCCLVI\r
+MMMMCCXLVIII\r
+DCCCCIIII\r
+MMCCCCIII\r
+MMMDCCLXXXVIIII\r
+MDCCCLXXXXV\r
+DVII\r
+MMMV\r
+DCXXV\r
+MMDCCCXCV\r
+DCVIII\r
+MMCDLXVI\r
+MCXXVIII\r
+MDCCXCVIII\r
+MMDCLX\r
+MMMDCCLXIV\r
+MMCDLXXVII\r
+MMDLXXXIIII\r
+MMMMCCCXXII\r
+MMMDCCCXLIIII\r
+DCCCCLXVII\r
+MMMCLXXXXIII\r
+MCCXV\r
+MMMMDCXI\r
+MMMMDCLXXXXV\r
+MMMCCCLII\r
+MMCMIX\r
+MMDCCXXV\r
+MMDLXXXVI\r
+MMMMDCXXVIIII\r
+DCCCCXXXVIIII\r
+MMCCXXXIIII\r
+MMDCCLXXVIII\r
+MDCCLXVIIII\r
+MMCCLXXXV\r
+MMMMDCCCLXXXVIII\r
+MMCMXCI\r
+MDXLII\r
+MMMMDCCXIV\r
+MMMMLI\r
+DXXXXIII\r
+MMDCCXI\r
+MMMMCCLXXXIII\r
+MMMDCCCLXXIII\r
+MDCLVII\r
+MMCD\r
+MCCCXXVII\r
+MMMMDCCIIII\r
+MMMDCCXLVI\r
+MMMCLXXXVII\r
+MMMCCVIIII\r
+MCCCCLXXIX\r
+DL\r
+DCCCLXXVI\r
+MMDXCI\r
+MMMMDCCCCXXXVI\r
+MMCII\r
+MMMDCCCXXXXV\r
+MMMCDXLV\r
+MMDCXXXXIV\r
+MMD\r
+MDCCCLXXXX\r
+MMDCXLIII\r
+MMCCXXXII\r
+MMDCXXXXVIIII\r
+DCCCLXXI\r
+MDXCVIIII\r
+MMMMCCLXXVIII\r
+MDCLVIIII\r
+MMMCCCLXXXIX\r
+MDCLXXXV\r
+MDLVIII\r
+MMMMCCVII\r
+MMMMDCXIV\r
+MMMCCCLXIIII\r
+MMIIII\r
+MMMMCCCLXXIII\r
+CCIII\r
+MMMCCLV\r
+MMMDXIII\r
+MMMCCCXC\r
+MMMDCCCXXI\r
+MMMMCCCCXXXII\r
+CCCLVI\r
+MMMCCCLXXXVI\r
+MXVIIII\r
+MMMCCCCXIIII\r
+CLXVII\r
+MMMCCLXX\r
+CCCCLXIV\r
+MMXXXXII\r
+MMMMCCLXXXX\r
+MXL\r
+CCXVI\r
+CCCCLVIIII\r
+MMCCCII\r
+MCCCLVIII\r
+MMMMCCCX\r
+MCDLXXXXIV\r
+MDCCCXIII\r
+MMDCCCXL\r
+MMMMCCCXXIII\r
+DXXXIV\r
+CVI\r
+MMMMDCLXXX\r
+DCCCVII\r
+MMCMLXIIII\r
+MMMDCCCXXXIII\r
+DCCC\r
+MDIII\r
+MMCCCLXVI\r
+MMMCCCCLXXI\r
+MMDCCCCXVIII\r
+CCXXXVII\r
+CCCXXV\r
+MDCCCXII\r
+MMMCMV\r
+MMMMCMXV\r
+MMMMDCXCI\r
+DXXI\r
+MMCCXLVIIII\r
+MMMMCMLII\r
+MDLXXX\r
+MMDCLXVI\r
+CXXI\r
+MMMDCCCLIIII\r
+MMMCXXI\r
+MCCIII\r
+MMDCXXXXI\r
+CCXCII\r
+MMMMDXXXV\r
+MMMCCCLXV\r
+MMMMDLXV\r
+MMMCCCCXXXII\r
+MMMCCCVIII\r
+DCCCCLXXXXII\r
+MMCLXIV\r
+MMMMCXI\r
+MLXXXXVII\r
+MMMCDXXXVIII\r
+MDXXII\r
+MLV\r
+MMMMDLXVI\r
+MMMCXII\r
+XXXIII\r
+MMMMDCCCXXVI\r
+MMMLXVIIII\r
+MMMLX\r
+MMMCDLXVII\r
+MDCCCLVII\r
+MMCXXXVII\r
+MDCCCCXXX\r
+MMDCCCLXIII\r
+MMMMDCXLIX\r
+MMMMCMXLVIII\r
+DCCCLXXVIIII\r
+MDCCCLIII\r
+MMMCMLXI\r
+MMMMCCLXI\r
+MMDCCCLIII\r
+MMMDCCCVI\r
+MMDXXXXIX\r
+MMCLXXXXV\r
+MMDXXX\r
+MMMXIII\r
+DCLXXIX\r
+DCCLXII\r
+MMMMDCCLXVIII\r
+MDCCXXXXIII\r
+CCXXXII\r
+MMMMDCXXV\r
+MMMCCCXXVIII\r
+MDCVIII\r
+MMMCLXXXXIIII\r
+CLXXXI\r
+MDCCCCXXXIII\r
+MMMMDCXXX\r
+MMMDCXXIV\r
+MMMCCXXXVII\r
+MCCCXXXXIIII\r
+CXVIII\r
+MMDCCCCIV\r
+MMMMCDLXXV\r
+MMMDLXIV\r
+MDXCIII\r
+MCCLXXXI\r
+MMMDCCCXXIV\r
+MCXLIII\r
+MMMDCCCI\r
+MCCLXXX\r
+CCXV\r
+MMDCCLXXI\r
+MMDLXXXIII\r
+MMMMDCXVII\r
+MMMCMLXV\r
+MCLXVIII\r
+MMMMCCLXXVI\r
+MMMDCCLXVIIII\r
+MMMMDCCCIX\r
+DLXXXXIX\r
+DCCCXXII\r
+MMMMIII\r
+MMMMCCCLXXVI\r
+DCCCXCIII\r
+DXXXI\r
+MXXXIIII\r
+CCXII\r
+MMMDCCLXXXIIII\r
+MMMCXX\r
+MMMCMXXVII\r
+DCCCXXXX\r
+MMCDXXXVIIII\r
+MMMMDCCXVIII\r
+LV\r
+MMMDCCCCVI\r
+MCCCII\r
+MMCMLXVIIII\r
+MDCCXI\r
+MMMMDLXVII\r
+MMCCCCLXI\r
+MMDCCV\r
+MMMCCCXXXIIII\r
+MMMMDI\r
+MMMDCCCXCV\r
+MMDCCLXXXXI\r
+MMMDXXVI\r
+MMMDCCCLVI\r
+MMDCXXX\r
+MCCCVII\r
+MMMMCCCLXII\r
+MMMMXXV\r
+MMCMXXV\r
+MMLVI\r
+MMDXXX\r
+MMMMCVII\r
+MDC\r
+MCCIII\r
+MMMMDCC\r
+MMCCLXXV\r
+MMDCCCXXXXVI\r
+MMMMCCCLXV\r
+CDXIIII\r
+MLXIIII\r
+CCV\r
+MMMCMXXXI\r
+CCCCLXVI\r
+MDXXXII\r
+MMMMCCCLVIII\r
+MMV\r
+MMMCLII\r
+MCMLI\r
+MMDCCXX\r
+MMMMCCCCXXXVI\r
+MCCLXXXI\r
+MMMCMVI\r
+DCCXXX\r
+MMMMCCCLXV\r
+DCCCXI\r
+MMMMDCCCXIV\r
+CCCXXI\r
+MMDLXXV\r
+CCCCLXXXX\r
+MCCCLXXXXII\r
+MMDCIX\r
+DCCXLIIII\r
+DXIV\r
+MMMMCLII\r
+CDLXI\r
+MMMCXXVII\r
+MMMMDCCCCLXIII\r
+MMMDCLIIII\r
+MCCCCXXXXII\r
+MMCCCLX\r
+CCCCLIII\r
+MDCCLXXVI\r
+MCMXXIII\r
+MMMMDLXXVIII\r
+MMDCCCCLX\r
+MMMCCCLXXXX\r
+MMMCDXXVI\r
+MMMDLVIII\r
+CCCLXI\r
+MMMMDCXXII\r
+MMDCCCXXI\r
+MMDCCXIII\r
+MMMMCLXXXVI\r
+MDCCCCXXVI\r
+MDV\r
+MMDCCCCLXXVI\r
+MMMMCCXXXVII\r
+MMMDCCLXXVIIII\r
+MMMCCCCLXVII\r
+DCCXLI\r
+MMCLXXXVIII\r
+MCCXXXVI\r
+MMDCXLVIII\r
+MMMMCXXXII\r
+MMMMDCCLXVI\r
+MMMMCMLI\r
+MMMMCLXV\r
+MMMMDCCCXCIV\r
+MCCLXXVII\r
+LXXVIIII\r
+DCCLII\r
+MMMCCCXCVI\r
+MMMCLV\r
+MMDCCCXXXXVIII\r
+DCCCXV\r
+MXC\r
+MMDCCLXXXXVII\r
+MMMMCML\r
+MMDCCCLXXVIII\r
+DXXI\r
+MCCCXLI\r
+DCLXXXXI\r
+MMCCCLXXXXVIII\r
+MDCCCCLXXVIII\r
+MMMMDXXV\r
+MMMDCXXXVI\r
+MMMCMXCVII\r
+MMXVIIII\r
+MMMDCCLXXIV\r
+MMMCXXV\r
+DXXXVIII\r
+MMMMCLXVI\r
+MDXII\r
+MMCCCLXX\r
+CCLXXI\r
+DXIV\r
+MMMCLIII\r
+DLII\r
+MMMCCCXLIX\r
+MMCCCCXXVI\r
+MMDCXLIII\r
+MXXXXII\r
+CCCLXXXV\r
+MDCLXXVI\r
+MDCXII\r
+MMMCCCLXXXIII\r
+MMDCCCCLXXXII\r
+MMMMCCCLXXXV\r
+MMDCXXI\r
+DCCCXXX\r
+MMMDCCCCLII\r
+MMMDCCXXII\r
+MMMMCDXCVIII\r
+MMMCCLXVIIII\r
+MMXXV\r
+MMMMCDXIX\r
+MMMMCCCX\r
+MMMCCCCLXVI\r
+MMMMDCLXXVIIII\r
+MMMMDCXXXXIV\r
+MMMCMXII\r
+MMMMXXXIII\r
+MMMMDLXXXII\r
+DCCCLIV\r
+MDXVIIII\r
+MMMCLXXXXV\r
+CCCCXX\r
+MMDIX\r
+MMCMLXXXVIII\r
+DCCXLIII\r
+DCCLX\r
+D\r
+MCCCVII\r
+MMMMCCCLXXXIII\r
+MDCCCLXXIIII\r
+MMMDCCCCLXXXVII\r
+MMMMCCCVII\r
+MMMDCCLXXXXVI\r
+CDXXXIV\r
+MCCLXVIII\r
+MMMMDLX\r
+MMMMDXII\r
+MMMMCCCCLIIII\r
+MCMLXXXXIII\r
+MMMMDCCCIII\r
+MMDCLXXXIII\r
+MDCCCXXXXIV\r
+XXXXVII\r
+MMMDCCCXXXII\r
+MMMDCCCXLII\r
+MCXXXV\r
+MDCXXVIIII\r
+MMMCXXXXIIII\r
+MMMMCDXVII\r
+MMMDXXIII\r
+MMMMCCCCLXI\r
+DCLXXXXVIIII\r
+LXXXXI\r
+CXXXIII\r
+MCDX\r
+MCCLVII\r
+MDCXXXXII\r
+MMMCXXIV\r
+MMMMLXXXX\r
+MMDCCCCXLV\r
+MLXXX\r
+MMDCCCCLX\r
+MCDLIII\r
+MMMCCCLXVII\r
+MMMMCCCLXXIV\r
+MMMDCVIII\r
+DCCCCXXIII\r
+MMXCI\r
+MMDCCIV\r
+MMMMDCCCXXXIV\r
+CCCLXXI\r
+MCCLXXXII\r
+MCMIII\r
+CCXXXI\r
+DCCXXXVIII\r
+MMMMDCCXLVIIII\r
+MMMMCMXXXV\r
+DCCCLXXV\r
+DCCXCI\r
+MMMMDVII\r
+MMMMDCCCLXVIIII\r
+CCCXCV\r
+MMMMDCCXX\r
+MCCCCII\r
+MMMCCCXC\r
+MMMCCCII\r
+MMDCCLXXVII\r
+MMDCLIIII\r
+CCXLIII\r
+MMMDCXVIII\r
+MMMCCCIX\r
+MCXV\r
+MMCCXXV\r
+MLXXIIII\r
+MDCCXXVI\r
+MMMCCCXX\r
+MMDLXX\r
+MMCCCCVI\r
+MMDCCXX\r
+MMMMDCCCCXCV\r
+MDCCCXXXII\r
+MMMMDCCCCXXXX\r
+XCIV\r
+MMCCCCLX\r
+MMXVII\r
+MLXXI\r
+MMMDXXVIII\r
+MDCCCCII\r
+MMMCMLVII\r
+MMCLXXXXVIII\r
+MDCCCCLV\r
+MCCCCLXXIIII\r
+MCCCLII\r
+MCDXLVI\r
+MMMMDXVIII\r
+DCCLXXXIX\r
+MMMDCCLXIV\r
+MDCCCCXLIII\r
+CLXXXXV\r
+MMMMCCXXXVI\r
+MMMDCCCXXI\r
+MMMMCDLXXVII\r
+MCDLIII\r
+MMCCXLVI\r
+DCCCLV\r
+MCDLXX\r
+DCLXXVIII\r
+MMDCXXXIX\r
+MMMMDCLX\r
+MMDCCLI\r
+MMCXXXV\r
+MMMCCXII\r
+MMMMCMLXII\r
+MMMMCCV\r
+MCCCCLXIX\r
+MMMMCCIII\r
+CLXVII\r
+MCCCLXXXXIIII\r
+MMMMDCVIII\r
+MMDCCCLXI\r
+MMLXXIX\r
+CMLXIX\r
+MMDCCCXLVIIII\r
+DCLXII\r
+MMMCCCXLVII\r
+MDCCCXXXV\r
+MMMMDCCXCVI\r
+DCXXX\r
+XXVI\r
+MMLXIX\r
+MMCXI\r
+DCXXXVII\r
+MMMMCCCXXXXVIII\r
+MMMMDCLXI\r
+MMMMDCLXXIIII\r
+MMMMVIII\r
+MMMMDCCCLXII\r
+MDCXCI\r
+MMCCCXXIIII\r
+CCCCXXXXV\r
+MMDCCCXXI\r
+MCVI\r
+MMDCCLXVIII\r
+MMMMCXL\r
+MLXVIII\r
+CMXXVII\r
+CCCLV\r
+MDCCLXXXIX\r
+MMMCCCCLXV\r
+MMDCCLXII\r
+MDLXVI\r
+MMMCCCXVIII\r
+MMMMCCLXXXI\r
+MMCXXVII\r
+MMDCCCLXVIII\r
+MMMCXCII\r
+MMMMDCLVIII\r
+MMMMDCCCXXXXII\r
+MMDCCCCLXXXXVI\r
+MDCCXL\r
+MDCCLVII\r
+MMMMDCCCLXXXVI\r
+DCCXXXIII\r
+MMMMDCCCCLXXXV\r
+MMCCXXXXVIII\r
+MMMCCLXXVIII\r
+MMMDCLXXVIII\r
+DCCCI\r
+MMMMLXXXXVIIII\r
+MMMCCCCLXXII\r
+MMCLXXXVII\r
+CCLXVI\r
+MCDXLIII\r
+MMCXXVIII\r
+MDXIV\r
+CCCXCVIII\r
+CLXXVIII\r
+MMCXXXXVIIII\r
+MMMDCLXXXIV\r
+CMLVIII\r
+MCDLIX\r
+MMMMDCCCXXXII\r
+MMMMDCXXXIIII\r
+MDCXXI\r
+MMMDCXLV\r
+MCLXXVIII\r
+MCDXXII\r
+IV\r
+MCDLXXXXIII\r
+MMMMDCCLXV\r
+CCLI\r
+MMMMDCCCXXXVIII\r
+DCLXII\r
+MCCCLXVII\r
+MMMMDCCCXXXVI\r
+MMDCCXLI\r
+MLXI\r
+MMMCDLXVIII\r
+MCCCCXCIII\r
+XXXIII\r
+MMMDCLXIII\r
+MMMMDCL\r
+DCCCXXXXIIII\r
+MMDLVII\r
+DXXXVII\r
+MCCCCXXIIII\r
+MCVII\r
+MMMMDCCXL\r
+MMMMCXXXXIIII\r
+MCCCCXXIV\r
+MMCLXVIII\r
+MMXCIII\r
+MDCCLXXX\r
+MCCCLIIII\r
+MMDCLXXI\r
+MXI\r
+MCMLIV\r
+MMMCCIIII\r
+DCCLXXXVIIII\r
+MDCLIV\r
+MMMDCXIX\r
+CMLXXXI\r
+DCCLXXXVII\r
+XXV\r
+MMMXXXVI\r
+MDVIIII\r
+CLXIII\r
+MMMCDLVIIII\r
+MMCCCCVII\r
+MMMLXX\r
+MXXXXII\r
+MMMMCCCLXVIII\r
+MMDCCCXXVIII\r
+MMMMDCXXXXI\r
+MMMMDCCCXXXXV\r
+MMMXV\r
+MMMMCCXVIIII\r
+MMDCCXIIII\r
+MMMXXVII\r
+MDCCLVIIII\r
+MMCXXIIII\r
+MCCCLXXIV\r
+DCLVIII\r
+MMMLVII\r
+MMMCXLV\r
+MMXCVII\r
+MMMCCCLXXXVII\r
+MMMMCCXXII\r
+DXII\r
+MMMDLV\r
+MCCCLXXVIII\r
+MMMCLIIII\r
+MMMMCLXXXX\r
+MMMCLXXXIIII\r
+MDCXXIII\r
+MMMMCCXVI\r
+MMMMDLXXXIII\r
+MMMDXXXXIII\r
+MMMMCCCCLV\r
+MMMDLXXXI\r
+MMMCCLXXVI\r
+MMMMXX\r
+MMMMDLVI\r
+MCCCCLXXX\r
+MMMXXII\r
+MMXXII\r
+MMDCCCCXXXI\r
+MMMDXXV\r
+MMMDCLXXXVIIII\r
+MMMDLXXXXVII\r
+MDLXIIII\r
+CMXC\r
+MMMXXXVIII\r
+MDLXXXVIII\r
+MCCCLXXVI\r
+MMCDLIX\r
+MMDCCCXVIII\r
+MDCCCXXXXVI\r
+MMMMCMIV\r
+MMMMDCIIII\r
+MMCCXXXV\r
+XXXXVI\r
+MMMMCCXVII\r
+MMCCXXIV\r
+MCMLVIIII\r
+MLXXXIX\r
+MMMMLXXXIX\r
+CLXXXXIX\r
+MMMDCCCCLVIII\r
+MMMMCCLXXIII\r
+MCCCC\r
+DCCCLIX\r
+MMMCCCLXXXII\r
+MMMCCLXVIIII\r
+MCLXXXV\r
+CDLXXXVII\r
+DCVI\r
+MMX\r
+MMCCXIII\r
+MMMMDCXX\r
+MMMMXXVIII\r
+DCCCLXII\r
+MMMMCCCXLIII\r
+MMMMCLXV\r
+DXCI\r
+MMMMCLXXX\r
+MMMDCCXXXXI\r
+MMMMXXXXVI\r
+DCLX\r
+MMMCCCXI\r
+MCCLXXX\r
+MMCDLXXII\r
+DCCLXXI\r
+MMMCCCXXXVI\r
+MCCCCLXXXVIIII\r
+CDLVIII\r
+DCCLVI\r
+MMMMDCXXXVIII\r
+MMCCCLXXXIII\r
+MMMMDCCLXXV\r
+MMMXXXVI\r
+CCCLXXXXIX\r
+CV\r
+CCCCXIII\r
+CCCCXVI\r
+MDCCCLXXXIIII\r
+MMDCCLXXXII\r
+MMMMCCCCLXXXI\r
+MXXV\r
+MMCCCLXXVIIII\r
+MMMCCXII\r
+MMMMCCXXXIII\r
+MMCCCLXXXVI\r
+MMMDCCCLVIIII\r
+MCCXXXVII\r
+MDCLXXV\r
+XXXV\r
+MMDLI\r
+MMMCCXXX\r
+MMMMCXXXXV\r
+CCCCLIX\r
+MMMMDCCCLXXIII\r
+MMCCCXVII\r
+DCCCXVI\r
+MMMCCCXXXXV\r
+MDCCCCXCV\r
+CLXXXI\r
+MMMMDCCLXX\r
+MMMDCCCIII\r
+MMCLXXVII\r
+MMMDCCXXIX\r
+MMDCCCXCIIII\r
+MMMCDXXIIII\r
+MMMMXXVIII\r
+MMMMDCCCCLXVIII\r
+MDCCCXX\r
+MMMMCDXXI\r
+MMMMDLXXXIX\r
+CCXVI\r
+MDVIII\r
+MMCCLXXI\r
+MMMDCCCLXXI\r
+MMMCCCLXXVI\r
+MMCCLXI\r
+MMMMDCCCXXXIV\r
+DLXXXVI\r
+MMMMDXXXII\r
+MMMXXIIII\r
+MMMMCDIV\r
+MMMMCCCXLVIII\r
+MMMMCXXXVIII\r
+MMMCCCLXVI\r
+MDCCXVIII\r
+MMCXX\r
+CCCLIX\r
+MMMMDCCLXXII\r
+MDCCCLXXV\r
+MMMMDCCCXXIV\r
+DCCCXXXXVIII\r
+MMMDCCCCXXXVIIII\r
+MMMMCCXXXV\r
+MDCLXXXIII\r
+MMCCLXXXIV\r
+MCLXXXXIIII\r
+DXXXXIII\r
+MCCCXXXXVIII\r
+MMCLXXIX\r
+MMMMCCLXIV\r
+MXXII\r
+MMMCXIX\r
+MDCXXXVII\r
+MMDCCVI\r
+MCLXXXXVIII\r
+MMMCXVI\r
+MCCCLX\r
+MMMCDX\r
+CCLXVIIII\r
+MMMCCLX\r
+MCXXVIII\r
+LXXXII\r
+MCCCCLXXXI\r
+MMMI\r
+MMMCCCLXIV\r
+MMMCCCXXVIIII\r
+CXXXVIII\r
+MMCCCXX\r
+MMMCCXXVIIII\r
+MCCLXVI\r
+MMMCCCCXXXXVI\r
+MMDCCXCIX\r
+MCMLXXI\r
+MMCCLXVIII\r
+CDLXXXXIII\r
+MMMMDCCXXII\r
+MMMMDCCLXXXVII\r
+MMMDCCLIV\r
+MMCCLXIII\r
+MDXXXVII\r
+DCCXXXIIII\r
+MCII\r
+MMMDCCCLXXI\r
+MMMLXXIII\r
+MDCCCLIII\r
+MMXXXVIII\r
+MDCCXVIIII\r
+MDCCCCXXXVII\r
+MMCCCXVI\r
+MCMXXII\r
+MMMCCCLVIII\r
+MMMMDCCCXX\r
+MCXXIII\r
+MMMDLXI\r
+MMMMDXXII\r
+MDCCCX\r
+MMDXCVIIII\r
+MMMDCCCCVIII\r
+MMMMDCCCCXXXXVI\r
+MMDCCCXXXV\r
+MMCXCIV\r
+MCMLXXXXIII\r
+MMMCCCLXXVI\r
+MMMMDCLXXXV\r
+CMLXIX\r
+DCXCII\r
+MMXXVIII\r
+MMMMCCCXXX\r
+XXXXVIIII
\ No newline at end of file
<PRIVATE
: next-link ( n -- m )
- number>digits [ sq ] sigma ;
+ number>digits [ sq ] map-sum ;
: chain-ending ( n -- m )
dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;
! http://projecteuler.net/index.php?section=problems&id=100
-! DESCRIPTION
-! -----------
+! DESCRIPTION ! -----------
! If a box contains twenty-one coloured discs, composed of fifteen blue discs
-! and six red discs, and two discs were taken at random, it can be seen that
-! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2.
+! and six red discs, and two discs were taken at random, it can be seen that
+! the probability of taking two blue discs, P(BB) = (15/21)*(14/20) = 1/2.
! The next such arrangement, for which there is exactly 50% chance of taking
-! two blue discs at random, is a box containing eighty-five blue discs and
-! thirty-five red discs.
+! two blue discs at random, is a box containing eighty-five blue discs and
+! thirty-five red discs.
! By finding the first arrangement to contain over 10^12 = 1,000,000,000,000
-! discs in total, determine the number of blue discs that the box would contain.
+! discs in total, determine the number of blue discs that the box would contain.
! SOLUTION
: euler100 ( -- answer )
1 1
[ dup dup 1 - * 2 * 10 24 ^ <= ]
- [ tuck 6 * swap - 2 - ] while nip ;
+ [ [ 6 * swap - 2 - ] keep swap ] while nip ;
! TODO: solution needs generalization
V{ 1 } clone [ [ next ] 2curry times ] keep last 1 - ;
: (euler116) ( length -- permutations )
- 3 [1,b] [ ways ] with sigma ;
+ 3 [1,b] [ ways ] with map-sum ;
PRIVATE>
[ 4 short tail* sum ] keep push ;
: (euler117) ( n -- m )
- V{ 1 } clone tuck [ next ] curry times last ;
+ [ V{ 1 } clone ] dip over [ next ] curry times last ;
PRIVATE>
0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
- [let | table [ sums-triangle ] |
- m [| x |
- x 1 + [| y |
- m x - [0,b) [| z |
- x z + table nth-unsafe
- [ y z + 1 + swap nth-unsafe ]
- [ y swap nth-unsafe ] bi -
- ] map partial-sum-infimum
- ] map-infimum
+ sums-triangle :> table
+ m [| x |
+ x 1 + [| y |
+ m x - [0,b) [| z |
+ x z + table nth-unsafe
+ [ y z + 1 + swap nth-unsafe ]
+ [ y swap nth-unsafe ] bi -
+ ] map partial-sum-infimum
] map-infimum
- ] ;
+ ] map-infimum ;
HINTS: (euler150) fixnum ;
m [1,b] [| i | 2 i * m 1 + / i ^ ] PI ;
: euler190 ( -- answer )
- 2 15 [a,b] [ P_m truncate ] sigma ;
+ 2 15 [a,b] [ P_m truncate ] map-sum ;
! [ euler150 ] 100 ave-time
! 5 ms ave run time - 1.01 SD (100 trials)
$nl
"A nicer word for interactive use is " { $link ave-time } "." } ;
-HELP: nth-place
-{ $values { "x" float } { "n" integer } { "y" float } }
-{ $description "Rounds a floating point number to " { $snippet "n" } " decimal places." }
-{ $examples
- "This word is useful for display purposes when showing 15 decimal places is not desired:"
- { $unchecked-example "3.141592653589793 3 nth-place number>string" "\"3.142\"" }
-} ;
-
HELP: ave-time
{ $values { "quot" quotation } { "n" integer } }
{ $description "Runs a quotation " { $snippet "n" } " times, then prints the average run time and standard deviation." }
--- /dev/null
+IN: project-euler.ave-time.tests
+USING: tools.test math arrays project-euler.ave-time ;
+
+{ 0 3 } [ 1 2 [ + ] 10 collect-benchmarks ] must-infer-as
+[ 1 2 t ] [ 1 2 [ + ] 10 collect-benchmarks array? ] unit-test
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations fry io kernel make math math.functions
-math.parser math.statistics memory tools.time ;
+USING: combinators.smart formatting fry io kernel macros math
+math.functions math.statistics memory sequences tools.time ;
IN: project-euler.ave-time
-: nth-place ( x n -- y )
- 10^ [ * round >integer ] keep /f ;
-
-: collect-benchmarks ( quot n -- seq )
- [
- [ datastack ]
- [
- '[ _ gc benchmark 1000 / , ] tuck
- '[ _ _ with-datastack drop ]
- ]
- [ 1 - ] tri* swap times call
- ] { } make ; inline
+MACRO: collect-benchmarks ( quot n -- seq )
+ swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 1000 / ] replicate ] ;
: ave-time ( quot n -- )
- [ collect-benchmarks ] keep swap
- [ std 2 nth-place ] [ mean round >integer ] bi [
- # " ms ave run time - " % # " SD (" % # " trials)" %
- ] "" make print flush ; inline
+ [
+ collect-benchmarks
+ [ mean round >integer ]
+ [ std ] bi
+ ] keep
+ "%d ms ave run time - %.2f SD (%d trials)\n" printf flush ; inline
PRIVATE>
: alpha-value ( str -- n )
- >lower [ CHAR: a - 1 + ] sigma ;
+ >lower [ CHAR: a - 1 + ] map-sum ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
[ [ 2array ] with map ] curry map concat ;
! (c) 2009 Joe Groff, see BSD license
-USING: assocs kernel math.rectangles combinators accessors
+USING: assocs kernel math.rectangles combinators accessors locals
math.vectors vectors sequences math combinators.short-circuit arrays fry ;
IN: quadtrees
: insert ( value point tree -- )
dup leaf?>> [ leaf-insert ] [ node-insert ] if ;
-: leaf-at-point ( point leaf -- value/f ? )
- tuck point>> = [ value>> t ] [ drop f f ] if ;
+:: leaf-at-point ( point leaf -- value/f ? )
+ point leaf point>> =
+ [ leaf value>> t ] [ f f ] if ;
: node-at-point ( point node -- value/f ? )
descend at-point ;
: node-in-rect* ( values rect node -- values )
[ (node-in-rect*) ] with each-quadrant ;
-: leaf-in-rect* ( values rect leaf -- values )
- tuck { [ nip point>> ] [ point>> swap contains-point? ] } 2&&
- [ value>> over push ] [ drop ] if ;
+:: leaf-in-rect* ( values rect leaf -- values )
+ { [ leaf point>> ] [ leaf point>> rect contains-point? ] } 0&&
+ [ values leaf value>> suffix! ] [ values ] if ;
: in-rect* ( values rect tree -- values )
dup leaf?>> [ leaf-in-rect* ] [ node-in-rect* ] if ;
-: leaf-erase ( point leaf -- )
- tuck point>> = [ f >>point f >>value ] when drop ;
+:: leaf-erase ( point leaf -- )
+ point leaf point>> = [ leaf f >>point f >>value drop ] when ;
: node-erase ( point node -- )
descend erase ;
! (c)2009 Joe Groff bsd license
-USING: lexer parser ;
+USING: lexer sequences parser ;
IN: qw
-SYNTAX: qw{ "}" parse-tokens parsed ;
+SYNTAX: qw{ "}" parse-tokens suffix! ;
[ 3716213681 ]
[
- 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
+ T{ blum-blum-shub f 200352954495 846054538649 } clone 100 over [
random-32* drop
] curry times
random-32*
t 0.5 * t!
] times
s
- ] change-each
+ ] map! drop
lagged-fibonacci p-r >>pt0
q-r >>pt1 ; inline
: badness ( word -- n )\r
H{\r
{ -nrot 5 }\r
- { -roll 4 }\r
{ -rot 3 }\r
{ bi@ 1 }\r
{ 2curry 1 }\r
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
- { ntuck 6 }\r
{ nwith 4 }\r
{ over 2 }\r
{ pick 4 }\r
- { roll 4 }\r
{ rot 3 }\r
- { spin 3 }\r
{ swap 1 }\r
{ swapd 3 }\r
- { tuck 2 }\r
{ with 1/2 }\r
\r
{ bi 1/2 }\r
\r
M: let noise body>> noise ;\r
\r
-M: wlet noise body>> noise ;\r
-\r
M: lambda noise body>> noise ;\r
\r
M: object noise drop { 0 0 } ;\r
USING: kernel math sequences strings io combinators ascii ;
IN: rot13
-: rotate ( ch base -- ch ) tuck - 13 + 26 mod + ;
+: rotate ( ch base -- ch ) [ - 13 + 26 mod ] [ + ] bi ;
: rot-letter ( ch -- ch )
{
+++ /dev/null
-USING: tools.test sequence-parser unicode.categories kernel
-accessors ;
-IN: sequence-parser.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] parse-sequence ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ "foo " "and bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ]
- [ "and" take-sequence drop ]
- [ take-rest ] tri
- ] parse-sequence
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence* ]
- [ take-rest ] bi
- ] parse-sequence
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ f "aaaa" ]
-[
- "aaaa" <sequence-parser>
- [ "b" take-until-sequence ] [ take-rest ] bi
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] parse-sequence
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
-
-[ "ab" ]
-[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
- "abcd" <sequence-parser>
- [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <sequence-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[ "" <sequence-parser> take-rest ] unit-test
-
-[ f ]
-[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
-
-[ "1234" ]
-[ "1234f" <sequence-parser> take-integer ] unit-test
-
-[ "yes" ]
-[
- "yes1234f" <sequence-parser>
- [ take-integer drop ] [ "yes" take-sequence ] bi
-] unit-test
-
-[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
-[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
-[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
-
-[ f ]
-[ "\n" <sequence-parser> take-integer ] unit-test
-
-[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
-[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors circular combinators.short-circuit fry io
-kernel locals math math.order sequences sorting.functor
-sorting.slots unicode.categories ;
-IN: sequence-parser
-
-TUPLE: sequence-parser sequence n ;
-
-: <sequence-parser> ( sequence -- sequence-parser )
- sequence-parser new
- swap >>sequence
- 0 >>n ;
-
-:: with-sequence-parser ( sequence-parser quot -- seq/f )
- sequence-parser n>> :> n
- sequence-parser quot call [
- n sequence-parser (>>n) f
- ] unless* ; inline
-
-: offset ( sequence-parser offset -- char/f )
- swap
- [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( sequence-parser -- char/f ) 0 offset ; inline
-
-: previous ( sequence-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
-
-: advance ( sequence-parser -- sequence-parser )
- [ 1 + ] change-n ; inline
-
-: advance* ( sequence-parser -- )
- advance drop ; inline
-
-: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
-
-: get+increment ( sequence-parser -- char/f )
- [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
- sequence-parser current [
- sequence-parser quot call
- [ sequence-parser advance quot skip-until ] unless
- ] when ; inline recursive
-
-: sequence-parse-end? ( sequence-parser -- ? ) current not ;
-
-: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
- over sequence-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
- ] if ; inline
-
-: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
- [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
- 3dup {
- [ 2drop 0 < ]
- [ [ drop ] 2dip length > ]
- [ drop > ]
- } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( sequence-parser sequence -- obj/f )
- sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
- <safe-slice> sequence sequence= [
- sequence
- sequence-parser [ sequence length + ] change-n drop
- ] [
- f
- ] if ;
-
-: take-sequence* ( sequence-parser sequence -- )
- take-sequence drop ;
-
-:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
- sequence-parser n>> :> saved
- sequence length <growing-circular> :> growing
- sequence-parser
- [
- current growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- growing sequence sequence= [
- found dup length
- growing length 1 - - head
- sequence-parser [ growing length - 1 + ] change-n drop
- ! sequence-parser advance drop
- ] [
- saved sequence-parser (>>n)
- f
- ] if ;
-
-:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
- sequence-parser sequence take-until-sequence :> out
- out [
- sequence-parser [ sequence length + ] change-n drop
- ] when out ;
-
-: skip-whitespace ( sequence-parser -- sequence-parser )
- [ [ current blank? not ] take-until drop ] keep ;
-
-: skip-whitespace-eol ( sequence-parser -- sequence-parser )
- [ [ current " \t\r" member? not ] take-until drop ] keep ;
-
-: take-rest-slice ( sequence-parser -- sequence/f )
- [ sequence>> ] [ n>> ] bi
- 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( sequence-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi f like ;
-
-: take-until-object ( sequence-parser obj -- sequence )
- '[ current _ = ] take-until ;
-
-: parse-sequence ( sequence quot -- )
- [ <sequence-parser> ] dip call ; inline
-
-: take-integer ( sequence-parser -- n/f )
- [ current digit? ] take-while ;
-
-:: take-n ( sequence-parser n -- seq/f )
- n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
- sequence-parser take-rest
- ] [
- sequence-parser n>> dup n + sequence-parser sequence>> subseq
- sequence-parser [ n + ] change-n drop
- ] if ;
-
-<< "length" [ length ] define-sorting >>
-
-: sort-tokens ( seq -- seq' )
- { length>=< <=> } sort-by ;
-
-: take-first-matching ( sequence-parser seq -- seq )
- swap
- '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
-
-: take-longest ( sequence-parser seq -- seq )
- sort-tokens take-first-matching ;
-
-: write-full ( sequence-parser -- ) sequence>> write ;
-: write-rest ( sequence-parser -- ) take-rest write ;
[ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
: assoc-merge ( assoc1 assoc2 -- assoc3 )
- tuck '[ over _ at dup [ append ] [ drop ] if ] assoc-map assoc-union ;
+ [ '[ over _ at dup [ append ] [ drop ] if ] assoc-map ] keep swap assoc-union ;
PRIVATE>
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: help.markup help.syntax sequences ;
-IN: sequences.merged
-
-ARTICLE: "sequences-merge" "Merging sequences"
-"When multiple sequences are merged into one sequence, the new sequence takes an element from each input sequence in turn. For example, if we merge " { $code "{ 1 2 3 }" } "and" { $code "{ \"a\" \"b\" \"c\" }" } "we get:" { $code "{ 1 \"a\" 2 \"b\" 3 \"c\" }" } "."
-{ $subsections
- merge
- 2merge
- 3merge
- <merged>
- <2merged>
- <3merged>
-} ;
-
-ABOUT: "sequences-merge"
-
-HELP: merged
-{ $class-description "A virtual sequence which presents a merged view of its underlying elements. New instances are created by calling one of " { $link <merged> } ", " { $link <2merged> } ", or " { $link <3merged> } "." }
-{ $see-also merge } ;
-
-HELP: <merged> ( seqs -- merged )
-{ $values { "seqs" "a sequence of sequences to merge" } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence." }
-{ $see-also <2merged> <3merged> merge } ;
-
-HELP: <2merged> ( seq1 seq2 -- merged )
-{ $values { "seq1" sequence } { "seq2" sequence } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the two input sequences." }
-{ $see-also <merged> <3merged> 2merge } ;
-
-HELP: <3merged> ( seq1 seq2 seq3 -- merged )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "merged" "a virtual sequence" } }
-{ $description "Creates an instance of the " { $link merged } " virtual sequence which merges the three input sequences." }
-{ $see-also <merged> <2merged> 3merge } ;
-
-HELP: merge ( seqs -- seq )
-{ $values { "seqs" "a sequence of sequences to merge" } { "seq" "a new sequence" } }
-{ $description "Outputs a new sequence which merges the elements of each sequence in " { $snippet "seqs" } "." }
-{ $examples
- { $example "USING: prettyprint sequences.merged ;" "{ { 1 2 } { 3 4 } { 5 6 } } merge ." "{ 1 3 5 2 4 6 }" }
- { $example "USING: prettyprint sequences.merged ;" "{ \"abc\" \"def\" } merge ." "\"adbecf\"" }
-}
-{ $see-also 2merge 3merge <merged> } ;
-
-HELP: 2merge ( seq1 seq2 -- seq )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq" "a new sequence" } }
-{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of " { $snippet "seq1" } " and " { $snippet "seq2" } }
-{ $see-also merge 3merge <2merged> } ;
-
-HELP: 3merge ( seq1 seq2 seq3 -- seq )
-{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "seq" "a new sequence" } }
-{ $description "Creates a new sequence of the same type as " { $snippet "seq1" } " which merges the elements of all three sequences" }
-{ $see-also merge 2merge <3merged> } ;
+++ /dev/null
-USING: sequences sequences.merged tools.test ;
-IN: sequences.merged.tests
-
-[ 0 { 1 2 } ] [ 0 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 0 { 3 4 } ] [ 1 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 1 { 1 2 } ] [ 2 T{ merged f { { 1 2 } { 3 4 } } } virtual@ ] unit-test
-[ 4 ] [ 3 { { 1 2 3 4 } } <merged> nth ] unit-test
-[ 4 { { 1 2 3 4 } } <merged> nth ] must-fail
-
-[ 1 ] [ 0 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 4 ] [ 1 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 2 ] [ 2 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 5 ] [ 3 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 3 ] [ 4 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-[ 6 ] [ 5 { 1 2 3 } { 4 5 6 } <2merged> nth ] unit-test
-
-[ 4 ] [ 4 { 1 2 } { 3 4 } { 5 6 } 3merge nth ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences ;
-IN: sequences.merged
-
-TUPLE: merged seqs ;
-C: <merged> merged
-
-: <2merged> ( seq1 seq2 -- merged ) 2array <merged> ;
-: <3merged> ( seq1 seq2 seq3 -- merged ) 3array <merged> ;
-
-: merge ( seqs -- seq )
- dup <merged> swap first like ;
-
-: 2merge ( seq1 seq2 -- seq )
- dupd <2merged> swap like ;
-
-: 3merge ( seq1 seq2 seq3 -- seq )
- pick [ <3merged> ] dip like ;
-
-M: merged length seqs>> [ length ] map sum ;
-
-M: merged virtual@ ( n seq -- n' seq' )
- seqs>> [ length /mod ] [ nth ] bi ;
-
-M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ;
-
-INSTANCE: merged virtual-sequence
+++ /dev/null
-A virtual sequence which merges (interleaves) other sequences.
+++ /dev/null
-collections
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math math.order
+USING: accessors arrays kernel locals math math.order
sequences sequences.private shuffle ;
IN: sequences.modified
M: modified length seq>> length ;
M: modified set-length seq>> set-length ;
-M: 1modified virtual-seq seq>> ;
+M: 1modified virtual-exemplar seq>> ;
TUPLE: scaled < 1modified c ;
C: <scaled> scaled
M: scaled modified-nth ( n seq -- elt )
[ seq>> nth ] [ c>> * ] bi ;
-M: scaled modified-set-nth ( elt n seq -- elt )
+M:: scaled modified-set-nth ( elt n seq -- elt )
! don't set c to 0!
- tuck [ c>> / ] 2dip seq>> set-nth ;
+ elt seq c>> / n seq seq>> set-nth ;
TUPLE: offset < 1modified n ;
C: <offset> offset
M: offset modified-nth ( n seq -- elt )
[ seq>> nth ] [ n>> + ] bi ;
-M: offset modified-set-nth ( elt n seq -- )
- tuck [ n>> - ] 2dip seq>> set-nth ;
+M:: offset modified-set-nth ( elt n seq -- )
+ elt seq n>> - n seq seq>> set-nth ;
TUPLE: summed < modified seqs ;
C: <summed> summed
M: summed set-length ( n seq -- )
seqs>> [ set-length ] with each ;
-M: summed virtual-seq ( summed -- seq ) [ ] { } map-as ;
+M: summed virtual-exemplar ( summed -- seq )
+ seqs>> [ f ] [ first ] if-empty ;
: <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
: <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax quotations sequences ;
-IN: sequences.product
-
-HELP: product-sequence
-{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
-{ $examples
-{ $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
-""" """{
- { 1 "a" }
- { 2 "a" }
- { 3 "a" }
- { 1 "b" }
- { 2 "b" }
- { 3 "b" }
- { 1 "c" }
- { 2 "c" }
- { 3 "c" }
-}""" } } ;
-
-HELP: <product-sequence>
-{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
-{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
-{ $examples
-{ $example """USING: arrays prettyprint sequences.product ;
-{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array ."""
-"""{
- { 1 "a" }
- { 2 "a" }
- { 3 "a" }
- { 1 "b" }
- { 2 "b" }
- { 3 "b" }
- { 1 "c" }
- { 2 "c" }
- { 3 "c" }
-}""" } } ;
-
-{ product-sequence <product-sequence> } related-words
-
-HELP: product-map
-{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
-{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
-{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
-
-HELP: product-each
-{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
-{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
-{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
-
-{ product-map product-each } related-words
-
-ARTICLE: "sequences.product" "Product sequences"
-"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
-{ $subsections
- product-sequence
- <product-sequence>
- product-map
- product-each
-} ;
-
-ABOUT: "sequences.product"
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: arrays kernel make sequences sequences.product tools.test ;
-IN: sequences.product.tests
-
-
-[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
-[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
-
-: x ( n s -- sss ) <repetition> concat ;
-
-[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
-[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
-
-[
- {
- { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
- { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
- }
-] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
-
-[ "a1b1c1a2b2c2" ] [
- [
- { { "a" "b" "c" } { "1" "2" } }
- [ [ % ] each ] product-each
- ] "" make
-] unit-test
-
-[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
-[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: accessors arrays kernel locals math sequences ;
-IN: sequences.product
-
-TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
-
-: <product-sequence> ( sequences -- product-sequence )
- >array dup [ length ] map product-sequence boa ;
-
-INSTANCE: product-sequence sequence
-
-M: product-sequence length lengths>> product ;
-
-<PRIVATE
-
-: ns ( n lengths -- ns )
- [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
-
-: nths ( ns seqs -- nths )
- [ nth ] { } 2map-as ;
-
-: product@ ( n product-sequence -- ns seqs )
- [ lengths>> ns ] [ nip sequences>> ] 2bi ;
-
-:: (carry-n) ( ns lengths i -- )
- ns length i 1 + = [
- i ns nth i lengths nth = [
- 0 i ns set-nth
- i 1 + ns [ 1 + ] change-nth
- ns lengths i 1 + (carry-n)
- ] when
- ] unless ;
-
-: carry-ns ( ns lengths -- )
- 0 (carry-n) ;
-
-: product-iter ( ns lengths -- )
- [ 0 over [ 1 + ] change-nth ] dip carry-ns ;
-
-: start-product-iter ( sequences -- ns lengths )
- [ [ drop 0 ] map ] [ [ length ] map ] bi ;
-
-: end-product-iter? ( ns lengths -- ? )
- [ 1 tail* first ] bi@ = ;
-
-PRIVATE>
-
-M: product-sequence nth
- product@ nths ;
-
-:: product-each ( sequences quot -- )
- sequences start-product-iter :> lengths :> ns
- lengths [ 0 = ] any? [
- [ ns lengths end-product-iter? ]
- [ ns sequences nths quot call ns lengths product-iter ] until
- ] unless ; inline
-
-:: product-map ( sequences quot -- sequence )
- 0 :> i!
- sequences [ length ] [ * ] map-reduce sequences
- [| result |
- sequences [ quot call i result set-nth i 1 + i! ] product-each
- result
- ] new-like ; inline
-
+++ /dev/null
-Cartesian products of sequences
M: repeating virtual@ ( n seq -- n' seq' ) circular>> ;
-M: repeating virtual-seq circular>> ;
+M: repeating virtual-exemplar circular>> ;
INSTANCE: repeating virtual-sequence
-USING: accessors assocs fry generalizations kernel math
-namespaces parser sequences words ;
+USING: accessors assocs fry generalizations kernel locals math
+namespaces parser sequences shuffle words ;
IN: set-n
: get* ( var n -- val ) namestack dup length rot - head assoc-stack ;
: set* ( val var n -- ) 1 + namestack [ length swap - ] keep nth set-at ;
! dynamic lambda
-SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
\ No newline at end of file
+SYNTAX: :| (:) dup in>> dup length [ spin '[ _ narray _ swap zip _ bind ] ] 2curry dip define-declared ;
] with map ;
SYNTAX: STRIP-TEASE:
- parse-definition strip-tease [ parsed ] each ;
+ parse-definition strip-tease [ suffix! ] each ;
\ slides H{
{ T{ button-down } [ request-focus ] }
io.files
io.pathnames
kernel
+ locals
math
+ math.order
openal
opengl.gl
sequences
#! Point is a {x y}.
first2 game-width 3 * * swap 3 * + ;
-: set-bitmap-pixel ( color point array -- )
- #! 'color' is a {r g b}. Point is {x y}.
- [ bitmap-index ] dip ! color index array
- [ [ first ] 2dip set-nth ] 3keep
- [ [ second ] 2dip [ 1 + ] dip set-nth ] 3keep
- [ third ] 2dip [ 2 + ] dip set-nth ;
+:: set-bitmap-pixel ( bitmap point color -- )
+ point bitmap-index :> index
+ color first index bitmap set-nth
+ color second index 1 + bitmap set-nth
+ color third index 2 + bitmap set-nth ;
: get-bitmap-pixel ( point array -- color )
#! Point is a {x y}. color is a {r g b}
CONSTANT: SOUND-UFO-HIT 8
: init-sound ( index cpu filename -- )
- canonicalize-path swapd [ sounds>> nth AL_BUFFER ] dip
+ absolute-path swapd [ sounds>> nth AL_BUFFER ] dip
create-buffer-from-wav set-source-param ;
: init-sounds ( cpu -- )
#! Setting this value affects the value read from port 3
(>>port2o) ;
-: bit-newly-set? ( old-value new-value bit -- bool )
- tuck bit? [ bit? not ] dip and ;
+:: bit-newly-set? ( old-value new-value bit -- bool )
+ new-value bit bit? [ old-value bit bit? not ] dip and ;
: port3-newly-set? ( new-value cpu bit -- bool )
[ port3o>> swap ] dip bit-newly-set? ;
: plot-bitmap-pixel ( bitmap point color -- )
#! point is a {x y}. color is a {r g b}.
- spin set-bitmap-pixel ;
-
-: within ( n a b -- bool )
- #! n >= a and n <= b
- rot tuck swap <= [ swap >= ] dip and ;
+ set-bitmap-pixel ;
: get-point-color ( point -- color )
#! Return the color to use for the given x/y position.
first2
{
- { [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
- { [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
- { [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
+ { [ dup 184 238 between? pick 0 223 between? and ] [ 2drop green ] }
+ { [ dup 240 247 between? pick 16 133 between? and ] [ 2drop green ] }
+ { [ dup 247 215 - 247 184 - between? pick 0 223 between? and ] [ 2drop red ] }
[ 2drop white ]
} cond ;
[ filter-base-links ] 2keep
depth>> 1 + swap
[ add-nonmatching ]
- [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
+ [ dup '[ _ apply-filters ] curry 2dip add-todo ] 2bi ;
: normalize-hrefs ( base links -- links' )
[ derive-url ] with map ;
:: fill-spidered-result ( spider spider-result -- )
f spider-result url>> spider spidered>> set-at
- [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
+ [ spider-result url>> http-get ] benchmark :> ( headers html fetched-in )
[
html parse-html
spider currently-spidering>>
over find-all-links normalize-hrefs
- ] benchmark :> processed-in :> links :> parsed-html
+ ] benchmark :> ( parsed-html links processed-in )
spider-result
headers >>headers
fetched-in >>fetched-in
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel ;
+USING: accessors assocs deques dlists kernel locals ;
IN: spider.unique-deque
TUPLE: todo-url url depth ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
-: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
- pick deque-empty? [ 3drop ] [
- [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ]
- [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
- ] if ; inline recursive
+:: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+ deque deque-empty? [
+ deque pop-front dup quot1 call
+ [ quot2 call t ] [ drop f ] if
+ [ deque quot1 quot2 slurp-deque-when ] when
+ ] unless ; inline recursive
lists.lazy locals math math.functions math.parser math.ranges
models.product monads random sequences sets ui ui.gadgets.controls
ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
-ui.gadgets.labels ;
+ui.gadgets.labels shuffle ;
IN: sudokus
: row ( index -- row ) 1 + 9 / ceiling ;
: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
: create ( difficulty -- puzzle ) 81 [ f ] replicate
- 40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
+ 40 random solution [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
: do-sudoku ( -- ) [ [
[
] with-self , ] <vbox> { 280 220 } >>pref-dim
"Sudoku Sleuth" open-window ] with-ui ;
-MAIN: do-sudoku
\ No newline at end of file
+MAIN: do-sudoku
[ sample-freq>> -rot sine-wave ] keep swap >>data ;
: >silent-buffer ( seconds buffer -- buffer )
- tuck sample-freq>> * >integer 0 <repetition> >>data ;
+ [ sample-freq>> * >integer 0 <repetition> ] [ (>>data) ] [ ] tri ;
TUPLE: harmonic n amplitude ;
C: <harmonic> harmonic
harmonic amplitude>> <scaled> ;
: >note ( harmonics note buffer -- buffer )
- dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
+ [ [ note-harmonic-data ] 2curry map <summed> ] [ (>>data) ] [ ] tri ;
level>> 1 - 60 * 1000 swap - ;
: add-block ( tetris block -- )
- over board>> spin current-piece tetromino>> colour>> set-block ;
+ over [ board>> ] 2dip current-piece tetromino>> colour>> set-block ;
: game-over? ( tetris -- ? )
[ board>> ] [ next-piece ] bi piece-valid? not ;
: modulo ( n m -- n )
#! -2 7 mod => -2, -2 7 modulo => 5
- tuck mod over + swap mod ;
+ [ mod ] [ + ] [ mod ] tri ;
: (rotate-piece) ( rotation inc n-states -- rotation' )
[ + ] dip modulo ;
] while 3drop ;
M: TYPE >alist ( db -- alist )
- [ DBKEYS dup ] keep '[ dup _ at 2array ] change-each ;
+ [ DBKEYS dup ] keep '[ dup _ at 2array ] map! drop ;
M: TYPE set-at ( value key db -- )
- handle>> spin [ object>bytes dup length ] bi@ DBPUT drop ;
+ handle>> swap rot [ object>bytes dup length ] bi@ DBPUT drop ;
M: TYPE delete-at ( key db -- )
handle>> swap object>bytes dup length DBOUT drop ;
M: TYPE hashcode* assoc-hashcode ;
-;FUNCTOR
\ No newline at end of file
+;FUNCTOR
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel generic math math.functions
-math.parser namespaces io sequences trees
+math.parser namespaces io sequences trees shuffle
assocs parser accessors math.order prettyprint.custom ;
IN: trees.avl
! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser
-trees generic math.order accessors prettyprint.custom ;
+trees generic math.order accessors prettyprint.custom shuffle ;
IN: trees.splay
TUPLE: splay < tree ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel generic math sequences arrays io namespaces
prettyprint.private kernel.private assocs random combinators
-parser math.order accessors deques make prettyprint.custom ;
+parser math.order accessors deques make prettyprint.custom
+shuffle ;
IN: trees
TUPLE: tree root count ;
: alert* ( str -- ) [ ] swap alert ;
:: ask-user ( string -- model' )
- [ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
- fldm [ <model-field*> ->% 1 ]
- btn [ "okay" <model-border-btn> ] |
- btn -> [ fldm swap updates ]
- [ [ drop lbl close-window ] $> , ] bi
- ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
+ [
+ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
+ <model-field*> ->% 1 :> fldm
+ "okay" <model-border-btn> :> btn
+ btn -> [ fldm swap updates ]
+ [ [ drop lbl close-window ] $> , ] bi
+ ] <vbox> { 161 86 } >>pref-dim "" open-window ;
MACRO: ask-buttons ( buttons -- quot ) dup length [
[ swap
[ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window
] dip firstn
- ] 2curry ;
\ No newline at end of file
+ ] 2curry ;
: <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
-SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry over push-all ;
+SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry append! ;
-SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry append! ;
GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ;
INSTANCE: gadget monad
M: gadget monad-of drop gadget-monad ;
M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
! Just take the previous mentioned placeholder and use it
! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
DEFER: with-interface
-: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
- templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+: insertion-quot ( quot -- quot' )
+ make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+ [ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
-SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
-SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
+SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
GENERIC: -> ( uiitem -- model )
M: gadget -> dup , output-model ;
ERROR: not-in-template word ;
SYNTAX: $ CREATE-WORD dup
[ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
- [ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi over push-all ;
+ [ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi append! ;
: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
: insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
M: model >>= [ swap insertion-quot <action> ] curry ;
M: model fmap insertion-quot <mapped> ;
M: model $> insertion-quot side-effect-model new-mapped-model ;
-M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
+M: model <$ insertion-quot quot-model new-mapped-model ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.vectors classes.tuple math.rectangles colors
-kernel sequences models opengl math math.order namespaces
+kernel locals sequences models opengl math math.order namespaces
ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports
ui.gadgets.packs ;
dup list-empty? [
2drop
] [
- tuck control-value length rem >>index
+ [ control-value length rem ] [ (>>index) ] [ ] tri
[ relayout-1 ] [ scroll>selected ] bi
] if ;
[ index>> ] keep nth-gadget invoke-secondary
] if ;
-: select-gadget ( gadget list -- )
- tuck children>> index
- [ swap select-index ] [ drop ] if* ;
+:: select-gadget ( gadget list -- )
+ gadget list children>> index
+ [ list select-index ] when* ;
: clamp-loc ( point max -- point )
vmin { 0 0 } vmax ;
[ t ] [ 5 m 1 m d- 4 m = ] unit-test
[ t ] [ 5 m 2 m d* 10 m^2 = ] unit-test
[ t ] [ 5 m 2 m d/ 5/2 { } { } <dimensioned> = ] unit-test
-[ t ] [ 5 m 2 m tuck d/ drop 2 m = ] unit-test
+[ t ] [ 2 m 5 m 2 m d/ drop 2 m = ] unit-test
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
dimensioned boa ;
: >dimensioned< ( d -- n top bot )
- [ value>> ] [ top>> ] [ bot>> ] tri ;
+ [ bot>> ] [ top>> ] [ value>> ] tri ;
-\ <dimensioned> [ >dimensioned< ] define-inverse
+\ <dimensioned> [ [ dimensioned boa ] undo ] define-inverse
: dimensions ( dimensioned -- top bot )
[ top>> ] [ bot>> ] bi ;
: d-sq ( d -- d ) dup d* ;
: d-recip ( d -- d' )
- >dimensioned< spin recip dimension-op> ;
+ >dimensioned< recip dimension-op> ;
: d/ ( d d -- d ) d-recip d* ;
MEMO: cities-named-in ( name state -- cities )
cities [
- tuck [ name>> = ] [ state>> = ] 2bi* and
+ [ name>> = ] [ state>> = ] bi-curry bi* and
] with with filter ;
: find-zip-code ( code -- city )
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: fry io io.directories io.encodings.ascii
+io.encodings.utf8 io.launcher io.pathnames kernel lexer
+namespaces parser sequences splitting vocabs vocabs.loader ;
+IN: vocabs.git
+
+<PRIVATE
+: git-object-id ( filename rev -- id/f )
+ [ [ parent-directory ] [ file-name ] bi ] dip swap '[
+ { "git" "ls-tree" } _ suffix _ suffix ascii [
+ readln
+ [ " " split1 nip " " split1 nip "\t" split1 drop ]
+ [ f ] if*
+ ] with-process-reader
+ ] with-directory ;
+
+: with-git-object-stream ( id quot -- )
+ [ { "git" "cat-file" "-p" } swap suffix utf8 ] dip with-process-reader ; inline
+PRIVATE>
+
+ERROR: git-revision-not-found path ;
+
+: use-vocab-rev ( vocab-name rev -- )
+ [ create-vocab vocab-source-path dup ] dip git-object-id
+ [ [ input-stream get swap parse-stream call( -- ) ] with-git-object-stream ]
+ [ git-revision-not-found ] if* ;
+
+SYNTAX: USE-REV: scan scan use-vocab-rev ;
}
{ $slide "Locals and lexical scope"
{ "Define lambda words with " { $link POSTPONE: :: } }
- { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+ { "Establish bindings with " { $link POSTPONE: [let } " and " { $snippet "[let*" } }
"Mutable bindings with correct semantics"
{ "Named inputs for quotations with " { $link POSTPONE: [| } }
"Full closures"
<plist version="1.0">
<dict>
<key>content</key>
- <string>
- [let | $1 [ $2 ] $3|
- $0
- ]</string>
+ <string>[let $0 ]</string>
<key>name</key>
<string>let</string>
<key>scope</key>
# change directories to a factor module
function cdfactor {
code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; "
- printf "\"%s\" <vocab> vocab-source-path (normalize-path) print" $1)
+ printf "\"%s\" <vocab> vocab-source-path absolute-path print" $1)
echo $code > $HOME/.cdfactor
fn=$(factor $HOME/.cdfactor)
dn=$(dirname $fn)
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
- ("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
+ ("\\(\\[\\)\\(let\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
("\\(\\[\\)\\(|\\) +[^|]* \\(|\\)" (1 "(]") (2 "(|") (3 ")|"))
(" \\(|\\) " (1 "(|"))
(" \\(|\\)$" (1 ")"))
syn keyword factorKeyword boolean
syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
-syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
+syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* assoc-map-as >alist assoc-filter-as clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
syn keyword factorKeyword byte-array>bignum sgn >bignum next-float number= each-integer next-power-of-2 ?1+ fp-special? imaginary-part mod recip float>bits rational >float number? 2^ bignum? integer fixnum? neg fixnum sq bignum fp-snan? fp-infinity? denominator (all-integers?) times find-last-integer (each-integer) bit? * + fp-bitwise= - fp-qnan? / power-of-2? >= bitand find-integer complex <fp-nan> < log2 > integer? real number bits>double double>bits bitor 2/ zero? rem fp-nan-payload all-integers? (find-integer) real-part prev-float align bits>float float? shift float fp-nan? abs bitxor ratio? even? <= /mod odd? >integer ratio rational? bitnot real? >fixnum complex? /i numerator /f
-syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter-here last-index-from reversed index-from cut* pad-tail (indices) concat-as remq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length delq drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift delete sigma new-sequence follow like delete-nth first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse-here sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode memq? pop set-nth ?nth <flat-slice> second change-each join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
+syn keyword factorKeyword append assert-sequence= find-last-from trim-head-slice clone-like 3sequence assert-sequence? map-as filter! last-index-from reversed index-from cut* pad-tail (indices) concat-as remove-eq but-last snip trim-tail nths nth 2pusher sequence slice? <slice> partition remove-nth tail-slice empty? tail* if-empty find-from virtual-sequence? member? set-length remove-eq! drop-prefix unclip iota unclip-last-slice bounds-error? sequence-hashcode-step map start midpoint@ rest-slice prepend fourth sift remove! map-sum new-sequence follow like remove-nth! first4 1sequence reverse slice unless-empty padding virtual@ repetition? set-last index 4sequence max-length set-second immutable-sequence first2 first3 replicate-as reduce-index unclip-slice supremum insert-nth trim-tail-slice tail 3append short count suffix concat flip filter sum immutable? 2sequence map-integers delete-all start* indices snip-slice check-slice sequence? head map-find reduce append-as reverse! sequence= halves collapse-slice interleave 2map binary-reduce virtual-seq slice-error? product bounds-check? bounds-check harvest immutable find produce remove pad-head last replicate set-fourth shorten reversed? map-find-last 3map-as 2unclip-slice shorter? 3map find-last head-slice pop* 2map-as tail-slice* but-last-slice 2map-reduce iota? accumulate each pusher cut-slice new-resizable each-index head-slice* 2reverse-each sequence-hashcode member-eq? pop set-nth ?nth <flat-slice> second map! join when-empty accumulator immutable-sequence? <reversed> all? 3append-as virtual-sequence subseq? push-either new-like length last-index push-if 2all? lengthen assert-sequence copy map-reduce move third first 3each tail? set-first prefix bounds-error any? <repetition> trim-slice exchange surround 2reduce cut change-nth min-length set-third produce-as push-all head? delete-slice rest sum-lengths 2each head* infimum glue slice-error subseq replace-slice push repetition map-index trim-head unclip-last mismatch trim
syn keyword factorKeyword global +@ change set-namestack change-global init-namespaces on off set-global namespace set with-scope bind with-variable inc dec counter initialize namestack get get-global make-assoc
syn keyword factorKeyword <array> 2array 3array pair >array 1array 4array pair? array resize-array array?
syn keyword factorKeyword +character+ bad-seek-type? readln stream-seek read print with-output-stream contents write1 stream-write1 stream-copy stream-element-type with-input-stream stream-print stream-read stream-contents bl seek-output bad-seek-type nl stream-nl write flush stream-lines +byte+ stream-flush read1 seek-absolute? stream-read1 lines stream-readln stream-read-until each-line seek-end with-output-stream* seek-absolute with-streams seek-input seek-relative? input-stream stream-write read-partial seek-end? seek-relative error-stream read-until with-input-stream* with-streams* each-block output-stream stream-read-partial
<ul>
<li>Windows: Double-click <code>factor.exe</code>, or run
<code>.\factor.com</code> in a command prompt</li>
-<li>Mac OS X: Double-click <code>Factor.app</code>code> or run <code>open
+<li>Mac OS X: Double-click <code>Factor.app</code> or run <code>open
Factor.app</code> in a Terminal</li>
-<li>Unix: Run <code>./factor</code>code> in a shell</li>
+<li>Unix: Run <code>./factor</code> in a shell</li>
</ul>
<h2>Documentation</h2>
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations strings ;
+IN: 4DNav
+
+
+HELP: menu-3D
+{ $values
+ { "gadget" "gadget" }
+}
+{ $description "The menu dedicated to 3D movements of the camera" } ;
+
+HELP: menu-4D
+{ $values
+
+ { "gadget" "gadget" }
+}
+{ $description "The menu dedicated to 4D movements of space" } ;
+
+HELP: menu-bar
+{ $values
+
+ { "gadget" "gadget" }
+}
+{ $description "return gadget containing menu buttons" } ;
+
+HELP: model-projection
+{ $values
+ { "x" "interger" }
+ { "space" "space" }
+}
+{ $description "Project space following coordinate x" } ;
+
+HELP: mvt-3D-1
+{ $values
+
+ { "quot" "quotation" }
+}
+{ $description "return a quotation to orientate space to see it from first point of view" } ;
+
+HELP: mvt-3D-2
+{ $values
+
+ { "quot" "quotation" }
+}
+{ $description "return a quotation to orientate space to see it from second point of view" } ;
+
+HELP: mvt-3D-3
+{ $values
+
+ { "quot" "quotation" }
+}
+{ $description "return a quotation to orientate space to see it from third point of view" } ;
+
+HELP: mvt-3D-4
+{ $values
+
+ { "quot" "quotation" }
+}
+{ $description "return a quotation to orientate space to see it from first point of view" } ;
+
+HELP: load-model-file
+{ $description "load space from file" } ;
+
+HELP: rotation-4D
+{ $values
+ { "m" "a rotation matrix" }
+}
+{ $description "Apply a 4D rotation matrix" } ;
+
+HELP: translation-4D
+{ $values
+ { "v" "vector" }
+}
+{ $description "Apply a 4D translation" } ;
+
+
+ARTICLE: "implementation details" "How 4DNav is done"
+"4DNav is build using :"
+
+{ $subsections
+ "4DNav.camera"
+ "adsoda-main-page"
+}
+;
+
+ARTICLE: "Space file" "Create a new space file"
+"To build a new space, create an XML file using " { $vocab-link "adsoda" } " model description. A solid is not caracterized by its corners but is defined as the intersection of hyperplanes."
+
+$nl
+"An example is:"
+{ $code """
+<model>
+<space>
+ <dimension>4</dimension>
+ <solid>
+ <name>4cube1</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,100</face>
+ <face>-1,0,0,0,-150</face>
+ <face>0,1,0,0,100</face>
+ <face>0,-1,0,0,-150</face>
+ <face>0,0,1,0,100</face>
+ <face>0,0,-1,0,-150</face>
+ <face>0,0,0,1,100</face>
+ <face>0,0,0,-1,-150</face>
+ <color>1,0,0</color>
+ </solid>
+ <solid>
+ <name>4triancube</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,160</face>
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>
+ <face>0,0,1,0,140</face>
+ <face>0,0,-1,0,-180</face>
+ <face>0,0,0,1,110</face>
+ <face>0,0,0,-1,-180</face>
+ <color>0,1,0</color>
+ </solid>
+ <solid>
+ <name>triangone</name>
+ <dimension>4</dimension>
+ <face>1,0,0,0,60</face>
+ <face>0.5,0.8660254037844386,0,0,60</face>
+ <face>-0.5,0.8660254037844387,0,0,-20</face>
+ <face>-1.0,0,0,0,-100</face>
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>
+ <face>0.5,-0.8660254037844387,0,0,-20</face>
+ <face>0,0,1,0,120</face>
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>
+ <color>0,1,1</color>
+ </solid>
+ <light>
+ <direction>1,1,1,1</direction>
+ <color>0.2,0.2,0.6</color>
+ </light>
+ <color>0.8,0.9,0.9</color>
+</space>
+</model>""" } ;
+
+ARTICLE: "TODO" "Todo"
+{ $list
+ "A vocab to initialize parameters"
+ "an editor mode"
+ { $list "add a face to a solid"
+ "add a solid to the space"
+ "move a face"
+ "move a solid"
+ "select a solid in a list"
+ "select a face"
+ "display selected face"
+ "edit a solid color"
+ "add a light"
+ "edit a light color"
+ "move a light"
+ }
+ "add a tool wich give an hyperplane normal vector with enought points. Will use adsoda.intersect-hyperplanes with { { 0 } { 0 } { 1 } } "
+ "decorrelate 3D camera and activate them with select buttons"
+
+} ;
+
+
+ARTICLE: "4DNav" "The 4DNav app"
+{ $vocab-link "4DNav" }
+$nl
+{ $heading "4D Navigator" }
+"4DNav is a simple tool to visualize 4 dimensionnal objects."
+$nl
+"It uses " { $vocab-link "adsoda" } " library to display a 4D space and navigate thru it."
+$nl
+"It will display:"
+{ $list
+ { "a menu window" }
+ { "4 visualization windows" }
+}
+"Each visualization window represents the projection of the 4D space on a particular 3D space."
+
+{ $heading "Start" }
+"type:" { $code "\"4DNav\" run" }
+
+{ $heading "Navigation" }
+"Menu window is divided in 4 areas"
+{ $list
+ { "a space-file chooser to select the file to display" }
+ { "a parametrization area to select the projection mode" }
+ { "4D submenu to translate and rotate the 4D space" }
+ { "3D submenu to move the camera in 3D space. Cameras in every 3D spaces are manipulated as a single one" }
+ }
+
+{ $heading "Links" }
+{ $subsections
+ "Space file"
+ "TODO"
+ "implementation details"
+}
+
+;
+
+ABOUT: "4DNav"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+namespaces\r
+accessors\r
+assocs\r
+make\r
+math\r
+math.functions\r
+math.trig\r
+math.parser\r
+hashtables\r
+sequences\r
+combinators\r
+continuations\r
+colors\r
+colors.constants\r
+prettyprint\r
+vars\r
+quotations\r
+io\r
+io.directories\r
+io.pathnames\r
+help.markup\r
+io.files\r
+ui.gadgets.panes\r
+ ui\r
+ ui.gadgets\r
+ ui.traverse\r
+ ui.gadgets.borders\r
+ ui.gadgets.frames\r
+ ui.gadgets.tracks\r
+ ui.gadgets.labels\r
+ ui.gadgets.labeled \r
+ ui.gadgets.lists\r
+ ui.gadgets.buttons\r
+ ui.gadgets.packs\r
+ ui.gadgets.grids\r
+ ui.gadgets.corners\r
+ ui.gestures\r
+ ui.gadgets.scrollers\r
+splitting\r
+vectors\r
+math.vectors\r
+values\r
+4DNav.turtle\r
+4DNav.window3D\r
+4DNav.deep\r
+4DNav.space-file-decoder\r
+models\r
+fry\r
+adsoda\r
+adsoda.tools\r
+;\r
+QUALIFIED-WITH: ui.pens.solid s\r
+QUALIFIED-WITH: ui.gadgets.wrappers w\r
+\r
+\r
+IN: 4DNav\r
+VALUE: selected-file\r
+VALUE: translation-step\r
+VALUE: rotation-step\r
+\r
+3 to: translation-step \r
+5 to: rotation-step\r
+\r
+VAR: selected-file-model\r
+VAR: observer3d \r
+VAR: view1 \r
+VAR: view2\r
+VAR: view3\r
+VAR: view4\r
+VAR: present-space\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+! namespace utilities\r
+\r
+: closed-quot ( quot -- quot )\r
+ namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! waiting for deep-cleave-quots\r
+\r
+: 4D-Rxy ( angle -- Rx ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , dup cos , dup sin neg ,\r
+ 0.0 , 0.0 , dup sin , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rxz ( angle -- Ry ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , dup cos , 0.0 , dup sin neg ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ 0.0 , dup sin , 0.0 , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rxw ( angle -- Rz ) deg>rad\r
+[ 1.0 , 0.0 , 0.0 , 0.0 ,\r
+ 0.0 , dup cos , dup sin neg , 0.0 ,\r
+ 0.0 , dup sin , dup cos , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+: 4D-Ryz ( angle -- Rx ) deg>rad\r
+[ dup cos , 0.0 , 0.0 , dup sin neg ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ dup sin , 0.0 , 0.0 , dup cos , ] 4 make-matrix nip ;\r
+\r
+: 4D-Ryw ( angle -- Ry ) deg>rad\r
+[ dup cos , 0.0 , dup sin neg , 0.0 ,\r
+ 0.0 , 1.0 , 0.0 , 0.0 ,\r
+ dup sin , 0.0 , dup cos , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+: 4D-Rzw ( angle -- Rz ) deg>rad\r
+[ dup cos , dup sin neg , 0.0 , 0.0 ,\r
+ dup sin , dup cos , 0.0 , 0.0 ,\r
+ 0.0 , 0.0 , 1.0 , 0.0 ,\r
+ 0.0 , 0.0 , 0.0 , 1.0 , ] 4 make-matrix nip ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! UI\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: button* ( string quot -- button ) \r
+ closed-quot <repeat-button> ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: model-projection-chooser ( -- gadget )\r
+ observer3d> projection-mode>>\r
+ { { 1 "perspective" } { 0 "orthogonal" } } \r
+ <radio-buttons> ;\r
+\r
+: collision-detection-chooser ( -- gadget )\r
+ observer3d> collision-mode>>\r
+ { { t "on" } { f "off" } } <radio-buttons> ;\r
+\r
+: model-projection ( x -- space ) \r
+ present-space> swap space-project ;\r
+\r
+: update-observer-projections ( -- )\r
+ view1> relayout-1 \r
+ view2> relayout-1 \r
+ view3> relayout-1 \r
+ view4> relayout-1 ;\r
+\r
+: update-model-projections ( -- )\r
+ 0 model-projection <model> view1> (>>model)\r
+ 1 model-projection <model> view2> (>>model)\r
+ 2 model-projection <model> view3> (>>model)\r
+ 3 model-projection <model> view4> (>>model) ;\r
+\r
+: camera-action ( quot -- quot ) \r
+ '[ drop _ observer3d> \r
+ with-self update-observer-projections ] \r
+ closed-quot ;\r
+\r
+: win3D ( text gadget -- ) \r
+ "navigateur 4D : " rot append open-window ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! 4D object manipulation\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: (mvt-4D) ( quot -- ) \r
+ present-space> \r
+ swap call space-ensure-solids \r
+ >present-space \r
+ update-model-projections \r
+ update-observer-projections ; inline\r
+\r
+: rotation-4D ( m -- ) \r
+ '[ _ [ [ middle-of-space dup vneg ] keep \r
+ swap space-translate ] dip\r
+ space-transform \r
+ swap space-translate\r
+ ] (mvt-4D) ;\r
+\r
+: translation-4D ( v -- ) '[ _ space-translate ] (mvt-4D) ;\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! menu\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: menu-rotations-4D ( -- gadget )\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
+ <pile> 1 >>fill\r
+ "XY +" [ drop rotation-step 4D-Rxy rotation-4D ] \r
+ button* add-gadget\r
+ "XY -" [ drop rotation-step neg 4D-Rxy rotation-4D ] \r
+ button* add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ "XZ +" [ drop rotation-step 4D-Rxz rotation-4D ] \r
+ button* add-gadget\r
+ "XZ -" [ drop rotation-step neg 4D-Rxz rotation-4D ] \r
+ button* add-gadget \r
+ @top grid-add \r
+ <pile> 1 >>fill\r
+ "YZ +" [ drop rotation-step 4D-Ryz rotation-4D ] \r
+ button* add-gadget\r
+ "YZ -" [ drop rotation-step neg 4D-Ryz rotation-4D ] \r
+ button* add-gadget \r
+ @center grid-add\r
+ <pile> 1 >>fill\r
+ "XW +" [ drop rotation-step 4D-Rxw rotation-4D ] \r
+ button* add-gadget\r
+ "XW -" [ drop rotation-step neg 4D-Rxw rotation-4D ] \r
+ button* add-gadget \r
+ @top-right grid-add \r
+ <pile> 1 >>fill\r
+ "YW +" [ drop rotation-step 4D-Ryw rotation-4D ] \r
+ button* add-gadget\r
+ "YW -" [ drop rotation-step neg 4D-Ryw rotation-4D ] \r
+ button* add-gadget \r
+ @right grid-add \r
+ <pile> 1 >>fill\r
+ "ZW +" [ drop rotation-step 4D-Rzw rotation-4D ] \r
+ button* add-gadget\r
+ "ZW -" [ drop rotation-step neg 4D-Rzw rotation-4D ] \r
+ button* add-gadget \r
+ @bottom-right grid-add \r
+;\r
+\r
+: menu-translations-4D ( -- gadget )\r
+ 3 3 <frame> \r
+ { 1 1 } >>filled-cell\r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill \r
+ "X+" [ drop { 1 0 0 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget\r
+ "X-" [ drop { -1 0 0 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "YZW" <label> add-gadget\r
+ @bottom-right grid-add\r
+ <pile> 1 >>fill\r
+ "XZW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
+ "Y+" [ drop { 0 1 0 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget\r
+ "Y-" [ drop { 0 -1 0 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ @top-right grid-add\r
+ <pile> 1 >>fill\r
+ "XYW" <label> add-gadget\r
+ <shelf> 1 >>fill\r
+ "Z+" [ drop { 0 0 1 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget\r
+ "Z-" [ drop { 0 0 -1 0 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget \r
+ @top-left grid-add \r
+ <pile> 1 >>fill\r
+ <shelf> 1 >>fill\r
+ "W+" [ drop { 0 0 0 1 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget\r
+ "W-" [ drop { 0 0 0 -1 } translation-step v*n \r
+ translation-4D ] \r
+ button* add-gadget \r
+ add-gadget\r
+ "XYZ" <label> add-gadget\r
+ @bottom-left grid-add \r
+ "X" <label> @center grid-add\r
+;\r
+\r
+: menu-4D ( -- gadget ) \r
+ <shelf> \r
+ "rotations" <label> add-gadget\r
+ menu-rotations-4D add-gadget\r
+ "translations" <label> add-gadget\r
+ menu-translations-4D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+;\r
+\r
+\r
+! ------------------------------------------------------\r
+\r
+: redraw-model ( space -- )\r
+ >present-space \r
+ update-model-projections \r
+ update-observer-projections ;\r
+\r
+: load-model-file ( -- )\r
+ selected-file dup selected-file-model> set-model \r
+ read-model-file \r
+ redraw-model ;\r
+\r
+: mvt-3D-X ( turn pitch -- quot )\r
+ '[ turtle-pos> norm neg reset-turtle \r
+ _ turn-left \r
+ _ pitch-up \r
+ step-turtle ] ;\r
+\r
+: mvt-3D-1 ( -- quot ) 90 0 mvt-3D-X ; inline\r
+: mvt-3D-2 ( -- quot ) 0 90 mvt-3D-X ; inline\r
+: mvt-3D-3 ( -- quot ) 0 0 mvt-3D-X ; inline\r
+: mvt-3D-4 ( -- quot ) 45 45 mvt-3D-X ; inline\r
+\r
+: camera-button ( string quot -- button ) \r
+ [ <label> ] dip camera-action <repeat-button> ;\r
+\r
+! ----------------------------------------------------------\r
+! file chooser\r
+! ----------------------------------------------------------\r
+: <run-file-button> ( file-name -- button )\r
+ dup '[ drop _ \ selected-file set-value load-model-file \r
+ ] \r
+ closed-quot <roll-button> { 0 0 } >>align ;\r
+\r
+: <list-runner> ( -- gadget )\r
+ "resource:extra/4DNav" \r
+ <pile> 1 >>fill \r
+ over dup directory-files \r
+ [ ".xml" tail? ] filter \r
+ [ append-path ] with map\r
+ [ <run-file-button> add-gadget ] each\r
+ swap <labeled-gadget> ;\r
+\r
+! -----------------------------------------------------\r
+\r
+: menu-rotations-3D ( -- gadget )\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
+ "Turn\n left" [ rotation-step turn-left ] \r
+ camera-button @left grid-add \r
+ "Turn\n right" [ rotation-step turn-right ] \r
+ camera-button @right grid-add \r
+ "Pitch down" [ rotation-step pitch-down ] \r
+ camera-button @bottom grid-add \r
+ "Pitch up" [ rotation-step pitch-up ] \r
+ camera-button @top grid-add \r
+ <shelf> 1 >>fill\r
+ "Roll left\n (ctl)" [ rotation-step roll-left ] \r
+ camera-button add-gadget \r
+ "Roll right\n(ctl)" [ rotation-step roll-right ] \r
+ camera-button add-gadget \r
+ @center grid-add \r
+;\r
+\r
+: menu-translations-3D ( -- gadget )\r
+ 3 3 <frame>\r
+ { 1 1 } >>filled-cell\r
+ "left\n(alt)" [ translation-step strafe-left ]\r
+ camera-button @left grid-add \r
+ "right\n(alt)" [ translation-step strafe-right ]\r
+ camera-button @right grid-add \r
+ "Strafe up \n (alt)" [ translation-step strafe-up ] \r
+ camera-button @top grid-add\r
+ "Strafe down\n (alt)" [ translation-step strafe-down ]\r
+ camera-button @bottom grid-add \r
+ <pile> 1 >>fill\r
+ "Forward (ctl)" [ translation-step step-turtle ] \r
+ camera-button add-gadget\r
+ "Backward (ctl)" \r
+ [ translation-step neg step-turtle ] \r
+ camera-button add-gadget\r
+ @center grid-add\r
+;\r
+\r
+: menu-quick-views ( -- gadget )\r
+ <shelf>\r
+ "View 1 (1)" mvt-3D-1 camera-button add-gadget\r
+ "View 2 (2)" mvt-3D-2 camera-button add-gadget\r
+ "View 3 (3)" mvt-3D-3 camera-button add-gadget \r
+ "View 4 (4)" mvt-3D-4 camera-button add-gadget \r
+;\r
+\r
+: menu-3D ( -- gadget ) \r
+ <pile>\r
+ <shelf> \r
+ menu-rotations-3D add-gadget\r
+ menu-translations-3D add-gadget\r
+ 0.5 >>align\r
+ { 0 10 } >>gap\r
+ add-gadget\r
+ menu-quick-views add-gadget ; \r
+\r
+TUPLE: handler < w:wrapper table ;\r
+\r
+: <handler> ( child -- handler ) handler w:new-wrapper ;\r
+\r
+M: handler handle-gesture ( gesture gadget -- ? )\r
+ tuck table>> at dup [ call( gadget -- ) f ] [ 2drop t ] if ;\r
+\r
+: add-keyboard-delegate ( obj -- obj )\r
+ <handler>\r
+H{\r
+ { T{ key-down f f "LEFT" } \r
+ [ [ rotation-step turn-left ] camera-action ] }\r
+ { T{ key-down f f "RIGHT" } \r
+ [ [ rotation-step turn-right ] camera-action ] }\r
+ { T{ key-down f f "UP" } \r
+ [ [ rotation-step pitch-down ] camera-action ] }\r
+ { T{ key-down f f "DOWN" } \r
+ [ [ rotation-step pitch-up ] camera-action ] }\r
+\r
+ { T{ key-down f { C+ } "UP" } \r
+ [ [ translation-step step-turtle ] camera-action ] }\r
+ { T{ key-down f { C+ } "DOWN" } \r
+ [ [ translation-step neg step-turtle ] \r
+ camera-action ] }\r
+ { T{ key-down f { C+ } "LEFT" } \r
+ [ [ rotation-step roll-left ] camera-action ] }\r
+ { T{ key-down f { C+ } "RIGHT" } \r
+ [ [ rotation-step roll-right ] camera-action ] }\r
+\r
+ { T{ key-down f { A+ } "LEFT" } \r
+ [ [ translation-step strafe-left ] camera-action ] }\r
+ { T{ key-down f { A+ } "RIGHT" } \r
+ [ [ translation-step strafe-right ] camera-action ] }\r
+ { T{ key-down f { A+ } "UP" } \r
+ [ [ translation-step strafe-up ] camera-action ] }\r
+ { T{ key-down f { A+ } "DOWN" } \r
+ [ [ translation-step strafe-down ] camera-action ] }\r
+\r
+\r
+ { T{ key-down f f "1" } [ mvt-3D-1 camera-action ] }\r
+ { T{ key-down f f "2" } [ mvt-3D-2 camera-action ] }\r
+ { T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
+ { T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
+\r
+ } >>table\r
+ ; \r
+\r
+! --------------------------------------------\r
+! print elements \r
+! --------------------------------------------\r
+! print-content\r
+\r
+GENERIC: adsoda-display-model ( x -- ) \r
+\r
+M: light adsoda-display-model \r
+"\n light : " .\r
+ { \r
+ [ direction>> "direction : " pprint . ] \r
+ [ color>> "color : " pprint . ]\r
+ } cleave\r
+ ;\r
+\r
+M: face adsoda-display-model \r
+ {\r
+ [ halfspace>> "halfspace : " pprint . ] \r
+ [ touching-corners>> "touching corners : " pprint . ]\r
+ } cleave\r
+ ;\r
+M: solid adsoda-display-model \r
+ {\r
+ [ name>> "solid called : " pprint . ] \r
+ [ color>> "color : " pprint . ]\r
+ [ dimension>> "dimension : " pprint . ]\r
+ [ faces>> "composed of faces : " pprint \r
+ [ adsoda-display-model ] each ]\r
+ } cleave\r
+ ;\r
+M: space adsoda-display-model \r
+ {\r
+ [ dimension>> "dimension : " pprint . ] \r
+ [ ambient-color>> "ambient-color : " pprint . ]\r
+ [ solids>> "composed of solids : " pprint \r
+ [ adsoda-display-model ] each ]\r
+ [ lights>> "composed of lights : " pprint \r
+ [ adsoda-display-model ] each ] \r
+ } cleave\r
+ ;\r
+\r
+! ----------------------------------------------\r
+: menu-bar ( -- gadget )\r
+ <shelf>\r
+ "reinit" [ drop load-model-file ] button* add-gadget\r
+ selected-file-model> <label-control> add-gadget\r
+ ;\r
+\r
+\r
+: controller-window* ( -- gadget )\r
+ { 0 1 } <track>\r
+ menu-bar f track-add\r
+ <list-runner> \r
+ <scroller>\r
+ f track-add\r
+ <shelf>\r
+ "Projection mode : " <label> add-gadget\r
+ model-projection-chooser add-gadget\r
+ f track-add\r
+ <shelf>\r
+ "Collision detection (slow and buggy ) : " \r
+ <label> add-gadget\r
+ collision-detection-chooser add-gadget\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align \r
+ menu-4D add-gadget \r
+ COLOR: purple s:<solid> >>interior\r
+ "4D movements" <labeled-gadget>\r
+ f track-add\r
+ <pile>\r
+ 0.5 >>align\r
+ { 2 2 } >>gap\r
+ menu-3D add-gadget\r
+ COLOR: purple s:<solid> >>interior\r
+ "Camera 3D" <labeled-gadget>\r
+ f track-add \r
+ COLOR: gray s:<solid> >>interior\r
+ ;\r
+ \r
+: viewer-windows* ( -- )\r
+ "YZW" view1> win3D \r
+ "XZW" view2> win3D \r
+ "XYW" view3> win3D \r
+ "XYZ" view4> win3D \r
+;\r
+\r
+: navigator-window* ( -- )\r
+ controller-window*\r
+ viewer-windows* \r
+ add-keyboard-delegate\r
+ "navigateur 4D" open-window\r
+;\r
+\r
+: windows ( -- ) [ [ navigator-window* ] with-scope ] with-ui ;\r
+\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+: init-variables ( -- )\r
+ "choose a file" <model> >selected-file-model \r
+ <observer> >observer3d\r
+ [ observer3d> >self\r
+ reset-turtle \r
+ 45 turn-left \r
+ 45 pitch-up \r
+ -300 step-turtle \r
+ ] with-scope\r
+ \r
+;\r
+\r
+\r
+: init-models ( -- )\r
+ 0 model-projection observer3d> <window3D> >view1\r
+ 1 model-projection observer3d> <window3D> >view2\r
+ 2 model-projection observer3d> <window3D> >view3\r
+ 3 model-projection observer3d> <window3D> >view4\r
+;\r
+\r
+: 4DNav ( -- ) \r
+ init-variables\r
+ selected-file read-model-file >present-space\r
+ init-models\r
+ windows\r
+;\r
+\r
+MAIN: 4DNav\r
+\r
+\r
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+Adam Wendt
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.camera
+
+HELP: camera-eye
+{ $values
+
+ { "point" "position" }
+}
+{ $description "return the position of the camera" } ;
+
+HELP: camera-focus
+{ $values
+
+ { "point" "position" }
+}
+{ $description "return the point the camera looks at" } ;
+
+HELP: camera-up
+{ $values
+
+ { "dirvec" "upside direction" }
+}
+{ $description "In order to precise the roling position of camera give an upward vector" } ;
+
+HELP: do-look-at
+{ $values
+ { "camera" "direction" }
+}
+{ $description "Word to use in replacement of gl-look-at when using a camera" } ;
+
+ARTICLE: "4DNav.camera" "Camera"
+{ $vocab-link "4DNav.camera" }
+$nl
+"A camera is defined by:"
+{ $list
+{ "a position (" { $link camera-eye } ")" }
+{ "a focus direction (" { $link camera-focus } ")" }
+{ "an attitude information (" { $link camera-up } ")" }
+}
+"Use " { $link do-look-at } " in opengl statement in placement of gl-look-at"
+$nl
+"A camera is a " { $vocab-link "4DNav.turtle" } " object. Its a special vocab to handle mouvements of a 3D object:"
+{ $list
+{ "To define a camera"
+{
+ $unchecked-example
+
+"VAR: my-camera"
+": init-my-camera ( -- )"
+" <turtle> >my-camera"
+" [ my-camera> >self"
+" reset-turtle "
+" ] with-scope ;"
+} }
+{ "To move it"
+{
+ $unchecked-example
+
+" [ my-camera> >self"
+" 45 pitch-up "
+" 5 step-turtle"
+" ] with-scope "
+} }
+{ "or"
+{
+ $unchecked-example
+
+" [ my-camera> >self"
+" 5 strafe-left"
+" ] with-scope "
+}
+}
+{
+"to use it in an opengl statement"
+{
+ $unchecked-example
+ "my-camera> do-look-at"
+
+}
+}
+}
+
+
+;
+
+ABOUT: "4DNav.camera"
--- /dev/null
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
+
+IN: 4DNav.camera
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: camera-eye ( -- point ) turtle-pos> ;
+
+: camera-focus ( -- point )
+ [ 1 step-turtle turtle-pos> ] save-self ;
+
+: camera-up ( -- dirvec )
+[ 90 pitch-up turtle-pos> 1 step-turtle turtle-pos> swap v- ]
+ save-self ;
+
+: do-look-at ( camera -- )
+[ >self camera-eye camera-focus camera-up gl-look-at ]
+ with-scope ;
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences ;
+IN: 4DNav.deep
+
+! HELP: deep-cleave-quots
+! { $values
+! { "seq" sequence }
+! { "quot" quotation }
+! }
+! { $description "A word to build a soquence from a sequence of quotation" }
+!
+! { $examples
+! "It is useful to build matrix"
+! { $example "USING: math math.trig ; "
+! " 30 deg>rad "
+! " { { [ cos ] [ sin neg ] 0 } "
+! " { [ sin ] [ cos ] 0 } "
+! " { 0 0 1 } "
+! " } deep-cleave-quots "
+! " "
+!
+!
+! } }
+! ;
+
+ARTICLE: "4DNav.deep" "Deep"
+{ $vocab-link "4DNav.deep" }
+;
+
+ABOUT: "4DNav.deep"
--- /dev/null
+USING: macros quotations math math.functions math.trig \r
+sequences.deep kernel make fry combinators grouping ;\r
+IN: 4DNav.deep\r
+\r
+! USING: bake ;\r
+! MACRO: deep-cleave-quots ( seq -- quot )\r
+! [ [ quotation? ] deep-filter ]\r
+! [ [ dup quotation? [ drop , ] when ] deep-map ]\r
+! bi '[ _ cleave _ bake ] ;\r
+\r
+: make-matrix ( quot width -- matrix ) \r
+ [ { } make ] dip group ; inline\r
+\r
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-c-types? t }
+ { deploy-word-props? t }
+ { deploy-name "4DNav" }
+ { deploy-ui? t }
+ { deploy-math? t }
+ { deploy-threads? t }
+ { deploy-reflection 3 }
+ { deploy-unicode? t }
+ { deploy-io 3 }
+ { "stop-after-last-window?" t }
+ { deploy-word-defs? t }
+}
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING:\r
+kernel\r
+io.files\r
+io.backend\r
+io.directories\r
+io.files.info\r
+io.pathnames\r
+sequences\r
+models\r
+strings\r
+ui\r
+ui.operations\r
+ui.commands\r
+ui.gestures\r
+ui.gadgets\r
+ui.gadgets.buttons\r
+ui.gadgets.lists\r
+ui.gadgets.labels\r
+ui.gadgets.tracks\r
+ui.gadgets.packs\r
+ui.gadgets.panes\r
+ui.gadgets.scrollers\r
+prettyprint\r
+combinators\r
+accessors\r
+values\r
+tools.walker\r
+fry\r
+;\r
+IN: 4DNav.file-chooser\r
+\r
+TUPLE: file-chooser < track \r
+ path\r
+ extension \r
+ selected-file\r
+ presenter\r
+ hook \r
+ list\r
+ ;\r
+\r
+: find-file-list ( gadget -- list )\r
+ [ file-chooser? ] find-parent list>> ;\r
+\r
+file-chooser H{\r
+ { T{ key-down f f "UP" } \r
+ [ find-file-list select-previous ] }\r
+ { T{ key-down f f "DOWN" } \r
+ [ find-file-list select-next ] }\r
+ { T{ key-down f f "PAGE_UP" } \r
+ [ find-file-list list-page-up ] }\r
+ { T{ key-down f f "PAGE_DOWN" } \r
+ [ find-file-list list-page-down ] }\r
+ { T{ key-down f f "RET" } \r
+ [ find-file-list invoke-value-action ] }\r
+ { T{ button-down } \r
+ request-focus }\r
+ { T{ button-down f 1 } \r
+ [ find-file-list invoke-value-action ] }\r
+} set-gestures\r
+\r
+: list-of-files ( file-chooser -- seq )\r
+ [ path>> value>> directory-entries ] [ extension>> ] bi\r
+ '[ [ name>> _ [ tail? ] with any? ] \r
+ [ directory? ] bi or ] filter\r
+;\r
+\r
+: update-filelist-model ( file-chooser -- )\r
+ [ list-of-files ] [ model>> ] bi set-model ;\r
+\r
+: init-filelist-model ( file-chooser -- file-chooser )\r
+ dup list-of-files <model> >>model ; \r
+\r
+: (fc-go) ( file-chooser button quot -- )\r
+ [ [ file-chooser? ] find-parent dup path>> ] dip\r
+ call\r
+ normalize-path swap set-model\r
+ update-filelist-model\r
+ drop ; inline\r
+\r
+: fc-go-parent ( file-chooser button -- )\r
+ [ dup value>> parent-directory ] (fc-go) ;\r
+\r
+: fc-go-home ( file-chooser button -- )\r
+ [ home ] (fc-go) ;\r
+\r
+: fc-change-directory ( file-chooser file -- )\r
+ dupd [ path>> value>> normalize-path ] [ name>> ] bi* \r
+ append-path over path>> set-model \r
+ update-filelist-model\r
+;\r
+\r
+: fc-load-file ( file-chooser file -- )\r
+ over [ name>> ] [ selected-file>> ] bi* set-model \r
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
+ call( path -- )\r
+; inline\r
+\r
+! : fc-ok-action ( file-chooser -- quot )\r
+! dup selected-file>> value>> "" =\r
+! [ drop [ drop ] ] [ \r
+! [ path>> value>> ] \r
+! [ selected-file>> value>> append ] \r
+! [ hook>> prefix ] tri\r
+! [ drop ] prepend\r
+! ] if ; \r
+\r
+: line-selected-action ( file-chooser -- )\r
+ dup list>> list-value\r
+ dup directory? \r
+ [ fc-change-directory ] [ fc-load-file ] if ;\r
+\r
+: present-dir-element ( element -- string )\r
+ [ name>> ] [ directory? ] bi [ "-> " prepend ] when ;\r
+\r
+: <file-list> ( file-chooser -- list )\r
+ dup [ nip line-selected-action ] curry \r
+ [ present-dir-element ] rot model>> <list> ;\r
+\r
+: <file-chooser> ( hook path extension -- gadget )\r
+ { 0 1 } file-chooser new-track\r
+ swap >>extension\r
+ swap <model> >>path\r
+ "" <model> >>selected-file\r
+ swap >>hook\r
+ init-filelist-model\r
+ dup <file-list> >>list\r
+ "choose a file in directory " <label> f track-add\r
+ dup path>> <label-control> f track-add\r
+ dup extension>> ", " join "limited to : " prepend \r
+ <label> f track-add\r
+ <shelf> \r
+ "selected file : " <label> add-gadget\r
+ over selected-file>> <label-control> add-gadget\r
+ f track-add\r
+ <shelf> \r
+ over [ swap fc-go-parent ] curry "go up" \r
+ swap <border-button> add-gadget\r
+ over [ swap fc-go-home ] curry "go home" \r
+ swap <border-button> add-gadget\r
+ ! over [ swap fc-ok-action ] curry "OK" \r
+ ! swap <bevel-button> add-gadget\r
+ ! [ drop ] "Cancel" swap <bevel-button> add-gadget\r
+ f track-add\r
+ dup list>> <scroller> 1 track-add\r
+;\r
+\r
+M: file-chooser pref-dim* drop { 400 200 } ;\r
+\r
+: file-chooser-window ( -- )\r
+ [ . ] home { "xml" "txt" } <file-chooser> \r
+ "Choose a file" open-window ;\r
+\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>hypercube</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>1,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,0,0,0</direction>\r
+ <color>0,0,0,0.6</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,1,0,0</direction>\r
+ <color>0,0.6,0,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,1,0</direction>\r
+ <color>0,0,0.6,0</color>\r
+ </light>\r
+ <light>\r
+ <direction>0,0,0,1</direction>\r
+ <color>0.6,0.6,0.6</color>\r
+ </light>\r
+ <color>0.99,0.99,0.99</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>multi solids</name>\r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>4cube1</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,100</face>\r
+ <face>-1,0,0,0,-150</face>\r
+ <face>0,1,0,0,100</face>\r
+ <face>0,-1,0,0,-150</face>\r
+ <face>0,0,1,0,100</face>\r
+ <face>0,0,-1,0,-150</face>\r
+ <face>0,0,0,1,100</face>\r
+ <face>0,0,0,-1,-150</face>\r
+ <color>1,0,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>4triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+<model>\r
+<space>\r
+ <name>Prismetragone</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triangone</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,60</face>\r
+ <face>0.5,0.8660254037844386,0,0,60</face>\r
+ <face>-0.5,0.8660254037844387,0,0,-20</face>\r
+ <face>-1.0,0,0,0,-100</face>\r
+ <face>-0.5,-0.8660254037844384,0,0,-100</face>\r
+ <face>0.5,-0.8660254037844387,0,0,-20</face>\r
+ <face>0,0,1,0,120</face>\r
+ <face>0,0,-0.4999999999999998,-0.8660254037844387,-120</face>\r
+ <face>0,0,-0.5000000000000004,0.8660254037844384,-120</face>\r
+ <color>0,1,1</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.space-file-decoder
+
+
+
+HELP: read-model-file
+{ $values
+
+ { "path" "path to the file to read" }
+ { "x" "value" }
+}
+{ $description "Read a file containing the xml description of the model" } ;
+
+ARTICLE: "4DNav.space-file-decoder" "Space XMLfile decoder"
+{ $vocab-link "4DNav.space-file-decoder" }
+;
+
+ABOUT: "4DNav.space-file-decoder"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: adsoda xml xml.traversal xml.syntax accessors \r
+combinators sequences math.parser kernel splitting values \r
+continuations ;\r
+IN: 4DNav.space-file-decoder\r
+\r
+: decode-number-array ( x -- y ) \r
+ "," split [ string>number ] map ;\r
+\r
+TAGS: adsoda-read-model ( tag -- model )\r
+\r
+TAG: dimension adsoda-read-model \r
+ children>> first string>number ;\r
+TAG: direction adsoda-read-model \r
+ children>> first decode-number-array ;\r
+TAG: color adsoda-read-model \r
+ children>> first decode-number-array ;\r
+TAG: name adsoda-read-model \r
+ children>> first ;\r
+TAG: face adsoda-read-model \r
+ children>> first decode-number-array ;\r
+\r
+TAG: solid adsoda-read-model \r
+ <solid> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ]\r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ [ "face" \r
+ tags-named [ adsoda-read-model cut-solid ] each ] \r
+ } cleave\r
+ ensure-adjacencies\r
+;\r
+\r
+TAG: light adsoda-read-model \r
+ <light> swap \r
+ { \r
+ [ "direction" tag-named adsoda-read-model >>direction ]\r
+ [ "color" tag-named adsoda-read-model >>color ] \r
+ } cleave\r
+;\r
+\r
+TAG: space adsoda-read-model \r
+ <space> swap \r
+ { \r
+ [ "dimension" tag-named adsoda-read-model >>dimension ]\r
+ [ "name" tag-named adsoda-read-model >>name ] \r
+ [ "color" tag-named \r
+ adsoda-read-model >>ambient-color ] \r
+ [ "solid" tags-named \r
+ [ adsoda-read-model suffix-solids ] each ] \r
+ [ "light" tags-named \r
+ [ adsoda-read-model suffix-lights ] each ]\r
+ } cleave\r
+;\r
+\r
+: read-model-file ( path -- x )\r
+ [\r
+ [ file>xml "space" tag-named adsoda-read-model ] \r
+ [ 2drop <space> ] recover \r
+ ] [ <space> ] if*\r
+;\r
+\r
--- /dev/null
+Simple tool to navigate through a 4D space with projections on 4 3D spaces
--- /dev/null
+4D viewer
\ No newline at end of file
--- /dev/null
+<model>\r
+<space>\r
+ <name>triancube</name> \r
+ <dimension>4</dimension>\r
+ <solid>\r
+ <name>triancube</name>\r
+ <dimension>4</dimension>\r
+ <face>1,0,0,0,160</face>\r
+ <face>-0.4999999999999998,-0.8660254037844387,0,0,-130</face>\r
+ <face>-0.5000000000000004,0.8660254037844384,0,0,-130</face>\r
+ <face>0,0,1,0,140</face>\r
+ <face>0,0,-1,0,-180</face>\r
+ <face>0,0,0,1,110</face>\r
+ <face>0,0,0,-1,-180</face>\r
+ <color>0,1,0</color>\r
+ </solid>\r
+ <light>\r
+ <direction>1,1,1,1</direction>\r
+ <color>0.2,0.2,0.6</color>\r
+ </light>\r
+ <color>0.8,0.9,0.9</color>\r
+</space>\r
+</model>\r
--- /dev/null
+Eduardo Cavazos
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: 4DNav.turtle
+
+
+ARTICLE: "4DNav.turtle" "Turtle"
+{ $vocab-link "4DNav.turtle" }
+;
+
+ABOUT: "4DNav.turtle"
--- /dev/null
+USING: kernel math arrays math.vectors math.matrices namespaces make
+math.constants math.functions splitting grouping math.trig sequences
+accessors 4DNav.deep models vars ;
+IN: 4DNav.turtle
+
+! replacement of self
+
+VAR: self
+
+: with-self ( quot obj -- ) [ >self call ] with-scope ; inline
+
+: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: turtle pos ori ;
+
+: <turtle> ( -- turtle )
+ turtle new
+ { 0 0 0 } clone >>pos
+ 3 identity-matrix >>ori
+;
+
+
+TUPLE: observer < turtle projection-mode collision-mode ;
+
+: <observer> ( -- object )
+ observer new
+ 0 <model> >>projection-mode
+ f <model> >>collision-mode
+ ;
+
+
+: turtle-pos> ( -- val ) self> pos>> ;
+: >turtle-pos ( val -- ) self> (>>pos) ;
+
+: turtle-ori> ( -- val ) self> ori>> ;
+: >turtle-ori ( val -- ) self> (>>ori) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! These rotation matrices are from
+! `Computer Graphics: Principles and Practice'
+
+
+! waiting for deep-cleave-quots
+
+! : Rz ( angle -- Rx ) deg>rad
+! { { [ cos ] [ sin neg ] 0 }
+! { [ sin ] [ cos ] 0 }
+! { 0 0 1 }
+! } deep-cleave-quots ;
+
+! : Ry ( angle -- Ry ) deg>rad
+! { { [ cos ] 0 [ sin ] }
+! { 0 1 0 }
+! { [ sin neg ] 0 [ cos ] }
+! } deep-cleave-quots ;
+
+! : Rx ( angle -- Rz ) deg>rad
+! { { 1 0 0 }
+! { 0 [ cos ] [ sin neg ] }
+! { 0 [ sin ] [ cos ] }
+! } deep-cleave-quots ;
+
+: Rz ( angle -- Rx ) deg>rad
+[ dup cos , dup sin neg , 0 ,
+ dup sin , dup cos , 0 ,
+ 0 , 0 , 1 , ] 3 make-matrix nip ;
+
+: Ry ( angle -- Ry ) deg>rad
+[ dup cos , 0 , dup sin ,
+ 0 , 1 , 0 ,
+ dup sin neg , 0 , dup cos , ] 3 make-matrix nip ;
+
+: Rx ( angle -- Rz ) deg>rad
+[ 1 , 0 , 0 ,
+ 0 , dup cos , dup sin neg ,
+ 0 , dup sin , dup cos , ] 3 make-matrix nip ;
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: apply-rotation ( rotation -- )
+ turtle-ori> swap m. >turtle-ori ;
+: rotate-x ( angle -- ) Rx apply-rotation ;
+: rotate-y ( angle -- ) Ry apply-rotation ;
+: rotate-z ( angle -- ) Rz apply-rotation ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pitch-up ( angle -- ) neg rotate-x ;
+: pitch-down ( angle -- ) rotate-x ;
+
+: turn-left ( angle -- ) rotate-y ;
+: turn-right ( angle -- ) neg rotate-y ;
+
+: roll-left ( angle -- ) neg rotate-z ;
+: roll-right ( angle -- ) rotate-z ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! roll-until-horizontal
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: V ( -- V ) { 0 1 0 } ;
+
+: X ( -- 3array ) turtle-ori> [ first ] map ;
+: Y ( -- 3array ) turtle-ori> [ second ] map ;
+: Z ( -- 3array ) turtle-ori> [ third ] map ;
+
+: set-X ( seq -- ) turtle-ori> [ set-first ] 2each ;
+: set-Y ( seq -- ) turtle-ori> [ set-second ] 2each ;
+: set-Z ( seq -- ) turtle-ori> [ set-third ] 2each ;
+
+: roll-until-horizontal ( -- )
+ V Z cross normalize set-X
+ Z X cross normalize set-Y ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: distance ( turtle turtle -- n )
+ pos>> swap pos>> v- [ sq ] map sum sqrt ;
+
+: move-by ( point -- ) turtle-pos> v+ >turtle-pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-turtle ( -- )
+ { 0 0 0 } clone >turtle-pos 3 identity-matrix >turtle-ori ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-vector ( length -- array ) { 0 0 1 } n*v ;
+
+: step-turtle ( length -- )
+ step-vector turtle-ori> swap m.v
+ turtle-pos> v+ >turtle-pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: strafe-up ( length -- )
+ 90 pitch-up
+ step-turtle
+ 90 pitch-down ;
+
+: strafe-down ( length -- )
+ 90 pitch-down
+ step-turtle
+ 90 pitch-up ;
+
+: strafe-left ( length -- )
+ 90 turn-left
+ step-turtle
+ 90 turn-right ;
+
+: strafe-right ( length -- )
+ 90 turn-right
+ step-turtle
+ 90 turn-left ;
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jean-François Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: 4DNav.window3D
+
+
+
+ARTICLE: "4DNav.window3D" "Window3D"
+{ $vocab-link "4DNav.window3D" }
+;
+
+ABOUT: "4DNav.window3D"
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel \r
+ui.gadgets\r
+ui.render\r
+opengl\r
+opengl.gl\r
+opengl.glu\r
+4DNav.camera\r
+4DNav.turtle\r
+math\r
+values\r
+alien.c-types\r
+accessors\r
+namespaces\r
+adsoda \r
+models\r
+prettyprint\r
+;\r
+\r
+IN: 4DNav.window3D\r
+\r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+! drawing functions \r
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
+\r
+TUPLE: window3D < gadget observer ; \r
+\r
+: <window3D> ( model observer -- gadget )\r
+ window3D new\r
+ swap 2dup \r
+ projection-mode>> add-connection\r
+ 2dup \r
+ collision-mode>> add-connection\r
+ >>observer \r
+ swap <model> >>model \r
+ t >>root?\r
+;\r
+\r
+M: window3D pref-dim* ( gadget -- dim ) drop { 300 300 } ;\r
+\r
+M: window3D draw-gadget* ( gadget -- )\r
+\r
+ GL_PROJECTION glMatrixMode\r
+ glLoadIdentity\r
+ 0.6 0.6 0.6 .9 glClearColor\r
+ dup observer>> projection-mode>> value>> 1 = \r
+ [ 60.0 1.0 0.1 3000.0 gluPerspective ]\r
+ [ -400.0 400.0 -400.0 400.0 0.0 4000.0 glOrtho ] if\r
+ dup observer>> collision-mode>> value>> \r
+ \ remove-hidden-solids? \r
+ set-value\r
+ dup observer>> do-look-at\r
+ GL_MODELVIEW glMatrixMode\r
+ glLoadIdentity \r
+ 0.9 0.9 0.9 1.0 glClearColor\r
+ 1.0 glClearDepth\r
+ GL_LINE_SMOOTH glEnable\r
+ GL_BLEND glEnable\r
+ GL_DEPTH_TEST glEnable \r
+ GL_LEQUAL glDepthFunc\r
+ GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc\r
+ GL_LINE_SMOOTH_HINT GL_NICEST glHint\r
+ 1.25 glLineWidth\r
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor \r
+ glClear\r
+ glLoadIdentity\r
+ GL_LIGHTING glEnable\r
+ GL_LIGHT0 glEnable\r
+ GL_COLOR_MATERIAL glEnable\r
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial\r
+ ! *************************\r
+ \r
+ model>> value>> \r
+ [ space->GL ] when*\r
+\r
+ ! *************************\r
+;\r
+\r
+M: window3D graft* drop ;\r
+\r
+M: window3D model-changed nip relayout ; \r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: help.markup help.syntax ;\r
+IN: adsoda\r
+\r
+! --------------------------------------------------------------\r
+! faces\r
+! --------------------------------------------------------------\r
+ARTICLE: "face-page" "Face in ADSODA"\r
+"explanation of faces"\r
+$nl\r
+"link to functions" $nl\r
+"what is an halfspace" $nl\r
+"halfspace touching-corners adjacent-faces" $nl\r
+"touching-corners list of pointers to the corners which touch this face" $nl\r
+"adjacent-faces list of pointers to the faces which touch this face"\r
+{ $subsections\r
+ face\r
+ <face>\r
+}\r
+"test relative position"\r
+{ $subsections\r
+ point-inside-or-on-face?\r
+ point-inside-face?\r
+}\r
+"handling face"\r
+{ $subsections\r
+ flip-face\r
+ face-translate\r
+ face-transform\r
+}\r
+\r
+;\r
+\r
+HELP: face\r
+{ $class-description "a face is defined by"\r
+{ $list "halfspace equation" }\r
+{ $list "list of touching corners" }\r
+{ $list "list of adjacent faces" }\r
+$nl\r
+"Touching corners and adjacent faces are defined by algorithm thanks to other faces of the solid"\r
+}\r
+\r
+\r
+;\r
+HELP: <face> \r
+{ $values { "v" "an halfspace equation" } { "tuple" "a face" } } ;\r
+HELP: flip-face \r
+{ $values { "face" "a face" } { "face" "flipped face" } }\r
+{ $description "change the orientation of a face" }\r
+;\r
+\r
+HELP: face-translate \r
+{ $values { "face" "a face" } { "v" "a vector" } }\r
+{ $description \r
+"translate a face following a vector"\r
+$nl\r
+"a translation of an halfspace doesn't change the normal vector. this word just compute the new constant term" }\r
+\r
+ \r
+ ;\r
+HELP: face-transform \r
+{ $values { "face" "a face" } { "m" "a transformation matrix" } }\r
+{ $description "compute the transformation of a face using a transformation matrix" }\r
+ \r
+ ;\r
+! --------------------------------\r
+! solid\r
+! --------------------------------------------------------------\r
+ARTICLE: "solid-page" "Solid in ADSODA"\r
+"explanation of solids"\r
+$nl\r
+"link to functions"\r
+{ $subsections\r
+ solid\r
+ <solid>\r
+}\r
+"test relative position"\r
+{ $subsections\r
+ point-inside-solid?\r
+ point-inside-or-on-solid?\r
+}\r
+"playing with faces and solids"\r
+{ $subsections\r
+ add-face\r
+ cut-solid\r
+ slice-solid\r
+}\r
+"solid handling"\r
+{ $subsections\r
+ solid-project\r
+ solid-translate\r
+ solid-transform\r
+ subtract\r
+ get-silhouette \r
+ solid=\r
+}\r
+;\r
+\r
+HELP: solid \r
+{ $class-description "dimension" $nl "silhouettes" $nl "faces" $nl "corners" $nl "adjacencies-valid" $nl "color" $nl "name" \r
+}\r
+;\r
+\r
+HELP: add-face \r
+{ $values { "solid" "a solid" } { "face" "a face" } }\r
+{ $description "reshape a solid with a face. The face truncate the solid." } ;\r
+\r
+HELP: cut-solid\r
+{ $values { "solid" "a solid" } { "halfspace" "an halfspace" } }\r
+{ $description "like add-face but just with halfspace equation" } ;\r
+\r
+HELP: slice-solid\r
+{ $values { "solid" "a solid" } { "face" "a face" } { "solid1" "the outer part of the former solid" } { "solid2" "the inner part of the former solid" } }\r
+{ $description "cut a solid into two parts. The face acts like a knife"\r
+} ;\r
+\r
+\r
+HELP: solid-project\r
+{ $values { "lights" "lights" } { "ambient" "ambient" } { "solid" "solid" } { "solids" "projection of solid" } }\r
+{ $description "Project the solid using pv vector" \r
+$nl\r
+"TODO: explain how to use lights"\r
+} ;\r
+\r
+HELP: solid-translate \r
+{ $values { "solid" "a solid" } { "v" "translating vector" } }\r
+{ $description "Translate a solid using a vector" \r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: solid-transform \r
+{ $values { "solid" "a solid" } { "m" "transformation matrix" } }\r
+{ $description "Transform a solid using a matrix"\r
+$nl\r
+"v and solid must have the same dimension "\r
+} ;\r
+\r
+HELP: subtract \r
+{ $values { "solid1" "initial shape" } { "solid2" "shape to remove" } { "solids" "resulting shape" } }\r
+{ $description "Substract solid2 from solid1" } ;\r
+\r
+\r
+! --------------------------------------------------------------\r
+! space \r
+! --------------------------------------------------------------\r
+ARTICLE: "space-page" "Space in ADSODA"\r
+"A space is a collection of solids and lights."\r
+$nl\r
+"link to functions"\r
+$nl\r
+"Defining words"\r
+{ $subsections\r
+ space\r
+ <space>\r
+ suffix-solids \r
+ suffix-lights\r
+ clear-space-solids \r
+ describe-space\r
+}\r
+\r
+\r
+"Handling space"\r
+{ $subsections\r
+ space-ensure-solids\r
+ eliminate-empty-solids\r
+ space-transform\r
+ space-translate\r
+ remove-hidden-solids\r
+ space-project\r
+}\r
+\r
+\r
+;\r
+\r
+HELP: space \r
+{ $class-description \r
+"dimension" $nl " solids" $nl " ambient-color" $nl "lights" \r
+}\r
+;\r
+\r
+HELP: suffix-solids \r
+"( space solid -- space )"\r
+{ $values { "space" "a space" } { "solid" "a solid to add" } }\r
+{ $description "Add solid to space definition" } ;\r
+\r
+HELP: suffix-lights \r
+"( space light -- space ) "\r
+{ $values { "space" "a space" } { "light" "a light to add" } }\r
+{ $description "Add a light to space definition" } ;\r
+\r
+HELP: clear-space-solids \r
+"( space -- space )" \r
+{ $values { "space" "a space" } }\r
+{ $description "remove all solids in space" } ;\r
+\r
+HELP: space-ensure-solids \r
+{ $values { "space" "a space" } }\r
+{ $description "rebuild corners of all solids in space" } ;\r
+\r
+\r
+\r
+HELP: space-transform \r
+" ( space m -- space )" \r
+{ $values { "space" "a space" } { "m" "a matrix" } }\r
+{ $description "Transform a space using a matrix" } ;\r
+\r
+HELP: space-translate \r
+{ $values { "space" "a space" } { "v" "a vector" } }\r
+{ $description "Translate a space following a vector" } ;\r
+\r
+HELP: describe-space " ( space -- )"\r
+{ $values { "space" "a space" } }\r
+{ $description "return a description of space" } ;\r
+\r
+HELP: space-project \r
+{ $values { "space" "a space" } { "i" "an integer" } }\r
+{ $description "Project a space along ith coordinate" } ;\r
+\r
+! --------------------------------------------------------------\r
+! 3D rendering\r
+! --------------------------------------------------------------\r
+ARTICLE: "3D-rendering-page" "The 3D rendering in ADSODA"\r
+"explanation of 3D rendering"\r
+$nl\r
+"link to functions"\r
+{ $subsections\r
+ face->GL\r
+ solid->GL\r
+ space->GL\r
+}\r
+\r
+;\r
+\r
+HELP: face->GL \r
+{ $values { "face" "a face" } { "color" "3 3 values array" } }\r
+{ $description "display a face" } ;\r
+\r
+HELP: solid->GL \r
+{ $values { "solid" "a solid" } }\r
+{ $description "display a solid" } ;\r
+\r
+HELP: space->GL \r
+{ $values { "space" "a space" } }\r
+{ $description "display a space" } ;\r
+\r
+! --------------------------------------------------------------\r
+! light\r
+! --------------------------------------------------------------\r
+\r
+ARTICLE: "light-page" "Light in ADSODA"\r
+"explanation of light"\r
+$nl\r
+"link to functions"\r
+;\r
+\r
+ARTICLE: { "adsoda" "light" } "ADSODA : lights"\r
+{ $code """\r
+! HELP: light position color\r
+! <light> ( -- tuple ) light new ;\r
+! light est un vecteur avec 3 variables pour les couleurs\n\r
+ void Light::Apply(Vector& normal, double &cRed, double &cGreen, double &cBlue)\n\r
+ { \n\r
+ // Dot the light direction with the normalized normal of Face.\r
+ register double intensity = -(normal * (*this));\r
+ // Face is a backface, from light's perspective\r
+ if (intensity < 0)\r
+ return;\r
+ \r
+ // Add the intensity componentwise\r
+ cRed += red * intensity;\r
+ cGreen += green * intensity;\r
+ cBlue += blue * intensity;\r
+ // Clip to unit range\r
+ if (cRed > 1.0) cRed = 1.0;\r
+ if (cGreen > 1.0) cGreen = 1.0;\r
+ if (cBlue > 1.0) cBlue = 1.0;\r
+""" }\r
+;\r
+\r
+\r
+\r
+ARTICLE: { "adsoda" "halfspace" } "ADSODA : halfspace"\r
+" defined by the concatenation of the normal vector and a constant" \r
+ ;\r
+\r
+\r
+\r
+ARTICLE: "adsoda-main-page" "ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm"\r
+"multidimensional handler :" \r
+$nl\r
+"design a solid using face delimitations. Only works on convex shapes"\r
+$nl\r
+{ $emphasis "written in C++ by Greg Ferrar" }\r
+$nl\r
+"full explanation on adsoda page at " { $url "http://www.flowerfire.com/ADSODA/" }\r
+$nl\r
+"Useful words are describe on the following pages: "\r
+{ $subsections\r
+ "face-page"\r
+ "solid-page"\r
+ "space-page"\r
+ "light-page"\r
+ "3D-rendering-page"\r
+} ;\r
+\r
+ABOUT: "adsoda-main-page"\r
--- /dev/null
+USING: adsoda\r
+kernel\r
+math\r
+accessors\r
+sequences\r
+ adsoda.solution2\r
+ fry\r
+ tools.test \r
+ arrays ;\r
+\r
+IN: adsoda.tests\r
+\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
+\r
+\r
+! {\r
+! { 1 0 0 0 }\r
+! { 0 1 0 0 }\r
+! { 0 0 0.984807753012208 -0.1736481776669303 }\r
+! { 0 0 0.1736481776669303 0.984807753012208 }\r
+! }\r
+\r
+! ------------------------------------------------------------\r
+! constant+\r
+[ { 1 2 5 } ] [ { 1 2 3 } 2 constant+ ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! translate\r
+[ { 1 -1 0 } ] [ { 1 -1 -5 } { 3 -2 } translate ] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! transform\r
+[ { -1 -1 -5 21.0 } ] [ { -1 -1 -5 21 }\r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 }\r
+ } transform \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+! compare-nleft-to-identity-matrix\r
+[ t ] [ \r
+ { \r
+ { 1 0 0 1232 } \r
+ { 0 1 0 0 321 } \r
+ { 0 0 1 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 } { 0 1 0 } { 0 0 0 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 2 0 0 } { 0 1 0 } { 0 0 1 } } \r
+ 3 compare-nleft-to-identity-matrix \r
+] unit-test\r
+! ------------------------------------------------------------\r
+[ t ] [ \r
+ { { 1 0 0 }\r
+ { 0 1 0 }\r
+ { 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 } } 3 valid-solution? \r
+] unit-test\r
+\r
+[ f ] [ \r
+ { { 1 0 0 1 }\r
+ { 0 0 0 1 }\r
+ { 0 0 1 0 } } 2 valid-solution? \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+[ 3 ] [ { 1 2 3 } last ] unit-test \r
+\r
+[ { 1 2 5 } ] [ { 1 2 3 } dup [ 2 + ] change-last ] unit-test \r
+\r
+! ------------------------------------------------------------\r
+! position-point \r
+[ 0 ] [ \r
+ { 1 -1 -5 } { 2 7 } position-point \r
+] unit-test\r
+\r
+! ------------------------------------------------------------\r
+\r
+! transform\r
+! TODO construire un exemple\r
+\r
+\r
+! ------------------------------------------------------------\r
+! slice-solid \r
+\r
+! ------------------------------------------------------------\r
+! solve-equation \r
+! deux cas de tests, avec solution et sans solution\r
+\r
+[ { 2 7 } ] \r
+[ { { 1 -1 -5 } { 1 2 16 } } intersect-hyperplanes ] \r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 -1 -5 } { 1 2 16 } { -1 -1 -21 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+[ f ] \r
+[ { { 1 0 -5 } { 1 0 16 } } intersect-hyperplanes ]\r
+unit-test\r
+\r
+! ------------------------------------------------------------\r
+! point-inside-halfspace\r
+[ t ] [ { 1 -1 -5 } { 0 0 } point-inside-halfspace? ] \r
+unit-test\r
+[ f ] [ { 1 -1 -5 } { 8 13 } point-inside-halfspace? ] \r
+unit-test\r
+[ t ] [ { 1 -1 -5 } { 8 13 } point-inside-or-on-halfspace? ] \r
+unit-test\r
+\r
+\r
+! ------------------------------\r
+! order solid\r
+\r
+[ 1 ] [ 0 >pv solid1 solid2 order-solid ] unit-test\r
+[ -1 ] [ 0 >pv solid2 solid1 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid1 solid2 order-solid ] unit-test\r
+[ f ] [ 1 >pv solid2 solid1 order-solid ] unit-test\r
+\r
+\r
+! clip-solid\r
+[ { { 13 15 } { 15 13 } { 13 13 } } ]\r
+ [ 0 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid1 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 0 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+\r
+solid1 corners>> '[ _ ]\r
+ [ 1 >pv solid1 solid2 clip-solid first corners>> ] unit-test\r
+solid2 corners>> '[ _ ]\r
+ [ 1 >pv solid2 solid1 clip-solid first corners>> ] unit-test\r
+\r
+!\r
+[\r
+ {\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 13 } { 36 17 } { 36 13 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+ }\r
+] [ 0 >pv solid2 solid3 2array \r
+ solid1 (solids-silhouette-subtract) \r
+ [ corners>> ] map\r
+ ] unit-test\r
+\r
+\r
+[\r
+{\r
+ { { 8 13 } { 2 7 } { 12 9 } { 12 2 } }\r
+ { { 13 15 } { 15 13 } { 13 13 } }\r
+ { { 16 17 } { 16 15 } { 36 17 } { 36 15 } }\r
+ { { 16 1 } { 16 2 } { 36 1 } { 36 2 } }\r
+}\r
+] [ \r
+ 0 >pv <space> solid1 suffix-solids \r
+ solid2 suffix-solids \r
+ solid3 suffix-solids\r
+ remove-hidden-solids\r
+ solids>> [ corners>> ] map\r
+] unit-test\r
+\r
+! { }\r
+! { }\r
+! <light> { 0.2 0.3 0.4 } >>color { 1 -1 1 } >>direction suffix\r
+! <light> { 0.4 0.3 0.1 } >>color { -1 -1 -1 } >>direction suffix\r
+! suffix \r
+! { 0.1 0.1 0.1 } suffix ! ambient color\r
+! { 0.23 0.32 0.17 } suffix ! solid color\r
+! solid3 faces>> first \r
+\r
+! enlight-projection\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors\r
+arrays \r
+assocs\r
+combinators\r
+kernel \r
+fry\r
+math \r
+math.constants\r
+math.functions\r
+math.libm\r
+math.order\r
+math.vectors \r
+math.matrices \r
+math.parser\r
+namespaces\r
+prettyprint\r
+sequences\r
+sequences.deep\r
+sets\r
+slots\r
+sorting\r
+tools.time\r
+vars\r
+continuations\r
+words\r
+opengl\r
+opengl.gl\r
+colors\r
+adsoda.solution2\r
+adsoda.combinators\r
+opengl.demo-support\r
+values\r
+tools.walker\r
+;\r
+\r
+IN: adsoda\r
+\r
+DEFER: combinations\r
+VAR: pv\r
+\r
+\r
+! -------------------------------------------------------------\r
+! global values\r
+VALUE: remove-hidden-solids?\r
+VALUE: VERY-SMALL-NUM\r
+VALUE: ZERO-VALUE\r
+VALUE: MAX-FACE-PER-CORNER\r
+\r
+t to: remove-hidden-solids?\r
+0.0000001 to: VERY-SMALL-NUM\r
+0.0000001 to: ZERO-VALUE\r
+4 to: MAX-FACE-PER-CORNER\r
+! -------------------------------------------------------------\r
+! sequence complement\r
+\r
+: with-pv ( i quot -- ) [ swap >pv call ] with-scope ; inline\r
+\r
+: dimension ( array -- x ) length 1 - ; inline \r
+: change-last ( seq quot -- ) \r
+ [ [ dimension ] keep ] dip change-nth ; inline\r
+\r
+! -------------------------------------------------------------\r
+! light\r
+! -------------------------------------------------------------\r
+\r
+TUPLE: light name { direction array } color ;\r
+: <light> ( -- tuple ) light new ;\r
+\r
+! -------------------------------------------------------------\r
+! halfspace manipulation\r
+! -------------------------------------------------------------\r
+\r
+: constant+ ( v x -- w ) '[ [ _ + ] change-last ] keep ;\r
+: translate ( u v -- w ) dupd v* sum constant+ ; \r
+\r
+: transform ( u matrix -- w )\r
+ [ swap m.v ] 2keep ! compute new normal vector \r
+ [\r
+ [ [ abs ZERO-VALUE > ] find ] keep \r
+ ! find a point on the frontier\r
+ ! be sure it's not null vector\r
+ last ! get constant\r
+ swap /f neg swap ! intercept value\r
+ ] dip \r
+ flip \r
+ nth\r
+ [ * ] with map ! apply intercep value\r
+ over v*\r
+ sum neg\r
+ suffix ! add value as constant at the end of equation\r
+;\r
+\r
+: position-point ( halfspace v -- x ) \r
+ -1 suffix v* sum ; inline\r
+: point-inside-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM > ; \r
+: point-inside-or-on-halfspace? ( halfspace v -- ? ) \r
+ position-point VERY-SMALL-NUM neg > ;\r
+: project-vector ( seq -- seq ) \r
+ pv> [ head ] [ 1 + tail ] 2bi append ; \r
+: get-intersection ( matrice -- seq ) \r
+ [ 1 tail* ] map flip first ;\r
+\r
+: islenght=? ( seq n -- seq n ? ) 2dup [ length ] [ = ] bi* ;\r
+\r
+: compare-nleft-to-identity-matrix ( seq n -- ? ) \r
+ [ [ head ] curry map ] keep identity-matrix m- \r
+ flatten\r
+ [ abs ZERO-VALUE < ] all?\r
+;\r
+\r
+: valid-solution? ( matrice n -- ? )\r
+ islenght=?\r
+ [ compare-nleft-to-identity-matrix ] \r
+ [ 2drop f ] if ; inline\r
+\r
+: intersect-hyperplanes ( matrice -- seq )\r
+ [ solution dup ] [ first dimension ] bi\r
+ valid-solution? [ get-intersection ] [ drop f ] if ;\r
+\r
+! -------------------------------------------------------------\r
+! faces\r
+! -------------------------------------------------------------\r
+\r
+TUPLE: face { halfspace array } \r
+ touching-corners adjacent-faces ;\r
+: <face> ( v -- tuple ) face new swap >>halfspace ;\r
+: flip-face ( face -- face ) [ vneg ] change-halfspace ;\r
+: erase-face-touching-corners ( face -- face ) \r
+ f >>touching-corners ;\r
+: erase-face-adjacent-faces ( face -- face ) \r
+ f >>adjacent-faces ;\r
+: faces-intersection ( faces -- v ) \r
+ [ halfspace>> ] map intersect-hyperplanes ;\r
+: face-translate ( face v -- face ) \r
+ [ translate ] curry change-halfspace ; inline\r
+: face-transform ( face m -- face )\r
+ [ transform ] curry change-halfspace ; inline\r
+: face-orientation ( face -- x ) pv> swap halfspace>> nth sgn ;\r
+: backface? ( face -- face ? ) dup face-orientation 0 <= ;\r
+: pv-factor ( face -- f face ) \r
+ halfspace>> [ pv> swap nth [ * ] curry ] keep ; inline\r
+: suffix-touching-corner ( face corner -- face ) \r
+ [ suffix ] curry change-touching-corners ; inline\r
+: real-face? ( face -- ? )\r
+ [ touching-corners>> length ] \r
+ [ halfspace>> dimension ] bi >= ;\r
+\r
+: (add-to-adjacent-faces) ( face face -- face )\r
+ over adjacent-faces>> 2dup member?\r
+ [ 2drop ] [ swap suffix >>adjacent-faces ] if ;\r
+\r
+: add-to-adjacent-faces ( face face -- face )\r
+ 2dup = [ drop ] [ (add-to-adjacent-faces) ] if ;\r
+\r
+: update-adjacent-faces ( faces corner -- )\r
+ '[ [ _ suffix-touching-corner drop ] each ] keep \r
+ 2 among [ \r
+ [ first ] keep second \r
+ [ add-to-adjacent-faces drop ] 2keep \r
+ swap add-to-adjacent-faces drop \r
+ ] each ; inline\r
+\r
+: face-project-dim ( face -- x ) halfspace>> length 2 - ;\r
+\r
+: apply-light ( color light normal -- u )\r
+ over direction>> v. \r
+ neg dup 0 > \r
+ [ \r
+ [ color>> swap ] dip \r
+ [ * ] curry map v+ \r
+ [ 1 min ] map \r
+ ] \r
+ [ 2drop ] \r
+ if\r
+;\r
+\r
+: enlight-projection ( array face -- color )\r
+ ! array = lights + ambient color\r
+ [ [ third ] [ second ] [ first ] tri ]\r
+ [ halfspace>> project-vector normalize ] bi*\r
+ [ apply-light ] curry each\r
+ v*\r
+;\r
+\r
+: (intersection-into-face) ( face-init face-adja quot -- face )\r
+ [\r
+ [ [ pv-factor ] bi@ \r
+ roll \r
+ [ map ] 2bi@\r
+ v-\r
+ ] 2keep\r
+ [ touching-corners>> ] bi@\r
+ [ swap [ = ] curry find nip f = ] curry find nip\r
+ ] dip over\r
+ [\r
+ call\r
+ dupd\r
+ point-inside-halfspace? [ vneg ] unless \r
+ <face> \r
+ ] [ 3drop f ] if \r
+ ; inline\r
+\r
+: intersection-into-face ( face-init face-adja -- face )\r
+ [ [ project-vector ] bi@ ] (intersection-into-face) ;\r
+\r
+: intersection-into-silhouette-face ( face-init face-adja -- face )\r
+ [ ] (intersection-into-face) ;\r
+\r
+: intersections-into-faces ( face -- faces )\r
+ clone dup \r
+ adjacent-faces>> [ intersection-into-face ] with map \r
+ [ ] filter ;\r
+\r
+: (face-silhouette) ( face -- faces )\r
+ clone dup adjacent-faces>>\r
+ [ backface?\r
+ [ intersection-into-silhouette-face ] [ 2drop f ] if \r
+ ] with map \r
+ [ ] filter\r
+; inline\r
+\r
+: face-silhouette ( face -- faces ) \r
+ backface? [ drop f ] [ (face-silhouette) ] if ;\r
+\r
+! --------------------------------\r
+! solid\r
+! -------------------------------------------------------------\r
+TUPLE: solid dimension silhouettes \r
+ faces corners adjacencies-valid color name ;\r
+\r
+: <solid> ( -- tuple ) solid new ;\r
+\r
+: suffix-silhouettes ( solid silhouette -- solid ) \r
+ [ suffix ] curry change-silhouettes ;\r
+\r
+: suffix-face ( solid face -- solid ) \r
+ [ suffix ] curry change-faces ;\r
+: suffix-corner ( solid corner -- solid ) \r
+ [ suffix ] curry change-corners ; \r
+: erase-solid-corners ( solid -- solid ) f >>corners ;\r
+\r
+: erase-silhouettes ( solid -- solid ) \r
+ dup dimension>> f <array> >>silhouettes ;\r
+: filter-real-faces ( solid -- solid ) \r
+ [ [ real-face? ] filter ] change-faces ;\r
+: initiate-solid-from-face ( face -- solid ) \r
+ face-project-dim <solid> swap >>dimension ;\r
+\r
+: erase-old-adjacencies ( solid -- solid )\r
+ erase-solid-corners\r
+ [ dup [ erase-face-touching-corners \r
+ erase-face-adjacent-faces drop ] each ]\r
+ change-faces ;\r
+\r
+: point-inside-or-on-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-or-on-halfspace? ;\r
+\r
+: point-inside-face? ( face v -- ? ) \r
+ [ halfspace>> ] dip point-inside-halfspace? ;\r
+\r
+: point-inside-solid? ( solid point -- ? )\r
+ [ faces>> ] dip [ point-inside-face? ] curry all? ; inline\r
+\r
+: point-inside-or-on-solid? ( solid point -- ? )\r
+ [ faces>> ] dip \r
+ [ point-inside-or-on-face? ] curry all? ; inline\r
+\r
+: unvalid-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies f >>adjacencies-valid \r
+ erase-silhouettes ;\r
+\r
+: add-face ( solid face -- solid ) \r
+ suffix-face unvalid-adjacencies ; \r
+\r
+: cut-solid ( solid halfspace -- solid ) <face> add-face ; \r
+\r
+: slice-solid ( solid face -- solid1 solid2 )\r
+ [ [ clone ] bi@ flip-face add-face \r
+ [ "/outer/" append ] change-name ] 2keep\r
+ add-face [ "/inner/" append ] change-name ;\r
+\r
+! -------------\r
+\r
+\r
+: add-silhouette ( solid -- solid )\r
+ dup \r
+ ! find-adjacencies \r
+ faces>> { } \r
+ [ face-silhouette append ] reduce\r
+ [ ] filter \r
+ <solid> \r
+ swap >>faces\r
+ over dimension>> >>dimension \r
+ over name>> " silhouette " append \r
+ pv> number>string append \r
+ >>name\r
+ ! ensure-adjacencies\r
+ suffix-silhouettes ; inline\r
+\r
+: find-silhouettes ( solid -- solid )\r
+ { } >>silhouettes \r
+ dup dimension>> [ [ add-silhouette ] with-pv ] each ;\r
+\r
+: ensure-silhouettes ( solid -- solid )\r
+ dup silhouettes>> [ f = ] all?\r
+ [ find-silhouettes ] when ; \r
+\r
+! ------------\r
+\r
+: corner-added? ( solid corner -- ? ) \r
+ ! add corner to solid if it is inside solid\r
+ [ ] \r
+ [ point-inside-or-on-solid? ] \r
+ [ swap corners>> member? not ] \r
+ 2tri and\r
+ [ suffix-corner drop t ] [ 2drop f ] if ;\r
+\r
+: process-corner ( solid faces corner -- )\r
+ swapd \r
+ [ corner-added? ] keep swap ! test if corner is inside solid\r
+ [ update-adjacent-faces ] \r
+ [ 2drop ]\r
+ if ;\r
+\r
+: compute-intersection ( solid faces -- )\r
+ dup faces-intersection\r
+ dup f = [ 3drop ] [ process-corner ] if ;\r
+\r
+: test-faces-combinaisons ( solid n -- )\r
+ [ dup faces>> ] dip among \r
+ [ compute-intersection ] with each ;\r
+\r
+: compute-adjacencies ( solid -- solid )\r
+ dup dimension>> [ >= ] curry \r
+ [ keep swap ] curry MAX-FACE-PER-CORNER swap\r
+ [ [ test-faces-combinaisons ] 2keep 1 - ] while drop ;\r
+\r
+: find-adjacencies ( solid -- solid ) \r
+ erase-old-adjacencies \r
+ compute-adjacencies\r
+ filter-real-faces \r
+ t >>adjacencies-valid ;\r
+\r
+: ensure-adjacencies ( solid -- solid ) \r
+ dup adjacencies-valid>> \r
+ [ find-adjacencies ] unless \r
+ ensure-silhouettes\r
+ ;\r
+\r
+: (non-empty-solid?) ( solid -- ? ) \r
+ [ dimension>> ] [ corners>> length ] bi < ;\r
+: non-empty-solid? ( solid -- ? ) \r
+ ensure-adjacencies (non-empty-solid?) ;\r
+\r
+: compare-corners-roughly ( corner corner -- ? )\r
+ 2drop t ;\r
+! : remove-inner-faces ( -- ) ;\r
+: face-project ( array face -- seq )\r
+ backface? \r
+ [ 2drop f ]\r
+ [ [ enlight-projection ] \r
+ [ initiate-solid-from-face ]\r
+ [ intersections-into-faces ] tri\r
+ >>faces\r
+ swap >>color \r
+ ] if ;\r
+\r
+: solid-project ( lights ambient solid -- solids )\r
+ ensure-adjacencies\r
+ [ color>> ] [ faces>> ] bi [ 3array ] dip\r
+ [ face-project ] with map \r
+ [ ] filter \r
+ [ ensure-adjacencies ] map\r
+;\r
+\r
+: (solid-move) ( solid v move -- solid ) \r
+ curry [ map ] curry \r
+ [ dup faces>> ] dip call drop \r
+ unvalid-adjacencies ; inline\r
+\r
+: solid-translate ( solid v -- solid ) \r
+ [ face-translate ] (solid-move) ; \r
+: solid-transform ( solid m -- solid ) \r
+ [ face-transform ] (solid-move) ; \r
+\r
+: find-corner-in-silhouette ( s1 s2 -- elt bool )\r
+ pv> swap silhouettes>> nth \r
+ swap corners>>\r
+ [ point-inside-solid? ] with find swap ;\r
+\r
+: valid-face-for-order ( solid point -- face )\r
+ [ point-inside-face? not ] \r
+ [ drop face-orientation 0 = not ] 2bi and ;\r
+\r
+: check-orientation ( s1 s2 pt -- int )\r
+ [ nip faces>> ] dip\r
+ [ valid-face-for-order ] curry find swap\r
+ [ face-orientation ] [ drop f ] if ;\r
+\r
+: (order-solid) ( s1 s2 -- int )\r
+ 2dup find-corner-in-silhouette\r
+ [ check-orientation ] [ 3drop f ] if ;\r
+\r
+: order-solid ( solid solid -- i ) \r
+ 2dup (order-solid)\r
+ [ 2nip ]\r
+ [ swap (order-solid)\r
+ [ neg ] [ f ] if*\r
+ ] if* ;\r
+\r
+: subtract ( solid1 solid2 -- solids )\r
+ faces>> swap clone ensure-adjacencies ensure-silhouettes \r
+ [ swap slice-solid drop ] curry map\r
+ [ non-empty-solid? ] filter\r
+ [ ensure-adjacencies ] map\r
+; inline\r
+\r
+! -------------------------------------------------------------\r
+! space \r
+! -------------------------------------------------------------\r
+TUPLE: space name dimension solids ambient-color lights ;\r
+: <space> ( -- space ) space new ;\r
+: suffix-solids ( space solid -- space ) \r
+ [ suffix ] curry change-solids ; inline\r
+: suffix-lights ( space light -- space ) \r
+ [ suffix ] curry change-lights ; inline\r
+: clear-space-solids ( space -- space ) f >>solids ;\r
+\r
+: space-ensure-solids ( space -- space ) \r
+ [ [ ensure-adjacencies ] map ] change-solids ;\r
+: eliminate-empty-solids ( space -- space ) \r
+ [ [ non-empty-solid? ] filter ] change-solids ;\r
+\r
+: projected-space ( space solids -- space ) \r
+ swap dimension>> 1 - <space> \r
+ swap >>dimension swap >>solids ;\r
+\r
+: get-silhouette ( solid -- silhouette ) \r
+ silhouettes>> pv> swap nth ;\r
+: solid= ( solid solid -- ? ) [ corners>> ] bi@ = ;\r
+\r
+: space-apply ( space m quot -- space ) \r
+ curry [ map ] curry [ dup solids>> ] dip\r
+ [ call ] [ 2drop ] recover drop ; inline\r
+: space-transform ( space m -- space ) \r
+ [ solid-transform ] space-apply ;\r
+: space-translate ( space v -- space ) \r
+ [ solid-translate ] space-apply ; \r
+\r
+: describe-space ( space -- ) \r
+ solids>> \r
+ [ [ corners>> [ pprint ] each ] [ name>> . ] bi ] each ;\r
+\r
+: clip-solid ( solid solid -- solids )\r
+ [ ]\r
+ [ solid= not ]\r
+ [ order-solid -1 = ] 2tri \r
+ and\r
+ [ get-silhouette subtract ] \r
+ [ drop 1array ] \r
+ if \r
+ \r
+ ;\r
+\r
+: (solids-silhouette-subtract) ( solids solid -- solids ) \r
+ [ clip-solid append ] curry { } -rot each ; inline\r
+\r
+: solids-silhouette-subtract ( solids i solid -- solids )\r
+! solids is an array of 1 solid arrays\r
+ [ (solids-silhouette-subtract) ] curry map-but \r
+; inline \r
+\r
+: remove-hidden-solids ( space -- space ) \r
+! We must include each solid in a sequence because \r
+! during substration \r
+! a solid can be divided in more than on solid\r
+ [ \r
+ [ [ 1array ] map ] \r
+ [ length ] \r
+ [ ] \r
+ tri \r
+ [ solids-silhouette-subtract ] 2each\r
+ { } [ append ] reduce \r
+ ] change-solids\r
+ eliminate-empty-solids ! TODO include into change-solids\r
+;\r
+\r
+: space-project ( space i -- space )\r
+ [\r
+ [ clone \r
+ remove-hidden-solids? [ remove-hidden-solids ] when\r
+ dup \r
+ [ solids>> ] \r
+ [ lights>> ] \r
+ [ ambient-color>> ] tri \r
+ [ rot solid-project ] 2curry \r
+ map \r
+ [ append ] { } -rot each \r
+ ! TODO project lights\r
+ projected-space \r
+ ! remove-inner-faces \r
+ ! \r
+ eliminate-empty-solids\r
+ ] with-pv \r
+ ] [ 3drop <space> ] recover\r
+ ; inline\r
+\r
+: middle-of-space ( space -- point )\r
+ solids>> [ corners>> ] map concat\r
+ [ [ ] [ v+ ] map-reduce ] [ length ] bi v/n\r
+;\r
+\r
+! -------------------------------------------------------------\r
+! 3D rendering\r
+! -------------------------------------------------------------\r
+\r
+: face-reference ( face -- halfspace point vect )\r
+ [ halfspace>> ] \r
+ [ touching-corners>> first ] \r
+ [ touching-corners>> second ] tri \r
+ over v-\r
+;\r
+\r
+: theta ( v halfspace point vect -- v x )\r
+ [ [ over ] dip v- ] dip \r
+ [ cross dup norm >float ]\r
+ [ v. >float ] \r
+ 2bi \r
+ fatan2\r
+ -rot v. \r
+ 0 < [ neg ] when\r
+;\r
+\r
+: ordered-face-points ( face -- corners ) \r
+ [ touching-corners>> 1 head ] \r
+ [ touching-corners>> 1 tail ] \r
+ [ face-reference [ theta ] 3curry ] tri\r
+ { } map>assoc sort-values keys \r
+ append\r
+ ; inline\r
+\r
+: point->GL ( point -- ) gl-vertex ;\r
+: points->GL ( array -- ) do-cycle [ point->GL ] each ;\r
+\r
+: face->GL ( face color -- )\r
+ [ ordered-face-points ] dip\r
+ [ first3 1.0 glColor4d GL_POLYGON \r
+ [ [ point->GL ] each ] do-state ] curry\r
+ [ 0 0 0 1 glColor4d GL_LINE_LOOP \r
+ [ [ point->GL ] each ] do-state ]\r
+ bi\r
+ ; inline\r
+\r
+: solid->GL ( solid -- ) \r
+ [ faces>> ] \r
+ [ color>> ] bi\r
+ [ face->GL ] curry each ; inline\r
+\r
+: space->GL ( space -- )\r
+ solids>>\r
+ [ solid->GL ] each ;\r
+\r
+\r
+\r
+\r
+\r
--- /dev/null
+! : init-4D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 4 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 100 150 } "4cube1" 4cube suffix-solids\r
+ { 160 180 160 180 160 180 160 180 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+! : init-3D-demo ( -- space )\r
+! OK\r
+! espace de dimension 4 et de couleur 0,3 0.3 0.3\r
+<space> \r
+ 3 >>dimension\r
+ { 0.3 0.3 0.3 } >>ambient-color\r
+ { 100 150 100 150 100 150 } "3cube1" 3cube suffix-solids\r
+ ! { -150 -10 -150 -10 -150 -10 -150 -10 } "4cube2" 4cube suffix-solids\r
+ <light>\r
+ { -100 -100 -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+! ;\r
+\r
+\r
+: s1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "s1" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+: solid1 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid1" >>name\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+: solid2 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid2" >>name\r
+ { -1 1 -10 } cut-solid \r
+ { -1 -1 -28 } cut-solid \r
+ { 1 0 13 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid3 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid3" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 16 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ! { 1 2 16 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+\r
+;\r
+\r
+: solid4 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid4" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 21 } cut-solid \r
+ { -1 0 -36 } cut-solid \r
+ { 0 1 1 } cut-solid \r
+ { 0 -1 -17 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid5 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid5" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 6 } cut-solid \r
+ { -1 0 -17 } cut-solid \r
+ { 0 1 17 } cut-solid \r
+ { 0 -1 -19 } cut-solid \r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid7 ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ "solid7" >>name\r
+ { 1 1 1 } >>color\r
+ { 1 0 38 } cut-solid \r
+ { 1 -5 -66 } cut-solid \r
+ { -2 1 -75 } cut-solid\r
+ ensure-adjacencies\r
+ \r
+;\r
+\r
+: solid6s ( -- seq )\r
+ solid3 clone solid2 clone subtract\r
+;\r
+\r
+: space1 ( -- space )\r
+ <space>\r
+ 2 >>dimension\r
+ ! solid3 suffix-solids\r
+ solid1 suffix-solids\r
+ solid2 suffix-solids\r
+ ! solid6s [ suffix-solids ] each \r
+ solid4 suffix-solids\r
+ ! solid5 suffix-solids\r
+ solid7 suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+;\r
+\r
+: space2 ( -- space )\r
+ <space>\r
+ 4 >>dimension\r
+ ! 4cube suffix-solids\r
+ { 1 1 1 } >>ambient-color\r
+ <light>\r
+ { -100 -100 } >>position\r
+ { 0.2 0.7 0.1 } >>color\r
+ suffix-lights\r
+\r
+ ;\r
+\r
--- /dev/null
+Jeff Bigot\r
+Greg Ferrar
\ No newline at end of file
--- /dev/null
+JF Bigot, after Greg Ferrar
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.combinators
+
+HELP: among
+{ $values
+ { "array" array } { "n" "number of value to select" }
+ { "array" array }
+}
+{ $description "returns an array containings every possibilities of n choices among a given sequence" } ;
+
+HELP: columnize
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "flip a sequence into a sequence of 1 element sequences" } ;
+
+HELP: concat-nth
+{ $values
+ { "seq1" sequence } { "seq2" sequence }
+ { "seq" sequence }
+}
+{ $description "merges 2 sequences of sequences appending corresponding elements" } ;
+
+HELP: do-cycle
+{ $values
+ { "array" array }
+ { "array" array }
+}
+{ $description "Copy the first element at the end of the sequence in order to close the cycle." } ;
+
+
+ARTICLE: "adsoda.combinators" "Combinators"
+{ $vocab-link "adsoda.combinators" }
+;
+
+ABOUT: "adsoda.combinators"
--- /dev/null
+USING: adsoda.combinators\r
+sequences\r
+ tools.test \r
+ ;\r
+\r
+IN: adsoda.combinators.tests\r
+\r
+\r
+[ { "atoto" "b" "ctoto" } ] [ { "a" "b" "c" } 1 [ "toto" append ] map-but ] \r
+ unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel arrays sequences fry math combinators ;\r
+\r
+IN: adsoda.combinators\r
+\r
+! : (combinations) ( seq -- seq ) [ 1 tail ] dip combinations ;\r
+\r
+! : prefix-each [ prefix ] curry map ; inline\r
+\r
+! : combinations ( seq n -- seqs )\r
+! {\r
+! { [ dup 0 = ] [ 2drop { { } } ] }\r
+! { [ over empty? ] [ 2drop { } ] }\r
+! { [ t ] [ \r
+! [ [ 1 - (combinations) ] [ drop first ] 2bi prefix-each ]\r
+! [ (combinations) ] 2bi append\r
+! ] }\r
+! } cond ;\r
+\r
+: columnize ( array -- array ) [ 1array ] map ; inline\r
+\r
+: among ( array n -- array )\r
+ 2dup swap length \r
+ {\r
+ { [ over 1 = ] [ 3drop columnize ] }\r
+ { [ over 0 = ] [ 2drop 2drop { } ] }\r
+ { [ 2dup < ] [ 2drop [ 1 cut ] dip \r
+ [ 1 - among [ append ] with map ] \r
+ [ among append ] 2bi\r
+ ] }\r
+ { [ 2dup = ] [ 3drop 1array ] }\r
+ { [ 2dup > ] [ 2drop 2drop { } ] } \r
+ } cond\r
+;\r
+\r
+: concat-nth ( seq1 seq2 -- seq ) \r
+ [ nth append ] curry map-index ;\r
+\r
+: do-cycle ( array -- array ) dup first suffix ;\r
+\r
+: map-but ( seq i quot -- seq )\r
+ ! quot : ( seq x -- seq )\r
+ '[ _ = [ @ ] unless ] map-index ; inline\r
+\r
--- /dev/null
+USING: kernel\r
+sequences\r
+namespaces\r
+\r
+math\r
+math.vectors\r
+math.matrices\r
+;\r
+IN: adsoda.solution2\r
+\r
+! -------------------\r
+! correctif solution\r
+! ---------------\r
+SYMBOL: matrix\r
+: MIN-VAL-adsoda ( -- x ) 0.00000001\r
+! 0.000000000001 \r
+;\r
+\r
+: zero? ( x -- ? ) \r
+ abs MIN-VAL-adsoda <\r
+;\r
+\r
+! [ number>string string>number ] map \r
+\r
+: with-matrix ( matrix quot -- )\r
+ [ swap matrix set call matrix get ] with-scope ; inline\r
+\r
+: nth-row ( row# -- seq ) matrix get nth ;\r
+\r
+: change-row ( row# quot -- seq ) ! row# quot -- | quot: seq -- seq )\r
+ matrix get swap change-nth ; inline\r
+\r
+: exchange-rows ( row# row# -- ) matrix get exchange ;\r
+\r
+: rows ( -- n ) matrix get length ;\r
+\r
+: cols ( -- n ) 0 nth-row length ;\r
+\r
+: skip ( i seq quot -- n )\r
+ over [ find-from drop ] dip length or ; inline\r
+\r
+: first-col ( row# -- n )\r
+ #! First non-zero column\r
+ 0 swap nth-row [ zero? not ] skip ;\r
+\r
+: clear-scale ( col# pivot-row i-row -- n )\r
+ [ over ] dip nth dup zero? [\r
+ 3drop 0\r
+ ] [\r
+ [ nth dup zero? ] dip swap [\r
+ 2drop 0\r
+ ] [\r
+ swap / neg\r
+ ] if\r
+ ] if ;\r
+\r
+: (clear-col) ( col# pivot-row i -- )\r
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;\r
+\r
+: rows-from ( row# -- slice )\r
+ rows dup <slice> ;\r
+\r
+: clear-col ( col# row# rows -- )\r
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;\r
+\r
+: do-row ( exchange-with row# -- )\r
+ [ exchange-rows ] keep\r
+ [ first-col ] keep\r
+ dup 1 + rows-from clear-col ;\r
+\r
+: find-row ( row# quot -- i elt )\r
+ [ rows-from ] dip find ; inline\r
+\r
+: pivot-row ( col# row# -- n )\r
+ [ dupd nth-row nth zero? not ] find-row 2nip ;\r
+\r
+: (echelon) ( col# row# -- )\r
+ over cols < over rows < and [\r
+ 2dup pivot-row [ over do-row 1 + ] when*\r
+ [ 1 + ] dip (echelon)\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: echelon ( matrix -- matrix' )\r
+ [ 0 0 (echelon) ] with-matrix ;\r
+\r
+: nonzero-rows ( matrix -- matrix' )\r
+ [ [ zero? ] all? not ] filter ;\r
+\r
+: null/rank ( matrix -- null rank )\r
+ echelon dup length swap nonzero-rows length [ - ] keep ;\r
+\r
+: leading ( seq -- n elt ) [ zero? not ] find ;\r
+\r
+: reduced ( matrix' -- matrix'' )\r
+ [\r
+ rows <reversed> [\r
+ dup nth-row leading drop\r
+ dup [ swap dup clear-col ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix ;\r
+\r
+: basis-vector ( row col# -- )\r
+ [ clone ] dip\r
+ [ swap nth neg recip ] 2keep\r
+ [ 0 spin set-nth ] 2keep\r
+ [ n*v ] dip\r
+ matrix get set-nth ;\r
+\r
+: nullspace ( matrix -- seq )\r
+ echelon reduced dup empty? [\r
+ dup first length identity-matrix [\r
+ [\r
+ dup leading drop\r
+ dup [ basis-vector ] [ 2drop ] if\r
+ ] each\r
+ ] with-matrix flip nonzero-rows\r
+ ] unless ;\r
+\r
+: 1-pivots ( matrix -- matrix )\r
+ [ dup leading nip [ recip v*n ] when* ] map ;\r
+\r
+: solution ( matrix -- matrix )\r
+ echelon nonzero-rows reduced 1-pivots ;\r
+\r
--- /dev/null
+A modification of solution to approximate solutions
\ No newline at end of file
--- /dev/null
+ADSODA : Arbitrary-Dimensional Solid Object Display Algorithm
\ No newline at end of file
--- /dev/null
+adsoda 4D viewer
\ No newline at end of file
--- /dev/null
+Jeff Bigot
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays help.markup help.syntax kernel sequences ;
+IN: adsoda.tools
+
+HELP: 3cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax"
+"returns a 3D solid with given limits"
+} ;
+
+HELP: 4cube
+{ $values
+ { "array" "array" } { "name" "name" }
+ { "solid" "solid" }
+}
+{ $description "array : xmin xmax ymin ymax zmin zmax wmin wmax"
+"returns a 4D solid with given limits"
+} ;
+
+
+HELP: equation-system-for-normal
+{ $values
+ { "points" "a list of n points" }
+ { "matrix" "matrix" }
+}
+{ $description "From a list of points, return the matrix"
+"to solve in order to find the vector normal to the plan defined by the points" }
+;
+
+HELP: normal-vector
+{ $values
+ { "points" "a list of n points" }
+ { "v" "a vector" }
+}
+{ $description "From a list of points, returns the vector normal to the plan defined by the points"
+"With n points, creates n-1 vectors and then find a vector orthogonal to every others"
+"returns { f } if a normal vector can not be found" }
+;
+
+HELP: points-to-hyperplane
+{ $values
+ { "points" "a list of n points" }
+ { "hyperplane" "an hyperplane equation" }
+}
+{ $description "From a list of points, returns the equation of the hyperplan"
+"Finds a normal vector and then translate it so that it includes one of the points"
+
+}
+;
+
+ARTICLE: "adsoda.tools" "Tools"
+{ $vocab-link "adsoda.tools" }
+"Tools to help in building an " { $vocab-link "adsoda" } "-space"
+;
+
+ABOUT: "adsoda.tools"
+
+
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+adsoda.tools\r
+tools.test\r
+;\r
+\r
+IN: adsoda.tools.tests\r
+\r
+\r
+ [ { 1 0 } ] [ { { 0 0 } { 0 1 } } normal-vector ] unit-test\r
+ [ f ] [ { { 0 0 } { 0 0 } } normal-vector ] unit-test\r
+\r
+ [ { 1/2 1/2 1+1/2 } ] [ { { 1 2 } { 2 1 } } points-to-hyperplane ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Jeff Bigot\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: \r
+kernel\r
+sequences\r
+math\r
+accessors\r
+adsoda\r
+math.vectors \r
+math.matrices\r
+bunny.model\r
+io.encodings.ascii\r
+io.files\r
+sequences.deep\r
+combinators\r
+adsoda.combinators\r
+fry\r
+io.files.temp\r
+grouping\r
+;\r
+\r
+IN: adsoda.tools\r
+\r
+\r
+\r
+\r
+\r
+! ---------------------------------\r
+: coord-min ( x array -- array ) swap suffix ;\r
+: coord-max ( x array -- array ) swap neg suffix ;\r
+\r
+: 4cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 4 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 0 } coord-min ] [ { -1 0 0 0 } coord-max ] \r
+ [ { 0 1 0 0 } coord-min ] [ { 0 -1 0 0 } coord-max ]\r
+ [ { 0 0 1 0 } coord-min ] [ { 0 0 -1 0 } coord-max ] \r
+ [ { 0 0 0 1 } coord-min ] [ { 0 0 0 -1 } coord-max ]\r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+: 3cube ( array name -- solid )\r
+! array : xmin xmax ymin ymax zmin zmax wmin wmax\r
+ <solid> \r
+ 3 >>dimension\r
+ swap >>name\r
+ swap\r
+ { \r
+ [ { 1 0 0 } coord-min ] [ { -1 0 0 } coord-max ] \r
+ [ { 0 1 0 } coord-min ] [ { 0 -1 0 } coord-max ]\r
+ [ { 0 0 1 } coord-min ] [ { 0 0 -1 } coord-max ] \r
+ }\r
+ [ curry call ] 2map \r
+ [ cut-solid ] each \r
+ ensure-adjacencies\r
+ \r
+; inline\r
+\r
+\r
+: equation-system-for-normal ( points -- matrix )\r
+ unclip [ v- 0 suffix ] curry map\r
+ dup first [ drop 1 ] map suffix\r
+;\r
+\r
+: normal-vector ( points -- v ) \r
+ equation-system-for-normal\r
+ intersect-hyperplanes ;\r
+\r
+: points-to-hyperplane ( points -- hyperplane )\r
+ [ normal-vector 0 suffix ] [ first ] bi\r
+ translate ;\r
+\r
+: refs-to-points ( points faces -- faces )\r
+ [ swap [ nth 10 v*n { 100 100 100 } v+ ] curry map ] \r
+ with map\r
+;\r
+! V{ { 0.1 0.2 } { 1.1 1.3 } } V{ { 1 0 } { 0 1 } }\r
+! V{ { { 1.1 1.3 } { 0.1 0.2 } } { { 0.1 0.2 } { 1.1 1.3 } } }\r
+\r
+: ply-model-path ( -- path )\r
+\r
+! "bun_zipper.ply" \r
+"screw2.ply"\r
+temp-file \r
+;\r
+\r
+: read-bunny-model ( -- v )\r
+ply-model-path ascii [ parse-model ] with-file-reader\r
+\r
+refs-to-points\r
+;\r
+\r
+: 3points-to-normal ( seq -- v )\r
+ unclip [ v- ] curry map first2 cross normalize\r
+;\r
+: 2-faces-to-prism ( seq seq -- seq )\r
+ 2dup\r
+ [ do-cycle 2 clump ] bi@ concat-nth \r
+ ! 3 faces rectangulaires\r
+ swap prefix\r
+ swap prefix\r
+; \r
+\r
+: Xpoints-to-prisme ( seq height -- cube )\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube of height "height"\r
+ ! and of based on the three points\r
+ ! a face is a group of 3 or mode points. \r
+ [ dup dup 3points-to-normal ] dip \r
+ v*n [ v+ ] curry map ! 2 eme face triangulaire \r
+ 2-faces-to-prism \r
+\r
+! [ dup number? [ 1 + ] when ] deep-map\r
+! dup keep \r
+;\r
+\r
+\r
+: Xpoints-to-plane4D ( seq x y -- 4Dplane )\r
+ ! from 3 points gives a list of faces representing \r
+ ! a cube in 4th dim\r
+ ! from x to y (height = y-x)\r
+ ! and of based on the X points\r
+ ! a face is a group of 3 or mode points. \r
+ '[ [ [ _ suffix ] map ] [ [ _ suffix ] map ] bi ] call\r
+ 2-faces-to-prism\r
+;\r
+\r
+: 3pointsfaces-to-3Dsolidfaces ( seq -- seq )\r
+ [ 1 Xpoints-to-prisme [ 100 \r
+ 110 Xpoints-to-plane4D ] map concat ] map \r
+\r
+;\r
+\r
+: test-figure ( -- solid )\r
+ <solid> \r
+ 2 >>dimension\r
+ { 1 -1 -5 } cut-solid \r
+ { -1 -1 -21 } cut-solid \r
+ { -1 0 -12 } cut-solid \r
+ { 1 2 16 } cut-solid\r
+;\r
+\r
scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
SYNTAX: UNADVISE:
- scan-word parsed \ unadvise parsed ;
+ scan-word suffix! \ unadvise suffix! ;
+++ /dev/null
-Eduardo Cavazos
+++ /dev/null
-
-USING: kernel math math.functions tools.test combinators.cleave ;
-
-IN: combinators.cleave.tests
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: unit-test* ( input output -- ) swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
-
-[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
-
-[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
-
-[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
-
+++ /dev/null
-
-USING: kernel combinators words quotations arrays sequences locals macros
- shuffle generalizations fry ;
-
-IN: combinators.cleave
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
-
-: >quots ( seq -- seq ) [ >quot ] map ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: [ncleave] ( SEQ N -- quot )
- SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
-
-MACRO: ncleave ( seq n -- quot ) [ncleave] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Cleave into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: [narr] ( seq n -- quot ) over length '[ _ _ ncleave _ narray ] ;
-
-MACRO: narr ( seq n -- array ) [narr] ;
-
-MACRO: 0arr ( seq -- array ) 0 [narr] ;
-MACRO: 1arr ( seq -- array ) 1 [narr] ;
-MACRO: 2arr ( seq -- array ) 2 [narr] ;
-MACRO: 3arr ( seq -- array ) 3 [narr] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ cleave _ narray ] ;
-
-MACRO: <2arr> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ 2cleave _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {1} ( x -- {x} ) 1array ; inline
-: {2} ( x y -- {x,y} ) 2array ; inline
-: {3} ( x y z -- {x,y,z} ) 3array ; inline
-
-: {n} narray ;
-
-: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
-
-: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Spread into array
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: <arr*> ( seq -- )
- [ >quots ] [ length ] bi
- '[ _ spread _ narray ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
-: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
+++ /dev/null
-
-USING: combinators.cleave fry kernel macros parser quotations ;
-
-IN: combinators.cleave.enhanced
-
-: \\
- scan-word literalize parsed
- scan-word literalize parsed ; parsing
-
-MACRO: bi ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ keep ] dip call ] ;
-
-MACRO: tri ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ keep ] dip keep ] dip call ] ;
-
-MACRO: bi* ( p q -- quot )
- [ >quot ] dip
- >quot
- '[ _ _ [ dip ] dip call ] ;
-
-MACRO: tri* ( p q r -- quot )
- [ >quot ] 2dip
- [ >quot ] dip
- >quot
- '[ _ _ _ [ [ 2dip ] dip dip ] dip call ] ;
-
+++ /dev/null
-
-USING: kernel combinators sequences macros fry newfx combinators.cleave ;
-
-IN: combinators.conditional
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MACRO: 1cond ( tbl -- )
- [ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
- [ cond ] prefix-on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
--- /dev/null
+
+USING: kernel assocs locals combinators
+ math math.functions system unicode.case ;
+
+IN: dns.cache.nx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nx-cache ( -- table ) H{ } ;
+
+: nx-cache-at ( name -- time ) >lower nx-cache at ;
+: nx-cache-delete-at ( name -- ) >lower nx-cache delete-at ;
+: nx-cache-set-at ( time name -- ) >lower nx-cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+:: non-existent-name? ( NAME -- ? )
+ [let | TIME [ NAME nx-cache-at ] |
+ {
+ { [ TIME f = ] [ f ] }
+ { [ TIME now <= ] [ NAME nx-cache-delete-at f ] }
+ { [ t ] [ t ] }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-non-existent-name ( NAME TTL -- )
+ [let | TIME [ TTL now + ] | TIME NAME nx-cache-set-at ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences assocs sets locals combinators
+ accessors system math math.functions unicode.case prettyprint
+ combinators.smart dns ;
+
+IN: dns.cache.rr
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: <entry> time data ;
+
+: now ( -- seconds ) millis 1000.0 / round >integer ;
+
+: expired? ( <entry> -- ? ) time>> now <= ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-cache-key ( obj -- key )
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cache ( -- table ) H{ } ;
+
+: cache-at ( obj -- ent ) make-cache-key cache at ;
+: cache-delete ( obj -- ) make-cache-key cache delete-at ;
+: cache-set-at ( ent obj -- ) make-cache-key cache set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-get ( OBJ -- rrs/f )
+ [let | ENT [ OBJ cache-at ] |
+ {
+ { [ ENT f = ] [ f ] }
+ { [ ENT expired? ] [ OBJ cache-delete f ] }
+ {
+ [ t ]
+ [
+ [let | NAME [ OBJ name>> ]
+ TYPE [ OBJ type>> ]
+ CLASS [ OBJ class>> ]
+ TTL [ ENT time>> now - ] |
+ ENT data>>
+ [| RDATA | T{ rr f NAME TYPE CLASS TTL RDATA } ]
+ map
+ ]
+ ]
+ }
+ }
+ cond
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: cache-add ( RR -- )
+ [let | ENT [ RR cache-at ]
+ TIME [ RR ttl>> now + ]
+ RDATA [ RR rdata>> ] |
+ {
+ { [ ENT f = ] [ T{ <entry> f TIME V{ RDATA } } RR cache-set-at ] }
+ { [ ENT expired? ] [ RR cache-delete RR cache-add ] }
+ { [ t ] [ TIME ENT (>>time) RDATA ENT data>> adjoin ] }
+ }
+ cond
+ ] ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel byte-arrays combinators strings arrays sequences splitting
+ grouping
+ math math.functions math.parser random
+ destructors
+ io io.binary io.sockets io.encodings.binary
+ accessors
+ combinators.smart
+ assocs
+ ;
+
+IN: dns
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: query name type class ;
+
+TUPLE: rr name type class ttl rdata ;
+
+TUPLE: hinfo cpu os ;
+
+TUPLE: mx preference exchange ;
+
+TUPLE: soa mname rname serial refresh retry expire minimum ;
+
+TUPLE: message
+ id qr opcode aa tc rd ra z rcode
+ question-section
+ answer-section
+ authority-section
+ additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: random-id ( -- id ) 2 16 ^ random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TYPE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: A NS MD MF CNAME SOA MB MG MR NULL WKS PTR HINFO MINFO MX TXT AAAA ;
+
+: type-table ( -- table )
+ {
+ { A 1 }
+ { NS 2 }
+ { MD 3 }
+ { MF 4 }
+ { CNAME 5 }
+ { SOA 6 }
+ { MB 7 }
+ { MG 8 }
+ { MR 9 }
+ { NULL 10 }
+ { WKS 11 }
+ { PTR 12 }
+ { HINFO 13 }
+ { MINFO 14 }
+ { MX 15 }
+ { TXT 16 }
+ { AAAA 28 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! CLASS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: IN CS CH HS ;
+
+: class-table ( -- table )
+ {
+ { IN 1 }
+ { CS 2 }
+ { CH 3 }
+ { HS 4 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! OPCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: QUERY IQUERY STATUS ;
+
+: opcode-table ( -- table )
+ {
+ { QUERY 0 }
+ { IQUERY 1 }
+ { STATUS 2 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! RCODE
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
+ REFUSED ;
+
+: rcode-table ( -- table )
+ {
+ { NO-ERROR 0 }
+ { FORMAT-ERROR 1 }
+ { SERVER-FAILURE 2 }
+ { NAME-ERROR 3 }
+ { NOT-IMPLEMENTED 4 }
+ { REFUSED 5 }
+ } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <message> ( -- message )
+ message new
+ random-id >>id
+ 0 >>qr
+ QUERY >>opcode
+ 0 >>aa
+ 0 >>tc
+ 1 >>rd
+ 0 >>ra
+ 0 >>z
+ NO-ERROR >>rcode
+ { } >>question-section
+ { } >>answer-section
+ { } >>authority-section
+ { } >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
+
+: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ;
+
+: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: uint8->ba ( n -- ba ) 1 >be ;
+: uint16->ba ( n -- ba ) 2 >be ;
+: uint32->ba ( n -- ba ) 4 >be ;
+: uint64->ba ( n -- ba ) 8 >be ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dn->ba ( dn -- ba ) "." split [ label->ba ] map concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: query->ba ( query -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: hinfo->ba ( rdata -- ba )
+ [ cpu>> label->ba ]
+ [ os>> label->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mx->ba ( rdata -- ba )
+ [ preference>> uint16->ba ]
+ [ exchange>> dn->ba ]
+ bi append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: soa->ba ( rdata -- ba )
+ [
+ {
+ [ mname>> dn->ba ]
+ [ rname>> dn->ba ]
+ [ serial>> uint32->ba ]
+ [ refresh>> uint32->ba ]
+ [ retry>> uint32->ba ]
+ [ expire>> uint32->ba ]
+ [ minimum>> uint32->ba ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rdata->ba ( type rdata -- ba )
+ swap
+ {
+ { CNAME [ dn->ba ] }
+ { HINFO [ hinfo->ba ] }
+ { MX [ mx->ba ] }
+ { NS [ dn->ba ] }
+ { PTR [ dn->ba ] }
+ { SOA [ soa->ba ] }
+ { A [ ip->ba ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->ba ( rr -- ba )
+ [
+ {
+ [ name>> dn->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
+ [ ttl>> uint32->ba ]
+ [
+ [ type>> ] [ rdata>> ] bi rdata->ba
+ [ length uint16->ba ] [ ] bi append
+ ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: header-bits-ba ( message -- ba )
+ [
+ {
+ [ qr>> 15 shift ]
+ [ opcode>> opcode-table at 11 shift ]
+ [ aa>> 10 shift ]
+ [ tc>> 9 shift ]
+ [ rd>> 8 shift ]
+ [ ra>> 7 shift ]
+ [ z>> 4 shift ]
+ [ rcode>> rcode-table at 0 shift ]
+ } cleave
+ ] sum-outputs uint16->ba ;
+
+: message->ba ( message -- ba )
+ [
+ {
+ [ id>> uint16->ba ]
+ [ header-bits-ba ]
+ [ question-section>> length uint16->ba ]
+ [ answer-section>> length uint16->ba ]
+ [ authority-section>> length uint16->ba ]
+ [ additional-section>> length uint16->ba ]
+ [ question-section>> [ query->ba ] map concat ]
+ [ answer-section>> [ rr->ba ] map concat ]
+ [ authority-section>> [ rr->ba ] map concat ]
+ [ additional-section>> [ rr->ba ] map concat ]
+ } cleave
+ ] output>array concat ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-single ( ba i -- n ) at ;
+: get-double ( ba i -- n ) dup 2 + subseq be> ;
+: get-quad ( ba i -- n ) dup 4 + subseq be> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: label-length ( ba i -- length ) get-single ;
+
+: skip-label ( ba i -- ba i ) 2dup label-length + 1 + ;
+
+: null-label? ( ba i -- ? ) get-single 0 = ;
+
+: get-label ( ba i -- label ) [ 1 + ] [ skip-label nip ] 2bi subseq >string ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bit-test ( a b -- ? ) bitand 0 = not ;
+
+: pointer? ( ba i -- ? ) get-single BIN: 11000000 bit-test ;
+
+: pointer ( ba i -- val ) get-double BIN: 0011111111111111 bitand ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: skip-name ( ba i -- ba i )
+ {
+ { [ 2dup null-label? ] [ 1 + ] }
+ { [ 2dup pointer? ] [ 2 + ] }
+ { [ t ] [ skip-label skip-name ] }
+ }
+ cond ;
+
+: get-name ( ba i -- name )
+ {
+ { [ 2dup null-label? ] [ 2drop "" ] }
+ { [ 2dup pointer? ] [ dupd pointer get-name ] }
+ {
+ [ t ]
+ [
+ [ get-label ]
+ [ skip-label get-name ]
+ 2bi
+ "." glue
+ ]
+ }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-query ( ba i -- query )
+ [ get-name ]
+ [
+ skip-name
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ 2bi
+ ]
+ 2bi query boa ;
+
+: skip-query ( ba i -- ba i ) skip-name 4 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-mx ( ba i -- mx ) [ get-double ] [ 2 + get-double ] 2bi mx boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-soa ( ba i -- soa )
+ {
+ [ get-name ]
+ [ skip-name get-name ]
+ [
+ skip-name
+ skip-name
+ {
+ [ 0 + get-quad ]
+ [ 4 + get-quad ]
+ [ 8 + get-quad ]
+ [ 12 + get-quad ]
+ [ 16 + get-quad ]
+ }
+ 2cleave
+ ]
+ }
+ 2cleave soa boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ip ( ba i -- ip ) dup 4 + subseq >array [ number>string ] map "." join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-ipv6 ( ba i -- ip )
+ dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rdata ( ba i type -- rdata )
+ {
+ { CNAME [ get-name ] }
+ { NS [ get-name ] }
+ { PTR [ get-name ] }
+ { MX [ get-mx ] }
+ { SOA [ get-soa ] }
+ { A [ get-ip ] }
+ { AAAA [ get-ipv6 ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr ( ba i -- rr )
+ [ get-name ]
+ [
+ skip-name
+ {
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
+ [ 4 + get-quad ]
+ [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
+ }
+ 2cleave
+ ]
+ 2bi rr boa ;
+
+: skip-rr ( ba i -- ba i ) skip-name 8 + 2dup get-double + 2 + ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-question-section ( ba i count -- seq ba i )
+ [ drop [ skip-query ] [ get-query ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-rr-section ( ba i count -- seq ba i )
+ [ drop [ skip-rr ] [ get-rr ] 2bi ] map -rot ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >> ( x n -- y ) neg shift ;
+
+: get-header-bits ( ba i -- qr opcode aa tc rd ra z rcode )
+ get-double
+ {
+ [ 15 >> BIN: 1 bitand ]
+ [ 11 >> BIN: 111 bitand opcode-table value-at ]
+ [ 10 >> BIN: 1 bitand ]
+ [ 9 >> BIN: 1 bitand ]
+ [ 8 >> BIN: 1 bitand ]
+ [ 7 >> BIN: 1 bitand ]
+ [ 4 >> BIN: 111 bitand ]
+ [ BIN: 1111 bitand rcode-table value-at ]
+ }
+ cleave ;
+
+: parse-message ( ba -- message )
+ 0
+ {
+ [ get-double ]
+ [ 2 + get-header-bits ]
+ [
+ 4 +
+ {
+ [ 8 + ]
+ [ 0 + get-double ]
+ [ 2 + get-double ]
+ [ 4 + get-double ]
+ [ 6 + get-double ]
+ }
+ 2cleave
+ {
+ [ get-question-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ [ get-rr-section ]
+ } spread
+ 2drop
+ ]
+ }
+ 2cleave message boa ;
+
+: ba->message ( ba -- message ) parse-message ;
+
+: with-message-bytes ( ba quot -- ) [ ba->message ] dip call message->ba ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-udp ( ba server -- ba )
+ f 0 <inet4> <datagram>
+ [
+ [ send ] [ receive drop ] bi
+ ]
+ with-disposal ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: send-receive-tcp ( ba server -- ba )
+ [ dup length 2 >be prepend ] [ ] bi*
+ binary
+ [
+ write flush
+ 2 read be> read
+ ]
+ with-client ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: >dns-inet4 ( obj -- inet4 )
+ dup string?
+ [ 53 <inet4> ]
+ [ ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ask-server ( message server -- message )
+ [ message->ba ] [ >dns-inet4 ] bi*
+ 2dup
+ send-receive-udp parse-message
+ dup tc>> 1 =
+ [ drop send-receive-tcp parse-message ]
+ [ nip nip ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq ) V{ } ;
+
+: dns-server ( -- server ) dns-servers random ;
+
+: ask ( message -- message ) dns-server ask-server ;
+
+: query->message ( query -- message ) <message> swap 1array >>question-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-query ( message -- query ) question-section>> first ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ERROR: name-error name ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name )
+ {
+ { [ dup empty? ] [ "." append ] }
+ { [ dup last CHAR: . = ] [ ] }
+ { [ t ] [ "." append ] }
+ }
+ cond ;
--- /dev/null
+
+USING: kernel sequences combinators accessors locals random
+ combinators.short-circuit
+ io.sockets
+ dns dns.util dns.cache.rr dns.cache.nx
+ dns.resolver ;
+
+IN: dns.forwarding
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: query->rrs ( QUERY -- rrs/f )
+ [let | RRS [ QUERY cache-get ] |
+ RRS
+ [ RRS ]
+ [
+ [let | NAME [ QUERY name>> ]
+ TYPE [ QUERY type>> ]
+ CLASS [ QUERY class>> ] |
+
+ [let | RRS/CNAME [ T{ query f NAME CNAME CLASS } cache-get ] |
+
+ RRS/CNAME f =
+ [ f ]
+ [
+ [let | RR/CNAME [ RRS/CNAME first ] |
+
+ [let | REAL-NAME [ RR/CNAME rdata>> ] |
+
+ [let | RRS [
+ T{ query f REAL-NAME TYPE CLASS } query->rrs
+ ] |
+
+ RRS
+ [ RRS/CNAME RRS append ]
+ [ f ]
+ if
+ ] ] ]
+ ]
+ if
+ ] ]
+ ]
+ if
+ ] ;
+
+:: answer-from-cache ( MSG -- msg/f )
+ [let | QUERY [ MSG message-query ] |
+
+ [let | NX [ QUERY name>> non-existent-name? ]
+ RRS [ QUERY query->rrs ] |
+
+ {
+ { [ NX ] [ MSG NAME-ERROR >>rcode ] }
+ { [ RRS ] [ MSG RRS >>answer-section ] }
+ { [ t ] [ f ] }
+ }
+ cond
+ ]
+ ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: message-soa ( message -- rr/soa )
+ authority-section>> [ type>> SOA = ] filter first ;
+
+! :: cache-message ( MSG -- msg )
+! MSG rcode>> NAME-ERROR =
+! [
+! [let | NAME [ MSG message-query name>> ]
+! TTL [ MSG message-soa ttl>> ] |
+! NAME TTL cache-non-existent-name
+! ]
+! ]
+! when
+! MSG answer-section>> [ cache-add ] each
+! MSG authority-section>> [ cache-add ] each
+! MSG additional-section>> [ cache-add ] each
+! MSG ;
+
+:: cache-message ( MSG -- msg )
+ MSG rcode>> NAME-ERROR =
+ [
+ [let | RR/SOA [ MSG
+ authority-section>>
+ [ type>> SOA = ] filter
+ dup empty? [ drop f ] [ first ] if ] |
+ RR/SOA
+ [
+ [let | NAME [ MSG message-query name>> ]
+ TTL [ MSG message-soa ttl>> ] |
+ NAME TTL cache-non-existent-name
+ ]
+ ]
+ when
+ ]
+ ]
+ when
+ MSG answer-section>> [ cache-add ] each
+ MSG authority-section>> [ cache-add ] each
+ MSG additional-section>> [ cache-add ] each
+ MSG ;
+
+! : answer-from-server ( msg servers -- msg ) random ask-server cache-message ;
+
+: answer-from-server ( msg servers -- msg ) ask-servers cache-message ;
+
+:: find-answer ( MSG SERVERS -- msg )
+ { [ MSG answer-from-cache ] [ MSG SERVERS answer-from-server ] } 0|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: start-server ( ADDR-SPEC SERVERS -- )
+
+ [let | SOCKET [ ADDR-SPEC <datagram> ] |
+
+ [
+ SOCKET receive-packet
+ [ parse-message SERVERS find-answer message->ba ]
+ change-data
+ respond
+ ]
+ forever
+
+ ] ;
--- /dev/null
+
+USING: kernel combinators sequences splitting math
+ io.files io.encodings.utf8 random dns.util ;
+
+IN: dns.misc
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: resolv-conf-servers ( -- seq )
+ "/etc/resolv.conf" utf8 file-lines
+ [ " " split ] map
+ [ first "nameserver" = ] filter
+ [ second ] map ;
+
+: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: domain-has-name? ( domain name -- ? )
+ {
+ { [ 2dup = ] [ 2drop t ] }
+ { [ 2dup longer? ] [ 2drop f ] }
+ { [ t ] [ cdr-name domain-has-name? ] }
+ }
+ cond ;
+
+: name-in-domain? ( name domain -- ? ) swap domain-has-name? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel accessors namespaces continuations
+ io io.sockets io.binary io.timeouts io.encodings.binary
+ destructors
+ locals strings sequences random prettyprint calendar dns dns.misc ;
+
+IN: dns.resolver
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: send-receive-udp ( BA SERVER -- ba )
+ T{ inet4 f f 0 } <datagram>
+ T{ duration { second 3 } } over set-timeout
+ [| SOCKET | BA SERVER SOCKET send SOCKET receive drop ]
+ with-disposal ;
+
+:: send-receive-tcp ( BA SERVER -- ba )
+ [let | BA [ BA length 2 >be BA append ] |
+ SERVER binary
+ [
+ T{ duration { second 3 } } input-stream get set-timeout
+ BA write flush 2 read be> read
+ ]
+ with-client ] ;
+
+:: send-receive-server ( BA SERVER -- msg )
+ [let | RESULT [ BA SERVER send-receive-udp parse-message ] |
+ RESULT tc>> 1 =
+ [ BA SERVER send-receive-tcp parse-message ]
+ [ RESULT ]
+ if ] ;
+
+: >dns-inet4 ( obj -- inet4 ) dup string? [ 53 <inet4> ] [ ] if ;
+
+:: send-receive-servers ( BA SERVERS -- msg )
+ SERVERS empty? [ "send-receive-servers: servers list empty" throw ] when
+ [let | SERVER [ SERVERS random >dns-inet4 ] |
+ ! if this throws an error ...
+ [ BA SERVER send-receive-server ]
+ ! we try with the other servers...
+ [ drop BA SERVER SERVERS remove send-receive-servers ]
+ recover ] ;
+
+:: ask-servers ( MSG SERVERS -- msg )
+ MSG message->ba SERVERS send-receive-servers ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fully-qualified ( name -- name ) dup "." tail? [ ] [ "." append ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-servers ( -- seq )
+ \ dns-servers get
+ [ ]
+ [ resolv-conf-servers \ dns-servers set dns-servers ]
+ if* ;
+
+! : dns-server ( -- server ) dns-servers random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dns-ip4 ( name -- ips )
+ fully-qualified
+ [let | MSG [ A IN query boa query->message dns-servers ask-servers ] |
+ MSG rcode>> NO-ERROR =
+ [ MSG answer-section>> [ type>> A = ] filter [ rdata>> ] map ]
+ [ "dns-ip: rcode = " MSG rcode>> unparse append throw ]
+ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel combinators sequences sets math threads namespaces continuations
+ debugger io io.sockets unicode.case accessors destructors
+ combinators.short-circuit combinators.smart
+ fry arrays
+ dns dns.util dns.misc ;
+
+IN: dns.server
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: records-var
+
+: records ( -- records ) records-var get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {name-type-class} ( obj -- array )
+ [ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
+
+: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: matching-rrs ( query -- rrs ) records [ rr=query? ] with filter ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: zones ( -- names ) records [ type>> NS = ] filter [ name>> ] map prune ;
+: my-zones ( -- names ) records [ type>> SOA = ] filter [ name>> ] map ;
+
+: delegated-zones ( -- names ) zones my-zones diff ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->zone
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->zone ( name -- zone/f )
+ zones sort-largest-first [ name-in-domain? ] with find nip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! name->authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! extract-names
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rr->rdata-names ( rr -- names/f )
+ {
+ { [ dup type>> NS = ] [ rdata>> 1array ] }
+ { [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
+ { [ dup type>> CNAME = ] [ rdata>> 1array ] }
+ { [ t ] [ drop f ] }
+ }
+ cond ;
+
+: extract-rdata-names ( message -- names )
+ [ answer-section>> ] [ authority-section>> ] bi append
+ [ rr->rdata-names ] map concat ;
+
+: extract-names ( message -- names )
+ [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-authority
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill-authority ( message -- message )
+ dup
+ extract-names [ name->authority ] map concat prune
+ over answer-section>> diff
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! fill-additional
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ;
+
+: fill-additional ( message -- message )
+ dup
+ extract-rdata-names [ name->rrs-a ] map concat prune
+ over answer-section>> diff
+ >>additional-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! query->rrs
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: query->rrs
+
+: matching-rrs? ( query -- rrs/f ) matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: matching-cname? ( query -- rrs/f )
+ [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
+ [ empty? not ]
+ [ first swap clone over rdata>> >>name query->rrs swap prefix ]
+ [ 2drop f ]
+ 1if ;
+
+: query->rrs ( query -- rrs/f ) { [ matching-rrs? ] [ matching-cname? ] } 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-answers
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: have-answers ( message -- message/f )
+ dup message-query query->rrs
+ [ empty? ]
+ [ 2drop f ]
+ [ >>answer-section fill-authority fill-additional ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! have-delegates?
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cdr-name ( name -- name ) dup CHAR: . index 1 + tail ;
+
+: is-soa? ( name -- ? ) SOA IN query boa matching-rrs empty? not ;
+
+: have-ns? ( name -- rrs/f )
+ NS IN query boa matching-rrs [ empty? ] [ drop f ] [ ] 1if ;
+
+: name->delegates ( name -- rrs-ns )
+ {
+ [ "" = { } and ]
+ [ is-soa? { } and ]
+ [ have-ns? ]
+ [ cdr-name name->delegates ]
+ }
+ 1|| ;
+
+: have-delegates ( message -- message/f )
+ dup message-query name>> name->delegates ! message rrs-ns
+ [ empty? ]
+ [ 2drop f ]
+ [
+ dup [ rdata>> A IN query boa matching-rrs ] map concat
+ ! message rrs-ns rrs-a
+ [ >>authority-section ]
+ [ >>additional-section ]
+ bi*
+ ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! outsize-zones
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: outside-zones ( message -- message/f )
+ dup message-query name>> name->zone f =
+ [ ]
+ [ drop f ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! is-nx
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: is-nx ( message -- message/f )
+ [ message-query name>> records [ name>> = ] with filter empty? ]
+ [
+ NAME-ERROR >>rcode
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section
+ ]
+ [ drop f ]
+ 1if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: none-of-type ( message -- message )
+ dup
+ message-query name>> name->zone SOA IN query boa matching-rrs
+ >>authority-section ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: find-answer ( message -- message )
+ {
+ [ have-answers ]
+ [ have-delegates ]
+ [ outside-zones ]
+ [ is-nx ]
+ [ none-of-type ]
+ }
+ 1|| ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (handle-request) ( packet -- )
+ [ [ find-answer ] with-message-bytes ] change-data respond ;
+
+: handle-request ( packet -- ) [ (handle-request) ] curry in-thread ;
+
+: receive-loop ( socket -- )
+ [ receive-packet handle-request ] [ receive-loop ] bi ;
+
+: loop ( addr-spec -- )
+ [ <datagram> '[ _ [ receive-loop ] with-disposal ] try ] [ loop ] bi ;
+
--- /dev/null
+
+USING: kernel sequences random accessors dns ;
+
+IN: dns.stub
+
+! Stub resolver
+!
+! Generally useful, but particularly when running a forwarding,
+! caching, nameserver on localhost with multiple Factor instances
+! querying it.
+
+: name->ip ( name -- ip )
+ A IN query boa
+ query->message
+ ask
+ dup rcode>> NAME-ERROR =
+ [ message-query name>> name-error ]
+ [ answer-section>> [ type>> A = ] filter random rdata>> ]
+ if ;
+
--- /dev/null
+
+USING: kernel sequences sorting math math.order macros fry ;
+
+IN: dns.util
+
+: tri-chain ( obj p q r -- x y z )
+ [ [ call dup ] dip call dup ] dip call ; inline
+
+MACRO: 1if ( test then else -- ) '[ dup @ _ _ if ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: sort-largest-first ( seq -- seq ) [ length ] sort-with reverse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: io.sockets accessors ;
+
+TUPLE: packet data addr socket ;
+
+: receive-packet ( socket -- packet ) [ receive ] keep packet boa ;
+
+: respond ( packet -- ) [ data>> ] [ addr>> ] [ socket>> ] tri send ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
vertices length ;
M: graph num-edges
- [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
+ [ vertices ] [ '[ _ adjlist length ] map-sum ] bi ;
M: graph adjlist
[ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
+++ /dev/null
-
-USING: kernel sequences assocs circular sets fry ;
-
-USING: math multi-methods ;
-
-QUALIFIED: sequences
-QUALIFIED: assocs
-QUALIFIED: circular
-QUALIFIED: sets
-
-IN: newfx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Now, we can see a new world coming into view.
-! A world in which there is the very real prospect of a new world order.
-!
-! - George Herbert Walker Bush
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at ( col key -- val )
-GENERIC: of ( key col -- val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: grab ( col key -- col val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is ( col key val -- col )
-GENERIC: as ( col val key -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is-of ( key val col -- col )
-GENERIC: as-of ( val key col -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: mutate-at ( col key val -- )
-GENERIC: mutate-as ( col val key -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at-mutate ( key val col -- )
-GENERIC: as-mutate ( val key col -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! sequence
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { sequence number } swap nth ;
-METHOD: of { number sequence } nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { sequence number } dupd swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { sequence number object } swap pick set-nth ;
-METHOD: as { sequence object number } pick set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { number object sequence } dup [ swapd set-nth ] dip ;
-METHOD: as-of { object number sequence } dup [ set-nth ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { sequence number object } swap rot set-nth ;
-METHOD: mutate-as { sequence object number } rot set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { number object sequence } swapd set-nth ;
-METHOD: as-mutate { object number sequence } set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! assoc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { assoc object } swap assocs:at ;
-METHOD: of { object assoc } assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { assoc object } dupd swap assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { assoc object object } swap pick set-at ;
-METHOD: as { assoc object object } pick set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { object object assoc } dup [ swapd set-at ] dip ;
-METHOD: as-of { object object assoc } dup [ set-at ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { assoc object object } swap rot set-at ;
-METHOD: mutate-as { assoc object object } rot set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { object object assoc } swapd set-at ;
-METHOD: as-mutate { object object assoc } set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push ( seq obj -- seq ) over sequences:push ;
-: push-on ( obj seq -- seq ) tuck sequences:push ;
-: pushed ( seq obj -- ) swap sequences:push ;
-: pushed-on ( obj seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: member? ( seq obj -- ? ) swap sequences:member? ;
-: member-of? ( obj seq -- ? ) sequences:member? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-at-key ( tbl key -- tbl ) over delete-at ;
-: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete ( seq elt -- seq ) over sequences:delete ;
-: delete-from ( elt seq -- seq ) tuck sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: deleted ( seq elt -- ) swap sequences:delete ;
-: deleted-from ( elt seq -- ) sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove ( seq obj -- seq ) swap sequences:remove ;
-: remove-from ( obj seq -- seq ) sequences:remove ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: filter-of ( quot seq -- seq ) swap filter ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map-over ( quot seq -- seq ) swap map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push-circular ( seq elt -- seq ) over circular:push-circular ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prefix-on ( elt seq -- seq ) swap prefix ;
-: suffix-on ( elt seq -- seq ) swap suffix ;
-
-: suffix! ( seq elt -- seq ) over sequences:push ;
-: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
-: suffixed! ( seq elt -- ) swap sequences:push ;
-: suffixed-on! ( elt seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: subseq ( seq from to -- subseq ) rot sequences:subseq ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key ( table val -- key ) swap assocs:value-at ;
-
-: key-of ( val table -- key ) assocs:value-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: index ( seq obj -- i ) swap sequences:index ;
-: index-of ( obj seq -- i ) sequences:index ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 1st ( seq -- obj ) 0 swap nth ;
-: 2nd ( seq -- obj ) 1 swap nth ;
-: 3rd ( seq -- obj ) 2 swap nth ;
-: 4th ( seq -- obj ) 3 swap nth ;
-: 5th ( seq -- obj ) 4 swap nth ;
-: 6th ( seq -- obj ) 5 swap nth ;
-: 7th ( seq -- obj ) 6 swap nth ;
-: 8th ( seq -- obj ) 7 swap nth ;
-: 9th ( seq -- obj ) 8 swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A note about the 'mutate' qualifier. Other words also technically mutate
-! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
-
-: adjoin ( seq elt -- seq ) over sets:adjoin ;
-: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
-: adjoined ( set elt -- ) swap sets:adjoin ;
-: adjoined-on ( elt set -- ) sets:adjoin ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( seq subseq -- i ) swap sequences:start ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pluck ( seq i -- seq ) cut-slice rest-slice append ;
-: pluck-from ( i seq -- seq ) swap pluck ;
-: pluck! ( seq i -- seq ) over delete-nth ;
-: pluck-from! ( i seq -- seq ) tuck delete-nth ;
-: plucked! ( seq i -- ) swap delete-nth ;
-: plucked-from! ( i seq -- ) delete-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: snip ( seq a b -- seq ) [ over ] dip [ head ] [ tail ] 2bi* append ;
-: snip-this ( a b seq -- seq ) -rot snip ;
-: snip! ( seq a b -- seq ) pick delete-slice ;
-: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
-: snipped! ( seq a b -- ) rot delete-slice ;
-: snipped-from! ( a b seq -- ) delete-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: invert-index ( seq i -- seq i ) [ dup length 1 - ] dip - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: append! ( a b -- ab ) over sequences:push-all ;
-: append-to! ( b a -- ab ) swap over sequences:push-all ;
-: appended! ( a b -- ) swap sequences:push-all ;
-: appended-to! ( b a -- ) sequences:push-all ;
-
-: prepend! ( a b -- ba ) over append 0 pick copy ;
-: prepended! ( a b -- ) over append 0 rot copy ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insert ( seq i obj -- seq ) [ cut ] dip prefix append ;
-
-: splice ( seq i seq -- seq ) [ cut ] dip prepend append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: purge ( seq quot -- seq ) [ not ] compose filter ; inline
-
-: purge! ( seq quot -- seq )
- dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline
aging_collector::aging_collector(factor_vm *parent_) :
copying_collector<aging_space,aging_policy>(
parent_,
- &parent_->gc_stats.aging_stats,
parent_->data->aging,
aging_policy(parent_)) {}
current_gc->op = collect_to_tenured_op;
to_tenured_collector collector(this);
+
+ current_gc->event->started_code_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
- simple_unmarker(card_mark_mask));
- collector.cheneys_algorithm();
+ full_unmarker());
+ current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+
+ current_gc->event->started_code_scan();
+ collector.trace_code_heap_roots(&code->points_to_aging);
+ current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+
+ collector.tenure_reachable_objects();
+
+ current_gc->event->started_code_sweep();
+ update_code_heap_for_minor_gc(&code->points_to_aging);
+ current_gc->event->ended_code_sweep();
}
{
/* If collection fails here, do a to_tenured collection. */
current_gc->op = collect_aging_op;
std::swap(data->aging,data->aging_semispace);
- reset_generation(data->aging);
+ data->reset_generation(data->aging);
aging_collector collector(this);
collector.trace_roots();
collector.trace_contexts();
- collector.trace_code_heap_roots(&code->points_to_aging);
+
collector.cheneys_algorithm();
- update_code_heap_for_minor_gc(&code->points_to_aging);
- nursery.here = nursery.start;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
+ code->points_to_aging.clear();
}
}
struct aging_policy {
factor_vm *parent;
- zone *aging, *tenured;
+ aging_space *aging;
+ tenured_space *tenured;
- aging_policy(factor_vm *parent_) :
+ explicit aging_policy(factor_vm *parent_) :
parent(parent_),
aging(parent->data->aging),
tenured(parent->data->tenured) {}
{
return !(aging->contains_p(untagged) || tenured->contains_p(untagged));
}
+
+ void promoted_object(object *obj) {}
+
+ void visited_object(object *obj) {}
};
struct aging_collector : copying_collector<aging_space,aging_policy> {
- aging_collector(factor_vm *parent_);
+ explicit aging_collector(factor_vm *parent_);
};
}
namespace factor
{
-struct aging_space : old_space {
- aging_space(cell size, cell start) : old_space(size,start) {}
+struct aging_space : bump_allocator<object> {
+ object_start_map starts;
+
+ explicit aging_space(cell size, cell start) :
+ bump_allocator<object>(size,start), starts(size,start) {}
+
+ object *allot(cell size)
+ {
+ if(here + size > end) return NULL;
+
+ object *obj = bump_allocator<object>::allot(size);
+ starts.record_object_start_offset(obj);
+ return obj;
+ }
};
}
alien *ptr = untag<alien>(obj);
if(to_boolean(ptr->expired))
general_error(ERROR_EXPIRED,obj,false_object,NULL);
- return pinned_alien_offset(ptr->base) + ptr->displacement;
+ if(to_boolean(ptr->base))
+ type_error(ALIEN_TYPE,obj);
+ else
+ return (char *)ptr->address;
}
case F_TYPE:
return NULL;
/* make an alien */
cell factor_vm::allot_alien(cell delegate_, cell displacement)
{
- gc_root<object> delegate(delegate_,this);
- gc_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
+ data_root<object> delegate(delegate_,this);
+ data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);
if(delegate.type_p(ALIEN_TYPE))
{
new_alien->displacement = displacement;
new_alien->expired = false_object;
+ new_alien->update_address();
return new_alien.value();
}
/* open a native library and push a handle */
void factor_vm::primitive_dlopen()
{
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
path.untag_check(this);
- gc_root<dll> library(allot<dll>(sizeof(dll)),this);
+ data_root<dll> library(allot<dll>(sizeof(dll)),this);
library->path = path.value();
ffi_dlopen(library.untagged());
dpush(library.value());
/* look up a symbol in a native library */
void factor_vm::primitive_dlsym()
{
- gc_root<object> library(dpop(),this);
- gc_root<byte_array> name(dpop(),this);
+ data_root<object> library(dpop(),this);
+ data_root<byte_array> name(dpop(),this);
name.untag_check(this);
symbol_char *sym = name->data<symbol_char>();
case BYTE_ARRAY_TYPE:
return untag<byte_array>(obj)->data<char>();
case ALIEN_TYPE:
- {
- alien *ptr = untag<alien>(obj);
- if(to_boolean(ptr->expired))
- general_error(ERROR_EXPIRED,obj,false_object,NULL);
- return alien_offset(ptr->base) + ptr->displacement;
- }
+ return (char *)untag<alien>(obj)->address;
case F_TYPE:
return NULL;
default:
--- /dev/null
+namespace factor
+{
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline object *factor_vm::allot_object(header header, cell size)
+{
+ /* If the object is smaller than the nursery, allocate it in the nursery,
+ after a GC if needed */
+ if(nursery.size > size)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + size > nursery.end)
+ primitive_minor_gc();
+
+ object *obj = nursery.allot(size);
+
+ obj->h = header;
+ return obj;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ return allot_large_object(header,size);
+}
+
+}
/* make a new array with an initial element */
array *factor_vm::allot_array(cell capacity, cell fill_)
{
- gc_root<object> fill(fill_,this);
- gc_root<array> new_array(allot_array_internal<array>(capacity),this);
-
- if(fill.value() == tag_fixnum(0))
- memset(new_array->data(),'\0',capacity * sizeof(cell));
- else
- {
- /* No need for write barrier here. Either the object is in
- the nursery, or it was allocated directly in tenured space
- and the write barrier is already hit for us in that case. */
- for(cell i = 0; i < capacity; i++)
- new_array->data()[i] = fill.value();
- }
- return new_array.untagged();
+ data_root<object> fill(fill_,this);
+ array *new_array = allot_uninitialized_array<array>(capacity);
+ memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
+ return new_array;
}
/* push a new array on the stack */
cell factor_vm::allot_array_1(cell obj_)
{
- gc_root<object> obj(obj_,this);
- gc_root<array> a(allot_array_internal<array>(1),this);
+ data_root<object> obj(obj_,this);
+ data_root<array> a(allot_uninitialized_array<array>(1),this);
set_array_nth(a.untagged(),0,obj.value());
return a.value();
}
cell factor_vm::allot_array_2(cell v1_, cell v2_)
{
- gc_root<object> v1(v1_,this);
- gc_root<object> v2(v2_,this);
- gc_root<array> a(allot_array_internal<array>(2),this);
+ data_root<object> v1(v1_,this);
+ data_root<object> v2(v2_,this);
+ data_root<array> a(allot_uninitialized_array<array>(2),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
return a.value();
cell factor_vm::allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
{
- gc_root<object> v1(v1_,this);
- gc_root<object> v2(v2_,this);
- gc_root<object> v3(v3_,this);
- gc_root<object> v4(v4_,this);
- gc_root<array> a(allot_array_internal<array>(4),this);
+ data_root<object> v1(v1_,this);
+ data_root<object> v2(v2_,this);
+ data_root<object> v3(v3_,this);
+ data_root<object> v4(v4_,this);
+ data_root<array> a(allot_uninitialized_array<array>(4),this);
set_array_nth(a.untagged(),0,v1.value());
set_array_nth(a.untagged(),1,v2.value());
set_array_nth(a.untagged(),2,v3.value());
void growable_array::add(cell elt_)
{
factor_vm *parent = elements.parent;
- gc_root<object> elt(elt_,parent);
+ data_root<object> elt(elt_,parent);
if(count == array_capacity(elements.untagged()))
elements = parent->reallot_array(elements.untagged(),count * 2);
void growable_array::append(array *elts_)
{
factor_vm *parent = elements.parent;
- gc_root<array> elts(elts_,parent);
+ data_root<array> elts(elts_,parent);
cell capacity = array_capacity(elts.untagged());
if(count + capacity > array_capacity(elements.untagged()))
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(array->h.hi_tag() == ARRAY_TYPE);
- check_tagged_pointer(value);
#endif
cell *slot_ptr = &array->data()[slot];
*slot_ptr = value;
struct growable_array {
cell count;
- gc_root<array> elements;
+ data_root<array> elements;
explicit growable_array(factor_vm *parent, cell capacity = 10) :
count(0), elements(parent->allot_array(capacity,false_object),parent) {}
bignum *factor_vm::allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum * result = allot_array_internal<bignum>(length + 1);
+ bignum * result = allot_uninitialized_array<bignum>(length + 1);
BIGNUM_SET_NEGATIVE_P (result, negative_p);
return (result);
}
--- /dev/null
+namespace factor
+{
+
+inline cell log2(cell x)
+{
+ cell n;
+#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
+ asm ("bsr %1, %0;":"=r"(n):"r"(x));
+#elif defined(FACTOR_PPC)
+ asm ("cntlzw %1, %0;":"=r"(n):"r"(x));
+ n = (31 - n);
+#else
+ #error Unsupported CPU
+#endif
+ return n;
+}
+
+inline cell rightmost_clear_bit(cell x)
+{
+ return log2(~x & (x + 1));
+}
+
+inline cell rightmost_set_bit(cell x)
+{
+ return log2(x & -x);
+}
+
+inline cell popcount(cell x)
+{
+#ifdef FACTOR_64
+ u64 k1 = 0x5555555555555555ll;
+ u64 k2 = 0x3333333333333333ll;
+ u64 k4 = 0x0f0f0f0f0f0f0f0fll;
+ u64 kf = 0x0101010101010101ll;
+ cell ks = 56;
+#else
+ u32 k1 = 0x55555555;
+ u32 k2 = 0x33333333;
+ u32 k4 = 0xf0f0f0f;
+ u32 kf = 0x1010101;
+ cell ks = 24;
+#endif
+
+ x = x - ((x >> 1) & k1); // put count of each 2 bits into those 2 bits
+ x = (x & k2) + ((x >> 2) & k2); // put count of each 4 bits into those 4 bits
+ x = (x + (x >> 4)) & k4 ; // put count of each 8 bits into those 8 bits
+ x = (x * kf) >> ks; // returns 8 most significant bits of x + (x<<8) + (x<<16) + (x<<24) + ...
+
+ return x;
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+template<typename Block> struct bump_allocator {
+ /* offset of 'here' and 'end' is hardcoded in compiler backends */
+ cell here;
+ cell start;
+ cell end;
+ cell size;
+
+ explicit bump_allocator(cell size_, cell start_) :
+ here(start_), start(start_), end(start_ + size_), size(size_) {}
+
+ bool contains_p(Block *block)
+ {
+ return ((cell)block - start) < size;
+ }
+
+ Block *allot(cell size)
+ {
+ cell h = here;
+ here = h + align(size,data_alignment);
+ return (Block *)h;
+ }
+
+ cell occupied_space()
+ {
+ return here - start;
+ }
+
+ cell free_space()
+ {
+ return end - here;
+ }
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((Block *)scan)->size();
+ if(scan + size < here)
+ return scan + size;
+ else
+ return 0;
+ }
+
+ cell first_object()
+ {
+ if(start != here)
+ return start;
+ else
+ return 0;
+ }
+};
+
+}
byte_array *factor_vm::allot_byte_array(cell size)
{
- byte_array *array = allot_array_internal<byte_array>(size);
+ byte_array *array = allot_uninitialized_array<byte_array>(size);
memset(array + 1,0,size);
return array;
}
void factor_vm::primitive_uninitialized_byte_array()
{
cell size = unbox_array_size();
- dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
+ dpush(tag<byte_array>(allot_uninitialized_array<byte_array>(size)));
}
void factor_vm::primitive_resize_byte_array()
void growable_byte_array::append_byte_array(cell byte_array_)
{
- gc_root<byte_array> byte_array(byte_array_,elements.parent);
+ data_root<byte_array> byte_array(byte_array_,elements.parent);
cell len = array_capacity(byte_array.untagged());
cell new_size = count + len;
struct growable_byte_array {
cell count;
- gc_root<byte_array> elements;
+ data_root<byte_array> elements;
explicit growable_byte_array(factor_vm *parent,cell capacity = 40) : count(0), elements(parent->allot_byte_array(capacity),parent) { }
void trim();
};
+template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value)
+{
+ return byte_array_from_values(value,1);
+}
+
+template<typename Type> byte_array *factor_vm::byte_array_from_values(Type *values, cell len)
+{
+ cell size = sizeof(Type) * len;
+ byte_array *data = allot_uninitialized_array<byte_array>(size);
+ memcpy(data->data<char>(),values,size);
+ return data;
+}
+
}
void callback_heap::update(callback *stub)
{
- tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
+ tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
cell rel_class = untag_fixnum(array_nth(code_template.untagged(),1));
cell offset = untag_fixnum(array_nth(code_template.untagged(),3));
callback *callback_heap::add(code_block *compiled)
{
- tagged<array> code_template(parent->userenv[CALLBACK_STUB]);
+ tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
tagged<byte_array> insns(array_nth(code_template.untagged(),0));
cell size = array_capacity(insns.untagged());
- cell bump = align8(size) + sizeof(callback);
+ cell bump = align(size,sizeof(cell)) + sizeof(callback);
if(here + bump > seg->end) fatal_error("Out of callback space",0);
callback *stub = (callback *)here;
stub->compiled = compiled;
memcpy(stub + 1,insns->data<void>(),size);
- stub->size = align8(size);
+ stub->size = align(size,sizeof(cell));
here += bump;
update(stub);
return (code_block *)frame->xt - 1;
}
-cell factor_vm::frame_type(stack_frame *frame)
+code_block_type factor_vm::frame_type(stack_frame *frame)
{
return frame_code(frame)->type();
}
{
switch(frame_type(frame))
{
- case QUOTATION_TYPE:
+ case code_block_unoptimized:
{
cell quot = frame_executing(frame);
if(to_boolean(quot))
else
return false_object;
}
- case WORD_TYPE:
+ case code_block_optimized:
return false_object;
default:
critical_error("Bad frame type",frame_type(frame));
void operator()(stack_frame *frame)
{
- gc_root<object> executing(parent->frame_executing(frame),parent);
- gc_root<object> scan(parent->frame_scan(frame),parent);
+ data_root<object> executing(parent->frame_executing(frame),parent);
+ data_root<object> scan(parent->frame_scan(frame),parent);
frames.add(executing.value());
frames.add(scan.value());
void factor_vm::primitive_callstack_to_array()
{
- gc_root<callstack> callstack(dpop(),this);
+ data_root<callstack> callstack(dpop(),this);
stack_frame_accumulator accum(this);
iterate_callstack_object(callstack.untagged(),accum);
void factor_vm::primitive_set_innermost_stack_frame_quot()
{
- gc_root<callstack> callstack(dpop(),this);
- gc_root<quotation> quot(dpop(),this);
+ data_root<callstack> callstack(dpop(),this);
+ data_root<quotation> quot(dpop(),this);
callstack.untag_check(this);
quot.untag_check(this);
keep the callstack in a GC root and use relative offsets */
template<typename Iterator> void factor_vm::iterate_callstack_object(callstack *stack_, Iterator &iterator)
{
- gc_root<callstack> stack(stack_,this);
+ data_root<callstack> stack(stack_,this);
fixnum frame_offset = untag_fixnum(stack->length) - sizeof(stack_frame);
while(frame_offset >= 0)
}
case ARRAY_TYPE:
{
- cell i;
array *names = untag<array>(symbol);
- for(i = 0; i < array_capacity(names); i++)
+ for(cell i = 0; i < array_capacity(names); i++)
{
symbol_char *name = alien_offset(array_nth(names,i));
void *sym = ffi_dlsym(d,name);
case RT_UNTAGGED:
return untag_fixnum(ARG);
case RT_MEGAMORPHIC_CACHE_HITS:
- return (cell)&megamorphic_cache_hits;
+ return (cell)&dispatch_stats.megamorphic_cache_hits;
case RT_VM:
return (cell)this + untag_fixnum(ARG);
case RT_CARDS_OFFSET:
if(parent->relocation_type_of(rel) == RT_IMMEDIATE)
{
cell offset = parent->relocation_offset_of(rel) + (cell)(compiled + 1);
- array *literals = parent->untag<array>(compiled->literals);
+ array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
parent->store_address_in_code_block(parent->relocation_class_of(rel),offset,absolute_value);
}
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
- else if(compiled->type() == PIC_TYPE)
+ else if(compiled->pic_p())
code->code_heap_free(compiled);
else
{
}
};
-void factor_vm::update_code_block_for_full_gc(code_block *compiled)
+void factor_vm::update_code_block_words_and_literals(code_block *compiled)
{
if(code->needs_fixup_p(compiled))
relocate_code_block(compiled);
}
/* Might GC */
-code_block *factor_vm::allot_code_block(cell size, cell type)
+code_block *factor_vm::allot_code_block(cell size, code_block_type type)
{
- heap_block *block = code->heap_allot(size + sizeof(code_block),type);
+ code_block *block = code->allocator->allot(size + sizeof(code_block));
/* If allocation failed, do a full GC and compact the code heap.
A full GC that occurs as a result of the data heap filling up does not
if(block == NULL)
{
primitive_compact_gc();
- block = code->heap_allot(size + sizeof(code_block),type);
+ block = code->allocator->allot(size + sizeof(code_block));
/* Insufficient room even after code GC, give up */
if(block == NULL)
{
- cell used, total_free, max_free;
- code->heap_usage(&used,&total_free,&max_free);
-
- print_string("Code heap stats:\n");
- print_string("Used: "); print_cell(used); nl();
- print_string("Total free space: "); print_cell(total_free); nl();
- print_string("Largest free block: "); print_cell(max_free); nl();
+ std::cout << "Code heap used: " << code->allocator->occupied_space() << "\n";
+ std::cout << "Code heap free: " << code->allocator->free_space() << "\n";
fatal_error("Out of memory in add-compiled-block",0);
}
}
- return (code_block *)block;
+ block->set_type(type);
+ return block;
}
/* Might GC */
-code_block *factor_vm::add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
+code_block *factor_vm::add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_)
{
- gc_root<byte_array> code(code_,this);
- gc_root<object> labels(labels_,this);
- gc_root<object> owner(owner_,this);
- gc_root<byte_array> relocation(relocation_,this);
- gc_root<array> literals(literals_,this);
+ data_root<byte_array> code(code_,this);
+ data_root<object> labels(labels_,this);
+ data_root<object> owner(owner_,this);
+ data_root<byte_array> relocation(relocation_,this);
+ data_root<array> literals(literals_,this);
- cell code_length = align8(array_capacity(code.untagged()));
+ cell code_length = array_capacity(code.untagged());
code_block *compiled = allot_code_block(code_length,type);
compiled->owner = owner.value();
--- /dev/null
+namespace factor
+{
+
+template<typename Visitor> struct call_frame_code_block_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit call_frame_code_block_visitor(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void operator()(stack_frame *frame)
+ {
+ cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
+
+ code_block *new_block = visitor(parent->frame_code(frame));
+ frame->xt = new_block->xt();
+
+ FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
+ }
+};
+
+template<typename Visitor> struct callback_code_block_visitor {
+ callback_heap *callbacks;
+ Visitor visitor;
+
+ explicit callback_code_block_visitor(callback_heap *callbacks_, Visitor visitor_) :
+ callbacks(callbacks_), visitor(visitor_) {}
+
+ void operator()(callback *stub)
+ {
+ stub->compiled = visitor(stub->compiled);
+ callbacks->update(stub);
+ }
+};
+
+template<typename Visitor> struct code_block_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit code_block_visitor(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void visit_object_code_block(object *obj)
+ {
+ switch(obj->h.hi_tag())
+ {
+ case WORD_TYPE:
+ {
+ word *w = (word *)obj;
+ if(w->code)
+ w->code = visitor(w->code);
+ if(w->profiling)
+ w->profiling = visitor(w->profiling);
+
+ parent->update_word_xt(w);
+ break;
+ }
+ case QUOTATION_TYPE:
+ {
+ quotation *q = (quotation *)obj;
+ if(q->code)
+ parent->set_quot_xt(q,visitor(q->code));
+ break;
+ }
+ case CALLSTACK_TYPE:
+ {
+ callstack *stack = (callstack *)obj;
+ call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ parent->iterate_callstack_object(stack,call_frame_visitor);
+ break;
+ }
+ }
+ }
+
+ void visit_context_code_blocks()
+ {
+ call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
+ parent->iterate_active_frames(call_frame_visitor);
+ }
+
+ void visit_callback_code_blocks()
+ {
+ callback_code_block_visitor<Visitor> callback_visitor(parent->callbacks,visitor);
+ parent->callbacks->iterate(callback_visitor);
+ }
+
+};
+
+}
namespace factor
{
-code_heap::code_heap(bool secure_gc, cell size) : heap(secure_gc,size,true) {}
+code_heap::code_heap(cell size)
+{
+ if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
+ seg = new segment(align_page(size),true);
+ if(!seg) fatal_error("Out of memory in heap allocator",size);
+ allocator = new free_list_allocator<code_block>(size,seg->start);
+}
+
+code_heap::~code_heap()
+{
+ delete allocator;
+ allocator = NULL;
+ delete seg;
+ seg = NULL;
+}
void code_heap::write_barrier(code_block *compiled)
{
return needs_fixup.count(compiled) > 0;
}
+bool code_heap::marked_p(code_block *compiled)
+{
+ return allocator->state.marked_p(compiled);
+}
+
+void code_heap::set_marked_p(code_block *compiled)
+{
+ allocator->state.set_marked_p(compiled);
+}
+
+void code_heap::clear_mark_bits()
+{
+ allocator->state.clear_mark_bits();
+}
+
void code_heap::code_heap_free(code_block *compiled)
{
points_to_nursery.erase(compiled);
points_to_aging.erase(compiled);
needs_fixup.erase(compiled);
- heap_free(compiled);
+ allocator->free(compiled);
}
/* Allocate a code heap during startup */
void factor_vm::init_code_heap(cell size)
{
- code = new code_heap(secure_gc,size);
+ code = new code_heap(size);
}
bool factor_vm::in_code_heap_p(cell ptr)
/* Compile a word definition with the non-optimizing compiler. Allocates memory */
void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
{
- gc_root<word> word(word_,this);
- gc_root<quotation> def(def_,this);
+ data_root<word> word(word_,this);
+ data_root<quotation> def(def_,this);
jit_compile(def.value(),relocate);
factor_vm *parent;
explicit word_updater(factor_vm *parent_) : parent(parent_) {}
- void operator()(code_block *compiled)
+
+ void operator()(code_block *compiled, cell size)
{
parent->update_word_references(compiled);
}
iterate_code_heap(updater);
}
+/* After a full GC that did not grow the heap, we have to update references
+to literals and other words. */
+struct word_and_literal_code_heap_updater {
+ factor_vm *parent;
+
+ explicit word_and_literal_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+
+ void operator()(code_block *block, cell size)
+ {
+ parent->update_code_block_words_and_literals(block);
+ }
+};
+
+void factor_vm::update_code_heap_words_and_literals()
+{
+ word_and_literal_code_heap_updater updater(this);
+ iterate_code_heap(updater);
+}
+
+/* After growing the heap, we have to perform a full relocation to update
+references to card and deck arrays. */
+struct code_heap_relocator {
+ factor_vm *parent;
+
+ explicit code_heap_relocator(factor_vm *parent_) : parent(parent_) {}
+
+ void operator()(code_block *block, cell size)
+ {
+ parent->relocate_code_block(block);
+ }
+};
+
void factor_vm::primitive_modify_code_heap()
{
- gc_root<array> alist(dpop(),this);
+ data_root<array> alist(dpop(),this);
cell count = array_capacity(alist.untagged());
if(count == 0)
return;
- cell i;
- for(i = 0; i < count; i++)
+ for(cell i = 0; i < count; i++)
{
- gc_root<array> pair(array_nth(alist.untagged(),i),this);
+ data_root<array> pair(array_nth(alist.untagged(),i),this);
- gc_root<word> word(array_nth(pair.untagged(),0),this);
- gc_root<object> data(array_nth(pair.untagged(),1),this);
+ data_root<word> word(array_nth(pair.untagged(),0),this);
+ data_root<object> data(array_nth(pair.untagged(),1),this);
switch(data.type())
{
cell code = array_nth(compiled_data,4);
code_block *compiled = add_code_block(
- WORD_TYPE,
+ code_block_optimized,
code,
labels,
owner,
break;
}
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
update_code_heap_words();
}
-/* Push the free space and total size of the code heap */
-void factor_vm::primitive_code_room()
-{
- cell used, total_free, max_free;
- code->heap_usage(&used,&total_free,&max_free);
- dpush(tag_fixnum(code->seg->size / 1024));
- dpush(tag_fixnum(used / 1024));
- dpush(tag_fixnum(total_free / 1024));
- dpush(tag_fixnum(max_free / 1024));
-}
-
-code_block *code_heap::forward_code_block(code_block *compiled)
-{
- return (code_block *)forwarding[compiled];
-}
-
-struct callframe_forwarder {
- factor_vm *parent;
-
- explicit callframe_forwarder(factor_vm *parent_) : parent(parent_) {}
-
- void operator()(stack_frame *frame)
- {
- cell offset = (cell)FRAME_RETURN_ADDRESS(frame,parent) - (cell)frame->xt;
-
- code_block *forwarded = parent->code->forward_code_block(parent->frame_code(frame));
- frame->xt = forwarded->xt();
-
- FRAME_RETURN_ADDRESS(frame,parent) = (void *)((cell)frame->xt + offset);
- }
-};
-
-void factor_vm::forward_object_xts()
-{
- begin_scan();
-
- cell obj;
-
- while(to_boolean(obj = next_object()))
- {
- switch(tagged<object>(obj).type())
- {
- case WORD_TYPE:
- {
- word *w = untag<word>(obj);
-
- if(w->code)
- w->code = code->forward_code_block(w->code);
- if(w->profiling)
- w->profiling = code->forward_code_block(w->profiling);
-
- update_word_xt(obj);
- }
- break;
- case QUOTATION_TYPE:
- {
- quotation *quot = untag<quotation>(obj);
-
- if(quot->code)
- {
- quot->code = code->forward_code_block(quot->code);
- set_quot_xt(quot,quot->code);
- }
- }
- break;
- case CALLSTACK_TYPE:
- {
- callstack *stack = untag<callstack>(obj);
- callframe_forwarder forwarder(this);
- iterate_callstack_object(stack,forwarder);
- }
- break;
- default:
- break;
- }
- }
-
- end_scan();
-}
-
-void factor_vm::forward_context_xts()
+code_heap_room factor_vm::code_room()
{
- callframe_forwarder forwarder(this);
- iterate_active_frames(forwarder);
-}
-
-struct callback_forwarder {
- code_heap *code;
- callback_heap *callbacks;
-
- callback_forwarder(code_heap *code_, callback_heap *callbacks_) :
- code(code_), callbacks(callbacks_) {}
+ code_heap_room room;
- void operator()(callback *stub)
- {
- stub->compiled = code->forward_code_block(stub->compiled);
- callbacks->update(stub);
- }
-};
+ room.size = code->allocator->size;
+ room.occupied_space = code->allocator->occupied_space();
+ room.total_free = code->allocator->free_space();
+ room.contiguous_free = code->allocator->largest_free_block();
+ room.free_block_count = code->allocator->free_block_count();
-void factor_vm::forward_callback_xts()
-{
- callback_forwarder forwarder(code,callbacks);
- callbacks->iterate(forwarder);
+ return room;
}
-/* Move all free space to the end of the code heap. Live blocks must be marked
-on entry to this function. XTs in code blocks must be updated after this
-function returns. */
-void factor_vm::compact_code_heap(bool trace_contexts_p)
+void factor_vm::primitive_code_room()
{
- code->compact_heap();
- forward_object_xts();
- if(trace_contexts_p)
- {
- forward_context_xts();
- forward_callback_xts();
- }
+ code_heap_room room = code_room();
+ dpush(tag<byte_array>(byte_array_from_value(&room)));
}
struct stack_trace_stripper {
explicit stack_trace_stripper() {}
- void operator()(code_block *compiled)
+ void operator()(code_block *compiled, cell size)
{
compiled->owner = false_object;
}
namespace factor
{
-struct code_heap : heap {
+struct code_heap {
+ /* The actual memory area */
+ segment *seg;
+
+ /* Memory allocator */
+ free_list_allocator<code_block> *allocator;
+
/* Set of blocks which need full relocation. */
std::set<code_block *> needs_fixup;
/* Code blocks which may reference objects in aging space or the nursery */
std::set<code_block *> points_to_aging;
- explicit code_heap(bool secure_gc, cell size);
+ explicit code_heap(cell size);
+ ~code_heap();
void write_barrier(code_block *compiled);
void clear_remembered_set();
bool needs_fixup_p(code_block *compiled);
+ bool marked_p(code_block *compiled);
+ void set_marked_p(code_block *compiled);
+ void clear_mark_bits();
void code_heap_free(code_block *compiled);
- code_block *forward_code_block(code_block *compiled);
+};
+
+struct code_heap_room {
+ cell size;
+ cell occupied_space;
+ cell total_free;
+ cell contiguous_free;
+ cell free_block_count;
};
}
--- /dev/null
+namespace factor
+{
+
+struct code_root {
+ cell value;
+ bool valid;
+ factor_vm *parent;
+
+ void push()
+ {
+ parent->code_roots.push_back(this);
+ }
+
+ explicit code_root(cell value_, factor_vm *parent_) :
+ value(value_), valid(true), parent(parent_)
+ {
+ push();
+ }
+
+ ~code_root()
+ {
+#ifdef FACTOR_DEBUG
+ assert(parent->code_roots.back() == this);
+#endif
+ parent->code_roots.pop_back();
+ }
+};
+
+}
namespace factor
{
-template<typename TargetGeneration, typename Policy> struct collector {
+template<typename TargetGeneration, typename Policy> struct collector_workhorse {
factor_vm *parent;
- data_heap *data;
- code_heap *code;
- gc_state *current_gc;
- generation_statistics *stats;
TargetGeneration *target;
Policy policy;
- explicit collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
+ explicit collector_workhorse(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
parent(parent_),
- data(parent_->data),
- code(parent_->code),
- current_gc(parent_->current_gc),
- stats(stats_),
target(target_),
policy(policy_) {}
return untagged;
}
- void trace_handle(cell *handle)
+ object *promote_object(object *untagged)
{
- cell pointer = *handle;
+ cell size = untagged->size();
+ object *newpointer = target->allot(size);
+ /* XXX not exception-safe */
+ if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
- if(immediate_p(pointer)) return;
+ memcpy(newpointer,untagged,size);
+ untagged->h.forward_to(newpointer);
- object *untagged = parent->untag<object>(pointer);
- if(!policy.should_copy_p(untagged))
- return;
+ policy.promoted_object(newpointer);
- object *forwarding = resolve_forwarding(untagged);
+ return newpointer;
+ }
+
+ object *operator()(object *obj)
+ {
+ if(!policy.should_copy_p(obj))
+ {
+ policy.visited_object(obj);
+ return obj;
+ }
+
+ object *forwarding = resolve_forwarding(obj);
- if(forwarding == untagged)
- untagged = promote_object(untagged);
+ if(forwarding == obj)
+ return promote_object(obj);
else if(policy.should_copy_p(forwarding))
- untagged = promote_object(forwarding);
+ return promote_object(forwarding);
else
- untagged = forwarding;
+ {
+ policy.visited_object(forwarding);
+ return forwarding;
+ }
+ }
+};
+
+template<typename TargetGeneration, typename Policy>
+inline static slot_visitor<collector_workhorse<TargetGeneration,Policy> > make_collector_workhorse(
+ factor_vm *parent,
+ TargetGeneration *target,
+ Policy policy)
+{
+ return slot_visitor<collector_workhorse<TargetGeneration,Policy> >(parent,
+ collector_workhorse<TargetGeneration,Policy>(parent,target,policy));
+}
+
+struct dummy_unmarker {
+ void operator()(card *ptr) {}
+};
+
+struct simple_unmarker {
+ card unmask;
+ explicit simple_unmarker(card unmask_) : unmask(unmask_) {}
+ void operator()(card *ptr) { *ptr &= ~unmask; }
+};
+
+struct full_unmarker {
+ explicit full_unmarker() {}
+ void operator()(card *ptr) { *ptr = 0; }
+};
+
+template<typename TargetGeneration, typename Policy> struct collector {
+ factor_vm *parent;
+ data_heap *data;
+ code_heap *code;
+ TargetGeneration *target;
+ slot_visitor<collector_workhorse<TargetGeneration,Policy> > workhorse;
+ cell cards_scanned;
+ cell decks_scanned;
+ cell code_blocks_scanned;
+
+ explicit collector(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
+ parent(parent_),
+ data(parent_->data),
+ code(parent_->code),
+ target(target_),
+ workhorse(make_collector_workhorse(parent_,target_,policy_)),
+ cards_scanned(0),
+ decks_scanned(0),
+ code_blocks_scanned(0) {}
- *handle = RETAG(untagged,TAG(pointer));
+ void trace_handle(cell *handle)
+ {
+ workhorse.visit_handle(handle);
}
- void trace_slots(object *ptr)
+ void trace_object(object *ptr)
{
- cell *slot = (cell *)ptr;
- cell *end = (cell *)((cell)ptr + parent->binary_payload_start(ptr));
+ workhorse.visit_slots(ptr);
+ if(ptr->h.hi_tag() == ALIEN_TYPE)
+ ((alien *)ptr)->update_address();
+ }
- if(slot != end)
- {
- slot++;
- for(; slot < end; slot++) trace_handle(slot);
- }
+ void trace_roots()
+ {
+ workhorse.visit_roots();
}
- object *promote_object(object *untagged)
+ void trace_contexts()
{
- cell size = parent->untagged_object_size(untagged);
- object *newpointer = target->allot(size);
- /* XXX not exception-safe */
- if(!newpointer) longjmp(current_gc->gc_unwind,1);
+ workhorse.visit_contexts();
+ }
- memcpy(newpointer,untagged,size);
- untagged->h.forward_to(newpointer);
+ /* Trace all literals referenced from a code block. Only for aging and nursery collections */
+ void trace_literal_references(code_block *compiled)
+ {
+ workhorse.visit_literal_references(compiled);
+ }
- stats->object_count++;
- stats->bytes_copied += size;
+ void trace_code_heap_roots(std::set<code_block *> *remembered_set)
+ {
+ std::set<code_block *>::const_iterator iter = remembered_set->begin();
+ std::set<code_block *>::const_iterator end = remembered_set->end();
- return newpointer;
+ for(; iter != end; iter++)
+ {
+ trace_literal_references(*iter);
+ code_blocks_scanned++;
+ }
+ }
+
+ inline cell first_card_in_deck(cell deck)
+ {
+ return deck << (deck_bits - card_bits);
}
- void trace_stack_elements(segment *region, cell *top)
+ inline cell last_card_in_deck(cell deck)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- trace_handle(ptr);
+ return first_card_in_deck(deck + 1);
}
- void trace_registered_locals()
+ inline cell card_deck_for_address(cell a)
{
- std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
- std::vector<cell>::const_iterator end = parent->gc_locals.end();
+ return addr_to_deck(a - data->start);
+ }
- for(; iter < end; iter++)
- trace_handle((cell *)(*iter));
+ inline cell card_start_address(cell card)
+ {
+ return (card << card_bits) + data->start;
}
- void trace_registered_bignums()
+ inline cell card_end_address(cell card)
{
- std::vector<cell>::const_iterator iter = parent->gc_bignums.begin();
- std::vector<cell>::const_iterator end = parent->gc_bignums.end();
+ return ((card + 1) << card_bits) + data->start;
+ }
- for(; iter < end; iter++)
+ void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
+ {
+ if(card_start < end)
{
- cell *handle = (cell *)(*iter);
+ start += sizeof(cell);
- if(*handle)
- {
- *handle |= BIGNUM_TYPE;
- trace_handle(handle);
- *handle &= ~BIGNUM_TYPE;
- }
+ if(start < card_start) start = card_start;
+ if(end > card_end) end = card_end;
+
+ cell *slot_ptr = (cell *)start;
+ cell *end_ptr = (cell *)end;
+
+ for(; slot_ptr < end_ptr; slot_ptr++)
+ workhorse.visit_handle(slot_ptr);
}
}
- /* Copy roots over at the start of GC, namely various constants, stacks,
- the user environment and extra roots registered by local_roots.hpp */
- void trace_roots()
+ template<typename SourceGeneration, typename Unmarker>
+ void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
{
- trace_handle(&parent->true_object);
- trace_handle(&parent->bignum_zero);
- trace_handle(&parent->bignum_pos_one);
- trace_handle(&parent->bignum_neg_one);
+ card_deck *decks = data->decks;
+ card_deck *cards = data->cards;
- trace_registered_locals();
- trace_registered_bignums();
+ cell gen_start_card = addr_to_card(gen->start - data->start);
- for(int i = 0; i < USER_ENV; i++) trace_handle(&parent->userenv[i]);
- }
+ cell first_deck = card_deck_for_address(gen->start);
+ cell last_deck = card_deck_for_address(gen->end);
- void trace_contexts()
- {
- context *ctx = parent->ctx;
+ cell start = 0, binary_start = 0, end = 0;
- while(ctx)
+ for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
{
- trace_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
- trace_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+ if(decks[deck_index] & mask)
+ {
+ decks_scanned++;
+
+ cell first_card = first_card_in_deck(deck_index);
+ cell last_card = last_card_in_deck(deck_index);
- trace_handle(&ctx->catchstack_save);
- trace_handle(&ctx->current_callback_save);
+ for(cell card_index = first_card; card_index < last_card; card_index++)
+ {
+ if(cards[card_index] & mask)
+ {
+ cards_scanned++;
- ctx = ctx->next;
+ if(end < card_start_address(card_index))
+ {
+ start = gen->starts.find_object_containing_card(card_index - gen_start_card);
+ binary_start = start + ((object *)start)->binary_payload_start();
+ end = start + ((object *)start)->size();
+ }
+
+scan_next_object: if(start < card_end_address(card_index))
+ {
+ trace_partial_objects(
+ start,
+ binary_start,
+ card_start_address(card_index),
+ card_end_address(card_index));
+ if(end < card_end_address(card_index))
+ {
+ start = gen->next_object_after(start);
+ if(start)
+ {
+ binary_start = start + ((object *)start)->binary_payload_start();
+ end = start + ((object *)start)->size();
+ goto scan_next_object;
+ }
+ }
+ }
+
+ unmarker(&cards[card_index]);
+
+ if(!start) return;
+ }
+ }
+
+ unmarker(&decks[deck_index]);
+ }
}
}
};
--- /dev/null
+#include "master.hpp"
+
+namespace factor {
+
+template<typename Block> struct forwarder {
+ mark_bits<Block> *forwarding_map;
+
+ explicit forwarder(mark_bits<Block> *forwarding_map_) :
+ forwarding_map(forwarding_map_) {}
+
+ Block *operator()(Block *block)
+ {
+ return forwarding_map->forward_block(block);
+ }
+};
+
+static inline cell tuple_size_with_forwarding(mark_bits<object> *forwarding_map, object *obj)
+{
+ /* The tuple layout may or may not have been forwarded already. Tricky. */
+ object *layout_obj = (object *)UNTAG(((tuple *)obj)->layout);
+ tuple_layout *layout;
+
+ if(layout_obj < obj)
+ {
+ /* It's already been moved up; dereference through forwarding
+ map to get the size */
+ layout = (tuple_layout *)forwarding_map->forward_block(layout_obj);
+ }
+ else
+ {
+ /* It hasn't been moved up yet; dereference directly */
+ layout = (tuple_layout *)layout_obj;
+ }
+
+ return tuple_size(layout);
+}
+
+struct compaction_sizer {
+ mark_bits<object> *forwarding_map;
+
+ explicit compaction_sizer(mark_bits<object> *forwarding_map_) :
+ forwarding_map(forwarding_map_) {}
+
+ cell operator()(object *obj)
+ {
+ if(!forwarding_map->marked_p(obj))
+ return forwarding_map->unmarked_block_size(obj);
+ else if(obj->h.hi_tag() == TUPLE_TYPE)
+ return align(tuple_size_with_forwarding(forwarding_map,obj),data_alignment);
+ else
+ return obj->size();
+ }
+};
+
+struct object_compaction_updater {
+ factor_vm *parent;
+ slot_visitor<forwarder<object> > slot_forwarder;
+ code_block_visitor<forwarder<code_block> > code_forwarder;
+ mark_bits<object> *data_forwarding_map;
+ object_start_map *starts;
+
+ explicit object_compaction_updater(factor_vm *parent_,
+ slot_visitor<forwarder<object> > slot_forwarder_,
+ code_block_visitor<forwarder<code_block> > code_forwarder_,
+ mark_bits<object> *data_forwarding_map_) :
+ parent(parent_),
+ slot_forwarder(slot_forwarder_),
+ code_forwarder(code_forwarder_),
+ data_forwarding_map(data_forwarding_map_),
+ starts(&parent->data->tenured->starts) {}
+
+ void operator()(object *old_address, object *new_address, cell size)
+ {
+ cell payload_start;
+ if(old_address->h.hi_tag() == TUPLE_TYPE)
+ payload_start = tuple_size_with_forwarding(data_forwarding_map,old_address);
+ else
+ payload_start = old_address->binary_payload_start();
+
+ memmove(new_address,old_address,size);
+
+ slot_forwarder.visit_slots(new_address,payload_start);
+ code_forwarder.visit_object_code_block(new_address);
+ starts->record_object_start_offset(new_address);
+ }
+};
+
+template<typename SlotForwarder> struct code_block_compaction_updater {
+ factor_vm *parent;
+ SlotForwarder slot_forwarder;
+
+ explicit code_block_compaction_updater(factor_vm *parent_, SlotForwarder slot_forwarder_) :
+ parent(parent_), slot_forwarder(slot_forwarder_) {}
+
+ void operator()(code_block *old_address, code_block *new_address, cell size)
+ {
+ memmove(new_address,old_address,size);
+ slot_forwarder.visit_literal_references(new_address);
+ parent->relocate_code_block(new_address);
+ }
+};
+
+/* Compact data and code heaps */
+void factor_vm::collect_compact_impl(bool trace_contexts_p)
+{
+ current_gc->event->started_compaction();
+
+ tenured_space *tenured = data->tenured;
+ mark_bits<object> *data_forwarding_map = &tenured->state;
+ mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
+
+ /* Figure out where blocks are going to go */
+ data_forwarding_map->compute_forwarding();
+ code_forwarding_map->compute_forwarding();
+
+ slot_visitor<forwarder<object> > slot_forwarder(this,forwarder<object>(data_forwarding_map));
+ code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+
+ /* Object start offsets get recomputed by the object_compaction_updater */
+ data->tenured->starts.clear_object_start_offsets();
+
+ /* Slide everything in tenured space up, and update data and code heap
+ pointers inside objects. */
+ object_compaction_updater object_updater(this,slot_forwarder,code_forwarder,data_forwarding_map);
+ compaction_sizer object_sizer(data_forwarding_map);
+ tenured->compact(object_updater,object_sizer);
+
+ /* Slide everything in the code heap up, and update data and code heap
+ pointers inside code blocks. */
+ code_block_compaction_updater<slot_visitor<forwarder<object> > > code_block_updater(this,slot_forwarder);
+ standard_sizer<code_block> code_block_sizer;
+ code->allocator->compact(code_block_updater,code_block_sizer);
+
+ slot_forwarder.visit_roots();
+ if(trace_contexts_p)
+ {
+ slot_forwarder.visit_contexts();
+ code_forwarder.visit_context_code_blocks();
+ code_forwarder.visit_callback_code_blocks();
+ }
+
+ update_code_roots_for_compaction();
+
+ current_gc->event->ended_compaction();
+}
+
+struct object_code_block_updater {
+ code_block_visitor<forwarder<code_block> > *visitor;
+
+ explicit object_code_block_updater(code_block_visitor<forwarder<code_block> > *visitor_) :
+ visitor(visitor_) {}
+
+ void operator()(object *obj)
+ {
+ visitor->visit_object_code_block(obj);
+ }
+};
+
+struct dummy_slot_forwarder {
+ void visit_literal_references(code_block *compiled) {}
+};
+
+/* Compact just the code heap */
+void factor_vm::collect_compact_code_impl(bool trace_contexts_p)
+{
+ /* Figure out where blocks are going to go */
+ mark_bits<code_block> *code_forwarding_map = &code->allocator->state;
+ code_forwarding_map->compute_forwarding();
+ code_block_visitor<forwarder<code_block> > code_forwarder(this,forwarder<code_block>(code_forwarding_map));
+
+ if(trace_contexts_p)
+ {
+ code_forwarder.visit_context_code_blocks();
+ code_forwarder.visit_callback_code_blocks();
+ }
+
+ /* Update code heap references in data heap */
+ object_code_block_updater updater(&code_forwarder);
+ each_object(updater);
+
+ /* Slide everything in the code heap up, and update code heap
+ pointers inside code blocks. */
+ dummy_slot_forwarder slot_forwarder;
+ code_block_compaction_updater<dummy_slot_forwarder> code_block_updater(this,slot_forwarder);
+ standard_sizer<code_block> code_block_sizer;
+ code->allocator->compact(code_block_updater,code_block_sizer);
+
+ update_code_roots_for_compaction();
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+}
namespace factor
{
+context::context(cell ds_size, cell rs_size) :
+ callstack_top(NULL),
+ callstack_bottom(NULL),
+ datastack(0),
+ retainstack(0),
+ datastack_save(0),
+ retainstack_save(0),
+ magic_frame(NULL),
+ datastack_region(new segment(ds_size,false)),
+ retainstack_region(new segment(rs_size,false)),
+ catchstack_save(0),
+ current_callback_save(0),
+ next(NULL) {}
+
void factor_vm::reset_datastack()
{
ds = ds_bot - sizeof(cell);
unused_contexts = unused_contexts->next;
}
else
- {
- new_context = new context;
- new_context->datastack_region = new segment(ds_size,false);
- new_context->retainstack_region = new segment(rs_size,false);
- }
+ new_context = new context(ds_size,rs_size);
return new_context;
}
new_ctx->magic_frame = magic_frame;
- /* save per-callback userenv */
- new_ctx->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
- new_ctx->catchstack_save = userenv[CATCHSTACK_ENV];
+ /* save per-callback special_objects */
+ new_ctx->current_callback_save = special_objects[OBJ_CURRENT_CALLBACK];
+ new_ctx->catchstack_save = special_objects[OBJ_CATCHSTACK];
new_ctx->next = ctx;
ctx = new_ctx;
ds = ctx->datastack_save;
rs = ctx->retainstack_save;
- /* restore per-callback userenv */
- userenv[CURRENT_CALLBACK_ENV] = ctx->current_callback_save;
- userenv[CATCHSTACK_ENV] = ctx->catchstack_save;
+ /* restore per-callback special_objects */
+ special_objects[OBJ_CURRENT_CALLBACK] = ctx->current_callback_save;
+ special_objects[OBJ_CATCHSTACK] = ctx->catchstack_save;
context *old_ctx = ctx;
ctx = old_ctx->next;
return false;
else
{
- array *a = allot_array_internal<array>(depth / sizeof(cell));
+ array *a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1,(void*)bottom,depth);
dpush(tag<array>(a));
return true;
}
}
+void factor_vm::primitive_load_locals()
+{
+ fixnum count = untag_fixnum(dpop());
+ memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
+ ds -= sizeof(cell) * count;
+ rs += sizeof(cell) * count;
+}
+
}
/* memory region holding current retain stack */
segment *retainstack_region;
- /* saved userenv slots on entry to callback */
+ /* saved special_objects slots on entry to callback */
cell catchstack_save;
cell current_callback_save;
context *next;
+
+ context(cell ds_size, cell rs_size);
};
#define ds_bot (ctx->datastack_region->start)
namespace factor
{
-struct dummy_unmarker {
- void operator()(card *ptr) {}
-};
-
-struct simple_unmarker {
- card unmask;
- simple_unmarker(card unmask_) : unmask(unmask_) {}
- void operator()(card *ptr) { *ptr &= ~unmask; }
-};
-
template<typename TargetGeneration, typename Policy>
struct copying_collector : collector<TargetGeneration,Policy> {
cell scan;
- explicit copying_collector(factor_vm *parent_, generation_statistics *stats_, TargetGeneration *target_, Policy policy_) :
- collector<TargetGeneration,Policy>(parent_,stats_,target_,policy_), scan(target_->here) {}
-
- inline cell first_card_in_deck(cell deck)
- {
- return deck << (deck_bits - card_bits);
- }
-
- inline cell last_card_in_deck(cell deck)
- {
- return first_card_in_deck(deck + 1);
- }
-
- inline cell card_deck_for_address(cell a)
- {
- return addr_to_deck(a - this->data->start);
- }
-
- inline cell card_start_address(cell card)
- {
- return (card << card_bits) + this->data->start;
- }
-
- inline cell card_end_address(cell card)
- {
- return ((card + 1) << card_bits) + this->data->start;
- }
-
- void trace_partial_objects(cell start, cell end, cell card_start, cell card_end)
- {
- if(card_start < end)
- {
- start += sizeof(cell);
-
- if(start < card_start) start = card_start;
- if(end > card_end) end = card_end;
-
- cell *slot_ptr = (cell *)start;
- cell *end_ptr = (cell *)end;
-
- if(slot_ptr != end_ptr)
- {
- for(; slot_ptr < end_ptr; slot_ptr++)
- this->trace_handle(slot_ptr);
- }
- }
- }
-
- template<typename SourceGeneration, typename Unmarker>
- void trace_cards(SourceGeneration *gen, card mask, Unmarker unmarker)
- {
- u64 start_time = current_micros();
-
- card_deck *decks = this->data->decks;
- card_deck *cards = this->data->cards;
-
- cell gen_start_card = addr_to_card(gen->start - this->data->start);
-
- cell first_deck = card_deck_for_address(gen->start);
- cell last_deck = card_deck_for_address(gen->end);
-
- cell start = 0, binary_start = 0, end = 0;
-
- for(cell deck_index = first_deck; deck_index < last_deck; deck_index++)
- {
- if(decks[deck_index] & mask)
- {
- this->parent->gc_stats.decks_scanned++;
-
- cell first_card = first_card_in_deck(deck_index);
- cell last_card = last_card_in_deck(deck_index);
-
- for(cell card_index = first_card; card_index < last_card; card_index++)
- {
- if(cards[card_index] & mask)
- {
- this->parent->gc_stats.cards_scanned++;
-
- if(end < card_start_address(card_index))
- {
- start = gen->find_object_containing_card(card_index - gen_start_card);
- binary_start = start + this->parent->binary_payload_start((object *)start);
- end = start + this->parent->untagged_object_size((object *)start);
- }
-
-#ifdef FACTOR_DEBUG
- assert(addr_to_card(start - this->data->start) <= card_index);
- assert(start < card_end_address(card_index));
-#endif
-
-scan_next_object: {
- trace_partial_objects(
- start,
- binary_start,
- card_start_address(card_index),
- card_end_address(card_index));
- if(end < card_end_address(card_index))
- {
- start = gen->next_object_after(this->parent,start);
- if(start)
- {
- binary_start = start + this->parent->binary_payload_start((object *)start);
- end = start + this->parent->untagged_object_size((object *)start);
- goto scan_next_object;
- }
- }
- }
-
- unmarker(&cards[card_index]);
-
- if(!start) goto end;
- }
- }
-
- unmarker(&decks[deck_index]);
- }
- }
-
-end: this->parent->gc_stats.card_scan_time += (current_micros() - start_time);
- }
-
- /* Trace all literals referenced from a code block. Only for aging and nursery collections */
- void trace_literal_references(code_block *compiled)
- {
- this->trace_handle(&compiled->owner);
- this->trace_handle(&compiled->literals);
- this->trace_handle(&compiled->relocation);
- this->parent->gc_stats.code_blocks_scanned++;
- }
-
- void trace_code_heap_roots(std::set<code_block *> *remembered_set)
- {
- std::set<code_block *>::const_iterator iter = remembered_set->begin();
- std::set<code_block *>::const_iterator end = remembered_set->end();
-
- for(; iter != end; iter++) trace_literal_references(*iter);
- }
+ explicit copying_collector(factor_vm *parent_, TargetGeneration *target_, Policy policy_) :
+ collector<TargetGeneration,Policy>(parent_,target_,policy_), scan(target_->here) {}
void cheneys_algorithm()
{
while(scan && scan < this->target->here)
{
- this->trace_slots((object *)scan);
- scan = this->target->next_object_after(this->parent,scan);
+ this->trace_object((object *)scan);
+ scan = this->target->next_object_after(scan);
}
}
};
lwz r3,0(DS_REG)
lwz r4,-4(DS_REG)
subi DS_REG,DS_REG,4
- srawi r3,r3,3
+ srawi r3,r3,4
mullwo. r6,r3,r4
bso multiply_overflow
stw r6,0(DS_REG)
blr
multiply_overflow:
- srawi r4,r4,3
+ srawi r4,r4,4
b MANGLE(overflow_fixnum_multiply)
/* Note that the XT is passed to the quotation in r11 */
#define PUSH_NONVOLATILE \
push %ebx ; \
- push %ebp ; \
push %ebp
#define POP_NONVOLATILE \
- pop %ebp ; \
pop %ebp ; \
pop %ebx
push %rdi ; \
push %rsi ; \
push %rbx ; \
- push %rbp ; \
push %rbp
#define POP_NONVOLATILE \
- pop %rbp ; \
pop %rbp ; \
pop %rbx ; \
pop %rsi ; \
push %rbx ; \
push %rbp ; \
push %r12 ; \
- push %r13 ; \
push %r13
#define POP_NONVOLATILE \
- pop %r13 ; \
pop %r13 ; \
pop %r12 ; \
pop %rbp ; \
mov (DS_REG),ARITH_TEMP_1
mov ARITH_TEMP_1,DIV_RESULT
mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
- sar $3,ARITH_TEMP_2
+ sar $4,ARITH_TEMP_2
sub $CELL_SIZE,DS_REG
imul ARITH_TEMP_2
jo multiply_overflow
pop ARG2
ret
multiply_overflow:
- sar $3,ARITH_TEMP_1
+ sar $4,ARITH_TEMP_1
mov ARITH_TEMP_1,ARG0
mov ARITH_TEMP_2,ARG1
pop ARG2
PUSH_NONVOLATILE
mov ARG0,NV0
mov ARG1,NV1
-
+
+ /* Save old stack pointer and align */
+ mov STACK_REG,ARG0
+ and $-16,STACK_REG
+ add $CELL_SIZE,STACK_REG
+ push ARG0
+
/* Create register shadow area for Win64 */
sub $32,STACK_REG
-
+
/* Save stack pointer */
lea -CELL_SIZE(STACK_REG),ARG0
call MANGLE(save_callstack_bottom)
-
+
/* Call quot-xt */
mov NV0,ARG0
mov NV1,ARG1
/* Tear down register shadow area */
add $32,STACK_REG
+ /* Undo stack alignment */
+ mov (STACK_REG),STACK_REG
+
POP_NONVOLATILE
ret
decks_offset = (cell)data->decks - addr_to_deck(data->start);
}
-data_heap::data_heap(cell young_size_, cell aging_size_, cell tenured_size_)
+data_heap::data_heap(cell young_size_,
+ cell aging_size_,
+ cell tenured_size_)
{
young_size_ = align(young_size_,deck_size);
aging_size_ = align(aging_size_,deck_size);
aging_size = aging_size_;
tenured_size = tenured_size_;
- cell total_size = young_size + 2 * aging_size + 2 * tenured_size;
-
- total_size += deck_size;
-
+ cell total_size = young_size + 2 * aging_size + tenured_size + deck_size;
seg = new segment(total_size,false);
cell cards_size = addr_to_card(total_size);
-
cards = new card[cards_size];
cards_end = cards + cards_size;
+ memset(cards,0,cards_size);
cell decks_size = addr_to_deck(total_size);
decks = new card_deck[decks_size];
decks_end = decks + decks_size;
+ memset(decks,0,decks_size);
start = align(seg->start,deck_size);
tenured = new tenured_space(tenured_size,start);
- tenured_semispace = new tenured_space(tenured_size,tenured->end);
- aging = new aging_space(aging_size,tenured_semispace->end);
+ aging = new aging_space(aging_size,tenured->end);
aging_semispace = new aging_space(aging_size,aging->end);
- nursery = new zone(young_size,aging_semispace->end);
+ nursery = new nursery_space(young_size,aging_semispace->end);
assert(seg->end - nursery->end <= deck_size);
}
delete aging;
delete aging_semispace;
delete tenured;
- delete tenured_semispace;
delete[] cards;
delete[] decks;
}
data_heap *data_heap::grow(cell requested_bytes)
{
cell new_tenured_size = (tenured_size * 2) + requested_bytes;
- return new data_heap(young_size,aging_size,new_tenured_size);
+ return new data_heap(young_size,
+ aging_size,
+ new_tenured_size);
}
-void factor_vm::clear_cards(old_space *gen)
+template<typename Generation> void data_heap::clear_cards(Generation *gen)
{
- cell first_card = addr_to_card(gen->start - data->start);
- cell last_card = addr_to_card(gen->end - data->start);
- memset(&data->cards[first_card],0,last_card - first_card);
+ cell first_card = addr_to_card(gen->start - start);
+ cell last_card = addr_to_card(gen->end - start);
+ memset(&cards[first_card],0,last_card - first_card);
}
-void factor_vm::clear_decks(old_space *gen)
+template<typename Generation> void data_heap::clear_decks(Generation *gen)
{
- cell first_deck = addr_to_deck(gen->start - data->start);
- cell last_deck = addr_to_deck(gen->end - data->start);
- memset(&data->decks[first_deck],0,last_deck - first_deck);
+ cell first_deck = addr_to_deck(gen->start - start);
+ cell last_deck = addr_to_deck(gen->end - start);
+ memset(&decks[first_deck],0,last_deck - first_deck);
}
-/* After garbage collection, any generations which are now empty need to have
-their allocation pointers and cards reset. */
-void factor_vm::reset_generation(old_space *gen)
+void data_heap::reset_generation(nursery_space *gen)
{
gen->here = gen->start;
- if(secure_gc) memset((void*)gen->start,69,gen->size);
+}
+void data_heap::reset_generation(aging_space *gen)
+{
+ gen->here = gen->start;
clear_cards(gen);
clear_decks(gen);
- gen->clear_object_start_offsets();
+ gen->starts.clear_object_start_offsets();
+}
+
+void data_heap::reset_generation(tenured_space *gen)
+{
+ clear_cards(gen);
+ clear_decks(gen);
+}
+
+bool data_heap::low_memory_p()
+{
+ return (tenured->free_space() <= nursery->size + aging->size);
+}
+
+void data_heap::mark_all_cards()
+{
+ memset(cards,-1,cards_end - cards);
+ memset(decks,-1,decks_end - decks);
}
void factor_vm::set_data_heap(data_heap *data_)
{
data = data_;
nursery = *data->nursery;
- nursery.here = nursery.start;
init_card_decks();
- reset_generation(data->aging);
- reset_generation(data->tenured);
}
-void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_)
+void factor_vm::init_data_heap(cell young_size, cell aging_size, cell tenured_size)
{
set_data_heap(new data_heap(young_size,aging_size,tenured_size));
- secure_gc = secure_gc_;
-}
-
-/* Size of the object pointed to by a tagged pointer */
-cell factor_vm::object_size(cell tagged)
-{
- if(immediate_p(tagged))
- return 0;
- else
- return untagged_object_size(untag<object>(tagged));
}
/* Size of the object pointed to by an untagged pointer */
-cell factor_vm::untagged_object_size(object *pointer)
+cell object::size() const
{
- return align8(unaligned_object_size(pointer));
-}
+ if(free_p()) return ((free_heap_block *)this)->size();
-/* Size of the data area of an object pointed to by an untagged pointer */
-cell factor_vm::unaligned_object_size(object *pointer)
-{
- switch(pointer->h.hi_tag())
+ switch(h.hi_tag())
{
case ARRAY_TYPE:
- return array_size((array*)pointer);
+ return align(array_size((array*)this),data_alignment);
case BIGNUM_TYPE:
- return array_size((bignum*)pointer);
+ return align(array_size((bignum*)this),data_alignment);
case BYTE_ARRAY_TYPE:
- return array_size((byte_array*)pointer);
+ return align(array_size((byte_array*)this),data_alignment);
case STRING_TYPE:
- return string_size(string_capacity((string*)pointer));
+ return align(string_size(string_capacity((string*)this)),data_alignment);
case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ {
+ tuple_layout *layout = (tuple_layout *)UNTAG(((tuple *)this)->layout);
+ return align(tuple_size(layout),data_alignment);
+ }
case QUOTATION_TYPE:
- return sizeof(quotation);
+ return align(sizeof(quotation),data_alignment);
case WORD_TYPE:
- return sizeof(word);
+ return align(sizeof(word),data_alignment);
case FLOAT_TYPE:
- return sizeof(boxed_float);
+ return align(sizeof(boxed_float),data_alignment);
case DLL_TYPE:
- return sizeof(dll);
+ return align(sizeof(dll),data_alignment);
case ALIEN_TYPE:
- return sizeof(alien);
+ return align(sizeof(alien),data_alignment);
case WRAPPER_TYPE:
- return sizeof(wrapper);
+ return align(sizeof(wrapper),data_alignment);
case CALLSTACK_TYPE:
- return callstack_size(untag_fixnum(((callstack *)pointer)->length));
+ return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
default:
- critical_error("Invalid header",(cell)pointer);
+ critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
-void factor_vm::primitive_size()
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
/* The number of cells from the start of the object which should be scanned by
the GC. Some types have a binary payload at the end (string, word, DLL) which
we ignore. */
-cell factor_vm::binary_payload_start(object *pointer)
+cell object::binary_payload_start() const
{
- switch(pointer->h.hi_tag())
+ switch(h.hi_tag())
{
/* these objects do not refer to other objects at all */
case FLOAT_TYPE:
return sizeof(string);
/* everything else consists entirely of pointers */
case ARRAY_TYPE:
- return array_size<array>(array_capacity((array*)pointer));
+ return array_size<array>(array_capacity((array*)this));
case TUPLE_TYPE:
- return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ return tuple_size(untag<tuple_layout>(((tuple *)this)->layout));
case WRAPPER_TYPE:
return sizeof(wrapper);
default:
- critical_error("Invalid header",(cell)pointer);
+ critical_error("Invalid header",(cell)this);
return 0; /* can't happen */
}
}
-/* Push memory usage statistics in data heap */
-void factor_vm::primitive_data_room()
+data_heap_room factor_vm::data_room()
{
- dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
- dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
-
- growable_array a(this);
-
- a.add(tag_fixnum((nursery.end - nursery.here) >> 10));
- a.add(tag_fixnum((nursery.size) >> 10));
-
- a.add(tag_fixnum((data->aging->end - data->aging->here) >> 10));
- a.add(tag_fixnum((data->aging->size) >> 10));
-
- a.add(tag_fixnum((data->tenured->end - data->tenured->here) >> 10));
- a.add(tag_fixnum((data->tenured->size) >> 10));
-
- a.trim();
- dpush(a.elements.value());
+ data_heap_room room;
+
+ room.nursery_size = nursery.size;
+ room.nursery_occupied = nursery.occupied_space();
+ room.nursery_free = nursery.free_space();
+ room.aging_size = data->aging->size;
+ room.aging_occupied = data->aging->occupied_space();
+ room.aging_free = data->aging->free_space();
+ room.tenured_size = data->tenured->size;
+ room.tenured_occupied = data->tenured->occupied_space();
+ room.tenured_total_free = data->tenured->free_space();
+ room.tenured_contiguous_free = data->tenured->largest_free_block();
+ room.tenured_free_block_count = data->tenured->free_block_count();
+ room.cards = data->cards_end - data->cards;
+ room.decks = data->decks_end - data->decks;
+ room.mark_stack = data->tenured->mark_stack.capacity() * sizeof(cell);
+
+ return room;
}
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void factor_vm::begin_scan()
+void factor_vm::primitive_data_room()
{
- heap_scan_ptr = data->tenured->start;
- gc_off = true;
+ data_heap_room room = data_room();
+ dpush(tag<byte_array>(byte_array_from_value(&room)));
}
-void factor_vm::end_scan()
-{
- gc_off = false;
-}
+struct object_accumulator {
+ cell type;
+ std::vector<cell> objects;
-void factor_vm::primitive_begin_scan()
-{
- begin_scan();
-}
+ explicit object_accumulator(cell type_) : type(type_) {}
+
+ void operator()(object *obj)
+ {
+ if(type == TYPE_COUNT || obj->h.hi_tag() == type)
+ objects.push_back(tag_dynamic(obj));
+ }
+};
-cell factor_vm::next_object()
+cell factor_vm::instances(cell type)
{
- if(!gc_off)
- general_error(ERROR_HEAP_SCAN,false_object,false_object,NULL);
+ object_accumulator accum(type);
+ each_object(accum);
+ cell object_count = accum.objects.size();
- if(heap_scan_ptr >= data->tenured->here)
- return false_object;
+ data_roots.push_back(data_root_range(&accum.objects[0],object_count));
- object *obj = (object *)heap_scan_ptr;
- heap_scan_ptr += untagged_object_size(obj);
- return tag_dynamic(obj);
-}
+ array *objects = allot_array(object_count,false_object);
+ memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell));
-/* Push object at heap scan cursor and advance; pushes f when done */
-void factor_vm::primitive_next_object()
-{
- dpush(next_object());
-}
+ data_roots.pop_back();
-/* Re-enables GC */
-void factor_vm::primitive_end_scan()
-{
- gc_off = false;
+ return tag<array>(objects);
}
-template<typename Iterator> void factor_vm::each_object(Iterator &iterator)
+void factor_vm::primitive_all_instances()
{
- begin_scan();
- cell obj;
- while(to_boolean(obj = next_object()))
- iterator(tagged<object>(obj));
- end_scan();
+ primitive_full_gc();
+ dpush(instances(TYPE_COUNT));
}
-struct word_counter {
- cell count;
- explicit word_counter() : count(0) {}
- void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) count++; }
-};
-
-struct word_accumulator {
- growable_array words;
- explicit word_accumulator(int count,factor_vm *vm) : words(vm,count) {}
- void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
-};
-
cell factor_vm::find_all_words()
{
- word_counter counter;
- each_object(counter);
- word_accumulator accum(counter.count,this);
- each_object(accum);
- accum.words.trim();
- return accum.words.elements.value();
+ return instances(WORD_TYPE);
}
}
segment *seg;
- zone *nursery;
+ nursery_space *nursery;
aging_space *aging;
aging_space *aging_semispace;
tenured_space *tenured;
- tenured_space *tenured_semispace;
card *cards;
card *cards_end;
explicit data_heap(cell young_size, cell aging_size, cell tenured_size);
~data_heap();
data_heap *grow(cell requested_size);
+ template<typename Generation> void clear_cards(Generation *gen);
+ template<typename Generation> void clear_decks(Generation *gen);
+ void reset_generation(nursery_space *gen);
+ void reset_generation(aging_space *gen);
+ void reset_generation(tenured_space *gen);
+ bool low_memory_p();
+ void mark_all_cards();
+};
+
+struct data_heap_room {
+ cell nursery_size;
+ cell nursery_occupied;
+ cell nursery_free;
+ cell aging_size;
+ cell aging_occupied;
+ cell aging_free;
+ cell tenured_size;
+ cell tenured_occupied;
+ cell tenured_total_free;
+ cell tenured_contiguous_free;
+ cell tenured_free_block_count;
+ cell cards;
+ cell decks;
+ cell mark_stack;
};
}
--- /dev/null
+namespace factor
+{
+
+template<typename Type>
+struct data_root : public tagged<Type> {
+ factor_vm *parent;
+
+ void push()
+ {
+ parent->data_roots.push_back(data_root_range(&this->value_,1));
+ }
+
+ explicit data_root(cell value_, factor_vm *parent_)
+ : tagged<Type>(value_), parent(parent_)
+ {
+ push();
+ }
+
+ explicit data_root(Type *value_, factor_vm *parent_) :
+ tagged<Type>(value_), parent(parent_)
+ {
+ push();
+ }
+
+ const data_root<Type>& operator=(const Type *x) { tagged<Type>::operator=(x); return *this; }
+ const data_root<Type>& operator=(const cell &x) { tagged<Type>::operator=(x); return *this; }
+
+ ~data_root()
+ {
+ parent->data_roots.pop_back();
+ }
+};
+
+/* A similar hack for the bignum implementation */
+struct gc_bignum {
+ bignum **addr;
+ factor_vm *parent;
+
+ gc_bignum(bignum **addr_, factor_vm *parent_) : addr(addr_), parent(parent_)
+ {
+ if(*addr_) parent->check_data_pointer(*addr_);
+ parent->bignum_roots.push_back((cell)addr);
+ }
+
+ ~gc_bignum()
+ {
+#ifdef FACTOR_DEBUG
+ assert(parent->bignum_roots.back() == (cell)addr);
+#endif
+ parent->bignum_roots.pop_back();
+ }
+};
+
+#define GC_BIGNUM(x) gc_bignum x##__data_root(&x,this)
+
+}
namespace factor
{
-void factor_vm::print_chars(string* str)
+std::ostream &operator<<(std::ostream &out, const string *str)
{
- cell i;
- for(i = 0; i < string_capacity(str); i++)
- putchar(string_nth(str,i));
+ for(cell i = 0; i < string_capacity(str); i++)
+ out << (char)str->nth(i);
+ return out;
}
void factor_vm::print_word(word* word, cell nesting)
{
if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
- {
- print_chars(untag<string>(word->vocabulary));
- print_string(":");
- }
+ std::cout << untag<string>(word->vocabulary) << ":";
if(tagged<object>(word->name).type_p(STRING_TYPE))
- print_chars(untag<string>(word->name));
+ std::cout << untag<string>(word->name);
else
{
- print_string("#<not a string: ");
+ std::cout << "#<not a string: ";
print_nested_obj(word->name,nesting);
- print_string(">");
+ std::cout << ">";
}
}
-void factor_vm::print_factor_string(string* str)
+void factor_vm::print_factor_string(string *str)
{
- putchar('"');
- print_chars(str);
- putchar('"');
+ std::cout << '"' << str << '"';
}
void factor_vm::print_array(array* array, cell nesting)
for(i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(array_nth(array,i),nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_tuple(tuple *tuple, cell nesting)
tuple_layout *layout = untag<tuple_layout>(tuple->layout);
cell length = to_fixnum(layout->size);
- print_string(" ");
+ std::cout << " ";
print_nested_obj(layout->klass,nesting);
- cell i;
bool trimmed;
-
if(length > 10 && !full_output)
{
trimmed = true;
else
trimmed = false;
- for(i = 0; i < length; i++)
+ for(cell i = 0; i < length; i++)
{
- print_string(" ");
+ std::cout << " ";
print_nested_obj(tuple->data()[i],nesting);
}
if(trimmed)
- print_string("...");
+ std::cout << "...";
}
void factor_vm::print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
- print_string(" ... ");
+ std::cout << " ... ";
return;
}
switch(tagged<object>(obj).type())
{
case FIXNUM_TYPE:
- print_fixnum(untag_fixnum(obj));
+ std::cout << untag_fixnum(obj);
break;
case WORD_TYPE:
print_word(untag<word>(obj),nesting - 1);
print_factor_string(untag<string>(obj));
break;
case F_TYPE:
- print_string("f");
+ std::cout << "f";
break;
case TUPLE_TYPE:
- print_string("T{");
+ std::cout << "T{";
print_tuple(untag<tuple>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case ARRAY_TYPE:
- print_string("{");
+ std::cout << "{";
print_array(untag<array>(obj),nesting - 1);
- print_string(" }");
+ std::cout << " }";
break;
case QUOTATION_TYPE:
- print_string("[");
+ std::cout << "[";
quot = untag<quotation>(obj);
print_array(untag<array>(quot->array),nesting - 1);
- print_string(" ]");
+ std::cout << " ]";
break;
default:
- print_string("#<type ");
- print_cell(tagged<object>(obj).type());
- print_string(" @ ");
- print_cell_hex(obj);
- print_string(">");
+ std::cout << "#<type " << tagged<object>(obj).type() << " @ ";
+ std::cout << std::hex << obj << std::dec << ">";
break;
}
}
for(; start <= end; start++)
{
print_obj(*start);
- nl();
+ std::cout << std::endl;
}
}
void factor_vm::print_datastack()
{
- print_string("==== DATA STACK:\n");
+ std::cout << "==== DATA STACK:\n";
print_objects((cell *)ds_bot,(cell *)ds);
}
void factor_vm::print_retainstack()
{
- print_string("==== RETAIN STACK:\n");
+ std::cout << "==== RETAIN STACK:\n";
print_objects((cell *)rs_bot,(cell *)rs);
}
void operator()(stack_frame *frame)
{
parent->print_obj(parent->frame_executing(frame));
- print_string("\n");
+ std::cout << std::endl;
parent->print_obj(parent->frame_scan(frame));
- print_string("\n");
- print_string("word/quot addr: ");
- print_cell_hex((cell)parent->frame_executing(frame));
- print_string("\n");
- print_string("word/quot xt: ");
- print_cell_hex((cell)frame->xt);
- print_string("\n");
- print_string("return address: ");
- print_cell_hex((cell)FRAME_RETURN_ADDRESS(frame,parent));
- print_string("\n");
+ std::cout << std::endl;
+ std::cout << "word/quot addr: ";
+ std::cout << std::hex << (cell)parent->frame_executing(frame) << std::dec;
+ std::cout << std::endl;
+ std::cout << "word/quot xt: ";
+ std::cout << std::hex << (cell)frame->xt << std::dec;
+ std::cout << std::endl;
+ std::cout << "return address: ";
+ std::cout << std::hex << (cell)FRAME_RETURN_ADDRESS(frame,parent) << std::dec;
+ std::cout << std::endl;
}
};
void factor_vm::print_callstack()
{
- print_string("==== CALL STACK:\n");
+ std::cout << "==== CALL STACK:\n";
stack_frame_printer printer(this);
iterate_callstack(ctx,printer);
}
+struct padded_address {
+ cell value;
+
+ explicit padded_address(cell value_) : value(value_) {}
+};
+
+std::ostream &operator<<(std::ostream &out, const padded_address &value)
+{
+ char prev = out.fill('0');
+ out.width(sizeof(cell) * 2);
+ out << std::hex << value.value << std::dec;
+ out.fill(prev);
+ return out;
+}
+
void factor_vm::dump_cell(cell x)
{
- print_cell_hex_pad(x); print_string(": ");
+ std::cout << padded_address(x) << ": ";
x = *(cell *)x;
- print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x));
- nl();
+ std::cout << padded_address(x) << " tag " << TAG(x) << std::endl;
}
void factor_vm::dump_memory(cell from, cell to)
dump_cell(from);
}
-void factor_vm::dump_zone(const char *name, zone *z)
+template<typename Generation>
+void factor_vm::dump_generation(const char *name, Generation *gen)
{
- print_string(name); print_string(": ");
- print_string("Start="); print_cell(z->start);
- print_string(", size="); print_cell(z->size);
- print_string(", here="); print_cell(z->here - z->start); nl();
+ std::cout << name << ": ";
+ std::cout << "Start=" << gen->start;
+ std::cout << ", size=" << gen->size;
+ std::cout << ", end=" << gen->end;
+ std::cout << std::endl;
}
void factor_vm::dump_generations()
{
- dump_zone("Nursery",&nursery);
- dump_zone("Aging",data->aging);
- dump_zone("Tenured",data->tenured);
-
- print_string("Cards: base=");
- print_cell((cell)data->cards);
- print_string(", size=");
- print_cell((cell)(data->cards_end - data->cards));
- nl();
+ dump_generation("Nursery",&nursery);
+ dump_generation("Aging",data->aging);
+ dump_generation("Tenured",data->tenured);
+
+ std::cout << "Cards:";
+ std::cout << "base=" << (cell)data->cards << ", ";
+ std::cout << "size=" << (cell)(data->cards_end - data->cards) << std::endl;
}
-void factor_vm::dump_objects(cell type)
-{
- primitive_full_gc();
- begin_scan();
+struct object_dumper {
+ factor_vm *parent;
+ cell type;
- cell obj;
- while(to_boolean(obj = next_object()))
+ explicit object_dumper(factor_vm *parent_, cell type_) :
+ parent(parent_), type(type_) {}
+
+ void operator()(object *obj)
{
- if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
+ if(type == TYPE_COUNT || obj->h.hi_tag() == type)
{
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
+ std::cout << padded_address((cell)obj) << " ";
+ parent->print_nested_obj(tag_dynamic(obj),2);
+ std::cout << std::endl;
}
}
+};
- end_scan();
+void factor_vm::dump_objects(cell type)
+{
+ primitive_full_gc();
+ object_dumper dumper(this,type);
+ each_object(dumper);
}
-struct data_references_finder {
- cell look_for, obj;
+struct data_reference_slot_visitor {
+ cell look_for;
+ object *obj;
factor_vm *parent;
- explicit data_references_finder(cell look_for_, cell obj_, factor_vm *parent_)
- : look_for(look_for_), obj(obj_), parent(parent_) { }
+ explicit data_reference_slot_visitor(cell look_for_, object *obj_, factor_vm *parent_) :
+ look_for(look_for_), obj(obj_), parent(parent_) { }
void operator()(cell *scan)
{
if(look_for == *scan)
{
- print_cell_hex_pad(obj);
- print_string(" ");
- parent->print_nested_obj(obj,2);
- nl();
+ std::cout << padded_address((cell)obj) << " ";
+ parent->print_nested_obj(tag_dynamic(obj),2);
+ std::cout << std::endl;
}
}
};
-void factor_vm::find_data_references(cell look_for)
-{
- begin_scan();
+struct data_reference_object_visitor {
+ cell look_for;
+ factor_vm *parent;
- cell obj;
+ explicit data_reference_object_visitor(cell look_for_, factor_vm *parent_) :
+ look_for(look_for_), parent(parent_) {}
- while(to_boolean(obj = next_object()))
+ void operator()(object *obj)
{
- data_references_finder finder(look_for,obj,this);
- do_slots(UNTAG(obj),finder);
+ data_reference_slot_visitor visitor(look_for,obj,parent);
+ parent->do_slots(obj,visitor);
}
+};
- end_scan();
+void factor_vm::find_data_references(cell look_for)
+{
+ data_reference_object_visitor visitor(look_for,this);
+ each_object(visitor);
}
-/* Dump all code blocks for debugging */
-void factor_vm::dump_code_heap()
-{
- cell reloc_size = 0, literal_size = 0;
+struct code_block_printer {
+ factor_vm *parent;
+ cell reloc_size, literal_size;
- heap_block *scan = code->first_block();
+ explicit code_block_printer(factor_vm *parent_) :
+ parent(parent_), reloc_size(0), literal_size(0) {}
- while(scan)
+ void operator()(code_block *scan, cell size)
{
const char *status;
- if(scan->type() == FREE_BLOCK_TYPE)
+ if(scan->free_p())
status = "free";
- else if(code->state->is_marked_p(scan))
+ else if(parent->code->marked_p(scan))
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "marked";
}
else
{
- reloc_size += object_size(((code_block *)scan)->relocation);
- literal_size += object_size(((code_block *)scan)->literals);
+ reloc_size += parent->object_size(scan->relocation);
+ literal_size += parent->object_size(scan->literals);
status = "allocated";
}
- print_cell_hex((cell)scan); print_string(" ");
- print_cell_hex(scan->size()); print_string(" ");
- print_string(status); print_string("\n");
-
- scan = code->next_block(scan);
+ std::cout << std::hex << (cell)scan << std::dec << " ";
+ std::cout << std::hex << size << std::dec << " ";
+ std::cout << status << std::endl;
}
-
- print_cell(reloc_size); print_string(" bytes of relocation data\n");
- print_cell(literal_size); print_string(" bytes of literal data\n");
+};
+
+/* Dump all code blocks for debugging */
+void factor_vm::dump_code_heap()
+{
+ code_block_printer printer(this);
+ code->allocator->iterate(printer);
+ std::cout << printer.reloc_size << " bytes of relocation data\n";
+ std::cout << printer.literal_size << " bytes of literal data\n";
}
void factor_vm::factorbug()
{
if(fep_disabled)
{
- print_string("Low level debugger disabled\n");
+ std::cout << "Low level debugger disabled\n";
exit(1);
}
/* open_console(); */
- print_string("Starting low level debugger...\n");
- print_string(" Basic commands:\n");
- print_string("q -- continue executing Factor - NOT SAFE\n");
- print_string("im -- save image to fep.image\n");
- print_string("x -- exit Factor\n");
- print_string(" Advanced commands:\n");
- print_string("d <addr> <count> -- dump memory\n");
- print_string("u <addr> -- dump object at tagged <addr>\n");
- print_string(". <addr> -- print object at tagged <addr>\n");
- print_string("t -- toggle output trimming\n");
- print_string("s r -- dump data, retain stacks\n");
- print_string(".s .r .c -- print data, retain, call stacks\n");
- print_string("e -- dump environment\n");
- print_string("g -- dump generations\n");
- print_string("data -- data heap dump\n");
- print_string("words -- words dump\n");
- print_string("tuples -- tuples dump\n");
- print_string("refs <addr> -- find data heap references to object\n");
- print_string("push <addr> -- push object on data stack - NOT SAFE\n");
- print_string("code -- code heap dump\n");
+ std::cout << "Starting low level debugger...\n";
+ std::cout << " Basic commands:\n";
+ std::cout << "q -- continue executing Factor - NOT SAFE\n";
+ std::cout << "im -- save image to fep.image\n";
+ std::cout << "x -- exit Factor\n";
+ std::cout << " Advanced commands:\n";
+ std::cout << "d <addr> <count> -- dump memory\n";
+ std::cout << "u <addr> -- dump object at tagged <addr>\n";
+ std::cout << ". <addr> -- print object at tagged <addr>\n";
+ std::cout << "t -- toggle output trimming\n";
+ std::cout << "s r -- dump data, retain stacks\n";
+ std::cout << ".s .r .c -- print data, retain, call stacks\n";
+ std::cout << "e -- dump environment\n";
+ std::cout << "g -- dump generations\n";
+ std::cout << "data -- data heap dump\n";
+ std::cout << "words -- words dump\n";
+ std::cout << "tuples -- tuples dump\n";
+ std::cout << "refs <addr> -- find data heap references to object\n";
+ std::cout << "push <addr> -- push object on data stack - NOT SAFE\n";
+ std::cout << "code -- code heap dump\n";
bool seen_command = false;
{
char cmd[1024];
- print_string("READY\n");
+ std::cout << "READY\n";
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
{
cell addr = read_cell_hex();
print_obj(addr);
- print_string("\n");
+ std::cout << std::endl;
}
else if(strcmp(cmd,"t") == 0)
full_output = !full_output;
print_callstack();
else if(strcmp(cmd,"e") == 0)
{
- int i;
- for(i = 0; i < USER_ENV; i++)
- dump_cell((cell)&userenv[i]);
+ for(cell i = 0; i < special_object_count; i++)
+ dump_cell((cell)&special_objects[i]);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
else if(strcmp(cmd,"refs") == 0)
{
cell addr = read_cell_hex();
- print_string("Data heap references:\n");
+ std::cout << "Data heap references:\n";
find_data_references(addr);
- nl();
+ std::cout << std::endl;
}
else if(strcmp(cmd,"words") == 0)
dump_objects(WORD_TYPE);
else if(strcmp(cmd,"code") == 0)
dump_code_heap();
else
- print_string("unknown command\n");
+ std::cout << "unknown command\n";
}
}
void factor_vm::primitive_die()
{
- print_string("The die word was called by the library. Unless you called it yourself,\n");
- print_string("you have triggered a bug in Factor. Please report.\n");
+ std::cout << "The die word was called by the library. Unless you called it yourself,\n";
+ std::cout << "you have triggered a bug in Factor. Please report.\n";
factorbug();
}
{
array *buckets = untag<array>(table);
cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
- if(tagged<object>(bucket).type_p(WORD_TYPE) || !to_boolean(bucket))
- return bucket;
- else
+ if(TAG(bucket) == ARRAY_TYPE)
return search_lookup_alist(bucket,klass);
+ else
+ return bucket;
}
cell factor_vm::nth_superclass(tuple_layout *layout, fixnum echelon)
array *echelons = untag<array>(methods);
- fixnum echelon = untag_fixnum(layout->echelon);
- fixnum max_echelon = array_capacity(echelons) - 1;
- if(echelon > max_echelon) echelon = max_echelon;
-
+ fixnum echelon = std::min(untag_fixnum(layout->echelon),(fixnum)array_capacity(echelons) - 1);
+
while(echelon >= 0)
{
cell echelon_methods = array_nth(echelons,echelon);
return false_object;
}
-cell factor_vm::lookup_hi_tag_method(cell obj, cell methods)
+cell factor_vm::lookup_method(cell obj, cell methods)
{
- array *hi_tag_methods = untag<array>(methods);
- cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
-#ifdef FACTOR_DEBUG
- assert(tag < TYPE_COUNT - HEADER_TYPE);
-#endif
- return array_nth(hi_tag_methods,tag);
-}
+ cell tag = TAG(obj);
+ cell method = array_nth(untag<array>(methods),tag);
-cell factor_vm::lookup_hairy_method(cell obj, cell methods)
-{
- cell method = array_nth(untag<array>(methods),TAG(obj));
- if(tagged<object>(method).type_p(WORD_TYPE))
- return method;
- else
+ if(tag == TUPLE_TYPE)
{
- switch(TAG(obj))
- {
- case TUPLE_TYPE:
+ if(TAG(method) == ARRAY_TYPE)
return lookup_tuple_method(obj,method);
- break;
- case OBJECT_TYPE:
- return lookup_hi_tag_method(obj,method);
- break;
- default:
- critical_error("Bad methods array",methods);
- return 0;
- }
+ else
+ return method;
}
-}
-
-cell factor_vm::lookup_method(cell obj, cell methods)
-{
- cell tag = TAG(obj);
- if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
- return lookup_hairy_method(obj,methods);
else
- return array_nth(untag<array>(methods),TAG(obj));
+ return method;
}
void factor_vm::primitive_lookup_method()
cell factor_vm::object_class(cell obj)
{
- switch(TAG(obj))
- {
- case TUPLE_TYPE:
+ cell tag = TAG(obj);
+ if(tag == TUPLE_TYPE)
return untag<tuple>(obj)->layout;
- case OBJECT_TYPE:
- return untag<object>(obj)->h.value;
- default:
- return tag_fixnum(TAG(obj));
- }
+ else
+ return tag_fixnum(tag);
}
cell factor_vm::method_cache_hashcode(cell klass, array *array)
void factor_vm::primitive_mega_cache_miss()
{
- megamorphic_cache_misses++;
+ dispatch_stats.megamorphic_cache_misses++;
cell cache = dpop();
fixnum index = untag_fixnum(dpop());
void factor_vm::primitive_reset_dispatch_stats()
{
- megamorphic_cache_hits = megamorphic_cache_misses = 0;
+ memset(&dispatch_stats,0,sizeof(dispatch_statistics));
}
void factor_vm::primitive_dispatch_stats()
{
- growable_array stats(this);
- stats.add(allot_cell(megamorphic_cache_hits));
- stats.add(allot_cell(megamorphic_cache_misses));
- stats.trim();
- dpush(stats.elements.value());
+ dpush(tag<byte_array>(byte_array_from_value(&dispatch_stats)));
}
void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
{
- gc_root<array> methods(methods_,parent);
- gc_root<array> cache(cache_,parent);
+ data_root<array> methods(methods_,parent);
+ data_root<array> cache(cache_,parent);
/* Generate machine code to determine the object's class. */
- emit_class_lookup(index,PIC_HI_TAG_TUPLE);
+ emit_class_lookup(index,PIC_TUPLE);
/* Do a cache lookup. */
- emit_with(parent->userenv[MEGA_LOOKUP],cache.value());
+ emit_with(parent->special_objects[MEGA_LOOKUP],cache.value());
/* If we end up here, the cache missed. */
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
/* Push index, method table and cache on the stack. */
push(methods.value());
push(tag_fixnum(index));
push(cache.value());
- word_call(parent->userenv[MEGA_MISS_WORD]);
+ word_call(parent->special_objects[MEGA_MISS_WORD]);
/* Now the new method has been stored into the cache, and its on
the stack. */
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
}
namespace factor
{
+struct dispatch_statistics {
+ cell megamorphic_cache_hits;
+ cell megamorphic_cache_misses;
+
+ cell cold_call_to_ic_transitions;
+ cell ic_to_pic_transitions;
+ cell pic_to_mega_transitions;
+
+ cell pic_tag_count;
+ cell pic_tuple_count;
+};
+
}
void fatal_error(const char *msg, cell tagged)
{
- print_string("fatal_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "fatal_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
exit(1);
}
void critical_error(const char *msg, cell tagged)
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("critical_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "critical_error: " << msg;
+ std::cout << ": " << std::hex << tagged << std::dec;
+ std::cout << std::endl;
tls_vm()->factorbug();
}
void out_of_memory()
{
- print_string("Out of memory\n\n");
+ std::cout << "Out of memory\n\n";
tls_vm()->dump_generations();
exit(1);
}
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
- if(!current_gc && to_boolean(userenv[BREAK_ENV]))
+ if(!current_gc && to_boolean(special_objects[OBJ_BREAK]))
{
/* If error was thrown during heap scan, we re-enable the GC */
gc_off = false;
/* Reset local roots */
- gc_locals.clear();
- gc_bignums.clear();
+ data_roots.clear();
+ bignum_roots.clear();
+ code_roots.clear();
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
else
callstack_top = ctx->callstack_top;
- throw_impl(userenv[BREAK_ENV],callstack_top,this);
+ throw_impl(special_objects[OBJ_BREAK],callstack_top,this);
}
/* Error was thrown in early startup before error handler is set, just
crash. */
else
{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("early_error: ");
+ std::cout << "You have triggered a bug in Factor. Please report.\n";
+ std::cout << "early_error: ";
print_obj(error);
- nl();
+ std::cout << std::endl;
factorbug();
}
}
void factor_vm::general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *callstack_top)
{
- throw_error(allot_array_4(userenv[ERROR_ENV],
+ throw_error(allot_array_4(special_objects[OBJ_ERROR],
tag_fixnum(error),arg1,arg2),callstack_top);
}
ERROR_ARRAY_SIZE,
ERROR_C_STRING,
ERROR_FFI,
- ERROR_HEAP_SCAN,
ERROR_UNDEFINED_SYMBOL,
ERROR_DS_UNDERFLOW,
ERROR_DS_OVERFLOW,
{
factor_vm *vm;
-unordered_map<THREADHANDLE, factor_vm*> thread_vms;
+std::map<THREADHANDLE, factor_vm*> thread_vms;
void init_globals()
{
{
p->image_path = NULL;
- /* We make a wild guess here that if we're running on ARM, we don't
- have a lot of memory. */
-#ifdef FACTOR_ARM
- p->ds_size = 8 * sizeof(cell);
- p->rs_size = 8 * sizeof(cell);
-
- p->code_size = 4;
- p->young_size = 1;
- p->aging_size = 1;
- p->tenured_size = 6;
-#else
p->ds_size = 32 * sizeof(cell);
p->rs_size = 32 * sizeof(cell);
p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4;
p->aging_size = sizeof(cell) / 2;
- p->tenured_size = 4 * sizeof(cell);
-#endif
+ p->tenured_size = 24 * sizeof(cell);
p->max_pic_size = 3;
- p->secure_gc = false;
p->fep = false;
p->signals = true;
else if(factor_arg(arg,STRING_LITERAL("-codeheap=%d"),&p->code_size));
else if(factor_arg(arg,STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(factor_arg(arg,STRING_LITERAL("-callbacks=%d"),&p->callback_size));
- else if(STRCMP(arg,STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(arg,STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRCMP(arg,STRING_LITERAL("-nosignals")) == 0) p->signals = false;
else if(STRNCMP(arg,STRING_LITERAL("-i="),3) == 0) p->image_path = arg + 3;
/* Do some initialization that we do once only */
void factor_vm::do_stage1_init()
{
- print_string("*** Stage 2 early init... ");
+ std::cout << "*** Stage 2 early init... ";
fflush(stdout);
compile_all_words();
- userenv[STAGE2_ENV] = true_object;
+ update_code_heap_words();
+ special_objects[OBJ_STAGE2] = true_object;
- print_string("done\n");
- fflush(stdout);
+ std::cout << "done\n";
}
void factor_vm::init_factor(vm_parameters *p)
init_profiler();
- userenv[CPU_ENV] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
- userenv[OS_ENV] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(cell));
- userenv[EXECUTABLE_ENV] = allot_alien(false_object,(cell)p->executable_path);
- userenv[ARGS_ENV] = false_object;
- userenv[EMBEDDED_ENV] = false_object;
+ special_objects[OBJ_CPU] = allot_alien(false_object,(cell)FACTOR_CPU_STRING);
+ special_objects[OBJ_OS] = allot_alien(false_object,(cell)FACTOR_OS_STRING);
+ special_objects[OBJ_CELL_SIZE] = tag_fixnum(sizeof(cell));
+ special_objects[OBJ_EXECUTABLE] = allot_alien(false_object,(cell)p->executable_path);
+ special_objects[OBJ_ARGS] = false_object;
+ special_objects[OBJ_EMBEDDED] = false_object;
/* We can GC now */
gc_off = false;
- if(!to_boolean(userenv[STAGE2_ENV]))
+ if(!to_boolean(special_objects[OBJ_STAGE2]))
do_stage1_init();
}
}
args.trim();
- userenv[ARGS_ENV] = args.elements.value();
+ special_objects[OBJ_ARGS] = args.elements.value();
}
void factor_vm::start_factor(vm_parameters *p)
if(p->fep) factorbug();
nest_stacks(NULL);
- c_to_factor_toplevel(userenv[BOOT_ENV]);
+ c_to_factor_toplevel(special_objects[OBJ_BOOT]);
unnest_stacks();
}
char *factor_vm::factor_eval_string(char *string)
{
- char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(special_objects[OBJ_EVAL_CALLBACK]);
return callback(string);
}
void factor_vm::factor_yield()
{
- void (*callback)() = (void (*)())alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)() = (void (*)())alien_offset(special_objects[OBJ_YIELD_CALLBACK]);
callback();
}
void factor_vm::factor_sleep(long us)
{
- void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ void (*callback)(long) = (void (*)(long))alien_offset(special_objects[OBJ_SLEEP_CALLBACK]);
callback(us);
}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void free_list::clear_free_list()
+{
+ for(cell i = 0; i < free_list_count; i++)
+ small_blocks[i].clear();
+ large_blocks.clear();
+ free_block_count = 0;
+ free_space = 0;
+}
+
+void free_list::initial_free_list(cell start, cell end, cell occupied)
+{
+ clear_free_list();
+ if(occupied != end - start)
+ {
+ free_heap_block *last_block = (free_heap_block *)(start + occupied);
+ last_block->make_free(end - (cell)last_block);
+ add_to_free_list(last_block);
+ }
+}
+
+void free_list::add_to_free_list(free_heap_block *block)
+{
+ cell size = block->size();
+
+ free_block_count++;
+ free_space += size;
+
+ if(size < free_list_count * block_granularity)
+ small_blocks[size / block_granularity].push_back(block);
+ else
+ large_blocks.insert(block);
+}
+
+free_heap_block *free_list::find_free_block(cell size)
+{
+ /* Check small free lists */
+ for(cell i = size / block_granularity; i < free_list_count; i++)
+ {
+ std::vector<free_heap_block *> &blocks = small_blocks[i];
+ if(blocks.size())
+ {
+ free_heap_block *block = blocks.back();
+ blocks.pop_back();
+
+ free_block_count--;
+ free_space -= block->size();
+
+ return block;
+ }
+ }
+
+ /* Check large free lists */
+ free_heap_block key;
+ key.make_free(size);
+ large_block_set::iterator iter = large_blocks.lower_bound(&key);
+ large_block_set::iterator end = large_blocks.end();
+
+ if(iter != end)
+ {
+ free_heap_block *block = *iter;
+ large_blocks.erase(iter);
+
+ free_block_count--;
+ free_space -= block->size();
+
+ return block;
+ }
+
+ return NULL;
+}
+
+free_heap_block *free_list::split_free_block(free_heap_block *block, cell size)
+{
+ if(block->size() != size)
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->make_free(block->size() - size);
+ block->make_free(size);
+ add_to_free_list(split);
+ }
+
+ return block;
+}
+
+bool free_list::can_allot_p(cell size)
+{
+ /* Check small free lists */
+ for(cell i = size / block_granularity; i < free_list_count; i++)
+ {
+ if(small_blocks[i].size()) return true;
+ }
+
+ /* Check large free lists */
+ large_block_set::const_iterator iter = large_blocks.begin();
+ large_block_set::const_iterator end = large_blocks.end();
+
+ for(; iter != end; iter++)
+ {
+ if((*iter)->size() >= size) return true;
+ }
+
+ return false;
+}
+
+cell free_list::largest_free_block()
+{
+ if(large_blocks.size())
+ {
+ large_block_set::reverse_iterator last = large_blocks.rbegin();
+ return (*last)->size();
+ }
+ else
+ {
+ for(int i = free_list_count - 1; i >= 0; i--)
+ {
+ if(small_blocks[i].size())
+ return small_blocks[i].back()->size();
+ }
+
+ return 0;
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell free_list_count = 32;
+
+struct free_heap_block
+{
+ cell header;
+
+ bool free_p() const
+ {
+ return (header & 1) == 1;
+ }
+
+ cell size() const
+ {
+ return header & ~7;
+ }
+
+ void make_free(cell size)
+ {
+ header = size | 1;
+ }
+};
+
+struct block_size_compare {
+ bool operator()(free_heap_block *a, free_heap_block *b)
+ {
+ return a->size() < b->size();
+ }
+};
+
+typedef std::multiset<free_heap_block *, block_size_compare> large_block_set;
+
+struct free_list {
+ std::vector<free_heap_block *> small_blocks[free_list_count];
+ large_block_set large_blocks;
+ cell free_block_count;
+ cell free_space;
+
+ void clear_free_list();
+ void initial_free_list(cell start, cell end, cell occupied);
+ void add_to_free_list(free_heap_block *block);
+ free_heap_block *find_free_block(cell size);
+ free_heap_block *split_free_block(free_heap_block *block, cell size);
+ bool can_allot_p(cell size);
+ cell largest_free_block();
+};
+
+}
--- /dev/null
+namespace factor
+{
+
+template<typename Block> struct free_list_allocator {
+ cell size;
+ cell start;
+ cell end;
+ free_list free_blocks;
+ mark_bits<Block> state;
+
+ explicit free_list_allocator(cell size, cell start);
+ void initial_free_list(cell occupied);
+ bool contains_p(Block *block);
+ Block *first_block();
+ Block *last_block();
+ Block *next_block_after(Block *block);
+ Block *next_allocated_block_after(Block *block);
+ bool can_allot_p(cell size);
+ Block *allot(cell size);
+ void free(Block *block);
+ cell occupied_space();
+ cell free_space();
+ cell largest_free_block();
+ cell free_block_count();
+ void sweep();
+ template<typename Iterator, typename Sizer> void compact(Iterator &iter, Sizer &sizer);
+ template<typename Iterator, typename Sizer> void iterate(Iterator &iter, Sizer &sizer);
+ template<typename Iterator> void iterate(Iterator &iter);
+};
+
+template<typename Block>
+free_list_allocator<Block>::free_list_allocator(cell size_, cell start_) :
+ size(size_),
+ start(start_),
+ end(start_ + size_),
+ state(mark_bits<Block>(size_,start_))
+{
+ initial_free_list(0);
+}
+
+template<typename Block> void free_list_allocator<Block>::initial_free_list(cell occupied)
+{
+ free_blocks.initial_free_list(start,end,occupied);
+}
+
+template<typename Block> bool free_list_allocator<Block>::contains_p(Block *block)
+{
+ return ((cell)block - start) < size;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::first_block()
+{
+ return (Block *)start;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::last_block()
+{
+ return (Block *)end;
+}
+
+template<typename Block> Block *free_list_allocator<Block>::next_block_after(Block *block)
+{
+ return (Block *)((cell)block + block->size());
+}
+
+template<typename Block> Block *free_list_allocator<Block>::next_allocated_block_after(Block *block)
+{
+ while(block != this->last_block() && block->free_p())
+ {
+ free_heap_block *free_block = (free_heap_block *)block;
+ block = (object *)((cell)free_block + free_block->size());
+ }
+
+ if(block == this->last_block())
+ return NULL;
+ else
+ return block;
+}
+
+template<typename Block> bool free_list_allocator<Block>::can_allot_p(cell size)
+{
+ return free_blocks.can_allot_p(size);
+}
+
+template<typename Block> Block *free_list_allocator<Block>::allot(cell size)
+{
+ size = align(size,block_granularity);
+
+ free_heap_block *block = free_blocks.find_free_block(size);
+ if(block)
+ {
+ block = free_blocks.split_free_block(block,size);
+ return (Block *)block;
+ }
+ else
+ return NULL;
+}
+
+template<typename Block> void free_list_allocator<Block>::free(Block *block)
+{
+ free_heap_block *free_block = (free_heap_block *)block;
+ free_block->make_free(block->size());
+ free_blocks.add_to_free_list(free_block);
+}
+
+template<typename Block> cell free_list_allocator<Block>::free_space()
+{
+ return free_blocks.free_space;
+}
+
+template<typename Block> cell free_list_allocator<Block>::occupied_space()
+{
+ return size - free_blocks.free_space;
+}
+
+template<typename Block> cell free_list_allocator<Block>::largest_free_block()
+{
+ return free_blocks.largest_free_block();
+}
+
+template<typename Block> cell free_list_allocator<Block>::free_block_count()
+{
+ return free_blocks.free_block_count;
+}
+
+template<typename Block>
+void free_list_allocator<Block>::sweep()
+{
+ free_blocks.clear_free_list();
+
+ Block *start = this->first_block();
+ Block *end = this->last_block();
+
+ while(start != end)
+ {
+ /* find next unmarked block */
+ start = state.next_unmarked_block_after(start);
+
+ if(start != end)
+ {
+ /* find size */
+ cell size = state.unmarked_block_size(start);
+ assert(size > 0);
+
+ free_heap_block *free_block = (free_heap_block *)start;
+ free_block->make_free(size);
+ free_blocks.add_to_free_list(free_block);
+
+ start = (Block *)((char *)start + size);
+ }
+ }
+}
+
+template<typename Block, typename Iterator> struct heap_compactor {
+ mark_bits<Block> *state;
+ char *address;
+ Iterator &iter;
+
+ explicit heap_compactor(mark_bits<Block> *state_, Block *address_, Iterator &iter_) :
+ state(state_), address((char *)address_), iter(iter_) {}
+
+ void operator()(Block *block, cell size)
+ {
+ if(this->state->marked_p(block))
+ {
+ iter(block,(Block *)address,size);
+ address += size;
+ }
+ }
+};
+
+/* The forwarding map must be computed first by calling
+state.compute_forwarding(). */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::compact(Iterator &iter, Sizer &sizer)
+{
+ heap_compactor<Block,Iterator> compactor(&state,first_block(),iter);
+ iterate(compactor,sizer);
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ free_blocks.initial_free_list(start,end,(cell)compactor.address - start);
+}
+
+/* During compaction we have to be careful and measure object sizes differently */
+template<typename Block>
+template<typename Iterator, typename Sizer>
+void free_list_allocator<Block>::iterate(Iterator &iter, Sizer &sizer)
+{
+ Block *scan = first_block();
+ Block *end = last_block();
+
+ while(scan != end)
+ {
+ cell size = sizer(scan);
+ Block *next = (Block *)((cell)scan + size);
+ if(!scan->free_p()) iter(scan,size);
+ scan = next;
+ }
+}
+
+template<typename Block> struct standard_sizer {
+ cell operator()(Block *block)
+ {
+ return block->size();
+ }
+};
+
+template<typename Block>
+template<typename Iterator>
+void free_list_allocator<Block>::iterate(Iterator &iter)
+{
+ standard_sizer<Block> sizer;
+ iterate(iter,sizer);
+}
+
+}
{
full_collector::full_collector(factor_vm *parent_) :
- copying_collector<tenured_space,full_policy>(
+ collector<tenured_space,full_policy>(
parent_,
- &parent_->gc_stats.full_stats,
parent_->data->tenured,
full_policy(parent_)) {}
-struct stack_frame_marker {
- factor_vm *parent;
- full_collector *collector;
+/* After a sweep, invalidate any code heap roots which are not marked,
+so that if a block makes a tail call to a generic word, and the PIC
+compiler triggers a GC, and the caller block gets gets GCd as a result,
+the PIC code won't try to overwrite the call site */
+void factor_vm::update_code_roots_for_sweep()
+{
+ std::vector<code_root *>::const_iterator iter = code_roots.begin();
+ std::vector<code_root *>::const_iterator end = code_roots.end();
- explicit stack_frame_marker(full_collector *collector_) :
- parent(collector_->parent), collector(collector_) {}
+ mark_bits<code_block> *state = &code->allocator->state;
- void operator()(stack_frame *frame)
+ for(; iter < end; iter++)
{
- collector->mark_code_block(parent->frame_code(frame));
+ code_root *root = *iter;
+ code_block *block = (code_block *)(root->value & -block_granularity);
+ if(root->valid && !state->marked_p(block))
+ root->valid = false;
}
-};
-
-/* Mark code blocks executing in currently active stack frames. */
-void full_collector::mark_active_blocks()
-{
- stack_frame_marker marker(this);
- parent->iterate_active_frames(marker);
}
-void full_collector::mark_object_code_block(object *obj)
+/* After a compaction, invalidate any code heap roots which are not
+marked as above, and also slide the valid roots up so that call sites
+can be updated correctly. */
+void factor_vm::update_code_roots_for_compaction()
{
- switch(obj->h.hi_tag())
- {
- case WORD_TYPE:
- {
- word *w = (word *)obj;
- if(w->code)
- mark_code_block(w->code);
- if(w->profiling)
- mark_code_block(w->profiling);
- break;
- }
- case QUOTATION_TYPE:
- {
- quotation *q = (quotation *)obj;
- if(q->code)
- mark_code_block(q->code);
- break;
- }
- case CALLSTACK_TYPE:
- {
- callstack *stack = (callstack *)obj;
- stack_frame_marker marker(this);
- parent->iterate_callstack_object(stack,marker);
- break;
- }
- }
-}
+ std::vector<code_root *>::const_iterator iter = code_roots.begin();
+ std::vector<code_root *>::const_iterator end = code_roots.end();
-struct callback_tracer {
- full_collector *collector;
+ mark_bits<code_block> *state = &code->allocator->state;
- callback_tracer(full_collector *collector_) : collector(collector_) {}
-
- void operator()(callback *stub)
+ for(; iter < end; iter++)
{
- collector->mark_code_block(stub->compiled);
- }
-};
+ code_root *root = *iter;
+ code_block *block = (code_block *)(root->value & -block_granularity);
-void full_collector::trace_callbacks()
-{
- callback_tracer tracer(this);
- parent->callbacks->iterate(tracer);
-}
-
-/* Trace all literals referenced from a code block. Only for aging and nursery collections */
-void full_collector::trace_literal_references(code_block *compiled)
-{
- this->trace_handle(&compiled->owner);
- this->trace_handle(&compiled->literals);
- this->trace_handle(&compiled->relocation);
-}
-
-/* Mark all literals referenced from a word XT. Only for tenured
-collections */
-void full_collector::mark_code_block(code_block *compiled)
-{
- this->code->mark_block(compiled);
- trace_literal_references(compiled);
-}
+ /* Offset of return address within 16-byte allocation line */
+ cell offset = root->value - (cell)block;
-void full_collector::cheneys_algorithm()
-{
- while(scan && scan < target->here)
- {
- object *obj = (object *)scan;
- this->trace_slots(obj);
- this->mark_object_code_block(obj);
- scan = target->next_object_after(this->parent,scan);
+ if(root->valid && state->marked_p((code_block *)root->value))
+ {
+ block = state->forward_block(block);
+ root->value = (cell)block + offset;
+ }
+ else
+ root->valid = false;
}
}
-/* After growing the heap, we have to perform a full relocation to update
-references to card and deck arrays. */
-struct big_code_heap_updater {
- factor_vm *parent;
+struct code_block_marker {
+ code_heap *code;
+ full_collector *collector;
- big_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+ explicit code_block_marker(code_heap *code_, full_collector *collector_) :
+ code(code_), collector(collector_) {}
- void operator()(heap_block *block)
+ code_block *operator()(code_block *compiled)
{
- parent->relocate_code_block((code_block *)block);
- }
-};
-
-/* After a full GC that did not grow the heap, we have to update references
-to literals and other words. */
-struct small_code_heap_updater {
- factor_vm *parent;
-
- small_code_heap_updater(factor_vm *parent_) : parent(parent_) {}
+ if(!code->marked_p(compiled))
+ {
+ code->set_marked_p(compiled);
+ collector->trace_literal_references(compiled);
+ }
- void operator()(heap_block *block)
- {
- parent->update_code_block_for_full_gc((code_block *)block);
+ return compiled;
}
};
-void factor_vm::collect_full_impl(bool trace_contexts_p)
+void factor_vm::collect_mark_impl(bool trace_contexts_p)
{
full_collector collector(this);
- code->state->clear_mark_bits();
+ code->clear_mark_bits();
+ data->tenured->clear_mark_bits();
+ data->tenured->clear_mark_stack();
+
+ code_block_visitor<code_block_marker> code_marker(this,code_block_marker(code,&collector));
collector.trace_roots();
if(trace_contexts_p)
{
collector.trace_contexts();
- collector.mark_active_blocks();
- collector.trace_callbacks();
+ code_marker.visit_context_code_blocks();
+ code_marker.visit_callback_code_blocks();
}
- collector.cheneys_algorithm();
-
- reset_generation(data->aging);
- nursery.here = nursery.start;
-}
-
-void factor_vm::collect_growing_heap(cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
-{
- /* Grow the data heap and copy all live objects to the new heap. */
- data_heap *old = data;
- set_data_heap(data->grow(requested_bytes));
- collect_full_impl(trace_contexts_p);
- delete old;
+ std::vector<object *> *mark_stack = &data->tenured->mark_stack;
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
- else
+ while(!mark_stack->empty())
{
- big_code_heap_updater updater(this);
- code->free_unmarked(updater);
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ collector.trace_object(obj);
+ code_marker.visit_object_code_block(obj);
}
+ data->reset_generation(data->tenured);
+ data->reset_generation(data->aging);
+ data->reset_generation(&nursery);
code->clear_remembered_set();
}
-void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p)
+void factor_vm::collect_sweep_impl()
{
- /* Copy all live objects to the tenured semispace. */
- std::swap(data->tenured,data->tenured_semispace);
- reset_generation(data->tenured);
- collect_full_impl(trace_contexts_p);
+ current_gc->event->started_data_sweep();
+ data->tenured->sweep();
+ update_code_roots_for_sweep();
+ current_gc->event->ended_data_sweep();
+
+ current_gc->event->started_code_sweep();
+ code->allocator->sweep();
+ current_gc->event->ended_code_sweep();
+}
- if(compact_code_heap_p)
- {
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
+void factor_vm::collect_full(bool trace_contexts_p)
+{
+ collect_mark_impl(trace_contexts_p);
+ collect_sweep_impl();
+ if(data->low_memory_p())
+ collect_compact_impl(trace_contexts_p);
else
- {
- small_code_heap_updater updater(this);
- code->free_unmarked(updater);
- }
+ update_code_heap_words_and_literals();
+}
- code->clear_remembered_set();
+void factor_vm::collect_compact(bool trace_contexts_p)
+{
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_impl(trace_contexts_p);
+}
+
+void factor_vm::collect_growing_heap(cell requested_bytes, bool trace_contexts_p)
+{
+ /* Grow the data heap and copy all live objects to the new heap. */
+ data_heap *old = data;
+ set_data_heap(data->grow(requested_bytes));
+ collect_mark_impl(trace_contexts_p);
+ collect_compact_code_impl(trace_contexts_p);
+ delete old;
}
}
struct full_policy {
factor_vm *parent;
- zone *tenured;
+ tenured_space *tenured;
- full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
+ explicit full_policy(factor_vm *parent_) : parent(parent_), tenured(parent->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_and_push(obj);
+ }
+
+ void visited_object(object *obj)
+ {
+ if(!tenured->marked_p(obj))
+ tenured->mark_and_push(obj);
+ }
};
-struct full_collector : copying_collector<tenured_space,full_policy> {
+struct full_collector : collector<tenured_space,full_policy> {
bool trace_contexts_p;
- full_collector(factor_vm *parent_);
- void mark_active_blocks();
- void mark_object_code_block(object *object);
- void trace_callbacks();
- void trace_literal_references(code_block *compiled);
- void mark_code_block(code_block *compiled);
- void cheneys_algorithm();
+ explicit full_collector(factor_vm *parent_);
};
}
namespace factor
{
-gc_state::gc_state(gc_op op_) : op(op_), start_time(current_micros()) {}
+gc_event::gc_event(gc_op op_, factor_vm *parent) :
+ op(op_),
+ cards_scanned(0),
+ decks_scanned(0),
+ code_blocks_scanned(0),
+ start_time(current_micros()),
+ card_scan_time(0),
+ code_scan_time(0),
+ data_sweep_time(0),
+ code_sweep_time(0),
+ compaction_time(0)
+{
+ data_heap_before = parent->data_room();
+ code_heap_before = parent->code_room();
+ start_time = current_micros();
+}
+
+void gc_event::started_card_scan()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_card_scan(cell cards_scanned_, cell decks_scanned_)
+{
+ cards_scanned += cards_scanned_;
+ decks_scanned += decks_scanned_;
+ card_scan_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_code_scan()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_code_scan(cell code_blocks_scanned_)
+{
+ code_blocks_scanned += code_blocks_scanned_;
+ code_scan_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_data_sweep()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_data_sweep()
+{
+ data_sweep_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_code_sweep()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_code_sweep()
+{
+ code_sweep_time = (current_micros() - temp_time);
+}
+
+void gc_event::started_compaction()
+{
+ temp_time = current_micros();
+}
+
+void gc_event::ended_compaction()
+{
+ compaction_time = (current_micros() - temp_time);
+}
+
+void gc_event::ended_gc(factor_vm *parent)
+{
+ data_heap_after = parent->data_room();
+ code_heap_after = parent->code_room();
+ total_time = current_micros() - start_time;
+}
+
+gc_state::gc_state(gc_op op_, factor_vm *parent) : op(op_), start_time(current_micros())
+{
+ event = new gc_event(op,parent);
+}
+
+gc_state::~gc_state()
+{
+ delete event;
+ event = NULL;
+}
+
+void factor_vm::end_gc()
+{
+ current_gc->event->ended_gc(this);
+ if(gc_events) gc_events->push_back(*current_gc->event);
+ delete current_gc->event;
+ current_gc->event = NULL;
+}
-gc_state::~gc_state() {}
+void factor_vm::start_gc_again()
+{
+ end_gc();
+
+ switch(current_gc->op)
+ {
+ case collect_nursery_op:
+ current_gc->op = collect_aging_op;
+ break;
+ case collect_aging_op:
+ current_gc->op = collect_to_tenured_op;
+ break;
+ case collect_to_tenured_op:
+ current_gc->op = collect_full_op;
+ break;
+ case collect_full_op:
+ case collect_compact_op:
+ current_gc->op = collect_growing_heap_op;
+ break;
+ default:
+ critical_error("Bad GC op",current_gc->op);
+ break;
+ }
+
+ current_gc->event = new gc_event(current_gc->op,this);
+}
void factor_vm::update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set)
{
for(; iter != end; iter++) update_literal_references(*iter);
}
-void factor_vm::record_gc_stats(generation_statistics *stats)
-{
- cell gc_elapsed = (current_micros() - current_gc->start_time);
- stats->collections++;
- stats->gc_time += gc_elapsed;
- if(stats->max_gc_time < gc_elapsed)
- stats->max_gc_time = gc_elapsed;
-}
-
-void factor_vm::gc(gc_op op,
- cell requested_bytes,
- bool trace_contexts_p,
- bool compact_code_heap_p)
+void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
{
assert(!gc_off);
assert(!current_gc);
save_stacks();
- current_gc = new gc_state(op);
+ current_gc = new gc_state(op,this);
/* Keep trying to GC higher and higher generations until we don't run out
of space */
if(setjmp(current_gc->gc_unwind))
{
/* We come back here if a generation is full */
- switch(current_gc->op)
- {
- case collect_nursery_op:
- current_gc->op = collect_aging_op;
- break;
- case collect_aging_op:
- current_gc->op = collect_to_tenured_op;
- break;
- case collect_to_tenured_op:
- current_gc->op = collect_full_op;
- break;
- case collect_full_op:
- current_gc->op = collect_growing_heap_op;
- break;
- default:
- critical_error("Bad GC op\n",op);
- break;
- }
+ start_gc_again();
}
+ current_gc->event->op = current_gc->op;
+
switch(current_gc->op)
{
case collect_nursery_op:
collect_nursery();
- record_gc_stats(&gc_stats.nursery_stats);
break;
case collect_aging_op:
collect_aging();
- record_gc_stats(&gc_stats.aging_stats);
+ if(data->low_memory_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
break;
case collect_to_tenured_op:
collect_to_tenured();
- record_gc_stats(&gc_stats.aging_stats);
+ if(data->low_memory_p())
+ {
+ current_gc->op = collect_full_op;
+ current_gc->event->op = collect_full_op;
+ collect_full(trace_contexts_p);
+ }
break;
case collect_full_op:
- collect_full(trace_contexts_p,compact_code_heap_p);
- record_gc_stats(&gc_stats.full_stats);
+ collect_full(trace_contexts_p);
+ break;
+ case collect_compact_op:
+ collect_compact(trace_contexts_p);
break;
case collect_growing_heap_op:
- collect_growing_heap(requested_bytes,trace_contexts_p,compact_code_heap_p);
- record_gc_stats(&gc_stats.full_stats);
+ collect_growing_heap(requested_bytes,trace_contexts_p);
break;
default:
- critical_error("Bad GC op\n",op);
+ critical_error("Bad GC op",current_gc->op);
break;
}
+ end_gc();
+
delete current_gc;
current_gc = NULL;
}
{
gc(collect_nursery_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_full_gc()
{
gc(collect_full_op,
0, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
void factor_vm::primitive_compact_gc()
{
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- true, /* trace contexts? */
- true /* compact code heap? */);
-}
-
-void factor_vm::add_gc_stats(generation_statistics *stats, growable_array *result)
-{
- result->add(allot_cell(stats->collections));
- result->add(tag<bignum>(long_long_to_bignum(stats->gc_time)));
- result->add(tag<bignum>(long_long_to_bignum(stats->max_gc_time)));
- result->add(allot_cell(stats->collections == 0 ? 0 : stats->gc_time / stats->collections));
- result->add(allot_cell(stats->object_count));
- result->add(tag<bignum>(long_long_to_bignum(stats->bytes_copied)));
-}
-
-void factor_vm::primitive_gc_stats()
-{
- growable_array result(this);
-
- add_gc_stats(&gc_stats.nursery_stats,&result);
- add_gc_stats(&gc_stats.aging_stats,&result);
- add_gc_stats(&gc_stats.full_stats,&result);
-
- u64 total_gc_time =
- gc_stats.nursery_stats.gc_time +
- gc_stats.aging_stats.gc_time +
- gc_stats.full_stats.gc_time;
-
- result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.cards_scanned)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.decks_scanned)));
- result.add(tag<bignum>(ulong_long_to_bignum(gc_stats.card_scan_time)));
- result.add(allot_cell(gc_stats.code_blocks_scanned));
-
- result.trim();
- dpush(result.elements.value());
-}
-
-void factor_vm::clear_gc_stats()
-{
- memset(&gc_stats,0,sizeof(gc_statistics));
-}
-
-void factor_vm::primitive_clear_gc_stats()
-{
- clear_gc_stats();
+ true /* trace contexts? */);
}
-/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
- to coalesce equal but distinct quotations and wrappers. */
-void factor_vm::primitive_become()
+void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
{
- array *new_objects = untag_check<array>(dpop());
- array *old_objects = untag_check<array>(dpop());
-
- cell capacity = array_capacity(new_objects);
- if(capacity != array_capacity(old_objects))
- critical_error("bad parameters to become",0);
-
- cell i;
-
- for(i = 0; i < capacity; i++)
- {
- tagged<object> old_obj(array_nth(old_objects,i));
- tagged<object> new_obj(array_nth(new_objects,i));
-
- if(old_obj != new_obj)
- old_obj->h.forward_to(new_obj.untagged());
- }
-
- primitive_full_gc();
-
- /* If a word's definition quotation was in old_objects and the
- quotation in new_objects is not compiled, we might leak memory
- by referencing the old quotation unless we recompile all
- unoptimized words. */
- compile_all_words();
-}
-
-void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
-{
- for(cell i = 0; i < gc_roots_size; i++)
- gc_locals.push_back((cell)&gc_roots_base[i]);
-
+ data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
primitive_minor_gc();
-
- for(cell i = 0; i < gc_roots_size; i++)
- gc_locals.pop_back();
+ data_roots.pop_back();
}
-VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
{
- parent->inline_gc(gc_roots_base,gc_roots_size);
+ parent->inline_gc(data_roots_base,data_roots_size);
}
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-object *factor_vm::allot_object(header header, cell size)
+object *factor_vm::allot_large_object(header header, cell size)
{
-#ifdef GC_DEBUG
- if(!gc_off)
- primitive_full_gc();
-#endif
-
- object *obj;
-
- /* If the object is smaller than the nursery, allocate it in the nursery,
- after a GC if needed */
- if(nursery.size > size)
+ /* If tenured space does not have enough room, collect and compact */
+ if(!data->tenured->can_allot_p(size))
{
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + size > nursery.end)
- primitive_minor_gc();
-
- obj = nursery.allot(size);
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- /* If tenured space does not have enough room, collect */
- if(data->tenured->here + size > data->tenured->end)
- primitive_full_gc();
+ primitive_compact_gc();
/* If it still won't fit, grow the heap */
- if(data->tenured->here + size > data->tenured->end)
+ if(!data->tenured->can_allot_p(size))
{
gc(collect_growing_heap_op,
size, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ true /* trace contexts? */);
}
+ }
- obj = data->tenured->allot(size);
+ object *obj = data->tenured->allot(size);
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- char *start = (char *)obj;
- for(cell offset = 0; offset < size; offset += card_size)
- write_barrier((cell *)(start + offset));
- }
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier(obj,size);
obj->h = header;
return obj;
}
+void factor_vm::primitive_enable_gc_events()
+{
+ gc_events = new std::vector<gc_event>();
+}
+
+void factor_vm::primitive_disable_gc_events()
+{
+ if(gc_events)
+ {
+ byte_array *data = byte_array_from_values(&gc_events->front(),gc_events->size());
+ dpush(tag<byte_array>(data));
+
+ delete gc_events;
+ gc_events = NULL;
+ }
+ else
+ dpush(false_object);
+}
+
}
collect_aging_op,
collect_to_tenured_op,
collect_full_op,
+ collect_compact_op,
collect_growing_heap_op
};
-/* statistics */
-struct generation_statistics {
- cell collections;
- u64 gc_time;
- u64 max_gc_time;
- cell object_count;
- u64 bytes_copied;
-};
+struct gc_event {
+ gc_op op;
+ data_heap_room data_heap_before;
+ code_heap_room code_heap_before;
+ data_heap_room data_heap_after;
+ code_heap_room code_heap_after;
+ cell cards_scanned;
+ cell decks_scanned;
+ cell code_blocks_scanned;
+ u64 start_time;
+ cell total_time;
+ cell card_scan_time;
+ cell code_scan_time;
+ cell data_sweep_time;
+ cell code_sweep_time;
+ cell compaction_time;
+ cell temp_time;
-struct gc_statistics {
- generation_statistics nursery_stats;
- generation_statistics aging_stats;
- generation_statistics full_stats;
- u64 cards_scanned;
- u64 decks_scanned;
- u64 card_scan_time;
- u64 code_blocks_scanned;
+ explicit gc_event(gc_op op_, factor_vm *parent);
+ void started_card_scan();
+ void ended_card_scan(cell cards_scanned_, cell decks_scanned_);
+ void started_code_scan();
+ void ended_code_scan(cell code_blocks_scanned_);
+ void started_data_sweep();
+ void ended_data_sweep();
+ void started_code_sweep();
+ void ended_code_sweep();
+ void started_compaction();
+ void ended_compaction();
+ void ended_gc(factor_vm *parent);
};
struct gc_state {
gc_op op;
u64 start_time;
jmp_buf gc_unwind;
+ gc_event *event;
- explicit gc_state(gc_op op_);
+ explicit gc_state(gc_op op_, factor_vm *parent);
~gc_state();
+ void start_again(gc_op op_, factor_vm *parent);
};
-VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
}
namespace factor
{
-template<typename Array> cell array_capacity(Array *array)
+template<typename Array> cell array_capacity(const Array *array)
{
#ifdef FACTOR_DEBUG
assert(array->h.hi_tag() == Array::type_number);
return array_size<Array>(array_capacity(array));
}
-template<typename Array> Array *factor_vm::allot_array_internal(cell capacity)
+template<typename Array> Array *factor_vm::allot_uninitialized_array(cell capacity)
{
Array *array = allot<Array>(array_size<Array>(capacity));
array->capacity = tag_fixnum(capacity);
template<typename Array> Array *factor_vm::reallot_array(Array *array_, cell capacity)
{
- gc_root<Array> array(array_,this);
+ data_root<Array> array(array_,this);
if(reallot_array_in_place_p(array.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- Array *new_array = allot_array_internal<Array>(capacity);
+ Array *new_array = allot_uninitialized_array<Array>(capacity);
memcpy(new_array + 1,array.untagged() + 1,to_copy * Array::element_size);
memset((char *)(new_array + 1) + to_copy * Array::element_size,
+++ /dev/null
-#include "master.hpp"
-
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
-will be used for the data heap too, if we ever get mark/sweep/compact GC. */
-
-namespace factor
-{
-
-void heap::clear_free_list()
-{
- memset(&free,0,sizeof(heap_free_list));
-}
-
-heap::heap(bool secure_gc_, cell size, bool executable_p) : secure_gc(secure_gc_)
-{
- if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
- seg = new segment(align_page(size),executable_p);
- if(!seg) fatal_error("Out of memory in heap allocator",size);
- state = new mark_bits<heap_block,block_size_increment>(seg->start,size);
- clear_free_list();
-}
-
-heap::~heap()
-{
- delete seg;
- seg = NULL;
- delete state;
- state = NULL;
-}
-
-void heap::add_to_free_list(free_heap_block *block)
-{
- if(block->size() < free_list_count * block_size_increment)
- {
- int index = block->size() / block_size_increment;
- block->next_free = free.small_blocks[index];
- free.small_blocks[index] = block;
- }
- else
- {
- block->next_free = free.large_blocks;
- free.large_blocks = block;
- }
-}
-
-/* Called after reading the code heap from the image file, and after code heap
-compaction. Makes a free list consisting of one free block, at the very end. */
-void heap::build_free_list(cell size)
-{
- clear_free_list();
- free_heap_block *end = (free_heap_block *)(seg->start + size);
- end->set_type(FREE_BLOCK_TYPE);
- end->set_size(seg->end - (cell)end);
- add_to_free_list(end);
-}
-
-void heap::assert_free_block(free_heap_block *block)
-{
- if(block->type() != FREE_BLOCK_TYPE)
- critical_error("Invalid block in free list",(cell)block);
-}
-
-free_heap_block *heap::find_free_block(cell size)
-{
- cell attempt = size;
-
- while(attempt < free_list_count * block_size_increment)
- {
- int index = attempt / block_size_increment;
- free_heap_block *block = free.small_blocks[index];
- if(block)
- {
- assert_free_block(block);
- free.small_blocks[index] = block->next_free;
- return block;
- }
-
- attempt *= 2;
- }
-
- free_heap_block *prev = NULL;
- free_heap_block *block = free.large_blocks;
-
- while(block)
- {
- assert_free_block(block);
- if(block->size() >= size)
- {
- if(prev)
- prev->next_free = block->next_free;
- else
- free.large_blocks = block->next_free;
- return block;
- }
-
- prev = block;
- block = block->next_free;
- }
-
- return NULL;
-}
-
-free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
-{
- if(block->size() != size )
- {
- /* split the block in two */
- free_heap_block *split = (free_heap_block *)((cell)block + size);
- split->set_type(FREE_BLOCK_TYPE);
- split->set_size(block->size() - size);
- split->next_free = block->next_free;
- block->set_size(size);
- add_to_free_list(split);
- }
-
- return block;
-}
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *heap::heap_allot(cell size, cell type)
-{
- size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
- free_heap_block *block = find_free_block(size);
- if(block)
- {
- block = split_free_block(block,size);
- block->set_type(type);
- return block;
- }
- else
- return NULL;
-}
-
-/* Deallocates a block manually */
-void heap::heap_free(heap_block *block)
-{
- block->set_type(FREE_BLOCK_TYPE);
- add_to_free_list((free_heap_block *)block);
-}
-
-void heap::mark_block(heap_block *block)
-{
- state->set_marked_p(block,true);
-}
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- heap_block *scan = first_block();
-
- while(scan)
- {
- cell size = scan->size();
-
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- *total_free += size;
- if(size > *max_free)
- *max_free = size;
- }
- else
- *used += size;
-
- scan = next_block(scan);
- }
-}
-
-/* The size of the heap after compaction */
-cell heap::heap_size()
-{
- heap_block *scan = first_block();
-
- while(scan)
- {
- if(scan->type() == FREE_BLOCK_TYPE) break;
- else scan = next_block(scan);
- }
-
- assert(scan->type() == FREE_BLOCK_TYPE);
- assert((cell)scan + scan->size() == seg->end);
-
- return (cell)scan - (cell)first_block();
-}
-
-void heap::compact_heap()
-{
- forwarding.clear();
-
- heap_block *scan = first_block();
- char *address = (char *)scan;
-
- /* Slide blocks up while building the forwarding hashtable. */
- while(scan)
- {
- heap_block *next = next_block(scan);
-
- if(state->is_marked_p(scan))
- {
- cell size = scan->size();
- memmove(address,scan,size);
- forwarding[scan] = address;
- address += size;
- }
-
- scan = next;
- }
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list((cell)address - seg->start);
-}
-
-heap_block *heap::free_allocated(heap_block *prev, heap_block *scan)
-{
- if(secure_gc)
- memset(scan + 1,0,scan->size() - sizeof(heap_block));
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- {
- prev->set_size(prev->size() + scan->size());
- return prev;
- }
- else
- {
- scan->set_type(FREE_BLOCK_TYPE);
- return scan;
- }
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell free_list_count = 32;
-static const cell block_size_increment = 16;
-
-struct heap_free_list {
- free_heap_block *small_blocks[free_list_count];
- free_heap_block *large_blocks;
-};
-
-struct heap {
- bool secure_gc;
- segment *seg;
- heap_free_list free;
- mark_bits<heap_block,block_size_increment> *state;
- unordered_map<heap_block *, char *> forwarding;
-
- explicit heap(bool secure_gc_, cell size, bool executable_p);
- ~heap();
-
- inline heap_block *next_block(heap_block *block)
- {
- cell next = ((cell)block + block->size());
- if(next == seg->end)
- return NULL;
- else
- return (heap_block *)next;
- }
-
- inline heap_block *first_block()
- {
- return (heap_block *)seg->start;
- }
-
- inline heap_block *last_block()
- {
- return (heap_block *)seg->end;
- }
-
- void clear_free_list();
- void new_heap(cell size);
- void add_to_free_list(free_heap_block *block);
- void build_free_list(cell size);
- void assert_free_block(free_heap_block *block);
- free_heap_block *find_free_block(cell size);
- free_heap_block *split_free_block(free_heap_block *block, cell size);
- heap_block *heap_allot(cell size, cell type);
- void heap_free(heap_block *block);
- void mark_block(heap_block *block);
- void heap_usage(cell *used, cell *total_free, cell *max_free);
- cell heap_size();
- void compact_heap();
-
- heap_block *free_allocated(heap_block *prev, heap_block *scan);
-
- /* After code GC, all referenced code blocks have status set to B_MARKED, so any
- which are allocated and not marked can be reclaimed. */
- template<typename Iterator> void free_unmarked(Iterator &iter)
- {
- clear_free_list();
-
- heap_block *prev = NULL;
- heap_block *scan = first_block();
-
- while(scan)
- {
- if(scan->type() == FREE_BLOCK_TYPE)
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- prev->set_size(prev->size() + scan->size());
- else
- prev = scan;
- }
- else if(state->is_marked_p(scan))
- {
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- prev = scan;
- iter(scan);
- }
- else
- prev = free_allocated(prev,scan);
-
- scan = next_block(scan);
- }
-
- if(prev && prev->type() == FREE_BLOCK_TYPE)
- add_to_free_list((free_heap_block *)prev);
- }
-};
-
-}
/* Certain special objects in the image are known to the runtime */
void factor_vm::init_objects(image_header *h)
{
- memcpy(userenv,h->userenv,sizeof(userenv));
+ memcpy(special_objects,h->special_objects,sizeof(special_objects));
true_object = h->true_object;
bignum_zero = h->bignum_zero;
void factor_vm::load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
- cell good_size = h->data_size + (1 << 20);
-
- if(good_size > p->tenured_size)
- p->tenured_size = good_size;
+ p->tenured_size = std::max((h->data_size * 3) / 2,p->tenured_size);
init_data_heap(p->young_size,
p->aging_size,
- p->tenured_size,
- p->secure_gc);
-
- clear_gc_stats();
+ p->tenured_size);
fixnum bytes_read = fread((void*)data->tenured->start,1,h->data_size,file);
if((cell)bytes_read != h->data_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->data_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->data_size << " bytes expected\n";
fatal_error("load_data_heap failed",0);
}
- data->tenured->here = data->tenured->start + h->data_size;
+ data->tenured->initial_free_list(h->data_size);
}
void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
if(h->code_size != 0)
{
- size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
+ size_t bytes_read = fread(code->allocator->first_block(),1,h->code_size,file);
if(bytes_read != h->code_size)
{
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->code_size);
- print_string(" bytes expected\n");
+ std::cout << "truncated image: " << bytes_read << " bytes read, ";
+ std::cout << h->code_size << " bytes expected\n";
fatal_error("load_code_heap failed",0);
}
}
- code->build_free_list(h->code_size);
+ code->allocator->initial_free_list(h->code_size);
}
void factor_vm::data_fixup(cell *handle, cell data_relocation_base)
quot->xt = (void *)lazy_jit_compile;
}
-void factor_vm::fixup_alien(alien *d)
+void factor_vm::fixup_alien(alien *ptr)
{
- if(!to_boolean(d->base)) d->expired = true_object;
+ if(!to_boolean(ptr->base))
+ ptr->expired = true_object;
+ else
+ ptr->update_address();
}
struct stack_frame_fixupper {
data_fixup(&t->layout,data_relocation_base);
cell *scan = t->data();
- cell *end = (cell *)((cell)object + untagged_object_size(object));
+ cell *end = (cell *)((cell)object + object->size());
for(; scan < end; scan++)
data_fixup(scan,data_relocation_base);
else
{
object_fixupper fixupper(this,data_relocation_base);
- do_slots((cell)object,fixupper);
+ do_slots(object,fixupper);
switch(hi_tag)
{
where it is loaded, we need to fix up pointers in the image. */
void factor_vm::relocate_data(cell data_relocation_base, cell code_relocation_base)
{
- for(cell i = 0; i < USER_ENV; i++)
- data_fixup(&userenv[i],data_relocation_base);
+ for(cell i = 0; i < special_object_count; i++)
+ data_fixup(&special_objects[i],data_relocation_base);
data_fixup(&true_object,data_relocation_base);
data_fixup(&bignum_zero,data_relocation_base);
while(obj)
{
relocate_object((object *)obj,data_relocation_base,code_relocation_base);
- data->tenured->record_object_start_offset((object *)obj);
- obj = data->tenured->next_object_after(this,obj);
+ data->tenured->starts.record_object_start_offset((object *)obj);
+ obj = data->tenured->next_object_after(obj);
}
}
factor_vm *parent;
cell data_relocation_base;
- code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
+ explicit code_block_fixupper(factor_vm *parent_, cell data_relocation_base_) :
parent(parent_), data_relocation_base(data_relocation_base_) { }
- void operator()(code_block *compiled)
+ void operator()(code_block *compiled, cell size)
{
parent->fixup_code_block(compiled,data_relocation_base);
}
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << p->image_path << std::endl;
+ std::cout << strerror(errno) << std::endl;
exit(1);
}
relocate_code(h.data_relocation_base);
/* Store image path name */
- userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path);
+ special_objects[OBJ_IMAGE] = allot_alien(false_object,(cell)p->image_path);
}
/* Save the current image to disk */
file = OPEN_WRITE(filename);
if(file == NULL)
{
- print_string("Cannot open image file: "); print_native_string(filename); nl();
- print_string(strerror(errno)); nl();
+ std::cout << "Cannot open image file: " << filename << std::endl;
+ std::cout << strerror(errno) << std::endl;
return false;
}
h.magic = image_magic;
h.version = image_version;
h.data_relocation_base = data->tenured->start;
- h.data_size = data->tenured->here - data->tenured->start;
+ h.data_size = data->tenured->occupied_space();
h.code_relocation_base = code->seg->start;
- h.code_size = code->heap_size();
+ h.code_size = code->allocator->occupied_space();
h.true_object = true_object;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
- for(cell i = 0; i < USER_ENV; i++)
- h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
+ for(cell i = 0; i < special_object_count; i++)
+ h.special_objects[i] = (save_env_p(i) ? special_objects[i] : false_object);
bool ok = true;
if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
+ if(fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
if(fclose(file)) ok = false;
if(!ok)
- {
- print_string("save-image failed: "); print_string(strerror(errno)); nl();
- }
+ std::cout << "save-image failed: " << strerror(errno) << std::endl;
return ok;
}
/* do a full GC to push everything into tenured space */
primitive_compact_gc();
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
path.untag_check(this);
save_image((vm_char *)(path.untagged() + 1));
}
/* We unbox this before doing anything else. This is the only point
where we might throw an error, so we have to throw an error here since
later steps destroy the current image. */
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
path.untag_check(this);
- /* strip out userenv data which is set on startup anyway */
- for(cell i = 0; i < USER_ENV; i++)
- if(!save_env_p(i)) userenv[i] = false_object;
+ /* strip out special_objects data which is set on startup anyway */
+ for(cell i = 0; i < special_object_count; i++)
+ if(!save_env_p(i)) special_objects[i] = false_object;
- gc(collect_full_op,
+ gc(collect_compact_op,
0, /* requested size */
- false, /* discard objects only reachable from stacks */
- true /* compact the code heap */);
+ false /* discard objects only reachable from stacks */);
/* Save the image */
if(save_image((vm_char *)(path.untagged() + 1)))
/* tagged pointer to bignum -1 */
cell bignum_neg_one;
/* Initial user environment */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
};
struct vm_parameters {
cell ds_size, rs_size;
cell young_size, aging_size, tenured_size;
cell code_size;
- bool secure_gc;
bool fep;
bool console;
bool signals;
void factor_vm::init_inline_caching(int max_size)
{
max_pic_size = max_size;
- cold_call_to_ic_transitions = 0;
- ic_to_pic_transitions = 0;
- pic_to_mega_transitions = 0;
- for(int i = 0; i < 4; i++) pic_counts[i] = 0;
}
void factor_vm::deallocate_inline_cache(cell return_address)
check_code_pointer((cell)old_xt);
code_block *old_block = (code_block *)old_xt - 1;
- cell old_type = old_block->type();
-#ifdef FACTOR_DEBUG
- /* The call target was either another PIC,
- or a compiled quotation (megamorphic stub) */
- assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
-#endif
-
- if(old_type == PIC_TYPE)
+ /* Free the old PIC since we know its unreachable */
+ if(old_block->pic_p())
code->code_heap_free(old_block);
}
it contains */
cell factor_vm::determine_inline_cache_type(array *cache_entries)
{
- bool seen_hi_tag = false, seen_tuple = false;
+ bool seen_tuple = false;
cell i;
for(i = 0; i < array_capacity(cache_entries); i += 2)
{
- cell klass = array_nth(cache_entries,i);
-
/* Is it a tuple layout? */
- switch(TAG(klass))
+ if(TAG(array_nth(cache_entries,i)) == ARRAY_TYPE)
{
- case FIXNUM_TYPE:
- {
- fixnum type = untag_fixnum(klass);
- if(type >= HEADER_TYPE)
- seen_hi_tag = true;
- }
- break;
- case ARRAY_TYPE:
seen_tuple = true;
break;
- default:
- critical_error("Expected a fixnum or array",klass);
- break;
}
}
- if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
- if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
- if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
- if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
-
- critical_error("Oops",0);
- return 0;
+ return seen_tuple ? PIC_TUPLE : PIC_TAG;
}
void factor_vm::update_pic_count(cell type)
{
- pic_counts[type - PIC_TAG]++;
+ if(type == PIC_TAG)
+ dispatch_stats.pic_tag_count++;
+ else
+ dispatch_stats.pic_tuple_count++;
}
struct inline_cache_jit : public jit {
fixnum index;
- explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(PIC_TYPE,generic_word_,vm) {};
+ explicit inline_cache_jit(cell generic_word_,factor_vm *vm) : jit(code_block_pic,generic_word_,vm) {};
void emit_check(cell klass);
void compile_inline_cache(fixnum index,
void inline_cache_jit::emit_check(cell klass)
{
cell code_template;
- if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
- code_template = parent->userenv[PIC_CHECK_TAG];
+ if(TAG(klass) == FIXNUM_TYPE)
+ code_template = parent->special_objects[PIC_CHECK_TAG];
else
- code_template = parent->userenv[PIC_CHECK];
+ code_template = parent->special_objects[PIC_CHECK_TUPLE];
emit_with(code_template,klass);
}
cell cache_entries_,
bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,parent);
- gc_root<array> methods(methods_,parent);
- gc_root<array> cache_entries(cache_entries_,parent);
+ data_root<word> generic_word(generic_word_,parent);
+ data_root<array> methods(methods_,parent);
+ data_root<array> cache_entries(cache_entries_,parent);
cell inline_cache_type = parent->determine_inline_cache_type(cache_entries.untagged());
parent->update_pic_count(inline_cache_type);
/* Yes? Jump to method */
cell method = array_nth(cache_entries.untagged(),i + 1);
- emit_with(parent->userenv[PIC_HIT],method);
+ emit_with(parent->special_objects[PIC_HIT],method);
}
/* Generate machine code to handle a cache miss, which ultimately results in
push(methods.value());
push(tag_fixnum(index));
push(cache_entries.value());
- word_special(parent->userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+ word_special(parent->special_objects[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
}
-code_block *factor_vm::compile_inline_cache(fixnum index,cell generic_word_,cell methods_,cell cache_entries_,bool tail_call_p)
+code_block *factor_vm::compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p)
{
- gc_root<word> generic_word(generic_word_,this);
- gc_root<array> methods(methods_,this);
- gc_root<array> cache_entries(cache_entries_,this);
+ data_root<word> generic_word(generic_word_,this);
+ data_root<array> methods(methods_,this);
+ data_root<array> cache_entries(cache_entries_,this);
inline_cache_jit jit(generic_word.value(),this);
jit.compile_inline_cache(index,
return code;
}
-/* A generic word's definition performs general method lookup. Allocates memory */
+/* A generic word's definition performs general method lookup. */
void *factor_vm::megamorphic_call_stub(cell generic_word)
{
return untag<word>(generic_word)->xt;
/* Allocates memory */
cell factor_vm::add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
{
- gc_root<array> cache_entries(cache_entries_,this);
- gc_root<object> klass(klass_,this);
- gc_root<word> method(method_,this);
+ data_root<array> cache_entries(cache_entries_,this);
+ data_root<object> klass(klass_,this);
+ data_root<word> method(method_,this);
cell pic_size = array_capacity(cache_entries.untagged());
- gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
+ data_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2),this);
set_array_nth(new_cache_entries.untagged(),pic_size,klass.value());
set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value());
return new_cache_entries.value();
void factor_vm::update_pic_transitions(cell pic_size)
{
if(pic_size == max_pic_size)
- pic_to_mega_transitions++;
+ dispatch_stats.pic_to_mega_transitions++;
else if(pic_size == 0)
- cold_call_to_ic_transitions++;
+ dispatch_stats.cold_call_to_ic_transitions++;
else if(pic_size == 1)
- ic_to_pic_transitions++;
+ dispatch_stats.ic_to_pic_transitions++;
}
-/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
-Called from assembly with the actual return address */
-void *factor_vm::inline_cache_miss(cell return_address)
+/* The cache_entries parameter is empty (on cold call site) or has entries
+(on cache miss). Called from assembly with the actual return address.
+Compilation of the inline cache may trigger a GC, which may trigger a compaction;
+also, the block containing the return address may now be dead. Use a code_root
+to take care of the details. */
+void *factor_vm::inline_cache_miss(cell return_address_)
{
- check_code_pointer(return_address);
+ code_root return_address(return_address_,this);
+
+ check_code_pointer(return_address.value);
/* Since each PIC is only referenced from a single call site,
if the old call target was a PIC, we can deallocate it immediately,
instead of leaving dead PICs around until the next GC. */
- deallocate_inline_cache(return_address);
+ deallocate_inline_cache(return_address.value);
- gc_root<array> cache_entries(dpop(),this);
+ data_root<array> cache_entries(dpop(),this);
fixnum index = untag_fixnum(dpop());
- gc_root<array> methods(dpop(),this);
- gc_root<word> generic_word(dpop(),this);
- gc_root<object> object(((cell *)ds)[-index],this);
+ data_root<array> methods(dpop(),this);
+ data_root<word> generic_word(dpop(),this);
+ data_root<object> object(((cell *)ds)[-index],this);
void *xt;
cell klass = object_class(object.value());
cell method = lookup_method(object.value(),methods.value());
- gc_root<array> new_cache_entries(add_inline_cache_entry(
+ data_root<array> new_cache_entries(add_inline_cache_entry(
cache_entries.value(),
klass,
method),this);
generic_word.value(),
methods.value(),
new_cache_entries.value(),
- tail_call_site_p(return_address))->xt();
+ tail_call_site_p(return_address.value))->xt();
}
/* Install the new stub. */
- set_call_target(return_address,xt);
+ if(return_address.valid)
+ {
+ set_call_target(return_address.value,xt);
#ifdef PIC_DEBUG
- printf("Updated %s call site 0x%lx with 0x%lx\n",
- tail_call_site_p(return_address) ? "tail" : "non-tail",
- return_address,
- (cell)xt);
+ std::cout << "Updated "
+ << (tail_call_site_p(return_address) ? "tail" : "non-tail")
+ << " call site 0x" << std::hex << return_address << std::dec
+ << " with " << std::hex << (cell)xt << std::dec;
#endif
+ }
return xt;
}
return parent->inline_cache_miss(return_address);
}
-void factor_vm::primitive_reset_inline_cache_stats()
-{
- cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
- cell i;
- for(i = 0; i < 4; i++) pic_counts[i] = 0;
-}
-
-void factor_vm::primitive_inline_cache_stats()
-{
- growable_array stats(this);
- stats.add(allot_cell(cold_call_to_ic_transitions));
- stats.add(allot_cell(ic_to_pic_transitions));
- stats.add(allot_cell(pic_to_mega_transitions));
- cell i;
- for(i = 0; i < 4; i++)
- stats.add(allot_cell(pic_counts[i]));
- stats.trim();
- dpush(stats.elements.value());
-}
-
}
void factor_vm::init_c_io()
{
- userenv[STDIN_ENV] = allot_alien(false_object,(cell)stdin);
- userenv[STDOUT_ENV] = allot_alien(false_object,(cell)stdout);
- userenv[STDERR_ENV] = allot_alien(false_object,(cell)stderr);
+ special_objects[OBJ_STDIN] = allot_alien(false_object,(cell)stdin);
+ special_objects[OBJ_STDOUT] = allot_alien(false_object,(cell)stdout);
+ special_objects[OBJ_STDERR] = allot_alien(false_object,(cell)stderr);
}
void factor_vm::io_error()
void factor_vm::primitive_fopen()
{
- gc_root<byte_array> mode(dpop(),this);
- gc_root<byte_array> path(dpop(),this);
+ data_root<byte_array> mode(dpop(),this);
+ data_root<byte_array> path(dpop(),this);
mode.untag_check(this);
path.untag_check(this);
return;
}
- gc_root<byte_array> buf(allot_array_internal<byte_array>(size),this);
+ data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
for(;;)
{
- polymorphic inline caches (inline_cache.cpp) */
/* Allocates memory */
-jit::jit(cell type_, cell owner_, factor_vm *vm)
+jit::jit(code_block_type type_, cell owner_, factor_vm *vm)
: type(type_),
owner(owner_,vm),
code(vm),
void jit::emit_relocation(cell code_template_)
{
- gc_root<array> code_template(code_template_,parent);
+ data_root<array> code_template(code_template_,parent);
cell capacity = array_capacity(code_template.untagged());
for(cell i = 1; i < capacity; i += 3)
{
/* Allocates memory */
void jit::emit(cell code_template_)
{
- gc_root<array> code_template(code_template_,parent);
+ data_root<array> code_template(code_template_,parent);
emit_relocation(code_template.value());
- gc_root<byte_array> insns(array_nth(code_template.untagged(),0),parent);
+ data_root<byte_array> insns(array_nth(code_template.untagged(),0),parent);
if(computing_offset_p)
{
}
void jit::emit_with(cell code_template_, cell argument_) {
- gc_root<array> code_template(code_template_,parent);
- gc_root<object> argument(argument_,parent);
+ data_root<array> code_template(code_template_,parent);
+ data_root<object> argument(argument_,parent);
literal(argument.value());
emit(code_template.value());
}
void jit::emit_class_lookup(fixnum index, cell type)
{
- emit_with(parent->userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
- emit(parent->userenv[type]);
+ emit_with(parent->special_objects[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(parent->special_objects[type]);
}
/* Facility to convert compiled code offsets to quotation offsets.
{
struct jit {
- cell type;
- gc_root<object> owner;
+ code_block_type type;
+ data_root<object> owner;
growable_byte_array code;
growable_byte_array relocation;
growable_array literals;
cell offset;
factor_vm *parent;
- explicit jit(cell jit_type, cell owner, factor_vm *vm);
+ explicit jit(code_block_type type, cell owner, factor_vm *parent);
void compute_position(cell offset);
void emit_relocation(cell code_template);
void literal(cell literal) { literals.add(literal); }
void emit_with(cell code_template_, cell literal_);
- void push(cell literal) {
- emit_with(parent->userenv[JIT_PUSH_IMMEDIATE],literal);
+ void push(cell literal)
+ {
+ emit_with(parent->special_objects[JIT_PUSH_IMMEDIATE],literal);
}
- void word_jump(cell word_) {
- gc_root<word> word(word_,parent);
+ void word_jump(cell word_)
+ {
+ data_root<word> word(word_,parent);
literal(tag_fixnum(xt_tail_pic_offset));
literal(word.value());
- emit(parent->userenv[JIT_WORD_JUMP]);
+ emit(parent->special_objects[JIT_WORD_JUMP]);
}
- void word_call(cell word) {
- emit_with(parent->userenv[JIT_WORD_CALL],word);
+ void word_call(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_CALL],word);
}
- void word_special(cell word) {
- emit_with(parent->userenv[JIT_WORD_SPECIAL],word);
+ void word_special(cell word)
+ {
+ emit_with(parent->special_objects[JIT_WORD_SPECIAL],word);
}
- void emit_subprimitive(cell word_) {
- gc_root<word> word(word_,parent);
- gc_root<array> code_pair(word->subprimitive,parent);
- literals.append(parent->untag<array>(array_nth(code_pair.untagged(),0)));
+ void emit_subprimitive(cell word_)
+ {
+ data_root<word> word(word_,parent);
+ data_root<array> code_pair(word->subprimitive,parent);
+ literals.append(untag<array>(array_nth(code_pair.untagged(),0)));
emit(array_nth(code_pair.untagged(),1));
}
void emit_class_lookup(fixnum index, cell type);
- fixnum get_position() {
+ fixnum get_position()
+ {
if(computing_offset_p)
{
/* If this is still on, emit() didn't clear it,
return position;
}
- void set_position(fixnum position_) {
+ void set_position(fixnum position_)
+ {
if(computing_offset_p)
position = position_;
}
return (a + (b-1)) & ~(b-1);
}
-inline static cell align8(cell a)
-{
- return align(a,8);
-}
+static const cell data_alignment = 16;
#define WORD_SIZE (signed)(sizeof(cell)*8)
-#define TAG_MASK 7
-#define TAG_BITS 3
+#define TAG_MASK 15
+#define TAG_BITS 4
#define TAG(x) ((cell)(x) & TAG_MASK)
#define UNTAG(x) ((cell)(x) & ~TAG_MASK)
#define RETAG(x,tag) (UNTAG(x) | (tag))
/*** Tags ***/
#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
+#define F_TYPE 1
#define ARRAY_TYPE 2
#define FLOAT_TYPE 3
#define QUOTATION_TYPE 4
-#define F_TYPE 5
-#define OBJECT_TYPE 6
+#define BIGNUM_TYPE 5
+#define ALIEN_TYPE 6
#define TUPLE_TYPE 7
-
-#define HEADER_TYPE 8 /* anything less than this is a tag */
-
-#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
-
-/*** Header types ***/
#define WRAPPER_TYPE 8
#define BYTE_ARRAY_TYPE 9
#define CALLSTACK_TYPE 10
#define STRING_TYPE 11
#define WORD_TYPE 12
#define DLL_TYPE 13
-#define ALIEN_TYPE 14
-#define TYPE_COUNT 15
+#define TYPE_COUNT 14
+
+#define FORWARDING_POINTER 5 /* can be anything other than FIXNUM_TYPE */
-/* Not real types, but code_block's type can be set to this */
-#define PIC_TYPE 16
-#define FREE_BLOCK_TYPE 17
+enum code_block_type
+{
+ code_block_unoptimized,
+ code_block_optimized,
+ code_block_profiling,
+ code_block_pic
+};
/* Constants used when floating-point trap exceptions are thrown */
enum
inline static bool immediate_p(cell obj)
{
- return (obj == false_object || TAG(obj) == FIXNUM_TYPE);
+ /* We assume that fixnums have tag 0 and false_object has tag 1 */
+ return TAG(obj) <= F_TYPE;
}
inline static fixnum untag_fixnum(cell tagged)
return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
}
-inline static cell tag_for(cell type)
-{
- return type < HEADER_TYPE ? type : OBJECT_TYPE;
-}
-
struct object;
struct header {
explicit header(cell value_) : value(value_ << TAG_BITS) {}
- void check_header() {
+ void check_header() const
+ {
#ifdef FACTOR_DEBUG
assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
#endif
}
- cell hi_tag() {
+ cell hi_tag() const
+ {
check_header();
return value >> TAG_BITS;
}
- bool forwarding_pointer_p() {
- return TAG(value) == GC_COLLECTED;
+ bool forwarding_pointer_p() const
+ {
+ return TAG(value) == FORWARDING_POINTER;
}
- object *forwarding_pointer() {
+ object *forwarding_pointer() const
+ {
return (object *)UNTAG(value);
}
- void forward_to(object *pointer) {
- value = RETAG(pointer,GC_COLLECTED);
+ void forward_to(object *pointer)
+ {
+ value = RETAG(pointer,FORWARDING_POINTER);
}
};
struct object {
NO_TYPE_CHECK;
header h;
- cell *slots() { return (cell *)this; }
+
+ cell size() const;
+ cell binary_payload_start() const;
+
+ cell *slots() const { return (cell *)this; }
+
+ /* Only valid for objects in tenured space; must fast to free_heap_block
+ to do anything with it if its free */
+ bool free_p() const
+ {
+ return (h.value & 1) == 1;
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
/* These are really just arrays, but certain elements have special
/* tagged */
cell capacity;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
};
struct byte_array : public object {
/* tagged */
cell capacity;
- template<typename Scalar> Scalar *data() { return (Scalar *)(this + 1); }
+#ifndef FACTOR_64
+ cell padding0;
+ cell padding1;
+#endif
+
+ template<typename Scalar> Scalar *data() const { return (Scalar *)(this + 1); }
};
/* Assembly code makes assumptions about the layout of this struct */
/* tagged */
cell hashcode;
- u8 *data() { return (u8 *)(this + 1); }
+ u8 *data() const { return (u8 *)(this + 1); }
+
+ cell nth(cell i) const;
};
/* The compiled code heap is structured into blocks. */
-struct heap_block
+struct code_block
{
cell header;
+ cell owner; /* tagged pointer to word, quotation or f */
+ cell literals; /* tagged pointer to array or f */
+ cell relocation; /* tagged pointer to byte-array or f */
- cell type() { return (header >> 1) & 0x1f; }
- void set_type(cell type)
+ bool free_p() const
{
- header = ((header & ~(0x1f << 1)) | (type << 1));
+ return (header & 1) == 1;
}
- cell size() { return (header >> 6); }
- void set_size(cell size)
+ code_block_type type() const
{
- header = (header & 0x2f) | (size << 6);
+ return (code_block_type)((header >> 1) & 0x3);
}
-};
-struct free_heap_block : public heap_block
-{
- free_heap_block *next_free;
-};
+ void set_type(code_block_type type)
+ {
+ header = ((header & ~0x7) | (type << 1));
+ }
-struct code_block : public heap_block
-{
- cell owner; /* tagged pointer to word, quotation or f */
- cell literals; /* tagged pointer to array or f */
- cell relocation; /* tagged pointer to byte-array or f */
+ bool pic_p() const
+ {
+ return type() == code_block_pic;
+ }
+
+ bool optimized_p() const
+ {
+ return type() == code_block_optimized;
+ }
- void *xt() { return (void *)(this + 1); }
+ cell size() const
+ {
+ return header & ~7;
+ }
+
+ void *xt() const
+ {
+ return (void *)(this + 1);
+ }
};
/* Assembly code makes assumptions about the layout of this struct */
cell expired;
/* untagged */
cell displacement;
+ /* untagged */
+ cell address;
+
+ void update_address()
+ {
+ if(base == false_object)
+ address = displacement;
+ else
+ address = UNTAG(base) + sizeof(byte_array) + displacement;
+ }
};
struct dll : public object {
void *dll;
};
-struct stack_frame
-{
+struct stack_frame {
void *xt;
/* Frame size in bytes */
cell size;
/* tagged */
cell length;
- stack_frame *frame_at(cell offset)
+ stack_frame *frame_at(cell offset) const
{
return (stack_frame *)((char *)(this + 1) + offset);
}
- stack_frame *top() { return (stack_frame *)(this + 1); }
- stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+ stack_frame *top() const { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() const { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
};
struct tuple : public object {
/* tagged layout */
cell layout;
- cell *data() { return (cell *)(this + 1); }
+ cell *data() const { return (cell *)(this + 1); }
+};
+
+struct data_root_range {
+ cell *start;
+ cell len;
+
+ explicit data_root_range(cell *start_, cell len_) :
+ start(start_), len(len_) {}
};
}
+++ /dev/null
-namespace factor
-{
-
-template<typename Type>
-struct gc_root : public tagged<Type>
-{
- factor_vm *parent;
-
- void push() { parent->check_tagged_pointer(tagged<Type>::value()); parent->gc_locals.push_back((cell)this); }
-
- explicit gc_root(cell value_,factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
- explicit gc_root(Type *value_, factor_vm *vm) : tagged<Type>(value_),parent(vm) { push(); }
-
- const gc_root<Type>& operator=(const Type *x) { tagged<Type>::operator=(x); return *this; }
- const gc_root<Type>& operator=(const cell &x) { tagged<Type>::operator=(x); return *this; }
-
- ~gc_root() {
-#ifdef FACTOR_DEBUG
- assert(parent->gc_locals.back() == (cell)this);
-#endif
- parent->gc_locals.pop_back();
- }
-};
-
-/* A similar hack for the bignum implementation */
-struct gc_bignum
-{
- bignum **addr;
- factor_vm *parent;
- gc_bignum(bignum **addr_, factor_vm *vm) : addr(addr_), parent(vm) {
- if(*addr_)
- parent->check_data_pointer(*addr_);
- parent->gc_bignums.push_back((cell)addr);
- }
-
- ~gc_bignum() {
-#ifdef FACTOR_DEBUG
- assert(parent->gc_bignums.back() == (cell)addr);
-#endif
- parent->gc_bignums.pop_back();
- }
-};
-
-#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x,this)
-
-}
{
THREADHANDLE thread_id = pthread_from_mach_thread_np(thread);
assert(thread_id);
- unordered_map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
+ std::map<THREADHANDLE, factor_vm*>::const_iterator vm = thread_vms.find(thread_id);
if (vm != thread_vms.end())
vm->second->call_fault_handler(exception,code,exc_state,thread_state,float_state);
}
namespace factor
{
-const int forwarding_granularity = 128;
+const int block_granularity = 16;
+const int mark_bits_granularity = sizeof(cell) * 8;
+const int mark_bits_mask = sizeof(cell) * 8 - 1;
-template<typename Block, int Granularity> struct mark_bits {
- cell start;
+template<typename Block> struct mark_bits {
cell size;
+ cell start;
cell bits_size;
- unsigned int *marked;
- unsigned int *freed;
- cell forwarding_size;
+ cell *marked;
cell *forwarding;
void clear_mark_bits()
{
- memset(marked,0,bits_size * sizeof(unsigned int));
- }
-
- void clear_free_bits()
- {
- memset(freed,0,bits_size * sizeof(unsigned int));
+ memset(marked,0,bits_size * sizeof(cell));
}
void clear_forwarding()
{
- memset(forwarding,0,forwarding_size * sizeof(cell));
+ memset(forwarding,0,bits_size * sizeof(cell));
}
- explicit mark_bits(cell start_, cell size_) :
- start(start_),
+ explicit mark_bits(cell size_, cell start_) :
size(size_),
- bits_size(size / Granularity / 32),
- marked(new unsigned int[bits_size]),
- freed(new unsigned int[bits_size]),
- forwarding_size(size / Granularity / forwarding_granularity),
- forwarding(new cell[forwarding_size])
+ start(start_),
+ bits_size(size / block_granularity / mark_bits_granularity),
+ marked(new cell[bits_size]),
+ forwarding(new cell[bits_size])
{
clear_mark_bits();
- clear_free_bits();
clear_forwarding();
}
{
delete[] marked;
marked = NULL;
- delete[] freed;
- freed = NULL;
delete[] forwarding;
forwarding = NULL;
}
- std::pair<cell,cell> bitmap_deref(Block *address)
+ cell block_line(Block *address)
{
- cell word_number = (((cell)address - start) / Granularity);
- cell word_index = (word_number >> 5);
- cell word_shift = (word_number & 31);
+ return (((cell)address - start) / block_granularity);
+ }
-#ifdef FACTOR_DEBUG
- assert(word_index < bits_size);
-#endif
+ Block *line_block(cell line)
+ {
+ return (Block *)(line * block_granularity + start);
+ }
+ std::pair<cell,cell> bitmap_deref(Block *address)
+ {
+ cell line_number = block_line(address);
+ cell word_index = (line_number / mark_bits_granularity);
+ cell word_shift = (line_number & mark_bits_mask);
return std::make_pair(word_index,word_shift);
}
- bool bitmap_elt(unsigned int *bits, Block *address)
+ bool bitmap_elt(cell *bits, Block *address)
+ {
+ std::pair<cell,cell> position = bitmap_deref(address);
+ return (bits[position.first] & ((cell)1 << position.second)) != 0;
+ }
+
+ Block *next_block_after(Block *block)
{
- std::pair<cell,cell> pair = bitmap_deref(address);
- return (bits[pair.first] & (1 << pair.second)) != 0;
+ return (Block *)((cell)block + block->size());
}
- void set_bitmap_elt(unsigned int *bits, Block *address, bool flag)
+ void set_bitmap_range(cell *bits, Block *address)
{
- std::pair<cell,cell> pair = bitmap_deref(address);
- if(flag)
- bits[pair.first] |= (1 << pair.second);
+ std::pair<cell,cell> start = bitmap_deref(address);
+ std::pair<cell,cell> end = bitmap_deref(next_block_after(address));
+
+ cell start_mask = ((cell)1 << start.second) - 1;
+ cell end_mask = ((cell)1 << end.second) - 1;
+
+ if(start.first == end.first)
+ bits[start.first] |= start_mask ^ end_mask;
else
- bits[pair.first] &= ~(1 << pair.second);
+ {
+#ifdef FACTOR_DEBUG
+ assert(start.first < bits_size);
+#endif
+ bits[start.first] |= ~start_mask;
+
+ for(cell index = start.first + 1; index < end.first; index++)
+ bits[index] = (cell)-1;
+
+ if(end_mask != 0)
+ {
+#ifdef FACTOR_DEBUG
+ assert(end.first < bits_size);
+#endif
+ bits[end.first] |= end_mask;
+ }
+ }
}
- bool is_marked_p(Block *address)
+ bool marked_p(Block *address)
{
return bitmap_elt(marked,address);
}
- void set_marked_p(Block *address, bool marked_p)
+ void set_marked_p(Block *address)
+ {
+ set_bitmap_range(marked,address);
+ }
+
+ /* The eventual destination of a block after compaction is just the number
+ of marked blocks before it. Live blocks must be marked on entry. */
+ void compute_forwarding()
+ {
+ cell accum = 0;
+ for(cell index = 0; index < bits_size; index++)
+ {
+ forwarding[index] = accum;
+ accum += popcount(marked[index]);
+ }
+ }
+
+ /* We have the popcount for every mark_bits_granularity entries; look
+ up and compute the rest */
+ Block *forward_block(Block *original)
+ {
+#ifdef FACTOR_DEBUG
+ assert(marked_p(original));
+#endif
+ std::pair<cell,cell> position = bitmap_deref(original);
+
+ cell approx_popcount = forwarding[position.first];
+ cell mask = ((cell)1 << position.second) - 1;
+
+ cell new_line_number = approx_popcount + popcount(marked[position.first] & mask);
+ Block *new_block = line_block(new_line_number);
+#ifdef FACTOR_DEBUG
+ assert(new_block <= original);
+#endif
+ return new_block;
+ }
+
+ Block *next_unmarked_block_after(Block *original)
{
- set_bitmap_elt(marked,address,marked_p);
+ std::pair<cell,cell> position = bitmap_deref(original);
+ cell bit_index = position.second;
+
+ for(cell index = position.first; index < bits_size; index++)
+ {
+ cell mask = ((fixnum)marked[index] >> bit_index);
+ if(~mask)
+ {
+ /* Found an unmarked block on this page.
+ Stop, it's hammer time */
+ cell clear_bit = rightmost_clear_bit(mask);
+ return line_block(index * mark_bits_granularity + bit_index + clear_bit);
+ }
+ else
+ {
+ /* No unmarked blocks on this page.
+ Keep looking */
+ bit_index = 0;
+ }
+ }
+
+ /* No unmarked blocks were found */
+ return (Block *)(this->start + this->size);
}
- bool is_free_p(Block *address)
+ Block *next_marked_block_after(Block *original)
{
- return bitmap_elt(freed,address);
+ std::pair<cell,cell> position = bitmap_deref(original);
+ cell bit_index = position.second;
+
+ for(cell index = position.first; index < bits_size; index++)
+ {
+ cell mask = (marked[index] >> bit_index);
+ if(mask)
+ {
+ /* Found an marked block on this page.
+ Stop, it's hammer time */
+ cell set_bit = rightmost_set_bit(mask);
+ return line_block(index * mark_bits_granularity + bit_index + set_bit);
+ }
+ else
+ {
+ /* No marked blocks on this page.
+ Keep looking */
+ bit_index = 0;
+ }
+ }
+
+ /* No marked blocks were found */
+ return (Block *)(this->start + this->size);
}
- void set_free_p(Block *address, bool free_p)
+ cell unmarked_block_size(Block *original)
{
- set_bitmap_elt(freed,address,free_p);
+ Block *next_marked = next_marked_block_after(original);
+ return ((char *)next_marked - (char *)original);
}
};
/* C++ headers */
#include <algorithm>
+#include <map>
#include <set>
#include <vector>
-
-#if __GNUC__ == 4
- #include <tr1/unordered_map>
-
- namespace factor
- {
- using std::tr1::unordered_map;
- }
-#elif __GNUC__ == 3
- #include <boost/unordered_map.hpp>
-
- namespace factor
- {
- using boost::unordered_map;
- }
-#else
- #error Factor requires GCC 3.x or later
-#endif
+#include <iostream>
/* Forward-declare this since it comes up in function prototypes */
namespace factor
#include "segments.hpp"
#include "contexts.hpp"
#include "run.hpp"
+#include "objects.hpp"
#include "profiler.hpp"
#include "errors.hpp"
#include "bignumint.hpp"
#include "bignum.hpp"
#include "code_block.hpp"
-#include "zone.hpp"
+#include "bump_allocator.hpp"
+#include "bitwise_hacks.hpp"
+#include "mark_bits.hpp"
+#include "free_list.hpp"
+#include "free_list_allocator.hpp"
#include "write_barrier.hpp"
-#include "old_space.hpp"
+#include "object_start_map.hpp"
+#include "nursery_space.hpp"
#include "aging_space.hpp"
#include "tenured_space.hpp"
#include "data_heap.hpp"
+#include "code_heap.hpp"
#include "gc.hpp"
#include "debug.hpp"
#include "strings.hpp"
#include "words.hpp"
#include "float_bits.hpp"
#include "io.hpp"
-#include "mark_bits.hpp"
-#include "heap.hpp"
#include "image.hpp"
#include "alien.hpp"
-#include "code_heap.hpp"
#include "callbacks.hpp"
+#include "dispatch.hpp"
#include "vm.hpp"
+#include "allot.hpp"
#include "tagged.hpp"
-#include "local_roots.hpp"
+#include "data_roots.hpp"
+#include "code_roots.hpp"
+#include "slot_visitor.hpp"
#include "collector.hpp"
#include "copying_collector.hpp"
#include "nursery_collector.hpp"
#include "aging_collector.hpp"
#include "to_tenured_collector.hpp"
+#include "code_block_visitor.hpp"
+#include "compaction.hpp"
#include "full_collector.hpp"
#include "callstack.hpp"
#include "generic_arrays.hpp"
#include "byte_arrays.hpp"
#include "jit.hpp"
#include "quotations.hpp"
-#include "dispatch.hpp"
#include "inline_cache.hpp"
#include "factor.hpp"
#include "utilities.hpp"
drepl(tag<bignum>(result));
}
-cell factor_vm::unbox_array_size()
+cell factor_vm::unbox_array_size_slow()
{
- switch(tagged<object>(dpeek()).type())
+ if(tagged<object>(dpeek()).type() == BIGNUM_TYPE)
{
- case FIXNUM_TYPE:
- {
- fixnum n = untag_fixnum(dpeek());
- if(n >= 0 && n < (fixnum)array_size_max)
- {
- dpop();
- return n;
- }
- break;
- }
- case BIGNUM_TYPE:
+ bignum *zero = untag<bignum>(bignum_zero);
+ bignum *max = cell_to_bignum(array_size_max);
+ bignum *n = untag<bignum>(dpeek());
+ if(bignum_compare(n,zero) != bignum_comparison_less
+ && bignum_compare(n,max) == bignum_comparison_less)
{
- bignum * zero = untag<bignum>(bignum_zero);
- bignum * max = cell_to_bignum(array_size_max);
- bignum * n = untag<bignum>(dpeek());
- if(bignum_compare(n,zero) != bignum_comparison_less
- && bignum_compare(n,max) == bignum_comparison_less)
- {
- dpop();
- return bignum_to_cell(n);
- }
- break;
+ dpop();
+ return bignum_to_cell(n);
}
}
}
}
-VM_C_API fixnum to_fixnum(cell tagged,factor_vm *parent)
+VM_C_API fixnum to_fixnum(cell tagged, factor_vm *parent)
{
return parent->to_fixnum(tagged);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_1(s8 n,factor_vm *parent)
+VM_C_API void box_signed_1(s8 n, factor_vm *parent)
{
return parent->box_signed_1(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_1(u8 n,factor_vm *parent)
+VM_C_API void box_unsigned_1(u8 n, factor_vm *parent)
{
return parent->box_unsigned_1(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_2(s16 n,factor_vm *parent)
+VM_C_API void box_signed_2(s16 n, factor_vm *parent)
{
return parent->box_signed_2(n);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_2(u16 n,factor_vm *parent)
+VM_C_API void box_unsigned_2(u16 n, factor_vm *parent)
{
return parent->box_unsigned_2(n);
}
dpush(allot_integer(n));
}
-VM_C_API void box_signed_4(s32 n,factor_vm *parent)
+VM_C_API void box_signed_4(s32 n, factor_vm *parent)
{
return parent->box_signed_4(n);
}
dpush(allot_cell(n));
}
-VM_C_API void box_unsigned_4(u32 n,factor_vm *parent)
+VM_C_API void box_unsigned_4(u32 n, factor_vm *parent)
{
return parent->box_unsigned_4(n);
}
dpush(allot_integer(integer));
}
-VM_C_API void box_signed_cell(fixnum integer,factor_vm *parent)
+VM_C_API void box_signed_cell(fixnum integer, factor_vm *parent)
{
return parent->box_signed_cell(integer);
}
dpush(allot_cell(cell));
}
-VM_C_API void box_unsigned_cell(cell cell,factor_vm *parent)
+VM_C_API void box_unsigned_cell(cell cell, factor_vm *parent)
{
return parent->box_unsigned_cell(cell);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_signed_8(s64 n,factor_vm *parent)
+VM_C_API void box_signed_8(s64 n, factor_vm *parent)
{
return parent->box_signed_8(n);
}
}
}
-VM_C_API s64 to_signed_8(cell obj,factor_vm *parent)
+VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
{
return parent->to_signed_8(obj);
}
dpush(tag_fixnum(n));
}
-VM_C_API void box_unsigned_8(u64 n,factor_vm *parent)
+VM_C_API void box_unsigned_8(u64 n, factor_vm *parent)
{
return parent->box_unsigned_8(n);
}
}
}
-VM_C_API u64 to_unsigned_8(cell obj,factor_vm *parent)
+VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
{
return parent->to_unsigned_8(obj);
}
return untag_float_check(value);
}
-VM_C_API float to_float(cell value,factor_vm *parent)
+VM_C_API float to_float(cell value, factor_vm *parent)
{
return parent->to_float(value);
}
dpush(allot_float(flo));
}
-VM_C_API void box_double(double flo,factor_vm *parent)
+VM_C_API void box_double(double flo, factor_vm *parent)
{
return parent->box_double(flo);
}
return untag_float_check(value);
}
-VM_C_API double to_double(cell value,factor_vm *parent)
+VM_C_API double to_double(cell value, factor_vm *parent)
{
return parent->to_double(value);
}
return (double)untag_fixnum(tagged);
}
-// defined in assembler
+inline cell factor_vm::unbox_array_size()
+{
+ cell obj = dpeek();
+ if(TAG(obj) == FIXNUM_TYPE)
+ {
+ fixnum n = untag_fixnum(obj);
+ if(n >= 0 && n < (fixnum)array_size_max)
+ {
+ dpop();
+ return n;
+ }
+ }
+
+ return unbox_array_size_slow();
+}
VM_C_API void box_float(float flo, factor_vm *vm);
VM_C_API float to_float(cell value, factor_vm *vm);
nursery_collector::nursery_collector(factor_vm *parent_) :
copying_collector<aging_space,nursery_policy>(
parent_,
- &parent_->gc_stats.nursery_stats,
parent_->data->aging,
nursery_policy(parent_)) {}
collector.trace_roots();
collector.trace_contexts();
+
+ current_gc->event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_nursery,
simple_unmarker(card_points_to_nursery));
- collector.trace_cards(data->aging,
- card_points_to_nursery,
- simple_unmarker(card_mark_mask));
+ if(data->aging->here != data->aging->start)
+ {
+ collector.trace_cards(data->aging,
+ card_points_to_nursery,
+ full_unmarker());
+ }
+ current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+
+ current_gc->event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_nursery);
+ current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+
collector.cheneys_algorithm();
+
+ current_gc->event->started_code_sweep();
update_code_heap_for_minor_gc(&code->points_to_nursery);
+ current_gc->event->ended_code_sweep();
- nursery.here = nursery.start;
+ data->reset_generation(&nursery);
code->points_to_nursery.clear();
}
struct nursery_policy {
factor_vm *parent;
- nursery_policy(factor_vm *parent_) : parent(parent_) {}
+ explicit nursery_policy(factor_vm *parent_) : parent(parent_) {}
- bool should_copy_p(object *untagged)
+ bool should_copy_p(object *obj)
{
- return parent->nursery.contains_p(untagged);
+ return parent->nursery.contains_p(obj);
}
+
+ void promoted_object(object *obj) {}
+
+ void visited_object(object *obj) {}
};
struct nursery_collector : copying_collector<aging_space,nursery_policy> {
- nursery_collector(factor_vm *parent_);
+ explicit nursery_collector(factor_vm *parent_);
};
}
--- /dev/null
+namespace factor
+{
+
+struct nursery_space : bump_allocator<object>
+{
+ explicit nursery_space(cell size, cell start) : bump_allocator<object>(size,start) {}
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+object_start_map::object_start_map(cell size_, cell start_) :
+ size(size_), start(start_)
+{
+ object_start_offsets = new card[addr_to_card(size_)];
+ object_start_offsets_end = object_start_offsets + addr_to_card(size_);
+ clear_object_start_offsets();
+}
+
+object_start_map::~object_start_map()
+{
+ delete[] object_start_offsets;
+}
+
+cell object_start_map::first_object_in_card(cell card_index)
+{
+ return object_start_offsets[card_index];
+}
+
+cell object_start_map::find_object_containing_card(cell card_index)
+{
+ if(card_index == 0)
+ return start;
+ else
+ {
+ card_index--;
+
+ while(first_object_in_card(card_index) == card_starts_inside_object)
+ {
+#ifdef FACTOR_DEBUG
+ /* First card should start with an object */
+ assert(card_index > 0);
+#endif
+ card_index--;
+ }
+
+ return start + (card_index << card_bits) + first_object_in_card(card_index);
+ }
+}
+
+/* we need to remember the first object allocated in the card */
+void object_start_map::record_object_start_offset(object *obj)
+{
+ cell idx = addr_to_card((cell)obj - start);
+ card obj_start = ((cell)obj & addr_card_mask);
+ object_start_offsets[idx] = std::min(object_start_offsets[idx],obj_start);
+}
+
+void object_start_map::clear_object_start_offsets()
+{
+ memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
+}
+
+void object_start_map::update_card_for_sweep(cell index, u16 mask)
+{
+ cell offset = object_start_offsets[index];
+ if(offset != card_starts_inside_object)
+ {
+ mask >>= (offset / block_granularity);
+
+ if(mask == 0)
+ {
+ /* The rest of the block after the old object start is free */
+ object_start_offsets[index] = card_starts_inside_object;
+ }
+ else
+ {
+ /* Move the object start forward if necessary */
+ object_start_offsets[index] = offset + (rightmost_set_bit(mask) * block_granularity);
+ }
+ }
+}
+
+void object_start_map::update_for_sweep(mark_bits<object> *state)
+{
+ for(cell index = 0; index < state->bits_size; index++)
+ {
+ cell mask = state->marked[index];
+#ifdef FACTOR_64
+ update_card_for_sweep(index * 4, mask & 0xffff);
+ update_card_for_sweep(index * 4 + 1, (mask >> 16) & 0xffff);
+ update_card_for_sweep(index * 4 + 2, (mask >> 32) & 0xffff);
+ update_card_for_sweep(index * 4 + 3, (mask >> 48) & 0xffff);
+#else
+ update_card_for_sweep(index * 2, mask & 0xffff);
+ update_card_for_sweep(index * 2 + 1, (mask >> 16) & 0xffff);
+#endif
+ }
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell card_starts_inside_object = 0xff;
+
+struct object_start_map {
+ cell size, start;
+ card *object_start_offsets;
+ card *object_start_offsets_end;
+
+ explicit object_start_map(cell size_, cell start_);
+ ~object_start_map();
+
+ cell first_object_in_card(cell card_index);
+ cell find_object_containing_card(cell card_index);
+ void record_object_start_offset(object *obj);
+ void clear_object_start_offsets();
+ void update_card_for_sweep(cell index, u16 mask);
+ void update_for_sweep(mark_bits<object> *state);
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void factor_vm::primitive_special_object()
+{
+ fixnum e = untag_fixnum(dpeek());
+ drepl(special_objects[e]);
+}
+
+void factor_vm::primitive_set_special_object()
+{
+ fixnum e = untag_fixnum(dpop());
+ cell value = dpop();
+ special_objects[e] = value;
+}
+
+void factor_vm::primitive_set_slot()
+{
+ fixnum slot = untag_fixnum(dpop());
+ object *obj = untag<object>(dpop());
+ cell value = dpop();
+
+ cell *slot_ptr = &obj->slots()[slot];
+ *slot_ptr = value;
+ write_barrier(slot_ptr);
+}
+
+cell factor_vm::clone_object(cell obj_)
+{
+ data_root<object> obj(obj_,this);
+
+ if(immediate_p(obj.value()))
+ return obj.value();
+ else
+ {
+ cell size = object_size(obj.value());
+ object *new_obj = allot_object(header(obj.type()),size);
+ memcpy(new_obj,obj.untagged(),size);
+ return tag_dynamic(new_obj);
+ }
+}
+
+void factor_vm::primitive_clone()
+{
+ drepl(clone_object(dpeek()));
+}
+
+/* Size of the object pointed to by a tagged pointer */
+cell factor_vm::object_size(cell tagged)
+{
+ if(immediate_p(tagged))
+ return 0;
+ else
+ return untag<object>(tagged)->size();
+}
+
+void factor_vm::primitive_size()
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
+struct slot_become_visitor {
+ std::map<object *,object *> *become_map;
+
+ explicit slot_become_visitor(std::map<object *,object *> *become_map_) :
+ become_map(become_map_) {}
+
+ object *operator()(object *old)
+ {
+ std::map<object *,object *>::const_iterator iter = become_map->find(old);
+ if(iter != become_map->end())
+ return iter->second;
+ else
+ return old;
+ }
+};
+
+struct object_become_visitor {
+ slot_visitor<slot_become_visitor> *workhorse;
+
+ explicit object_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ workhorse(workhorse_) {}
+
+ void operator()(object *obj)
+ {
+ workhorse->visit_slots(obj);
+ }
+};
+
+/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
+ to coalesce equal but distinct quotations and wrappers. */
+void factor_vm::primitive_become()
+{
+ array *new_objects = untag_check<array>(dpop());
+ array *old_objects = untag_check<array>(dpop());
+
+ cell capacity = array_capacity(new_objects);
+ if(capacity != array_capacity(old_objects))
+ critical_error("bad parameters to become",0);
+
+ /* Build the forwarding map */
+ std::map<object *,object *> become_map;
+
+ for(cell i = 0; i < capacity; i++)
+ {
+ tagged<object> old_obj(array_nth(old_objects,i));
+ tagged<object> new_obj(array_nth(new_objects,i));
+
+ if(old_obj != new_obj)
+ become_map[old_obj.untagged()] = new_obj.untagged();
+ }
+
+ /* Update all references to old objects to point to new objects */
+ slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ workhorse.visit_roots();
+ workhorse.visit_contexts();
+
+ object_become_visitor object_visitor(&workhorse);
+ each_object(object_visitor);
+
+ /* Since we may have introduced old->new references, need to revisit
+ all objects on a minor GC. */
+ data->mark_all_cards();
+ primitive_minor_gc();
+
+ /* If a word's definition quotation was in old_objects and the
+ quotation in new_objects is not compiled, we might leak memory
+ by referencing the old quotation unless we recompile all
+ unoptimized words. */
+ compile_all_words();
+
+ /* Update references to old objects in the code heap */
+ update_code_heap_words_and_literals();
+}
+
+}
--- /dev/null
+namespace factor
+{
+
+static const cell special_object_count = 70;
+
+enum special_object {
+ OBJ_NAMESTACK, /* used by library only */
+ OBJ_CATCHSTACK, /* used by library only, per-callback */
+
+ OBJ_CURRENT_CALLBACK = 2, /* used by library only, per-callback */
+ OBJ_WALKER_HOOK, /* non-local exit hook, used by library only */
+ OBJ_CALLCC_1, /* used to pass the value in callcc1 */
+
+ OBJ_BREAK = 5, /* quotation called by throw primitive */
+ OBJ_ERROR, /* a marker consed onto kernel errors */
+
+ OBJ_CELL_SIZE = 7, /* sizeof(cell) */
+ OBJ_CPU, /* CPU architecture */
+ OBJ_OS, /* operating system name */
+
+ OBJ_ARGS = 10, /* command line arguments */
+ OBJ_STDIN, /* stdin FILE* handle */
+ OBJ_STDOUT, /* stdout FILE* handle */
+
+ OBJ_IMAGE = 13, /* image path name */
+ OBJ_EXECUTABLE, /* runtime executable path name */
+
+ OBJ_EMBEDDED = 15, /* are we embedded in another app? */
+ OBJ_EVAL_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_YIELD_CALLBACK, /* used when Factor is embedded in a C app */
+ OBJ_SLEEP_CALLBACK, /* used when Factor is embedded in a C app */
+
+ OBJ_COCOA_EXCEPTION = 19, /* Cocoa exception handler quotation */
+
+ OBJ_BOOT = 20, /* boot quotation */
+ OBJ_GLOBAL, /* global namespace */
+
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
+ JIT_WORD_JUMP,
+ JIT_WORD_CALL,
+ JIT_WORD_SPECIAL,
+ JIT_IF_WORD,
+ JIT_IF,
+ JIT_EPILOG,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+ JIT_DECLARE_WORD,
+
+ /* Callback stub generation in callbacks.c */
+ CALLBACK_STUB = 45,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 47,
+ PIC_TAG,
+ PIC_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK_TUPLE,
+ PIC_HIT,
+ PIC_MISS_WORD,
+ PIC_MISS_TAIL_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
+
+ OBJ_UNDEFINED = 60, /* default quotation for undefined words */
+
+ OBJ_STDERR = 61, /* stderr FILE* handle */
+
+ OBJ_STAGE2 = 62, /* have we bootstrapped? */
+
+ OBJ_CURRENT_THREAD = 63,
+
+ OBJ_THREADS = 64,
+ OBJ_RUN_QUEUE = 65,
+ OBJ_SLEEP_QUEUE = 66,
+};
+
+#define OBJ_FIRST_SAVE OBJ_BOOT
+#define OBJ_LAST_SAVE OBJ_STAGE2
+
+inline static bool save_env_p(cell i)
+{
+ return (i >= OBJ_FIRST_SAVE && i <= OBJ_LAST_SAVE);
+}
+
+}
+++ /dev/null
-#include "master.hpp"
-
-namespace factor
-{
-
-old_space::old_space(cell size_, cell start_) : zone(size_,start_)
-{
- object_start_offsets = new card[addr_to_card(size_)];
- object_start_offsets_end = object_start_offsets + addr_to_card(size_);
-}
-
-old_space::~old_space()
-{
- delete[] object_start_offsets;
-}
-
-cell old_space::first_object_in_card(cell card_index)
-{
- return object_start_offsets[card_index];
-}
-
-cell old_space::find_object_containing_card(cell card_index)
-{
- if(card_index == 0)
- return start;
- else
- {
- card_index--;
-
- while(first_object_in_card(card_index) == card_starts_inside_object)
- {
-#ifdef FACTOR_DEBUG
- /* First card should start with an object */
- assert(card_index > 0);
-#endif
- card_index--;
- }
-
- return start + (card_index << card_bits) + first_object_in_card(card_index);
- }
-}
-
-/* we need to remember the first object allocated in the card */
-void old_space::record_object_start_offset(object *obj)
-{
- cell idx = addr_to_card((cell)obj - start);
- if(object_start_offsets[idx] == card_starts_inside_object)
- object_start_offsets[idx] = ((cell)obj & addr_card_mask);
-}
-
-object *old_space::allot(cell size)
-{
- if(here + size > end) return NULL;
-
- object *obj = zone::allot(size);
- record_object_start_offset(obj);
- return obj;
-}
-
-void old_space::clear_object_start_offsets()
-{
- memset(object_start_offsets,card_starts_inside_object,addr_to_card(size));
-}
-
-cell old_space::next_object_after(factor_vm *parent, cell scan)
-{
- cell size = parent->untagged_object_size((object *)scan);
- if(scan + size < here)
- return scan + size;
- else
- return 0;
-}
-
-}
+++ /dev/null
-namespace factor
-{
-
-static const cell card_starts_inside_object = 0xff;
-
-struct old_space : zone {
- card *object_start_offsets;
- card *object_start_offsets_end;
-
- old_space(cell size_, cell start_);
- ~old_space();
-
- cell first_object_in_card(cell card_index);
- cell find_object_containing_card(cell card_index);
- void record_object_start_offset(object *obj);
- object *allot(cell size);
- void clear_object_start_offsets();
- cell next_object_after(factor_vm *parent, cell scan);
-};
-
-}
NS_VOIDRETURN;
NS_HANDLER
dpush(allot_alien(false_object,(cell)localException));
- quot = userenv[COCOA_EXCEPTION_ENV];
+ quot = special_objects[OBJ_COCOA_EXCEPTION];
if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{
/* No Cocoa exception handler was registered, so
#define OPEN_READ(path) _wfopen(path,L"rb")
#define OPEN_WRITE(path) _wfopen(path,L"wb")
-#define print_native_string(string) wprintf(L"%s",string)
-
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
PRIMITIVE_FORWARD(float_greatereq)
PRIMITIVE_FORWARD(word)
PRIMITIVE_FORWARD(word_xt)
-PRIMITIVE_FORWARD(getenv)
-PRIMITIVE_FORWARD(setenv)
+PRIMITIVE_FORWARD(special_object)
+PRIMITIVE_FORWARD(set_special_object)
PRIMITIVE_FORWARD(existsp)
PRIMITIVE_FORWARD(minor_gc)
PRIMITIVE_FORWARD(full_gc)
PRIMITIVE_FORWARD(compact_gc)
-PRIMITIVE_FORWARD(gc_stats)
PRIMITIVE_FORWARD(save_image)
PRIMITIVE_FORWARD(save_image_and_exit)
PRIMITIVE_FORWARD(datastack)
PRIMITIVE_FORWARD(resize_array)
PRIMITIVE_FORWARD(resize_string)
PRIMITIVE_FORWARD(array)
-PRIMITIVE_FORWARD(begin_scan)
-PRIMITIVE_FORWARD(next_object)
-PRIMITIVE_FORWARD(end_scan)
+PRIMITIVE_FORWARD(all_instances)
PRIMITIVE_FORWARD(size)
PRIMITIVE_FORWARD(die)
PRIMITIVE_FORWARD(fopen)
PRIMITIVE_FORWARD(resize_byte_array)
PRIMITIVE_FORWARD(dll_validp)
PRIMITIVE_FORWARD(unimplemented)
-PRIMITIVE_FORWARD(clear_gc_stats)
PRIMITIVE_FORWARD(jit_compile)
PRIMITIVE_FORWARD(load_locals)
PRIMITIVE_FORWARD(check_datastack)
PRIMITIVE_FORWARD(lookup_method)
PRIMITIVE_FORWARD(reset_dispatch_stats)
PRIMITIVE_FORWARD(dispatch_stats)
-PRIMITIVE_FORWARD(reset_inline_cache_stats)
-PRIMITIVE_FORWARD(inline_cache_stats)
PRIMITIVE_FORWARD(optimized_p)
PRIMITIVE_FORWARD(quot_compiled_p)
PRIMITIVE_FORWARD(vm_ptr)
PRIMITIVE_FORWARD(strip_stack_traces)
PRIMITIVE_FORWARD(callback)
+PRIMITIVE_FORWARD(enable_gc_events)
+PRIMITIVE_FORWARD(disable_gc_events)
const primitive_type primitives[] = {
primitive_bignum_to_fixnum,
primitive_float_greatereq,
primitive_word,
primitive_word_xt,
- primitive_getenv,
- primitive_setenv,
+ primitive_special_object,
+ primitive_set_special_object,
primitive_existsp,
primitive_minor_gc,
primitive_full_gc,
primitive_compact_gc,
- primitive_gc_stats,
primitive_save_image,
primitive_save_image_and_exit,
primitive_datastack,
primitive_resize_array,
primitive_resize_string,
primitive_array,
- primitive_begin_scan,
- primitive_next_object,
- primitive_end_scan,
+ primitive_all_instances,
primitive_size,
primitive_die,
primitive_fopen,
primitive_resize_byte_array,
primitive_dll_validp,
primitive_unimplemented,
- primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
primitive_check_datastack,
primitive_lookup_method,
primitive_reset_dispatch_stats,
primitive_dispatch_stats,
- primitive_reset_inline_cache_stats,
- primitive_inline_cache_stats,
primitive_optimized_p,
primitive_quot_compiled_p,
primitive_vm_ptr,
primitive_strip_stack_traces,
primitive_callback,
+ primitive_enable_gc_events,
+ primitive_disable_gc_events,
};
}
/* Allocates memory */
code_block *factor_vm::compile_profiling_stub(cell word_)
{
- gc_root<word> word(word_,this);
+ data_root<word> word(word_,this);
- jit jit(WORD_TYPE,word.value(),this);
- jit.emit_with(userenv[JIT_PROFILING],word.value());
+ jit jit(code_block_profiling,word.value(),this);
+ jit.emit_with(special_objects[JIT_PROFILING],word.value());
return jit.to_code_block();
}
if(profiling == profiling_p)
return;
- profiling_p = profiling;
-
/* Push everything to tenured space so that we can heap scan
and allocate profiling blocks if necessary */
primitive_full_gc();
- gc_root<array> words(find_all_words(),this);
+ data_root<array> words(find_all_words(),this);
+
+ profiling_p = profiling;
- cell i;
cell length = array_capacity(words.untagged());
- for(i = 0; i < length; i++)
+ for(cell i = 0; i < length; i++)
{
tagged<word> word(array_nth(words.untagged(),i));
if(profiling)
word->counter = tag_fixnum(0);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
update_code_heap_words();
/* 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.
+in Factor and performs advanced optimizations. See basis/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.
+code chunks are generated from Factor code in basis/cpu/.../bootstrap.factor.
Calls to words and constant quotations (referenced by conditionals and dips)
are direct jumps to machine code blocks. Literals are also referenced directly
bool quotation_jit::primitive_call_p(cell i, cell length)
{
- return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_PRIMITIVE_WORD];
+ return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_PRIMITIVE_WORD];
}
bool quotation_jit::fast_if_p(cell i, cell length)
{
return (i + 3) == length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
- && array_nth(elements.untagged(),i + 2) == parent->userenv[JIT_IF_WORD];
+ && array_nth(elements.untagged(),i + 2) == parent->special_objects[JIT_IF_WORD];
}
bool quotation_jit::fast_dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DIP_WORD];
}
bool quotation_jit::fast_2dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_2DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_2DIP_WORD];
}
bool quotation_jit::fast_3dip_p(cell i, cell length)
{
- return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_3DIP_WORD];
+ return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_3DIP_WORD];
}
bool quotation_jit::mega_lookup_p(cell i, cell length)
return (i + 4) <= length
&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
- && array_nth(elements.untagged(),i + 3) == parent->userenv[MEGA_LOOKUP_WORD];
+ && array_nth(elements.untagged(),i + 3) == parent->special_objects[MEGA_LOOKUP_WORD];
}
bool quotation_jit::declare_p(cell i, cell length)
{
return (i + 2) <= length
- && array_nth(elements.untagged(),i + 1) == parent->userenv[JIT_DECLARE_WORD];
+ && array_nth(elements.untagged(),i + 1) == parent->special_objects[JIT_DECLARE_WORD];
}
bool quotation_jit::stack_frame_p()
switch(tagged<object>(obj).type())
{
case WORD_TYPE:
- if(!parent->to_boolean(parent->untag<word>(obj)->subprimitive))
+ if(!parent->to_boolean(untag<word>(obj)->subprimitive))
return true;
break;
case QUOTATION_TYPE:
void quotation_jit::emit_quot(cell quot_)
{
- gc_root<quotation> quot(quot_,parent);
+ data_root<quotation> quot(quot_,parent);
- array *elements = parent->untag<array>(quot->array);
+ array *elements = untag<array>(quot->array);
/* If the quotation consists of a single word, compile a direct call
to the word. */
set_position(0);
if(stack_frame)
- emit(parent->userenv[JIT_PROLOG]);
+ emit(parent->special_objects[JIT_PROLOG]);
cell i;
cell length = array_capacity(elements.untagged());
{
set_position(i);
- gc_root<object> obj(array_nth(elements.untagged(),i),parent);
+ data_root<object> obj(array_nth(elements.untagged(),i),parent);
switch(obj.type())
{
if(parent->to_boolean(obj.as<word>()->subprimitive))
emit_subprimitive(obj.value());
/* The (execute) primitive is special-cased */
- else if(obj.value() == parent->userenv[JIT_EXECUTE_WORD])
+ else if(obj.value() == parent->special_objects[JIT_EXECUTE_WORD])
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
- emit(parent->userenv[JIT_EXECUTE_JUMP]);
+ emit(parent->special_objects[JIT_EXECUTE_JUMP]);
}
else
- emit(parent->userenv[JIT_EXECUTE_CALL]);
+ emit(parent->special_objects[JIT_EXECUTE_CALL]);
}
/* Everything else */
else
{
if(i == length - 1)
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
/* Inline cache misses are special-cased.
The calling convention for tail
the inline cache miss primitive, and
we don't want to clobber the saved
address. */
- if(obj.value() == parent->userenv[PIC_MISS_WORD]
- || obj.value() == parent->userenv[PIC_MISS_TAIL_WORD])
+ if(obj.value() == parent->special_objects[PIC_MISS_WORD]
+ || obj.value() == parent->special_objects[PIC_MISS_TAIL_WORD])
{
word_special(obj.value());
}
{
literal(tag_fixnum(0));
literal(obj.value());
- emit(parent->userenv[JIT_PRIMITIVE]);
+ emit(parent->special_objects[JIT_PRIMITIVE]);
i++;
mutually recursive in the library, but both still work) */
if(fast_if_p(i,length))
{
- if(stack_frame) emit(parent->userenv[JIT_EPILOG]);
+ if(stack_frame) emit(parent->special_objects[JIT_EPILOG]);
tail_call = true;
emit_quot(array_nth(elements.untagged(),i));
emit_quot(array_nth(elements.untagged(),i + 1));
- emit(parent->userenv[JIT_IF]);
+ emit(parent->special_objects[JIT_IF]);
i += 2;
}
else if(fast_dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_DIP]);
+ emit(parent->special_objects[JIT_DIP]);
i++;
}
/* 2dip */
else if(fast_2dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_2DIP]);
+ emit(parent->special_objects[JIT_2DIP]);
i++;
}
/* 3dip */
else if(fast_3dip_p(i,length))
{
emit_quot(obj.value());
- emit(parent->userenv[JIT_3DIP]);
+ emit(parent->special_objects[JIT_3DIP]);
i++;
}
else
set_position(length);
if(stack_frame)
- emit(parent->userenv[JIT_EPILOG]);
- emit(parent->userenv[JIT_RETURN]);
+ emit(parent->special_objects[JIT_EPILOG]);
+ emit(parent->special_objects[JIT_RETURN]);
}
}
void factor_vm::set_quot_xt(quotation *quot, code_block *code)
{
- assert(code->type() == QUOTATION_TYPE);
quot->code = code;
quot->xt = code->xt();
}
/* Allocates memory */
void factor_vm::jit_compile(cell quot_, bool relocating)
{
- gc_root<quotation> quot(quot_,this);
+ data_root<quotation> quot(quot_,this);
if(quot->code) return;
quotation_jit compiler(quot.value(),true,relocating,this);
void factor_vm::compile_all_words()
{
- gc_root<array> words(find_all_words(),this);
+ data_root<array> words(find_all_words(),this);
cell i;
cell length = array_capacity(words.untagged());
for(i = 0; i < length; i++)
{
- gc_root<word> word(array_nth(words.untagged(),i),this);
+ data_root<word> word(array_nth(words.untagged(),i),this);
- if(!word->code || !word_optimized_p(word.untagged()))
+ if(!word->code || !word->code->optimized_p())
jit_compile_word(word.value(),word->def,false);
- update_word_xt(word.value());
+ update_word_xt(word.untagged());
}
-
- update_code_heap_words();
}
/* Allocates memory */
fixnum factor_vm::quot_code_offset_to_scan(cell quot_, cell offset)
{
- gc_root<quotation> quot(quot_,this);
- gc_root<array> array(quot->array,this);
+ data_root<quotation> quot(quot_,this);
+ data_root<array> array(quot->array,this);
quotation_jit compiler(quot.value(),false,false,this);
compiler.compute_position(offset);
cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
{
- gc_root<quotation> quot(quot_,this);
+ data_root<quotation> quot(quot_,this);
ctx->callstack_top = stack;
jit_compile(quot.value(),true);
return quot.value();
{
struct quotation_jit : public jit {
- gc_root<array> elements;
+ data_root<array> elements;
bool compiling, relocate;
explicit quotation_jit(cell quot, bool compiling_, bool relocate_, factor_vm *vm)
- : jit(QUOTATION_TYPE,quot,vm),
+ : jit(code_block_unoptimized,quot,vm),
elements(owner.as<quotation>().untagged()->array,vm),
compiling(compiling_),
relocate(relocate_){};
namespace factor
{
-void factor_vm::primitive_getenv()
-{
- fixnum e = untag_fixnum(dpeek());
- drepl(userenv[e]);
-}
-
-void factor_vm::primitive_setenv()
-{
- fixnum e = untag_fixnum(dpop());
- cell value = dpop();
- userenv[e] = value;
-}
-
void factor_vm::primitive_exit()
{
exit(to_fixnum(dpop()));
sleep_micros(to_cell(dpop()));
}
-void factor_vm::primitive_set_slot()
-{
- fixnum slot = untag_fixnum(dpop());
- object *obj = untag<object>(dpop());
- cell value = dpop();
-
- cell *slot_ptr = &obj->slots()[slot];
- *slot_ptr = value;
- write_barrier(slot_ptr);
-}
-
-void factor_vm::primitive_load_locals()
-{
- fixnum count = untag_fixnum(dpop());
- memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
- ds -= sizeof(cell) * count;
- rs += sizeof(cell) * count;
-}
-
-cell factor_vm::clone_object(cell obj_)
-{
- gc_root<object> obj(obj_,this);
-
- if(immediate_p(obj.value()))
- return obj.value();
- else
- {
- cell size = object_size(obj.value());
- object *new_obj = allot_object(header(obj.type()),size);
- memcpy(new_obj,obj.untagged(),size);
- return tag_dynamic(new_obj);
- }
-}
-
-void factor_vm::primitive_clone()
-{
- drepl(clone_object(dpeek()));
-}
-
}
namespace factor
{
-#define USER_ENV 70
-
-enum special_object {
- NAMESTACK_ENV, /* used by library only */
- CATCHSTACK_ENV, /* used by library only, per-callback */
-
- CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
- WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
- CALLCC_1_ENV, /* used to pass the value in callcc1 */
-
- BREAK_ENV = 5, /* quotation called by throw primitive */
- ERROR_ENV, /* a marker consed onto kernel errors */
-
- CELL_SIZE_ENV = 7, /* sizeof(cell) */
- CPU_ENV, /* CPU architecture */
- OS_ENV, /* operating system name */
-
- ARGS_ENV = 10, /* command line arguments */
- STDIN_ENV, /* stdin FILE* handle */
- STDOUT_ENV, /* stdout FILE* handle */
-
- IMAGE_ENV = 13, /* image path name */
- EXECUTABLE_ENV, /* runtime executable path name */
-
- EMBEDDED_ENV = 15, /* are we embedded in another app? */
- EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
-
- COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
-
- BOOT_ENV = 20, /* boot quotation */
- GLOBAL_ENV, /* global namespace */
-
- /* Quotation compilation in quotations.c */
- JIT_PROLOG = 23,
- JIT_PRIMITIVE_WORD,
- JIT_PRIMITIVE,
- JIT_WORD_JUMP,
- JIT_WORD_CALL,
- JIT_WORD_SPECIAL,
- JIT_IF_WORD,
- JIT_IF,
- JIT_EPILOG,
- JIT_RETURN,
- JIT_PROFILING,
- JIT_PUSH_IMMEDIATE,
- JIT_DIP_WORD,
- JIT_DIP,
- JIT_2DIP_WORD,
- JIT_2DIP,
- JIT_3DIP_WORD,
- JIT_3DIP,
- JIT_EXECUTE_WORD,
- JIT_EXECUTE_JUMP,
- JIT_EXECUTE_CALL,
- JIT_DECLARE_WORD,
-
- /* Callback stub generation in callbacks.c */
- CALLBACK_STUB = 45,
-
- /* Polymorphic inline cache generation in inline_cache.c */
- PIC_LOAD = 47,
- PIC_TAG,
- PIC_HI_TAG,
- PIC_TUPLE,
- PIC_HI_TAG_TUPLE,
- PIC_CHECK_TAG,
- PIC_CHECK,
- PIC_HIT,
- PIC_MISS_WORD,
- PIC_MISS_TAIL_WORD,
-
- /* Megamorphic cache generation in dispatch.c */
- MEGA_LOOKUP = 57,
- MEGA_LOOKUP_WORD,
- MEGA_MISS_WORD,
-
- UNDEFINED_ENV = 60, /* default quotation for undefined words */
-
- STDERR_ENV = 61, /* stderr FILE* handle */
-
- STAGE2_ENV = 62, /* have we bootstrapped? */
-
- CURRENT_THREAD_ENV = 63,
-
- THREADS_ENV = 64,
- RUN_QUEUE_ENV = 65,
- SLEEP_QUEUE_ENV = 66,
-};
-
-#define FIRST_SAVE_ENV BOOT_ENV
-#define LAST_SAVE_ENV STAGE2_ENV
-
-inline static bool save_env_p(cell i)
-{
- return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV);
}
-
-}
-
-
--- /dev/null
+namespace factor
+{
+
+template<typename Visitor> struct slot_visitor {
+ factor_vm *parent;
+ Visitor visitor;
+
+ explicit slot_visitor<Visitor>(factor_vm *parent_, Visitor visitor_) :
+ parent(parent_), visitor(visitor_) {}
+
+ void visit_handle(cell *handle)
+ {
+ cell pointer = *handle;
+ if(immediate_p(pointer)) return;
+
+ object *untagged = untag<object>(pointer);
+ untagged = visitor(untagged);
+ *handle = RETAG(untagged,TAG(pointer));
+ }
+
+ void visit_slots(object *ptr, cell payload_start)
+ {
+ cell *slot = (cell *)ptr;
+ cell *end = (cell *)((cell)ptr + payload_start);
+
+ if(slot != end)
+ {
+ slot++;
+ for(; slot < end; slot++) visit_handle(slot);
+ }
+ }
+
+ void visit_slots(object *ptr)
+ {
+ visit_slots(ptr,ptr->binary_payload_start());
+ }
+
+ void visit_stack_elements(segment *region, cell *top)
+ {
+ for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
+ visit_handle(ptr);
+ }
+
+ void visit_data_roots()
+ {
+ std::vector<data_root_range>::const_iterator iter = parent->data_roots.begin();
+ std::vector<data_root_range>::const_iterator end = parent->data_roots.end();
+
+ for(; iter < end; iter++)
+ {
+ data_root_range r = *iter;
+ for(cell index = 0; index < r.len; index++)
+ visit_handle(r.start + index);
+ }
+ }
+
+ void visit_bignum_roots()
+ {
+ std::vector<cell>::const_iterator iter = parent->bignum_roots.begin();
+ std::vector<cell>::const_iterator end = parent->bignum_roots.end();
+
+ for(; iter < end; iter++)
+ {
+ cell *handle = (cell *)(*iter);
+
+ if(*handle)
+ *handle = (cell)visitor(*(object **)handle);
+ }
+ }
+
+ void visit_roots()
+ {
+ visit_handle(&parent->true_object);
+ visit_handle(&parent->bignum_zero);
+ visit_handle(&parent->bignum_pos_one);
+ visit_handle(&parent->bignum_neg_one);
+
+ visit_data_roots();
+ visit_bignum_roots();
+
+ for(cell i = 0; i < special_object_count; i++)
+ visit_handle(&parent->special_objects[i]);
+ }
+
+ void visit_contexts()
+ {
+ context *ctx = parent->ctx;
+
+ while(ctx)
+ {
+ visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
+ visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
+
+ visit_handle(&ctx->catchstack_save);
+ visit_handle(&ctx->current_callback_save);
+
+ ctx = ctx->next;
+ }
+ }
+
+ void visit_literal_references(code_block *compiled)
+ {
+ visit_handle(&compiled->owner);
+ visit_handle(&compiled->literals);
+ visit_handle(&compiled->relocation);
+ }
+};
+
+}
namespace factor
{
-cell factor_vm::string_nth(string* str, cell index)
+cell string::nth(cell index) const
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
corresponding aux vector entry is negated, so that we can
XOR the two components together and get the original code point
back. */
- cell lo_bits = str->data()[index];
+ cell lo_bits = data()[index];
if((lo_bits & 0x80) == 0)
return lo_bits;
else
{
- byte_array *aux = untag<byte_array>(str->aux);
+ byte_array *aux = untag<byte_array>(this->aux);
cell hi_bits = aux->data<u16>()[index];
return (hi_bits << 7) ^ lo_bits;
}
void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
byte_array *aux;
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
- aux = allot_array_internal<byte_array>(untag_fixnum(str->length) * sizeof(u16));
+ aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
str->aux = tag<byte_array>(aux);
write_barrier(&str->aux);
/* Allocates memory */
void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
if(fill <= 0x7f)
memset(&str->data()[start],fill,capacity - start);
/* Allocates memory */
string *factor_vm::allot_string(cell capacity, cell fill)
{
- gc_root<string> str(allot_string_internal(capacity),this);
+ data_root<string> str(allot_string_internal(capacity),this);
fill_string(str.untagged(),0,capacity,fill);
return str.untagged();
}
string* factor_vm::reallot_string(string *str_, cell capacity)
{
- gc_root<string> str(str_,this);
+ data_root<string> str(str_,this);
if(reallot_string_in_place_p(str.untagged(),capacity))
{
if(capacity < to_copy)
to_copy = capacity;
- gc_root<string> new_str(allot_string_internal(capacity),this);
+ data_root<string> new_str(allot_string_internal(capacity),this);
memcpy(new_str->data(),str->data(),to_copy);
{
string *str = untag<string>(dpop());
cell index = untag_fixnum(dpop());
- dpush(tag_fixnum(string_nth(str,index)));
+ dpush(tag_fixnum(str->nth(index)));
}
void factor_vm::primitive_set_string_nth_fast()
namespace factor
{
-inline static cell string_capacity(string *str)
+inline static cell string_capacity(const string *str)
{
return untag_fixnum(str->length);
}
template<typename Type> cell tag(Type *value)
{
- return RETAG(value,tag_for(Type::type_number));
+ return RETAG(value,Type::type_number);
}
inline static cell tag_dynamic(object *value)
{
- return RETAG(value,tag_for(value->h.hi_tag()));
+ return RETAG(value,value->h.hi_tag());
}
template<typename Type>
{
cell value_;
- cell value() const { return value_; }
- Type *untagged() const { return (Type *)(UNTAG(value_)); }
-
- cell type() const {
- cell tag = TAG(value_);
- if(tag == OBJECT_TYPE)
- return untagged()->h.hi_tag();
- else
- return tag;
+ cell type() const
+ {
+ return TAG(value_);
}
- bool type_p(cell type_) const { return type() == type_; }
+ bool type_p(cell type_) const
+ {
+ return type() == type_;
+ }
- Type *untag_check(factor_vm *parent) const {
- if(Type::type_number != TYPE_COUNT && !type_p(Type::type_number))
- parent->type_error(Type::type_number,value_);
- return untagged();
+ bool type_p() const
+ {
+ if(Type::type_number == TYPE_COUNT)
+ return true;
+ else
+ return type_p(Type::type_number);
}
- explicit tagged(cell tagged) : value_(tagged) {
+ cell value() const
+ {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return value_;
}
- explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {
+ Type *untagged() const
+ {
#ifdef FACTOR_DEBUG
- untag_check(tls_vm());
+ assert(type_p());
#endif
+ return (Type *)(UNTAG(value_));
}
+ Type *untag_check(factor_vm *parent) const
+ {
+ if(!type_p())
+ parent->type_error(Type::type_number,value_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {}
+ explicit tagged(Type *untagged) : value_(factor::tag(untagged)) {}
+
Type *operator->() const { return untagged(); }
cell *operator&() const { return &value_; }
return tagged<Type>(value).untag_check(this);
}
-template<typename Type> Type *factor_vm::untag(cell value)
+template<typename Type> Type *untag(cell value)
{
return tagged<Type>(value).untagged();
}
namespace factor
{
-struct tenured_space : old_space {
- tenured_space(cell size, cell start) : old_space(size,start) {}
+struct tenured_space : free_list_allocator<object> {
+ object_start_map starts;
+ std::vector<object *> mark_stack;
+
+ explicit tenured_space(cell size, cell start) :
+ free_list_allocator<object>(size,start), starts(size,start) {}
+
+ object *allot(cell size)
+ {
+ object *obj = free_list_allocator<object>::allot(size);
+ if(obj)
+ {
+ starts.record_object_start_offset(obj);
+ return obj;
+ }
+ else
+ return NULL;
+ }
+
+ cell first_object()
+ {
+ return (cell)next_allocated_block_after(this->first_block());
+ }
+
+ cell next_object_after(cell scan)
+ {
+ cell size = ((object *)scan)->size();
+ object *next = (object *)(scan + size);
+ return (cell)next_allocated_block_after(next);
+ }
+
+ void clear_mark_bits()
+ {
+ state.clear_mark_bits();
+ }
+
+ void clear_mark_stack()
+ {
+ mark_stack.clear();
+ }
+
+ bool marked_p(object *obj)
+ {
+ return this->state.marked_p(obj);
+ }
+
+ void mark_and_push(object *obj)
+ {
+ this->state.set_marked_p(obj);
+ this->mark_stack.push_back(obj);
+ }
+
+ void sweep()
+ {
+ free_list_allocator<object>::sweep();
+ starts.update_for_sweep(&this->state);
+ }
};
}
{
to_tenured_collector::to_tenured_collector(factor_vm *myvm_) :
- copying_collector<tenured_space,to_tenured_policy>(
+ collector<tenured_space,to_tenured_policy>(
myvm_,
- &myvm_->gc_stats.aging_stats,
myvm_->data->tenured,
to_tenured_policy(myvm_)) {}
+void to_tenured_collector::tenure_reachable_objects()
+{
+ std::vector<object *> *mark_stack = &this->target->mark_stack;
+ while(!mark_stack->empty())
+ {
+ object *obj = mark_stack->back();
+ mark_stack->pop_back();
+ this->trace_object(obj);
+ }
+}
+
void factor_vm::collect_to_tenured()
{
/* Copy live objects from aging space to tenured space. */
to_tenured_collector collector(this);
+ data->tenured->clear_mark_stack();
+
collector.trace_roots();
collector.trace_contexts();
+
+ current_gc->event->started_card_scan();
collector.trace_cards(data->tenured,
card_points_to_aging,
- dummy_unmarker());
+ full_unmarker());
+ current_gc->event->ended_card_scan(collector.cards_scanned,collector.decks_scanned);
+
+ current_gc->event->started_code_scan();
collector.trace_code_heap_roots(&code->points_to_aging);
- collector.cheneys_algorithm();
+ current_gc->event->ended_code_scan(collector.code_blocks_scanned);
+
+ collector.tenure_reachable_objects();
+
+ current_gc->event->started_code_sweep();
update_code_heap_for_minor_gc(&code->points_to_aging);
+ current_gc->event->ended_code_sweep();
- nursery.here = nursery.start;
- reset_generation(data->aging);
- code->points_to_nursery.clear();
- code->points_to_aging.clear();
+ data->reset_generation(&nursery);
+ data->reset_generation(data->aging);
+ code->clear_remembered_set();
}
}
struct to_tenured_policy {
factor_vm *myvm;
- zone *tenured;
+ tenured_space *tenured;
- to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
+ explicit to_tenured_policy(factor_vm *myvm_) : myvm(myvm_), tenured(myvm->data->tenured) {}
bool should_copy_p(object *untagged)
{
return !tenured->contains_p(untagged);
}
+
+ void promoted_object(object *obj)
+ {
+ tenured->mark_stack.push_back(obj);
+ }
+
+ void visited_object(object *obj) {}
};
-struct to_tenured_collector : copying_collector<tenured_space,to_tenured_policy> {
- to_tenured_collector(factor_vm *myvm_);
+struct to_tenured_collector : collector<tenured_space,to_tenured_policy> {
+ explicit to_tenured_collector(factor_vm *myvm_);
+ void tenure_reachable_objects();
};
}
namespace factor
{
-/* push a new tuple on the stack */
-tuple *factor_vm::allot_tuple(cell layout_)
+/* push a new tuple on the stack, filling its slots with f */
+void factor_vm::primitive_tuple()
{
- gc_root<tuple_layout> layout(layout_,this);
- gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())),this);
+ data_root<tuple_layout> layout(dpop(),this);
+ tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
t->layout = layout.value();
- return t.untagged();
-}
-void factor_vm::primitive_tuple()
-{
- gc_root<tuple_layout> layout(dpop(),this);
- tuple *t = allot_tuple(layout.value());
- fixnum i;
- for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
- t->data()[i] = false_object;
+ memset_cell(t->data(),false_object,tuple_size(layout.untagged()) - sizeof(cell));
- dpush(tag<tuple>(t));
+ dpush(t.value());
}
/* push a new tuple on the stack, filling its slots from the stack */
void factor_vm::primitive_tuple_boa()
{
- gc_root<tuple_layout> layout(dpop(),this);
- gc_root<tuple> t(allot_tuple(layout.value()),this);
+ data_root<tuple_layout> layout(dpop(),this);
+ tagged<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+ t->layout = layout.value();
+
cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
- memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
+ memcpy(t->data(),(cell *)(ds - size + sizeof(cell)),size);
ds -= size;
+
dpush(t.value());
}
namespace factor
{
-inline static cell tuple_size(tuple_layout *layout)
+inline static cell tuple_size(const tuple_layout *layout)
{
cell size = untag_fixnum(layout->size);
return sizeof(tuple) + size * sizeof(cell);
return ptr;
}
-/* We don't use printf directly, because format directives are not portable.
-Instead we define the common cases here. */
-void nl()
-{
- fputs("\n",stdout);
-}
-
-void print_string(const char *str)
-{
- fputs(str,stdout);
-}
-
-void print_cell(cell x)
-{
- printf(CELL_FORMAT,x);
-}
-
-void print_cell_hex(cell x)
-{
- printf(CELL_HEX_FORMAT,x);
-}
-
-void print_cell_hex_pad(cell x)
-{
- printf(CELL_HEX_PAD_FORMAT,x);
-}
-
-void print_fixnum(fixnum x)
-{
- printf(FIXNUM_FORMAT,x);
-}
-
cell read_cell_hex()
{
cell cell;
namespace factor
{
- vm_char *safe_strdup(const vm_char *str);
- void print_string(const char *str);
- void nl();
- void print_cell(cell x);
- void print_cell_hex(cell x);
- void print_cell_hex_pad(cell x);
- void print_fixnum(fixnum x);
- cell read_cell_hex();
+
+inline static void memset_cell(void *dst, cell pattern, size_t size)
+{
+#ifdef __APPLE__
+ #ifdef FACTOR_64
+ memset_pattern8(dst,&pattern,size);
+ #else
+ memset_pattern4(dst,&pattern,size);
+ #endif
+#else
+ if(pattern == 0)
+ memset(dst,0,size);
+ else
+ {
+ cell *start = (cell *)dst;
+ cell *end = (cell *)((cell)dst + size);
+ while(start < end)
+ {
+ *start = pattern;
+ start++;
+ }
+ }
+#endif
+}
+
+vm_char *safe_strdup(const vm_char *str);
+cell read_cell_hex();
+
}
factor_vm::factor_vm() :\r
nursery(0,0),\r
profiling_p(false),\r
- secure_gc(false),\r
gc_off(false),\r
current_gc(NULL),\r
+ gc_events(NULL),\r
fep_disabled(false),\r
full_output(false)\r
- { }\r
+{\r
+ primitive_reset_dispatch_stats();\r
+}\r
\r
}\r
{
struct growable_array;
+struct code_root;
struct factor_vm
{
context *ctx;
/* New objects are allocated here */
- zone nursery;
+ nursery_space nursery;
/* Add this to a shifted address to compute write barrier offsets */
cell cards_offset;
cell decks_offset;
/* TAGGED user environment data; see getenv/setenv prims */
- cell userenv[USER_ENV];
+ cell special_objects[special_object_count];
/* Data stack and retain stack sizes */
cell ds_size, rs_size;
unsigned int signal_fpu_status;
stack_frame *signal_callstack_top;
- /* Zeroes out deallocated memory; set by the -securegc command line argument */
- bool secure_gc;
-
- /* A heap walk allows useful things to be done, like finding all
- references to an object for debugging purposes. */
- cell heap_scan_ptr;
-
/* GC is off during heap walking */
bool gc_off;
/* Only set if we're performing a GC */
gc_state *current_gc;
- /* Statistics */
- gc_statistics gc_stats;
+ /* If not NULL, we push GC events here */
+ std::vector<gc_event> *gc_events;
/* If a runtime function needs to call another function which potentially
- allocates memory, it must wrap any local variable references to Factor
- objects in gc_root instances */
- std::vector<cell> gc_locals;
- std::vector<cell> gc_bignums;
+ allocates memory, it must wrap any references to the data and code
+ heaps with data_root and code_root smart pointers, which register
+ themselves here. See data_roots.hpp and code_roots.hpp */
+ std::vector<data_root_range> data_roots;
+ std::vector<cell> bignum_roots;
+ std::vector<code_root *> code_roots;
/* Debugger */
bool fep_disabled;
cell bignum_neg_one;
/* Method dispatch statistics */
- cell megamorphic_cache_hits;
- cell megamorphic_cache_misses;
-
- cell cold_call_to_ic_transitions;
- cell ic_to_pic_transitions;
- cell pic_to_mega_transitions;
- /* Indexed by PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
- cell pic_counts[4];
+ dispatch_statistics dispatch_stats;
/* Number of entries in a polymorphic inline cache */
cell max_pic_size;
void primitive_set_datastack();
void primitive_set_retainstack();
void primitive_check_datastack();
+ void primitive_load_locals();
template<typename Iterator> void iterate_active_frames(Iterator &iter)
{
}
// run
- void primitive_getenv();
- void primitive_setenv();
void primitive_exit();
void primitive_micros();
void primitive_sleep();
void primitive_set_slot();
- void primitive_load_locals();
+
+ // objects
+ void primitive_special_object();
+ void primitive_set_special_object();
+ cell object_size(cell tagged);
cell clone_object(cell obj_);
void primitive_clone();
+ void primitive_become();
// profiler
void init_profiler();
//data heap
void init_card_decks();
- void clear_cards(old_space *gen);
- void clear_decks(old_space *gen);
- void reset_generation(old_space *gen);
void set_data_heap(data_heap *data_);
- void init_data_heap(cell young_size, cell aging_size, cell tenured_size, bool secure_gc_);
- cell untagged_object_size(object *pointer);
- cell unaligned_object_size(object *pointer);
+ void init_data_heap(cell young_size, cell aging_size, cell tenured_size);
void primitive_size();
- cell binary_payload_start(object *pointer);
+ data_heap_room data_room();
void primitive_data_room();
void begin_scan();
void end_scan();
- void primitive_begin_scan();
- cell next_object();
- void primitive_next_object();
- void primitive_end_scan();
- template<typename Iterator> void each_object(Iterator &iterator);
+ cell instances(cell type);
+ void primitive_all_instances();
cell find_all_words();
- cell object_size(cell tagged);
+
+ template<typename Generation, typename Iterator>
+ inline void each_object(Generation *gen, Iterator &iterator)
+ {
+ cell obj = gen->first_object();
+ while(obj)
+ {
+ iterator((object *)obj);
+ obj = gen->next_object_after(obj);
+ }
+ }
+
+ template<typename Iterator> inline void each_object(Iterator &iterator)
+ {
+ gc_off = true;
+
+ each_object(data->tenured,iterator);
+ each_object(data->aging,iterator);
+ each_object(data->nursery,iterator);
+
+ gc_off = false;
+ }
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
*(char *)(decks_offset + ((cell)slot_ptr >> deck_bits)) = card_mark_mask;
}
+ inline void write_barrier(object *obj, cell size)
+ {
+ char *start = (char *)obj;
+ for(cell offset = 0; offset < size; offset += card_size)
+ write_barrier((cell *)(start + offset));
+ }
+
// gc
+ void end_gc();
+ void start_gc_again();
void update_code_heap_for_minor_gc(std::set<code_block *> *remembered_set);
void collect_nursery();
void collect_aging();
void collect_to_tenured();
- void collect_full_impl(bool trace_contexts_p);
- void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
- void collect_full(bool trace_contexts_p, bool compact_code_heap_p);
- void record_gc_stats(generation_statistics *stats);
- void gc(gc_op op, cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
+ void update_code_roots_for_sweep();
+ void update_code_roots_for_compaction();
+ void collect_mark_impl(bool trace_contexts_p);
+ void collect_sweep_impl();
+ void collect_full(bool trace_contexts_p);
+ void collect_compact_impl(bool trace_contexts_p);
+ void collect_compact_code_impl(bool trace_contexts_p);
+ void collect_compact(bool trace_contexts_p);
+ void collect_growing_heap(cell requested_bytes, bool trace_contexts_p);
+ void gc(gc_op op, cell requested_bytes, bool trace_contexts_p);
void primitive_minor_gc();
void primitive_full_gc();
void primitive_compact_gc();
- void primitive_gc_stats();
- void clear_gc_stats();
- void primitive_become();
- void inline_gc(cell *gc_roots_base, cell gc_roots_size);
+ void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void primitive_enable_gc_events();
+ void primitive_disable_gc_events();
object *allot_object(header header, cell size);
- void add_gc_stats(generation_statistics *stats, growable_array *result);
- void primitive_clear_gc_stats();
+ object *allot_large_object(header header, cell size);
template<typename Type> Type *allot(cell size)
{
#endif
}
- inline void check_tagged_pointer(cell tagged)
- {
- #ifdef FACTOR_DEBUG
- if(!immediate_p(tagged))
- {
- object *obj = untag<object>(tagged);
- check_data_pointer(obj);
- obj->h.hi_tag();
- }
- #endif
- }
-
// generic arrays
- template<typename Array> Array *allot_array_internal(cell capacity);
+ template<typename Array> Array *allot_uninitialized_array(cell capacity);
template<typename Array> bool reallot_array_in_place_p(Array *array, cell capacity);
template<typename Array> Array *reallot_array(Array *array_, cell capacity);
void print_callstack();
void dump_cell(cell x);
void dump_memory(cell from, cell to);
- void dump_zone(const char *name, zone *z);
+ template<typename Generation> void dump_generation(const char *name, Generation *gen);
void dump_generations();
void dump_objects(cell type);
void find_data_references_step(cell *scan);
inline void set_array_nth(array *array, cell slot, cell value);
//strings
- cell string_nth(string* str, cell index);
+ cell string_nth(const string *str, cell index);
void set_string_nth_fast(string *str, cell index, cell ch);
void set_string_nth_slow(string *str_, cell index, cell ch);
void set_string_nth(string *str, cell index, cell ch);
void primitive_uninitialized_byte_array();
void primitive_resize_byte_array();
+ template<typename Type> byte_array *byte_array_from_value(Type *value);
+ template<typename Type> byte_array *byte_array_from_values(Type *values, cell len);
+
//tuples
- tuple *allot_tuple(cell layout_);
void primitive_tuple();
void primitive_tuple_boa();
word *allot_word(cell name_, cell vocab_, cell hashcode_);
void primitive_word();
void primitive_word_xt();
- void update_word_xt(cell w_);
+ void update_word_xt(word *w_);
void primitive_optimized_p();
void primitive_wrapper();
void primitive_bignum_log2();
unsigned int bignum_producer(unsigned int digit);
void primitive_byte_array_to_bignum();
- cell unbox_array_size();
+ inline cell unbox_array_size();
+ cell unbox_array_size_slow();
void primitive_fixnum_to_float();
void primitive_bignum_to_float();
void primitive_str_to_float();
inline double untag_float_check(cell tagged);
inline fixnum float_to_fixnum(cell tagged);
inline double fixnum_to_float(cell tagged);
+
+ // tagged
template<typename Type> Type *untag_check(cell value);
- template<typename Type> Type *untag(cell value);
//io
void init_c_io();
void update_literal_references(code_block *compiled);
void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled);
void update_word_references(code_block *compiled);
- void update_code_block_for_full_gc(code_block *compiled);
+ void update_code_block_words_and_literals(code_block *compiled);
void check_code_address(cell address);
void relocate_code_block(code_block *compiled);
void fixup_labels(array *labels, code_block *compiled);
- code_block *allot_code_block(cell size, cell type);
- code_block *add_code_block(cell type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
+ code_block *allot_code_block(cell size, code_block_type type);
+ code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell literals_);
//code heap
inline void check_code_pointer(cell ptr)
bool in_code_heap_p(cell ptr);
void jit_compile_word(cell word_, cell def_, bool relocate);
void update_code_heap_words();
+ void update_code_heap_words_and_literals();
void primitive_modify_code_heap();
+ code_heap_room code_room();
void primitive_code_room();
- void forward_object_xts();
- void forward_context_xts();
- void forward_callback_xts();
- void compact_code_heap(bool trace_contexts_p);
void primitive_strip_stack_traces();
/* Apply a function to every code block */
template<typename Iterator> void iterate_code_heap(Iterator &iter)
{
- heap_block *scan = code->first_block();
-
- while(scan)
- {
- if(scan->type() != FREE_BLOCK_TYPE)
- iter((code_block *)scan);
- scan = code->next_block(scan);
- }
+ code->allocator->iterate(iter);
}
//callbacks
void primitive_callstack();
void primitive_set_callstack();
code_block *frame_code(stack_frame *frame);
- cell frame_type(stack_frame *frame);
+ code_block_type frame_type(stack_frame *frame);
cell frame_executing(stack_frame *frame);
stack_frame *frame_successor(stack_frame *frame);
cell frame_scan(stack_frame *frame);
/* Every object has a regular representation in the runtime, which makes GC
much simpler. Every slot of the object until binary_payload_start is a pointer
to some other object. */
- template<typename Iterator> void do_slots(cell obj, Iterator &iter)
+ template<typename Iterator> void do_slots(object *obj, Iterator &iter)
{
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
+ cell scan = (cell)obj;
+ cell payload_start = obj->binary_payload_start();
+ cell end = scan + payload_start;
scan += sizeof(cell);
cell nth_superclass(tuple_layout *layout, fixnum echelon);
cell nth_hashcode(tuple_layout *layout, fixnum echelon);
cell lookup_tuple_method(cell obj, cell methods);
- cell lookup_hi_tag_method(cell obj, cell methods);
- cell lookup_hairy_method(cell obj, cell methods);
cell lookup_method(cell obj, cell methods);
void primitive_lookup_method();
cell object_class(cell obj);
cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_);
void update_pic_transitions(cell pic_size);
void *inline_cache_miss(cell return_address);
- void primitive_reset_inline_cache_stats();
- void primitive_inline_cache_stats();
//factor
void default_parameters(vm_parameters *p);
};
-extern unordered_map<THREADHANDLE, factor_vm *> thread_vms;
+extern std::map<THREADHANDLE, factor_vm *> thread_vms;
}
word *factor_vm::allot_word(cell name_, cell vocab_, cell hashcode_)
{
- gc_root<object> vocab(vocab_,this);
- gc_root<object> name(name_,this);
+ data_root<object> vocab(vocab_,this);
+ data_root<object> name(name_,this);
- gc_root<word> new_word(allot<word>(sizeof(word)),this);
+ data_root<word> new_word(allot<word>(sizeof(word)),this);
new_word->hashcode = hashcode_;
new_word->vocabulary = vocab.value();
new_word->name = name.value();
- new_word->def = userenv[UNDEFINED_ENV];
+ new_word->def = special_objects[OBJ_UNDEFINED];
new_word->props = false_object;
new_word->counter = tag_fixnum(0);
new_word->pic_def = false_object;
new_word->code = NULL;
jit_compile_word(new_word.value(),new_word->def,true);
- update_word_xt(new_word.value());
+ update_word_xt(new_word.untagged());
if(profiling_p)
relocate_code_block(new_word->profiling);
/* word-xt ( word -- start end ) */
void factor_vm::primitive_word_xt()
{
- gc_root<word> w(dpop(),this);
+ data_root<word> w(dpop(),this);
w.untag_check(this);
if(profiling_p)
}
/* Allocates memory */
-void factor_vm::update_word_xt(cell w_)
+void factor_vm::update_word_xt(word *w_)
{
- gc_root<word> w(w_,this);
+ data_root<word> w(w_,this);
if(profiling_p)
{
if(!w->profiling)
{
- /* Note: can't do w->profiling = ... since if LHS
- evaluates before RHS, since in that case if RHS does a
- GC, we will have an invalid pointer on the LHS */
+ /* Note: can't do w->profiling = ... since LHS evaluates
+ before RHS, and if RHS does a GC, we will have an
+ invalid pointer on the LHS */
code_block *profiling = compile_profiling_stub(w.value());
w->profiling = profiling;
}
void factor_vm::primitive_optimized_p()
{
- drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
+ word *w = untag_check<word>(dpeek());
+ drepl(tag_boolean(w->code->optimized_p()));
}
void factor_vm::primitive_wrapper()
namespace factor
{
-inline bool word_optimized_p(word *word)
-{
- return word->code->type() == WORD_TYPE;
-}
-
}
+++ /dev/null
-namespace factor
-{
-
-struct zone {
- /* offset of 'here' and 'end' is hardcoded in compiler backends */
- cell here;
- cell start;
- cell end;
- cell size;
-
- zone(cell size_, cell start_) : here(0), start(start_), end(start_ + size_), size(size_) {}
-
- inline bool contains_p(object *pointer)
- {
- return ((cell)pointer - start) < size;
- }
-
- inline object *allot(cell size)
- {
- cell h = here;
- here = h + align8(size);
- return (object *)h;
- }
-};
-
-}