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

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

db4
Eduardo Cavazos 2008-03-29 16:08:55 -06:00
parent 8ea195d8ce f72336e70e
commit 2e04b8623d
11 changed files with 147 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/parser/parser-tests.factor
View File

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

2
core/parser/parser.factor
View File

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

2
core/vocabs/loader/loader-tests.factor
View File

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

3
extra/cairo/ffi/ffi.factor
View File

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

27
extra/cairo/png/png.factor
View File

@ -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 ]
[ cairo_image_surface_get_height ] [ ] tri
dup cairo_surface_status cairo-png-error
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.

54
extra/inverse/inverse.factor
View File

@ -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 -- )
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ 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 ;
: enough? ( stack quot -- ? )
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
recover ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] both? and ;
: fold-word ( stack quot -- stack )
2dup enough?
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [
dup first3 3dup math-exp?
[ execute , 3 ] [ 2drop , 1 ] if
tail-slice (fold-constants)
] if ;
: fold ( quot -- folded-quot )
[ { } swap [ fold-word ] each % ] [ ] make ;
: fold-constants ( quot -- folded )
[ (fold-constants) ] [ ] make ;
: flattenable? ( object -- ? )
[ [ word? ] [ primitive? not ] and? ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
] and? ;
: do-inlining ( quot -- inlined-quot )
[ [ inline-word ] each ] [ ] make fold-constants ;
: (flatten) ( quot -- )
[ 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] ;

6
extra/random/random.factor
View File

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

57
extra/random/windows/windows.factor
View File

@ -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 -- )
context>> dispose ;
: acquire-crypto-context ( provider type -- handle )
[ 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 )
"HCRYPTPROV" <c-object>
dup f f PROV_RSA_AES CRYPT_NEWKEYSET
CryptAcquireContextW win32-error=0/f *void*
<windows-crypto-context> ;
: windows-crypto-context ( provider type -- context )
acquire-crypto-context <windows-crypto-context> ;
! [
! windows-aes-context secure-random-generator set-global
! ] "random.windows" add-init-hook
M: windows-rng random-bytes* ( n tuple -- bytes )
[
[ 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

4
extra/units/units-tests.factor
View File

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

6
extra/units/units.factor
View File

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

34
extra/windows/advapi32/advapi32.factor
View File

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