Merge branch 'master' into fortran
Joe Groff
commit
d41c1f2b09
basis
alien/c-types
cocoa/messages
compiler/tree/propagation/inlining
furnace/utilities
help/lint
html/templates
chloe
compiler
fhtml
io
backend
unix
windows/nt
ports
mime/multipart
pack
persistent/deques
ui
tools/interactor
unix
windows/kernel32
xml/writer
core
extra
graphics/tiff
promises
websites/concatenative
unmaintained/openal
14
README.txt
14
README.txt
|
|
@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
|
|||
|
||||
* Running Factor on Windows XP/Vista
|
||||
|
||||
The Factor runtime is compiled into two binaries:
|
||||
|
||||
factor.com - a Windows console application
|
||||
factor.exe - a Windows native application, without a console
|
||||
|
||||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt:
|
||||
the command prompt using the console application:
|
||||
|
||||
factor.exe -i=boot.<cpu>.image
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor.exe -run=listener
|
||||
factor.com -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry ;
|
||||
accessors combinators effects continuations fry call ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -258,7 +258,7 @@ M: long-long-type box-return ( type -- )
|
|||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> { } swap with-datastack first
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
|
|
|
|||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations effects words ;
|
||||
IN: call
|
||||
|
||||
ABOUT: "call"
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection call-effect }
|
||||
{ $subsection execute-effect } ;
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "[ ] call( foo -- bar )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "word execute( foo -- bar )" }
|
||||
{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
{ execute-effect call-effect } related-words
|
||||
{ POSTPONE: call( POSTPONE: execute( } related-words
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call kernel ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences generalizations accessors
|
||||
continuations effects.parser parser words ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call(
|
||||
")" parse-effect parsed \ call-effect parsed ; parsing
|
||||
|
||||
: execute-effect ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ; inline
|
||||
|
||||
: execute(
|
||||
")" parse-effect parsed \ execute-effect parsed ; parsing
|
||||
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math
|
|||
namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private parser lexer init core-foundation fry
|
||||
generalizations specialized-arrays.direct.alien ;
|
||||
generalizations specialized-arrays.direct.alien call ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -83,7 +83,7 @@ class-init-hooks global [ H{ } clone or ] change-at
|
|||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
drop over class-init-hooks get at [ assert-depth ] when*
|
||||
drop over class-init-hooks get at [ call( -- ) ] when*
|
||||
2dup execute dup [ 2nip ] [
|
||||
2drop "No such class: " prepend throw
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
|
@ -181,8 +181,9 @@ SYMBOL: history
|
|||
"custom-inlining" word-prop ;
|
||||
|
||||
: inline-custom ( #call word -- ? )
|
||||
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
|
||||
first object swap eliminate-dispatch ;
|
||||
[ dup ] [ "custom-inlining" word-prop ] bi*
|
||||
call( #call -- word/quot/f )
|
||||
object swap eliminate-dispatch ;
|
||||
|
||||
: inline-instance-check ( #call word -- ? )
|
||||
over in-d>> second value-info literal>> dup class?
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel namespaces tools.test endian ;
|
||||
IN: endian.tests
|
||||
|
||||
[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test
|
||||
[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
kernel math ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
||||
: native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
native-endianness \ native-endianness set-global
|
||||
|
||||
SYMBOL: endianness
|
||||
|
||||
\ native-endianness get-global endianness set-global
|
||||
|
||||
HOOK: >native-endian native-endianness ( obj n -- str )
|
||||
|
||||
M: big-endian >native-endian >be ;
|
||||
|
||||
M: little-endian >native-endian >le ;
|
||||
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
|
||||
|
||||
M: big-endian unsigned-native-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-native-endian> le> ;
|
||||
|
||||
: signed-native-endian> ( obj n -- str )
|
||||
[ unsigned-native-endian> ] dip >signed ;
|
||||
|
||||
HOOK: >endian endianness ( obj n -- str )
|
||||
|
||||
M: big-endian >endian >be ;
|
||||
|
||||
M: little-endian >endian >le ;
|
||||
|
||||
HOOK: endian> endianness ( seq -- n )
|
||||
|
||||
M: big-endian endian> be> ;
|
||||
|
||||
M: little-endian endian> le> ;
|
||||
|
||||
HOOK: unsigned-endian> endianness ( obj -- str )
|
||||
|
||||
M: big-endian unsigned-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-endian> le> ;
|
||||
|
||||
: signed-endian> ( obj n -- str )
|
||||
[ unsigned-endian> ] dip >signed ;
|
||||
|
||||
: with-endianness ( endian quot -- )
|
||||
[ endianness ] dip with-variable ; inline
|
||||
|
||||
: with-big-endian ( quot -- )
|
||||
big-endian swap with-endianness ; inline
|
||||
|
||||
: with-little-endian ( quot -- )
|
||||
little-endian swap with-endianness ; inline
|
||||
|
||||
: with-native-endian ( quot -- )
|
||||
\ native-endianness get-global swap with-endianness ; inline
|
||||
|
|
@ -27,7 +27,7 @@ HELP: hidden-form-field
|
|||
{ $example
|
||||
"USING: furnace.utilities io ;"
|
||||
"\"bar\" \"foo\" hidden-form-field nl"
|
||||
"<input type=\"hidden\" name=\"foo\" value=\"bar\"/>"
|
||||
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,10 @@ HELP: narray
|
|||
|
||||
{ nsequence narray } related-words
|
||||
|
||||
HELP: nsum
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
|
||||
|
||||
HELP: firstn
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link first } ", "
|
||||
|
|
@ -238,6 +242,11 @@ HELP: ncleave
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nspread
|
||||
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
|
||||
{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
|
||||
} ;
|
||||
|
||||
HELP: mnswap
|
||||
{ $values { "m" integer } { "n" integer } }
|
||||
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
|
||||
|
|
@ -250,6 +259,17 @@ HELP: mnswap
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nweave
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel generalizations prettyprint ;"
|
||||
"\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
|
||||
"{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: n*quot
|
||||
{ $values
|
||||
{ "n" integer } { "seq" sequence }
|
||||
|
|
@ -299,18 +319,14 @@ HELP: ntuck
|
|||
}
|
||||
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
$nl
|
||||
"Generalized sequence operations:"
|
||||
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
|
||||
{ $subsection narray }
|
||||
{ $subsection nsequence }
|
||||
{ $subsection firstn }
|
||||
{ $subsection nappend }
|
||||
{ $subsection nappend-as }
|
||||
"Generated stack shuffle operations:"
|
||||
{ $subsection nappend-as } ;
|
||||
|
||||
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
|
|
@ -319,14 +335,28 @@ $nl
|
|||
{ $subsection ndrop }
|
||||
{ $subsection ntuck }
|
||||
{ $subsection mnswap }
|
||||
"Generalized combinators:"
|
||||
{ $subsection nweave } ;
|
||||
|
||||
ARTICLE: "combinator-generalizations" "Generalized combinators"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
{ $subsection ncleave }
|
||||
"Generalized quotation construction:"
|
||||
{ $subsection nspread } ;
|
||||
|
||||
ARTICLE: "other-generalizations" "Additional generalizations"
|
||||
{ $subsection ncurry }
|
||||
{ $subsection nwith } ;
|
||||
{ $subsection nwith }
|
||||
{ $subsection nsum } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
{ $subsection "sequence-generalizations" }
|
||||
{ $subsection "shuffle-generalizations" }
|
||||
{ $subsection "combinator-generalizations" }
|
||||
{ $subsection "other-generalizations" } ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
|
|||
|
|
@ -53,3 +53,12 @@ IN: generalizations.tests
|
|||
|
||||
[ 4 nappend ] must-infer
|
||||
[ 4 { } nappend-as ] must-infer
|
||||
|
||||
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
|
||||
{ 4 1 } [ 4 nsum ] must-infer-as
|
||||
|
||||
[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
|
||||
{ 3 5 } [ 2 nweave ] must-infer-as
|
||||
|
||||
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
|
||||
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
|
||||
! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
|
||||
! Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private math combinators
|
||||
|
|
@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- )
|
|||
MACRO: narray ( n -- )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
||||
MACRO: nsum ( n -- )
|
||||
1- [ + ] n*quot ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
|
||||
|
|
@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- )
|
|||
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
|
||||
compose ;
|
||||
|
||||
MACRO: nspread ( quots n -- )
|
||||
over empty? [ 2drop [ ] ] [
|
||||
[ [ but-last ] dip ]
|
||||
[ [ peek ] dip ] 2bi
|
||||
swap
|
||||
'[ [ _ _ nspread ] _ ndip @ ]
|
||||
] if ;
|
||||
|
||||
MACRO: napply ( quot n -- )
|
||||
swap <repetition> spread>quot ;
|
||||
|
||||
MACRO: mnswap ( m n -- )
|
||||
1+ '[ _ -nrot ] <repetition> spread>quot ;
|
||||
1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
|
||||
|
||||
MACRO: nweave ( n -- )
|
||||
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
||||
: nappend-as ( n exemplar -- seq )
|
||||
[ narray concat ] dip like ; inline
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger
|
|||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep ;
|
||||
sequences.deep call ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
|
|
@ -15,9 +15,9 @@ SYMBOL: vocabs-quot
|
|||
: check-example ( element -- )
|
||||
[
|
||||
rest [
|
||||
but-last "\n" join 1vector
|
||||
[ (eval>string) ] with-datastack
|
||||
peek "\n" ?tail drop
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call ;
|
||||
|
|
@ -145,7 +145,7 @@ M: help-error error.
|
|||
bi ;
|
||||
|
||||
: check-something ( obj quot -- )
|
||||
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
|
||||
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
|
||||
|
||||
: check-word ( word -- )
|
||||
[ with-file-vocabs ] vocabs-quot set
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging continuations
|
||||
logging call
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
|
|
@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ;
|
|||
template-cache get clear-assoc ;
|
||||
|
||||
M: chloe call-template*
|
||||
template-quot assert-depth ;
|
||||
template-quot call( -- ) ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax continuations ;
|
||||
xml.writer xml.data xml.entities html.forms call
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
|
|
@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: compile-chloe-tag ( tag -- )
|
||||
dup main>> dup tags get at
|
||||
[ curry assert-depth ]
|
||||
[ call( tag -- ) ]
|
||||
[ unknown-chloe-tag ]
|
||||
?if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
assocs fry vocabs.parser parser lexer io io.files call
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
|
@ -72,6 +72,6 @@ TUPLE: fhtml path ;
|
|||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[ _ path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
[ path>> utf8 file-contents eval-template ] call( filename -- ) ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
|
|||
|
|
@ -46,6 +46,15 @@ M: fd cancel-operation ( fd -- )
|
|||
2bi
|
||||
] if ;
|
||||
|
||||
M: unix seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ io:seek-absolute [ SEEK_SET ] }
|
||||
{ io:seek-relative [ SEEK_CUR ] }
|
||||
{ io:seek-end [ SEEK_END ] }
|
||||
[ io:bad-seek-type ]
|
||||
} case
|
||||
[ fd>> swap ] dip lseek io-error ;
|
||||
|
||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
|
|
|
|||
|
|
@ -82,6 +82,24 @@ M: winnt init-io ( -- )
|
|||
H{ } clone pending-overlapped set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
||||
ERROR: invalid-file-size n ;
|
||||
|
||||
: handle>file-size ( handle -- n )
|
||||
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
|
||||
|
||||
ERROR: seek-before-start n ;
|
||||
|
||||
: set-seek-ptr ( n handle -- )
|
||||
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
|
||||
|
||||
M: winnt seek-handle ( n seek-type handle -- )
|
||||
swap {
|
||||
{ seek-absolute [ set-seek-ptr ] }
|
||||
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
|
||||
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
|
||||
[ bad-seek-type ]
|
||||
} case ;
|
||||
|
||||
: file-error? ( n -- eof? )
|
||||
zero? [
|
||||
GetLastError {
|
||||
|
|
|
|||
|
|
@ -120,6 +120,18 @@ M: output-port stream-write
|
|||
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
HOOK: seek-handle os ( n seek-type handle -- )
|
||||
|
||||
M: input-port stream-seek ( n seek-type stream -- )
|
||||
[ check-disposed ]
|
||||
[ buffer>> 0 swap buffer-reset ]
|
||||
[ handle>> seek-handle ] tri ;
|
||||
|
||||
M: output-port stream-seek ( n seek-type stream -- )
|
||||
[ check-disposed ]
|
||||
[ stream-flush ]
|
||||
[ handle>> seek-handle ] tri ;
|
||||
|
||||
GENERIC: shutdown ( handle -- )
|
||||
|
||||
M: object shutdown drop ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
! Copyright (C) 2006 Matthew Willis and Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
USING: lists lists.lazy tools.test kernel math io sequences ;
|
||||
IN: lists.lazy.tests
|
||||
|
||||
|
|
@ -27,3 +26,10 @@ IN: lists.lazy.tests
|
|||
[ { 4 5 6 } ] [
|
||||
3 { 1 2 3 } >list [ + ] lazy-map-with list>array
|
||||
] unit-test
|
||||
|
||||
[ [ ] lmap ] must-infer
|
||||
[ [ ] lmap>array ] must-infer
|
||||
[ [ drop ] foldr ] must-infer
|
||||
[ [ drop ] foldl ] must-infer
|
||||
[ [ drop ] leach ] must-infer
|
||||
[ lnth ] must-infer
|
||||
|
|
@ -1,12 +1,7 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
! Updated by James Cash, June 2008
|
||||
!
|
||||
USING: kernel sequences math vectors arrays namespaces make
|
||||
quotations promises combinators io lists accessors ;
|
||||
quotations promises combinators io lists accessors call ;
|
||||
IN: lists.lazy
|
||||
|
||||
M: promise car ( promise -- car )
|
||||
|
|
@ -86,7 +81,7 @@ C: <lazy-map> lazy-map
|
|||
|
||||
M: lazy-map car ( lazy-map -- car )
|
||||
[ cons>> car ] keep
|
||||
quot>> call ;
|
||||
quot>> call( old -- new ) ;
|
||||
|
||||
M: lazy-map cdr ( lazy-map -- cdr )
|
||||
[ cons>> cdr ] keep
|
||||
|
|
@ -130,7 +125,7 @@ M: lazy-until car ( lazy-until -- car )
|
|||
cons>> car ;
|
||||
|
||||
M: lazy-until cdr ( lazy-until -- cdr )
|
||||
[ cons>> uncons ] keep quot>> tuck call
|
||||
[ cons>> uncons ] keep quot>> tuck call( elt -- ? )
|
||||
[ 2drop nil ] [ luntil ] if ;
|
||||
|
||||
M: lazy-until nil? ( lazy-until -- bool )
|
||||
|
|
@ -150,7 +145,7 @@ M: lazy-while cdr ( lazy-while -- cdr )
|
|||
[ cons>> cdr ] keep quot>> lwhile ;
|
||||
|
||||
M: lazy-while nil? ( lazy-while -- bool )
|
||||
[ car ] keep quot>> call not ;
|
||||
[ car ] keep quot>> call( elt -- ? ) not ;
|
||||
|
||||
TUPLE: lazy-filter cons quot ;
|
||||
|
||||
|
|
@ -160,7 +155,7 @@ C: <lazy-filter> lazy-filter
|
|||
over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
|
||||
|
||||
: car-filter? ( lazy-filter -- ? )
|
||||
[ cons>> car ] [ quot>> ] bi call ;
|
||||
[ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
|
||||
|
||||
: skip ( lazy-filter -- )
|
||||
dup cons>> cdr >>cons drop ;
|
||||
|
|
@ -221,7 +216,7 @@ M: lazy-from-by car ( lazy-from-by -- car )
|
|||
|
||||
M: lazy-from-by cdr ( lazy-from-by -- cdr )
|
||||
[ n>> ] keep
|
||||
quot>> dup slip lfrom-by ;
|
||||
quot>> [ call( old -- new ) ] keep lfrom-by ;
|
||||
|
||||
M: lazy-from-by nil? ( lazy-from-by -- bool )
|
||||
drop f ;
|
||||
|
|
@ -355,7 +350,8 @@ M: lazy-io car ( lazy-io -- car )
|
|||
dup car>> dup [
|
||||
nip
|
||||
] [
|
||||
drop dup stream>> over quot>> call
|
||||
drop dup stream>> over quot>>
|
||||
call( stream -- value )
|
||||
>>car
|
||||
] if ;
|
||||
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors math arrays vectors classes words locals ;
|
||||
|
||||
IN: lists
|
||||
|
||||
! List Protocol
|
||||
|
|
@ -46,7 +45,7 @@ M: object nil? drop f ;
|
|||
: 2car ( cons -- car caar )
|
||||
[ car ] [ cdr car ] bi ;
|
||||
|
||||
: 3car ( cons -- car caar caaar )
|
||||
: 3car ( cons -- car cadr caddr )
|
||||
[ car ] [ cdr car ] [ cdr cdr car ] tri ;
|
||||
|
||||
: lnth ( n list -- elt )
|
||||
|
|
@ -109,4 +108,4 @@ M: object nil? drop f ;
|
|||
[ 2over call [ tuck [ call ] 2dip ] when
|
||||
pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive
|
||||
|
||||
INSTANCE: cons list
|
||||
INSTANCE: cons list
|
||||
|
|
@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ;
|
|||
[ t >>end-of-stream? ] if* ;
|
||||
|
||||
: maybe-fill-bytes ( multipart -- multipart )
|
||||
dup bytes>> [ fill-bytes ] unless ;
|
||||
dup bytes>> length 256 < [ fill-bytes ] when ;
|
||||
|
||||
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
||||
dupd [ length ] bi@ 1- - short cut-slice swap ;
|
||||
|
|
@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ;
|
|||
[ dump-until-separator ] with-string-writer ;
|
||||
|
||||
: read-header ( multipart -- multipart )
|
||||
maybe-fill-bytes
|
||||
dup bytes>> "--\r\n" sequence= [
|
||||
t >>end-of-stream?
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces
|
|||
make parser prettyprint quotations sequences strings vectors
|
||||
words macros math.functions math.bitwise fry generalizations
|
||||
combinators.smart io.streams.byte-array io.encodings.binary
|
||||
math.vectors combinators multiline ;
|
||||
math.vectors combinators multiline endian ;
|
||||
IN: pack
|
||||
|
||||
SYMBOL: big-endian
|
||||
|
||||
: big-endian? ( -- ? )
|
||||
1 <int> *char zero? ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: set-big-endian ( -- )
|
||||
big-endian? big-endian set ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
: >endian ( obj n -- str )
|
||||
big-endian get [ >be ] [ >le ] if ; inline
|
||||
|
||||
: unsigned-endian> ( obj -- str )
|
||||
big-endian get [ be> ] [ le> ] if ; inline
|
||||
|
||||
: signed-endian> ( obj n -- str )
|
||||
[ unsigned-endian> ] dip >signed ;
|
||||
|
||||
GENERIC: >n-byte-array ( obj n -- byte-array )
|
||||
|
||||
M: integer >n-byte-array ( m n -- byte-array ) >endian ;
|
||||
|
|
@ -124,13 +100,13 @@ PRIVATE>
|
|||
[ ch>packed-length ] sigma ;
|
||||
|
||||
: pack-native ( seq str -- seq )
|
||||
[ set-big-endian pack ] with-scope ; inline
|
||||
'[ _ _ pack ] with-native-endian ; inline
|
||||
|
||||
: pack-be ( seq str -- seq )
|
||||
[ big-endian on pack ] with-scope ; inline
|
||||
'[ _ _ pack ] with-big-endian ; inline
|
||||
|
||||
: pack-le ( seq str -- seq )
|
||||
[ big-endian off pack ] with-scope ; inline
|
||||
'[ _ _ pack ] with-little-endian ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -146,13 +122,13 @@ MACRO: unpack ( str -- quot )
|
|||
PRIVATE>
|
||||
|
||||
: unpack-native ( seq str -- seq )
|
||||
[ set-big-endian unpack ] with-scope ; inline
|
||||
'[ _ _ unpack ] with-native-endian ; inline
|
||||
|
||||
: unpack-be ( seq str -- seq )
|
||||
[ big-endian on unpack ] with-scope ; inline
|
||||
'[ _ _ unpack ] with-big-endian ; inline
|
||||
|
||||
: unpack-le ( seq str -- seq )
|
||||
[ big-endian off unpack ] with-scope ; inline
|
||||
'[ _ _ unpack ] with-little-endian ; inline
|
||||
|
||||
ERROR: packed-read-fail str bytes ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyback (C) 2008 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math ;
|
||||
USING: kernel accessors math lists ;
|
||||
QUALIFIED: sequences
|
||||
IN: persistent.deques
|
||||
|
||||
|
|
@ -9,25 +9,23 @@ IN: persistent.deques
|
|||
! same source, it could take O(m) amortized time per update.
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: cons { car read-only } { cdr read-only } ;
|
||||
C: <cons> cons
|
||||
|
||||
: each ( list quot: ( elt -- ) -- )
|
||||
over
|
||||
[ [ [ car>> ] dip call ] [ [ cdr>> ] dip ] 2bi each ]
|
||||
[ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ]
|
||||
[ 2drop ] if ; inline recursive
|
||||
|
||||
: reduce ( list start quot -- end )
|
||||
swapd each ; inline
|
||||
|
||||
: reverse ( list -- reversed )
|
||||
f [ swap <cons> ] reduce ;
|
||||
f [ swap cons ] reduce ;
|
||||
|
||||
: length ( list -- length )
|
||||
0 [ drop 1+ ] reduce ;
|
||||
|
||||
: cut ( list index -- back front-reversed )
|
||||
f swap [ [ [ cdr>> ] [ car>> ] bi ] dip <cons> ] times ;
|
||||
f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ;
|
||||
|
||||
: split-reverse ( list -- back-reversed front )
|
||||
dup length 2/ cut [ reverse ] bi@ ;
|
||||
|
|
@ -49,7 +47,7 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
: push ( item deque -- newdeque )
|
||||
[ front>> <cons> ] [ back>> ] bi deque boa ; inline
|
||||
[ front>> cons ] [ back>> ] bi deque boa ; inline
|
||||
PRIVATE>
|
||||
|
||||
: push-front ( deque item -- newdeque )
|
||||
|
|
@ -60,7 +58,7 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
: remove ( deque -- item newdeque )
|
||||
[ front>> car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline
|
||||
[ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline
|
||||
|
||||
: transfer ( deque -- item newdeque )
|
||||
back>> [ split-reverse deque boa remove ]
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ hashtables io io.styles kernel math math.order math.vectors
|
|||
models models.delay namespaces parser lexer prettyprint
|
||||
quotations sequences strings threads listener classes.tuple
|
||||
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures call
|
||||
definitions calendar concurrency.flags concurrency.mailboxes
|
||||
ui.tools.workspace accessors sets destructors fry vocabs.parser ;
|
||||
IN: ui.tools.interactor
|
||||
|
|
@ -82,8 +82,7 @@ M: interactor model-changed
|
|||
mailbox>> mailbox-put ;
|
||||
|
||||
: clear-input ( interactor -- )
|
||||
#! The with-datastack is a kludge to make it infer. Stupid.
|
||||
model>> 1array [ clear-doc ] with-datastack drop ;
|
||||
model>> [ clear-doc ] call( model -- ) ;
|
||||
|
||||
: interactor-finish ( interactor -- )
|
||||
[ editor-string ] keep
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make
|
|||
dlists deques sequences threads sequences words ui.gadgets
|
||||
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
|
||||
ui.render continuations init combinators hashtables
|
||||
concurrency.flags sets accessors calendar ;
|
||||
concurrency.flags sets accessors calendar call ;
|
||||
IN: ui
|
||||
|
||||
! Assoc mapping aliens to gadgets
|
||||
|
|
@ -140,7 +140,7 @@ SYMBOL: ui-hook
|
|||
layout-queued
|
||||
redraw-worlds
|
||||
send-queued-gestures
|
||||
] assert-depth
|
||||
] call( -- )
|
||||
] [ ui-error ] recover ;
|
||||
|
||||
SYMBOL: ui-thread
|
||||
|
|
|
|||
|
|
@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0
|
|||
CONSTANT: MAP_SHARED 1
|
||||
CONSTANT: MAP_PRIVATE 2
|
||||
|
||||
CONSTANT: SEEK_SET 0
|
||||
CONSTANT: SEEK_CUR 1
|
||||
CONSTANT: SEEK_END 2
|
||||
|
||||
: MAP_FAILED ( -- alien ) -1 <alien> ; inline
|
||||
|
||||
CONSTANT: NGROUPS_MAX 16
|
||||
|
|
|
|||
|
|
@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW
|
|||
|
||||
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
|
||||
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ;
|
||||
! FUNCTION: GetFileSizeEx
|
||||
FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ;
|
||||
FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ;
|
||||
FUNCTION: DWORD GetFileType ( HANDLE hFile ) ;
|
||||
! FUNCTION: GetFirmwareEnvironmentVariableA
|
||||
|
|
|
|||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup strings math ;
|
||||
IN: wrap.strings
|
||||
|
||||
ABOUT: "wrap.strings"
|
||||
|
||||
ARTICLE: "wrap.strings" "String word wrapping"
|
||||
"The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font."
|
||||
{ $subsection wrap-lines }
|
||||
{ $subsection wrap-string }
|
||||
{ $subsection wrap-indented-string } ;
|
||||
|
||||
HELP: wrap-lines
|
||||
{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
|
||||
{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
|
||||
|
||||
HELP: wrap-string
|
||||
{ $values { "string" string } { "width" integer } { "newstring" string } }
|
||||
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
|
||||
|
||||
HELP: wrap-indented-string
|
||||
{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
|
||||
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
|
||||
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: wrap.strings tools.test multiline ;
|
||||
IN: wrap.strings.tests
|
||||
|
||||
[
|
||||
<" This is a
|
||||
long piece
|
||||
of text
|
||||
that we
|
||||
wish to
|
||||
word wrap.">
|
||||
] [
|
||||
<" This is a long piece of text that we wish to word wrap."> 10
|
||||
wrap-string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<" This is a
|
||||
long piece
|
||||
of text
|
||||
that we
|
||||
wish to
|
||||
word wrap.">
|
||||
] [
|
||||
<" This is a long piece of text that we wish to word wrap."> 12
|
||||
" " wrap-indented-string
|
||||
] unit-test
|
||||
|
||||
[ "this text\nhas lots\nof spaces" ]
|
||||
[ "this text has lots of spaces" 12 wrap-string ] unit-test
|
||||
|
||||
[ "hello\nhow\nare\nyou\ntoday?" ]
|
||||
[ "hello how are you today?" 3 wrap-string ] unit-test
|
||||
|
||||
[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
|
||||
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
|
||||
|
||||
\ wrap-string must-infer
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: wrap kernel sequences fry splitting math ;
|
||||
IN: wrap.strings
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: split-lines ( string -- elements-lines )
|
||||
string-lines [
|
||||
" \t" split harvest
|
||||
[ dup length 1 <element> ] map
|
||||
] map ;
|
||||
|
||||
: join-elements ( wrapped-lines -- lines )
|
||||
[ " " join ] map ;
|
||||
|
||||
: join-lines ( strings -- string )
|
||||
"\n" join ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wrap-lines ( lines width -- newlines )
|
||||
[ split-lines ] dip '[ _ dup wrap join-elements ] map concat ;
|
||||
|
||||
: wrap-string ( string width -- newstring )
|
||||
wrap-lines join-lines ;
|
||||
|
||||
: wrap-indented-string ( string width indent -- newstring )
|
||||
[ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup math kernel ;
|
||||
IN: wrap.words
|
||||
|
||||
ABOUT: "wrap.words"
|
||||
|
||||
ARTICLE: "wrap.words" "Word object wrapping"
|
||||
"The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings."
|
||||
{ $subsection wrap-words }
|
||||
{ $subsection word }
|
||||
{ $subsection <word> } ;
|
||||
|
||||
HELP: wrap-words
|
||||
{ $values { "words" { "a sequence of " { $instance word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
|
||||
{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
|
||||
|
||||
HELP: word
|
||||
{ $class-description "A word is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
|
||||
{ $see-also wrap-words } ;
|
||||
|
||||
HELP: <word>
|
||||
{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
|
||||
{ $description "Creates a " { $link word } " object with the given parameters." }
|
||||
{ $see-also wrap-words } ;
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test wrap multiline sequences ;
|
||||
IN: wrap.tests
|
||||
|
||||
USING: tools.test wrap.words sequences ;
|
||||
IN: wrap.words.tests
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
|
|
@ -22,7 +22,7 @@ IN: wrap.tests
|
|||
T{ word f 3 2 t }
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
} 35 wrap [ { } like ] map
|
||||
} 35 35 wrap-words [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -48,35 +48,35 @@ IN: wrap.tests
|
|||
T{ word f 3 9 t }
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
} 35 wrap [ { } like ] map
|
||||
} 35 35 wrap-words [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<" This is a
|
||||
long piece
|
||||
of text
|
||||
that we
|
||||
wish to
|
||||
word wrap.">
|
||||
{
|
||||
{
|
||||
T{ word f 1 10 t }
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 3 9 t }
|
||||
}
|
||||
{
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 9 t }
|
||||
}
|
||||
{
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
}
|
||||
}
|
||||
] [
|
||||
<" This is a long piece of text that we wish to word wrap."> 10
|
||||
wrap-string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
<" This is a
|
||||
long piece
|
||||
of text
|
||||
that we
|
||||
wish to
|
||||
word wrap.">
|
||||
] [
|
||||
<" This is a long piece of text that we wish to word wrap."> 12
|
||||
" " wrap-indented-string
|
||||
{
|
||||
T{ word f 1 10 t }
|
||||
T{ word f 1 10 f }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 2 10 f }
|
||||
T{ word f 3 9 t }
|
||||
T{ word f 4 10 f }
|
||||
T{ word f 5 10 f }
|
||||
} 35 35 wrap-words [ { } like ] map
|
||||
] unit-test
|
||||
|
||||
[ "this text\nhas lots of\nspaces" ]
|
||||
[ "this text has lots of spaces" 12 wrap-string ] unit-test
|
||||
|
||||
[ "hello\nhow\nare\nyou\ntoday?" ]
|
||||
[ "hello how are you today?" 3 wrap-string ] unit-test
|
||||
\ wrap-words must-infer
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel splitting.monotonic accessors wrap grouping ;
|
||||
IN: wrap.words
|
||||
|
||||
TUPLE: word key width break? ;
|
||||
C: <word> word
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: words-length ( words -- length )
|
||||
[ width>> ] map sum ;
|
||||
|
||||
: make-element ( whites blacks -- element )
|
||||
[ append ] [ [ words-length ] bi@ ] 2bi <element> ;
|
||||
|
||||
: ?first2 ( seq -- first/f second/f )
|
||||
[ 0 swap ?nth ]
|
||||
[ 1 swap ?nth ] bi ;
|
||||
|
||||
: split-words ( seq -- half-elements )
|
||||
[ [ break?>> ] bi@ = ] monotonic-split ;
|
||||
|
||||
: ?first-break ( seq -- newseq f/element )
|
||||
dup first first break?>>
|
||||
[ unclip-slice f swap make-element ]
|
||||
[ f ] if ;
|
||||
|
||||
: make-elements ( seq f/element -- elements )
|
||||
[ 2 <groups> [ ?first2 make-element ] map ] dip
|
||||
[ prefix ] when* ;
|
||||
|
||||
: words>elements ( seq -- newseq )
|
||||
split-words ?first-break make-elements ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wrap-words ( words line-max line-ideal -- lines )
|
||||
[ words>elements ] 2dip wrap [ concat ] map ;
|
||||
|
||||
|
|
@ -6,36 +6,6 @@ IN: wrap
|
|||
ABOUT: "wrap"
|
||||
|
||||
ARTICLE: "wrap" "Word wrapping"
|
||||
"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:"
|
||||
{ $subsection wrap-lines }
|
||||
{ $subsection wrap-string }
|
||||
{ $subsection wrap-indented-string }
|
||||
"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words."
|
||||
{ $subsection wrap }
|
||||
{ $subsection word }
|
||||
{ $subsection <word> } ;
|
||||
|
||||
HELP: wrap-lines
|
||||
{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
|
||||
{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
|
||||
|
||||
HELP: wrap-string
|
||||
{ $values { "string" string } { "width" integer } { "newstring" string } }
|
||||
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
|
||||
|
||||
HELP: wrap-indented-string
|
||||
{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
|
||||
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
|
||||
|
||||
HELP: wrap
|
||||
{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } }
|
||||
{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
|
||||
|
||||
HELP: word
|
||||
{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
|
||||
{ $see-also wrap } ;
|
||||
|
||||
HELP: <word>
|
||||
{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
|
||||
{ $description "Creates a " { $link word } " object with the given parameters." }
|
||||
{ $see-also wrap } ;
|
||||
"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. Wrapping can take place based on simple strings, assumed to be monospace, or abstract word objects."
|
||||
{ $vocab-subsection "String word wrapping" "wrap.strings" }
|
||||
{ $vocab-subsection "Word object wrapping" "wrap.words" } ;
|
||||
|
|
|
|||
|
|
@ -1,73 +1,95 @@
|
|||
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
|
||||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel namespaces make splitting
|
||||
math math.order fry assocs accessors ;
|
||||
USING: kernel sequences math arrays locals fry accessors
|
||||
lists splitting call make combinators.short-circuit namespaces
|
||||
grouping splitting.monotonic ;
|
||||
IN: wrap
|
||||
|
||||
! Word wrapping/line breaking -- not Unicode-aware
|
||||
! black is the text length, white is the whitespace length
|
||||
TUPLE: element contents black white ;
|
||||
C: <element> element
|
||||
|
||||
TUPLE: word key width break? ;
|
||||
: element-length ( element -- n )
|
||||
[ black>> ] [ white>> ] bi + ;
|
||||
|
||||
C: <word> word
|
||||
: swons ( cdr car -- cons )
|
||||
swap cons ;
|
||||
|
||||
<PRIVATE
|
||||
: unswons ( cons -- cdr car )
|
||||
[ cdr ] [ car ] bi ;
|
||||
|
||||
SYMBOL: width
|
||||
: 1list? ( list -- ? )
|
||||
{ [ ] [ cdr +nil+ = ] } 1&& ;
|
||||
|
||||
: break-here? ( column word -- ? )
|
||||
break?>> not [ width get > ] [ drop f ] if ;
|
||||
: lists>arrays ( lists -- arrays )
|
||||
[ list>seq ] lmap>array ;
|
||||
|
||||
: walk ( n words -- n )
|
||||
! If on a break, take the rest of the breaks
|
||||
! If not on a break, go back until you hit a break
|
||||
2dup bounds-check? [
|
||||
2dup nth break?>>
|
||||
[ [ break?>> not ] find-from drop ]
|
||||
[ [ break?>> ] find-last-from drop 1+ ] if
|
||||
] [ drop ] if ;
|
||||
TUPLE: paragraph lines head-width tail-cost ;
|
||||
C: <paragraph> paragraph
|
||||
|
||||
: find-optimal-break ( words -- n )
|
||||
[ 0 ] keep
|
||||
[ [ width>> + dup ] keep break-here? ] find drop nip
|
||||
[ 1 max swap walk ] [ drop f ] if* ;
|
||||
SYMBOL: line-max
|
||||
SYMBOL: line-ideal
|
||||
|
||||
: (wrap) ( words -- )
|
||||
: deviation ( length -- n )
|
||||
line-ideal get - sq ;
|
||||
|
||||
: top-fits? ( paragraph -- ? )
|
||||
[ head-width>> ]
|
||||
[ lines>> 1list? line-ideal line-max ? get ] bi <= ;
|
||||
|
||||
: fits? ( paragraph -- ? )
|
||||
! Make this not count spaces at end
|
||||
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
|
||||
|
||||
:: min-by ( seq quot -- elt )
|
||||
f 1.0/0.0 seq [| key value new |
|
||||
new quot call :> newvalue
|
||||
newvalue value < [ new newvalue ] [ key value ] if
|
||||
] each drop ; inline
|
||||
|
||||
: paragraph-cost ( paragraph -- cost )
|
||||
[ head-width>> deviation ]
|
||||
[ tail-cost>> ] bi + ;
|
||||
|
||||
: min-cost ( paragraphs -- paragraph )
|
||||
[ paragraph-cost ] min-by ;
|
||||
|
||||
: new-line ( paragraph element -- paragraph )
|
||||
[ [ lines>> ] [ 1list ] bi* swons ]
|
||||
[ nip black>> ]
|
||||
[ drop paragraph-cost ] 2tri
|
||||
<paragraph> ;
|
||||
|
||||
: glue ( paragraph element -- paragraph )
|
||||
[ [ lines>> unswons ] dip swons swons ]
|
||||
[ [ head-width>> ] [ element-length ] bi* + ]
|
||||
[ drop tail-cost>> ] 2tri
|
||||
<paragraph> ;
|
||||
|
||||
: wrap-step ( paragraphs element -- paragraphs )
|
||||
[ '[ _ glue ] map ]
|
||||
[ [ min-cost ] dip new-line ]
|
||||
2bi prefix
|
||||
[ fits? ] filter ;
|
||||
|
||||
: 1paragraph ( element -- paragraph )
|
||||
[ 1list 1list ]
|
||||
[ black>> ] bi
|
||||
0 <paragraph> ;
|
||||
|
||||
: post-process ( paragraph -- array )
|
||||
lines>> lists>arrays
|
||||
[ [ contents>> ] map ] map ;
|
||||
|
||||
: initialize ( elements -- elements paragraph )
|
||||
<reversed> unclip-slice 1paragraph 1array ;
|
||||
|
||||
: wrap ( elements line-max line-ideal -- paragraph )
|
||||
[
|
||||
dup find-optimal-break
|
||||
[ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
|
||||
] unless-empty ;
|
||||
|
||||
: intersperse ( seq elt -- seq' )
|
||||
[ '[ _ , ] [ , ] interleave ] { } make ;
|
||||
|
||||
: split-lines ( string -- words-lines )
|
||||
string-lines [
|
||||
" \t" split harvest
|
||||
[ dup length f <word> ] map
|
||||
" " 1 t <word> intersperse
|
||||
] map ;
|
||||
|
||||
: join-words ( wrapped-lines -- lines )
|
||||
[
|
||||
[ break?>> ] trim-slice
|
||||
[ key>> ] map concat
|
||||
] map ;
|
||||
|
||||
: join-lines ( strings -- string )
|
||||
"\n" join ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: wrap ( words width -- lines )
|
||||
width [
|
||||
[ (wrap) ] { } make
|
||||
] with-variable ;
|
||||
|
||||
: wrap-lines ( lines width -- newlines )
|
||||
[ split-lines ] dip '[ _ wrap join-words ] map concat ;
|
||||
|
||||
: wrap-string ( string width -- newstring )
|
||||
wrap-lines join-lines ;
|
||||
|
||||
: wrap-indented-string ( string width indent -- newstring )
|
||||
[ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;
|
||||
line-ideal set
|
||||
line-max set
|
||||
initialize
|
||||
[ wrap-step ] reduce
|
||||
min-cost
|
||||
post-process
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables kernel math namespaces sequences strings
|
||||
assocs combinators io io.streams.string accessors
|
||||
xml.data wrap xml.entities unicode.categories fry ;
|
||||
xml.data wrap.strings xml.entities unicode.categories fry ;
|
||||
IN: xml.writer
|
||||
|
||||
SYMBOL: sensitive-tags
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
USING: tools.test io.files io.files.private io.files.temp
|
||||
io.directories io.encodings.8-bit arrays make system
|
||||
io.encodings.binary io threads kernel continuations
|
||||
io.encodings.ascii sequences strings accessors
|
||||
io.encodings.utf8 math destructors namespaces ;
|
||||
USING: arrays debugger.threads destructors io io.directories
|
||||
io.encodings.8-bit io.encodings.ascii io.encodings.binary
|
||||
io.files io.files.private io.files.temp io.files.unique kernel
|
||||
make math sequences system threads tools.test ;
|
||||
IN: io.files.tests
|
||||
|
||||
\ exists? must-infer
|
||||
|
|
@ -75,3 +74,73 @@ USE: debugger.threads
|
|||
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
|
||||
|
||||
! File seeking tests
|
||||
[ B{ 3 2 3 4 5 } ]
|
||||
[
|
||||
"seek-test1" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
|
||||
B{ 3 } write
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[ B{ 1 2 3 4 3 } ]
|
||||
[
|
||||
"seek-test2" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write -1 seek-relative seek-output
|
||||
B{ 3 } write
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[ B{ 1 2 3 4 5 0 3 } ]
|
||||
[
|
||||
"seek-test3" unique-file binary
|
||||
[
|
||||
[
|
||||
B{ 1 2 3 4 5 } write 1 seek-relative seek-output
|
||||
B{ 3 } write
|
||||
] with-file-writer
|
||||
] [
|
||||
file-contents
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[ B{ 3 } ]
|
||||
[
|
||||
B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
-3 seek-end seek-input 1 read
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[ B{ 2 } ]
|
||||
[
|
||||
B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
|
||||
set-file-contents
|
||||
] [
|
||||
[
|
||||
3 seek-absolute seek-input
|
||||
-2 seek-relative seek-input
|
||||
1 read
|
||||
] with-file-reader
|
||||
] 2bi
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"seek-test6" unique-file binary [
|
||||
-10 seek-absolute seek-input
|
||||
] with-file-reader
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -68,6 +68,51 @@ HELP: stream-copy
|
|||
{ $description "Copies the contents of one stream into another, closing both streams when done." }
|
||||
$io-error ;
|
||||
|
||||
|
||||
HELP: stream-seek
|
||||
{ $values
|
||||
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
|
||||
}
|
||||
{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
|
||||
"Three methods of seeking are supported:"
|
||||
{ $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
|
||||
}
|
||||
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
|
||||
|
||||
HELP: seek-absolute
|
||||
{ $values
|
||||
|
||||
{ "value" "a seek singleton" }
|
||||
}
|
||||
{ $description "Seeks to an offset from the beginning of the stream." } ;
|
||||
|
||||
HELP: seek-end
|
||||
{ $values
|
||||
|
||||
{ "value" "a seek singleton" }
|
||||
}
|
||||
{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
|
||||
|
||||
HELP: seek-relative
|
||||
{ $values
|
||||
|
||||
{ "value" "a seek singleton" }
|
||||
}
|
||||
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
|
||||
|
||||
|
||||
HELP: seek-input
|
||||
{ $values
|
||||
{ "n" integer } { "seek-type" "a seek singleton" }
|
||||
}
|
||||
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
|
||||
|
||||
HELP: seek-output
|
||||
{ $values
|
||||
{ "n" integer } { "seek-type" "a seek singleton" }
|
||||
}
|
||||
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
|
||||
|
||||
HELP: input-stream
|
||||
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
|
||||
|
||||
|
|
@ -196,6 +241,8 @@ $nl
|
|||
{ $subsection stream-write }
|
||||
"This word is only required for string output streams:"
|
||||
{ $subsection stream-nl }
|
||||
"This word is for streams that allow seeking:"
|
||||
{ $subsection stream-seek }
|
||||
"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
|
||||
{ $see-also "io.timeouts" } ;
|
||||
|
||||
|
|
@ -249,6 +296,8 @@ $nl
|
|||
{ $subsection read-partial }
|
||||
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
|
||||
{ $subsection readln }
|
||||
"Seeking on the default input stream:"
|
||||
{ $subsection seek-input }
|
||||
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
|
||||
{ $subsection with-input-stream }
|
||||
{ $subsection with-input-stream* }
|
||||
|
|
@ -256,7 +305,7 @@ $nl
|
|||
{ $subsection output-stream }
|
||||
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
|
||||
$nl
|
||||
"Words writing to the default input stream:"
|
||||
"Words writing to the default output stream:"
|
||||
{ $subsection flush }
|
||||
{ $subsection write1 }
|
||||
{ $subsection write }
|
||||
|
|
@ -265,6 +314,8 @@ $nl
|
|||
{ $subsection print }
|
||||
{ $subsection nl }
|
||||
{ $subsection bl }
|
||||
"Seeking on the default output stream:"
|
||||
{ $subsection seek-output }
|
||||
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
|
||||
{ $subsection with-output-stream }
|
||||
{ $subsection with-output-stream* }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
USING: arrays io io.files kernel math parser strings system
|
||||
tools.test words namespaces make io.encodings.8-bit
|
||||
io.encodings.binary sequences ;
|
||||
USING: io parser tools.test words ;
|
||||
IN: io.tests
|
||||
|
||||
[ f ] [
|
||||
|
|
|
|||
|
|
@ -15,6 +15,10 @@ GENERIC: stream-write ( seq stream -- )
|
|||
GENERIC: stream-flush ( stream -- )
|
||||
GENERIC: stream-nl ( stream -- )
|
||||
|
||||
ERROR: bad-seek-type type ;
|
||||
SINGLETONS: seek-absolute seek-relative seek-end ;
|
||||
GENERIC: stream-seek ( n seek-type stream -- )
|
||||
|
||||
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
|
||||
|
||||
! Default streams
|
||||
|
|
@ -27,6 +31,8 @@ SYMBOL: error-stream
|
|||
: read ( n -- seq ) input-stream get stream-read ;
|
||||
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ;
|
||||
: read-partial ( n -- seq ) input-stream get stream-read-partial ;
|
||||
: seek-input ( n seek-type -- ) input-stream get stream-seek ;
|
||||
: seek-output ( n seek-type -- ) output-stream get stream-seek ;
|
||||
|
||||
: write1 ( elt -- ) output-stream get stream-write1 ;
|
||||
: write ( seq -- ) output-stream get stream-write ;
|
||||
|
|
@ -82,4 +88,4 @@ PRIVATE>
|
|||
|
||||
: stream-copy ( in out -- )
|
||||
[ [ [ write ] each-block ] with-output-stream ]
|
||||
curry with-input-stream ;
|
||||
curry with-input-stream ;
|
||||
|
|
|
|||
|
|
@ -53,8 +53,9 @@ HELP: 1string
|
|||
|
||||
HELP: >string
|
||||
{ $values { "seq" "a sequence of characters" } { "str" string } }
|
||||
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
|
||||
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." }
|
||||
{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." }
|
||||
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
|
||||
|
||||
HELP: resize-string ( n str -- newstr )
|
||||
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }
|
||||
|
|
|
|||
|
|
@ -551,12 +551,12 @@ HELP: BIN:
|
|||
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
|
||||
|
||||
HELP: GENERIC:
|
||||
{ $syntax "GENERIC: word" }
|
||||
{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
|
||||
|
||||
HELP: GENERIC#
|
||||
{ $syntax "GENERIC# word n" }
|
||||
{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
|
||||
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
|
||||
{ $notes
|
||||
|
|
@ -571,7 +571,7 @@ HELP: MATH:
|
|||
{ $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
|
||||
|
||||
HELP: HOOK:
|
||||
{ $syntax "HOOK: word variable" }
|
||||
{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
|
||||
{ $values { "word" "a new word to define" } { "variable" word } }
|
||||
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
Binary file not shown.
|
|
@ -0,0 +1,9 @@
|
|||
! Copyright (C) 2009 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test graphics.tiff ;
|
||||
IN: graphics.tiff.tests
|
||||
|
||||
: tiff-test-path ( -- path )
|
||||
"resource:extra/graphics/tiff/rgb.tiff" ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,227 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io io.encodings.binary io.files
|
||||
kernel pack endian tools.hexdump constructors sequences arrays
|
||||
sorting.slots math.order math.parser prettyprint classes ;
|
||||
IN: graphics.tiff
|
||||
|
||||
TUPLE: tiff
|
||||
endianness
|
||||
the-answer
|
||||
ifd-offset
|
||||
ifds ;
|
||||
|
||||
CONSTRUCTOR: tiff ( -- tiff )
|
||||
V{ } clone >>ifds ;
|
||||
|
||||
TUPLE: ifd count ifd-entries next processed-tags strips ;
|
||||
|
||||
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
|
||||
|
||||
TUPLE: ifd-entry tag type count offset ;
|
||||
|
||||
CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
|
||||
|
||||
|
||||
TUPLE: photometric-interpretation color ;
|
||||
|
||||
CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
|
||||
|
||||
SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
|
||||
|
||||
ERROR: bad-photometric-interpretation n ;
|
||||
|
||||
: lookup-photometric-interpretation ( n -- singleton )
|
||||
{
|
||||
{ 0 [ white-is-zero ] }
|
||||
{ 1 [ black-is-zero ] }
|
||||
{ 2 [ rgb ] }
|
||||
{ 3 [ palette-color ] }
|
||||
[ bad-photometric-interpretation ]
|
||||
} case <photometric-interpretation> ;
|
||||
|
||||
|
||||
TUPLE: compression method ;
|
||||
|
||||
CONSTRUCTOR: compression ( method -- object ) ;
|
||||
|
||||
SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
|
||||
|
||||
ERROR: bad-compression n ;
|
||||
|
||||
: lookup-compression ( n -- compression )
|
||||
{
|
||||
{ 1 [ no-compression ] }
|
||||
{ 2 [ CCITT-2 ] }
|
||||
{ 5 [ lzw ] }
|
||||
{ 32773 [ pack-bits ] }
|
||||
[ bad-compression ]
|
||||
} case <compression> ;
|
||||
|
||||
TUPLE: image-length n ;
|
||||
CONSTRUCTOR: image-length ( n -- object ) ;
|
||||
|
||||
TUPLE: image-width n ;
|
||||
CONSTRUCTOR: image-width ( n -- object ) ;
|
||||
|
||||
TUPLE: x-resolution n ;
|
||||
CONSTRUCTOR: x-resolution ( n -- object ) ;
|
||||
|
||||
TUPLE: y-resolution n ;
|
||||
CONSTRUCTOR: y-resolution ( n -- object ) ;
|
||||
|
||||
TUPLE: rows-per-strip n ;
|
||||
CONSTRUCTOR: rows-per-strip ( n -- object ) ;
|
||||
|
||||
TUPLE: strip-offsets n ;
|
||||
CONSTRUCTOR: strip-offsets ( n -- object ) ;
|
||||
|
||||
TUPLE: strip-byte-counts n ;
|
||||
CONSTRUCTOR: strip-byte-counts ( n -- object ) ;
|
||||
|
||||
TUPLE: bits-per-sample n ;
|
||||
CONSTRUCTOR: bits-per-sample ( n -- object ) ;
|
||||
|
||||
TUPLE: samples-per-pixel n ;
|
||||
CONSTRUCTOR: samples-per-pixel ( n -- object ) ;
|
||||
|
||||
SINGLETONS: no-resolution-unit
|
||||
inch-resolution-unit
|
||||
centimeter-resolution-unit ;
|
||||
|
||||
TUPLE: resolution-unit type ;
|
||||
CONSTRUCTOR: resolution-unit ( type -- object ) ;
|
||||
|
||||
ERROR: bad-resolution-unit n ;
|
||||
|
||||
: lookup-resolution-unit ( n -- object )
|
||||
{
|
||||
{ 1 [ no-resolution-unit ] }
|
||||
{ 2 [ inch-resolution-unit ] }
|
||||
{ 3 [ centimeter-resolution-unit ] }
|
||||
[ bad-resolution-unit ]
|
||||
} case <resolution-unit> ;
|
||||
|
||||
|
||||
TUPLE: predictor type ;
|
||||
CONSTRUCTOR: predictor ( type -- object ) ;
|
||||
|
||||
SINGLETONS: no-predictor horizontal-differencing-predictor ;
|
||||
|
||||
ERROR: bad-predictor n ;
|
||||
|
||||
: lookup-predictor ( n -- object )
|
||||
{
|
||||
{ 1 [ no-predictor ] }
|
||||
{ 2 [ horizontal-differencing-predictor ] }
|
||||
[ bad-predictor ]
|
||||
} case <predictor> ;
|
||||
|
||||
|
||||
TUPLE: planar-configuration type ;
|
||||
CONSTRUCTOR: planar-configuration ( type -- object ) ;
|
||||
|
||||
SINGLETONS: chunky planar ;
|
||||
|
||||
ERROR: bad-planar-configuration n ;
|
||||
|
||||
: lookup-planar-configuration ( n -- object )
|
||||
{
|
||||
{ 1 [ no-predictor ] }
|
||||
{ 2 [ horizontal-differencing-predictor ] }
|
||||
[ bad-predictor ]
|
||||
} case <planar-configuration> ;
|
||||
|
||||
|
||||
TUPLE: new-subfile-type n ;
|
||||
CONSTRUCTOR: new-subfile-type ( n -- object ) ;
|
||||
|
||||
ERROR: bad-tiff-magic bytes ;
|
||||
|
||||
: tiff-endianness ( byte-array -- ? )
|
||||
{
|
||||
{ B{ CHAR: M CHAR: M } [ big-endian ] }
|
||||
{ B{ CHAR: I CHAR: I } [ little-endian ] }
|
||||
[ bad-tiff-magic ]
|
||||
} case ;
|
||||
|
||||
: with-tiff-endianness ( tiff quot -- tiff )
|
||||
[ dup endianness>> ] dip with-endianness ; inline
|
||||
|
||||
: read-header ( tiff -- tiff )
|
||||
2 read tiff-endianness [ >>endianness ] keep
|
||||
[
|
||||
2 read endian> >>the-answer
|
||||
4 read endian> >>ifd-offset
|
||||
] with-endianness ;
|
||||
|
||||
: push-ifd ( tiff ifd -- tiff )
|
||||
over ifds>> push ;
|
||||
|
||||
: read-ifd ( -- ifd )
|
||||
2 read endian>
|
||||
2 read endian>
|
||||
4 read endian>
|
||||
4 read endian> <ifd-entry> ;
|
||||
|
||||
: read-ifds ( tiff -- tiff )
|
||||
[
|
||||
dup ifd-offset>> seek-absolute seek-input
|
||||
2 read endian>
|
||||
dup [ read-ifd ] replicate
|
||||
4 read endian>
|
||||
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
|
||||
] with-tiff-endianness ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
dup processed-tags>>
|
||||
[ [ strip-byte-counts instance? ] find nip n>> ]
|
||||
[ [ strip-offsets instance? ] find nip n>> ] bi
|
||||
[ seek-absolute seek-input read ] { } 2map-as >>strips ;
|
||||
|
||||
! ERROR: unhandled-ifd-entry data n ;
|
||||
|
||||
: unhandled-ifd-entry ;
|
||||
|
||||
: ifd-entry-value ( ifd-entry -- n )
|
||||
dup count>> 1 = [
|
||||
offset>>
|
||||
] [
|
||||
[ offset>> seek-absolute seek-input ] [ count>> read ] bi
|
||||
] if ;
|
||||
|
||||
: process-ifd-entry ( ifd-entry -- object )
|
||||
[ ifd-entry-value ] [ tag>> ] bi {
|
||||
{ 254 [ <new-subfile-type> ] }
|
||||
{ 256 [ <image-width> ] }
|
||||
{ 257 [ <image-length> ] }
|
||||
{ 258 [ <bits-per-sample> ] }
|
||||
{ 259 [ lookup-compression ] }
|
||||
{ 262 [ lookup-photometric-interpretation ] }
|
||||
{ 273 [ <strip-offsets> ] }
|
||||
{ 277 [ <samples-per-pixel> ] }
|
||||
{ 278 [ <rows-per-strip> ] }
|
||||
{ 279 [ <strip-byte-counts> ] }
|
||||
{ 282 [ <x-resolution> ] }
|
||||
{ 283 [ <y-resolution> ] }
|
||||
{ 284 [ <planar-configuration> ] }
|
||||
{ 296 [ lookup-resolution-unit ] }
|
||||
{ 317 [ lookup-predictor ] }
|
||||
[ unhandled-ifd-entry swap 2array ]
|
||||
} case ;
|
||||
|
||||
: process-ifd ( ifd -- ifd )
|
||||
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
|
||||
|
||||
: (load-tiff) ( path -- tiff )
|
||||
binary [
|
||||
<tiff>
|
||||
read-header
|
||||
read-ifds
|
||||
dup ifds>> [ process-ifd read-strips drop ] each
|
||||
] with-file-reader ;
|
||||
|
||||
: load-tiff ( path -- tiff )
|
||||
(load-tiff) ;
|
||||
|
||||
! TODO: duplicate ifds = error, seeking out of bounds = error
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
IN: infix.ast
|
||||
|
||||
TUPLE: ast-number value ;
|
||||
TUPLE: ast-local name ;
|
||||
TUPLE: ast-array name index ;
|
||||
TUPLE: ast-function name arguments ;
|
||||
TUPLE: ast-op left right op ;
|
||||
TUPLE: ast-negation term ;
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
USING: help.syntax help.markup prettyprint locals ;
|
||||
IN: infix
|
||||
|
||||
HELP: [infix
|
||||
{ $syntax "[infix ... infix]" }
|
||||
{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: infix prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"[infix 8+2*3 infix] ."
|
||||
"14"
|
||||
} $nl
|
||||
{ $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :"
|
||||
{ $example
|
||||
"USING: infix locals math.functions prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
":: quadratic-equation ( a b c -- z- z+ )"
|
||||
" [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]"
|
||||
" [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;"
|
||||
"1 0 -1 quadratic-equation . ."
|
||||
"1.0\n-1.0"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: [infix|
|
||||
{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
|
||||
{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: infix prettyprint ;"
|
||||
"IN: scratchpad"
|
||||
"[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
|
||||
"452.16"
|
||||
}
|
||||
} ;
|
||||
|
||||
{ POSTPONE: [infix POSTPONE: [infix| } related-words
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
USING: infix infix.private kernel locals math math.functions
|
||||
tools.test ;
|
||||
IN: infix.tests
|
||||
|
||||
[ 0 ] [ [infix 0 infix] ] unit-test
|
||||
[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test
|
||||
[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test
|
||||
[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test
|
||||
[ 1 ] [ [infix 2-
|
||||
1
|
||||
-5*
|
||||
0 infix] ] unit-test
|
||||
|
||||
[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
|
||||
r*r*pi infix] ] unit-test
|
||||
[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
|
||||
[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
|
||||
[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
|
||||
|
||||
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
|
||||
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
|
||||
[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
|
||||
[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
|
||||
|
||||
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
|
||||
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
|
||||
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
|
||||
|
||||
[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values
|
||||
[ f ] [ 1 \ drop check-word ] unit-test ! no return value
|
||||
[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args
|
||||
: no-stack-effect-declared + ;
|
||||
[ 0 \ no-stack-effect-declared check-word ] must-fail
|
||||
|
||||
: qux ( -- x ) 2 ;
|
||||
[ t ] [ 0 \ qux check-word ] unit-test
|
||||
[ 8 ] [ [infix qux()*3+2 infix] ] unit-test
|
||||
: foobar ( x -- y ) 1 + ;
|
||||
[ t ] [ 1 \ foobar check-word ] unit-test
|
||||
[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test
|
||||
: stupid_function ( x x x x x -- y ) + + + + ;
|
||||
[ t ] [ 5 \ stupid_function check-word ] unit-test
|
||||
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
|
||||
|
||||
[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
USING: accessors assocs combinators combinators.short-circuit
|
||||
effects fry infix.parser infix.ast kernel locals.parser
|
||||
locals.types math multiline namespaces parser quotations
|
||||
sequences summary words ;
|
||||
IN: infix
|
||||
|
||||
<PRIVATE
|
||||
: prepare-operand ( term -- quot )
|
||||
dup callable? [ 1quotation ] unless ;
|
||||
|
||||
ERROR: local-not-defined name ;
|
||||
M: local-not-defined summary
|
||||
drop "local is not defined" ;
|
||||
|
||||
: at? ( key assoc -- value/key ? )
|
||||
dupd at* [ nip t ] [ drop f ] if ;
|
||||
|
||||
: >local-word ( string -- word )
|
||||
locals get at? [ local-not-defined ] unless ;
|
||||
|
||||
: select-op ( string -- word )
|
||||
{
|
||||
{ "+" [ [ + ] ] }
|
||||
{ "-" [ [ - ] ] }
|
||||
{ "*" [ [ * ] ] }
|
||||
{ "/" [ [ / ] ] }
|
||||
[ drop [ mod ] ]
|
||||
} case ;
|
||||
|
||||
GENERIC: infix-codegen ( ast -- quot/number )
|
||||
|
||||
M: ast-number infix-codegen value>> ;
|
||||
|
||||
M: ast-local infix-codegen
|
||||
name>> >local-word ;
|
||||
|
||||
M: ast-array infix-codegen
|
||||
[ index>> infix-codegen prepare-operand ]
|
||||
[ name>> >local-word ] bi '[ @ _ nth ] ;
|
||||
|
||||
M: ast-op infix-codegen
|
||||
[ left>> infix-codegen ] [ right>> infix-codegen ]
|
||||
[ op>> select-op ] tri
|
||||
2over [ number? ] both? [ call ] [
|
||||
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
|
||||
] if ;
|
||||
|
||||
M: ast-negation infix-codegen
|
||||
term>> infix-codegen
|
||||
{
|
||||
{ [ dup number? ] [ neg ] }
|
||||
{ [ dup callable? ] [ '[ @ neg ] ] }
|
||||
[ '[ _ neg ] ] ! local word
|
||||
} cond ;
|
||||
|
||||
ERROR: bad-stack-effect word ;
|
||||
M: bad-stack-effect summary
|
||||
drop "Words used in infix must declare a stack effect and return exactly one value" ;
|
||||
|
||||
: check-word ( argcount word -- ? )
|
||||
dup stack-effect [ ] [ bad-stack-effect ] ?if
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
[ = ] dip 1 = and ;
|
||||
|
||||
: find-and-check ( args argcount string -- quot )
|
||||
dup search [ ] [ no-word ] ?if
|
||||
[ nip ] [ check-word ] 2bi
|
||||
[ 1quotation compose ] [ bad-stack-effect ] if ;
|
||||
|
||||
: arguments-codegen ( seq -- quot )
|
||||
dup empty? [ drop [ ] ] [
|
||||
[ infix-codegen prepare-operand ]
|
||||
[ compose ] map-reduce
|
||||
] if ;
|
||||
|
||||
M: ast-function infix-codegen
|
||||
[ arguments>> [ arguments-codegen ] [ length ] bi ]
|
||||
[ name>> ] bi find-and-check ;
|
||||
|
||||
: [infix-parse ( end -- result/quot )
|
||||
parse-multiline-string build-infix-ast
|
||||
infix-codegen prepare-operand ;
|
||||
PRIVATE>
|
||||
|
||||
: [infix
|
||||
"infix]" [infix-parse parsed \ call parsed ; parsing
|
||||
|
||||
<PRIVATE
|
||||
: parse-infix-locals ( assoc end -- quot )
|
||||
[
|
||||
in-lambda? on
|
||||
[ dup [ locals set ] [ push-locals ] bi ] dip
|
||||
[infix-parse prepare-operand swap pop-locals
|
||||
] with-scope ;
|
||||
PRIVATE>
|
||||
|
||||
: [infix|
|
||||
"|" parse-bindings "infix]" parse-infix-locals <let>
|
||||
parsed-lambda ; parsing
|
||||
|
|
@ -0,0 +1,175 @@
|
|||
USING: infix.ast infix.parser infix.tokenizer tools.test ;
|
||||
IN: infix.parser.tests
|
||||
|
||||
\ parse-infix must-infer
|
||||
\ build-infix-ast must-infer
|
||||
|
||||
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
|
||||
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
|
||||
[ "-1" build-infix-ast ] unit-test
|
||||
[ T{ ast-op
|
||||
{ left
|
||||
T{ ast-op
|
||||
{ left T{ ast-number { value 1 } } }
|
||||
{ right T{ ast-number { value 2 } } }
|
||||
{ op "+" }
|
||||
}
|
||||
}
|
||||
{ right T{ ast-number { value 4 } } }
|
||||
{ op "+" }
|
||||
} ] [ "1+2+4" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-op
|
||||
{ left T{ ast-number { value 1 } } }
|
||||
{ right
|
||||
T{ ast-op
|
||||
{ left T{ ast-number { value 2 } } }
|
||||
{ right T{ ast-number { value 3 } } }
|
||||
{ op "*" }
|
||||
}
|
||||
}
|
||||
{ op "+" }
|
||||
} ] [ "1+2*3" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-op
|
||||
{ left T{ ast-number { value 1 } } }
|
||||
{ right T{ ast-number { value 2 } } }
|
||||
{ op "+" }
|
||||
} ] [ "(1+2)" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test
|
||||
[ "-" build-infix-ast ] must-fail
|
||||
|
||||
[ T{ ast-function
|
||||
{ name "foo" }
|
||||
{ arguments
|
||||
V{
|
||||
T{ ast-op
|
||||
{ left T{ ast-number { value 1 } } }
|
||||
{ right T{ ast-number { value 2 } } }
|
||||
{ op "+" }
|
||||
}
|
||||
T{ ast-op
|
||||
{ left T{ ast-number { value 2 } } }
|
||||
{ right T{ ast-number { value 3 } } }
|
||||
{ op "%" }
|
||||
}
|
||||
}
|
||||
}
|
||||
} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-op
|
||||
{ left
|
||||
T{ ast-op
|
||||
{ left
|
||||
T{ ast-function
|
||||
{ name "bar" }
|
||||
{ arguments V{ } }
|
||||
}
|
||||
}
|
||||
{ right
|
||||
T{ ast-array
|
||||
{ name "baz" }
|
||||
{ index
|
||||
T{ ast-op
|
||||
{ left
|
||||
T{ ast-op
|
||||
{ left
|
||||
T{ ast-number
|
||||
{ value 2 }
|
||||
}
|
||||
}
|
||||
{ right
|
||||
T{ ast-number
|
||||
{ value 3 }
|
||||
}
|
||||
}
|
||||
{ op "/" }
|
||||
}
|
||||
}
|
||||
{ right
|
||||
T{ ast-number { value 4 } }
|
||||
}
|
||||
{ op "+" }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
{ op "+" }
|
||||
}
|
||||
}
|
||||
{ right T{ ast-number { value 2 } } }
|
||||
{ op "/" }
|
||||
} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-op
|
||||
{ left T{ ast-number { value 1 } } }
|
||||
{ right
|
||||
T{ ast-op
|
||||
{ left T{ ast-number { value 2 } } }
|
||||
{ right T{ ast-number { value 3 } } }
|
||||
{ op "/" }
|
||||
}
|
||||
}
|
||||
{ op "+" }
|
||||
} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-negation
|
||||
{ term
|
||||
T{ ast-function
|
||||
{ name "foo" }
|
||||
{ arguments
|
||||
V{
|
||||
T{ ast-number { value 2 } }
|
||||
T{ ast-negation
|
||||
{ term T{ ast-number { value 3 } } }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test
|
||||
|
||||
[ T{ ast-array
|
||||
{ name "arr" }
|
||||
{ index
|
||||
T{ ast-op
|
||||
{ left
|
||||
T{ ast-negation
|
||||
{ term
|
||||
T{ ast-op
|
||||
{ left
|
||||
T{ ast-function
|
||||
{ name "foo" }
|
||||
{ arguments
|
||||
V{
|
||||
T{ ast-number
|
||||
{ value 2 }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
{ right
|
||||
T{ ast-negation
|
||||
{ term
|
||||
T{ ast-number
|
||||
{ value 1 }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
{ op "+" }
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
{ right T{ ast-number { value 3 } } }
|
||||
{ op "/" }
|
||||
}
|
||||
}
|
||||
} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test
|
||||
|
||||
[ "foo bar baz" build-infix-ast ] must-fail
|
||||
[ "1+2/4+" build-infix-ast ] must-fail
|
||||
[ "quaz(2/3,)" build-infix-ast ] must-fail
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences
|
||||
strings vectors ;
|
||||
IN: infix.parser
|
||||
|
||||
EBNF: parse-infix
|
||||
Number = . ?[ ast-number? ]?
|
||||
Identifier = . ?[ string? ]?
|
||||
Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]]
|
||||
Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]]
|
||||
|
||||
FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]]
|
||||
| Sum:s => [[ s 1vector ]]
|
||||
|
||||
Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]]
|
||||
| "(" Sum:s ")" => [[ s ]]
|
||||
| Number | Array | Function
|
||||
| Identifier => [[ ast-local boa ]]
|
||||
|
||||
Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]]
|
||||
| Terminal
|
||||
|
||||
Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]]
|
||||
| Product
|
||||
|
||||
End = !(.)
|
||||
Expression = Sum End
|
||||
;EBNF
|
||||
|
||||
: build-infix-ast ( string -- ast )
|
||||
tokenize-infix parse-infix ;
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
USING: infix.ast infix.tokenizer tools.test ;
|
||||
IN: infix.tokenizer.tests
|
||||
|
||||
\ tokenize-infix must-infer
|
||||
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
|
||||
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
|
||||
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
|
||||
[ "3/(3+4)" tokenize-infix ] unit-test
|
||||
[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test
|
||||
[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ]
|
||||
[ "arr[x+3]" tokenize-infix ] unit-test
|
||||
[ "1.0.4" tokenize-infix ] must-fail
|
||||
[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ]
|
||||
[ "+]3.4,bar" tokenize-infix ] unit-test
|
||||
[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test
|
||||
[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test
|
||||
[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ]
|
||||
[ "(1+2)" tokenize-infix ] unit-test
|
||||
[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ]
|
||||
[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
USING: infix.ast kernel peg peg.ebnf math.parser sequences
|
||||
strings ;
|
||||
IN: infix.tokenizer
|
||||
|
||||
EBNF: tokenize-infix
|
||||
Letter = [a-zA-Z]
|
||||
Digit = [0-9]
|
||||
Digits = Digit+
|
||||
Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]]
|
||||
| Digits => [[ >string string>number ast-number boa ]]
|
||||
Space = " " | "\n" | "\r" | "\t"
|
||||
Spaces = Space* => [[ ignore ]]
|
||||
NameFirst = Letter | "_" => [[ CHAR: _ ]]
|
||||
NameRest = NameFirst | Digit
|
||||
Name = NameFirst NameRest* => [[ first2 swap prefix >string ]]
|
||||
Special = [+*/%(),] | "-" => [[ CHAR: - ]]
|
||||
| "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]]
|
||||
Tok = Spaces (Name | Number | Special )
|
||||
End = !(.)
|
||||
Toks = Tok* Spaces End
|
||||
;EBNF
|
||||
|
|
@ -1,10 +1,6 @@
|
|||
! Copyright (C) 2004 Chris Double.
|
||||
! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
!
|
||||
! Updated by Matthew Willis, July 2006
|
||||
! Updated by Chris Double, September 2006
|
||||
|
||||
USING: arrays kernel sequences math vectors arrays namespaces
|
||||
USING: arrays kernel sequences math vectors arrays namespaces call
|
||||
make quotations parser effects stack-checker words accessors ;
|
||||
IN: promises
|
||||
|
||||
|
|
@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ;
|
|||
#! promises quotation on the stack. Re-forcing the promise
|
||||
#! will return the same value and not recall the quotation.
|
||||
dup forced?>> [
|
||||
dup quot>> call >>value
|
||||
dup quot>> call( -- value ) >>value
|
||||
t >>forced?
|
||||
] unless
|
||||
value>> ;
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@ SYMBOL: dh-file
|
|||
"concatenative.org" 25 <inet> smtp-server set-global
|
||||
"noreply@concatenative.org" lost-password-from set-global
|
||||
"website@concatenative.org" insomniac-sender set-global
|
||||
"slava@factorcode.org" insomniac-recipients set-global
|
||||
{ "slava@factorcode.org" } insomniac-recipients set-global
|
||||
init-factor-db ;
|
||||
|
||||
: init-testing ( -- )
|
||||
|
|
|
|||
|
|
@ -18,6 +18,15 @@
|
|||
(require 'fuel-eval)
|
||||
(require 'fuel-log)
|
||||
|
||||
|
||||
;;; Aux:
|
||||
|
||||
(defvar fuel-completion--minibuffer-map
|
||||
(let ((map (make-keymap)))
|
||||
(set-keymap-parent map minibuffer-local-completion-map)
|
||||
(define-key map "?" 'self-insert-command)
|
||||
map))
|
||||
|
||||
|
||||
;;; Vocabs dictionary:
|
||||
|
||||
|
|
@ -33,7 +42,8 @@
|
|||
fuel-completion--vocabs)
|
||||
|
||||
(defun fuel-completion--read-vocab (&optional reload init-input history)
|
||||
(let ((vocabs (fuel-completion--vocabs reload)))
|
||||
(let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
|
||||
(vocabs (fuel-completion--vocabs reload)))
|
||||
(completing-read "Vocab name: " vocabs nil nil init-input history)))
|
||||
|
||||
(defsubst fuel-completion--vocab-list (prefix)
|
||||
|
|
@ -170,12 +180,23 @@ terminates a current completion."
|
|||
(cons completions partial)))
|
||||
|
||||
(defun fuel-completion--read-word (prompt &optional default history all)
|
||||
(completing-read prompt
|
||||
(if all fuel-completion--all-words-list-func
|
||||
fuel-completion--word-list-func)
|
||||
nil nil nil
|
||||
history
|
||||
(or default (fuel-syntax-symbol-at-point))))
|
||||
(let ((minibuffer-local-completion-map fuel-completion--minibuffer-map))
|
||||
(completing-read prompt
|
||||
(if all fuel-completion--all-words-list-func
|
||||
fuel-completion--word-list-func)
|
||||
nil nil nil
|
||||
history
|
||||
(or default (fuel-syntax-symbol-at-point)))))
|
||||
|
||||
(defvar fuel-completion--vocab-history nil)
|
||||
|
||||
(defun fuel-completion--read-vocab (refresh)
|
||||
(let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
|
||||
(vocabs (fuel-completion--vocabs refresh))
|
||||
(prompt "Vocabulary name: "))
|
||||
(if vocabs
|
||||
(completing-read prompt vocabs nil nil nil fuel-completion--vocab-history)
|
||||
(read-string prompt nil fuel-completion--vocab-history))))
|
||||
|
||||
(defun fuel-completion--complete-symbol ()
|
||||
"Complete the symbol at point.
|
||||
|
|
|
|||
|
|
@ -144,8 +144,12 @@
|
|||
(add-hook 'comint-redirect-hook
|
||||
'fuel-con--comint-redirect-hook nil t))
|
||||
|
||||
(defadvice comint-redirect-setup (after fuel-con--advice activate)
|
||||
(setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))
|
||||
(defadvice comint-redirect-setup
|
||||
(after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo))
|
||||
(with-current-buffer comint-buffer
|
||||
(when fuel-con--connection
|
||||
(setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))))
|
||||
(ad-activate 'comint-redirect-setup)
|
||||
|
||||
(defun fuel-con--comint-preoutput-filter (str)
|
||||
(when (string-match fuel-con--comint-finished-regex str)
|
||||
|
|
|
|||
|
|
@ -57,13 +57,6 @@
|
|||
(fuel-edit--visit-file (car loc) fuel-edit-word-method)
|
||||
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
|
||||
|
||||
(defun fuel-edit--read-vocabulary-name (refresh)
|
||||
(let* ((vocabs (fuel-completion--vocabs refresh))
|
||||
(prompt "Vocabulary name: "))
|
||||
(if vocabs
|
||||
(completing-read prompt vocabs nil nil nil fuel-edit--vocab-history)
|
||||
(read-string prompt nil fuel-edit--vocab-history))))
|
||||
|
||||
(defun fuel-edit--edit-article (name)
|
||||
(let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t)))
|
||||
(fuel-edit--try-edit (fuel-eval--send/wait cmd))))
|
||||
|
|
@ -72,7 +65,6 @@
|
|||
;;; Editing commands:
|
||||
|
||||
(defvar fuel-edit--word-history nil)
|
||||
(defvar fuel-edit--vocab-history nil)
|
||||
(defvar fuel-edit--previous-location nil)
|
||||
|
||||
(defun fuel-edit-vocabulary (&optional refresh vocab)
|
||||
|
|
@ -80,7 +72,7 @@
|
|||
When called interactively, asks for vocabulary with completion.
|
||||
With prefix argument, refreshes cached vocabulary list."
|
||||
(interactive "P")
|
||||
(let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh)))
|
||||
(let* ((vocab (or vocab (fuel-completion--read-vocab refresh)))
|
||||
(cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
|
||||
(fuel-edit--try-edit (fuel-eval--send/wait cmd))))
|
||||
|
||||
|
|
|
|||
|
|
@ -257,7 +257,7 @@ buffer."
|
|||
|
||||
(defun fuel-help-vocab (vocab)
|
||||
"Ask for a vocabulary name and show its help page."
|
||||
(interactive (list (fuel-edit--read-vocabulary-name nil)))
|
||||
(interactive (list (fuel-completion--read-vocab nil)))
|
||||
(fuel-help--get-vocab vocab))
|
||||
|
||||
(defun fuel-help-next (&optional forget-current)
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
|
||||
(defcustom fuel-listener-factor-binary
|
||||
(expand-file-name (cond ((eq system-type 'windows-nt)
|
||||
"factor.exe")
|
||||
"factor.com")
|
||||
((eq system-type 'darwin)
|
||||
"Factor.app/Contents/MacOS/factor")
|
||||
(t "factor"))
|
||||
|
|
|
|||
|
|
@ -282,7 +282,8 @@
|
|||
(fuel-markup--insert-newline)
|
||||
(dolist (s (cdr e))
|
||||
(fuel-markup--snippet (list '$snippet s))
|
||||
(newline)))
|
||||
(newline))
|
||||
(newline))
|
||||
|
||||
(defun fuel-markup--markup-example (e)
|
||||
(fuel-markup--insert-newline)
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
|
|||
`user-full-name') for the name to be inserted in the generated file."
|
||||
(interactive "P")
|
||||
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-edit--read-vocabulary-name nil)))
|
||||
(fuel-completion--read-vocab nil)))
|
||||
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
|
||||
"fuel"))
|
||||
(ret (fuel-eval--send/wait cmd))
|
||||
|
|
|
|||
|
|
@ -244,7 +244,7 @@ With prefix argument, force reload of vocabulary list."
|
|||
With prefix argument, ask for the vocab."
|
||||
(interactive "P")
|
||||
(let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
|
||||
(fuel-edit--read-vocabulary-name))))
|
||||
(fuel-completion--read-vocab nil))))
|
||||
(when vocab
|
||||
(fuel-xref--show-vocab-words vocab
|
||||
(fuel-syntax--file-has-private)))))
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ LIBRARY: alut
|
|||
FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
|
||||
|
||||
M: macosx load-wav-file ( path -- format data size frequency )
|
||||
0 <int> f <void*> 0 <int> 0 <int>
|
||||
[ alutLoadWAVFile ] 4keep
|
||||
>r >r >r *int r> *void* r> *int r> *int ;
|
||||
0 <int> f <void*> 0 <int> 0 <int>
|
||||
[ alutLoadWAVFile ] 4keep
|
||||
[ [ [ *int ] dip *void* ] dip *int ] dip *int ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays alien system combinators alien.syntax namespaces
|
||||
alien.c-types sequences vocabs.loader shuffle combinators.lib
|
||||
alien.c-types sequences vocabs.loader shuffle
|
||||
openal.backend specialized-arrays.uint ;
|
||||
IN: openal
|
||||
|
||||
|
|
@ -36,75 +36,75 @@ TYPEDEF: int ALenum
|
|||
TYPEDEF: float ALfloat
|
||||
TYPEDEF: double ALdouble
|
||||
|
||||
: AL_INVALID ( -- number ) -1 ; inline
|
||||
: AL_NONE ( -- number ) 0 ; inline
|
||||
: AL_FALSE ( -- number ) 0 ; inline
|
||||
: AL_TRUE ( -- number ) 1 ; inline
|
||||
: AL_SOURCE_RELATIVE ( -- number ) HEX: 202 ; inline
|
||||
: AL_CONE_INNER_ANGLE ( -- nmber ) HEX: 1001 ; inline
|
||||
: AL_CONE_OUTER_ANGLE ( -- number ) HEX: 1002 ; inline
|
||||
: AL_PITCH ( -- number ) HEX: 1003 ; inline
|
||||
: AL_POSITION ( -- number ) HEX: 1004 ; inline
|
||||
: AL_DIRECTION ( -- number ) HEX: 1005 ; inline
|
||||
: AL_VELOCITY ( -- number ) HEX: 1006 ; inline
|
||||
: AL_LOOPING ( -- number ) HEX: 1007 ; inline
|
||||
: AL_BUFFER ( -- number ) HEX: 1009 ; inline
|
||||
: AL_GAIN ( -- number ) HEX: 100A ; inline
|
||||
: AL_MIN_GAIN ( -- number ) HEX: 100D ; inline
|
||||
: AL_MAX_GAIN ( -- number ) HEX: 100E ; inline
|
||||
: AL_ORIENTATION ( -- number ) HEX: 100F ; inline
|
||||
: AL_CHANNEL_MASK ( -- number ) HEX: 3000 ; inline
|
||||
: AL_SOURCE_STATE ( -- number ) HEX: 1010 ; inline
|
||||
: AL_INITIAL ( -- number ) HEX: 1011 ; inline
|
||||
: AL_PLAYING ( -- number ) HEX: 1012 ; inline
|
||||
: AL_PAUSED ( -- number ) HEX: 1013 ; inline
|
||||
: AL_STOPPED ( -- number ) HEX: 1014 ; inline
|
||||
: AL_BUFFERS_QUEUED ( -- number ) HEX: 1015 ; inline
|
||||
: AL_BUFFERS_PROCESSED ( -- number ) HEX: 1016 ; inline
|
||||
: AL_SEC_OFFSET ( -- number ) HEX: 1024 ; inline
|
||||
: AL_SAMPLE_OFFSET ( -- number ) HEX: 1025 ; inline
|
||||
: AL_BYTE_OFFSET ( -- number ) HEX: 1026 ; inline
|
||||
: AL_SOURCE_TYPE ( -- number ) HEX: 1027 ; inline
|
||||
: AL_STATIC ( -- number ) HEX: 1028 ; inline
|
||||
: AL_STREAMING ( -- number ) HEX: 1029 ; inline
|
||||
: AL_UNDETERMINED ( -- number ) HEX: 1030 ; inline
|
||||
: AL_FORMAT_MONO8 ( -- number ) HEX: 1100 ; inline
|
||||
: AL_FORMAT_MONO16 ( -- number ) HEX: 1101 ; inline
|
||||
: AL_FORMAT_STEREO8 ( -- number ) HEX: 1102 ; inline
|
||||
: AL_FORMAT_STEREO16 ( -- number ) HEX: 1103 ; inline
|
||||
: AL_REFERENCE_DISTANCE ( -- number ) HEX: 1020 ; inline
|
||||
: AL_ROLLOFF_FACTOR ( -- number ) HEX: 1021 ; inline
|
||||
: AL_CONE_OUTER_GAIN ( -- number ) HEX: 1022 ; inline
|
||||
: AL_MAX_DISTANCE ( -- number ) HEX: 1023 ; inline
|
||||
: AL_FREQUENCY ( -- number ) HEX: 2001 ; inline
|
||||
: AL_BITS ( -- number ) HEX: 2002 ; inline
|
||||
: AL_CHANNELS ( -- number ) HEX: 2003 ; inline
|
||||
: AL_SIZE ( -- number ) HEX: 2004 ; inline
|
||||
: AL_UNUSED ( -- number ) HEX: 2010 ; inline
|
||||
: AL_PENDING ( -- number ) HEX: 2011 ; inline
|
||||
: AL_PROCESSED ( -- number ) HEX: 2012 ; inline
|
||||
: AL_NO_ERROR ( -- number ) AL_FALSE ; inline
|
||||
: AL_INVALID_NAME ( -- number ) HEX: A001 ; inline
|
||||
: AL_ILLEGAL_ENUM ( -- number ) HEX: A002 ; inline
|
||||
: AL_INVALID_ENUM ( -- number ) HEX: A002 ; inline
|
||||
: AL_INVALID_VALUE ( -- number ) HEX: A003 ; inline
|
||||
: AL_ILLEGAL_COMMAND ( -- number ) HEX: A004 ; inline
|
||||
: AL_INVALID_OPERATION ( -- number ) HEX: A004 ; inline
|
||||
: AL_OUT_OF_MEMORY ( -- number ) HEX: A005 ; inline
|
||||
: AL_VENDOR ( -- number ) HEX: B001 ; inline
|
||||
: AL_VERSION ( -- number ) HEX: B002 ; inline
|
||||
: AL_RENDERER ( -- number ) HEX: B003 ; inline
|
||||
: AL_EXTENSIONS ( -- number ) HEX: B004 ; inline
|
||||
: AL_DOPPLER_FACTOR ( -- number ) HEX: C000 ; inline
|
||||
: AL_DOPPLER_VELOCITY ( -- number ) HEX: C001 ; inline
|
||||
: AL_SPEED_OF_SOUND ( -- number ) HEX: C003 ; inline
|
||||
: AL_DISTANCE_MODEL ( -- number ) HEX: D000 ; inline
|
||||
: AL_INVERSE_DISTANCE ( -- number ) HEX: D001 ; inline
|
||||
: AL_INVERSE_DISTANCE_CLAMPED ( -- number ) HEX: D002 ; inline
|
||||
: AL_LINEAR_DISTANCE ( -- number ) HEX: D003 ; inline
|
||||
: AL_LINEAR_DISTANCE_CLAMPED ( -- number ) HEX: D004 ; inline
|
||||
: AL_EXPONENT_DISTANCE ( -- number ) HEX: D005 ; inline
|
||||
: AL_EXPONENT_DISTANCE_CLAMPED ( -- number ) HEX: D006 ; inline
|
||||
CONSTANT: AL_INVALID -1
|
||||
CONSTANT: AL_NONE 0
|
||||
CONSTANT: AL_FALSE 0
|
||||
CONSTANT: AL_TRUE 1
|
||||
CONSTANT: AL_SOURCE_RELATIVE HEX: 202
|
||||
CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
|
||||
CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
|
||||
CONSTANT: AL_PITCH HEX: 1003
|
||||
CONSTANT: AL_POSITION HEX: 1004
|
||||
CONSTANT: AL_DIRECTION HEX: 1005
|
||||
CONSTANT: AL_VELOCITY HEX: 1006
|
||||
CONSTANT: AL_LOOPING HEX: 1007
|
||||
CONSTANT: AL_BUFFER HEX: 1009
|
||||
CONSTANT: AL_GAIN HEX: 100A
|
||||
CONSTANT: AL_MIN_GAIN HEX: 100D
|
||||
CONSTANT: AL_MAX_GAIN HEX: 100E
|
||||
CONSTANT: AL_ORIENTATION HEX: 100F
|
||||
CONSTANT: AL_CHANNEL_MASK HEX: 3000
|
||||
CONSTANT: AL_SOURCE_STATE HEX: 1010
|
||||
CONSTANT: AL_INITIAL HEX: 1011
|
||||
CONSTANT: AL_PLAYING HEX: 1012
|
||||
CONSTANT: AL_PAUSED HEX: 1013
|
||||
CONSTANT: AL_STOPPED HEX: 1014
|
||||
CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
|
||||
CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
|
||||
CONSTANT: AL_SEC_OFFSET HEX: 1024
|
||||
CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
|
||||
CONSTANT: AL_BYTE_OFFSET HEX: 1026
|
||||
CONSTANT: AL_SOURCE_TYPE HEX: 1027
|
||||
CONSTANT: AL_STATIC HEX: 1028
|
||||
CONSTANT: AL_STREAMING HEX: 1029
|
||||
CONSTANT: AL_UNDETERMINED HEX: 1030
|
||||
CONSTANT: AL_FORMAT_MONO8 HEX: 1100
|
||||
CONSTANT: AL_FORMAT_MONO16 HEX: 1101
|
||||
CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
|
||||
CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
|
||||
CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
|
||||
CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
|
||||
CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
|
||||
CONSTANT: AL_MAX_DISTANCE HEX: 1023
|
||||
CONSTANT: AL_FREQUENCY HEX: 2001
|
||||
CONSTANT: AL_BITS HEX: 2002
|
||||
CONSTANT: AL_CHANNELS HEX: 2003
|
||||
CONSTANT: AL_SIZE HEX: 2004
|
||||
CONSTANT: AL_UNUSED HEX: 2010
|
||||
CONSTANT: AL_PENDING HEX: 2011
|
||||
CONSTANT: AL_PROCESSED HEX: 2012
|
||||
CONSTANT: AL_NO_ERROR AL_FALSE
|
||||
CONSTANT: AL_INVALID_NAME HEX: A001
|
||||
CONSTANT: AL_ILLEGAL_ENUM HEX: A002
|
||||
CONSTANT: AL_INVALID_ENUM HEX: A002
|
||||
CONSTANT: AL_INVALID_VALUE HEX: A003
|
||||
CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
|
||||
CONSTANT: AL_INVALID_OPERATION HEX: A004
|
||||
CONSTANT: AL_OUT_OF_MEMORY HEX: A005
|
||||
CONSTANT: AL_VENDOR HEX: B001
|
||||
CONSTANT: AL_VERSION HEX: B002
|
||||
CONSTANT: AL_RENDERER HEX: B003
|
||||
CONSTANT: AL_EXTENSIONS HEX: B004
|
||||
CONSTANT: AL_DOPPLER_FACTOR HEX: C000
|
||||
CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
|
||||
CONSTANT: AL_SPEED_OF_SOUND HEX: C003
|
||||
CONSTANT: AL_DISTANCE_MODEL HEX: D000
|
||||
CONSTANT: AL_INVERSE_DISTANCE HEX: D001
|
||||
CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
|
||||
CONSTANT: AL_LINEAR_DISTANCE HEX: D003
|
||||
CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
|
||||
CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
|
||||
CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
|
||||
|
||||
FUNCTION: void alEnable ( ALenum capability ) ;
|
||||
FUNCTION: void alDisable ( ALenum capability ) ;
|
||||
|
|
@ -182,34 +182,34 @@ FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
|
|||
|
||||
LIBRARY: alut
|
||||
|
||||
: ALUT_API_MAJOR_VERSION ( -- number ) 1 ; inline
|
||||
: ALUT_API_MINOR_VERSION ( -- number ) 1 ; inline
|
||||
: ALUT_ERROR_NO_ERROR ( -- number ) 0 ; inline
|
||||
: ALUT_ERROR_OUT_OF_MEMORY ( -- number ) HEX: 200 ; inline
|
||||
: ALUT_ERROR_INVALID_ENUM ( -- number ) HEX: 201 ; inline
|
||||
: ALUT_ERROR_INVALID_VALUE ( -- number ) HEX: 202 ; inline
|
||||
: ALUT_ERROR_INVALID_OPERATION ( -- number ) HEX: 203 ; inline
|
||||
: ALUT_ERROR_NO_CURRENT_CONTEXT ( -- number ) HEX: 204 ; inline
|
||||
: ALUT_ERROR_AL_ERROR_ON_ENTRY ( -- number ) HEX: 205 ; inline
|
||||
: ALUT_ERROR_ALC_ERROR_ON_ENTRY ( -- number ) HEX: 206 ; inline
|
||||
: ALUT_ERROR_OPEN_DEVICE ( -- number ) HEX: 207 ; inline
|
||||
: ALUT_ERROR_CLOSE_DEVICE ( -- number ) HEX: 208 ; inline
|
||||
: ALUT_ERROR_CREATE_CONTEXT ( -- number ) HEX: 209 ; inline
|
||||
: ALUT_ERROR_MAKE_CONTEXT_CURRENT ( -- number ) HEX: 20A ; inline
|
||||
: ALUT_ERROR_DESTRY_CONTEXT ( -- number ) HEX: 20B ; inline
|
||||
: ALUT_ERROR_GEN_BUFFERS ( -- number ) HEX: 20C ; inline
|
||||
: ALUT_ERROR_BUFFER_DATA ( -- number ) HEX: 20D ; inline
|
||||
: ALUT_ERROR_IO_ERROR ( -- number ) HEX: 20E ; inline
|
||||
: ALUT_ERROR_UNSUPPORTED_FILE_TYPE ( -- number ) HEX: 20F ; inline
|
||||
: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE ( -- number ) HEX: 210 ; inline
|
||||
: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA ( -- number ) HEX: 211 ; inline
|
||||
: ALUT_WAVEFORM_SINE ( -- number ) HEX: 100 ; inline
|
||||
: ALUT_WAVEFORM_SQUARE ( -- number ) HEX: 101 ; inline
|
||||
: ALUT_WAVEFORM_SAWTOOTH ( -- number ) HEX: 102 ; inline
|
||||
: ALUT_WAVEFORM_WHITENOISE ( -- number ) HEX: 103 ; inline
|
||||
: ALUT_WAVEFORM_IMPULSE ( -- number ) HEX: 104 ; inline
|
||||
: ALUT_LOADER_BUFFER ( -- number ) HEX: 300 ; inline
|
||||
: ALUT_LOADER_MEMORY ( -- number ) HEX: 301 ; inline
|
||||
CONSTANT: ALUT_API_MAJOR_VERSION 1
|
||||
CONSTANT: ALUT_API_MINOR_VERSION 1
|
||||
CONSTANT: ALUT_ERROR_NO_ERROR 0
|
||||
CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
|
||||
CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
|
||||
CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
|
||||
CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
|
||||
CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
|
||||
CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
|
||||
CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
|
||||
CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
|
||||
CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
|
||||
CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
|
||||
CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
|
||||
CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
|
||||
CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
|
||||
CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
|
||||
CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
|
||||
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
|
||||
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
|
||||
CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
|
||||
CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
|
||||
CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
|
||||
CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
|
||||
CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
|
||||
CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
|
||||
CONSTANT: ALUT_LOADER_BUFFER HEX: 300
|
||||
CONSTANT: ALUT_LOADER_MEMORY HEX: 301
|
||||
|
||||
FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
|
||||
FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
|
||||
|
|
@ -234,37 +234,37 @@ FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei
|
|||
SYMBOL: init
|
||||
|
||||
: init-openal ( -- )
|
||||
init get-global expired? [
|
||||
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
|
||||
1337 <alien> init set-global
|
||||
] when ;
|
||||
init get-global expired? [
|
||||
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
|
||||
1337 <alien> init set-global
|
||||
] when ;
|
||||
|
||||
: exit-openal ( -- )
|
||||
init get-global expired? [
|
||||
alutExit 0 = [ "Could not close OpenAL" throw ] when
|
||||
f init set-global
|
||||
] unless ;
|
||||
init get-global expired? [
|
||||
alutExit 0 = [ "Could not close OpenAL" throw ] when
|
||||
f init set-global
|
||||
] unless ;
|
||||
|
||||
: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
|
||||
|
||||
: gen-sources ( size -- seq )
|
||||
dup <uint-array> 2dup underlying>> alGenSources swap ;
|
||||
dup <uint-array> 2dup underlying>> alGenSources swap ;
|
||||
|
||||
: gen-buffers ( size -- seq )
|
||||
dup <uint-array> 2dup underlying>> alGenBuffers swap ;
|
||||
dup <uint-array> 2dup underlying>> alGenBuffers swap ;
|
||||
|
||||
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
|
||||
|
||||
: create-buffer-from-file ( filename -- buffer )
|
||||
alutCreateBufferFromFile dup AL_NONE = [
|
||||
"create-buffer-from-file failed" throw
|
||||
] when ;
|
||||
alutCreateBufferFromFile dup AL_NONE = [
|
||||
"create-buffer-from-file failed" throw
|
||||
] when ;
|
||||
|
||||
os macosx? "openal.macosx" "openal.other" ? require
|
||||
|
||||
: create-buffer-from-wav ( filename -- buffer )
|
||||
gen-buffer dup rot load-wav-file
|
||||
[ alBufferData ] 4keep alutUnloadWAV ;
|
||||
gen-buffer dup rot load-wav-file
|
||||
[ alBufferData ] 4keep alutUnloadWAV ;
|
||||
|
||||
: queue-buffers ( source buffers -- )
|
||||
[ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
|
||||
|
|
@ -273,29 +273,27 @@ os macosx? "openal.macosx" "openal.other" ? require
|
|||
1array queue-buffers ;
|
||||
|
||||
: set-source-param ( source param value -- )
|
||||
alSourcei ;
|
||||
alSourcei ;
|
||||
|
||||
: get-source-param ( source param -- value )
|
||||
0 <uint> dup >r alGetSourcei r> *uint ;
|
||||
0 <uint> dup [ alGetSourcei ] dip *uint ;
|
||||
|
||||
: set-buffer-param ( source param value -- )
|
||||
alBufferi ;
|
||||
alBufferi ;
|
||||
|
||||
: get-buffer-param ( source param -- value )
|
||||
0 <uint> dup >r alGetBufferi r> *uint ;
|
||||
0 <uint> dup [ alGetBufferi ] dip *uint ;
|
||||
|
||||
: source-play ( source -- )
|
||||
alSourcePlay ;
|
||||
: source-play ( source -- ) alSourcePlay ;
|
||||
|
||||
: source-stop ( source -- )
|
||||
alSourceStop ;
|
||||
: source-stop ( source -- ) alSourceStop ;
|
||||
|
||||
: check-error ( -- )
|
||||
alGetError dup ALUT_ERROR_NO_ERROR = [
|
||||
drop
|
||||
] [
|
||||
alGetString throw
|
||||
] if ;
|
||||
alGetError dup ALUT_ERROR_NO_ERROR = [
|
||||
drop
|
||||
] [
|
||||
alGetString throw
|
||||
] if ;
|
||||
|
||||
: source-playing? ( source -- bool )
|
||||
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
|
||||
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue