Move match to basis since compiler.tree.debugger uses it, fix conflict

db4
Slava Pestov 2008-09-05 19:48:44 -05:00
commit bcc8483b5b
32 changed files with 210 additions and 60 deletions

View File

@ -127,7 +127,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
[ zero? ] left-trim
[ zero? ] trim-left
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;

View File

@ -151,7 +151,7 @@ M: #branch normalize*
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
dup [ +bottom+ eq? ] left-trim
dup [ +bottom+ eq? ] trim-left
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;

View File

@ -14,6 +14,7 @@ ARTICLE: "span-elements" "Span elements"
{ $subsection $link }
{ $subsection $vocab-link }
{ $subsection $snippet }
{ $subsection $slot }
{ $subsection $url } ;
ARTICLE: "block-elements" "Block elements"
@ -212,6 +213,18 @@ HELP: $code
{ $markup-example { $code "2 2 + ." } }
} ;
HELP: $nl
{ $values { "children" "unused parameter" } }
{ $description "Prints a paragraph break. The parameter is unused." } ;
HELP: $snippet
{ $values { "children" "markup elements" } }
{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ;
HELP: $slot
{ $values { "children" "markup elements" } }
{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ;
HELP: $vocabulary
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ;

View File

@ -3,7 +3,7 @@
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
vocabs help.stylesheet help.topics vocabs.loader ;
vocabs help.stylesheet help.topics vocabs.loader alias ;
IN: help.markup
! Simple markup language.
@ -61,6 +61,9 @@ M: f print-element drop ;
: $snippet ( children -- )
[ snippet-style get print-element* ] ($span) ;
! for help-lint
ALIAS: $slot $snippet
: $emphasis ( children -- )
[ emphasis-style get print-element* ] ($span) ;

View File

@ -113,7 +113,7 @@ SYMBOL: redirects
PRIVATE>
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] right-trim
read-crlf ";" split1 drop [ blank? ] trim-right
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunks ( -- )

View File

@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename )
file-responder get root>> right-trim-separators
file-responder get root>> trim-right-separators
"/"
rot "" or left-trim-separators 3append ;
rot "" or trim-left-separators 3append ;
: serve-file ( filename -- response )
dup mime-type

View File

@ -54,7 +54,7 @@ os { winnt linux macosx } member? [
"m" get next-change drop
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
[ trim-right-separators "xyz" tail? ] either? not
] loop
"c1" get count-down
@ -63,7 +63,7 @@ os { winnt linux macosx } member? [
"m" get next-change drop
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
[ trim-right-separators "yxy" tail? ] either? not
] loop
"c2" get count-down

View File

@ -21,8 +21,8 @@ IN: io.windows.nt.files.tests
[ t ] [ "\\\\" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

View File

@ -22,7 +22,7 @@ M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
{ [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
{ [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;

View File

@ -513,18 +513,11 @@ TUPLE: action-parser p1 quot ;
M: action-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
dup first blank? [ rest-slice left-trim-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
input-slice left-trim-slice input-from pos set @
input-slice trim-left-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;

View File

@ -1,4 +1,5 @@
USING: help.markup help.syntax words parser ;
USING: help.markup help.syntax words parser quotations strings
system sequences ;
IN: tools.annotations
ARTICLE: "tools.annotations" "Word annotations"
@ -20,6 +21,8 @@ HELP: watch
{ $values { "word" word } }
{ $description "Annotates a word definition to print the data stack on entry and exit." } ;
{ watch watch-vars reset } related-words
HELP: breakpoint
{ $values { "word" word } }
{ $description "Annotates a word definition to enter the single stepper when executed." } ;
@ -27,3 +30,36 @@ HELP: breakpoint
HELP: breakpoint-if
{ $values { "quot" "a quotation with stack effect" { $snippet "( -- ? )" } } { "word" word } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: annotate-methods
{ $values
{ "word" word } { "quot" quotation } }
{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ;
HELP: entering
{ $values
{ "str" string } }
{ $description "Prints a message and the inputs to the word before the word has been called." } ;
HELP: leaving
{ $values
{ "str" string } }
{ $description "Prints a message and the outputs from a word after a word has been called." } ;
HELP: reset
{ $values
{ "word" word } }
{ $description "Resets any annotations on a word." }
{ $notes "This word will remove a " { $link watch } "." } ;
HELP: watch-vars
{ $values
{ "word" word } { "vars" "a sequence of symbols" } }
{ $description "Annotates a word definition to print the " { $snippet "vars" } " upon entering the word. This word is useful for debugging." } ;
HELP: word-inputs
{ $values
{ "word" word }
{ "seq" sequence } }
{ $description "Makes a sequence of the inputs to a word by counting the number of inputs in the stack effect and saving that many items from the datastack." } ;

View File

@ -4,7 +4,7 @@ USING: assocs io.files hashtables kernel namespaces sequences
vocabs.loader io combinators io.encodings.utf8 calendar accessors
math.parser io.streams.string ui.tools.operations quotations
strings arrays prettyprint words vocabs sorting sets
classes ;
classes alien ;
IN: tools.scaffold
SYMBOL: developer-name
@ -95,6 +95,7 @@ ERROR: no-vocab vocab ;
{ "obj3" object } { "obj4" object }
{ "quot" quotation } { "quot1" quotation }
{ "quot2" quotation } { "quot3" quotation }
{ "quot'" quotation }
{ "string" string } { "string1" string }
{ "string2" string } { "string3" string }
{ "str" string }
@ -105,9 +106,20 @@ ERROR: no-vocab vocab ;
{ "ch" "a character" }
{ "word" word }
{ "array" array }
{ "duration" duration }
{ "path" "a pathname string" }
{ "vocab" "a vocabulary specifier" }
{ "vocab-root" "a vocabulary root string" }
{ "c-ptr" c-ptr }
{ "seq" sequence } { "seq1" sequence } { "seq2" sequence }
{ "seq3" sequence } { "seq4" sequence }
{ "seq1'" sequence } { "seq2'" sequence }
{ "newseq" sequence }
{ "assoc" assoc } { "assoc1" assoc } { "assoc2" assoc }
{ "assoc3" assoc } { "newassoc" assoc }
{ "alist" "an array of key/value pairs" }
{ "keys" sequence } { "values" sequence }
{ "class" class }
} at* ;
: add-using ( object -- )
@ -227,3 +239,20 @@ PRIVATE>
[ drop scaffold-authors ]
[ nip require ]
} 2cleave ;
SYMBOL: examples-flag
: example ( -- )
{
"{ $example \"\" \"USING: prettyprint ;\""
" \"\""
" \"\""
"}"
} [ examples-flag get [ " " write ] when print ] each ;
: examples ( n -- )
t \ examples-flag [
"{ $examples " print
[ example ] times
"}" print
] with-variable ;

View File

@ -9,8 +9,8 @@ IN: tools.vocabs.monitor
TR: convert-separators "/\\" ".." ;
: vocab-dir>vocab-name ( path -- vocab )
left-trim-separators
right-trim-separators
trim-left-separators
trim-right-separators
convert-separators ;
: path>vocab-name ( path -- vocab )

View File

@ -136,7 +136,7 @@ PRIVATE>
: insensitive= ( str1 str2 levels-removed -- ? )
[
swap collation-key swap
[ [ 0 = not ] right-trim but-last ] times
[ [ 0 = not ] trim-right but-last ] times
] curry bi@ = ;
PRIVATE>

View File

@ -16,6 +16,10 @@ $nl
{ $subsection while }
"Generalization of " { $link bi } " and " { $link tri } ":"
{ $subsection cleave }
"Generalization of " { $link 2bi } " and " { $link 2tri } ":"
{ $subsection 2cleave }
"Generalization of " { $link 3bi } " and " { $link 3tri } ":"
{ $subsection 3cleave }
"Generalization of " { $link bi* } " and " { $link tri* } ":"
{ $subsection spread }
"Two combinators which abstract out nested chains of " { $link if } ":"
@ -50,6 +54,16 @@ HELP: cleave
}
} ;
HELP: 2cleave
{ $values { "x" object } { "y" object }
{ "seq" "a sequence of quotations with stack effect " { $snippet "( x y -- ... )" } } }
{ $description "Applies each quotation to the two objects in turn." } ;
HELP: 3cleave
{ $values { "x" object } { "y" object } { "z" object }
{ "seq" "a sequence of quotations with stack effect " { $snippet "( x y z -- ... )" } } }
{ $description "Applies each quotation to the three objects in turn." } ;
{ bi tri cleave } related-words
HELP: spread

View File

@ -13,14 +13,14 @@ IN: combinators
[ [ keep ] curry ] map concat [ drop ] append [ ] like ;
! 2cleave
: 2cleave ( x seq -- )
: 2cleave ( x y seq -- )
[ 2keep ] each 2drop ;
: 2cleave>quot ( seq -- quot )
[ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
! 3cleave
: 3cleave ( x seq -- )
: 3cleave ( x y z seq -- )
[ 3keep ] each 3drop ;
: 3cleave>quot ( seq -- quot )

View File

@ -47,11 +47,11 @@ HOOK: (file-appender) io-backend ( path -- stream )
: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
: trim-right-separators ( str -- newstr )
[ path-separator? ] trim-right ;
: left-trim-separators ( str -- newstr )
[ path-separator? ] left-trim ;
: trim-left-separators ( str -- newstr )
[ path-separator? ] trim-left ;
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last-from ;
@ -65,7 +65,7 @@ ERROR: no-parent-directory path ;
: parent-directory ( path -- parent )
dup root-directory? [
right-trim-separators
trim-right-separators
dup last-path-separator [
1+ cut
] [
@ -92,7 +92,7 @@ ERROR: no-parent-directory path ;
: append-path-empty ( path1 path2 -- path' )
{
{ [ dup head.? ] [
rest left-trim-separators append-path-empty
rest trim-left-separators append-path-empty
] }
{ [ dup head..? ] [ drop no-parent-directory ] }
[ nip ]
@ -121,19 +121,19 @@ PRIVATE>
{
{ [ over empty? ] [ append-path-empty ] }
{ [ dup empty? ] [ drop ] }
{ [ over right-trim-separators "." = ] [ nip ] }
{ [ over trim-right-separators "." = ] [ nip ] }
{ [ dup absolute-path? ] [ nip ] }
{ [ dup head.? ] [ rest left-trim-separators append-path ] }
{ [ dup head.? ] [ rest trim-left-separators append-path ] }
{ [ dup head..? ] [
2 tail left-trim-separators
2 tail trim-left-separators
>r parent-directory r> append-path
] }
{ [ over absolute-path? over first path-separator? and ] [
>r 2 head r> append
] }
[
>r right-trim-separators "/" r>
left-trim-separators 3append
>r trim-right-separators "/" r>
trim-left-separators 3append
]
} cond ;
@ -142,7 +142,7 @@ PRIVATE>
: file-name ( path -- string )
dup root-directory? [
right-trim-separators
trim-right-separators
dup last-path-separator [ 1+ tail ] [
drop "resource:" ?head [ file-name ] when
] if
@ -200,7 +200,7 @@ SYMBOL: current-directory
: (normalize-path) ( path -- path' )
"resource:" ?head [
left-trim-separators resource-path
trim-left-separators resource-path
(normalize-path)
] [
current-directory get prepend-path
@ -219,7 +219,7 @@ M: object normalize-path ( path -- path' )
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
normalize-path right-trim-separators {
normalize-path trim-right-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }

View File

@ -178,6 +178,16 @@ ARTICLE: "sequences-search" "Searching sequences"
{ $subsection find-last }
{ $subsection find-last-from } ;
ARTICLE: "sequences-trimming" "Trimming sequences"
"Trimming words:"
{ $subsection trim }
{ $subsection trim-left }
{ $subsection trim-right }
"Potentially more efficient trim:"
{ $subsection trim-slice }
{ $subsection trim-left-slice }
{ $subsection trim-right-slice } ;
ARTICLE: "sequences-destructive" "Destructive operations"
"These words modify their input, instead of creating a new sequence."
$nl
@ -245,6 +255,7 @@ $nl
{ $subsection "sequences-sorting" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
@ -731,7 +742,7 @@ HELP: reverse-here
HELP: padding
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( seq1 seq2 -- newseq )" } } { "newseq" "a new sequence" } }
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of { " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
{ $description "Outputs a new string sequence of " { $snippet "elt" } " repeated, that when appended to " { $snippet "seq" } ", yields a sequence of length " { $snippet "n" } ". If the length of " { $snippet "seq" } " is greater than " { $snippet "n" } ", this word outputs an empty sequence." } ;
HELP: pad-left
{ $values { "seq" sequence } { "n" "a non-negative integer" } { "elt" object } { "padded" "a new sequence" } }
@ -1004,3 +1015,45 @@ HELP: count
"50"
} ;
HELP: pusher
{ $values
{ "quot" "a predicate quotation" }
{ "quot" quotation } { "accum" vector } }
{ $description "Creates a new vector to accumulate the values which return true for a predicate. Returns a new quotation which accepts an object to be tested and stored in the accumulator if the test yields true. The accumulator is left on the stack for convenience." }
{ $example "! Find all the even numbers:" "USING: prettyprint sequences math kernel ;"
"10 [ even? ] pusher [ each ] dip ."
"V{ 0 2 4 6 8 }"
}
{ $notes "Used to implement the " { $link filter } " word." } ;
HELP: trim-left
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-left ."
"{ 1 2 3 0 0 }"
} ;
HELP: trim-right
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the right side of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim-right ."
"{ 0 0 1 2 3 }"
} ;
HELP: trim
{ $values
{ "seq" sequence } { "quot" quotation }
{ "newseq" sequence } }
{ $description "Removes elements starting from the left and right sides of a sequence if they match a predicate. Once an element does not match, the test stops and the rest of the sequence is left on the stack as a new sequence." }
{ $example "" "USING: prettyprint math sequences ;"
"{ 0 0 1 2 3 0 0 } [ zero? ] trim ."
"{ 1 2 3 }"
} ;
{ trim-left trim-right trim } related-words

View File

@ -237,13 +237,13 @@ unit-test
[ -1./0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test
[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test
[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-left ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-right ] unit-test
[ "" ] [ " " [ CHAR: \s = ] trim-left ] unit-test
[ "" ] [ " " [ CHAR: \s = ] trim-right ] unit-test
[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
[ "asdf " ] [ " asdf " [ CHAR: \s = ] trim-left ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] trim-right ] unit-test
[ 328350 ] [ 100 [ sq ] sigma ] unit-test

View File

@ -748,16 +748,25 @@ PRIVATE>
dup slice? [ { } like ] when 0 over length rot <slice> ;
inline
: left-trim ( seq quot -- newseq )
: trim-left-slice ( seq quot -- slice )
over >r [ not ] compose find drop r> swap
[ tail ] [ dup length tail ] if* ; inline
[ tail-slice ] [ dup length tail-slice ] if* ; inline
: trim-left ( seq quot -- newseq )
over [ trim-left-slice ] dip like ; inline
: right-trim ( seq quot -- newseq )
: trim-right-slice ( seq quot -- slice )
over >r [ not ] compose find-last drop r> swap
[ 1+ head ] [ 0 head ] if* ; inline
[ 1+ head-slice ] [ 0 head-slice ] if* ; inline
: trim-right ( seq quot -- newseq )
over [ trim-right-slice ] dip like ; inline
: trim-slice ( seq quot -- slice )
[ trim-left-slice ] [ trim-right-slice ] bi ;
: trim ( seq quot -- newseq )
[ left-trim ] [ right-trim ] bi ; inline
over [ trim-slice ] dip like ; inline
: sum ( seq -- n ) 0 [ + ] binary-reduce ;

View File

@ -22,7 +22,7 @@ PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
dup length 1 = [ [ zero? ] right-trim ] unless ;
dup length 1 = [ [ zero? ] trim-right ] unless ;
: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;

View File

@ -84,7 +84,7 @@ M: string b, ( n string -- ) heap-size b, ;
"\0" read-until [ drop f ] unless ;
: read-c-string* ( n -- str/f )
read [ zero? ] right-trim dup empty? [ drop f ] when ;
read [ zero? ] trim-right dup empty? [ drop f ] when ;
: (read-128-ber) ( n -- n )
read1

View File

@ -175,11 +175,11 @@ M: or-parser parse ( input parser1 -- list )
parsers>> 0 swap seq>list
[ parse ] lazy-map-with lconcat ;
: left-trim-slice ( string -- string )
: trim-left-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
dup first blank? [ rest-slice left-trim-slice ] when
dup first blank? [ rest-slice trim-left-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
@ -191,7 +191,7 @@ C: sp sp-parser ( p1 -- parser )
M: sp-parser parse ( input parser -- list )
#! Skip all leading whitespace from the input then call
#! the parser on the remaining input.
>r left-trim-slice r> p1>> parse ;
>r trim-left-slice r> p1>> parse ;
TUPLE: just-parser p1 ;

View File

@ -53,7 +53,7 @@ IN: project-euler.059
: source-059 ( -- seq )
"resource:extra/project-euler/059/cipher1.txt"
ascii file-contents [ blank? ] right-trim "," split
ascii file-contents [ blank? ] trim-right "," split
[ string>number ] map ;
TUPLE: rollover seq n ;

View File

@ -15,7 +15,7 @@ TR: soundex-tr
[ 2 <clumps> [ = not ] assoc-filter values ] [ first ] bi prefix ;
: first>upper ( seq -- seq' ) 1 head >upper ;
: trim-first ( seq -- seq' ) dup first [ = ] curry left-trim ;
: trim-first ( seq -- seq' ) dup first [ = ] curry trim-left ;
: remove-zeroes ( seq -- seq' ) CHAR: 0 swap remove ;
: remove-non-alpha ( seq -- seq' ) [ alpha? ] filter ;
: pad-4 ( first seq -- seq' ) "000" 3append 4 head ;

View File

@ -135,7 +135,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-L ( header -- )
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] right-trim filename set
! >string [ zero? ] trim-right filename set
! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry