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

db4
Daniel Ehrenberg 2009-03-06 14:34:08 -06:00
commit 81b68eac48
8 changed files with 74 additions and 24 deletions

View File

@ -1,25 +1,26 @@
USING: kernel tools.test base64 strings sequences ; USING: kernel tools.test base64 strings sequences
io.encodings.string io.encodings.ascii ;
IN: base64.tests IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test ] unit-test
[ "" ] [ "" >base64 base64> >string ] unit-test [ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
[ "a" ] [ "a" >base64 base64> >string ] unit-test [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test [ "abcde" ] [ "abcde" ascii encode >base64 3 cut "\r\n" swap 3append base64> ascii decode ] unit-test
! From http://en.wikipedia.org/wiki/Base64 ! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[ [
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
>base64 >string ascii encode >base64 >string
] unit-test ] unit-test
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ] [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[ [
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure." "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
>base64-lines >string ascii encode >base64-lines >string
] unit-test ] unit-test
\ >base64 must-infer \ >base64 must-infer

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg. ! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary USING: combinators io io.binary io.encodings.binary
io.streams.byte-array io.streams.string kernel math namespaces io.streams.byte-array kernel math namespaces
sequences strings io.crlf ; sequences strings io.crlf ;
IN: base64 IN: base64
@ -75,10 +75,10 @@ PRIVATE>
} case ; } case ;
: >base64 ( seq -- base64 ) : >base64 ( seq -- base64 )
binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ; binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
: base64> ( base64 -- seq ) : base64> ( base64 -- seq )
[ binary [ decode-base64 ] with-byte-reader ] with-string-writer ; binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
: >base64-lines ( seq -- base64 ) : >base64-lines ( seq -- base64 )
binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ; binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;

View File

@ -64,7 +64,6 @@ M: topic url-of topic>filename ;
tri simple-page ; tri simple-page ;
: generate-help-file ( topic -- ) : generate-help-file ( topic -- )
dup .
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ; dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq ) : all-vocabs-really ( -- seq )

View File

@ -38,3 +38,11 @@ M: object another-generic ;
[ ] [ \ another-generic reset ] unit-test [ ] [ \ another-generic reset ] unit-test
[ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test [ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test
GENERIC: blah-generic ( a -- b )
M: string blah-generic ;
{ string blah-generic } watch
[ ] [ "hi" blah-generic ] unit-test

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math sorting words parser io summary USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects quotations sequences prettyprint continuations effects
@ -20,16 +20,34 @@ M: word reset
f "unannotated-def" set-word-prop f "unannotated-def" set-word-prop
] [ drop ] if ; ] [ drop ] if ;
M: method-spec reset
first2 method reset ;
ERROR: cannot-annotate-twice word ; ERROR: cannot-annotate-twice word ;
<PRIVATE
: check-annotate-twice ( word -- word )
dup "unannotated-def" word-prop [
cannot-annotate-twice
] when ;
: method-spec>word ( obj -- word )
dup method-spec? [ first2 method ] when ;
: save-unannotated-def ( word -- )
dup def>> "unannotated-def" set-word-prop ;
: (annotate) ( word quot -- )
[ dup def>> ] dip call define ; inline
PRIVATE>
: annotate ( word quot -- ) : annotate ( word quot -- )
over "unannotated-def" word-prop [ [ method-spec>word check-annotate-twice ] dip
over cannot-annotate-twice [ over save-unannotated-def (annotate) ] with-compilation-unit ; inline
] when
[ <PRIVATE
over dup def>> "unannotated-def" set-word-prop
[ dup def>> ] dip call define
] with-compilation-unit ; inline
: word-inputs ( word -- seq ) : word-inputs ( word -- seq )
stack-effect [ stack-effect [
@ -58,8 +76,12 @@ ERROR: cannot-annotate-twice word ;
: (watch) ( word def -- def ) : (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ; over '[ _ entering @ _ leaving ] ;
PRIVATE>
: watch ( word -- ) : watch ( word -- )
dup [ (watch) ] annotate ; dup '[ [ _ ] dip (watch) ] annotate ;
<PRIVATE
: (watch-vars) ( word vars quot -- newquot ) : (watch-vars) ( word vars quot -- newquot )
'[ '[
@ -71,6 +93,8 @@ ERROR: cannot-annotate-twice word ;
: watch-vars ( word vars -- ) : watch-vars ( word vars -- )
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ; dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
PRIVATE>
GENERIC# annotate-methods 1 ( word quot -- ) GENERIC# annotate-methods 1 ( word quot -- )
M: generic annotate-methods M: generic annotate-methods
@ -79,6 +103,9 @@ M: generic annotate-methods
M: word annotate-methods M: word annotate-methods
annotate ; annotate ;
M: method-spec annotate-methods
annotate ;
: breakpoint ( word -- ) : breakpoint ( word -- )
[ add-breakpoint ] annotate-methods ; [ add-breakpoint ] annotate-methods ;
@ -92,9 +119,13 @@ word-timing [ H{ } clone ] initialize
: reset-word-timing ( -- ) : reset-word-timing ( -- )
word-timing get clear-assoc ; word-timing get clear-assoc ;
<PRIVATE
: (add-timing) ( def word -- def' ) : (add-timing) ( def word -- def' )
'[ _ benchmark _ word-timing get at+ ] ; '[ _ benchmark _ word-timing get at+ ] ;
PRIVATE>
: add-timing ( word -- ) : add-timing ( word -- )
dup '[ _ (add-timing) ] annotate ; dup '[ _ (add-timing) ] annotate ;

View File

@ -106,3 +106,9 @@ ARTICLE: "test-article-2" "This is a test article"
[ ] [ [ ] [
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget \ = <model> [ see ] <pane-control> [ ] with-grafted-gadget
] unit-test ] unit-test
: <test-pane> ( -- foo )
<gadget> pane new-pane ;
[ t ] [ <test-pane> dup input>> child? ] unit-test
[ t ] [ <test-pane> dup last-line>> child? ] unit-test

View File

@ -63,7 +63,9 @@ M: pane gadget-selection ( pane -- string/f )
selection-color >>selection-color ; inline selection-color >>selection-color ; inline
: init-last-line ( pane -- pane ) : init-last-line ( pane -- pane )
horizontal <track> [ >>last-line ] [ 1 track-add ] bi ; inline horizontal <track>
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
: new-pane ( input class -- pane ) : new-pane ( input class -- pane )
[ vertical ] dip new-track [ vertical ] dip new-track

View File

@ -83,6 +83,9 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word PREDICATE: method-body < word
"method-generic" word-prop >boolean ; "method-generic" word-prop >boolean ;
M: method-spec stack-effect
first2 method stack-effect ;
M: method-body stack-effect M: method-body stack-effect
"method-generic" word-prop stack-effect ; "method-generic" word-prop stack-effect ;