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

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

db4
Joe Groff 2009-08-30 19:05:43 -05:00
parent 0df9884ee5 bd629c1262
commit c9e83ba3c3
66 changed files with 885 additions and 695 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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 frame-required? on
stack-frame [ max-stack-frame ] change ; stack-frame [ max-stack-frame ] change ;
M: ##alien-invoke compute-stack-frame* UNION: stack-frame-insn
stack-frame>> request-stack-frame ; ##alien-invoke
##alien-indirect
##alien-callback ;
M: ##alien-indirect compute-stack-frame* M: stack-frame-insn compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##alien-callback compute-stack-frame*
stack-frame>> request-stack-frame ; stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame* M: ##call compute-stack-frame*
@ -40,6 +39,8 @@ M: insn compute-stack-frame*
] when ; ] when ;
\ _spill t frame-required? set-word-prop \ _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 -- ) : compute-stack-frame ( insns -- )
frame-required? off 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: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ; M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast 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 temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float 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 : ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline : ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-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 : ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline : ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; 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 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline : ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
: ^^box-displaced-alien ( base displacement base-class -- dst ) : ^^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-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ; : ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline : ^^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: ##max-float < ##binary ;
INSN: ##sqrt < ##unary ; INSN: ##sqrt < ##unary ;
! libc intrinsics
INSN: ##unary-float-function < ##unary func ;
INSN: ##binary-float-function < ##binary func ;
! Float/integer conversion ! Float/integer conversion
INSN: ##float>integer < ##unary ; INSN: ##float>integer < ##unary ;
INSN: ##integer>float < ##unary ; INSN: ##integer>float < ##unary ;
@ -122,7 +126,7 @@ INSN: ##unbox-float < ##unary ;
INSN: ##unbox-any-c-ptr < ##unary/temp ; INSN: ##unbox-any-c-ptr < ##unary/temp ;
INSN: ##box-float < ##unary/temp ; INSN: ##box-float < ##unary/temp ;
INSN: ##box-alien < ##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-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ; : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
@ -252,6 +256,11 @@ UNION: vreg-insn
_compare-imm-branch _compare-imm-branch
_dispatch ; _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 ! Instructions that kill all live vregs
UNION: kill-vreg-insn UNION: kill-vreg-insn
##call ##call
@ -270,6 +279,8 @@ UNION: output-float-insn
##min-float ##min-float
##max-float ##max-float
##sqrt ##sqrt
##unary-float-function
##binary-float-function
##integer>float ##integer>float
##unbox-float ##unbox-float
##alien-float ##alien-float
@ -284,6 +295,8 @@ UNION: input-float-insn
##min-float ##min-float
##max-float ##max-float
##sqrt ##sqrt
##unary-float-function
##binary-float-function
##float>integer ##float>integer
##box-float ##box-float
##set-alien-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 ( -- ) : emit-fsqrt ( -- )
ds-pop ^^sqrt ds-push ; 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 ;

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

@ -108,6 +108,27 @@ IN: compiler.cfg.intrinsics
math.floats.private:float-max math.floats.private:float-max
} enable-intrinsics ; } enable-intrinsics ;
: enable-float-functions ( -- )
! Everything except for fsqrt
{
math.libm:facos
math.libm:fasin
math.libm:fatan
math.libm:fatan2
math.libm:fcos
math.libm:fsin
math.libm:ftan
math.libm:fcosh
math.libm:fsinh
math.libm:ftanh
math.libm:fexp
math.libm:flog
math.libm:fpow
math.libm:facosh
math.libm:fasinh
math.libm:fatanh
} enable-intrinsics ;
: enable-min/max ( -- ) : enable-min/max ( -- )
{ {
math.integers.private:fixnum-min math.integers.private:fixnum-min
@ -157,6 +178,22 @@ IN: compiler.cfg.intrinsics
{ \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] } { \ math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
{ \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] } { \ math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
{ \ math.libm:fsqrt [ drop emit-fsqrt ] } { \ math.libm:fsqrt [ drop emit-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 ] }
{ \ slots.private:slot [ emit-slot ] } { \ slots.private:slot [ emit-slot ] }
{ \ slots.private:set-slot [ emit-set-slot ] } { \ slots.private:set-slot [ emit-set-slot ] }
{ \ strings.private:string-nth [ drop emit-string-nth ] } { \ strings.private:string-nth [ drop emit-string-nth ] }

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

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math 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.live-intervals
compiler.cfg.linear-scan.allocation.spilling compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.splitting
@ -34,22 +34,48 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ] [ drop assign-blocked-register ]
} cond ; } cond ;
: handle-interval ( live-interval -- ) : handle-sync-point ( n -- )
[ [ active-intervals get values ] dip
start>> [ '[ [ _ spill ] each ] each ]
[ drop [ delete-all ] each ]
2bi ;
:: handle-progress ( n sync? -- )
n {
[ progress set ] [ progress set ]
[ deactivate-intervals ] [ deactivate-intervals ]
[ activate-intervals ] tri [ sync? [ handle-sync-point ] [ drop ] if ]
] [ assign-register ] bi ; [ 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) ( -- ) : (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 ( -- ) : finish-allocation ( -- )
active-intervals inactive-intervals active-intervals inactive-intervals
[ get values [ handled-intervals get push-all ] each ] bi@ ; [ 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-allocator
init-unhandled init-unhandled
(allocate-registers) (allocate-registers)

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

@ -29,7 +29,7 @@ ERROR: bad-live-ranges interval ;
2bi ; 2bi ;
: assign-spill ( live-interval -- ) : 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 ) : spill-before ( before -- before/f )
! If the interval does not have any usages before the spill location, ! If the interval does not have any usages before the spill location,
@ -46,7 +46,7 @@ ERROR: bad-live-ranges interval ;
] if ; ] if ;
: assign-reload ( live-interval -- ) : 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 ) : spill-after ( after -- after/f )
! If the interval has no more usages after the spill location, ! 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 rep-size cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; [ 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 ! Mapping from vregs to spill slots
SYMBOL: spill-slots SYMBOL: spill-slots
: assign-spill-slot ( vreg -- n ) : vreg-spill-slot ( vreg -- n )
spill-slots get [ rep-of next-spill-slot ] cache ; spill-slots get [ rep-of next-spill-slot ] cache ;
: init-allocator ( registers -- ) : init-allocator ( registers -- )
registers set registers set
<min-heap> unhandled-intervals 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 active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set [ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set V{ } clone handled-intervals set
@ -136,9 +140,10 @@ SYMBOL: spill-slots
H{ } clone spill-slots set H{ } clone spill-slots set
-1 progress set ; -1 progress set ;
: init-unhandled ( live-intervals -- ) : init-unhandled ( live-intervals sync-points -- )
[ [ start>> ] keep ] { } map>assoc [ [ [ start>> ] keep ] { } map>assoc unhandled-intervals get heap-push-all ]
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 ! A utility used by register-status and spill-status words
: free-positions ( new -- assoc ) : 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 -- ) : remove-pending ( live-interval -- )
vreg>> pending-interval-assoc get delete-at ; 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 ! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals SYMBOL: unhandled-intervals
@ -96,8 +110,6 @@ SYMBOL: register-live-outs
GENERIC: assign-registers-in-insn ( insn -- ) GENERIC: assign-registers-in-insn ( insn -- )
: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ] RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
M: vreg-insn assign-registers-in-insn M: vreg-insn assign-registers-in-insn
@ -123,7 +135,7 @@ M: vreg-insn assign-registers-in-insn
[ [
[ [
2dup spill-on-gc? 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 ] assoc-each
] { } make ; ] { } make ;
@ -137,23 +149,13 @@ M: ##gc assign-registers-in-insn
M: insn assign-registers-in-insn drop ; 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 -- ) : begin-block ( bb -- )
dup basic-block set dup basic-block set
dup block-from activate-new-intervals dup block-from activate-new-intervals
[ live-in compute-live-values ] keep [ live-in vregs>regs ] keep register-live-ins get set-at ;
register-live-ins get set-at ;
: end-block ( bb -- ) : end-block ( bb -- )
[ live-out compute-live-values ] keep [ live-out vregs>regs ] keep register-live-outs get set-at ;
register-live-outs get set-at ;
ERROR: bad-vreg vreg ; 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 [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
live-intervals set live-intervals set
f
] dip ] dip
allocate-registers drop ; 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? covers?
] if ; ] if ;
ERROR: dead-value-error vreg ; : add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: shorten-range ( n live-interval -- ) : shorten-range ( n live-interval -- )
dup ranges>> empty? 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 -- ) : extend-range ( from to live-range -- )
ranges>> last ranges>> last
@ -42,9 +43,6 @@ ERROR: dead-value-error vreg ;
[ min ] change-from [ min ] change-from
drop ; drop ;
: add-new-range ( from to live-interval -- )
[ <live-range> ] dip ranges>> push ;
: extend-range? ( to live-interval -- ? ) : extend-range? ( to live-interval -- ? )
ranges>> [ drop f ] [ last from>> >= ] if-empty ; ranges>> [ drop f ] [ last from>> >= ] if-empty ;
@ -52,8 +50,18 @@ ERROR: dead-value-error vreg ;
2dup extend-range? 2dup extend-range?
[ extend-range ] [ add-new-range ] if ; [ extend-range ] [ add-new-range ] if ;
: add-use ( n live-interval -- ) GENERIC: operands-in-registers? ( insn -- ? )
uses>> push ;
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> ( vreg -- live-interval )
\ live-interval new \ live-interval new
@ -68,51 +76,68 @@ ERROR: dead-value-error vreg ;
M: live-interval hashcode* M: live-interval hashcode*
nip [ start>> ] [ end>> 1000 * ] bi + ; nip [ start>> ] [ end>> 1000 * ] bi + ;
M: live-interval clone
call-next-method [ clone ] change-uses ;
! Mapping from vreg to live-interval ! Mapping from vreg to live-interval
SYMBOL: live-intervals SYMBOL: live-intervals
: live-interval ( vreg live-intervals -- live-interval ) : live-interval ( vreg -- live-interval )
[ <live-interval> ] cache ; live-intervals get [ <live-interval> ] cache ;
GENERIC: compute-live-intervals* ( insn -- ) GENERIC: compute-live-intervals* ( insn -- )
M: insn compute-live-intervals* drop ; M: insn compute-live-intervals* drop ;
: handle-output ( n vreg live-intervals -- ) : handle-output ( insn vreg -- )
live-interval 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 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 live-interval
[ dupd add-range ] [ add-use ] 2bi ; [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
M: vreg-insn compute-live-intervals* M: vreg-insn compute-live-intervals*
dup insn#>> [ dup defs-vreg [ handle-output ] with when* ]
live-intervals get [ dup uses-vregs [ handle-input ] with each ]
[ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ] [ dup temp-vregs [ handle-temp ] with each ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] tri ;
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
: handle-live-out ( bb -- ) : handle-live-out ( bb -- )
live-out keys [ block-from ] [ block-to ] [ live-out keys ] tri
basic-block get [ block-from ] [ block-to ] bi [ live-interval add-range ] with with each ;
live-intervals get '[
[ _ _ ] dip _ live-interval add-range ! A location where all registers have to be spilled
] each ; 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 -- ) : compute-live-intervals-step ( bb -- )
[ basic-block set ] [ basic-block set ]
[ handle-live-out ] [ 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 -- ) : compute-start/end ( live-interval -- )
dup ranges>> [ first from>> ] [ last to>> ] bi dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ; [ >>start ] [ >>end ] bi* drop ;
@ -122,10 +147,10 @@ ERROR: bad-live-interval live-interval ;
: check-start ( live-interval -- ) : check-start ( live-interval -- )
dup start>> -1 = [ bad-live-interval ] [ drop ] if ; 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 ! Since live intervals are computed in a backward order, we have
! to reverse some sequences, and compute the start and end. ! to reverse some sequences, and compute the start and end.
[ values dup [
{ {
[ ranges>> reverse-here ] [ ranges>> reverse-here ]
[ uses>> reverse-here ] [ uses>> reverse-here ]
@ -134,12 +159,11 @@ ERROR: bad-live-interval live-interval ;
} cleave } cleave
] each ; ] each ;
: compute-live-intervals ( cfg -- live-intervals ) : compute-live-intervals ( cfg -- live-intervals sync-points )
H{ } clone [ init-live-intervals
live-intervals set linearization-order <reversed> [ compute-live-intervals-step ] each
linearization-order <reversed> live-intervals get finish-live-intervals
[ compute-live-intervals-step ] each sync-points get ;
] keep values dup finish-live-intervals ;
: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 ) : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ; [ [ 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 ; TEMP-QUOT change-temp drop ;
M: ##box-displaced-alien rename-insn-temps 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 M: ##compare rename-insn-temps
TEMP-QUOT change-temp drop ; 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: ##set-slot temp-vreg-reps drop { int-rep } ;
M: ##string-nth 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: ##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 temp-vreg-reps drop { int-rep } ;
M: ##compare-imm temp-vreg-reps drop { int-rep } ; M: ##compare-imm temp-vreg-reps drop { int-rep } ;
M: ##compare-float 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: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ; TUPLE: constant-expr < expr value ;
TUPLE: reference-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 ; TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
: <constant> ( constant -- expr ) : <constant> ( constant -- expr )
@ -94,6 +96,19 @@ M: ##box-displaced-alien >expr
[ base-class>> ] [ base-class>> ]
} cleave box-displaced-alien-expr boa ; } 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 ; M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- ) : 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: ##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: ##integer>float generate-insn dst/src %integer>float ;
M: ##float>integer generate-insn dst/src %float>integer ; 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-alien generate-insn dst/src/temp %box-alien ;
M: ##box-displaced-alien generate-insn 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-1 generate-insn dst/src %alien-unsigned-1 ;
M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ; 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 namespaces.private slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make alien.c-types combinators.short-circuit combinators vectors grouping make alien.c-types combinators.short-circuit
math.order ; math.order math.libm math.parser ;
QUALIFIED: namespaces.private QUALIFIED: namespaces.private
IN: compiler.tests.codegen IN: compiler.tests.codegen
@ -407,4 +407,9 @@ cell 4 = [
: missing-gc-check-1 ( a -- b ) { fixnum } declare <alien> ; : 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 ( -- ) 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>> underlying>>
] unit-test ] 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 B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-call
] must-fail ] 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: %min-float cpu ( dst src1 src2 -- )
HOOK: %max-float cpu ( dst src1 src2 -- ) HOOK: %max-float cpu ( dst src1 src2 -- )
HOOK: %sqrt cpu ( dst src -- ) 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: %integer>float cpu ( dst src -- )
HOOK: %float>integer 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: %unbox-any-c-ptr cpu ( dst src temp -- )
HOOK: %box-float cpu ( dst src temp -- ) HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien 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-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 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 "f" resolve-label
] with-scope ; ] with-scope ;
M:: ppc %box-displaced-alien ( dst displacement base temp -- ) M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
[ [
"end" define-label "end" define-label
"ok" define-label "ok" define-label
@ -343,7 +343,12 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
dst base MR dst base MR
0 displacement 0 CMPI 0 displacement 0 CMPI
"end" get BEQ "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 ! If base is already a displaced alien, unpack it
base' base MR
displacement' displacement MR
0 base \ f tag-number CMPI 0 base \ f tag-number CMPI
"ok" get BEQ "ok" get BEQ
temp base header-offset LWZ temp base header-offset LWZ
@ -351,11 +356,17 @@ M:: ppc %box-displaced-alien ( dst displacement base temp -- )
"ok" get BNE "ok" get BNE
! displacement += base.displacement ! displacement += base.displacement
temp base 3 alien@ LWZ temp base 3 alien@ LWZ
displacement displacement temp ADD displacement' displacement temp ADD
! base = base.base ! base = base.base
base base 1 alien@ LWZ base' base 1 alien@ LWZ
"ok" resolve-label "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 "end" resolve-label
] with-scope ; ] 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 former top of data stack to return registers
unbox-return ; 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 ! The result of reading 4 bytes from memory is a fixnum on
! x86-64. ! x86-64.
enable-alien-4-intrinsics enable-alien-4-intrinsics
@ -204,6 +221,9 @@ enable-alien-4-intrinsics
! SSE2 is always available on x86-64. ! SSE2 is always available on x86-64.
enable-sse2 enable-sse2
! Enable fast calling of libc math functions
enable-float-functions
USE: vocabs.loader 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 "end" resolve-label
] with-scope ; ] with-scope ;
M:: x86 %box-displaced-alien ( dst displacement base temp -- ) M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
[ [
"end" define-label "end" define-label
"ok" define-label "ok" define-label
@ -286,17 +286,23 @@ M:: x86 %box-displaced-alien ( dst displacement base temp -- )
dst base MOV dst base MOV
displacement 0 CMP displacement 0 CMP
"end" get JE "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 ! If base is already a displaced alien, unpack it
base' base MOV
displacement' displacement MOV
base \ f tag-number CMP base \ f tag-number CMP
"ok" get JE "ok" get JE
base header-offset [+] alien type-number tag-fixnum CMP base header-offset [+] alien type-number tag-fixnum CMP
"ok" get JNE "ok" get JNE
! displacement += base.displacement ! displacement += base.displacement
displacement base 3 alien@ ADD displacement' base 3 alien@ ADD
! base = base.base ! base = base.base
base base 1 alien@ MOV base' base 1 alien@ MOV
"ok" resolve-label "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 "end" resolve-label
] with-scope ; ] with-scope ;

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

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

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 ) M: bsd stat>file-info ( stat -- file-info )
[ call-next-method ] keep [ call-next-method ] keep
{ {
[ stat-st_flags >>flags ] [ st_flags>> >>flags ]
[ stat-st_gen >>gen ] [ st_gen>> >>gen ]
[ [ st_birthtimespec>> timespec>unix-time >>birth-time ]
stat-st_birthtimespec timespec>unix-time
>>birth-time
]
} cleave ; } 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 io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types 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 IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info 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 new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array ) 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 ) M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{ {
[ statfs-f_version >>version ] [ f_version>> >>version ]
[ statfs-f_type >>type ] [ f_type>> >>type ]
[ statfs-f_flags >>flags ] [ f_flags>> >>flags ]
[ statfs-f_bsize >>block-size ] [ f_bsize>> >>block-size ]
[ statfs-f_iosize >>io-size ] [ f_iosize>> >>io-size ]
[ statfs-f_blocks >>blocks ] [ f_blocks>> >>blocks ]
[ statfs-f_bfree >>blocks-free ] [ f_bfree>> >>blocks-free ]
[ statfs-f_bavail >>blocks-available ] [ f_bavail>> >>blocks-available ]
[ statfs-f_files >>files ] [ f_files>> >>files ]
[ statfs-f_ffree >>files-free ] [ f_ffree>> >>files-free ]
[ statfs-f_syncwrites >>syncwrites ] [ f_syncwrites>> >>syncwrites ]
[ statfs-f_asyncwrites >>asyncwrites ] [ f_asyncwrites>> >>asyncwrites ]
[ statfs-f_syncreads >>syncreads ] [ f_syncreads>> >>syncreads ]
[ statfs-f_asyncreads >>asyncreads ] [ f_asyncreads>> >>asyncreads ]
[ statfs-f_namemax >>name-max ] [ f_namemax>> >>name-max ]
[ statfs-f_owner >>owner ] [ f_owner>> >>owner ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ] [ f_fsid>> >>id ]
[ statfs-f_fstypename utf8 alien>string >>type ] [ f_fstypename>> utf8 alien>string >>type ]
[ statfs-f_mntfromname utf8 alien>string >>device-name ] [ f_mntfromname>> utf8 alien>string >>device-name ]
[ statfs-f_mntonname utf8 alien>string >>mount-point ] [ f_mntonname>> utf8 alien>string >>mount-point ]
} cleave ; } cleave ;
M: freebsd file-system-statvfs ( path -- byte-array ) 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 ) M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{ {
[ statvfs-f_favail >>files-available ] [ f_favail>> >>files-available ]
[ statvfs-f_frsize >>preferred-block-size ] [ f_frsize>> >>preferred-block-size ]
} cleave ; } cleave ;
M: freebsd file-systems ( -- array ) M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error f 0 0 getfsstat dup io-error
"statfs" <c-array> dup dup length 0 getfsstat io-error \ statfs <struct> dup dup length 0 getfsstat io-error
"statfs" heap-size group statfs heap-size group
[ statfs-f_mntonname alien>native-string file-system-info ] map ; [ 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.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux io.files.links system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs arrays io.files.info.unix assocs io.pathnames unix.types
io.pathnames unix.types ; classes.struct ;
FROM: csv => delimiter ; FROM: csv => delimiter ;
IN: io.files.info.unix.linux IN: io.files.info.unix.linux
@ -15,30 +15,30 @@ namelen ;
M: linux new-file-system-info linux-file-system-info new ; M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array ) 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 ) M: linux statfs>file-system-info ( struct -- statfs )
{ {
[ statfs64-f_type >>type ] [ f_type>> >>type ]
[ statfs64-f_bsize >>block-size ] [ f_bsize>> >>block-size ]
[ statfs64-f_blocks >>blocks ] [ f_blocks>> >>blocks ]
[ statfs64-f_bfree >>blocks-free ] [ f_bfree>> >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ] [ f_bavail>> >>blocks-available ]
[ statfs64-f_files >>files ] [ f_files>> >>files ]
[ statfs64-f_ffree >>files-free ] [ f_ffree>> >>files-free ]
[ statfs64-f_fsid 2 <direct-uint-array> >array >>id ] [ f_fsid>> >>id ]
[ statfs64-f_namelen >>namelen ] [ f_namelen>> >>namelen ]
[ statfs64-f_frsize >>preferred-block-size ] [ f_frsize>> >>preferred-block-size ]
! [ statfs64-f_spare >>spare ] ! [ statfs64-f_spare >>spare ]
} cleave ; } cleave ;
M: linux file-system-statvfs ( path -- byte-array ) 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 ) M: linux statvfs>file-system-info ( struct -- statfs )
{ {
[ statvfs64-f_flag >>flags ] [ f_flag>> >>flags ]
[ statvfs64-f_namemax >>name-max ] [ f_namemax>> >>name-max ]
} cleave ; } cleave ;
TUPLE: mtab-entry file-system-name mount-point type options 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 grouping io.encodings.utf8 io.files kernel math sequences
system unix io.files.unix specialized-arrays.direct.uint arrays system unix io.files.unix specialized-arrays.direct.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx 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 IN: io.files.info.unix.macosx
TUPLE: macosx-file-system-info < unix-file-system-info 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 ) M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error f <void*> dup 0 getmntinfo64 dup io-error
[ *void* ] dip [ *void* ] dip \ statfs64 <direct-struct-array>
"statfs64" heap-size [ * memory>byte-array ] keep group [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
[ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
M: macosx new-file-system-info macosx-file-system-info new ; M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs ) 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 ) 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' ) M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{ {
[ statfs64-f_bsize >>block-size ] [ f_bsize>> >>block-size ]
[ statfs64-f_iosize >>io-size ] [ f_iosize>> >>io-size ]
[ statfs64-f_blocks >>blocks ] [ f_blocks>> >>blocks ]
[ statfs64-f_bfree >>blocks-free ] [ f_bfree>> >>blocks-free ]
[ statfs64-f_bavail >>blocks-available ] [ f_bavail>> >>blocks-available ]
[ statfs64-f_files >>files ] [ f_files>> >>files ]
[ statfs64-f_ffree >>files-free ] [ f_ffree>> >>files-free ]
[ statfs64-f_fsid 2 <direct-uint-array> >array >>id ] [ f_fsid>> >>id ]
[ statfs64-f_owner >>owner ] [ f_owner>> >>owner ]
[ statfs64-f_type >>type-id ] [ f_type>> >>type-id ]
[ statfs64-f_flags >>flags ] [ f_flags>> >>flags ]
[ statfs64-f_fssubtype >>filesystem-subtype ] [ f_fssubtype>> >>filesystem-subtype ]
[ statfs64-f_fstypename utf8 alien>string >>type ] [ f_fstypename>> utf8 alien>string >>type ]
[ statfs64-f_mntonname utf8 alien>string >>mount-point ] [ f_mntonname>> utf8 alien>string >>mount-point ]
[ statfs64-f_mntfromname utf8 alien>string >>device-name ] [ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ; } cleave ;
M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' ) M: macosx statvfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{ {
[ statvfs-f_frsize >>preferred-block-size ] [ f_frsize>> >>preferred-block-size ]
[ statvfs-f_favail >>files-available ] [ f_favail>> >>files-available ]
[ statvfs-f_namemax >>name-max ] [ f_namemax>> >>name-max ]
} cleave ; } 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 combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
grouping sequences io.encodings.utf8 grouping sequences io.encodings.utf8 classes.struct
specialized-arrays.direct.uint io.files.info.unix ; io.files.info.unix ;
IN: io.files.info.unix.netbsd IN: io.files.info.unix.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info 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 new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs 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' ) M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{ {
[ statvfs-f_flag >>flags ] [ f_flag>> >>flags ]
[ statvfs-f_bsize >>block-size ] [ f_bsize>> >>block-size ]
[ statvfs-f_frsize >>preferred-block-size ] [ f_frsize>> >>preferred-block-size ]
[ statvfs-f_iosize >>io-size ] [ f_iosize>> >>io-size ]
[ statvfs-f_blocks >>blocks ] [ f_blocks>> >>blocks ]
[ statvfs-f_bfree >>blocks-free ] [ f_bfree>> >>blocks-free ]
[ statvfs-f_bavail >>blocks-available ] [ f_bavail>> >>blocks-available ]
[ statvfs-f_bresvd >>blocks-reserved ] [ f_bresvd>> >>blocks-reserved ]
[ statvfs-f_files >>files ] [ f_files>> >>files ]
[ statvfs-f_ffree >>files-free ] [ f_ffree>> >>files-free ]
[ statvfs-f_favail >>files-available ] [ f_favail>> >>files-available ]
[ statvfs-f_fresvd >>files-reserved ] [ f_fresvd>> >>files-reserved ]
[ statvfs-f_syncreads >>sync-reads ] [ f_syncreads>> >>sync-reads ]
[ statvfs-f_syncwrites >>sync-writes ] [ f_syncwrites>> >>sync-writes ]
[ statvfs-f_asyncreads >>async-reads ] [ f_asyncreads>> >>async-reads ]
[ statvfs-f_asyncwrites >>async-writes ] [ f_asyncwrites>> >>async-writes ]
[ statvfs-f_fsidx 2 <direct-uint-array> >array >>idx ] [ f_fsidx>> >>idx ]
[ statvfs-f_fsid >>id ] [ f_fsid>> >>id ]
[ statvfs-f_namemax >>name-max ] [ f_namemax>> >>name-max ]
[ statvfs-f_owner >>owner ] [ f_owner>> >>owner ]
! [ statvfs-f_spare >>spare ] [ f_fstypename>> utf8 alien>string >>type ]
[ statvfs-f_fstypename utf8 alien>string >>type ] [ f_mntonname>> utf8 alien>string >>mount-point ]
[ statvfs-f_mntonname utf8 alien>string >>mount-point ] [ f_mntfromname>> utf8 alien>string >>device-name ]
[ statvfs-f_mntfromname utf8 alien>string >>device-name ]
} cleave ; } cleave ;
M: netbsd file-systems ( -- array ) M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error f 0 0 getvfsstat dup io-error
"statvfs" <c-array> dup dup length 0 getvfsstat io-error \ statvfs <c-type-array> dup dup length 0 getvfsstat io-error
"statvfs" heap-size group \ statvfs heap-size group
[ statvfs-f_mntonname utf8 alien>string file-system-info ] map ; [ 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 combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types 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 IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info 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 new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs 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' ) M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{ {
[ statfs-f_flags >>flags ] [ f_flags>> >>flags ]
[ statfs-f_bsize >>block-size ] [ f_bsize>> >>block-size ]
[ statfs-f_iosize >>io-size ] [ f_iosize>> >>io-size ]
[ statfs-f_blocks >>blocks ] [ f_blocks>> >>blocks ]
[ statfs-f_bfree >>blocks-free ] [ f_bfree>> >>blocks-free ]
[ statfs-f_bavail >>blocks-available ] [ f_bavail>> >>blocks-available ]
[ statfs-f_files >>files ] [ f_files>> >>files ]
[ statfs-f_ffree >>files-free ] [ f_ffree>> >>files-free ]
[ statfs-f_favail >>files-available ] [ f_favail>> >>files-available ]
[ statfs-f_syncwrites >>sync-writes ] [ f_syncwrites>> >>sync-writes ]
[ statfs-f_syncreads >>sync-reads ] [ f_syncreads>> >>sync-reads ]
[ statfs-f_asyncwrites >>async-writes ] [ f_asyncwrites>> >>async-writes ]
[ statfs-f_asyncreads >>async-reads ] [ f_asyncreads>> >>async-reads ]
[ statfs-f_fsid 2 <direct-uint-array> >array >>id ] [ f_fsid>> >>id ]
[ statfs-f_namemax >>name-max ] [ f_namemax>> >>name-max ]
[ statfs-f_owner >>owner ] [ f_owner>> >>owner ]
! [ statfs-f_spare >>spare ] [ f_fstypename>> alien>native-string >>type ]
[ statfs-f_fstypename alien>native-string >>type ] [ f_mntonname>> alien>native-string >>mount-point ]
[ statfs-f_mntonname alien>native-string >>mount-point ] [ f_mntfromname>> alien>native-string >>device-name ]
[ statfs-f_mntfromname alien>native-string >>device-name ]
} cleave ; } cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs ) 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' ) M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{ f_frsize>> >>preferred-block-size ;
[ statvfs-f_frsize >>preferred-block-size ]
} cleave ;
M: openbsd file-systems ( -- seq ) M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error f 0 0 getfsstat dup io-error
"statfs" <c-array> dup dup length 0 getfsstat io-error statfs <c-type-array> dup dup length 0 getfsstat io-error
"statfs" heap-size group statfs heap-size group
[ statfs-f_mntonname alien>native-string file-system-info ] map ; [ 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 sequences combinators combinators.short-circuit alien.c-types
vocabs.loader calendar calendar.unix io.files.info vocabs.loader calendar calendar.unix io.files.info
io.files.types io.backend io.directories unix unix.stat unix.time unix.users 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 IN: io.files.info.unix
TUPLE: unix-file-system-info < file-system-info TUPLE: unix-file-system-info < file-system-info
@ -69,19 +69,19 @@ M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip [ new-file-info ] dip
{ {
[ stat>type >>type ] [ stat>type >>type ]
[ stat-st_size >>size ] [ st_size>> >>size ]
[ stat-st_mode >>permissions ] [ st_mode>> >>permissions ]
[ stat-st_ctimespec timespec>unix-time >>created ] [ st_ctimespec>> timespec>unix-time >>created ]
[ stat-st_mtimespec timespec>unix-time >>modified ] [ st_mtimespec>> timespec>unix-time >>modified ]
[ stat-st_atimespec timespec>unix-time >>accessed ] [ st_atimespec>> timespec>unix-time >>accessed ]
[ stat-st_uid >>uid ] [ st_uid>> >>uid ]
[ stat-st_gid >>gid ] [ st_gid>> >>gid ]
[ stat-st_dev >>dev ] [ st_dev>> >>dev ]
[ stat-st_ino >>ino ] [ st_ino>> >>ino ]
[ stat-st_nlink >>nlink ] [ st_nlink>> >>nlink ]
[ stat-st_rdev >>rdev ] [ st_rdev>> >>rdev ]
[ stat-st_blocks >>blocks ] [ st_blocks>> >>blocks ]
[ stat-st_blksize >>blocksize ] [ st_blksize>> >>blocksize ]
[ drop dup blocks>> standard-unix-block-size * >>size-on-disk ] [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ; } cleave ;
@ -98,12 +98,12 @@ M: unix stat>file-info ( stat -- file-info )
} case ; } case ;
M: unix stat>type ( stat -- type ) M: unix stat>type ( stat -- type )
stat-st_mode n>file-type ; st_mode>> n>file-type ;
<PRIVATE <PRIVATE
: stat-mode ( path -- mode ) : stat-mode ( path -- mode )
normalize-path file-status stat-st_mode ; normalize-path file-status st_mode>> ;
: chmod-set-bit ( path mask ? -- ) : chmod-set-bit ( path mask ? -- )
[ dup stat-mode ] 2dip [ dup stat-mode ] 2dip
@ -179,14 +179,12 @@ M: unix copy-file-and-info ( from to -- )
<PRIVATE <PRIVATE
: make-timeval-array ( array -- byte-array )
[ [ "timeval" <c-object> ] unless* ] map concat ;
: timestamp>timeval ( timestamp -- timeval ) : timestamp>timeval ( timestamp -- timeval )
unix-1970 time- duration>microseconds make-timeval ; unix-1970 time- duration>microseconds make-timeval ;
: timestamps>byte-array ( timestamps -- byte-array ) : timestamps>byte-array ( timestamps -- byte-array )
[ dup [ timestamp>timeval ] when ] map make-timeval-array ; [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
\ timeval >struct-array ;
PRIVATE> PRIVATE>
@ -202,8 +200,7 @@ PRIVATE>
f swap 2array set-file-times ; f swap 2array set-file-times ;
: set-file-ids ( path uid gid -- ) : set-file-ids ( path uid gid -- )
[ normalize-path ] 2dip [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
[ [ -1 ] unless* ] bi@ chown io-error ;
GENERIC: set-file-user ( path string/id -- ) GENERIC: set-file-user ( path string/id -- )

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

@ -6,6 +6,7 @@ IN: math.bits
ABOUT: "math.bits" ABOUT: "math.bits"
ARTICLE: "math.bits" "Number bits virtual sequence" 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 <bits> } { $subsection <bits> }
{ $subsection make-bits } ; { $subsection make-bits } ;

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

@ -1,8 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov. ! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private USING: accessors kernel kernel.private math math.private
math.libm math.functions arrays math.functions.private sequences math.functions arrays math.functions.private sequences parser ;
parser ;
IN: math.complex.private IN: math.complex.private
M: real real-part ; inline M: real real-part ; inline
@ -26,8 +25,8 @@ M: complex * [ *re - ] [ *im + ] 2bi rect> ; inline
M: complex / [ / ] complex/ ; inline M: complex / [ / ] complex/ ; inline
M: complex /f [ /f ] complex/ ; inline M: complex /f [ /f ] complex/ ; inline
M: complex /i [ /i ] complex/ ; inline M: complex /i [ /i ] complex/ ; inline
M: complex abs absq >float fsqrt ; inline M: complex abs absq sqrt ; inline
M: complex sqrt >polar [ fsqrt ] [ 2.0 / ] bi* polar> ; inline M: complex sqrt >polar [ sqrt ] [ 2.0 / ] bi* polar> ; inline
IN: syntax 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 3 ^ ] unit-test
[ 0.0 ] [ 1 log ] 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 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test [ 0.0 ] [ 1 acosh ] unit-test
[ 0.0 ] [ 1.0 acosh ] unit-test
[ 1.0 ] [ 0 cos ] unit-test [ 1.0 ] [ 0 cos ] unit-test
[ 1.0 ] [ 0.0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test [ 0.0 ] [ 1 acos ] unit-test
[ 0.0 ] [ 1.0 acos ] unit-test
[ 0.0 ] [ 0 sinh ] unit-test [ 0.0 ] [ 0 sinh ] unit-test
[ 0.0 ] [ 0.0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test [ 0.0 ] [ 0 asinh ] unit-test
[ 0.0 ] [ 0.0 asinh ] unit-test
[ 0.0 ] [ 0 sin ] unit-test [ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0.0 sin ] unit-test
[ 0.0 ] [ 0 asin ] 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 atan real? ] unit-test
[ t ] [ 10.0 atan real? ] unit-test
[ f ] [ 10 atanh 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 ] [ 10 asin sin 10 1.e-10 ~ ] unit-test
[ t ] [ -1 sqrt neg dup acos cos 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 ) : >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline >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 : 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 <PRIVATE
: ^mag ( w abs arg -- magnitude ) : ^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 ) : ^theta ( w abs arg -- theta )
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline [ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
@ -91,7 +102,7 @@ PRIVATE>
{ {
{ [ over 0 = ] [ nip 0^ ] } { [ over 0 = ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] } { [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] } { [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
[ ^complex ] [ ^complex ]
} cond ; inline } cond ; inline
@ -146,17 +157,13 @@ M: real absq sq ; inline
: >=1? ( x -- ? ) : >=1? ( x -- ? )
dup complex? [ drop f ] [ 1 >= ] if ; inline 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 ) 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 : 10^ ( x -- y ) 10 swap ^ ; inline
@ -169,7 +176,9 @@ M: complex cos
[ [ fcos ] [ fcosh ] bi* * ] [ [ fcos ] [ fcosh ] bi* * ]
[ [ fsin neg ] [ fsinh ] bi* * ] 2bi rect> ; [ [ 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 : sec ( x -- y ) cos recip ; inline
@ -180,7 +189,9 @@ M: complex cosh
[ [ fcosh ] [ fcos ] bi* * ] [ [ fcosh ] [ fcos ] bi* * ]
[ [ fsinh ] [ fsin ] bi* * ] 2bi rect> ; [ [ 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 : sech ( x -- y ) cosh recip ; inline
@ -191,7 +202,9 @@ M: complex sin
[ [ fsin ] [ fcosh ] bi* * ] [ [ fsin ] [ fcosh ] bi* * ]
[ [ fcos ] [ fsinh ] bi* * ] 2bi rect> ; [ [ 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 : cosec ( x -- y ) sin recip ; inline
@ -202,7 +215,9 @@ M: complex sinh
[ [ fsinh ] [ fcos ] bi* * ] [ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ; [ [ 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 : cosech ( x -- y ) sinh recip ; inline
@ -210,13 +225,17 @@ GENERIC: tan ( x -- y ) foldable
M: complex tan [ sin ] [ cos ] bi / ; 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 GENERIC: tanh ( x -- y ) foldable
M: complex tanh [ sinh ] [ cosh ] bi / ; 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 : cot ( x -- y ) tan recip ; inline
@ -242,17 +261,19 @@ M: real tanh ftanh ; inline
: -i* ( x -- y ) >rect swap neg rect> ; : -i* ( x -- y ) >rect swap neg rect> ;
: asin ( x -- y ) : 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 ) : acos ( x -- y )
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; dup [-1,1]? [ >float facos ] [ asin pi 2 / swap - ] if ;
inline inline
GENERIC: atan ( x -- y ) foldable 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 : 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" 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." "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 { $warning
"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:" "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 acos ." "C{ 0.0 1.316957896924817 }" } { $example "USE: math.functions" "2.0 acos ." "C{ 0.0 1.316957896924817 }" }
{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." } { $unchecked-example "USE: math.libm" "2 facos ." "0/0." } }
"Trigonometric functions:" "Trigonometric functions:"
{ $subsection fcos } { $subsection fcos }
{ $subsection fsin } { $subsection fsin }

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

@ -4,54 +4,53 @@ USING: alien ;
IN: math.libm IN: math.libm
: facos ( x -- y ) : facos ( x -- y )
"double" "libm" "acos" { "double" } alien-invoke ; inline "double" "libm" "acos" { "double" } alien-invoke ;
: fasin ( x -- y ) : fasin ( x -- y )
"double" "libm" "asin" { "double" } alien-invoke ; inline "double" "libm" "asin" { "double" } alien-invoke ;
: fatan ( x -- y ) : fatan ( x -- y )
"double" "libm" "atan" { "double" } alien-invoke ; inline "double" "libm" "atan" { "double" } alien-invoke ;
: fatan2 ( x y -- z ) : fatan2 ( x y -- z )
"double" "libm" "atan2" { "double" "double" } alien-invoke ; inline "double" "libm" "atan2" { "double" "double" } alien-invoke ;
: fcos ( x -- y ) : fcos ( x -- y )
"double" "libm" "cos" { "double" } alien-invoke ; inline "double" "libm" "cos" { "double" } alien-invoke ;
: fsin ( x -- y ) : fsin ( x -- y )
"double" "libm" "sin" { "double" } alien-invoke ; inline "double" "libm" "sin" { "double" } alien-invoke ;
: ftan ( x -- y ) : ftan ( x -- y )
"double" "libm" "tan" { "double" } alien-invoke ; inline "double" "libm" "tan" { "double" } alien-invoke ;
: fcosh ( x -- y ) : fcosh ( x -- y )
"double" "libm" "cosh" { "double" } alien-invoke ; inline "double" "libm" "cosh" { "double" } alien-invoke ;
: fsinh ( x -- y ) : fsinh ( x -- y )
"double" "libm" "sinh" { "double" } alien-invoke ; inline "double" "libm" "sinh" { "double" } alien-invoke ;
: ftanh ( x -- y ) : ftanh ( x -- y )
"double" "libm" "tanh" { "double" } alien-invoke ; inline "double" "libm" "tanh" { "double" } alien-invoke ;
: fexp ( x -- y ) : fexp ( x -- y )
"double" "libm" "exp" { "double" } alien-invoke ; inline "double" "libm" "exp" { "double" } alien-invoke ;
: flog ( x -- y ) : flog ( x -- y )
"double" "libm" "log" { "double" } alien-invoke ; inline "double" "libm" "log" { "double" } alien-invoke ;
: fpow ( x y -- z ) : 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 ) : fsqrt ( x -- y )
"double" "libm" "sqrt" { "double" } alien-invoke ; "double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these... ! Windows doesn't have these...
: facosh ( x -- y ) : facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ; inline "double" "libm" "acosh" { "double" } alien-invoke ;
: fasinh ( x -- y ) : fasinh ( x -- y )
"double" "libm" "asinh" { "double" } alien-invoke ; inline "double" "libm" "asinh" { "double" } alien-invoke ;
: fatanh ( x -- y ) : 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 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ] [ { { { 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 ) : m^n ( m n -- n )
make-bits over first length identity-matrix make-bits over first length identity-matrix
[ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

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 } S{ test-struct-array f 20 20 }
} second } second
] unit-test ] 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 , "disposables" "destructors" lookup ,
"functor-words" "functors.backend" lookup ,
deploy-threads? [ deploy-threads? [
"initial-thread" "threads" lookup , "initial-thread" "threads" lookup ,
] unless ] unless

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 IN: unix.stat
cell-bits { ! FreeBSD 8.0-CURRENT
{ 32 [ "unix.stat.freebsd.32" require ] }
{ 64 [ "unix.stat.freebsd.64" require ] } STRUCT: stat
} case { st_dev __dev_t }
{ st_ino ino_t }
{ st_mode mode_t }
{ st_nlink nlink_t }
{ st_uid uid_t }
{ st_gid git_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 USING: kernel alien.syntax math classes.struct ;
alien.c-types arrays accessors combinators ;
IN: unix.stat IN: unix.stat
! stat64 ! stat64
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "ushort" "__pad1" } { __pad1 ushort }
{ "__ino_t" "__st_ino" } { __st_ino __ino_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ { "ushort" 2 } "__pad2" } { __pad2 ushort[2] }
{ "off64_t" "st_size" } { st_size off64_t }
{ "blksize_t" "st_blksize" } { st_blksize blksize_t }
{ "blkcnt64_t" "st_blocks" } { st_blocks blkcnt64_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "ulonglong" "st_ino" } ; { st_ino ulonglong } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( 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 USING: kernel alien.syntax math classes.struct ;
alien.c-types arrays accessors combinators ;
IN: unix.stat IN: unix.stat
! Ubuntu 7.10 64-bit ! Ubuntu 7.10 64-bit
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "ino_t" "st_ino" } { st_ino ino_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "int" "pad0" } { pad0 int }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ "off64_t" "st_size" } { st_size off64_t }
{ "blksize_t" "st_blksize" } { st_blksize blksize_t }
{ "blkcnt64_t" "st_blocks" } { st_blocks blkcnt64_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "long" "__unused0" } { __unused0 long[3] } ;
{ "long" "__unused1" }
{ "long" "__unused2" } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( 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 USING: alien.c-types arrays accessors combinators classes.struct
alien.c-types alien sequences grouping accessors combinators ; alien.syntax ;
IN: unix.stat IN: unix.stat
! Mac OS X ppc ! Mac OS X ppc
! stat64 structure ! stat64 structure
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "ino64_t" "st_ino" } { st_ino ino64_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "timespec" "st_birthtimespec" } { st_birthtimespec timespec }
{ "off_t" "st_size" } { st_size off_t }
{ "blkcnt_t" "st_blocks" } { st_blocks blkcnt_t }
{ "blksize_t" "st_blksize" } { st_blksize blksize_t }
{ "__uint32_t" "st_flags" } { st_flags __uint32_t }
{ "__uint32_t" "st_gen" } { st_gen __uint32_t }
{ "__int32_t" "st_lspare" } { st_lspare __int32_t }
{ "__int64_t" "st_qspare0" } { st_qspare0 __int64_t }
{ "__int64_t" "st_qspare1" } ; { st_qspare1 __int64_t } ;
FUNCTION: int stat64 ( char* pathname, stat* buf ) ; FUNCTION: int stat64 ( char* pathname, stat* buf ) ;
FUNCTION: int lstat64 ( 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 IN: unix.stat
! NetBSD 4.0 ! NetBSD 4.0
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "ino_t" "st_ino" } { st_ino ino_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "timespec" "st_birthtimespec" } { st_birthtimespec timespec }
{ "off_t" "st_size" } { st_size off_t }
{ "blkcnt_t" "st_blocks" } { st_blocks blkcnt_t }
{ "blksize_t" "st_blksize" } { st_blksize blksize_t }
{ "uint32_t" "st_flags" } { st_flags uint32_t }
{ "uint32_t" "st_gen" } { st_gen uint32_t }
{ { "uint32_t" 2 } "st_qspare" } ; { st_qspare uint32_t[2] } ;
FUNCTION: int __stat30 ( char* pathname, stat* buf ) ; FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat30 ( 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 IN: unix.stat
! NetBSD 4.0 ! NetBSD 4.0
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "ino_t" "st_ino" } { st_ino ino_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "off_t" "st_size" } { st_size off_t }
{ "blkcnt_t" "st_blocks" } { st_blocks blkcnt_t }
{ "blksize_t" "st_blksize" } { st_blksize blksize_t }
{ "uint32_t" "st_flags" } { st_flags uint32_t }
{ "uint32_t" "st_gen" } { st_gen uint32_t }
{ "uint32_t" "st_spare0" } { st_spare0 uint32_t }
{ "timespec" "st_birthtimespec" } ; { st_birthtimespec timespec } ;
FUNCTION: int __stat13 ( char* pathname, stat* buf ) ; FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
FUNCTION: int __lstat13 ( 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 IN: unix.stat
! OpenBSD 4.2 ! OpenBSD 4.2
C-STRUCT: stat STRUCT: stat
{ "dev_t" "st_dev" } { st_dev dev_t }
{ "ino_t" "st_ino" } { st_ino ino_t }
{ "mode_t" "st_mode" } { st_mode mode_t }
{ "nlink_t" "st_nlink" } { st_nlink nlink_t }
{ "uid_t" "st_uid" } { st_uid uid_t }
{ "gid_t" "st_gid" } { st_gid gid_t }
{ "dev_t" "st_rdev" } { st_rdev dev_t }
{ "int32_t" "st_lspare0" } { st_lspare0 int32_t }
{ "timespec" "st_atimespec" } { st_atimespec timespec }
{ "timespec" "st_mtimespec" } { st_mtimespec timespec }
{ "timespec" "st_ctimespec" } { st_ctimespec timespec }
{ "off_t" "st_size" } { st_size off_t }
{ "int64_t" "st_blocks" } { st_blocks int64_t }
{ "u_int32_t" "st_blksize" } { st_blksize u_int32_t }
{ "u_int32_t" "st_flags" } { st_flags u_int32_t }
{ "u_int32_t" "st_gen" } { st_gen u_int32_t }
{ "int32_t" "st_lspare1" } { st_lspare1 int32_t }
{ "timespec" "st_birthtimespec" } { st_birthtimespec timespec }
{ { "int64_t" 2 } "st_qspare" } ; { st_qspare int64_t[2] } ;
FUNCTION: int stat ( char* pathname, stat* buf ) ; FUNCTION: int stat ( char* pathname, stat* buf ) ;
FUNCTION: int lstat ( 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 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 IN: unix.stat
! File Types ! File Types
@ -15,8 +15,8 @@ CONSTANT: S_IFLNK OCT: 120000 ! Symbolic link.
CONSTANT: S_IFSOCK OCT: 140000 ! Socket. CONSTANT: S_IFSOCK OCT: 140000 ! Socket.
CONSTANT: S_IFWHT OCT: 160000 ! Whiteout. CONSTANT: S_IFWHT OCT: 160000 ! Whiteout.
C-STRUCT: fsid STRUCT: fsid
{ { "int" 2 } "__val" } ; { __val int[2] } ;
TYPEDEF: fsid __fsid_t TYPEDEF: fsid __fsid_t
TYPEDEF: fsid fsid_t TYPEDEF: fsid fsid_t
@ -30,7 +30,7 @@ TYPEDEF: fsid fsid_t
} case >> } case >>
: file-status ( pathname -- stat ) : 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 ) : 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: unix.statfs.freebsd
CONSTANT: MFSNAMELEN 16 ! length of type name including null */ CONSTANT: MFSNAMELEN 16 ! length of type name including null */
CONSTANT: MNAMELEN 88 ! size of on/from name bufs CONSTANT: MNAMELEN 88 ! size of on/from name bufs
CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number CONSTANT: STATFS_VERSION HEX: 20030518 ! current version number
C-STRUCT: statfs STRUCT: statfs
{ "uint32_t" "f_version" } { f_version uint32_t }
{ "uint32_t" "f_type" } { f_type uint32_t }
{ "uint64_t" "f_flags" } { f_flags uint64_t }
{ "uint64_t" "f_bsize" } { f_bsize uint64_t }
{ "uint64_t" "f_iosize" } { f_iosize uint64_t }
{ "uint64_t" "f_blocks" } { f_blocks uint64_t }
{ "uint64_t" "f_bfree" } { f_bfree uint64_t }
{ "int64_t" "f_bavail" } { f_bavail int64_t }
{ "uint64_t" "f_files" } { f_files uint64_t }
{ "int64_t" "f_ffree" } { f_ffree int64_t }
{ "uint64_t" "f_syncwrites" } { f_syncwrites uint64_t }
{ "uint64_t" "f_asyncwrites" } { f_asyncwrites uint64_t }
{ "uint64_t" "f_syncreads" } { f_syncreads uint64_t }
{ "uint64_t" "f_asyncreads" } { f_asyncreads uint64_t }
{ { "uint64_t" 10 } "f_spare" } { f_spare uint64_t[10] }
{ "uint32_t" "f_namemax" } { f_namemax uint32_t }
{ "uid_t" "f_owner" } { f_owner uid_t }
{ "fsid_t" "f_fsid" } { f_fsid fsid_t }
{ { "char" 80 } "f_charspare" } { f_charspare char[80] }
{ { "char" MFSNAMELEN } "f_fstypename" } { f_fstypename { "char" MFSNAMELEN } }
{ { "char" MNAMELEN } "f_mntfromname" } { f_mntfromname { "char" MNAMELEN } }
{ { "char" MNAMELEN } "f_mntonname" } ; { f_mntonname { "char" MNAMELEN } } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ; 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: unix.statfs.linux
C-STRUCT: statfs64 STRUCT: statfs64
{ "__SWORD_TYPE" "f_type" } { f_type __SWORD_TYPE }
{ "__SWORD_TYPE" "f_bsize" } { f_bsize __SWORD_TYPE }
{ "__fsblkcnt64_t" "f_blocks" } { f_blocks __fsblkcnt64_t }
{ "__fsblkcnt64_t" "f_bfree" } { f_bfree __fsblkcnt64_t }
{ "__fsblkcnt64_t" "f_bavail" } { f_bavail __fsblkcnt64_t }
{ "__fsfilcnt64_t" "f_files" } { f_files __fsblkcnt64_t }
{ "__fsfilcnt64_t" "f_ffree" } { f_ffree __fsblkcnt64_t }
{ "__fsid_t" "f_fsid" } { f_fsid __fsid_t }
{ "__SWORD_TYPE" "f_namelen" } { f_namelen __SWORD_TYPE }
{ "__SWORD_TYPE" "f_frsize" } { f_frsize __SWORD_TYPE }
{ { "__SWORD_TYPE" 5 } "f_spare" } ; { f_spare __SWORD_TYPE[5] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; 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 USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax grouping system alien.strings math.bitwise alien.syntax
unix.types ; unix.types classes.struct ;
IN: unix.statfs.macosx IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001 CONSTANT: MNT_RDONLY HEX: 00000001
@ -65,9 +65,9 @@ CONSTANT: VFS_CTL_NEWADDR HEX: 00010004
CONSTANT: VFS_CTL_TIMEO HEX: 00010005 CONSTANT: VFS_CTL_TIMEO HEX: 00010005
CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006 CONSTANT: VFS_CTL_NOLOCKS HEX: 00010006
C-STRUCT: vfsquery STRUCT: vfsquery
{ "uint32_t" "vq_flags" } { vq_flags uint32_t }
{ { "uint32_t" 31 } "vq_spare" } ; { vq_spare uint32_t[31] } ;
CONSTANT: VQ_NOTRESP HEX: 0001 CONSTANT: VQ_NOTRESP HEX: 0001
CONSTANT: VQ_NEEDAUTH HEX: 0002 CONSTANT: VQ_NEEDAUTH HEX: 0002
@ -95,26 +95,26 @@ CONSTANT: MFSNAMELEN 15
CONSTANT: MNAMELEN 90 CONSTANT: MNAMELEN 90
CONSTANT: MFSTYPENAMELEN 16 CONSTANT: MFSTYPENAMELEN 16
C-STRUCT: fsid_t STRUCT: fsid_t
{ { "int32_t" 2 } "val" } ; { val int32_t[2] } ;
C-STRUCT: statfs64 STRUCT: statfs64
{ "uint32_t" "f_bsize" } { f_bsize uint32_t }
{ "int32_t" "f_iosize" } { f_iosize int32_t }
{ "uint64_t" "f_blocks" } { f_blocks uint64_t }
{ "uint64_t" "f_bfree" } { f_bfree uint64_t }
{ "uint64_t" "f_bavail" } { f_bavail uint64_t }
{ "uint64_t" "f_files" } { f_files uint64_t }
{ "uint64_t" "f_ffree" } { f_ffree uint64_t }
{ "fsid_t" "f_fsid" } { f_fsid fsid_t }
{ "uid_t" "f_owner" } { f_owner uid_t }
{ "uint32_t" "f_type" } { f_type uint32_t }
{ "uint32_t" "f_flags" } { f_flags uint32_t }
{ "uint32_t" "f_fssubtype" } { f_fssubtype uint32_t }
{ { "char" MFSTYPENAMELEN } "f_fstypename" } { f_fstypename { "char" MFSTYPENAMELEN } }
{ { "char" MAXPATHLEN } "f_mntonname" } { f_mntonname { "char" MAXPATHLEN } }
{ { "char" MAXPATHLEN } "f_mntfromname" } { f_mntfromname { "char" MAXPATHLEN } }
{ { "uint32_t" 8 } "f_reserved" } ; { f_reserved uint32_t[8] } ;
FUNCTION: int statfs64 ( char* path, statfs64* buf ) ; FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
FUNCTION: int getmntinfo64 ( statfs64** mntbufp, int flags ) ; 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! 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 IN: unix.statfs.openbsd
CONSTANT: MFSNAMELEN 16 CONSTANT: MFSNAMELEN 16
CONSTANT: MNAMELEN 90 CONSTANT: MNAMELEN 90
C-STRUCT: statfs STRUCT: statfs
{ "u_int32_t" "f_flags" } { f_flags u_int32_t }
{ "u_int32_t" "f_bsize" } { f_bsize u_int32_t }
{ "u_int32_t" "f_iosize" } { f_iosize u_int32_t }
{ "u_int64_t" "f_blocks" } { f_blocks u_int64_t }
{ "u_int64_t" "f_bfree" } { f_bfree u_int64_t }
{ "int64_t" "f_bavail" } { f_bavail int64_t }
{ "u_int64_t" "f_files" } { f_files u_int64_t }
{ "u_int64_t" "f_ffree" } { f_ffree u_int64_t }
{ "int64_t" "f_favail" } { f_favail int64_t }
{ "u_int64_t" "f_syncwrites" } { f_syncwrites u_int64_t }
{ "u_int64_t" "f_syncreads" } { f_syncreads u_int64_t }
{ "u_int64_t" "f_asyncwrites" } { f_asyncwrites u_int64_t }
{ "u_int64_t" "f_asyncreads" } { f_asyncreads u_int64_t }
{ "fsid_t" "f_fsid" } { f_fsid fsid_t }
{ "u_int32_t" "f_namemax" } { f_namemax u_int32_t }
{ "uid_t" "f_owner" } { f_owner uid_t }
{ "u_int32_t" "f_ctime" } { f_ctime u_int32_t }
{ { "u_int32_t" 3 } "f_spare" } { f_spare u_int32_t[3] }
{ { "char" MFSNAMELEN } "f_fstypename" } { f_fstypename { "char" MFSNAMELEN } }
{ { "char" MNAMELEN } "f_mntonname" } { f_mntonname { "char" MNAMELEN } }
{ { "char" MNAMELEN } "f_mntfromname" } { f_mntfromname { "char" MNAMELEN } }
{ { "char" 160 } "mount_info" } ; { mount_info char[160] } ;
FUNCTION: int statfs ( char* path, statvfs* buf ) ; 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax classes.struct ;
IN: unix.statvfs.freebsd IN: unix.statvfs.freebsd
C-STRUCT: statvfs STRUCT: statvfs
{ "fsblkcnt_t" "f_bavail" } { f_bavail fsblkcnt_t }
{ "fsblkcnt_t" "f_bfree" } { f_bfree fsblkcnt_t }
{ "fsblkcnt_t" "f_blocks" } { f_blocks fsblkcnt_t }
{ "fsfilcnt_t" "f_favail" } { f_favail fsfilcnt_t }
{ "fsfilcnt_t" "f_ffree" } { f_ffree fsfilcnt_t }
{ "fsfilcnt_t" "f_files" } { f_files fsfilcnt_t }
{ "ulong" "f_bsize" } { f_bsize ulong }
{ "ulong" "f_flag" } { f_flag ulong }
{ "ulong" "f_frsize" } { f_frsize ulong }
{ "ulong" "f_fsid" } { f_fsid ulong }
{ "ulong" "f_namemax" } ; { f_namemax ulong } ;
! Flags ! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax classes.struct ;
IN: unix.statvfs.linux IN: unix.statvfs.linux
C-STRUCT: statvfs64 STRUCT: statvfs64
{ "ulong" "f_bsize" } { f_bsize ulong }
{ "ulong" "f_frsize" } { f_frsize ulong }
{ "__fsblkcnt64_t" "f_blocks" } { f_blocks __fsblkcnt64_t }
{ "__fsblkcnt64_t" "f_bfree" } { f_bfree __fsblkcnt64_t }
{ "__fsblkcnt64_t" "f_bavail" } { f_bavail __fsblkcnt64_t }
{ "__fsfilcnt64_t" "f_files" } { f_files __fsfilcnt64_t }
{ "__fsfilcnt64_t" "f_ffree" } { f_ffree __fsfilcnt64_t }
{ "__fsfilcnt64_t" "f_favail" } { f_favail __fsfilcnt64_t }
{ "ulong" "f_fsid" } { f_fsid ulong }
{ "ulong" "f_flag" } { f_flag ulong }
{ "ulong" "f_namemax" } { f_namemax ulong }
{ { "int" 6 } "__f_spare" } ; { __f_spare int[6] } ;
FUNCTION: int statvfs64 ( char* path, statvfs64* buf ) ; 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax classes.struct ;
IN: unix.statvfs.macosx IN: unix.statvfs.macosx
C-STRUCT: statvfs STRUCT: statvfs
{ "ulong" "f_bsize" } { f_bsize ulong }
{ "ulong" "f_frsize" } { f_frsize ulong }
{ "fsblkcnt_t" "f_blocks" } { f_blocks fsblkcnt_t }
{ "fsblkcnt_t" "f_bfree" } { f_bfree fsblkcnt_t }
{ "fsblkcnt_t" "f_bavail" } { f_bavail fsblkcnt_t }
{ "fsfilcnt_t" "f_files" } { f_files fsfilcnt_t }
{ "fsfilcnt_t" "f_ffree" } { f_ffree fsfilcnt_t }
{ "fsfilcnt_t" "f_favail" } { f_favail fsfilcnt_t }
{ "ulong" "f_fsid" } { f_fsid ulong }
{ "ulong" "f_flag" } { f_flag ulong }
{ "ulong" "f_namemax" } ; { f_namemax ulong } ;
! Flags ! Flags
CONSTANT: ST_RDONLY HEX: 1 ! Read-only file system 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax classes.struct ;
IN: unix.statvfs.netbsd IN: unix.statvfs.netbsd
CONSTANT: _VFS_NAMELEN 32 CONSTANT: _VFS_NAMELEN 32
CONSTANT: _VFS_MNAMELEN 1024 CONSTANT: _VFS_MNAMELEN 1024
C-STRUCT: statvfs STRUCT: statvfs
{ "ulong" "f_flag" } { f_flag ulong }
{ "ulong" "f_bsize" } { f_bsize ulong }
{ "ulong" "f_frsize" } { f_frsize ulong }
{ "ulong" "f_iosize" } { f_iosize ulong }
{ "fsblkcnt_t" "f_blocks" } { f_blocks fsblkcnt_t }
{ "fsblkcnt_t" "f_bfree" } { f_bfree fsblkcnt_t }
{ "fsblkcnt_t" "f_bavail" } { f_bavail fsblkcnt_t }
{ "fsblkcnt_t" "f_bresvd" } { f_bresvd fsblkcnt_t }
{ "fsfilcnt_t" "f_files" } { f_files fsfilcnt_t }
{ "fsfilcnt_t" "f_ffree" } { f_ffree fsfilcnt_t }
{ "fsfilcnt_t" "f_favail" } { f_favail fsfilcnt_t }
{ "fsfilcnt_t" "f_fresvd" } { f_fresvd fsfilcnt_t }
{ "uint64_t" "f_syncreads" } { f_syncreads uint64_t }
{ "uint64_t" "f_syncwrites" } { f_syncwrites uint64_t }
{ "uint64_t" "f_asyncreads" } { f_asyncreads uint64_t }
{ "uint64_t" "f_asyncwrites" } { f_asyncwrites uint64_t }
{ "fsid_t" "f_fsidx" } { f_fsidx fsid_t }
{ "ulong" "f_fsid" } { f_fsid ulong }
{ "ulong" "f_namemax" } { f_namemax ulong }
{ "uid_t" "f_owner" } { f_owner uid_t }
{ { "uint32_t" 4 } "f_spare" } { f_spare uint32_t[4] }
{ { "char" _VFS_NAMELEN } "f_fstypename" } { f_fstypename { "char" _VFS_NAMELEN } }
{ { "char" _VFS_MNAMELEN } "f_mntonname" } { f_mntonname { "char" _VFS_MNAMELEN } }
{ { "char" _VFS_MNAMELEN } "f_mntfromname" } ; { f_mntfromname { "char" _VFS_MNAMELEN } } ;
FUNCTION: int statvfs ( char* path, statvfs* buf ) ; 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. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax ; USING: alien.syntax classes.struct ;
IN: unix.statvfs.openbsd IN: unix.statvfs.openbsd
C-STRUCT: statvfs STRUCT: statvfs
{ "ulong" "f_bsize" } { f_bsize ulong }
{ "ulong" "f_frsize" } { f_frsize ulong }
{ "fsblkcnt_t" "f_blocks" } { f_blocks fsblkcnt_t }
{ "fsblkcnt_t" "f_bfree" } { f_bfree fsblkcnt_t }
{ "fsblkcnt_t" "f_bavail" } { f_bavail fsblkcnt_t }
{ "fsfilcnt_t" "f_files" } { f_files fsfilcnt_t }
{ "fsfilcnt_t" "f_ffree" } { f_ffree fsfilcnt_t }
{ "fsfilcnt_t" "f_favail" } { f_favail fsfilcnt_t }
{ "ulong" "f_fsid" } { f_fsid ulong }
{ "ulong" "f_flag" } { f_flag ulong }
{ "ulong" "f_namemax" } ; { f_namemax ulong } ;
CONSTANT: ST_RDONLY 1 CONSTANT: ST_RDONLY 1
CONSTANT: ST_NOSUID 2 CONSTANT: ST_NOSUID 2

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

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

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

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

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

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