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

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

db4
Doug Coleman 2009-03-11 15:06:31 -05:00
parent 7a6ae79ed9 c193f1b68a
commit b38348aae0
97 changed files with 920 additions and 794 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -514,4 +514,9 @@ cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
] unit-test
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test

2
basis/debugger/debugger.factor
View File

@ -220,7 +220,7 @@ M: assert error.
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output ;
] tabular-output nl ;
M: immutable summary drop "Sequence is immutable" ;

2
basis/globs/globs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case
USING: sequences kernel regexp.combinators strings unicode.case
peg.ebnf regexp arrays ;
IN: globs

2
basis/help/cookbook/cookbook.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker
help command-line multiline ;
help command-line multiline see ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"

4
basis/help/definitions/definitions.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint.custom prettyprint words kernel
effects ;
effects see ;
IN: help.definitions
! Definition protocol implementation

1
basis/help/handbook/handbook.factor
View File

@ -194,6 +194,7 @@ ARTICLE: "io" "Input and output"
ARTICLE: "tools" "Developer tools"
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "see" }
{ $subsection "editor" }
{ $subsection "listener" }
{ $subsection "tools.crossref" }

2
basis/help/help-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.crossref help.stylesheet help.topics
help.syntax definitions io prettyprint summary arrays math
sequences vocabs strings ;
sequences vocabs strings see ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"

8
basis/help/lint/lint.factor
View File

@ -132,6 +132,11 @@ SYMBOL: vocabs-quot
[ check-descriptions ]
} cleave ;
: check-class-description ( word element -- )
[ class? not ]
[ { $class-description } swap elements empty? not ] bi* and
[ "A word that is not a class has a $class-description" throw ] when ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
@ -153,7 +158,8 @@ M: help-error error.
dup '[
_ dup word-help
[ check-values ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
[ check-class-description ]
[ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
] check-something
] [ drop ] if ;

11
basis/help/markup/markup.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots fry
sets vocabs help.stylesheet help.topics vocabs.loader quotations
combinators call ;
combinators call see ;
IN: help.markup
PREDICATE: simple-element < array
@ -13,7 +13,6 @@ PREDICATE: simple-element < array
SYMBOL: last-element
SYMBOL: span
SYMBOL: block
SYMBOL: table
: last-span? ( -- ? ) last-element get span eq? ;
: last-block? ( -- ? ) last-element get block eq? ;
@ -44,7 +43,7 @@ M: f print-element drop ;
[ print-element ] with-default-style ;
: ($block) ( quot -- )
last-element get { f table } member? [ nl ] unless
last-element get [ nl ] when
span last-element set
call
block last-element set ; inline
@ -218,7 +217,7 @@ ALIAS: $slot $snippet
table-content-style get [
swap [ last-element off call ] tabular-output
] with-style
] ($block) table last-element set ; inline
] ($block) ; inline
: $list ( element -- )
list-style get [
@ -301,7 +300,7 @@ M: f ($instance)
] with-style
] ($block) ; inline
: $see ( element -- ) first [ see ] ($see) ;
: $see ( element -- ) first [ see* ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
@ -346,6 +345,8 @@ M: f ($instance)
drop
"Throws an error if the I/O operation fails." $errors ;
FROM: prettyprint.private => with-pprint ;
: $prettyprinting-note ( children -- )
drop {
"This word should only be called from inside the "

6
basis/images/bitmap/bitmap.factor
View File

@ -108,11 +108,6 @@ M: bitmap-image load-image* ( path bitmap -- bitmap )
load-bitmap-data process-bitmap-data
fill-image-slots ;
M: bitmap-image normalize-scan-line-order
dup dim>> '[
_ first 4 * <sliced-groups> reverse concat
] change-bitmap ;
MACRO: (nbits>bitmap) ( bits -- )
[ -3 shift ] keep '[
bitmap-image new
@ -121,6 +116,7 @@ MACRO: (nbits>bitmap) ( bits -- )
swap >>width
swap array-copy [ >>bitmap ] [ >>color-index ] bi
_ >>bit-count fill-image-slots
t >>upside-down?
] ;
: bgr>bitmap ( array height width -- bitmap )

15
basis/images/images.factor
View File

@ -27,7 +27,7 @@ R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
{ R32G32B32A32 [ 16 ] }
} case ;
TUPLE: image dim component-order bitmap ;
TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
@ -82,11 +82,16 @@ M: ARGB normalize-component-order*
M: ABGR normalize-component-order*
drop ARGB>RGBA 4 BGR>RGB ;
GENERIC: normalize-scan-line-order ( image -- image )
M: image normalize-scan-line-order ;
: normalize-scan-line-order ( image -- image )
dup upside-down?>> [
dup dim>> first 4 * '[
_ <groups> reverse concat
] change-bitmap
f >>upside-down?
] when ;
: normalize-image ( image -- image )
[ >byte-array ] change-bitmap
normalize-component-order
normalize-scan-line-order ;
normalize-scan-line-order
RGBA >>component-order ;

2
basis/images/tiff/tiff.factor
View File

@ -503,7 +503,7 @@ ERROR: unknown-component-order ifd ;
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
[ ifd-component-order f ]
[ bitmap>> ]
} cleave tiff-image boa ;

4
basis/inspector/inspector.factor
View File

@ -9,7 +9,7 @@ IN: inspector
SYMBOL: +number-rows+
: summary. ( obj -- ) [ summary ] keep write-object nl ;
: print-summary ( obj -- ) [ summary ] keep write-object ;
<PRIVATE
@ -40,7 +40,7 @@ M: mirror fix-slot-names
: (describe) ( obj assoc -- keys )
t pprint-string-cells? [
[ summary. ] [
[ print-summary nl ] [
dup hashtable? [ sort-unparsed-keys ] when
[ fix-slot-names add-numbers simple-table. ] [ keys ] bi
] bi*

2
basis/io/styles/styles.factor
View File

@ -97,7 +97,7 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-output-stream* ;
[ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;

2
basis/listener/listener.factor
View File

@ -84,7 +84,7 @@ SYMBOL: max-stack-items
bi
] with-row
] each
] tabular-output
] tabular-output nl
] unless-empty ;
: trimmed-stack. ( seq -- )

2
basis/locals/definitions/definitions.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors definitions effects generic kernel locals
macros memoize prettyprint prettyprint.backend words ;
macros memoize prettyprint prettyprint.backend see words ;
IN: locals.definitions
PREDICATE: lambda-word < word "lambda" word-prop >boolean ;

2
basis/locals/locals-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.syntax help.markup kernel macros prettyprint
memoize combinators arrays generalizations ;
memoize combinators arrays generalizations see ;
IN: locals
HELP: [|

2
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -84,7 +84,7 @@ M: word integer-op-input-classes
: define-integer-op-word ( fix-word big-word triple -- )
[
[ 2nip integer-op-word ] [ integer-op-quot ] 3bi
[ 2nip integer-op-word dup make-foldable ] [ integer-op-quot ] 3bi
(( x y -- z )) define-declared
] [
2nip

6
basis/opengl/textures/textures.factor
View File

@ -11,14 +11,16 @@ IN: opengl.textures
TUPLE: texture loc dim texture-coords texture display-list disposed ;
<PRIVATE
GENERIC: component-order>format ( component-order -- format type )
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
<PRIVATE
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;

58
basis/prettyprint/prettyprint-docs.factor
View File

@ -1,6 +1,7 @@
USING: prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections prettyprint.private help.markup help.syntax
io kernel words definitions quotations strings generic classes ;
io kernel words definitions quotations strings generic classes
prettyprint.private ;
IN: prettyprint
ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
@ -149,10 +150,6 @@ $nl
{ $subsection unparse-use }
"Utility for tabular output:"
{ $subsection pprint-cell }
"Printing a definition (see " { $link "definitions" } "):"
{ $subsection see }
"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
{ $subsection see-methods }
"More prettyprinter usage:"
{ $subsection "prettyprint-numbers" }
{ $subsection "prettyprint-stacks" }
@ -160,7 +157,7 @@ $nl
{ $subsection "prettyprint-variables" }
{ $subsection "prettyprint-extension" }
{ $subsection "prettyprint-limitations" }
{ $see-also "number-strings" } ;
{ $see-also "number-strings" "see" } ;
ABOUT: "prettyprint"
@ -232,51 +229,4 @@ HELP: .s
HELP: in.
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Prettyprints a " { $snippet "IN:" } " declaration." }
$prettyprinting-note ;
HELP: synopsis
{ $values { "defspec" "a definition specifier" } { "str" string } }
{ $contract "Prettyprints the prologue of a definition." } ;
HELP: synopsis*
{ $values { "defspec" "a definition specifier" } }
{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
HELP: comment.
{ $values { "string" "a string" } }
{ $description "Prettyprints some text with the comment style." }
$prettyprinting-note ;
HELP: see
{ $values { "defspec" "a definition specifier" } }
{ $contract "Prettyprints a definition." } ;
HELP: see-methods
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
{ $contract "Prettyprints the methods defined on a generic word or class." } ;
HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
": foo ; \\ foo definer . ."
";\nPOSTPONE: :"
}
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
"SYMBOL: foo \\ foo definer . ."
"f\nPOSTPONE: SYMBOL:"
}
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
HELP: definition
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
{ $contract "Outputs the body of a definition." }
{ $examples
{ $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
$prettyprinting-note ;

2
basis/prettyprint/prettyprint-tests.factor
View File

@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
accessors make vocabs.parser ;
accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test

232
basis/prettyprint/prettyprint.factor
View File

@ -1,16 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic generic.standard assocs io kernel math
namespaces make sequences strings io.styles io.streams.string
vectors words words.symbol prettyprint.backend prettyprint.custom
prettyprint.sections prettyprint.config sorting splitting
grouping math.parser vocabs definitions effects classes.builtin
classes.tuple io.pathnames classes continuations hashtables
classes.mixin classes.union classes.intersection
classes.predicate classes.singleton combinators quotations sets
accessors colors parser summary vocabs.parser ;
USING: accessors assocs colors combinators grouping io
io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
vocabs.parser words ;
IN: prettyprint
<PRIVATE
: make-pprint ( obj quot -- block in use )
[
0 position set
@ -65,6 +63,8 @@ IN: prettyprint
nl
] print-use-hook set-global
PRIVATE>
: with-use ( obj quot -- )
make-pprint use/in. do-pprint ; inline
@ -165,214 +165,4 @@ SYMBOL: pprint-string-cells?
] each
] with-row
] each
] tabular-output ;
GENERIC: see ( defspec -- )
: comment. ( string -- )
[ H{ { font-style italic } } styled-text ] when* ;
: seeing-word ( word -- )
vocabulary>> pprinter-in set ;
: definer. ( defspec -- )
definer drop pprint-word ;
: stack-effect. ( word -- )
[ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
: word-synopsis ( word -- )
{
[ seeing-word ]
[ definer. ]
[ pprint-word ]
[ stack-effect. ]
} cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ dispatch# pprint* ]
[ stack-effect. ]
} cleave ;
M: hook-generic synopsis*
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ "combination" word-prop var>> pprint* ]
[ stack-effect. ]
} cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
[ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
[ definer. ]
[ class>> pprint-word ]
[ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
: synopsis ( defspec -- str )
[
0 margin set
1 line-limit set
[ synopsis* ] with-in
] with-string-writer ;
M: word summary synopsis ;
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
: declaration. ( word prop -- )
[ nip ] [ name>> word-prop ] 2bi
[ pprint-word ] [ drop ] if ;
M: word declarations.
{
POSTPONE: parsing
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: recursive
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; ( -- ) \ ; pprint-word ;
M: object see
[
12 nesting-limit set
100 length-limit set
<colon dup synopsis*
<block dup definition pprint-elements block>
dup definer nip [ pprint-word ] when* declarations.
block>
] with-use nl ;
M: method-spec see
first2 method see ;
GENERIC: see-class* ( word -- )
M: union-class see-class*
<colon \ UNION: pprint-word
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
dup members [
hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
] with each block> block> ;
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
dup pprint-word
"<" text
dup superclass pprint-word
<block
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
GENERIC: pprint-slot-name ( object -- )
M: string pprint-slot-name text ;
M: array pprint-slot-name
<flow \ { pprint-word
f <inset unclip text pprint-elements block>
\ } pprint-word block> ;
: unparse-slot ( slot-spec -- array )
[
dup name>> ,
dup class>> object eq? [
dup class>> ,
initial: ,
dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
drop
] { } make ;
: pprint-slot ( slot-spec -- )
unparse-slot
dup length 1 = [ first ] when
pprint-slot-name ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
<block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ;
M: word see-class* drop ;
M: builtin-class see-class*
drop "! Built-in class" comment. ;
: see-class ( class -- )
dup class? [
[
dup seeing-word dup see-class*
] with-use nl
] when drop ;
M: word see
[ see-class ]
[ [ class? ] [ symbol? not ] bi and [ nl ] when ]
[
dup [ class? ] [ symbol? ] bi and
[ drop ] [ call-next-method ] if
] tri ;
: see-all ( seq -- )
natural-sort [ nl ] [ see ] interleave ;
: (see-implementors) ( class -- seq )
dup implementors [ method ] with map natural-sort ;
: (see-methods) ( generic -- seq )
"methods" word-prop values natural-sort ;
: methods ( word -- seq )
[
dup class? [ dup (see-implementors) % ] when
dup generic? [ dup (see-methods) % ] when
drop
] { } make prune ;
: see-methods ( word -- )
methods see-all ;
] tabular-output nl ;

2
basis/prettyprint/sections/sections-docs.factor
View File

@ -199,7 +199,7 @@ HELP: <flow
HELP: colon
{ $class-description "A " { $link block } " section. When printed as a " { $link long-section } ", indents every line except the first." }
{ $notes "Colon sections are used to enclose word definitions printed by " { $link see } "." } ;
{ $notes "Colon sections are used to enclose word definitions when " { $link "see" } "." } ;
HELP: <colon
{ $description "Begins a " { $link colon } " section." } ;

26
basis/regexp/classes/classes-tests.factor
View File

@ -30,15 +30,15 @@ IN: regexp.classes.tests
[ T{ or-class { seq { 3 2 } } } ] [ { 2 3 } <or-class> 1 <not-class> 2array <and-class> ] unit-test
[ f ] [ t <not-class> ] unit-test
[ t ] [ f <not-class> ] unit-test
[ f ] [ 1 <not-class> 1 t replace-question ] unit-test
[ f ] [ 1 <not-class> 1 t answer ] unit-test
! Making classes into nested conditionals
[ V{ 1 2 3 4 } ] [ T{ and-class f { 1 T{ not-class f 2 } T{ or-class f { 3 4 } } 2 } } class>questions ] unit-test
[ { 3 } ] [ { { 3 t } } table>condition ] unit-test
[ { T{ primitive-class } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>questions ] unit-test
[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t answer ] unit-test
[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f answer ] unit-test
[ { { 1 t } { 2 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } t assoc-answer ] unit-test
[ { { 1 t } } ] [ { { 1 t } { 2 T{ primitive-class } } } T{ primitive-class } f assoc-answer ] unit-test
[ T{ condition f T{ primitive-class } { 1 2 } { 1 } } ] [ { { 1 t } { 2 T{ primitive-class } } } table>condition ] unit-test
SYMBOL: foo
@ -46,13 +46,13 @@ SYMBOL: bar
[ T{ condition f T{ primitive-class f bar } T{ condition f T{ primitive-class f foo } { 1 3 2 } { 1 3 } } T{ condition f T{ primitive-class f foo } { 1 2 } { 1 } } } ] [ { { 1 t } { 3 T{ primitive-class f bar } } { 2 T{ primitive-class f foo } } } table>condition ] unit-test
[ t ] [ foo <primitive-class> dup t replace-question ] unit-test
[ f ] [ foo <primitive-class> dup f replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t replace-question ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f replace-question ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f replace-question ] unit-test
[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t replace-question ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f replace-question ] unit-test
[ t ] [ foo <primitive-class> dup t answer ] unit-test
[ f ] [ foo <primitive-class> dup f answer ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> t answer ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> f answer ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> t answer ] unit-test
[ T{ primitive-class f bar } ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> t answer ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> foo <primitive-class> f answer ] unit-test
[ f ] [ foo <primitive-class> bar <primitive-class> 2array <and-class> bar <primitive-class> f answer ] unit-test
[ t ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> t answer ] unit-test
[ T{ primitive-class f foo } ] [ foo <primitive-class> bar <primitive-class> 2array <or-class> bar <primitive-class> f answer ] unit-test

52
basis/regexp/classes/classes.factor
View File

@ -163,20 +163,32 @@ M: integer combine-or
: try-combine ( elt1 elt2 quot -- combined/f ? )
3dup call [ [ 3drop ] dip t ] [ drop swapd call ] if ; inline
DEFER: answer
:: try-cancel ( elt1 elt2 empty -- combined/f ? )
[ elt1 elt2 empty answer dup elt1 = not ] try-combine ;
:: prefix-combining ( seq elt quot: ( elt1 elt2 -- combined/f ? ) -- newseq )
f :> combined!
seq [ elt quot try-combine swap combined! ] find drop
seq [ elt quot call swap combined! ] find drop
[ seq remove-nth combined prefix ]
[ seq elt prefix ] if* ; inline
: combine-by ( seq quot -- new-seq )
{ } swap '[ _ prefix-combining ] reduce ; inline
:: seq>instance ( seq empty class -- instance )
seq length {
{ 0 [ empty ] }
{ 1 [ seq first ] }
[ drop class new seq >>seq ]
} case ; inline
:: combine ( seq quot: ( elt1 elt2 -- combined/f ? ) empty class -- newseq )
seq class flatten
{ } [ quot prefix-combining ] reduce
dup length {
{ 0 [ drop empty ] }
{ 1 [ first ] }
[ drop class new swap >>seq ]
} case ; inline
[ quot try-combine ] combine-by
! [ empty try-cancel ] combine-by ! This makes the algorithm O(n^4)
empty class seq>instance ; inline
: <and-class> ( seq -- class )
[ combine-and ] t and-class combine ;
@ -218,36 +230,36 @@ UNION: class primitive-class not-class or-class and-class range ;
TUPLE: condition question yes no ;
C: <condition> condition
GENERIC# replace-question 2 ( class from to -- new-class )
GENERIC# answer 2 ( class from to -- new-class )
M:: object replace-question ( class from to -- new-class )
M:: object answer ( class from to -- new-class )
class from = to class ? ;
: replace-compound ( class from to -- seq )
[ seq>> ] 2dip '[ _ _ replace-question ] map ;
[ seq>> ] 2dip '[ _ _ answer ] map ;
M: and-class replace-question
M: and-class answer
replace-compound <and-class> ;
M: or-class replace-question
M: or-class answer
replace-compound <or-class> ;
M: not-class replace-question
[ class>> ] 2dip replace-question <not-class> ;
M: not-class answer
[ class>> ] 2dip answer <not-class> ;
: answer ( table question answer -- new-table )
'[ _ _ replace-question ] assoc-map
: assoc-answer ( table question answer -- new-table )
'[ _ _ answer ] assoc-map
[ nip ] assoc-filter ;
: answers ( table questions answer -- new-table )
'[ _ answer ] each ;
: assoc-answers ( table questions answer -- new-table )
'[ _ assoc-answer ] each ;
DEFER: make-condition
: (make-condition) ( table questions question -- condition )
[ 2nip ]
[ swap [ t answer ] dip make-condition ]
[ swap [ f answer ] dip make-condition ] 3tri
[ swap [ t assoc-answer ] dip make-condition ]
[ swap [ f assoc-answer ] dip make-condition ] 3tri
2dup = [ 2nip ] [ <condition> ] if ;
: make-condition ( table questions -- condition )

4
basis/regexp/combinators/combinators-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.combinators tools.test regexp kernel sequences regexp.matchers ;
USING: regexp.combinators tools.test regexp kernel sequences ;
IN: regexp.combinators.tests
: strings ( -- regexp )
@ -16,7 +16,7 @@ USE: multiline
{ R' .*a' R' b.*' } <and> ;
[ t ] [ "bljhasflsda" conj matches? ] unit-test
[ f ] [ "bsdfdfs" conj matches? ] unit-test ! why does this fail?
[ f ] [ "bsdfdfs" conj matches? ] unit-test
[ f ] [ "fsfa" conj matches? ] unit-test
[ f ] [ "bljhasflsda" conj <not> matches? ] unit-test

59
basis/regexp/compiler/compiler.factor
View File

@ -1,19 +1,19 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: regexp.classes kernel sequences regexp.negation
quotations regexp.minimize assocs fry math locals combinators
quotations assocs fry math locals combinators
accessors words compiler.units kernel.private strings
sequences.private arrays regexp.matchers call namespaces
sequences.private arrays call namespaces
regexp.transition-tables combinators.short-circuit ;
IN: regexp.compiler
GENERIC: question>quot ( question -- quot )
<PRIVATE
SYMBOL: shortest?
SYMBOL: backwards?
<PRIVATE
M: t question>quot drop [ 2drop t ] ;
M: beginning-of-input question>quot
@ -64,7 +64,7 @@ C: <box> box
: non-literals>dispatch ( literals non-literals -- quot )
[ swap ] assoc-map ! we want state => predicate, and get the opposite as input
swap keys f answers
swap keys f assoc-answers
table>condition [ <box> ] condition-map condition>quot ;
: literals>cases ( literal-transitions -- case-body )
@ -106,13 +106,15 @@ C: <box> box
transitions>quot ;
: states>code ( words dfa -- )
'[
[ ! with-compilation-unit doesn't compile, so we need call( -- )
[
dup _ word>quot
(( last-match index string -- ? ))
define-declared
] each
] with-compilation-unit ;
'[
dup _ word>quot
(( last-match index string -- ? ))
define-declared
] each
] with-compilation-unit
] call( words dfa -- ) ;
: states>words ( dfa -- words dfa )
dup transitions>> keys [ gensym ] H{ } map>assoc
@ -120,34 +122,23 @@ C: <box> box
[ values ]
bi swap ;
: dfa>word ( dfa -- word )
: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
: check-string ( string -- string )
! Make this configurable
dup string? [ "String required" throw ] unless ;
: setup-regexp ( start-index string -- f start-index string )
[ f ] [ >fixnum ] [ check-string ] tri* ; inline
PRIVATE>
! The quotation returned is ( start-index string -- i/f )
: simple-define-temp ( quot effect -- word )
[ [ define-temp ] with-compilation-unit ] call( quot effect -- word ) ;
: dfa>quotation ( dfa -- quot )
dfa>word execution-quot '[ setup-regexp @ ] ;
: dfa>word ( dfa -- quot )
dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
(( start-index string regexp -- i/f )) simple-define-temp ;
: dfa>shortest-quotation ( dfa -- quot )
t shortest? [ dfa>quotation ] with-variable ;
: dfa>shortest-word ( dfa -- word )
t shortest? [ dfa>word ] with-variable ;
: dfa>reverse-quotation ( dfa -- quot )
t backwards? [ dfa>quotation ] with-variable ;
: dfa>reverse-word ( dfa -- word )
t backwards? [ dfa>word ] with-variable ;
: dfa>reverse-shortest-quotation ( dfa -- quot )
t backwards? [ dfa>shortest-quotation ] with-variable ;
TUPLE: quot-matcher quot ;
C: <quot-matcher> quot-matcher
M: quot-matcher match-index-from
quot>> call( index string -- i/f ) ;
: dfa>reverse-shortest-word ( dfa -- word )
t backwards? [ dfa>shortest-word ] with-variable ;

59
basis/regexp/matchers/matchers.factor
View File

@ -1,59 +0,0 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math splitting make fry locals math.ranges
accessors arrays ;
IN: regexp.matchers
! For now, a matcher is just something with a method to do the
! equivalent of match.
GENERIC: match-index-from ( i string matcher -- index/f )
: match-index-head ( string matcher -- index/f )
[ 0 ] 2dip match-index-from ;
: match-slice ( i string matcher -- slice/f )
[ 2dup ] dip match-index-from
[ swap <slice> ] [ 2drop f ] if* ;
: matches? ( string matcher -- ? )
dupd match-index-head
[ swap length = ] [ drop f ] if* ;
: match-from ( i string matcher -- slice/f )
[ [ length [a,b) ] keep ] dip
'[ _ _ match-slice ] map-find drop ;
: match-head ( str matcher -- slice/f )
[ 0 ] 2dip match-from ;
<PRIVATE
: next-match ( i string matcher -- i match/f )
match-from [ dup [ to>> ] when ] keep ;
PRIVATE>
:: all-matches ( string matcher -- seq )
0 [ dup ] [ string matcher next-match ] produce nip but-last ;
: count-matches ( string matcher -- n )
all-matches length ;
<PRIVATE
:: split-slices ( string slices -- new-slices )
slices [ to>> ] map 0 prefix
slices [ from>> ] map string length suffix
[ string <slice> ] 2map ;
PRIVATE>
: re-split1 ( string matcher -- before after/f )
dupd match-head [ 1array split-slices first2 ] [ f ] if* ;
: re-split ( string matcher -- seq )
dupd all-matches split-slices ;
: re-replace ( string matcher replacement -- result )
[ re-split ] dip join ;

6
basis/regexp/negation/negation.factor
View File

@ -6,9 +6,6 @@ regexp.ast regexp.transition-tables regexp.minimize
regexp.dfa namespaces ;
IN: regexp.negation
: ast>dfa ( parse-tree -- minimal-dfa )
construct-nfa disambiguate construct-dfa minimize ;
CONSTANT: fail-state -1
: add-default-transition ( state's-transitions -- new-state's-transitions )
@ -49,5 +46,8 @@ CONSTANT: fail-state -1
[ final-states>> keys first ]
[ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
: ast>dfa ( parse-tree -- minimal-dfa )
construct-nfa disambiguate construct-dfa minimize ;
M: negation nfa-node ( node -- start end )
term>> ast>dfa negate-table adjoin-dfa ;

31
basis/regexp/regexp-docs.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings help.markup help.syntax regexp.matchers math ;
USING: kernel strings help.markup help.syntax math ;
IN: regexp
ABOUT: "regexp"
@ -23,7 +23,7 @@ ARTICLE: { "regexp" "construction" } "Constructing regular expressions"
{ $vocab-link "regexp.combinators" } ;
ARTICLE: { "regexp" "syntax" } "Regular expression syntax"
"Regexp syntax is largely compatible with Perl, Java and extended POSTFIX regexps, but not completely." $nl
"Regexp syntax is largely compatible with Perl, Java and extended POSIX regexps, but not completely." $nl
"A new addition is the inclusion of a negation operator, with the syntax " { $snippet "(?~foo)" } " to match everything that does not match " { $snippet "foo" } "." $nl
"One missing feature is backreferences. This is because of a design decision to allow only regular expressions following the formal theory of regular languages. For more information, see " { $link { "regexp" "theory" } } ". You can create a new regular expression to match a particular string using " { $vocab-link "regexp.combinators" } " and group capture is available to extract parts of a regular expression match." $nl
"A distinction from Perl is that " { $snippet "\\G" } ", which references the previous match, is not included. This is because that sequence is inherently stateful, and Factor regexps don't hold state." $nl
@ -39,13 +39,14 @@ ARTICLE: { "regexp" "theory" } "The theory of regular expressions"
"The Factor regular expression engine was built with the design decision to support negation and intersection at the expense of backreferences. This lets us have a guaranteed linear-time matching algorithm. Systems like Ragel and Lex also use this algorithm, but in the Factor regular expression engine, all other features of regexps are still present." ;
ARTICLE: { "regexp" "operations" } "Matching operations with regular expressions"
{ $subsection all-matches }
{ $subsection matches? }
{ $subsection re-contains? }
{ $subsection first-match }
{ $subsection all-matches }
{ $subsection re-split1 }
{ $subsection re-split }
{ $subsection re-replace }
{ $subsection count-matches }
{ $subsection re-replace } ;
{ $subsection count-matches } ;
HELP: <regexp>
{ $values { "string" string } { "regexp" regexp } }
@ -63,25 +64,33 @@ HELP: regexp
{ $class-description "The class of regular expressions. To construct these, see " { $link { "regexp" "construction" } } "." } ;
HELP: matches?
{ $values { "string" string } { "matcher" regexp } { "?" "a boolean" } }
{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
{ $description "Tests if the string as a whole matches the given regular expression." } ;
HELP: re-split1
{ $values { "string" string } { "matcher" regexp } { "before" string } { "after/f" string } }
{ $values { "string" string } { "regexp" regexp } { "before" string } { "after/f" string } }
{ $description "Searches the string for a substring which matches the pattern. If found, the input string is split on the leftmost and longest occurence of the match, and the two halves are given as output. If no match is found, then the input string and " { $link f } " are output." } ;
HELP: all-matches
{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
{ $description "Finds a sequence of disjoint substrings which each match the pattern. It chooses this by finding the leftmost longest match, and then the leftmost longest match which starts after the end of the previous match, and so on." } ;
HELP: count-matches
{ $values { "string" string } { "matcher" regexp } { "n" integer } }
{ $values { "string" string } { "regexp" regexp } { "n" integer } }
{ $description "Counts how many disjoint matches the regexp has in the string, as made unambiguous by " { $link all-matches } "." } ;
HELP: re-split
{ $values { "string" string } { "matcher" regexp } { "seq" "a sequence of slices of the input" } }
{ $values { "string" string } { "regexp" regexp } { "seq" "a sequence of slices of the input" } }
{ $description "Splits the input string into chunks separated by the regular expression. Each chunk contains no match of the regexp. The chunks are chosen by the strategy of " { $link all-matches } "." } ;
HELP: re-replace
{ $values { "string" string } { "matcher" regexp } { "replacement" string } { "result" string } }
{ $values { "string" string } { "regexp" regexp } { "replacement" string } { "result" string } }
{ $description "Replaces substrings which match the input regexp with the given replacement text. The boundaries of the substring are chosen by the strategy used by " { $link all-matches } "." } ;
HELP: first-match
{ $values { "string" string } { "regexp" regexp } { "slice/f" "the match, if one exists" } }
{ $description "Finds the first match of the regular expression in the string, and returns it as a slice. If there is no match, then " { $link f } " is returned." } ;
HELP: re-contains?
{ $values { "string" string } { "regexp" regexp } { "?" "a boolean" } }
{ $description "Determines whether the string has a substring which matches the regular expression given." } ;

67
basis/regexp/regexp-tests.factor
View File

@ -1,13 +1,12 @@
! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: regexp tools.test kernel sequences regexp.parser regexp.private
eval strings multiline accessors regexp.matchers ;
eval strings multiline accessors ;
IN: regexp-tests
\ <regexp> must-infer
! the following don't compile because [ ] with-compilation-unit doesn't compile
! \ compile-regexp must-infer
! \ matches? must-infer
\ compile-regexp must-infer
\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
@ -212,8 +211,8 @@ IN: regexp-tests
[ f ] [ "aaaxb" "a+ab" <regexp> matches? ] unit-test
[ t ] [ "aaacb" "a+cb" <regexp> matches? ] unit-test
[ 3 ] [ "aaacb" "a*" <regexp> match-index-head ] unit-test
[ 2 ] [ "aaacb" "aa?" <regexp> match-index-head ] unit-test
[ "aaa" ] [ "aaacb" "a*" <regexp> first-match >string ] unit-test
[ "aa" ] [ "aaacb" "aa?" <regexp> first-match >string ] unit-test
[ t ] [ "aaa" R/ AAA/i matches? ] unit-test
[ f ] [ "aax" R/ AAA/i matches? ] unit-test
@ -240,11 +239,11 @@ IN: regexp-tests
[ f ] [ "A" "\\p{Lower}" <regexp> matches? ] unit-test
[ t ] [ "A" R/ \p{Lower}/i matches? ] unit-test
[ t ] [ "abc" reverse R/ abc/r matches? ] unit-test
[ t ] [ "abc" reverse R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ "abc" R/ abc/r matches? ] unit-test
[ t ] [ "abc" R/ a[bB][cC]/r matches? ] unit-test
[ t ] [ 3 "xabc" R/ abc/ <reverse-matcher> match-index-from >boolean ] unit-test
[ t ] [ 3 "xabc" R/ a[bB][cC]/ <reverse-matcher> match-index-from >boolean ] unit-test
[ t ] [ 3 "xabc" R/ abc/r match-index-from >boolean ] unit-test
[ t ] [ 3 "xabc" R/ a[bB][cC]/r match-index-from >boolean ] unit-test
[ t ] [ "s@f" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" <regexp> matches? ] unit-test
@ -269,13 +268,13 @@ IN: regexp-tests
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> match-head >string ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> match-head >string ] unit-test
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> match-head >string ] unit-test
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
[ { "1" "2" "3" "4" } ]
[ "1ABC2DEF3GHI4" R/ [A-Z]+/ re-split [ >string ] map ] unit-test
@ -301,18 +300,18 @@ IN: regexp-tests
[ "-- title --" ] [ "== title ==" R/ =/ "-" re-replace ] unit-test
[ "" ] [ "ab" "a(?!b)" <regexp> match-head >string ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> match-head >string ] unit-test
[ "" ] [ "ab" "a(?!b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
[ t ] [ "fxxbar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "foobar" ".{3}(?!foo)bar" <regexp> matches? ] unit-test
[ t ] [ "fxxbar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ f ] [ "foobar" "(?!foo).{3}bar" <regexp> matches? ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> match-head >string ] unit-test
[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> match-head >string ] unit-test
[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> match-head >string ] unit-test
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
[ "a" ] [ "ba" "(?<=b)(?<=b)a" <regexp> first-match >string ] unit-test
[ "a" ] [ "cab" "(?<=c)a(?=b)" <regexp> first-match >string ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> match-index-head ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> match-index-head ] unit-test
[ 3 ] [ "foobar" "foo(?=bar)" <regexp> first-match length ] unit-test
[ f ] [ "foobxr" "foo(?=bar)" <regexp> first-match ] unit-test
! Bug in parsing word
[ t ] [ "a" R' a' matches? ] unit-test
@ -342,9 +341,19 @@ IN: regexp-tests
[ t ] [ "aaaa" R/ .*a./ matches? ] unit-test
[ f ] [ "ab" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
[ f ] [ "ab" R/ (?~ac|[a-z]b)/ matches? ] unit-test
[ f ] [ "ac" R/ (?~ac|\p{Lower}b)/ matches? ] unit-test
[ f ] [ "ac" R/ (?~ac|[a-z]b)/ matches? ] unit-test
[ f ] [ "ac" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
[ f ] [ "ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
[ f ] [ "πb" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
[ t ] [ "πc" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
[ t ] [ "Ab" R/ (?~[a-zA-Z]c|\p{Lower}b)/ matches? ] unit-test
! DFA is compiled when needed, or when literal
[ f ] [ "foo" <regexp> dfa>> >boolean ] unit-test
[ t ] [ R/ foo/ dfa>> >boolean ] unit-test
[ regexp-initial-word ] [ "foo" <regexp> dfa>> ] unit-test
[ f ] [ R/ foo/ dfa>> \ regexp-initial-word = ] unit-test
[ t ] [ "a" R/ ^a/ matches? ] unit-test
[ f ] [ "\na" R/ ^a/ matches? ] unit-test
@ -415,8 +424,14 @@ IN: regexp-tests
[ 1 ] [ "a\r" R/ a$/m count-matches ] unit-test
[ 1 ] [ "a\r\n" R/ a$/m count-matches ] unit-test
[ f ] [ "foobxr" "foo\\z" <regexp> match-index-head ] unit-test
[ 3 ] [ "foo" "foo\\z" <regexp> match-index-head ] unit-test
[ f ] [ "foobxr" "foo\\z" <regexp> first-match ] unit-test
[ 3 ] [ "foo" "foo\\z" <regexp> first-match length ] unit-test
[ t ] [ "a foo b" R/ foo/ re-contains? ] unit-test
[ f ] [ "a bar b" R/ foo/ re-contains? ] unit-test
[ t ] [ "foo" R/ foo/ re-contains? ] unit-test
[ { "foo" "fxx" "fab" } ] [ "fab fxx foo" R/ f../r all-matches [ >string ] map ] unit-test
! [ t ] [ "foo" "\\bfoo\\b" <regexp> matches? ] unit-test
! [ t ] [ "afoob" "\\Bfoo\\B" <regexp> matches? ] unit-test

214
basis/regexp/regexp.factor
View File

@ -2,71 +2,194 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel math sequences strings sets
assocs prettyprint.backend prettyprint.custom make lexer
namespaces parser arrays fry locals regexp.minimize
regexp.parser regexp.nfa regexp.dfa regexp.classes
regexp.transition-tables splitting sorting regexp.ast
regexp.negation regexp.matchers regexp.compiler ;
namespaces parser arrays fry locals regexp.parser splitting
sorting regexp.ast regexp.negation regexp.compiler words
call call.private math.ranges ;
IN: regexp
TUPLE: regexp
{ raw read-only }
{ parse-tree read-only }
{ options read-only }
dfa reverse-dfa ;
dfa next-match ;
: make-regexp ( string ast -- regexp )
f f <options> f f regexp boa ; foldable
! Foldable because, when the dfa slot is set,
! it'll be set to the same thing regardless of who sets it
TUPLE: reverse-regexp < regexp ;
: <optioned-regexp> ( string options -- regexp )
[ dup parse-regexp ] [ string>options ] bi*
f f regexp boa ;
<PRIVATE
: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
: maybe-negated ( lookaround quot -- regexp-quot )
'[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
TUPLE: reverse-matcher regexp ;
C: <reverse-matcher> reverse-matcher
! Reverse matchers won't work properly with most combinators, for now
M: lookahead question>quot ! Returns ( index string -- ? )
[ ast>dfa dfa>shortest-word '[ f _ execute ] ] maybe-negated ;
: <reversed-option> ( ast -- reversed )
"r" string>options <with-options> ;
M: lookbehind question>quot ! Returns ( index string -- ? )
[
<reversed-option>
ast>dfa dfa>reverse-shortest-word
'[ [ 1- ] dip f _ execute ]
] maybe-negated ;
: check-string ( string -- string )
! Make this configurable
dup string? [ "String required" throw ] unless ;
: match-index-from ( i string regexp -- index/f )
! This word is unsafe. It assumes that i is a fixnum
! and that string is a string.
dup dfa>> execute-unsafe( index string regexp -- i/f ) ;
GENERIC: end/start ( string regexp -- end start )
M: regexp end/start drop length 0 ;
M: reverse-regexp end/start drop length 1- -1 swap ;
PRIVATE>
: matches? ( string regexp -- ? )
[ end/start ] 2keep
[ check-string ] dip
match-index-from
[ swap = ] [ drop f ] if* ;
<PRIVATE
TUPLE: match { i read-only } { j read-only } { seq read-only } ;
: match-slice ( i string quot -- match/f )
[ 2dup ] dip call
[ swap match boa ] [ 2drop f ] if* ; inline
: search-range ( i string reverse? -- seq )
[ drop 0 [a,b] ] [ length [a,b) ] if ; inline
: match>result ( match reverse? -- i start end string )
over [
[ [ i>> ] [ j>> tuck ] [ seq>> ] tri ] dip
[ [ swap [ 1+ ] bi@ ] dip ] when
] [ 2drop f f f f ] if ; inline
:: next-match ( i string quot reverse? -- i start end string )
i string reverse? search-range
[ string quot match-slice ] map-find drop
reverse? match>result ; inline
: do-next-match ( i string regexp -- i start end string )
dup next-match>>
execute-unsafe( i string regexp -- i start end string ) ;
: next-slice ( i string regexp -- i/f slice/f )
do-next-match
[ slice boa ] [ drop ] if* ; inline
PRIVATE>
TUPLE: match-iterator
{ string read-only }
{ regexp read-only }
{ i read-only }
{ value read-only } ;
: iterate ( iterator -- iterator'/f )
dup
[ i>> ] [ string>> ] [ regexp>> ] tri next-slice
[ [ [ string>> ] [ regexp>> ] bi ] 2dip match-iterator boa ]
[ 2drop f ] if* ;
: value ( iterator/f -- value/f )
dup [ value>> ] when ;
: <match-iterator> ( string regexp -- match-iterator )
[ check-string ] dip
2dup end/start nip f
match-iterator boa
iterate ; inline
: all-matches ( string regexp -- seq )
<match-iterator> [ iterate ] follow [ value ] map ;
: count-matches ( string regexp -- n )
all-matches length ;
<PRIVATE
:: split-slices ( string slices -- new-slices )
slices [ to>> ] map 0 prefix
slices [ from>> ] map string length suffix
[ string <slice> ] 2map ;
PRIVATE>
: first-match ( string regexp -- slice/f )
<match-iterator> value ;
: re-contains? ( string regexp -- ? )
first-match >boolean ;
: re-split1 ( string regexp -- before after/f )
dupd first-match [ 1array split-slices first2 ] [ f ] if* ;
: re-split ( string regexp -- seq )
dupd all-matches split-slices ;
: re-replace ( string regexp replacement -- result )
[ re-split ] dip join ;
<PRIVATE
: get-ast ( regexp -- ast )
[ parse-tree>> ] [ options>> ] bi <with-options> ;
: compile-regexp ( regexp -- regexp )
dup '[ [ _ get-ast ast>dfa dfa>quotation ] unless* ] change-dfa ;
GENERIC: compile-regexp ( regex -- regexp )
: <reversed-option> ( ast -- reversed )
"r" string>options <with-options> ;
: regexp-initial-word ( i string regexp -- i/f )
compile-regexp match-index-from ;
: maybe-negated ( lookaround quot -- regexp-quot )
'[ term>> @ ] [ positive?>> [ ] [ not ] ? ] bi compose ; inline
M: lookahead question>quot ! Returns ( index string -- ? )
[ ast>dfa dfa>shortest-quotation ] maybe-negated ;
M: lookbehind question>quot ! Returns ( index string -- ? )
[
<reversed-option>
ast>dfa dfa>reverse-shortest-quotation
[ [ 1- ] dip ] prepose
] maybe-negated ;
: compile-reverse ( regexp -- regexp )
: do-compile-regexp ( regexp -- regexp )
dup '[
[
_ get-ast <reversed-option>
ast>dfa dfa>reverse-quotation
] unless*
] change-reverse-dfa ;
dup \ regexp-initial-word =
[ drop _ get-ast ast>dfa dfa>word ] when
] change-dfa ;
M: regexp match-index-from
compile-regexp dfa>> <quot-matcher> match-index-from ;
M: regexp compile-regexp ( regexp -- regexp )
do-compile-regexp ;
M: reverse-matcher match-index-from
regexp>> compile-reverse reverse-dfa>>
<quot-matcher> match-index-from ;
M: reverse-regexp compile-regexp ( regexp -- regexp )
t backwards? [ do-compile-regexp ] with-variable ;
DEFER: compile-next-match
: next-initial-word ( i string regexp -- i start end string )
compile-next-match do-next-match ;
: compile-next-match ( regexp -- regexp )
dup '[
dup \ next-initial-word = [
drop _ [ compile-regexp dfa>> ] [ reverse-regexp? ] bi
'[ _ '[ _ _ execute ] _ next-match ]
(( i string regexp -- i start end string )) simple-define-temp
] when
] change-next-match ;
PRIVATE>
: new-regexp ( string ast options class -- regexp )
[ \ regexp-initial-word \ next-initial-word ] dip boa ; inline
: make-regexp ( string ast -- regexp )
f f <options> regexp new-regexp ;
: <optioned-regexp> ( string options -- regexp )
[ dup parse-regexp ] [ string>options ] bi*
dup on>> reversed-regexp swap member?
[ reverse-regexp new-regexp ]
[ regexp new-regexp ] if ;
: <regexp> ( string -- regexp ) "" <optioned-regexp> ;
<PRIVATE
! The following two should do some caching
@ -97,7 +220,7 @@ M: reverse-matcher match-index-from
: parsing-regexp ( accum end -- accum )
lexer get [ take-until ] [ parse-noblank-token ] bi
<optioned-regexp> compile-regexp parsed ;
<optioned-regexp> compile-next-match parsed ;
PRIVATE>
@ -120,3 +243,4 @@ M: regexp pprint*
[ options>> options>string % ] bi
] "" make
] keep present-text ;

69
basis/regexp/traversal/traversal.factor
View File

@ -1,69 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math
quotations sequences regexp.classes fry arrays regexp.matchers
combinators.short-circuit prettyprint regexp.nfa ;
IN: regexp.traversal
TUPLE: dfa-traverser
dfa-table
current-state
text
current-index
match-index ;
: <dfa-traverser> ( start-index text dfa -- match )
dfa-traverser new
swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
swap >>text
swap >>current-index ;
: final-state? ( dfa-traverser -- ? )
[ current-state>> ]
[ dfa-table>> final-states>> ] bi key? ;
: end-of-text? ( dfa-traverser -- ? )
[ current-index>> ] [ text>> length ] bi >= ; inline
: text-finished? ( dfa-traverser -- ? )
{
[ current-state>> not ]
[ end-of-text? ]
} 1|| ;
: save-final-state ( dfa-traverser -- dfa-traverser )
dup current-index>> >>match-index ;
: match-done? ( dfa-traverser -- ? )
dup final-state? [ save-final-state ] when text-finished? ;
: increment-state ( dfa-traverser state -- dfa-traverser )
>>current-state
[ 1 + ] change-current-index ;
: match-literal ( transition from-state table -- to-state/f )
transitions>> at at ;
: match-class ( transition from-state table -- to-state/f )
transitions>> at* [
swap '[ drop _ swap class-member? ] assoc-find spin ?
] [ drop ] if ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] } 3|| ;
: setup-match ( match -- obj state dfa-table )
[ [ current-index>> ] [ text>> ] bi nth ]
[ current-state>> ]
[ dfa-table>> ] tri ;
: do-match ( dfa-traverser -- dfa-traverser )
dup match-done? [
dup setup-match match-transition
[ increment-state do-match ] when*
] unless ;
TUPLE: dfa-matcher dfa ;
C: <dfa-matcher> dfa-matcher
M: dfa-matcher match-index-from
dfa>> <dfa-traverser> do-match match-index>> ;

1
basis/see/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

55
basis/see/see-docs.factor Normal file
View File

@ -0,0 +1,55 @@
IN: see
USING: help.markup help.syntax strings prettyprint.private
definitions generic words classes ;
HELP: synopsis
{ $values { "defspec" "a definition specifier" } { "str" string } }
{ $contract "Prettyprints the prologue of a definition." } ;
HELP: synopsis*
{ $values { "defspec" "a definition specifier" } }
{ $contract "Adds sections to the current block corresponding to a the prologue of a definition, in source code-like form." }
{ $notes "This word should only be called from inside the " { $link with-pprint } " combinator. Client code should call " { $link synopsis } " instead." } ;
HELP: see
{ $values { "defspec" "a definition specifier" } }
{ $contract "Prettyprints a definition." } ;
HELP: see-methods
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
{ $contract "Prettyprints the methods defined on a generic word or class." } ;
HELP: definer
{ $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
{ $contract "Outputs the parsing words which delimit the definition." }
{ $examples
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
": foo ; \\ foo definer . ."
";\nPOSTPONE: :"
}
{ $example "USING: definitions prettyprint ;"
"IN: scratchpad"
"SYMBOL: foo \\ foo definer . ."
"f\nPOSTPONE: SYMBOL:"
}
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
HELP: definition
{ $values { "defspec" "a definition specifier" } { "seq" "a sequence" } }
{ $contract "Outputs the body of a definition." }
{ $examples
{ $example "USING: definitions math prettyprint ;" "\\ sq definition ." "[ dup * ]" }
}
{ $notes "This word is used in the implementation of " { $link see } "." } ;
ARTICLE: "see" "Printing definitions"
"The " { $vocab-link "see" } " vocabulary implements support for printing out " { $link "definitions" } " in the image."
$nl
"Printing a definition:"
{ $subsection see }
"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
{ $subsection see-methods } ;
ABOUT: "see"

227
basis/see/see.factor Normal file
View File

@ -0,0 +1,227 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
definitions effects generic generic.standard io io.pathnames
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary
words words.symbol ;
IN: see
GENERIC: see* ( defspec -- )
: see ( defspec -- ) see* nl ;
: synopsis ( defspec -- str )
[
0 margin set
1 line-limit set
[ synopsis* ] with-in
] with-string-writer ;
: definer. ( defspec -- )
definer drop pprint-word ;
: comment. ( text -- )
H{ { font-style italic } } styled-text ;
: stack-effect. ( word -- )
[ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
<PRIVATE
: seeing-word ( word -- )
vocabulary>> pprinter-in set ;
: word-synopsis ( word -- )
{
[ seeing-word ]
[ definer. ]
[ pprint-word ]
[ stack-effect. ]
} cleave ;
M: word synopsis* word-synopsis ;
M: simple-generic synopsis* word-synopsis ;
M: standard-generic synopsis*
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ dispatch# pprint* ]
[ stack-effect. ]
} cleave ;
M: hook-generic synopsis*
{
[ definer. ]
[ seeing-word ]
[ pprint-word ]
[ "combination" word-prop var>> pprint* ]
[ stack-effect. ]
} cleave ;
M: method-spec synopsis*
first2 method synopsis* ;
M: method-body synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
[ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
[ definer. ]
[ class>> pprint-word ]
[ mixin>> pprint-word ] tri ;
M: pathname synopsis* pprint* ;
M: word summary synopsis ;
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
: declaration. ( word prop -- )
[ nip ] [ name>> word-prop ] 2bi
[ pprint-word ] [ drop ] if ;
M: word declarations.
{
POSTPONE: parsing
POSTPONE: delimiter
POSTPONE: inline
POSTPONE: recursive
POSTPONE: foldable
POSTPONE: flushable
} [ declaration. ] with each ;
: pprint-; ( -- ) \ ; pprint-word ;
M: object see*
[
12 nesting-limit set
100 length-limit set
<colon dup synopsis*
<block dup definition pprint-elements block>
dup definer nip [ pprint-word ] when* declarations.
block>
] with-use ;
M: method-spec see*
first2 method see* ;
GENERIC: see-class* ( word -- )
M: union-class see-class*
<colon \ UNION: pprint-word
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
dup members [
hard line-break
\ INSTANCE: pprint-word pprint-word pprint-word
] with each block> block> ;
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
dup pprint-word
"<" text
dup superclass pprint-word
<block
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
M: singleton-class see-class* ( class -- )
\ SINGLETON: pprint-word pprint-word ;
GENERIC: pprint-slot-name ( object -- )
M: string pprint-slot-name text ;
M: array pprint-slot-name
<flow \ { pprint-word
f <inset unclip text pprint-elements block>
\ } pprint-word block> ;
: unparse-slot ( slot-spec -- array )
[
dup name>> ,
dup class>> object eq? [
dup class>> ,
initial: ,
dup initial>> ,
] unless
dup read-only>> [
read-only ,
] when
drop
] { } make ;
: pprint-slot ( slot-spec -- )
unparse-slot
dup length 1 = [ first ] when
pprint-slot-name ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
<block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ;
M: word see-class* drop ;
M: builtin-class see-class*
drop "! Built-in class" comment. ;
: see-class ( class -- )
dup class? [
[
[ seeing-word ] [ see-class* ] bi
] with-use
] [ drop ] if ;
M: word see*
[ see-class ]
[ [ class? ] [ symbol? not ] bi and [ nl nl ] when ]
[
dup [ class? ] [ symbol? ] bi and
[ drop ] [ call-next-method ] if
] tri ;
: seeing-implementors ( class -- seq )
dup implementors [ method ] with map natural-sort ;
: seeing-methods ( generic -- seq )
"methods" word-prop values natural-sort ;
PRIVATE>
: see-all ( seq -- )
natural-sort [ nl nl ] [ see* ] interleave ;
: methods ( word -- seq )
[
dup class? [ dup seeing-implementors % ] when
dup generic? [ dup seeing-methods % ] when
drop
] { } make prune ;
: see-methods ( word -- )
methods see-all nl ;

1
basis/see/summary.txt Normal file
View File

@ -0,0 +1 @@
Printing loaded definitions as source code

2
basis/stack-checker/backend/backend.factor
View File

@ -155,7 +155,7 @@ M: object apply-object push-literal ;
"cannot-infer" word-prop rethrow ;
: maybe-cannot-infer ( word quot -- )
[ [ "cannot-infer" set-word-prop ] keep throw ] recover ; inline
[ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
: infer-word ( word -- effect )
[

2
basis/tools/crossref/crossref-docs.factor
View File

@ -3,7 +3,7 @@ IN: tools.crossref
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
{ $see-also "definitions" "words" see see-methods } ;
{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"

6
basis/tools/crossref/crossref.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs definitions io io.styles kernel prettyprint
sorting ;
sorting see ;
IN: tools.crossref
: synopsis-alist ( definitions -- alist )
[ dup synopsis swap ] { } map>assoc ;
[ [ synopsis ] keep ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;

7
basis/tools/memory/memory.factor
View File

@ -63,11 +63,12 @@ PRIVATE>
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
] tabular-output
nl
nl nl
"==== CODE HEAP" print
standard-table-style [
(code-room.)
] tabular-output ;
] tabular-output
nl ;
: heap-stats ( -- counts sizes )
[ ] instances H{ } clone H{ } clone
@ -83,4 +84,4 @@ PRIVATE>
pick at pprint-cell
] with-row
] each 2drop
] tabular-output ;
] tabular-output nl ;

4
basis/tools/profiler/profiler.factor
View File

@ -46,9 +46,7 @@ IN: tools.profiler
profiler-usage counters ;
: counters. ( assoc -- )
standard-table-style [
sort-values simple-table.
] tabular-output ;
sort-values simple-table. ;
: profile. ( -- )
"Call counts for all words:" print

2
basis/tools/threads/threads.factor
View File

@ -29,4 +29,4 @@ IN: tools.threads
threads >alist sort-keys values [
[ thread. ] with-row
] each
] tabular-output ;
] tabular-output nl ;

13
basis/tools/vocabs/browser/browser.factor
View File

@ -66,15 +66,18 @@ C: <vocab-author> vocab-author
: describe-children ( vocab -- )
vocab-name all-child-vocabs $vocab-roots ;
: files. ( seq -- )
snippet-style get [
code-style get [
[ nl ] [ [ string>> ] keep write-object ] interleave
] with-nesting
] with-style ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
"Files" $heading
[
snippet-style get [
code-style get [
stack.
] with-nesting
] with-style
files.
] ($block)
] unless-empty ;

55
basis/ui/gadgets/glass/glass-docs.factor Normal file
View File

@ -0,0 +1,55 @@
IN: ui.gadgets.glass
USING: help.markup help.syntax ui.gadgets math.rectangles ;
HELP: show-glass
{ $values { "owner" gadget } { "child" gadget } { "visible-rect" rect } }
{ $description "Displays " { $snippet "child" } " in the glass layer of the window containing " { $snippet "owner" } "."
$nl
"The child's position is calculated with a heuristic:"
{ $list
"The child must fit inside the window"
{ "The child must not obscure " { $snippet "visible-rect" } ", which is a rectangle whose origin is relative to " { $snippet "owner" } }
{ "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
}
"For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
} ;
HELP: hide-glass
{ $values { "child" gadget } }
{ $description "Hides a gadget displayed in a glass layer." } ;
HELP: hide-glass-hook
{ $values { "gadget" gadget } }
{ $description "Called when a gadget displayed in a glass layer is hidden. The gadget can perform cleanup tasks here." } ;
HELP: pass-to-popup
{ $values { "gesture" "a gesture" } { "owner" "the popup's owner" } { "?" "a boolean" } }
{ $description "Resends the gesture to the popup displayed by " { $snippet "owner" } ". The owner must have a " { $slot "popup" } " slot. Outputs " { $link f } " if the gesture was handled, " { $link t } " otherwise." } ;
HELP: show-popup
{ $values { "owner" gadget } { "popup" gadget } { "visible-rect" rect } }
{ $description "Displays " { $snippet "popup" } " in the glass layer of the window containing " { $snippet "owner" } " as a popup."
$nl
"This word differs from " { $link show-glass } " in two respects:"
{ $list
{ "The popup is stored in the owner's " { $slot "popup" } " slot; the owner can call " { $link pass-to-popup } " to pass keyboard gestures to the popup" }
{ "Pressing " { $snippet "ESC" } " with the popup visible will hide it" }
}
} ;
ARTICLE: "ui.gadgets.glass" "Glass layers"
"The " { $vocab-link "ui.gadgets.glass" } " vocabulary implements support for displaying gadgets in the glass layer of a window. The gadget can be positioned arbitrarily within the glass layer, and while it is visible, mouse clicks outside of the glass layer are intercepted to hide the glass layer. Multiple glass layers can be active at a time; they behave as if stacked on top of each other."
$nl
"This feature is used for completion popups and " { $link "ui.gadgets.menus" } " in the " { $link "ui-tools" } "."
$nl
"Displaying a gadget in a glass layer:"
{ $subsection show-glass }
"Hiding a gadget in a glass layer:"
{ $subsection hide-glass }
"Callback generic invoked on the gadget when its glass layer is hidden:"
{ $subsection hide-glass-hook }
"Popup gadgets add support for forwarding keyboard gestures from an owner gadget to the glass layer:"
{ $subsection show-popup }
{ $subsection pass-to-popup } ;
ABOUT: "ui.gadgets.glass"

2
basis/ui/gadgets/glass/glass.factor
View File

@ -71,7 +71,7 @@ popup H{
{ T{ key-down f f "ESC" } [ hide-glass ] }
} set-gestures
: pass-to-popup ( gesture interactor -- ? )
: pass-to-popup ( gesture owner -- ? )
popup>> focusable-child resend-gesture ;
: show-popup ( owner popup visible-rect -- )

2
basis/ui/gadgets/menus/menus-docs.factor
View File

@ -16,7 +16,7 @@ HELP: show-commands-menu
{ $notes "Useful for right-click context menus." } ;
ARTICLE: "ui.gadgets.menus" "Popup menus"
"The " { $vocab-link "ui.gadgets.menus" } " vocabulary implements popup menus."
"The " { $vocab-link "ui.gadgets.menus" } " vocabulary displays popup menus in " { $link "ui.gadgets.glass" } "."
{ $subsection <commands-menu> }
{ $subsection show-menu }
{ $subsection show-commands-menu } ;

4
basis/ui/gadgets/panes/panes-docs.factor
View File

@ -26,10 +26,6 @@ HELP: gadget.
{ $description "Writes a gadget followed by a newline to " { $link output-stream } "." }
{ $notes "Not all streams support this operation." } ;
HELP: ?nl
{ $values { "stream" pane-stream } }
{ $description "Inserts a line break in the pane unless the current line is empty." } ;
HELP: with-pane
{ $values { "pane" pane } { "quot" quotation } }
{ $description "Clears the pane and calls the quotation in a new scope where " { $link output-stream } " is rebound to a " { $link pane-stream } " writing to the pane." } ;

24
basis/ui/gadgets/panes/panes-tests.factor
View File

@ -19,7 +19,7 @@ IN: ui.gadgets.panes.tests
: test-gadget-text ( quot -- ? )
dup make-pane gadget-text dup print "======" print
swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
swap with-string-writer dup print = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
@ -87,6 +87,28 @@ IN: ui.gadgets.panes.tests
] test-gadget-text
] unit-test
[ t ] [
[
last-element off
\ = >link title-style get [
$navigation-table
] with-nesting
"Hello world" print-content
] test-gadget-text
] unit-test
[ t ] [
[ { { "a\n" } } simple-table. ] test-gadget-text
] unit-test
[ t ] [
[ { { "a" } } simple-table. "x" write ] test-gadget-text
] unit-test
[ t ] [
[ H{ } [ { { "a" } } simple-table. ] with-nesting "x" write ] test-gadget-text
] unit-test
ARTICLE: "test-article-1" "This is a test article"
"Hello world, how are you today." ;

135
basis/ui/gadgets/panes/panes.factor
View File

@ -17,6 +17,12 @@ TUPLE: pane < track
output current input last-line prototype scrolls?
selection-color caret mark selecting? ;
TUPLE: pane-stream pane ;
C: <pane-stream> pane-stream
<PRIVATE
: clear-selection ( pane -- pane )
f >>caret f >>mark ; inline
@ -49,12 +55,6 @@ M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f )
selected-children gadget-text ;
: pane-clear ( pane -- )
clear-selection
[ output>> clear-incremental ]
[ current>> clear-gadget ]
bi ;
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
@ -70,17 +70,6 @@ M: pane gadget-selection ( pane -- string/f )
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
: new-pane ( input class -- pane )
[ vertical ] dip new-track
swap >>input
pane-theme
init-prototype
init-output
init-current
init-last-line ; inline
: <pane> ( -- pane ) f pane new-pane ;
GENERIC: draw-selection ( loc obj -- )
: if-fits ( rect quot -- )
@ -112,10 +101,6 @@ M: pane draw-gadget*
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
TUPLE: pane-stream pane ;
C: <pane-stream> pane-stream
: smash-line ( current -- gadget )
dup children>> {
{ [ dup empty? ] [ 2drop "" <label> ] }
@ -123,14 +108,18 @@ C: <pane-stream> pane-stream
[ drop ]
} cond ;
: smash-pane ( pane -- gadget ) output>> smash-line ;
: pane-nl ( pane -- )
[
[ current>> [ unparent ] [ smash-line ] bi ] [ output>> ] bi
add-incremental
] [ next-line ] bi ;
: ?pane-nl ( pane -- )
[ dup current>> children>> empty? [ pane-nl ] [ drop ] if ]
[ pane-nl ] bi ;
: smash-pane ( pane -- gadget ) [ pane-nl ] [ output>> smash-line ] bi ;
: pane-write ( seq pane -- )
[ pane-nl ] [ current>> stream-write ]
bi-curry interleave ;
@ -139,43 +128,6 @@ C: <pane-stream> pane-stream
[ nip pane-nl ] [ current>> stream-format ]
bi-curry bi-curry interleave ;
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- )
pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
: print-gadget ( gadget stream -- )
[ write-gadget ] [ nip stream-nl ] 2bi ;
: gadget. ( gadget -- )
output-stream get print-gadget ;
: ?nl ( stream -- )
dup pane>> current>> children>> empty?
[ dup stream-nl ] unless drop ;
: with-pane ( pane quot -- )
over scroll>top
over pane-clear [ <pane-stream> ] dip
over [ with-output-stream* ] dip ?nl ; inline
: make-pane ( quot -- gadget )
<pane> [ swap with-pane ] keep smash-pane ; inline
TUPLE: pane-control < pane quot ;
M: pane-control model-changed ( model pane-control -- )
[ value>> ] [ dup quot>> ] bi*
'[ _ call( value -- ) ] with-pane ;
: <pane-control> ( model quot -- pane )
f pane-control new-pane
swap >>quot
swap >>model ;
: do-pane-stream ( pane-stream quot -- )
[ pane>> ] dip keep scroll-pane ; inline
@ -198,7 +150,59 @@ M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
swap <style-stream> <ignore-close-stream> ;
PRIVATE>
: new-pane ( input class -- pane )
[ vertical ] dip new-track
swap >>input
pane-theme
init-prototype
init-output
init-current
init-last-line ; inline
: <pane> ( -- pane ) f pane new-pane ;
GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget ( gadget pane-stream -- )
pane>> current>> swap add-gadget drop ;
M: style-stream write-gadget
stream>> write-gadget ;
: print-gadget ( gadget stream -- )
[ write-gadget ] [ nip stream-nl ] 2bi ;
: gadget. ( gadget -- )
output-stream get print-gadget ;
: pane-clear ( pane -- )
clear-selection
[ output>> clear-incremental ]
[ current>> clear-gadget ]
bi ;
: with-pane ( pane quot -- )
[ [ scroll>top ] [ pane-clear ] [ <pane-stream> ] tri ] dip
with-output-stream* ; inline
: make-pane ( quot -- gadget )
[ <pane> ] dip [ with-pane ] [ drop smash-pane ] 2bi ; inline
TUPLE: pane-control < pane quot ;
M: pane-control model-changed ( model pane-control -- )
[ value>> ] [ dup quot>> ] bi*
'[ _ call( value -- ) ] with-pane ;
: <pane-control> ( model quot -- pane )
f pane-control new-pane
swap >>quot
swap >>model ;
! Character styles
<PRIVATE
MEMO: specified-font ( assoc -- font )
#! We memoize here to avoid creating lots of duplicate font objects.
@ -279,10 +283,7 @@ TUPLE: nested-pane-stream < pane-stream style parent ;
inline
: unnest-pane-stream ( stream -- child parent )
dup ?nl
dup style>>
over pane>> smash-pane style-pane
swap parent>> ;
[ [ style>> ] [ pane>> smash-pane ] bi style-pane ] [ parent>> ] bi ;
TUPLE: pane-block-stream < nested-pane-stream ;
@ -309,7 +310,7 @@ M: pane-stream make-block-stream
TUPLE: pane-cell-stream < nested-pane-stream ;
M: pane-cell-stream dispose ?nl ;
M: pane-cell-stream dispose drop ;
M: pane-stream make-cell-stream
pane-cell-stream new-nested-pane-stream ;
@ -318,7 +319,7 @@ M: pane-stream stream-write-table
[
swap [ [ pane>> smash-pane ] map ] map
styled-grid
] dip print-gadget ;
] dip write-gadget ;
! Stream utilities
M: pack dispose drop ;
@ -433,6 +434,8 @@ M: f sloppy-pick-up*
: pane-menu ( pane -- ) { com-copy } show-commands-menu ;
PRIVATE>
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }

2
basis/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -3,7 +3,7 @@ ui.gadgets ui.gadgets.worlds ui ;
IN: ui.gadgets.status-bar
HELP: show-status
{ $values { "string" string } { "gadget" gadget } }
{ $values { "string/f" string } { "gadget" gadget } }
{ $description "Displays a status message in the gadget's world." }
{ $notes "The status message will only be visible if the window was opened with " { $link open-status-window } ", and not " { $link open-window } "." } ;

4
basis/ui/pens/gradient/gradient.factor
View File

@ -41,4 +41,6 @@ M: gradient draw-interior
[ last-vertices>> gl-vertex-pointer ]
[ last-colors>> gl-color-pointer ]
[ colors>> draw-gradient ]
} cleave ;
} cleave ;
M: gradient pen-background 2drop transparent ;

4
basis/ui/pens/solid/solid.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors opengl ui.pens ui.pens.caching ;
USING: kernel accessors opengl math colors ui.pens ui.pens.caching ;
IN: ui.pens.solid
TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
@ -29,4 +29,4 @@ M: solid draw-boundary
(gl-rect) ;
M: solid pen-background
nip color>> ;
nip color>> dup alpha>> 1 number= [ drop transparent ] unless ;

6
basis/ui/tools/inspector/inspector.factor
View File

@ -33,19 +33,19 @@ M: inspector-renderer column-titles
[
[
[ "Class:" write ] with-cell
[ class . ] with-cell
[ class pprint ] with-cell
] with-row
]
[
[
[ "Object:" write ] with-cell
[ short. ] with-cell
[ pprint-short ] with-cell
] with-row
]
[
[
[ "Summary:" write ] with-cell
[ summary. ] with-cell
[ print-summary ] with-cell
] with-row
] tri
] tabular-output

2
basis/ui/tools/listener/listener.factor
View File

@ -175,7 +175,7 @@ TUPLE: listener-gadget < tool input output scroller ;
[ listener-gadget? ] find-parent ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> ] bi <pane-stream> ;
[ input>> ] [ output>> <pane-stream> ] bi ;
: init-listener ( listener -- listener )
<interactor>

2
basis/ui/tools/profiler/profiler.factor
View File

@ -3,7 +3,7 @@
USING: kernel quotations accessors fry assocs present math.order
math.vectors arrays locals models.search models.sort models sequences
vocabs tools.profiler words prettyprint combinators.smart
definitions.icons ui ui.commands ui.gadgets ui.gadgets.panes
definitions.icons see ui ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
ui.gadgets.tables ui.gadgets.search-tables ui.gadgets.labeled
ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels

2
basis/ui/tools/tools-docs.factor
View File

@ -1,7 +1,7 @@
USING: editors help.markup help.syntax summary inspector io io.styles
listener parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.panes ui.gadgets.presentations ui.operations
ui.tools.operations ui.tools.profiler ui.tools.common vocabs ;
ui.tools.operations ui.tools.profiler ui.tools.common vocabs see ;
IN: ui.tools
ARTICLE: "starting-ui-tools" "Starting the UI tools"

1
basis/ui/ui-docs.factor
View File

@ -171,6 +171,7 @@ ARTICLE: "ui-layouts" "Gadget hierarchy and layouts"
{ $subsection "ui-frame-layout" }
{ $subsection "ui-book-layout" }
"Advanced topics:"
{ $subsection "ui.gadgets.glass" }
{ $subsection "ui-null-layout" }
{ $subsection "ui-incremental-layout" }
{ $subsection "ui-layout-impl" }

2
basis/validators/validators.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations sequences math namespaces make sets
math.parser math.ranges assocs regexp regexp.matchers unicode.categories arrays
math.parser math.ranges assocs regexp unicode.categories arrays
hashtables words classes quotations xmode.catalog unicode.case ;
IN: validators

8
basis/xmode/marker/marker.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: xmode.marker
USING: kernel namespaces make xmode.rules xmode.tokens
xmode.marker.state xmode.marker.context xmode.utilities
xmode.catalog sequences math assocs combinators strings
regexp splitting ascii unicode.case regexp.matchers
ascii combinators.short-circuit accessors ;
regexp splitting unicode.case ascii
combinators.short-circuit accessors ;
IN: xmode.marker
! Next two words copied from parser-combinators
! Just like head?, but they optionally ignore case
@ -84,7 +84,7 @@ M: string-matcher text-matches?
] keep string>> length and ;
M: regexp text-matches?
[ >string ] dip match-head ;
[ >string ] dip re-contains? ;
: rule-start-matches? ( rule -- match-count/f )
dup start>> tuck swap can-match-here? [

4
core/definitions/definitions-docs.factor
View File

@ -56,12 +56,12 @@ $nl
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, and help articles. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary. Implementations of the definition protocol include pathnames, words, methods, and help articles."
"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
{ $subsection "definition-protocol" }
{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
{ $see-also "parser" "source-files" "words" "generic" "help-impl" } ;
{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions"

2
core/generic/generic-docs.factor
View File

@ -47,7 +47,7 @@ $nl
{ $subsection <method> }
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
{ $subsection method-spec }
{ $see-also see see-methods } ;
{ $see-also "see" } ;
ARTICLE: "method-combination" "Custom method combination"
"Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"

1
core/parser/parser.factor
View File

@ -176,6 +176,7 @@ SYMBOL: interactive-vocabs
"memory"
"namespaces"
"prettyprint"
"see"
"sequences"
"slicing"
"sorting"

16
core/sequences/sequences.factor
View File

@ -213,12 +213,16 @@ TUPLE: slice
: collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
ERROR: slice-error from to seq reason ;
TUPLE: slice-error from to seq reason ;
: slice-error ( from to seq ? string -- from to seq )
[ \ slice-error boa throw ] curry when ; inline
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
dup length pick < [ "end > sequence" slice-error ] when
2over > [ "start > end" slice-error ] when ; inline
3dup
[ 2drop 0 < "start < 0" slice-error ]
[ nip length > "end > sequence" slice-error ]
[ drop > "start > end" slice-error ] 3tri ; inline
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
@ -326,8 +330,8 @@ PRIVATE>
[ (append) ] new-like ; inline
: 3append-as ( seq1 seq2 seq3 exemplar -- newseq )
[ pick length pick length pick length + + ] dip [
[ [ pick length pick length + ] dip copy ]
[ 3dup [ length ] tri@ + + ] dip [
[ [ 2over [ length ] bi@ + ] dip copy ]
[ (append) ] bi
] new-like ; inline

2
core/words/words-docs.factor
View File

@ -161,7 +161,7 @@ $nl
{ $subsection "word-definition" }
{ $subsection "word-props" }
{ $subsection "word.private" }
{ $see-also "vocabularies" "vocabs.loader" "definitions" } ;
{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ;
ABOUT: "words"

2
extra/benchmark/regex-dna/regex-dna.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors regexp.matchers prettyprint io io.encodings.ascii
USING: accessors prettyprint io io.encodings.ascii
io.files kernel sequences assocs namespaces regexp ;
IN: benchmark.regex-dna

27
extra/cap/cap.factor
View File

@ -1,30 +1,31 @@
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
opengl.gl sequences math.vectors ui images.bitmap images.viewer
opengl.gl sequences math.vectors ui images images.viewer
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )
dim>> [ first 3 * 4 align ] [ second ] bi * <byte-array> ;
dim>> [ first 4 * ] [ second ] bi * <byte-array> ;
: gl-screenshot ( gadget -- byte-array )
[
GL_BACK glReadBuffer
GL_PACK_ALIGNMENT 4 glPixelStorei
0 0
] dip
[ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
[
GL_BACK glReadBuffer
GL_PACK_ALIGNMENT 4 glPixelStorei
0 0
] dip
dim>> first2 GL_RGBA GL_UNSIGNED_BYTE
]
[ screenshot-array ] bi
[ glReadPixels ] keep ;
: screenshot ( window -- bitmap )
[ gl-screenshot ]
[ dim>> first2 ] bi
bgr>bitmap ;
: save-screenshot ( window path -- )
[ screenshot ] dip save-bitmap ;
[ <image> ] dip
[ gl-screenshot >>bitmap ] [ dim>> >>dim ] bi
RGBA >>component-order
t >>upside-down?
normalize-image ;
: screenshot. ( window -- )
[ screenshot <image-gadget> ] [ title>> ] bi open-window ;

4
extra/dns/cache/rr/rr.factor vendored
View File

@ -1,7 +1,7 @@
USING: kernel sequences assocs sets locals combinators
accessors system math math.functions unicode.case prettyprint
combinators.cleave dns ;
combinators.smart dns ;
IN: dns.cache.rr
@ -16,7 +16,7 @@ TUPLE: <entry> time data ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: make-cache-key ( obj -- key )
{ [ name>> >lower ] [ type>> unparse ] [ class>> unparse ] } 1arr " " join ;
[ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

29
extra/dns/dns.factor
View File

@ -5,7 +5,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting
destructors
io io.binary io.sockets io.encodings.binary
accessors
combinators.cleave
combinators.smart
newfx
;
@ -145,12 +145,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: query->ba ( query -- ba )
[
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
[ class>> class-table of uint16->ba ]
}
<arr> concat ;
} cleave
] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -169,6 +170,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: soa->ba ( rdata -- ba )
[
{
[ mname>> dn->ba ]
[ rname>> dn->ba ]
@ -177,8 +179,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ retry>> uint32->ba ]
[ expire>> uint32->ba ]
[ minimum>> uint32->ba ]
}
<arr> concat ;
} cleave
] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -198,6 +200,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: rr->ba ( rr -- ba )
[
{
[ name>> dn->ba ]
[ type>> type-table of uint16->ba ]
@ -207,12 +210,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ type>> ] [ rdata>> ] bi rdata->ba
[ length uint16->ba ] [ ] bi append
]
}
<arr> concat ;
} cleave
] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: header-bits-ba ( message -- ba )
[
{
[ qr>> 15 shift ]
[ opcode>> opcode-table of 11 shift ]
@ -222,10 +226,11 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ ra>> 7 shift ]
[ z>> 4 shift ]
[ rcode>> rcode-table of 0 shift ]
}
<arr> sum uint16->ba ;
} cleave
] sum-outputs uint16->ba ;
: message->ba ( message -- ba )
[
{
[ id>> uint16->ba ]
[ header-bits-ba ]
@ -237,8 +242,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ answer-section>> [ rr->ba ] map concat ]
[ authority-section>> [ rr->ba ] map concat ]
[ additional-section>> [ rr->ba ] map concat ]
}
<arr> concat ;
} cleave
] output>array concat ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -475,7 +480,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ask ( message -- message ) dns-server ask-server ;
: query->message ( query -- message ) <message> swap {1} >>question-section ;
: query->message ( query -- message ) <message> swap 1array >>question-section ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

12
extra/dns/server/server.factor
View File

@ -1,8 +1,8 @@
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
combinators.cleave combinators.short-circuit
newfx fry
combinators.short-circuit combinators.smart
newfx fry arrays
dns dns.util dns.misc ;
IN: dns.server
@ -16,7 +16,7 @@ SYMBOL: records-var
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: {name-type-class} ( obj -- array )
{ [ name>> >lower ] [ type>> ] [ class>> ] } <arr> ;
[ [ name>> >lower ] [ type>> ] [ class>> ] tri ] output>array ;
: rr=query? ( obj obj -- ? ) [ {name-type-class} ] bi@ = ;
@ -52,9 +52,9 @@ SYMBOL: records-var
: rr->rdata-names ( rr -- names/f )
{
{ [ dup type>> NS = ] [ rdata>> {1} ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> {1} ] }
{ [ dup type>> CNAME = ] [ rdata>> {1} ] }
{ [ dup type>> NS = ] [ rdata>> 1array ] }
{ [ dup type>> MX = ] [ rdata>> exchange>> 1array ] }
{ [ dup type>> CNAME = ] [ rdata>> 1array ] }
{ [ t ] [ drop f ] }
}
cond ;

2
extra/fuel/help/help.factor
View File

@ -4,7 +4,7 @@
USING: accessors arrays assocs combinators help help.crossref
help.markup help.topics io io.streams.string kernel make namespaces
parser prettyprint sequences summary tools.vocabs tools.vocabs.browser
vocabs vocabs.loader words ;
vocabs vocabs.loader words see ;
IN: fuel.help

8
extra/images/viewer/viewer.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel
namespaces opengl opengl.gl sequences strings ui ui.gadgets
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: images.viewer
@ -12,8 +12,8 @@ M: image-gadget pref-dim*
: draw-image ( image -- )
0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
[ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
[ bitmap>> ] bi glDrawPixels ;
[ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
glDrawPixels ;
M: image-gadget draw-gadget* ( gadget -- )
image>> draw-image ;

2
extra/multi-methods/multi-methods.factor
View File

@ -5,7 +5,7 @@ combinators arrays words assocs parser namespaces make
definitions prettyprint prettyprint.backend prettyprint.custom
quotations generalizations debugger io compiler.units
kernel.private effects accessors hashtables sorting shuffle
math.order sets ;
math.order sets see ;
IN: multi-methods
! PART I: Converting hook specializers

BIN
extra/otug-talk/2bi.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 6.6 KiB

BIN
extra/otug-talk/2bi.tiff Normal file
View File

Binary file not shown.

BIN
extra/otug-talk/2bi_at.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 7.5 KiB

BIN
extra/otug-talk/2bi_at.tiff Normal file
View File

Binary file not shown.

BIN
extra/otug-talk/2bi_star.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 6.3 KiB

BIN
extra/otug-talk/2bi_star.tiff Normal file
View File

Binary file not shown.

BIN
extra/otug-talk/bi.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.7 KiB

BIN
extra/otug-talk/bi.tiff Normal file
View File

Binary file not shown.

BIN
extra/otug-talk/bi_at.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.6 KiB

BIN
extra/otug-talk/bi_at.tiff Normal file
View File

Binary file not shown.

BIN
extra/otug-talk/bi_star.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 4.3 KiB

BIN
extra/otug-talk/bi_star.tiff Normal file
View File

Binary file not shown.

53
extra/otug-talk/otug-talk.factor
View File

@ -1,41 +1,14 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slides help.markup math arrays hashtables namespaces
sequences kernel sequences parser memoize io.encodings.binary
locals kernel.private tools.vocabs.browser assocs quotations
tools.vocabs tools.annotations tools.crossref
help.topics math.functions compiler.tree.optimizer
compiler.cfg.optimizer fry
ui.gadgets.panes tetris tetris.game combinators generalizations
multiline sequences.private ;
USING: slides help.markup math arrays hashtables namespaces sequences
kernel sequences parser memoize io.encodings.binary locals
kernel.private tools.vocabs.browser assocs quotations tools.vocabs
tools.annotations tools.crossref help.topics math.functions
compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
tetris tetris.game combinators generalizations multiline
sequences.private ;
IN: otug-talk
USING: cairo cairo.ffi cairo.gadgets accessors
io.backend ui.gadgets ;
TUPLE: png-gadget < cairo-gadget surface ;
: <png-gadget> ( file -- gadget )
png-gadget new-gadget
swap normalize-path
cairo_image_surface_create_from_png >>surface ; inline
M: png-gadget pref-dim* ( gadget -- )
surface>>
[ cairo_image_surface_get_width ]
[ cairo_image_surface_get_height ]
bi 2array ;
M: png-gadget render-cairo* ( gadget -- )
cr swap surface>> 0 0 cairo_set_source_surface
cr cairo_paint ;
M: png-gadget ungraft* ( gadget -- )
surface>> cairo_surface_destroy ;
: $bitmap ( element -- )
[ first <png-gadget> gadget. ] ($block) ;
: $tetris ( element -- )
drop [ <default-tetris> <tetris-gadget> gadget. ] ($block) ;
@ -105,11 +78,11 @@ CONSTANT: otug-slides
}
{ $slide "Data flow combinators - cleave family"
{ { $link bi } ", " { $link tri } ", " { $link cleave } }
{ $bitmap "resource:extra/otug-talk/bi.png" }
{ $image "resource:extra/otug-talk/bi.tiff" }
}
{ $slide "Data flow combinators - cleave family"
{ { $link 2bi } ", " { $link 2tri } ", " { $link 2cleave } }
{ $bitmap "resource:extra/otug-talk/2bi.png" }
{ $image "resource:extra/otug-talk/2bi.tiff" }
}
{ $slide "Data flow combinators"
"First, let's define a data type:"
@ -128,19 +101,19 @@ CONSTANT: otug-slides
}
{ $slide "Data flow combinators - spread family"
{ { $link bi* } ", " { $link tri* } ", " { $link spread } }
{ $bitmap "resource:extra/otug-talk/bi_star.png" }
{ $image "resource:extra/otug-talk/bi_star.tiff" }
}
{ $slide "Data flow combinators - spread family"
{ { $link 2bi* } }
{ $bitmap "resource:extra/otug-talk/2bi_star.png" }
{ $image "resource:extra/otug-talk/2bi_star.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link bi@ } ", " { $link tri@ } ", " { $link napply } }
{ $bitmap "resource:extra/otug-talk/bi_at.png" }
{ $image "resource:extra/otug-talk/bi_at.tiff" }
}
{ $slide "Data flow combinators - apply family"
{ { $link 2bi@ } }
{ $bitmap "resource:extra/otug-talk/2bi_at.png" }
{ $image "resource:extra/otug-talk/2bi_at.tiff" }
}
{ $slide "Shuffle words"
"When data flow combinators are not enough"

3
extra/slides/slides.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient
parser accessors colors ;
IN: slides
@ -98,6 +98,7 @@ TUPLE: slides < book ;
parse-definition strip-tease [ parsed ] each ; parsing
\ slides H{
{ T{ button-down } [ request-focus ] }
{ T{ key-down f f "DOWN" } [ next-page ] }
{ T{ key-down f f "UP" } [ prev-page ] }
} set-gestures

7
extra/tetris/gl/gl.factor
View File

@ -35,7 +35,7 @@ IN: tetris.gl
: scale-board ( width height board -- )
[ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
: (draw-tetris) ( width height tetris -- )
: draw-tetris ( width height tetris -- )
#! width and height are in pixels
GL_MODELVIEW [
{
@ -44,7 +44,4 @@ IN: tetris.gl
[ next-piece draw-next-piece ]
[ current-piece draw-piece ]
} cleave
] do-matrix ;
: draw-tetris ( width height tetris -- )
origin get [ (draw-tetris) ] with-translation ;
] do-matrix ;

4
extra/update/util/util.factor
View File

@ -1,6 +1,6 @@
USING: kernel classes strings quotations words math math.parser arrays
combinators.cleave
combinators.smart
accessors
system prettyprint splitting
sequences combinators sequences.deep
@ -58,5 +58,5 @@ DEFER: to-strings
: datestamp ( -- string )
now
{ year>> month>> day>> hour>> minute>> } <arr>
[ { [ year>> ] [ month>> ] [ day>> ] [ hour>> ] [ minute>> ] } cleave ] output>array
[ pad-00 ] map "-" join ;

0
extra/combinators/cleave/authors.txt → unmaintained/combinators/cleave/authors.txt
View File

0
extra/combinators/cleave/cleave-tests.factor → unmaintained/combinators/cleave/cleave-tests.factor
View File

0
extra/combinators/cleave/cleave.factor → unmaintained/combinators/cleave/cleave.factor
View File

0
extra/combinators/cleave/enhanced/enhanced.factor → unmaintained/combinators/cleave/enhanced/enhanced.factor
View File

0
extra/combinators/conditional/conditional.factor → unmaintained/combinators/conditional/conditional.factor
View File

0
extra/multi-method-syntax/multi-method-syntax.factor → unmaintained/multi-method-syntax/multi-method-syntax.factor
View File

0
extra/math/physics/pos/pos.factor → unmaintained/physics/pos/pos.factor
View File

0
extra/math/physics/vel/vel.factor → unmaintained/physics/vel/vel.factor
View File