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

core/parser/parser-tests.factor

@@ -322,7 +322,7 @@ IN: parser.tests
     [
         "IN: parser.tests \\ class-fwd-test"
         <string-reader> "redefining-a-class-3" parse-stream drop
-    ] [ [ no-word? ] is? ] must-fail-with
+    ] [ [ no-word-error? ] is? ] must-fail-with
 
     [ ] [
         "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
@@ -332,7 +332,7 @@ IN: parser.tests
     [
         "IN: parser.tests \\ class-fwd-test"
         <string-reader> "redefining-a-class-3" parse-stream drop
-    ] [ [ no-word? ] is? ] must-fail-with
+    ] [ [ no-word-error? ] is? ] must-fail-with
 
     [
         "IN: parser.tests : foo ; TUPLE: foo ;"

core/parser/parser.factor

@@ -252,7 +252,7 @@ PREDICATE: unexpected-eof < unexpected
         [ "Use the word " swap summary append ] keep
     ] { } map>assoc ;
 
-ERROR: no-word-error name ;
+TUPLE: no-word-error name ;
 
 M: no-word-error summary
     drop "Word not found in current vocabulary search path" ;

core/vocabs/loader/loader-tests.factor

@@ -68,7 +68,7 @@ IN: vocabs.loader.tests
     <string-reader>
     "resource:core/vocabs/loader/test/a/a.factor"
     parse-stream
-] [ [ no-word? ] is? ] must-fail-with
+] [ [ no-word-error? ] is? ] must-fail-with
 
 0 "count-me" set-global
 

extra/cairo/ffi/ffi.factor

@@ -203,6 +203,9 @@ C-ENUM:
     CAIRO_HINT_METRICS_ON
 ;
 
+FUNCTION: char* cairo_status_to_string ( cairo_status_t status ) ;
+FUNCTION: cairo_status_t cairo_status ( cairo_t* cr ) ;
+
 : cairo_create ( cairo_surface_t -- cairo_t )
     "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
 

extra/cairo/png/png.factor

@@ -1,16 +1,34 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel accessors math ui.gadgets ui.render
-opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib ;
+opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
+inspector sequences combinators io.backend ;
 IN: cairo.png
 
 TUPLE: png surface width height cairo-t array ;
 TUPLE: png-gadget png ;
 
+ERROR: cairo-error string ;
+
+: check-zero
+    dup zero? [
+        "PNG dimension is 0" cairo-error
+    ] when ;
+
+: cairo-png-error ( n -- )
+    {
+        { [ dup CAIRO_STATUS_NO_MEMORY = ] [ "Cairo: no memory" cairo-error ] }
+        { [ dup CAIRO_STATUS_FILE_NOT_FOUND = ] [ "Cairo: file not found" cairo-error ] }
+        { [ dup CAIRO_STATUS_READ_ERROR = ] [ "Cairo: read error" cairo-error ] }
+        { [ t ] [ drop ] }
+    } cond ;
+
 : <png> ( path -- png )
+    normalize-pathname
     cairo_image_surface_create_from_png
-    dup [ cairo_image_surface_get_width ]
+    dup cairo_surface_status cairo-png-error
-    [ cairo_image_surface_get_height ] [ ] tri
+    dup [ cairo_image_surface_get_width check-zero ]
+    [ cairo_image_surface_get_height check-zero ] [ ] tri
     cairo-surface>array png construct-boa ;
 
 : write-png ( png path -- )
@@ -33,6 +51,7 @@ M: png-gadget draw-gadget* ( gadget -- )
         png>>
         [ width>> ]
         [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
+        ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
         [ array>> ] tri
         glDrawPixels
     ] with-translation ;
@@ -42,3 +61,5 @@ M: png-gadget graft* ( gadget -- )
 
 M: png-gadget ungraft* ( gadget -- )
     png>> surface>> cairo_destroy ;
+
+! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.

extra/inverse/inverse.factor

@@ -2,7 +2,7 @@ USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 classes.tuple namespaces vectors bit-arrays byte-arrays strings
 sbufs math.functions macros sequences.private combinators
-mirrors ;
+mirrors combinators.lib ;
 IN: inverse
 
 TUPLE: fail ;
@@ -60,38 +60,44 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
 PREDICATE: pop-inverse < word "pop-length" word-prop ;
 UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
-: inline-word ( word -- )
+: enough? ( stack quot -- ? )
-    {
+    [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
-        { [ dup word? not over symbol? or ] [ , ] }
+    recover ;
-        { [ dup explicit-inverse? ] [ , ] }
-        ! { [ dup compound? over { if dispatch } member? not and ]
-          ! [ word-def [ inline-word ] each ] }
-        { [ dup word? over { if dispatch } member? not and ]
-          [ word-def [ inline-word ] each ] }
-        { [ drop t ] [ "Quotation is not invertible" throw ] }
-    } cond ;
 
-: math-exp? ( n n word -- ? )
+: fold-word ( stack quot -- stack )
-    { + - * / ^ } member? -rot [ number? ] both? and ;
+    2dup enough?
+    [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
 
-: (fold-constants) ( quot -- )
+: fold ( quot -- folded-quot )
-    dup length 3 < [ % ] [
+    [ { } swap [ fold-word ] each % ] [ ] make ; 
-        dup first3 3dup math-exp?
-        [ execute , 3 ] [ 2drop , 1 ] if
-        tail-slice (fold-constants) 
-    ] if ;
 
-: fold-constants ( quot -- folded )
+: flattenable? ( object -- ? )
-    [ (fold-constants) ] [ ] make ;
+    [ [ word? ] [ primitive? not ] and? ] [
+        { "inverse" "math-inverse" "pop-inverse" }
+        [ word-prop ] with contains? not
+    ] and? ; 
 
-: do-inlining ( quot -- inlined-quot )
+: (flatten) ( quot -- )
-    [ [ inline-word ] each ] [ ] make fold-constants ;
+    [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
+
+ : retain-stack-overflow? ( error -- ? )
+    { "kernel-error" 14 f f } = ;
+
+: flatten ( quot -- expanded )
+    [ [ (flatten) ] [ ] make ] [
+        dup retain-stack-overflow?
+        [ drop "No inverse defined on recursive word" ] when
+        throw
+    ] recover ;
 
 GENERIC: inverse ( revquot word -- revquot* quot )
 
 M: object inverse undo-literal ;
+
 M: symbol inverse undo-literal ;
 
+M: word inverse drop "Inverse is undefined" throw ;
+
 M: normal-inverse inverse
     "inverse" word-prop ;
 
@@ -109,7 +115,7 @@ M: pop-inverse inverse
     [ unclip-slice inverse % (undo) ] if ;
 
 : [undo] ( quot -- undo )
-    do-inlining reverse [ (undo) ] [ ] make ;
+    flatten fold reverse [ (undo) ] [ ] make ;
 
 MACRO: undo ( quot -- ) [undo] ;
 

extra/random/random.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel math namespaces sequences
-io.backend io.binary combinators system vocabs.loader ;
+io.backend io.binary combinators system vocabs.loader
+inspector ;
 IN: random
 
 SYMBOL: insecure-random-generator
@@ -19,6 +20,9 @@ M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
 
 ERROR: no-random-number-generator ;
 
+M: no-random-number-generator summary
+    drop "Random number generator is not defined." ;
+
 M: f random-bytes* ( n obj -- * ) no-random-number-generator ;
 
 M: f random-32* ( obj -- * ) no-random-number-generator ;

extra/random/windows/windows.factor

@@ -1,31 +1,54 @@
 USING: accessors alien.c-types byte-arrays continuations
-kernel windows windows.advapi32 init namespaces random ;
+kernel windows windows.advapi32 init namespaces random
+destructors locals ;
+USE: tools.walker
 IN: random.windows
 
-TUPLE: windows-crypto-context handle ;
+TUPLE: windows-rng provider type ;
+C: <windows-rng> windows-rng
 
+TUPLE: windows-crypto-context handle ;
 C: <windows-crypto-context> windows-crypto-context
 
 M: windows-crypto-context dispose ( tuple -- )
     handle>> 0 CryptReleaseContext win32-error=0/f ;
 
-TUPLE: windows-cryptographic-rng context ;
+: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline
 
-C: <windows-cryptographic-rng> windows-cryptographic-rng
+:: (acquire-crypto-context) ( provider type flags -- handle )
+    [let | handle [ "HCRYPTPROV" <c-object> ] |
+        handle
+        factor-crypto-container
+        provider
+        type
+        flags
+        CryptAcquireContextW win32-error=0/f
+        handle *void* ] ;
 
-M: windows-cryptographic-rng dispose ( tuple -- )
+: acquire-crypto-context ( provider type -- handle )
-    context>> dispose ;
+    [ 0 (acquire-crypto-context) ]
+    [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
 
-M: windows-cryptographic-rng random-bytes* ( tuple n -- bytes )
-    >r context>> r> dup <byte-array>
-    [ CryptGenRandom win32-error=0/f ] keep ;
 
-: windows-aes-context ( -- context )
+: windows-crypto-context ( provider type -- context )
-    "HCRYPTPROV" <c-object>
+    acquire-crypto-context <windows-crypto-context> ;
-    dup f f PROV_RSA_AES CRYPT_NEWKEYSET
-    CryptAcquireContextW win32-error=0/f *void*
-    <windows-crypto-context> ;
 
-! [
+M: windows-rng random-bytes* ( n tuple -- bytes )
-    ! windows-aes-context secure-random-generator set-global
+    [
-! ] "random.windows" add-init-hook
+        [ provider>> ] [ type>> ] bi
+        windows-crypto-context
+        dup add-always-destructor handle>>
+        swap dup <byte-array>
+        [ CryptGenRandom win32-error=0/f ] keep
+    ] with-destructors ;
+
+[
+    MS_DEF_PROV
+    PROV_RSA_FULL <windows-rng> insecure-random-generator set-global
+
+    ! MS_STRONG_PROV
+    ! PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+
+    MS_ENH_RSA_AES_PROV
+    PROV_RSA_AES <windows-rng> secure-random-generator set-global
+] "random.windows" add-init-hook

extra/units/units-tests.factor

@@ -15,9 +15,7 @@ IN: units.tests
 [ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
 [ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
 
-! I want these to work, Dan
-
 : km/L km 1 L d/ ;
 : mpg miles 1 gallons d/ ;
 
-! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
+[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test

extra/units/units.factor

@@ -95,3 +95,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
 : d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ;
 
 : d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ;
+
+\ d+ [ d- ] [ d- ] define-math-inverse
+\ d- [ d+ ] [ d- ] define-math-inverse
+\ d* [ d/ ] [ d/ ] define-math-inverse
+\ d/ [ d* ] [ d/ ] define-math-inverse
+\ d-recip [ d-recip ] define-inverse

extra/windows/advapi32/advapi32.factor

@@ -21,6 +21,40 @@ LIBRARY: advapi32
 : PROV_REPLACE_OWF   23 ; inline
 : PROV_RSA_AES       24 ; inline
 
+: MS_DEF_DH_SCHANNEL_PROV
+    "Microsoft DH Schannel Cryptographic Provider" ; inline
+
+: MS_DEF_DSS_DH_PROV
+    "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider" ; inline
+
+: MS_DEF_DSS_PROV
+    "Microsoft Base DSS Cryptographic Provider" ; inline
+
+: MS_DEF_PROV
+    "Microsoft Base Cryptographic Provider v1.0" ; inline
+
+: MS_DEF_RSA_SCHANNEL_PROV
+    "Microsoft RSA Schannel Cryptographic Provider" ; inline
+
+! Unsupported (!)
+: MS_DEF_RSA_SIG_PROV
+    "Microsoft RSA Signature Cryptographic Provider" ; inline
+
+: MS_ENH_DSS_DH_PROV
+    "Microsoft Enhanced DSS and Diffie-Hellman Cryptographic Provider" ; inline
+
+: MS_ENH_RSA_AES_PROV
+    "Microsoft Enhanced RSA and AES Cryptographic Provider" ; inline
+
+: MS_ENHANCED_PROV
+    "Microsoft Enhanced Cryptographic Provider v1.0" ; inline
+
+: MS_SCARD_PROV
+    "Microsoft Base Smart Card Crypto Provider" ; inline
+
+: MS_STRONG_PROV
+    "Microsoft Strong Cryptographic Provider" ; inline
+
 : CRYPT_VERIFYCONTEXT  HEX: F0000000 ; inline
 : CRYPT_NEWKEYSET      HEX: 8 ; inline
 : CRYPT_DELETEKEYSET   HEX: 10 ; inline