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

Fix conflict

db4
Slava Pestov 2009-02-08 00:07:59 -06:00
parent f4ae56a85b bf05232086
commit 043b77c702
69 changed files with 1380 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
basis/compiler/tests/alien.factor
View File

@ -559,9 +559,17 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
[ ] [ stack-frame-bustage 2drop ] unit-test
FUNCTION: complex-float ffi_test_45 ( complex-float x, complex-double y ) ;
FUNCTION: complex-float ffi_test_45 ( int x ) ;
[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
FUNCTION: complex-double ffi_test_46 ( int x ) ;
[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test
FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
[ C{ 4.0 4.0 } ] [
C{ 1.0 2.0 }
C{ 1.5 1.0 } ffi_test_45
] unit-test
C{ 1.5 1.0 } ffi_test_47
] unit-test

1
basis/endian/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

7
basis/endian/endian-tests.factor Executable file
View File

@ -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

67
basis/endian/endian.factor Executable file
View File

@ -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

89
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -10,7 +10,6 @@ xml.writer
xml.traversal
xml.syntax
html.components
html.elements
html.forms
html.templates
html.templates.chloe
@ -20,6 +19,7 @@ http
http.server
http.server.redirection
http.server.responses
io.streams.string
furnace.utilities ;
IN: furnace.chloe-tags
@ -58,62 +58,67 @@ CHLOE: write-atom drop [ write-atom-feeds ] [code] ;
#! Side-effects current namespace.
'[ [ [ _ ] dip link-attr ] each-responder ] [code] ;
: a-start-tag ( tag -- )
[ <a ] [code]
[ attrs>> non-chloe-attrs-only compile-attrs ]
[ compile-link-attrs ]
[ compile-a-url ]
tri
[ =href a> ] [code] ;
: process-attrs ( assoc -- newassoc )
[ "@" ?head [ value present ] when ] assoc-map ;
: a-end-tag ( tag -- )
drop [ </a> ] [code] ;
: non-chloe-attrs ( tag -- )
attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
: a-attrs ( tag -- )
[ non-chloe-attrs ]
[ compile-link-attrs ]
[ compile-a-url ] tri
[ present swap "href" swap [ set-at ] keep ] [code] ;
CHLOE: a
[
[ a-start-tag ] [ compile-children ] [ a-end-tag ] tri
[ a-attrs ]
[ compile-children>string ] bi
[ <unescaped> [XML <a><-></a> XML] second swap >>attrs ]
[xml-code]
] compile-with-scope ;
CHLOE: base
compile-a-url [ <base =href base/> ] [code] ;
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
: compile-hidden-form-fields ( for -- )
'[
<div "display: none;" =style div>
_ [ "," split [ hidden render ] each ] when*
nested-forms get " " join f like nested-forms-key hidden-form-field
[ modify-form ] each-responder
</div>
_ [ "," split [ hidden render>xml ] map ] [ f ] if*
nested-forms get " " join f like nested-forms-key hidden-form-field>xml
[ [ modify-form ] each-responder ] with-string-writer <unescaped>
[XML <div style="display: none;"><-><-><-></div> XML]
] [code] ;
: compile-form-attrs ( method action attrs -- )
[ <form ] [code]
[ compile-attr [ =method ] [code] ]
[ compile-attr [ resolve-base-path =action ] [code] ]
[ compile-attrs ]
tri*
[ form> ] [code] ;
: (compile-form-attrs) ( method action -- )
! Leaves an assoc on the stack at runtime
[ compile-attr [ "method" pick set-at ] [code] ]
[ compile-attr [ resolve-base-path "action" pick set-at ] [code] ]
bi* ;
: form-start-tag ( tag -- )
[
[ "method" optional-attr "post" or ]
[ "action" required-attr ]
[ attrs>> non-chloe-attrs-only ] tri
compile-form-attrs
]
[ "for" optional-attr compile-hidden-form-fields ] bi ;
: compile-method/action ( tag -- )
! generated code is ( assoc -- assoc )
[ "method" optional-attr "post" or ]
[ "action" required-attr ] bi
(compile-form-attrs) ;
: form-end-tag ( tag -- )
drop [ </form> ] [code] ;
: compile-form-attrs ( tag -- )
[ non-chloe-attrs ]
[ compile-link-attrs ]
[ compile-method/action ] tri ;
: hidden-fields ( tag -- )
"for" optional-attr compile-hidden-form-fields ;
CHLOE: form
[
{
[ compile-link-attrs ]
[ form-start-tag ]
[ compile-children ]
[ form-end-tag ]
} cleave
[ compile-form-attrs ]
[ hidden-fields ]
[ compile-children>string ] tri
[
<unescaped> [XML <form><-><-></form> XML] second
swap >>attrs
write-xml
] [code]
] compile-with-scope ;
: button-tag-markup ( -- xml )
@ -121,13 +126,13 @@ CHLOE: form
<t:form class="inline" xmlns:t="http://factorcode.org/chloe/1.0">
<div style="display: inline;"><button type="submit"></button></div>
</t:form>
XML> ;
XML> body>> clone ;
: add-tag-attrs ( attrs tag -- )
attrs>> swap update ;
CHLOE: button
button-tag-markup body>>
button-tag-markup
{
[ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ]
[ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ]

2
basis/furnace/furnace-tests.factor
View File

@ -30,7 +30,7 @@ M: base-path-check-responder call-responder*
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
[ "<input type='hidden' name='foo' value='&amp;&amp;&amp;'/>" ]
[ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test

2
basis/furnace/sessions/sessions.factor
View File

@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences
continuations fry calendar combinators combinators.short-circuit
destructors alarms io.sockets db db.tuples db.types
http http.server http.server.dispatchers http.server.filters
html.elements furnace.cache furnace.scopes furnace.utilities ;
furnace.cache furnace.scopes furnace.utilities ;
IN: furnace.sessions
TUPLE: session < scope user-agent client ;

2
basis/furnace/utilities/utilities-docs.factor
View File

@ -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\"/>"
}
} ;

15
basis/furnace/utilities/utilities.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make assocs sequences kernel classes splitting
words vocabs.loader accessors strings combinators arrays
continuations present fry urls html.elements http http.server
continuations present fry urls http http.server xml.syntax xml.writer
http.server.redirection http.server.remapping ;
IN: furnace.utilities
@ -81,14 +81,13 @@ GENERIC: modify-form ( responder -- )
M: object modify-form drop ;
: hidden-form-field ( value name -- )
: hidden-form-field>xml ( value name -- xml )
over [
<input
"hidden" =type
=name
present =value
input/>
] [ 2drop ] if ;
[XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ;
: hidden-form-field ( value name -- )
hidden-form-field>xml write-xml ;
: nested-forms-key "__n" ;

52
basis/generalizations/generalizations-docs.factor
View File

@ -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"

9
basis/generalizations/generalizations-tests.factor
View File

@ -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

19
basis/generalizations/generalizations.factor
View File

@ -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
basis/html/components/components.factor
View File

@ -11,7 +11,7 @@ IN: html.components
GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- )
: render>xml ( name renderer -- xml )
prepare-value
[
dup validation-error?
@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml )
if
] 2dip
render*
swap 2array write-xml ;
swap 2array ;
: render ( name renderer -- )
render>xml write-xml ;
SINGLETON: label

6
basis/html/templates/chloe/chloe-docs.factor
View File

@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags"
"<a href=\"http://mysite.org/wiki/view/Factor\""
" class=\"small-link\">"
" View"
"s</a>"
"</a>"
}
} }
{ { $snippet "t:base" } { "Outputs an HTML " { $snippet "<base>" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } }
@ -261,8 +261,8 @@ $nl
ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component"
"As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:"
{ $code "SINGLETON: image" }
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":"
{ $code "M: image render* 2drop <img =src img/> ;" }
"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":"
{ $code "M: image render* 2drop [XML <img src=<-> /> XML] ;" }
"Finally, we can define a Chloe component:"
{ $code "COMPONENT: image" }
"We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":"

2
basis/html/templates/chloe/chloe-tests.factor
View File

@ -135,7 +135,7 @@ TUPLE: person first-name last-name ;
[ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test
[ "<form method='post' action='foo'><div style='display: none;'><input type='hidden' name='__n' value='a'/></div></form>" ] [
[ "<form method=\"post\" action=\"foo\"><div style=\"display: none;\"><input type=\"hidden\" value=\"a\" name=\"__n\"/></div></form>" ] [
[
"test10" test-template call-template
] run-template

12
basis/html/templates/chloe/chloe.factor
View File

@ -8,7 +8,6 @@ logging continuations
xml.data xml.writer xml.syntax strings
html.forms
html
html.elements
html.components
html.templates
html.templates.chloe.compiler
@ -28,7 +27,9 @@ CHLOE: write-title
drop
"head" tag-stack get member?
"title" tag-stack get member? not and
[ <title> write-title </title> ] [ write-title ] ? [code] ;
[ get-title [XML <title><-></title> XML] ]
[ get-title ] ?
[xml-code] ;
CHLOE: style
dup "include" optional-attr [
@ -39,10 +40,9 @@ CHLOE: style
CHLOE: write-style
drop [
<style "text/css" =type style>
write-style
</style>
] [code] ;
get-style
[XML <style type="text/css"> <-> </style> XML]
] [xml-code] ;
CHLOE: even
[ "index" value even? swap when ] process-children ;

3
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -42,6 +42,9 @@ DEFER: compile-element
: [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ;
: [xml-code] ( quot -- )
[ write-xml ] compose [code] ;
: expand-attr ( value -- )
[ value present write ] [code-with] ;

23
basis/html/templates/templates.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry io io.encodings.utf8 io.files
debugger prettyprint continuations namespaces boxes sequences
arrays strings html io.streams.string
arrays strings html io.streams.string assocs
quotations xml.data xml.writer xml.syntax ;
IN: html.templates
@ -34,8 +34,11 @@ SYMBOL: title
: set-title ( string -- )
title get >box ;
: get-title ( -- string )
title get value>> ;
: write-title ( -- )
title get value>> write ;
get-title write ;
SYMBOL: style
@ -43,24 +46,30 @@ SYMBOL: style
"\n" style get push-all
style get push-all ;
: get-style ( -- string )
style get >string ;
: write-style ( -- )
style get >string write ;
get-style write ;
SYMBOL: atom-feeds
: add-atom-feed ( title url -- )
2array atom-feeds get push ;
: write-atom-feeds ( -- )
: get-atom-feeds ( -- xml )
atom-feeds get [
first2 [XML
[XML
<link
rel="alternate"
type="application/atom+xml"
title=<->
href=<->/>
XML] write-xml
] each ;
XML]
] { } assoc>map ;
: write-atom-feeds ( -- )
get-atom-feeds write-xml ;
SYMBOL: nested-template?

21
basis/io/backend/unix/unix.factor
View File

@ -46,6 +46,15 @@ M: fd cancel-operation ( fd -- )
2bi
] if ;
M: unix (stream-seek) ( n seek-type stream -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] }
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
[ handle>> fd>> swap ] dip lseek io-error ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
@ -84,8 +93,8 @@ M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
{
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +input+ ] }
[ (io-error) ]
} cond ;
@ -104,8 +113,8 @@ M: fd drain
over buffer>> buffer-consume
buffer>> buffer-empty? f +output+ ?
] }
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +output+ ] }
[ (io-error) ]
} cond ;
@ -143,7 +152,7 @@ M: stdin dispose*
stdin data>> handle-fd buffer buffer-end size read
dup 0 < [
drop
err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
] [
size = [ "Error reading stdin pipe" throw ] unless
size buffer n>buffer
@ -177,7 +186,7 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- n )
dup 0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or
errno [ EAGAIN = ] [ EINTR = ] bi or
[ drop 0 ] [ (io-error) ] if
] when ;

13
basis/io/backend/windows/nt/nt.factor
View File

@ -82,6 +82,19 @@ 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 ;
M: winnt (stream-seek) ( n seek-type stream -- )
swap {
{ seek-absolute [ handle>> (>>ptr) ] }
{ seek-relative [ handle>> [ + ] change-ptr drop ] }
{ seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] }
[ bad-seek-type ]
} case ;
: file-error? ( n -- eof? )
zero? [
GetLastError {

3
basis/io/buffers/buffers.factor
View File

@ -21,6 +21,9 @@ M: buffer dispose* ptr>> free ;
: buffer-reset ( n buffer -- )
swap >>fill 0 >>pos drop ;
: buffer-reset-hard ( buffer -- )
0 >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ; inline

7
basis/io/ports/ports.factor
View File

@ -120,6 +120,13 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
HOOK: (stream-seek) os ( n seek-type stream -- )
M: port stream-seek ( n seek-type stream -- )
dup check-disposed
[ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ;
GENERIC: shutdown ( handle -- )
M: object shutdown drop ;

2
basis/io/sockets/secure/unix/unix.factor
View File

@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ;
ERR_get_error dup zero? [
drop
{
{ -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] }
{ 0 [ premature-close ] }
} case
] [ nip (ssl-error) ] if ;

14
basis/io/sockets/unix/unix.factor
View File

@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr )
dup handle>> handle-fd f 0 write
{
{ [ 0 = ] [ drop ] }
{ [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ err_no EINTR = ] [ wait-to-connect ] }
{ [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] }
{ [ errno EINTR = ] [ wait-to-connect ] }
[ (io-error) ]
} cond ;
@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- )
[ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi
{
{ [ 0 = ] [ drop ] }
{ [ err_no EINPROGRESS = ] [
{ [ errno EINPROGRESS = ] [
[ +output+ wait-for-port ] [ wait-to-connect ] bi
] }
[ (io-error) ]
@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr )
2dup do-accept
{
{ [ over 0 >= ] [ [ 2nip <fd> init-fd ] dip ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
{ [ errno EINTR = ] [ 2drop (accept) ] }
{ [ errno EAGAIN = ] [
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr )
:: do-send ( packet sockaddr len socket datagram -- )
socket handle-fd packet dup length 0 sockaddr len sendto
0 < [
err_no EINTR = [
errno EINTR = [
packet sockaddr len socket datagram do-send
] [
err_no EAGAIN = [
errno EAGAIN = [
datagram +output+ wait-for-port
packet sockaddr len socket datagram do-send
] [

6
basis/libc/libc.factor
View File

@ -6,6 +6,12 @@ USING: alien assocs continuations alien.destructors kernel
namespaces accessors sets summary ;
IN: libc
: errno ( -- int )
"int" "factor" "err_no" { } alien-invoke ;
: clear-errno ( -- )
"void" "factor" "clear_err_no" { } alien-invoke ;
<PRIVATE
: (malloc) ( size -- alien )

1
basis/math/primes/factors/factors-tests.factor
View File

@ -6,3 +6,4 @@ USING: math.primes.factors tools.test ;
{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
{ 999967000236000612 } [ 999969000187000867 totient ] unit-test
{ 0 } [ 1 totient ] unit-test
{ { 425612003 } } [ 425612003 factors ] unit-test

6
basis/math/primes/factors/factors.factor
View File

@ -16,7 +16,11 @@ IN: math.primes.factors
PRIVATE>
: group-factors ( n -- seq )
[ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ;
[
2
[ 2dup sq < ] [ write-factor next-prime ] [ ] until
drop dup 2 < [ drop ] [ 1 2array , ] if
] { } make ;
: unique-factors ( n -- seq ) group-factors [ first ] map ;

3
basis/mime/multipart/multipart.factor
View File

@ -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?
] [

38
basis/pack/pack.factor
View File

@ -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 ;

16
basis/unicode/case/case-tests.factor
View File

@ -1,4 +1,7 @@
USING: unicode.case tools.test namespaces ;
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ;
IN: unicode.case.tests
\ >upper must-infer
\ >lower must-infer
@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ;
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
[ t ] [ "hello how are you?" lower? ] unit-test
[
[ f ] [ i-dot? ] unit-test
[ f ] [ lt? ] unit-test
"tr" locale set
[ t ] [ i-dot? ] unit-test
[ f ] [ lt? ] unit-test
[ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test
[ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test
[ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test
"lt" locale set
! Lithuanian casing tests
[ f ] [ i-dot? ] unit-test
[ t ] [ lt? ] unit-test
[ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test
[ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test
[ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test
! [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test
] with-scope
[ t ] [ "asdf" lower? ] unit-test

30
basis/unicode/case/case.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: unicode.data sequences namespaces
sbufs make unicode.syntax unicode.normalize math hints
unicode.categories combinators unicode.syntax assocs
unicode.categories combinators unicode.syntax assocs combinators.short-circuit
strings splitting kernel accessors unicode.breaks fry locals ;
QUALIFIED: ascii
IN: unicode.case
@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall?
: i-dot? ( -- ? )
locale get { "tr" "az" } member? ;
: lt? ( -- ? )
locale get "lt" = ;
: lithuanian? ( -- ? ) locale get "lt" = ;
: dot-over ( -- ch ) HEX: 307 ;
@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall?
: mark-above? ( ch -- ? )
combining-class 230 = ;
: with-rest ( seq quot: ( seq -- seq ) -- seq )
[ unclip ] dip swap slip prefix ; inline
:: with-rest ( seq quot: ( seq -- seq ) -- seq )
seq unclip quot dip prefix ; inline
: add-dots ( seq -- seq )
[ [ "" ] [
dup first mark-above?
[ CHAR: combining-dot-above prefix ] when
[ [ { } ] [
[
dup first
{ [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
[ CHAR: combining-dot-above prefix ] when
] map
] if-empty ] with-rest ; inline
: lithuanian>lower ( string -- lower )
"i" split add-dots "i" join
"j" split add-dots "i" join ; inline
"I" split add-dots "I" join
"J" split add-dots "J" join ; inline
: turk>upper ( string -- upper-i )
"i" "I\u000307" replace ; inline
@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall?
PRIVATE>
: >lower ( string -- lower )
i-dot? [ turk>lower ] when final-sigma
i-dot? [ turk>lower ] when
lt? [ lithuanian>lower ] when
final-sigma
[ lower>> ] [ ch>lower ] map-case ;
HINTS: >lower string ;
: >upper ( string -- upper )
i-dot? [ turk>upper ] when
lt? [ lithuanian>upper ] when
[ upper>> ] [ ch>upper ] map-case ;
HINTS: >upper string ;
@ -103,6 +112,7 @@ HINTS: >upper string ;
: (>title) ( string -- title )
i-dot? [ turk>upper ] when
lt? [ lithuanian>upper ] when
[ title>> ] [ ch>title ] map-case ; inline
: title-word ( string -- title )

13
basis/unix/unix.factor
View File

@ -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
@ -37,18 +41,13 @@ C-STRUCT: group
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
LIBRARY: factor
FUNCTION: void clear_err_no ( ) ;
FUNCTION: int err_no ( ) ;
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
ERROR: unix-error errno message ;
: (io-error) ( -- * ) err_no dup strerror unix-error ;
: (io-error) ( -- * ) errno dup strerror unix-error ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
@ -61,7 +60,7 @@ MACRO:: unix-system-call ( quot -- )
n ndup quot call dup 0 < [
drop
n narray
err_no dup strerror
errno dup strerror
word unix-system-call-error
] [
n nnip

2
basis/windows/kernel32/kernel32.factor
View File

@ -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

1
basis/zlib/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

1
basis/zlib/ffi/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

30
basis/zlib/ffi/ffi.factor Executable file
View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system ;
IN: zlib.ffi
<< "zlib" {
{ [ os winnt? ] [ "zlib1.dll" ] }
{ [ os macosx? ] [ "libz.dylib" ] }
{ [ os unix? ] [ "libz.so" ] }
} cond "cdecl" add-library >>
LIBRARY: zlib
CONSTANT: Z_OK 0
CONSTANT: Z_STREAM_END 1
CONSTANT: Z_NEED_DICT 2
CONSTANT: Z_ERRNO -1
CONSTANT: Z_STREAM_ERROR -2
CONSTANT: Z_DATA_ERROR -3
CONSTANT: Z_MEM_ERROR -4
CONSTANT: Z_BUF_ERROR -5
CONSTANT: Z_VERSION_ERROR -6
TYPEDEF: void Bytef
TYPEDEF: ulong uLongf
TYPEDEF: ulong uLong
FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;

9
basis/zlib/zlib-tests.factor Executable file
View File

@ -0,0 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test zlib classes ;
IN: zlib.tests
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
[ t ] [ compress-me compress compressed instance? ] unit-test

48
basis/zlib/zlib.factor Executable file
View File

@ -0,0 +1,48 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax byte-arrays combinators
kernel math math.functions sequences system accessors
libc ;
QUALIFIED: zlib.ffi
IN: zlib
TUPLE: compressed data length ;
: <compressed> ( data length -- compressed )
compressed new
swap >>length
swap >>data ;
ERROR: zlib-failed n string ;
: zlib-error-message ( n -- * )
dup zlib.ffi:Z_ERRNO = [
drop errno "native libc error"
] [
dup {
"no error" "libc_error"
"stream error" "data error"
"memory error" "buffer error" "zlib version error"
} ?nth
] if zlib-failed ;
: zlib-error ( n -- )
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
: compressed-size ( byte-array -- n )
length 1001/1000 * ceiling 12 + ;
: compress ( byte-array -- compressed )
[
[ compressed-size <byte-array> dup length <ulong> ] keep [
dup length zlib.ffi:compress zlib-error
] 3keep drop *ulong head
] keep length <compressed> ;
: uncompress ( compressed -- byte-array )
[
length>> [ <byte-array> ] keep <ulong> 2dup
] [
data>> dup length
zlib.ffi:uncompress zlib-error
] bi *ulong head ;

65
core/io/io-tests.factor
View File

@ -1,6 +1,6 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces make io.encodings.8-bit
io.encodings.binary sequences ;
io.encodings.binary sequences io.files.unique ;
IN: io.tests
[ f ] [
@ -10,3 +10,66 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
[ B{ 3 2 3 4 5 } ]
[
"seek-test1" unique-file binary
[
[
B{ 1 2 3 4 5 } write flush 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 flush -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 flush 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

8
core/io/io.factor
View File

@ -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 ;

5
core/strings/strings-docs.factor
View File

@ -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 } }

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

@ -107,7 +107,7 @@ $nl
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
{ { $snippet "\"infer\"" } { $link "compiler-transforms" } }
{ { $snippet "\"infer\"" } { $link "macros" } }
{ { { $snippet "\"inferred-effect\"" } } { $link "inference" } }

5
extra/24-game/24-game.factor
View File

@ -15,7 +15,8 @@ SYMBOL: commands
{ nop rot -rot swap spin swapd } amb-execute ;
: makes-24? ( a b c d -- ? )
[
2 [ some-rots do-something ] times
some-rots do-something
some-rots do-something
maybe-swap do-something
24 =
]
@ -60,4 +61,4 @@ DEFER: check-status
: 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
: set-commands ( -- ) { + - * / rot swap q } commands set ;
: play-game ( -- ) set-commands 24-able repeat ;
MAIN: play-game
MAIN: play-game

33
extra/graphics/bitmap/bitmap-tests.factor
View File

@ -1,15 +1,30 @@
USING: graphics.bitmap graphics.viewer ;
USING: graphics.bitmap graphics.viewer io.encodings.binary
io.files io.files.unique kernel tools.test ;
IN: graphics.bitmap.tests
: test-bitmap24 ( -- )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
: test-bitmap32-alpha ( -- path )
"resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
: test-bitmap8 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
: test-bitmap24 ( -- path )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
: test-bitmap4 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
: test-bitmap16 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
: test-bitmap1 ( -- )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
: test-bitmap8 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
: test-bitmap4 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ;
: test-bitmap1 ( -- path )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" ;
[ t ]
[
test-bitmap24
[ binary file-contents ] [ load-bitmap ] bi
"test-bitmap24" unique-file
[ save-bitmap ] [ binary file-contents ] bi =
] unit-test

39
extra/graphics/bitmap/bitmap.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2007 Doug Coleman.
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary
io io.binary io.files kernel libc math
math.functions math.bitwise namespaces opengl opengl.gl
prettyprint sequences strings ui ui.gadgets.panes fry
io.encodings.binary accessors grouping macros alien.c-types ;
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary
io.files kernel libc macros math math.bitwise math.functions
namespaces opengl opengl.gl prettyprint sequences strings
summary ui ui.gadgets.panes ;
IN: graphics.bitmap
! Currently can only handle 24/32bit bitmaps.
@ -14,6 +13,7 @@ IN: graphics.bitmap
TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index
alpha-channel-zero?
array ;
: array-copy ( bitmap array -- bitmap array' )
@ -39,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: 4bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
{ 24 [ color-index>> ] }
{ 16 [ "16bit" throw ] }
{ 16 [ bmp-not-supported ] }
{ 8 [ 8bit>array ] }
{ 4 [ 4bit>array ] }
{ 2 [ "2bit" throw ] }
{ 1 [ "1bit" throw ] }
{ 4 [ bmp-not-supported ] }
{ 2 [ bmp-not-supported ] }
{ 1 [ bmp-not-supported ] }
} case >byte-array ;
ERROR: bitmap-magic ;
@ -97,12 +95,19 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap )
: (load-bitmap) ( path -- bitmap )
binary [
bitmap new
parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader
dup raw-bitmap>array >>array ;
] with-file-reader ;
: alpha-channel-zero? ( bitmap -- ? )
array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
: load-bitmap ( path -- bitmap )
(load-bitmap)
dup raw-bitmap>array >>array
dup alpha-channel-zero? >>alpha-channel-zero? ;
: write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ;

1
extra/graphics/tiff/authors.txt Executable file
View File

@ -0,0 +1 @@
Doug Coleman

BIN
extra/graphics/tiff/rgb.tiff Executable file
View File

Binary file not shown.

9
extra/graphics/tiff/tiff-tests.factor Executable file
View File

@ -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" ;

223
extra/graphics/tiff/tiff.factor Executable file
View File

@ -0,0 +1,223 @@
! 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 ;
IN: graphics.tiff
TUPLE: tiff
endianness
the-answer
ifd-offset
ifds
processed-ifds ;
CONSTRUCTOR: tiff ( -- tiff )
V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next ;
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 ;
! 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 -- processed-ifd )
ifd-entries>> [ process-ifd-entry ] map ;
: (load-tiff) ( path -- tiff )
binary [
<tiff>
read-header
read-ifds
dup ifds>> [ process-ifd ] map
>>processed-ifds
] with-file-reader ;
: load-tiff ( path -- tiff )
(load-tiff) ;

0
basis/html/elements/authors.txt → extra/html/elements/authors.txt
View File

0
basis/html/elements/elements-docs.factor → extra/html/elements/elements-docs.factor
View File

0
basis/html/elements/elements-tests.factor → extra/html/elements/elements-tests.factor
View File

0
basis/html/elements/elements.factor → extra/html/elements/elements.factor
View File

0
basis/html/elements/summary.txt → extra/html/elements/summary.txt
View File

0
basis/html/elements/tags.txt → extra/html/elements/tags.txt
View File

8
extra/infix/ast/ast.factor Normal file
View File

@ -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 ;

38
extra/infix/infix-docs.factor Normal file
View File

@ -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

45
extra/infix/infix-tests.factor Normal file
View File

@ -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

99
extra/infix/infix.factor Normal file
View File

@ -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

175
extra/infix/parser/parser-tests.factor Normal file
View File

@ -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

30
extra/infix/parser/parser.factor Normal file
View File

@ -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 ;

20
extra/infix/tokenizer/tokenizer-tests.factor Normal file
View File

@ -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

21
extra/infix/tokenizer/tokenizer.factor Normal file
View File

@ -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
extra/webapps/user-admin/user-admin.factor
View File

@ -3,7 +3,6 @@
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
html.forms
html.elements
html.components
furnace
furnace.boilerplate

6
unmaintained/openal/macosx/macosx.factor
View File

@ -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 ;

252
unmaintained/openal/openal.factor
View File

@ -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 = ;

12
vm/ffi_test.c
View File

@ -303,7 +303,17 @@ struct test_struct_14 ffi_test_44(void)
return retval;
}
_Complex float ffi_test_45(_Complex float x, _Complex double y)
_Complex float ffi_test_45(int x)
{
return x;
}
_Complex double ffi_test_46(int x)
{
return x;
}
_Complex float ffi_test_47(_Complex float x, _Complex double y)
{
return x + 2 * y;
}

6
vm/ffi_test.h
View File

@ -89,4 +89,8 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();
DLLEXPORT _Complex float ffi_test_45(_Complex float x, _Complex double y);
DLLEXPORT _Complex float ffi_test_45(int x);
DLLEXPORT _Complex double ffi_test_46(int x);
DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);

4
vm/io.h
View File

@ -1,7 +1,7 @@
void init_c_io(void);
void io_error(void);
int err_no(void);
void clear_err_no(void);
DLLEXPORT int err_no(void);
DLLEXPORT void clear_err_no(void);
void primitive_fopen(void);
void primitive_fgetc(void);