steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-05-12 09:23:59 -03:00
parent 422195b052 cc390dd53a
commit c1a5eeb432
59 changed files with 1988 additions and 292 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/strings/strings.factor Normal file → Executable file
View File

@ -85,10 +85,10 @@ M: string-type c-type-getter
M: string-type c-type-setter
drop [ set-alien-cell ] ;
TUPLE: utf16n ;
! Native-order UTF-16
SINGLETON: utf16n
: utf16n ( -- descriptor )
little-endian? utf16le utf16be ? ; foldable

16
core/bootstrap/primitives.factor
View File

@ -5,8 +5,9 @@ hashtables.private io kernel math namespaces parser sequences
strings vectors words quotations assocs layouts classes
classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
slots.deprecated classes.union compiler.units
bootstrap.image.private io.files accessors combinators ;
slots.deprecated classes.union classes.intersection
compiler.units bootstrap.image.private io.files accessors
combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
@ -127,7 +128,7 @@ bootstrapping? on
: register-builtin ( class -- )
[ dup lookup-type-number "type" set-word-prop ]
[ dup "type" word-prop builtins get set-nth ]
[ f f builtin-class define-class ]
[ f f f builtin-class define-class ]
tri ;
: define-builtin-slots ( symbol slotspec -- )
@ -159,8 +160,13 @@ bootstrapping? on
"tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method.
! "object" "kernel" create
! [ f builtins get [ ] filter f union-class define-class ]
! [ [ drop t ] "predicate" set-word-prop ]
! bi
"object" "kernel" create
[ f builtins get [ ] filter union-class define-class ]
[ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ]
bi
@ -172,7 +178,7 @@ builtins get num-tags get tail define-union-class
! Empty class with no instances
"null" "kernel" create
[ f { } union-class define-class ]
[ f { } f union-class define-class ]
[ [ drop f ] "predicate" set-word-prop ]
bi

1
core/bootstrap/syntax.factor
View File

@ -46,6 +46,7 @@ IN: bootstrap.syntax
"TUPLE:"
"T{"
"UNION:"
"INTERSECTION:"
"USE:"
"USING:"
"V{"

43
core/classes/algebra/algebra-tests.factor
View File

@ -1,10 +1,16 @@
IN: classes.algebra.tests
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
random inference effects kernel.private sbufs math.order ;
IN: classes.algebra.tests
\ class< must-infer
\ class-and must-infer
\ class-or must-infer
\ flatten-class must-infer
\ flatten-builtin-class must-infer
: class= [ class<= ] [ swap class<= ] 2bi and ;
@ -261,3 +267,38 @@ TUPLE: xg < xb ;
TUPLE: xh < xb ;
[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
INTERSECTION: generic-class generic class ;
[ t ] [ generic-class generic class<= ] unit-test
[ t ] [ generic-class \ class class<= ] unit-test
! Later
[
[ t ] [ \ class generic class-and generic-class class<= ] unit-test
[ t ] [ \ class generic class-and generic-class swap class<= ] unit-test
] drop
[ t ] [ \ word generic-class classes-intersect? ] unit-test
[ f ] [ number generic-class classes-intersect? ] unit-test
[ H{ { word word } } ] [
generic-class flatten-class
] unit-test
INTERSECTION: empty-intersection ;
[ t ] [ object empty-intersection class<= ] unit-test
[ t ] [ empty-intersection object class<= ] unit-test
[ t ] [ \ f class-not empty-intersection class<= ] unit-test
[ f ] [ empty-intersection \ f class-not class<= ] unit-test
[ t ] [ \ number empty-intersection class<= ] unit-test
[ t ] [ empty-intersection class-not null class<= ] unit-test
[ t ] [ null empty-intersection class-not class<= ] unit-test
[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
[ ] [ object flatten-builtin-class drop ] unit-test

162
core/classes/algebra/algebra.factor
View File

@ -37,7 +37,7 @@ TUPLE: anonymous-union members ;
C: <anonymous-union> anonymous-union
TUPLE: anonymous-intersection members ;
TUPLE: anonymous-intersection participants ;
C: <anonymous-intersection> anonymous-intersection
@ -48,57 +48,83 @@ C: <anonymous-complement> anonymous-complement
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
: left-union-class<= ( first second -- ? )
>r members r> [ class<= ] curry all? ;
: right-union-class<= ( first second -- ? )
members [ class<= ] with contains? ;
: left-anonymous-union< ( first second -- ? )
: left-anonymous-union<= ( first second -- ? )
>r members>> r> [ class<= ] curry all? ;
: right-anonymous-union< ( first second -- ? )
: right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with contains? ;
: left-anonymous-intersection< ( first second -- ? )
>r members>> r> [ class<= ] curry contains? ;
: left-anonymous-intersection<= ( first second -- ? )
>r participants>> r> [ class<= ] curry contains? ;
: right-anonymous-intersection< ( first second -- ? )
members>> [ class<= ] with all? ;
: right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ;
: anonymous-complement< ( first second -- ? )
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
: (class<=) ( first second -- -1/0/1 )
: normalize-class ( class -- class' )
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup object eq? ] [ 2drop t ] }
{ [ over null eq? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }
{ [ over anonymous-union? ] [ left-anonymous-union< ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }
{ [ over members ] [ left-union-class<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union< ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }
{ [ over anonymous-complement? ] [ 2drop f ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ dup members ] [ right-union-class<= ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
{ [ dup members ] [ members <anonymous-union> ] }
{ [ dup participants ] [ participants <anonymous-intersection> ] }
[ ]
} cond ;
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
members>>
[ class-not normalize-class ] map
<anonymous-intersection>
] }
{ [ dup anonymous-intersection? ] [
participants>>
[ class-not normalize-class ] map
<anonymous-union>
] }
} cond ;
: left-anonymous-complement<= ( first second -- ? )
>r normalize-complement r> class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> {
[ anonymous-union? ]
[ anonymous-intersection? ]
[ members ]
[ participants ]
} cleave or or or ;
PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 )
2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ {
{ [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
{ [ over superclass ] [ superclass<= ] }
[ 2drop f ]
} cond
] if ;
: anonymous-union-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with contains? ;
: anonymous-intersection-intersect? ( first second -- ? )
members>> [ classes-intersect? ] with all? ;
participants>> [ classes-intersect? ] with all? ;
: anonymous-complement-intersect? ( first second -- ? )
class>> class<= not ;
: union-class-intersect? ( first second -- ? )
members [ classes-intersect? ] with contains? ;
: tuple-class-intersect? ( first second -- ? )
{
{ [ over tuple eq? ] [ 2drop t ] }
@ -115,61 +141,57 @@ C: <anonymous-complement> anonymous-complement
} cond ;
: (classes-intersect?) ( first second -- ? )
{
normalize-class {
{ [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
{ [ dup tuple-class? ] [ tuple-class-intersect? ] }
{ [ dup builtin-class? ] [ builtin-class-intersect? ] }
{ [ dup superclass ] [ superclass classes-intersect? ] }
{ [ dup members ] [ union-class-intersect? ] }
} cond ;
: left-union-and ( first second -- class )
>r members r> [ class-and ] curry map <anonymous-union> ;
: right-union-and ( first second -- class )
members [ class-and ] with map <anonymous-union> ;
: left-anonymous-union-and ( first second -- class )
>r members>> r> [ class-and ] curry map <anonymous-union> ;
: right-anonymous-union-and ( first second -- class )
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
: left-anonymous-intersection-and ( first second -- class )
>r members>> r> suffix <anonymous-intersection> ;
: right-anonymous-intersection-and ( first second -- class )
members>> swap suffix <anonymous-intersection> ;
: anonymous-intersection-and ( first second -- class )
participants>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class )
{
{ [ 2dup class<= ] [ drop ] }
{ [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] }
{ [ dup members ] [ right-union-and ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }
{ [ over members ] [ left-union-and ] }
{ [ over anonymous-union? ] [ left-anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ]
[
[ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
{ [ over anonymous-union? ] [ swap anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ]
} cond
]
} cond ;
: left-anonymous-union-or ( first second -- class )
>r members>> r> suffix <anonymous-union> ;
: right-anonymous-union-or ( first second -- class )
: anonymous-union-or ( first second -- class )
members>> swap suffix <anonymous-union> ;
: ((class-or)) ( first second -- class )
[ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-or ] }
{ [ over anonymous-union? ] [ swap anonymous-union-or ] }
[ 2array <anonymous-union> ]
} cond ;
: anonymous-complement-or ( first second -- class )
2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
: (class-or) ( first second -- class )
{
{ [ 2dup class<= ] [ nip ] }
{ [ 2dup swap class<= ] [ drop ] }
{ [ dup anonymous-union? ] [ right-anonymous-union-or ] }
{ [ over anonymous-union? ] [ left-anonymous-union-or ] }
[ 2array <anonymous-union> ]
{ [ dup anonymous-complement? ] [ anonymous-complement-or ] }
{ [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
[ ((class-or)) ]
} cond ;
: (class-not) ( class -- complement )
@ -203,11 +225,23 @@ C: <anonymous-complement> anonymous-complement
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
DEFER: (flatten-class)
DEFER: flatten-builtin-class
: flatten-intersection-class ( class -- )
participants [ flatten-builtin-class ] map
dup empty? [
drop builtins get [ (flatten-class) ] each
] [
unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
] if ;
: (flatten-class) ( class -- )
{
{ [ dup tuple-class? ] [ dup set ] }
{ [ dup builtin-class? ] [ dup set ] }
{ [ dup members ] [ members [ (flatten-class) ] each ] }
{ [ dup participants ] [ flatten-intersection-class ] }
{ [ dup superclass ] [ superclass (flatten-class) ] }
[ drop ]
} cond ;

7
core/classes/classes-docs.factor
View File

@ -40,6 +40,7 @@ $nl
"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "intersections" }
{ $subsection "mixins" }
{ $subsection "predicates" }
{ $subsection "singletons" }
@ -86,7 +87,11 @@ HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
HELP: participants
{ $values { "class" class } { "seq" "a sequence of intersection participants, or " { $link f } } }
{ $description "If " { $snippet "class" } " is an intersection class, outputs a sequence of its participant classes, otherwise outputs " { $link f } "." } ;
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $values { "word" word } { "superclass" class } { "members" "a sequence of class words" } { "participants" "a sequence of class words" } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;

25
core/classes/classes.factor
View File

@ -57,6 +57,10 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ;
#! Output f for non-classes to work with algebra code
dup class? [ "members" word-prop ] [ drop f ] if ;
: participants ( class -- seq )
#! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
@ -67,7 +71,12 @@ M: word reset-class drop ;
! update-map
: class-uses ( class -- seq )
[ members ] [ superclass ] bi [ suffix ] when* ;
[
[ members % ]
[ participants % ]
[ superclass [ , ] when* ]
tri
] { } make ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
@ -78,12 +87,14 @@ M: word reset-class drop ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
: make-class-props ( superclass members metaclass -- assoc )
: make-class-props ( superclass members participants metaclass -- assoc )
[
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ "metaclass" set ]
tri*
{
[ dup [ bootstrap-word ] when "superclass" set ]
[ [ bootstrap-word ] map "members" set ]
[ [ bootstrap-word ] map "participants" set ]
[ "metaclass" set ]
} spread
] H{ } make-assoc ;
: (define-class) ( word props -- )
@ -112,7 +123,7 @@ GENERIC: update-methods ( assoc -- )
[ update-methods ]
bi ;
: define-class ( word superclass members metaclass -- )
: define-class ( word superclass members participants metaclass -- )
#! If it was already a class, update methods after.
reset-caches
make-class-props

28
core/classes/intersection/intersection-docs.factor Normal file
View File

@ -0,0 +1,28 @@
USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
layouts classes.private classes compiler.units ;
IN: classes.intersection
ARTICLE: "intersections" "Intersection classes"
"An object is an instance of a intersection class if it is an instance of all of its participants."
{ $subsection POSTPONE: INTERSECTION: }
{ $subsection define-intersection-class }
"Intersection classes can be introspected:"
{ $subsection participants }
"The set of intersection classes is a class:"
{ $subsection intersection-class }
{ $subsection intersection-class? }
"Intersection classes are used to associate a method with objects which are simultaneously instances of multiple different classes, as well as to conveniently define predicates." ;
ABOUT: "intersections"
HELP: define-intersection-class
{ $values { "class" class } { "participants" "a sequence of classes" } }
{ $description "Defines a intersection class with specified participants. This is the run time equivalent of " { $link POSTPONE: INTERSECTION: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
{ intersection-class define-intersection-class POSTPONE: INTERSECTION: } related-words
HELP: intersection-class
{ $class-description "The class of intersection classes." } ;

33
core/classes/intersection/intersection.factor Normal file
View File

@ -0,0 +1,33 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
: intersection-predicate-quot ( members -- quot )
dup empty? [
drop [ drop t ]
] [
unclip "predicate" word-prop swap [
"predicate" word-prop [ dup ] swap [ not ] 3append
[ drop f ]
] { } map>assoc alist>quot
] if ;
: define-intersection-predicate ( class -- )
dup participants intersection-predicate-quot define-predicate ;
M: intersection-class update-class define-intersection-predicate ;
: define-intersection-class ( class participants -- )
[ f f rot intersection-class define-class ]
[ drop update-classes ]
2bi ;
M: intersection-class reset-class
{ "class" "metaclass" "participants" } reset-props ;
M: intersection-class rank-class drop 2 ;

2
core/classes/predicate/predicate.factor
View File

@ -14,7 +14,7 @@ PREDICATE: predicate-class < class
] [ ] make ;
: define-predicate-class ( class superclass definition -- )
[ drop f predicate-class define-class ]
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
[
2drop

7
core/classes/singleton/singleton-tests.factor
View File

@ -10,3 +10,10 @@ GENERIC: zammo ( obj -- str )
[ ] [ SINGLETON: omg ] unit-test
[ t ] [ omg singleton-class? ] unit-test
[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
SINGLETON: word-and-singleton
: word-and-singleton 3 ;
[ t ] [ \ word-and-singleton word-and-singleton? ] unit-test
[ 3 ] [ word-and-singleton ] unit-test

4
core/classes/tuple/tuple-tests.factor
View File

@ -541,7 +541,7 @@ TUPLE: another-forget-accessors-test ;
] unit-test
! Missing error check
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
TUPLE: subclass-forget-test ;
@ -554,3 +554,5 @@ TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail

8
core/classes/tuple/tuple.factor
View File

@ -160,7 +160,7 @@ M: tuple-class update-class
tri ;
: define-new-tuple-class ( class superclass slots -- )
[ drop f tuple-class define-class ]
[ drop f f tuple-class define-class ]
[ nip "slot-names" set-word-prop ]
[ 2drop update-classes ]
3tri ;
@ -226,6 +226,12 @@ M: tuple-class reset-class
} reset-props
] bi ;
: reset-tuple-class ( class -- )
[ [ reset-class ] [ update-map- ] bi ] each-subclass ;
M: tuple-class forget*
[ reset-tuple-class ] [ call-next-method ] bi ;
M: tuple-class rank-class drop 0 ;
M: tuple clone

4
core/classes/union/union-docs.factor
View File

@ -4,7 +4,7 @@ layouts classes.private classes compiler.units ;
IN: classes.union
ARTICLE: "unions" "Union classes"
"An object is an instance of a union class if it is an instance of one of its members. Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates."
"An object is an instance of a union class if it is an instance of one of its members."
{ $subsection POSTPONE: UNION: }
{ $subsection define-union-class }
"Union classes can be introspected:"
@ -12,7 +12,7 @@ ARTICLE: "unions" "Union classes"
"The set of union classes is a class:"
{ $subsection union-class }
{ $subsection union-class? }
"Unions are used to define behavior shared between a fixed set of classes."
"Unions are used to define behavior shared between a fixed set of classes, as well as to conveniently define predicates."
{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"

3
core/classes/union/union.factor
View File

@ -7,7 +7,6 @@ IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
@ -24,7 +23,7 @@ PREDICATE: union-class < class
M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
[ f swap union-class define-class ]
[ f swap f union-class define-class ]
[ drop update-classes ]
2bi ;

25
core/generic/generic.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects ;
classes.algebra quotations arrays vocabs effects combinators ;
IN: generic
! Method combination protocol
@ -123,12 +123,13 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
dup generic? [
[ delete-at* ] with-methods
[ call-next-method ] [ drop ] if
] [ 2drop ] if
[ ]
[ "method-class" word-prop ]
[ "method-generic" word-prop ] tri
3dup method eq? [
[ delete-at ] with-methods
call-next-method
] [ 3drop ] if
]
[ t "forgotten" set-word-prop ] bi
] if ;
@ -146,10 +147,12 @@ M: method-body forget*
[ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
[ forget-methods ]
[ update-map- ]
[ call-next-method ]
tri ;
{
[ forget-methods ]
[ update-map- ]
[ reset-class ]
[ call-next-method ]
} cleave ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;

2
core/io/encodings/binary/binary.factor Normal file → Executable file
View File

@ -3,6 +3,6 @@
USING: io.encodings kernel ;
IN: io.encodings.binary
TUPLE: binary ;
SINGLETON: binary
M: binary <encoder> drop ;
M: binary <decoder> drop ;

21
core/io/encodings/encodings-tests.factor
View File

@ -1,5 +1,6 @@
USING: io.files io.streams.string io
tools.test kernel io.encodings.ascii ;
USING: io.files io.streams.string io io.streams.byte-array
tools.test kernel io.encodings.ascii io.encodings.utf8
namespaces accessors io.encodings ;
IN: io.streams.encodings.tests
[ { } ]
@ -56,3 +57,19 @@ unit-test
dup stream-readln drop
stream-read1
] unit-test
[ utf8 ascii ] [
"foo" utf8 [
input-stream get code>>
ascii decode-input
input-stream get code>>
] with-byte-reader
] unit-test
[ utf8 ascii ] [
utf8 [
output-stream get code>>
ascii encode-output
output-stream get code>>
] with-byte-writer drop
] unit-test

19
core/io/encodings/encodings.factor
View File

@ -30,8 +30,7 @@ ERROR: encode-error ;
<PRIVATE
M: tuple-class <decoder> new <decoder> ;
M: tuple <decoder> f decoder boa ;
M: object <decoder> f decoder boa ;
: >decoder< ( decoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
@ -104,8 +103,7 @@ M: decoder stream-readln ( stream -- str )
M: decoder dispose decoder-stream dispose ;
! Encoding
M: tuple-class <encoder> new <encoder> ;
M: tuple <encoder> encoder boa ;
M: object <encoder> encoder boa ;
: >encoder< ( encoder -- stream encoding )
[ stream>> ] [ code>> ] bi ;
@ -121,13 +119,16 @@ M: encoder dispose encoder-stream dispose ;
M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer
PRIVATE>
! Rebinding duplex streams which have not read anything yet
: reencode ( stream encoding -- newstream )
: re-encode ( stream encoding -- newstream )
over encoder? [ >r encoder-stream r> ] when <encoder> ;
: redecode ( stream encoding -- newstream )
: encode-output ( encoding -- )
output-stream [ swap re-encode ] change ;
: re-decode ( stream encoding -- newstream )
over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE>
: decode-input ( encoding -- )
input-stream [ swap re-decode ] change ;

2
core/io/encodings/utf16/utf16-tests.factor
View File

@ -24,7 +24,7 @@ IN: io.encodings.utf16.tests
[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
: correct-endian
code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
[ t ] [ utf16n <byte-writer> correct-endian ] unit-test

6
core/io/encodings/utf16/utf16.factor
View File

@ -4,11 +4,11 @@ USING: math kernel sequences sbufs vectors namespaces io.binary
io.encodings combinators splitting io byte-arrays inspector ;
IN: io.encodings.utf16
TUPLE: utf16be ;
SINGLETON: utf16be
TUPLE: utf16le ;
SINGLETON: utf16le
TUPLE: utf16 ;
SINGLETON: utf16
<PRIVATE

2
core/io/encodings/utf8/utf8.factor Normal file → Executable file
View File

@ -6,7 +6,7 @@ IN: io.encodings.utf8
! Decoding UTF-8
TUPLE: utf8 ;
SINGLETON: utf8
<PRIVATE

3
core/io/files/files-tests.factor
View File

@ -66,6 +66,9 @@ strings accessors io.encodings.utf8 math ;
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
[ "" ] [ "" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:freetype6.dll" file-name ] unit-test
[ "freetype6.dll" ] [ "resource:/freetype6.dll" file-name ] unit-test
[ ] [
{ "Hello world." }
"test-foo.txt" temp-file ascii set-file-lines

4
core/io/files/files.factor
View File

@ -142,7 +142,9 @@ PRIVATE>
: file-name ( path -- string )
dup root-directory? [
right-trim-separators
dup last-path-separator [ 1+ tail ] [ drop ] if
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
] unless ;
! File info

2
core/io/streams/string/string.factor
View File

@ -49,7 +49,7 @@ M: growable stream-read
M: growable stream-read-partial
stream-read ;
TUPLE: null ;
SINGLETON: null
M: null decode-char drop stream-read1 ;
: <string-reader> ( str -- stream )

25
core/parser/parser-tests.factor
View File

@ -435,3 +435,28 @@ must-fail-with
[ 92 ] [ "CHAR: \\" eval ] unit-test
[ 92 ] [ "CHAR: \\\\" eval ] unit-test
[ ] [
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC: change-combination"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ ] [
{
"IN: parser.tests"
"USING: math arrays ;"
"GENERIC# change-combination 1"
"M: integer change-combination 1 ;"
"M: array change-combination 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ 2 ] [
"change-combination" "parser.tests" lookup
"methods" word-prop assoc-size
] unit-test

6
core/prettyprint/prettyprint-tests.factor
View File

@ -334,5 +334,11 @@ PREDICATE: predicate-see-test < integer even? ;
[ \ predicate-see-test see ] with-string-writer
] unit-test
INTERSECTION: intersection-see-test sequence number ;
[ "USING: math sequences ;\nIN: prettyprint.tests\nINTERSECTION: intersection-see-test sequence number ;\n" ] [
[ \ intersection-see-test see ] with-string-writer
] unit-test
[ ] [ \ compose see ] unit-test
[ ] [ \ curry see ] unit-test

9
core/prettyprint/prettyprint.factor
View File

@ -7,8 +7,8 @@ vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.predicate classes.singleton combinators quotations
sets ;
classes.intersection classes.predicate classes.singleton
combinators quotations sets ;
: make-pprint ( obj quot -- block in use )
[
@ -238,6 +238,11 @@ M: union-class see-class*
dup pprint-word
members pprint-elements pprint-; block> ;
M: intersection-class see-class*
<colon \ INTERSECTION: pprint-word
dup pprint-word
participants pprint-elements pprint-; block> ;
M: mixin-class see-class*
<block \ MIXIN: pprint-word
dup pprint-word <block

9
core/syntax/syntax-docs.factor
View File

@ -496,14 +496,17 @@ HELP: M:
HELP: UNION:
{ $syntax "UNION: class members... ;" }
{ $values { "class" "a new class word to define" } { "members" "a list of class words separated by whitespace" } }
{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." }
{ $notes "Union classes are used to associate the same method with several different classes, as well as to conveniently define predicates." } ;
{ $description "Defines a union class. An object is an instance of a union class if it is an instance of one of its members." } ;
HELP: INTERSECTION:
{ $syntax "INTERSECTION: class participants... ;" }
{ $values { "class" "a new class word to define" } { "participants" "a list of class words separated by whitespace" } }
{ $description "Defines an intersection class. An object is an instance of a union class if it is an instance of all of its participants." } ;
HELP: MIXIN:
{ $syntax "MIXIN: class" }
{ $values { "class" "a new class word to define" } }
{ $description "Defines a mixin class. A mixin is similar to a union class, except it has no members initially, and new members can be added with the " { $link POSTPONE: INSTANCE: } " word." }
{ $notes "Mixins classes are used to mark implementations of a protocol and define default methods." }
{ $examples "The " { $link sequence } " and " { $link assoc } " mixin classes." } ;
HELP: INSTANCE:

12
core/syntax/syntax.factor
View File

@ -5,8 +5,9 @@ definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
quotations io assocs splitting classes.tuple generic.standard
generic.math classes io.files vocabs float-arrays
classes.union classes.mixin classes.predicate classes.singleton
compiler.units combinators debugger ;
classes.union classes.intersection classes.mixin
classes.predicate classes.singleton compiler.units
combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
@ -135,6 +136,10 @@ IN: bootstrap.syntax
CREATE-CLASS parse-definition define-union-class
] define-syntax
"INTERSECTION:" [
CREATE-CLASS parse-definition define-intersection-class
] define-syntax
"MIXIN:" [
CREATE-CLASS define-mixin-class
] define-syntax
@ -153,8 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"SINGLETON:" [
scan create-class-in
dup save-location define-singleton-class
CREATE-CLASS define-singleton-class
] define-syntax
"TUPLE:" [

4
core/words/words.factor
View File

@ -3,7 +3,7 @@
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
quotations assocs hashtables sorting words.private vocabs
math.order ;
math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
@ -121,7 +121,7 @@ SYMBOL: +called+
compiled-crossref get at ;
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
[ unique dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-filter update
] with each keys ;

3
extra/assocs/lib/lib.factor
View File

@ -2,9 +2,6 @@ USING: arrays assocs kernel vectors sequences namespaces
random math.parser ;
IN: assocs.lib
: >set ( seq -- hash )
[ dup ] H{ } map>assoc ;
: ref-at ( table key -- value ) swap at ;
: put-at* ( table key value -- ) swap rot set-at ;

7
extra/cairo/cairo-tests.factor Normal file
View File

@ -0,0 +1,7 @@
USING: cairo math.parser kernel sequences tools.test ;
IN: cairo.tests
[ t ] [ ! apply a little pressure to cairo_version
cairo_version number>string CHAR: 0 swap remove
CHAR: . cairo_version_string remove =
] unit-test

968
extra/cairo/cairo.factor Normal file
View File

@ -0,0 +1,968 @@
! Copyright (c) 2007 Sampo Vuori
! Copyright (c) 2008 Matthew Willis
!
! Adapted from cairo.h, version 1.5.14
! License: http://factorcode.org/license.txt
USING: system combinators alien alien.syntax kernel
alien.c-types accessors sequences arrays ui.gadgets ;
IN: cairo
<< "cairo" {
{ [ os winnt? ] [ "libcairo-2.dll" ] }
{ [ os macosx? ] [ "libcairo.dylib" ] }
{ [ os unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
LIBRARY: cairo
FUNCTION: int cairo_version ( ) ;
FUNCTION: char* cairo_version_string ( ) ;
TYPEDEF: int cairo_bool_t
! I am leaving these and other void* types as opaque structures
TYPEDEF: void* cairo_t
TYPEDEF: void* cairo_surface_t
C-STRUCT: cairo_matrix_t
{ "double" "xx" }
{ "double" "yx" }
{ "double" "xy" }
{ "double" "yy" }
{ "double" "x0" }
{ "double" "y0" } ;
TYPEDEF: void* cairo_pattern_t
TYPEDEF: void* cairo_destroy_func_t
: cairo-destroy-func ( quot -- callback )
>r "void" { "void*" } "cdecl" r> alien-callback ; inline
! See cairo.h for details
C-STRUCT: cairo_user_data_key_t
{ "int" "unused" } ;
TYPEDEF: int cairo_status_t
C-ENUM:
CAIRO_STATUS_SUCCESS
CAIRO_STATUS_NO_MEMORY
CAIRO_STATUS_INVALID_RESTORE
CAIRO_STATUS_INVALID_POP_GROUP
CAIRO_STATUS_NO_CURRENT_POINT
CAIRO_STATUS_INVALID_MATRIX
CAIRO_STATUS_INVALID_STATUS
CAIRO_STATUS_NULL_POINTER
CAIRO_STATUS_INVALID_STRING
CAIRO_STATUS_INVALID_PATH_DATA
CAIRO_STATUS_READ_ERROR
CAIRO_STATUS_WRITE_ERROR
CAIRO_STATUS_SURFACE_FINISHED
CAIRO_STATUS_SURFACE_TYPE_MISMATCH
CAIRO_STATUS_PATTERN_TYPE_MISMATCH
CAIRO_STATUS_INVALID_CONTENT
CAIRO_STATUS_INVALID_FORMAT
CAIRO_STATUS_INVALID_VISUAL
CAIRO_STATUS_FILE_NOT_FOUND
CAIRO_STATUS_INVALID_DASH
CAIRO_STATUS_INVALID_DSC_COMMENT
CAIRO_STATUS_INVALID_INDEX
CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
CAIRO_STATUS_TEMP_FILE_ERROR
CAIRO_STATUS_INVALID_STRIDE ;
TYPEDEF: int cairo_content_t
: CAIRO_CONTENT_COLOR HEX: 1000 ;
: CAIRO_CONTENT_ALPHA HEX: 2000 ;
: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
TYPEDEF: void* cairo_write_func_t
: cairo-write-func ( quot -- callback )
>r "cairo_status_t" { "void*" "uchar*" "int" }
"cdecl" r> alien-callback ; inline
TYPEDEF: void* cairo_read_func_t
: cairo-read-func ( quot -- callback )
>r "cairo_status_t" { "void*" "uchar*" "int" }
"cdecl" r> alien-callback ; inline
! Functions for manipulating state objects
FUNCTION: cairo_t*
cairo_create ( cairo_surface_t* target ) ;
FUNCTION: cairo_t*
cairo_reference ( cairo_t* cr ) ;
FUNCTION: void
cairo_destroy ( cairo_t* cr ) ;
FUNCTION: uint
cairo_get_reference_count ( cairo_t* cr ) ;
FUNCTION: void*
cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_save ( cairo_t* cr ) ;
FUNCTION: void
cairo_restore ( cairo_t* cr ) ;
FUNCTION: void
cairo_push_group ( cairo_t* cr ) ;
FUNCTION: void
cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
FUNCTION: cairo_pattern_t*
cairo_pop_group ( cairo_t* cr ) ;
FUNCTION: void
cairo_pop_group_to_source ( cairo_t* cr ) ;
! Modify state
TYPEDEF: int cairo_operator_t
C-ENUM:
CAIRO_OPERATOR_CLEAR
CAIRO_OPERATOR_SOURCE
CAIRO_OPERATOR_OVER
CAIRO_OPERATOR_IN
CAIRO_OPERATOR_OUT
CAIRO_OPERATOR_ATOP
CAIRO_OPERATOR_DEST
CAIRO_OPERATOR_DEST_OVER
CAIRO_OPERATOR_DEST_IN
CAIRO_OPERATOR_DEST_OUT
CAIRO_OPERATOR_DEST_ATOP
CAIRO_OPERATOR_XOR
CAIRO_OPERATOR_ADD
CAIRO_OPERATOR_SATURATE ;
FUNCTION: void
cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
FUNCTION: void
cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
FUNCTION: void
cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
FUNCTION: void
cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
FUNCTION: void
cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
FUNCTION: void
cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
TYPEDEF: int cairo_antialias_t
C-ENUM:
CAIRO_ANTIALIAS_DEFAULT
CAIRO_ANTIALIAS_NONE
CAIRO_ANTIALIAS_GRAY
CAIRO_ANTIALIAS_SUBPIXEL ;
FUNCTION: void
cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
TYPEDEF: int cairo_fill_rule_t
C-ENUM:
CAIRO_FILL_RULE_WINDING
CAIRO_FILL_RULE_EVEN_ODD ;
FUNCTION: void
cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
FUNCTION: void
cairo_set_line_width ( cairo_t* cr, double width ) ;
TYPEDEF: int cairo_line_cap_t
C-ENUM:
CAIRO_LINE_CAP_BUTT
CAIRO_LINE_CAP_ROUND
CAIRO_LINE_CAP_SQUARE ;
FUNCTION: void
cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
TYPEDEF: int cairo_line_join_t
C-ENUM:
CAIRO_LINE_JOIN_MITER
CAIRO_LINE_JOIN_ROUND
CAIRO_LINE_JOIN_BEVEL ;
FUNCTION: void
cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
FUNCTION: void
cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
FUNCTION: void
cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
FUNCTION: void
cairo_translate ( cairo_t* cr, double tx, double ty ) ;
FUNCTION: void
cairo_scale ( cairo_t* cr, double sx, double sy ) ;
FUNCTION: void
cairo_rotate ( cairo_t* cr, double angle ) ;
FUNCTION: void
cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_identity_matrix ( cairo_t* cr ) ;
FUNCTION: void
cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: void
cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
FUNCTION: void
cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: void
cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
! Path creation functions
FUNCTION: void
cairo_new_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_move_to ( cairo_t* cr, double x, double y ) ;
FUNCTION: void
cairo_new_sub_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_line_to ( cairo_t* cr, double x, double y ) ;
FUNCTION: void
cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
FUNCTION: void
cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
FUNCTION: void
cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
FUNCTION: void
cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
FUNCTION: void
cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
FUNCTION: void
cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
FUNCTION: void
cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
FUNCTION: void
cairo_close_path ( cairo_t* cr ) ;
FUNCTION: void
cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Painting functions
FUNCTION: void
cairo_paint ( cairo_t* cr ) ;
FUNCTION: void
cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
FUNCTION: void
cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
FUNCTION: void
cairo_stroke ( cairo_t* cr ) ;
FUNCTION: void
cairo_stroke_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_fill ( cairo_t* cr ) ;
FUNCTION: void
cairo_fill_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_copy_page ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_page ( cairo_t* cr ) ;
! Insideness testing
FUNCTION: cairo_bool_t
cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
FUNCTION: cairo_bool_t
cairo_in_fill ( cairo_t* cr, double x, double y ) ;
! Rectangular extents
FUNCTION: void
cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
FUNCTION: void
cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
! Clipping
FUNCTION: void
cairo_reset_clip ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip_preserve ( cairo_t* cr ) ;
FUNCTION: void
cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
C-STRUCT: cairo_rectangle_t
{ "double" "x" }
{ "double" "y" }
{ "double" "width" }
{ "double" "height" } ;
: <cairo-rect> ( x y width height -- cairo_rectangle_t )
"cairo_rectangle_t" <c-object> dup
{
[ set-cairo_rectangle_t-height ] [ set-cairo_rectangle_t-width ]
[ set-cairo_rectangle_t-y ] [ set-cairo_rectangle_t-x ]
} cleave ;
: rect>cairo ( rect -- cairo_rectangle_t )
[ loc>> ] [ dim>> ] bi [ [ first ] [ second ] bi ] bi@
<cairo-rect> ;
: cairo>rect ( cairo_rectangle_t -- rect )
{
[ cairo_rectangle_t-x ] [ cairo_rectangle_t-y ]
[ cairo_rectangle_t-width ] [ cairo_rectangle_t-height ]
} cleave
[ 2array ] 2bi@ <rect> ;
C-STRUCT: cairo_rectangle_list_t
{ "cairo_status_t" "status" }
{ "cairo_rectangle_t*" "rectangles" }
{ "int" "num_rectangles" } ;
FUNCTION: cairo_rectangle_list_t*
cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
FUNCTION: void
cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
! Font/Text functions
TYPEDEF: void* cairo_scaled_font_t
TYPEDEF: void* cairo_font_face_t
C-STRUCT: cairo_glyph_t
{ "ulong" "index" }
{ "double" "x" }
{ "double" "y" } ;
C-STRUCT: cairo_text_extents_t
{ "double" "x_bearing" }
{ "double" "y_bearing" }
{ "double" "width" }
{ "double" "height" }
{ "double" "x_advance" }
{ "double" "y_advance" } ;
C-STRUCT: cairo_font_extents_t
{ "double" "ascent" }
{ "double" "descent" }
{ "double" "height" }
{ "double" "max_x_advance" }
{ "double" "max_y_advance" } ;
TYPEDEF: int cairo_font_slant_t
C-ENUM:
CAIRO_FONT_SLANT_NORMAL
CAIRO_FONT_SLANT_ITALIC
CAIRO_FONT_SLANT_OBLIQUE ;
TYPEDEF: int cairo_font_weight_t
C-ENUM:
CAIRO_FONT_WEIGHT_NORMAL
CAIRO_FONT_WEIGHT_BOLD ;
TYPEDEF: int cairo_subpixel_order_t
C-ENUM:
CAIRO_SUBPIXEL_ORDER_DEFAULT
CAIRO_SUBPIXEL_ORDER_RGB
CAIRO_SUBPIXEL_ORDER_BGR
CAIRO_SUBPIXEL_ORDER_VRGB
CAIRO_SUBPIXEL_ORDER_VBGR ;
TYPEDEF: int cairo_hint_style_t
C-ENUM:
CAIRO_HINT_STYLE_DEFAULT
CAIRO_HINT_STYLE_NONE
CAIRO_HINT_STYLE_SLIGHT
CAIRO_HINT_STYLE_MEDIUM
CAIRO_HINT_STYLE_FULL ;
TYPEDEF: int cairo_hint_metrics_t
C-ENUM:
CAIRO_HINT_METRICS_DEFAULT
CAIRO_HINT_METRICS_OFF
CAIRO_HINT_METRICS_ON ;
TYPEDEF: void* cairo_font_options_t
FUNCTION: cairo_font_options_t*
cairo_font_options_create ( ) ;
FUNCTION: cairo_font_options_t*
cairo_font_options_copy ( cairo_font_options_t* original ) ;
FUNCTION: void
cairo_font_options_destroy ( cairo_font_options_t* options ) ;
FUNCTION: cairo_status_t
cairo_font_options_status ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
FUNCTION: cairo_bool_t
cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
FUNCTION: ulong
cairo_font_options_hash ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
FUNCTION: cairo_antialias_t
cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
FUNCTION: cairo_subpixel_order_t
cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
FUNCTION: cairo_hint_style_t
cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
FUNCTION: void
cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
FUNCTION: cairo_hint_metrics_t
cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
! This interface is for dealing with text as text, not caring about the
! font object inside the the cairo_t.
FUNCTION: void
cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
FUNCTION: void
cairo_set_font_size ( cairo_t* cr, double size ) ;
FUNCTION: void
cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
FUNCTION: cairo_font_face_t*
cairo_get_font_face ( cairo_t* cr ) ;
FUNCTION: void
cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_scaled_font_t*
cairo_get_scaled_font ( cairo_t* cr ) ;
FUNCTION: void
cairo_show_text ( cairo_t* cr, char* utf8 ) ;
FUNCTION: void
cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_path ( cairo_t* cr, char* utf8 ) ;
FUNCTION: void
cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
FUNCTION: void
cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
! Generic identifier for a font style
FUNCTION: cairo_font_face_t*
cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
FUNCTION: void
cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
FUNCTION: uint
cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
FUNCTION: cairo_status_t
cairo_font_face_status ( cairo_font_face_t* font_face ) ;
TYPEDEF: int cairo_font_type_t
C-ENUM:
CAIRO_FONT_TYPE_TOY
CAIRO_FONT_TYPE_FT
CAIRO_FONT_TYPE_WIN32
CAIRO_FONT_TYPE_QUARTZ ;
FUNCTION: cairo_font_type_t
cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
FUNCTION: void*
cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
! Portable interface to general font features.
FUNCTION: cairo_scaled_font_t*
cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
FUNCTION: cairo_scaled_font_t*
cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void
cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: uint
cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_status_t
cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: cairo_font_type_t
cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void*
cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
FUNCTION: void
cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
FUNCTION: cairo_font_face_t*
cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
FUNCTION: void
cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
FUNCTION: void
cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
FUNCTION: void
cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
! Query functions
FUNCTION: cairo_operator_t
cairo_get_operator ( cairo_t* cr ) ;
FUNCTION: cairo_pattern_t*
cairo_get_source ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_tolerance ( cairo_t* cr ) ;
FUNCTION: cairo_antialias_t
cairo_get_antialias ( cairo_t* cr ) ;
FUNCTION: cairo_bool_t
cairo_has_current_point ( cairo_t* cr ) ;
FUNCTION: void
cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
FUNCTION: cairo_fill_rule_t
cairo_get_fill_rule ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_line_width ( cairo_t* cr ) ;
FUNCTION: cairo_line_cap_t
cairo_get_line_cap ( cairo_t* cr ) ;
FUNCTION: cairo_line_join_t
cairo_get_line_join ( cairo_t* cr ) ;
FUNCTION: double
cairo_get_miter_limit ( cairo_t* cr ) ;
FUNCTION: int
cairo_get_dash_count ( cairo_t* cr ) ;
FUNCTION: void
cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
FUNCTION: void
cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
FUNCTION: cairo_surface_t*
cairo_get_target ( cairo_t* cr ) ;
FUNCTION: cairo_surface_t*
cairo_get_group_target ( cairo_t* cr ) ;
TYPEDEF: int cairo_path_data_type_t
C-ENUM:
CAIRO_PATH_MOVE_TO
CAIRO_PATH_LINE_TO
CAIRO_PATH_CURVE_TO
CAIRO_PATH_CLOSE_PATH ;
! NEED TO DO UNION HERE
C-STRUCT: cairo_path_data_t-point
{ "double" "x" }
{ "double" "y" } ;
C-STRUCT: cairo_path_data_t-header
{ "cairo_path_data_type_t" "type" }
{ "int" "length" } ;
C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
C-STRUCT: cairo_path_t
{ "cairo_status_t" "status" }
{ "cairo_path_data_t*" "data" }
{ "int" "num_data" } ;
FUNCTION: cairo_path_t*
cairo_copy_path ( cairo_t* cr ) ;
FUNCTION: cairo_path_t*
cairo_copy_path_flat ( cairo_t* cr ) ;
FUNCTION: void
cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
FUNCTION: void
cairo_path_destroy ( cairo_path_t* path ) ;
! Error status queries
FUNCTION: cairo_status_t
cairo_status ( cairo_t* cr ) ;
FUNCTION: char*
cairo_status_to_string ( cairo_status_t status ) ;
! Surface manipulation
FUNCTION: cairo_surface_t*
cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
FUNCTION: cairo_surface_t*
cairo_surface_reference ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_finish ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_destroy ( cairo_surface_t* surface ) ;
FUNCTION: uint
cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_status ( cairo_surface_t* surface ) ;
TYPEDEF: int cairo_surface_type_t
C-ENUM:
CAIRO_SURFACE_TYPE_IMAGE
CAIRO_SURFACE_TYPE_PDF
CAIRO_SURFACE_TYPE_PS
CAIRO_SURFACE_TYPE_XLIB
CAIRO_SURFACE_TYPE_XCB
CAIRO_SURFACE_TYPE_GLITZ
CAIRO_SURFACE_TYPE_QUARTZ
CAIRO_SURFACE_TYPE_WIN32
CAIRO_SURFACE_TYPE_BEOS
CAIRO_SURFACE_TYPE_DIRECTFB
CAIRO_SURFACE_TYPE_SVG
CAIRO_SURFACE_TYPE_OS2
CAIRO_SURFACE_TYPE_WIN32_PRINTING
CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
FUNCTION: cairo_surface_type_t
cairo_surface_get_type ( cairo_surface_t* surface ) ;
FUNCTION: cairo_content_t
cairo_surface_get_content ( cairo_surface_t* surface ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
FUNCTION: cairo_status_t
cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
FUNCTION: void*
cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
FUNCTION: void
cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
FUNCTION: void
cairo_surface_flush ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
FUNCTION: void
cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
FUNCTION: void
cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
FUNCTION: void
cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
FUNCTION: void
cairo_surface_copy_page ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_show_page ( cairo_surface_t* surface ) ;
! Image-surface functions
TYPEDEF: int cairo_format_t
C-ENUM:
CAIRO_FORMAT_ARGB32
CAIRO_FORMAT_RGB24
CAIRO_FORMAT_A8
CAIRO_FORMAT_A1
CAIRO_FORMAT_RGB16_565 ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
FUNCTION: int
cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
FUNCTION: uchar*
cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
FUNCTION: cairo_format_t
cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
FUNCTION: int
cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png ( char* filename ) ;
FUNCTION: cairo_surface_t*
cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
! Pattern creation functions
FUNCTION: cairo_pattern_t*
cairo_pattern_create_rgb ( double red, double green, double blue ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
FUNCTION: cairo_pattern_t*
cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
FUNCTION: uint
cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
FUNCTION: cairo_status_t
cairo_pattern_status ( cairo_pattern_t* pattern ) ;
FUNCTION: void*
cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
FUNCTION: cairo_status_t
cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
TYPEDEF: int cairo_pattern_type_t
C-ENUM:
CAIRO_PATTERN_TYPE_SOLID
CAIRO_PATTERN_TYPE_SURFACE
CAIRO_PATTERN_TYPE_LINEAR
CAIRO_PATTERN_TYPE_RADIA ;
FUNCTION: cairo_pattern_type_t
cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
FUNCTION: void
cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
FUNCTION: void
cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
FUNCTION: void
cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
TYPEDEF: int cairo_extend_t
C-ENUM:
CAIRO_EXTEND_NONE
CAIRO_EXTEND_REPEAT
CAIRO_EXTEND_REFLECT
CAIRO_EXTEND_PAD ;
FUNCTION: void
cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
FUNCTION: cairo_extend_t
cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
TYPEDEF: int cairo_filter_t
C-ENUM:
CAIRO_FILTER_FAST
CAIRO_FILTER_GOOD
CAIRO_FILTER_BEST
CAIRO_FILTER_NEAREST
CAIRO_FILTER_BILINEAR
CAIRO_FILTER_GAUSSIAN ;
FUNCTION: void
cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
FUNCTION: cairo_filter_t
cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
! Matrix functions
FUNCTION: void
cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
FUNCTION: void
cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
FUNCTION: void
cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
FUNCTION: void
cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
FUNCTION: void
cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
FUNCTION: void
cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
FUNCTION: void
cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
FUNCTION: cairo_status_t
cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
FUNCTION: void
cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
FUNCTION: void
cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
FUNCTION: void
cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
! Functions to be used while debugging (not intended for use in production code)
FUNCTION: void
cairo_debug_reset_static_data ( ) ;

73
extra/cairo/gadgets/gadgets.factor Normal file
View File

@ -0,0 +1,73 @@
! Copyright (C) 2008 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
USING: cairo cairo.lib ui.render kernel opengl.gl opengl
math byte-arrays ui.gadgets accessors arrays
namespaces io.backend ;
IN: cairo.gadgets
! We need two kinds of gadgets:
! one performs the cairo ops once and caches the bytes, the other
! performs cairo ops every refresh
TUPLE: cairo-gadget width height quot cache? bytes ;
PREDICATE: cached-cairo < cairo-gadget cache?>> ;
: <cairo-gadget> ( width height quot -- cairo-gadget )
cairo-gadget construct-gadget
swap >>quot
swap >>height
swap >>width ;
: <cached-cairo> ( width height quot -- cairo-gadget )
<cairo-gadget> t >>cache? ;
: width>stride ( width -- stride ) 4 * ;
: copy-cairo ( width height quot -- byte-array )
>r over width>stride
[ * nip <byte-array> dup CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_create_for_data ] 3bi
r> with-cairo-from-surface ;
: (cairo>bytes) ( gadget -- byte-array )
[ width>> ] [ height>> ] [ quot>> ] tri copy-cairo ;
GENERIC: cairo>bytes
M: cairo-gadget cairo>bytes ( gadget -- byte-array )
(cairo>bytes) ;
M: cached-cairo cairo>bytes ( gadget -- byte-array )
dup bytes>> [ ] [
dup (cairo>bytes) [ >>bytes drop ] keep
] ?if ;
: cairo>png ( gadget path -- )
>r [ cairo>bytes CAIRO_FORMAT_ARGB32 ] [ width>> ]
[ height>> ] tri over width>stride
cairo_image_surface_create_for_data
r> [ cairo_surface_write_to_png check-cairo ] curry with-surface ;
M: cairo-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
[ width>> ] [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ cairo>bytes ] tri glDrawPixels
] with-translation ;
M: cairo-gadget pref-dim* ( gadget -- rect )
[ width>> ] [ height>> ] bi 2array ;
: copy-surface ( surface -- )
cr swap 0 0 cairo_set_source_surface
cr cairo_paint ;
: <bytes-gadget> ( width height bytes -- cairo-gadget )
>r [ ] <cached-cairo> r> >>bytes ;
: <png-gadget> ( path -- gadget )
normalize-path cairo_image_surface_create_from_png
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height 2dup ]
[ [ copy-surface ] curry copy-cairo ] tri
<bytes-gadget> ;

49
extra/cairo/lib/lib.factor
View File

@ -1,39 +1,36 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
kernel libc locals math shuffle accessors ;
USING: cairo kernel accessors sequences
namespaces fry continuations ;
IN: cairo.lib
TUPLE: cairo-t alien ;
C: <cairo-t> cairo-t
M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
TUPLE: cairo-surface-t alien ;
C: <cairo-surface-t> cairo-surface-t
M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
: cairo-surface-t-destroy-always ( alien -- )
<cairo-surface-t> add-always-destructor ;
: check-cairo ( cairo_status_t -- )
dup CAIRO_STATUS_SUCCESS = [ drop ]
[ cairo_status_to_string "Cairo error: " prepend throw ] if ;
: cairo-surface-t-destroy-later ( alien -- )
<cairo-surface-t> add-error-destructor ;
SYMBOL: cairo
: cr ( -- cairo ) cairo get ;
: cairo-surface>array ( surface -- cairo-t byte-array )
[
dup
[ drop CAIRO_FORMAT_ARGB32 ]
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ] tri
over 4 *
2dup * [
malloc dup free-always [
5 -nrot cairo_image_surface_create_for_data
dup cairo-surface-t-destroy-always
cairo_create dup cairo-t-destroy-later
[ swap 0 0 cairo_set_source_surface ] keep
dup cairo_paint
] keep
] keep memory>byte-array
] with-destructors ;
: (with-cairo) ( cairo-t quot -- )
>r alien>> cairo r> [ cr cairo_status check-cairo ]
compose with-variable ; inline
: with-cairo ( cairo quot -- )
>r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
: (with-surface) ( cairo-surface-t quot -- )
>r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
: with-surface ( cairo_surface quot -- )
>r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
: with-cairo-from-surface ( cairo_surface quot -- )
'[ cairo_create , with-cairo ] with-surface ; inline

65
extra/cairo/png/png.factor
View File

@ -1,65 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel accessors math ui.gadgets ui.render
opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
inspector sequences combinators io.backend ;
IN: cairo.png
TUPLE: png surface width height cairo-t array ;
TUPLE: png-gadget png ;
ERROR: cairo-error string ;
: check-zero ( n -- n )
dup zero? [
"PNG dimension is 0" cairo-error
] when ;
: cairo-png-error ( n -- )
{
{ CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
{ CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
{ CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
[ drop ]
} case ;
: <png> ( path -- png )
normalize-path
cairo_image_surface_create_from_png
dup cairo_surface_status cairo-png-error
dup [ cairo_image_surface_get_width check-zero ]
[ cairo_image_surface_get_height check-zero ] [ ] tri
cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
cairo_surface_write_to_png
zero? [ "write png failed" throw ] unless ;
: <png-gadget> ( path -- gadget )
png-gadget construct-gadget swap
<png> >>png ;
M: png-gadget pref-dim* ( gadget -- )
png>>
[ width>> ] [ height>> ] bi 2array ;
M: png-gadget draw-gadget* ( gadget -- )
origin get [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
png>>
[ width>> ]
[ height>> GL_RGBA GL_UNSIGNED_BYTE ]
! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ array>> ] tri
glDrawPixels
] with-translation ;
M: png-gadget graft* ( gadget -- )
drop ;
M: png-gadget ungraft* ( gadget -- )
png>> surface>> cairo_destroy ;
! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.

140
extra/cairo/samples/samples.factor Normal file
View File

@ -0,0 +1,140 @@
! Copyright (C) 2008 Matthew Willis
! See http://factorcode.org/license.txt for BSD license.
!
! these samples are a subset of the samples on
! http://cairographics.org/samples/
USING: cairo cairo.lib locals math.constants math
io.backend kernel alien.c-types libc namespaces ;
IN: cairo.samples
:: arc ( -- )
[let | xc [ 128.0 ]
yc [ 128.0 ]
radius [ 100.0 ]
angle1 [ pi 1/4 * ]
angle2 [ pi ] |
cr 10.0 cairo_set_line_width
cr xc yc radius angle1 angle2 cairo_arc
cr cairo_stroke
! draw helping lines
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6.0 cairo_set_line_width
cr xc yc 10.0 0 2 pi * cairo_arc
cr cairo_fill
cr xc yc radius angle1 angle1 cairo_arc
cr xc yc cairo_line_to
cr xc yc radius angle2 angle2 cairo_arc
cr xc yc cairo_line_to
cr cairo_stroke
] ;
: clip ( -- )
cr 128 128 76.8 0 2 pi * cairo_arc
cr cairo_clip
cr cairo_new_path
cr 0 0 256 256 cairo_rectangle
cr cairo_fill
cr 0 1 0 cairo_set_source_rgb
cr 0 0 cairo_move_to
cr 256 256 cairo_line_to
cr 256 0 cairo_move_to
cr 0 256 cairo_line_to
cr 10 cairo_set_line_width
cr cairo_stroke ;
:: clip-image ( -- )
[let* | png [ "resource:misc/icons/Factor_128x128.png"
normalize-path cairo_image_surface_create_from_png ]
w [ png cairo_image_surface_get_width ]
h [ png cairo_image_surface_get_height ] |
cr 128 128 76.8 0 2 pi * cairo_arc
cr cairo_clip
cr cairo_new_path
cr 192.0 w / 192.0 h / cairo_scale
cr png 32 32 cairo_set_source_surface
cr cairo_paint
png cairo_surface_destroy
] ;
:: dash ( -- )
[let | dashes [ { 50 10 10 10 } >c-double-array ]
ndash [ 4 ] |
cr dashes ndash -50 cairo_set_dash
cr 10 cairo_set_line_width
cr 128.0 25.6 cairo_move_to
cr 230.4 230.4 cairo_line_to
cr -102.4 0 cairo_rel_line_to
cr 51.2 230.4 51.2 128.0 128.0 128.0 cairo_curve_to
cr cairo_stroke
] ;
:: gradient ( -- )
[let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
radial [ 115.2 102.4 25.6 102.4 102.4 128.0
cairo_pattern_create_radial ] |
pat 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
pat 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
cr 0 0 256 256 cairo_rectangle
cr pat cairo_set_source
cr cairo_fill
pat cairo_pattern_destroy
radial 0 1 1 1 1 cairo_pattern_add_color_stop_rgba
radial 1 0 0 0 1 cairo_pattern_add_color_stop_rgba
cr radial cairo_set_source
cr 128.0 128.0 76.8 0 2 pi * cairo_arc
cr cairo_fill
radial cairo_pattern_destroy
] ;
: text ( -- )
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
cairo_select_font_face
cr 50 cairo_set_font_size
cr 10 135 cairo_move_to
cr "Hello" cairo_show_text
cr 70 165 cairo_move_to
cr "factor" cairo_text_path
cr 0.5 0.5 1 cairo_set_source_rgb
cr cairo_fill_preserve
cr 0 0 0 cairo_set_source_rgb
cr 2.56 cairo_set_line_width
cr cairo_stroke
! draw helping lines
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 10 135 5.12 0 2 pi * cairo_arc
cr cairo_close_path
cr 70 165 5.12 0 2 pi * cairo_arc
cr cairo_fill ;
: utf8 ( -- )
cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
cairo_select_font_face
cr 50 cairo_set_font_size
"cairo_text_extents_t" malloc-object
cr B{ 230 151 165 230 156 172 232 170 158 } pick cairo_text_extents
cr over
[ cairo_text_extents_t-width 2 / ]
[ cairo_text_extents_t-x_bearing ] bi +
128 swap - pick
[ cairo_text_extents_t-height 2 / ]
[ cairo_text_extents_t-y_bearing ] bi +
128 swap - cairo_move_to
free
cr B{ 230 151 165 230 156 172 232 170 158 } cairo_show_text
cr 1 0.2 0.2 0.6 cairo_set_source_rgba
cr 6 cairo_set_line_width
cr 128 0 cairo_move_to
cr 0 256 cairo_rel_line_to
cr 0 128 cairo_move_to
cr 256 0 cairo_rel_line_to
cr cairo_stroke ;

54
extra/delegate/delegate-tests.factor Normal file → Executable file
View File

@ -1,5 +1,6 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string ;
compiler.units parser generic prettyprint io.streams.string
accessors ;
IN: delegate.tests
TUPLE: hello this that ;
@ -16,14 +17,14 @@ PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
: hello-test ( hello/goodbye -- array )
[ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
CONSULT: baz goodbye these>> ;
M: hello foo this>> ;
M: hello bar hello-test ;
M: hello whoa >r hello-this r> + ;
M: hello whoa >r this>> r> + ;
GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;
CONSULT: hello goodbye goodbye-those ;
CONSULT: hello goodbye those>> ;
M: hello bing hello-test ;
[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
@ -33,11 +34,48 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
! [ f ] [ goodbye baz method ] unit-test
GENERIC: one
M: integer one ;
GENERIC: two
M: integer two ;
GENERIC: three
M: integer three ;
GENERIC: four
M: integer four ;
PROTOCOL: alpha one two ;
PROTOCOL: beta three ;
TUPLE: hey value ;
C: <hey> hey
CONSULT: alpha hey value>> 1+ ;
CONSULT: beta hey value>> 1- ;
[ 2 ] [ 1 <hey> one ] unit-test
[ 2 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
[ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
[ f ] [ hey \ one method ] unit-test

33
extra/delegate/delegate.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: parser generic kernel classes words slots assocs sequences arrays
vectors definitions prettyprint combinators.lib math hashtables sets ;
USING: parser generic kernel classes words slots assocs
sequences arrays vectors definitions prettyprint combinators.lib
math hashtables sets ;
IN: delegate
: protocol-words ( protocol -- words )
@ -22,7 +23,8 @@ M: tuple-class group-words
: consult-method ( word class quot -- )
[ drop swap first create-method ]
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
[ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi
define ;
: change-word-prop ( word prop quot -- )
rot word-props swap change-at ; inline
@ -31,10 +33,9 @@ M: tuple-class group-words
rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
: define-consult ( group class quot -- )
[ register-protocol ] [
rot group-words -rot
[ consult-method ] 2curry each
] 3bi ;
[ register-protocol ]
[ rot group-words -rot [ consult-method ] 2curry each ]
3bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
@ -45,7 +46,7 @@ M: tuple-class group-words
[ with each ] 2curry each ; inline
: forget-all-methods ( classes words -- )
[ 2array forget ] cross-2each ;
[ first method forget ] cross-2each ;
: protocol-users ( protocol -- users )
protocol-consult keys ;
@ -54,19 +55,21 @@ M: tuple-class group-words
>r protocol-words r> diff ;
: forget-old-definitions ( protocol new-wordlist -- )
>r [ protocol-users ] [ protocol-words ] bi r>
swap diff forget-all-methods ;
[ drop protocol-users ] [ lost-words ] 2bi
forget-all-methods ;
: added-words ( protocol wordlist -- added-words )
swap protocol-words swap diff ;
swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
dupd added-words >r protocol-consult >alist r>
[ first2 consult-method ] cross-2each ;
[ drop protocol-consult >alist ] [ added-words ] 2bi
[ swap first2 consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[ drop H{ } clone \ protocol-consult set-word-prop ]
[ { } like \ protocol-words set-word-prop ] 2bi ;
[
drop \ protocol-consult
[ H{ } assoc-like ] change-word-prop
] [ { } like \ protocol-words set-word-prop ] 2bi ;
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;

15
extra/delegate/protocols/protocols.factor
View File

@ -1,16 +1,19 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections
io definitions kernel continuations listener ;
USING: delegate sequences.private sequences assocs
prettyprint.sections io definitions kernel continuations
listener ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
clone clone-like like new-sequence new-resizable nth nth-unsafe
set-nth set-nth-unsafe length set-length lengthen ;
clone clone-like like new-sequence new-resizable nth
nth-unsafe set-nth set-nth-unsafe length set-length
lengthen ;
PROTOCOL: assoc-protocol
at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
at* assoc-size >alist set-at assoc-clone-like
{ assoc-find 1 } delete-at clear-assoc new-assoc
assoc-like ;
PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-partial stream-readln

1
extra/descriptive/authors.txt Executable file
View File

@ -0,0 +1 @@
Daniel Ehrenberg

22
extra/descriptive/descriptive-docs.factor Executable file
View File

@ -0,0 +1,22 @@
USING: help.syntax help.markup ;
IN: descriptive
HELP: DESCRIPTIVE:
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
HELP: DESCRIPTIVE::
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
HELP: descriptive
{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
ARTICLE: "descriptive" "Descriptive errors"
"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
{ $subsection descriptive }
"To define words which throw descriptive errors, use the following words:"
{ $subsection POSTPONE: DESCRIPTIVE: }
{ $subsection POSTPONE: DESCRIPTIVE:: } ;
ABOUT: "descriptive"

16
extra/descriptive/descriptive-tests.factor Executable file
View File

@ -0,0 +1,16 @@
USING: descriptive kernel math tools.test continuations prettyprint io.streams.string ;
IN: descriptive.tests
DESCRIPTIVE: divide ( num denom -- fraction ) / ;
[ 3 ] [ 9 3 divide ] unit-test
[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test
[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test
DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;
[ 3 ] [ 9 3 divide* ] unit-test
[ T{ descriptive-error f { { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test
[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test

45
extra/descriptive/descriptive.factor Executable file
View File

@ -0,0 +1,45 @@
USING: words kernel sequences combinators.lib locals
locals.private accessors parser namespaces continuations
inspector definitions arrays.lib arrays ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
M: descriptive-error summary
word>> "The " swap word-name " word encountered an error."
3append ;
<PRIVATE
: rethrower ( word inputs -- quot )
[ length ] keep [ >r narray r> swap 2array flip ] 2curry
[ 2 ndip descriptive-error ] 2curry ;
: [descriptive] ( word def -- newdef )
swap dup "declared-effect" word-prop in>> rethrower
[ recover ] 2curry ;
PRIVATE>
: define-descriptive ( word def -- )
[ "descriptive-definition" set-word-prop ]
[ dupd [descriptive] define ] 2bi ;
: DESCRIPTIVE:
(:) define-descriptive ; parsing
PREDICATE: descriptive < word
"descriptive-definition" word-prop ;
M: descriptive definer drop \ DESCRIPTIVE: \ ; ;
M: descriptive definition
"descriptive-definition" word-prop ;
: DESCRIPTIVE::
(::) define-descriptive ; parsing
INTERSECTION: descriptive-lambda descriptive lambda-word ;
M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ;
M: descriptive-lambda definition
"lambda" word-prop body>> ;

1
extra/descriptive/summary.txt Executable file
View File

@ -0,0 +1 @@
Descriptive errors generated automatically for specially defined words

1
extra/ftp/client/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

138
extra/ftp/client/client.factor Normal file
View File

@ -0,0 +1,138 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.singleton combinators continuations
io io.encodings.binary io.encodings.ascii io.files io.sockets
kernel math math.parser sequences splitting namespaces strings ;
IN: ftp.client
TUPLE: ftp-client host port stream user password mode ;
TUPLE: ftp-response n strings ;
SINGLETON: active
SINGLETON: passive
: <ftp-response> ( -- ftp-response )
ftp-response new
V{ } clone >>strings ;
: <ftp-client> ( host -- ftp-client )
ftp-client new
swap >>host
21 >>port
"anonymous" >>user
"factor-ftp@factorcode.org" >>password ;
: add-response-line ( ftp-response string -- ftp-response )
over strings>> push ;
: (ftp-response-code) ( str -- n )
3 head string>number ;
: ftp-response-code ( string -- n/f )
dup fourth CHAR: - = [ drop f ] [ (ftp-response-code) ] if ;
: last-code ( ftp-response -- n )
strings>> peek (ftp-response-code) ;
: read-response-until ( stream ftp-response n -- ftp-response )
>r over stream-readln
[ add-response-line ] [ ftp-response-code ] bi
r> tuck = [ drop nip ] [ read-response-until ] if ;
: read-response ( stream -- ftp-response )
<ftp-response>
over stream-readln
[ add-response-line ] [ fourth CHAR: - = ] bi
[ dup last-code read-response-until ]
[ nip ] if dup last-code >>n ;
: ftp-read ( ftp-client -- ftp-response )
stream>> read-response ;
: ftp-send ( str ftp-client -- )
stream>>
[ stream-write ]
[ "\r\n" swap stream-write ]
[ stream-flush ] tri ;
: ftp-command ( string ftp-client -- ftp-response )
[ ftp-send ] [ ftp-read ] bi ;
: ftp-user ( ftp-client -- ftp-response )
[ user>> "USER " prepend ] [ ftp-command ] bi ;
: ftp-password ( ftp-client -- ftp-response )
[ password>> "PASS " prepend ] [ ftp-command ] bi ;
: ftp-set-binary ( ftp-client -- ftp-response )
>r "TYPE I" r> ftp-command ;
: ftp-pwd ( ftp-client -- ftp-response )
>r "PWD" r> ftp-command ;
: ftp-list ( ftp-client -- ftp-response )
>r "LIST" r> ftp-command ;
: ftp-quit ( ftp-client -- ftp-response )
>r "QUIT" r> ftp-command ;
: ftp-cwd ( directory ftp-client -- ftp-response )
>r "CWD " prepend r> ftp-command ;
: ftp-retr ( filename ftp-client -- ftp-response )
>r "RETR " prepend r> ftp-command ;
: parse-epsv ( ftp-response -- port )
strings>> first
"|" split 2 tail* first string>number ;
: ftp-epsv ( ftp-client -- ftp-response )
>r "EPSV" r> ftp-command ;
M: ftp-client dispose ( ftp-client -- )
[ ftp-quit drop ] [ stream>> dispose ] bi ;
ERROR: ftp-error got expected ;
: ftp-assert ( ftp-response n -- )
2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
: ftp-connect ( ftp-client -- )
dup
[ host>> ] [ port>> ] bi <inet> ascii <client>
>>stream drop ;
: ftp-login ( ftp-client -- )
{
[ ftp-connect ]
[ ftp-read 220 ftp-assert ]
[ ftp-user 331 ftp-assert ]
[ ftp-password 230 ftp-assert ]
[ ftp-set-binary 200 ftp-assert ]
} cleave ;
: start-2nd ( ftp-client -- port )
ftp-epsv [ 229 ftp-assert ] [ parse-epsv ] bi ;
: list ( ftp-client -- ftp-response )
dup [ host>> ] [ start-2nd ] bi <inet> ascii <client>
over ftp-list 150 ftp-assert
lines <ftp-response> swap >>strings
>r ftp-read 226 ftp-assert r> ;
: ftp-get ( filename ftp-client -- ftp-response )
dup [ host>> ] [ start-2nd ] bi <inet> binary <client>
rot tuck
[ over ftp-retr 150 ftp-assert ]
[ binary <file-writer> stream-copy ] 2bi*
ftp-read dup 226 ftp-assert ;
GENERIC: ftp-download ( path obj -- )
M: ftp-client ftp-download ( path ftp-client -- )
dup ftp-login
[ >r parent-directory r> ftp-cwd drop ]
[ >r file-name r> ftp-get drop ]
[ dispose drop ] 2tri ;
M: string ftp-download ( path string -- )
<ftp-client> ftp-download ;

2
extra/io/encodings/ascii/ascii.factor Normal file → Executable file
View File

@ -13,7 +13,7 @@ IN: io.encodings.ascii
[ drop f ] if* ;
PRIVATE>
TUPLE: ascii ;
SINGLETON: ascii
M: ascii encode-char
128 encode-if< ;

2
extra/io/streams/duplex/duplex.factor
View File

@ -47,7 +47,7 @@ M: duplex-stream dispose
] unless drop ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;
tuck re-encode >r re-decode r> <duplex-stream> ;
: with-stream* ( stream quot -- )
>r [ in>> ] [ out>> ] bi r> with-streams* ; inline

8
extra/locals/locals-tests.factor
View File

@ -246,3 +246,11 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
: no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
[ { 4 5 6 } ] [ no-with-locals-test ] unit-test
{ 3 0 } [| a b c | ] must-infer-as
[ ] [ 1 [let | a [ ] | ] ] unit-test
[ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
[ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test

30
extra/locals/locals.factor
View File

@ -116,7 +116,9 @@ UNION: special local quote local-word local-reader local-writer ;
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
over empty?
[ nip length \ drop <repetition> >quotation ]
[ (point-free) ] if ;
UNION: lexical local local-reader local-writer local-word ;
@ -355,40 +357,34 @@ M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
PREDICATE: lambda-word < word
"lambda" word-prop >boolean ;
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
"lambda" word-prop body>> ;
: lambda-word-synopsis ( word -- )
dup definer.
dup seeing-word
dup pprint-word
stack-effect. ;
M: lambda-word synopsis* lambda-word-synopsis ;
PREDICATE: lambda-macro < macro
"lambda" word-prop >boolean ;
INTERSECTION: lambda-macro macro lambda-word ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
"lambda" word-prop body>> ;
M: lambda-macro synopsis* lambda-word-synopsis ;
PREDICATE: lambda-method < method-body
"lambda" word-prop >boolean ;
INTERSECTION: lambda-method method-body lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
"lambda" word-prop body>> ;
INTERSECTION: lambda-memoized memoized lambda-word ;
M: lambda-memoized definer drop \ MEMO:: \ ; ;
M: lambda-memoized definition
"lambda" word-prop body>> ;
: method-stack-effect ( method -- effect )
dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect

12
extra/tools/deploy/backend/backend.factor
View File

@ -8,14 +8,14 @@ debugger io.streams.c io.files io.backend
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name extension -- vm )
[ prepend-path ] dip append vm over copy-file ;
: copy-fonts ( name dir -- )
append-path "fonts/" resource-path swap copy-tree-into ;
: image-name ( vocab bundle-name -- str )
: copy-fonts ( name dir -- )
append-path "resource:fonts/" swap copy-tree-into ;
: image-name ( vocab bundle-name -- str )
prepend-path ".image" append ;
: (copy-lines) ( stream -- )

7
extra/tools/deploy/windows/windows-tests.factor Executable file
View File

@ -0,0 +1,7 @@
IN: tools.deploy.windows.tests
USING: tools.deploy.windows tools.test sequences ;
[ t ] [
"foo" "resource:temp/test-copy-files" create-exe-dir
".exe" tail?
] unit-test

27
extra/tools/deploy/windows/windows.factor
View File

@ -2,12 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io io.files kernel namespaces sequences system
tools.deploy.backend tools.deploy.config assocs hashtables
prettyprint windows.shell32 windows.user32 ;
prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
: copy-dlls ( bundle-name -- )
{ "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
swap copy-files-into ;
{
"resource:freetype6.dll"
"resource:zlib1.dll"
"resource:factor.dll"
} swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
@ -15,11 +18,15 @@ IN: tools.deploy.windows
".exe" copy-vm ;
M: winnt deploy*
"." resource-path [
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
[ deploy-name get image-name ] keep
[ namespace make-deploy-image ] keep
open-in-explorer
] bind
"resource:" [
deploy-name over deploy-config at
[
{
[ create-exe-dir ]
[ image-name ]
[ drop ]
[ drop deploy-config ]
} 2cleave make-deploy-image
]
[ nip open-in-explorer ] 2bi
] with-directory ;

2
extra/tools/time/time-docs.factor Normal file → Executable file
View File

@ -16,7 +16,7 @@ ABOUT: "timing"
HELP: benchmark
{ $values { "quot" "a quotation" }
{ "runtime" "an integer denoting milliseconds" } }
{ $description "Runs a quotation, measuring the total wall clock time and the total time spent in the garbage collector." }
{ $description "Runs a quotation, measuring the total wall clock time." }
{ $notes "A nicer word for interactive use is " { $link time } "." } ;
HELP: time

4
extra/unicode/breaks/breaks.factor
View File

@ -1,7 +1,7 @@
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
math.ranges unicode.normalize values io.encodings.ascii
unicode.syntax unicode.data compiler.units alien.syntax ;
unicode.syntax unicode.data compiler.units alien.syntax sets ;
IN: unicode.breaks
C-ENUM: Any L V T Extend Control CR LF graphemes ;
@ -27,7 +27,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] filter
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
concat [ dup ] H{ } map>assoc ;
concat unique ;
: other-extend-lines ( -- lines )
"resource:extra/unicode/PropList.txt" ascii file-lines ;

55
vm/data_gc.c
View File

@ -648,12 +648,63 @@ void do_code_slots(CELL scan)
}
}
/* This function is performance-critical */
CELL collect_next(CELL scan)
{
do_slots(scan,copy_handle);
CELL *obj = (CELL *)scan;
CELL *end = (CELL *)(scan + binary_payload_start(scan));
obj++;
CELL newspace_start = newspace->start;
CELL newspace_end = newspace->end;
if(HAVE_NURSERY_P && collecting_gen == NURSERY)
{
CELL nursery_start = nursery.start;
CELL nursery_end = nursery.end;
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer)
&& (pointer >= nursery_start && pointer < nursery_end))
*obj = copy_object(pointer);
}
}
else if(HAVE_AGING_P && collecting_gen == AGING)
{
F_ZONE *tenured = &data_heap->generations[TENURED];
CELL tenured_start = tenured->start;
CELL tenured_end = tenured->end;
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer)
&& !(pointer >= newspace_start && pointer < newspace_end)
&& !(pointer >= tenured_start && pointer < tenured_end))
*obj = copy_object(pointer);
}
}
else if(collecting_gen == TENURED)
{
for(; obj < end; obj++)
{
CELL pointer = *obj;
if(!immediate_p(pointer)
&& !(pointer >= newspace_start && pointer < newspace_end))
*obj = copy_object(pointer);
}
if(collecting_gen == TENURED)
do_code_slots(scan);
}
else
critical_error("Bug in collect_next",0);
return scan + untagged_object_size(scan);
}

2
vm/layouts.h
View File

@ -64,7 +64,7 @@ typedef signed long long s64;
INLINE bool immediate_p(CELL obj)
{
return (TAG(obj) == FIXNUM_TYPE || obj == F);
return (obj == F || TAG(obj) == FIXNUM_TYPE);
}
INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)