vm/callstack.o \
vm/code_block.o \
vm/code_heap.o \
+ vm/compaction.o \
vm/contexts.o \
vm/data_heap.o \
+ vm/data_heap_checker.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 \
-IN: alarms\r
USING: help.markup help.syntax calendar quotations ;\r
+IN: alarms\r
\r
HELP: alarm\r
{ $class-description "An alarm. Can be passed to " { $link cancel-alarm } "." } ;\r
\r
HELP: add-alarm\r
{ $values { "quot" quotation } { "time" timestamp } { "frequency" { $maybe duration } } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;\r
+{ $description "Creates and registers an alarm to start at " { $snippet "time" } ". If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;\r
\r
HELP: later\r
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;\r
+{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: alarms io calendar ;"\r
+ """[ "GET BACK TO WORK, Guy." print flush ] 10 minutes later drop"""\r
+ ""\r
+ }\r
+} ;\r
\r
HELP: cancel-alarm\r
{ $values { "alarm" alarm } }\r
{ $values\r
{ "quot" quotation } { "duration" duration }\r
{ "alarm" alarm } }\r
-{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;\r
+{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." }\r
+{ $examples\r
+ { $unchecked-example\r
+ "USING: alarms io calendar ;"\r
+ """[ "Hi Buddy." print flush ] 10 seconds every drop"""\r
+ ""\r
+ }\r
+} ;\r
\r
ARTICLE: "alarms" "Alarms"\r
-"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread."\r
+"The " { $vocab-link "alarms" } " vocabulary provides a lightweight way to schedule one-time and recurring tasks without spawning a new thread." $nl\r
+"The alarm class:"\r
{ $subsections\r
alarm\r
- add-alarm\r
- later\r
- cancel-alarm\r
}\r
+"Register a recurring alarm:"\r
+{ $subsections every }\r
+"Register a one-time alarm:"\r
+{ $subsections later }\r
+"Low-level interface to add alarms:"\r
+{ $subsections add-alarm }\r
+"Cancelling an alarm:"\r
+{ $subsections cancel-alarm }\r
"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ;\r
\r
ABOUT: "alarms"\r
M: array c-type-align first c-type-align ;
+M: array c-type-align-first first c-type-align-first ;
+
M: array c-type-stack-align? drop f ;
M: array unbox-parameter drop void* unbox-parameter ;
M: string-type c-type-align
drop void* c-type-align ;
+M: string-type c-type-align-first
+ drop void* c-type-align-first ;
+
M: string-type c-type-stack-align?
drop void* c-type-stack-align? ;
{ char* utf8 } char* typedef
char* uchar* typedef
-char char* "pointer-c-type" set-word-prop
+char char* "pointer-c-type" set-word-prop
uchar uchar* "pointer-c-type" set-word-prop
{ unboxer-quot callable }
{ getter callable }
{ setter callable }
-size
-align ;
+{ size integer }
+{ align integer }
+{ align-first integer } ;
TUPLE: c-type < abstract-c-type
boxer
GENERIC: c-struct? ( c-type -- ? )
-M: object c-struct?
- drop f ;
-M: c-type-name c-struct?
- dup void? [ drop f ] [ c-type c-struct? ] if ;
+M: object c-struct? drop f ;
+
+M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
M: c-type-name c-type-align c-type c-type-align ;
+GENERIC: c-type-align-first ( name -- n )
+
+M: c-type-name c-type-align-first c-type c-type-align-first ;
+
+M: abstract-c-type c-type-align-first align-first>> ;
+
GENERIC: c-type-stack-align? ( name -- ? )
M: c-type c-type-stack-align? stack-align?>> ;
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 -- )
ptrdiff_t intptr_t uintptr_t size_t
char* uchar* ;
+: 8-byte-alignment ( c-type -- c-type )
+ {
+ { [ cpu ppc? os macosx? and ] [ 4 >>align 8 >>align-first ] }
+ { [ cpu x86.32? os windows? not and ] [ 4 >>align 4 >>align-first ] }
+ [ 8 >>align 8 >>align-first ]
+ } cond ;
+
[
<c-type>
c-ptr >>class
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
+ bootstrap-cell >>align-first
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
[ alien-signed-8 ] >>getter
[ set-alien-signed-8 ] >>setter
8 >>size
- 8 >>align
+ 8-byte-alignment
"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
+ 8-byte-alignment
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
\ ulonglong define-primitive-type
[ set-alien-signed-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
+ bootstrap-cell >>align-first
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
\ long define-primitive-type
[ set-alien-unsigned-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
+ bootstrap-cell >>align-first
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
\ ulong define-primitive-type
[ set-alien-signed-4 ] >>setter
4 >>size
4 >>align
+ 4 >>align-first
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
\ int define-primitive-type
[ set-alien-unsigned-4 ] >>setter
4 >>size
4 >>align
+ 4 >>align-first
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
\ uint define-primitive-type
[ set-alien-signed-2 ] >>setter
2 >>size
2 >>align
+ 2 >>align-first
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
\ short define-primitive-type
[ set-alien-unsigned-2 ] >>setter
2 >>size
2 >>align
+ 2 >>align-first
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
\ ushort define-primitive-type
[ set-alien-signed-1 ] >>setter
1 >>size
1 >>align
+ 1 >>align-first
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
\ char define-primitive-type
[ set-alien-unsigned-1 ] >>setter
1 >>size
1 >>align
+ 1 >>align-first
"box_unsigned_1" >>boxer
"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
+ cpu ppc? [
+ <c-type>
+ [ alien-unsigned-4 c-bool> ] >>getter
+ [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ 4 >>align-first
+ "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
+ 1 >>align-first
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
+ ] if
\ bool define-primitive-type
<c-type>
[ [ >float ] 2dip set-alien-float ] >>setter
4 >>size
4 >>align
+ 4 >>align-first
"box_float" >>boxer
"to_float" >>unboxer
float-rep >>rep
[ alien-double ] >>getter
[ [ >float ] 2dip set-alien-double ] >>setter
8 >>size
- 8 >>align
+ 8-byte-alignment
"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
M: eq-wrapper equal?
over eq-wrapper? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
+M: eq-wrapper hashcode*
+ nip obj>> identity-hashcode ;
+
SYMBOL: objects
: cache-eql-object ( obj quot -- value )
! 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-header ( n -- ) tag-header 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 emit-header call align-here ] dip ;
inline
! Write an object to the image.
! Image header
-: emit-header ( -- )
+: emit-image-header ( -- )
image-magic emit
image-version emit
data-base emit ! relocation base at end of header
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 ;
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
- emit-header t, 0, 1, -1,
+ emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
remake-generics
"Serializing words..." print flush
"stage2: deployment mode" print
] [
"debugger" require
- "inspector" require
- "tools.errors" require
"listener" require
"none" require
] if
IN: bootstrap.tools
{
+ "editors"
"inspector"
"bootstrap.image"
+ "see"
"tools.annotations"
"tools.crossref"
"tools.errors"
"tools.deploy"
"tools.destructors"
"tools.disassembler"
+ "tools.dispatch"
"tools.memory"
"tools.profiler"
"tools.test"
"vocabs.hierarchy"
"vocabs.refresh"
"vocabs.refresh.monitor"
- "editors"
} [ require ] each
"}" parse-tokens "" join
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
- parsed ;
+ suffix! ;
{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
HELP: month-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
HELP: month-abbreviations
HELP: day-names
-{ $values { "array" array } }
+{ $values { "value" array } }
{ $description "Returns an array with the English names of the days of the week." } ;
HELP: day-name
-{ $values { "n" integer } { "string" string } }
+{ $values { "obj" { $or integer timestamp } } { "string" string } }
{ $description "Looks up the day name and returns it as a string." } ;
HELP: day-abbreviations2
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test
+
+[ t ] [ 1325376000 unix-time>timestamp 2012 <year-gmt> = ] unit-test
+[ t ] [ 1356998399 unix-time>timestamp 2013 <year-gmt> 1 seconds time- = ] unit-test
+
+[ t ] [ 1500000000 random [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test
C: <duration> duration
+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+
TUPLE: timestamp
{ year integer }
{ month integer }
: <date> ( year month day -- timestamp )
0 0 0 gmt-offset-duration <timestamp> ;
+: <date-gmt> ( year month day -- timestamp )
+ 0 0 0 instant <timestamp> ;
+
+: <year> ( year -- timestamp )
+ 1 1 <date> ;
+
+: <year-gmt> ( year -- timestamp )
+ 1 1 <date-gmt> ;
+
ERROR: not-a-month ;
M: not-a-month summary
drop "Months are indexed starting at 1" ;
"July" "August" "September" "October" "November" "December"
}
-: month-name ( n -- string )
- check-month 1 - month-names nth ;
+<PRIVATE
+
+: (month-name) ( n -- string ) 1 - month-names nth ;
+
+PRIVATE>
+
+GENERIC: month-name ( obj -- string )
+
+M: integer month-name check-month 1 - month-names nth ;
+M: timestamp month-name month>> 1 - month-names nth ;
CONSTANT: month-abbreviations
{
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
-: day-names ( -- array )
- {
- "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
- } ;
-
-: day-name ( n -- string ) day-names nth ;
+CONSTANT: day-names
+ { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" }
CONSTANT: day-abbreviations2
{ "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
:: 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 )
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
-: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
: years ( x -- duration ) instant clone swap >>year ;
: months ( x -- duration ) instant clone swap >>month ;
: days ( x -- duration ) instant clone swap >>day ;
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
+GENERIC: year ( obj -- n )
+M: integer year ;
+M: timestamp year year>> ;
+
+GENERIC: month ( obj -- n )
+M: integer month ;
+M: timestamp month month>> ;
+
+GENERIC: day ( obj -- n )
+M: integer day ;
+M: timestamp day day>> ;
+
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
+: same-day? ( ts1 ts2 -- ? )
+ [ >gmt >date< <date> ] bi@ = ;
+
: (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
: day-of-week ( timestamp -- n )
>date< zeller-congruence ;
+GENERIC: day-name ( obj -- string )
+M: integer day-name day-names nth ;
+M: timestamp day-name day-of-week day-names nth ;
+
:: (day-of-year) ( year month day -- n )
day-counts month head-slice sum day +
year leap-year? [
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
+: midnight ( timestamp -- new-timestamp )
+ clone 0 >>hour 0 >>minute 0 >>second ; inline
+
+: noon ( timestamp -- new-timestamp )
+ midnight 12 >>hour ; inline
+
+: beginning-of-month ( timestamp -- new-timestamp )
+ midnight 1 >>day ;
+
+: end-of-month ( timestamp -- new-timestamp )
+ [ midnight ] [ days-in-month ] bi >>day ;
+
<PRIVATE
-: day-offset ( timestamp m -- timestamp n )
+
+: day-offset ( timestamp m -- new-timestamp n )
over day-of-week - ; inline
-: day-this-week ( timestamp n -- timestamp )
+: day-this-week ( timestamp n -- new-timestamp )
day-offset days time+ ;
+
+:: nth-day-this-month ( timestamp n day -- new-timestamp )
+ timestamp beginning-of-month day day-this-week
+ dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
+ n 1 - [ weeks time+ ] unless-zero ;
+
+: last-day-this-month ( timestamp day -- new-timestamp )
+ [ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
+
PRIVATE>
+GENERIC: january ( obj -- timestamp )
+GENERIC: february ( obj -- timestamp )
+GENERIC: march ( obj -- timestamp )
+GENERIC: april ( obj -- timestamp )
+GENERIC: may ( obj -- timestamp )
+GENERIC: june ( obj -- timestamp )
+GENERIC: july ( obj -- timestamp )
+GENERIC: august ( obj -- timestamp )
+GENERIC: september ( obj -- timestamp )
+GENERIC: october ( obj -- timestamp )
+GENERIC: november ( obj -- timestamp )
+GENERIC: december ( obj -- timestamp )
+
+M: integer january 1 1 <date> ;
+M: integer february 2 1 <date> ;
+M: integer march 3 1 <date> ;
+M: integer april 4 1 <date> ;
+M: integer may 5 1 <date> ;
+M: integer june 6 1 <date> ;
+M: integer july 7 1 <date> ;
+M: integer august 8 1 <date> ;
+M: integer september 9 1 <date> ;
+M: integer october 10 1 <date> ;
+M: integer november 11 1 <date> ;
+M: integer december 12 1 <date> ;
+
+M: timestamp january clone 1 >>month ;
+M: timestamp february clone 2 >>month ;
+M: timestamp march clone 3 >>month ;
+M: timestamp april clone 4 >>month ;
+M: timestamp may clone 5 >>month ;
+M: timestamp june clone 6 >>month ;
+M: timestamp july clone 7 >>month ;
+M: timestamp august clone 8 >>month ;
+M: timestamp september clone 9 >>month ;
+M: timestamp october clone 10 >>month ;
+M: timestamp november clone 11 >>month ;
+M: timestamp december clone 12 >>month ;
+
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
-: midnight ( timestamp -- new-timestamp )
- clone 0 >>hour 0 >>minute 0 >>second ; inline
-
-: noon ( timestamp -- new-timestamp )
- midnight 12 >>hour ; inline
-
-: beginning-of-month ( timestamp -- new-timestamp )
- midnight 1 >>day ;
+: sunday? ( timestamp -- ? ) day-of-week 0 = ;
+: monday? ( timestamp -- ? ) day-of-week 1 = ;
+: tuesday? ( timestamp -- ? ) day-of-week 2 = ;
+: wednesday? ( timestamp -- ? ) day-of-week 3 = ;
+: thursday? ( timestamp -- ? ) day-of-week 4 = ;
+: friday? ( timestamp -- ? ) day-of-week 5 = ;
+: saturday? ( timestamp -- ? ) day-of-week 6 = ;
+
+: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
+: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
+: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
+: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
+: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
+: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
+: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
+
+: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
+: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
+: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
+: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
+: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
+: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
+: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
: beginning-of-week ( timestamp -- new-timestamp )
midnight sunday ;
-: beginning-of-year ( timestamp -- new-timestamp )
- beginning-of-month 1 >>month ;
+GENERIC: beginning-of-year ( object -- new-timestamp )
+M: timestamp beginning-of-year beginning-of-month 1 >>month ;
+M: integer beginning-of-year <year> ;
+
+GENERIC: end-of-year ( object -- new-timestamp )
+M: timestamp end-of-year 12 >>month 31 >>day ;
+M: integer end-of-year 12 31 <date> ;
: time-since-midnight ( timestamp -- duration )
dup midnight time- ;
: since-1970 ( duration -- timestamp )
unix-1970 time+ >local-time ;
+: timestamp>unix-time ( timestamp -- seconds )
+ unix-1970 time- second>> ;
+
+: unix-time>timestamp ( seconds -- timestamp )
+ seconds unix-1970 time+ ;
+
M: timestamp sleep-until timestamp>micros sleep-until ;
M: duration sleep hence sleep-until ;
: timespec>seconds ( timespec -- seconds )
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
+: timespec>nanoseconds ( timespec -- seconds )
+ [ sec>> 1000000000 * ] [ nsec>> ] bi + ;
+
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
] 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
[ -2 ] [ bit-field-test <struct> 2 >>b b>> ] unit-test
[ 1 ] [ bit-field-test <struct> 257 >>c c>> ] unit-test
[ 3 ] [ bit-field-test heap-size ] unit-test
+
+cpu ppc? [
+ STRUCT: ppc-align-test-1
+ { x longlong }
+ { y int } ;
+
+ [ 16 ] [ ppc-align-test-1 heap-size ] unit-test
+
+ STRUCT: ppc-align-test-2
+ { y int }
+ { x longlong } ;
+
+ [ 12 ] [ ppc-align-test-2 heap-size ] unit-test
+ [ 4 ] [ "x" ppc-align-test-2 offset-of ] unit-test
+] when
slots >>fields
size >>size
align >>align
+ align >>align-first
class (unboxer-quot) >>unboxer-quot
- class (boxer-quot) >>boxer-quot ;
-
-GENERIC: align-offset ( offset class -- offset' )
+ class (boxer-quot) >>boxer-quot ;
+
+GENERIC: compute-slot-offset ( offset class -- offset' )
-M: struct-slot-spec align-offset
- [ type>> c-type-align 8 * align ] keep
+: c-type-align-at ( class offset -- n )
+ 0 = [ c-type-align-first ] [ c-type-align ] if ;
+
+M: struct-slot-spec compute-slot-offset
+ [ type>> over c-type-align-at 8 * align ] keep
[ [ 8 /i ] dip (>>offset) ] [ type>> heap-size 8 * + ] 2bi ;
-M: struct-bit-slot-spec align-offset
+M: struct-bit-slot-spec compute-slot-offset
[ (>>offset) ] [ bits>> + ] 2bi ;
-: struct-offsets ( slots -- size )
- 0 [ align-offset ] reduce 8 align 8 /i ;
+: compute-struct-offsets ( slots -- size )
+ 0 [ compute-slot-offset ] reduce 8 align 8 /i ;
-: union-struct-offsets ( slots -- size )
+: compute-union-offsets ( slots -- size )
1 [ 0 >>offset type>> heap-size max ] reduce ;
-: struct-align ( slots -- align )
+: struct-alignment ( slots -- align )
[ struct-bit-slot-spec? not ] filter
- 1 [ type>> c-type-align max ] reduce ;
+ 1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+
PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable
M: object binary-zero? drop f ;
M: f binary-zero? drop t ;
-M: number binary-zero? zero? ;
-M: struct binary-zero?
- [ byte-length iota ] [ >c-ptr ] bi
- [ <displaced-alien> *uchar zero? ] curry all? ;
+M: number binary-zero? 0 = ;
+M: struct binary-zero? >c-ptr [ 0 = ] all? ;
: struct-needs-prototype? ( class -- ? )
struct-slots [ initial>> binary-zero? ] all? not ;
slots empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
slots make-slots dup check-struct-slots :> slot-specs
- slot-specs struct-align :> alignment
+ slot-specs struct-alignment :> alignment
slot-specs offsets-quot call alignment align :> size
class slot-specs size alignment c-type-for-class :> c-type
PRIVATE>
: define-struct-class ( class slots -- )
- [ struct-offsets ] (define-struct-class) ;
+ [ compute-struct-offsets ] (define-struct-class) ;
: define-union-struct-class ( class slots -- )
- [ union-struct-offsets ] (define-struct-class) ;
+ [ compute-union-offsets ] (define-struct-class) ;
M: struct-class reset-class
[ call-next-method ] [ name>> c-types get delete-at ] bi ;
: 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 ;
{ +superclass+ "NSObject" }
}
-{ "perform:" "void" { "id" "SEL" "id" }
+{ "perform:" void { id SEL id }
[ 2drop callbacks get at try ]
}
-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
[
drop
dup callbacks get delete-at
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
-compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math core-graphics.types ;
+compiler kernel namespaces cocoa.classes cocoa.runtime
+tools.test memory compiler.units math core-graphics.types ;
+FROM: alien.c-types => int void ;
IN: cocoa.tests
CLASS: {
{ +name+ "Foo" }
} {
"foo:"
- "void"
- { "id" "SEL" "NSRect" }
+ void
+ { id SEL NSRect }
[ gc "x" set 2drop ]
} ;
{ +name+ "Bar" }
} {
"bar"
- "NSRect"
- { "id" "SEL" }
+ NSRect
+ { id SEL }
[ 2drop test-foo "x" get ]
} ;
{ +name+ "Bar" }
} {
"bar"
- "NSRect"
- { "id" "SEL" }
+ NSRect
+ { id SEL }
[ 2drop test-foo "x" get ]
} {
"babb"
- "int"
- { "id" "SEL" "int" }
+ int
+ { id SEL int }
[ 2nip sq ]
} ;
: 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
IN: cocoa.messages
HELP: send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to " { $snippet "receiver" } ". The arguments must be on the stack in left-to-right order." }
{ $errors "Throws an error if the receiver does not recognize the message, or if the arguments have inappropriate types." }
{ $notes "This word uses a special fast code path if " { $snippet "selector" } " is a literal and the word containing the call to " { $link send } " is compiled." } ;
HELP: super-send
-{ $values { "args..." "method arguments" } { "receiver" alien } { "selector" string } { "return..." "value returned by method, if any" } }
+{ $values { "receiver" alien } { "args..." "method arguments" } { "selector" string } { "return..." "value returned by method, if any" } }
{ $description "Sends an Objective C message named by " { $snippet "selector" } " to the super class of " { $snippet "receiver" } ". Otherwise behaves identically to " { $link send } "." } ;
HELP: objc-class
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings arrays assocs
classes.struct continuations combinators compiler compiler.alien
-stack-checker kernel math namespaces make quotations sequences
-strings words cocoa.runtime io macros memoize io.encodings.utf8
-effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays ;
+core-graphics.types stack-checker kernel math namespaces make
+quotations sequences strings words cocoa.runtime cocoa.types io
+macros memoize io.encodings.utf8 effects layouts libc
+libc.private lexer init core-foundation fry generalizations
+specialized-arrays ;
+QUALIFIED-WITH: alien.c-types c
IN: cocoa.messages
SPECIALIZED-ARRAY: void*
SYMBOL: objc>alien-types
H{
- { "c" "char" }
- { "i" "int" }
- { "s" "short" }
- { "C" "uchar" }
- { "I" "uint" }
- { "S" "ushort" }
- { "f" "float" }
- { "d" "double" }
- { "B" "bool" }
- { "v" "void" }
- { "*" "char*" }
- { "?" "unknown_type" }
- { "@" "id" }
- { "#" "Class" }
- { ":" "SEL" }
+ { "c" c:char }
+ { "i" c:int }
+ { "s" c:short }
+ { "C" c:uchar }
+ { "I" c:uint }
+ { "S" c:ushort }
+ { "f" c:float }
+ { "d" c:double }
+ { "B" c:bool }
+ { "v" c:void }
+ { "*" c:char* }
+ { "?" unknown_type }
+ { "@" id }
+ { "#" Class }
+ { ":" SEL }
}
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "l" "long" }
- { "q" "longlong" }
- { "L" "ulong" }
- { "Q" "ulonglong" }
+ { "l" c:long }
+ { "q" c:longlong }
+ { "L" c:ulong }
+ { "Q" c:ulonglong }
} ] }
{ 8 [ H{
- { "l" "long32" }
- { "q" "long" }
- { "L" "ulong32" }
- { "Q" "ulong" }
+ { "l" long32 }
+ { "q" long }
+ { "L" ulong32 }
+ { "Q" ulong }
} ] }
} case
assoc-union objc>alien-types set-global
+SYMBOL: objc>struct-types
+
+H{
+ { "_NSPoint" NSPoint }
+ { "NSPoint" NSPoint }
+ { "CGPoint" NSPoint }
+ { "_NSRect" NSRect }
+ { "NSRect" NSRect }
+ { "CGRect" NSRect }
+ { "_NSSize" NSSize }
+ { "NSSize" NSSize }
+ { "CGSize" NSSize }
+ { "_NSRange" NSRange }
+ { "NSRange" NSRange }
+} objc>struct-types set-global
+
! The transpose of the above map
SYMBOL: alien>objc-types
objc>alien-types get [ swap ] assoc-map
! A hack...
-"ptrdiff_t" heap-size {
+cell {
{ 4 [ H{
- { "NSPoint" "{_NSPoint=ff}" }
- { "NSRect" "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
- { "NSSize" "{_NSSize=ff}" }
- { "NSRange" "{_NSRange=II}" }
- { "NSInteger" "i" }
- { "NSUInteger" "I" }
- { "CGFloat" "f" }
+ { NSPoint "{_NSPoint=ff}" }
+ { NSRect "{_NSRect={_NSPoint=ff}{_NSSize=ff}}" }
+ { NSSize "{_NSSize=ff}" }
+ { NSRange "{_NSRange=II}" }
+ { NSInteger "i" }
+ { NSUInteger "I" }
+ { CGFloat "f" }
} ] }
{ 8 [ H{
- { "NSPoint" "{CGPoint=dd}" }
- { "NSRect" "{CGRect={CGPoint=dd}{CGSize=dd}}" }
- { "NSSize" "{CGSize=dd}" }
- { "NSRange" "{_NSRange=QQ}" }
- { "NSInteger" "q" }
- { "NSUInteger" "Q" }
- { "CGFloat" "d" }
+ { NSPoint "{CGPoint=dd}" }
+ { NSRect "{CGRect={CGPoint=dd}{CGSize=dd}}" }
+ { NSSize "{CGSize=dd}" }
+ { NSRange "{_NSRange=QQ}" }
+ { NSInteger "q" }
+ { NSUInteger "Q" }
+ { CGFloat "d" }
} ] }
} case
assoc-union alien>objc-types set-global
-: internal-cocoa-type? ( c-type -- ? )
- [ "?" = ] [ first CHAR: _ = ] bi or ;
-
-: warn-c-type ( c-type -- )
- dup internal-cocoa-type?
- [ drop ] [ "Warning: no such C type: " write print ] if ;
-
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
- dup c-types get key? [ warn-c-type "void*" ] unless ;
+ objc>struct-types get at* [ drop void* ] unless ;
ERROR: no-objc-type name ;
: (parse-objc-type) ( i string -- ctype )
[ [ 1 + ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
- { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: ^ = ] [ 3drop void* ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
- { [ dup CHAR: [ = ] [ 3drop "void*" ] }
+ { [ dup CHAR: [ = ] [ 3drop void* ] }
[ 2nip decode-type ]
} cond ;
IN: cocoa.subclassing
HELP: define-objc-class
-{ $values { "hash" hashtable } { "imeth" "a sequence of instance method definitions" } }
+{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
{ $list
{ { $link +name+ } " - a string naming the new class. Required." }
: 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 ;
slots.private vectors sbufs strings math.partial-dispatch
hashtables assocs combinators.short-circuit
strings.private accessors compiler.cfg.instructions ;
+FROM: alien.c-types => int ;
IN: compiler.cfg.builder.tests
! Just ensure that various CFGs build correctly.
[ [ t ] loop ]
[ [ dup ] loop ]
[ [ 2 ] [ 3 throw ] if 4 ]
- [ "int" f "malloc" { "int" } alien-invoke ]
- [ "int" { "int" } "cdecl" alien-indirect ]
- [ "int" { "int" } "cdecl" [ ] alien-callback ]
+ [ int f "malloc" { int } alien-invoke ]
+ [ int { int } "cdecl" alien-indirect ]
+ [ int { int } "cdecl" [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
{
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
] when
! Regression. Make sure everything is inlined correctly
-[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
\ No newline at end of file
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] 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
{
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
-{ id integer }
+id
number
{ instructions vector }
{ successors vector }
{ predecessors vector } ;
-M: basic-block hashcode* nip id>> ;
-
: <basic-block> ( -- bb )
basic-block new
+ \ basic-block counter >>id
V{ } clone >>instructions
V{ } clone >>successors
- V{ } clone >>predecessors
- \ basic-block counter >>id ;
+ V{ } clone >>predecessors ;
+
+M: basic-block hashcode* nip id>> ;
TUPLE: cfg { entry basic-block } word label
spill-area-size reps
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
{
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:getenv [ emit-getenv ] }
+ { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ math.private:fixnum- [ drop emit-fixnum- ] }
{ math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
{ 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 ] }
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel
-accessors compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.utilities ;
+USING: namespaces layouts sequences kernel math accessors
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
swap node-input-infos first literal>>
[ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
ds-push ;
+
+: emit-identity-hashcode ( -- )
+ ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
+ hashcode-shift ^^shr-imm
+ ^^tag-fixnum
+ ds-push ;
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.intrinsics.alien
specialized-arrays ;
-FROM: alien.c-types => heap-size char uchar float double ;
-SPECIALIZED-ARRAYS: float double ;
+FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
+SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
IN: compiler.cfg.intrinsics.simd
MACRO: check-elements ( quots -- )
: [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 ;
[ ^^not-vector ]
[ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
-:: (generate-compare-vector) ( src1 src2 rep {cc,swap} -- dst )
- {cc,swap} first2 :> swap? :> cc
+:: ((generate-compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
+ {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
+:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
+ rep orig-cc %compare-vector-ccs :> ( ccs not? )
ccs empty?
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
- ccs unclip :> first-cc :> rest-ccs
- src1 src2 rep first-cc (generate-compare-vector) :> first-dst
+ ccs unclip :> ( rest-ccs first-cc )
+ src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
rest-ccs first-dst
- [ [ src1 src2 rep ] dip (generate-compare-vector) rep ^^or-vector ]
+ [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
reduce
not? [ rep generate-not-vector ] when
] if ;
+: sign-bit-mask ( rep -- byte-array )
+ unsign-rep {
+ { char-16-rep [ uchar-array{
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ } underlying>> ] }
+ { short-8-rep [ ushort-array{
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ } underlying>> ] }
+ { int-4-rep [ uint-array{
+ HEX: 8000,0000 HEX: 8000,0000
+ HEX: 8000,0000 HEX: 8000,0000
+ } underlying>> ] }
+ { longlong-2-rep [ ulonglong-array{
+ HEX: 8000,0000,0000,0000
+ HEX: 8000,0000,0000,0000
+ } underlying>> ] }
+ } case ;
+
+:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
+ orig-cc order-cc {
+ { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
+ { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
+ { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
+ { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
+ } case ;
+
+:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
+ {
+ {
+ [ rep orig-cc %compare-vector-reps member? ]
+ [ src1 src2 rep orig-cc (generate-compare-vector) ]
+ }
+ {
+ [ rep %min-vector-reps member? ]
+ [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
+ }
+ {
+ [ rep unsign-rep orig-cc %compare-vector-reps member? ]
+ [
+ rep sign-bit-mask ^^load-constant :> sign-bits
+ src1 sign-bits rep ^^xor-vector
+ src2 sign-bits rep ^^xor-vector
+ rep unsign-rep orig-cc (generate-compare-vector)
+ ]
+ }
+ } cond ;
+
:: generate-unpack-vector-head ( src rep -- 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
]
} cond ;
+: generate-min-vector ( src1 src2 rep -- dst )
+ dup %min-vector-reps member?
+ [ ^^min-vector ] [
+ [ cc< generate-compare-vector ]
+ [ generate-blend-vector ] 3bi
+ ] if ;
+
+: generate-max-vector ( src1 src2 rep -- dst )
+ dup %max-vector-reps member?
+ [ ^^max-vector ] [
+ [ cc> generate-compare-vector ]
+ [ generate-blend-vector ] 3bi
+ ] if ;
+
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences math
-classes.algebra locals combinators cpu.architecture
-compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.hats compiler.cfg.registers
+classes.algebra classes.builtin locals combinators
+cpu.architecture compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
compiler.cfg.instructions compiler.cfg.utilities
compiler.cfg.builder.blocks compiler.constants ;
IN: compiler.cfg.intrinsics.slots
-: value-tag ( info -- n ) class>> class-tag ; inline
+: class-tag ( class -- tag/f )
+ builtins get [ class<= ] with find drop ;
+
+: value-tag ( info -- n ) class>> class-tag ;
: ^^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 '[
M: reference-expr equal?
over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
+M: reference-expr hashcode*
+ nip value>> identity-hashcode ;
+
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
GENERIC: >expr ( insn -- expr )
<<
: 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 ;
M: ##xor-vector rewrite
dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
[ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
+
+: vector-not? ( expr -- ? )
+ {
+ [ not-vector-expr? ]
+ [ {
+ [ xor-vector-expr? ]
+ [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+ } 1&& ]
+ } 1|| ;
+
+GENERIC: vector-not-src ( expr -- vreg )
+M: not-vector-expr vector-not-src src>> vn>vreg ;
+M: xor-vector-expr vector-not-src
+ dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+
+M: ##and-vector rewrite
+ {
+ { [ dup src1>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ { [ dup src2>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src2>> vreg>expr vector-not-src ]
+ [ src1>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ [ drop f ]
+ } cond ;
+
+M: ##andn-vector rewrite
+ dup src1>> vreg>expr vector-not? [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##and-vector new-insn
+ ] [ drop f ] if ;
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 ] }
}
] [
{
} value-numbering-step
] unit-test
+! NOT x AND y => x ANDN y
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! x AND NOT y => y ANDN x
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 1 4 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 1 4 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! NOT x ANDN y => x AND y
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 0 1 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 4 1 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! AND <=> ANDN
+
+[
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ T{ ##and-vector f 6 0 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ }
+] [
+ {
+ T{ ##fill-vector f 3 float-4-rep }
+ T{ ##xor-vector f 4 0 3 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ T{ ##andn-vector f 6 4 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##andn-vector f 5 0 1 float-4-rep }
+ T{ ##and-vector f 6 0 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ }
+] [
+ {
+ T{ ##not-vector f 4 0 float-4-rep }
+ T{ ##and-vector f 5 4 1 float-4-rep }
+ T{ ##andn-vector f 6 4 2 float-4-rep }
+ T{ ##or-vector f 7 5 6 float-4-rep }
+ } value-numbering-step
+] unit-test
+
+! branch folding
+
: test-branch-folding ( insns -- insns' n )
<basic-block>
[ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
{
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
GENERIC: no-compile? ( word -- ? )
-M: word no-compile? "no-compile" word-prop ;
-
M: method-body no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
+M: word no-compile?
+ { [ 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'.
- [
- {
- [ macro? ]
- [ inline? ]
- [ no-compile? ]
- [ "special" word-prop ]
- } 1||
- ] [
- {
- [ 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" ] }
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result )
- "int" { } "cdecl" alien-indirect ;
+ int { } "cdecl" alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
- "int" { } "cdecl" alien-indirect drop ;
+ int { } "cdecl" alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
- "int" { "int" "int" } "cdecl" alien-indirect gc ;
+ int { int int } "cdecl" alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
unit-test
: indirect-test-3 ( a b c d ptr -- result )
- "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+ int { int int int int } "stdcall" alien-indirect
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
- "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+ int "f-stdcall" "ffi_test_18" { int int int int }
alien-invoke gc ;
[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
: ffi_test_19 ( x y z -- BAR )
- "BAR" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+ BAR "f-stdcall" "ffi_test_19" { long long long }
alien-invoke gc ;
[ 11 6 -7 ] [
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
- "int"
+ int
"f-cdecl" "ffi_test_31"
- { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+ { int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int int }
alien-invoke gc 3 ;
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
- "float"
+ float
"f-cdecl" "ffi_test_31_point_5"
- { "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
+ { float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float float }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
! Test callbacks
-: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> ] [ out>> ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
[ t ] [
namestack*
] unit-test
: callback-4 ( -- callback )
- "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ void { } "cdecl" [ "Hello world" write ] alien-callback
gc ;
[ "Hello world" ] [
] unit-test
: callback-5 ( -- callback )
- "void" { } "cdecl" [ gc ] alien-callback ;
+ void { } "cdecl" [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5b ( -- callback )
- "void" { } "cdecl" [ compact-gc ] alien-callback ;
+ void { } "cdecl" [ compact-gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5b callback_test_1
] unit-test
: callback-6 ( -- callback )
- "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+ void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
- "void" { } "cdecl" [ 1000000 sleep ] alien-callback ;
+ void { } "cdecl" [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
- "void" { } "cdecl" [
+ void { } "cdecl" [
[ continue ] callcc0
] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback )
- "int" { "int" "int" "int" } "cdecl" [
+ int { int int int } "cdecl" [
+ + 1 +
] alien-callback ;
} cleave ;
: double-rect-callback ( -- alien )
- "void" { "void*" "void*" "double-rect" } "cdecl"
+ void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
- "void" { "void*" "void*" "double-rect" } "cdecl" alien-indirect
+ void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
] unit-test
: callback-10 ( -- callback )
- "test_struct_14" { "double" "double" } "cdecl"
+ test_struct_14 { double double } "cdecl"
[
test_struct_14 <struct>
swap >>x2
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
- "test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
+ test_struct_14 { double double } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
] unit-test
: callback-11 ( -- callback )
- "test-struct-12" { "int" "double" } "cdecl"
+ test-struct-12 { int double } "cdecl"
[
test-struct-12 <struct>
swap >>x
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
- "test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
+ test-struct-12 { int double } "cdecl" alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
- "test_struct_15" { "float" "float" } "cdecl"
+ test_struct_15 { float float } "cdecl"
[
test_struct_15 <struct>
swap >>y
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
- "test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
+ test_struct_15 { float float } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
- "test_struct_16" { "float" "int" } "cdecl"
+ test_struct_16 { float int } "cdecl"
[
test_struct_16 <struct>
swap >>a
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
- "test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
+ test_struct_16 { float int } "cdecl" alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
! 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
{ float } declare dup 0 =
[ drop 1 ] [
dup 0 >=
- [ 2 "double" "libm" "pow" { "double" "double" } alien-invoke ]
- [ -0.5 "double" "libm" "pow" { "double" "double" } alien-invoke ]
+ [ 2 double "libm" "pow" { double double } alien-invoke ]
+ [ -0.5 double "libm" "pow" { double double } alien-invoke ]
if
] if ;
[ 2 0 ] [
1 1
[ [ HEX: f bitand ] bi@ [ shift ] [ drop -3 shift ] 2bi ] compile-call
-] unit-test
\ No newline at end of file
+] unit-test
[ 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
swap [
{ tuple } declare 1 slot
] [
- 0 slot
+ 1 slot
] if ;
-[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+[ 0 ] [ f { } mutable-value-bug-1 ] unit-test
: mutable-value-bug-2 ( a b -- c )
swap [
- 0 slot
+ 1 slot
] [
{ tuple } declare 1 slot
] if ;
-[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
+[ 0 ] [ t { } mutable-value-bug-2 ] 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
[ -1 ] [ 3 4 0 dispatch-branch-problem ] unit-test
[ 12 ] [ 3 4 1 dispatch-branch-problem ] unit-test
+[ 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
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
-arrays memory vocabs parser eval ;
+arrays memory vocabs parser eval quotations compiler.errors
+definitions ;
IN: compiler.tests.simple
! Test empty word
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test
] times
+
+! This should not compile
+GENERIC: bad-effect-test ( a -- )
+M: quotation bad-effect-test call ; inline
+: bad-effect-test* ( -- ) [ 1 2 3 ] bad-effect-test ;
+
+[ bad-effect-test* ] [ not-compiled? ] must-fail-with
+
+! Don't want compiler error to stick around
+[ ] [ [ M\ quotation bad-effect-test forget ] with-compilation-unit ] 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*
{
constraints get last update-constraints ;
: branch-phi-constraints ( output values booleans -- )
- {
+ {
{
{ { t } { f } }
[
swap t-->
]
}
+ {
+ { { t f } { t } }
+ [
+ first =f
+ condition-value get =t /\
+ swap f-->
+ ]
+ }
+ {
+ { { t } { t f } }
+ [
+ second =f
+ condition-value get =f /\
+ swap f-->
+ ]
+ }
{
{ { t f } { } }
[
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
-compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences
+eval combinators ;
IN: compiler.tree.propagation.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
! [ boa ] by itself doesn't infer
TUPLE: a-tuple x ;
-[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
\ No newline at end of file
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
+
+! See if redefinitions are handled correctly
+: call(-redefine-test ( a -- b ) 1 + ;
+
+: test-quotatation ( -- quot ) [ call(-redefine-test ] ;
+
+[ t ] [ test-quotatation cached-effect (( a -- b )) effect<= ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a b -- c ) + ;" eval( -- ) ] unit-test
+
+[ t ] [ test-quotatation cached-effect (( a b -- c )) effect<= ] unit-test
+
+: inline-cache-invalidation-test ( a b c -- c ) call( a b -- c ) ;
+
+[ 4 ] [ 1 3 test-quotatation inline-cache-invalidation-test ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
+
+[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
-words math stack-checker stack-checker.transforms
-compiler.tree.propagation.info
-compiler.tree.propagation.inlining ;
+words math stack-checker combinators.short-circuit
+stack-checker.transforms compiler.tree.propagation.info
+compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
! and compare it with declaration. If matches, call it unsafely.
! - Fallback. If the above doesn't work, call it and compare the datastack before
! and after to make sure it didn't mess anything up.
+! - Inline caches and cached effects are invalidated whenever a macro is redefined, or
+! a word's effect changes, by comparing a global counter against the counter value
+! last observed. The counter is incremented by compiler.units.
! execute( uses a similar strategy.
-TUPLE: inline-cache value ;
+TUPLE: inline-cache value counter ;
-: cache-hit? ( word/quot ic -- ? )
- [ value>> eq? ] [ value>> ] bi and ; inline
+: inline-cache-hit? ( word/quot ic -- ? )
+ { [ value>> eq? ] [ nip counter>> effect-counter eq? ] } 2&& ; inline
+
+: update-inline-cache ( word/quot ic -- )
+ [ effect-counter ] dip
+ [ (>>value) ] [ (>>counter) ] bi-curry bi* ; inline
SINGLETON: +unknown+
: safe-infer ( quot -- effect )
[ infer ] [ 2drop +unknown+ ] recover ;
+: cached-effect-valid? ( quot -- ? )
+ cache-counter>> effect-counter eq? ; inline
+
+: save-effect ( effect quot -- )
+ [ effect-counter ] dip
+ [ (>>cached-effect) ] [ (>>cache-counter) ] bi-curry bi* ;
+
M: quotation cached-effect
- dup cached-effect>>
- [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
+ dup cached-effect-valid?
+ [ cached-effect>> ] [ [ safe-infer dup ] keep save-effect ] if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
: call-effect-fast ( quot effect inline-cache -- )
2over call-effect-unsafe?
- [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
+ [ [ nip update-inline-cache ] [ drop call-effect-unsafe ] 3bi ]
[ drop call-effect-slow ]
if ; inline
: call-effect-ic ( quot effect inline-cache -- )
- 3dup nip cache-hit?
+ 3dup nip inline-cache-hit?
[ drop call-effect-unsafe ]
[ call-effect-fast ]
if ; inline
: execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe?
- [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+ [ [ nip update-inline-cache ] [ drop execute-effect-unsafe ] 3bi ]
[ drop execute-effect-slow ]
if ; inline
: execute-effect-ic ( word effect inline-cache -- )
- 3dup nip cache-hit?
+ 3dup nip inline-cache-hit?
[ drop execute-effect-unsafe ]
[ execute-effect-fast ]
if ; inline
bi ;
M: true-constraint satisfied?
- value>> value-info class>>
- { [ true-class? ] [ null-class? not ] } 1&& ;
+ value>> value-info*
+ [ class>> true-class? ] [ drop f ] if ;
TUPLE: false-constraint value ;
bi ;
M: false-constraint satisfied?
- value>> value-info class>>
- { [ false-class? ] [ null-class? not ] } 1&& ;
+ value>> value-info*
+ [ class>> false-class? ] [ drop f ] if ;
! Class constraints
TUPLE: class-constraint value class ;
! Assoc stack of current value --> info mapping
SYMBOL: value-infos
+: value-info* ( value -- info ? )
+ resolve-copy value-infos get assoc-stack [ null-info or ] [ >boolean ] bi ; inline
+
: value-info ( value -- info )
- resolve-copy value-infos get assoc-stack null-info or ;
+ value-info* drop ;
: set-value-info ( info value -- )
resolve-copy value-infos get last set-at ;
! 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
'[ _ _ 2bi ] "outputs" set-word-prop
] each
-\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
-\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+: shift-op-class ( info1 info2 -- newclass )
+ [ class>> ] bi@
+ 2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
+
+: shift-op ( word interval-quot post-proc-quot -- )
+ '[
+ [ shift-op-class ] [ _ binary-op-interval ] 2bi
+ @
+ <class/interval-info>
+ ] "outputs" set-word-prop ;
+
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
\ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
\ 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 ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
+[ V{ fixnum } ] [
+ [
+ [ { fixnum } declare ] [ drop f ] if
+ dup [ dup 13 eq? [ t ] [ f ] if ] [ t ] if
+ [ "Oops" throw ] when
+ ] final-classes
+] unit-test
+
[ V{ fixnum } ] [
[
>fixnum
] final-classes
] unit-test
+[ ] [
+ [
+ dup dup dup [ 100 < ] [ drop f ] if dup
+ [ 2drop f ] [ 2drop f ] if
+ [ ] [ dup [ ] [ ] if ] if
+ ] final-info drop
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare (clone) ] final-classes
] unit-test
[ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ { fixnum fixnum } declare 7 bitand neg >bignum shift ] final-classes
+] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare 1 swap 7 bitand shift ] final-classes
] unit-test
+[ V{ fixnum } ] [
+ [ { fixnum } declare 1 swap 7 bitand >bignum shift ] final-classes
+] unit-test
+
cell-bits 32 = [
[ V{ integer } ] [
[ { fixnum } declare 1 swap 31 bitand shift ]
[ 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
[ t ] [ [ void* <c-direct-array> ] { <c-direct-array> } inlined? ] unit-test
[ V{ void*-array } ] [ [ void* <c-direct-array> ] final-classes ] unit-test
+! bitand identities
[ t ] [ [ alien-unsigned-1 255 bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ alien-unsigned-1 255 swap bitand ] { bitand fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 256 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ t ] [ [ { fixnum } declare 250 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
[ f ] [ [ { fixnum } declare 257 rem -256 bitand ] { fixnum-bitand } inlined? ] unit-test
+
+[ V{ fixnum } ] [ [ >bignum 10 mod 2^ ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ >bignum 10 mod ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum bitand ] final-classes ] unit-test
+[ V{ bignum } ] [ [ { fixnum } declare -1 >bignum swap bitand ] final-classes ] unit-test
+
+! Could be bignum not integer but who cares
+[ V{ integer } ] [ [ 10 >bignum bitand ] final-classes ] unit-test
+
] 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
+sets combinators.short-circuit sequences.private locals growable
stack-checker namespaces compiler.tree.propagation.info ;
IN: compiler.tree.propagation.transforms
: positive-fixnum? ( obj -- ? )
{ [ fixnum? ] [ 0 >= ] } 1&& ;
-: simplify-bitand? ( value -- ? )
- value-info literal>> positive-fixnum? ;
+: simplify-bitand? ( value1 value2 -- ? )
+ [ literal>> positive-fixnum? ]
+ [ class>> fixnum swap class<= ]
+ bi* and ;
-: all-ones? ( int -- ? )
- dup 1 + bitand zero? ; inline
+: all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
-: redundant-bitand? ( var 111... -- ? )
- [ value-info ] bi@ [ interval>> ] [ literal>> ] bi* {
+: redundant-bitand? ( value1 value2 -- ? )
+ [ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip all-ones? ]
[ 0 swap [a,b] interval-subset? ]
} 2&& ;
-: (zero-bitand?) ( value-info value-info' -- ? )
+: zero-bitand? ( value1 value2 -- ? )
[ interval>> ] [ literal>> ] bi* {
[ nip integer? ]
[ nip bitnot all-ones? ]
[ 0 swap bitnot [a,b] interval-subset? ]
} 2&& ;
-: zero-bitand? ( var1 var2 -- ? )
- [ value-info ] bi@
- { [ (zero-bitand?) ] [ swap (zero-bitand?) ] } 2|| ;
-
{
bitand-integer-integer
bitand-integer-fixnum
bitand
} [
[
- {
+ in-d>> first2 [ value-info ] bi@ {
{
- [ dup in-d>> first2 zero-bitand? ]
- [ drop [ 2drop 0 ] ]
+ [ 2dup zero-bitand? ]
+ [ 2drop [ 2drop 0 ] ]
}
{
- [ dup in-d>> first2 redundant-bitand? ]
- [ drop [ drop ] ]
+ [ 2dup swap zero-bitand? ]
+ [ 2drop [ 2drop 0 ] ]
}
{
- [ dup in-d>> first2 swap redundant-bitand? ]
- [ drop [ nip ] ]
+ [ 2dup redundant-bitand? ]
+ [ 2drop [ drop ] ]
}
{
- [ dup in-d>> first simplify-bitand? ]
- [ drop [ >fixnum fixnum-bitand ] ]
+ [ 2dup swap redundant-bitand? ]
+ [ 2drop [ nip ] ]
}
{
- [ dup in-d>> second simplify-bitand? ]
- [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
+ [ 2dup simplify-bitand? ]
+ [ 2drop [ >fixnum fixnum-bitand ] ]
}
- [ drop f ]
+ {
+ [ 2dup swap simplify-bitand? ]
+ [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
+ }
+ [ 2drop f ]
} cond
] "custom-inlining" set-word-prop
] each
! Speeds up 2^
+: 2^? ( #call -- ? )
+ in-d>> first2 [ value-info ] bi@
+ [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
+ [ class>> fixnum class<= ]
+ bi* and ;
+
\ shift [
- in-d>> first value-info literal>> 1 = [
+ 2^? [
cell-bits tag-bits get - 1 -
'[
>fixnum dup 0 < [ 2drop 0 ] [
] [ 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
+
+! Speeds up sum-file, sort and reverse-complement benchmarks by
+! compiling decoder-readln better
+\ push [
+ in-d>> second value-info class>> growable class<=
+ [ \ push def>> ] [ f ] if
+] "custom-inlining" set-word-prop
TUPLE: node < identity-tuple ;
-M: node hashcode* drop node hashcode* ;
-
TUPLE: #introduce < node out-d ;
: #introduce ( out-d -- node )
: 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
{ $description "Put the object into the mailbox. Any threads that have a blocking get on the mailbox are resumed. Only one of those threads will successfully get the object, the rest will immediately block waiting for the next item in the mailbox." } ;\r
\r
HELP: block-unless-pred\r
-{ $values { "pred" { $quotation "( obj -- ? )" } } \r
+{ $values\r
{ "mailbox" mailbox }\r
{ "timeout" "a " { $link duration } " or " { $link f } }\r
+ { "pred" { $quotation "( obj -- ? )" } } \r
}\r
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack." } ;\r
\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 )
{ release void* }
{ copyDescription void* } ;
-! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
-TYPEDEF: void* FSEventStreamCallback
+! callback(
+CALLBACK: void FSEventStreamCallback ( FSEventStreamRef streamRef, void* clientCallBackInfo, size_t numEvents, void* eventPaths, FSEventStreamEventFlags* eventFlags, FSEventStreamEventId* eventIds ) ;
CONSTANT: FSEventStreamEventIdSinceNow HEX: FFFFFFFFFFFFFFFF
[ fds>> [ enable-all-callbacks ] each ] bi ;
: timer-callback ( -- callback )
- "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
+ void { CFRunLoopTimerRef void* } "cdecl"
[ 2drop reset-run-loop yield ] alien-callback ;
: init-thread-timer ( -- )
! 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 1 SRAWI\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
\r
[\r
3 ds-reg 0 LWZ\r
- 3 3 1 SRAWI\r
+ 3 3 2 SRAWI\r
rs-reg 3 3 LWZX\r
3 ds-reg 0 STW\r
] \ get-local define-sub-primitive\r
[\r
3 ds-reg 0 LWZ\r
ds-reg ds-reg 4 SUBI\r
- 3 3 1 SRAWI\r
+ 3 3 2 SRAWI\r
rs-reg 3 rs-reg SUBF\r
] \ drop-locals define-sub-primitive\r
\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
alien.c-types cpu.architecture cpu.ppc ;
IN: cpu.ppc.macosx
-<<
-4 "longlong" c-type (>>align)
-4 "ulonglong" c-type (>>align)
-4 "double" c-type (>>align)
->>
-
M: macosx reserved-area-size 6 cells ;
M: macosx lr-save 2 cells ;
M: ppc %unbox-alien ( dst src -- )
alien-offset LWZ ;
-M:: ppc %unbox-any-c-ptr ( dst src temp -- )
+M:: ppc %unbox-any-c-ptr ( dst src -- )
[
- { "is-byte-array" "end" "start" } [ define-label ] each
- ! Address is computed in dst
+ "end" define-label
0 dst LI
- ! Load object into scratch-reg
- scratch-reg src MR
- ! We come back here with displaced aliens
- "start" resolve-label
! Is the object f?
- 0 scratch-reg \ f tag-number CMPI
- ! If so, done
+ 0 src \ f type-number CMPI
"end" get BEQ
+ ! Compute tag in dst register
+ dst src tag-mask get ANDI
! Is the object an alien?
- 0 scratch-reg header-offset LWZ
- 0 0 alien type-number tag-fixnum CMPI
- "is-byte-array" get BNE
- ! If so, load the offset
- 0 scratch-reg alien-offset LWZ
- ! Add it to address being computed
- dst dst 0 ADD
- ! Now recurse on the underlying alien
- scratch-reg scratch-reg underlying-alien-offset LWZ
- "start" get B
- "is-byte-array" resolve-label
- ! Add byte array address to address being computed
- dst dst scratch-reg ADD
- ! Add an offset to start of byte array's data area
- dst dst byte-array-offset ADDI
+ 0 dst alien type-number CMPI
+ ! Add an offset to start of byte array's data
+ dst src byte-array-offset ADDI
+ "end" get BNE
+ ! If so, load the offset and add it to the address
+ dst src alien-offset LWZ
"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 \ f type-number %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
+ src dst 3 alien@ STW
+ src dst 4 alien@ STW
"f" resolve-label
] with-scope ;
-M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
+M:: ppc %box-displaced-alien ( dst displacement base temp base-class -- )
+ ! This is ridiculous
[
"end" define-label
- "alloc" define-label
- "simple-case" define-label
+ "not-f" define-label
+ "not-alien" define-label
+
! If displacement is zero, return the base
dst base MR
0 displacement 0 CMPI
"end" get BEQ
- ! Quickly use displacement' before its needed for real, as allot temporary
- displacement' :> temp
- dst 4 cells alien temp %allot
- ! If base is already a displaced alien, unpack it
- 0 base \ f tag-number CMPI
- "simple-case" get BEQ
- temp base header-offset LWZ
- 0 temp alien type-number tag-fixnum CMPI
- "simple-case" get BNE
- ! displacement += base.displacement
- temp base 3 alien@ LWZ
- displacement' displacement temp ADD
- ! base = base.base
- base' base 1 alien@ LWZ
- "alloc" get B
- "simple-case" resolve-label
- displacement' displacement MR
- base' base MR
- "alloc" resolve-label
- ! Store underlying-alien slot
- base' dst 1 alien@ STW
- ! Store offset
- displacement' dst 3 alien@ STW
- ! Store expired slot (its ok to clobber displacement')
- temp \ f tag-number %load-immediate
+
+ ! Displacement is non-zero, we're going to be allocating a new
+ ! object
+ dst 5 cells alien temp %allot
+
+ ! Set expired to f
+ temp \ f type-number %load-immediate
temp dst 2 alien@ STW
+
+ ! Is base f?
+ 0 base \ f type-number CMPI
+ "not-f" get BNE
+
+ ! Yes, it is f. Fill in new object
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ displacement dst 4 alien@ STW
+
+ "end" get B
+
+ "not-f" resolve-label
+
+ ! Check base type
+ temp base tag-mask get ANDI
+
+ ! Is base an alien?
+ 0 temp alien type-number CMPI
+ "not-alien" get BNE
+
+ ! Yes, it is an alien. Set new alien's base to base.base
+ temp base 1 alien@ LWZ
+ temp dst 1 alien@ STW
+
+ ! Compute displacement
+ temp base 3 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 3 alien@ STW
+
+ ! Compute address
+ temp base 4 alien@ LWZ
+ temp temp displacement ADD
+ temp dst 4 alien@ STW
+
+ ! We are done
+ "end" get B
+
+ ! Is base a byte array? It has to be, by now...
+ "not-alien" resolve-label
+
+ base dst 1 alien@ STW
+ displacement dst 3 alien@ STW
+ temp base byte-array-offset ADDI
+ temp temp displacement ADD
+ temp dst 4 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 -- )
- class type-number tag-fixnum scratch-reg LI
+ class type-number tag-header scratch-reg LI
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 ;
+ [ [] ] [ type-number tag-header ] 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 ;
{
{ sse? { float-4-rep } }
{ sse2? { double-2-rep char-16-rep short-8-rep int-4-rep } }
- { sse4.1? { longlong-2-rep } }
+ { sse4.2? { longlong-2-rep } }
} available-reps ;
M: x86 %compare-vector-reps
{
- { [ dup { 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 ;
M: x86 %min-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
M: x86 %max-vector-reps
{
{ sse? { float-4-rep } }
- { sse2? { uchar-16-rep short-8-rep double-2-rep short-8-rep uchar-16-rep } }
+ { sse2? { uchar-16-rep short-8-rep double-2-rep } }
{ sse4.1? { char-16-rep ushort-8-rep int-4-rep uint-4-rep } }
} available-reps ;
{ 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" } } ]
[
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
-TYPEDEF: void sqlite3
-TYPEDEF: void sqlite3_stmt
+TYPEDEF: void* sqlite3*
+TYPEDEF: void* sqlite3_stmt*
TYPEDEF: longlong sqlite3_int64
TYPEDEF: ulonglong sqlite3_uint64
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-bind-uint64 ( pStmt index in64 -- int )
- "int" "sqlite" "sqlite3_bind_int64"
- { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
+ int "sqlite" "sqlite3_bind_int64"
+ { sqlite3_stmt* int sqlite3_uint64 } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
! Bind the same function as above, but for unsigned 64bit integers
: sqlite3-column-uint64 ( pStmt col -- uint64 )
- "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
- { "sqlite3_stmt*" "int" } alien-invoke ;
+ sqlite3_uint64 "sqlite" "sqlite3_column_int64"
+ { sqlite3_stmt* int } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
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." } ;
compiler.units generic.standard generic.single vocabs init
kernel.private io.encodings accessors math.order destructors
source-files parser classes.tuple.parser effects.parser lexer
-generic.parser strings.parser vocabs.loader vocabs.parser see
+generic.parser strings.parser vocabs.loader vocabs.parser
source-files.errors ;
IN: debugger
-GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
-M: object error. . ;
-
M: object error-help drop f ;
M: tuple error-help class ;
+M: source-file-error error-help error>> error-help ;
+
+GENERIC: error. ( 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" ;
M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
+
{
{ [ os windows? ] [ "debugger.windows" require ] }
{ [ os unix? ] [ "debugger.unix" require ] }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger io prettyprint sequences system ;
+USING: assocs debugger io kernel literals math.parser namespaces
+prettyprint sequences system windows.kernel32 ;
IN: debugger.windows
-M: windows signal-error. "Windows exception #" write third .h ;
\ No newline at end of file
+CONSTANT: seh-names
+ H{
+ { $ STATUS_GUARD_PAGE_VIOLATION "STATUS_GUARD_PAGE_VIOLATION" }
+ { $ STATUS_DATATYPE_MISALIGNMENT "STATUS_DATATYPE_MISALIGNMENT" }
+ { $ STATUS_BREAKPOINT "STATUS_BREAKPOINT" }
+ { $ STATUS_SINGLE_STEP "STATUS_SINGLE_STEP" }
+ { $ STATUS_ACCESS_VIOLATION "STATUS_ACCESS_VIOLATION" }
+ { $ STATUS_IN_PAGE_ERROR "STATUS_IN_PAGE_ERROR" }
+ { $ STATUS_INVALID_HANDLE "STATUS_INVALID_HANDLE" }
+ { $ STATUS_NO_MEMORY "STATUS_NO_MEMORY" }
+ { $ STATUS_ILLEGAL_INSTRUCTION "STATUS_ILLEGAL_INSTRUCTION" }
+ { $ STATUS_NONCONTINUABLE_EXCEPTION "STATUS_NONCONTINUABLE_EXCEPTION" }
+ { $ STATUS_INVALID_DISPOSITION "STATUS_INVALID_DISPOSITION" }
+ { $ STATUS_ARRAY_BOUNDS_EXCEEDED "STATUS_ARRAY_BOUNDS_EXCEEDED" }
+ { $ STATUS_FLOAT_DENORMAL_OPERAND "STATUS_FLOAT_DENORMAL_OPERAND" }
+ { $ STATUS_FLOAT_DIVIDE_BY_ZERO "STATUS_FLOAT_DIVIDE_BY_ZERO" }
+ { $ STATUS_FLOAT_INEXACT_RESULT "STATUS_FLOAT_INEXACT_RESULT" }
+ { $ STATUS_FLOAT_INVALID_OPERATION "STATUS_FLOAT_INVALID_OPERATION" }
+ { $ STATUS_FLOAT_OVERFLOW "STATUS_FLOAT_OVERFLOW" }
+ { $ STATUS_FLOAT_STACK_CHECK "STATUS_FLOAT_STACK_CHECK" }
+ { $ STATUS_FLOAT_UNDERFLOW "STATUS_FLOAT_UNDERFLOW" }
+ { $ STATUS_INTEGER_DIVIDE_BY_ZERO "STATUS_INTEGER_DIVIDE_BY_ZERO" }
+ { $ STATUS_INTEGER_OVERFLOW "STATUS_INTEGER_OVERFLOW" }
+ { $ STATUS_PRIVILEGED_INSTRUCTION "STATUS_PRIVILEGED_INSTRUCTION" }
+ { $ STATUS_STACK_OVERFLOW "STATUS_STACK_OVERFLOW" }
+ { $ STATUS_CONTROL_C_EXIT "STATUS_CONTROL_C_EXIT" }
+ { $ STATUS_FLOAT_MULTIPLE_FAULTS "STATUS_FLOAT_MULTIPLE_FAULTS" }
+ { $ STATUS_FLOAT_MULTIPLE_TRAPS "STATUS_FLOAT_MULTIPLE_TRAPS" }
+ }
+
+: seh-name. ( n -- )
+ seh-names at [ " (" ")" surround write ] when* ;
+
+M: windows signal-error.
+ "Windows exception 0x" write
+ third [ >hex write ] [ seh-name. ] bi nl ;
IN: delegate
HELP: define-protocol
-{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
+{ $values { "protocol" "a word for the new protocol" } { "wordlist" "a sequence of words" } }
{ $description "Defines a symbol as a protocol." }
{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
{ $description "Adds an integer to the line number of a line/column pair." } ;
HELP: =col
-{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
+{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the column number of a line/column pair." } ;
HELP: =line
-{ $values { "loc" "a pair of integers" } { "n" integer } { "newloc" "a pair of integers" } }
+{ $values { "n" integer } { "loc" "a pair of integers" } { "newloc" "a pair of integers" } }
{ $description "Sets the line number of a line/column pair." } ;
HELP: lines-equal?
: 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 -- )
'[
USING: accessors assocs byte-arrays calendar classes
combinators combinators.short-circuit concurrency.promises
continuations destructors ftp io io.backend io.directories
-io.encodings io.encodings.8-bit io.encodings.binary
+io.encodings io.encodings.binary
tools.files io.encodings.utf8 io.files io.files.info
io.pathnames io.launcher.unix.parser io.servers.connection
io.sockets io.streams.duplex io.streams.string io.timeouts
kernel make math math.bitwise math.parser namespaces sequences
splitting threads unicode.case logging calendar.format
-strings io.files.links io.files.types ;
+strings io.files.links io.files.types io.encodings.8-bit.latin1 ;
IN: ftp.server
SYMBOL: server
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 )
{ $class-description "The class of authentication realms. See " { $link "furnace.auth.realms" } " for details." } ;
HELP: uchange
-{ $values { "key" symbol } { "quot" { $quotation "( old -- new )" } } }
+{ $values { "quot" { $quotation "( old -- new )" } } { "key" symbol } }
{ $description "Applies the quotation to the old value of the user profile variable, and assigns the resulting value back to the variable." } ;
HELP: uget
! 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
{ $description "Curries the " { $snippet "n" } " quotations on the top of the datastack with the " { $snippet "n" } " values just below them. A generalization of " { $link bi-curry* } " and " { $link tri-curry* } "." }\r
{ $notes "This word can be used with " { $link cleave* } " and " { $link spread* } " to generalize dataflow patterns such as " { $snippet "bi-curry* bi" } ", " { $snippet "tri-curry* tri" } ", " { $snippet "bi-curry* bi*" } ", and " { $snippet "tri-curry* tri*" } "." } ;\r
\r
-HELP: neach\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }\r
-{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;\r
-\r
-HELP: nmap\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }\r
-{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;\r
-\r
-HELP: nmap-as\r
-{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }\r
-{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;\r
-\r
-HELP: mnmap\r
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }\r
-{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;\r
-\r
-HELP: mnmap-as\r
-{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the " { $snippet "exemplar" } "s" } }\r
-{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;\r
-\r
HELP: mnswap\r
{ $values { "m" integer } { "n" integer } }\r
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\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
apply-curry\r
cleave-curry\r
spread-curry\r
- neach\r
- nmap\r
- nmap-as\r
- mnmap\r
- mnmap-as\r
} ;\r
\r
ARTICLE: "other-generalizations" "Additional generalizations"\r
"shuffle-generalizations"\r
"combinator-generalizations"\r
"other-generalizations"\r
-} ;\r
+}\r
+"Also see the " { $vocab-link "sequences.generalizations" } " vocabulary for generalized sequence iteration combinators." ;\r
\r
ABOUT: "generalizations"\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
\r
[ '[ number>string _ append ] 4 napply ] must-infer\r
\r
-: neach-test ( a b c d -- )\r
- [ 4 nappend print ] 4 neach ;\r
-: nmap-test ( a b c d -- e )\r
- [ 4 nappend ] 4 nmap ;\r
-: nmap-as-test ( a b c d -- e )\r
- [ 4 nappend ] [ ] 4 nmap-as ;\r
-: mnmap-3-test ( a b c d -- e f g )\r
- [ append ] 4 3 mnmap ;\r
-: mnmap-2-test ( a b c d -- e f )\r
- [ [ append ] 2bi@ ] 4 2 mnmap ;\r
-: mnmap-as-test ( a b c d -- e f )\r
- [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;\r
-: mnmap-1-test ( a b c d -- e )\r
- [ 4 nappend ] 4 1 mnmap ;\r
-: mnmap-0-test ( a b c d -- )\r
- [ 4 nappend print ] 4 0 mnmap ;\r
-\r
-[ """A1a!\r
-B2b@\r
-C3c#\r
-D4d$\r
-""" ] [\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- [ neach-test ] with-string-writer\r
-] unit-test\r
-\r
-[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- nmap-test\r
-] unit-test\r
-\r
-[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- nmap-as-test\r
-] unit-test\r
-\r
-[\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a!" "b@" "c#" "d$" }\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-3-test\r
-] unit-test\r
-\r
-[\r
- { "A1" "B2" "C3" "D4" }\r
- { "a!" "b@" "c#" "d$" }\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-2-test\r
-] unit-test\r
-\r
-[\r
- { "A1" "B2" "C3" "D4" }\r
- [ "a!" "b@" "c#" "d$" ]\r
-] [ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-as-test\r
-] unit-test\r
-\r
-[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]\r
-[ \r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- mnmap-1-test\r
-] unit-test\r
-\r
-[ """A1a!\r
-B2b@\r
-C3c#\r
-D4d$\r
-""" ] [\r
- { "A" "B" "C" "D" }\r
- { "1" "2" "3" "4" }\r
- { "a" "b" "c" "d" }\r
- { "!" "@" "#" "$" }\r
- [ mnmap-0-test ] with-string-writer\r
-] unit-test\r
-\r
[ 6 8 10 12 ] [\r
1 2 3 4\r
5 6 7 8 [ + ] 4 apply-curry 4 spread*\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 ;
-
-MACRO: nmin-length ( n -- )
- dup 1 - [ min ] n*quot
- '[ [ length ] _ napply @ ] ;
-
-: nnth-unsafe ( n ...seq n -- )
- [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
-MACRO: nset-nth-unsafe ( n -- )
- [ [ drop ] ]
- [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
- if-zero ;
-
-: (neach) ( ...seq quot n -- len quot' )
- dup dup dup
- '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
-
-: neach ( ...seq quot n -- )
- (neach) each-integer ; inline
-
-: nmap-as ( ...seq quot exemplar n -- result )
- '[ _ (neach) ] dip map-integers ; inline
-
-: nmap ( ...seq quot n -- result )
- dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
-
-MACRO: nnew-sequence ( n -- )
- [ [ drop ] ]
- [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
-
-: nnew-like ( len ...exemplar quot n -- result... )
- dup dup dup dup '[
- _ nover
- [ [ _ nnew-sequence ] dip call ]
- _ ndip [ like ]
- _ apply-curry
- _ spread*
- ] call ; inline
-
-MACRO: (ncollect) ( n -- )
- dup dup 1 +
- '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
-
-: ncollect ( len quot ...into n -- )
- (ncollect) each-integer ; inline
-
-: nmap-integers ( len quot ...exemplar n -- result... )
- dup dup dup
- '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
-
-: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
- dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
-
-: mnmap ( m*seq quot m n -- result*n )
- 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
-
{ $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
USING: grouping tools.test kernel sequences arrays
-math ;
+math accessors ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
>array
] unit-test
+[ 0 ] [ { } 2 <clumps> length ] unit-test
+[ 0 ] [ { 1 } 2 <clumps> length ] unit-test
+[ 1 ] [ { 1 2 } 2 <clumps> length ] unit-test
+[ 2 ] [ { 1 2 3 } 2 <clumps> length ] unit-test
+
+[ 1 ] [ V{ } 2 <clumps> 0 over set-length seq>> length ] unit-test
+[ 2 ] [ V{ } 2 <clumps> 1 over set-length seq>> length ] unit-test
+[ 3 ] [ V{ } 2 <clumps> 2 over set-length seq>> length ] unit-test
+
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 <sliced-clumps> [ >array ] map ] unit-test
[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
TUPLE: abstract-clumps < chunking-seq ;
M: abstract-clumps length
- [ seq>> length ] [ n>> ] bi - 1 + ; inline
+ [ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps set-length
[ n>> + 1 - ] [ seq>> ] bi set-length ; inline
--- /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
+ 2 >>align-first
+ [ >float ] >>unboxer-quot
+\ half define-primitive-type
+
+>>
--- /dev/null
+Half-precision float support for FFI
{ $description "Create a new " { $link max-heap } "." } ;
HELP: heap-push
-{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
+{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } }
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
{ $side-effects "heap" } ;
HELP: heap-push*
-{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
+{ $values { "value" object } { "key" "a comparable object" } { "heap" "a heap" } { "entry" entry } }
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
{ $side-effects "heap" } ;
{ $side-effects "heap" } ;
HELP: heap-peek
-{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output the first element in the heap, leaving it in the heap." } ;
HELP: heap-pop*
{ $side-effects "heap" } ;
HELP: heap-pop
-{ $values { "heap" "a heap" } { "key" object } { "value" object } }
+{ $values { "heap" "a heap" } { "value" object } { "key" object } }
{ $description "Output and remove the first element in the heap." }
{ $side-effects "heap" } ;
INSTANCE: apropos topic
: apropos ( str -- )
- <apropos> print-topic ;
+ <apropos> print-topic nl ;
USING: help.crossref help.topics help.markup tools.test words
definitions assocs sequences kernel namespaces parser arrays
-io.streams.string continuations debugger compiler.units eval ;
+io.streams.string continuations debugger compiler.units eval
+help.syntax ;
IN: help.crossref.tests
[ ] [
] unit-test
[ "xxx" ] [ "yyy" article-parent ] unit-test
+
+ARTICLE: "crossref-test-1" "Crossref test 1"
+"Hello world" ;
+
+ARTICLE: "crossref-test-2" "Crossref test 2"
+{ $markup-example { $subsection "crossref-test-1" } } ;
+
+[ V{ } ] [ "crossref-test-2" >link article-children ] unit-test
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"
SYMBOL: help-hook
-help-hook [ [ print-topic ] ] initialize
+help-hook [ [ print-topic nl ] ] initialize
: help ( topic -- )
help-hook get call( topic -- ) ;
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"
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
- first rest [ first ] map prune natural-sort
+ first rest [ first ] map prune
] unless ;
: effect-values ( word -- seq )
stack-effect
[ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map
- prune natural-sort ;
+ [ dup pair? [ first ] when effect>string ] map prune ;
: 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
M: object elements* 2drop ;
M: array elements*
- [ [ elements* ] with each ] 2keep
- [ first eq? ] keep swap [ , ] [ drop ] if ;
+ [ dup first \ $markup-example eq? [ 2drop ] [ [ elements* ] with each ] if ]
+ [ [ first eq? ] keep swap [ , ] [ drop ] if ] 2bi ;
: elements ( elt-type element -- seq ) [ elements* ] { } make ;
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
-USING: help.vocabs tools.test help.markup help vocabs ;
+USING: help.vocabs tools.test help.markup help vocabs io ;
IN: help.vocabs.tests
[ ] [ { $vocab "scratchpad" } print-content ] unit-test
[ ] [ "classes" vocab print-topic ] unit-test
+[ ] [ nl ] unit-test
{ $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 )
USING: http help.markup help.syntax io.pathnames io.streams.string
-io.encodings.8-bit io.encodings.binary kernel urls
+io.encodings.binary kernel urls
urls.encoding byte-arrays strings assocs sequences destructors
-http.client.post-data.private ;
+http.client.post-data.private io.encodings.8-bit.latin1 ;
IN: http.client
HELP: download-failed
math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
-io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
+io.encodings.utf8 io.encodings.binary io.crlf
io.streams.duplex fry ascii urls urls.encoding present locals
http http.parsers http.client.post-data ;
IN: http.client
multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string io.encodings.ascii kernel
arrays splitting sequences assocs io.sockets db db.sqlite
-continuations urls hashtables accessors namespaces xml.data ;
+continuations urls hashtables accessors namespaces xml.data
+io.encodings.8-bit.latin1 ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
quotations arrays byte-arrays math.parser calendar
calendar.format present urls fry
io io.encodings io.encodings.iana io.encodings.binary
-io.encodings.8-bit io.crlf ascii
-http.parsers
-base64 ;
+io.crlf ascii io.encodings.8-bit.latin1 http.parsers base64 ;
IN: http
CONSTANT: max-redirects 10
[ 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
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays byte-arrays combinators
compression.run-length fry grouping images images.loader io
-io.binary io.encodings.8-bit io.encodings.binary
+io.binary io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
-sequences specialized-arrays summary images.bitmap ;
+io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAY: ushort
IN: images.bitmap.loading
! 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
USING: kernel arrays namespaces math accessors alien locals
destructors system threads io.backend.unix.multiplexers
io.backend.unix.multiplexers.kqueue core-foundation
-core-foundation.run-loop ;
+core-foundation.run-loop core-foundation.file-descriptors ;
+FROM: alien.c-types => void void* ;
IN: io.backend.unix.multiplexers.run-loop
TUPLE: run-loop-mx kqueue-mx ;
: file-descriptor-callback ( -- callback )
- "void" { "CFFileDescriptorRef" "CFOptionFlags" "void*" }
+ void { CFFileDescriptorRef CFOptionFlags void* }
"cdecl" [
3drop
0 mx get kqueue-mx>> wait-for-events
} 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 -- )
IN: io.encodings.8-bit
ARTICLE: "io.encodings.8-bit" "Legacy 8-bit encodings"
-"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
-{ $subsections
- latin1
- latin2
- latin3
- latin4
- latin/cyrillic
- latin/arabic
- latin/greek
- latin/hebrew
- latin5
- latin6
- latin/thai
- latin7
- latin8
- latin9
- latin10
- koi8-r
- windows-1252
- ebcdic
- mac-roman
+"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are available:"
+{ $list
+ { $vocab-link "io.encodings.8-bit.ebcdic" }
+ { $vocab-link "io.encodings.8-bit.latin1" }
+ { $vocab-link "io.encodings.8-bit.latin2" }
+ { $vocab-link "io.encodings.8-bit.latin3" }
+ { $vocab-link "io.encodings.8-bit.latin4" }
+ { $vocab-link "io.encodings.8-bit.cyrillic" }
+ { $vocab-link "io.encodings.8-bit.arabic" }
+ { $vocab-link "io.encodings.8-bit.greek" }
+ { $vocab-link "io.encodings.8-bit.hebrew" }
+ { $vocab-link "io.encodings.8-bit.latin5" }
+ { $vocab-link "io.encodings.8-bit.latin6" }
+ { $vocab-link "io.encodings.8-bit.thai" }
+ { $vocab-link "io.encodings.8-bit.latin7" }
+ { $vocab-link "io.encodings.8-bit.latin8" }
+ { $vocab-link "io.encodings.8-bit.latin9" }
+ { $vocab-link "io.encodings.8-bit.koi8-r" }
+ { $vocab-link "io.encodings.8-bit.mac-roman" }
+ { $vocab-link "io.encodings.8-bit.windows-1250" }
+ { $vocab-link "io.encodings.8-bit.windows-1251" }
+ { $vocab-link "io.encodings.8-bit.windows-1252" }
+ { $vocab-link "io.encodings.8-bit.windows-1253" }
+ { $vocab-link "io.encodings.8-bit.windows-1254" }
+ { $vocab-link "io.encodings.8-bit.windows-1255" }
+ { $vocab-link "io.encodings.8-bit.windows-1256" }
+ { $vocab-link "io.encodings.8-bit.windows-1257" }
+ { $vocab-link "io.encodings.8-bit.windows-1258" }
} ;
ABOUT: "io.encodings.8-bit"
-
-HELP: 8-bit
-{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
-
-HELP: latin1
-{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin2
-{ $description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin3
-{ $description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin4
-{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin/cyrillic
-{ $description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin/arabic
-{ $description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin/greek
-{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin/hebrew
-{ $description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin5
-{ $description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin6
-{ $description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin/thai
-{ $description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin7
-{ $description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necesary to represent Baltic Rim languages, as previous character sets were incomplete." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin8
-{ $description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin9
-{ $description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: latin10
-{ $description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: windows-1252
-{ $description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: ebcdic
-{ $description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: mac-roman
-{ $description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: koi8-r
-{ $description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." }
-{ $see-also "encodings-introduction" } ;
USING: io.encodings.string io.encodings.8-bit
-io.encodings.8-bit.private tools.test strings arrays ;
+io.encodings.8-bit.private tools.test strings arrays
+io.encodings.8-bit.latin1 io.encodings.8-bit.windows-1252 ;
IN: io.encodings.8-bit.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
-! Copyright (C) 2008 Daniel Ehrenberg
+! Copyright (C) 2008 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: math.parser arrays io.encodings sequences kernel assocs
hashtables io.encodings.ascii generic parser classes.tuple words
words.symbol io io.files splitting namespaces math
compiler.units accessors classes.singleton classes.mixin
-io.encodings.iana fry simple-flat-file ;
+io.encodings.iana fry simple-flat-file lexer ;
IN: io.encodings.8-bit
<PRIVATE
-CONSTANT: mappings {
- ! encoding-name iana-name file-name
- { "latin1" "ISO_8859-1:1987" "8859-1" }
- { "latin2" "ISO_8859-2:1987" "8859-2" }
- { "latin3" "ISO_8859-3:1988" "8859-3" }
- { "latin4" "ISO_8859-4:1988" "8859-4" }
- { "latin/cyrillic" "ISO_8859-5:1988" "8859-5" }
- { "latin/arabic" "ISO_8859-6:1987" "8859-6" }
- { "latin/greek" "ISO_8859-7:1987" "8859-7" }
- { "latin/hebrew" "ISO_8859-8:1988" "8859-8" }
- { "latin5" "ISO_8859-9:1989" "8859-9" }
- { "latin6" "ISO-8859-10" "8859-10" }
- { "latin/thai" "TIS-620" "8859-11" }
- { "latin7" "ISO-8859-13" "8859-13" }
- { "latin8" "ISO-8859-14" "8859-14" }
- { "latin9" "ISO-8859-15" "8859-15" }
- { "latin10" "ISO-8859-16" "8859-16" }
- { "koi8-r" "KOI8-R" "KOI8-R" }
- { "windows-1252" "windows-1252" "CP1252" }
- { "ebcdic" "IBM037" "CP037" }
- { "mac-roman" "macintosh" "ROMAN" }
-}
-
: encoding-file ( file-name -- stream )
"vocab:io/encodings/8-bit/" ".TXT" surround ;
SYMBOL: 8-bit-encodings
+8-bit-encodings [ H{ } clone ] initialize
TUPLE: 8-bit biassoc ;
8-bit-encodings get-global at <decoder> ;
: create-encoding ( name -- word )
- "io.encodings.8-bit" create
+ create-in
[ define-singleton-class ]
[ 8-bit-encoding add-mixin-instance ]
[ ] tri ;
+: load-encoding ( name iana-name file-name -- )
+ [ create-encoding dup ]
+ [ register-encoding ]
+ [ encoding-file flat-file>biassoc 8-bit boa ] tri*
+ swap 8-bit-encodings get-global set-at ;
+
PRIVATE>
-[
- mappings [
- first3
- [ create-encoding ]
- [ dupd register-encoding ]
- [ encoding-file flat-file>biassoc 8-bit boa ]
- tri*
- ] H{ } map>assoc
- 8-bit-encodings set-global
-] with-compilation-unit
+SYNTAX: 8-BIT: scan scan scan load-encoding ;
--- /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
--- /dev/null
+#
+# Name: cp1251 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 cp1251 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 cp1251 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 0x0402 #CYRILLIC CAPITAL LETTER DJE
+0x81 0x0403 #CYRILLIC CAPITAL LETTER GJE
+0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
+0x83 0x0453 #CYRILLIC SMALL LETTER GJE
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x20AC #EURO SIGN
+0x89 0x2030 #PER MILLE SIGN
+0x8A 0x0409 #CYRILLIC CAPITAL LETTER LJE
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x040A #CYRILLIC CAPITAL LETTER NJE
+0x8D 0x040C #CYRILLIC CAPITAL LETTER KJE
+0x8E 0x040B #CYRILLIC CAPITAL LETTER TSHE
+0x8F 0x040F #CYRILLIC CAPITAL LETTER DZHE
+0x90 0x0452 #CYRILLIC SMALL LETTER DJE
+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 0x0459 #CYRILLIC SMALL LETTER LJE
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x045A #CYRILLIC SMALL LETTER NJE
+0x9D 0x045C #CYRILLIC SMALL LETTER KJE
+0x9E 0x045B #CYRILLIC SMALL LETTER TSHE
+0x9F 0x045F #CYRILLIC SMALL LETTER DZHE
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x040E #CYRILLIC CAPITAL LETTER SHORT U
+0xA2 0x045E #CYRILLIC SMALL LETTER SHORT U
+0xA3 0x0408 #CYRILLIC CAPITAL LETTER JE
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x0490 #CYRILLIC CAPITAL LETTER GHE WITH UPTURN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x0401 #CYRILLIC CAPITAL LETTER IO
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x0404 #CYRILLIC CAPITAL LETTER UKRAINIAN IE
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x0407 #CYRILLIC CAPITAL LETTER YI
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x0406 #CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
+0xB3 0x0456 #CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I
+0xB4 0x0491 #CYRILLIC SMALL LETTER GHE WITH UPTURN
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x0451 #CYRILLIC SMALL LETTER IO
+0xB9 0x2116 #NUMERO SIGN
+0xBA 0x0454 #CYRILLIC SMALL LETTER UKRAINIAN IE
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x0458 #CYRILLIC SMALL LETTER JE
+0xBD 0x0405 #CYRILLIC CAPITAL LETTER DZE
+0xBE 0x0455 #CYRILLIC SMALL LETTER DZE
+0xBF 0x0457 #CYRILLIC SMALL LETTER YI
+0xC0 0x0410 #CYRILLIC CAPITAL LETTER A
+0xC1 0x0411 #CYRILLIC CAPITAL LETTER BE
+0xC2 0x0412 #CYRILLIC CAPITAL LETTER VE
+0xC3 0x0413 #CYRILLIC CAPITAL LETTER GHE
+0xC4 0x0414 #CYRILLIC CAPITAL LETTER DE
+0xC5 0x0415 #CYRILLIC CAPITAL LETTER IE
+0xC6 0x0416 #CYRILLIC CAPITAL LETTER ZHE
+0xC7 0x0417 #CYRILLIC CAPITAL LETTER ZE
+0xC8 0x0418 #CYRILLIC CAPITAL LETTER I
+0xC9 0x0419 #CYRILLIC CAPITAL LETTER SHORT I
+0xCA 0x041A #CYRILLIC CAPITAL LETTER KA
+0xCB 0x041B #CYRILLIC CAPITAL LETTER EL
+0xCC 0x041C #CYRILLIC CAPITAL LETTER EM
+0xCD 0x041D #CYRILLIC CAPITAL LETTER EN
+0xCE 0x041E #CYRILLIC CAPITAL LETTER O
+0xCF 0x041F #CYRILLIC CAPITAL LETTER PE
+0xD0 0x0420 #CYRILLIC CAPITAL LETTER ER
+0xD1 0x0421 #CYRILLIC CAPITAL LETTER ES
+0xD2 0x0422 #CYRILLIC CAPITAL LETTER TE
+0xD3 0x0423 #CYRILLIC CAPITAL LETTER U
+0xD4 0x0424 #CYRILLIC CAPITAL LETTER EF
+0xD5 0x0425 #CYRILLIC CAPITAL LETTER HA
+0xD6 0x0426 #CYRILLIC CAPITAL LETTER TSE
+0xD7 0x0427 #CYRILLIC CAPITAL LETTER CHE
+0xD8 0x0428 #CYRILLIC CAPITAL LETTER SHA
+0xD9 0x0429 #CYRILLIC CAPITAL LETTER SHCHA
+0xDA 0x042A #CYRILLIC CAPITAL LETTER HARD SIGN
+0xDB 0x042B #CYRILLIC CAPITAL LETTER YERU
+0xDC 0x042C #CYRILLIC CAPITAL LETTER SOFT SIGN
+0xDD 0x042D #CYRILLIC CAPITAL LETTER E
+0xDE 0x042E #CYRILLIC CAPITAL LETTER YU
+0xDF 0x042F #CYRILLIC CAPITAL LETTER YA
+0xE0 0x0430 #CYRILLIC SMALL LETTER A
+0xE1 0x0431 #CYRILLIC SMALL LETTER BE
+0xE2 0x0432 #CYRILLIC SMALL LETTER VE
+0xE3 0x0433 #CYRILLIC SMALL LETTER GHE
+0xE4 0x0434 #CYRILLIC SMALL LETTER DE
+0xE5 0x0435 #CYRILLIC SMALL LETTER IE
+0xE6 0x0436 #CYRILLIC SMALL LETTER ZHE
+0xE7 0x0437 #CYRILLIC SMALL LETTER ZE
+0xE8 0x0438 #CYRILLIC SMALL LETTER I
+0xE9 0x0439 #CYRILLIC SMALL LETTER SHORT I
+0xEA 0x043A #CYRILLIC SMALL LETTER KA
+0xEB 0x043B #CYRILLIC SMALL LETTER EL
+0xEC 0x043C #CYRILLIC SMALL LETTER EM
+0xED 0x043D #CYRILLIC SMALL LETTER EN
+0xEE 0x043E #CYRILLIC SMALL LETTER O
+0xEF 0x043F #CYRILLIC SMALL LETTER PE
+0xF0 0x0440 #CYRILLIC SMALL LETTER ER
+0xF1 0x0441 #CYRILLIC SMALL LETTER ES
+0xF2 0x0442 #CYRILLIC SMALL LETTER TE
+0xF3 0x0443 #CYRILLIC SMALL LETTER U
+0xF4 0x0444 #CYRILLIC SMALL LETTER EF
+0xF5 0x0445 #CYRILLIC SMALL LETTER HA
+0xF6 0x0446 #CYRILLIC SMALL LETTER TSE
+0xF7 0x0447 #CYRILLIC SMALL LETTER CHE
+0xF8 0x0448 #CYRILLIC SMALL LETTER SHA
+0xF9 0x0449 #CYRILLIC SMALL LETTER SHCHA
+0xFA 0x044A #CYRILLIC SMALL LETTER HARD SIGN
+0xFB 0x044B #CYRILLIC SMALL LETTER YERU
+0xFC 0x044C #CYRILLIC SMALL LETTER SOFT SIGN
+0xFD 0x044D #CYRILLIC SMALL LETTER E
+0xFE 0x044E #CYRILLIC SMALL LETTER YU
+0xFF 0x044F #CYRILLIC SMALL LETTER YA
--- /dev/null
+#
+# Name: cp1253 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 cp1253 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 cp1253 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 0x0192 #LATIN SMALL LETTER F WITH HOOK
+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 #UNDEFINED
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C #UNDEFINED
+0x8D #UNDEFINED
+0x8E #UNDEFINED
+0x8F #UNDEFINED
+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 #UNDEFINED
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C #UNDEFINED
+0x9D #UNDEFINED
+0x9E #UNDEFINED
+0x9F #UNDEFINED
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x0385 #GREEK DIALYTIKA TONOS
+0xA2 0x0386 #GREEK CAPITAL LETTER ALPHA WITH TONOS
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA #UNDEFINED
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x2015 #HORIZONTAL BAR
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x0384 #GREEK TONOS
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x0388 #GREEK CAPITAL LETTER EPSILON WITH TONOS
+0xB9 0x0389 #GREEK CAPITAL LETTER ETA WITH TONOS
+0xBA 0x038A #GREEK CAPITAL LETTER IOTA WITH TONOS
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x038C #GREEK CAPITAL LETTER OMICRON WITH TONOS
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x038E #GREEK CAPITAL LETTER UPSILON WITH TONOS
+0xBF 0x038F #GREEK CAPITAL LETTER OMEGA WITH TONOS
+0xC0 0x0390 #GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
+0xC1 0x0391 #GREEK CAPITAL LETTER ALPHA
+0xC2 0x0392 #GREEK CAPITAL LETTER BETA
+0xC3 0x0393 #GREEK CAPITAL LETTER GAMMA
+0xC4 0x0394 #GREEK CAPITAL LETTER DELTA
+0xC5 0x0395 #GREEK CAPITAL LETTER EPSILON
+0xC6 0x0396 #GREEK CAPITAL LETTER ZETA
+0xC7 0x0397 #GREEK CAPITAL LETTER ETA
+0xC8 0x0398 #GREEK CAPITAL LETTER THETA
+0xC9 0x0399 #GREEK CAPITAL LETTER IOTA
+0xCA 0x039A #GREEK CAPITAL LETTER KAPPA
+0xCB 0x039B #GREEK CAPITAL LETTER LAMDA
+0xCC 0x039C #GREEK CAPITAL LETTER MU
+0xCD 0x039D #GREEK CAPITAL LETTER NU
+0xCE 0x039E #GREEK CAPITAL LETTER XI
+0xCF 0x039F #GREEK CAPITAL LETTER OMICRON
+0xD0 0x03A0 #GREEK CAPITAL LETTER PI
+0xD1 0x03A1 #GREEK CAPITAL LETTER RHO
+0xD2 #UNDEFINED
+0xD3 0x03A3 #GREEK CAPITAL LETTER SIGMA
+0xD4 0x03A4 #GREEK CAPITAL LETTER TAU
+0xD5 0x03A5 #GREEK CAPITAL LETTER UPSILON
+0xD6 0x03A6 #GREEK CAPITAL LETTER PHI
+0xD7 0x03A7 #GREEK CAPITAL LETTER CHI
+0xD8 0x03A8 #GREEK CAPITAL LETTER PSI
+0xD9 0x03A9 #GREEK CAPITAL LETTER OMEGA
+0xDA 0x03AA #GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
+0xDB 0x03AB #GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
+0xDC 0x03AC #GREEK SMALL LETTER ALPHA WITH TONOS
+0xDD 0x03AD #GREEK SMALL LETTER EPSILON WITH TONOS
+0xDE 0x03AE #GREEK SMALL LETTER ETA WITH TONOS
+0xDF 0x03AF #GREEK SMALL LETTER IOTA WITH TONOS
+0xE0 0x03B0 #GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
+0xE1 0x03B1 #GREEK SMALL LETTER ALPHA
+0xE2 0x03B2 #GREEK SMALL LETTER BETA
+0xE3 0x03B3 #GREEK SMALL LETTER GAMMA
+0xE4 0x03B4 #GREEK SMALL LETTER DELTA
+0xE5 0x03B5 #GREEK SMALL LETTER EPSILON
+0xE6 0x03B6 #GREEK SMALL LETTER ZETA
+0xE7 0x03B7 #GREEK SMALL LETTER ETA
+0xE8 0x03B8 #GREEK SMALL LETTER THETA
+0xE9 0x03B9 #GREEK SMALL LETTER IOTA
+0xEA 0x03BA #GREEK SMALL LETTER KAPPA
+0xEB 0x03BB #GREEK SMALL LETTER LAMDA
+0xEC 0x03BC #GREEK SMALL LETTER MU
+0xED 0x03BD #GREEK SMALL LETTER NU
+0xEE 0x03BE #GREEK SMALL LETTER XI
+0xEF 0x03BF #GREEK SMALL LETTER OMICRON
+0xF0 0x03C0 #GREEK SMALL LETTER PI
+0xF1 0x03C1 #GREEK SMALL LETTER RHO
+0xF2 0x03C2 #GREEK SMALL LETTER FINAL SIGMA
+0xF3 0x03C3 #GREEK SMALL LETTER SIGMA
+0xF4 0x03C4 #GREEK SMALL LETTER TAU
+0xF5 0x03C5 #GREEK SMALL LETTER UPSILON
+0xF6 0x03C6 #GREEK SMALL LETTER PHI
+0xF7 0x03C7 #GREEK SMALL LETTER CHI
+0xF8 0x03C8 #GREEK SMALL LETTER PSI
+0xF9 0x03C9 #GREEK SMALL LETTER OMEGA
+0xFA 0x03CA #GREEK SMALL LETTER IOTA WITH DIALYTIKA
+0xFB 0x03CB #GREEK SMALL LETTER UPSILON WITH DIALYTIKA
+0xFC 0x03CC #GREEK SMALL LETTER OMICRON WITH TONOS
+0xFD 0x03CD #GREEK SMALL LETTER UPSILON WITH TONOS
+0xFE 0x03CE #GREEK SMALL LETTER OMEGA WITH TONOS
+0xFF #UNDEFINED
--- /dev/null
+#
+# Name: cp1254 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 cp1254 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 cp1254 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 0x0192 #LATIN SMALL LETTER F WITH HOOK
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT
+0x89 0x2030 #PER MILLE SIGN
+0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x0152 #LATIN CAPITAL LIGATURE OE
+0x8D #UNDEFINED
+0x8E #UNDEFINED
+0x8F #UNDEFINED
+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 0x02DC #SMALL TILDE
+0x99 0x2122 #TRADE MARK SIGN
+0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x0153 #LATIN SMALL LIGATURE OE
+0x9D #UNDEFINED
+0x9E #UNDEFINED
+0x9F 0x0178 #LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x00A1 #INVERTED EXCLAMATION MARK
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x00AA #FEMININE ORDINAL INDICATOR
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00AF #MACRON
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x00BA #MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF #INVERTED QUESTION MARK
+0xC0 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 #LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 #LATIN CAPITAL LETTER AE
+0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC #LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x011E #LATIN CAPITAL LETTER G WITH BREVE
+0xD1 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 #LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x0130 #LATIN CAPITAL LETTER I WITH DOT ABOVE
+0xDE 0x015E #LATIN CAPITAL LETTER S WITH CEDILLA
+0xDF 0x00DF #LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 #LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 #LATIN SMALL LETTER AE
+0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC #LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x011F #LATIN SMALL LETTER G WITH BREVE
+0xF1 0x00F1 #LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 #LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 #LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x00F8 #LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x0131 #LATIN SMALL LETTER DOTLESS I
+0xFE 0x015F #LATIN SMALL LETTER S WITH CEDILLA
+0xFF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS
--- /dev/null
+#
+# Name: cp1255 to Unicode table
+# Unicode version: 2.0
+# Table version: 2.01
+# Table format: Format A
+# Date: 1/7/2000
+#
+# Contact: Shawn.Steele@microsoft.com
+#
+# General notes: none
+#
+# Format: Three tab-separated columns
+# Column #1 is the cp1255 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 cp1255 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 0x0192 #LATIN SMALL LETTER F WITH HOOK
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT
+0x89 0x2030 #PER MILLE SIGN
+0x8A #UNDEFINED
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C #UNDEFINED
+0x8D #UNDEFINED
+0x8E #UNDEFINED
+0x8F #UNDEFINED
+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 0x02DC #SMALL TILDE
+0x99 0x2122 #TRADE MARK SIGN
+0x9A #UNDEFINED
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C #UNDEFINED
+0x9D #UNDEFINED
+0x9E #UNDEFINED
+0x9F #UNDEFINED
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x00A1 #INVERTED EXCLAMATION MARK
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x20AA #NEW SHEQEL SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x00D7 #MULTIPLICATION SIGN
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00AF #MACRON
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x00F7 #DIVISION SIGN
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF #INVERTED QUESTION MARK
+0xC0 0x05B0 #HEBREW POINT SHEVA
+0xC1 0x05B1 #HEBREW POINT HATAF SEGOL
+0xC2 0x05B2 #HEBREW POINT HATAF PATAH
+0xC3 0x05B3 #HEBREW POINT HATAF QAMATS
+0xC4 0x05B4 #HEBREW POINT HIRIQ
+0xC5 0x05B5 #HEBREW POINT TSERE
+0xC6 0x05B6 #HEBREW POINT SEGOL
+0xC7 0x05B7 #HEBREW POINT PATAH
+0xC8 0x05B8 #HEBREW POINT QAMATS
+0xC9 0x05B9 #HEBREW POINT HOLAM
+0xCA #UNDEFINED
+0xCB 0x05BB #HEBREW POINT QUBUTS
+0xCC 0x05BC #HEBREW POINT DAGESH OR MAPIQ
+0xCD 0x05BD #HEBREW POINT METEG
+0xCE 0x05BE #HEBREW PUNCTUATION MAQAF
+0xCF 0x05BF #HEBREW POINT RAFE
+0xD0 0x05C0 #HEBREW PUNCTUATION PASEQ
+0xD1 0x05C1 #HEBREW POINT SHIN DOT
+0xD2 0x05C2 #HEBREW POINT SIN DOT
+0xD3 0x05C3 #HEBREW PUNCTUATION SOF PASUQ
+0xD4 0x05F0 #HEBREW LIGATURE YIDDISH DOUBLE VAV
+0xD5 0x05F1 #HEBREW LIGATURE YIDDISH VAV YOD
+0xD6 0x05F2 #HEBREW LIGATURE YIDDISH DOUBLE YOD
+0xD7 0x05F3 #HEBREW PUNCTUATION GERESH
+0xD8 0x05F4 #HEBREW PUNCTUATION GERSHAYIM
+0xD9 #UNDEFINED
+0xDA #UNDEFINED
+0xDB #UNDEFINED
+0xDC #UNDEFINED
+0xDD #UNDEFINED
+0xDE #UNDEFINED
+0xDF #UNDEFINED
+0xE0 0x05D0 #HEBREW LETTER ALEF
+0xE1 0x05D1 #HEBREW LETTER BET
+0xE2 0x05D2 #HEBREW LETTER GIMEL
+0xE3 0x05D3 #HEBREW LETTER DALET
+0xE4 0x05D4 #HEBREW LETTER HE
+0xE5 0x05D5 #HEBREW LETTER VAV
+0xE6 0x05D6 #HEBREW LETTER ZAYIN
+0xE7 0x05D7 #HEBREW LETTER HET
+0xE8 0x05D8 #HEBREW LETTER TET
+0xE9 0x05D9 #HEBREW LETTER YOD
+0xEA 0x05DA #HEBREW LETTER FINAL KAF
+0xEB 0x05DB #HEBREW LETTER KAF
+0xEC 0x05DC #HEBREW LETTER LAMED
+0xED 0x05DD #HEBREW LETTER FINAL MEM
+0xEE 0x05DE #HEBREW LETTER MEM
+0xEF 0x05DF #HEBREW LETTER FINAL NUN
+0xF0 0x05E0 #HEBREW LETTER NUN
+0xF1 0x05E1 #HEBREW LETTER SAMEKH
+0xF2 0x05E2 #HEBREW LETTER AYIN
+0xF3 0x05E3 #HEBREW LETTER FINAL PE
+0xF4 0x05E4 #HEBREW LETTER PE
+0xF5 0x05E5 #HEBREW LETTER FINAL TSADI
+0xF6 0x05E6 #HEBREW LETTER TSADI
+0xF7 0x05E7 #HEBREW LETTER QOF
+0xF8 0x05E8 #HEBREW LETTER RESH
+0xF9 0x05E9 #HEBREW LETTER SHIN
+0xFA 0x05EA #HEBREW LETTER TAV
+0xFB #UNDEFINED
+0xFC #UNDEFINED
+0xFD 0x200E #LEFT-TO-RIGHT MARK
+0xFE 0x200F #RIGHT-TO-LEFT MARK
+0xFF #UNDEFINED
--- /dev/null
+#
+# Name: cp1256 to Unicode table
+# Unicode version: 2.1
+# Table version: 2.01
+# Table format: Format A
+# Date: 01/5/99
+#
+# Contact: Shawn.Steele@microsoft.com
+#
+# General notes: none
+#
+# Format: Three tab-separated columns
+# Column #1 is the cp1256 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 cp1256 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 0x067E #ARABIC LETTER PEH
+0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
+0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT
+0x89 0x2030 #PER MILLE SIGN
+0x8A 0x0679 #ARABIC LETTER TTEH
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x0152 #LATIN CAPITAL LIGATURE OE
+0x8D 0x0686 #ARABIC LETTER TCHEH
+0x8E 0x0698 #ARABIC LETTER JEH
+0x8F 0x0688 #ARABIC LETTER DDAL
+0x90 0x06AF #ARABIC LETTER GAF
+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 0x06A9 #ARABIC LETTER KEHEH
+0x99 0x2122 #TRADE MARK SIGN
+0x9A 0x0691 #ARABIC LETTER RREH
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x0153 #LATIN SMALL LIGATURE OE
+0x9D 0x200C #ZERO WIDTH NON-JOINER
+0x9E 0x200D #ZERO WIDTH JOINER
+0x9F 0x06BA #ARABIC LETTER NOON GHUNNA
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x060C #ARABIC COMMA
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x06BE #ARABIC LETTER HEH DOACHASHMEE
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00AF #MACRON
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x061B #ARABIC SEMICOLON
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x061F #ARABIC QUESTION MARK
+0xC0 0x06C1 #ARABIC LETTER HEH GOAL
+0xC1 0x0621 #ARABIC LETTER HAMZA
+0xC2 0x0622 #ARABIC LETTER ALEF WITH MADDA ABOVE
+0xC3 0x0623 #ARABIC LETTER ALEF WITH HAMZA ABOVE
+0xC4 0x0624 #ARABIC LETTER WAW WITH HAMZA ABOVE
+0xC5 0x0625 #ARABIC LETTER ALEF WITH HAMZA BELOW
+0xC6 0x0626 #ARABIC LETTER YEH WITH HAMZA ABOVE
+0xC7 0x0627 #ARABIC LETTER ALEF
+0xC8 0x0628 #ARABIC LETTER BEH
+0xC9 0x0629 #ARABIC LETTER TEH MARBUTA
+0xCA 0x062A #ARABIC LETTER TEH
+0xCB 0x062B #ARABIC LETTER THEH
+0xCC 0x062C #ARABIC LETTER JEEM
+0xCD 0x062D #ARABIC LETTER HAH
+0xCE 0x062E #ARABIC LETTER KHAH
+0xCF 0x062F #ARABIC LETTER DAL
+0xD0 0x0630 #ARABIC LETTER THAL
+0xD1 0x0631 #ARABIC LETTER REH
+0xD2 0x0632 #ARABIC LETTER ZAIN
+0xD3 0x0633 #ARABIC LETTER SEEN
+0xD4 0x0634 #ARABIC LETTER SHEEN
+0xD5 0x0635 #ARABIC LETTER SAD
+0xD6 0x0636 #ARABIC LETTER DAD
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x0637 #ARABIC LETTER TAH
+0xD9 0x0638 #ARABIC LETTER ZAH
+0xDA 0x0639 #ARABIC LETTER AIN
+0xDB 0x063A #ARABIC LETTER GHAIN
+0xDC 0x0640 #ARABIC TATWEEL
+0xDD 0x0641 #ARABIC LETTER FEH
+0xDE 0x0642 #ARABIC LETTER QAF
+0xDF 0x0643 #ARABIC LETTER KAF
+0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x0644 #ARABIC LETTER LAM
+0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x0645 #ARABIC LETTER MEEM
+0xE4 0x0646 #ARABIC LETTER NOON
+0xE5 0x0647 #ARABIC LETTER HEH
+0xE6 0x0648 #ARABIC LETTER WAW
+0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x0649 #ARABIC LETTER ALEF MAKSURA
+0xED 0x064A #ARABIC LETTER YEH
+0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x064B #ARABIC FATHATAN
+0xF1 0x064C #ARABIC DAMMATAN
+0xF2 0x064D #ARABIC KASRATAN
+0xF3 0x064E #ARABIC FATHA
+0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x064F #ARABIC DAMMA
+0xF6 0x0650 #ARABIC KASRA
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x0651 #ARABIC SHADDA
+0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x0652 #ARABIC SUKUN
+0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x200E #LEFT-TO-RIGHT MARK
+0xFE 0x200F #RIGHT-TO-LEFT MARK
+0xFF 0x06D2 #ARABIC LETTER YEH BARREE
--- /dev/null
+#
+# Name: cp1257 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 cp1257 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 cp1257 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 #UNDEFINED
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C #UNDEFINED
+0x8D 0x00A8 #DIAERESIS
+0x8E 0x02C7 #CARON
+0x8F 0x00B8 #CEDILLA
+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 #UNDEFINED
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C #UNDEFINED
+0x9D 0x00AF #MACRON
+0x9E 0x02DB #OGONEK
+0x9F #UNDEFINED
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 #UNDEFINED
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 #UNDEFINED
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x0156 #LATIN CAPITAL LETTER R WITH CEDILLA
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00C6 #LATIN CAPITAL LETTER AE
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00F8 #LATIN SMALL LETTER O WITH STROKE
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x0157 #LATIN SMALL LETTER R WITH CEDILLA
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x00E6 #LATIN SMALL LETTER AE
+0xC0 0x0104 #LATIN CAPITAL LETTER A WITH OGONEK
+0xC1 0x012E #LATIN CAPITAL LETTER I WITH OGONEK
+0xC2 0x0100 #LATIN CAPITAL LETTER A WITH MACRON
+0xC3 0x0106 #LATIN CAPITAL LETTER C WITH ACUTE
+0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x0118 #LATIN CAPITAL LETTER E WITH OGONEK
+0xC7 0x0112 #LATIN CAPITAL LETTER E WITH MACRON
+0xC8 0x010C #LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0179 #LATIN CAPITAL LETTER Z WITH ACUTE
+0xCB 0x0116 #LATIN CAPITAL LETTER E WITH DOT ABOVE
+0xCC 0x0122 #LATIN CAPITAL LETTER G WITH CEDILLA
+0xCD 0x0136 #LATIN CAPITAL LETTER K WITH CEDILLA
+0xCE 0x012A #LATIN CAPITAL LETTER I WITH MACRON
+0xCF 0x013B #LATIN CAPITAL LETTER L WITH CEDILLA
+0xD0 0x0160 #LATIN CAPITAL LETTER S WITH CARON
+0xD1 0x0143 #LATIN CAPITAL LETTER N WITH ACUTE
+0xD2 0x0145 #LATIN CAPITAL LETTER N WITH CEDILLA
+0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x014C #LATIN CAPITAL LETTER O WITH MACRON
+0xD5 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x0172 #LATIN CAPITAL LETTER U WITH OGONEK
+0xD9 0x0141 #LATIN CAPITAL LETTER L WITH STROKE
+0xDA 0x015A #LATIN CAPITAL LETTER S WITH ACUTE
+0xDB 0x016A #LATIN CAPITAL LETTER U WITH MACRON
+0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x017B #LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xDE 0x017D #LATIN CAPITAL LETTER Z WITH CARON
+0xDF 0x00DF #LATIN SMALL LETTER SHARP S
+0xE0 0x0105 #LATIN SMALL LETTER A WITH OGONEK
+0xE1 0x012F #LATIN SMALL LETTER I WITH OGONEK
+0xE2 0x0101 #LATIN SMALL LETTER A WITH MACRON
+0xE3 0x0107 #LATIN SMALL LETTER C WITH ACUTE
+0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x0119 #LATIN SMALL LETTER E WITH OGONEK
+0xE7 0x0113 #LATIN SMALL LETTER E WITH MACRON
+0xE8 0x010D #LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x017A #LATIN SMALL LETTER Z WITH ACUTE
+0xEB 0x0117 #LATIN SMALL LETTER E WITH DOT ABOVE
+0xEC 0x0123 #LATIN SMALL LETTER G WITH CEDILLA
+0xED 0x0137 #LATIN SMALL LETTER K WITH CEDILLA
+0xEE 0x012B #LATIN SMALL LETTER I WITH MACRON
+0xEF 0x013C #LATIN SMALL LETTER L WITH CEDILLA
+0xF0 0x0161 #LATIN SMALL LETTER S WITH CARON
+0xF1 0x0144 #LATIN SMALL LETTER N WITH ACUTE
+0xF2 0x0146 #LATIN SMALL LETTER N WITH CEDILLA
+0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x014D #LATIN SMALL LETTER O WITH MACRON
+0xF5 0x00F5 #LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x0173 #LATIN SMALL LETTER U WITH OGONEK
+0xF9 0x0142 #LATIN SMALL LETTER L WITH STROKE
+0xFA 0x015B #LATIN SMALL LETTER S WITH ACUTE
+0xFB 0x016B #LATIN SMALL LETTER U WITH MACRON
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x017C #LATIN SMALL LETTER Z WITH DOT ABOVE
+0xFE 0x017E #LATIN SMALL LETTER Z WITH CARON
+0xFF 0x02D9 #DOT ABOVE
--- /dev/null
+#
+# Name: cp1258 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 cp1258 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 cp1258 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 0x0192 #LATIN SMALL LETTER F WITH HOOK
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT
+0x89 0x2030 #PER MILLE SIGN
+0x8A #UNDEFINED
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x0152 #LATIN CAPITAL LIGATURE OE
+0x8D #UNDEFINED
+0x8E #UNDEFINED
+0x8F #UNDEFINED
+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 0x02DC #SMALL TILDE
+0x99 0x2122 #TRADE MARK SIGN
+0x9A #UNDEFINED
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x0153 #LATIN SMALL LIGATURE OE
+0x9D #UNDEFINED
+0x9E #UNDEFINED
+0x9F 0x0178 #LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x00A1 #INVERTED EXCLAMATION MARK
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x00AA #FEMININE ORDINAL INDICATOR
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00AF #MACRON
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x00BA #MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF #INVERTED QUESTION MARK
+0xC0 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE
+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 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 #LATIN CAPITAL LETTER AE
+0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x0300 #COMBINING GRAVE ACCENT
+0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x0110 #LATIN CAPITAL LETTER D WITH STROKE
+0xD1 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x0309 #COMBINING HOOK ABOVE
+0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x01A0 #LATIN CAPITAL LETTER O WITH HORN
+0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x01AF #LATIN CAPITAL LETTER U WITH HORN
+0xDE 0x0303 #COMBINING TILDE
+0xDF 0x00DF #LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE
+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 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 #LATIN SMALL LETTER AE
+0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x0301 #COMBINING ACUTE ACCENT
+0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x0111 #LATIN SMALL LETTER D WITH STROKE
+0xF1 0x00F1 #LATIN SMALL LETTER N WITH TILDE
+0xF2 0x0323 #COMBINING DOT BELOW
+0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x01A1 #LATIN SMALL LETTER O WITH HORN
+0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x00F8 #LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x01B0 #LATIN SMALL LETTER U WITH HORN
+0xFE 0x20AB #DONG SIGN
+0xFF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.arabic
+
+HELP: latin/arabic
+{ $var-description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.arabic" "Arabic encoding"
+"The " { $vocab-link "io.encodings.8-bit.arabic" } " vocabulary provides the " { $link latin/arabic } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.arabic"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.arabic
+
+8-BIT: latin/arabic ISO_8859-6:1987 8859-6
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.cyrillic
+
+HELP: latin/cyrillic
+{ $var-description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.cyrillic" "Cyrillic encoding"
+"The " { $vocab-link "io.encodings.8-bit.cyrillic" } " vocabulary provides the " { $link latin/cyrillic } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.cyrillic"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.cyrillic
+
+8-BIT: latin/cyrillic ISO_8859-5:1988 8859-5
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.ebcdic
+
+HELP: ebcdic
+{ $var-description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.ebcdic" "EBCDIC encoding"
+"The " { $vocab-link "io.encodings.8-bit.ebcdic" } " vocabulary provides the " { $link ebcdic } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.ebcdic"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.ebcdic
+
+8-BIT: ebcdic IBM037 CP037
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.greek
+
+HELP: latin/greek
+{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.greek" "Greek encoding"
+"The " { $vocab-link "io.encodings.8-bit.greek" } " vocabulary provides the " { $link latin/greek } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.greek"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.greek
+
+8-BIT: latin/greek ISO_8859-7:1987 8859-7
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.hebrew
+
+HELP: latin/hebrew
+{ $var-description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.hebrew" "Hebrew encoding"
+"The " { $vocab-link "io.encodings.8-bit.hebrew" } " vocabulary provides the " { $link latin/hebrew } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.hebrew"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.hebrew
+
+8-BIT: latin/hebrew ISO_8859-8:1988 8859-8
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.koi8-r
+
+HELP: koi8-r
+{ $var-description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.koi8-r" "KOI8-R encoding"
+"The " { $vocab-link "io.encodings.8-bit.koi8-r" } " vocabulary provides the " { $link koi8-r } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.koi8-r"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.koi8-r
+
+8-BIT: koi8-r KOI8-R KOI8-R
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin1
+
+HELP: latin1
+{ $var-description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin1" "Latin1 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin1" } " vocabulary provides the " { $link latin1 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin1"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin1
+
+8-BIT: latin1 ISO_8859-1:1987 8859-1
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin10
+
+HELP: latin10
+{ $var-description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin10" "Latin10 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin10" } " vocabulary provides the " { $link latin10 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin10"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin10
+
+8-BIT: latin10 ISO-8859-16 8859-16
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin2
+
+HELP: latin2
+{ $var-description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin2" "Latin2 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin2" } " vocabulary provides the " { $link latin2 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin2"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin2
+
+8-BIT: latin2 ISO_8859-2:1987 8859-2
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin3
+
+HELP: latin3
+{ $var-description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin3" "Latin3 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin3" } " vocabulary provides the " { $link latin3 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin3"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin3
+
+8-BIT: latin3 ISO_8859-3:1988 8859-3
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin4
+
+HELP: latin4
+{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin4" "Latin4 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin4" } " vocabulary provides the " { $link latin4 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin4"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin4
+
+8-BIT: latin4 ISO_8859-4:1988 8859-4
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin5
+
+HELP: latin5
+{ $var-description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin5" "Latin5 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin5" } " vocabulary provides the " { $link latin5 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin5"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin5
+
+8-BIT: latin5 ISO_8859-9:1989 8859-9
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin6
+
+HELP: latin6
+{ $var-description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin6" "Latin6 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin6" } " vocabulary provides the " { $link latin6 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin6"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin6
+
+8-BIT: latin6 ISO-8859-10 8859-10
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin7
+
+HELP: latin7
+{ $var-description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necessary to represent Baltic Rim languages, as previous character sets were incomplete." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin7" "Latin7 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin7" } " vocabulary provides the " { $link latin7 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin7"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin7
+
+8-BIT: latin7 ISO-8859-13 8859-13
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin8
+
+HELP: latin8
+{ $var-description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin8" "Latin8 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin8" } " vocabulary provides the " { $link latin8 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin8"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin8
+
+8-BIT: latin8 ISO-8859-14 8859-14
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.latin9
+
+HELP: latin9
+{ $var-description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.latin9" "Latin9 encoding"
+"The " { $vocab-link "io.encodings.8-bit.latin9" } " vocabulary provides the " { $link latin9 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.latin9"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.latin9
+
+8-BIT: latin9 ISO-8859-15 8859-15
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.mac-roman
+
+HELP: mac-roman
+{ $var-description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.mac-roman" "Mac Roman encoding"
+"The " { $vocab-link "io.encodings.8-bit.mac-roman" } " vocabulary provides the " { $link mac-roman } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.mac-roman"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.mac-roman
+
+8-BIT: mac-roman macintosh ROMAN
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.thai
+
+HELP: latin/thai
+{ $var-description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.thai" "Thai encoding"
+"The " { $vocab-link "io.encodings.8-bit.thai" } " vocabulary provides the " { $link latin/thai } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.thai"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.thai
+
+8-BIT: latin/thai TIS-620 8859-11
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1250
+
+8-BIT: windows-1250 windows-1250 CP1250
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1251
+
+8-BIT: windows-1251 windows-1251 CP1251
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.8-bit.windows-1252
+
+HELP: windows-1252
+{ $var-description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "io.encodings.8-bit.windows-1252" "Windows 1252 encoding"
+"The " { $vocab-link "io.encodings.8-bit.windows-1252" } " vocabulary provides the " { $link windows-1252 } " encoding." ;
+
+ABOUT: "io.encodings.8-bit.windows-1252"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1252
+
+8-BIT: windows-1252 windows-1252 CP1252
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1253
+
+8-BIT: windows-1253 windows-1253 CP1253
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1254
+
+8-BIT: windows-1254 windows-1254 CP1254
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1255
+
+8-BIT: windows-1255 windows-1255 CP1255
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1256
+
+8-BIT: windows-1256 windows-1256 CP1256
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1257
+
+8-BIT: windows-1257 windows-1257 CP1257
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.8-bit ;
+IN: io.encodings.8-bit.windows-1258
+
+8-BIT: windows-1258 windows-1258 CP1258
] 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
ascii "ANSI_X3.4-1968" register-encoding
utf16be "UTF-16BE" register-encoding
utf16le "UTF-16LE" register-encoding
-utf16 "UTF-16" register-encoding
\ No newline at end of file
+utf16 "UTF-16" register-encoding
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 ;
V{ } clone swap processes get set-at
wait-flag get-global raise-flag ;
-M: process hashcode* handle>> hashcode* ;
-
: pass-environment? ( process -- ? )
dup environment>> assoc-empty? not
swap environment-mode>> +replace-environment+ eq? or ;
! 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 ;
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
{ $subsections <mapped-array> }
"Additionally, files may be opened with two combinators which take a c-type as input:"
-{ $subsections with-mapped-array }
-{ $subsections with-mapped-array-reader }
+{ $subsections with-mapped-array with-mapped-array-reader }
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
$nl
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
""
"\"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"
} ;
{ $subsections <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
"Utility combinators which wrap the above:"
-{ $subsections with-mapped-file }
-{ $subsections with-mapped-file-reader }
-{ $subsections with-mapped-array }
-{ $subsections with-mapped-array-reader }
+{ $subsections with-mapped-file
+ with-mapped-file-reader
+ with-mapped-array
+ with-mapped-array-reader }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
{ $subsections
"io.mmap.arrays"
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
alien.strings libc continuations destructors summary splitting
assocs random math.parser locals unicode.case openssl
openssl.libcrypto openssl.libssl io.backend io.ports io.pathnames
-io.encodings.8-bit io.timeouts io.sockets.secure ;
+io.encodings.8-bit.latin1 io.timeouts io.sockets.secure ;
IN: io.sockets.secure.openssl
GENERIC: ssl-method ( symbol -- method )
: 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 ;
[ <input-port> |dispose ] [ <output-port> |dispose ] bi
] with-destructors ;
+SYMBOL: bind-local-address
+
GENERIC: establish-connection ( client-out remote -- )
GENERIC: ((client)) ( remote -- handle )
M: inet (server)
invalid-inet-server ;
+ERROR: invalid-local-address addrspec ;
+
+M: invalid-local-address summary
+ drop "Cannot use with-local-address with <inet>; use <inet4> or <inet6> instead" ;
+
+: with-local-address ( addr quot -- )
+ [
+ [ ] [ inet4? ] [ inet6? ] tri or
+ [ bind-local-address ]
+ [ invalid-local-address ] if
+ ] dip with-variable ; inline
+
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] }
[ (io-error) ]
} cond ;
+: ?bind-client ( socket -- )
+ bind-local-address get [ [ fd>> ] dip make-sockaddr/size bind io-error ] [ drop ] if* ; inline
+
M: object ((client)) ( addrspec -- fd )
- protocol-family SOCK_STREAM socket-fd dup init-client-socket ;
+ protocol-family SOCK_STREAM socket-fd
+ [ init-client-socket ] [ ?bind-client ] [ ] tri ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
[ packet-size malloc &free receive-buffer set-global ] "io.sockets.unix" add-startup-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
+! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
+! See http://factorcode.org/license.txt for BSD license.\r
USING: kernel accessors io.sockets io.sockets.private\r
io.backend.windows io.backend windows.winsock system destructors\r
alien.c-types classes.struct combinators ;\r
+FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
M: windows addrinfo-error ( n -- )\r
\r
M: object ((client)) ( addrspec -- handle )\r
[ SOCK_STREAM open-socket ] keep\r
- [ unspecific-sockaddr/size bind-socket ] [ drop ] 2bi ;\r
+ [\r
+ bind-local-address get\r
+ [ nip make-sockaddr/size ]\r
+ [ unspecific-sockaddr/size ] if* bind-socket\r
+ ] [ drop ] 2bi ;\r
\r
: server-socket ( addrspec type -- fd )\r
[ open-socket ] [ drop ] 2bi\r
USING: accessors continuations destructors io io.encodings
-io.encodings.8-bit io.encodings.ascii io.encodings.binary
+io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files io.pipes
io.streams.byte-array io.streams.limited io.streams.string
-kernel namespaces strings tools.test system ;
+kernel namespaces strings tools.test system
+io.encodings.8-bit.latin1 ;
IN: io.streams.limited.tests
[ ] [
<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 -- )
USING: alien.syntax alien.c-types core-foundation
core-foundation.bundles core-foundation.dictionaries system
-combinators kernel sequences io accessors ;
+combinators kernel sequences io accessors unix.types ;
IN: iokit
<<
CONSTANT: kNilOptions 0
-TYPEDEF: uint mach_port_t
-TYPEDEF: int kern_return_t
-TYPEDEF: int boolean_t
-TYPEDEF: mach_port_t io_object_t
-TYPEDEF: io_object_t io_iterator_t
-TYPEDEF: io_object_t io_registry_entry_t
-TYPEDEF: io_object_t io_service_t
-TYPEDEF: char[128] io_name_t
-TYPEDEF: char[512] io_string_t
-TYPEDEF: kern_return_t IOReturn
-
-TYPEDEF: uint IOOptionBits
-
CONSTANT: MACH_PORT_NULL 0
CONSTANT: KERN_SUCCESS 0
[ [ + ] 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"
{ $description "Put the head and tail of the list on the stack." } ;
HELP: unswons
-{ $values { "cons" list } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
+{ $values { "cons" list } { "cdr" "the tail of the list" } { "car" "the head of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
{ leach foldl lmap>array } related-words
{ $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
{ $description "Sends a message to the current log if the level is more urgent than " { $link log-level } ". Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ;
HELP: add-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log a message every time it is called." } ;
HELP: add-input-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-output-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ;
HELP: add-error-logging
-{ $values { "level" "a log level" } { "word" word } }
+{ $values { "word" word } { "level" "a log level" } }
{ $description "Causes the word to log its input values and any errors it throws."
$nl
"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller."
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs
-definitions quotations namespaces memoize accessors ;
+definitions quotations namespaces memoize accessors
+compiler.units ;
IN: macros
<PRIVATE
M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
+
+M: macro bump-effect-counter* drop t ;
: 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
{ cis exp } related-words
HELP: polar>
-{ $values { "z" number } { "abs" "a non-negative real number" } { "arg" real } }
+{ $values { "abs" "a non-negative real number" } { "arg" real } { "z" number } }
{ $description "Converts an absolute value and argument (polar form) to a complex number." } ;
HELP: [-1,1]?
{ $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
: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
: mnorm ( m -- n ) dup mmax abs m/n ;
-<PRIVATE
-
-: x ( seq -- elt ) first ; inline
-: y ( seq -- elt ) second ; inline
-: z ( seq -- elt ) third ; inline
-
-: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
-
-PRIVATE>
-
-: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
+: cross ( vec1 vec2 -- vec3 )
+ [ [ { 1 2 1 } vshuffle ] [ { 2 0 0 } vshuffle ] bi* v* ]
+ [ [ { 2 0 0 } vshuffle ] [ { 1 2 1 } vshuffle ] bi* v* ] 2bi v- ; inline
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
[ 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
HELP: unique-primes
{ $values
- { "numbits" integer } { "n" integer }
+ { "n" integer }
+ { "numbits" integer }
{ "seq" sequence }
}
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
{ $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
+ 16 >>align-first
rep >>rep
class c:typedef ;
3bi
] >>setter
32 >>size
- 8 >>align
+ 16 >>align
+ 16 >>align-first
rep >>rep
class c:typedef ;
{ \ (simd-v*) [ %mul-vector-reps ] }
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] }
{ \ (simd-v/) [ %div-vector-reps ] }
- { \ (simd-vmin) [ %min-vector-reps ] }
- { \ (simd-vmax) [ %max-vector-reps ] }
+ { \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] }
+ { \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] }
{ \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] }
{ \ (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 ] }
{ \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] }
{ \ (simd-(vunpack-head)) [ (%unpack-reps) ] }
{ \ (simd-(vunpack-tail)) [ (%unpack-reps) ] }
- { \ (simd-v<=) [ cc<= %compare-vector-reps ] }
- { \ (simd-v<) [ cc< %compare-vector-reps ] }
- { \ (simd-v=) [ cc= %compare-vector-reps ] }
- { \ (simd-v>) [ cc> %compare-vector-reps ] }
- { \ (simd-v>=) [ cc>= %compare-vector-reps ] }
- { \ (simd-vunordered?) [ cc/<>= %compare-vector-reps ] }
+ { \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] }
+ { \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] }
+ { \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] }
+ { \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] }
+ { \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] }
+ { \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] }
{ \ (simd-vany?) [ %test-vector-reps ] }
{
[ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
[ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
- [ [ call ] dip call ]
- [ [ call ] dip compile-call ]
+ [ [ [ call ] dip call ] call( quot quot -- result ) ]
+ [ [ [ call ] dip compile-call ] call( quot quot -- result ) ]
} 2cleave
@ not
] filter ; inline
] [ ] map-as
word '[ _ execute ] ;
-: check-boolean-ops ( class elt-class compare-quot -- )
+: check-boolean-ops ( class elt-class compare-quot -- seq )
[
[ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip
'[ first2 inputs _ _ check-boolean-op ]
new [ drop 16 random ] map ;
:: test-shift-vector ( class -- ? )
- class random-int-vector :> src
- char-16 random-shift-vector :> perm
- { class char-16 } :> decl
-
- src perm vshuffle
- src perm [ decl declare vshuffle ] compile-call
- = ; inline
+ [
+ class random-int-vector :> src
+ char-16 random-shift-vector :> perm
+ { class char-16 } :> decl
+
+ src perm vshuffle
+ src perm [ decl declare vshuffle ] compile-call
+ =
+ ] call( -- ? ) ;
{ char-16 uchar-16 short-8 ushort-8 int-4 uint-4 longlong-2 ulonglong-2 }
[ 10 swap '[ [ t ] [ _ test-shift-vector ] unit-test ] times ] each
"== Checking vector tests" print
:: test-vector-tests-bool ( vector declaration -- none? any? all? )
- vector
- [ [ declaration declare vnone? ] compile-call ]
- [ [ declaration declare vany? ] compile-call ]
- [ [ declaration declare vall? ] compile-call ] tri ; inline
+ [
+ vector
+ [ [ declaration declare vnone? ] compile-call ]
+ [ [ declaration declare vany? ] compile-call ]
+ [ [ declaration declare vall? ] compile-call ] tri
+ ] call( -- none? any? all? ) ;
: yes ( -- x ) t ;
: no ( -- x ) f ;
:: test-vector-tests-branch ( vector declaration -- none? any? all? )
- vector
- [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
- [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
- [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri ; inline
+ [
+ vector
+ [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
+ [ [ declaration declare vany? [ yes ] [ no ] if ] compile-call ]
+ [ [ declaration declare vall? [ yes ] [ no ] if ] compile-call ] tri
+ ] call( -- none? any? all? ) ;
TUPLE: inconsistent-vector-test bool branch ;
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
-
- bool-none branch-none ?inconsistent
- bool-any branch-any ?inconsistent
- bool-all branch-all ?inconsistent ; inline
+ [
+ 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
+ bool-all branch-all ?inconsistent
+ ] call( -- none? any? all? ) ;
[ f t t ]
[ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
"== Checking broadcast" print
: test-broadcast ( seq -- failures )
[ length >array ] keep
- '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline
+ '[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ;
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
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 ( -- )
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects sets kernel.private
accessors combinators math math.intervals math.vectors
-math.vectors.conversion.backend
-namespaces assocs fry splitting classes.algebra generalizations
-locals compiler.tree.propagation.info ;
+math.vectors.conversion.backend namespaces assocs fry splitting
+classes.algebra generalizations locals
+compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
vxor
vnot
v?
+ vif
}
"Entire vector tests:"
{ $subsections
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
HELP: v?
-{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "result" "a sequence of numbers" } }
{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." }
{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types." } ;
+HELP: vif
+{ $values { "mask" "a sequence of booleans" } { "true-quot" { $quotation "( -- vector )" } } { "false-quot" { $quotation "( -- vector )" } } { "result" "a sequence" } }
+{ $description "If all of the elements of " { $snippet "mask" } " are true, " { $snippet "true-quot" } " is called and its output value returned. If all of the elements of " { $snippet "mask" } " are false, " { $snippet "false-quot" } " is called and its output value returned. Otherwise, both quotations are called and " { $snippet "mask" } " is used to select elements from each output as with " { $link v? } "." }
+{ $notes "See " { $link "math-vectors-simd-logic" } " for notes on dealing with vector boolean inputs and results when using SIMD types."
+$nl
+"For most conditional SIMD code, unless a case is exceptionally expensive to compute, it is usually most efficient to just compute all cases and blend them with " { $link v? } " instead of using " { $snippet "vif" } "." } ;
+
+{ v? vif } related-words
+
HELP: vany?
{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
{ $description "Returns true if any element of " { $snippet "v" } " is true." }
:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
: vshuffle-elements ( u perm -- v )
+ over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ;
: vshuffle-bytes ( u perm -- v )
: vunordered? ( u v -- w ) [ unordered? ] 2map ;
: v= ( u v -- w ) [ = ] 2map ;
-: v? ( mask true false -- w )
+: v? ( mask true false -- result )
[ vand ] [ vandn ] bi-curry* bi vor ; inline
+:: vif ( mask true-quot false-quot -- result )
+ {
+ { [ mask vall? ] [ true-quot call ] }
+ { [ mask vnone? ] [ false-quot call ] }
+ [ mask true-quot call false-quot call v? ]
+ } cond ; inline
+
: vfloor ( u -- v ) [ floor ] map ;
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
: bilerp ( aa ba ab bb {t,u} -- a_tu )
[ first lerp ] [ second lerp ] bi-curry
- [ 2bi@ ] [ call ] bi* ;
+ [ 2bi@ ] [ call ] bi* ; inline
: vlerp ( a b t -- a_t )
- [ lerp ] 3map ;
+ [ over v- ] dip v* v+ ; inline
: vnlerp ( a b t -- a_t )
- [ lerp ] curry 2map ;
+ [ over v- ] dip v*n v+ ; inline
: vbilerp ( aa ba ab bb {t,u} -- a_tu )
[ first vnlerp ] [ second vnlerp ] bi-curry
- [ 2bi@ ] [ call ] bi* ;
+ [ 2bi@ ] [ call ] bi* ; inline
: v~ ( a b epsilon -- ? )
- [ ~ ] curry 2all? ;
+ [ ~ ] curry 2all? ; inline
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
USING: assocs hashtables kernel sequences generic words
arrays classes slots slots.private classes.tuple
classes.tuple.private math vectors math.vectors quotations
-accessors combinators byte-arrays specialized-arrays ;
+accessors combinators byte-arrays vocabs vocabs.loader ;
IN: mirrors
TUPLE: mirror { object read-only } ;
INSTANCE: vector enumerated-sequence
INSTANCE: callable enumerated-sequence
INSTANCE: byte-array enumerated-sequence
-INSTANCE: specialized-array enumerated-sequence
-INSTANCE: simd-128 enumerated-sequence
-INSTANCE: simd-256 enumerated-sequence
GENERIC: make-mirror ( obj -- assoc )
M: hashtable make-mirror ;
M: integer make-mirror drop f ;
M: enumerated-sequence make-mirror <enum> ;
M: object make-mirror <mirror> ;
+
+"specialized-arrays" vocab [
+ "specialized-arrays.mirrors" require
+] when
"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
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors models models.arrow inverse kernel ;
-IN: models.illusion
-
-TUPLE: illusion < arrow ;
-
-: <illusion> ( model quot -- illusion )
- illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
- swap >>quot over >>model [ add-dependency ] keep ;
-
-: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
-
-: backtalk ( value object -- )
- [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
-
-M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
+++ /dev/null
-Two Way Arrows
\ No newline at end of file
: <model> ( value -- model )
model new-model ;
-M: model hashcode* drop model hashcode* ;
-
: add-dependency ( dep model -- )
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 ;
{ $description "Gets the object in the heap with minumum priority." } ;
HELP: pheap-push
-{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
+{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
HELP: pheap-pop*
[ 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 ;
: check-recursion ( obj quot -- )
nesting-limit? [
drop
- "~" over class name>> "~" 3append
- swap present-text
+ [ class name>> "~" dup surround ] keep present-text
] [
- over recursion-check get memq? [
+ over recursion-check get member-eq? [
drop "~circularity~" swap present-text
] [
over recursion-check get push
: pprint-elements ( seq -- )
do-length-limit
[ [ pprint* ] each ] dip
- [ "~" swap number>string " more~" 3append text ] when* ;
+ [ number>string "~" " more~" surround text ] when* ;
M: quotation pprint-delims drop \ [ \ ] ;
M: curry pprint-delims drop \ [ \ ] ;
" 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. ;
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test quoted-printable io.encodings.string
-sequences io.encodings.8-bit splitting kernel ;
+sequences splitting kernel io.encodings.8-bit.latin2 ;
IN: quoted-printable.tests
[ """José was the
{ $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
+! (c)2009 Joe Groff bsd license
+USING: help.syntax help.markup kernel sequences quotations
+math arrays combinators ;
+IN: sequences.generalizations
+
+HELP: neach
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- )" } } { "n" integer } }
+{ $description "A generalization of " { $link each } ", " { $link 2each } ", and " { $link 3each } " that can iterate over any number of sequences in parallel." } ;
+
+HELP: nmap
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "n" integer } { "result" "a sequence of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel." } ;
+
+HELP: nmap-as
+{ $values { "...seq" { $snippet "n" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( ...element -- result )" } } { "exemplar" sequence } { "n" integer } { "result" "a sequence of the same type as " { $snippet "exemplar" } } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel." } ;
+
+HELP: mnmap
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences of the same type as the first " { $snippet "seq" } } }
+{ $description "A generalization of " { $link map } ", " { $link 2map } ", and " { $link 3map } " that can map over any number of sequences in parallel and provide any number of output sequences." } ;
+
+HELP: mnmap-as
+{ $values { "m*seq" { $snippet "m" } " sequences on the datastack" } { "quot" "a quotation with stack effect " { $snippet "( m*element -- result*n )" } } { "n*exemplar" { $snippet "n" } " sequences on the datastack" } { "m" integer } { "n" integer } { "result*n" { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link map-as } ", " { $link 2map-as } ", and " { $link 3map-as } " that can map over any number of sequences in parallel and provide any number of output sequences of distinct types." } ;
+
+HELP: nproduce
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "n" integer } { "seq..." { $snippet "n" } " arrays on the datastack" } }
+{ $description "A generalization of " { $link produce } " that generates " { $snippet "n" } " arrays in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+HELP: nproduce-as
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj1 obj2 ... objn )" } } { "...exemplar" { $snippet "n" } " sequences on the datastack" } { "n" integer } { "seq..." { $snippet "n" } " sequences on the datastack of the same types as the " { $snippet "exemplar" } "s" } }
+{ $description "A generalization of " { $link produce-as } " that generates " { $snippet "n" } " sequences in parallel by calling " { $snippet "quot" } " repeatedly until " { $snippet "pred" } " outputs false." } ;
+
+ARTICLE: "sequences.generalizations" "Generalized sequence iteration combinators"
+"The " { $vocab-link "sequences.generalizations" } " vocabulary defines generalized versions of the iteration " { $link "sequences-combinators" } "."
+{ $subsections
+ neach
+ nmap
+ nmap-as
+ mnmap
+ mnmap-as
+ nproduce
+ nproduce-as
+} ;
+
+ABOUT: "sequences.generalizations"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: tools.test generalizations kernel math arrays sequences
+sequences.generalizations ascii fry math.parser io io.streams.string ;
+IN: sequences.generalizations.tests
+
+: neach-test ( a b c d -- )
+ [ 4 nappend print ] 4 neach ;
+: nmap-test ( a b c d -- e )
+ [ 4 nappend ] 4 nmap ;
+: nmap-as-test ( a b c d -- e )
+ [ 4 nappend ] [ ] 4 nmap-as ;
+: mnmap-3-test ( a b c d -- e f g )
+ [ append ] 4 3 mnmap ;
+: mnmap-2-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] 4 2 mnmap ;
+: mnmap-as-test ( a b c d -- e f )
+ [ [ append ] 2bi@ ] { } [ ] 4 2 mnmap-as ;
+: mnmap-1-test ( a b c d -- e )
+ [ 4 nappend ] 4 1 mnmap ;
+: mnmap-0-test ( a b c d -- )
+ [ 4 nappend print ] 4 0 mnmap ;
+: nproduce-as-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] { } B{ } 2 nproduce-as
+ [ drop ] 2dip ;
+: nproduce-test ( n -- a b )
+ [ dup zero? not ]
+ [ [ 2 - ] [ ] [ 1 - ] tri ] 2 nproduce
+ [ drop ] 2dip ;
+
+[ """A1a!
+B2b@
+C3c#
+D4d$
+""" ] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ neach-test ] with-string-writer
+] unit-test
+
+[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-test
+] unit-test
+
+[ [ "A1a!" "B2b@" "C3c#" "D4d$" ] ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ nmap-as-test
+] unit-test
+
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a!" "b@" "c#" "d$" }
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-3-test
+] unit-test
+
+[
+ { "A1" "B2" "C3" "D4" }
+ { "a!" "b@" "c#" "d$" }
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-2-test
+] unit-test
+
+[
+ { "A1" "B2" "C3" "D4" }
+ [ "a!" "b@" "c#" "d$" ]
+] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-as-test
+] unit-test
+
+[ { "A1a!" "B2b@" "C3c#" "D4d$" } ]
+[
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ mnmap-1-test
+] unit-test
+
+[ """A1a!
+B2b@
+C3c#
+D4d$
+""" ] [
+ { "A" "B" "C" "D" }
+ { "1" "2" "3" "4" }
+ { "a" "b" "c" "d" }
+ { "!" "@" "#" "$" }
+ [ mnmap-0-test ] with-string-writer
+] unit-test
+
+[ { 10 8 6 4 2 } B{ 9 7 5 3 1 } ]
+[ 10 nproduce-as-test ] unit-test
+
+[ { 10 8 6 4 2 } { 9 7 5 3 1 } ]
+[ 10 nproduce-test ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel sequences sequences.private math
+combinators macros math.order math.ranges quotations fry effects
+memoize.private generalizations ;
+IN: sequences.generalizations
+
+MACRO: nmin-length ( n -- )
+ dup 1 - [ min ] n*quot
+ '[ [ length ] _ napply @ ] ;
+
+: nnth-unsafe ( n ...seq n -- )
+ [ nth-unsafe ] swap [ apply-curry ] [ cleave* ] bi ; inline
+MACRO: nset-nth-unsafe ( n -- )
+ [ [ drop ] ]
+ [ '[ [ set-nth-unsafe ] _ [ apply-curry ] [ cleave-curry ] [ spread* ] tri ] ]
+ if-zero ;
+
+: (neach) ( ...seq quot n -- len quot' )
+ dup dup dup
+ '[ [ _ nmin-length ] _ nkeep [ _ nnth-unsafe ] _ ncurry ] dip compose ; inline
+
+: neach ( ...seq quot n -- )
+ (neach) each-integer ; inline
+
+: nmap-as ( ...seq quot exemplar n -- result )
+ '[ _ (neach) ] dip map-integers ; inline
+
+: nmap ( ...seq quot n -- result )
+ dup '[ [ _ npick ] dip swap ] dip nmap-as ; inline
+
+MACRO: nnew-sequence ( n -- )
+ [ [ drop ] ]
+ [ dup '[ [ new-sequence ] _ apply-curry _ cleave* ] ] if-zero ;
+
+: nnew-like ( len ...exemplar quot n -- result... )
+ 5 dupn '[
+ _ nover
+ [ [ _ nnew-sequence ] dip call ]
+ _ ndip [ like ]
+ _ apply-curry
+ _ spread*
+ ] call ; inline
+
+MACRO: (ncollect) ( n -- )
+ 3 dupn 1 +
+ '[ [ [ keep ] _ ndip _ nset-nth-unsafe ] _ ncurry ] ;
+
+: ncollect ( len quot ...into n -- )
+ (ncollect) each-integer ; inline
+
+: nmap-integers ( len quot ...exemplar n -- result... )
+ 4 dupn
+ '[ [ over ] _ ndip [ [ _ ncollect ] _ nkeep ] _ nnew-like ] call ; inline
+
+: mnmap-as ( m*seq quot n*exemplar m n -- result*n )
+ dup '[ [ _ (neach) ] _ ndip _ nmap-integers ] call ; inline
+
+: mnmap ( m*seq quot m n -- result*n )
+ 2dup '[ [ _ npick ] dip swap _ dupn ] 2dip mnmap-as ; inline
+
+: naccumulator-for ( quot ...exemplar n -- quot' vec... )
+ 5 dupn '[
+ [ [ length ] keep new-resizable ] _ napply
+ [ [ [ push ] _ apply-curry _ spread* ] _ ncurry compose ] _ nkeep
+ ] call ; inline
+
+: naccumulator ( quot n -- quot' vec... )
+ [ V{ } swap dupn ] keep naccumulator-for ; inline
+
+: nproduce-as ( pred quot ...exemplar n -- seq... )
+ 7 dupn '[
+ _ ndup
+ [ _ naccumulator-for [ while ] _ ndip ]
+ _ ncurry _ ndip
+ [ like ] _ apply-curry _ spread*
+ ] call ; inline
+
+: nproduce ( pred quot n -- seq... )
+ [ { } swap dupn ] keep nproduce-as ; inline
--- /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" } }
}
C: <id> id
-M: id hashcode* obj>> hashcode* ;
+M: id hashcode* nip obj>> identity-hashcode ;
M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
:: (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
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: mirrors specialized-arrays math.vectors ;
+IN: specialized-arrays.mirrors
+
+INSTANCE: specialized-array enumerated-sequence
+INSTANCE: simd-128 enumerated-sequence
+INSTANCE: simd-256 enumerated-sequence
[ 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
"prettyprint" vocab [
"specialized-arrays.prettyprint" require
] when
+
+"mirrors" vocab [
+ "specialized-arrays.mirrors" require
+] when
pop-literal nip >>abi
pop-literal nip >>parameters
pop-literal nip >>return
- "( callback )" f <word> >>xt
+ "( callback )" <uninterned-word> >>xt
dup callback-bottom
#alien-callback, ;
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
introductions
loop? ;
-M: inline-recursive hashcode* id>> hashcode* ;
-
: inlined-block? ( word -- ? ) "inlined-block" word-prop ;
: <inline-recursive> ( word -- label )
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
+
+\ (identity-hashcode) { object } { fixnum } define-primitive
+
+\ compute-identity-hashcode { 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"
+ "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Cannot apply “call” to a run-time computed value\nmacro call"
}
-"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 )"
} ;
"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
{ $heading "Input quotation declaration" }
"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
-{ $example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected" }
+{ $unchecked-example ": bad ( quot -- ) [ call ] keep bad ; inline recursive" "[ [ ] bad ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
"The stack checker does not trace data flow in two instances."
$nl
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
-{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected" }
+{ $unchecked-example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Cannot apply “call” to a run-time computed value\nmacro call" }
"However a small change can be made:"
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"
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 ;
+TUPLE: literal < identity-tuple value recursion ;
: literal ( value -- literal ) known (literal) ;
-: literal-value? ( value -- ? ) known (literal-value?) ;
-
-M: literal hashcode* nip hashcode>> ;
+M: literal hashcode* nip value>> identity-hashcode ;
: <literal> ( obj -- value )
- recursive-state get over hashcode \ literal boa ;
+ recursive-state get \ literal boa ;
+
+M: literal (input-value?) drop f ;
M: literal (literal-value?) drop t ;
: curried/composed-literal ( input1 input2 quot -- literal )
[ [ literal ] bi@ ] dip
[ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi
- over hashcode \ literal boa ; inline
+ \ literal boa ; inline
! Result of curry
TUPLE: curried obj quot ;
: >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
IN: system-info.linux
: (uname) ( buf -- int )
- "int" f "uname" { "char*" } alien-invoke ;
+ int f "uname" { char* } alien-invoke ;
: uname ( -- seq )
65536 <char-array> [ (uname) io-error ] keep
[ [ 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 ;
urls math.parser io.directories tools.deploy.test ;\r
IN: tools.deploy.tests\r
\r
-[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
+[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
\r
-[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
+[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
\r
-[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
+[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
[ "staging.math-threads-compiler-ui.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
-[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
+[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
\r
-[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
+[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
-[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
+[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
-[ t ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
+[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
\r
-[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
+[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
os macosx? [\r
- [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
+ [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
] when\r
\r
-[ t ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
+[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
\r
{\r
"tools.deploy.test.1"\r
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 [
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct cocoa cocoa.classes
-cocoa.subclassing core-graphics.types kernel math ;
+cocoa.runtime cocoa.subclassing cocoa.types core-graphics.types
+kernel math ;
+FROM: alien.c-types => float ;
IN: tools.deploy.test.14
CLASS: {
{ +name+ "Bar" }
} {
"bar:"
- "float"
- { "id" "SEL" "NSRect" }
+ float
+ { id SEL NSRect }
[
[ origin>> [ x>> ] [ y>> ] bi + ]
[ size>> [ w>> ] [ h>> ] bi + ]
+USING: io.encodings.string kernel io.encodings.8-bit.latin7 ;
IN: tools.deploy.test.4
-USING: io.encodings.8-bit io.encodings.string kernel ;
: deploy-test-4 ( -- )
"xyzthg" \ latin7 encode drop ;
-USING: alien kernel math ;
+USING: alien alien.c-types kernel math ;
IN: tools.deploy.test.9
: callback-test ( -- callback )
- "int" { "int" } "cdecl" [ 1 + ] alien-callback ;
+ int { int } "cdecl" [ 1 + ] alien-callback ;
: indirect-test ( -- )
- 10 callback-test "int" { "int" } "cdecl" alien-indirect 11 assert= ;
+ 10 callback-test int { int } "cdecl" alien-indirect 11 assert= ;
MAIN: indirect-test
dup deploy-config make-deploy-image
] with-directory ;
-: small-enough? ( n -- ? )
+ERROR: image-too-big actual-size max-size ;
+
+: small-enough? ( n -- )
[ "test.image" temp-file file-info size>> ]
[
cell 4 / *
cpu ppc? [ 100000 + ] when
os windows? [ 150000 + ] when
] bi*
- <= ;
+ 2dup <= [ 2drop ] [ image-too-big ] if ;
: deploy-test-command ( -- args )
os macosx?
{ $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
#! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting
-M: source-file-error compute-restarts error>> compute-restarts ;
-
-M: source-file-error error-help error>> error-help ;
-
CONSTANT: +listener-input+ "<Listener input>"
: error-location ( error -- string )
-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 splitting strings system vm words ;
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 [ gc-event memory>struct ] map 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"
-IN: tools.profiler.tests
USING: accessors tools.profiler tools.test kernel memory math
-threads alien tools.profiler.private sequences compiler compiler.units
-words ;
+threads alien alien.c-types tools.profiler.private sequences
+compiler compiler.units words ;
+IN: tools.profiler.tests
[ t ] [
\ length counter>>
[ ] [ \ + usage-profile. ] unit-test
-: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ;
+: callback-test ( -- callback ) void { } "cdecl" [ ] alien-callback ;
-: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
+: indirect-test ( callback -- ) void { } "cdecl" alien-indirect ;
: foobar ( -- ) ;
[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
-: crash-bug-1 ( -- x ) "hi" "bye" <word> ;
+: crash-bug-1 ( -- x ) "hi" <uninterned-word> ;
: crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ;
[ ] [ [ crash-bug-2 ] profile ] unit-test
! 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>> ;
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
HELP: breakpoint-if
-{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
+{ $values { "word" word } { "quot" { $quotation "( -- ? )" } } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: B
! 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
{ +name+ "FactorApplicationDelegate" }
}
-{ "applicationDidUpdate:" "void" { "id" "SEL" "id" }
+{ "applicationDidUpdate:" void { id SEL id }
[ 3drop reset-run-loop ]
} ;
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax cocoa cocoa.nibs cocoa.application
-cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
-core-foundation core-foundation.strings help.topics kernel
-memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.backend.cocoa eval locals
-vocabs.refresh ;
+cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
+cocoa.subclassing core-foundation core-foundation.strings
+help.topics kernel memory namespaces parser system ui
+ui.tools.browser ui.tools.listener ui.backend.cocoa eval
+locals vocabs.refresh ;
+FROM: alien.c-types => int void ;
IN: ui.backend.cocoa.tools
: finder-run-files ( alien -- )
{ +name+ "FactorWorkspaceApplicationDelegate" }
}
-{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
+{ "application:openFiles:" void { id SEL id id }
[ [ 3drop ] dip finder-run-files ]
}
-{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
+{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
-{ "factorListener:" "id" { "id" "SEL" "id" }
+{ "factorListener:" id { id SEL id }
[ 3drop show-listener f ]
}
-{ "factorBrowser:" "id" { "id" "SEL" "id" }
+{ "factorBrowser:" id { id SEL id }
[ 3drop show-browser f ]
}
-{ "newFactorListener:" "id" { "id" "SEL" "id" }
+{ "newFactorListener:" id { id SEL id }
[ 3drop listener-window f ]
}
-{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
+{ "newFactorBrowser:" id { id SEL id }
[ 3drop browser-window f ]
}
-{ "runFactorFile:" "id" { "id" "SEL" "id" }
+{ "runFactorFile:" id { id SEL id }
[ 3drop menu-run-files f ]
}
-{ "saveFactorImage:" "id" { "id" "SEL" "id" }
+{ "saveFactorImage:" id { id SEL id }
[ 3drop save f ]
}
-{ "saveFactorImageAs:" "id" { "id" "SEL" "id" }
+{ "saveFactorImageAs:" id { id SEL id }
[ 3drop menu-save-image f ]
}
-{ "refreshAll:" "id" { "id" "SEL" "id" }
+{ "refreshAll:" id { id SEL id }
[ 3drop [ refresh-all ] \ refresh-all call-listener f ]
} ;
{ +name+ "FactorServiceProvider" }
} {
"evalInListener:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval-listener f ] do-service 2drop ]
} {
"evalToString:userData:error:"
- "void"
- { "id" "SEL" "id" "id" "id" }
+ void
+ { id SEL id id id }
[ nip [ eval>string ] do-service 2drop ]
} ;
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.types cocoa.windows sequences io.encodings.utf8 ui ui.private
-ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
+ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
core-foundation.strings core-graphics core-graphics.types threads
combinators math.rectangles ;
IN: ui.backend.cocoa.views
}
! Rendering
-{ "drawRect:" "void" { "id" "SEL" "NSRect" }
+{ "drawRect:" void { id SEL NSRect }
[ 2drop window relayout-1 yield ]
}
! Events
-{ "acceptsFirstMouse:" "char" { "id" "SEL" "id" }
+{ "acceptsFirstMouse:" char { id SEL id }
[ 3drop 1 ]
}
-{ "mouseEntered:" "void" { "id" "SEL" "id" }
+{ "mouseEntered:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseExited:" "void" { "id" "SEL" "id" }
+{ "mouseExited:" void { id SEL id }
[ 3drop forget-rollover ]
}
-{ "mouseMoved:" "void" { "id" "SEL" "id" }
+{ "mouseMoved:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseDragged:" "void" { "id" "SEL" "id" }
+{ "mouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
+{ "rightMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
+{ "otherMouseDragged:" void { id SEL id }
[ nip send-mouse-moved ]
}
-{ "mouseDown:" "void" { "id" "SEL" "id" }
+{ "mouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "mouseUp:" "void" { "id" "SEL" "id" }
+{ "mouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "rightMouseDown:" "void" { "id" "SEL" "id" }
+{ "rightMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "rightMouseUp:" "void" { "id" "SEL" "id" }
+{ "rightMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "otherMouseDown:" "void" { "id" "SEL" "id" }
+{ "otherMouseDown:" void { id SEL id }
[ nip send-button-down$ ]
}
-{ "otherMouseUp:" "void" { "id" "SEL" "id" }
+{ "otherMouseUp:" void { id SEL id }
[ nip send-button-up$ ]
}
-{ "scrollWheel:" "void" { "id" "SEL" "id" }
+{ "scrollWheel:" void { id SEL id }
[ nip send-wheel$ ]
}
-{ "keyDown:" "void" { "id" "SEL" "id" }
+{ "keyDown:" void { id SEL id }
[ nip send-key-down-event ]
}
-{ "keyUp:" "void" { "id" "SEL" "id" }
+{ "keyUp:" void { id SEL id }
[ nip send-key-up-event ]
}
-{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
+{ "validateUserInterfaceItem:" char { id SEL id }
[
nip -> action
2dup [ window ] [ utf8 alien>string ] bi* validate-action
]
}
-{ "undo:" "id" { "id" "SEL" "id" }
+{ "undo:" id { id SEL id }
[ nip undo-action send-action$ ]
}
-{ "redo:" "id" { "id" "SEL" "id" }
+{ "redo:" id { id SEL id }
[ nip redo-action send-action$ ]
}
-{ "cut:" "id" { "id" "SEL" "id" }
+{ "cut:" id { id SEL id }
[ nip cut-action send-action$ ]
}
-{ "copy:" "id" { "id" "SEL" "id" }
+{ "copy:" id { id SEL id }
[ nip copy-action send-action$ ]
}
-{ "paste:" "id" { "id" "SEL" "id" }
+{ "paste:" id { id SEL id }
[ nip paste-action send-action$ ]
}
-{ "delete:" "id" { "id" "SEL" "id" }
+{ "delete:" id { id SEL id }
[ nip delete-action send-action$ ]
}
-{ "selectAll:" "id" { "id" "SEL" "id" }
+{ "selectAll:" id { id SEL id }
[ nip select-all-action send-action$ ]
}
-{ "newDocument:" "id" { "id" "SEL" "id" }
+{ "newDocument:" id { id SEL id }
[ nip new-action send-action$ ]
}
-{ "openDocument:" "id" { "id" "SEL" "id" }
+{ "openDocument:" id { id SEL id }
[ nip open-action send-action$ ]
}
-{ "saveDocument:" "id" { "id" "SEL" "id" }
+{ "saveDocument:" id { id SEL id }
[ nip save-action send-action$ ]
}
-{ "saveDocumentAs:" "id" { "id" "SEL" "id" }
+{ "saveDocumentAs:" id { id SEL id }
[ nip save-as-action send-action$ ]
}
-{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" }
+{ "revertDocumentToSaved:" id { id SEL id }
[ nip revert-action send-action$ ]
}
! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
-{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+{ "magnifyWithEvent:" void { id SEL id }
[
nip
dup -> deltaZ sgn {
]
}
-{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+{ "swipeWithEvent:" void { id SEL id }
[
nip
dup -> deltaX sgn {
]
}
-! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+! "rotateWithEvent:" void { id SEL id }}
-{ "acceptsFirstResponder" "char" { "id" "SEL" }
+{ "acceptsFirstResponder" char { id SEL }
[ 2drop 1 ]
}
! Services
-{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+{ "validRequestorForSendType:returnType:" id { id SEL id id }
[
! We return either self or nil
[ over window-focus ] 2dip
]
}
-{ "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" }
+{ "writeSelectionToPasteboard:types:" char { id SEL id id }
[
CF>string-array NSStringPboardType swap member? [
[ drop window-focus gadget-selection ] dip over
]
}
-{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
+{ "readSelectionFromPasteboard:" char { id SEL id }
[
pasteboard-string dup [
[ drop window ] dip swap user-input 1
}
! Text input
-{ "insertText:" "void" { "id" "SEL" "id" }
+{ "insertText:" void { id SEL id }
[ nip CF>string swap window user-input ]
}
-{ "hasMarkedText" "char" { "id" "SEL" }
+{ "hasMarkedText" char { id SEL }
[ 2drop 0 ]
}
-{ "markedRange" "NSRange" { "id" "SEL" }
+{ "markedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
-{ "selectedRange" "NSRange" { "id" "SEL" }
+{ "selectedRange" NSRange { id SEL }
[ 2drop 0 0 <NSRange> ]
}
-{ "setMarkedText:selectedRange:" "void" { "id" "SEL" "id" "NSRange" }
+{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
[ 2drop 2drop ]
}
-{ "unmarkText" "void" { "id" "SEL" }
+{ "unmarkText" void { id SEL }
[ 2drop ]
}
-{ "validAttributesForMarkedText" "id" { "id" "SEL" }
+{ "validAttributesForMarkedText" id { id SEL }
[ 2drop NSArray -> array ]
}
-{ "attributedSubstringFromRange:" "id" { "id" "SEL" "NSRange" }
+{ "attributedSubstringFromRange:" id { id SEL NSRange }
[ 3drop f ]
}
-{ "characterIndexForPoint:" "NSUInteger" { "id" "SEL" "NSPoint" }
+{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
[ 3drop 0 ]
}
-{ "firstRectForCharacterRange:" "NSRect" { "id" "SEL" "NSRange" }
+{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
[ 3drop 0 0 0 0 <CGRect> ]
}
-{ "conversationIdentifier" "NSInteger" { "id" "SEL" }
+{ "conversationIdentifier" NSInteger { id SEL }
[ drop alien-address ]
}
! Initialization
-{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
+{ "updateFactorGadgetSize:" void { id SEL id }
[ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
-{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
+{ "doCommandBySelector:" void { id SEL SEL }
[ 3drop ]
}
-{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }
+{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
[
[ drop ] 2dip
SUPER-> initWithFrame:pixelFormat:
]
}
-{ "isOpaque" "char" { "id" "SEL" }
+{ "isOpaque" char { id SEL }
[
2drop 0
]
}
-{ "dealloc" "void" { "id" "SEL" }
+{ "dealloc" void { id SEL }
[
drop
[ unregister-window ]
{ +name+ "FactorWindowDelegate" }
}
-{ "windowDidMove:" "void" { "id" "SEL" "id" }
+{ "windowDidMove:" void { id SEL id }
[
2nip -> object [ -> contentView window ] keep save-position
]
}
-{ "windowDidBecomeKey:" "void" { "id" "SEL" "id" }
+{ "windowDidBecomeKey:" void { id SEL id }
[
2nip -> object -> contentView window focus-world
]
}
-{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
+{ "windowDidResignKey:" void { id SEL id }
[
forget-rollover
2nip -> object -> contentView
]
}
-{ "windowShouldClose:" "char" { "id" "SEL" "id" }
+{ "windowShouldClose:" char { id SEL id }
[
3drop 1
]
}
-{ "windowWillClose:" "void" { "id" "SEL" "id" }
+{ "windowWillClose:" void { id SEL id }
[
2nip -> object -> contentView window ungraft
]
: 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 }
! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object )
- "uint" { "void*" "uint" "long" "long" } "stdcall" [
+ uint { void* uint long long } "stdcall" [
pick
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
: 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 ;
CONSTANT: vertical { 0 1 }
TUPLE: gadget < rect
-id
pref-dim
parent
children
M: gadget equal? 2drop f ;
-M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
+M: gadget hashcode* nip identity-hashcode ;
M: gadget model-changed 2drop ;
[ 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 ;
IN: ui.gadgets.menus
HELP: <commands-menu>
-{ $values { "target" object } { "commands" "a sequence of commands" } { "hook" { $quotation "( button -- )" } } { "menu" "a new " { $link gadget } } }
+{ $values { "target" object } { "hook" { $quotation "( button -- )" } } { "commands" "a sequence of commands" } { "menu" "a new " { $link gadget } } }
{ $description "Creates a popup menu of commands which are to be invoked on " { $snippet "target" } ". The " { $snippet "hook" } " quotation is run before a command is invoked." } ;
HELP: show-menu
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>
{ <viewport> <scroller> } related-words
HELP: set-scroll-position
-{ $values { "scroller" scroller } { "value" "a pair of integers" } }
+{ $values { "value" "a pair of integers" } { "scroller" scroller } }
{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
HELP: relative-scroll-rect
{ $description "Creates a new track which lays out children along the given orientation, either " { $link horizontal } " or " { $link vertical } "." } ;
HELP: track-add
-{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
+{ $values { "track" track } { "gadget" gadget } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
ABOUT: "ui-track-layout"
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 ;
USING: help.markup help.syntax kernel ui.gadgets ;
HELP: draw-interior
-{ $values { "pen" object } { "gadget" gadget } }
+{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the interior of a gadget by making OpenGL calls. The " { $snippet "interior" } " slot may be set to objects implementing this generic word." } ;
HELP: draw-boundary
-{ $values { "pen" object } { "gadget" gadget } }
+{ $values { "gadget" gadget } { "pen" object } }
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
ARTICLE: "ui-pen-protocol" "UI pen protocol"
{ $vocab-subsection "Polygon pens" "ui.pens.polygon" }
{ $vocab-subsection "Solid pens" "ui.pens.solid" }
{ $vocab-subsection "Tile pens" "ui.pens.tile" }
-"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
\ No newline at end of file
+"Custom implementations must follow the guidelines set forth in " { $link "ui-paint-custom" } "." ;
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 )
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t
+TYPEDEF: uint mach_port_t
+TYPEDEF: int kern_return_t
+TYPEDEF: int boolean_t
+TYPEDEF: mach_port_t io_object_t
+TYPEDEF: io_object_t io_iterator_t
+TYPEDEF: io_object_t io_registry_entry_t
+TYPEDEF: io_object_t io_service_t
+TYPEDEF: char[128] io_name_t
+TYPEDEF: char[512] io_string_t
+TYPEDEF: kern_return_t IOReturn
-ALIAS: <time_t> <long>
\ No newline at end of file
+TYPEDEF: uint IOOptionBits
+
+
+
+ALIAS: <time_t> <long>
TYPEDEF: fsfilcnt_t __fsfilcnt_t
TYPEDEF: __uint64_t rlim_t
TYPEDEF: uint32_t id_t
+TYPEDEF: long clockid_t
C-TYPE: DIR
C-TYPE: FILE
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
-io vocabs classes.struct unix.time ;
+io vocabs classes.struct unix.time alien.libraries ;
IN: unix
CONSTANT: PROT_NONE 0
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 )
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
+"librt" "librt.so" "cdecl" add-library
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>> ;
M: A new-resizable drop <V> ; inline
+M: V new-resizable drop <V> ; inline
+
M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
: >V ( seq -- vector ) V new clone-like ; inline
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 ulonglong } ;
+
+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
CONSTANT: PIPE_UNLIMITED_INSTANCES 255
+CONSTANT: EXCEPTION_NONCONTINUABLE HEX: 1
+CONSTANT: STATUS_GUARD_PAGE_VIOLATION HEX: 80000001
+CONSTANT: STATUS_DATATYPE_MISALIGNMENT HEX: 80000002
+CONSTANT: STATUS_BREAKPOINT HEX: 80000003
+CONSTANT: STATUS_SINGLE_STEP HEX: 80000004
+CONSTANT: STATUS_ACCESS_VIOLATION HEX: C0000005
+CONSTANT: STATUS_IN_PAGE_ERROR HEX: C0000006
+CONSTANT: STATUS_INVALID_HANDLE HEX: C0000008
+CONSTANT: STATUS_NO_MEMORY HEX: C0000017
+CONSTANT: STATUS_ILLEGAL_INSTRUCTION HEX: C000001D
+CONSTANT: STATUS_NONCONTINUABLE_EXCEPTION HEX: C0000025
+CONSTANT: STATUS_INVALID_DISPOSITION HEX: C0000026
+CONSTANT: STATUS_ARRAY_BOUNDS_EXCEEDED HEX: C000008C
+CONSTANT: STATUS_FLOAT_DENORMAL_OPERAND HEX: C000008D
+CONSTANT: STATUS_FLOAT_DIVIDE_BY_ZERO HEX: C000008E
+CONSTANT: STATUS_FLOAT_INEXACT_RESULT HEX: C000008F
+CONSTANT: STATUS_FLOAT_INVALID_OPERATION HEX: C0000090
+CONSTANT: STATUS_FLOAT_OVERFLOW HEX: C0000091
+CONSTANT: STATUS_FLOAT_STACK_CHECK HEX: C0000092
+CONSTANT: STATUS_FLOAT_UNDERFLOW HEX: C0000093
+CONSTANT: STATUS_INTEGER_DIVIDE_BY_ZERO HEX: C0000094
+CONSTANT: STATUS_INTEGER_OVERFLOW HEX: C0000095
+CONSTANT: STATUS_PRIVILEGED_INSTRUCTION HEX: C0000096
+CONSTANT: STATUS_STACK_OVERFLOW HEX: C00000FD
+CONSTANT: STATUS_CONTROL_C_EXIT HEX: C000013A
+CONSTANT: STATUS_FLOAT_MULTIPLE_FAULTS HEX: C00002B4
+CONSTANT: STATUS_FLOAT_MULTIPLE_TRAPS HEX: C00002B5
+
LIBRARY: kernel32
! FUNCTION: _hread
! FUNCTION: _hwrite
! FUNCTION: QueryDosDeviceW
! FUNCTION: QueryInformationJobObject
! FUNCTION: QueryMemoryResourceNotification
-! FUNCTION: QueryPerformanceCounter
-! FUNCTION: QueryPerformanceFrequency
+FUNCTION: BOOL QueryPerformanceCounter ( LARGE_INTEGER* lpPerformanceCount ) ;
+FUNCTION: BOOL QueryPerformanceFrequency ( LARGE_INTEGER* lpFrequency ) ;
! FUNCTION: QueryWin31IniFilesMappedToRegistry
! FUNCTION: QueueUserAPC
! FUNCTION: QueueUserWorkItem
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> ;
: get-html ( -- table )
{ "lat1" "special" "symbol" } [
- "vocab:xml/entities/html/xhtml-"
- swap ".ent" 3append read-entities-file
+ "vocab:xml/entities/html/xhtml-" ".ent" surround
+ read-entities-file
] map first3 assoc-union assoc-union ;
get-html to: html-entities
"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>
-USING: xml xml.data xml.traversal tools.test accessors kernel
-io.encodings.8-bit ;
+USING: xml xml.data xml.traversal tools.test accessors kernel ;
[ "\u000131" ] [ "vocab:xml/tests/latin5.xml" file>xml children>string ] unit-test
[ "\u0000e9" ] [ "vocab:xml/tests/latin1.xml" file>xml children>string ] unit-test
: 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 )
HELP: alien-callback
{ $values { "return" "a C return type" } { "parameters" "a sequence of C parameter types" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } { "quot" "a quotation" } { "alien" alien } }
{ $description
- "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "\"void\"" } " indicates that no value is to be returned."
+ "Defines a callback from C to Factor which accepts the given set of parameters from the C caller, pushes them on the data stack, calls the quotation, and passes a return value back to the C caller. A return type of " { $snippet "void" } " indicates that no value is to be returned."
$nl
"When a compiled reference to this word is called, it pushes the callback's alien address on the data stack. This address can be passed to any C function expecting a C function pointer with the correct signature. The callback is actually generated when the word calling " { $link alien-callback } " is compiled."
$nl
"A simple example, showing a C function which returns the difference of two given integers:"
{ $code
": difference-callback ( -- alien )"
- " \"int\" { \"int\" \"int\" } \"cdecl\" [ - ] alien-callback ;"
+ " int { int int } \"cdecl\" [ - ] alien-callback ;"
}
}
{ $errors "Throws an " { $link alien-callback-error } " if the word calling " { $link alien-callback } " is not compiled." } ;
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 ;
-USING: alien.strings alien.c-types alien.data tools.test kernel libc
-io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
+USING: alien.strings alien.c-types alien.data tools.test
+kernel libc io.encodings.utf8 io.encodings.utf16 io.encodings.utf16n
+io.encodings.ascii alien io.encodings.string io.encodings.8-bit.latin1 ;
IN: alien.strings.tests
[ "\u0000ff" ]
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
+
+2 header-bits set
"vocab:bootstrap/syntax.factor" parse-file
-"vocab:cpu/" architecture get {
+architecture get {
{ "x86.32" "x86/32" }
{ "winnt-x86.64" "x86/64/winnt" }
{ "unix-x86.64" "x86/64/unix" }
{ "macosx-ppc" "ppc/macosx" }
{ "arm" "arm" }
} ?at [ "Bad architecture: " prepend throw ] unless
-"/bootstrap.factor" 3append parse-file
+"vocab:cpu/" "/bootstrap.factor" surround parse-file
"vocab:bootstrap/layouts/layouts.factor" parse-file
bootstrapping? on
+[
+
! Create some empty vocabs where the below primitives and
! classes will go
{
"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 )) }
+ { "(identity-hashcode)" "kernel.private" (( obj -- code )) }
+ { "compute-identity-hashcode" "kernel.private" (( obj -- )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared
+
+] with-compilation-unit
load-help? off
{ "resource:core" } vocab-roots set
-! Create a boot quotation for the target
+! Create a boot quotation for the target by collecting all top-level
+! forms into a quotation, surrounded by some boilerplate.
[
[
- ! 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
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words words.symbol sequences vocabs kernel ;
+USING: words words.symbol sequences vocabs kernel
+compiler.units ;
IN: bootstrap.syntax
-"syntax" create-vocab drop
+[
+ "syntax" create-vocab drop
-{
- "!"
- "\""
- "#!"
- "("
- "(("
- ":"
- ";"
- "<PRIVATE"
- "BIN:"
- "B{"
- "BV{"
- "C:"
- "CHAR:"
- "DEFER:"
- "ERROR:"
- "FORGET:"
- "GENERIC#"
- "GENERIC:"
- "HEX:"
- "HOOK:"
- "H{"
- "IN:"
- "INSTANCE:"
- "M:"
- "MAIN:"
- "MATH:"
- "MIXIN:"
- "NAN:"
- "OCT:"
- "P\""
- "POSTPONE:"
- "PREDICATE:"
- "PRIMITIVE:"
- "PRIVATE>"
- "SBUF\""
- "SINGLETON:"
- "SINGLETONS:"
- "SYMBOL:"
- "SYMBOLS:"
- "CONSTANT:"
- "TUPLE:"
- "SLOT:"
- "T{"
- "UNION:"
- "INTERSECTION:"
- "USE:"
- "UNUSE:"
- "USING:"
- "QUALIFIED:"
- "QUALIFIED-WITH:"
- "FROM:"
- "EXCLUDE:"
- "RENAME:"
- "ALIAS:"
- "SYNTAX:"
- "V{"
- "W{"
- "["
- "\\"
- "M\\"
- "]"
- "delimiter"
- "deprecated"
- "f"
- "flushable"
- "foldable"
- "inline"
- "recursive"
- "t"
- "{"
- "}"
- "CS{"
- "<<"
- ">>"
- "call-next-method"
- "initial:"
- "read-only"
- "call("
- "execute("
-} [ "syntax" create drop ] each
+ {
+ "!"
+ "\""
+ "#!"
+ "("
+ "(("
+ ":"
+ ";"
+ "BIN:"
+ "B{"
+ "BV{"
+ "C:"
+ "CHAR:"
+ "DEFER:"
+ "ERROR:"
+ "FORGET:"
+ "GENERIC#"
+ "GENERIC:"
+ "HEX:"
+ "HOOK:"
+ "H{"
+ "IN:"
+ "INSTANCE:"
+ "M:"
+ "MAIN:"
+ "MATH:"
+ "MIXIN:"
+ "NAN:"
+ "OCT:"
+ "P\""
+ "POSTPONE:"
+ "PREDICATE:"
+ "PRIMITIVE:"
+ "PRIVATE>"
+ "SBUF\""
+ "SINGLETON:"
+ "SINGLETONS:"
+ "SYMBOL:"
+ "SYMBOLS:"
+ "CONSTANT:"
+ "TUPLE:"
+ "SLOT:"
+ "T{"
+ "UNION:"
+ "INTERSECTION:"
+ "USE:"
+ "UNUSE:"
+ "USING:"
+ "QUALIFIED:"
+ "QUALIFIED-WITH:"
+ "FROM:"
+ "EXCLUDE:"
+ "RENAME:"
+ "ALIAS:"
+ "SYNTAX:"
+ "V{"
+ "W{"
+ "["
+ "\\"
+ "M\\"
+ "]"
+ "delimiter"
+ "deprecated"
+ "f"
+ "flushable"
+ "foldable"
+ "inline"
+ "recursive"
+ "t"
+ "{"
+ "}"
+ "CS{"
+ "<<"
+ ">>"
+ "call-next-method"
+ "initial:"
+ "read-only"
+ "call("
+ "execute("
+ } [ "syntax" create drop ] each
-"t" "syntax" lookup define-symbol
+ "t" "syntax" lookup define-symbol
+] with-compilation-unit
\r
M: byte-array new-resizable drop <byte-vector> ; inline\r
\r
+M: byte-vector new-resizable drop <byte-vector> ; inline\r
+\r
INSTANCE: byte-vector growable\r
class-and\r
class-or\r
classes-intersect?\r
-}\r
-"Low-level implementation detail:"\r
-{ $subsections\r
flatten-class\r
- flatten-builtin-class\r
- class-types\r
- class-tags\r
} ;\r
\r
ARTICLE: "class-linearization" "Class linearization"\r
"Metaclass order:"\r
{ $subsections rank-class } ;\r
\r
-HELP: flatten-builtin-class\r
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
-{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;\r
-\r
HELP: flatten-class\r
{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;\r
\r
-HELP: class-types\r
-{ $values { "class" class } { "seq" "an increasing sequence of integers" } }\r
-{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;\r
-\r
HELP: class<=\r
{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }\r
{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }\r
classes.tuple accessors generic.private ;\r
IN: classes.algebra.tests\r
\r
-: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
+TUPLE: first-one ;\r
+TUPLE: second-one ;\r
+UNION: both first-one union-class ;\r
\r
-: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
+PREDICATE: no-docs < word "documentation" word-prop not ;\r
\r
-[ t ] [ object object object class-and* ] unit-test\r
-[ t ] [ fixnum object fixnum class-and* ] unit-test\r
-[ t ] [ object fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
-[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
+UNION: no-docs-union no-docs integer ;\r
\r
-[ t ] [ vector fixnum null class-and* ] unit-test\r
-[ t ] [ number object number class-and* ] unit-test\r
-[ t ] [ object number number class-and* ] unit-test\r
-[ t ] [ slice reversed null class-and* ] unit-test\r
-[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
-[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
+TUPLE: a ;\r
+TUPLE: b ;\r
+UNION: c a b ;\r
\r
-TUPLE: first-one ;\r
-TUPLE: second-one ;\r
-UNION: both first-one union-class ;\r
+TUPLE: tuple-example ;\r
\r
-[ t ] [ both tuple classes-intersect? ] unit-test\r
-[ t ] [ vector virtual-sequence null class-and* ] unit-test\r
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
+TUPLE: a1 ;\r
+TUPLE: b1 ;\r
+TUPLE: c1 ;\r
\r
-[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
+UNION: x1 a1 b1 ;\r
+UNION: y1 a1 c1 ;\r
+UNION: z1 b1 c1 ;\r
\r
-[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
+SINGLETON: sa\r
+SINGLETON: sb\r
+SINGLETON: sc\r
+\r
+INTERSECTION: empty-intersection ;\r
+\r
+INTERSECTION: generic-class generic class ;\r
\r
+UNION: union-with-one-member a ;\r
+\r
+MIXIN: mixin-with-one-member\r
+INSTANCE: union-with-one-member mixin-with-one-member\r
+\r
+! class<=\r
[ t ] [ \ fixnum \ integer class<= ] unit-test\r
[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
[ f ] [ \ integer \ fixnum class<= ] unit-test\r
[ f ] [ \ reversed \ slice class<= ] unit-test\r
[ f ] [ \ slice \ reversed class<= ] unit-test\r
\r
-PREDICATE: no-docs < word "documentation" word-prop not ;\r
-\r
-UNION: no-docs-union no-docs integer ;\r
-\r
[ t ] [ no-docs no-docs-union class<= ] unit-test\r
[ f ] [ no-docs-union no-docs class<= ] unit-test\r
\r
-TUPLE: a ;\r
-TUPLE: b ;\r
-UNION: c a b ;\r
-\r
[ t ] [ \ c \ tuple class<= ] unit-test\r
[ f ] [ \ tuple \ c class<= ] unit-test\r
\r
[ t ] [ \ tuple-class \ class class<= ] unit-test\r
[ f ] [ \ class \ tuple-class class<= ] unit-test\r
\r
-TUPLE: tuple-example ;\r
-\r
[ t ] [ \ null \ tuple-example class<= ] unit-test\r
[ f ] [ \ object \ tuple-example class<= ] unit-test\r
[ f ] [ \ object \ tuple-example class<= ] unit-test\r
[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
\r
-TUPLE: a1 ;\r
-TUPLE: b1 ;\r
-TUPLE: c1 ;\r
-\r
-UNION: x1 a1 b1 ;\r
-UNION: y1 a1 c1 ;\r
-UNION: z1 b1 c1 ;\r
-\r
[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
\r
[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
\r
-[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
-\r
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
\r
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\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
+[ t ] [ growable tuple sequence class-and class<= ] unit-test\r
\r
-[ t ] [\r
- growable assoc class-and tuple class<=\r
-] unit-test\r
+[ t ] [ growable assoc class-and tuple class<= ] unit-test\r
\r
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
\r
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
\r
-[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
-\r
[ t ] [ array number class-not class<= ] unit-test\r
\r
[ f ] [ bignum number class-not class<= ] unit-test\r
\r
-[ vector ] [ vector class-not class-not ] unit-test\r
-\r
[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
\r
[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
\r
[ t ] [ number class-not integer class-not class<= ] unit-test\r
\r
-[ t ] [ vector array class-not class-and vector class= ] unit-test\r
+[ f ] [ fixnum class-not integer class<= ] unit-test\r
+\r
+[ t ] [ object empty-intersection class<= ] unit-test\r
+[ t ] [ empty-intersection object class<= ] unit-test\r
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
+[ t ] [ \ number empty-intersection class<= ] unit-test\r
+[ t ] [ empty-intersection class-not null class<= ] unit-test\r
+[ t ] [ null empty-intersection class-not class<= ] unit-test\r
+\r
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
+\r
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
+\r
+[ t ] [\r
+ fixnum class-not\r
+ fixnum fixnum class-not class-or\r
+ class<=\r
+] unit-test\r
+\r
+[ t ] [ generic-class generic class<= ] unit-test\r
+[ t ] [ generic-class \ class class<= ] unit-test\r
+\r
+[ t ] [ a union-with-one-member class<= ] unit-test\r
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test\r
+\r
+! class-and\r
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
+\r
+[ t ] [ object object object class-and* ] unit-test\r
+[ t ] [ fixnum object fixnum class-and* ] unit-test\r
+[ t ] [ object fixnum fixnum class-and* ] unit-test\r
+[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
+[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
+[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
+\r
+[ t ] [ vector fixnum null class-and* ] unit-test\r
+[ t ] [ number object number class-and* ] unit-test\r
+[ t ] [ object number number class-and* ] unit-test\r
+[ t ] [ slice reversed null class-and* ] unit-test\r
+[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
+\r
+[ t ] [ vector virtual-sequence null class-and* ] unit-test\r
+\r
+[ t ] [ vector array class-not vector class-and* ] unit-test\r
+\r
+! class-or\r
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
+\r
+[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
+\r
+! class-not\r
+[ vector ] [ vector class-not class-not ] unit-test\r
+\r
+! classes-intersect?\r
+[ t ] [ both tuple classes-intersect? ] unit-test\r
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
+\r
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
+\r
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
+\r
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
+\r
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
+\r
+[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
\r
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
+[ t ] [ \ word generic-class classes-intersect? ] unit-test\r
+[ f ] [ number generic-class classes-intersect? ] unit-test\r
+\r
+[ f ] [ sa sb classes-intersect? ] unit-test\r
\r
+[ t ] [ a union-with-one-member classes-intersect? ] unit-test\r
+[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test\r
+[ t ] [ object union-with-one-member classes-intersect? ] unit-test\r
+\r
+[ t ] [ union-with-one-member a classes-intersect? ] unit-test\r
+[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test\r
+[ t ] [ union-with-one-member object classes-intersect? ] unit-test\r
+\r
+[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test\r
+[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test\r
+[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test\r
+\r
+[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test\r
+[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test\r
+[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test\r
+\r
+! class=\r
[ t ] [ null class-not object class= ] unit-test\r
\r
[ t ] [ object class-not null class= ] unit-test\r
\r
[ f ] [ null class-not null class= ] unit-test\r
\r
-[ t ] [\r
- fixnum class-not\r
- fixnum fixnum class-not class-or\r
- class<=\r
-] unit-test\r
+! class<=>\r
\r
-! Test method inlining\r
+[ +lt+ ] [ integer sequence class<=> ] unit-test\r
+[ +lt+ ] [ sequence object class<=> ] unit-test\r
+[ +gt+ ] [ object sequence class<=> ] unit-test\r
+[ +eq+ ] [ integer integer class<=> ] unit-test\r
+\r
+! smallest-class etc\r
[ real ] [ { real sequence } smallest-class ] unit-test\r
[ real ] [ { sequence real } smallest-class ] unit-test\r
\r
\r
[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
\r
-INTERSECTION: generic-class generic class ;\r
-\r
-[ t ] [ generic-class generic class<= ] unit-test\r
-[ t ] [ generic-class \ class class<= ] unit-test\r
-\r
-! Later\r
-[\r
- [ t ] [ \ class generic class-and generic-class class<= ] unit-test\r
- [ t ] [ \ class generic class-and generic-class swap class<= ] unit-test\r
-] drop\r
-\r
-[ t ] [ \ word generic-class classes-intersect? ] unit-test\r
-[ f ] [ number generic-class classes-intersect? ] unit-test\r
-\r
[ H{ { word word } } ] [ \r
generic-class flatten-class\r
] unit-test\r
\r
-[ \ + flatten-class ] must-fail\r
-\r
-INTERSECTION: empty-intersection ;\r
-\r
-[ t ] [ object empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection object class<= ] unit-test\r
-[ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
-[ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
-[ t ] [ \ number empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection class-not null class<= ] unit-test\r
-[ t ] [ null empty-intersection class-not class<= ] unit-test\r
-\r
-[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ ] [ object flatten-builtin-class drop ] unit-test\r
-\r
-SINGLETON: sa\r
-SINGLETON: sb\r
-SINGLETON: sc\r
-\r
[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
\r
-[ f ] [ sa sb classes-intersect? ] unit-test\r
-\r
-[ +lt+ ] [ integer sequence class<=> ] unit-test\r
-[ +lt+ ] [ sequence object class<=> ] unit-test\r
-[ +gt+ ] [ object sequence class<=> ] unit-test\r
-[ +eq+ ] [ integer integer class<=> ] unit-test\r
-\r
-! Limitations:\r
-\r
-! UNION: u1 sa sb ;\r
-! UNION: u2 sc ;\r
-\r
-! [ f ] [ u1 u2 classes-intersect? ] unit-test\r
+[ \ + flatten-class ] must-fail\r
kernel.private sets math.order ;\r
IN: classes.algebra\r
\r
-TUPLE: anonymous-union members ;\r
+<PRIVATE\r
\r
-C: <anonymous-union> anonymous-union\r
+TUPLE: anonymous-union { members read-only } ;\r
\r
-TUPLE: anonymous-intersection participants ;\r
+: <anonymous-union> ( members -- class )\r
+ [ null eq? not ] filter prune\r
+ dup length 1 = [ first ] [ anonymous-union boa ] if ;\r
\r
-C: <anonymous-intersection> anonymous-intersection\r
+TUPLE: anonymous-intersection { participants read-only } ;\r
\r
-TUPLE: anonymous-complement class ;\r
+: <anonymous-intersection> ( participants -- class )\r
+ prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;\r
+\r
+TUPLE: anonymous-complement { class read-only } ;\r
\r
C: <anonymous-complement> anonymous-complement\r
\r
+DEFER: (class<=)\r
+\r
+DEFER: (class-not)\r
+\r
+GENERIC: (classes-intersect?) ( first second -- ? )\r
+\r
+DEFER: (class-and)\r
+\r
+DEFER: (class-or)\r
+\r
+GENERIC: (flatten-class) ( class -- )\r
+\r
+: normalize-class ( class -- class' )\r
+ {\r
+ { [ dup members ] [ members <anonymous-union> normalize-class ] }\r
+ { [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }\r
+ [ ]\r
+ } cond ;\r
+\r
+PRIVATE>\r
+\r
GENERIC: valid-class? ( obj -- ? )\r
\r
M: class valid-class? drop t ;\r
M: anonymous-complement valid-class? class>> valid-class? ;\r
M: word valid-class? drop f ;\r
\r
-DEFER: (class<=)\r
-\r
: class<= ( first second -- ? )\r
class<=-cache get [ (class<=) ] 2cache ;\r
\r
-DEFER: (class-not)\r
-\r
-: class-not ( class -- complement )\r
- class-not-cache get [ (class-not) ] cache ;\r
-\r
-GENERIC: (classes-intersect?) ( first second -- ? )\r
+: class< ( first second -- ? )\r
+ {\r
+ { [ 2dup class<= not ] [ 2drop f ] }\r
+ { [ 2dup swap class<= not ] [ 2drop t ] }\r
+ [ [ rank-class ] bi@ < ]\r
+ } cond ;\r
\r
-: normalize-class ( class -- class' )\r
+: class<=> ( first second -- ? )\r
{\r
- { [ dup members ] [ members <anonymous-union> ] }\r
- { [ dup participants ] [ participants <anonymous-intersection> ] }\r
- [ ]\r
+ { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
+ { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
+ [ [ rank-class ] bi@ <=> ]\r
} cond ;\r
\r
+: class= ( first second -- ? )\r
+ [ class<= ] [ swap class<= ] 2bi and ;\r
+\r
+: class-not ( class -- complement )\r
+ class-not-cache get [ (class-not) ] cache ;\r
+\r
: classes-intersect? ( first second -- ? )\r
classes-intersect-cache get [\r
normalize-class (classes-intersect?)\r
] 2cache ;\r
\r
-DEFER: (class-and)\r
-\r
: class-and ( first second -- class )\r
class-and-cache get [ (class-and) ] 2cache ;\r
\r
-DEFER: (class-or)\r
-\r
: class-or ( first second -- class )\r
class-or-cache get [ (class-or) ] 2cache ;\r
\r
+<PRIVATE\r
+\r
: superclass<= ( first second -- ? )\r
swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
\r
[ class-not normalize-class ] map\r
<anonymous-union>\r
] }\r
+ [ <anonymous-complement> ]\r
} cond ;\r
\r
: left-anonymous-complement<= ( first second -- ? )\r
\r
: (class<=) ( first second -- ? )\r
2dup eq? [ 2drop t ] [\r
+ [ normalize-class ] bi@\r
2dup superclass<= [ 2drop t ] [\r
- [ normalize-class ] bi@ {\r
+ {\r
+ { [ 2dup eq? ] [ 2drop t ] }\r
{ [ dup empty-intersection? ] [ 2drop t ] }\r
{ [ over empty-union? ] [ 2drop t ] }\r
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
[ <anonymous-complement> ]\r
} cond ;\r
\r
-: class< ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop f ] }\r
- { [ 2dup swap class<= not ] [ 2drop t ] }\r
- [ [ rank-class ] bi@ < ]\r
- } cond ;\r
-\r
-: class<=> ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
- { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
- [ [ rank-class ] bi@ <=> ]\r
- } cond ;\r
+M: anonymous-union (flatten-class)\r
+ members>> [ (flatten-class) ] each ;\r
\r
-: class= ( first second -- ? )\r
- [ class<= ] [ swap class<= ] 2bi and ;\r
+PRIVATE>\r
\r
ERROR: topological-sort-failed ;\r
\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 [ swap remove-nth! ] dip ]\r
produce nip ;\r
\r
: smallest-class ( classes -- class/f )\r
[ ] [ [ class<= ] most ] map-reduce\r
] if-empty ;\r
\r
-GENERIC: (flatten-class) ( class -- )\r
-\r
-M: anonymous-union (flatten-class)\r
- members>> [ (flatten-class) ] each ;\r
-\r
: flatten-class ( class -- assoc )\r
[ (flatten-class) ] H{ } make-assoc ;\r
-\r
-: flatten-builtin-class ( class -- assoc )\r
- flatten-class [\r
- dup tuple class<= [ 2drop tuple tuple ] when\r
- ] assoc-map ;\r
-\r
-: class-types ( class -- seq )\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
builtin-class
builtin-class?
}
-"See " { $link "type-index" } " for a list of built-in classes." ;
+"See " { $link "class-index" } " for a list of built-in classes." ;
HELP: builtin-class
{ $class-description "The class of built-in classes." }
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra words kernel
-kernel.private namespaces sequences math math.private
-combinators assocs quotations ;
+USING: accessors classes classes.algebra classes.algebra.private
+words kernel kernel.private namespaces sequences math
+math.private combinators assocs quotations ;
IN: classes.builtin
SYMBOL: builtins
: 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 ;
[ swap classes-intersect? ]
} cond ;
-: full-cover ( -- ) builtins get sift [ (flatten-class) ] each ;
+: full-cover ( -- ) builtins get [ (flatten-class) ] each ;
M: anonymous-complement (flatten-class) drop full-cover ;
[ 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 )
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words accessors sequences kernel assocs combinators classes
-classes.algebra classes.builtin namespaces arrays math quotations ;
+classes.algebra classes.algebra.private classes.builtin
+namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
] 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
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra kernel namespaces make words
-sequences quotations arrays kernel.private assocs combinators ;
+USING: classes classes.algebra classes.algebra.private kernel
+namespaces make words sequences quotations arrays kernel.private
+assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra classes.predicate kernel
-sequences words ;
+USING: classes classes.algebra classes.algebra.private
+classes.predicate kernel sequences words ;
IN: classes.singleton
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
[ 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 ;
USING: arrays definitions hashtables kernel kernel.private math
namespaces make sequences sequences.private strings vectors
words quotations memory combinators generic classes
-classes.algebra classes.builtin classes.private slots.private
-slots math.private accessors assocs effects ;
+classes.algebra classes.algebra.private classes.builtin
+classes.private slots.private slots math.private accessors
+assocs effects ;
IN: classes.tuple
PREDICATE: tuple-class < class
} 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 )
[
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-classes.algebra namespaces arrays math quotations ;
+classes.algebra classes.algebra.private namespaces arrays math
+quotations ;
IN: classes.union
PREDICATE: union-class < class
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"
{ $notes "This word is used behind the scenes to compile " { $link cond } " forms efficiently; it can also be called directly, which is useful for meta-programming." } ;
HELP: case>quot
-{ $values { "assoc" "a sequence of pairs of quotations" } { "default" quotation } { "quot" quotation } }
+{ $values { "default" quotation } { "assoc" "a sequence of pairs of quotations" } { "quot" quotation } }
{ $description "Creates a quotation that when called, has the same effect as applying " { $link case } " to " { $snippet "assoc" } "."
$nl
"This word uses three strategies:"
[ [ [ ] 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
+ "A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
1 swap execute
] unit-test
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic source-files.errors ;
+classes.tuple.private generic source-files.errors
+kernel.private ;
IN: compiler.units
SYMBOL: old-definitions
\ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
+<PRIVATE
+
: add-once ( key assoc -- )
2dup key? [ over redefine-error ] when conjoin ;
: (remember-definition) ( definition loc assoc -- )
[ over set-where ] dip add-once ;
+PRIVATE>
+
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
HOOK: recompile compiler-impl ( words -- alist )
+HOOK: to-recompile compiler-impl ( -- words )
+
+HOOK: process-forgotten-words compiler-impl ( words -- )
+
+: compile ( words -- ) recompile modify-code-heap ;
+
! 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
[ definitions-changed ] with each ;
+! Incremented each time stack effects potentially changed, used
+! by compiler.tree.propagation.call-effect for call( and execute(
+! inline caching
+: effect-counter ( -- n ) 46 getenv ; inline
+
+GENERIC: bump-effect-counter* ( defspec -- ? )
+
+M: object bump-effect-counter* drop f ;
+
+<PRIVATE
+
: changed-vocabs ( assoc -- vocabs )
[ drop word? ] assoc-filter
[ drop vocabulary>> dup [ vocab ] when dup ] assoc-map ;
dup changed-definitions get update
dup dup changed-vocabs update ;
-: 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 ;
+: bump-effect-counter? ( -- ? )
+ changed-effects get new-words get assoc-diff assoc-empty? not
+ changed-definitions get [ drop bump-effect-counter* ] assoc-any?
+ or ;
+
+: bump-effect-counter ( -- )
+ bump-effect-counter? [ 46 getenv 0 or 1 + 46 setenv ] when ;
+
+: notify-observers ( -- )
+ updated-definitions dup assoc-empty?
+ [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
process-forgotten-definitions
modify-code-heap
- updated-definitions dup assoc-empty?
- [ drop ] [ notify-definition-observers notify-error-observers ] if ;
+ bump-effect-counter
+ notify-observers ;
+
+PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
+ H{ } clone new-words set
H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
+ H{ } clone new-words set
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
HELP: >continuation<
-{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } }
+{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc
HELP: restart
{ $values { "restart" restart } }
{ $description "Invokes a restart." }
-{ $class-description "The class of restarts." } ;
\ No newline at end of file
+{ $class-description "The class of restarts." } ;
{ $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
SYMBOL: outdated-generics
+SYMBOL: new-words
+
SYMBOL: new-classes
+: new-word ( word -- )
+ dup new-words get set-in-unit ;
+
+: new-word? ( word -- ? )
+ new-words get key? ;
+
: new-class ( word -- )
dup new-classes get set-in-unit ;
PRIVATE>
TUPLE: disposable < identity-tuple
-{ id integer }
{ disposed boolean }
continuation ;
-M: disposable hashcode* nip id>> ;
-
: new-disposable ( class -- disposable )
- new \ disposable counter >>id
- dup register-disposable ; inline
+ new dup register-disposable ; inline
GENERIC: dispose* ( disposable -- )
: parse-effect-tokens ( end -- tokens )
[ parse-effect-token dup ] curry [ ] produce nip ;
-ERROR: stack-effect-omits-dashes effect ;
+ERROR: stack-effect-omits-dashes tokens ;
: parse-effect ( end -- effect )
parse-effect-tokens { "--" } split1 dup
"(" expect ")" parse-effect ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect ] dip 2array over push-all ;
+ [ ")" parse-effect ] dip 2array append! ;
$low-level-note ;
HELP: define-generic
-{ $values { "word" word } { "effect" effect } { "combination" "a method combination" } }
+{ $values { "word" word } { "combination" "a method combination" } { "effect" effect } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
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
2dup (>>length)
] when 2drop ; inline
+M: growable new-resizable new-sequence 0 over set-length ; inline
+
INSTANCE: growable sequence
$nl
"In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots."
$nl
-"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ;
+"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words."
+{ $subsections hashcode hashcode* identity-hashcode } ;
ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:"
] { } 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 [
[ count>> ] [ deleted>> ] bi - ; inline
: rehash ( hash -- )
- dup >alist [
- dup clear-assoc
- ] dip (rehash) ;
+ dup >alist [ dup clear-assoc ] dip (rehash) ;
M: hashtable set-at ( value key hash -- )
dup ?grow-hash
: 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 ]
USING: arrays debugger.threads destructors io io.directories
-io.encodings.8-bit io.encodings.ascii io.encodings.binary
+io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test generic.single ;
+make math sequences system threads tools.test generic.single
+io.encodings.8-bit.latin1 ;
IN: io.files.tests
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [
"closing-twice" unique-file ascii <file-writer>
[ dispose ] [ dispose ] bi
-] unit-test
\ No newline at end of file
+] unit-test
: bl ( -- ) " " write ;
-<PRIVATE
-
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap while drop ; inline
-: stream-element-exemplar ( type -- exemplar )
+<PRIVATE
+
+: (stream-element-exemplar) ( type -- exemplar )
{
{ +byte+ [ B{ } ] }
{ +character+ [ "" ] }
- } case ;
+ } case ; inline
+
+: stream-element-exemplar ( stream -- exemplar )
+ stream-element-type (stream-element-exemplar) ;
: element-exemplar ( -- exemplar )
- input-stream get
- stream-element-type
- stream-element-exemplar ;
+ input-stream get stream-element-exemplar ; inline
PRIVATE>
+: each-stream-line ( stream quot -- )
+ swap [ stream-readln ] curry each-morsel ; inline
+
: each-line ( quot -- )
- [ readln ] each-morsel ; inline
+ input-stream get swap each-stream-line ; inline
+
+: stream-lines ( stream -- seq )
+ [ [ ] accumulator [ each-stream-line ] dip { } like ] with-disposal ;
: lines ( -- seq )
- [ ] accumulator [ each-line ] dip { } like ;
+ input-stream get stream-lines ; inline
-: stream-lines ( stream -- seq )
- [ lines ] with-input-stream ;
+: stream-contents ( stream -- seq )
+ [
+ [ [ 65536 swap stream-read-partial dup ] curry [ ] produce nip ]
+ [ stream-element-exemplar concat-as ] bi
+ ] with-disposal ;
: contents ( -- seq )
- [ 65536 read-partial dup ] [ ] produce nip
- element-exemplar concat-as ;
+ input-stream get stream-contents ; inline
-: stream-contents ( stream -- seq )
- [ contents ] with-input-stream ;
+: each-stream-block ( stream quot: ( block -- ) -- )
+ swap [ 8192 swap stream-read-partial ] curry each-morsel ; inline
: each-block ( quot: ( block -- ) -- )
- [ 8192 read-partial ] each-morsel ; inline
+ input-stream get swap each-stream-block ; inline
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]
-USING: help.markup help.syntax io.backend io.files io.directories strings
-sequences io.pathnames.private ;
+USING: help.markup help.syntax io.backend io.files
+io.directories strings system sequences io.pathnames.private ;
IN: io.pathnames
HELP: path-separator?
HELP: normalize-path
{ $values { "path" "a pathname string" } { "path'" "a new pathname string" } }
-{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present, and performs any platform-specific pathname normalization." }
+{ $description "Prepends the " { $link current-directory } " to the pathname, resolves a " { $snippet "resource:" } " or " { $snippet "vocab:" } " prefix, if present (see " { $link "io.pathnames.special" } "). Also converts the path into a UNC path on Windows." }
{ $notes "High-level words, such as " { $link <file-reader> } " and " { $link delete-file } " call this word for you. It only needs to be called directly when passing pathnames to C functions or external processes. This is because Factor does not use the operating system's notion of a current directory, and instead maintains its own dynamically-scoped " { $link current-directory } " variable." }
{ $notes "On Windows NT platforms, this word does prepends the Unicode path prefix." }
{ $examples
}
} ;
-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." } ;
+{ $description "Prepends the " { $link current-directory } " to the pathname and resolves a " { $snippet "resource:" } " or " { $snippet "voacb:" } " prefix, if present (see " { $link "io.pathnames.special" } ")." }
+{ $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." } ;
}
} ;
+ARTICLE: "io.pathnames.special" "Special pathnames"
+"If a pathname begins with " { $snippet "resource:" } ", it is resolved relative to the directory containing the current image (see " { $link image } ")."
+$nl
+"If a pathname begins with " { $snippet "vocab:" } ", then it will be searched for in all current vocabulary roots (see " { $link "add-vocab-roots" } ")." ;
+
+ARTICLE: "io.pathnames.presentations" "Pathname presentations"
+"Pathname presentations are objects that wrap a pathname string. Clicking a pathname presentation in the UI brings up the file in one of the supported editors. See " { $link "editor" } " for more details."
+{ $subsections
+ pathname
+ <pathname>
+}
+"Literal pathname presentations:"
+{ $subsections POSTPONE: P" }
+"Many words that accept pathname strings can also work on pathname presentations." ;
+
ARTICLE: "io.pathnames" "Pathnames"
-"Pathnames are objects that contain a string representing the path to a file on disk. Pathnames are cross-platform; Windows accepts both forward and backward slashes as directory separators and new separators are added as a forward slash on all platforms. Clicking a pathname object in the UI brings up the file in one of the supported editors, but otherwise, pathnames and strings are interchangeable. See " { $link "editor" } " for more details." $nl
+"Pathnames are strings that refer to a file on disk. Pathname semantics are platform-specific, and Factor makes no attempt to abstract away the differences. Note that on Windows, both forward and backward slashes are accepted as directory separators."
+$nl
"Pathname introspection:"
{ $subsections
parent-directory
prepend-path
append-path
}
-"Pathname presentations:"
-{ $subsections
- pathname
- <pathname>
-}
-"Literal pathnames:"
-{ $subsections POSTPONE: P" }
-"Low-level words:"
-{ $subsections
- normalize-path
- (normalize-path)
- canonicalize-path
-} ;
+"Normalizing pathnames:"
+{ $subsections normalize-path absolute-path resolve-symlinks }
+"Additional topics:"
+{ $subsections "io.pathnames.presentations" "io.pathnames.special" } ;
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
[ 2 head ] dip append
] }
[
- [ trim-tail-separators "/" ] dip
- trim-head-separators 3append
+ [ trim-tail-separators ]
+ [ trim-head-separators ] bi* "/" glue
]
} cond ;
: 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 ;
{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
HELP: with-byte-reader
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation } { "byte-array" byte-array } }
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
HELP: with-byte-writer
: 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 } }
{ $values { "obj" object } { "code" fixnum } }
{ $description "Computes the hashcode of an object with a default hashing depth. See " { $link hashcode* } " for the hashcode contract." } ;
-{ hashcode hashcode* } related-words
+HELP: identity-hashcode
+{ $values { "obj" object } { "code" fixnum } }
+{ $description "Outputs the identity hashcode of an object. The identity hashcode is not guaranteed to be unique, however it will not change during the object's lifetime." } ;
+
+{ hashcode hashcode* identity-hashcode } related-words
HELP: =
{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
{ $notes "This word implements boolean exclusive or, so applying it to integers will not yield useful results (all integers have a true value). Bitwise exclusive or is the " { $link bitxor } " word." } ;
HELP: both?
-{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to both " { $snippet "x" } " and " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 5 [ odd? ] both? ." "t" }
} ;
HELP: either?
-{ $values { "quot" { $quotation "( obj -- ? )" } } { "x" object } { "y" object } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( obj -- ? )" } } { "?" "a boolean" } }
{ $description "Tests if the quotation yields a true value when applied to either " { $snippet "x" } " or " { $snippet "y" } "." }
{ $examples
{ $example "USING: kernel math prettyprint ;" "3 6 [ odd? ] either? ." "t" }
{ $notes "Used to implement " { $link "threads" } "." } ;
HELP: keep
-{ $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
+{ $values { "x" object } { "quot" { $quotation "( x -- ... )" } } }
{ $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
{ $examples
{ $example "USING: arrays kernel prettyprint ;" "2 \"greetings\" [ <array> ] keep 2array ." "{ { \"greetings\" \"greetings\" } \"greetings\" }" }
} ;
HELP: 2keep
-{ $values { "quot" { $quotation "( x y -- ... )" } } { "x" object } { "y" object } }
+{ $values { "x" object } { "y" object } { "quot" { $quotation "( x y -- ... )" } } }
{ $description "Call a quotation with two values on the stack, restoring the values when the quotation returns." } ;
HELP: 3keep
-{ $values { "quot" { $quotation "( x y z -- ... )" } } { "x" object } { "y" object } { "z" object } }
+{ $values { "x" object } { "y" object } { "z" object } { "quot" { $quotation "( x y z -- ... )" } } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
HELP: bi
"[ 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 } }
{ $description "Reads an object from the Factor VM's environment table. User code never has to read the environment table directly; instead, use one of the callers of this word." } ;
HELP: setenv ( obj n -- )
-{ $values { "n" "a non-negative integer" } { "obj" object } }
+{ $values { "obj" object } { "n" "a non-negative integer" } }
{ $description "Writes an object to the Factor VM's environment table. User code never has to write to the environment table directly; instead, use one of the callers of this word." } ;
HELP: 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
[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
+
+[ t ] [ { } identity-hashcode fixnum? ] unit-test
+[ 123 ] [ 123 identity-hashcode ] unit-test
+[ t ] [ f identity-hashcode fixnum? ] unit-test
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
: 2bi@ ( w x y z quot -- )
dup 2bi* ; inline
-: 2tri@ ( u v w y x z quot -- )
+: 2tri@ ( u v w x y z quot -- )
dup dup 2tri* ; inline
! Quotation building
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
+: identity-hashcode ( obj -- code )
+ dup tag 0 eq? [
+ dup tag 1 eq? [ drop 0 ] [
+ dup (identity-hashcode) dup 0 eq? [
+ drop dup compute-identity-hashcode
+ (identity-hashcode)
+ ] [ nip ] if
+ ] if
+ ] unless ; inline
+
GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ; inline
M: identity-tuple equal? 2drop f ; inline
+M: identity-tuple hashcode* nip identity-hashcode ; inline
+
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [
2dup both-fixnums? [ 2drop f ] [ equal? ] if
: 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
+SYMBOL: header-bits
+
: 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 ;
+: tag-header ( n -- tagged )
+ header-bits get shift ;
+
: untag-fixnum ( n -- tagged )
tag-bits get neg shift ;
+: hashcode-shift ( -- n )
+ tag-bits get header-bits get + ;
+
! We do this in its own compilation unit so that they can be
! folded below
<<
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 -- )
IN: math.parser
: digit> ( ch -- n )
- H{
- { CHAR: 0 0 }
- { CHAR: 1 1 }
- { CHAR: 2 2 }
- { CHAR: 3 3 }
- { CHAR: 4 4 }
- { CHAR: 5 5 }
- { CHAR: 6 6 }
- { CHAR: 7 7 }
- { CHAR: 8 8 }
- { CHAR: 9 9 }
- { CHAR: A 10 }
- { CHAR: B 11 }
- { CHAR: C 12 }
- { CHAR: D 13 }
- { CHAR: E 14 }
- { CHAR: F 15 }
- { CHAR: a 10 }
- { CHAR: b 11 }
- { CHAR: c 12 }
- { CHAR: d 13 }
- { CHAR: e 14 }
- { CHAR: f 15 }
- { CHAR: , f }
- } at* [ drop 255 ] unless ; inline
+ 127 bitand {
+ { [ dup CHAR: 9 <= ] [ CHAR: 0 - ] }
+ { [ dup CHAR: a < ] [ CHAR: A 10 - - ] }
+ [ CHAR: a 10 - - ]
+ } cond
+ dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline
: string>digits ( str -- digits )
[ digit> ] B{ } map-as ; inline
: (digits>integer) ( valid? accum digit radix -- valid? accum )
- over [
- 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if
- ] [ 2drop ] if ; inline
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
: each-digit ( seq radix quot -- n/f )
[ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
: string>natural ( seq radix -- n/f )
over empty? [ 2drop f ] [
- [ [ digit> ] dip (digits>integer) ] each-digit
- ] if ; inline
+ [ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit
+ ] if ;
: sign ( -- str ) negative? get "-" "+" ? ;
] if ; inline
: dec>float ( str -- n/f )
- [ CHAR: , eq? not ] filter
- >byte-array 0 suffix (string>float) ;
+ [ CHAR: , eq? not ] BV{ } filter-as
+ 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
{
{ 16 [ hex>float ] }
[ drop dec>float ]
- } case ;
+ } case ; inline
: number-char? ( char -- ? )
- "0123456789ABCDEFabcdef." member? ;
+ "0123456789ABCDEFabcdef." member? ; inline
+
+: last-unsafe ( seq -- elt )
+ [ length 1 - ] [ nth-unsafe ] bi ; inline
: numeric-looking? ( str -- ? )
- "-" ?head drop
dup empty? [ drop f ] [
- dup first number-char? [
- last number-char?
- ] [ drop f ] if
- ] if ;
+ dup first-unsafe number-char? [
+ last-unsafe number-char?
+ ] [
+ dup first-unsafe CHAR: - eq? [
+ dup length 1 eq? [ drop f ] [
+ 1 over nth-unsafe number-char? [
+ last-unsafe number-char?
+ ] [ drop f ] if
+ ] if
+ ] [ drop f ] if
+ ] if
+ ] if ; inline
PRIVATE>
: string>float ( str -- n/f )
- 10 base>float ;
+ 10 base>float ; inline
: base> ( str radix -- n/f )
over numeric-looking? [
} case
] [ 2drop f ] if ;
-: string>number ( str -- n/f ) 10 base> ;
-: bin> ( str -- n/f ) 2 base> ;
-: oct> ( str -- n/f ) 8 base> ;
-: hex> ( str -- n/f ) 16 base> ;
+: string>number ( str -- n/f ) 10 base> ; inline
+: bin> ( str -- n/f ) 2 base> ; inline
+: oct> ( str -- n/f ) 8 base> ; inline
+: hex> ( str -- n/f ) 16 base> ; inline
: >digit ( n -- ch )
- dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ;
+ dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
: 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 )
{
{ 16 [ float>hex ] }
[ drop float>decimal ]
- } case ;
+ } case ; inline
PRIVATE>
: float>string ( n -- str )
- 10 float>base ;
+ 10 float>base ; inline
M: float >base
{
[ float>base ]
} cond ;
-: number>string ( n -- str ) 10 >base ;
-: >bin ( n -- str ) 2 >base ;
-: >oct ( n -- str ) 8 >base ;
-: >hex ( n -- str ) 16 >base ;
+: number>string ( n -- str ) 10 >base ; inline
+: >bin ( n -- str ) 2 >base ; inline
+: >oct ( n -- str ) 8 >base ; inline
+: >hex ( n -- str ) 16 >base ; inline
-: # ( n -- ) number>string % ;
+: # ( n -- ) number>string % ; inline
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
2 [ [ [ 3 throw ] instances ] must-fail ] times
! Bug found on Windows build box, having too many words in the image breaks 'become'
-[ ] [ 100000 [ f f <word> ] replicate { } { } become drop ] unit-test
+[ ] [ 100000 [ f <uninterned-word> ] replicate { } { } become drop ] unit-test
! 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." }
{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ;
HELP: parse-base
-{ $values { "base" "an integer between 2 and 36" } { "parsed" integer } }
+{ $values { "parsed" integer } { "base" "an integer between 2 and 36" } { "parsed" integer } }
{ $description "Reads an integer in a specific numerical base from the parser input." }
$parsing-note ;
{ $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 < [
dup string? [ dup length sbuf boa ] [ >sbuf ] if
] unless ; inline
-M: sbuf new-resizable drop <sbuf> ; inline
-
M: sbuf equal?
over sbuf? [ sequence= ] [ 2drop f ] if ;
M: string new-resizable drop <sbuf> ; inline
+M: sbuf new-resizable drop <sbuf> ; inline
+
M: string like
#! If we have a string, we're done.
#! If we have an sbuf, and it's at full capacity, we're done.
{ $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 ."
{ $description "Creates a three-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: 4sequence
-{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "obj3" object } { "obj4" object } { "seq" sequence } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "obj4" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a four-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: first2
} } ;
HELP: accumulate-as
-{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "exemplar" sequence } { "final" "the final result" } { "newseq" "a new sequence" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of the same type as " { $snippet "exemplar" } " containing 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."
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." } ;
HELP: accumulate
-{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
+{ $values { "seq" sequence } { "identity" object } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new array" } }
{ $description "Combines successive elements of the sequence using a binary operation, and outputs an array 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."
{ $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." } ;
HELP: map-as
-{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "newseq" "a new sequence" } { "exemplar" sequence } }
+{ $values { "seq" sequence } { "quot" { $quotation "( old -- new )" } } { "exemplar" sequence } { "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 " { $snippet "exemplar" } "." }
{ $examples
"The following example converts a string into an array of one-element strings:"
{ $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 -- ? )" } } { "subseq" "a new sequence" } }
{ $description "Applies the quotation to each element in turn, and outputs a new sequence 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-as
+{ $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!
+{ $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? } ")." } ;
} } ;
HELP: move
-{ $values { "from" "an index in " { $snippet "seq" } } { "to" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
+{ $values { "to" "an index in " { $snippet "seq" } } { "from" "an index in " { $snippet "seq" } } { "seq" "a mutable sequence" } }
{ $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" } ;
{ $side-effects "seq" } ;
HELP: replace-slice
-{ $values { "new" sequence } { "seq" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq'" sequence } }
+{ $values { "new" sequence } { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "seq'" sequence } }
{ $description "Replaces a range of elements beginning at index " { $snippet "from" } " and ending before index " { $snippet "to" } " with a new sequence." }
{ $errors "Throws an error if " { $snippet "new" } " contains elements whose types are not permissible in " { $snippet "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
}
"Filtering:"
{ $subsections
filter
+ filter-as
partition
}
"Testing if a sequence contains elements satisfying a predicate:"
"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
: push-if ( elt quot accum -- )
[ keep ] dip rot [ push ] [ 2drop ] if ; inline
+: pusher-for ( quot exemplar -- quot accum )
+ [ length ] keep new-resizable [ [ push-if ] 2curry ] keep ; inline
+
: pusher ( quot -- quot accum )
- V{ } clone [ [ push-if ] 2curry ] keep ; inline
+ V{ } pusher-for ; inline
+
+: filter-as ( seq quot exemplar -- subseq )
+ dup [ pusher-for [ each ] dip ] curry dip like ; inline
: filter ( seq quot -- subseq )
- over [ pusher [ each ] dip ] dip like ; inline
+ over filter-as ; inline
: push-either ( elt quot accum1 accum2 -- )
[ keep swap ] 2dip ? push ; inline
: partition ( seq quot -- trueseq falseseq )
over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
+: accumulator-for ( quot exemplar -- quot' vec )
+ [ length ] keep new-resizable [ [ push ] curry compose ] keep ; inline
+
: accumulator ( quot -- quot' vec )
- V{ } clone [ [ push ] curry compose ] keep ; inline
+ V{ } accumulator-for ; inline
: produce-as ( pred quot exemplar -- seq )
- [ accumulator [ while ] dip ] dip like ; inline
+ dup [ accumulator-for [ while ] dip ] curry dip like ; inline
: produce ( pred quot -- seq )
{ } produce-as ; 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 ; inline
+
+: append! ( seq1 seq2 -- seq1 ) over push-all ; inline
+
: 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 ;
M: source-file-error error-file [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line [ error>> error-line ] [ line#>> ] bi or ;
+M: source-file-error compute-restarts error>> compute-restarts ;
: sort-errors ( errors -- alist )
[ [ line#>> ] sort-with ] { } assoc-map-as sort-keys ;
: 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 -- )
} ;
HELP: record-checksum
-{ $values { "source-file" source-file } { "lines" "a sequence of strings" } }
+{ $values { "lines" "a sequence of strings" } { "source-file" source-file } }
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
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
HELP: <word> ( name vocab -- word )
{ $values { "name" string } { "vocab" string } { "word" word } }
-{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." } ;
+{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
HELP: gensym
{ $values { "word" word } }
HELP: create
{ $values { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." } ;
+{ $description "Creates a new word. If the vocabulary already contains a word with the requested name, outputs the existing word. The vocabulary must exist already; if it does not, you must call " { $link create-vocab } " first." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } ". Parsing words should call " { $link create-in } " instead of this word." } ;
HELP: constructor-word
{ $values { "name" string } { "vocab" string } { "word" word } }
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
-{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $examples { $example "USING: compiler.units prettyprint words ;" "[ \"salmon\" \"scratchpad\" constructor-word ] with-compilation-unit ." "<salmon>" } } ;
{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
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 ] [
\ plist-test "sample-property" word-prop
] unit-test
-"create-test" "scratchpad" create { 1 2 } "testing" set-word-prop
+[ ] [ [ "create-test" "scratchpad" create { 1 2 } "testing" set-word-prop ] with-compilation-unit ] unit-test
+
[ { 1 2 } ] [
"create-test" "scratchpad" lookup "testing" word-prop
] unit-test
[
[ t ] [ \ array? "array?" "arrays" lookup = ] unit-test
- [ ] [ "test-scope" "scratchpad" create drop ] unit-test
+ [ ] [ [ "test-scope" "scratchpad" create drop ] with-compilation-unit ] unit-test
] with-scope
[ "test-scope" ] [
DEFER: x
[ x ] [ undefined? ] must-fail-with
-[ ] [ "no-loc" "words.tests" create drop ] unit-test
+[ ] [ [ "no-loc" "words.tests" create drop ] with-compilation-unit ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test
[ { } ]
[
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 )
] tri ;
: <word> ( name vocab -- word )
- 2dup [ hashcode ] bi@ bitxor >fixnum (word) ;
+ 2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ;
+
+: <uninterned-word> ( name -- word )
+ f \ <uninterned-word> counter >fixnum (word) ;
: gensym ( -- word )
- "( gensym )" f \ gensym counter >fixnum (word) ;
+ "( gensym )" <uninterned-word> ;
: define-temp ( quot effect -- word )
[ gensym dup ] 2dip define-declared ;
+++ /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
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data alien.parser arrays
byte-arrays combinators effects.parser fry generalizations grouping kernel
-lexer locals macros make math math.ranges parser sequences sequences.private ;
+lexer locals macros make math math.ranges parser sequences
+sequences.generalizations sequences.private ;
FROM: alien.arrays => array-length ;
IN: alien.data.map
: 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 -- )
: fannkuch ( n -- )
[
- [ 0 0 ] dip [ 1 + ] B{ } map-as
+ [ 0 0 ] dip iota [ 1 + ] B{ } map-as
[ fannkuch-step ] each-permutation nip
] keep
"Pfannkuchen(" write pprint ") = " write . ;
[ 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: math kernel alien ;\r
+USING: math kernel alien alien.c-types ;\r
IN: benchmark.fib6\r
\r
: fib ( x -- y )\r
- "int" { "int" } "cdecl" [\r
+ int { int } "cdecl" [\r
dup 1 <= [ drop 1 ] [\r
1 - dup fib swap 1 - fib +\r
] if\r
] alien-callback\r
- "int" { "int" } "cdecl" alien-indirect ;\r
+ int { int } "cdecl" alien-indirect ;\r
\r
: fib-main ( -- ) 32 fib drop ;\r
\r
-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 ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.holidays calendar.holidays.canada kernel
+tools.test ;
+IN: calendar.holidays.canada.tests
+
+[ ] [ 2009 canada holidays drop ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar calendar.holidays ;
+IN: calendar.holidays.canada
+
+SINGLETONS: canada canadian-federal ;
+
+HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ;
+HOLIDAY-NAME: canadian-thanksgiving-day canadian-federal "Thanksgiving Day"
+
+HOLIDAY-NAME: armistice-day commonwealth-of-nations "Remembrance Day"
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar fry kernel parser sequences
+shuffle vocabs words memoize ;
+IN: calendar.holidays
+
+SINGLETONS: all world commonwealth-of-nations ;
+
+<<
+SYNTAX: HOLIDAY:
+ CREATE-WORD
+ dup "holiday" word-prop [
+ dup H{ } clone "holiday" set-word-prop
+ ] unless
+ parse-definition (( timestamp/n -- timestamp )) define-declared ;
+
+SYNTAX: HOLIDAY-NAME:
+ scan-word "holiday" word-prop scan-word scan-object spin set-at ;
+>>
+
+GENERIC: holidays ( n singleton -- seq )
+
+<PRIVATE
+
+: (holidays) ( singleton -- seq )
+ all-words swap '[ "holiday" word-prop _ swap key? ] filter ;
+
+M: object holidays
+ (holidays) [ execute( timestamp -- timestamp' ) ] with map ;
+
+PRIVATE>
+
+M: all holidays
+ drop
+ all-words [ "holiday" word-prop key? ] with filter ;
+
+: holiday? ( timestamp/n singleton -- ? )
+ [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
+
+: holiday-assoc ( timestamp singleton -- assoc )
+ (holidays) swap
+ '[ [ _ swap execute( ts -- ts' ) >gmt midnight ] keep ] { } map>assoc ;
+
+: holiday-name ( singleton word -- string/f )
+ "holiday" word-prop at ;
+
+: holiday-names ( timestamp/n singleton -- seq )
+ [
+ [ >gmt midnight ] dip
+ [ drop ] [ holiday-assoc ] 2bi swap
+ '[ drop _ same-day? ] assoc-filter values
+ ] keep '[ _ swap "holiday" word-prop at ] map ;
+
+HOLIDAY: armistice-day november 11 >>day ;
+HOLIDAY-NAME: armistice-day world "Armistice Day"
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.holidays calendar.holidays.us kernel sequences
+tools.test ;
+IN: calendar.holidays.us.tests
+
+[ 10 ] [ 2009 us-federal holidays length ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar calendar.holidays
+calendar.holidays.private combinators combinators.short-circuit
+fry kernel lexer math namespaces parser sequences shuffle
+vocabs words ;
+IN: calendar.holidays.us
+
+SINGLETONS: us us-federal ;
+
+<PRIVATE
+
+: adjust-federal-holiday ( timestamp -- timestamp' )
+ {
+ { [ dup saturday? ] [ 1 days time- ] }
+ { [ dup sunday? ] [ 1 days time+ ] }
+ [ ]
+ } cond ;
+
+PRIVATE>
+
+M: us-federal holidays
+ (holidays)
+ [ execute( timestamp -- timestamp' ) adjust-federal-holiday ] with map ;
+
+: us-post-office-open? ( timestamp -- ? )
+ { [ sunday? not ] [ us-federal holiday? not ] } 1&& ;
+
+HOLIDAY: new-years-day january 1 >>day ;
+HOLIDAY-NAME: new-years-day world "New Year's Day"
+HOLIDAY-NAME: new-years-day us-federal "New Year's Day"
+
+HOLIDAY: martin-luther-king-day january 3 monday-of-month ;
+HOLIDAY-NAME: martin-luther-king-day us-federal "Martin Luther King Day"
+
+HOLIDAY: inauguration-day year dup 4 neg rem + january 20 >>day ;
+HOLIDAY-NAME: inauguration-day us "Inauguration Day"
+
+HOLIDAY: washingtons-birthday february 3 monday-of-month ;
+HOLIDAY-NAME: washingtons-birthday us-federal "Washington's Birthday"
+
+HOLIDAY: memorial-day may last-monday-of-month ;
+HOLIDAY-NAME: memorial-day us-federal "Memorial Day"
+
+HOLIDAY: independence-day july 4 >>day ;
+HOLIDAY-NAME: independence-day us-federal "Independence Day"
+
+HOLIDAY: labor-day september 1 monday-of-month ;
+HOLIDAY-NAME: labor-day us-federal "Labor Day"
+
+HOLIDAY: columbus-day october 2 monday-of-month ;
+HOLIDAY-NAME: columbus-day us-federal "Columbus Day"
+
+HOLIDAY-NAME: armistice-day us-federal "Veterans Day"
+
+HOLIDAY: thanksgiving-day november 4 thursday-of-month ;
+HOLIDAY-NAME: thanksgiving-day us-federal "Thanksgiving Day"
+
+HOLIDAY: christmas-day december 25 >>day ;
+HOLIDAY-NAME: christmas-day world "Christmas Day"
+HOLIDAY-NAME: christmas-day us-federal "Christmas Day"
+
+HOLIDAY: belly-laugh-day january 24 >>day ;
+
+HOLIDAY: groundhog-day february 2 >>day ;
+
+HOLIDAY: lincolns-birthday february 12 >>day ;
+
+HOLIDAY: valentines-day february 14 >>day ;
+
+HOLIDAY: st-patricks-day march 17 >>day ;
+
+HOLIDAY: ash-wednesday easter 46 days time- ;
+
+ALIAS: first-day-of-lent ash-wednesday
+
+HOLIDAY: fat-tuesday ash-wednesday 1 days time- ;
+
+HOLIDAY: good-friday easter 2 days time- ;
+
+HOLIDAY: tax-day april 15 >>day ;
+
+HOLIDAY: earth-day april 22 >>day ;
+
+HOLIDAY: administrative-professionals-day april last-saturday-of-month wednesday ;
+
+HOLIDAY: cinco-de-mayo may 5 >>day ;
+
+HOLIDAY: mothers-day may 2 sunday-of-month ;
+
+HOLIDAY: armed-forces-day may 3 saturday-of-month ;
+
+HOLIDAY: flag-day june 14 >>day ;
+
+HOLIDAY: parents-day july 4 sunday-of-month ;
+
+HOLIDAY: grandparents-day labor-day 1 weeks time+ ;
+
+HOLIDAY: patriot-day september 11 >>day ;
+
+HOLIDAY: stepfamily-day september 16 >>day ;
+
+HOLIDAY: citizenship-day september 17 >>day ;
+
+HOLIDAY: bosss-day october 16 >>day ;
+
+HOLIDAY: sweetest-day october 3 saturday-of-month ;
+
+HOLIDAY: halloween october 31 >>day ;
+
+HOLIDAY: election-day november 1 monday-of-month 1 days time+ ;
+
+HOLIDAY: black-friday thanksgiving-day 1 days time+ ;
+
+HOLIDAY: pearl-harbor-remembrance-day december 7 >>day ;
+
+HOLIDAY: new-years-eve december 31 >>day ;
! 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! ;
[ f ] [ D: -1 D: -2 before? ] unit-test
[ f ] [ D: -2 D: -2 before? ] unit-test
[ t ] [ D: -3 D: -2 before? ] unit-test
+[ t ] [ D: .5 D: 0 D: 1.0 between? ] unit-test
: 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' )
- [ drop ]
- [ scale-mantissas <decimal> nip ] 2bi ;
+ 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
e1
e2 a + - <decimal> ;
+
+M: decimal <=>
+ 2dup before? [ 2drop +lt+ ] [ equal? +eq+ +gt+ ? ] if ; inline
: @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
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-name "drills" }
- { deploy-c-types? t }
- { "stop-after-last-window?" t }
- { deploy-unicode? t }
- { deploy-threads? t }
- { deploy-reflection 6 }
- { deploy-word-defs? t }
- { deploy-math? t }
- { deploy-ui? t }
- { deploy-word-props? t }
- { deploy-io 3 }
-}
+++ /dev/null
-USING: arrays cocoa.dialogs combinators continuations
-fry grouping io.encodings.utf8 io.files io.styles kernel math
-math.parser models models.arrow models.history namespaces random
-sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
-wrap.strings system ;
-EXCLUDE: accessors => change-model ;
-IN: drills.deployed
-SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
-
-: show ( model -- gadget ) dup it set-global [ random ] <arrow>
- { [ [ first ] card ]
- [ [ second ] card ]
- [ '[ |<< it get _ model-changed ] "No" op ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- } cleave
-2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-
-: drill ( -- ) [
- open-panel [
- [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
- ] [ 0 exit ] if*
-] with-ui ;
-
-MAIN: drill
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: arrays cocoa.dialogs combinators continuations
-fry grouping io.encodings.utf8 io.files io.styles kernel math
-math.parser models models.arrow models.history namespaces random
-sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
-wrap.strings ;
-EXCLUDE: accessors => change-model ;
-
-IN: drills
-SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
-
-: show ( model -- gadget ) dup it set-global [ random ] <arrow>
- { [ [ first ] card ]
- [ [ second ] card ]
- [ '[ |<< it get _ model-changed ] "No" op ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- } cleave
-2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-
-: drill ( -- ) [
- open-panel [
- [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
- ] when*
-] with-ui ;
-
-MAIN: drill
\ No newline at end of file
+++ /dev/null
-unportable
: 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 ;
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators combinators.smart csv io.encodings.8-bit
-math.parser memoize sequences kernel unicode.categories money ;
+math.parser memoize sequences kernel unicode.categories money
+io.encodings.8-bit.latin1 ;
IN: geobytes
! GeoBytes is not free software.
}
{ $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
combinators.short-circuit game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
-io io.encodings.ascii io.files io.files.temp kernel math
-math.matrices math.parser math.vectors method-chains sequences
-splitting threads ui ui.gadgets ui.gadgets.worlds
-ui.pixel-formats specialized-arrays specialized-vectors ;
+io io.encodings.ascii io.files io.files.temp kernel locals math
+math.matrices math.vectors.simd math.parser math.vectors
+method-chains namespaces sequences splitting threads ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats specialized-arrays
+specialized-vectors ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
+SIMD: float
IN: gpu.demos.bunny
GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
{ f float-components 1 f }
{ "normal" float-components 3 f }
{ f float-components 1 f } ;
-VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+
+STRUCT: bunny-vertex-struct
+ { vertex float-4 }
+ { normal float-4 } ;
SPECIALIZED-VECTOR: bunny-vertex-struct
{ "texcoord-scale" vec2-uniform f }
{ "loading-texture" texture-uniform f } ;
-: numbers ( str -- seq )
- " " split [ string>number ] map sift ;
+: numbers ( tokens -- seq )
+ [ string>number ] map ; inline
: <bunny-vertex> ( vertex -- struct )
bunny-vertex-struct <struct>
- swap >float-array >>vertex ; inline
+ swap first3 0.0 float-4-boa >>vertex ; inline
+
+: (read-line-tokens) ( seq stream -- seq )
+ " \n" over stream-read-until
+ [ [ pick push ] unless-empty ]
+ [
+ {
+ { CHAR: \s [ (read-line-tokens) ] }
+ { CHAR: \n [ drop ] }
+ [ 2drop [ f ] when-empty ]
+ } case
+ ] bi* ; inline recursive
+
+: stream-read-line-tokens ( stream -- seq )
+ V{ } clone swap (read-line-tokens) ;
+
+: each-line-tokens ( quot -- )
+ input-stream get [ stream-read-line-tokens ] curry each-morsel ; inline
: (parse-bunny-model) ( vs is -- vs is )
- readln [
+ [
numbers {
- { [ dup length 5 = ] [ 3 head <bunny-vertex> pick push ] }
- { [ dup first 3 = ] [ rest over push-all ] }
+ { [ dup length 5 = ] [ <bunny-vertex> pick push ] }
+ { [ dup first 3 = ] [ rest append! ] }
[ drop ]
- } cond (parse-bunny-model)
- ] when* ;
+ } cond
+ ] each-line-tokens ; inline
: parse-bunny-model ( -- vertexes indexes )
100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
- (parse-bunny-model) ;
+ (parse-bunny-model) ; inline
-: normal ( vertexes -- normal )
- [ [ second ] [ first ] bi v- ]
- [ [ third ] [ first ] bi v- ] bi cross
- vneg normalize ; inline
+:: normal ( a b c -- normal )
+ c a v-
+ b a v- cross normalize ; inline
-: calc-bunny-normal ( vertexes indexes -- )
- swap
- [ [ nth vertex>> ] curry { } map-as normal ]
- [ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
+:: calc-bunny-normal ( a b c vertexes -- )
+ a b c [ vertexes nth vertex>> ] tri@ normal :> n
+ a b c [ vertexes nth [ n v+ ] change-normal drop ] tri@ ; inline
: calc-bunny-normals ( vertexes indexes -- )
- 3 <groups>
- [ calc-bunny-normal ] with each ;
+ 3 <sliced-groups> swap
+ [ [ first3 ] dip calc-bunny-normal ] curry each ; inline
: normalize-bunny-normals ( vertexes -- )
- [ [ normalize ] change-normal drop ] each ;
+ [ [ normalize ] change-normal drop ] each ; inline
: bunny-data ( filename -- vertexes indexes )
ascii [ parse-bunny-model ] with-file-reader
[ 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 ;
] [ nip ] if ":" join ;
: replace-log-line-numbers ( object log -- log' )
- "\n" split [ empty? not ] filter
+ "\n" split harvest
[ replace-log-line-number ] with map
"\n" join ;
: 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
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
-destructors arrays sequences ;
+USING: accessors concurrency.mailboxes kernel calendar io.sockets
+destructors arrays sequences io.encodings.8-bit.latin1 ;
IN: irc.client.chats
CONSTANT: irc-port 6667 ! Default irc port
irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
: /JOIN ( channel password -- )
- [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+ [ " :" glue ] when* "JOIN " prepend irc-print ;
: try-connect ( -- stream/f )
irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry irc.client irc.client.chats kernel namespaces
-sequences threads io.encodings.8-bit io.launcher io splitting
-make mason.common mason.updates calendar math alarms ;
+sequences threads io.launcher io splitting
+make mason.common mason.updates calendar math alarms
+io.encodings.8-bit.latin1 ;
IN: irc.gitbot
: bot-profile ( -- obj )
USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
io.files io.pathnames irc.client irc.client.chats irc.messages
irc.messages.base kernel make namespaces sequences threads
-irc.logbot.log-line ;
+irc.logbot.log-line io.encodings.8-bit.latin1 ;
IN: irc.logbot
CONSTANT: bot-channel "#concatenative"
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
target-os get target-cpu get arch ;
: boot-image-name ( -- string )
- "boot." boot-image-arch ".image" 3append ;
+ boot-image-arch "boot." ".image" surround ;
[ [ 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 * + ;
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models models.arrow sequences monads ;
-IN: models.combinators
-
-HELP: merge
-{ $values { "models" "a list of models" } { "model" basic-model } }
-{ $description "Creates a model that merges the updates of others" } ;
-
-HELP: filter-model
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
-{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
-
-HELP: fold
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: switch-models
-{ $values { "model1" model } { "model2" model } { "model'" model } }
-{ $description "Creates a model that starts with the behavior of model2 and switches to the behavior of model1 on its update" } ;
-
-HELP: <mapped>
-{ $values { "model" model } { "quot" "applied to model's value on updates" } { "model" model } }
-{ $description "An expanded version of " { $link <arrow> } ". Use " { $link fmap } " instead." } ;
-
-HELP: when-model
-{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
-{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
-
-HELP: with-self
-{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
-{ $description "Fixed points for models: the quot reacts to the same model to gives" } ;
-
-HELP: #1
-{ $values { "model" model } { "model'" model } }
-{ $description "Moves a model to the top of its dependencies' connections, thus being notified before the others" } ;
-
-ARTICLE: "models.combinators" "Extending models"
-"The " { $vocab-link "models.combinators" } " library expands models to have discrete start and end times. "
-"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
-"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
-
-ABOUT: "models.combinators"
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays kernel models models.product monads
-sequences sequences.extras ;
-FROM: syntax => >> ;
-IN: models.combinators
-
-TUPLE: multi-model < model important? ;
-GENERIC: (model-changed) ( model observer -- )
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
-M: multi-model model-activated dup dependencies>> [ value>> ] find nip
- [ swap model-changed ] [ drop ] if* ;
-
-: #1 ( model -- model' ) t >>important? ;
-
-IN: models
-: notify-connections ( model -- )
- dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all
- [ second tuck [ remove ] dip prefix ] each
- [ model-changed ] with each ;
-IN: models.combinators
-
-TUPLE: basic-model < multi-model ;
-M: basic-model (model-changed) [ value>> ] dip set-model ;
-: merge ( models -- model ) basic-model <multi-model> ;
-: 2merge ( model1 model2 -- model ) 2array merge ;
-: <basic> ( value -- model ) basic-model new-model ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
- [ set-model ] [ 2drop ] if ;
-: filter-model ( model quot -- filter-model ) [ 1array \ filter-model <multi-model> ] dip >>quot ;
-
-TUPLE: fold-model < multi-model quot base values ;
-M: fold-model (model-changed) 2dup base>> =
- [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
- [ [ [ value>> ] [ values>> ] bi* push ]
- [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
- ] if ;
-M: fold-model model-activated drop ;
-: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
-: fold ( model oldval quot -- model ) rot 1array new-fold-model swap >>quot
- swap >>value ;
-: fold* ( model oldmodel quot -- model ) over [ [ 2array new-fold-model ] dip >>quot ]
- dip [ >>base ] [ value>> >>value ] bi ;
-
-TUPLE: updater-model < multi-model values updates ;
-M: updater-model (model-changed) [ tuck updates>> =
- [ [ values>> value>> ] keep set-model ]
- [ drop ] if ] keep f swap (>>value) ;
-: updates ( values updates -- model ) [ 2array updater-model <multi-model> ] 2keep
- [ >>values ] [ >>updates ] bi* ;
-
-SYMBOL: switch
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model (model-changed) 2dup switcher>> =
- [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ]
- [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
-: switch-models ( model1 model2 -- model' ) swap [ 2array switch-model <multi-model> ] 2keep
- [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: >behavior ( event -- behavior ) t >>value ;
-
-TUPLE: mapped-model < multi-model model quot ;
-: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
- <multi-model> swap >>quot swap >>model ;
-: <mapped> ( model quot -- model ) mapped-model new-mapped-model ;
-M: mapped-model (model-changed)
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
- set-model ;
-
-TUPLE: side-effect-model < mapped-model ;
-M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
-
-TUPLE: quot-model < mapped-model ;
-M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
-
-TUPLE: action-value < basic-model parent ;
-: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
-M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
-
-TUPLE: action < multi-model quot ;
-M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
- [ swap add-connection ] 2keep model-changed ;
-: <action> ( model quot -- action-model ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
-
-TUPLE: collection < multi-model ;
-: <collection> ( models -- product ) collection <multi-model> ;
-M: collection (model-changed)
- nip
- dup dependencies>> [ value>> ] all?
- [ dup [ value>> ] product-value swap set-model ]
- [ drop ] if ;
-M: collection model-activated dup (model-changed) ;
-
-! for side effects
-TUPLE: (when-model) < multi-model quot cond ;
-: when-model ( model quot cond -- model ) rot 1array (when-model) <multi-model> swap >>cond swap >>quot ;
-M: (when-model) (model-changed) [ quot>> ] 2keep
- [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
-
-! only used in construction
-: 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
+++ /dev/null
-Model combination and manipulation
\ No newline at end of file
+++ /dev/null
-USING: kernel sequences functors fry macros generalizations ;
-IN: models.combinators.templates
-FROM: models.combinators => <collection> #1 ;
-FUNCTOR: fmaps ( W -- )
-W IS ${W}
-w-n DEFINES ${W}-n
-w-2 DEFINES 2${W}
-w-3 DEFINES 3${W}
-w-4 DEFINES 4${W}
-w-n* DEFINES ${W}-n*
-w-2* DEFINES 2${W}*
-w-3* DEFINES 3${W}*
-w-4* DEFINES 4${W}*
-WHERE
-MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
-: w-2 ( a b quot -- mapped ) 2 w-n ; inline
-: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
-: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
-MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
-: w-2* ( a b quot -- mapped ) 2 w-n* ; inline
-: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
-: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
-;FUNCTOR
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors models models.arrow inverse kernel ;
+IN: models.illusion
+
+TUPLE: illusion < arrow ;
+
+: <illusion> ( model quot -- illusion )
+ illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
+ swap >>quot over >>model [ add-dependency ] keep ;
+
+: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
+
+: backtalk ( value object -- )
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+
+M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
--- /dev/null
+Two Way Arrows
\ No newline at end of file
] 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
: asc ( key -- spec ) 1 2array ; inline
: desc ( key -- spec ) -1 2array ; inline
-GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
-
-M: mdb-query-msg sort
+: sort ( mdb-query-msg sort-quot -- mdb-query-msg )
output>array [ 1array >hashtable ] map >>orderby ; inline
: key-spec ( spec-quot -- spec-assoc )
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
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators system vocabs.loader ;
+IN: monotonic-clock
+
+HOOK: monotonic-count os ( -- n )
+
+{
+ { [ os unix? ] [ "monotonic-clock.unix" ] }
+ { [ os windows? ] [ "monotonic-clock.windows" ] }
+ { [ os macosx? ] [ "monotonic-clock.unix.macosx" ] }
+} cond require
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.syntax classes.struct kernel math
+monotonic-clock system unix.types ;
+IN: monotonic-clock.unix.macosx
+
+STRUCT: mach_timebase_info
+ { numer uint32_t }
+ { denom uint32_t } ;
+
+TYPEDEF: mach_timebase_info* mach_timebase_info_t
+TYPEDEF: mach_timebase_info mach_timebase_info_data_t
+
+FUNCTION: uint64_t mach_absolute_time ( ) ;
+FUNCTION: kern_return_t mach_timebase_info ( mach_timebase_info_t info ) ;
+FUNCTION: kern_return_t mach_wait_until ( uint64_t deadline ) ;
+
+ERROR: mach-timebase-info ret ;
+
+M: macosx monotonic-count
+ mach_absolute_time
+ \ mach_timebase_info <struct> [
+ mach_timebase_info [ mach-timebase-info ] unless-zero
+ ] keep [ numer>> ] [ denom>> ] bi / * ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax calendar.unix classes.struct
+kernel monotonic-clock system unix unix.time unix.types ;
+IN: monotonic-clock.unix
+
+LIBRARY: librt
+
+FUNCTION: int clock_settime ( clockid_t clock_id, timespec* tp ) ;
+FUNCTION: int clock_gettime ( clockid_t clock_id, timespec* tp ) ;
+FUNCTION: int clock_getres ( clockid_t clock_id, timespec* res ) ;
+
+CONSTANT: CLOCK_REALTIME 0
+CONSTANT: CLOCK_MONOTONIC 1
+CONSTANT: CLOCK_PROCESS_CPUTIME_ID 2
+CONSTANT: CLOCK_THREAD_CPUTIME_ID 3
+
+CONSTANT: TIMER_ABSTIME 1
+
+M: unix monotonic-count
+ CLOCK_MONOTONIC timespec <struct> [ clock_gettime io-error ] keep
+ timespec>nanoseconds ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data fry kernel monotonic-clock
+system windows.errors windows.kernel32 ;
+IN: monotonic-clock.windows
+
+<PRIVATE
+
+: execute-performance-query ( word -- n )
+ [ "LARGE_INTEGER*" <c-object> ] dip
+ '[ _ execute win32-error=0/f ] keep *ulonglong ; inline
+
+PRIVATE>
+
+M: windows monotonic-count ( -- n )
+ \ QueryPerformanceCounter execute-performance-query ;
+
+: cpu-frequency ( -- n )
+ \ QueryPerformanceFrequency execute-performance-query ;
: 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 )
\ fake H{ } clone "multi-methods" set-word-prop
<< (( -- )) \ fake set-stack-effect >>
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+[
+ [ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
+ [ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+ [ { } \ fake method-word-props ] unit-test
-[ t ] [ { } \ fake <method> method-body? ] unit-test
+ [ t ] [ { } \ fake <method> method-body? ] unit-test
-[
[ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
[ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
dup { [ byte-array? ] [ length 512 >= ] } 1&&
[ invalid-perlin-noise-table ] unless ;
-! XXX doesn't work for NaNs or floats > 2^31
+! XXX doesn't work when v is nan or |v| >= 2^31
: floor-vector ( v -- v' )
[ float-4 int-4 vconvert int-4 float-4 vconvert ]
[ [ v> -1.0 float-4-with vand ] curry keep v+ ] bi ; inline
:: (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
USING: namespaces math partial-continuations tools.test
-kernel sequences ;
+kernel sequences fry ;
IN: partial-continuations.tests
SYMBOL: sum
: range ( r from to -- n )
over - 1 + rot [
- -rot [ over + pick call drop ] each 2drop f
+ '[ over + @ drop ] each drop f
] bshift 2nip ; inline
[ 55 ] [
: 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# ;
--- /dev/null
+Elie Chaftari
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs help.markup help.syntax kernel math
+sequences strings ;
+IN: pop3
+
+HELP: <pop3-account>
+{ $values
+
+ { "pop3-account" pop3-account }
+}
+{ $description "creates a " { $link pop3-account } " object with defaults for the port and timeout slots." } ;
+
+HELP: account
+{ $values
+
+ { "pop3-account" pop3-account }
+}
+{ $description "You only need to call " { $link connect } " after calling this word to reconnect to the latest accessed POP3 account." }
+{ $examples
+ { $code
+ "account connect"
+ ""
+ }
+} ;
+
+HELP: >user
+{ $values
+ { "name" "userID of the account" }
+}
+{ $description "Sends the userID of the account on the POP3 server (this could be the full e-mail address)" $nl
+"This must be the first command after " { $link connect } " if username and password have not been set with " { $link <pop3-account> } "."
+} ;
+
+HELP: >pwd
+{ $values
+ { "password" "password for the userID" }
+}
+{ $description "Sends the clear-text password for the userID. The password may be case sensitive. This must be the next command after " { $link >user } "." } ;
+
+HELP: capa
+{ $values
+
+ { "array" array }
+}
+{ $description "Queries the mail server capabilities, as described in RFC 2449. It is advised to check for command support before calling the appropriate words (e.g. TOP UIDL)." } ;
+
+HELP: connect
+{ $values
+ { "pop3-account" pop3-account }
+}
+{ $description "Opens a network connection to the pop3 mail server with the settings given in the pop3-account slots." }
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ " \"username@yourisp.com\" >>user"
+ " \"pass123\" >>pwd"
+ "connect"
+ ""
+ }
+} ;
+
+HELP: consolidate
+{ $values
+
+ { "seq" sequence }
+}
+{ $description "Builds a sequence of email tuples, iterating over each email top and consolidating its headers with its number, uidl, and size." } ;
+
+HELP: delete
+{ $values
+ { "message#" fixnum }
+}
+{ $description "This marks message number message# for deletion from the server. This is the way to get rid of a problem causing message. It is not actually deleted until the " { $link close } " word is issued. If you lose the connection to the mail server before calling the " { $link close } " word, the server should not delete any messages. Example: 3 delete" } ;
+
+HELP: headers
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Gathers and associates the From:, Subject:, and To: headers of each message." } ;
+
+HELP: list
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Lists each message with its number and size in bytes" } ;
+
+HELP: pop3-account
+{ $class-description "A POP3 account on a POP3 server. It has the following slots:"
+ { $table
+ { { $slot "#" } "The ephemeral ordinal number of the message." }
+ { { $slot "host" } "The name or IP address of the remote host to which a POP3 connection is required." }
+ { { $slot "port" } "The POP3 server port (defaults to 110)." }
+ { { $slot "timeout" } "Maximum time in minutes to wait for a response from the POP3 server (defaults to 1 minutes)." }
+ { { $slot "user" } "The userID of the account on the POP3 server." }
+ { { $slot "pwd" } { "The clear-text password for the userID." } }
+ { { $slot "stream" } { "The duplex input/output stream wrapping the POP3 session." } }
+ { { $slot "capa" } { "A list of the mail server capabilities." } }
+ { { $slot "count" } { "Number of messages in the mailbox." } }
+ { { $slot "list" } { "A list of every message with its number and size in bytes" } }
+ { { $slot "uidls" } { "The UIDL (Unique IDentification Listing) of every message in the mailbox together with its ordinal number." } }
+ { { $slot "messages" } { "A sequence of email tuples in the mailbox containing each email's headers, number, uidl, and size." } }
+ }
+"The " { $slot "host" } " is required; the rest are either set by default or optional." $nl
+"The " { $slot "user" } " and " { $slot "pwd" } " must either be set before using " { $link connect } " or immediately after it with the " { $link >user } " and " { $link >pwd } " words."
+} ;
+
+HELP: message
+{ $class-description "An e-mail message having the following slots:"
+ { $table
+ { { $slot "#" } "The ephemeral ordinal number of the message." }
+ { { $slot "uidl" } "The POP3 UIDL (Unique IDentification Listing) of the message." }
+ { { $slot "headers" } "The From:, Subject:, and To: headers of the message." }
+ { { $slot "from" } "The sender of the message. An e-mail address." }
+ { { $slot "to" } "The recipients of the message." }
+ { { $slot "subject" } { "The subject of the message." } }
+ { { $slot "size" } { "The size of the message in octets." } }
+ }
+} ;
+
+HELP: close
+{ $description "Deletes any messages marked for deletion, and then logs you off of the mail server. This is the last command to use." } ;
+
+HELP: retrieve
+{ $values
+ { "message#" fixnum }
+ { "seq" sequence }
+}
+{ $description "Sends message number message# to you. You should prepare for some base64 decoding. You probably want to do this with a mailer." } ;
+
+HELP: reset
+{ $description "Resets the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted." } ;
+
+HELP: count
+{ $values
+
+ { "n" fixnum }
+}
+{ $description "Gets the number of messages in the mailbox." } ;
+
+HELP: top
+{ $values
+ { "message#" fixnum } { "#lines" fixnum }
+ { "seq" sequence }
+}
+{ $description "Lists the header for message# and the first #lines of the message text. For example, 1 0 top would list just the headers for message 1, where as 1 5 top would list the headers and first 5 lines of the message text." } ;
+
+HELP: uidl
+{ $values
+ { "message#" fixnum }
+ { "uidl" string }
+}
+{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of the given message#." } ;
+
+HELP: uidls
+{ $values
+
+ { "assoc" assoc }
+}
+{ $description "Gets the POP3 UIDL (Unique IDentification Listing) of every specific message in the mailbox together with its ordinal number. UIDL provides a mechanism that avoids numbering issues between POP3 sessions by assigning a permanent and unique ID for each message." } ;
+
+ARTICLE: "pop3" "POP3 client library"
+"The " { $vocab-link "pop3" } " vocab implements a client interface to the POP3 protocol, enabling a Factor application to talk to POP3 servers. It allows interactive sessions similar to telnet ones to do maintenance on your mailbox on a POP3 mail server; to look at, and possibly delete, any problem causing message (e.g. too large, improperly formatted, etc.)." $nl
+"Word names do not necessarily map directly to POP3 commands defined in RFC1081 or RFC1939, although most commands are supported." $nl
+"This article assumes that you are familiar with the POP3 protocol."
+$nl
+"Connecting to the mail server:"
+{ $subsections connect }
+"You need to construct a pop3-account tuple first, setting at least the host slot."
+{ $subsections <pop3-account> }
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ " \"username@yourisp.com\" >>user"
+ " \"pass123\" >>pwd"
+ "connect"
+ ""
+ }
+}
+$nl
+"If you do not supply the username or password, you will need to call the " { $link >user } " and " { $link >pwd } " vocabs in this order after the " { $link connect } " vocab."
+{ $examples
+ { $code "USING: accessors pop3 ;"
+ "<pop3-account>"
+ " \"pop.yourisp.com\" >>host"
+ "connect"
+ ""
+ "\"username@yourisp.com\" >user"
+ "\"pass123\" >pwd"
+ ""
+ }
+}
+$nl
+{ $notes "Subsequent calls to the " { $link pop3-account } " thus created can be done by calling the " { $link account } " word. If you needed to reconnect to the same POP3 account after having called " { $link close } ", you only need to call " { $link account } " followed by " { $link connect } "." }
+$nl
+"Querying the mail server:"
+$nl
+"For its capabilities:"
+{ $subsections capa }
+{ $examples
+ { $code
+ "capa ."
+ "{ \"CAPA\" \"TOP\" \"UIDL\" }"
+ ""
+ }
+}
+$nl
+"For the message count:"
+{ $subsections count }
+{ $examples
+ { $code
+ "count ."
+ "2"
+ ""
+ }
+}
+$nl
+"For each message's size:"
+{ $subsections list }
+{ $examples
+ { $code
+ "list ."
+ "H{ { 1 \"1006\" } { 2 \"747\" } }"
+ ""
+ }
+}
+$nl
+"For a specific message raw header, appropriate headers, or number of lines:"
+{ $subsections top }
+{ $examples
+ { $code
+ "1 0 top ."
+ "<the raw-source of the message header is retrieved>"
+ ""
+ }
+ { $code
+ "1 5 top ."
+ "<the raw-source of the message header and its first 5 lines are retrieved>"
+ ""
+ }
+ { $code
+ "1 0 top headers ."
+ "H{"
+ " { \"From:\" \"from@mail.com\" }"
+ " { \"Subject:\" \"Re:\" }"
+ " { \"To:\" \"username@host.com\" }"
+ "}"
+ ""
+ }
+}
+$nl
+"To consolidate all the messages of this account into a single association:"
+{ $subsections consolidate }
+{ $examples
+ { $code
+ "consolidate ."
+"""{
+ T{ message
+ { # 1 }
+ { uidl \"000000d547ac2fc2\" }
+ { from \"from.first@mail.com\" }
+ { to \"username@host.com\" }
+ { subject \"First subject\" }
+ { size \"1006\" }
+ }
+ T{ message
+ { # 2 }
+ { uidl \"000000d647ac2fc2\" }
+ { from \"from.second@mail.com\" }
+ { to \"username@host.com\" }
+ { subject \"Second subject\" }
+ { size \"747\" }
+ }
+}"""
+ ""
+ }
+}
+$nl
+"You may want to delete message #2 but want to make sure you are deleting the right one. You can check that message #2 has the uidl from the example above."
+{ $subsections uidl }
+{ $examples
+ { $code
+ "2 uidl ."
+ "\"000000d647ac2fc2\""
+ ""
+ }
+}
+$nl
+"Now with your mind at rest, you can delete message #2. The message is marked for deletion."
+{ $subsections delete }
+{ $examples
+ { $code
+ "2 delete"
+ ""
+ }
+}
+$nl
+"The messages marked for deletion are actually deleted only when " { $link close } " is called. This should be the last command you issue. "
+{ $subsections close }
+{ $examples
+ { $code
+ "close"
+ ""
+ }
+}
+{ $notes "If you change your mind at any point, you can call " { $link reset } " to reset the status of all messages to not be deleted." } ;
+
+ABOUT: "pop3"
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises namespaces kernel pop3 pop3.server
+sequences tools.test accessors ;
+IN: pop3.tests
+
+FROM: pop3 => count delete ;
+
+<promise> "p1" set
+
+[ ] [ "p1" get mock-pop3-server ] unit-test
+[ ] [
+ <pop3-account>
+ "127.0.0.1" >>host
+ "p1" get ?promise >>port
+ connect
+] unit-test
+[ ] [ "username@host.com" >user ] unit-test
+[ ] [ "password" >pwd ] unit-test
+[ { "CAPA" "TOP" "UIDL" } ] [ capa ] unit-test
+[ 2 ] [ count ] unit-test
+[ H{ { 1 "1006" } { 2 "747" } } ] [ list ] unit-test
+[
+ H{
+ { "From:" "from.first@mail.com" }
+ { "Subject:" "First test with mock POP3 server" }
+ { "To:" "username@host.com" }
+ }
+] [ 1 0 top drop headers ] unit-test
+[
+ {
+ T{ message
+ { # 1 }
+ { uidl "000000d547ac2fc2" }
+ { from "from.first@mail.com" }
+ { to "username@host.com" }
+ { subject "First test with mock POP3 server" }
+ { size "1006" }
+ }
+ T{ message
+ { # 2 }
+ { uidl "000000d647ac2fc2" }
+ { from "from.second@mail.com" }
+ { to "username@host.com" }
+ { subject "Second test with mock POP3 server" }
+ { size "747" }
+ }
+ }
+] [ consolidate ] unit-test
+[ "000000d547ac2fc2" ] [ 1 uidl ] unit-test
+[ ] [ 1 delete ] unit-test
+[ ] [ reset ] unit-test
+[ ] [ close ] unit-test
+
+
+<promise> "p2" set
+
+[ ] [ "p2" get mock-pop3-server ] unit-test
+[ ] [
+ <pop3-account>
+ "127.0.0.1" >>host
+ "p2" get ?promise >>port
+ "username@host.com" >>user
+ "password" >>pwd
+ connect
+] unit-test
+[ f ] [ 1 retrieve empty? ] unit-test
+[ ] [ close ] unit-test
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors annotations arrays assocs calendar combinators
+fry hashtables io io.crlf io.encodings.utf8 io.sockets
+io.streams.duplex io.timeouts kernel make math math.parser
+math.ranges namespaces prettyprint sequences splitting
+strings ;
+IN: pop3
+
+TUPLE: pop3-account
+# host port timeout user pwd stream capa count list
+uidls messages ;
+
+: <pop3-account> ( -- pop3-account )
+ pop3-account new
+ 110 >>port
+ 1 minutes >>timeout ;
+
+: account ( -- pop3-account ) pop3-account get ;
+
+TUPLE: message # uidl headers from to subject size ;
+
+<PRIVATE
+
+: stream ( -- duplex-stream ) account stream>> ;
+
+: <message> ( -- message ) message new ; inline
+
+TUPLE: raw-source top headers content ;
+
+: <raw-source> ( -- raw-source ) raw-source new ; inline
+
+: raw ( -- raw-source ) raw-source get ;
+
+: set-read-timeout ( -- )
+ stream [
+ account timeout>> timeouts
+ ] with-stream* ;
+
+: get-ok ( -- )
+ stream [
+ readln dup "+OK" head? [ drop ] [ throw ] if
+ ] with-stream* ;
+
+: get-ok-and-total ( -- total )
+ stream [
+ readln dup "+OK" head? [
+ " " split second string>number dup account (>>count)
+ ] [ throw ] if
+ ] with-stream* ;
+
+: get-ok-and-uidl ( -- uidl )
+ stream [
+ readln dup "+OK" head? [
+ " " split last
+ ] [ throw ] if
+ ] with-stream* ;
+
+: command ( string -- ) write crlf flush get-ok ;
+
+: command-and-total ( string -- total ) write crlf flush
+ get-ok-and-total ;
+
+: command-and-uidl ( string -- uidl ) write crlf flush
+ get-ok-and-uidl ;
+
+: associate-split ( seq -- assoc )
+ [ " " split1 ] H{ } map>assoc ;
+
+: split-map ( seq -- assoc )
+ associate-split [ [ string>number ] dip ] assoc-map ;
+
+: (readlns) ( -- )
+ readln dup "." = [ , ] dip [ (readlns) ] unless ;
+
+: readlns ( -- seq ) [ (readlns) ] { } make but-last ;
+
+: (list) ( -- )
+ stream [
+ "LIST" command
+ readlns account (>>list)
+ ] with-stream* ;
+
+: (uidls) ( -- )
+ stream [
+ "UIDL" command
+ readlns account (>>uidls)
+ ] with-stream* ;
+
+PRIVATE>
+
+: >user ( name -- )
+ [ stream ] dip '[
+ "USER " _ append command
+ ] with-stream* ;
+
+: >pwd ( password -- )
+ [ stream ] dip '[
+ "PASS " _ append command
+ ] with-stream* ;
+
+: connect ( pop3-account -- )
+ [
+ [ host>> ] [ port>> ] bi
+ <inet> utf8 <client> drop
+ ] keep swap >>stream
+ {
+ [ pop3-account set ]
+ [ user>> [ >user ] when* ]
+ [ pwd>> [ >pwd ] when* ]
+ } cleave
+ set-read-timeout
+ get-ok ;
+
+: capa ( -- array )
+ stream [
+ "CAPA" command
+ readlns dup account (>>capa)
+ ] with-stream* ;
+
+: count ( -- n )
+ stream [
+ "STAT" command-and-total
+ ] with-stream* ;
+
+: list ( -- assoc )
+ (list) account list>> split-map ;
+
+: uidl ( message# -- uidl )
+ [ stream ] dip '[
+ "UIDL " _ number>string append command-and-uidl
+ ] with-stream* ;
+
+: uidls ( -- assoc )
+ (uidls) account uidls>> split-map ;
+
+: top ( message# #lines -- seq )
+ <raw-source> raw-source set
+ [ stream ] 2dip '[
+ "TOP " _ number>string append " "
+ append _ number>string append
+ command
+ readlns dup raw (>>top)
+ ] with-stream* ;
+
+: headers ( -- assoc )
+ raw top>> {
+ [
+ [ dup "From:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ [
+ [ dup "To:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ [
+ [ dup "Subject:" head?
+ [ raw [ swap suffix ] change-headers drop ]
+ [ drop ] if
+ ] each
+ ]
+ } cleave raw headers>> associate-split ;
+
+: retrieve ( message# -- seq )
+ [ stream ] dip '[
+ "RETR " _ number>string append command
+ readlns dup raw (>>content)
+ ] with-stream* ;
+
+: delete ( message# -- )
+ [ stream ] dip '[
+ "DELE " _ number>string append command
+ ] with-stream* ;
+
+: reset ( -- )
+ stream [ "RSET" command ] with-stream* ;
+
+: consolidate ( -- seq )
+ count zero? [ "No mail for account." ] [
+ 1 account count>> [a,b] [
+ {
+ [ 0 top drop ]
+ [ <message> swap >># ]
+ [ uidls at >>uidl ]
+ [ list at >>size ]
+ } cleave
+ "From:" headers at >>from
+ "To:" headers at >>to
+ "Subject:" headers at >>subject
+ account [ swap suffix ] change-messages drop
+ ] each account messages>>
+ ] if ;
+
+: close ( -- )
+ stream [ "QUIT" command ] with-stream ;
--- /dev/null
+! Copyright (C) 2009 Elie Chaftari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar combinators concurrency.promises
+destructors fry io io.crlf io.encodings.utf8 io.sockets
+io.sockets.secure.unix.debug io.streams.duplex io.timeouts
+kernel locals math.parser namespaces prettyprint sequences
+splitting threads ;
+IN: pop3.server
+
+! Mock POP3 server for testing purposes.
+
+! $ telnet 127.0.0.1 (start-pop3-server outputs listening port)
+! Trying 127.0.0.1...
+! Connected to localhost.
+! Escape character is '^]'.
+! +OK POP3 server ready
+! USER username@host.com
+! +OK Password required
+! PASS password
+! +OK Logged in
+! STAT
+! +OK 2 1753
+! LIST
+! +OK 2 messages:
+! 1 1006
+! 2 747
+! .
+! UIDL 1
+! +OK 1 000000d547ac2fc2
+! TOP 1 0
+! +OK
+! Return-Path: <from.first@mail.com>
+! Delivered-To: username@host.com
+! Received: from User.local ([66.249.71.201])
+! by mail.isp.com with ESMTP id n95BgmJg012655
+! for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+! Date: Mon, 5 Oct 2009 14:42:31 +0300
+! Message-Id: <4273644000823950677-1254742951070701@User.local>
+! MIME-Version: 1.0
+! Content-Transfer-Encoding: base64
+! From: from.first@mail.com
+! To: username@host.com
+! Subject: First test with mock POP3 server
+! Content-Type: text/plain; charset=UTF-8
+!
+! .
+! DELE 1
+! +OK Marked for deletion
+! QUIT
+! +OK POP3 server closing connection
+! Connection closed by foreign host.
+
+: process ( -- )
+ read-crlf {
+ {
+ [ dup "USER" head? ]
+ [
+
+ "+OK Password required\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "PASS" head? ]
+ [
+ "+OK Logged in\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "CAPA" = ]
+ [
+ "+OK\r\nCAPA\r\nTOP\r\nUIDL\r\n.\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "STAT" = ]
+ [
+ "+OK 2 1753\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "LIST" = ]
+ [
+ "+OK 2 messages:\r\n1 1006\r\n2 747\r\n.\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "UIDL" head? ]
+ [
+ {
+ {
+ [ dup "UIDL 1" = ]
+ [
+ "+OK 1 000000d547ac2fc2\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "UIDL 2" = ]
+ [
+ "+OK 2 000000d647ac2fc2\r\n"
+ write flush t
+ ]
+ }
+ [
+ "+OK\r\n1 000000d547ac2fc2\r\n2 000000d647ac2fc2\r\n.\r\n"
+ write flush t
+ ]
+ } cond
+ ]
+ }
+ {
+ [ dup "TOP" head? ]
+ [
+ {
+ {
+ [ dup "TOP 1 0" = ]
+ [
+"""+OK
+Return-Path: <from.first@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+Date: Mon, 5 Oct 2009 14:42:31 +0300
+Message-Id: <4273644000823950677-1254742951070701@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.first@mail.com
+To: username@host.com
+Subject: First test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+.
+"""
+ write flush t
+ ]
+ }
+ {
+ [ dup "TOP 2 0" = ]
+ [
+"""+OK
+Return-Path: <from.second@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:44:09 +0300
+Date: Mon, 5 Oct 2009 14:43:11 +0300
+Message-Id: <9783644000823934577-4563442951070856@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.second@mail.com
+To: username@host.com
+Subject: Second test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+.
+"""
+ write flush t
+ ]
+ }
+ } cond
+ ]
+ }
+ {
+ [ dup "RETR" head? ]
+ [
+ {
+ {
+ [ dup "RETR 1" = ]
+ [
+"""+OK
+Return-Path: <from.first@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:42:59 +0300
+Date: Mon, 5 Oct 2009 14:42:31 +0300
+Message-Id: <4273644000823950677-1254742951070701@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.first@mail.com
+To: username@host.com
+Subject: First test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+This is the body of the first test.
+.
+"""
+ write flush t
+ ]
+ }
+ {
+ [ dup "RETR 2" = ]
+ [
+"""+OK
+Return-Path: <from.second@mail.com>
+Delivered-To: username@host.com
+Received: from User.local ([66.249.71.201])
+ by mail.isp.com with ESMTP id n95BgmJg012655
+ for <username@host.com>; Mon, 5 Oct 2009 14:44:09 +0300
+Date: Mon, 5 Oct 2009 14:43:11 +0300
+Message-Id: <9783644000823934577-4563442951070856@User.local>
+MIME-Version: 1.0
+Content-Transfer-Encoding: base64
+From: from.second@mail.com
+To: username@host.com
+Subject: Second test with mock POP3 server
+Content-Type: text/plain; charset=UTF-8
+
+This is the body of the second test.
+.
+"""
+ write flush t
+ ]
+ }
+ } cond
+ ]
+ }
+ {
+ [ dup "DELE" head? ]
+ [
+ "+OK Marked for deletion\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "RSET" = ]
+ [
+ "+OK\r\n"
+ write flush t
+ ]
+ }
+ {
+ [ dup "QUIT" = ]
+ [
+ "+OK POP3 server closing connection\r\n"
+ write flush f
+ ]
+ }
+ } cond nip [ process ] when ;
+
+:: mock-pop3-server ( promise -- )
+ #! Store the port we are running on in the promise.
+ [
+ [
+ "127.0.0.1" 0 <inet4> utf8 <server> [
+ dup addr>> port>> promise fulfill
+ accept drop [
+ 1 minutes timeouts
+ "+OK POP3 server ready\r\n" write flush
+ process
+ global [ flush ] bind
+ ] with-stream
+ ] with-disposal
+ ] with-test-context
+ ] in-thread ;
+
+: start-pop3-server ( -- )
+ <promise> [ mock-pop3-server ] keep ?promise
+ number>string "POP3 server started on port "
+ prepend print ;
--- /dev/null
+POP3 server for testing purposes
--- /dev/null
+Retrieve mail via POP3
--- /dev/null
+enterprise
+network
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)
--- /dev/null
+USING: project-euler.062 tools.test ;
+IN: project-euler.062.tests
+
+[ 127035954683 ] [ euler062 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs hashtables kernel math math.functions
+project-euler.common sequences sorting ;
+IN: project-euler.062
+
+! http://projecteuler.net/index.php?section=problems&id=062
+
+! DESCRIPTION
+! -----------
+
+! The cube, 41063625 (345^3), can be permuted to produce two
+! other cubes: 56623104 (384^3) and 66430125 (405^3). In
+! fact, 41063625 is the smallest cube which has exactly three
+! permutations of its digits which are also cube.
+
+! Find the smallest cube for which exactly five permutations of
+! its digits are cube.
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: cube ( n -- n^3 ) 3 ^ ; inline
+: >key ( n -- k ) cube number>digits natural-sort ; inline
+: has-entry? ( n assoc -- ? ) [ >key ] dip key? ; inline
+
+: (euler062) ( n assoc -- n )
+ 2dup has-entry? [
+ 2dup [ >key ] dip
+ [ dup 0 swap [ 1 + ] change-nth ] change-at
+ 2dup [ >key ] dip at first 5 =
+ [
+ [ >key ] dip at second
+ ] [
+ [ 1 + ] dip (euler062)
+ ] if
+ ] [
+ 2dup 1 pick cube 2array -rot
+ [ >key ] dip set-at [ 1 + ] dip
+ (euler062)
+ ] if ;
+
+PRIVATE>
+
+: euler062 ( -- answer )
+ 1 1 <hashtable> (euler062) ;
+
+! [ euler062 ] 100 ave-time
+! 78 ms ave run time - 0.9 SD (100 trials)
+
+SOLUTION: euler062
--- /dev/null
+Guillaume Nargeot
! 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 ;
project-euler.045 project-euler.046 project-euler.047 project-euler.048
project-euler.049 project-euler.051 project-euler.052 project-euler.053
project-euler.054 project-euler.055 project-euler.056 project-euler.057
- project-euler.058 project-euler.059 project-euler.063 project-euler.065
- project-euler.067 project-euler.069 project-euler.071 project-euler.072
- project-euler.073 project-euler.074 project-euler.075 project-euler.076
- project-euler.079 project-euler.081 project-euler.085 project-euler.092
- project-euler.097 project-euler.099 project-euler.100 project-euler.102
- project-euler.112 project-euler.116 project-euler.117 project-euler.124
- project-euler.134 project-euler.148 project-euler.150 project-euler.151
- project-euler.164 project-euler.169 project-euler.173 project-euler.175
- project-euler.186 project-euler.188 project-euler.190 project-euler.203
- project-euler.215 ;
+ project-euler.058 project-euler.059 project-euler.062 project-euler.063
+ project-euler.065 project-euler.067 project-euler.069 project-euler.071
+ project-euler.072 project-euler.073 project-euler.074 project-euler.075
+ project-euler.076 project-euler.079 project-euler.081 project-euler.085
+ project-euler.092 project-euler.097 project-euler.099 project-euler.100
+ project-euler.102 project-euler.112 project-euler.116 project-euler.117
+ project-euler.124 project-euler.134 project-euler.148 project-euler.150
+ project-euler.151 project-euler.164 project-euler.169 project-euler.173
+ project-euler.175 project-euler.186 project-euler.188 project-euler.190
+ project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
! (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
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays colors.constants combinators
-db.sqlite db.tuples db.types kernel locals math
-monads persistency sequences sequences.extras ui ui.gadgets.controls
-ui.gadgets.layout models.combinators ui.gadgets.labels
-ui.gadgets.scrollers ui.pens.solid io.files.temp ;
-FROM: sets => prune ;
-IN: recipes
-
-STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
-: <recipe> ( title genre text -- recipe ) recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
-"recipes.db" temp-file <sqlite-db> recipe define-db
-: top-recipes ( offset search -- recipes ) <query> T{ recipe } rot >>title >>tuple
- "votes" >>order 30 >>limit swap >>offset get-tuples ;
-: top-genres ( -- genres ) f f top-recipes [ genre>> ] map prune 4 short head-slice ;
-
-: interface ( -- book ) [
- [
- [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
- [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
- { 5 0 } >>gap COLOR: gray <solid> >>interior ,
- $ RECIPES $
- ] <vbox> ,
- [
- [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
- $ BODY $
- $ BUTTON $
- ] <vbox> ,
- ] <book*> { 350 245 } >>pref-dim ;
-
-:: recipe-browser ( -- ) [ [
- interface
- <table*> :> tbl
- "okay" <model-border-btn> BUTTON -> :> ok
- IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
- IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
- IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
- IMG-MODEL-BTN: back -> [ -30 ] <$
- IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
- <spacer> <model-field*> ->% 1 :> search
- submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
- viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
- tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
- 4array merge
- [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
- ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
- [ text>> T{ recipe } swap >>genre get-tuples ] fmap
- tbl swap ups 2merge >>model
- [ [ title>> ] [ genre>> ] bi 2array ] >>quot
- { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
- submit [ "" dup dup <recipe> ] <$ 2array merge
- { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
- [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
- [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
- } cleave
- [ <recipe> ] 3fmap
- [ [ 1 ] <$ ]
- [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
- 2merge 0 <basic> switch-models >>model
- ] with-interface "recipes" open-window ] with-ui ;
-
-MAIN: recipe-browser
\ No newline at end of file
+++ /dev/null
-Database backed recipe sharing
\ No newline at end of file
! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io io.encodings.8-bit io.sockets
-io.streams.duplex kernel redis.command-writer
-redis.response-parser splitting ;
+USING: accessors io io.sockets io.streams.duplex kernel
+redis.command-writer redis.response-parser splitting
+io.encodings.8-bit.latin1 ;
IN: redis
#! Connection
: 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: ( value -- ) 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
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays combinators.short-circuit grouping kernel lists
-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 ;
-IN: sudokus
-
-: row ( index -- row ) 1 + 9 / ceiling ;
-: col ( index -- col ) 9 mod 1 + ;
-: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
-: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
-: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
-
-:: solutions ( puzzle random? -- solutions )
- f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
- [ :> pos
- 1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
- [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
- ] [ puzzle list-monad return ] if* ;
-
-: 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 ;
-
-: do-sudoku ( -- ) [ [
- [
- 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
- [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
- map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
- [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
- "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
- "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
- roll [ swap updates ] curry bi@
- [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
- ] bind
- ] with-self , ] <vbox> { 280 220 } >>pref-dim
- "Sudoku Sleuth" open-window ] with-ui ;
-
-MAIN: do-sudoku
\ No newline at end of file
+++ /dev/null
-graphical sudoku solver
\ No newline at end of file
[ 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 ;
+++ /dev/null
-USING: accessors models monads macros generalizations kernel
-ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
-ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
-ui.gadgets.packs locals sequences fonts io.styles
-wrap.strings ;
-
-IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
- string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
-
-: 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 ;
-
-MACRO: ask-buttons ( buttons -- quot ) dup length [
- [ swap
- [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
- [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
- "" open-window
- ] dip firstn
- ] 2curry ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-Really simple dialog boxes
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays kernel math.rectangles sequences
-ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
-ui.gadgets.labels ui.gestures ;
-QUALIFIED-WITH: ui.gadgets.tables tbl
-IN: ui.gadgets.comboboxes
-
-TUPLE: combo-table < table spawner ;
-
-M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
- T{ button-up } = [
- [ spawner>> ]
- [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
- [ hide-glass ] tri
- ] [ drop ] if t ;
-
-TUPLE: combobox < label-control table ;
-combobox H{
- { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
-} set-gestures
-
-: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
- <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
+++ /dev/null
-Combo boxes have a model choosen from a list of options
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors help.markup help.syntax ui.gadgets.buttons
-ui.gadgets.editors models ui.gadgets ;
-IN: ui.gadgets.controls
-
-HELP: <model-btn>
-{ $values { "gadget" "the button's label" } { "button" button } }
-{ $description "Creates an button whose signal updates on clicks. " } ;
-
-HELP: <model-border-btn>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose signal updates on clicks. " } ;
-
-HELP: <table>
-{ $values { "model" "values the table is to display" } { "table" table } }
-{ $description "Creates an " { $link table } } ;
-
-HELP: <table*>
-{ $values { "table" table } }
-{ $description "Creates an " { $link table } " with no initial values to display" } ;
-
-HELP: <list>
-{ $values { "column-model" "values the table is to display" } { "table" table } }
-{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
-
-HELP: <list*>
-{ $values { "table" table } }
-{ $description "Creates an model-list with no initial values to display" } ;
-
-HELP: indexed
-{ $values { "table" table } }
-{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
-
-HELP: <model-field>
-{ $values { "model" model } { "gadget" model-field } }
-{ $description "Creates a field with an initial value" } ;
-
-HELP: <model-field*>
-{ $values { "field" model-field } }
-{ $description "Creates a field with an empty initial value" } ;
-
-HELP: <empty-field>
-{ $values { "model" model } { "field" model-field } }
-{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
-
-HELP: <model-editor>
-{ $values { "model" model } { "gadget" model-field } }
-{ $description "Creates an editor with an initial value" } ;
-
-HELP: <model-editor*>
-{ $values { "editor" "an editor" } }
-{ $description "Creates a editor with an empty initial value" } ;
-
-HELP: <empty-editor>
-{ $values { "model" model } { "editor" "an editor" } }
-{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
-
-HELP: <model-action-field>
-{ $values { "field" action-field } }
-{ $description "Field that updates its model with its contents when the user hits the return key" } ;
-
-HELP: IMG-MODEL-BTN:
-{ $syntax "IMAGE-MODEL-BTN: filename" }
-{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
-
-HELP: IMG-BTN:
-{ $syntax "[ do-something ] IMAGE-BTN: filename" }
-{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
-
-HELP: output-model
-{ $values { "gadget" gadget } { "model" model } }
-{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
+++ /dev/null
-USING: accessors assocs arrays kernel models monads sequences
-models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
-words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
-models.range ui.gadgets.sliders ;
-QUALIFIED-WITH: ui.gadgets.sliders slider
-QUALIFIED-WITH: ui.gadgets.tables tbl
-EXCLUDE: ui.gadgets.editors => model-field ;
-IN: ui.gadgets.controls
-
-TUPLE: model-btn < button hook value ;
-: <model-btn> ( gadget -- button ) [
- [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
- [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
- [ model>> f swap (>>value) ] tri
- ] model-btn new-button f <basic> >>model ;
-: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
-
-TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
-M: table tbl:column-titles column-titles>> ;
-M: table tbl:column-alignment column-alignment>> ;
-M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
-
-: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
- f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
-: <table> ( model -- table ) table new-table ;
-: <table*> ( -- table ) V{ } clone <model> <table> ;
-: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
-: <list*> ( -- table ) V{ } clone <model> <list> ;
-: indexed ( table -- table ) f >>val-quot ;
-
-TUPLE: model-field < field model* ;
-: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
-: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
-M: model-field graft*
- [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
- [ dup editor>> model>> add-connection ]
- [ dup model*>> add-connection ] tri ;
-M: model-field ungraft*
- [ dup editor>> model>> remove-connection ]
- [ dup model*>> remove-connection ] bi ;
-M: model-field model-changed 2dup model*>> =
- [ [ value>> ] [ editor>> ] bi* set-editor-string ]
- [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
-
-: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
- field-theme { 1 0 } >>align ; inline
-: <model-field*> ( -- field ) "" <model> <model-field> ;
-: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
-: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
-: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
-: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
-
-: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
- f <model> >>model ;
-
-: <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-BTN: image-prep [ swap <button> ] curry over push-all ;
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
-M: model-field output-model model*>> ;
-M: scroller output-model viewport>> children>> first output-model ;
-M: slider output-model model>> range-model ;
-
-IN: accessors
-M: model-btn text>> children>> first text>> ;
-
-IN: ui.gadgets.controls
-
-SINGLETON: gadget-monad
-INSTANCE: gadget-monad monad
-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
+++ /dev/null
-Gadgets with expanded model usage
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models ui.gadgets.tracks ;
-IN: ui.gadgets.layout
-
-HELP: ,
-{ $values { "item" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-
-HELP: ,%
-{ $syntax "gadget ,% width" }
-{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
-
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like ',' but passes its model on for further use." } ;
-
-HELP: ->%
-{ $syntax "gadget ,% width" }
-{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
-
-HELP: <spacer>
-{ $description "Grows to fill any empty space in a box" } ;
-
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-HELP: $
-{ $syntax "$ PLACEHOLDER-NAME $" }
-{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
-
-HELP: with-interface
-{ $values { "quot" "quotation that builds a template and inserts into it" } }
-{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
-
-ARTICLE: "ui.gadgets.layout" "GUI Layout"
-"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
-". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
-{ $link , } " and " { $link -> } " add a model or gadget to the gadget you're building. "
-"Also, books can be made with " { $link <book> } ". "
-{ $link <spacer> } "s add flexable space between items. " $nl
-"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
-"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
-"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
-"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
-"For examples of templating, see the " { $vocab-link "recipes" } " demo. " ;
-
-ABOUT: "ui.gadgets.layout"
\ No newline at end of file
+++ /dev/null
-USING: accessors assocs arrays fry kernel lexer make math.parser
-models monads namespaces parser sequences
-sequences.extras models.combinators ui.gadgets
-ui.gadgets.tracks words ui.gadgets.controls ;
-QUALIFIED: make
-QUALIFIED-WITH: ui.gadgets.books book
-IN: ui.gadgets.layout
-
-SYMBOL: templates
-TUPLE: layout gadget size ; C: <layout> layout
-TUPLE: placeholder < gadget members ;
-: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
-
-: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
- [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
-
-: remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep delete-all ] if-empty ;
-: add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
-
-: , ( item -- ) make:, ;
-: make* ( quot -- list ) { } make ; inline
-
-! 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* ;
-
-SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
-SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup , output-model ;
-M: model -> dup , ;
-
-: <spacer> ( -- ) <gadget> 1 <layout> , ;
-
-: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ;
-: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
- [ [ dup layout? [ f <layout> ] unless ] map ]
- [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
-: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
- [ make* [ [ model? ] filter ] ] dip bi ; inline
-: <box> ( gadgets type -- track )
- [ t make-layout ] dip <track>
- swap [ add-layout ] each
- swap [ <collection> >>model ] unless-empty ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-
-: make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
-: <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
-: <book*> ( quot -- book ) f make-layout f make-book ; inline
-
-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 ;
-
-: 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 ;
-: insertion-point ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
-
-GENERIC: >layout ( gadget -- layout )
-M: gadget >layout f <layout> ;
-M: layout >layout ;
-
-GENERIC# (add-gadget-at) 2 ( parent item n -- )
-M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
-M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
-
-GENERIC# add-gadget-at 1 ( item location -- )
-M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
-M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
- [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
-: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
-: (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
-
-: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
- [ add-member ] 2keep add-gadget-at ;
-
-: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
-
-: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
-
-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
+++ /dev/null
-Syntax for easily building GUIs and using templates
\ No newline at end of file
! 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 ;
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors combinators kernel math
-models models.combinators namespaces sequences
-ui.gadgets ui.gadgets.controls ui.gadgets.layout
-ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
-EXCLUDE: ui.gadgets.editors => model-field ;
-IN: ui.gadgets.poppers
-
-TUPLE: popped < model-field { fatal? initial: t } ;
-TUPLE: popped-editor < multiline-editor ;
-: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
-
-: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
-: new-popped ( popped -- ) insertion-point "" <popped>
- [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
-: focus-prev ( popped -- ) dup parent>> children>> length 1 =
- [ drop ] [
- insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
- [ request-focus ] [ editor>> end-of-document ] bi
- ] if ;
-: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
-
-TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
-! list of strings is model (make shown objects implement sequence protocol)
-: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
-
-M: popped handle-gesture swap {
- { gain-focus [ 1 set-expansion f ] }
- { lose-focus [ dup parent>>
- [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
- [ drop ] if* f
- ] }
- { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
- { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
- [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
- [ f >>fatal? drop ] if f
- ] }
- [ swap call-next-method ]
-} case ;
-
-M: popper handle-gesture swap T{ button-down f f 1 } =
- [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
-
-M: popper model-changed
- [ children>> [ unparent ] each ]
- [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
-
-M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
-M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
[ 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
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "drills" }
+ { deploy-c-types? t }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? t }
+ { deploy-threads? t }
+ { deploy-reflection 6 }
+ { deploy-word-defs? t }
+ { deploy-math? t }
+ { deploy-ui? t }
+ { deploy-word-props? t }
+ { deploy-io 3 }
+}
--- /dev/null
+USING: arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings system ;
+EXCLUDE: accessors => change-model ;
+IN: drills.deployed
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] [ 0 exit ] if*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+USING: arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings ;
+EXCLUDE: accessors => change-model ;
+
+IN: drills
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] when*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
--- /dev/null
+unportable
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
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models models.arrow sequences monads ;
+IN: models.combinators
+
+HELP: merge
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: filter-model
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
+
+HELP: fold
+{ $values { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch-models
+{ $values { "model1" model } { "model2" model } { "model'" model } }
+{ $description "Creates a model that starts with the behavior of model2 and switches to the behavior of model1 on its update" } ;
+
+HELP: <mapped>
+{ $values { "model" model } { "quot" "applied to model's value on updates" } { "model" model } }
+{ $description "An expanded version of " { $link <arrow> } ". Use " { $link fmap } " instead." } ;
+
+HELP: when-model
+{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
+{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
+
+HELP: with-self
+{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
+{ $description "Fixed points for models: the quot reacts to the same model to gives" } ;
+
+HELP: #1
+{ $values { "model" model } { "model'" model } }
+{ $description "Moves a model to the top of its dependencies' connections, thus being notified before the others" } ;
+
+ARTICLE: "models.combinators" "Extending models"
+"The " { $vocab-link "models.combinators" } " library expands models to have discrete start and end times. "
+"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
+"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
+
+ABOUT: "models.combinators"
--- /dev/null
+USING: accessors arrays kernel models models.product monads
+sequences sequences.extras shuffle ;
+FROM: syntax => >> ;
+IN: models.combinators
+
+TUPLE: multi-model < model important? ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+M: multi-model model-activated dup dependencies>> [ value>> ] find nip
+ [ swap model-changed ] [ drop ] if* ;
+
+: #1 ( model -- model' ) t >>important? ;
+
+IN: models
+: notify-connections ( model -- )
+ dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all
+ [ second tuck [ remove ] dip prefix ] each
+ [ model-changed ] with each ;
+IN: models.combinators
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: merge ( models -- model ) basic-model <multi-model> ;
+: 2merge ( model1 model2 -- model ) 2array merge ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+ [ set-model ] [ 2drop ] if ;
+: filter-model ( model quot -- filter-model ) [ 1array \ filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model quot base values ;
+M: fold-model (model-changed) 2dup base>> =
+ [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
+ [ [ [ value>> ] [ values>> ] bi* push ]
+ [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
+ ] if ;
+M: fold-model model-activated drop ;
+: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
+: fold ( model oldval quot -- model ) rot 1array new-fold-model swap >>quot
+ swap >>value ;
+: fold* ( model oldmodel quot -- model ) over [ [ 2array new-fold-model ] dip >>quot ]
+ dip [ >>base ] [ value>> >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) [ tuck updates>> =
+ [ [ values>> value>> ] keep set-model ]
+ [ drop ] if ] keep f swap (>>value) ;
+: updates ( values updates -- model ) [ 2array updater-model <multi-model> ] 2keep
+ [ >>values ] [ >>updates ] bi* ;
+
+SYMBOL: switch
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+ [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
+: switch-models ( model1 model2 -- model' ) swap [ 2array switch-model <multi-model> ] 2keep
+ [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: >behavior ( event -- behavior ) t >>value ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
+ <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- model ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+ [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action-model ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: collection < multi-model ;
+: <collection> ( models -- product ) collection <multi-model> ;
+M: collection (model-changed)
+ nip
+ dup dependencies>> [ value>> ] all?
+ [ dup [ value>> ] product-value swap set-model ]
+ [ drop ] if ;
+M: collection model-activated dup (model-changed) ;
+
+! for side effects
+TUPLE: (when-model) < multi-model quot cond ;
+: when-model ( model quot cond -- model ) rot 1array (when-model) <multi-model> swap >>cond swap >>quot ;
+M: (when-model) (model-changed) [ quot>> ] 2keep
+ [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
+
+! only used in construction
+: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
+
+USE: models.combinators.templates
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
--- /dev/null
+Model combination and manipulation
\ No newline at end of file
--- /dev/null
+USING: kernel sequences functors fry macros generalizations ;
+IN: models.combinators.templates
+FROM: models.combinators => <collection> #1 ;
+FUNCTOR: fmaps ( W -- )
+W IS ${W}
+w-n DEFINES ${W}-n
+w-2 DEFINES 2${W}
+w-3 DEFINES 3${W}
+w-4 DEFINES 4${W}
+w-n* DEFINES ${W}-n*
+w-2* DEFINES 2${W}*
+w-3* DEFINES 3${W}*
+w-4* DEFINES 4${W}*
+WHERE
+MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] dip [ _ firstn ] prepend W ] ;
+: w-2 ( a b quot -- mapped ) 2 w-n ; inline
+: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
+: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
+MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ] prepend W ] ;
+: w-2* ( a b quot -- mapped ) 2 w-n* ; inline
+: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
+: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
+;FUNCTOR
\ No newline at end of file
+++ /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
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays colors.constants combinators
+db.sqlite db.tuples db.types kernel locals math
+monads persistency sequences sequences.extras ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.labels
+ui.gadgets.scrollers ui.pens.solid io.files.temp ;
+FROM: sets => prune ;
+IN: recipes
+
+STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
+: <recipe> ( title genre text -- recipe ) recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
+"recipes.db" temp-file <sqlite-db> recipe define-db
+: top-recipes ( offset search -- recipes ) <query> T{ recipe } rot >>title >>tuple
+ "votes" >>order 30 >>limit swap >>offset get-tuples ;
+: top-genres ( -- genres ) f f top-recipes [ genre>> ] map prune 4 short head-slice ;
+
+: interface ( -- book ) [
+ [
+ [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
+ [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
+ { 5 0 } >>gap COLOR: gray <solid> >>interior ,
+ $ RECIPES $
+ ] <vbox> ,
+ [
+ [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
+ $ BODY $
+ $ BUTTON $
+ ] <vbox> ,
+ ] <book*> { 350 245 } >>pref-dim ;
+
+:: recipe-browser ( -- ) [ [
+ interface
+ <table*> :> tbl
+ "okay" <model-border-btn> BUTTON -> :> ok
+ IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+ IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
+ IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
+ IMG-MODEL-BTN: back -> [ -30 ] <$
+ IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
+ <spacer> <model-field*> ->% 1 :> search
+ submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
+ viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
+ tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
+ 4array merge
+ [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
+ ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
+ [ text>> T{ recipe } swap >>genre get-tuples ] fmap
+ tbl swap ups 2merge >>model
+ [ [ title>> ] [ genre>> ] bi 2array ] >>quot
+ { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
+ submit [ "" dup dup <recipe> ] <$ 2array merge
+ { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
+ [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
+ [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
+ } cleave
+ [ <recipe> ] 3fmap
+ [ [ 1 ] <$ ]
+ [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
+ 2merge 0 <basic> switch-models >>model
+ ] with-interface "recipes" open-window ] with-ui ;
+
+MAIN: recipe-browser
\ No newline at end of file
--- /dev/null
+Database backed recipe sharing
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays combinators.short-circuit grouping kernel lists
+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 shuffle ;
+IN: sudokus
+
+: row ( index -- row ) 1 + 9 / ceiling ;
+: col ( index -- col ) 9 mod 1 + ;
+: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
+: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
+: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
+
+:: solutions ( puzzle random? -- solutions )
+ f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
+ [ :> pos
+ 1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
+ [ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
+ ] [ puzzle list-monad return ] if* ;
+
+: 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 [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
+
+: do-sudoku ( -- ) [ [
+ [
+ 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
+ [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
+ map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
+ [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
+ "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
+ "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
+ roll [ swap updates ] curry bi@
+ [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
+ ] bind
+ ] with-self , ] <vbox> { 280 220 } >>pref-dim
+ "Sudoku Sleuth" open-window ] with-ui ;
+
+MAIN: do-sudoku
--- /dev/null
+graphical sudoku solver
\ No newline at end of file
--- /dev/null
+USING: accessors models monads macros generalizations kernel
+ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
+ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
+ui.gadgets.packs locals sequences fonts io.styles
+wrap.strings ;
+
+IN: ui.gadgets.alerts
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+: alert* ( str -- ) [ ] swap alert ;
+
+:: ask-user ( string -- model' )
+ [
+ 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
+ [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ "" open-window
+ ] dip firstn
+ ] 2curry ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Really simple dialog boxes
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel math.rectangles sequences
+ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
+ui.gadgets.labels ui.gestures ;
+QUALIFIED-WITH: ui.gadgets.tables tbl
+IN: ui.gadgets.comboboxes
+
+TUPLE: combo-table < table spawner ;
+
+M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
+ T{ button-up } = [
+ [ spawner>> ]
+ [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
+ [ hide-glass ] tri
+ ] [ drop ] if t ;
+
+TUPLE: combobox < label-control table ;
+combobox H{
+ { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
+} set-gestures
+
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
+ <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
--- /dev/null
+Combo boxes have a model choosen from a list of options
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.editors models ui.gadgets ;
+IN: ui.gadgets.controls
+
+HELP: <model-btn>
+{ $values { "gadget" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <model-border-btn>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <table>
+{ $values { "model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } } ;
+
+HELP: <table*>
+{ $values { "table" table } }
+{ $description "Creates an " { $link table } " with no initial values to display" } ;
+
+HELP: <list>
+{ $values { "column-model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
+
+HELP: <list*>
+{ $values { "table" table } }
+{ $description "Creates an model-list with no initial values to display" } ;
+
+HELP: indexed
+{ $values { "table" table } }
+{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
+
+HELP: <model-field>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates a field with an initial value" } ;
+
+HELP: <model-field*>
+{ $values { "field" model-field } }
+{ $description "Creates a field with an empty initial value" } ;
+
+HELP: <empty-field>
+{ $values { "model" model } { "field" model-field } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-editor>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates an editor with an initial value" } ;
+
+HELP: <model-editor*>
+{ $values { "editor" "an editor" } }
+{ $description "Creates a editor with an empty initial value" } ;
+
+HELP: <empty-editor>
+{ $values { "model" model } { "editor" "an editor" } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-action-field>
+{ $values { "field" action-field } }
+{ $description "Field that updates its model with its contents when the user hits the return key" } ;
+
+HELP: IMG-MODEL-BTN:
+{ $syntax "IMAGE-MODEL-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
+
+HELP: IMG-BTN:
+{ $syntax "[ do-something ] IMAGE-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
+
+HELP: output-model
+{ $values { "gadget" gadget } { "model" model } }
+{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays kernel models monads sequences
+models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
+words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
+models.range ui.gadgets.sliders ;
+QUALIFIED-WITH: ui.gadgets.sliders slider
+QUALIFIED-WITH: ui.gadgets.tables tbl
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.controls
+
+TUPLE: model-btn < button hook value ;
+: <model-btn> ( gadget -- button ) [
+ [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
+ [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
+ [ model>> f swap (>>value) ] tri
+ ] model-btn new-button f <basic> >>model ;
+: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
+
+TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
+M: table tbl:column-titles column-titles>> ;
+M: table tbl:column-alignment column-alignment>> ;
+M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
+ f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
+: <table> ( model -- table ) table new-table ;
+: <table*> ( -- table ) V{ } clone <model> <table> ;
+: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
+: <list*> ( -- table ) V{ } clone <model> <list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+TUPLE: model-field < field model* ;
+: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
+: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
+M: model-field graft*
+ [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ [ dup model*>> add-connection ] tri ;
+M: model-field ungraft*
+ [ dup editor>> model>> remove-connection ]
+ [ dup model*>> remove-connection ] bi ;
+M: model-field model-changed 2dup model*>> =
+ [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+ [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
+
+: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
+ field-theme { 1 0 } >>align ; inline
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
+: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
+: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
+
+: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
+ f <model> >>model ;
+
+: <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 append! ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry append! ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
+M: model-field output-model model*>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: slider output-model model>> range-model ;
+
+IN: accessors
+M: model-btn text>> children>> first text>> ;
+
+IN: ui.gadgets.controls
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+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 ;
--- /dev/null
+Gadgets with expanded model usage
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models ui.gadgets.tracks ;
+IN: ui.gadgets.layout
+
+HELP: ,
+{ $values { "item" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+
+HELP: ,%
+{ $syntax "gadget ,% width" }
+{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like ',' but passes its model on for further use." } ;
+
+HELP: ->%
+{ $syntax "gadget ,% width" }
+{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: <spacer>
+{ $description "Grows to fill any empty space in a box" } ;
+
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+HELP: $
+{ $syntax "$ PLACEHOLDER-NAME $" }
+{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
+
+HELP: with-interface
+{ $values { "quot" "quotation that builds a template and inserts into it" } }
+{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
+
+ARTICLE: "ui.gadgets.layout" "GUI Layout"
+"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
+". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
+{ $link , } " and " { $link -> } " add a model or gadget to the gadget you're building. "
+"Also, books can be made with " { $link <book> } ". "
+{ $link <spacer> } "s add flexable space between items. " $nl
+"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
+"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
+"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
+"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
+"For examples of templating, see the " { $vocab-link "recipes" } " demo. " ;
+
+ABOUT: "ui.gadgets.layout"
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays fry kernel lexer make math.parser
+models monads namespaces parser sequences
+sequences.extras models.combinators ui.gadgets
+ui.gadgets.tracks words ui.gadgets.controls ;
+QUALIFIED: make
+QUALIFIED-WITH: ui.gadgets.books book
+IN: ui.gadgets.layout
+
+SYMBOL: templates
+TUPLE: layout gadget size ; C: <layout> layout
+TUPLE: placeholder < gadget members ;
+: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
+
+: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
+ [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
+
+: remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep delete-all ] if-empty ;
+: add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
+
+: , ( item -- ) make:, ;
+: make* ( quot -- list ) { } make ; inline
+
+! 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 ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+
+SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> , ;
+
+: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ;
+: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
+ [ [ dup layout? [ f <layout> ] unless ] map ]
+ [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
+: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
+ [ make* [ [ model? ] filter ] ] dip bi ; inline
+: <box> ( gadgets type -- track )
+ [ t make-layout ] dip <track>
+ swap [ add-layout ] each
+ swap [ <collection> >>model ] unless-empty ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+
+: make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
+: <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
+: <book*> ( quot -- book ) f make-layout f make-book ; inline
+
+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 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 ;
+: insertion-point ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
+
+GENERIC: >layout ( gadget -- layout )
+M: gadget >layout f <layout> ;
+M: layout >layout ;
+
+GENERIC# (add-gadget-at) 2 ( parent item n -- )
+M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
+M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+
+GENERIC# add-gadget-at 1 ( item location -- )
+M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
+M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
+ [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
+: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
+: (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
+
+: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
+ [ add-member ] 2keep add-gadget-at ;
+
+: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
+
+: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
+
+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 ;
--- /dev/null
+Syntax for easily building GUIs and using templates
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors combinators kernel math
+models models.combinators namespaces sequences
+ui.gadgets ui.gadgets.controls ui.gadgets.layout
+ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.poppers
+
+TUPLE: popped < model-field { fatal? initial: t } ;
+TUPLE: popped-editor < multiline-editor ;
+: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
+
+: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
+: new-popped ( popped -- ) insertion-point "" <popped>
+ [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
+: focus-prev ( popped -- ) dup parent>> children>> length 1 =
+ [ drop ] [
+ insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
+ [ request-focus ] [ editor>> end-of-document ] bi
+ ] if ;
+: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
+
+TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
+! list of strings is model (make shown objects implement sequence protocol)
+: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
+
+M: popped handle-gesture swap {
+ { gain-focus [ 1 set-expansion f ] }
+ { lose-focus [ dup parent>>
+ [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
+ [ drop ] if* f
+ ] }
+ { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
+ { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
+ [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
+ [ f >>fatal? drop ] if f
+ ] }
+ [ swap call-next-method ]
+} case ;
+
+M: popper handle-gesture swap T{ button-down f f 1 } =
+ [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
+
+M: popper model-changed
+ [ children>> [ unparent ] each ]
+ [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
+
+M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
+M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
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(cell type, 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->initialize(type);
+ return obj;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ return allot_large_object(type,size);
+}
+
+}
namespace factor
{
-/* 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 */
void factor_vm::primitive_array()
{
- cell initial = dpop();
- cell size = unbox_array_size();
- dpush(tag<array>(allot_array(size,initial)));
+ data_root<object> fill(dpop(),this);
+ cell capacity = unbox_array_size();
+ array *new_array = allot_uninitialized_array<array>(capacity);
+ memset_cell(new_array->data(),fill.value(),capacity * sizeof(cell));
+ dpush(tag<array>(new_array));
}
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 factor_vm::primitive_resize_array()
{
- array *a = untag_check<array>(dpop());
+ data_root<array> a(dpop(),this);
+ a.untag_check(this);
cell capacity = unbox_array_size();
- dpush(tag<array>(reallot_array(a,capacity)));
+ dpush(tag<array>(reallot_array(a.untagged(),capacity)));
}
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()
{
- byte_array *array = untag_check<byte_array>(dpop());
+ data_root<byte_array> array(dpop(),this);
+ array.untag_check(this);
cell capacity = unbox_array_size();
- dpush(tag<byte_array>(reallot_array(array,capacity)));
+ dpush(tag<byte_array>(reallot_array(array.untagged(),capacity)));
}
void growable_byte_array::append_bytes(void *elts, cell len)
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)
+{
+ byte_array *data = allot_uninitialized_array<byte_array>(sizeof(Type));
+ memcpy(data->data<char>(),value,sizeof(Type));
+ 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->type())
+ {
+ 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_) {}
parent->check_data_pointer(untagged);
/* is there another forwarding pointer? */
- while(untagged->h.forwarding_pointer_p())
- untagged = untagged->h.forwarding_pointer();
+ while(untagged->forwarding_pointer_p())
+ untagged = untagged->forwarding_pointer();
/* we've found the destination */
- untagged->h.check_header();
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->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;
+ }
- if(forwarding == untagged)
- untagged = promote_object(untagged);
+ object *forwarding = resolve_forwarding(obj);
+
+ 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->type() == 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++;
+ }
}
- void trace_stack_elements(segment *region, cell *top)
+ inline cell first_card_in_deck(cell deck)
{
- for(cell *ptr = (cell *)region->start; ptr <= top; ptr++)
- trace_handle(ptr);
+ return deck << (deck_bits - card_bits);
}
- void trace_registered_locals()
+ inline cell last_card_in_deck(cell deck)
{
- std::vector<cell>::const_iterator iter = parent->gc_locals.begin();
- std::vector<cell>::const_iterator end = parent->gc_locals.end();
+ return first_card_in_deck(deck + 1);
+ }
- for(; iter < end; iter++)
- trace_handle((cell *)(*iter));
+ inline cell card_deck_for_address(cell a)
+ {
+ return addr_to_deck(a - data->start);
}
- void trace_registered_bignums()
+ inline cell card_start_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 << card_bits) + data->start;
+ }
- for(; iter < end; iter++)
+ inline cell card_end_address(cell card)
+ {
+ return ((card + 1) << card_bits) + data->start;
+ }
+
+ 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->type() == 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->type() == 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(type())
{
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(type())
{
/* 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->type() == 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
+#include "master.hpp"
+
+/* A tool to debug write barriers. Call check_data_heap() to ensure that all
+cards that should be marked are actually marked. */
+
+namespace factor
+{
+
+enum generation {
+ nursery_generation,
+ aging_generation,
+ tenured_generation
+};
+
+inline generation generation_of(factor_vm *parent, object *obj)
+{
+ if(parent->data->nursery->contains_p(obj))
+ return nursery_generation;
+ else if(parent->data->aging->contains_p(obj))
+ return aging_generation;
+ else if(parent->data->tenured->contains_p(obj))
+ return tenured_generation;
+ else
+ {
+ critical_error("Bad object",(cell)obj);
+ return (generation)-1;
+ }
+}
+
+struct slot_checker {
+ factor_vm *parent;
+ object *obj;
+ generation gen;
+
+ explicit slot_checker(factor_vm *parent_, object *obj_, generation gen_) :
+ parent(parent_), obj(obj_), gen(gen_) {}
+
+ void check_write_barrier(cell *slot_ptr, generation target, char mask)
+ {
+ cell object_card_pointer = parent->cards_offset + ((cell)obj >> card_bits);
+ cell slot_card_pointer = parent->cards_offset + ((cell)slot_ptr >> card_bits);
+ char slot_card_value = *(char *)slot_card_pointer;
+ if((slot_card_value & mask) != mask)
+ {
+ printf("card not marked\n");
+ printf("source generation: %d\n",gen);
+ printf("target generation: %d\n",target);
+ printf("object: 0x%lx\n",(cell)obj);
+ printf("object type: %ld\n",obj->type());
+ printf("slot pointer: 0x%lx\n",(cell)slot_ptr);
+ printf("slot value: 0x%lx\n",*slot_ptr);
+ printf("card of object: 0x%lx\n",object_card_pointer);
+ printf("card of slot: 0x%lx\n",slot_card_pointer);
+ printf("\n");
+ parent->factorbug();
+ }
+ }
+
+ void operator()(cell *slot_ptr)
+ {
+ if(!immediate_p(*slot_ptr))
+ {
+ generation target = generation_of(parent,untag<object>(*slot_ptr));
+ switch(gen)
+ {
+ case nursery_generation:
+ break;
+ case aging_generation:
+ if(target == nursery_generation)
+ check_write_barrier(slot_ptr,target,card_points_to_nursery);
+ break;
+ case tenured_generation:
+ if(target == nursery_generation)
+ check_write_barrier(slot_ptr,target,card_points_to_nursery);
+ else if(target == aging_generation)
+ check_write_barrier(slot_ptr,target,card_points_to_aging);
+ break;
+ }
+ }
+ }
+};
+
+struct object_checker {
+ factor_vm *parent;
+
+ explicit object_checker(factor_vm *parent_) : parent(parent_) {}
+
+ void operator()(object *obj)
+ {
+ slot_checker checker(parent,obj,generation_of(parent,obj));
+ obj->each_slot(checker);
+ }
+};
+
+void factor_vm::check_data_heap()
+{
+ object_checker checker(this);
+ each_object(checker);
+}
+
+}
--- /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->type() == 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);
+ obj->each_slot(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);
}
void factor_vm::signal_error(int signal, stack_frame *native_stack)
{
- general_error(ERROR_SIGNAL,tag_fixnum(signal),false_object,native_stack);
+ general_error(ERROR_SIGNAL,allot_cell(signal),false_object,native_stack);
}
void factor_vm::divide_by_zero_error()
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 */
+ if(size / block_granularity < free_list_count)
+ {
+ std::vector<free_heap_block *> &blocks = small_blocks[size / block_granularity];
+ if(blocks.size() == 0)
+ {
+ /* Round up to a multiple of 'size' */
+ cell large_block_size = ((allocation_page_size + size - 1) / size) * size;
+
+ /* Allocate a block this big */
+ free_heap_block *large_block = find_free_block(large_block_size);
+ if(!large_block) return NULL;
+
+ large_block = split_free_block(large_block,large_block_size);
+
+ /* Split it up into pieces and add each piece back to the free list */
+ for(cell offset = 0; offset < large_block_size; offset += size)
+ {
+ free_heap_block *small_block = large_block;
+ large_block = (free_heap_block *)((cell)large_block + size);
+ small_block->make_free(size);
+ add_to_free_list(small_block);
+ }
+ }
+
+ free_heap_block *block = blocks.back();
+ blocks.pop_back();
+
+ free_block_count--;
+ free_space -= block->size();
+
+ return block;
+ }
+ else
+ {
+ /* Check large free list */
+ 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)
+{
+ return largest_free_block() >= std::max(size,allocation_page_size);
+}
+
+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;
+static const cell allocation_page_size = 1024;
+
+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);
- }
-};
-
-void full_collector::trace_callbacks()
-{
- callback_tracer tracer(this);
- parent->callbacks->iterate(tracer);
-}
+ code_root *root = *iter;
+ code_block *block = (code_block *)(root->value & -block_granularity);
-/* 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)
+ while(!mark_stack->empty())
{
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
- }
- else
- {
- 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)
+void factor_vm::collect_full(bool trace_contexts_p)
+{
+ collect_mark_impl(trace_contexts_p);
+ collect_sweep_impl();
+ if(data->low_memory_p())
{
- compact_code_heap(trace_contexts_p);
- big_code_heap_updater updater(this);
- iterate_code_heap(updater);
+ current_gc->op = collect_compact_op;
+ current_gc->event->op = collect_compact_op;
+ 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);
+}
-gc_state::~gc_state() {}
+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;
+}
+
+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? */);
+ true /* trace contexts? */);
}
-void factor_vm::add_gc_stats(generation_statistics *stats, growable_array *result)
+void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
{
- 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));
+ data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
+ primitive_minor_gc();
+ data_roots.pop_back();
}
-void factor_vm::primitive_clear_gc_stats()
+VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
{
- clear_gc_stats();
+ parent->inline_gc(data_roots_base,data_roots_size);
}
-/* 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()
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+object *factor_vm::allot_large_object(cell type, cell 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++)
+ /* If tenured space does not have enough room, collect and compact */
+ if(!data->tenured->can_allot_p(size))
{
- tagged<object> old_obj(array_nth(old_objects,i));
- tagged<object> new_obj(array_nth(new_objects,i));
+ primitive_compact_gc();
- if(old_obj != new_obj)
- old_obj->h.forward_to(new_obj.untagged());
+ /* If it still won't fit, grow the heap */
+ if(!data->tenured->can_allot_p(size))
+ {
+ gc(collect_growing_heap_op,
+ size, /* requested size */
+ true /* trace contexts? */);
+ }
}
- primitive_full_gc();
+ object *obj = data->tenured->allot(size);
- /* 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]);
+ /* 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);
- primitive_minor_gc();
-
- for(cell i = 0; i < gc_roots_size; i++)
- gc_locals.pop_back();
+ obj->initialize(type);
+ return obj;
}
-VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *parent)
+void factor_vm::primitive_enable_gc_events()
{
- parent->inline_gc(gc_roots_base,gc_roots_size);
+ gc_events = new std::vector<gc_event>();
}
-/*
- * 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)
+void factor_vm::primitive_disable_gc_events()
{
-#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(gc_events)
{
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + size > nursery.end)
- primitive_minor_gc();
+ growable_array result(this);
- 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();
+ std::vector<gc_event> *gc_events = this->gc_events;
+ this->gc_events = NULL;
- /* If it still won't fit, grow the heap */
- if(data->tenured->here + size > data->tenured->end)
+ std::vector<gc_event>::const_iterator iter = gc_events->begin();
+ std::vector<gc_event>::const_iterator end = gc_events->end();
+
+ for(; iter != end; iter++)
{
- gc(collect_growing_heap_op,
- size, /* requested size */
- true, /* trace contexts? */
- false /* compact code heap? */);
+ gc_event event = *iter;
+ byte_array *obj = byte_array_from_value(&event);
+ result.add(tag<byte_array>(obj));
}
- obj = data->tenured->allot(size);
+ result.trim();
+ dpush(result.elements.value());
- /* 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));
+ delete this->gc_events;
}
-
- obj->h = header;
- return obj;
+ 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;
+ u64 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 {
cell data_relocation_base,
cell code_relocation_base)
{
- cell hi_tag = object->h.hi_tag();
+ cell type = object->type();
/* Tuple relocation is a bit trickier; we have to fix up the
- layout object before we can get the tuple size, so do_slots is
+ layout object before we can get the tuple size, so each_slot is
out of the question */
- if(hi_tag == TUPLE_TYPE)
+ if(type == TUPLE_TYPE)
{
tuple *t = (tuple *)object;
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);
+ object->each_slot(fixupper);
- switch(hi_tag)
+ switch(type)
{
case WORD_TYPE:
fixup_word((word *)object,code_relocation_base);
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
-/* 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 {
- cell value;
+#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
+
+struct object {
+ NO_TYPE_CHECK;
+ cell header;
- /* Default ctor to make gcc 3.x happy */
- explicit header() { abort(); }
+ cell size() const;
+ cell binary_payload_start() const;
- explicit header(cell value_) : value(value_ << TAG_BITS) {}
+ cell *slots() const { return (cell *)this; }
- void check_header() {
-#ifdef FACTOR_DEBUG
- assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
-#endif
+ template<typename Iterator> void each_slot(Iterator &iter);
+
+ /* Only valid for objects in tenured space; must cast to free_heap_block
+ to do anything with it if its free */
+ bool free_p() const
+ {
+ return (header & 1) == 1;
}
- cell hi_tag() {
- check_header();
- return value >> TAG_BITS;
+ cell type() const
+ {
+ return (header >> 2) & TAG_MASK;
}
- bool forwarding_pointer_p() {
- return TAG(value) == GC_COLLECTED;
+ void initialize(cell type)
+ {
+ header = type << 2;
}
- object *forwarding_pointer() {
- return (object *)UNTAG(value);
+ cell hashcode() const
+ {
+ return (header >> 6);
}
- void forward_to(object *pointer) {
- value = RETAG(pointer,GC_COLLECTED);
+ void set_hashcode(cell hashcode)
+ {
+ header = (header & 0x3f) | (hashcode << 6);
}
-};
-#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
+ bool forwarding_pointer_p() const
+ {
+ return (header & 2) == 2;
+ }
-struct object {
- NO_TYPE_CHECK;
- header h;
- cell *slots() { return (cell *)this; }
+ object *forwarding_pointer() const
+ {
+ return (object *)UNTAG(header);
+ }
+
+ void forward_to(object *pointer)
+ {
+ header = ((cell)pointer | 2);
+ }
};
/* 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;
+ }
- void *xt() { return (void *)(this + 1); }
+ bool optimized_p() const
+ {
+ return type() == code_block_optimized;
+ }
+
+ 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)
-
-}
else
signal_callstack_top = NULL;
- MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+ MACH_STACK_POINTER(thread_state) = align_stack_pointer(MACH_STACK_POINTER(thread_state));
/* Now we point the program counter at the right handler function. */
if(exception == EXC_BAD_ACCESS)
}
else
{
- signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
+ switch(exception)
+ {
+ case EXC_ARITHMETIC: signal_number = SIGFPE; break;
+ case EXC_BAD_INSTRUCTION: signal_number = SIGILL; break;
+ default: signal_number = SIGABRT; break;
+ }
+
MACH_PROGRAM_COUNTER(thread_state) = (cell)factor::misc_signal_handler_impl;
}
}
{
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);
}
fatal_error("mach_port_insert_right() failed",0);
/* The exceptions we want to catch. */
- mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
+ mask = EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC;
/* Create the thread listening on the exception port. */
start_thread(mach_exception_thread,NULL);
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_identity_hashcode()
+{
+ cell tagged = dpeek();
+ object *obj = untag<object>(tagged);
+ drepl(tag_fixnum(obj->hashcode()));
+}
+
+void factor_vm::compute_identity_hashcode(object *obj)
+{
+ object_counter++;
+ if(object_counter == 0) object_counter++;
+ obj->set_hashcode((cell)obj ^ object_counter);
+}
+
+void factor_vm::primitive_compute_identity_hashcode()
+{
+ object *obj = untag<object>(dpop());
+ compute_identity_hashcode(obj);
+}
+
+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(obj.type(),size);
+ memcpy(new_obj,obj.untagged(),size);
+ new_obj->set_hashcode(0);
+ 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,
+
+ /* Incremented on every modify-code-heap call; invalidates call( inline
+ caching */
+ REDEFINITION_COUNTER = 46,
+
+ /* 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);
+}
+
+template<typename Iterator> void object::each_slot(Iterator &iter)
+{
+ cell scan = (cell)this;
+ cell payload_start = binary_payload_start();
+ cell end = scan + payload_start;
+
+ scan += sizeof(cell);
+
+ while(scan < end)
+ {
+ iter((cell *)scan);
+ scan += sizeof(cell);
+ }
+}
+
+}
+++ /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);
-};
-
-}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_esp;
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
}
}
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_esp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_eip)
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.mc_rsp;
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
}
}
-#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rsp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.mc_rip)
}
const char *vm_executable_path();
const char *default_image_path();
+template<typename Type> Type align_stack_pointer(Type sp)
+{
+ return sp;
+}
+
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.arm_sp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-
void flush_icache(cell start, cell len);
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_sp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.arm_pc)
+
}
{
#define FRAME_RETURN_ADDRESS(frame,vm) *((void **)(vm->frame_successor(frame) + 1) + 1)
-
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+#define UAP_STACK_POINTER(ucontext) ((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_R1]
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.uc_regs->gregs[PT_NIP])
}
#define X86_FXSR_MAGIC 0x0000
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
fpregs->mxcsr &= 0xffffffc0;
}
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[7])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[14])
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[15];
-}
-
inline static unsigned int uap_fpu_status(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
}
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[16])
}
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
return sp;
}
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
- return ((sp + 4) & ~15) - 4;
+ return (Type)((((cell)sp + 4) & ~15) - 4);
}
inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
return mach_fpu_status(UAP_FS(uap));
}
-inline static cell fix_stack_pointer(cell sp)
+template<typename Type> Type align_stack_pointer(Type sp)
{
- return ((sp + 8) & ~15) - 8;
+ return (Type)((((cell)sp + 8) & ~15) - 8);
}
inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
const char *vm_executable_path();
const char *default_image_path();
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
-
void c_to_factor_toplevel(cell quot);
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_stack.ss_sp)
+
}
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
namespace factor
{
-#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (_UC_MACHINE_SP((ucontext_t *)ucontext))
}
namespace factor
{
-#define ucontext_stack_pointer(uap) \
- ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.__gregs[_REG_URSP])
}
namespace factor
{
-inline static void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_esp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_esp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_eip)
}
namespace factor
{
-inline static void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_rsp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
-
static inline unsigned int uap_fpu_status(void *uap) { return 0; }
-static inline void uap_clear_fpu_status(void *uap) { }
+static inline void uap_clear_fpu_status(void *uap) {}
+
+#define UAP_STACK_POINTER(ucontext) (((struct sigcontext *)ucontext)->sc_rsp)
+#define UAP_PROGRAM_COUNTER(ucontext) (((struct sigcontext *)ucontext)->sc_rip)
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[ESP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[ESP])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[EIP])
}
namespace factor
{
-inline static void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[RSP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
+#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RSP])
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[RIP])
}
if(retval)
fatal_error("Segment deallocation failed",0);
}
-
-stack_frame *factor_vm::uap_stack_pointer(void *uap)
+
+void factor_vm::dispatch_signal(void *uap, void (handler)())
{
- /* There is a race condition here, but in practice a signal
- delivered during stack frame setup/teardown or while transitioning
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
{
- stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
- if(!ptr)
- critical_error("Invalid uap",(cell)uap);
- return ptr;
+ stack_frame *ptr = (stack_frame *)UAP_STACK_POINTER(uap);
+ assert(ptr);
+ signal_callstack_top = ptr;
}
else
- return NULL;
-}
+ signal_callstack_top = NULL;
-void factor_vm::memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- signal_fault_addr = (cell)siginfo->si_addr;
- signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)factor::memory_signal_handler_impl;
+ UAP_STACK_POINTER(uap) = align_stack_pointer(UAP_STACK_POINTER(uap));
+ UAP_PROGRAM_COUNTER(uap) = (cell)handler;
}
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- tls_vm()->memory_signal_handler(signal,siginfo,uap);
-}
-
-void factor_vm::misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- signal_number = signal;
- signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (cell)factor::misc_signal_handler_impl;
+ factor_vm *vm = tls_vm();
+ vm->signal_fault_addr = (cell)siginfo->si_addr;
+ vm->dispatch_signal(uap,factor::memory_signal_handler_impl);
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- tls_vm()->misc_signal_handler(signal,siginfo,uap);
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->dispatch_signal(uap,factor::misc_signal_handler_impl);
}
-void factor_vm::fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- signal_number = signal;
- signal_callstack_top = uap_stack_pointer(uap);
- signal_fpu_status = fpu_status(uap_fpu_status(uap));
+ factor_vm *vm = tls_vm();
+ vm->signal_number = signal;
+ vm->signal_fpu_status = fpu_status(uap_fpu_status(uap));
uap_clear_fpu_status(uap);
- UAP_PROGRAM_COUNTER(uap) =
- (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
- ? (cell)factor::misc_signal_handler_impl
- : (cell)factor::fp_signal_handler_impl;
-}
-void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- tls_vm()->fpe_signal_handler(signal, siginfo, uap);
+ vm->dispatch_signal(uap,
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? factor::misc_signal_handler_impl
+ : factor::fp_signal_handler_impl);
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
#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)
+PRIMITIVE_FORWARD(identity_hashcode)
+PRIMITIVE_FORWARD(compute_identity_hashcode)
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,
+ primitive_identity_hashcode,
+ primitive_compute_identity_hashcode,
};
}
/* 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,
- SHUTDOWN_ENV = 67,
-};
-
-#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);
void factor_vm::primitive_resize_string()
{
- string* str = untag_check<string>(dpop());
+ data_root<string> str(dpop(),this);
+ str.untag_check(this);
cell capacity = unbox_array_size();
- dpush(tag<string>(reallot_string(str,capacity)));
+ dpush(tag<string>(reallot_string(str.untagged(),capacity)));
}
void factor_vm::primitive_string_nth()
{
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->type());
}
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;
+ /* Incrementing object counter for identity hashing */
+ cell object_counter;
+
// contexts
void reset_datastack();
void reset_retainstack();
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();
+ void primitive_identity_hashcode();
+ void compute_identity_hashcode(object *obj);
+ void primitive_compute_identity_hashcode();
+ 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)
+ {
+ cell start = (cell)obj & -card_size;
+ cell end = ((cell)obj + size + card_size - 1) & -card_size;
+
+ for(cell offset = start; offset < end; offset += card_size)
+ write_barrier((cell *)offset);
+ }
+
+ // data heap checker
+ void check_data_heap();
+
// 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);
- object *allot_object(header header, cell size);
- void add_gc_stats(generation_statistics *stats, growable_array *result);
- void primitive_clear_gc_stats();
+ void inline_gc(cell *data_roots_base, cell data_roots_size);
+ void primitive_enable_gc_events();
+ void primitive_disable_gc_events();
+ object *allot_object(cell type, cell size);
+ object *allot_large_object(cell type, cell size);
template<typename Type> Type *allot(cell size)
{
- return (Type *)allot_object(header(Type::type_number),size);
+ return (Type *)allot_object(Type::type_number,size);
}
inline void check_data_pointer(object *pointer)
#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);
+
//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);
void save_callstack_bottom(stack_frame *callstack_bottom);
template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
- /* 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)
- {
- cell scan = obj;
- cell payload_start = binary_payload_start((object *)obj);
- cell end = obj + payload_start;
-
- scan += sizeof(cell);
-
- while(scan < end)
- {
- iter((cell *)scan);
- scan += sizeof(cell);
- }
- }
-
//alien
char *pinned_alien_offset(cell obj);
cell allot_alien(cell delegate_, cell displacement);
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);
void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);
bool windows_stat(vm_char *path);
- #if defined(WINNT)
+ #if defined(WINNT)
void open_console();
LONG exception_handler(PEXCEPTION_POINTERS pe);
- // next method here:
- #endif
+ #endif
#else // UNIX
- void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap);
- stack_frame *uap_stack_pointer(void *uap);
-
+ void dispatch_signal(void *uap, void (handler)());
#endif
#ifdef __APPLE__
};
-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;
- }
-};
-
-}
projects / factor.git / commitdiff
