diff --git a/README.txt b/README.txt index dfe70c00f4..bd9da0ab2b 100755 --- a/README.txt +++ b/README.txt @@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and gcc. Factor supports various platforms. For an up-to-date list, see -. +. Factor requires gcc 3.4 or later. @@ -36,17 +36,6 @@ arguments for make. Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM. -Compilation will yield an executable named 'factor' on Unix, -'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE. - -* Libraries needed for compilation - -For X11 support, you need recent development libraries for libc, -Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution -(like Ubuntu), you can use the following line to grab everything: - - sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev - * Bootstrapping the Factor image Once you have compiled the Factor runtime, you must bootstrap the Factor @@ -69,6 +58,12 @@ machines. On Unix, Factor can either run a graphical user interface using X11, or a terminal listener. +For X11 support, you need recent development libraries for libc, +Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution +(like Ubuntu), you can use the following line to grab everything: + + sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev + If your DISPLAY environment variable is set, the UI will start automatically: @@ -78,14 +73,6 @@ To run an interactive terminal listener: ./factor -run=listener -If you're inside a terminal session, you can start the UI with one of -the following two commands: - - ui - [ ui ] in-thread - -The latter keeps the terminal listener running. - * Running Factor on Mac OS X - Cocoa UI On Mac OS X, a Cocoa UI is available in addition to the terminal @@ -110,7 +97,7 @@ When compiling Factor, pass the X11=1 parameter: Then bootstrap with the following switches: - ./factor -i=boot..image -ui-backend=x11 + ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango Now if $DISPLAY is set, running ./factor will start the UI. @@ -126,6 +113,12 @@ the command prompt using the console application: factor.com -i=boot..image +Before bootstrapping, you will need to download the DLLs for the Pango +text rendering library. The required DLLs are listed in +build-support/dlls.txt and are available from the following location: + + + Once bootstrapped, double-clicking factor.exe or factor.com starts the Factor UI. @@ -135,7 +128,9 @@ To run the listener in the command prompt: * The Factor FAQ -The Factor FAQ is available at . +The Factor FAQ is available at the following location: + + * Command line usage diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index dc29ea9bb3..46afc05e2d 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -217,6 +217,8 @@ $nl "Utilities for automatically freeing memory in conjunction with " { $link with-destructors } ":" { $subsection &free } { $subsection |free } +"The " { $link &free } " and " { $link |free } " words are generated using " { $link "alien.destructors" } "." +$nl "You can unsafely copy a range of bytes from one memory location to another:" { $subsection memcpy } "You can copy a range of bytes from memory into a byte array:" @@ -243,4 +245,6 @@ $nl "New C types can be defined:" { $subsection "c-structs" } { $subsection "c-unions" } +"A utility for defining " { $link "destructors" } " for deallocating memory:" +{ $subsection "alien.destructors" } { $see-also "aliens" } ; diff --git a/basis/alien/destructors/destructors-docs.factor b/basis/alien/destructors/destructors-docs.factor new file mode 100644 index 0000000000..bc08dc7486 --- /dev/null +++ b/basis/alien/destructors/destructors-docs.factor @@ -0,0 +1,30 @@ +IN: alien.destructors +USING: help.markup help.syntax alien destructors ; + +HELP: DESTRUCTOR: +{ $syntax "DESTRUCTOR: word" } +{ $description "Defines four things:" + { $list + { "a tuple named " { $snippet "word" } " with a single slot holding a " { $link c-ptr } } + { "a " { $link dispose } " method on the tuple which calls " { $snippet "word" } " with the " { $link c-ptr } } + { "a pair of words, " { $snippet "&word" } " and " { $snippet "|word" } ", which call " { $link &dispose } " and " { $link |dispose } " with a new instance of the tuple" } + } + "The " { $snippet "word" } " must be defined in the current vocabulary, and must have stack effect " { $snippet "( c-ptr -- )" } "." +} +{ $examples + "Suppose you are writing a binding to the GLib library, which as a " { $snippet "g_object_unref" } " function. Then you can define the function and destructor like so," + { $code + "FUNCTION: void g_object_unref ( gpointer object ) ;" + "DESTRUCTOR: g_object_unref" + } + "Now, memory management becomes easier:" + { $code + "[ g_new_foo &g_object_unref ... ] with-destructors" + } +} ; + +ARTICLE: "alien.destructors" "Alien destructors" +"The " { $vocab-link "alien.destructors" } " vocabulary defines a utility parsing word for defining new disposable classes." +{ $subsection POSTPONE: DESTRUCTOR: } ; + +ABOUT: "alien.destructors" \ No newline at end of file diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor index 193e847d27..bd1b86b279 100644 --- a/basis/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -10,7 +10,7 @@ IN: ascii : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline +: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline : quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline : Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline : alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline @@ -20,4 +20,4 @@ IN: ascii : >upper ( str -- upper ) [ ch>upper ] map ; HINTS: >lower string ; -HINTS: >upper string ; \ No newline at end of file +HINTS: >upper string ; diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index f29e05c023..aba3cfbfe5 100644 --- a/basis/binary-search/binary-search.factor +++ b/basis/binary-search/binary-search.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private accessors math math.order combinators hints arrays ; @@ -16,14 +16,19 @@ IN: binary-search [ [ from>> ] [ midpoint@ ] bi + ] [ seq>> ] bi [ drop ] [ dup ] [ ] tri* nth ; inline +DEFER: (search) + +: keep-searching ( seq quot -- slice ) + [ dup midpoint@ ] dip call collapse-slice slice boa (search) ; inline + : (search) ( quot: ( elt -- <=> ) seq -- i elt ) dup length 1 <= [ finish ] [ decide { { +eq+ [ finish ] } - { +lt+ [ dup midpoint@ head-slice (search) ] } - { +gt+ [ dup midpoint@ tail-slice (search) ] } + { +lt+ [ [ (head) ] keep-searching ] } + { +gt+ [ [ (tail) ] keep-searching ] } } case ] if ; inline recursive diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 002478fb82..4e45c3cf8f 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -14,12 +14,20 @@ IN: call.tests [ 1 2 \ + execute( x y -- z a ) ] must-fail [ \ + execute( x y -- z ) ] must-infer +: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; + +[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test +[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test + +: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; + +[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test +[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test +[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test +[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test +[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test + [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test [ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test [ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test [ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test - -: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ; - -[ t ] [ \ compile-execute(-test optimized>> ] unit-test -[ 4 ] [ 1 3 compile-execute(-test ] unit-test \ No newline at end of file diff --git a/basis/call/call.factor b/basis/call/call.factor index 0ccc774ce0..0c1b5bbfbf 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2009 Daniel Ehrenberg. +! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel macros fry summary sequences generalizations accessors -continuations effects effects.parser parser words ; +USING: kernel macros fry summary sequences sequences.private +generalizations accessors continuations effects effects.parser +parser words ; IN: call ERROR: wrong-values values quot length-required ; @@ -14,17 +15,9 @@ M: wrong-values summary : firstn-safe ( array quot n -- ... ) 3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline -: execute-effect-unsafe ( word effect -- ) - drop execute ; - -: execute-effect-unsafe? ( word effect -- ? ) - swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline - : parse-call( ( accum word -- accum ) [ ")" parse-effect parsed ] dip parsed ; -: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing - PRIVATE> MACRO: call-effect ( effect -- quot ) @@ -33,10 +26,35 @@ MACRO: call-effect ( effect -- quot ) : call( \ call-effect parse-call( ; parsing -: execute-effect ( word effect -- ) - 2dup execute-effect-unsafe? - [ execute-effect-unsafe ] - [ [ [ execute ] curry ] dip call-effect ] - if ; inline +> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline + +: cache-miss ( word effect ic -- ) + [ 2dup execute-effect-unsafe? ] dip + '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ] + [ execute-effect-slow ] if ; inline + +: execute-effect-ic ( word effect ic -- ) + #! ic is a mutable cell { effect } + 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline + +PRIVATE> + +MACRO: execute-effect ( effect -- ) + { f } clone '[ _ _ execute-effect-ic ] ; : execute( \ execute-effect parse-call( ; parsing diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor index beb766561f..4f74cd850a 100644 --- a/basis/cocoa/plists/plists-tests.factor +++ b/basis/cocoa/plists/plists-tests.factor @@ -7,4 +7,34 @@ assocs cocoa.enumeration ; [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test [ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test + [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test + + [ t ] [ + { + H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } } + H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } } + H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } } + } [ >cf &CFRelease ] [ >cf &CFRelease ] bi + [ plist> ] bi@ = + ] unit-test + + [ t ] [ + { "DeviceUsagePage" 1 } + [ >cf &CFRelease ] [ >cf &CFRelease ] bi + [ plist> ] bi@ = + ] unit-test + + [ V{ "DeviceUsagePage" "Yes" } ] [ + { "DeviceUsagePage" "Yes" } + >cf &CFRelease plist> + ] unit-test + + [ V{ 2.0 1.0 } ] [ + { 2.0 1.0 } + >cf &CFRelease plist> + ] unit-test + + [ 3.5 ] [ + 3.5 >cf &CFRelease plist> + ] unit-test ] with-destructors \ No newline at end of file diff --git a/basis/colors/constants/constants-docs.factor b/basis/colors/constants/constants-docs.factor index 633bd20ed2..49d6fce3a1 100644 --- a/basis/colors/constants/constants-docs.factor +++ b/basis/colors/constants/constants-docs.factor @@ -2,7 +2,7 @@ IN: colors.constants USING: help.markup help.syntax strings colors ; HELP: named-color -{ $values { "string" string } { "color" color } } +{ $values { "name" string } { "color" color } } { $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." } { $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." } { $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ; diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 0e5610a144..91621c110b 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -27,7 +27,7 @@ PRIVATE> ERROR: no-such-color name ; -: named-color ( name -- rgb ) +: named-color ( name -- color ) dup rgb.txt at [ ] [ no-such-color ] ?if ; : COLOR: scan named-color parsed ; parsing \ No newline at end of file diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d6da95408d..24ce3debeb 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry -continuations vocabs assocs dlists definitions math graphs -generic combinators deques search-deques io stack-checker -stack-checker.state stack-checker.inlining -combinators.short-circuit compiler.errors compiler.units -compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer +continuations vocabs assocs dlists definitions math graphs generic +combinators deques search-deques macros io stack-checker +stack-checker.state stack-checker.inlining combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame -compiler.codegen compiler.utilities ; +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ; H{ } clone generic-dependencies set f swap compiler-error ; +: ignore-error? ( word error -- ? ) + [ [ inline? ] [ macro? ] bi or ] + [ compiler-error-type +warning+ eq? ] bi* and ; + : fail ( word error -- * ) - [ swap compiler-error ] + [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ] [ drop [ compiled-unxref ] diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a2e8671fb..e451694f48 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index ecd5429baf..0e72deb6fa 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -46,9 +46,6 @@ M: predicate finalize-word [ drop ] } cond ; -! M: math-partial finalize-word -! dup primitive? [ drop ] [ nip cached-expansion ] if ; - M: word finalize-word drop ; M: #call finalize* diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 7b1723620b..c56db570b2 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -238,7 +238,7 @@ DEFER: (value-info-union) : value-infos-union ( infos -- info ) [ null-info ] - [ dup first [ value-info-union ] reduce ] if-empty ; + [ unclip-slice [ value-info-union ] reduce ] if-empty ; : literals<= ( info1 info2 -- ? ) { diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 52ae83eb12..5dd647ae89 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -655,3 +655,36 @@ MIXIN: empty-mixin ! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test ! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test + +! generalize-counter-interval wasn't being called in all the right places. +! bug found by littledan + +TUPLE: littledan-1 { a read-only } ; + +: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive + +: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline + +[ ] [ [ littledan-1-test ] final-classes drop ] unit-test + +TUPLE: littledan-2 { from read-only } { to read-only } ; + +: (littledan-2-test) ( x -- i elt ) + [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive + +: littledan-2-test ( x -- i elt ) + [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline + +[ ] [ [ littledan-2-test ] final-classes drop ] unit-test + +: (littledan-3-test) ( x -- ) + length 1+ f (littledan-3-test) ; inline recursive + +: littledan-3-test ( x -- ) + 0 f (littledan-3-test) ; inline + +[ ] [ [ littledan-3-test ] final-classes drop ] unit-test + +[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test + +[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index ff9f262d28..1bcd36f6b0 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive } cond interval-union nip ; : generalize-counter ( info' initial -- info ) - 2dup [ class>> null-class? ] either? [ drop ] [ - [ drop clone ] [ [ interval>> ] bi@ ] 2bi - generalize-counter-interval >>interval + 2dup [ not ] either? [ drop ] [ + 2dup [ class>> null-class? ] either? [ drop ] [ + [ clone ] dip + [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ] + [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] + [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] + tri + ] if ] if ; : unify-recursive-stacks ( stacks initial -- infos ) diff --git a/basis/core-foundation/arrays/arrays.factor b/basis/core-foundation/arrays/arrays.factor index 3708059f2b..1205352fcb 100644 --- a/basis/core-foundation/arrays/arrays.factor +++ b/basis/core-foundation/arrays/arrays.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences ; +USING: alien.syntax kernel sequences fry ; IN: core-foundation.arrays TYPEDEF: void* CFArrayRef @@ -17,6 +17,5 @@ FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ; dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ; : ( seq -- alien ) - [ f swap length f CFArrayCreateMutable ] keep - [ length ] keep - [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ; + f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable + [ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ; diff --git a/basis/core-foundation/attributed-strings/tags.txt b/basis/core-foundation/attributed-strings/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-foundation/attributed-strings/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/core-text/fonts/tags.txt b/basis/core-text/fonts/tags.txt new file mode 100644 index 0000000000..2320bdd648 --- /dev/null +++ b/basis/core-text/fonts/tags.txt @@ -0,0 +1,2 @@ +unportable +bindings diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 45bc5bf50a..627fd95384 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -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" ; diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor index 9456941880..42b727852e 100644 --- a/basis/delegate/delegate-docs.factor +++ b/basis/delegate/delegate-docs.factor @@ -13,8 +13,8 @@ HELP: PROTOCOL: { define-protocol POSTPONE: PROTOCOL: } related-words HELP: define-consult -{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } } -{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." } +{ $values { "consultation" consultation } } +{ $description "Defines a class to consult, using the quotation, on the generic words contained in the group." } { $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ; HELP: CONSULT: diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index e2bea82e68..9bf07a5330 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -1,7 +1,7 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string accessors eval multiline generic.standard delegate.protocols -delegate.private assocs ; +delegate.private assocs see ; IN: delegate.tests TUPLE: hello this that ; diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 60a9f785e6..246da48b32 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -99,6 +99,7 @@ link-no-follow? off [ "

\"teh

" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test [ "

http://lol.com

" ] [ "[[http://lol.com]]" convert-farkup ] unit-test [ "

haha

" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test +[ "

haha

" ] [ "[[http://lol.com/search?q=sex|haha]]" convert-farkup ] unit-test [ "

Bar

" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test "/wiki/view/" relative-link-prefix [ diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index 50ee938659..4041d92773 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -165,12 +165,12 @@ CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');" { [ dup [ 127 > ] any? ] [ drop invalid-url ] } { [ dup first "/\\" member? ] [ drop invalid-url ] } { [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] } - [ relative-link-prefix get prepend "" like ] - } cond url-encode ; + [ relative-link-prefix get prepend "" like url-encode ] + } cond ; : write-link ( href text -- xml ) - [ check-url link-no-follow? get "true" and ] dip - [XML nofollow=<->><-> XML] ; + [ check-url link-no-follow? get "nofollow" and ] dip + [XML rel=<->><-> XML] ; : write-image-link ( href text -- xml ) disable-images? get [ diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor index 446f1ee0a9..45eb27ea62 100644 --- a/basis/globs/globs-tests.factor +++ b/basis/globs/globs-tests.factor @@ -14,5 +14,6 @@ USING: tools.test globs ; [ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test [ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test [ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test -[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test +[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test +[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test [ t ] [ "foo.{" "*.{" glob-matches? ] unit-test diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor index 14ddb0ed9b..cac7fd9a2f 100644 --- a/basis/globs/globs.factor +++ b/basis/globs/globs.factor @@ -1,42 +1,42 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: parser-combinators parser-combinators.regexp lists sequences kernel -promises strings unicode.case ; +USING: sequences kernel regexp.combinators strings unicode.case +peg.ebnf regexp arrays ; IN: globs - -: 'char' ( -- parser ) - [ ",*?" member? not ] satisfy ; +Character = "\\" .:c => [[ c 1string ]] + | !(","|"}") . => [[ 1string ]] -: 'string' ( -- parser ) - 'char' <+> [ >lower token ] <@ ; +RangeCharacter = !("]") . -: 'escaped-char' ( -- parser ) - "\\" token any-char-parser &> [ 1token ] <@ ; +Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b ]] + | RangeCharacter => [[ 1string ]] -: 'escaped-string' ( -- parser ) - 'string' 'escaped-char' <|> ; +StartRange = .:a "-" RangeCharacter:b => [[ a b ]] + | . => [[ 1string ]] -DEFER: 'term' +Ranges = StartRange:s Range*:r => [[ r s prefix ]] -: 'glob' ( -- parser ) - 'term' <*> [ ] <@ ; +CharClass = "^"?:n Ranges:e => [[ e n [ ] when ]] -: 'union' ( -- parser ) - 'glob' "," token nonempty-list-of "{" "}" surrounded-by - [ ] <@ ; +AlternationBody = Concatenation:c "," AlternationBody:a => [[ a c prefix ]] + | Concatenation => [[ 1array ]] -LAZY: 'term' ( -- parser ) - 'union' - 'character-class' <|> - "?" token [ drop any-char-parser ] <@ <|> - "*" token [ drop any-char-parser <*> ] <@ <|> - 'escaped-string' <|> ; +Element = "*" => [[ R/ .*/ ]] + | "?" => [[ R/ ./ ]] + | "[" CharClass:c "]" => [[ c ]] + | "{" AlternationBody:b "}" => [[ b ]] + | Character -PRIVATE> +Concatenation = Element* => [[ ]] -: ( string -- glob ) 'glob' just parse-1 just ; +End = !(.) + +Main = Concatenation End + +;EBNF : glob-matches? ( input glob -- ? ) - [ >lower ] [ ] bi* parse nil? not ; + [ >case-fold ] bi@ matches? ; diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index b2b65c3913..d6693cd94f 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -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" diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index d95f6988a2..5d83afae88 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -1,6 +1,6 @@ USING: math definitions help.topics help tools.test prettyprint parser io.streams.string kernel source-files -assocs namespaces words io sequences eval accessors ; +assocs namespaces words io sequences eval accessors see ; IN: help.definitions.tests [ ] [ \ + >link see ] unit-test diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor index 3e4066d8b7..91ee1c9c79 100644 --- a/basis/help/definitions/definitions.factor +++ b/basis/help/definitions/definitions.factor @@ -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 diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 331fafbbd1..f20732c7ee 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -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" } diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 8384799dbd..733199fc60 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -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" diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 57f64459c8..2281c295c3 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -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 ; diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index d4f664d6ff..ea64def751 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -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 " diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor index 410c3ce223..0b85455c2e 100644 --- a/basis/html/components/components-tests.factor +++ b/basis/html/components/components-tests.factor @@ -4,6 +4,8 @@ io.streams.null accessors inspector html.streams html.components html.forms namespaces xml.writer ; +\ render must-infer + [ ] [ begin-form ] unit-test [ ] [ 3 "hi" set-value ] unit-test diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 229d05615e..0d4282b1d7 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -9,14 +9,10 @@ IN: http.tests [ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test +[ "text/html" utf8 ] [ "text/html; charset=\"utf-8\"" parse-content-type ] unit-test + [ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test -[ { } ] [ "" parse-cookie ] unit-test -[ { } ] [ "" parse-set-cookie ] unit-test - -! Make sure that totally invalid cookies don't confuse us -[ { } ] [ "hello world; how are you" parse-cookie ] unit-test - : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 diff --git a/basis/http/http.factor b/basis/http/http.factor index a64a11690c..bf58f5c238 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -34,7 +34,7 @@ IN: http : check-header-string ( str -- str ) #! http://en.wikipedia.org/wiki/HTTP_Header_Injection - dup "\r\n\"" intersects? + dup "\r\n" intersects? [ "Header injection attack" throw ] when ; : write-header ( assoc -- ) @@ -213,7 +213,10 @@ TUPLE: post-data data params content-type content-encoding ; swap >>content-type ; : parse-content-type-attributes ( string -- attributes ) - " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; + " " split harvest [ + "=" split1 + [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi* + ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) ";" split1 diff --git a/basis/http/parsers/parsers-tests.factor b/basis/http/parsers/parsers-tests.factor new file mode 100644 index 0000000000..f87ed47f00 --- /dev/null +++ b/basis/http/parsers/parsers-tests.factor @@ -0,0 +1,16 @@ +IN: http.parsers.tests +USING: http http.parsers tools.test ; + +[ { } ] [ "" parse-cookie ] unit-test +[ { } ] [ "" parse-set-cookie ] unit-test + +! Make sure that totally invalid cookies don't confuse us +[ { } ] [ "hello world; how are you" parse-cookie ] unit-test + +[ { T{ cookie { name "__s" } { value "12345567" } } } ] +[ "__s=12345567" parse-cookie ] +unit-test + +[ { T{ cookie { name "__s" } { value "12345567" } } } ] +[ "__s=12345567;" parse-cookie ] +unit-test \ No newline at end of file diff --git a/basis/http/parsers/parsers.factor b/basis/http/parsers/parsers.factor index d72147b381..2520c35acb 100644 --- a/basis/http/parsers/parsers.factor +++ b/basis/http/parsers/parsers.factor @@ -162,7 +162,7 @@ PEG: (parse-set-cookie) ( string -- alist ) 'value' , 'space' , ] seq* - [ ";,=" member? not ] satisfy repeat1 [ drop f ] action + [ ";,=" member? not ] satisfy repeat0 [ drop f ] action 2choice ; PEG: (parse-cookie) ( string -- alist ) diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor index a64fe9af3c..d2f453034a 100644 --- a/basis/http/server/cgi/cgi.factor +++ b/basis/http/server/cgi/cgi.factor @@ -53,9 +53,9 @@ IN: http.server.cgi "CGI output follows" >>message swap '[ binary encode-output - _ output-stream get swap binary [ + output-stream get _ binary [ post-request? [ request get post-data>> data>> write flush ] when - '[ _ write ] each-block + '[ _ stream-write ] each-block ] with-stream ] >>body ; diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 88eb984488..cf16df7d82 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -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 * 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 ) diff --git a/basis/images/images.factor b/basis/images/images.factor index 82576774f4..cb44825e62 100644 --- a/basis/images/images.factor +++ b/basis/images/images.factor @@ -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 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 * '[ + _ 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 ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index a50ac0cad9..2ea1b08e20 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 ; diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index 4ce549ac83..3f3e7f13df 100644 --- a/basis/inspector/inspector-tests.factor +++ b/basis/inspector/inspector-tests.factor @@ -8,7 +8,7 @@ f describe H{ } describe H{ } describe -[ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test +[ "fixnum instance\n\n" ] [ [ 3 describe ] with-string-writer ] unit-test [ ] [ H{ } clone inspect ] unit-test diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 05c4dc2a94..8cab5b5ad3 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -9,7 +9,7 @@ IN: inspector SYMBOL: +number-rows+ -: summary. ( obj -- ) [ summary ] keep write-object nl ; +: print-summary ( obj -- ) [ summary ] keep write-object ; ERROR: file-not-found ; : find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) - [ - '[ _ _ find-file [ file-not-found ] unless* ] attempt-all + '[ + _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all ] [ drop f ] recover ; diff --git a/basis/io/encodings/euc-kr/euc-kr-docs.factor b/basis/io/encodings/euc-kr/euc-kr-docs.factor index 5e109f3536..60cd41ac57 100644 --- a/basis/io/encodings/euc-kr/euc-kr-docs.factor +++ b/basis/io/encodings/euc-kr/euc-kr-docs.factor @@ -3,8 +3,11 @@ USING: help.syntax help.markup ; IN: io.encodings.euc-kr -ABOUT: euc-kr - HELP: euc-kr -{ $class-description "This encoding class implements Microsoft's code page #949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatibility to EUC-KR, in practice." } +{ $class-description "This encoding class implements Microsoft's CP949 encoding, also called Unified Hangul Code or ks_c_5601-1987, UHC. CP949 is extended version of EUC-KR and downward-compatible with EUC-KR in practice." } { $see-also "encodings-introduction" } ; + +ARTICLE: "io.encodings.euc-kr" "EUC-KR encoding" +{ $subsection euc-kr } ; + +ABOUT: "io.encodings.euc-kr" \ No newline at end of file diff --git a/basis/io/encodings/johab/johab-docs.factor b/basis/io/encodings/johab/johab-docs.factor index 1d707e0f7d..d2eac30b25 100644 --- a/basis/io/encodings/johab/johab-docs.factor +++ b/basis/io/encodings/johab/johab-docs.factor @@ -3,7 +3,10 @@ USING: help.syntax help.markup ; IN: io.encodings.johab -ABOUT: johab - HELP: johab { $class-description "Korean Johab encoding (KSC5601-1992). This encoding is not commonly used anymore." } ; + +ARTICLE: "io.encodings.johab" "Korean Johab encoding" +{ $subsection johab } ; + +ABOUT: "io.encodings.johab" \ No newline at end of file diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index 8e93dc9450..55dc6ca9a4 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -97,7 +97,7 @@ M: plain-writer make-block-stream nip ; 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 ; diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 2ee0832269..78a9c03d20 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -84,7 +84,7 @@ SYMBOL: max-stack-items bi ] with-row ] each - ] tabular-output + ] tabular-output nl ] unless-empty ; : trimmed-stack. ( seq -- ) diff --git a/basis/locals/definitions/definitions.factor b/basis/locals/definitions/definitions.factor index 99f9d0bd22..a4299d0684 100644 --- a/basis/locals/definitions/definitions.factor +++ b/basis/locals/definitions/definitions.factor @@ -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 ; diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index 0998d84530..18dabed4b0 100644 --- a/basis/locals/locals-docs.factor +++ b/basis/locals/locals-docs.factor @@ -1,5 +1,5 @@ USING: help.syntax help.markup kernel macros prettyprint -memoize combinators arrays generalizations ; +memoize combinators arrays generalizations see ; IN: locals HELP: [| diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 923f890adf..558fa78494 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit combinators.short-circuit.smart math.order math.functions -definitions compiler.units fry lexer words.symbol ; +definitions compiler.units fry lexer words.symbol see ; IN: locals.tests :: foo ( a b -- a a ) a a ; diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 7b061ab2f5..7d93ce8a9e 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -1,6 +1,6 @@ IN: macros.tests USING: tools.test macros math kernel arrays -vectors io.streams.string prettyprint parser eval ; +vectors io.streams.string prettyprint parser eval see ; MACRO: see-test ( a b -- c ) + ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6618578a99..08cd8fb470 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -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 diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 168a0061e3..54378bd37e 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel memoize tools.test parser generalizations -prettyprint io.streams.string sequences eval namespaces ; +prettyprint io.streams.string sequences eval namespaces see ; IN: memoize.tests MEMO: fib ( m -- n ) diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor index 4db71c4595..82dd035467 100644 --- a/basis/models/models-docs.factor +++ b/basis/models/models-docs.factor @@ -137,7 +137,7 @@ $nl { $subsection "models-delay" } ; ARTICLE: "models-impl" "Implementing models" -"New types of models can be defined, for example see " { $vocab-link "models.filter" } "." +"New types of models can be defined, for example see " { $vocab-link "models.arrow" } "." $nl "Models can execute hooks when activated:" { $subsection model-activated } diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor index 45b1d8f706..7141caa67d 100644 --- a/basis/opengl/textures/textures-tests.factor +++ b/basis/opengl/textures/textures-tests.factor @@ -5,15 +5,19 @@ images kernel namespaces ; IN: opengl.textures.tests [ ] [ - { 3 5 } - RGB - B{ - 1 2 3 4 5 6 7 8 9 - 10 11 12 13 14 15 16 17 18 - 19 20 21 22 23 24 25 26 27 - 28 29 30 31 32 33 34 35 36 - 37 38 39 40 41 42 43 44 45 - } image boa "image" set + T{ image + { dim { 3 5 } } + { component-order RGB } + { bitmap + B{ + 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 + 19 20 21 22 23 24 25 26 27 + 28 29 30 31 32 33 34 35 36 + 37 38 39 40 41 42 43 44 45 + } + } + } "image" set ] unit-test [ diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 79af9be48b..48cdafb837 100644 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -11,14 +11,16 @@ IN: opengl.textures TUPLE: texture loc dim texture-coords texture display-list disposed ; -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 ; + = ] - } 0|| not nip + [ blank? ] + [ CHAR: " = ] + [ CHAR: ' = ] + [ CHAR: | = ] + [ CHAR: { = ] + [ CHAR: } = ] + [ CHAR: = = ] + [ CHAR: ) = ] + [ CHAR: ( = ] + [ CHAR: ] = ] + [ CHAR: [ = ] + [ CHAR: . = ] + [ CHAR: ! = ] + [ CHAR: & = ] + [ CHAR: * = ] + [ CHAR: + = ] + [ CHAR: ? = ] + [ CHAR: : = ] + [ CHAR: ~ = ] + [ CHAR: < = ] + [ CHAR: > = ] + } 1|| not ] satisfy repeat1 [ >string ] action ; : 'terminal' ( -- parser ) @@ -161,9 +161,9 @@ PEG: escaper ( string -- ast ) #! Parse a valid foreign parser name [ { - [ dup blank? ] - [ dup CHAR: > = ] - } 0|| not nip + [ blank? ] + [ CHAR: > = ] + } 1|| not ] satisfy repeat1 [ >string ] action ; : 'foreign' ( -- parser ) diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 1e372d7cc0..2be725c0f6 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -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 ; \ No newline at end of file diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index b1239086d7..aaaf6b80d1 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -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 diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 63d7bf217a..2286417dd1 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/basis/prettyprint/prettyprint.factor @@ -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: arrays 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 sets ; IN: prettyprint +> eq? nip ] with assoc-find 2drop ] curry map sift ; : prelude. ( -- ) - in get use get vocab-names use/in. ; + in get use get vocab-names prune in get ".private" append swap remove use/in. ; [ nl - "Restarts were invoked adding vocabularies to the search path." print - "To avoid doing this in the future, add the following USING:" print - "and IN: forms at the top of the source file:" print nl - prelude. - nl + { { font-style bold } { font-name "sans-serif" } } [ + "Restarts were invoked adding vocabularies to the search path." print + "To avoid doing this in the future, add the following USING:" print + "and IN: forms at the top of the source file:" print nl + ] with-style + { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } } [ prelude. ] with-nesting + nl nl ] print-use-hook set-global +PRIVATE> + : with-use ( obj quot -- ) - make-pprint use/in. do-pprint ; inline + make-pprint [ use/in. ] [ empty? not or [ nl ] when ] 2bi + do-pprint ; inline : with-in ( obj quot -- ) make-pprint drop [ write-in bl ] when* do-pprint ; inline @@ -165,214 +171,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 - - 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* - ; - -M: intersection-class see-class* - ; - -M: mixin-class see-class* - block> ; - -M: predicate-class see-class* - 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 - - \ } 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* - - 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 ; \ No newline at end of file diff --git a/basis/prettyprint/sections/sections-docs.factor b/basis/prettyprint/sections/sections-docs.factor index 4f1c073a2d..ce7430d040 100644 --- a/basis/prettyprint/sections/sections-docs.factor +++ b/basis/prettyprint/sections/sections-docs.factor @@ -199,7 +199,7 @@ HELP: [a,b] ; +IN: regexp.ast + +TUPLE: negation term ; +C: negation + +TUPLE: from-to n m ; +C: from-to + +TUPLE: at-least n ; +C: at-least + +TUPLE: tagged-epsilon tag ; +C: tagged-epsilon + +CONSTANT: epsilon T{ tagged-epsilon { tag t } } + +TUPLE: concatenation first second ; + +: ( seq -- concatenation ) + [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ; + +TUPLE: alternation first second ; + +: ( seq -- alternation ) + unclip [ alternation boa ] reduce ; + +TUPLE: star term ; +C: star + +TUPLE: with-options tree options ; +C: with-options + +TUPLE: options on off ; +C: options + +SINGLETONS: unix-lines dotall multiline comments case-insensitive +unicode-case reversed-regexp ; + +: ( term -- term' ) + f 2array ; + +: ( term -- term' ) + dup 2array ; + +: repetition ( n term -- term' ) + ; + +GENERIC: ( term times -- term' ) +M: at-least + n>> swap [ repetition ] [ ] bi 2array ; +M: from-to + [ n>> ] [ m>> ] bi [a,b] swap '[ _ repetition ] map ; + +: char-class ( ranges ? -- term ) + [ ] dip [ ] when ; + +TUPLE: lookahead term ; +C: lookahead + +TUPLE: lookbehind term ; +C: lookbehind diff --git a/basis/regexp/backend/backend.factor b/basis/regexp/backend/backend.factor deleted file mode 100644 index 5eff0579c8..0000000000 --- a/basis/regexp/backend/backend.factor +++ /dev/null @@ -1,27 +0,0 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors hashtables kernel math vectors ; -IN: regexp.backend - -TUPLE: regexp - raw - { options hashtable } - stack - parse-tree - nfa-table - dfa-table - minimized-table - matchers - { nfa-traversal-flags hashtable } - { dfa-traversal-flags hashtable } - { state integer } - { new-states vector } - { visited-states hashtable } ; - -: reset-regexp ( regexp -- regexp ) - 0 >>state - V{ } clone >>stack - V{ } clone >>new-states - H{ } clone >>visited-states ; - -SYMBOL: current-regexp diff --git a/basis/regexp/classes/classes-tests.factor b/basis/regexp/classes/classes-tests.factor new file mode 100644 index 0000000000..e2db86f6c1 --- /dev/null +++ b/basis/regexp/classes/classes-tests.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: regexp.classes tools.test arrays kernel ; +IN: regexp.classes.tests + +! Class algebra + +[ f ] [ { 1 2 } ] unit-test +[ T{ or-class f { 1 2 } } ] [ { 1 2 } ] unit-test +[ 3 ] [ { 1 2 } 3 2array ] unit-test +[ CHAR: A ] [ CHAR: A LETTER-class 2array ] unit-test +[ CHAR: A ] [ LETTER-class CHAR: A 2array ] unit-test +[ T{ primitive-class { class LETTER-class } } ] [ CHAR: A LETTER-class 2array ] unit-test +[ T{ primitive-class { class LETTER-class } } ] [ LETTER-class CHAR: A 2array ] unit-test +[ t ] [ { t 1 } ] unit-test +[ t ] [ { 1 t } ] unit-test +[ f ] [ { f 1 } ] unit-test +[ f ] [ { 1 f } ] unit-test +[ 1 ] [ { f 1 } ] unit-test +[ 1 ] [ { 1 f } ] unit-test +[ 1 ] [ { t 1 } ] unit-test +[ 1 ] [ { 1 t } ] unit-test +[ 1 ] [ 1 ] unit-test +[ 1 ] [ { 1 1 } ] unit-test +[ 1 ] [ { 1 1 } ] unit-test +[ t ] [ { t t } ] unit-test +[ T{ primitive-class { class letter-class } } ] [ letter-class dup 2array ] unit-test +[ T{ primitive-class { class letter-class } } ] [ letter-class dup 2array ] unit-test +[ T{ or-class { seq { 1 2 3 } } } ] [ { 1 2 } { 2 3 } 2array ] unit-test +[ T{ or-class { seq { 2 3 } } } ] [ { 2 3 } 1 2array ] unit-test +[ f ] [ t ] unit-test +[ t ] [ f ] unit-test +[ f ] [ 1 1 t answer ] unit-test +[ t ] [ { 1 2 } 1 2 3array ] unit-test +[ f ] [ { 1 2 } 1 2 3array ] 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 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 +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 dup t answer ] unit-test +[ f ] [ foo dup f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar f answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f bar } ] [ foo bar 2array foo t answer ] unit-test +[ f ] [ foo bar 2array foo f answer ] unit-test +[ f ] [ foo bar 2array bar f answer ] unit-test +[ t ] [ foo bar 2array bar t answer ] unit-test +[ T{ primitive-class f foo } ] [ foo bar 2array bar f answer ] unit-test diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor index 4a807fa51b..d26ff7f69c 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math math.order words regexp.utils -unicode.categories combinators.short-circuit ; +USING: accessors kernel math math.order words combinators locals +ascii unicode.categories combinators.short-circuit sequences +fry macros arrays assocs sets classes mirrors ; IN: regexp.classes SINGLETONS: any-char any-char-no-nl @@ -11,19 +12,18 @@ ascii-class punctuation-class java-printable-class blank-class control-character-class hex-digit-class java-blank-class c-identifier-class unmatchable-class terminator-class word-boundary-class ; -SINGLETONS: beginning-of-input beginning-of-line -end-of-input end-of-line ; +SINGLETONS: beginning-of-input ^ end-of-input $ end-of-file word-break ; -MIXIN: node -TUPLE: character-class-range from to ; INSTANCE: character-class-range node +TUPLE: range from to ; +C: range GENERIC: class-member? ( obj class -- ? ) -M: t class-member? ( obj class -- ? ) 2drop f ; +M: t class-member? ( obj class -- ? ) 2drop t ; -M: integer class-member? ( obj class -- ? ) 2drop f ; +M: integer class-member? ( obj class -- ? ) = ; -M: character-class-range class-member? ( obj class -- ? ) +M: range class-member? ( obj class -- ? ) [ from>> ] [ to>> ] bi between? ; M: any-char class-member? ( obj class -- ? ) @@ -47,16 +47,24 @@ M: ascii-class class-member? ( obj class -- ? ) M: digit-class class-member? ( obj class -- ? ) drop digit? ; +: c-identifier-char? ( ch -- ? ) + { [ alpha? ] [ CHAR: _ = ] } 1|| ; + M: c-identifier-class class-member? ( obj class -- ? ) - drop - { [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ; + drop c-identifier-char? ; M: alpha-class class-member? ( obj class -- ? ) drop alpha? ; +: punct? ( ch -- ? ) + "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ; + M: punctuation-class class-member? ( obj class -- ? ) drop punct? ; +: java-printable? ( ch -- ? ) + { [ alpha? ] [ punct? ] } 1|| ; + M: java-printable-class class-member? ( obj class -- ? ) drop java-printable? ; @@ -64,11 +72,24 @@ M: non-newline-blank-class class-member? ( obj class -- ? ) drop { [ blank? ] [ CHAR: \n = not ] } 1&& ; M: control-character-class class-member? ( obj class -- ? ) - drop control-char? ; + drop control? ; + +: hex-digit? ( ch -- ? ) + { + [ CHAR: A CHAR: F between? ] + [ CHAR: a CHAR: f between? ] + [ CHAR: 0 CHAR: 9 between? ] + } 1|| ; M: hex-digit-class class-member? ( obj class -- ? ) drop hex-digit? ; +: java-blank? ( ch -- ? ) + { + CHAR: \s CHAR: \t CHAR: \n + HEX: b HEX: 7 CHAR: \r + } member? ; + M: java-blank-class class-member? ( obj class -- ? ) drop java-blank? ; @@ -76,16 +97,219 @@ M: unmatchable-class class-member? ( obj class -- ? ) 2drop f ; M: terminator-class class-member? ( obj class -- ? ) - drop { - [ CHAR: \r = ] - [ CHAR: \n = ] - [ CHAR: \u000085 = ] - [ CHAR: \u002028 = ] - [ CHAR: \u002029 = ] + drop "\r\n\u000085\u002029\u002028" member? ; + +M: ^ class-member? ( obj class -- ? ) + 2drop f ; + +M: $ class-member? ( obj class -- ? ) + 2drop f ; + +M: f class-member? 2drop f ; + +TUPLE: primitive-class class ; +C: primitive-class + +TUPLE: not-class class ; + +PREDICATE: not-integer < not-class class>> integer? ; +PREDICATE: not-primitive < not-class class>> primitive-class? ; + +M: not-class class-member? + class>> class-member? not ; + +TUPLE: or-class seq ; + +M: or-class class-member? + seq>> [ class-member? ] with any? ; + +TUPLE: and-class seq ; + +M: and-class class-member? + seq>> [ class-member? ] with all? ; + +DEFER: substitute + +: flatten ( seq class -- newseq ) + '[ dup _ instance? [ seq>> ] [ 1array ] if ] map concat ; inline + +:: seq>instance ( seq empty class -- instance ) + seq length { + { 0 [ empty ] } + { 1 [ seq first ] } + [ drop class new seq { } like >>seq ] + } case ; inline + +TUPLE: class-partition integers not-integers primitives not-primitives and or other ; + +: partition-classes ( seq -- class-partition ) + prune + [ integer? ] partition + [ not-integer? ] partition + [ primitive-class? ] partition ! extend primitive-class to epsilon tags + [ not-primitive? ] partition + [ and-class? ] partition + [ or-class? ] partition + class-partition boa ; + +: class-partition>seq ( class-partition -- seq ) + make-mirror values concat ; + +: repartition ( partition -- partition' ) + ! This could be made more efficient; only and and or are effected + class-partition>seq partition-classes ; + +: filter-not-integers ( partition -- partition' ) + dup + [ primitives>> ] [ not-primitives>> ] [ or>> ] tri + 3append and-class boa + '[ [ class>> _ class-member? ] filter ] change-not-integers ; + +: answer-ors ( partition -- partition' ) + dup [ not-integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + '[ [ _ [ t substitute ] each ] map ] change-or ; + +: contradiction? ( partition -- ? ) + { + [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ other>> f swap member? ] } 1|| ; -M: beginning-of-line class-member? ( obj class -- ? ) - 2drop f ; +: make-and-class ( partition -- and-class ) + answer-ors repartition + [ t swap remove ] change-other + dup contradiction? + [ drop f ] + [ filter-not-integers class-partition>seq prune t and-class seq>instance ] if ; -M: end-of-line class-member? ( obj class -- ? ) - 2drop f ; +: ( seq -- class ) + dup and-class flatten partition-classes + dup integers>> length { + { 0 [ nip make-and-class ] } + { 1 [ integers>> first [ '[ _ swap class-member? ] all? ] keep and ] } + [ 3drop f ] + } case ; + +: filter-integers ( partition -- partition' ) + dup + [ primitives>> ] [ not-primitives>> ] [ and>> ] tri + 3append or-class boa + '[ [ _ class-member? not ] filter ] change-integers ; + +: answer-ands ( partition -- partition' ) + dup [ integers>> ] [ not-primitives>> ] [ primitives>> ] tri 3append + '[ [ _ [ f substitute ] each ] map ] change-and ; + +: tautology? ( partition -- ? ) + { + [ [ primitives>> ] [ not-primitives>> ] bi intersects? ] + [ other>> t swap member? ] + } 1|| ; + +: make-or-class ( partition -- and-class ) + answer-ands repartition + [ f swap remove ] change-other + dup tautology? + [ drop t ] + [ filter-integers class-partition>seq prune f or-class seq>instance ] if ; + +: ( seq -- class ) + dup or-class flatten partition-classes + dup not-integers>> length { + { 0 [ nip make-or-class ] } + { 1 [ not-integers>> first [ class>> '[ _ swap class-member? ] any? ] keep or ] } + [ 3drop t ] + } case ; + +GENERIC: ( class -- inverse ) + +M: object + not-class boa ; + +M: not-class + class>> ; + +M: and-class + seq>> [ ] map ; + +M: or-class + seq>> [ ] map ; + +M: t drop f ; +M: f drop t ; + +M: primitive-class class-member? + class>> class-member? ; + +UNION: class primitive-class not-class or-class and-class range ; + +TUPLE: condition question yes no ; +C: condition + +GENERIC# answer 2 ( 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 '[ _ _ answer ] map ; + +M: and-class answer + replace-compound ; + +M: or-class answer + replace-compound ; + +M: not-class answer + [ class>> ] 2dip answer ; + +GENERIC# substitute 1 ( class from to -- new-class ) +M: object substitute answer ; +M: not-class substitute [ ] bi@ answer ; + +: assoc-answer ( table question answer -- new-table ) + '[ _ _ substitute ] assoc-map + [ nip ] assoc-filter ; + +: assoc-answers ( table questions answer -- new-table ) + '[ _ assoc-answer ] each ; + +DEFER: make-condition + +: (make-condition) ( table questions question -- condition ) + [ 2nip ] + [ swap [ t assoc-answer ] dip make-condition ] + [ swap [ f assoc-answer ] dip make-condition ] 3tri + 2dup = [ 2nip ] [ ] if ; + +: make-condition ( table questions -- condition ) + [ keys ] [ unclip (make-condition) ] if-empty ; + +GENERIC: class>questions ( class -- questions ) +: compound-questions ( class -- questions ) seq>> [ class>questions ] gather ; +M: or-class class>questions compound-questions ; +M: and-class class>questions compound-questions ; +M: not-class class>questions class>> class>questions ; +M: object class>questions 1array ; + +: table>questions ( table -- questions ) + values [ class>questions ] gather >array t swap remove ; + +: table>condition ( table -- condition ) + ! input table is state => class + >alist dup table>questions make-condition ; + +: condition-map ( condition quot: ( obj -- obj' ) -- new-condition ) + over condition? [ + [ [ question>> ] [ yes>> ] [ no>> ] tri ] dip + '[ _ condition-map ] bi@ + ] [ call ] if ; inline recursive + +: condition-states ( condition -- states ) + dup condition? [ + [ yes>> ] [ no>> ] bi + [ condition-states ] bi@ append prune + ] [ 1array ] if ; + +: condition-at ( condition assoc -- new-condition ) + '[ _ at ] condition-map ; diff --git a/basis/regexp/combinators/authors.txt b/basis/regexp/combinators/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/regexp/combinators/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/regexp/combinators/combinators-docs.factor b/basis/regexp/combinators/combinators-docs.factor new file mode 100644 index 0000000000..7cb214f42b --- /dev/null +++ b/basis/regexp/combinators/combinators-docs.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup regexp strings ; +IN: regexp.combinators + +ABOUT: "regexp.combinators" + +ARTICLE: "regexp.combinators" "Regular expression combinators" +"The " { $vocab-link "regexp.combinators" } " vocabulary defines combinators which can be used to build up regular expressions to match strings. This is in addition to the traditional syntax defined in the " { $vocab-link "regexp" } " vocabulary." +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection } +{ $subsection