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

db4
Slava Pestov 2008-05-07 01:57:08 -05:00
commit a6ab5c3a47
23 changed files with 62 additions and 34 deletions
extra
help/lint
html/parser
porter-stemmer
project-euler
tools/deploy/backend
ui/gestures

View File

@ -102,7 +102,7 @@ ERROR: bad-superclass class ;
dup tuple-predicate-quot define-predicate ;
: superclass-size ( class -- n )
superclasses butlast-slice
superclasses but-last-slice
[ slot-names length ] map sum ;
: generate-tuple-slots ( class slots -- slot-specs )

View File

@ -32,7 +32,7 @@ IN: inference.transforms
drop [ no-case ]
] [
dup peek quotation? [
dup peek swap butlast
dup peek swap but-last
] [
[ no-case ] swap
] if case>quot

View File

@ -114,7 +114,7 @@ unit-test
[ parse-fresh drop ] with-compilation-unit
[
"prettyprint.tests" lookup see
] with-string-writer "\n" split butlast
] with-string-writer "\n" split but-last
] keep =
] with-scope ;

View File

@ -284,7 +284,7 @@ M: colon unindent-first-line? drop t ;
! Long section layout algorithm
: chop-break ( seq -- seq )
dup peek line-break? [ butlast-slice chop-break ] when ;
dup peek line-break? [ but-last-slice chop-break ] when ;
SYMBOL: prev
SYMBOL: next

View File

@ -92,7 +92,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection subseq }
{ $subsection head }
{ $subsection tail }
{ $subsection butlast }
{ $subsection but-last }
{ $subsection rest }
{ $subsection head* }
{ $subsection tail* }
@ -107,7 +107,7 @@ ARTICLE: "sequences-slices" "Subsequences and slices"
{ $subsection <slice> }
{ $subsection head-slice }
{ $subsection tail-slice }
{ $subsection butlast-slice }
{ $subsection but-last-slice }
{ $subsection rest-slice }
{ $subsection head-slice* }
{ $subsection tail-slice* }
@ -838,7 +838,7 @@ HELP: tail-slice
{ $description "Outputs a virtual sequence sharing storage with all elements from the " { $snippet "n" } "th index until the end of the input sequence." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: butlast-slice
HELP: but-last-slice
{ $values { "seq" sequence } { "slice" "a slice" } }
{ $description "Outputs a virtual sequence sharing storage with all but the last element of the input sequence." }
{ $errors "Throws an error on an empty sequence." } ;
@ -869,7 +869,7 @@ HELP: tail
{ $description "Outputs a new sequence consisting of the input sequence with the first n items removed." }
{ $errors "Throws an error if the index is out of bounds." } ;
HELP: butlast
HELP: but-last
{ $values { "seq" sequence } { "headseq" "a new sequence" } }
{ $description "Outputs a new sequence consisting of the input sequence with the last item removed." }
{ $errors "Throws an error on an empty sequence." } ;

View File

@ -216,7 +216,7 @@ M: slice length dup slice-to swap slice-from - ;
: tail-slice* ( seq n -- slice ) from-end tail-slice ;
: butlast-slice ( seq -- slice ) 1 head-slice* ;
: but-last-slice ( seq -- slice ) 1 head-slice* ;
INSTANCE: slice virtual-sequence
@ -265,7 +265,7 @@ PRIVATE>
: tail* ( seq n -- tailseq ) from-end tail ;
: butlast ( seq -- headseq ) 1 head* ;
: but-last ( seq -- headseq ) 1 head* ;
: copy ( src i dst -- )
pick length >r 3dup check-copy spin 0 r>
@ -675,13 +675,13 @@ PRIVATE>
[ rest ] [ first ] bi ;
: unclip-last ( seq -- butfirst last )
[ butlast ] [ peek ] bi ;
[ but-last ] [ peek ] bi ;
: unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ;
: unclip-last-slice ( seq -- butfirst last )
[ butlast-slice ] [ peek ] bi ;
[ but-last-slice ] [ peek ] bi ;
: <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ;

View File

@ -104,7 +104,7 @@ M: sliced-clumps nth group@ <slice> ;
1array
] [
"\n" split [
butlast-slice [
but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat

View File

@ -10,7 +10,7 @@ IN: help.lint
: check-example ( element -- )
rest [
butlast "\n" join 1vector
but-last "\n" join 1vector
[
use [ clone ] change
[ eval>string ] with-datastack

View File

@ -99,7 +99,7 @@ IN: html.parser.analyzer
: find-between ( i/f tag/f vector -- vector )
find-between* dup length 3 >= [
[ rest-slice butlast-slice ] keep like
[ rest-slice but-last-slice ] keep like
] when ;
: find-between-first ( string vector -- vector' )

View File

@ -36,7 +36,7 @@ IN: html.parser.utils
dup quoted? [ quote ] unless ;
: unquote ( str -- newstr )
dup quoted? [ butlast-slice rest-slice >string ] when ;
dup quoted? [ but-last-slice rest-slice >string ] when ;
: quote? ( ch -- ? ) "'\"" member? ;

View File

@ -197,7 +197,7 @@ DEFER: _
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
\ suffix [ dup butlast swap peek ] define-inverse
\ suffix [ dup but-last swap peek ] define-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )

View File

@ -184,7 +184,7 @@ DEFER: (d)
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
basis graded graded-ker/im-d flip first2 butlast 0 prefix v- ;
basis graded graded-ker/im-d flip first2 but-last 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )

View File

@ -101,7 +101,7 @@ UNION: special local quote local-word local-reader local-writer ;
] if ;
: point-free-body ( quot args -- newquot )
>r butlast-slice r> [ localize ] curry map concat ;
>r but-last-slice r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?

View File

@ -122,7 +122,7 @@ over class-class-methods assoc-stack call ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: send-message-next ( object message -- )
over object-class class-methods butlast assoc-stack call ;
over object-class class-methods but-last assoc-stack call ;
: <-~ scan parsed \ send-message-next parsed ; parsing

View File

@ -14,7 +14,7 @@ IN: multiline
] [ ";" unexpected-eof ] if* ;
: parse-here ( -- str )
[ (parse-here) ] "" make butlast
[ (parse-here) ] "" make but-last
lexer get next-line ;
: STRING:
@ -34,7 +34,7 @@ IN: multiline
[
lexer get lexer-column swap (parse-multiline-string)
lexer get set-lexer-column
] "" make rest butlast ;
] "" make rest but-last ;
: <"
"\">" parse-multiline-string parsed ; parsing

View File

@ -93,7 +93,7 @@ USING: kernel math parser sequences combinators splitting ;
{ [ "iz" ?tail ] [ "ize" append ] }
{
[ dup length 1- over double-consonant? ]
[ dup "lsz" last-is? [ butlast-slice ] unless ]
[ dup "lsz" last-is? [ but-last-slice ] unless ]
}
{
[ t ]
@ -120,7 +120,7 @@ USING: kernel math parser sequences combinators splitting ;
} cond ;
: step1c ( str -- newstr )
dup butlast-slice stem-vowel? [
dup but-last-slice stem-vowel? [
"y" ?tail [ "i" append ] when
] when ;
@ -196,18 +196,18 @@ USING: kernel math parser sequences combinators splitting ;
: remove-e? ( str -- ? )
dup consonant-seq dup 1 >
[ 2drop t ]
[ 1 = [ butlast-slice cvc? not ] [ drop f ] if ] if ;
[ 1 = [ but-last-slice cvc? not ] [ drop f ] if ] if ;
: remove-e ( str -- newstr )
dup peek CHAR: e = [
dup remove-e? [ butlast-slice ] when
dup remove-e? [ but-last-slice ] when
] when ;
: ll->l ( str -- newstr )
{
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast-slice ] }
{ [ dup consonant-seq 1 > ] [ but-last-slice ] }
[ ]
} cond ;

View File

@ -41,7 +41,7 @@ PRIVATE>
: fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
butlast-slice { 0 1 } prepend ;
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
1000000 fib-upto* [ even? ] filter sum ;

View File

@ -78,7 +78,7 @@ INSTANCE: rollover immutable-sequence
frequency-analysis sort-values keys peek ;
: crack-key ( seq key-length -- key )
[ " " decrypt ] dip group butlast-slice
[ " " decrypt ] dip group but-last-slice
flip [ most-frequent ] map ;
PRIVATE>

View File

@ -69,4 +69,4 @@ HELP: next
{ $description "originally written as " { $code "spot inc" } ", code that would no longer run, this word moves the state of the XML parser to the next place in the source file, keeping track of appropriate debugging information." } ;
HELP: parsing-error
{ $class-description "class to which parsing errors delegate, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;
{ $class-description "class from which parsing errors inherit, containing information about which line and column the error occured on, and what the line was. Contains three slots, line, an integer, column, another integer, and line-str, a string" } ;

View File

@ -63,11 +63,11 @@ DEFER: ?make-staging-image
dup empty? [
"-i=" my-boot-image-name append ,
] [
dup butlast ?make-staging-image
dup but-last ?make-staging-image
"-resource-path=" "" resource-path append ,
"-i=" over butlast staging-image-name append ,
"-i=" over but-last staging-image-name append ,
"-run=tools.deploy.restage" ,
] if

View File

@ -7,7 +7,7 @@ IN: tuple-syntax
: parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [
butlast swap object-slots slot-named slot-spec-offset
but-last swap object-slots slot-named slot-spec-offset
] if ;
: parse-slots ( accum tuple -- accum tuple )

View File

@ -54,7 +54,7 @@ TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
tuple>array butlast >tuple ;
tuple>array but-last >tuple ;
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;

View File

@ -0,0 +1,28 @@
USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
IN: xml.errors.tests
: xml-error-test ( expected-error xml-string -- )
[ string>xml ] curry swap [ = ] curry must-fail-with ;
T{ no-entity f 1 10 "nbsp" } "<x>&nbsp;</x>" xml-error-test
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
} "<x></y>" xml-error-test
T{ unclosed f 1 4 V{ T{ name f "" "x" "" } } } "<x>" xml-error-test
T{ nonexist-ns f 1 5 "x" } "<x:y/>" xml-error-test
T{ unopened f 1 5 } "</x>" xml-error-test
T{ not-yes/no f 1 41 "maybe" } "<?xml version='1.0' standalone='maybe'?><x/>" xml-error-test
T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } }
} "<?xml version='1.1' foo='bar'?><x/>" xml-error-test
T{ bad-version f 1 28 "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
T{ notags f 1 0 } "" xml-error-test
T{ multitags } "<x/><y/>" xml-error-test
T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f }
} "<x/><?xml version='1.0'?>" xml-error-test
T{ capitalized-prolog f 1 6 "XmL" } "<?XmL version='1.0'?><x/>"
xml-error-test
T{ pre/post-content f "x" t } "x<y/>" xml-error-test
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
T{ bad-instruction f 1 11 T{ instruction f "xsl" }
} "<x><?xsl?></x>" xml-error-test
T{ bad-directive f 1 15 T{ directive f "DOCTYPE" }
} "<x/><!DOCTYPE>" xml-error-test