diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index ff9d4cefc4..cf5daa1562 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -178,6 +178,8 @@ GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; +M: f byte-length drop 0 ; + : c-getter ( name -- quot ) c-type-getter [ [ "Cannot read struct fields with this type" throw ] diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index b9c62f1429..f3c2deb2d8 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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 \ No newline at end of file + C{ 1.5 1.0 } ffi_test_47 +] unit-test diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor index 6024607d37..d7d9ae9ebb 100644 --- a/basis/furnace/chloe-tags/chloe-tags.factor +++ b/basis/furnace/chloe-tags/chloe-tags.factor @@ -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 -- ) - [ > 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 [ ] [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 + [ [XML <-> XML] second swap >>attrs ] + [xml-code] ] compile-with-scope ; CHLOE: base - compile-a-url [ ] [code] ; + compile-a-url [ [XML /> XML] ] [xml-code] ; : compile-hidden-form-fields ( for -- ) '[ -
- _ [ "," split [ hidden render ] each ] when* - nested-forms get " " join f like nested-forms-key hidden-form-field - [ modify-form ] each-responder -
+ _ [ "," 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 + [XML
<-><-><->
XML] ] [code] ; -: compile-form-attrs ( method action attrs -- ) - [
] [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 [
] [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 + [ + [XML
<-><->
XML] second + swap >>attrs + write-xml + ] [code] ] compile-with-scope ; : button-tag-markup ( -- xml ) @@ -121,13 +126,13 @@ CHLOE: 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 ] diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f6e5434997..f01260c68b 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -30,7 +30,7 @@ M: base-path-check-responder call-responder* "a/b/c" split-path main-responder get call-responder body>> ] unit-test -[ "" ] +[ "" ] [ [ "&&&" "foo" hidden-form-field ] with-string-writer ] unit-test diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 8b7e1ab83f..52e705c153 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -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 ; diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..6defba54d2 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -27,7 +27,7 @@ HELP: hidden-form-field { $example "USING: furnace.utilities io ;" "\"bar\" \"foo\" hidden-form-field nl" - "" + "" } } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index e09047b74a..a2d4c4d996 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -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 [ - - ] [ 2drop ] if ; + [XML name=<->/> XML] + ] [ drop ] if ; + +: hidden-form-field ( value name -- ) + hidden-form-field>xml write-xml ; : nested-forms-key "__n" ; diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index 82bb75015e..2b18e28351 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -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 diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index f6408d3b59..18e6db66f6 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags" "" " View" - "s" + "" } } } { { $snippet "t:base" } { "Outputs an HTML " { $snippet "" } " 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 ;" } +"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 /> 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" } ":" diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 19b67f7018..4e454dcee4 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -135,7 +135,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index 6ab6722afe..89d00e1f6e 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -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 - [ write-title ] [ write-title ] ? [code] ; + [ get-title [XML <-> XML] ] + [ get-title ] ? + [xml-code] ; CHLOE: style dup "include" optional-attr [ @@ -39,10 +40,9 @@ CHLOE: style CHLOE: write-style drop [ - - ] [code] ; + get-style + [XML XML] + ] [xml-code] ; CHLOE: even [ "index" value even? swap when ] process-children ; diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 7180e8cdbc..394b5ef359 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -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] ; diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index 4aca73cc57..4a416e353f 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -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 href=<->/> - XML] write-xml - ] each ; + XML] + ] { } assoc>map ; + +: write-atom-feeds ( -- ) + get-atom-feeds write-xml ; SYMBOL: nested-template? diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4bc8868a3c..d86a72c665 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -84,8 +84,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 +104,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 +143,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 +177,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 ; diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 0326969e4f..f78f61ef3b 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ push ] [ drop ] 2bi ; : set-default-password ( ctx -- ) - [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] - [ - [ handle>> ] [ default-pasword ] bi - SSL_CTX_set_default_passwd_cb_userdata - ] bi ; + dup config>> password>> [ + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi + ] [ drop ] if ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8419246eb6..f1f39a0559 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -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 ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index f209df5862..e701874afd 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -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 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 ] [ diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index 1e751833a2..c154544f81 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,10 +2,16 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations destructors kernel -namespaces accessors sets summary ; +USING: alien assocs continuations 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 ; + > length ] keep '[ _ ndup @ ] ;" + } + "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:" + { $code + ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline" + } + "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand." + $nl + "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language." } ; HELP: macro { $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ; ARTICLE: "macros" "Macros" -"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances." +$nl +"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +$nl +"Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" { $subsection POSTPONE: MACRO: } -"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; +"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." +{ $subsection define-transform } +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; ABOUT: "macros" diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 1481e6eea5..4fba7efba3 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; IN: macros +> 1 ; +PRIVATE> + : define-macro ( word definition -- ) [ "macro" set-word-prop ] [ over real-macro-effect memoize-quot [ call ] append define ] diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor index f247683c1c..983de51216 100644 --- a/basis/math/primes/factors/factors-tests.factor +++ b/basis/math/primes/factors/factors-tests.factor @@ -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 diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 05d6b26010..4c36fc0a85 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -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 ; diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index aec4414c71..3cf7dbab4c 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -113,9 +113,7 @@ CONSTANT: packed-length-table MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as - '[ _ spread ] - '[ _ input @@ -143,7 +141,7 @@ MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map - '[ _ cleave ] '[ _ output>array ] ; + '[ [ _ cleave ] output>array ] ; PRIVATE> diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7cdce301b5..56aebb20e7 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -89,44 +89,37 @@ M: composed infer-call* M: object infer-call* \ literal-expected inference-warning ; -: infer-slip ( -- ) - 1 infer->r infer-call 1 infer-r> ; +: infer-nslip ( n -- ) + [ infer->r infer-call ] [ infer-r> ] bi ; -: infer-2slip ( -- ) - 2 infer->r infer-call 2 infer-r> ; +: infer-slip ( -- ) 1 infer-nslip ; -: infer-3slip ( -- ) - 3 infer->r infer-call 3 infer-r> ; +: infer-2slip ( -- ) 2 infer-nslip ; -: infer-dip ( -- ) - literals get - [ \ dip def>> infer-quot-here ] - [ pop 1 infer->r infer-quot-here 1 infer-r> ] +: infer-3slip ( -- ) 3 infer-nslip ; + +: infer-ndip ( word n -- ) + [ literals get ] 2dip + [ '[ _ def>> infer-quot-here ] ] + [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi* if-empty ; -: infer-2dip ( -- ) - literals get - [ \ 2dip def>> infer-quot-here ] - [ pop 2 infer->r infer-quot-here 2 infer-r> ] - if-empty ; +: infer-dip ( -- ) \ dip 1 infer-ndip ; -: infer-3dip ( -- ) - literals get - [ \ 3dip def>> infer-quot-here ] - [ pop 3 infer->r infer-quot-here 3 infer-r> ] - if-empty ; +: infer-2dip ( -- ) \ 2dip 2 infer-ndip ; -: infer-curry ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ curry #call, ; +: infer-3dip ( -- ) \ 3dip 3 infer-ndip ; -: infer-compose ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ compose #call, ; +: infer-builder ( quot word -- ) + [ + [ 2 consume-d ] dip + [ dup first2 ] dip call make-known + [ push-d ] [ 1array ] bi + ] dip #call, ; inline + +: infer-curry ( -- ) [ ] \ curry infer-builder ; + +: infer-compose ( -- ) [ ] \ compose infer-builder ; : infer-execute ( -- ) pop-literal nip diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5b67cd9adc..5926f08d8c 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -80,13 +80,6 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "compiler-transforms" "Compiler transforms" -"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time." -{ $subsection define-transform } -"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "." -$nl -"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; - ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl @@ -103,7 +96,6 @@ $nl { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } { $subsection "inference-errors" } -{ $subsection "compiler-transforms" } { $see-also "effects" } ; ABOUT: "inference" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 4d7295042c..bc6eb9f092 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -577,3 +577,8 @@ DEFER: eee' [ bogus-error ] must-infer [ [ clear ] infer. ] [ inference-error? ] must-fail-with + +: debugging-curry-folding ( quot -- ) + [ debugging-curry-folding ] curry call ; inline recursive + +[ [ ] debugging-curry-folding ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor index a178669595..de0edc4528 100644 --- a/basis/stack-checker/transforms/transforms-docs.factor +++ b/basis/stack-checker/transforms/transforms-docs.factor @@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ; HELP: define-transform { $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } } -{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." } -{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:" -{ $code ": ndrop ( n -- ) [ drop ] times ;" } -"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:" -{ $code "\\ ndrop [ \\ drop >quotation ] 1 define-transform" } -"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "." +{ $description "Defines a compiler transform for the optimizing compiler." + "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "." $nl -"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" +"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect." +$nl +"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." } +{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $code "\\ cond [ cond>quot ] 1 define-transform" } } ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 2e2dccd6c4..fe580084c0 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -57,3 +57,12 @@ DEFER: smart-combo ( quot -- ) [ [ "a" "b" "c" ] very-smart-combo ] must-infer [ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer + +! Caveat found by Doug +DEFER: curry-folding-test ( quot -- ) + +\ curry-folding-test [ length \ drop >quotation ] 1 define-transform + +{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as +{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index e5c2f05d72..a2f616480a 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -24,8 +24,10 @@ IN: stack-checker.transforms rstate infer-quot ] [ word give-up-transform ] if* ; +: literals? ( values -- ? ) [ literal-value? ] all? ; + : (apply-transform) ( word quot n -- ) - ensure-d dup [ known literal? ] all? [ + ensure-d dup literals? [ dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 97aa774e55..19db441381 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -26,27 +26,51 @@ SYMBOL: known-values : copy-values ( values -- values' ) [ copy-value ] map ; +GENERIC: (literal-value?) ( value -- ? ) + +M: object (literal-value?) drop f ; + +GENERIC: (literal) ( value -- literal ) + ! Literal value TUPLE: literal < identity-tuple value recursion hashcode ; +: literal ( value -- literal ) known (literal) ; + +: literal-value? ( value -- ? ) known (literal-value?) ; + M: literal hashcode* nip hashcode>> ; : ( obj -- value ) recursive-state get over hashcode \ literal boa ; -GENERIC: (literal) ( value -- literal ) +M: literal (literal-value?) drop t ; M: literal (literal) ; -: literal ( value -- literal ) - known (literal) ; +: curried/composed-literal ( input1 input2 quot -- literal ) + [ [ literal ] bi@ ] dip + [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi + over hashcode \ literal boa ; inline ! Result of curry TUPLE: curried obj quot ; C: curried +: >curried< ( curried -- obj quot ) + [ obj>> ] [ quot>> ] bi ; inline + +M: curried (literal-value?) >curried< [ literal-value? ] both? ; +M: curried (literal) >curried< [ curry ] curried/composed-literal ; + ! Result of compose TUPLE: composed quot1 quot2 ; C: composed + +: >composed< ( composed -- quot1 quot2 ) + [ quot1>> ] [ quot2>> ] bi ; inline + +M: composed (literal-value?) >composed< [ literal-value? ] both? ; +M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 6e26a36a19..52a8d9755e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -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 diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 65fab0ac38..3ac98cd57f 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -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 ) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 42444261e2..76613934af 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -37,18 +37,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 +56,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 diff --git a/basis/zlib/authors.txt b/basis/zlib/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/authors.txt b/basis/zlib/ffi/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/zlib/ffi/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..bda2809f56 --- /dev/null +++ b/basis/zlib/ffi/ffi.factor @@ -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 ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor new file mode 100755 index 0000000000..0ac77277dc --- /dev/null +++ b/basis/zlib/zlib-tests.factor @@ -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 diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor new file mode 100755 index 0000000000..b40d9c2a98 --- /dev/null +++ b/basis/zlib/zlib.factor @@ -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 ; + +: ( 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 dup length ] keep [ + dup length zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + zlib.ffi:uncompress zlib-error + ] bi *ulong head ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d85a51edff..71183093ee 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } ; + ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } { $subsection "words" } @@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -$nl -"Data flow combinators:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -"Control flow combinators:" +{ $subsection "dataflow-combinators" } { $subsection "conditionals" } { $subsection "looping-combinators" } -"Additional combinators:" { $subsection "compositional-combinators" } { $subsection "combinators" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." @@ -973,6 +973,7 @@ $nl "Advanced topics:" { $subsection "assertions" } { $subsection "implementing-combinators" } +{ $subsection "macros" } { $subsection "errors" } { $subsection "continuations" } ; diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 764df9924c..4dfa2d49bc 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -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" } } diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 126215ab13..f842d5f4cb 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -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 \ No newline at end of file +MAIN: play-game diff --git a/extra/graphics/bitmap/bitmap-tests.factor b/extra/graphics/bitmap/bitmap-tests.factor index 15e960084a..f8a125e855 100644 --- a/extra/graphics/bitmap/bitmap-tests.factor +++ b/extra/graphics/bitmap/bitmap-tests.factor @@ -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 diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor index bd34a9ee41..f8008dc7c1 100755 --- a/extra/graphics/bitmap/bitmap.factor +++ b/extra/graphics/bitmap/bitmap.factor @@ -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 [ 3 head-slice ] map ] [ color-index>> >array ] bi [ swap nth ] with map concat ; -: 4bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 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 3 [ 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 ; diff --git a/basis/html/elements/authors.txt b/extra/html/elements/authors.txt similarity index 100% rename from basis/html/elements/authors.txt rename to extra/html/elements/authors.txt diff --git a/basis/html/elements/elements-docs.factor b/extra/html/elements/elements-docs.factor similarity index 100% rename from basis/html/elements/elements-docs.factor rename to extra/html/elements/elements-docs.factor diff --git a/basis/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor similarity index 100% rename from basis/html/elements/elements-tests.factor rename to extra/html/elements/elements-tests.factor diff --git a/basis/html/elements/elements.factor b/extra/html/elements/elements.factor similarity index 100% rename from basis/html/elements/elements.factor rename to extra/html/elements/elements.factor diff --git a/basis/html/elements/summary.txt b/extra/html/elements/summary.txt similarity index 100% rename from basis/html/elements/summary.txt rename to extra/html/elements/summary.txt diff --git a/basis/html/elements/tags.txt b/extra/html/elements/tags.txt similarity index 100% rename from basis/html/elements/tags.txt rename to extra/html/elements/tags.txt diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 9d4e348596..c0cd601af5 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -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 diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 36147795d1..a5a43cf2ae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -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; } diff --git a/vm/ffi_test.h b/vm/ffi_test.h index de48d6dc5b..f8634b304e 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -89,4 +89,8 @@ DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); -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); diff --git a/vm/io.h b/vm/io.h index 08c9dd7807..dc7d69edee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -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); diff --git a/vm/master.h b/vm/master.h index 01b2335841..86b5223eaa 100644 --- a/vm/master.h +++ b/vm/master.h @@ -8,7 +8,6 @@ #include #include #include -#include #include #include