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

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

db4
Doug Coleman 2009-08-29 23:39:20 -05:00
parent fb9d7d67d0 6b2a108f03
commit d88cdffa47
95 changed files with 1815 additions and 1619 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/c-types/c-types.factor
View File

@ -265,9 +265,15 @@ M: f byte-length drop 0 ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
: (malloc-object) ( type -- alien )
heap-size malloc ; inline
: malloc-byte-array ( byte-array -- alien )
dup byte-length [ nip malloc dup ] 2keep memcpy ;

4
basis/alien/complex/functor/functor.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.structs alien.c-types classes.struct math
USING: accessors alien alien.structs alien.c-types classes.struct math
math.functions sequences arrays kernel functors vocabs.parser
namespaces quotations ;
IN: alien.complex.functor
@ -17,7 +17,7 @@ WHERE
STRUCT: T-class { real N } { imaginary N } ;
: <T> ( z -- alien )
>rect T-class <struct-boa> ;
>rect T-class <struct-boa> >c-ptr ;
: *T ( alien -- z )
T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline

15
basis/calendar/unix/unix.factor
View File

@ -1,28 +1,27 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
kernel math unix unix.time unix.types namespaces system ;
kernel math unix unix.time unix.types namespaces system
accessors classes.struct ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
[ timeval-sec seconds ] [ timeval-usec microseconds ] bi
time+ ;
[ sec>> seconds ] [ usec>> microseconds ] bi time+ ;
: timeval>unix-time ( timeval -- timestamp )
timeval>seconds since-1970 ;
: timespec>seconds ( timespec -- seconds )
[ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
time+ ;
[ sec>> seconds ] [ nsec>> nanoseconds ] bi time+ ;
: timespec>unix-time ( timespec -- timestamp )
timespec>seconds since-1970 ;
: get-time ( -- alien )
f time <time_t> localtime ;
f time <time_t> localtime tm memory>struct ;
: timezone-name ( -- string )
get-time tm-zone ;
get-time zone>> ;
M: unix gmt-offset ( -- hours minutes seconds )
get-time tm-gmtoff 3600 /mod 60 /mod ;
get-time gmtoff>> 3600 /mod 60 /mod ;

21
basis/classes/struct/struct-docs.factor
View File

@ -9,6 +9,15 @@ HELP: <struct-boa>
}
{ $description "This macro implements " { $link boa } " for " { $link struct } " classes. A struct of the given class is constructed, and its slots are initialized using values off the top of the datastack." } ;
HELP: (struct)
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates garbage-collected heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; in most cases, the " { $link <struct> } " word, which initializes the struct's slots with their initial values, should be used instead." } ;
{ (struct) (malloc-struct) } related-words
HELP: <struct>
{ $values
{ "class" class }
@ -55,7 +64,14 @@ HELP: malloc-struct
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ;
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are initialized to their initial values. The struct should be " { $link free } "d when it is no longer needed." } ;
HELP: (malloc-struct)
{ $values
{ "class" class }
{ "struct" struct }
}
{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized; to initialize the allocated memory with the slots' initial values, use " { $link malloc-struct } ". The struct should be " { $link free } "d when it is no longer needed." } ;
HELP: memory>struct
{ $values
@ -80,6 +96,9 @@ ARTICLE: "classes.struct" "Struct classes"
{ $subsection <struct-boa> }
{ $subsection malloc-struct }
{ $subsection memory>struct }
"When the contents of a struct will be immediately reset, faster primitive words are available that will create a struct without initializing its contents:"
{ $subsection (struct) }
{ $subsection (malloc-struct) }
"Structs have literal syntax like tuples:"
{ $subsection POSTPONE: S{ }
"Union structs are also supported, which behave like structs but share the same memory for all the type's slots."

31
basis/classes/struct/struct-tests.factor
View File

@ -1,12 +1,12 @@
! (c)Joe Groff bsd license
USING: accessors alien.c-types alien.libraries
USING: accessors alien alien.c-types alien.libraries
alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort
system tools.test compiler.tree.debugger struct-arrays
classes.tuple.private specialized-arrays.direct.int
compiler.units ;
compiler.units byte-arrays specialized-arrays.char ;
IN: classes.struct.tests
<<
@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits
[ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
[ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
STRUCT: struct-test-string-ptr
{ x char* } ;
@ -203,3 +203,28 @@ STRUCT: struct-test-optimization
] unit-test
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
[ 1 char-array{ 9 1 1 } ] [
clone-test-struct <struct>
1 >>x char-array{ 9 1 1 } >>y
clone
[ x>> ] [ y>> >char-array ] bi
] unit-test
[ t 1 char-array{ 9 1 1 } ] [
[
clone-test-struct malloc-struct &free
1 >>x char-array{ 9 1 1 } >>y
clone
[ >c-ptr byte-array? ] [ x>> ] [ y>> >char-array ] tri
] with-destructors
] unit-test
STRUCT: struct-that's-a-word { x int } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test

56
basis/classes/struct/struct.factor
View File

@ -37,6 +37,8 @@ M: struct equal?
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
} 2&& ;
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
[ 1array ] dip slots>tuple ;
@ -44,17 +46,22 @@ M: struct equal?
dup struct-class? [ '[ _ boa ] ] [ drop f ] if
] 1 define-partial-eval
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
'[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
PRIVATE>
: (malloc-struct) ( class -- struct )
[ heap-size malloc ] keep memory>struct ; inline
: malloc-struct ( class -- struct )
[ 1 swap heap-size calloc ] keep memory>struct ; inline
[ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ; inline
: (struct) ( class -- struct )
[ heap-size <byte-array> ] keep memory>struct ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
[ heap-size (byte-array) ] keep memory>struct ; inline
: <struct> ( class -- struct )
dup struct-prototype
[ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
[ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ; inline
MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[
@ -66,6 +73,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
] bi
] [ ] output>sequence ;
<PRIVATE
: pad-struct-slots ( values class -- values' class )
[ struct-slots [ initial>> ] map over length tail append ] keep ;
@ -82,6 +90,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
: (unboxer-quot) ( class -- quot )
drop [ >c-ptr ] ;
PRIVATE>
M: struct-class boa>object
swap pad-struct-slots
@ -98,21 +107,33 @@ M: struct-class reader-quot
M: struct-class writer-quot
nip (writer-quot) ;
! c-types
<PRIVATE
: struct-slot-values-quot ( class -- quot )
struct-slots
[ name>> reader-word 1quotation ] map
\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
: define-inline-method ( class generic quot -- )
[ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
: (define-struct-slot-values-method) ( class -- )
[ \ struct-slot-values create-method-in ]
[ struct-slot-values-quot ] bi define ;
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
: (define-byte-length-method) ( class -- )
[ \ byte-length create-method-in ]
[ heap-size \ drop swap [ ] 2sequence ] bi define ;
[ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
define-inline-method ;
! Struct as c-type
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
: (define-clone-method) ( class -- )
[ \ clone ]
[ \ clone-underlying swap literalize \ memory>struct [ ] 3sequence ] bi
define-inline-method ;
: slot>field ( slot -- field )
field-spec new swap {
@ -155,6 +176,7 @@ M: struct-class writer-quot
: struct-align ( slots -- align )
[ c-type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
M: struct-class c-type
name>> c-type ;
@ -180,6 +202,7 @@ M: struct-class heap-size
! class definition
<PRIVATE
: make-struct-prototype ( class -- prototype )
[ heap-size <byte-array> ]
[ memory>struct ]
@ -192,7 +215,9 @@ M: struct-class heap-size
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
[ (define-byte-length-method) ] bi ;
[ (define-byte-length-method) ]
[ (define-clone-method) ]
tri ;
: (struct-word-props) ( class slots size align -- )
[
@ -219,6 +244,7 @@ M: struct-class heap-size
(struct-word-props)
]
[ drop define-struct-for-class ] 2tri ; inline
PRIVATE>
: define-struct-class ( class slots -- )
[ struct-offsets ] (define-struct-class) ;
@ -228,6 +254,7 @@ M: struct-class heap-size
ERROR: invalid-struct-slot token ;
<PRIVATE
: struct-slot-class ( c-type -- class' )
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
@ -250,6 +277,7 @@ ERROR: invalid-struct-slot token ;
: parse-struct-definition ( -- class slots )
CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
PRIVATE>
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
@ -259,6 +287,9 @@ SYNTAX: UNION-STRUCT:
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
! functor support
<PRIVATE
: scan-c-type` ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
@ -280,6 +311,7 @@ SYNTAX: S{
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
scan-param parsed

13
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -14,13 +14,12 @@ GENERIC: compute-stack-frame* ( insn -- )
frame-required? on
stack-frame [ max-stack-frame ] change ;
M: ##alien-invoke compute-stack-frame*
stack-frame>> request-stack-frame ;
UNION: stack-frame-insn
##alien-invoke
##alien-indirect
##alien-callback ;
M: ##alien-indirect compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##alien-callback compute-stack-frame*
M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
@ -40,6 +39,8 @@ M: insn compute-stack-frame*
] when ;
\ _spill t frame-required? set-word-prop
\ ##unary-float-function t frame-required? set-word-prop
\ ##binary-float-function t frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off

2
basis/compiler/cfg/def-use/def-use.factor
View File

@ -21,7 +21,7 @@ M: ##slot temp-vregs temp>> 1array ;
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##box-displaced-alien temp-vregs temp>> 1array ;
M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;

4
basis/compiler/cfg/hats/hats.factor
View File

@ -47,6 +47,8 @@ IN: compiler.cfg.hats
: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
@ -56,7 +58,7 @@ IN: compiler.cfg.hats
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^box-displaced-alien ( base displacement base-class -- dst )
^^r3 [ next-vreg ] dip ##box-displaced-alien ; inline
^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline

15
basis/compiler/cfg/instructions/instructions.factor
View File

@ -112,6 +112,10 @@ INSN: ##min-float < ##binary ;
INSN: ##max-float < ##binary ;
INSN: ##sqrt < ##unary ;
! libc intrinsics
INSN: ##unary-float-function < ##unary func ;
INSN: ##binary-float-function < ##binary func ;
! Float/integer conversion
INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ;
@ -122,7 +126,7 @@ INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##unary/temp ;
INSN: ##box-displaced-alien < ##binary temp base-class ;
INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -252,6 +256,11 @@ UNION: vreg-insn
_compare-imm-branch
_dispatch ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn
##unary-float-function
##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
##call
@ -270,6 +279,8 @@ UNION: output-float-insn
##min-float
##max-float
##sqrt
##unary-float-function
##binary-float-function
##integer>float
##unbox-float
##alien-float
@ -284,6 +295,8 @@ UNION: input-float-insn
##min-float
##max-float
##sqrt
##unary-float-function
##binary-float-function
##float>integer
##box-float
##set-alien-float

6
basis/compiler/cfg/intrinsics/float/float.factor
View File

@ -18,3 +18,9 @@ IN: compiler.cfg.intrinsics.float
: emit-fsqrt ( -- )
ds-pop ^^sqrt ds-push ;
: emit-unary-float-function ( func -- )
[ ds-pop ] dip ^^unary-float-function ds-push ;
: emit-binary-float-function ( func -- )
[ 2inputs ] dip ^^binary-float-function ds-push ;

230
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture
USING: words sequences kernel combinators cpu.architecture assocs
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
@ -25,164 +25,120 @@ QUALIFIED: math.floats.private
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
: enable-intrinsics ( words -- )
[ t "intrinsic" set-word-prop ] each ;
: enable-intrinsics ( alist -- )
[ "intrinsic" set-word-prop ] assoc-each ;
{
kernel.private:tag
kernel.private:getenv
math.private:both-fixnums?
math.private:fixnum+
math.private:fixnum-
math.private:fixnum*
math.private:fixnum+fast
math.private:fixnum-fast
math.private:fixnum-bitand
math.private:fixnum-bitor
math.private:fixnum-bitxor
math.private:fixnum-shift-fast
math.private:fixnum-bitnot
math.private:fixnum*fast
math.private:fixnum<
math.private:fixnum<=
math.private:fixnum>=
math.private:fixnum>
! math.private:bignum>fixnum
! math.private:fixnum>bignum
kernel:eq?
slots.private:slot
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
kernel:<wrapper>
alien:<displaced-alien>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-signed-1
alien.accessors:alien-unsigned-2
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
alien.accessors:alien-cell
alien.accessors:set-alien-cell
{ kernel.private:tag [ drop emit-tag ] }
{ kernel.private:getenv [ emit-getenv ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ math.private:fixnum- [ drop emit-fixnum- ] }
{ math.private:fixnum* [ drop emit-fixnum* ] }
{ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
{ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
{ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
{ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
{ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
{ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
{ slots.private:slot [ emit-slot ] }
{ slots.private:set-slot [ emit-set-slot ] }
{ strings.private:string-nth [ drop emit-string-nth ] }
{ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ arrays:<array> [ emit-<array> ] }
{ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ kernel:<wrapper> [ emit-simple-allot ] }
{ alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
} enable-intrinsics
: enable-alien-4-intrinsics ( -- )
{
alien.accessors:alien-unsigned-4
alien.accessors:set-alien-unsigned-4
alien.accessors:alien-signed-4
alien.accessors:set-alien-signed-4
{ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
} enable-intrinsics ;
: enable-float-intrinsics ( -- )
{
math.private:float+
math.private:float-
math.private:float*
math.private:float/f
math.private:fixnum>float
math.private:float>fixnum
math.private:float<
math.private:float<=
math.private:float>
math.private:float>=
math.private:float=
alien.accessors:alien-float
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
{ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ math.private:float< [ drop cc< emit-float-comparison ] }
{ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ math.private:float> [ drop cc> emit-float-comparison ] }
{ math.private:float= [ drop cc= emit-float-comparison ] }
{ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
{ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
{ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
\ math.libm:fsqrt t "intrinsic" set-word-prop ;
{
{ math.libm:fsqrt [ drop emit-fsqrt ] }
} enable-intrinsics ;
: enable-float-min/max ( -- )
{
math.floats.private:float-min
math.floats.private:float-max
{ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
{ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
} enable-intrinsics ;
: enable-float-functions ( -- )
! Everything except for fsqrt
{
{ math.libm:facos [ drop "acos" emit-unary-float-function ] }
{ math.libm:fasin [ drop "asin" emit-unary-float-function ] }
{ math.libm:fatan [ drop "atan" emit-unary-float-function ] }
{ math.libm:fatan2 [ drop "atan2" emit-binary-float-function ] }
{ math.libm:fcos [ drop "cos" emit-unary-float-function ] }
{ math.libm:fsin [ drop "sin" emit-unary-float-function ] }
{ math.libm:ftan [ drop "tan" emit-unary-float-function ] }
{ math.libm:fcosh [ drop "cosh" emit-unary-float-function ] }
{ math.libm:fsinh [ drop "sinh" emit-unary-float-function ] }
{ math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
{ math.libm:fexp [ drop "exp" emit-unary-float-function ] }
{ math.libm:flog [ drop "log" emit-unary-float-function ] }
{ math.libm:fpow [ drop "pow" emit-binary-float-function ] }
{ math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
{ math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }
{ math.libm:fatanh [ drop "atanh" emit-unary-float-function ] }
} enable-intrinsics ;
: enable-min/max ( -- )
{
math.integers.private:fixnum-min
math.integers.private:fixnum-max
{ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
{ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
} enable-intrinsics ;
: enable-fixnum-log2 ( -- )
{ math.integers.private:fixnum-log2 } enable-intrinsics ;
{
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
: emit-intrinsic ( node word -- )
{
{ \ kernel.private:tag [ drop emit-tag ] }
{ \ kernel.private:getenv [ emit-getenv ] }
{ \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ \ math.private:fixnum+ [ drop emit-fixnum+ ] }
{ \ math.private:fixnum- [ drop emit-fixnum- ] }
{ \ math.private:fixnum* [ drop emit-fixnum* ] }
{ \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
{ \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
{ \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
{ \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
{ \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
{ \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
{ \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
{ \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
{ \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
{ \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
{ \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
{ \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
{ \ math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
{ \ math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
{ \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
{ \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
{ \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
{ \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
{ \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
{ \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
{ \ math.private:float< [ drop cc< emit-float-comparison ] }
{ \ math.private:float<= [ drop cc<= emit-float-comparison ] }
{ \ math.private:float>= [ drop cc>= emit-float-comparison ] }
{ \ math.private:float> [ drop cc> emit-float-comparison ] }
{ \ math.private:float= [ drop cc= emit-float-comparison ] }
{ \ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ \ math.private:fixnum>float [ drop emit-fixnum>float ] }
{ \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
{ \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
{ \ math.libm:fsqrt [ drop emit-fsqrt ] }
{ \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] }
{ \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
{ \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
{ \ arrays:<array> [ emit-<array> ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
{ \ kernel:<wrapper> [ emit-simple-allot ] }
{ \ alien:<displaced-alien> [ emit-<displaced-alien> ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
{ \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
{ \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
{ \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
{ \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
{ \ alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
{ \ alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
{ \ alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
} case ;
"intrinsic" word-prop call( node -- ) ;

42
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
math.order combinators arrays sorting compiler.utilities
math.order combinators arrays sorting compiler.utilities locals
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting
@ -34,22 +34,48 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ]
} cond ;
: handle-interval ( live-interval -- )
[
start>>
: handle-sync-point ( n -- )
[ active-intervals get values ] dip
[ '[ [ _ spill ] each ] each ]
[ drop [ delete-all ] each ]
2bi ;
:: handle-progress ( n sync? -- )
n {
[ progress set ]
[ deactivate-intervals ]
[ activate-intervals ] tri
] [ assign-register ] bi ;
[ sync? [ handle-sync-point ] [ drop ] if ]
[ activate-intervals ]
} cleave ;
GENERIC: handle ( obj -- )
M: live-interval handle ( live-interval -- )
[ start>> f handle-progress ] [ assign-register ] bi ;
M: sync-point handle ( sync-point -- )
n>> t handle-progress ;
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.
[ [ heap-peek nip ] bi@ <= ] most ;
: (allocate-registers) ( -- )
unhandled-intervals get [ handle-interval ] slurp-heap ;
{
{ [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
{ [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
! If a live interval begins at the same location as a sync point,
! process the sync point before the live interval. This ensures that the
! return value of C function calls doesn't get spilled and reloaded
! unnecessarily.
[ unhandled-sync-points get unhandled-intervals get smallest-heap ]
} cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
: finish-allocation ( -- )
active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ;
: allocate-registers ( live-intervals machine-registers -- live-intervals )
: allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
init-allocator
init-unhandled
(allocate-registers)

4
basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
View File

@ -29,7 +29,7 @@ ERROR: bad-live-ranges interval ;
2bi ;
: assign-spill ( live-interval -- )
dup vreg>> assign-spill-slot >>spill-to drop ;
dup vreg>> vreg-spill-slot >>spill-to drop ;
: spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location,
@ -46,7 +46,7 @@ ERROR: bad-live-ranges interval ;
] if ;
: assign-reload ( live-interval -- )
dup vreg>> assign-spill-slot >>reload-from drop ;
dup vreg>> vreg-spill-slot >>reload-from drop ;
: spill-after ( after -- after/f )
! If the interval has no more usages after the spill location,

13
basis/compiler/cfg/linear-scan/allocation/state/state.factor
View File

@ -120,15 +120,19 @@ SYMBOL: unhandled-intervals
rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ;
! Minheap of sync points which still need to be processed
SYMBOL: unhandled-sync-points
! Mapping from vregs to spill slots
SYMBOL: spill-slots
: assign-spill-slot ( vreg -- n )
: vreg-spill-slot ( vreg -- n )
spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- )
registers set
<min-heap> unhandled-intervals set
<min-heap> unhandled-sync-points set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
@ -136,9 +140,10 @@ SYMBOL: spill-slots
H{ } clone spill-slots set
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
unhandled-intervals get heap-push-all ;
: init-unhandled ( live-intervals sync-points -- )
[ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ]
[ [ [ n>> ] keep ] { } map>assoc unhandled-sync-points get heap-push-all ]
bi* ;
! A utility used by register-status and spill-status words
: free-positions ( new -- assoc )

32
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -28,6 +28,20 @@ SYMBOL: pending-interval-assoc
: remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ;
: (vreg>reg) ( vreg pending -- reg )
! If a live vreg is not in the pending set, then it must
! have been spilled.
?at [ spill-slots get at <spill-slot> ] unless ;
: vreg>reg ( vreg -- reg )
pending-interval-assoc get (vreg>reg) ;
: vregs>regs ( vregs -- assoc )
dup assoc-empty? [
pending-interval-assoc get
'[ _ (vreg>reg) ] assoc-map
] unless ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
@ -96,8 +110,6 @@ SYMBOL: register-live-outs
GENERIC: assign-registers-in-insn ( insn -- )
: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
M: vreg-insn assign-registers-in-insn
@ -123,7 +135,7 @@ M: vreg-insn assign-registers-in-insn
[
[
2dup spill-on-gc?
[ swap [ assign-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
[ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
@ -137,23 +149,13 @@ M: ##gc assign-registers-in-insn
M: insn assign-registers-in-insn drop ;
: compute-live-values ( vregs -- assoc )
! If a live vreg is not in active or inactive, then it must have been
! spilled.
dup assoc-empty? [
pending-interval-assoc get
'[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
] unless ;
: begin-block ( bb -- )
dup basic-block set
dup block-from activate-new-intervals
[ live-in compute-live-values ] keep
register-live-ins get set-at ;
[ live-in vregs>regs ] keep register-live-ins get set-at ;
: end-block ( bb -- )
[ live-out compute-live-values ] keep
register-live-outs get set-at ;
[ live-out vregs>regs ] keep register-live-outs get set-at ;
ERROR: bad-vreg vreg ;

1
basis/compiler/cfg/linear-scan/debugger/debugger.factor
View File

@ -9,6 +9,7 @@ IN: compiler.cfg.linear-scan.debugger
[
[ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set
f
] dip
allocate-registers drop ;

100
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -30,11 +30,12 @@ M: live-interval covers? ( insn# live-interval -- ? )
covers?
] if ;
ERROR: dead-value-error vreg ;
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: shorten-range ( n live-interval -- )
dup ranges>> empty?
[ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
[ dupd add-new-range ] [ ranges>> last (>>from) ] if ;
: extend-range ( from to live-range -- )
ranges>> last
@ -42,9 +43,6 @@ ERROR: dead-value-error vreg ;
[ min ] change-from
drop ;
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ;
@ -52,8 +50,18 @@ ERROR: dead-value-error vreg ;
2dup extend-range?
[ extend-range ] [ add-new-range ] if ;
: add-use ( n live-interval -- )
uses>> push ;
GENERIC: operands-in-registers? ( insn -- ? )
M: vreg-insn operands-in-registers? drop t ;
M: partial-sync-insn operands-in-registers? drop f ;
: add-def ( insn live-interval -- )
[ insn#>> ] [ uses>> ] bi* push ;
: add-use ( insn live-interval -- )
! Every use is a potential def, no SSA here baby!
over operands-in-registers? [ add-def ] [ 2drop ] if ;
: <live-interval> ( vreg -- live-interval )
\ live-interval new
@ -68,51 +76,68 @@ ERROR: dead-value-error vreg ;
M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ;
M: live-interval clone
call-next-method [ clone ] change-uses ;
! Mapping from vreg to live-interval
SYMBOL: live-intervals
: live-interval ( vreg live-intervals -- live-interval )
[ <live-interval> ] cache ;
: live-interval ( vreg -- live-interval )
live-intervals get [ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ;
: handle-output ( n vreg live-intervals -- )
: handle-output ( insn vreg -- )
live-interval
[ add-use ] [ shorten-range ] 2bi ;
[ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
: handle-input ( n vreg live-intervals -- )
: handle-input ( insn vreg -- )
live-interval
[ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
[ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
: handle-temp ( n vreg live-intervals -- )
: handle-temp ( insn vreg -- )
live-interval
[ dupd add-range ] [ add-use ] 2bi ;
[ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get
[ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
[ dup defs-vreg [ handle-output ] with when* ]
[ dup uses-vregs [ handle-input ] with each ]
[ dup temp-vregs [ handle-temp ] with each ]
tri ;
: handle-live-out ( bb -- )
live-out keys
basic-block get [ block-from ] [ block-to ] bi
live-intervals get '[
[ _ _ ] dip _ live-interval add-range
] each ;
[ block-from ] [ block-to ] [ live-out keys ] tri
[ live-interval add-range ] with with each ;
! A location where all registers have to be spilled
TUPLE: sync-point n ;
C: <sync-point> sync-point
! Sequence of sync points
SYMBOL: sync-points
GENERIC: compute-sync-points* ( insn -- )
M: partial-sync-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
: compute-live-intervals-step ( bb -- )
[ basic-block set ]
[ handle-live-out ]
[ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
[
instructions>> <reversed> [
[ compute-live-intervals* ]
[ compute-sync-points* ]
bi
] each
] tri ;
: init-live-intervals ( -- )
H{ } clone live-intervals set
V{ } clone sync-points set ;
: compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
@ -122,10 +147,10 @@ ERROR: bad-live-interval live-interval ;
: check-start ( live-interval -- )
dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
: finish-live-intervals ( live-intervals -- seq )
! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end.
[
values dup [
{
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
@ -134,12 +159,11 @@ ERROR: bad-live-interval live-interval ;
} cleave
] each ;
: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
linearization-order <reversed>
[ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
: compute-live-intervals ( cfg -- live-intervals sync-points )
init-live-intervals
linearization-order <reversed> [ compute-live-intervals-step ] each
live-intervals get finish-live-intervals
sync-points get ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;

4
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -141,7 +141,9 @@ M: ##set-string-nth-fast rename-insn-temps
TEMP-QUOT change-temp drop ;
M: ##box-displaced-alien rename-insn-temps
TEMP-QUOT change-temp drop ;
TEMP-QUOT change-temp1
TEMP-QUOT change-temp2
drop ;
M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ;

2
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -25,7 +25,7 @@ M: ##slot temp-vreg-reps drop { int-rep } ;
M: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth temp-vreg-reps drop { int-rep } ;
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
M: ##box-displaced-alien temp-vreg-reps drop { int-rep } ;
M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
M: ##compare temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float temp-vreg-reps drop { int-rep } ;

15
basis/compiler/cfg/value-numbering/expressions/expressions.factor
View File

@ -12,6 +12,8 @@ TUPLE: commutative-expr < binary-expr ;
TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
TUPLE: reference-expr < expr value ;
TUPLE: unary-float-function-expr < expr in func ;
TUPLE: binary-float-function-expr < expr in1 in2 func ;
TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
: <constant> ( constant -- expr )
@ -94,6 +96,19 @@ M: ##box-displaced-alien >expr
[ base-class>> ]
} cleave box-displaced-alien-expr boa ;
M: ##unary-float-function >expr
[ class ] [ src>> vreg>vn ] [ func>> ] tri
unary-float-function-expr boa ;
M: ##binary-float-function >expr
{
[ class ]
[ src1>> vreg>vn ]
[ src2>> vreg>vn ]
[ func>> ]
} cleave
binary-float-function-expr boa ;
M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- )

8
basis/compiler/codegen/codegen.factor
View File

@ -176,6 +176,12 @@ M: ##max-float generate-insn dst/src1/src2 %max-float ;
M: ##sqrt generate-insn dst/src %sqrt ;
M: ##unary-float-function generate-insn
[ dst/src ] [ func>> ] bi %unary-float-function ;
M: ##binary-float-function generate-insn
[ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
M: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ;
@ -187,7 +193,7 @@ M: ##box-float generate-insn dst/src/temp %box-float ;
M: ##box-alien generate-insn dst/src/temp %box-alien ;
M: ##box-displaced-alien generate-insn
[ dst/src1/src2 ] [ temp>> ] bi %box-displaced-alien ;
[ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;

9
basis/compiler/tests/codegen.factor
View File

@ -3,7 +3,7 @@ math hashtables.private math.private namespaces sequences tools.test
namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit
math.order ;
math.order math.libm math.parser ;
QUALIFIED: namespaces.private
IN: compiler.tests.codegen
@ -407,4 +407,9 @@ cell 4 = [
: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ;
: missing-gc-check-2 ( -- ) 10000000 [ missing-gc-check-1 drop ] each-integer ;
[ ] [ missing-gc-check-2 ] unit-test
[ ] [ missing-gc-check-2 ] unit-test
[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test

8
basis/compiler/tests/intrinsics.factor
View File

@ -519,6 +519,14 @@ cell 8 = [
underlying>>
] unit-test
[ ALIEN: 1234 ALIEN: 2234 ] [
ALIEN: 234 [
{ c-ptr } declare
[ 1000 swap <displaced-alien> ]
[ 2000 swap <displaced-alien> ] bi
] compile-call
] unit-test
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail

4
basis/cpu/architecture/architecture.factor
View File

@ -115,6 +115,8 @@ HOOK: %div-float cpu ( dst src1 src2 -- )
HOOK: %min-float cpu ( dst src1 src2 -- )
HOOK: %max-float cpu ( dst src1 src2 -- )
HOOK: %sqrt cpu ( dst src -- )
HOOK: %unary-float-function cpu ( dst src func -- )
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
@ -124,7 +126,7 @@ HOOK: %unbox-float cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp -- )
HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )

19
basis/cpu/ppc/ppc.factor
View File

@ -335,7 +335,7 @@ M:: ppc %box-alien ( dst src temp -- )
"f" resolve-label
] with-scope ;
M:: ppc %box-displaced-alien ( dst displacement base temp -- )
M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
[
"end" define-label
"ok" define-label
@ -343,7 +343,12 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
dst base MR
0 displacement 0 CMPI
"end" get BEQ
! Quickly use displacement' before its needed for real, as allot temporary
displacement' :> temp
dst 4 cells alien temp %allot
! If base is already a displaced alien, unpack it
base' base MR
displacement' displacement MR
0 base \ f tag-number CMPI
"ok" get BEQ
temp base header-offset LWZ
@ -351,11 +356,17 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
"ok" get BNE
! displacement += base.displacement
temp base 3 alien@ LWZ
displacement displacement temp ADD
displacement' displacement temp ADD
! base = base.base
base base 1 alien@ LWZ
base' base 1 alien@ LWZ
"ok" resolve-label
dst displacement base temp %allot-alien
! Store underlying-alien slot
base' dst 1 alien@ STW
! Store offset
displacement' dst 3 alien@ STW
! Store expired slot (its ok to clobber displacement')
temp \ f tag-number %load-immediate
temp dst 2 alien@ STW
"end" resolve-label
] with-scope ;

20
basis/cpu/x86/64/64.factor
View File

@ -197,6 +197,23 @@ M: x86.64 %callback-value ( ctype -- )
! Unbox former top of data stack to return registers
unbox-return ;
: float-function-param ( i spill-slot -- )
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
float-regs return-reg double-float-rep copy-register ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
func f %alien-invoke
dst float-function-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param
1 src2 float-function-param
func f %alien-invoke
dst float-function-return ;
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
@ -204,6 +221,9 @@ enable-alien-4-intrinsics
! SSE2 is always available on x86-64.
enable-sse2
! Enable fast calling of libc math functions
enable-float-functions
USE: vocabs.loader
{

14
basis/cpu/x86/x86.factor
View File

@ -278,7 +278,7 @@ M:: x86 %box-alien ( dst src temp -- )
"end" resolve-label
] with-scope ;
M:: x86 %box-displaced-alien ( dst displacement base temp -- )
M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
[
"end" define-label
"ok" define-label
@ -286,17 +286,23 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- )
dst base MOV
displacement 0 CMP
"end" get JE
! Quickly use displacement' before its needed for real, as allot temporary
dst 4 cells alien displacement' %allot
! If base is already a displaced alien, unpack it
base' base MOV
displacement' displacement MOV
base \ f tag-number CMP
"ok" get JE
base header-offset [+] alien type-number tag-fixnum CMP
"ok" get JNE
! displacement += base.displacement
displacement base 3 alien@ ADD
displacement' base 3 alien@ ADD
! base = base.base
base base 1 alien@ MOV
base' base 1 alien@ MOV
"ok" resolve-label
dst displacement base temp %allot-alien
dst 1 alien@ base' MOV ! alien
dst 2 alien@ \ f tag-number MOV ! expired
dst 3 alien@ displacement' MOV ! displacement
"end" resolve-label
] with-scope ;

5
basis/help/handbook/handbook.factor
View File

@ -106,10 +106,7 @@ ARTICLE: "numbers" "Numbers"
{ $subsection "complex-numbers" }
"Advanced features:"
{ $subsection "math-vectors" }
{ $subsection "math-intervals" }
{ $subsection "math-bitfields" }
"Implementation:"
{ $subsection "math.libm" } ;
{ $subsection "math-intervals" } ;
USE: io.buffers

19
basis/images/jpeg/jpeg.factor
View File

@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep images.loader ;
sequences sequences.deep images.loader io.streams.limited ;
IN: images.jpeg
QUALIFIED-WITH: bitstreams bs
@ -118,18 +118,18 @@ TUPLE: jpeg-color-info
] with-byte-reader ;
: decode-huff-table ( chunk -- )
data>>
binary
[
1 ! %fixme: Should handle multiple tables at once
data>> [ binary <byte-reader> ] [ length ] bi
stream-throws limit
[
[ input-stream get [ count>> ] [ limit>> ] bi < ]
[
read4/4 swap 2 * +
16 read
dup [ ] [ + ] map-reduce read
binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
swap jpeg> huff-tables>> set-nth
] times
] with-byte-reader ;
] while
] with-input-stream* ;
: decode-scan ( chunk -- )
data>>
@ -148,7 +148,10 @@ TUPLE: jpeg-color-info
: singleton-first ( seq -- elt )
[ length 1 assert= ] [ first ] bi ;
ERROR: not-a-baseline-jpeg-image ;
: baseline-parse ( -- )
jpeg> headers>> [ type>> { SOF 0 } = ] any? [ not-a-baseline-jpeg-image ] unless
jpeg> headers>>
{
[ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
@ -221,7 +224,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
: idct ( b -- b' ) idct-blas ;
: idct ( b -- b' ) idct-factor ;
:: draw-block ( block x,y color-id jpeg-image -- )
block dup length>> sqrt >fixnum group flip

25
basis/io/backend/unix/multiplexers/kqueue/kqueue.factor
View File

@ -2,28 +2,28 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types combinators destructors
io.backend.unix kernel math.bitwise sequences struct-arrays unix
unix.kqueue unix.time assocs io.backend.unix.multiplexers ;
unix.kqueue unix.time assocs io.backend.unix.multiplexers
classes.struct ;
IN: io.backend.unix.multiplexers.kqueue
TUPLE: kqueue-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
#! constant...
256 ; inline
! We read up to 256 events at a time. This is an arbitrary
! constant...
CONSTANT: max-events 256
: <kqueue-mx> ( -- mx )
kqueue-mx new-mx
kqueue dup io-error >>fd
max-events "kevent" <struct-array> >>events ;
max-events \ kevent <struct-array> >>events ;
M: kqueue-mx dispose* fd>> close-file ;
: make-kevent ( fd filter flags -- event )
"kevent" <c-object>
[ set-kevent-flags ] keep
[ set-kevent-filter ] keep
[ set-kevent-ident ] keep ;
\ kevent <struct>
swap >>flags
swap >>filter
swap >>ident ;
: register-kevent ( kevent mx -- )
fd>> swap 1 f 0 f kevent io-error ;
@ -63,13 +63,14 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq )
] dip kevent multiplexer-error ;
: handle-kevent ( mx kevent -- )
[ kevent-ident swap ] [ kevent-filter ] bi {
[ ident>> swap ] [ filter>> ] bi {
{ EVFILT_READ [ input-available ] }
{ EVFILT_WRITE [ output-available ] }
} case ;
: handle-kevents ( mx n -- )
[ dup events>> ] dip head-slice [ handle-kevent ] with each ;
[ dup events>> ] dip head-slice
[ handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( us mx -- )
swap dup [ make-timespec ] when

3
basis/io/backend/unix/unix-tests.factor
View File

@ -74,8 +74,7 @@ yield
[ datagram-client delete-file ] ignore-errors
datagram-client <local> <datagram>
"d" set
[ ] [ datagram-client <local> <datagram> "d" set ] unit-test
[ ] [
"hello" >byte-array

7
basis/io/directories/unix/linux/linux.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.directories.unix kernel system unix ;
USING: alien.c-types io.directories.unix kernel system unix
classes.struct ;
IN: io.directories.unix.linux
M: unix find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
M: unix find-next-file ( DIR* -- dirent )
dirent <struct>
f <void*>
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;

8
basis/io/directories/unix/unix.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
unix unix.stat vocabs.loader ;
unix unix.stat vocabs.loader classes.struct ;
IN: io.directories.unix
: touch-mode ( -- n )
@ -37,7 +37,7 @@ M: unix copy-file ( from to -- )
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
dirent <struct>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;
@ -57,8 +57,8 @@ M: unix find-next-file ( DIR* -- byte-array )
M: unix >directory-entry ( byte-array -- directory-entry )
{
[ dirent-d_name underlying>> utf8 alien>string ]
[ dirent-d_type dirent-type>file-type ]
[ d_name>> underlying>> utf8 alien>string ]
[ d_type>> dirent-type>file-type ]
} cleave directory-entry boa ;
M: unix (directory-entries) ( path -- seq )

9
basis/io/files/info/unix/bsd/bsd.factor
View File

@ -12,10 +12,7 @@ M: bsd new-file-info ( -- class ) bsd-file-info new ;
M: bsd stat>file-info ( stat -- file-info )
[ call-next-method ] keep
{
[ stat-st_flags >>flags ]
[ stat-st_gen >>gen ]
[
stat-st_birthtimespec timespec>unix-time
>>birth-time
]
[ st_flags>> >>flags ]
[ st_gen>> >>gen ]
[ st_birthtimespec>> timespec>unix-time >>birth-time ]
} cleave ;

56
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types
specialized-arrays.direct.uint arrays io.files.info.unix ;
arrays io.files.info.unix classes.struct ;
IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -13,43 +13,43 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
"statfs" <c-object> [ statfs io-error ] keep ;
\ statfs <struct> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
[ statfs-f_version >>version ]
[ statfs-f_type >>type ]
[ statfs-f_flags >>flags ]
[ statfs-f_bsize >>block-size ]
[ statfs-f_iosize >>io-size ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>blocks-free ]
[ statfs-f_bavail >>blocks-available ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>files-free ]
[ statfs-f_syncwrites >>syncwrites ]
[ statfs-f_asyncwrites >>asyncwrites ]
[ statfs-f_syncreads >>syncreads ]
[ statfs-f_asyncreads >>asyncreads ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_fstypename utf8 alien>string >>type ]
[ statfs-f_mntfromname utf8 alien>string >>device-name ]
[ statfs-f_mntonname utf8 alien>string >>mount-point ]
[ f_version>> >>version ]
[ f_type>> >>type ]
[ f_flags>> >>flags ]
[ f_bsize>> >>block-size ]
[ f_iosize>> >>io-size ]
[ f_blocks>> >>blocks ]
[ f_bfree>> >>blocks-free ]
[ f_bavail>> >>blocks-available ]
[ f_files>> >>files ]
[ f_ffree>> >>files-free ]
[ f_syncwrites>> >>syncwrites ]
[ f_asyncwrites>> >>asyncwrites ]
[ f_syncreads>> >>syncreads ]
[ f_asyncreads>> >>asyncreads ]
[ f_namemax>> >>name-max ]
[ f_owner>> >>owner ]
[ f_fsid>> >>id ]
[ f_fstypename>> utf8 alien>string >>type ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
[ f_mntonname>> utf8 alien>string >>mount-point ]
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> [ statvfs io-error ] keep ;
\ statvfs <struct> [ \ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
[ statvfs-f_favail >>files-available ]
[ statvfs-f_frsize >>preferred-block-size ]
[ f_favail>> >>files-available ]
[ f_frsize>> >>preferred-block-size ]
} cleave ;
M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error
"statfs" <c-array> dup dup length 0 getfsstat io-error
"statfs" heap-size group
[ statfs-f_mntonname alien>native-string file-system-info ] map ;
\ statfs <struct> dup dup length 0 getfsstat io-error
statfs heap-size group
[ f_mntonname>> alien>native-string file-system-info ] map ;

32
basis/io/files/info/unix/linux/linux.factor
View File

@ -4,8 +4,8 @@ USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames unix.types ;
arrays io.files.info.unix assocs io.pathnames unix.types
classes.struct ;
FROM: csv => delimiter ;
IN: io.files.info.unix.linux
@ -15,30 +15,30 @@ namelen ;
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
"statfs64" <c-object> [ statfs64 io-error ] keep ;
\ statfs64 <struct> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
[ statfs64-f_type >>type ]
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs64-f_namelen >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ]
[ f_type>> >>type ]
[ f_bsize>> >>block-size ]
[ f_blocks>> >>blocks ]
[ f_bfree>> >>blocks-free ]
[ f_bavail>> >>blocks-available ]
[ f_files>> >>files ]
[ f_ffree>> >>files-free ]
[ f_fsid>> >>id ]
[ f_namelen>> >>namelen ]
[ f_frsize>> >>preferred-block-size ]
! [ statfs64-f_spare >>spare ]
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
"statvfs64" <c-object> [ statvfs64 io-error ] keep ;
\ statvfs64 <struct> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{
[ statvfs64-f_flag >>flags ]
[ statvfs64-f_namemax >>name-max ]
[ f_flag>> >>flags ]
[ f_namemax>> >>name-max ]
} cleave ;
TUPLE: mtab-entry file-system-name mount-point type options

48
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
system unix io.files.unix specialized-arrays.direct.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
io.files.info.unix io.files.info ;
io.files.info.unix io.files.info classes.struct struct-arrays ;
IN: io.files.info.unix.macosx
TUPLE: macosx-file-system-info < unix-file-system-info
@ -12,41 +12,39 @@ io-size owner type-id filesystem-subtype ;
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip
"statfs64" heap-size [ * memory>byte-array ] keep group
[ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
[ *void* ] dip \ statfs64 <direct-struct-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
"statfs64" <c-object> [ statfs64 io-error ] keep ;
\ statfs64 <struct> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> [ statvfs io-error ] keep ;
\ statvfs <struct> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
[ statfs64-f_bsize >>block-size ]
[ statfs64-f_iosize >>io-size ]
[ statfs64-f_blocks >>blocks ]
[ statfs64-f_bfree >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ]
[ statfs64-f_files >>files ]
[ statfs64-f_ffree >>files-free ]
[ statfs64-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs64-f_owner >>owner ]
[ statfs64-f_type >>type-id ]
[ statfs64-f_flags >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ]
[ statfs64-f_fstypename utf8 alien>string >>type ]
[ statfs64-f_mntonname utf8 alien>string >>mount-point ]
[ statfs64-f_mntfromname utf8 alien>string >>device-name ]
[ f_bsize>> >>block-size ]
[ f_iosize>> >>io-size ]
[ f_blocks>> >>blocks ]
[ f_bfree>> >>blocks-free ]
[ f_bavail>> >>blocks-available ]
[ f_files>> >>files ]
[ f_ffree>> >>files-free ]
[ f_fsid>> >>id ]
[ f_owner>> >>owner ]
[ f_type>> >>type-id ]
[ f_flags>> >>flags ]
[ f_fssubtype>> >>filesystem-subtype ]
[ f_fstypename>> utf8 alien>string >>type ]
[ f_mntonname>> utf8 alien>string >>mount-point ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{
[ statvfs-f_frsize >>preferred-block-size ]
[ statvfs-f_favail >>files-available ]
[ statvfs-f_namemax >>name-max ]
[ f_frsize>> >>preferred-block-size ]
[ f_favail>> >>files-available ]
[ f_namemax>> >>name-max ]
} cleave ;

59
basis/io/files/info/unix/netbsd/netbsd.factor
View File

@ -4,8 +4,8 @@ USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
grouping sequences io.encodings.utf8
specialized-arrays.direct.uint io.files.info.unix ;
grouping sequences io.encodings.utf8 classes.struct
io.files.info.unix ;
IN: io.files.info.unix.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
@ -16,38 +16,37 @@ idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> [ statvfs io-error ] keep ;
\ statvfs <struct> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
[ statvfs-f_flag >>flags ]
[ statvfs-f_bsize >>block-size ]
[ statvfs-f_frsize >>preferred-block-size ]
[ statvfs-f_iosize >>io-size ]
[ statvfs-f_blocks >>blocks ]
[ statvfs-f_bfree >>blocks-free ]
[ statvfs-f_bavail >>blocks-available ]
[ statvfs-f_bresvd >>blocks-reserved ]
[ statvfs-f_files >>files ]
[ statvfs-f_ffree >>files-free ]
[ statvfs-f_favail >>files-available ]
[ statvfs-f_fresvd >>files-reserved ]
[ statvfs-f_syncreads >>sync-reads ]
[ statvfs-f_syncwrites >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ]
[ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ]
[ statvfs-f_fsid >>id ]
[ statvfs-f_namemax >>name-max ]
[ statvfs-f_owner >>owner ]
! [ statvfs-f_spare >>spare ]
[ statvfs-f_fstypename utf8 alien>string >>type ]
[ statvfs-f_mntonname utf8 alien>string >>mount-point ]
[ statvfs-f_mntfromname utf8 alien>string >>device-name ]
[ f_flag>> >>flags ]
[ f_bsize>> >>block-size ]
[ f_frsize>> >>preferred-block-size ]
[ f_iosize>> >>io-size ]
[ f_blocks>> >>blocks ]
[ f_bfree>> >>blocks-free ]
[ f_bavail>> >>blocks-available ]
[ f_bresvd>> >>blocks-reserved ]
[ f_files>> >>files ]
[ f_ffree>> >>files-free ]
[ f_favail>> >>files-available ]
[ f_fresvd>> >>files-reserved ]
[ f_syncreads>> >>sync-reads ]
[ f_syncwrites>> >>sync-writes ]
[ f_asyncreads>> >>async-reads ]
[ f_asyncwrites>> >>async-writes ]
[ f_fsidx>> >>idx ]
[ f_fsid>> >>id ]
[ f_namemax>> >>name-max ]
[ f_owner>> >>owner ]
[ f_fstypename>> utf8 alien>string >>type ]
[ f_mntonname>> utf8 alien>string >>mount-point ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
"statvfs" <c-array> dup dup length 0 getvfsstat io-error
"statvfs" heap-size group
[ statvfs-f_mntonname utf8 alien>string file-system-info ] map ;
\ statvfs <c-type-array> dup dup length 0 getvfsstat io-error
\ statvfs heap-size group
[ f_mntonname>> utf8 alien>string file-system-info ] map ;

55
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings alien.syntax
combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
specialized-arrays.direct.uint arrays io.files.info.unix ;
arrays io.files.info.unix classes.struct ;
IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -14,42 +14,39 @@ owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
"statfs" <c-object> [ statfs io-error ] keep ;
\ statfs <struct> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
[ statfs-f_flags >>flags ]
[ statfs-f_bsize >>block-size ]
[ statfs-f_iosize >>io-size ]
[ statfs-f_blocks >>blocks ]
[ statfs-f_bfree >>blocks-free ]
[ statfs-f_bavail >>blocks-available ]
[ statfs-f_files >>files ]
[ statfs-f_ffree >>files-free ]
[ statfs-f_favail >>files-available ]
[ statfs-f_syncwrites >>sync-writes ]
[ statfs-f_syncreads >>sync-reads ]
[ statfs-f_asyncwrites >>async-writes ]
[ statfs-f_asyncreads >>async-reads ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ]
[ statfs-f_namemax >>name-max ]
[ statfs-f_owner >>owner ]
! [ statfs-f_spare >>spare ]
[ statfs-f_fstypename alien>native-string >>type ]
[ statfs-f_mntonname alien>native-string >>mount-point ]
[ statfs-f_mntfromname alien>native-string >>device-name ]
[ f_flags>> >>flags ]
[ f_bsize>> >>block-size ]
[ f_iosize>> >>io-size ]
[ f_blocks>> >>blocks ]
[ f_bfree>> >>blocks-free ]
[ f_bavail>> >>blocks-available ]
[ f_files>> >>files ]
[ f_ffree>> >>files-free ]
[ f_favail>> >>files-available ]
[ f_syncwrites>> >>sync-writes ]
[ f_syncreads>> >>sync-reads ]
[ f_asyncwrites>> >>async-writes ]
[ f_asyncreads>> >>async-reads ]
[ f_fsid>> >>id ]
[ f_namemax>> >>name-max ]
[ f_owner>> >>owner ]
[ f_fstypename>> alien>native-string >>type ]
[ f_mntonname>> alien>native-string >>mount-point ]
[ f_mntfromname>> alien>native-string >>device-name ]
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> [ statvfs io-error ] keep ;
\ statvfs <struct> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{
[ statvfs-f_frsize >>preferred-block-size ]
} cleave ;
f_frsize>> >>preferred-block-size ;
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
"statfs" <c-array> dup dup length 0 getfsstat io-error
"statfs" heap-size group
[ statfs-f_mntonname alien>native-string file-system-info ] map ;
\ statfs <c-type-array> dup dup length 0 getfsstat io-error
\ statfs heap-size group
[ f_mntonname>> alien>native-string file-system-info ] map ;

41
basis/io/files/info/unix/unix.factor
View File

@ -4,7 +4,7 @@ USING: accessors kernel system math math.bitwise strings arrays
sequences combinators combinators.short-circuit alien.c-types
vocabs.loader calendar calendar.unix io.files.info
io.files.types io.backend io.directories unix unix.stat unix.time unix.users
unix.groups ;
unix.groups classes.struct struct-arrays ;
IN: io.files.info.unix
TUPLE: unix-file-system-info < file-system-info
@ -69,19 +69,19 @@ M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip
{
[ stat>type >>type ]
[ stat-st_size >>size ]
[ stat-st_mode >>permissions ]
[ stat-st_ctimespec timespec>unix-time >>created ]
[ stat-st_mtimespec timespec>unix-time >>modified ]
[ stat-st_atimespec timespec>unix-time >>accessed ]
[ stat-st_uid >>uid ]
[ stat-st_gid >>gid ]
[ stat-st_dev >>dev ]
[ stat-st_ino >>ino ]
[ stat-st_nlink >>nlink ]
[ stat-st_rdev >>rdev ]
[ stat-st_blocks >>blocks ]
[ stat-st_blksize >>blocksize ]
[ st_size>> >>size ]
[ st_mode>> >>permissions ]
[ st_ctimespec>> timespec>unix-time >>created ]
[ st_mtimespec>> timespec>unix-time >>modified ]
[ st_atimespec>> timespec>unix-time >>accessed ]
[ st_uid>> >>uid ]
[ st_gid>> >>gid ]
[ st_dev>> >>dev ]
[ st_ino>> >>ino ]
[ st_nlink>> >>nlink ]
[ st_rdev>> >>rdev ]
[ st_blocks>> >>blocks ]
[ st_blksize>> >>blocksize ]
[ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
@ -98,12 +98,12 @@ M: unix stat>file-info ( stat -- file-info )
} case ;
M: unix stat>type ( stat -- type )
stat-st_mode n>file-type ;
st_mode>> n>file-type ;
<PRIVATE
: stat-mode ( path -- mode )
normalize-path file-status stat-st_mode ;
normalize-path file-status st_mode>> ;
: chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip
@ -179,14 +179,12 @@ M: unix copy-file-and-info ( from to -- )
<PRIVATE
: make-timeval-array ( array -- byte-array )
[ [ "timeval" <c-object> ] unless* ] map concat ;
: timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array )
[ dup [ timestamp>timeval ] when ] map make-timeval-array ;
[ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
\ timeval >struct-array ;
PRIVATE>
@ -202,8 +200,7 @@ PRIVATE>
f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- )
[ normalize-path ] 2dip
[ [ -1 ] unless* ] bi@ chown io-error ;
[ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
GENERIC: set-file-user ( path string/id -- )

6
basis/io/sockets/unix/unix.factor
View File

@ -61,8 +61,8 @@ M: object ((client)) ( addrspec -- fd )
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
dup init-server-socket
dup handle-fd rot make-sockaddr/size bind io-error ;
[ init-server-socket ] keep
[ handle-fd swap make-sockaddr/size bind io-error ] keep ;
M: object (server) ( addrspec -- handle )
[
@ -148,7 +148,7 @@ M: local make-sockaddr
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
[ [ utf8 string>alien ] dip set-sockaddr-un-path ] keep ;
M: local parse-sockaddr
drop

1
basis/math/bits/bits-docs.factor
View File

@ -6,6 +6,7 @@ IN: math.bits
ABOUT: "math.bits"
ARTICLE: "math.bits" "Number bits virtual sequence"
"The " { $vocab-link "math.bits" } " vocabulary implements a virtual sequence which presents an integer as a sequence of bits, with the first element of the sequence being the least significant bit of the integer."
{ $subsection bits }
{ $subsection <bits> }
{ $subsection make-bits } ;

7
basis/math/complex/complex.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
math.libm math.functions arrays math.functions.private sequences
parser ;
math.functions arrays math.functions.private sequences parser ;
IN: math.complex.private
M: real real-part ; inline
@ -26,8 +25,8 @@ M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
M: complex / [ / ] complex/ ; inline
M: complex /f [ /f ] complex/ ; inline
M: complex /i [ /i ] complex/ ; inline
M: complex abs absq >float fsqrt ; inline
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline
M: complex abs absq sqrt ; inline
M: complex sqrt >polar [ sqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax

19
basis/math/functions/functions-tests.factor
View File

@ -30,21 +30,40 @@ IN: math.functions.tests
[ 0 ] [ 0 3 ^ ] unit-test
[ 0.0 ] [ 1 log ] unit-test
[ 0.0 ] [ 1.0 log ] unit-test
[ 1.0 ] [ e log ] unit-test
[ t ] [ 1 exp e = ] unit-test
[ t ] [ 1.0 exp e = ] unit-test
[ 1.0 ] [ -1 exp e * ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
[ 0.0 ] [ 1.0 acosh ] unit-test
[ 1.0 ] [ 0 cos ] unit-test
[ 1.0 ] [ 0.0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
[ 0.0 ] [ 1.0 acos ] unit-test
[ 0.0 ] [ 0 sinh ] unit-test
[ 0.0 ] [ 0.0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
[ 0.0 ] [ 0.0 asinh ] unit-test
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0.0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
[ 0.0 ] [ 0.0 asin ] unit-test
[ 0.0 ] [ 0 tan ] unit-test
[ t ] [ pi 2 / tan 1.e10 > ] unit-test
[ t ] [ 10 atan real? ] unit-test
[ t ] [ 10.0 atan real? ] unit-test
[ f ] [ 10 atanh real? ] unit-test
[ f ] [ 10.0 atanh real? ] unit-test
[ t ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 1.e-10 ~ ] unit-test

63
basis/math/functions/functions.factor
View File

@ -52,14 +52,25 @@ PRIVATE>
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
: cis ( arg -- z ) >float [ fcos ] [ fsin ] bi rect> ; inline
: polar> ( abs arg -- z ) cis * ; inline
GENERIC: exp ( x -- y )
M: float exp fexp ; inline
M: real exp >float exp ; inline
M: complex exp >rect swap fexp swap polar> ; inline
<PRIVATE
: ^mag ( w abs arg -- magnitude )
[ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
[ >float-rect swap ]
[ >float swap >float fpow ]
[ rot * exp /f ]
tri* ; inline
: ^theta ( w abs arg -- theta )
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
@ -91,7 +102,7 @@ PRIVATE>
{
{ [ over 0 = ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
{ [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
[ ^complex ]
} cond ; inline
@ -146,17 +157,13 @@ M: real absq sq ; inline
: >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline
GENERIC: exp ( x -- y )
M: real exp fexp ; inline
M: complex exp >rect swap fexp swap polar> ;
GENERIC: log ( x -- y )
M: real log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
M: float log dup 0.0 >= [ flog ] [ 0.0 rect> log ] if ; inline
M: complex log >polar swap flog swap rect> ;
M: real log >float log ; inline
M: complex log >polar swap flog swap rect> ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
@ -169,7 +176,9 @@ M: complex cos
[ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ;
M: real cos fcos ; inline
M: float cos fcos ; inline
M: real cos >float cos ; inline
: sec ( x -- y ) cos recip ; inline
@ -180,7 +189,9 @@ M: complex cosh
[ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ;
M: real cosh fcosh ; inline
M: float cosh fcosh ; inline
M: real cosh >float cosh ; inline
: sech ( x -- y ) cosh recip ; inline
@ -191,7 +202,9 @@ M: complex sin
[ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ;
M: real sin fsin ; inline
M: float sin fsin ; inline
M: real sin >float sin ; inline
: cosec ( x -- y ) sin recip ; inline
@ -202,7 +215,9 @@ M: complex sinh
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
M: real sinh fsinh ; inline
M: float sinh fsinh ; inline
M: real sinh >float sinh ; inline
: cosech ( x -- y ) sinh recip ; inline
@ -210,13 +225,17 @@ GENERIC: tan ( x -- y ) foldable
M: complex tan [ sin ] [ cos ] bi / ;
M: real tan ftan ; inline
M: float tan ftan ; inline
M: real tan >float tan ; inline
GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ;
M: real tanh ftanh ; inline
M: float tanh ftanh ; inline
M: real tanh >float tanh ; inline
: cot ( x -- y ) tan recip ; inline
@ -242,17 +261,19 @@ M: real tanh ftanh ; inline
: -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y )
dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
: acos ( x -- y )
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
inline
GENERIC: atan ( x -- y ) foldable
M: complex atan i* atanh i* ;
M: complex atan i* atanh i* ; inline
M: real atan fatan ; inline
M: float atan fatan ; inline
M: real atan >float atan ; inline
: asec ( x -- y ) recip acos ; inline

8
basis/math/libm/libm-docs.factor
View File

@ -3,10 +3,10 @@ IN: math.libm
ARTICLE: "math.libm" "C standard library math functions"
"The words in the " { $vocab-link "math.libm" } " vocabulary call C standard library math functions. They are used to implement words in the " { $vocab-link "math.functions" } " vocabulary."
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
{ $warning
"These functions are unsafe. The compiler special-cases them to operate on floats only. They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }

33
basis/math/libm/libm.factor
View File

@ -4,54 +4,53 @@ USING: alien ;
IN: math.libm
: facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ; inline
"double" "libm" "acos" { "double" } alien-invoke ;
: fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ; inline
"double" "libm" "asin" { "double" } alien-invoke ;
: fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ; inline
"double" "libm" "atan" { "double" } alien-invoke ;
: fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ; inline
"double" "libm" "atan2" { "double" "double" } alien-invoke ;
: fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ; inline
"double" "libm" "cos" { "double" } alien-invoke ;
: fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ; inline
"double" "libm" "sin" { "double" } alien-invoke ;
: ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ; inline
"double" "libm" "tan" { "double" } alien-invoke ;
: fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ; inline
"double" "libm" "cosh" { "double" } alien-invoke ;
: fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ; inline
"double" "libm" "sinh" { "double" } alien-invoke ;
: ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ; inline
"double" "libm" "tanh" { "double" } alien-invoke ;
: fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ; inline
"double" "libm" "exp" { "double" } alien-invoke ;
: flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ; inline
"double" "libm" "log" { "double" } alien-invoke ;
: fpow ( x y -- z )
"double" "libm" "pow" { "double" "double" } alien-invoke ; inline
"double" "libm" "pow" { "double" "double" } alien-invoke ;
! Don't inline fsqrt -- its an intrinsic!
: fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these...
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ; inline
"double" "libm" "acosh" { "double" } alien-invoke ;
: fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ; inline
"double" "libm" "asinh" { "double" } alien-invoke ;
: fatanh ( x -- y )
"double" "libm" "atanh" { "double" } alien-invoke ; inline
"double" "libm" "atanh" { "double" } alien-invoke ;

5
basis/math/matrices/matrices-tests.factor
View File

@ -106,4 +106,7 @@ USING: math.matrices math.vectors tools.test math ;
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
[ { { 4181 6765 } { 6765 10946 } } ]
[ { { 0 1 } { 1 1 } } 20 m^n ] unit-test

2
basis/math/matrices/matrices.factor
View File

@ -139,4 +139,4 @@ PRIVATE>
: m^n ( m n -- n )
make-bits over first length identity-matrix
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

3
basis/math/primes/primes.factor
View File

@ -56,7 +56,8 @@ PRIVATE>
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: random-prime ( numbits -- p )
random-bits* next-prime ;
[ ] [ 2^ ] [ random-bits* next-prime ] tri
2dup < [ 2drop random-prime ] [ 2nip ] if ;
: estimated-primes ( m -- n )
dup log / ; foldable

7
basis/struct-arrays/struct-arrays-tests.factor
View File

@ -44,3 +44,10 @@ STRUCT: test-struct-array
S{ test-struct-array f 20 20 }
} second
] unit-test
! Regression
STRUCT: fixed-string { text char[100] } ;
[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
] unit-test

2
basis/tools/deploy/shaker/shaker.factor
View File

@ -289,6 +289,8 @@ IN: tools.deploy.shaker
"disposables" "destructors" lookup ,
"functor-words" "functors.backend" lookup ,
deploy-threads? [
"initial-thread" "threads" lookup ,
] unless

9
basis/tools/disassembler/udis/udis.factor
View File

@ -3,7 +3,8 @@
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
math.parser system make fry arrays libc destructors ;
math.parser system make fry arrays libc destructors
tools.disassembler.utils splitting ;
IN: tools.disassembler.udis
<<
@ -103,19 +104,21 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- )
[ [ <ud> ] dip call ] with-destructors ; inline
[ [ [ <ud> ] dip call ] with-destructors ] with-words-xt ; inline
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
: resolve-call ( str -- str' ) "0x" split1-last [ resolve-xt append ] when* ;
: format-disassembly ( lines -- lines' )
dup [ second length ] [ max ] map-reduce
'[
[
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
[ second _ CHAR: \s pad-tail % " " % ]
[ third % ]
[ third resolve-call % ]
tri
] "" make
] map ;

41
basis/tools/disassembler/utils/utils.factor Normal file
View File

@ -0,0 +1,41 @@
USING: accessors arrays binary-search kernel math math.order
math.parser namespaces sequences sorting splitting vectors vocabs words ;
IN: tools.disassembler.utils
SYMBOL: words-xt
SYMBOL: smallest-xt
SYMBOL: greatest-xt
: (words-xt) ( -- assoc )
vocabs [ words ] map concat [ [ word-xt ] keep 3array ] map
[ [ first ] bi@ <=> ] sort >vector ;
: complete-address ( n seq -- str )
[ first - ] [ third name>> ] bi
over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
: search-xt ( n -- str/f )
dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
drop f
] [
words-xt get over [ swap first <=> ] curry search nip
2dup second <= [
[ complete-address ] [ drop f ] if*
] [
2drop f
] if
] if ;
: resolve-xt ( str -- str' )
[ "0x" prepend ] [ 16 base> ] bi
[ search-xt [ " (" ")" surround append ] when* ] when* ;
: resolve-call ( str -- str' )
"0x" split1-last [ resolve-xt "0x" glue ] when* ;
: with-words-xt ( quot -- )
[ (words-xt)
[ words-xt set ]
[ first first smallest-xt set ]
[ last second greatest-xt set ] tri
] prepose with-scope ; inline

82
basis/ui/backend/x11/x11.factor
View File

@ -1,14 +1,13 @@
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
ui.gadgets.private ui.gestures ui.backend ui.clipboards
ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows x11.io
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
command-line math.vectors classes.tuple opengl.gl threads
math.rectangles environment ascii literals
ui.pixel-formats ui.pixel-formats.private ;
USING: accessors alien.c-types arrays ascii assocs
classes.struct combinators io.encodings.ascii
io.encodings.string io.encodings.utf8 kernel literals math
namespaces sequences strings ui ui.backend ui.clipboards
ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
ui.gestures ui.pixel-formats ui.pixel-formats.private
ui.private x11 x11.clipboard x11.constants x11.events x11.glx
x11.io x11.windows x11.xim x11.xlib environment command-line ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
@ -25,8 +24,7 @@ C: <x11-pixmap-handle> x11-pixmap-handle
M: world expose-event nip relayout ;
M: world configure-event
over configured-loc >>window-loc
swap configured-dim >>dim
swap [ event-loc >>window-loc ] [ event-dim >>dim ] bi
! In case dimensions didn't change
relayout-1 ;
@ -103,7 +101,7 @@ CONSTANT: key-codes
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ;
state>> modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
@ -132,10 +130,7 @@ M: world key-up-event
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ]
[ XButtonEvent-button ]
[ mouse-event-loc ]
tri ;
[ event-modifiers ] [ button>> ] [ event-loc ] tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
@ -146,7 +141,7 @@ M: world button-up-event
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
XButtonEvent-button {
button>> {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
@ -154,7 +149,7 @@ M: world button-up-event
} at ;
M: world wheel-event
[ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
[ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
@ -162,16 +157,13 @@ M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
[ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
move-hand fire-motion ;
[ event-loc ] dip move-hand fire-motion ;
M: world focus-in-event
nip
[ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
nip [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
M: world focus-out-event
nip
[ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
nip [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
@ -189,22 +181,18 @@ M: world selection-notify-event
} case ;
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target
XA_UTF8_STRING = utf8 ascii ? encode ;
target>> XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ XSelectionRequestEvent-target ] keep
[ 8 PropModeReplace ] dip
[
XSelectionRequestEvent-selection
clipboard-for-atom contents>>
] keep encode-clipboard dup length XChangeProperty drop ;
[ requestor>> ] keep
[ property>> ] keep
[ target>> 8 PropModeReplace ] keep
[ selection>> clipboard-for-atom contents>> ] keep
encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
drop dup XSelectionRequestEvent-target {
drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
@ -235,7 +223,7 @@ M: world client-event
] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
wait-event dup window>> window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
@ -269,17 +257,13 @@ M: x11-ui-backend set-title ( string world -- )
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
M: x11-ui-backend (set-fullscreen) ( world ? -- )
[
handle>> window>> "XClientMessageEvent" <c-object>
[ set-XClientMessageEvent-window ] keep
] dip
_NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
over set-XClientMessageEvent-data0
ClientMessage over set-XClientMessageEvent-type
dpy get over set-XClientMessageEvent-display
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
32 over set-XClientMessageEvent-format
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
XClientMessageEvent <struct>
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
swap handle>> window>> >>window
dpy get >>display
"_NET_WM_STATE" x-atom >>message_type
32 >>format
"_NET_WM_STATE_FULLSCREEN" x-atom >>data1
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
@ -312,9 +296,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
with-world-pixel-format
dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ] with-world-pixel-format
<x11-pixmap-handle> >>handle drop ;
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]

14
basis/unix/bsd/freebsd/freebsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -13,12 +13,12 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "u_int32_t" "d_fileno" }
{ "u_int16_t" "d_reclen" }
{ "u_int8_t" "d_type" }
{ "u_int8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
STRUCT: dirent
{ d_fileno u_int32_t }
{ d_reclen u_int16_t }
{ d_type u_int8_t }
{ d_namlen u_int8_t }
{ d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2

14
basis/unix/bsd/macosx/macosx.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax unix.time ;
USING: alien.syntax unix.time classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -32,12 +32,12 @@ CONSTANT: __DARWIN_MAXPATHLEN 1024
CONSTANT: __DARWIN_MAXNAMELEN 255
CONSTANT: __DARWIN_MAXNAMELEN+1 255
C-STRUCT: dirent
{ "ino_t" "d_ino" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" __DARWIN_MAXNAMELEN+1 } "d_name" } ;
STRUCT: dirent
{ d_ino ino_t }
{ d_reclen __uint16_t }
{ d_type __uint8_t }
{ d_namlen __uint8_t }
{ d_name { "char" __DARWIN_MAXNAMELEN+1 } } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2

18
basis/unix/bsd/netbsd/netbsd.factor
View File

@ -1,4 +1,5 @@
USING: alien.syntax alien.c-types math vocabs.loader ;
USING: alien.syntax alien.c-types math vocabs.loader
classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 256
@ -13,12 +14,12 @@ C-STRUCT: addrinfo
{ "void*" "addr" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
STRUCT: dirent
{ d_fileno __uint32_t }
{ d_reclen __uint16_t }
{ d_type __uint8_t }
{ d_namlen __uint8_t }
{ d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
@ -126,8 +127,7 @@ CONSTANT: _UTX_LINESIZE 32
CONSTANT: _UTX_IDSIZE 4
CONSTANT: _UTX_HOSTSIZE 256
: _SS_MAXSIZE ( -- n )
128 ; inline
CONSTANT: _SS_MAXSIZE 128
: _SS_ALIGNSIZE ( -- n )
"__int64_t" heap-size ; inline

14
basis/unix/bsd/openbsd/openbsd.factor
View File

@ -1,4 +1,4 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix
CONSTANT: FD_SETSIZE 1024
@ -13,12 +13,12 @@ C-STRUCT: addrinfo
{ "char*" "canonname" }
{ "addrinfo*" "next" } ;
C-STRUCT: dirent
{ "__uint32_t" "d_fileno" }
{ "__uint16_t" "d_reclen" }
{ "__uint8_t" "d_type" }
{ "__uint8_t" "d_namlen" }
{ { "char" 256 } "d_name" } ;
STRUCT: dirent
{ d_fileno __uint32_t }
{ d_reclen __uint16_t }
{ d_type __uint8_t }
{ d_namlen __uint8_t }
{ d_name char[256] } ;
CONSTANT: EPERM 1
CONSTANT: ENOENT 2

17
basis/unix/kqueue/freebsd/freebsd.factor
View File

@ -1,14 +1,13 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.kqueue
C-STRUCT: kevent
{ "ulong" "ident" } ! identifier for this event
{ "short" "filter" } ! filter for event
{ "ushort" "flags" } ! action flags for kqueue
{ "uint" "fflags" } ! filter flag value
{ "long" "data" } ! filter data value
{ "void*" "udata" } ! opaque user data identifier
;
STRUCT: kevent
{ ident ulong }
{ filter short }
{ flags ushort }
{ fflags uint }
{ data long }
{ udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;

17
basis/unix/kqueue/macosx/macosx.factor
View File

@ -1,14 +1,13 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.kqueue
C-STRUCT: kevent
{ "ulong" "ident" } ! identifier for this event
{ "short" "filter" } ! filter for event
{ "ushort" "flags" } ! action flags for kqueue
{ "uint" "fflags" } ! filter flag value
{ "long" "data" } ! filter data value
{ "void*" "udata" } ! opaque user data identifier
;
STRUCT: kevent
{ ident ulong }
{ filter short }
{ flags ushort }
{ fflags uint }
{ data long }
{ udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;

17
basis/unix/kqueue/netbsd/netbsd.factor
View File

@ -1,14 +1,13 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.kqueue
C-STRUCT: kevent
{ "ulong" "ident" } ! identifier for this event
{ "uint" "filter" } ! filter for event
{ "uint" "flags" } ! action flags for kqueue
{ "uint" "fflags" } ! filter flag value
{ "longlong" "data" } ! filter data value
{ "void*" "udata" } ! opaque user data identifier
;
STRUCT: kevent
{ ident ulong }
{ filter uint }
{ flags uint }
{ fflags uint }
{ data longlong }
{ udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ;

17
basis/unix/kqueue/openbsd/openbsd.factor
View File

@ -1,14 +1,13 @@
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.kqueue
C-STRUCT: kevent
{ "uint" "ident" } ! identifier for this event
{ "short" "filter" } ! filter for event
{ "ushort" "flags" } ! action flags for kqueue
{ "uint" "fflags" } ! filter flag value
{ "int" "data" } ! filter data value
{ "void*" "udata" } ! opaque user data identifier
;
STRUCT: kevent
{ ident uint }
{ filter short }
{ flags ushort }
{ fflags uint }
{ data int }
{ udata void* } ;
FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;

14
basis/unix/linux/linux.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien system ;
USING: alien.syntax alien system classes.struct ;
IN: unix
! Linux.
@ -94,12 +94,12 @@ C-STRUCT: passwd
{ "char*" "pw_shell" } ;
! dirent64
C-STRUCT: dirent
{ "ulonglong" "d_ino" }
{ "longlong" "d_off" }
{ "ushort" "d_reclen" }
{ "uchar" "d_type" }
{ { "char" 256 } "d_name" } ;
STRUCT: dirent
{ d_ino ulonglong }
{ d_off longlong }
{ d_reclen ushort }
{ d_type uchar }
{ d_name char[256] } ;
FUNCTION: int open64 ( char* path, int flags, int prot ) ;
FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;

30
basis/unix/stat/freebsd/32/32.factor
View File

@ -1,30 +0,0 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
C-STRUCT: stat
{ "__dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "fflags_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "timespec" "st_birthtimespec" }
! not sure about the padding here.
{ "__uint32_t" "pad0" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

1
basis/unix/stat/freebsd/32/tags.txt
View File

@ -1 +0,0 @@
unportable

30
basis/unix/stat/freebsd/64/64.factor
View File

@ -1,30 +0,0 @@
USING: kernel alien.syntax math ;
IN: unix.stat
! FreeBSD 8.0-CURRENT
! untested
C-STRUCT: stat
{ "__dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "__dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "fflags_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "timespec" "st_birthtimespec" }
! not sure about the padding here.
{ "__uint32_t" "pad0" }
{ "__uint32_t" "pad1" } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

1
basis/unix/stat/freebsd/64/tags.txt
View File

@ -1 +0,0 @@
unportable

30
basis/unix/stat/freebsd/freebsd.factor
View File

@ -1,7 +1,27 @@
USING: layouts combinators vocabs.loader ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
cell-bits {
{ 32 [ "unix.stat.freebsd.32" require ] }
{ 64 [ "unix.stat.freebsd.64" require ] }
} case
! FreeBSD 8.0-CURRENT
STRUCT: stat
{ st_dev __dev_t }
{ st_ino ino_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev __dev_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_size off_t }
{ st_blocks blkcnt_t }
{ st_blksize blksize_t }
{ st_flags fflags_t }
{ st_gen __uint32_t }
{ st_lspare __int32_t }
{ st_birthtimespec timespec }
{ pad0 __int32_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

37
basis/unix/stat/linux/32/32.factor
View File

@ -1,25 +1,24 @@
USING: kernel alien.syntax math sequences unix
alien.c-types arrays accessors combinators ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! stat64
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ushort" "__pad1" }
{ "__ino_t" "__st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ { "ushort" 2 } "__pad2" }
{ "off64_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt64_t" "st_blocks" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "ulonglong" "st_ino" } ;
STRUCT: stat
{ st_dev dev_t }
{ __pad1 ushort }
{ __st_ino __ino_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev dev_t }
{ __pad2 ushort[2] }
{ st_size off64_t }
{ st_blksize blksize_t }
{ st_blocks blkcnt64_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_ino ulonglong } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;

37
basis/unix/stat/linux/64/64.factor
View File

@ -1,27 +1,24 @@
USING: kernel alien.syntax math sequences unix
alien.c-types arrays accessors combinators ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! Ubuntu 7.10 64-bit
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "nlink_t" "st_nlink" }
{ "mode_t" "st_mode" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "int" "pad0" }
{ "dev_t" "st_rdev" }
{ "off64_t" "st_size" }
{ "blksize_t" "st_blksize" }
{ "blkcnt64_t" "st_blocks" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "long" "__unused0" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
STRUCT: stat
{ st_dev dev_t }
{ st_ino ino_t }
{ st_nlink nlink_t }
{ st_mode mode_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ pad0 int }
{ st_rdev dev_t }
{ st_size off64_t }
{ st_blksize blksize_t }
{ st_blocks blkcnt64_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ __unused0 long[3] } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;

44
basis/unix/stat/macosx/macosx.factor
View File

@ -1,30 +1,30 @@
USING: kernel alien.syntax math unix math.bitwise
alien.c-types alien sequences grouping accessors combinators ;
USING: alien.c-types arrays accessors combinators classes.struct
alien.syntax ;
IN: unix.stat
! Mac OS X ppc
! stat64 structure
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "ino64_t" "st_ino" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "__uint32_t" "st_flags" }
{ "__uint32_t" "st_gen" }
{ "__int32_t" "st_lspare" }
{ "__int64_t" "st_qspare0" }
{ "__int64_t" "st_qspare1" } ;
STRUCT: stat
{ st_dev dev_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_ino ino64_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev dev_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_birthtimespec timespec }
{ st_size off_t }
{ st_blocks blkcnt_t }
{ st_blksize blksize_t }
{ st_flags __uint32_t }
{ st_gen __uint32_t }
{ st_lspare __int32_t }
{ st_qspare0 __int64_t }
{ st_qspare1 __int64_t } ;
FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
FUNCTION: int lstat64 ( char* pathname, stat* buf ) ;

38
basis/unix/stat/netbsd/32/32.factor
View File

@ -1,26 +1,26 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "mode_t" "st_mode" }
{ "ino_t" "st_ino" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "timespec" "st_birthtimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ { "uint32_t" 2 } "st_qspare" } ;
STRUCT: stat
{ st_dev dev_t }
{ st_mode mode_t }
{ st_ino ino_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev dev_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_birthtimespec timespec }
{ st_size off_t }
{ st_blocks blkcnt_t }
{ st_blksize blksize_t }
{ st_flags uint32_t }
{ st_gen uint32_t }
{ st_qspare uint32_t[2] } ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;

38
basis/unix/stat/netbsd/64/64.factor
View File

@ -1,26 +1,26 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! NetBSD 4.0
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "blkcnt_t" "st_blocks" }
{ "blksize_t" "st_blksize" }
{ "uint32_t" "st_flags" }
{ "uint32_t" "st_gen" }
{ "uint32_t" "st_spare0" }
{ "timespec" "st_birthtimespec" } ;
STRUCT: stat
{ st_dev dev_t }
{ st_ino ino_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev dev_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_size off_t }
{ st_blocks blkcnt_t }
{ st_blksize blksize_t }
{ st_flags uint32_t }
{ st_gen uint32_t }
{ st_spare0 uint32_t }
{ st_birthtimespec timespec } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;

42
basis/unix/stat/openbsd/openbsd.factor
View File

@ -1,28 +1,28 @@
USING: kernel alien.syntax math ;
USING: kernel alien.syntax math classes.struct ;
IN: unix.stat
! OpenBSD 4.2
C-STRUCT: stat
{ "dev_t" "st_dev" }
{ "ino_t" "st_ino" }
{ "mode_t" "st_mode" }
{ "nlink_t" "st_nlink" }
{ "uid_t" "st_uid" }
{ "gid_t" "st_gid" }
{ "dev_t" "st_rdev" }
{ "int32_t" "st_lspare0" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "off_t" "st_size" }
{ "int64_t" "st_blocks" }
{ "u_int32_t" "st_blksize" }
{ "u_int32_t" "st_flags" }
{ "u_int32_t" "st_gen" }
{ "int32_t" "st_lspare1" }
{ "timespec" "st_birthtimespec" }
{ { "int64_t" 2 } "st_qspare" } ;
STRUCT: stat
{ st_dev dev_t }
{ st_ino ino_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid gid_t }
{ st_rdev dev_t }
{ st_lspare0 int32_t }
{ st_atimespec timespec }
{ st_mtimespec timespec }
{ st_ctimespec timespec }
{ st_size off_t }
{ st_blocks int64_t }
{ st_blksize u_int32_t }
{ st_flags u_int32_t }
{ st_gen u_int32_t }
{ st_lspare1 int32_t }
{ st_birthtimespec timespec }
{ st_qspare int64_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( char* pathname, stat* buf ) ;

10
basis/unix/stat/stat.factor
View File

@ -1,5 +1,5 @@
USING: kernel system combinators alien.syntax alien.c-types
math io.backend.unix vocabs.loader unix ;
math io.backend.unix vocabs.loader unix classes.struct ;
IN: unix.stat
! File Types
@ -15,8 +15,8 @@ CONSTANT: S_IFLNK OCT: 120000 ! Symbolic link.
CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
C-STRUCT: fsid
{ { "int" 2 } "__val" } ;
STRUCT: fsid
{ __val int[2] } ;
TYPEDEF: fsid __fsid_t
TYPEDEF: fsid fsid_t
@ -30,7 +30,7 @@ TYPEDEF: fsid fsid_t
} case >>
: file-status ( pathname -- stat )
"stat" <c-object> [ [ stat ] unix-system-call drop ] keep ;
\ stat <struct> [ [ stat ] unix-system-call drop ] keep ;
: link-status ( pathname -- stat )
"stat" <c-object> [ [ lstat ] unix-system-call drop ] keep ;
\ stat <struct> [ [ lstat ] unix-system-call drop ] keep ;

48
basis/unix/statfs/freebsd/freebsd.factor
View File

@ -1,34 +1,34 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix.types unix.stat ;
USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */
CONSTANT: MNAMELEN 88 ! size of on/from name bufs
CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number
C-STRUCT: statfs
{ "uint32_t" "f_version" }
{ "uint32_t" "f_type" }
{ "uint64_t" "f_flags" }
{ "uint64_t" "f_bsize" }
{ "uint64_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "int64_t" "f_ffree" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncwrites" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_asyncreads" }
{ { "uint64_t" 10 } "f_spare" }
{ "uint32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "fsid_t" "f_fsid" }
{ { "char" 80 } "f_charspare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntfromname" }
{ { "char" MNAMELEN } "f_mntonname" } ;
STRUCT: statfs
{ f_version uint32_t }
{ f_type uint32_t }
{ f_flags uint64_t }
{ f_bsize uint64_t }
{ f_iosize uint64_t }
{ f_blocks uint64_t }
{ f_bfree uint64_t }
{ f_bavail int64_t }
{ f_files uint64_t }
{ f_ffree int64_t }
{ f_syncwrites uint64_t }
{ f_asyncwrites uint64_t }
{ f_syncreads uint64_t }
{ f_asyncreads uint64_t }
{ f_spare uint64_t[10] }
{ f_namemax uint32_t }
{ f_owner uid_t }
{ f_fsid fsid_t }
{ f_charspare char[80] }
{ f_fstypename { "char" MFSNAMELEN } }
{ f_mntfromname { "char" MNAMELEN } }
{ f_mntonname { "char" MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;

26
basis/unix/statfs/linux/linux.factor
View File

@ -1,19 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix.types unix.stat ;
USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.linux
C-STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" }
{ "__SWORD_TYPE" "f_bsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsid_t" "f_fsid" }
{ "__SWORD_TYPE" "f_namelen" }
{ "__SWORD_TYPE" "f_frsize" }
{ { "__SWORD_TYPE" 5 } "f_spare" } ;
STRUCT: statfs64
{ f_type __SWORD_TYPE }
{ f_bsize __SWORD_TYPE }
{ f_blocks __fsblkcnt64_t }
{ f_bfree __fsblkcnt64_t }
{ f_bavail __fsblkcnt64_t }
{ f_files __fsblkcnt64_t }
{ f_ffree __fsblkcnt64_t }
{ f_fsid __fsid_t }
{ f_namelen __SWORD_TYPE }
{ f_frsize __SWORD_TYPE }
{ f_spare __SWORD_TYPE[5] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;

46
basis/unix/statfs/macosx/macosx.factor
View File

@ -3,7 +3,7 @@
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
unix.types ;
unix.types classes.struct ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
@ -65,9 +65,9 @@ CONSTANT: VFS_CTL_NEWADDR HEX: 00010004
CONSTANT: VFS_CTL_TIMEO HEX: 00010005
CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006
C-STRUCT: vfsquery
{ "uint32_t" "vq_flags" }
{ { "uint32_t" 31 } "vq_spare" } ;
STRUCT: vfsquery
{ vq_flags uint32_t }
{ vq_spare uint32_t[31] } ;
CONSTANT: VQ_NOTRESP HEX: 0001
CONSTANT: VQ_NEEDAUTH HEX: 0002
@ -95,26 +95,26 @@ CONSTANT: MFSNAMELEN 15
CONSTANT: MNAMELEN 90
CONSTANT: MFSTYPENAMELEN 16
C-STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ;
STRUCT: fsid_t
{ val int32_t[2] } ;
C-STRUCT: statfs64
{ "uint32_t" "f_bsize" }
{ "int32_t" "f_iosize" }
{ "uint64_t" "f_blocks" }
{ "uint64_t" "f_bfree" }
{ "uint64_t" "f_bavail" }
{ "uint64_t" "f_files" }
{ "uint64_t" "f_ffree" }
{ "fsid_t" "f_fsid" }
{ "uid_t" "f_owner" }
{ "uint32_t" "f_type" }
{ "uint32_t" "f_flags" }
{ "uint32_t" "f_fssubtype" }
{ { "char" MFSTYPENAMELEN } "f_fstypename" }
{ { "char" MAXPATHLEN } "f_mntonname" }
{ { "char" MAXPATHLEN } "f_mntfromname" }
{ { "uint32_t" 8 } "f_reserved" } ;
STRUCT: statfs64
{ f_bsize uint32_t }
{ f_iosize int32_t }
{ f_blocks uint64_t }
{ f_bfree uint64_t }
{ f_bavail uint64_t }
{ f_files uint64_t }
{ f_ffree uint64_t }
{ f_fsid fsid_t }
{ f_owner uid_t }
{ f_type uint32_t }
{ f_flags uint32_t }
{ f_fssubtype uint32_t }
{ f_fstypename { "char" MFSTYPENAMELEN } }
{ f_mntonname { "char" MAXPATHLEN } }
{ f_mntfromname { "char" MAXPATHLEN } }
{ f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ;

48
basis/unix/statfs/openbsd/openbsd.factor
View File

@ -1,33 +1,33 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax unix.types unix.stat ;
USING: alien.syntax unix.types unix.stat classes.struct ;
IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16
CONSTANT: MNAMELEN 90
C-STRUCT: statfs
{ "u_int32_t" "f_flags" }
{ "u_int32_t" "f_bsize" }
{ "u_int32_t" "f_iosize" }
{ "u_int64_t" "f_blocks" }
{ "u_int64_t" "f_bfree" }
{ "int64_t" "f_bavail" }
{ "u_int64_t" "f_files" }
{ "u_int64_t" "f_ffree" }
{ "int64_t" "f_favail" }
{ "u_int64_t" "f_syncwrites" }
{ "u_int64_t" "f_syncreads" }
{ "u_int64_t" "f_asyncwrites" }
{ "u_int64_t" "f_asyncreads" }
{ "fsid_t" "f_fsid" }
{ "u_int32_t" "f_namemax" }
{ "uid_t" "f_owner" }
{ "u_int32_t" "f_ctime" }
{ { "u_int32_t" 3 } "f_spare" }
{ { "char" MFSNAMELEN } "f_fstypename" }
{ { "char" MNAMELEN } "f_mntonname" }
{ { "char" MNAMELEN } "f_mntfromname" }
{ { "char" 160 } "mount_info" } ;
STRUCT: statfs
{ f_flags u_int32_t }
{ f_bsize u_int32_t }
{ f_iosize u_int32_t }
{ f_blocks u_int64_t }
{ f_bfree u_int64_t }
{ f_bavail int64_t }
{ f_files u_int64_t }
{ f_ffree u_int64_t }
{ f_favail int64_t }
{ f_syncwrites u_int64_t }
{ f_syncreads u_int64_t }
{ f_asyncwrites u_int64_t }
{ f_asyncreads u_int64_t }
{ f_fsid fsid_t }
{ f_namemax u_int32_t }
{ f_owner uid_t }
{ f_ctime u_int32_t }
{ f_spare u_int32_t[3] }
{ f_fstypename { "char" MFSNAMELEN } }
{ f_mntonname { "char" MNAMELEN } }
{ f_mntfromname { "char" MNAMELEN } }
{ mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ;

26
basis/unix/statvfs/freebsd/freebsd.factor
View File

@ -1,20 +1,20 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.statvfs.freebsd
C-STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_files" }
{ "ulong" "f_bsize" }
{ "ulong" "f_flag" }
{ "ulong" "f_frsize" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" } ;
STRUCT: statvfs
{ f_bavail fsblkcnt_t }
{ f_bfree fsblkcnt_t }
{ f_blocks fsblkcnt_t }
{ f_favail fsfilcnt_t }
{ f_ffree fsfilcnt_t }
{ f_files fsfilcnt_t }
{ f_bsize ulong }
{ f_flag ulong }
{ f_frsize ulong }
{ f_fsid ulong }
{ f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system

28
basis/unix/statvfs/linux/linux.factor
View File

@ -1,21 +1,21 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.statvfs.linux
C-STRUCT: statvfs64
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "__fsblkcnt64_t" "f_blocks" }
{ "__fsblkcnt64_t" "f_bfree" }
{ "__fsblkcnt64_t" "f_bavail" }
{ "__fsfilcnt64_t" "f_files" }
{ "__fsfilcnt64_t" "f_ffree" }
{ "__fsfilcnt64_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" }
{ { "int" 6 } "__f_spare" } ;
STRUCT: statvfs64
{ f_bsize ulong }
{ f_frsize ulong }
{ f_blocks __fsblkcnt64_t }
{ f_bfree __fsblkcnt64_t }
{ f_bavail __fsblkcnt64_t }
{ f_files __fsfilcnt64_t }
{ f_ffree __fsfilcnt64_t }
{ f_favail __fsfilcnt64_t }
{ f_fsid ulong }
{ f_flag ulong }
{ f_namemax ulong }
{ __f_spare int[6] } ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ;

26
basis/unix/statvfs/macosx/macosx.factor
View File

@ -1,20 +1,20 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.statvfs.macosx
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
STRUCT: statvfs
{ f_bsize ulong }
{ f_frsize ulong }
{ f_blocks fsblkcnt_t }
{ f_bfree fsblkcnt_t }
{ f_bavail fsblkcnt_t }
{ f_files fsfilcnt_t }
{ f_ffree fsfilcnt_t }
{ f_favail fsfilcnt_t }
{ f_fsid ulong }
{ f_flag ulong }
{ f_namemax ulong } ;
! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system

52
basis/unix/statvfs/netbsd/netbsd.factor
View File

@ -1,35 +1,35 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32
CONSTANT: _VFS_MNAMELEN 1024
C-STRUCT: statvfs
{ "ulong" "f_flag" }
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "ulong" "f_iosize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsblkcnt_t" "f_bresvd" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "fsfilcnt_t" "f_fresvd" }
{ "uint64_t" "f_syncreads" }
{ "uint64_t" "f_syncwrites" }
{ "uint64_t" "f_asyncreads" }
{ "uint64_t" "f_asyncwrites" }
{ "fsid_t" "f_fsidx" }
{ "ulong" "f_fsid" }
{ "ulong" "f_namemax" }
{ "uid_t" "f_owner" }
{ { "uint32_t" 4 } "f_spare" }
{ { "char" _VFS_NAMELEN } "f_fstypename" }
{ { "char" _VFS_MNAMELEN } "f_mntonname" }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ;
STRUCT: statvfs
{ f_flag ulong }
{ f_bsize ulong }
{ f_frsize ulong }
{ f_iosize ulong }
{ f_blocks fsblkcnt_t }
{ f_bfree fsblkcnt_t }
{ f_bavail fsblkcnt_t }
{ f_bresvd fsblkcnt_t }
{ f_files fsfilcnt_t }
{ f_ffree fsfilcnt_t }
{ f_favail fsfilcnt_t }
{ f_fresvd fsfilcnt_t }
{ f_syncreads uint64_t }
{ f_syncwrites uint64_t }
{ f_asyncreads uint64_t }
{ f_asyncwrites uint64_t }
{ f_fsidx fsid_t }
{ f_fsid ulong }
{ f_namemax ulong }
{ f_owner uid_t }
{ f_spare uint32_t[4] }
{ f_fstypename { "char" _VFS_NAMELEN } }
{ f_mntonname { "char" _VFS_MNAMELEN } }
{ f_mntfromname { "char" _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ;

26
basis/unix/statvfs/openbsd/openbsd.factor
View File

@ -1,20 +1,20 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ;
USING: alien.syntax classes.struct ;
IN: unix.statvfs.openbsd
C-STRUCT: statvfs
{ "ulong" "f_bsize" }
{ "ulong" "f_frsize" }
{ "fsblkcnt_t" "f_blocks" }
{ "fsblkcnt_t" "f_bfree" }
{ "fsblkcnt_t" "f_bavail" }
{ "fsfilcnt_t" "f_files" }
{ "fsfilcnt_t" "f_ffree" }
{ "fsfilcnt_t" "f_favail" }
{ "ulong" "f_fsid" }
{ "ulong" "f_flag" }
{ "ulong" "f_namemax" } ;
STRUCT: statvfs
{ f_bsize ulong }
{ f_frsize ulong }
{ f_blocks fsblkcnt_t }
{ f_bfree fsblkcnt_t }
{ f_bavail fsblkcnt_t }
{ f_files fsfilcnt_t }
{ f_ffree fsfilcnt_t }
{ f_favail fsfilcnt_t }
{ f_fsid ulong }
{ f_flag ulong }
{ f_namemax ulong } ;
CONSTANT: ST_RDONLY 1
CONSTANT: ST_NOSUID 2

51
basis/unix/time/time.factor
View File

@ -1,40 +1,41 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel alien.syntax alien.c-types math unix.types ;
USING: kernel alien.syntax alien.c-types math unix.types
classes.struct accessors ;
IN: unix.time
C-STRUCT: timeval
{ "long" "sec" }
{ "long" "usec" } ;
STRUCT: timeval
{ sec long }
{ usec long } ;
C-STRUCT: timespec
{ "time_t" "sec" }
{ "long" "nsec" } ;
STRUCT: timespec
{ sec time_t }
{ nsec long } ;
: make-timeval ( us -- timeval )
1000000 /mod
"timeval" <c-object>
[ set-timeval-usec ] keep
[ set-timeval-sec ] keep ;
timeval <struct>
swap >>usec
swap >>sec ;
: make-timespec ( us -- timespec )
1000000 /mod 1000 *
"timespec" <c-object>
[ set-timespec-nsec ] keep
[ set-timespec-sec ] keep ;
timespec <struct>
swap >>nsec
swap >>sec ;
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "int" "min" } ! Minutes: 0-59
{ "int" "hour" } ! Hours since midnight: 0-23
{ "int" "mday" } ! Day of the month: 1-31
{ "int" "mon" } ! Months *since* january: 0-11
{ "int" "year" } ! Years since 1900
{ "int" "wday" } ! Days since Sunday (0-6)
{ "int" "yday" } ! Days since Jan. 1: 0-365
{ "int" "isdst" } ! +1 Daylight Savings Time, 0 No DST,
{ "long" "gmtoff" } ! Seconds: 0-59 (K&R says 0-61?)
{ "char*" "zone" } ;
STRUCT: tm
{ sec int }
{ min int }
{ hour int }
{ mday int }
{ mon int }
{ year int }
{ wday int }
{ yday int }
{ isdst int }
{ gmtoff long }
{ zone char* } ;
FUNCTION: time_t time ( time_t* t ) ;
FUNCTION: tm* localtime ( time_t* clock ) ;

47
basis/x11/clipboard/clipboard.factor
View File

@ -1,9 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
kernel math namespaces sequences io.encodings.string
io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
specialized-arrays.int accessors ;
USING: accessors alien.c-types alien.strings classes.struct
io.encodings.utf8 kernel namespaces sequences
specialized-arrays.int x11 x11.constants x11.xlib ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
@ -34,20 +33,15 @@ TUPLE: x-clipboard atom contents ;
[ XGetWindowProperty drop ] keep snarf-property ;
: selection-from-event ( event window -- string )
swap XSelectionEvent-property zero? [
drop f
] [
selection-property 1 window-property
] if ;
swap property>> 0 =
[ drop f ] [ selection-property 1 window-property ] if ;
: own-selection ( prop win -- )
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
XSelectionRequestEvent-property
[ dpy get ] dip [ requestor>> ] [ property>> ] bi
"TARGETS" x-atom 32 PropModeReplace
{
"UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
@ -55,28 +49,27 @@ TUPLE: x-clipboard atom contents ;
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ "TIMESTAMP" x-atom 32 PropModeReplace ] dip
XSelectionRequestEvent-time <int>
[ dpy get ] dip
[ requestor>> ]
[ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
[ time>> <int> ] tri
1 XChangeProperty drop ;
: send-notify ( evt prop -- )
"XSelectionEvent" <c-object>
SelectionNotify over set-XSelectionEvent-type
[ set-XSelectionEvent-property ] keep
over XSelectionRequestEvent-display over set-XSelectionEvent-display
over XSelectionRequestEvent-requestor over set-XSelectionEvent-requestor
over XSelectionRequestEvent-selection over set-XSelectionEvent-selection
over XSelectionRequestEvent-target over set-XSelectionEvent-target
over XSelectionRequestEvent-time over set-XSelectionEvent-time
[ dpy get swap XSelectionRequestEvent-requestor 0 0 ] dip
XSelectionEvent <struct>
SelectionNotify >>type
swap >>property
over display>> >>display
over requestor>> >>requestor
over selection>> >>selection
over target>> >>target
over time>> >>time
[ [ dpy get ] dip requestor>> 0 0 ] dip
XSendEvent drop
flush-dpy ;
: send-notify-success ( evt -- )
dup XSelectionRequestEvent-property send-notify ;
dup property>> send-notify ;
: send-notify-failure ( evt -- )
0 send-notify ;

56
basis/x11/events/events.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays hashtables io kernel math
math.order namespaces prettyprint sequences strings combinators
x11 x11.xlib ;
USING: accessors arrays classes.struct combinators kernel
math.order namespaces x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
@ -36,14 +35,14 @@ GENERIC: selection-request-event ( event window -- )
GENERIC: client-event ( event window -- )
: next-event ( -- event )
dpy get "XEvent" <c-object> [ XNextEvent drop ] keep ;
dpy get XEvent <struct> [ XNextEvent drop ] keep ;
: mask-event ( mask -- event )
[ dpy get ] dip "XEvent" <c-object> [ XMaskEvent drop ] keep ;
[ dpy get ] dip XEvent <struct> [ XMaskEvent drop ] keep ;
: events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
: wheel? ( event -- ? ) XButtonEvent-button 4 7 between? ;
: wheel? ( event -- ? ) button>> 4 7 between? ;
: button-down-event$ ( event window -- )
over wheel? [ wheel-event ] [ button-down-event ] if ;
@ -52,34 +51,31 @@ GENERIC: client-event ( event window -- )
over wheel? [ 2drop ] [ button-up-event ] if ;
: handle-event ( event window -- )
over XAnyEvent-type {
{ Expose [ expose-event ] }
{ ConfigureNotify [ configure-event ] }
{ ButtonPress [ button-down-event$ ] }
{ ButtonRelease [ button-up-event$ ] }
{ EnterNotify [ enter-event ] }
{ LeaveNotify [ leave-event ] }
{ MotionNotify [ motion-event ] }
{ KeyPress [ key-down-event ] }
{ KeyRelease [ key-up-event ] }
{ FocusIn [ focus-in-event ] }
{ FocusOut [ focus-out-event ] }
{ SelectionNotify [ selection-notify-event ] }
{ SelectionRequest [ selection-request-event ] }
{ ClientMessage [ client-event ] }
over type>> {
{ Expose [ XExposeEvent>> expose-event ] }
{ ConfigureNotify [ XConfigureEvent>> configure-event ] }
{ ButtonPress [ XButtonEvent>> button-down-event$ ] }
{ ButtonRelease [ XButtonEvent>> button-up-event$ ] }
{ EnterNotify [ XCrossingEvent>> enter-event ] }
{ LeaveNotify [ XCrossingEvent>> leave-event ] }
{ MotionNotify [ XMotionEvent>> motion-event ] }
{ KeyPress [ XKeyEvent>> key-down-event ] }
{ KeyRelease [ XKeyEvent>> key-up-event ] }
{ FocusIn [ XFocusChangeEvent>> focus-in-event ] }
{ FocusOut [ XFocusChangeEvent>> focus-out-event ] }
{ SelectionNotify [ XSelectionEvent>> selection-notify-event ] }
{ SelectionRequest [ XSelectionRequestEvent>> selection-request-event ] }
{ ClientMessage [ XClientMessageEvent>> client-event ] }
[ 3drop ]
} case ;
: configured-loc ( event -- dim )
[ XConfigureEvent-x ] [ XConfigureEvent-y ] bi 2array ;
: event-loc ( event -- loc )
[ x>> ] [ y>> ] bi 2array ;
: configured-dim ( event -- dim )
[ XConfigureEvent-width ] [ XConfigureEvent-height ] bi 2array ;
: mouse-event-loc ( event -- loc )
[ XButtonEvent-x ] [ XButtonEvent-y ] bi 2array ;
: event-dim ( event -- dim )
[ width>> ] [ height>> ] bi 2array ;
: close-box? ( event -- ? )
[ XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom = ]
[ XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom = ]
[ message_type>> "WM_PROTOCOLS" x-atom = ]
[ data0>> "WM_DELETE_WINDOW" x-atom = ]
bi and ;

26
basis/x11/windows/windows.factor
View File

@ -1,15 +1,15 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
arrays fry ;
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
fry classes.struct ;
IN: x11.windows
: create-window-mask ( -- n )
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
[ dpy get root get ] dip XVisualInfo-visual AllocNone
[ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
: event-mask ( -- n )
@ -28,15 +28,15 @@ IN: x11.windows
} flags ;
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
0 over set-XSetWindowAttributes-background_pixel
0 over set-XSetWindowAttributes-border_pixel
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;
XSetWindowAttributes <struct>
0 >>background_pixel
0 >>border_pixel
event-mask >>event_mask
swap create-colormap >>colormap ;
: set-size-hints ( window -- )
"XSizeHints" <c-object>
USPosition over set-XSizeHints-flags
XSizeHints <struct>
USPosition >>flags
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
@ -47,8 +47,8 @@ IN: x11.windows
: create-window ( loc dim visinfo -- window )
pick [
[ [ [ dpy get root get ] dip >xy ] dip { 1 1 } vmax >xy 0 ] dip
[ XVisualInfo-depth InputOutput ] keep
[ XVisualInfo-visual create-window-mask ] keep
[ depth>> InputOutput ] keep
[ visual>> create-window-mask ] keep
window-attributes XCreateWindow
dup
] dip auto-position ;

1082
basis/x11/xlib/xlib.factor
View File

File diff suppressed because it is too large Load Diff

1
core/math/math-docs.factor
View File

@ -420,6 +420,7 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
"Advanced topics:"
{ $subsection "math.bitwise" }
{ $subsection "math.bits" }
{ $see-also "booleans" } ;

4
extra/benchmark/struct-arrays/struct-arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences
struct-arrays hints io ;
struct-arrays io ;
IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ;
@ -45,8 +45,6 @@ STRUCT: point { x float } { y float } { z float } ;
: struct-array-benchmark ( len -- )
make-points [ normalize-points ] [ max-points ] bi print-point ;
HINTS: struct-array-benchmark fixnum ;
: main ( -- ) 5000000 struct-array-benchmark ;
MAIN: main

2
extra/benchmark/terrain-generation/terrain-generation.factor
View File

@ -4,7 +4,7 @@ IN: benchmark.terrain-generation
: terrain-generation-benchmark ( -- )
"Generating terrain segment..." write flush yield
<terrain> { 0.0 0.0 } terrain-segment drop
<terrain> { 0 0 } terrain-segment drop
"done" print ;
MAIN: terrain-generation-benchmark

6
extra/mongodb/driver/driver.factor
View File

@ -1,7 +1,8 @@
USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables
io io.pools io.sockets kernel linked-assocs math mongodb.connection
mongodb.msg parser prettyprint sequences sets splitting strings
mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
sequences sets splitting strings
tools.continuations uuid memoize locals ;
IN: mongodb.driver
@ -32,6 +33,9 @@ CONSTANT: PARTIAL? "partial?"
ERROR: mdb-error msg ;
M: mdb-error pprint* ( obj -- )
msg>> text ;
: >pwd-digest ( user password -- digest )
"mongo" swap 3array ":" join md5-checksum ;