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

basis/alien/c-types/c-types-docs.factor

@@ -49,7 +49,7 @@ HELP: c-setter
 { $errors "Throws an error if the type does not exist." } ;
 
 HELP: <c-array>
-{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
+{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
 { $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
 { $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -109,7 +109,6 @@ IN: compiler.cfg.intrinsics
     } enable-intrinsics ;
 
 : enable-float-functions ( -- )
-    ! Everything except for fsqrt
     {
         { math.libm:facos [ drop "acos" emit-unary-float-function ] }
         { math.libm:fasin [ drop "asin" emit-unary-float-function ] }
@@ -127,6 +126,9 @@ IN: compiler.cfg.intrinsics
         { 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 ] }
+        { math.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
+        { math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
+        { math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
     } enable-intrinsics ;
 
 : enable-min/max ( -- )

basis/cpu/ppc/ppc.factor

@@ -281,6 +281,23 @@ M:: ppc %box-float ( dst src temp -- )
     dst 16 float temp %allot
     src dst float-offset STFD ;
 
+: float-function-param ( i spill-slot -- )
+    [ float-regs param-regs nth 1 ] [ n>> spill@ ] bi* LFD ;
+
+: float-function-return ( reg -- )
+    float-regs return-reg 2dup = [ 2drop ] [ FMR ] if ;
+
+M:: ppc %unary-float-function ( dst src func -- )
+    0 src float-function-param
+    func f %alien-invoke
+    dst float-function-return ;
+
+M:: ppc %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 ;
+
 M:: ppc %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
@@ -338,7 +355,8 @@ M:: ppc %box-alien ( dst src temp -- )
 M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
     [
         "end" define-label
-        "ok" define-label
+        "alloc" define-label
+        "simple-case" define-label
         ! If displacement is zero, return the base
         dst base MR
         0 displacement 0 CMPI
@@ -347,19 +365,21 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
         displacement' :> temp
         dst 4 cells alien temp %allot
         ! If base is already a displaced alien, unpack it
-        base' base MR
-        displacement' displacement MR
         0 base \ f tag-number CMPI
-        "ok" get BEQ
+        "simple-case" get BEQ
         temp base header-offset LWZ
         0 temp alien type-number tag-fixnum CMPI
-        "ok" get BNE
+        "simple-case" get BNE
         ! displacement += base.displacement
         temp base 3 alien@ LWZ
         displacement' displacement temp ADD
         ! base = base.base
         base' base 1 alien@ LWZ
-        "ok" resolve-label
+        "alloc" get B
+        "simple-case" resolve-label
+        displacement' displacement MR
+        base' base MR
+        "alloc" resolve-label
         ! Store underlying-alien slot
         base' dst 1 alien@ STW
         ! Store offset
@@ -678,6 +698,8 @@ M: ppc %unbox-small-struct ( size -- )
         { 4 [ %unbox-struct-4 ] }
     } case ;
 
+enable-float-functions
+
 USE: vocabs.loader
 
 {

basis/cpu/x86/64/64.factor

@@ -218,12 +218,12 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
 ! x86-64.
 enable-alien-4-intrinsics
 
-! SSE2 is always available on x86-64.
-enable-sse2
-
 ! Enable fast calling of libc math functions
 enable-float-functions
 
+! SSE2 is always available on x86-64.
+enable-sse2
+
 USE: vocabs.loader
 
 {

basis/io/backend/unix/multiplexers/epoll/epoll.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types kernel destructors bit-arrays
+USING: accessors classes.struct kernel destructors bit-arrays
 sequences assocs struct-arrays math namespaces locals fry unix
 unix.linux.epoll unix.time io.ports io.backend.unix
 io.backend.unix.multiplexers ;
@@ -16,14 +16,14 @@ TUPLE: epoll-mx < mx events ;
 : <epoll-mx> ( -- mx )
     epoll-mx new-mx
         max-events epoll_create dup io-error >>fd
-        max-events "epoll-event" <struct-array> >>events ;
+        max-events epoll-event <struct-array> >>events ;
 
 M: epoll-mx dispose* fd>> close-file ;
 
 : make-event ( fd events -- event )
-    "epoll-event" <c-object>
+    epoll-event <struct>
-    [ set-epoll-event-events ] keep
+        swap >>events
-    [ set-epoll-event-fd ] keep ;
+        swap >>fd ;
 
 :: do-epoll-ctl ( fd mx what events -- )
     mx fd>> what fd fd events make-event epoll_ctl io-error ;
@@ -55,7 +55,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq )
     epoll_wait multiplexer-error ;
 
 : handle-event ( event mx -- )
-    [ epoll-event-fd ] dip
+    [ fd>> ] dip
     [ EPOLLIN EPOLLOUT bitor do-epoll-del ]
     [ input-available ] [ output-available ] 2tri ;
 

basis/struct-arrays/struct-arrays-docs.factor

@@ -7,15 +7,15 @@ $nl
 "The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
 
 HELP: <struct-array>
-{ $values { "length" integer } { "c-type" string } { "struct-array" struct-array } }
+{ $values { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified C type." } ;
+{ $description "Creates a new array for holding values of the specified struct type." } ;
 
 HELP: <direct-struct-array>
-{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } }
+{ $values { "alien" c-ptr } { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
 { $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
 
 HELP: struct-array-on
-{ $value { "struct" struct } { "length" integer } }
+{ $values { "struct" struct } { "length" integer } { "struct-array" struct-array } }
 { $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." }
 { $examples
 "This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:"

basis/struct-arrays/struct-arrays-tests.factor

@@ -51,3 +51,5 @@ 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
+
+[ 10 "int" <struct-array> ] must-fail

basis/struct-arrays/struct-arrays.factor

@@ -5,9 +5,6 @@ classes classes.struct kernel libc math parser sequences
 sequences.private words fry memoize compiler.units ;
 IN: struct-arrays
 
-: c-type-struct-class ( c-type -- class )
-    c-type boxed-class>> ; foldable
-
 TUPLE: struct-array
 { underlying c-ptr read-only }
 { length array-capacity read-only }
@@ -15,35 +12,39 @@ TUPLE: struct-array
 { class read-only }
 { ctor read-only } ;
 
-M: struct-array length length>> ; inline
+<PRIVATE
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
 
 : (nth-ptr) ( i struct-array -- alien )
     [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
 
+: (struct-element-constructor) ( struct-class -- word )
+    [
+        "struct-array-ctor" f <word>
+        [ swap '[ _ memory>struct ] (( alien -- object )) define-inline ] keep
+    ] with-compilation-unit ;
+
+! Foldable memo word. This is an optimization; by precompiling a
+! constructor for array elements, we avoid memory>struct's slow path.
+MEMO: struct-element-constructor ( struct-class -- word )
+    (struct-element-constructor) ; foldable
+
+PRIVATE>
+
+M: struct-array length length>> ; inline
+
+M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
+
 M: struct-array nth-unsafe
     [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
 
 M: struct-array set-nth-unsafe
     [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
 
-: (struct-element-constructor) ( c-type -- word )
+ERROR: not-a-struct-class struct-class ;
-    [
-        "struct-array-ctor" f <word>
-        [
-            swap dup struct-class?
-            [ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
-            (( alien -- object )) define-inline
-        ] keep
-    ] with-compilation-unit ;
 
-! Foldable memo word. This is an optimization; by precompiling a
+: <direct-struct-array> ( alien length struct-class -- struct-array )
-! constructor for array elements, we avoid memory>struct's slow path.
+    dup struct-class? [ not-a-struct-class ] unless
-MEMO: struct-element-constructor ( c-type -- word )
+    [ heap-size ] [ ] [ struct-element-constructor ]
-    (struct-element-constructor) ; foldable
-
-: <direct-struct-array> ( alien length c-type -- struct-array )
-    [ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
     tri struct-array boa ; inline
 
 M: struct-array new-sequence
@@ -54,7 +55,7 @@ M: struct-array resize ( n seq -- newseq )
     [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
     <direct-struct-array> ; inline
 
-: <struct-array> ( length c-type -- struct-array )
+: <struct-array> ( length struct-class -- struct-array )
     [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
 
 ERROR: bad-byte-array-length byte-array ;

basis/struct-vectors/struct-vectors-docs.factor

@@ -1,11 +1,11 @@
 IN: struct-vectors
-USING: help.markup help.syntax alien strings math ;
+USING: help.markup help.syntax classes.struct alien strings math ;
 
 HELP: struct-vector
 { $class-description "The class of growable C struct and union arrays." } ;
 
 HELP: <struct-vector>
-{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } }
+{ $values { "capacity" integer } { "struct-class" struct-class } { "struct-vector" struct-vector } }
 { $description "Creates a new vector with the given initial capacity." } ;
 
 ARTICLE: "struct-vectors" "C struct and union vectors"

basis/struct-vectors/struct-vectors-tests.factor

@@ -1,21 +1,16 @@
 IN: struct-vectors.tests
-USING: struct-vectors tools.test alien.c-types alien.syntax
+USING: struct-vectors tools.test alien.c-types classes.struct accessors
 namespaces kernel sequences ;
 
-C-STRUCT: point
+STRUCT: point { x float } { y float } ;
-    { "float" "x" }
-    { "float" "y" } ;
 
-: make-point ( x y -- point )
+: make-point ( x y -- point ) point <struct-boa> ;
-    "point" <c-object>
-    [ set-point-y ] keep
-    [ set-point-x ] keep ;
 
-[ ] [ 1 "point" <struct-vector> "v" set ] unit-test
+[ ] [ 1 point <struct-vector> "v" set ] unit-test
 
 [ 1.5 6.0 ] [
     1.0 2.0 make-point "v" get push
     3.0 4.5 make-point "v" get push
     1.5 6.0 make-point "v" get push
-    "v" get pop [ point-x ] [ point-y ] bi
+    "v" get pop [ x>> ] [ y>> ] bi
 ] unit-test

basis/struct-vectors/struct-vectors.factor

@@ -9,10 +9,11 @@ TUPLE: struct-vector
 { length array-capacity }
 { c-type read-only } ;
 
-: <struct-vector> ( capacity c-type -- struct-vector )
+: <struct-vector> ( capacity struct-class -- struct-vector )
     [ <struct-array> 0 ] keep struct-vector boa ; inline
 
 M: struct-vector byte-length underlying>> byte-length ;
+
 M: struct-vector new-sequence
     [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
     struct-vector boa ;

basis/unix/linux/epoll/epoll.factor

@@ -1,16 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: unix.linux.epoll
-USING: alien.syntax math ;
+USING: alien.syntax classes.struct math ;
 
 FUNCTION: int epoll_create ( int size ) ;
 
 FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
 
-C-STRUCT: epoll-event
+STRUCT: epoll-event
-    { "uint" "events" }
+{ events uint }
-    { "uint" "fd" }
+{ fd uint }
-    { "uint" "padding" } ;
+{ padding uint } ;
 
 FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
 

extra/gpu/shaders/shaders-docs.factor

@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff bsd license
 USING: classes classes.struct gpu.buffers help.markup help.syntax
-images kernel math multiline quotations sequences strings ;
+images kernel math multiline quotations sequences strings words ;
 IN: gpu.shaders
 
 HELP: <program-instance>
@@ -86,7 +86,7 @@ HELP: define-vertex-format
 
 HELP: define-vertex-struct
 { $values
-    { "struct-name" string } { "vertex-format" vertex-format }
+    { "class" word } { "vertex-format" vertex-format }
 }
 { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;