Merge branch 'master' of git://factorcode.org/git/factor into no-elements

db4
Daniel Ehrenberg 2009-02-08 21:04:08 -06:00
commit 7a8a48bdab
106 changed files with 1825 additions and 509 deletions

View File

@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
* Running Factor on Windows XP/Vista
The Factor runtime is compiled into two binaries:
factor.com - a Windows console application
factor.exe - a Windows native application, without a console
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
the command prompt using the console application:
factor.exe -i=boot.<cpu>.image
factor.com -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
To run the listener in the command prompt:
factor.exe -run=listener
factor.com -run=listener
* The Factor FAQ

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel namespaces make libc cpu.architecture ;
sequences math kernel namespaces fry libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -10,7 +10,7 @@ M: array c-type ;
M: array c-type-class drop object ;
M: array heap-size unclip heap-size [ * ] reduce ;
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot drop f ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
M: value-type c-type-reg-class drop int-regs ;
M: value-type c-type-boxer-quot drop f ;
M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
M: value-type c-type-setter ( type -- quot )
[
dup c-type-getter % \ swap , heap-size , \ memcpy ,
] [ ] make ;
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;

View File

@ -178,6 +178,8 @@ $nl
{ { $snippet "ulonglong" } { } }
{ { $snippet "float" } { } }
{ { $snippet "double" } { "same format as " { $link float } " objects" } }
{ { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } }
{ { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } }
}
"When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision."
$nl

View File

@ -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 ]
@ -201,13 +203,13 @@ M: byte-array byte-length length ;
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
dup length [ nip malloc dup ] 2keep memcpy ;
dup byte-length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
swap dup byte-length memcpy ;
: array-accessor ( type quot -- def )
[
@ -263,7 +265,7 @@ M: long-long-type box-return ( type -- )
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
binary file-contents [ malloc-byte-array ] [ length ] bi ;
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
@ -283,9 +285,10 @@ M: long-long-type box-return ( type -- )
<c-type>
c-ptr >>class
[ alien-cell ] >>getter
[ set-alien-cell ] >>setter
[ [ >c-ptr ] 2dip set-alien-cell ] >>setter
bootstrap-cell >>size
bootstrap-cell >>align
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
"void*" define-primitive-type

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex kernel alien.c-types alien.syntax
namespaces ;
IN: alien.complex.tests
C-STRUCT: complex-holder
{ "complex-float" "z" } ;
: <complex-holder> ( z -- alien )
"complex-holder" <c-object>
[ set-complex-holder-z ] keep ;
[ ] [
C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test

View File

@ -0,0 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.complex.functor sequences kernel ;
IN: alien.complex
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test alien.complex.functor ;
IN: alien.complex.functor.tests

View File

@ -0,0 +1,35 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.structs alien.c-types math math.functions sequences
arrays kernel functors vocabs.parser namespaces accessors
quotations ;
IN: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- )
T-real DEFINES ${T}-real
T-imaginary DEFINES ${T}-imaginary
set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary
>T DEFINES >${T}
T> DEFINES ${T}>
WHERE
: >T ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
: T> ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
T in get
{ { N "real" } { N "imaginary" } }
define-struct
T c-type
T> 1quotation >>boxer-quot
>T 1quotation >>unboxer-quot
drop
;FUNCTOR

View File

@ -0,0 +1 @@
Implementation details for C99 complex float and complex double types

View File

@ -5,7 +5,7 @@ math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order ;
IN: alien.structs
TUPLE: struct-type size align fields ;
TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
M: struct-type heap-size size>> ;
@ -15,6 +15,10 @@ M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type c-type-boxer-quot boxer-quot>> ;
M: struct-type c-type-unboxer-quot unboxer-quot>> ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
@ -40,7 +44,10 @@ M: struct-type stack-size
: (define-struct) ( name size align fields -- )
[ [ align ] keep ] dip
struct-type boa
struct-type new
swap >>fields
swap >>align
swap >>size
swap typedef ;
: make-fields ( name vocab fields -- fields )

View File

@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global
[ 0 <uint> [ class_copyMethodList ] keep *uint ] dip
over 0 = [ 3drop ] [
[ <direct-void*-array> ] dip
[ each ] [ drop underlying>> (free) ] 2bi
[ each ] [ drop (free) ] 2bi
] if ; inline
: register-objc-methods ( class -- )

View File

@ -68,7 +68,7 @@ PRIVATE>
NSOpenGLPFASamples , 8 ,
] when
0 ,
] int-array{ } make underlying>>
] int-array{ } make
-> initWithAttributes:
-> autorelease ;

View File

@ -37,3 +37,11 @@ IN: combinators.smart.tests
[
[ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
] unit-test
! Test nesting
: nested-smart-combo-test ( -- array )
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
\ nested-smart-combo-test must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test

View File

@ -3,8 +3,8 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays sets libc continuations.private
fry cpu.architecture
alien.strings alien.arrays alien.complex sets libc
continuations.private fry cpu.architecture
compiler.errors
compiler.alien
compiler.cfg

View File

@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
[ 32.0 ] [
{ 1.0 2.0 3.0 } >float-array underlying>>
{ 4.0 5.0 6.0 } >float-array underlying>>
{ 1.0 2.0 3.0 } >float-array
{ 4.0 5.0 6.0 } >float-array
ffi_test_23
] unit-test
@ -558,3 +558,18 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
[ ] [ stack-frame-bustage 2drop ] unit-test
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_47
] unit-test

View File

@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str )
} case ;
: param-types ( statement -- seq )
in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
in-params>> [ type>> type>oid ] uint-array{ } map-as ;
: malloc-byte-array/length ( byte-array -- alien length )
[ malloc-byte-array &free ] [ length ] bi ;
@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str )
] 2map flip [
f f
] [
first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
first2 [ >void*-array ] [ >uint-array ] bi*
] if-empty ;
: param-formats ( statement -- seq )
in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
in-params>> [ type>> type>param-format ] uint-array{ } map-as ;
: do-postgresql-bound-statement ( statement -- res )
[

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

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces tools.test endian ;
IN: endian.tests
[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test
[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test

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

@ -0,0 +1,67 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry
kernel math ;
IN: endian
SINGLETONS: big-endian little-endian ;
: native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ;
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
native-endianness \ native-endianness set-global
SYMBOL: endianness
\ native-endianness get-global endianness set-global
HOOK: >native-endian native-endianness ( obj n -- str )
M: big-endian >native-endian >be ;
M: little-endian >native-endian >le ;
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
M: big-endian unsigned-native-endian> be> ;
M: little-endian unsigned-native-endian> le> ;
: signed-native-endian> ( obj n -- str )
[ unsigned-native-endian> ] dip >signed ;
HOOK: >endian endianness ( obj n -- str )
M: big-endian >endian >be ;
M: little-endian >endian >le ;
HOOK: endian> endianness ( seq -- n )
M: big-endian endian> be> ;
M: little-endian endian> le> ;
HOOK: unsigned-endian> endianness ( obj -- str )
M: big-endian unsigned-endian> be> ;
M: little-endian unsigned-endian> le> ;
: signed-endian> ( obj n -- str )
[ unsigned-endian> ] dip >signed ;
: with-endianness ( endian quot -- )
[ endianness ] dip with-variable ; inline
: with-big-endian ( quot -- )
big-endian swap with-endianness ; inline
: with-little-endian ( quot -- )
little-endian swap with-endianness ; inline
: with-native-endian ( quot -- )
\ native-endianness get-global swap with-endianness ; inline

View File

@ -1,11 +1,12 @@
IN: functors.tests
USING: functors tools.test math words kernel ;
USING: functors tools.test math words kernel multiline parser
io.streams.string generic ;
<<
FUNCTOR: define-box ( T -- )
B DEFINES ${T}-box
B DEFINES-CLASS ${T}-box
<B> DEFINES <${B}>
WHERE
@ -62,4 +63,48 @@ WHERE
>>
[ 4 ] [ 1 3 blah ] unit-test
[ 4 ] [ 1 3 blah ] unit-test
GENERIC: some-generic ( a -- b )
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
<" IN: functors.tests
TUPLE: some-tuple ;
: some-word ( -- ) ;
M: some-tuple some-generic ;
"> <string-reader> "functors-test" parse-stream
] unit-test
: test-redefinition ( -- )
[ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
[ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
[ t ] [
"some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean
] unit-test ;
test-redefinition
FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic
WHERE
TUPLE: W-tuple ;
: W-word ( -- ) ;
M: W-tuple W-generic ;
;FUNCTOR
[ [ ] ] [
<" IN: functors.tests
<< "some" redefine-test >>
"> <string-reader> "functors-test" parse-stream
] unit-test
test-redefinition

View File

@ -3,8 +3,9 @@
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser
locals.rewrite.closures vocabs.parser arrays accessors ;
effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser
arrays accessors ;
IN: functors
! This is a hack
@ -29,7 +30,7 @@ M: object >fake-quotations ;
GENERIC: fake-quotations> ( fake -- quot )
M: fake-quotation fake-quotations>
seq>> [ fake-quotations> ] map >quotation ;
seq>> [ fake-quotations> ] [ ] map-as ;
M: array fake-quotations> [ fake-quotations> ] map ;
@ -57,7 +58,7 @@ M: object fake-quotations> ;
effect off
scan-param parsed
scan-param parsed
\ create-method parsed
\ create-method-in parsed
parse-definition*
DEFINE* ; parsing
@ -96,6 +97,8 @@ PRIVATE>
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing
DEFER: ;FUNCTOR delimiter
<PRIVATE

View File

@ -27,7 +27,7 @@ HELP: hidden-form-field
{ $example
"USING: furnace.utilities io ;"
"\"bar\" \"foo\" hidden-form-field nl"
"<input type='hidden' name='foo' value='bar'/>"
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
}
} ;

View File

@ -30,6 +30,10 @@ HELP: narray
{ nsequence narray } related-words
HELP: nsum
{ $values { "n" integer } }
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
HELP: firstn
{ $values { "n" integer } }
{ $description "A generalization of " { $link first } ", "
@ -238,6 +242,11 @@ HELP: ncleave
}
} ;
HELP: nspread
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
} ;
HELP: mnswap
{ $values { "m" integer } { "n" integer } }
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
@ -250,6 +259,17 @@ HELP: mnswap
}
} ;
HELP: nweave
{ $values { "n" integer } }
{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
{ $examples
{ $example
"USING: arrays kernel generalizations prettyprint ;"
"\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
"{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
}
} ;
HELP: n*quot
{ $values
{ "n" integer } { "seq" sequence }
@ -299,18 +319,14 @@ HELP: ntuck
}
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
$nl
"Generalized sequence operations:"
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
{ $subsection narray }
{ $subsection nsequence }
{ $subsection firstn }
{ $subsection nappend }
{ $subsection nappend-as }
"Generated stack shuffle operations:"
{ $subsection nappend-as } ;
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
{ $subsection ndup }
{ $subsection npick }
{ $subsection nrot }
@ -319,14 +335,28 @@ $nl
{ $subsection ndrop }
{ $subsection ntuck }
{ $subsection mnswap }
"Generalized combinators:"
{ $subsection nweave } ;
ARTICLE: "combinator-generalizations" "Generalized combinators"
{ $subsection ndip }
{ $subsection nslip }
{ $subsection nkeep }
{ $subsection napply }
{ $subsection ncleave }
"Generalized quotation construction:"
{ $subsection nspread } ;
ARTICLE: "other-generalizations" "Additional generalizations"
{ $subsection ncurry }
{ $subsection nwith } ;
{ $subsection nwith }
{ $subsection nsum } ;
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
"input parameter."
{ $subsection "sequence-generalizations" }
{ $subsection "shuffle-generalizations" }
{ $subsection "combinator-generalizations" }
{ $subsection "other-generalizations" } ;
ABOUT: "generalizations"

View File

@ -53,3 +53,12 @@ IN: generalizations.tests
[ 4 nappend ] must-infer
[ 4 { } nappend-as ] must-infer
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
{ 4 1 } [ 4 nsum ] must-infer-as
[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
{ 3 5 } [ 2 nweave ] must-infer-as
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test

View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators
@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- )
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
MACRO: nspread ( quots n -- )
over empty? [ 2drop [ ] ] [
[ [ but-last ] dip ]
[ [ peek ] dip ] 2bi
swap
'[ [ _ _ nspread ] _ ndip @ ]
] if ;
MACRO: napply ( quot n -- )
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] <repetition> spread>quot ;
1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
MACRO: nweave ( n -- )
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
'[ _ _ ncleave ] ;
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline

View File

@ -261,7 +261,7 @@ $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 "xml.literals" } ":"
"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" }

View File

@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
] [ 2drop f ] if ;
: wait-event ( mx us -- n )
[ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi*
[ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi*
epoll_wait multiplexer-error ;
: handle-event ( event mx -- )

View File

@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
: wait-kevent ( mx timespec -- n )
[
[ fd>> f 0 ]
[ events>> [ underlying>> ] [ length ] bi ] bi
[ events>> dup length ] bi
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )

View File

@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: init-fdsets ( mx -- nfds read write except )
[ num-fds ]
[ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ]
[ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri
[ read-fdset/tasks [ init-fdset ] keep ]
[ write-fdset/tasks [ init-fdset ] keep ] tri
f ;
M:: select-mx wait-for-events ( us mx -- )

View File

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

View File

@ -82,6 +82,24 @@ M: winnt init-io ( -- )
H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ;
ERROR: invalid-file-size n ;
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
M: winnt seek-handle ( n seek-type handle -- )
swap {
{ seek-absolute [ set-seek-ptr ] }
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
: file-error? ( n -- eof? )
zero? [
GetLastError {

View File

@ -103,7 +103,7 @@ TUPLE: CreateProcess-args
over get-environment
[ swap % "=" % % "\0" % ] assoc-each
"\0" %
] ushort-array{ } make underlying>>
] ushort-array{ } make
>>lpEnvironment
] when ;
@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- )
M: windows wait-for-processes ( -- ? )
processes get keys dup
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
[ length ] [ underlying>> ] bi 0 0
[ length ] keep 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;

View File

@ -7,5 +7,5 @@ QUALIFIED: io.pipes
M: unix io.pipes:(pipe) ( -- pair )
2 <int-array>
[ underlying>> pipe io-error ]
[ pipe io-error ]
[ first2 [ <fd> init-fd ] bi@ io.pipes:pipe boa ] bi ;

View File

@ -120,6 +120,18 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
HOOK: seek-handle os ( n seek-type handle -- )
M: input-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
[ buffer>> 0 swap buffer-reset ]
[ handle>> seek-handle ] tri ;
M: output-port stream-seek ( n seek-type stream -- )
[ check-disposed ]
[ stream-flush ]
[ handle>> seek-handle ] tri ;
GENERIC: shutdown ( handle -- )
M: object shutdown drop ;

View File

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

View File

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

View File

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

View File

@ -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 ;
<PRIVATE
: (malloc) ( size -- alien )
@ -75,14 +81,14 @@ PRIVATE>
dup add-malloc ;
: realloc ( alien size -- newalien )
[ >c-ptr ] dip
over malloc-exists? [ realloc-error ] unless
dupd (realloc) check-ptr
swap delete-malloc
dup add-malloc ;
: free ( alien -- )
dup delete-malloc
(free) ;
>c-ptr [ delete-malloc ] [ (free) ] bi ;
: memcpy ( dst src size -- )
"void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ;

View File

@ -1,27 +1,54 @@
USING: help.markup help.syntax quotations kernel ;
USING: help.markup help.syntax quotations kernel
stack-checker.transforms sequences ;
IN: macros
HELP: MACRO:
{ $syntax "MACRO: word ( inputs... -- ) definition... ;" }
{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "."
$nl
"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect."
}
{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." }
{ $notes
"Semantically, the following two definitions are equivalent:"
"A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:"
{ $list
{ "All inputs to the macro call are literal" }
{ "The word calling the macro has a static stack effect" }
{ "The expansion quotation produced by the macro has a static stack effect" }
}
"If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time."
$nl
"Other than possible compile-time expansion, the following two definition styles are equivalent:"
{ $code "MACRO: foo ... ;" }
{ $code ": foo ... call ;" }
"However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost."
"Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation."
}
{ $examples
"A macro that calls a quotation but preserves any values it consumes off the stack:"
{ $code
"USING: fry generalizations ;"
"MACRO: preserving ( quot -- )"
" [ infer in>> 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"

View File

@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors ;
IN: macros
<PRIVATE
: real-macro-effect ( word -- effect' )
"declared-effect" word-prop in>> 1 <effect> ;
PRIVATE>
: define-macro ( word definition -- )
[ "macro" set-word-prop ]
[ over real-macro-effect memoize-quot [ call ] append define ]

View File

@ -256,7 +256,7 @@ XGEMM IS cblas_${T}gemm
XGERU IS cblas_${T}ger${U}
XGERC IS cblas_${T}ger${C}
MATRIX DEFINES ${TYPE}-blas-matrix
MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
XMATRIX{ DEFINES ${T}matrix{

View File

@ -134,7 +134,7 @@ XCOPY IS cblas_${T}copy
XSWAP IS cblas_${T}swap
IXAMAX IS cblas_i${T}amax
VECTOR DEFINES ${TYPE}-blas-vector
VECTOR DEFINES-CLASS ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector

View File

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

View File

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

View File

@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ;
[ t >>end-of-stream? ] if* ;
: maybe-fill-bytes ( multipart -- multipart )
dup bytes>> [ fill-bytes ] unless ;
dup bytes>> length 256 < [ fill-bytes ] when ;
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
dupd [ length ] bi@ 1- - short cut-slice swap ;
@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ;
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
maybe-fill-bytes
dup bytes>> "--\r\n" sequence= [
t >>end-of-stream?
] [
@ -99,7 +100,7 @@ ERROR: end-of-stream multipart ;
dup name>> empty-name? [
drop
] [
[ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
[ name-content>> ]
[ name>> unquote ]
[ mime-parts>> set-at ] tri
] if ;

View File

@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
glMatrixMode glPopMatrix ; inline
: gl-material ( face pname params -- )
float-array{ } like underlying>> glMaterialfv ;
float-array{ } like glMaterialfv ;
: gl-vertex-pointer ( seq -- )
[ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline
[ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
: gl-color-pointer ( seq -- )
[ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline
[ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
: gl-texture-coord-pointer ( seq -- )
[ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
[ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence
@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- )
glActiveTexture swap glBindTexture gl-error ;
: (set-draw-buffers) ( buffers -- )
[ length ] [ >uint-array underlying>> ] bi glDrawBuffers ;
[ length ] [ >uint-array ] bi glDrawBuffers ;
MACRO: set-draw-buffers ( buffers -- )
words>values [ (set-draw-buffers) ] curry ;

View File

@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
dup gl-program-shaders-length
0 <int>
over <uint-array>
[ underlying>> glGetAttachedShaders ] keep ;
[ glGetAttachedShaders ] keep ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline

View File

@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces
make parser prettyprint quotations sequences strings vectors
words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline ;
math.vectors combinators multiline endian ;
IN: pack
SYMBOL: big-endian
: big-endian? ( -- ? )
1 <int> *char zero? ;
<PRIVATE
: set-big-endian ( -- )
big-endian? big-endian set ; inline
PRIVATE>
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
: >endian ( obj n -- str )
big-endian get [ >be ] [ >le ] if ; inline
: unsigned-endian> ( obj -- str )
big-endian get [ be> ] [ le> ] if ; inline
: signed-endian> ( obj n -- str )
[ unsigned-endian> ] dip >signed ;
GENERIC: >n-byte-array ( obj n -- byte-array )
M: integer >n-byte-array ( m n -- byte-array ) >endian ;
@ -113,9 +89,7 @@ CONSTANT: packed-length-table
MACRO: pack ( str -- quot )
[ pack-table at '[ _ execute ] ] { } map-as
'[ _ spread ]
'[ _ input<sequence ]
'[ _ B{ } append-outputs-as ] ;
'[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
PRIVATE>
@ -126,13 +100,13 @@ PRIVATE>
[ ch>packed-length ] sigma ;
: pack-native ( seq str -- seq )
[ set-big-endian pack ] with-scope ; inline
'[ _ _ pack ] with-native-endian ; inline
: pack-be ( seq str -- seq )
[ big-endian on pack ] with-scope ; inline
'[ _ _ pack ] with-big-endian ; inline
: pack-le ( seq str -- seq )
[ big-endian off pack ] with-scope ; inline
'[ _ _ pack ] with-little-endian ; inline
<PRIVATE
@ -143,18 +117,18 @@ MACRO: unpack ( str -- quot )
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
'[ _ cleave ] '[ _ output>array ] ;
'[ [ _ cleave ] output>array ] ;
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 ;

View File

@ -11,7 +11,7 @@ A' IS ${T}-array
>A' IS >${T}-array
<A'> IS <${A'}>
A DEFINES direct-${T}-array
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
NTH [ T dup c-getter array-accessor ]

View File

@ -15,7 +15,7 @@ M: bad-byte-array-length summary
FUNCTOR: define-array ( T -- )
A DEFINES ${T}-array
A DEFINES-CLASS ${T}-array
<A> DEFINES <${A}>
(A) DEFINES (${A})
>A DEFINES >${A}

View File

@ -1,7 +1,8 @@
IN: specialized-arrays.tests
USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel ;
specialized-arrays.ushort alien.c-types accessors kernel
specialized-arrays.direct.int arrays ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ;
] unit-test
[ B{ 210 4 1 } byte-array>ushort-array ] must-fail
[ { 3 1 3 3 7 } ] [
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
] unit-test

View File

@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- )
A IS ${T}-array
<A> IS <${A}>
V DEFINES ${T}-vector
V DEFINES-CLASS ${T}-vector
<V> DEFINES <${V}>
>V DEFINES >${V}
V{ DEFINES ${V}{

View File

@ -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 <curried> make-known
[ push-d ] [ 1array ] bi
\ curry #call, ;
: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
: infer-compose ( -- )
2 consume-d
dup first2 <composed> 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 ( -- ) [ <curried> ] \ curry infer-builder ;
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
: infer-execute ( -- )
pop-literal nip

View File

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

View File

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

View File

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

View File

@ -42,3 +42,27 @@ C: <color> color
[ bad-new-test ] must-infer
[ bad-new-test ] must-fail
! Corner case if macro expansion calls 'infer', found by Doug
DEFER: smart-combo ( quot -- )
\ smart-combo [ infer [ ] curry ] 1 define-transform
[ [ "a" "b" "c" ] smart-combo ] must-infer
[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer
: very-smart-combo ( quot -- ) smart-combo ; inline
[ [ "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 <repetition> >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

View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel words sequences generic math
namespaces make quotations assocs combinators classes.tuple
classes.tuple.private effects summary hashtables classes generic
sets definitions generic.standard slots.private continuations
sets definitions generic.standard slots.private continuations locals
stack-checker.backend stack-checker.state stack-checker.visitor
stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
@ -15,48 +15,34 @@ IN: stack-checker.transforms
[ dup infer-word apply-word/effect ]
if ;
: ((apply-transform)) ( word quot values stack -- )
rot with-datastack first2
dup [
[
[ drop ]
[ [ length meta-d shorten-by ] [ #drop, ] bi ] bi*
] 2dip
swap infer-quot
] [
3drop give-up-transform
] if ; inline
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
[ stack quot with-datastack first ] with-variable
[
word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
] [ word give-up-transform ] if* ;
: literals? ( values -- ? ) [ literal-value? ] all? ;
: (apply-transform) ( word quot n -- )
ensure-d dup [ known literal? ] all? [
dup empty? [
recursive-state get 1array
] [
ensure-d dup literals? [
dup empty? [ dup recursive-state get ] [
[ ]
[ [ literal value>> ] map ]
[ first literal recursion>> ] tri
prefix
] if
((apply-transform))
] [ 2drop give-up-transform ] if ;
: apply-transform ( word -- )
[ inlined-dependency depends-on ] [
[ ]
[ "transform-quot" word-prop ]
[ "transform-n" word-prop ]
tri
(apply-transform)
] bi ;
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
(apply-transform) ;
: apply-macro ( word -- )
[ inlined-dependency depends-on ] [
[ ]
[ "macro" word-prop ]
[ "declared-effect" word-prop in>> length ]
tri
(apply-transform)
] bi ;
[ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri
(apply-transform) ;
: define-transform ( word quot n -- )
[ drop "transform-quot" set-word-prop ]

View File

@ -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>> ;
: <literal> ( 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< ( 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< ( composed -- quot1 quot2 )
[ quot1>> ] [ quot2>> ] bi ; inline
M: composed (literal-value?) >composed< [ literal-value? ] both? ;
M: composed (literal) >composed< [ compose ] curried/composed-literal ;

View File

@ -22,7 +22,7 @@ C-STRUCT: test-struct
[ 5/4 ] [
[
2 "test-struct" malloc-struct-array
dup underlying>> &free drop
dup &free drop
1 2 make-point over set-first
3 4 make-point over set-second
0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce
@ -34,6 +34,6 @@ C-STRUCT: test-struct
[ ] [
[
10 "test-struct" malloc-struct-array
underlying>> &free drop
&free drop
] with-destructors
] unit-test

View File

@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0
CONSTANT: MAP_SHARED 1
CONSTANT: MAP_PRIVATE 2
CONSTANT: SEEK_SET 0
CONSTANT: SEEK_CUR 1
CONSTANT: SEEK_END 2
: MAP_FAILED ( -- alien ) -1 <alien> ; inline
CONSTANT: NGROUPS_MAX 16
@ -37,18 +41,13 @@ C-STRUCT: group
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
LIBRARY: factor
FUNCTION: void clear_err_no ( ) ;
FUNCTION: int err_no ( ) ;
LIBRARY: libc
FUNCTION: char* strerror ( int errno ) ;
ERROR: unix-error errno message ;
: (io-error) ( -- * ) err_no dup strerror unix-error ;
: (io-error) ( -- * ) errno dup strerror unix-error ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
@ -61,7 +60,7 @@ MACRO:: unix-system-call ( quot -- )
n ndup quot call dup 0 < [
drop
n narray
err_no dup strerror
errno dup strerror
word unix-system-call-error
] [
n nnip

View File

@ -16,5 +16,5 @@ IN: unix.utilities
'[ [ advance ] [ *void* _ alien>string ] bi ]
[ ] produce nip ;
: strings>alien ( strings encoding -- alien )
'[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ;
: strings>alien ( strings encoding -- array )
'[ _ malloc-string ] void*-array{ } map-as f suffix ;

View File

@ -132,7 +132,7 @@ unless
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
[ execute ] void*-array{ } map-as underlying>> malloc-byte-array ;
[ execute ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;

View File

@ -59,7 +59,7 @@ SYMBOLS:
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
] each-index
alien underlying>>
alien
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )

View File

@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW
FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ;
FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ;
! FUNCTION: GetFileSizeEx
FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ;
FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ;
FUNCTION: DWORD GetFileType ( HANDLE hFile ) ;
! FUNCTION: GetFirmwareEnvironmentVariableA

View File

@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ;
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
} [ x-atom ] int-array{ } map-as underlying>>
} [ x-atom ] int-array{ } map-as
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )

View File

@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
GLX_RGBA ,
GLX_DEPTH_SIZE , 16 ,
0 ,
] int-array{ } make underlying>>
] int-array{ } make
glXChooseVisual
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;

View File

@ -50,7 +50,7 @@ SYMBOL: keysym
: lookup-string ( event xic -- string keysym )
[
prepare-lookup
swap keybuf get underlying>> buf-size keysym get 0 <int>
swap keybuf get buf-size keysym get 0 <int>
XwcLookupString
finish-lookup
] with-scope ;

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

@ -0,0 +1 @@
Doug Coleman

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

@ -0,0 +1 @@
Doug Coleman

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

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

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

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

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

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

View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sequences system
kernel.private byte-arrays arrays init ;
@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
GENERIC: >c-ptr ( obj -- c-ptr )
M: c-ptr >c-ptr ;
SLOT: underlying
M: object >c-ptr underlying>> ;
GENERIC: expired? ( c-ptr -- ? ) flushable
M: alien expired? expired>> ;

View File

@ -1,8 +1,7 @@
USING: tools.test io.files io.files.private io.files.temp
io.directories io.encodings.8-bit arrays make system
io.encodings.binary io threads kernel continuations
io.encodings.ascii sequences strings accessors
io.encodings.utf8 math destructors namespaces ;
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
make math sequences system threads tools.test ;
IN: io.files.tests
\ exists? must-infer
@ -75,3 +74,73 @@ USE: debugger.threads
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
! File seeking tests
[ B{ 3 2 3 4 5 } ]
[
"seek-test1" unique-file binary
[
[
B{ 1 2 3 4 5 } write 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 -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 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
[
"seek-test6" unique-file binary [
-10 seek-absolute seek-input
] with-file-reader
] must-fail

View File

@ -68,6 +68,51 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
HELP: stream-seek
{ $values
{ "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
}
{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
"Three methods of seeking are supported:"
{ $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
}
{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
HELP: seek-absolute
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the beginning of the stream." } ;
HELP: seek-end
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
HELP: seek-relative
{ $values
{ "value" "a seek singleton" }
}
{ $description "Seeks to an offset from the current position of the stream pointer." } ;
HELP: seek-input
{ $values
{ "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
HELP: seek-output
{ $values
{ "n" integer } { "seek-type" "a seek singleton" }
}
{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
HELP: input-stream
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
@ -196,6 +241,8 @@ $nl
{ $subsection stream-write }
"This word is only required for string output streams:"
{ $subsection stream-nl }
"This word is for streams that allow seeking:"
{ $subsection stream-seek }
"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
{ $see-also "io.timeouts" } ;
@ -249,6 +296,8 @@ $nl
{ $subsection read-partial }
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
{ $subsection readln }
"Seeking on the default input stream:"
{ $subsection seek-input }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
@ -256,7 +305,7 @@ $nl
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
"Words writing to the default input stream:"
"Words writing to the default output stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
@ -265,6 +314,8 @@ $nl
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
"Seeking on the default output stream:"
{ $subsection seek-output }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }

View File

@ -1,6 +1,4 @@
USING: arrays io io.files kernel math parser strings system
tools.test words namespaces make io.encodings.8-bit
io.encodings.binary sequences ;
USING: io parser tools.test words ;
IN: io.tests
[ f ] [

View File

@ -15,6 +15,10 @@ GENERIC: stream-write ( seq stream -- )
GENERIC: stream-flush ( stream -- )
GENERIC: stream-nl ( stream -- )
ERROR: bad-seek-type type ;
SINGLETONS: seek-absolute seek-relative seek-end ;
GENERIC: stream-seek ( n seek-type stream -- )
: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
! Default streams
@ -27,6 +31,8 @@ SYMBOL: error-stream
: read ( n -- seq ) input-stream get stream-read ;
: read-until ( seps -- seq sep/f ) input-stream get stream-read-until ;
: read-partial ( n -- seq ) input-stream get stream-read-partial ;
: seek-input ( n seek-type -- ) input-stream get stream-seek ;
: seek-output ( n seek-type -- ) output-stream get stream-seek ;
: write1 ( elt -- ) output-stream get stream-write1 ;
: write ( seq -- ) output-stream get stream-write ;
@ -82,4 +88,4 @@ PRIVATE>
: stream-copy ( in out -- )
[ [ [ write ] each-block ] with-output-stream ]
curry with-input-stream ;
curry with-input-stream ;

View File

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

View File

@ -53,8 +53,9 @@ HELP: 1string
HELP: >string
{ $values { "seq" "a sequence of characters" } { "str" string } }
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." }
{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." }
{ $errors "Throws an error if the sequence contains elements other than integers." } ;
HELP: resize-string ( n str -- newstr )
{ $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }

View File

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

View File

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

View File

@ -0,0 +1,30 @@
USING: graphics.bitmap graphics.viewer io.encodings.binary
io.files io.files.unique kernel tools.test ;
IN: graphics.bitmap.tests
: test-bitmap32-alpha ( -- path )
"resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
: test-bitmap24 ( -- path )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
: test-bitmap16 ( -- path )
"resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
: 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

View File

@ -1,21 +1,22 @@
! 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
graphics.viewer 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.
! Handles row-reversed bitmaps (their height is negative)
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 array ;
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' )
: array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- )
@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- )
2over * _ * >>size-image
swap >>height
swap >>width
swap (array-copy) [ >>array ] [ >>color-index ] bi
swap array-copy [ >>array ] [ >>color-index ] bi
_ >>bit-count
] ;
@ -38,20 +39,18 @@ MACRO: (nbits>bitmap) ( bits -- )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
: 4bit>array ( bitmap -- array )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ;
: raw-bitmap>array ( bitmap -- array )
dup bit-count>>
{
{ 32 [ "32bit" throw ] }
{ 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 ;
@ -59,107 +58,82 @@ ERROR: bitmap-magic ;
M: bitmap-magic summary
drop "First two bytes of bitmap stream must be 'BM'" ;
: parse-file-header ( bitmap -- )
2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
4 read le> >>size
4 read le> >>reserved
4 read le> >>offset drop ;
: read2 ( -- n ) 2 read le> ;
: read4 ( -- n ) 4 read le> ;
: parse-bitmap-header ( bitmap -- )
4 read le> >>header-length
4 read signed-le> >>width
4 read signed-le> >>height
2 read le> >>planes
2 read le> >>bit-count
4 read le> >>compression
4 read le> >>size-image
4 read le> >>x-pels
4 read le> >>y-pels
4 read le> >>color-used
4 read le> >>color-important drop ;
: parse-file-header ( bitmap -- bitmap )
2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
read4 >>size
read4 >>reserved
read4 >>offset ;
: parse-bitmap-header ( bitmap -- bitmap )
read4 >>header-length
read4 >>width
read4 >>height
read2 >>planes
read2 >>bit-count
read4 >>compression
read4 >>size-image
read4 >>x-pels
read4 >>y-pels
read4 >>color-used
read4 >>color-important ;
: rgb-quads-length ( bitmap -- n )
[ offset>> 14 - ] keep header-length>> - ;
[ offset>> 14 - ] [ header-length>> ] bi - ;
: color-index-length ( bitmap -- n )
[ width>> ] keep [ planes>> * ] keep
[ bit-count>> * 31 + 32 /i 4 * ] keep
height>> abs * ;
{
[ width>> ]
[ planes>> * ]
[ bit-count>> * 31 + 32 /i 4 * ]
[ height>> abs * ]
} cleave ;
: parse-bitmap ( bitmap -- )
: parse-bitmap ( bitmap -- bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index drop ;
dup color-index-length read >>color-index ;
: load-bitmap ( path -- bitmap )
: (load-bitmap) ( path -- bitmap )
binary [
bitmap new
dup parse-file-header
dup parse-bitmap-header
dup parse-bitmap
] with-file-reader
dup raw-bitmap>array >>array ;
parse-file-header parse-bitmap-header parse-bitmap
] 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 ;
: save-bitmap ( bitmap path -- )
binary [
"BM" >byte-array write
dup array>> length 14 + 40 + 4 >le write
0 4 >le write
54 4 >le write
40 4 >le write
{
[ width>> 4 >le write ]
[ height>> 4 >le write ]
[ planes>> 1 or 2 >le write ]
[ bit-count>> 24 or 2 >le write ]
[ compression>> 0 or 4 >le write ]
[ size-image>> 4 >le write ]
[ x-pels>> 0 or 4 >le write ]
[ y-pels>> 0 or 4 >le write ]
[ color-used>> 0 or 4 >le write ]
[ color-important>> 0 or 4 >le write ]
[ rgb-quads>> write ]
[ color-index>> write ]
} cleave
B{ CHAR: B CHAR: M } write
[
array>> length 14 + 40 + write4
0 write4
54 write4
40 write4
] [
{
[ width>> write4 ]
[ height>> write4 ]
[ planes>> 1 or write2 ]
[ bit-count>> 24 or write2 ]
[ compression>> 0 or write4 ]
[ size-image>> write4 ]
[ x-pels>> 0 or write4 ]
[ y-pels>> 0 or write4 ]
[ color-used>> 0 or write4 ]
[ color-important>> 0 or write4 ]
[ rgb-quads>> write ]
[ color-index>> write ]
} cleave
] bi
] with-file-writer ;
M: bitmap draw-image ( bitmap -- )
dup height>> 0 < [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
] [
0 over height>> abs glRasterPos2i
1.0 1.0 glPixelZoom
] if
[ width>> ] keep
[
[ height>> abs ] keep
bit-count>> {
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
M: bitmap width ( bitmap -- ) width>> ;
M: bitmap height ( bitmap -- ) height>> ;
: bitmap. ( path -- )
load-bitmap <graphics-gadget> gadget. ;
: bitmap-window ( path -- gadget )
load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
: test-bitmap24 ( -- )
"resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
: test-bitmap8 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
: test-bitmap4 ( -- )
"resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
: test-bitmap1 ( -- )
"resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;

View File

@ -0,0 +1 @@
Doug Coleman

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

Binary file not shown.

View File

@ -0,0 +1,9 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test graphics.tiff ;
IN: graphics.tiff.tests
: tiff-test-path ( -- path )
"resource:extra/graphics/tiff/rgb.tiff" ;

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

@ -0,0 +1,227 @@
! 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 classes ;
IN: graphics.tiff
TUPLE: tiff
endianness
the-answer
ifd-offset
ifds ;
CONSTRUCTOR: tiff ( -- tiff )
V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next processed-tags strips ;
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 ;
: read-strips ( ifd -- ifd )
dup processed-tags>>
[ [ strip-byte-counts instance? ] find nip n>> ]
[ [ strip-offsets instance? ] find nip n>> ] bi
[ seek-absolute seek-input read ] { } 2map-as >>strips ;
! 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 -- ifd )
dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
: (load-tiff) ( path -- tiff )
binary [
<tiff>
read-header
read-ifds
dup ifds>> [ process-ifd read-strips drop ] each
] with-file-reader ;
: load-tiff ( path -- tiff )
(load-tiff) ;
! TODO: duplicate ifds = error, seeking out of bounds = error

View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces opengl
ui.gadgets ui.render accessors ;
USING: accessors arrays combinators graphics.bitmap kernel math
math.functions namespaces opengl opengl.gl ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: graphics.viewer
TUPLE: graphics-gadget < gadget image ;
@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- )
: <graphics-gadget> ( bitmap -- gadget )
\ graphics-gadget new-gadget
swap >>image ;
M: bitmap draw-image ( bitmap -- )
dup height>> 0 < [
0 0 glRasterPos2i
1.0 -1.0 glPixelZoom
] [
0 over height>> abs glRasterPos2i
1.0 1.0 glPixelZoom
] if
[ width>> ] keep
[
[ height>> abs ] keep
bit-count>> {
{ 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
{ 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
{ 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
} case
] keep array>> glDrawPixels ;
M: bitmap width ( bitmap -- ) width>> ;
M: bitmap height ( bitmap -- ) height>> ;
: bitmap. ( path -- )
load-bitmap <graphics-gadget> gadget. ;
: bitmap-window ( path -- gadget )
load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;

View File

@ -0,0 +1,8 @@
IN: infix.ast
TUPLE: ast-number value ;
TUPLE: ast-local name ;
TUPLE: ast-array name index ;
TUPLE: ast-function name arguments ;
TUPLE: ast-op left right op ;
TUPLE: ast-negation term ;

View File

@ -0,0 +1,38 @@
USING: help.syntax help.markup prettyprint locals ;
IN: infix
HELP: [infix
{ $syntax "[infix ... infix]" }
{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." }
{ $examples
{ $example
"USING: infix prettyprint ;"
"IN: scratchpad"
"[infix 8+2*3 infix] ."
"14"
} $nl
{ $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :"
{ $example
"USING: infix locals math.functions prettyprint ;"
"IN: scratchpad"
":: quadratic-equation ( a b c -- z- z+ )"
" [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]"
" [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;"
"1 0 -1 quadratic-equation . ."
"1.0\n-1.0"
}
} ;
HELP: [infix|
{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" }
{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." }
{ $examples
{ $example
"USING: infix prettyprint ;"
"IN: scratchpad"
"[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ."
"452.16"
}
} ;
{ POSTPONE: [infix POSTPONE: [infix| } related-words

View File

@ -0,0 +1,45 @@
USING: infix infix.private kernel locals math math.functions
tools.test ;
IN: infix.tests
[ 0 ] [ [infix 0 infix] ] unit-test
[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test
[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test
[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test
[ 1 ] [ [infix 2-
1
-5*
0 infix] ] unit-test
[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] |
r*r*pi infix] ] unit-test
[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test
[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test
[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test
[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test
[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test
[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test
[ 0.0 ] [ [infix sin(0) infix] ] unit-test
[ 10 ] [ [infix lcm(2,5) infix] ] unit-test
[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test
[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values
[ f ] [ 1 \ drop check-word ] unit-test ! no return value
[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args
: no-stack-effect-declared + ;
[ 0 \ no-stack-effect-declared check-word ] must-fail
: qux ( -- x ) 2 ;
[ t ] [ 0 \ qux check-word ] unit-test
[ 8 ] [ [infix qux()*3+2 infix] ] unit-test
: foobar ( x -- y ) 1 + ;
[ t ] [ 1 \ foobar check-word ] unit-test
[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test
: stupid_function ( x x x x x -- y ) + + + + ;
[ t ] [ 5 \ stupid_function check-word ] unit-test
[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test
[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test

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

@ -0,0 +1,99 @@
USING: accessors assocs combinators combinators.short-circuit
effects fry infix.parser infix.ast kernel locals.parser
locals.types math multiline namespaces parser quotations
sequences summary words ;
IN: infix
<PRIVATE
: prepare-operand ( term -- quot )
dup callable? [ 1quotation ] unless ;
ERROR: local-not-defined name ;
M: local-not-defined summary
drop "local is not defined" ;
: at? ( key assoc -- value/key ? )
dupd at* [ nip t ] [ drop f ] if ;
: >local-word ( string -- word )
locals get at? [ local-not-defined ] unless ;
: select-op ( string -- word )
{
{ "+" [ [ + ] ] }
{ "-" [ [ - ] ] }
{ "*" [ [ * ] ] }
{ "/" [ [ / ] ] }
[ drop [ mod ] ]
} case ;
GENERIC: infix-codegen ( ast -- quot/number )
M: ast-number infix-codegen value>> ;
M: ast-local infix-codegen
name>> >local-word ;
M: ast-array infix-codegen
[ index>> infix-codegen prepare-operand ]
[ name>> >local-word ] bi '[ @ _ nth ] ;
M: ast-op infix-codegen
[ left>> infix-codegen ] [ right>> infix-codegen ]
[ op>> select-op ] tri
2over [ number? ] both? [ call ] [
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
] if ;
M: ast-negation infix-codegen
term>> infix-codegen
{
{ [ dup number? ] [ neg ] }
{ [ dup callable? ] [ '[ @ neg ] ] }
[ '[ _ neg ] ] ! local word
} cond ;
ERROR: bad-stack-effect word ;
M: bad-stack-effect summary
drop "Words used in infix must declare a stack effect and return exactly one value" ;
: check-word ( argcount word -- ? )
dup stack-effect [ ] [ bad-stack-effect ] ?if
[ in>> length ] [ out>> length ] bi
[ = ] dip 1 = and ;
: find-and-check ( args argcount string -- quot )
dup search [ ] [ no-word ] ?if
[ nip ] [ check-word ] 2bi
[ 1quotation compose ] [ bad-stack-effect ] if ;
: arguments-codegen ( seq -- quot )
dup empty? [ drop [ ] ] [
[ infix-codegen prepare-operand ]
[ compose ] map-reduce
] if ;
M: ast-function infix-codegen
[ arguments>> [ arguments-codegen ] [ length ] bi ]
[ name>> ] bi find-and-check ;
: [infix-parse ( end -- result/quot )
parse-multiline-string build-infix-ast
infix-codegen prepare-operand ;
PRIVATE>
: [infix
"infix]" [infix-parse parsed \ call parsed ; parsing
<PRIVATE
: parse-infix-locals ( assoc end -- quot )
[
in-lambda? on
[ dup [ locals set ] [ push-locals ] bi ] dip
[infix-parse prepare-operand swap pop-locals
] with-scope ;
PRIVATE>
: [infix|
"|" parse-bindings "infix]" parse-infix-locals <let>
parsed-lambda ; parsing

View File

@ -0,0 +1,175 @@
USING: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
\ parse-infix must-infer
\ build-infix-ast must-infer
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
[ "-1" build-infix-ast ] unit-test
[ T{ ast-op
{ left
T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
}
}
{ right T{ ast-number { value 4 } } }
{ op "+" }
} ] [ "1+2+4" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "*" }
}
}
{ op "+" }
} ] [ "1+2*3" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
} ] [ "(1+2)" build-infix-ast ] unit-test
[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test
[ "-" build-infix-ast ] must-fail
[ T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right T{ ast-number { value 2 } } }
{ op "+" }
}
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "%" }
}
}
}
} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test
[ T{ ast-op
{ left
T{ ast-op
{ left
T{ ast-function
{ name "bar" }
{ arguments V{ } }
}
}
{ right
T{ ast-array
{ name "baz" }
{ index
T{ ast-op
{ left
T{ ast-op
{ left
T{ ast-number
{ value 2 }
}
}
{ right
T{ ast-number
{ value 3 }
}
}
{ op "/" }
}
}
{ right
T{ ast-number { value 4 } }
}
{ op "+" }
}
}
}
}
{ op "+" }
}
}
{ right T{ ast-number { value 2 } } }
{ op "/" }
} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test
[ T{ ast-op
{ left T{ ast-number { value 1 } } }
{ right
T{ ast-op
{ left T{ ast-number { value 2 } } }
{ right T{ ast-number { value 3 } } }
{ op "/" }
}
}
{ op "+" }
} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test
[ T{ ast-negation
{ term
T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-number { value 2 } }
T{ ast-negation
{ term T{ ast-number { value 3 } } }
}
}
}
}
}
} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test
[ T{ ast-array
{ name "arr" }
{ index
T{ ast-op
{ left
T{ ast-negation
{ term
T{ ast-op
{ left
T{ ast-function
{ name "foo" }
{ arguments
V{
T{ ast-number
{ value 2 }
}
}
}
}
}
{ right
T{ ast-negation
{ term
T{ ast-number
{ value 1 }
}
}
}
}
{ op "+" }
}
}
}
}
{ right T{ ast-number { value 3 } } }
{ op "/" }
}
}
} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test
[ "foo bar baz" build-infix-ast ] must-fail
[ "1+2/4+" build-infix-ast ] must-fail
[ "quaz(2/3,)" build-infix-ast ] must-fail

View File

@ -0,0 +1,30 @@
USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences
strings vectors ;
IN: infix.parser
EBNF: parse-infix
Number = . ?[ ast-number? ]?
Identifier = . ?[ string? ]?
Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]]
Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]]
FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]]
| Sum:s => [[ s 1vector ]]
Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]]
| "(" Sum:s ")" => [[ s ]]
| Number | Array | Function
| Identifier => [[ ast-local boa ]]
Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]]
| Terminal
Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]]
| Product
End = !(.)
Expression = Sum End
;EBNF
: build-infix-ast ( string -- ast )
tokenize-infix parse-infix ;

View File

@ -0,0 +1,20 @@
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
\ tokenize-infix must-infer
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
[ "3/(3+4)" tokenize-infix ] unit-test
[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test
[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ]
[ "arr[x+3]" tokenize-infix ] unit-test
[ "1.0.4" tokenize-infix ] must-fail
[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ]
[ "+]3.4,bar" tokenize-infix ] unit-test
[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test
[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test
[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ]
[ "(1+2)" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ]
[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test

View File

@ -0,0 +1,21 @@
USING: infix.ast kernel peg peg.ebnf math.parser sequences
strings ;
IN: infix.tokenizer
EBNF: tokenize-infix
Letter = [a-zA-Z]
Digit = [0-9]
Digits = Digit+
Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]]
| Digits => [[ >string string>number ast-number boa ]]
Space = " " | "\n" | "\r" | "\t"
Spaces = Space* => [[ ignore ]]
NameFirst = Letter | "_" => [[ CHAR: _ ]]
NameRest = NameFirst | Digit
Name = NameFirst NameRest* => [[ first2 swap prefix >string ]]
Special = [+*/%(),] | "-" => [[ CHAR: - ]]
| "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]]
Tok = Spaces (Name | Number | Special )
End = !(.)
Toks = Tok* Spaces End
;EBNF

View File

@ -65,7 +65,7 @@ SYMBOL: dh-file
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
"slava@factorcode.org" insomniac-recipients set-global
{ "slava@factorcode.org" } insomniac-recipients set-global
init-factor-db ;
: init-testing ( -- )

Some files were not shown because too many files have changed in this diff Show More