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

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

db4
John Benediktsson 2009-02-27 06:37:37 -08:00
parent 01a1e8b6ee 0214dc5e7d
commit c3e07a1423
39 changed files with 298 additions and 341 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -510,3 +510,8 @@ cell-bits 32 = [
[ { array } declare 2 <groups> [ . . ] assoc-each ]
\ nth-unsafe inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare = ]
\ both-fixnums? inlined?
] unit-test

7
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -199,8 +199,11 @@ generic-comparison-ops [
] "outputs" set-word-prop
\ both-fixnums? [
[ class>> fixnum classes-intersect? not ] either?
f <literal-info> object-info ?
[ class>> ] bi@ {
{ [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
{ [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
[ object-info ]
} cond 2nip
] "outputs" set-word-prop
{

2
basis/editors/editpadlite/editpadlite.factor
View File

@ -5,7 +5,7 @@ IN: editors.editpadlite
: editpadlite-path ( -- path )
\ editpadlite-path get-global [
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
"JGsoft" [ >lower "editpadlite.exe" tail? ] find-in-program-files
[ "editpadlite.exe" ] unless*
] unless* ;

2
basis/editors/editpadpro/editpadpro.factor
View File

@ -5,7 +5,7 @@ IN: editors.editpadpro
: editpadpro-path ( -- path )
\ editpadpro-path get-global [
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
"JGsoft" [ >lower "editpadpro.exe" tail? ] find-in-program-files
[ "editpadpro.exe" ] unless*
] unless* ;

2
basis/editors/editplus/editplus.factor
View File

@ -5,7 +5,7 @@ IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
"EditPlus 2" [ "editplus.exe" tail? ] find-in-program-files
[ "editplus.exe" ] unless*
] unless* ;

2
basis/editors/emacs/emacs.factor
View File

@ -11,7 +11,7 @@ M: object default-emacsclient ( -- path ) "emacsclient" ;
: emacsclient ( file line -- )
[
{ [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
{ [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
"--no-wait" ,
number>string "+" prepend ,
,

4
basis/editors/emacs/windows/windows.factor
View File

@ -6,7 +6,7 @@ IN: editors.emacs.windows
M: windows default-emacsclient
{
[ "Emacs" t [ "emacsclientw.exe" tail? ] find-in-program-files ]
[ "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files ]
[ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ]
[ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ]
[ "emacsclient.exe" ]
} 0|| ;

2
basis/editors/emeditor/emeditor.factor
View File

@ -5,7 +5,7 @@ IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
"EmEditor" [ "EmEditor.exe" tail? ] find-in-program-files
[ "EmEditor.exe" ] unless*
] unless* ;

2
basis/editors/etexteditor/etexteditor.factor
View File

@ -6,7 +6,7 @@ IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
"e" t [ "e.exe" tail? ] find-in-program-files
"e" [ "e.exe" tail? ] find-in-program-files
[ "e" ] unless*
] unless* ;

2
basis/editors/gvim/windows/windows.factor
View File

@ -5,6 +5,6 @@ IN: editors.gvim.windows
M: windows gvim-path
\ gvim-path get-global [
"vim" t [ "gvim.exe" tail? ] find-in-program-files
"vim" [ "gvim.exe" tail? ] find-in-program-files
[ "gvim.exe" ] unless*
] unless* ;

2
basis/editors/notepadpp/notepadpp.factor
View File

@ -4,7 +4,7 @@ IN: editors.notepadpp
: notepadpp-path ( -- path )
\ notepadpp-path get-global [
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
"notepad++" [ "notepad++.exe" tail? ] find-in-program-files
[ "notepad++.exe" ] unless*
] unless* ;

4
basis/editors/scite/scite.factor
View File

@ -7,11 +7,11 @@ IN: editors.scite
: scite-path ( -- path )
\ scite-path get-global [
"Scintilla Text Editor" t
"Scintilla Text Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
[
"SciTE Source Code Editor" t
"SciTE Source Code Editor"
[ >lower "scite.exe" tail? ] find-in-program-files
] unless*
[ "scite.exe" ] unless*

2
basis/editors/ted-notepad/ted-notepad.factor
View File

@ -4,7 +4,7 @@ IN: editors.ted-notepad
: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
"TED Notepad" [ "TedNPad.exe" tail? ] find-in-program-files
[ "TedNPad.exe" ] unless*
] unless* ;

2
basis/editors/textpad/textpad.factor
View File

@ -5,7 +5,7 @@ IN: editors.textpad
: textpad-path ( -- path )
\ textpad-path get-global [
"TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
"TextPad 5" [ "TextPad.exe" tail? ] find-in-program-files
[ "TextPad.exe" ] unless*
] unless* ;

2
basis/editors/ultraedit/ultraedit.factor
View File

@ -4,7 +4,7 @@ IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
"IDM Computer Solutions" [ "uedit32.exe" tail? ] find-in-program-files
[ "uedit32.exe" ] unless*
] unless* ;

2
basis/editors/wordpad/wordpad.factor
View File

@ -4,7 +4,7 @@ IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
"Windows NT\\Accessories" t
"Windows NT\\Accessories"
[ "wordpad.exe" tail? ] find-in-program-files
] unless* ;

2
basis/hints/hints.factor
View File

@ -96,8 +96,6 @@ M: object specializer-declaration class ;
{ string string }
"specializer" set-word-prop
\ find-last-sep { string sbuf } "specializer" set-word-prop
\ >string { sbuf } "specializer" set-word-prop
\ >array { { vector } } "specializer" set-word-prop

2
basis/io/directories/search/search-docs.factor
View File

@ -38,7 +38,7 @@ HELP: find-in-directories
HELP: find-all-files
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
{ "path" "a pathname string" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;

2
basis/io/directories/search/search-tests.factor
View File

@ -5,6 +5,6 @@ IN: io.directories.search.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get t [ ] find-all-files
current-temporary-directory get [ ] find-all-files
] with-unique-directory drop [ natural-sort ] bi@ =
] unit-test

3
basis/io/directories/search/search.factor
View File

@ -51,7 +51,8 @@ PRIVATE>
[ keep and ] curry iterate-directory
] [ drop f ] recover ; inline
: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths/f )
: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
f swap
'[
_ _ _ [ <directory-iterator> ] dip
pusher [ [ f ] compose iterate-directory drop ] dip

4
basis/io/directories/search/windows/windows.factor
View File

@ -7,7 +7,7 @@ IN: io.directories.search.windows
: program-files-directories ( -- array )
program-files program-files-x86 2array harvest ; inline
: find-in-program-files ( base-directory bfs? quot -- path )
[
: find-in-program-files ( base-directory quot -- path )
t swap [
[ program-files-directories ] dip '[ _ append-path ] map
] 2dip find-in-directories ; inline

12
basis/io/mmap/mmap-tests.factor
View File

@ -1,6 +1,6 @@
USING: io io.mmap io.mmap.char io.files io.files.temp
io.directories kernel tools.test continuations sequences
io.encodings.ascii accessors ;
io.encodings.ascii accessors math ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
@ -9,3 +9,13 @@ IN: io.mmap.tests
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ "mmap-empty-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "mmap-empty-file.txt" temp-file touch-file ] unit-test
[
"mmap-empty-file.txt" temp-file [
drop
] with-mapped-file
] [ bad-mmap-size? ] must-fail-with

9
basis/io/mmap/mmap.factor
View File

@ -2,15 +2,20 @@
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
accessors system vocabs.loader combinators alien.c-types ;
accessors system vocabs.loader combinators alien.c-types
math ;
IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
HOOK: (mapped-file) os ( path length -- address handle )
ERROR: bad-mmap-size path size ;
: <mapped-file> ( path -- mmap )
[ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep
[ normalize-path ] [ file-info size>> ] bi
dup 0 <= [ bad-mmap-size ] when
[ (mapped-file) ] keep
f mapped-file boa ;
HOOK: close-mapped-file io-backend ( mmap -- )

2
basis/io/mmap/unix/unix.factor
View File

@ -9,7 +9,7 @@ IN: io.mmap.unix
:: mmap-open ( path length prot flags -- alien fd )
[
f length prot flags
path open-r/w |dispose
path open-r/w [ <fd> |dispose drop ] keep
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;

15
basis/io/streams/byte-array/byte-array.factor
View File

@ -1,5 +1,8 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private accessors ;
sequences io namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
@ -9,8 +12,16 @@ IN: io.streams.byte-array
[ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
dup encoder? [ stream>> ] when >byte-array ; inline
TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
M: byte-reader stream-read-partial stream-read ;
M: byte-reader stream-read sequence-read ;
M: byte-reader stream-read1 sequence-read1 ;
M: byte-reader stream-read-until sequence-read-until ;
M: byte-reader dispose drop ;
: <byte-reader> ( byte-array encoding -- stream )
[ >byte-vector dup reverse-here ] dip <decoder> ;
[ B{ } like 0 byte-reader boa ] dip <decoder> ;
: with-byte-reader ( byte-array encoding quot -- )
[ <byte-reader> ] dip with-input-stream* ; inline

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

@ -80,4 +80,4 @@ TUPLE: inconsistent-recursive-call-error word ;
TUPLE: unknown-primitive-error ;
: unknown-primitive-error ( -- * )
\ unknown-primitive-error inference-error ;
\ unknown-primitive-error inference-warning ;

8
basis/stack-checker/known-words/known-words.factor
View File

@ -141,9 +141,7 @@ M: object infer-call*
apply-word/effect ;
: infer-exit ( -- )
\ exit
{ integer } { } t >>terminated? <effect>
apply-word/effect ;
\ exit (( n -- * )) apply-word/effect ;
: infer-load-locals ( -- )
pop-literal nip
@ -189,7 +187,7 @@ M: object infer-call*
{ \ load-locals [ infer-load-locals ] }
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
{ \ do-primitive [ unknown-primitive-error inference-warning ] }
{ \ do-primitive [ unknown-primitive-error ] }
{ \ alien-invoke [ infer-alien-invoke ] }
{ \ alien-indirect [ infer-alien-indirect ] }
{ \ alien-callback [ infer-alien-callback ] }
@ -207,7 +205,7 @@ M: object infer-call*
{
declare call (call) slip 2slip 3slip dip 2dip 3dip
curry compose execute (execute) if dispatch <tuple-boa>
(throw) load-local load-locals get-local drop-locals do-primitive
(throw) exit load-local load-locals get-local drop-locals do-primitive
alien-invoke alien-indirect alien-callback
} [ t "special" set-word-prop ] each

8
basis/stack-checker/stack-checker-docs.factor
View File

@ -21,7 +21,7 @@ $nl
ARTICLE: "inference-combinators" "Combinator stack effects"
"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
{ $example "[ dup call ] infer." "Literal value expected\n\nType :help for debugging help." }
{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
@ -38,7 +38,7 @@ $nl
{ $example ": foo 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Literal value expected\n\nType :help for debugging help."
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
}
"To make this work, pass the quotation on the retain stack instead:"
{ $example
@ -67,11 +67,11 @@ $nl
"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
$nl
"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:"
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Literal value expected\n\nType :help for debugging help." }
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"However a small change can be made:"
{ $example ": good ( ? quot: ( ? -- ) -- ) [ good ] 2keep [ not ] dip call ; inline recursive" "[ [ drop ] good ] infer." "( object -- )" }
"An inline recursive word must have a fixed stack effect in its base case. The following will not infer:"

7
basis/stack-checker/stack-checker-tests.factor
View File

@ -6,7 +6,8 @@ quotations effects tools.test continuations generic.standard
sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators eval locals.backend ;
sequences.private destructors combinators eval locals.backend
system ;
IN: stack-checker.tests
\ infer. must-infer
@ -581,4 +582,6 @@ DEFER: eee'
: debugging-curry-folding ( quot -- )
[ debugging-curry-folding ] curry call ; inline recursive
[ [ ] debugging-curry-folding ] must-infer
[ [ ] debugging-curry-folding ] must-infer
[ [ exit ] [ 1 2 3 ] if ] must-infer

8
build-support/cleanup Normal file
View File

@ -0,0 +1,8 @@
vm
temp
logs
.git
.gitignore
Makefile
unmaintained
build-support

2
core/checksums/crc32/crc32.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences sequences.private namespaces
words io io.binary io.files io.streams.string quotations
words io io.binary io.files quotations
definitions checksums ;
IN: checksums.crc32

38
core/io/streams/sequence/sequence.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: sequences io kernel accessors math math.order ;
IN: io.streams.sequence
SLOT: underlying
SLOT: i
: >sequence-stream< ( stream -- i underlying )
[ i>> ] [ underlying>> ] bi ; inline
: next ( stream -- )
[ 1+ ] change-i drop ;
: sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ]
[ next ] bi ; inline
: add-length ( n stream -- i+n )
[ i>> + ] [ underlying>> length ] bi min ;
: (sequence-read) ( n stream -- seq/f )
[ add-length ] keep
[ [ swap dup ] change-i drop ]
[ underlying>> ] bi
subseq ; inline
: sequence-read ( n stream -- seq/f )
dup >sequence-stream< bounds-check?
[ (sequence-read) ] [ 2drop f ] if ; inline
: find-sep ( seps stream -- sep/f n )
swap [ >sequence-stream< ] dip
[ memq? ] curry find-from swap ; inline
: sequence-read-until ( separators stream -- seq sep/f )
[ find-sep ] keep
[ sequence-read ] [ next ] bi swap ; inline

10
core/io/streams/string/string-tests.factor
View File

@ -15,12 +15,12 @@ unit-test
[ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test
[ "a" ] [ 1 SBUF" cba" stream-read ] unit-test
[ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test
[ "abc" ] [ 3 SBUF" cba" stream-read ] unit-test
[ "abc" ] [ 4 SBUF" cba" stream-read ] unit-test
[ "a" ] [ 1 "abc" <string-reader> stream-read ] unit-test
[ "ab" ] [ 2 "abc" <string-reader> stream-read ] unit-test
[ "abc" ] [ 3 "abc" <string-reader> stream-read ] unit-test
[ "abc" ] [ 4 "abc" <string-reader> stream-read ] unit-test
[ "abc" f ] [
3 SBUF" cba" [ stream-read ] keep stream-read1
3 "abc" <string-reader> [ stream-read ] keep stream-read1
] unit-test
[

44
core/io/streams/string/string.factor
View File

@ -1,18 +1,12 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces sequences sbufs
strings generic splitting continuations destructors
io.streams.plain io.encodings math.order growable ;
strings generic splitting continuations destructors sequences.private
io.streams.plain io.encodings math.order growable io.streams.sequence ;
IN: io.streams.string
<PRIVATE
: harden-as ( seq growble-exemplar -- newseq )
underlying>> like ;
: growable-read-until ( growable n -- str )
>fixnum dupd tail-slice swap harden-as dup reverse-here ;
SINGLETON: null-encoding
M: null-encoding decode-char drop stream-read1 ;
@ -32,34 +26,18 @@ M: growable stream-flush drop ;
<string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline
M: growable stream-read1 [ f ] [ pop ] if-empty ;
! New implementation
: find-last-sep ( seq seps -- n )
swap [ memq? ] curry find-last drop ;
TUPLE: string-reader { underlying string read-only } { i array-capacity } ;
M: growable stream-read-until
[ find-last-sep ] keep over [
[ swap 1+ growable-read-until ] 2keep [ nth ] 2keep
set-length
] [
[ swap drop 0 growable-read-until f like f ] keep
delete-all
] if ;
M: growable stream-read
[
drop f
] [
[ length swap - 0 max ] keep
[ swap growable-read-until ] 2keep
set-length
] if-empty ;
M: growable stream-read-partial
stream-read ;
M: string-reader stream-read-partial stream-read ;
M: string-reader stream-read sequence-read ;
M: string-reader stream-read1 sequence-read1 ;
M: string-reader stream-read-until sequence-read-until ;
M: string-reader dispose drop ;
: <string-reader> ( str -- stream )
>sbuf dup reverse-here null-encoding <decoder> ;
0 string-reader boa null-encoding <decoder> ;
: with-string-reader ( str quot -- )
[ <string-reader> ] dip with-input-stream ; inline

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

@ -308,7 +308,7 @@ HELP: find-last-integer
HELP: byte-array>bignum
{ $values { "byte-array" byte-array } { "n" integer } }
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ;
{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ;
ARTICLE: "division-by-zero" "Division by zero"
"Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."

2
extra/id3/authors.txt
View File

@ -1,2 +1,2 @@
Tim Wawrzynczak
Doug Coleman

2
extra/id3/id3-docs.factor
View File

@ -6,7 +6,7 @@ IN: id3
HELP: file-id3-tags
{ $values
{ "path" "a path string" }
{ "object/f" "a tuple storing ID3 metadata or f" } }
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
$nl { $link title>> }
$nl { $link artist>> }

59
extra/id3/id3-tests.factor
View File

@ -1,35 +1,42 @@
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test id3 id3.private ;
USING: tools.test id3 combinators ;
IN: id3.tests
[
T{ id3-info
{ title "BLAH" }
{ artist "ARTIST" }
{ album "ALBUM" }
{ year "2009" }
{ comment "COMMENT" }
{ genre "Bluegrass" }
}
] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
: id3-params ( id3 -- title artist album year comment genre )
{
[ id3-title ]
[ id3-artist ]
[ id3-album ]
[ id3-year ]
[ id3-comment ]
[ id3-genre ]
} cleave ;
[
T{ id3-info
{ title "Anthem of the Trinity" }
{ artist "Terry Riley" }
{ album "Shri Camel" }
{ genre "Classical" }
}
] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
"BLAH"
"ARTIST"
"ALBUM"
"2009"
"COMMENT"
"Bluegrass"
] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
[
"Anthem of the Trinity"
"Terry Riley"
"Shri Camel"
f
f
"Classical"
] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
[
T{ id3-info
{ title "Stormy Weather" }
{ artist "Frank Sinatra" }
{ album "Night and Day Frank Sinatra" }
{ comment "eng, AG# 08E1C12E" }
{ genre "Big Band" }
}
] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
"Stormy Weather"
"Frank Sinatra"
"Night and Day Frank Sinatra"
f
"eng, AG# 08E1C12E"
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test

352
extra/id3/id3.factor
View File

@ -1,142 +1,43 @@
! Copyright (C) 2009 Tim Wawrzynczak
! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf8 assocs math.parser ;
USING: sequences io io.encodings.binary io.files io.pathnames
strings kernel math io.mmap io.mmap.uchar accessors syntax
combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays ;
IN: id3
<PRIVATE
! genres
CONSTANT: genres
H{
{ 0 "Blues" }
{ 1 "Classic Rock" }
{ 2 "Country" }
{ 3 "Dance" }
{ 4 "Disco" }
{ 5 "Funk" }
{ 6 "Grunge" }
{ 7 "Hip-Hop" }
{ 8 "Jazz" }
{ 9 "Metal" }
{ 10 "New Age" }
{ 11 "Oldies" }
{ 12 "Other" }
{ 13 "Pop" }
{ 14 "R&B" }
{ 15 "Rap" }
{ 16 "Reggae" }
{ 17 "Rock" }
{ 18 "Techno" }
{ 19 "Industrial" }
{ 20 "Alternative" }
{ 21 "Ska" }
{ 22 "Death Metal" }
{ 23 "Pranks" }
{ 24 "Soundtrack" }
{ 25 "Euro-Techno" }
{ 26 "Ambient" }
{ 27 "Trip-Hop" }
{ 28 "Vocal" }
{ 29 "Jazz+Funk" }
{ 30 "Fusion" }
{ 31 "Trance" }
{ 32 "Classical" }
{ 33 "Instrumental" }
{ 34 "Acid" }
{ 35 "House" }
{ 36 "Game" }
{ 37 "Sound Clip" }
{ 38 "Gospel" }
{ 39 "Noise" }
{ 40 "AlternRock" }
{ 41 "Bass" }
{ 42 "Soul" }
{ 43 "Punk" }
{ 44 "Space" }
{ 45 "Meditative" }
{ 46 "Instrumental Pop" }
{ 47 "Instrumental Rock" }
{ 48 "Ethnic" }
{ 49 "Gothic" }
{ 50 "Darkwave" }
{ 51 "Techno-Industrial" }
{ 52 "Electronic" }
{ 53 "Pop-Folk" }
{ 54 "Eurodance" }
{ 55 "Dream" }
{ 56 "Southern Rock" }
{ 57 "Comedy" }
{ 58 "Cult" }
{ 59 "Gangsta" }
{ 60 "Top 40" }
{ 61 "Christian Rap" }
{ 62 "Pop/Funk" }
{ 63 "Jungle" }
{ 64 "Native American" }
{ 65 "Cabaret" }
{ 66 "New Wave" }
{ 67 "Psychedelic" }
{ 68 "Rave" }
{ 69 "Showtunes" }
{ 70 "Trailer" }
{ 71 "Lo-Fi" }
{ 72 "Tribal" }
{ 73 "Acid Punk" }
{ 74 "Acid Jazz" }
{ 75 "Polka" }
{ 76 "Retro" }
{ 77 "Musical" }
{ 78 "Rock & Roll" }
{ 79 "Hard Rock" }
{ 80 "Folk" }
{ 81 "Folk-Rock" }
{ 82 "National Folk" }
{ 83 "Swing" }
{ 84 "Fast Fusion" }
{ 85 "Bebop" }
{ 86 "Latin" }
{ 87 "Revival" }
{ 88 "Celtic" }
{ 89 "Bluegrass" }
{ 90 "Avantgarde" }
{ 91 "Gothic Rock" }
{ 92 "Progressive Rock" }
{ 93 "Psychedelic Rock" }
{ 94 "Symphonic Rock" }
{ 95 "Slow Rock" }
{ 96 "Big Band" }
{ 97 "Chorus" }
{ 98 "Easy Listening" }
{ 99 "Acoustic" }
{ 100 "Humour" }
{ 101 "Speech" }
{ 102 "Chanson" }
{ 103 "Opera" }
{ 104 "Chamber Music" }
{ 105 "Sonata" }
{ 106 "Symphony" }
{ 107 "Booty Bass" }
{ 108 "Primus" }
{ 109 "Porn Groove" }
{ 110 "Satire" }
{ 111 "Slow Jam" }
{ 112 "Club" }
{ 113 "Tango" }
{ 114 "Samba" }
{ 115 "Folklore" }
{ 116 "Ballad" }
{ 117 "Power Ballad" }
{ 118 "Rhythmic Soul" }
{ 119 "Freestyle" }
{ 120 "Duet" }
{ 121 "Punk Rock" }
{ 122 "Drum Solo" }
{ 123 "A capella" }
{ 124 "Euro-House" }
{ 125 "Dance Hall" }
} ! end genre hashtable
! tuples
{
"Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk"
"Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other"
"Pop" "R&B" "Rap" "Reggae" "Rock" "Techno" "Industrial"
"Alternative" "Ska" "Death Metal" "Pranks" "Soundtrack"
"Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk"
"Fusion" "Trance" "Classical" "Instrumental" "Acid" "House"
"Game" "Sound Clip" "Gospel" "Noise" "AlternRock" "Bass"
"Soul" "Punk" "Space" "Meditative" "Instrumental Pop"
"Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
"Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance"
"Dream" "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40"
"Christian Rap" "Pop/Funk" "Jungle" "Native American"
"Cabaret" "New Wave" "Psychedelic" "Rave" "Showtunes"
"Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka"
"Retro" "Musical" "Rock & Roll" "Hard Rock" "Folk"
"Folk-Rock" "National Folk" "Swing" "Fast Fusion" "Bebop"
"Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
"Gothic Rock" "Progressive Rock" "Psychedelic Rock"
"Symphonic Rock" "Slow Rock" "Big Band" "Chorus"
"Easy Listening" "Acoustic" "Humour" "Speech" "Chanson"
"Opera" "Chamber Music" "Sonata" "Symphony" "Booty Bass"
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
"Euro-House" "Dance Hall"
}
TUPLE: header version flags size ;
@ -144,63 +45,72 @@ TUPLE: frame frame-id flags size data ;
TUPLE: id3v2-info header frames ;
TUPLE: id3-info title artist album year comment genre ;
TUPLE: id3v1-info title artist album year comment genre ;
: <id3-info> ( -- object ) id3-info new ;
: <id3v1-info> ( -- object ) id3v1-info new ;
: <id3v2-info> ( header frames -- object ) id3v2-info boa ;
: <id3v2-info> ( header frames -- object )
[ [ frame-id>> ] keep ] H{ } map>assoc
id3v2-info boa ;
: <header> ( -- object ) header new ;
: <frame> ( -- object ) frame new ;
! utility words
: id3v2? ( mmap -- ? )
"ID3" head? ;
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
: id3v1? ( mmap -- ? )
128 tail-slice* "TAG" head? ;
{ [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
: id3v1-frame ( string key -- frame )
<frame>
swap >>frame-id
swap >>data ;
: id3v1>id3v2 ( id3v1 -- id3v2 )
[
{
[ title>> "TIT2" id3v1-frame ]
[ artist>> "TPE1" id3v1-frame ]
[ album>> "TALB" id3v1-frame ]
[ year>> "TYER" id3v1-frame ]
[ comment>> "COMM" id3v1-frame ]
[ genre>> "TCON" id3v1-frame ]
} cleave
] output>array f swap <id3v2-info> ;
: >28bitword ( seq -- int )
0 [ swap 7 shift bitor ] reduce ;
0 [ [ 7 shift ] dip bitor ] reduce ; inline
: filter-text-data ( data -- filtered )
[ printable? ] filter ;
! frame details stuff
[ printable? ] filter ; inline
: valid-frame-id? ( id -- ? )
[ [ digit? ] [ LETTER? ] bi or ] all? ;
: read-frame-id ( mmap -- id )
4 head-slice ;
: read-frame-size ( mmap -- size )
[ 4 8 ] dip subseq ;
: read-frame-flags ( mmap -- flags )
[ 8 10 ] dip subseq ;
[ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
: read-frame-data ( frame mmap -- frame data )
[ 10 over size>> 10 + ] dip <slice> filter-text-data ;
[ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
! read whole frames
: decode-text ( string -- string' )
dup 2 short head
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
utf16 ascii ? decode ; inline
: (read-frame) ( mmap -- frame )
[ <frame> ] dip
{
[ read-frame-id utf8 decode >>frame-id ]
[ read-frame-flags >byte-array >>flags ]
[ read-frame-size >28bitword >>size ]
[ read-frame-data utf8 decode >>data ]
[ 4 head-slice decode-text >>frame-id ]
[ [ 4 8 ] dip subseq >28bitword >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
} cleave ;
: read-frame ( mmap -- frame/f )
dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ;
dup 4 head-slice valid-frame-id?
[ (read-frame) ] [ drop f ] if ;
: remove-frame ( mmap frame -- mmap )
size>> 10 + tail-slice ;
size>> 10 + tail-slice ; inline
: read-frames ( mmap -- frames )
[ dup read-frame dup ]
@ -209,89 +119,71 @@ TUPLE: id3-info title artist album year comment genre ;
! header stuff
: read-header-supported-version? ( mmap -- ? )
3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ;
: read-header-flags ( mmap -- flags )
5 swap nth ;
: read-header-size ( mmap -- size )
[ 6 10 ] dip <slice> >28bitword ;
: read-v2-header ( mmap -- id3header )
: read-v2-header ( seq -- id3header )
[ <header> ] dip
{
[ read-header-supported-version? >>version ]
[ read-header-flags >>flags ]
[ read-header-size >>size ]
} cleave ;
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
[ [ 6 10 ] dip <slice> >28bitword >>size ]
} cleave ; inline
: drop-header ( mmap -- seq1 seq2 )
dup 10 tail-slice swap ;
: parse-frames ( id3v2-info -- id3-info )
[ <id3-info> ] dip frames>>
{
[ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ]
[ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ]
[ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ]
[ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when*
>>genre ] when* ]
[ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ]
[ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ]
} cleave ;
: read-v2-tag-data ( seq -- id3-info )
drop-header read-v2-header swap read-frames <id3v2-info> parse-frames ;
: read-v2-tag-data ( seq -- id3v2-info )
10 cut-slice
[ read-v2-header ]
[ read-frames ] bi* <id3v2-info> ; inline
! v1 information
: skip-to-v1-data ( seq -- seq )
125 tail-slice* ;
: read-title ( seq -- title )
30 head-slice ;
: read-artist ( seq -- title )
[ 30 60 ] dip subseq ;
: read-album ( seq -- album )
[ 60 90 ] dip subseq ;
: read-year ( seq -- year )
[ 90 94 ] dip subseq ;
: read-comment ( seq -- comment )
[ 94 124 ] dip subseq ;
: read-genre ( seq -- genre )
[ 124 ] dip nth ;
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
: (read-v1-tag-data) ( seq -- mp3-file )
[ <id3-info> ] dip
[ <id3v1-info> ] dip
{
[ read-title utf8 decode filter-text-data >>title ]
[ read-artist utf8 decode filter-text-data >>artist ]
[ read-album utf8 decode filter-text-data >>album ]
[ read-year utf8 decode filter-text-data >>year ]
[ read-comment utf8 decode filter-text-data >>comment ]
[ read-genre >fixnum genres at >>genre ]
} cleave ;
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
[ [ 60 90 ] dip subseq decode-text filter-text-data >>album ]
[ [ 90 94 ] dip subseq decode-text filter-text-data >>year ]
[ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ]
[ [ 124 ] dip nth number>string >>genre ]
} cleave ; inline
: read-v1-tag-data ( seq -- mp3-file )
skip-to-v1-data (read-v1-tag-data) ;
skip-to-v1-data (read-v1-tag-data) ; inline
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
string>number dup number? [
genres ?nth swap or
] [
drop
] if ; inline
PRIVATE>
! public interface
: frame-named ( id3 name quot -- obj )
[ swap frames>> at* ] dip
[ data>> ] prepose [ drop f ] if ; inline
: file-id3-tags ( path -- object/f )
: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
: id3-genre ( id3 -- genre/f )
"TCON" [ parse-genre ] frame-named ; inline
: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
: file-id3-tags ( path -- id3v2-info/f )
[
{
{ [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 )
{ [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info )
[ drop f ] ! ( mmap -- f )
{ [ dup id3v2? ] [ read-v2-tag-data ] }
{ [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
[ drop f ]
} cond
] with-mapped-uchar-file ;
! end