[ ] [ 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
\ No newline at end of file
+ C{ 1.5 1.0 } ffi_test_47
+] unit-test
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
--- /dev/null
+! 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
xml.traversal
xml.syntax
html.components
-html.elements
html.forms
html.templates
html.templates.chloe
http.server
http.server.redirection
http.server.responses
+io.streams.string
furnace.utilities ;
IN: furnace.chloe-tags
#! 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 ;
+
+: non-chloe-attrs ( tag -- )
+ attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ;
-: a-end-tag ( tag -- )
- drop [ </a> ] [code] ;
+: 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) ;
+
+: compile-form-attrs ( tag -- )
+ [ non-chloe-attrs ]
+ [ compile-link-attrs ]
+ [ compile-method/action ] tri ;
-: form-end-tag ( tag -- )
- drop [ </form> ] [code] ;
+: 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 )
<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 ]
"a/b/c" split-path main-responder get call-responder body>>
] unit-test
-[ "<input type='hidden' name='foo' value='&&&'/>" ]
+[ "<input type=\"hidden\" value=\"&&&\" name=\"foo\"/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
unit-test
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 ;
{ $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\"/>"
}
} ;
! 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
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" ;
\r
{ nsequence narray } related-words\r
\r
+HELP: nsum\r
+{ $values { "n" integer } }\r
+{ $description "Adds the top " { $snippet "n" } " stack values." } ;\r
+\r
HELP: firstn\r
{ $values { "n" integer } }\r
{ $description "A generalization of " { $link first } ", "\r
}\r
} ;\r
\r
+HELP: nspread\r
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }\r
+{ $description "A generalization of " { $link spread } " that can work for any quotation arity."\r
+} ;\r
+\r
HELP: mnswap\r
{ $values { "m" integer } { "n" integer } }\r
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\r
}\r
} ;\r
\r
+HELP: nweave\r
+{ $values { "n" integer } }\r
+{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }\r
+{ $examples\r
+ { $example\r
+ "USING: arrays kernel generalizations prettyprint ;"\r
+ "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."\r
+ "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"\r
+ }\r
+} ;\r
+\r
HELP: n*quot\r
{ $values\r
{ "n" integer } { "seq" sequence }\r
}\r
{ $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." } ;\r
\r
-ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
-"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "\r
-"macros where the arity of the input quotations depends on an "\r
-"input parameter."\r
-$nl\r
-"Generalized sequence operations:"\r
+ARTICLE: "sequence-generalizations" "Generalized sequence operations"\r
{ $subsection narray }\r
{ $subsection nsequence }\r
{ $subsection firstn }\r
{ $subsection nappend }\r
-{ $subsection nappend-as }\r
-"Generated stack shuffle operations:"\r
+{ $subsection nappend-as } ;\r
+\r
+ARTICLE: "shuffle-generalizations" "Generalized shuffle words"\r
{ $subsection ndup }\r
{ $subsection npick }\r
{ $subsection nrot }\r
{ $subsection ndrop }\r
{ $subsection ntuck }\r
{ $subsection mnswap }\r
-"Generalized combinators:"\r
+{ $subsection nweave } ;\r
+\r
+ARTICLE: "combinator-generalizations" "Generalized combinators"\r
{ $subsection ndip }\r
{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
{ $subsection ncleave }\r
-"Generalized quotation construction:"\r
+{ $subsection nspread } ;\r
+\r
+ARTICLE: "other-generalizations" "Additional generalizations"\r
{ $subsection ncurry } \r
-{ $subsection nwith } ;\r
+{ $subsection nwith }\r
+{ $subsection nsum } ;\r
+\r
+ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
+"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "\r
+"macros where the arity of the input quotations depends on an "\r
+"input parameter."\r
+{ $subsection "sequence-generalizations" }\r
+{ $subsection "shuffle-generalizations" }\r
+{ $subsection "combinator-generalizations" }\r
+{ $subsection "other-generalizations" } ;\r
\r
ABOUT: "generalizations"\r
\r
[ 4 nappend ] must-infer\r
[ 4 { } nappend-as ] must-infer\r
+\r
+[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test\r
+{ 4 1 } [ 4 nsum ] must-infer-as\r
+\r
+[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test\r
+{ 3 5 } [ 2 nweave ] must-infer-as\r
+\r
+[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
+[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
\ No newline at end of file
-! 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
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
+MACRO: nsum ( n -- )
+ 1- [ + ] n*quot ;
+
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ '[ _ '[ _ _ 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
GENERIC: render* ( value name renderer -- xml )
-: render ( name renderer -- )
+: render>xml ( name renderer -- xml )
prepare-value
[
dup validation-error?
if
] 2dip
render*
- swap 2array write-xml ;
+ swap 2array ;
+
+: render ( name renderer -- )
+ render>xml write-xml ;
SINGLETON: label
+++ /dev/null
-Chris Double
-Slava Pestov
+++ /dev/null
-USING: help.markup help.syntax io present html ;
-IN: html.elements
-
-ARTICLE: "html.elements" "HTML elements"
-"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
-$nl
-"HTML tags can be used in a number of different ways. The simplest is a tag with no attributes:"
-{ $code "<p> \"someoutput\" write </p>" }
-"In the above, " { $link <p> } " will output the opening tag with no attributes. and " { $link </p> } " will output the closing tag."
-{ $code "<p \"red\" =class p> \"someoutput\" write </p>" }
-"This time the opening tag does not have the '>'. Any attribute words used between the calls to " { $link <p } " and " { $link p> } " will write an attribute whose value is the top of the stack. Attribute values can be any object supported by the " { $link present } " word."
-$nl
-"Values for attributes can be used directly without any stack operations. Assuming we have a string on the stack, all three of the below will output a link:"
-{ $code "<a =href a> \"Click me\" write </a>" }
-{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
-{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
-"Tags that have no “closing” equivalent have a trailing " { $snippet "tag/>" } " form:"
-{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
-"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
-$nl
-"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
-{ $subsection write-html }
-{ $subsection print-html } ;
-
-ABOUT: "html.elements"
+++ /dev/null
-IN: html.elements.tests
-USING: tools.test html.elements io.streams.string ;
-
-[ "<a href='h&o'>" ]
-[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
+++ /dev/null
-! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.styles kernel namespaces prettyprint quotations
-sequences strings words xml.entities compiler.units effects
-xml.data urls math math.parser combinators
-present fry io.streams.string xml.writer html ;
-IN: html.elements
-
-SYMBOL: html
-
-: write-html ( str -- )
- H{ { html t } } format ;
-
-: print-html ( str -- )
- write-html "\n" write-html ;
-
-<<
-
-: elements-vocab ( -- vocab-name ) "html.elements" ;
-
-: html-word ( name def effect -- )
- #! Define 'word creating' word to allow
- #! dynamically creating words.
- [ elements-vocab create ] 2dip define-declared ;
-
-: <foo> ( str -- <str> ) "<" ">" surround ;
-
-: def-for-html-word-<foo> ( name -- )
- #! Return the name and code for the <foo> patterned
- #! word.
- dup <foo> swap '[ _ <foo> write-html ]
- (( -- )) html-word ;
-
-: <foo ( str -- <str ) "<" prepend ;
-
-: def-for-html-word-<foo ( name -- )
- #! Return the name and code for the <foo patterned
- #! word.
- <foo dup '[ _ write-html ]
- (( -- )) html-word ;
-
-: foo> ( str -- foo> ) ">" append ;
-
-: def-for-html-word-foo> ( name -- )
- #! Return the name and code for the foo> patterned
- #! word.
- foo> [ ">" write-html ] (( -- )) html-word ;
-
-: </foo> ( str -- </str> ) "</" ">" surround ;
-
-: def-for-html-word-</foo> ( name -- )
- #! Return the name and code for the </foo> patterned
- #! word.
- </foo> dup '[ _ write-html ] (( -- )) html-word ;
-
-: <foo/> ( str -- <str/> ) "<" "/>" surround ;
-
-: def-for-html-word-<foo/> ( name -- )
- #! Return the name and code for the <foo/> patterned
- #! word.
- dup <foo/> swap '[ _ <foo/> write-html ]
- (( -- )) html-word ;
-
-: foo/> ( str -- str/> ) "/>" append ;
-
-: def-for-html-word-foo/> ( name -- )
- #! Return the name and code for the foo/> patterned
- #! word.
- foo/> [ "/>" write-html ] (( -- )) html-word ;
-
-: define-closed-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that closable HTML tag.
- dup def-for-html-word-<foo>
- dup def-for-html-word-<foo
- dup def-for-html-word-foo>
- def-for-html-word-</foo> ;
-
-: define-open-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that open HTML tag.
- dup def-for-html-word-<foo/>
- dup def-for-html-word-<foo
- def-for-html-word-foo/> ;
-
-: write-attr ( value name -- )
- " " write-html
- write-html
- "='" write-html
- present escape-quoted-string write-html
- "'" write-html ;
-
-: define-attribute-word ( name -- )
- dup "=" prepend swap
- '[ _ write-attr ] (( string -- )) html-word ;
-
-! Define some closed HTML tags
-[
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style" "input"
- "strong"
-] [ define-closed-html-word ] each
-
-! Define some open HTML tags
-[
- "input"
- "br"
- "hr"
- "link"
- "img"
- "base"
-] [ define-open-html-word ] each
-
-! Define some attributes
-[
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media" "title" "multiple" "checked"
- "summary" "cellspacing" "align" "scope" "abbr"
- "nofollow" "alt" "target"
-] [ define-attribute-word ] each
-
->>
+++ /dev/null
-Rendering HTML with a familiar look and feel
"<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" } "." } }
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" } ":"
[ ] [ 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
xml.data xml.writer xml.syntax strings
html.forms
html
-html.elements
html.components
html.templates
html.templates.chloe.compiler
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 [
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 ;
: [code-with] ( obj quot -- )
reset-buffer [ , ] [ % ] bi* ;
+: [xml-code] ( quot -- )
+ [ write-xml ] compose [code] ;
+
: expand-attr ( value -- )
[ value present write ] [code-with] ;
! 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
: set-title ( string -- )
title get >box ;
+: get-title ( -- string )
+ title get value>> ;
+
: write-title ( -- )
- title get value>> write ;
+ get-title write ;
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?
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+
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 ;
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 ;
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
: multiplexer-error ( n -- n )
dup 0 < [
- err_no [ EAGAIN = ] [ EINTR = ] bi or
+ errno [ EAGAIN = ] [ EINTR = ] bi or
[ drop 0 ] [ (io-error) ] if
] when ;
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 {
: 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
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 ;
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 ;
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 ;
[ 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) ]
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) ]
:: 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
] [
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 )
{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
{ 999967000236000612 } [ 999969000187000867 totient ] unit-test
{ 0 } [ 1 totient ] unit-test
+{ { 425612003 } } [ 425612003 factors ] unit-test
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 ;
[ 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 ;
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
+ maybe-fill-bytes
dup bytes>> "--\r\n" sequence= [
t >>end-of-stream?
] [
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 ;
[ 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
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 ;
-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
[ "\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
-! 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
: i-dot? ( -- ? )
locale get { "tr" "az" } member? ;
+: lt? ( -- ? )
+ locale get "lt" = ;
+
: lithuanian? ( -- ? ) locale get "lt" = ;
: dot-over ( -- ch ) HEX: 307 ;
: 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
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 ;
: (>title) ( string -- title )
i-dot? [ turk>upper ] when
+ lt? [ lithuanian>upper ] when
[ title>> ] [ ch>title ] map-case ; inline
: title-word ( string -- title )
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
{ "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 ;
n ndup quot call dup 0 < [
drop
n narray
- err_no dup strerror
+ errno dup strerror
word unix-system-call-error
] [
n nnip
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
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ) ;
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
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 ] [
! 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
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
: 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 ;
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]
- curry with-input-stream ;
\ No newline at end of file
+ curry with-input-stream ;
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 } }
{ { { $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" } }
{ 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 =
]
: 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
\ No newline at end of file
+MAIN: play-game
-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
-! 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.
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' )
[ 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 ;
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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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" ;
+
+
--- /dev/null
+! 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) ;
--- /dev/null
+Chris Double
+Slava Pestov
--- /dev/null
+USING: help.markup help.syntax io present html ;
+IN: html.elements
+
+ARTICLE: "html.elements" "HTML elements"
+"The " { $vocab-link "html.elements" } " vocabulary provides words for writing HTML tags to the " { $link output-stream } " with a familiar look and feel in the code."
+$nl
+"HTML tags can be used in a number of different ways. The simplest is a tag with no attributes:"
+{ $code "<p> \"someoutput\" write </p>" }
+"In the above, " { $link <p> } " will output the opening tag with no attributes. and " { $link </p> } " will output the closing tag."
+{ $code "<p \"red\" =class p> \"someoutput\" write </p>" }
+"This time the opening tag does not have the '>'. Any attribute words used between the calls to " { $link <p } " and " { $link p> } " will write an attribute whose value is the top of the stack. Attribute values can be any object supported by the " { $link present } " word."
+$nl
+"Values for attributes can be used directly without any stack operations. Assuming we have a string on the stack, all three of the below will output a link:"
+{ $code "<a =href a> \"Click me\" write </a>" }
+{ $code "<a \"http://\" prepend =href a> \"click\" write </a>" }
+{ $code "<a [ \"http://\" % % ] \"\" make =href a> \"click\" write </a>" }
+"Tags that have no “closing” equivalent have a trailing " { $snippet "tag/>" } " form:"
+{ $code "<input \"text\" =type \"name\" =name 20 =size input/>" }
+"For the full list of HTML tags and attributes, consult the word list for the " { $vocab-link "html.elements" } " vocabulary. In addition to HTML tag and attribute words, a few utilities are provided."
+$nl
+"Writing unescaped HTML to " { $vocab-link "html.streams" } ":"
+{ $subsection write-html }
+{ $subsection print-html } ;
+
+ABOUT: "html.elements"
--- /dev/null
+IN: html.elements.tests
+USING: tools.test html.elements io.streams.string ;
+
+[ "<a href='h&o'>" ]
+[ [ <a "h&o" =href a> ] with-string-writer ] unit-test
--- /dev/null
+! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.styles kernel namespaces prettyprint quotations
+sequences strings words xml.entities compiler.units effects
+xml.data urls math math.parser combinators
+present fry io.streams.string xml.writer html ;
+IN: html.elements
+
+SYMBOL: html
+
+: write-html ( str -- )
+ H{ { html t } } format ;
+
+: print-html ( str -- )
+ write-html "\n" write-html ;
+
+<<
+
+: elements-vocab ( -- vocab-name ) "html.elements" ;
+
+: html-word ( name def effect -- )
+ #! Define 'word creating' word to allow
+ #! dynamically creating words.
+ [ elements-vocab create ] 2dip define-declared ;
+
+: <foo> ( str -- <str> ) "<" ">" surround ;
+
+: def-for-html-word-<foo> ( name -- )
+ #! Return the name and code for the <foo> patterned
+ #! word.
+ dup <foo> swap '[ _ <foo> write-html ]
+ (( -- )) html-word ;
+
+: <foo ( str -- <str ) "<" prepend ;
+
+: def-for-html-word-<foo ( name -- )
+ #! Return the name and code for the <foo patterned
+ #! word.
+ <foo dup '[ _ write-html ]
+ (( -- )) html-word ;
+
+: foo> ( str -- foo> ) ">" append ;
+
+: def-for-html-word-foo> ( name -- )
+ #! Return the name and code for the foo> patterned
+ #! word.
+ foo> [ ">" write-html ] (( -- )) html-word ;
+
+: </foo> ( str -- </str> ) "</" ">" surround ;
+
+: def-for-html-word-</foo> ( name -- )
+ #! Return the name and code for the </foo> patterned
+ #! word.
+ </foo> dup '[ _ write-html ] (( -- )) html-word ;
+
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
+
+: def-for-html-word-<foo/> ( name -- )
+ #! Return the name and code for the <foo/> patterned
+ #! word.
+ dup <foo/> swap '[ _ <foo/> write-html ]
+ (( -- )) html-word ;
+
+: foo/> ( str -- str/> ) "/>" append ;
+
+: def-for-html-word-foo/> ( name -- )
+ #! Return the name and code for the foo/> patterned
+ #! word.
+ foo/> [ "/>" write-html ] (( -- )) html-word ;
+
+: define-closed-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that closable HTML tag.
+ dup def-for-html-word-<foo>
+ dup def-for-html-word-<foo
+ dup def-for-html-word-foo>
+ def-for-html-word-</foo> ;
+
+: define-open-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that open HTML tag.
+ dup def-for-html-word-<foo/>
+ dup def-for-html-word-<foo
+ def-for-html-word-foo/> ;
+
+: write-attr ( value name -- )
+ " " write-html
+ write-html
+ "='" write-html
+ present escape-quoted-string write-html
+ "'" write-html ;
+
+: define-attribute-word ( name -- )
+ dup "=" prepend swap
+ '[ _ write-attr ] (( string -- )) html-word ;
+
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style" "input"
+ "strong"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "hr"
+ "link"
+ "img"
+ "base"
+] [ define-open-html-word ] each
+
+! Define some attributes
+[
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
+ "media" "title" "multiple" "checked"
+ "summary" "cellspacing" "align" "scope" "abbr"
+ "nofollow" "alt" "target"
+] [ define-attribute-word ] each
+
+>>
--- /dev/null
+Rendering HTML with a familiar look and feel
--- /dev/null
+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 ;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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 ;
--- /dev/null
+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
--- /dev/null
+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
USING: kernel sequences accessors namespaces combinators words
assocs db.tuples arrays splitting strings validators urls
html.forms
-html.elements
html.components
furnace
furnace.boilerplate
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 ;
! 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
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 ) ;
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 ) ;
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 ;
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 = ;
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;
}
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);
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);
projects / factor.git / commitdiff