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

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

@@ -49,12 +49,11 @@ HELP: c-setter
 { $errors "Throws an error if the type does not exist." } ;
 
 HELP: <c-array>
+{ $deprecated "New code should use " { $link <c-type-array> } " or the " { $vocab-link "specialized-arrays" } " vocabularies." }
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
 { $errors "Throws an error if the type does not exist or the requested size is negative." } ;
 
-{ <c-array> malloc-array } related-words
-
 HELP: <c-object>
 { $values { "type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array suitable for holding a value with the given C type." }
@@ -73,9 +72,10 @@ HELP: byte-array>memory
 
 HELP: malloc-array
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-type-direct-array> } "." }
+{ $notes "The appropriate direct 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-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ;
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
 
 HELP: malloc-object
 { $values { "type" "a C type" } { "alien" alien } }
@@ -89,6 +89,8 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
+{ <c-type-array> <c-type-direct-array> malloc-array } related-words
+
 HELP: box-parameter
 { $values { "n" integer } { "ctype" string } }
 { $description "Generates code for converting a C value stored at  offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }

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

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

basis/alien/complex/complex-tests.factor

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

basis/alien/complex/functor/functor.factor

@@ -1,33 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.c-types math math.functions sequences
-arrays kernel functors vocabs.parser namespaces accessors
-quotations ;
+USING: accessors alien alien.structs alien.c-types classes.struct math
+math.functions sequences arrays kernel functors vocabs.parser
+namespaces quotations ;
 IN: alien.complex.functor
 
 FUNCTOR: define-complex-type ( N T -- )
 
-T-real DEFINES ${T}-real
-T-imaginary DEFINES ${T}-imaginary
-set-T-real DEFINES set-${T}-real
-set-T-imaginary DEFINES set-${T}-imaginary
+T-class DEFINES-CLASS ${T}
 
 <T> DEFINES <${T}>
 *T DEFINES *${T}
 
 WHERE
 
+STRUCT: T-class { real N } { imaginary N } ;
+
 : <T> ( z -- alien )
-    >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
+    >rect T-class <struct-boa> >c-ptr ;
 
 : *T ( alien -- z )
-    [ T-real ] [ T-imaginary ] bi rect> ; inline
+    T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
 
-T current-vocab
-{ { N "real" } { N "imaginary" } }
-define-struct
-
-T c-type
+T-class c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
 number >>boxed-class

basis/classes/struct/struct-docs.factor

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

basis/classes/struct/struct-tests.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien.c-types alien.libraries
+USING: accessors alien alien.c-types alien.libraries
 alien.structs.fields alien.syntax ascii classes.struct combinators
 destructors io.encodings.utf8 io.pathnames io.streams.string
 kernel libc literals math multiline namespaces prettyprint
@@ -63,7 +63,7 @@ UNION-STRUCT: struct-test-float-and-bits
 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
 [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
 
-[ ] [ [ struct-test-foo malloc-struct &free drop ] with-destructors ] unit-test
+[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
 
 STRUCT: struct-test-string-ptr
     { x char* } ;
@@ -203,3 +203,5 @@ STRUCT: struct-test-optimization
 ] unit-test
 
 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+
+[ f ] [ struct-test-foo <struct> dup clone [ >c-ptr ] bi@ eq? ] unit-test

basis/classes/struct/struct.factor

@@ -2,11 +2,11 @@
 USING: accessors alien alien.c-types alien.structs
 alien.structs.fields arrays byte-arrays classes classes.parser
 classes.tuple classes.tuple.parser classes.tuple.private
-combinators combinators.short-circuit combinators.smart fry
-generalizations generic.parser kernel kernel.private lexer
-libc macros make math math.order parser quotations sequences
-slots slots.private struct-arrays vectors words
-compiler.tree.propagation.transforms ;
+combinators combinators.short-circuit combinators.smart
+functors.backend fry generalizations generic.parser kernel
+kernel.private lexer libc locals macros make math math.order parser
+quotations sequences slots slots.private struct-arrays vectors
+words compiler.tree.propagation.transforms ;
 FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
@@ -37,6 +37,8 @@ M: struct equal?
         [ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
     } 2&& ;
 
+: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+
 : memory>struct ( ptr class -- struct )
     [ 1array ] dip slots>tuple ;
 
@@ -44,17 +46,25 @@ M: struct equal?
     dup struct-class? [ '[ _ boa ] ] [ drop f ] if
 ] 1 define-partial-eval
 
-: malloc-struct ( class -- struct )
+M: struct clone
+    [ >c-ptr ] [ byte-length memory>byte-array ] [ class memory>struct ] tri ;
+
+<PRIVATE
+: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
+    '[ dup struct-prototype _ _ ?if ] keep memory>struct ; inline
+PRIVATE>
+
+: (malloc-struct) ( class -- struct )
     [ heap-size malloc ] keep memory>struct ; inline
 
-: (struct) ( class -- struct )
-    [ heap-size <byte-array> ] keep memory>struct ; inline
+: malloc-struct ( class -- struct )
+    [ >c-ptr malloc-byte-array ] [ 1 swap heap-size calloc ] (init-struct) ;
 
-: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
+: (struct) ( class -- struct )
+    [ heap-size (byte-array) ] keep memory>struct ; inline
 
 : <struct> ( class -- struct )
-    dup struct-prototype
-    [ >c-ptr clone swap memory>struct ] [ (struct) ] if* ; inline
+    [ >c-ptr clone ] [ heap-size <byte-array> ] (init-struct) ;
 
 MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
     [
@@ -66,6 +76,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
         ] bi
     ] [ ] output>sequence ;
 
+<PRIVATE
 : pad-struct-slots ( values class -- values' class )
     [ struct-slots [ initial>> ] map over length tail append ] keep ;
 
@@ -82,6 +93,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 
 : (unboxer-quot) ( class -- quot )
     drop [ >c-ptr ] ;
+PRIVATE>
 
 M: struct-class boa>object
     swap pad-struct-slots
@@ -98,6 +110,9 @@ M: struct-class reader-quot
 M: struct-class writer-quot
     nip (writer-quot) ;
 
+! c-types
+
+<PRIVATE
 : struct-slot-values-quot ( class -- quot )
     struct-slots
     [ name>> reader-word 1quotation ] map
@@ -112,8 +127,6 @@ M: struct-class writer-quot
     [ \ byte-length create-method-in ]
     [ heap-size \ drop swap [ ] 2sequence ] bi define ;
 
-! Struct as c-type
-
 : slot>field ( slot -- field )
     field-spec new swap {
         [ name>> >>name ]
@@ -155,6 +168,7 @@ M: struct-class writer-quot
 
 : struct-align ( slots -- align )
     [ c-type>> c-type-align ] [ max ] map-reduce ;
+PRIVATE>
 
 M: struct-class c-type
     name>> c-type ;
@@ -180,6 +194,7 @@ M: struct-class heap-size
 
 ! class definition
 
+<PRIVATE
 : make-struct-prototype ( class -- prototype )
     [ heap-size <byte-array> ]
     [ memory>struct ]
@@ -219,6 +234,7 @@ M: struct-class heap-size
         (struct-word-props)
     ]
     [ drop define-struct-for-class ] 2tri ; inline
+PRIVATE>
 
 : define-struct-class ( class slots -- )
     [ struct-offsets ] (define-struct-class) ;
@@ -228,6 +244,7 @@ M: struct-class heap-size
 
 ERROR: invalid-struct-slot token ;
 
+<PRIVATE
 : struct-slot-class ( c-type -- class' )
     c-type c-type-boxed-class
     dup \ byte-array = [ drop \ c-ptr ] when ;
@@ -250,6 +267,7 @@ ERROR: invalid-struct-slot token ;
 
 : parse-struct-definition ( -- class slots )
     CREATE-CLASS 8 <vector> [ parse-struct-slots ] [ ] while >array ;
+PRIVATE>
 
 SYNTAX: STRUCT:
     parse-struct-definition define-struct-class ;
@@ -259,6 +277,38 @@ SYNTAX: UNION-STRUCT:
 SYNTAX: S{
     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 
+! functor support
+
+<PRIVATE
+: scan-c-type` ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+:: parse-struct-slot` ( accum -- accum )
+    scan-string-param :> name
+    scan-c-type` :> c-type
+    \ } parse-until :> attributes
+    accum {
+        \ struct-slot-spec new 
+            name >>name
+            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
+            attributes [ dup empty? ] [ peel-off-attributes ] until drop
+        over push
+    } over push-all ;
+
+: parse-struct-slots` ( accum -- accum more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot` t ] }
+        [ invalid-struct-slot ]
+    } case ;
+PRIVATE>
+
+FUNCTOR-SYNTAX: STRUCT:
+    scan-param parsed
+    [ 8 <vector> ] over push-all
+    [ parse-struct-slots` ] [ ] while
+    [ >array define-struct-class ] over push-all ;
+
 USING: vocabs vocabs.loader ;
 
 "prettyprint" vocab [ "classes.struct.prettyprint" require ] when

basis/cocoa/enumeration/enumeration.factor

@@ -1,27 +1,28 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cocoa cocoa.types alien.c-types locals math
-sequences vectors fry libc destructors
-specialized-arrays.direct.alien ;
+USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
+locals math sequences vectors fry libc destructors ;
 IN: cocoa.enumeration
 
+<< "id" require-c-type-arrays >>
+
 CONSTANT: NS-EACH-BUFFER-SIZE 16
 
 : with-enumeration-buffers ( quot -- )
     '[
-        "NSFastEnumerationState" malloc-object &free
+        NSFastEnumerationState malloc-struct &free
         NS-EACH-BUFFER-SIZE "id" malloc-array &free
         NS-EACH-BUFFER-SIZE
         @
     ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
-    object state stackbuf count -> countByEnumeratingWithState:objects:count:
-    dup 0 = [ drop ] [
-        state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
-        swap <direct-void*-array> quot each
+    object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
+    items-count 0 = [
+        state itemsPtr>> [ items-count "id" <c-type-direct-array> ] [ stackbuf ] if* :> items
+        items-count iota [ items nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
-    ] if ; inline recursive
+    ] unless ; inline recursive
 
 : NSFastEnumeration-each ( object quot -- )
     [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline

basis/cocoa/messages/messages.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-continuations combinators compiler compiler.alien stack-checker kernel
-math namespaces make quotations sequences strings words
-cocoa.runtime io macros memoize io.encodings.utf8 effects libc
-libc.private lexer init core-foundation fry generalizations
-specialized-arrays.direct.alien ;
+classes.struct continuations combinators compiler compiler.alien
+stack-checker kernel math namespaces make quotations sequences
+strings words cocoa.runtime io macros memoize io.encodings.utf8
+effects libc libc.private lexer init core-foundation fry
+generalizations specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize
     bi ;
 
 : <super> ( receiver -- super )
-    "objc-super" <c-object> [
-        [ dup object_getClass class_getSuperclass ] dip
-        set-objc-super-class
-    ] keep
-    [ set-objc-super-receiver ] keep ;
+    [ ] [ object_getClass class_getSuperclass ] bi
+    objc-super <struct-boa> ;
 
 TUPLE: selector name object ;
 

basis/cocoa/runtime/runtime.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
 IN: cocoa.runtime
 
 TYPEDEF: void* SEL
@@ -17,9 +17,9 @@ TYPEDEF: void* Class
 TYPEDEF: void* Method
 TYPEDEF: void* Protocol
 
-C-STRUCT: objc-super
-    { "id" "receiver" }
-    { "Class" "class" } ;
+STRUCT: objc-super
+    { receiver id }
+    { class Class } ;
 
 CONSTANT: CLS_CLASS        HEX: 1
 CONSTANT: CLS_META         HEX: 2

basis/cocoa/types/types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax combinators kernel layouts
-core-graphics.types ;
+classes.struct core-graphics.types ;
 IN: cocoa.types
 
 TYPEDEF: long NSInteger
@@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize
 TYPEDEF: CGRect NSRect
 TYPEDEF: NSRect _NSRect
 
-C-STRUCT: NSRange
-    { "NSUInteger" "location" }
-    { "NSUInteger" "length" } ;
+STRUCT: NSRange
+    { location NSUInteger }
+    { length NSUInteger } ;
 
 TYPEDEF: NSRange _NSRange
 
@@ -27,13 +27,11 @@ TYPEDEF: int long32
 TYPEDEF: uint ulong32
 TYPEDEF: void* unknown_type
 
-: <NSRange> ( length location -- size )
-    "NSRange" <c-object>
-    [ set-NSRange-length ] keep
-    [ set-NSRange-location ] keep ;
+: <NSRange> ( location length -- size )
+    NSRange <struct-boa> ;
 
-C-STRUCT: NSFastEnumerationState
-    { "ulong" "state" }
-    { "id*" "itemsPtr" }
-    { "ulong*" "mutationsPtr" }
-    { "ulong[5]" "extra" } ;
+STRUCT: NSFastEnumerationState
+    { state ulong }
+    { itemsPtr id* }
+    { mutationsPtr ulong* }
+    { extra ulong[5] } ;

basis/cocoa/views/views.factor

@@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222
 : mouse-location ( view event -- loc )
     [
         -> locationInWindow f -> convertPoint:fromView:
-        [ CGPoint-x ] [ CGPoint-y ] bi
+        [ x>> ] [ y>> ] bi
     ] [ drop -> frame CGRect-h ] 2bi
     swap - [ >integer ] bi@ 2array ;

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

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

basis/compiler/cfg/def-use/def-use.factor

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

basis/compiler/cfg/hats/hats.factor

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

basis/compiler/cfg/instructions/instructions.factor

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

basis/compiler/cfg/intrinsics/float/float.factor

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

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -108,6 +108,27 @@ IN: compiler.cfg.intrinsics
         math.floats.private:float-max
     } 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 ( -- )
     {
         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-max [ drop [ ^^max-float ] emit-float-op ] }
         { \ 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:set-slot [ emit-set-slot ] }
         { \ strings.private:string-nth [ drop emit-string-nth ] }

basis/compiler/cfg/linear-scan/allocation/allocation.factor

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

basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor

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

basis/compiler/cfg/linear-scan/allocation/state/state.factor

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

basis/compiler/cfg/linear-scan/assignment/assignment.factor

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

basis/compiler/cfg/linear-scan/debugger/debugger.factor

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

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

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

basis/compiler/cfg/renaming/functor/functor.factor

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

basis/compiler/cfg/representations/preferred/preferred.factor

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

basis/compiler/cfg/value-numbering/expressions/expressions.factor

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

basis/compiler/codegen/codegen.factor

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

basis/compiler/tests/codegen.factor

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

basis/compiler/tests/intrinsics.factor

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

basis/core-foundation/core-foundation.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
+USING: alien.syntax alien.c-types alien.destructors accessors classes.struct kernel ;
 IN: core-foundation
 
 TYPEDEF: void* CFTypeRef
@@ -20,17 +20,15 @@ TYPEDEF: void* CFUUIDRef
 ALIAS: <CFIndex> <long>
 ALIAS: *CFIndex *long
 
-C-STRUCT: CFRange
-{ "CFIndex" "location" }
-{ "CFIndex" "length" } ;
+STRUCT: CFRange
+    { location CFIndex }
+    { length CFIndex } ;
 
 : <CFRange> ( location length -- range )
-    "CFRange" <c-object>
-    [ set-CFRange-length ] keep
-    [ set-CFRange-location ] keep ;
+    CFRange <struct-boa> ;
 
 FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
 
 FUNCTION: void CFRelease ( CFTypeRef cf ) ;
 
-DESTRUCTOR: CFRelease
+DESTRUCTOR: CFRelease

basis/core-foundation/fsevents/fsevents.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types alien.strings alien.syntax kernel
 math sequences namespaces make assocs init accessors
 continuations combinators io.encodings.utf8 destructors locals
-arrays specialized-arrays.direct.alien
+arrays specialized-arrays.direct.alien classes.struct
 specialized-arrays.direct.int specialized-arrays.direct.longlong
 core-foundation core-foundation.run-loop core-foundation.strings
 core-foundation.time ;
@@ -26,12 +26,12 @@ TYPEDEF: int FSEventStreamEventFlags
 TYPEDEF: longlong FSEventStreamEventId
 TYPEDEF: void* FSEventStreamRef
 
-C-STRUCT: FSEventStreamContext
-    { "CFIndex" "version" }
-    { "void*" "info" }
-    { "void*" "retain" }
-    { "void*" "release" }
-    { "void*" "copyDescription" } ;
+STRUCT: FSEventStreamContext
+    { version CFIndex }
+    { info void* }
+    { retain void* }
+    { release void* }
+    { copyDescription void* } ;
 
 ! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
 TYPEDEF: void* FSEventStreamCallback
@@ -104,8 +104,8 @@ FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ;
 FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ;
 
 : make-FSEventStreamContext ( info -- alien )
-    "FSEventStreamContext" <c-object>
-    [ set-FSEventStreamContext-info ] keep ;
+    FSEventStreamContext <struct>
+        swap >>info ;
 
 :: <FSEventStream> ( callback info paths latency flags -- event-stream )
     f ! allocator

basis/core-graphics/types/types.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel layouts
+USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
 math math.rectangles arrays ;
 IN: core-graphics.types
 
@@ -12,63 +12,56 @@ IN: core-graphics.types
 : *CGFloat ( alien -- x )
     cell 4 = [ *float ] [ *double ] if ; inline
 
-C-STRUCT: CGPoint
-    { "CGFloat" "x" }
-    { "CGFloat" "y" } ;
+STRUCT: CGPoint
+    { x CGFloat }
+    { y CGFloat } ;
 
 : <CGPoint> ( x y -- point )
-    "CGPoint" <c-object>
-    [ set-CGPoint-y ] keep
-    [ set-CGPoint-x ] keep ;
+    CGPoint <struct-boa> ;
 
-C-STRUCT: CGSize
-    { "CGFloat" "w" }
-    { "CGFloat" "h" } ;
+STRUCT: CGSize
+    { w CGFloat }
+    { h CGFloat } ;
 
 : <CGSize> ( w h -- size )
-    "CGSize" <c-object>
-    [ set-CGSize-h ] keep
-    [ set-CGSize-w ] keep ;
+    CGSize <struct-boa> ;
 
-C-STRUCT: CGRect
-    { "CGPoint" "origin" }
-    { "CGSize"  "size"   } ;
+STRUCT: CGRect
+    { origin CGPoint }
+    { size   CGSize  } ;
 
 : CGPoint>loc ( CGPoint -- loc )
-    [ CGPoint-x ] [ CGPoint-y ] bi 2array ;
+    [ x>> ] [ y>> ] bi 2array ;
 
 : CGSize>dim ( CGSize -- dim )
-    [ CGSize-w ] [ CGSize-h ] bi 2array ;
+    [ w>> ] [ h>> ] bi 2array ;
 
 : CGRect>rect ( CGRect -- rect )
-    [ CGRect-origin CGPoint>loc ]
-    [ CGRect-size CGSize>dim ]
+    [ origin>> CGPoint>loc ]
+    [ size>>   CGSize>dim ]
     bi <rect> ; inline
 
 : CGRect-x ( CGRect -- x )
-    CGRect-origin CGPoint-x ; inline
+    origin>> x>> ; inline
 : CGRect-y ( CGRect -- y )
-    CGRect-origin CGPoint-y ; inline
+    origin>> y>> ; inline
 : CGRect-w ( CGRect -- w )
-    CGRect-size CGSize-w ; inline
+    size>> w>> ; inline
 : CGRect-h ( CGRect -- h )
-    CGRect-size CGSize-h ; inline
+    size>> h>> ; inline
 
 : set-CGRect-x ( x CGRect -- )
-    CGRect-origin set-CGPoint-x ; inline
+    origin>> (>>x) ; inline
 : set-CGRect-y ( y CGRect -- )
-    CGRect-origin set-CGPoint-y ; inline
+    origin>> (>>y) ; inline
 : set-CGRect-w ( w CGRect -- )
-    CGRect-size set-CGSize-w ; inline
+    size>> (>>w) ; inline
 : set-CGRect-h ( h CGRect -- )
-    CGRect-size set-CGSize-h ; inline
+    size>> (>>h) ; inline
 
 : <CGRect> ( x y w h -- rect )
-    "CGRect" <c-object>
-    [ set-CGRect-h ] keep
-    [ set-CGRect-w ] keep
-    [ set-CGRect-y ] keep
-    [ set-CGRect-x ] keep ;
+    [ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*
+    CGRect <struct-boa> ;
 
 : CGRect-x-y ( alien -- origin-x origin-y )
     [ CGRect-x ] [ CGRect-y ] bi ;
@@ -76,13 +69,13 @@ C-STRUCT: CGRect
 : CGRect-top-left ( alien -- x y )
     [ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ;
 
-C-STRUCT: CGAffineTransform
-    { "CGFloat" "a" }
-    { "CGFloat" "b" }
-    { "CGFloat" "c" }
-    { "CGFloat" "d" }
-    { "CGFloat" "tx" }
-    { "CGFloat" "ty" } ;
+STRUCT: CGAffineTransform
+    { a CGFloat }
+    { b CGFloat }
+    { c CGFloat }
+    { d CGFloat }
+    { tx CGFloat }
+    { ty CGFloat } ;
 
 TYPEDEF: void* CGColorRef
 TYPEDEF: void* CGColorSpaceRef

basis/core-text/core-text.factor

@@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ;
                 line [ string open-font font foreground>> <CTLine> |CFRelease ]
 
                 rect [ line line-rect ]
-                (loc) [ rect CGRect-origin CGPoint>loc ]
-                (dim) [ rect CGRect-size CGSize>dim ]
+                (loc) [ rect origin>> CGPoint>loc ]
+                (dim) [ rect size>> CGSize>dim ]
                 (ext) [ (loc) (dim) v+ ]
                 loc [ (loc) [ floor ] map ]
                 ext [ (loc) (dim) [ + ceiling ] 2map ]

basis/cpu/architecture/architecture.factor

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

basis/cpu/ppc/ppc.factor

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

basis/cpu/x86/64/64.factor

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

basis/cpu/x86/x86.factor

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

basis/functors/backend/backend.factor

@@ -0,0 +1,33 @@
+USING: accessors arrays assocs generic.standard kernel
+lexer locals.types namespaces parser quotations vocabs.parser
+words ;
+IN: functors.backend
+
+DEFER: functor-words
+\ functor-words [ H{ } clone ] initialize
+
+SYNTAX: FUNCTOR-SYNTAX:
+    scan-word
+    gensym [ parse-definition define-syntax ] keep
+    swap name>> \ functor-words get-global set-at ;
+
+: functor-words ( -- assoc )
+    \ functor-words get-global ;
+
+: scan-param ( -- obj ) scan-object literalize ;
+
+: >string-param ( string -- string/param )
+    dup search dup lexical? [ nip ] [ drop ] if ;
+
+: scan-string-param ( -- name/param )
+    scan >string-param ;
+
+: scan-c-type-param ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+: define* ( word def -- ) over set-word define ;
+
+: define-declared* ( word def effect -- ) pick set-word define-declared ;
+
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+

basis/functors/functors-tests.factor

@@ -1,5 +1,5 @@
-USING: functors tools.test math words kernel multiline parser
-io.streams.string generic ;
+USING: classes.struct functors tools.test math words kernel
+multiline parser io.streams.string generic ;
 IN: functors.tests
 
 <<
@@ -151,3 +151,64 @@ SYMBOL: W-symbol
 
 test-redefinition
 
+<<
+
+FUNCTOR: define-a-struct ( T NAME TYPE N -- )
+
+T-class DEFINES-CLASS ${T}
+
+WHERE
+
+STRUCT: T-class
+    { NAME int }
+    { x { TYPE 4 } }
+    { y { "short" N } }
+    { z TYPE initial: 5 }
+    { float { "float" 2 } } ;
+
+;FUNCTOR
+
+"a-struct" "nemo" "char" 2 define-a-struct
+
+>>
+
+[
+    {
+        T{ struct-slot-spec
+            { name "nemo" }
+            { offset 0 }
+            { class integer }
+            { initial 0 } 
+            { c-type "int" }
+        }
+        T{ struct-slot-spec
+            { name "x" }
+            { offset 4 }
+            { class object }
+            { initial f } 
+            { c-type { "char" 4 } }
+        }
+        T{ struct-slot-spec
+            { name "y" }
+            { offset 8 }
+            { class object }
+            { initial f } 
+            { c-type { "short" 2 } }
+        }
+        T{ struct-slot-spec
+            { name "z" }
+            { offset 12 }
+            { class fixnum }
+            { initial 5 } 
+            { c-type "char" }
+        }
+        T{ struct-slot-spec
+            { name "float" }
+            { offset 16 }
+            { class object }
+            { initial f } 
+            { c-type { "float" 2 } }
+        }
+    }
+] [ a-struct struct-slots ] unit-test
+

basis/functors/functors.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.mixin classes.parser
 classes.singleton classes.tuple classes.tuple.parser
-combinators effects.parser fry generic generic.parser
-generic.standard interpolate io.streams.string kernel lexer
+combinators effects.parser fry functors.backend generic
+generic.parser interpolate io.streams.string kernel lexer
 locals.parser locals.types macros make namespaces parser
 quotations sequences vocabs.parser words words.symbol ;
 IN: functors
@@ -12,14 +12,6 @@ IN: functors
 
 <PRIVATE
 
-: scan-param ( -- obj ) scan-object literalize ;
-
-: define* ( word def -- ) over set-word define ;
-
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
-
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
-
 TUPLE: fake-call-next-method ;
 
 TUPLE: fake-quotation seq ;
@@ -58,7 +50,7 @@ M: object (fake-quotations>) , ;
     [ parse-definition* ] dip
     parsed ;
 
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
@@ -71,60 +63,60 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
-SYNTAX: `SINGLETON:
+FUNCTOR-SYNTAX: SINGLETON:
     scan-param parsed
     \ define-singleton-class parsed ;
 
-SYNTAX: `MIXIN:
+FUNCTOR-SYNTAX: MIXIN:
     scan-param parsed
     \ define-mixin-class parsed ;
 
-SYNTAX: `M:
+FUNCTOR-SYNTAX: M:
     scan-param parsed
     scan-param parsed
     [ create-method-in dup method-body set ] over push-all
     parse-definition*
     \ define* parsed ;
 
-SYNTAX: `C:
+FUNCTOR-SYNTAX: C:
     scan-param parsed
     scan-param parsed
     complete-effect
     [ [ [ boa ] curry ] over push-all ] dip parsed
     \ define-declared* parsed ;
 
-SYNTAX: `:
+FUNCTOR-SYNTAX: :
     scan-param parsed
     parse-declared*
     \ define-declared* parsed ;
 
-SYNTAX: `SYMBOL:
+FUNCTOR-SYNTAX: SYMBOL:
     scan-param parsed
     \ define-symbol parsed ;
 
-SYNTAX: `SYNTAX:
+FUNCTOR-SYNTAX: SYNTAX:
     scan-param parsed
     parse-definition*
     \ define-syntax parsed ;
 
-SYNTAX: `INSTANCE:
+FUNCTOR-SYNTAX: INSTANCE:
     scan-param parsed
     scan-param parsed
     \ add-mixin-instance parsed ;
 
-SYNTAX: `GENERIC:
+FUNCTOR-SYNTAX: GENERIC:
     scan-param parsed
     complete-effect parsed
     \ define-simple-generic* parsed ;
 
-SYNTAX: `MACRO:
+FUNCTOR-SYNTAX: MACRO:
     scan-param parsed
     parse-declared*
     \ define-macro parsed ;
 
-SYNTAX: `inline [ word make-inline ] over push-all ;
+FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
 
-SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
+FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
 
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
@@ -144,23 +136,6 @@ DEFER: ;FUNCTOR delimiter
 
 <PRIVATE
 
-: functor-words ( -- assoc )
-    H{
-        { "TUPLE:" POSTPONE: `TUPLE: }
-        { "SINGLETON:" POSTPONE: `SINGLETON: }
-        { "MIXIN:" POSTPONE: `MIXIN: }
-        { "M:" POSTPONE: `M: }
-        { "C:" POSTPONE: `C: }
-        { ":" POSTPONE: `: }
-        { "GENERIC:" POSTPONE: `GENERIC: }
-        { "INSTANCE:" POSTPONE: `INSTANCE: }
-        { "SYNTAX:" POSTPONE: `SYNTAX: }
-        { "SYMBOL:" POSTPONE: `SYMBOL: }
-        { "inline" POSTPONE: `inline }
-        { "MACRO:" POSTPONE: `MACRO: }
-        { "call-next-method" POSTPONE: `call-next-method }
-    } ;
-
 : push-functor-words ( -- )
     functor-words use-words ;
 

basis/images/jpeg/jpeg.factor

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

basis/math/libm/libm.factor

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

basis/math/matrices/matrices-tests.factor

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

basis/math/matrices/matrices.factor

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

basis/math/primes/primes.factor

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

basis/specialized-arrays/functor/functor.factor

@@ -13,6 +13,9 @@ M: bad-byte-array-length summary
 : (c-array) ( n c-type -- array )
     heap-size * (byte-array) ; inline
 
+: <c-array> ( n type -- array )
+    heap-size * <byte-array> ; inline
+
 FUNCTOR: define-array ( T -- )
 
 A            DEFINES-CLASS ${T}-array

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

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

basis/tools/deprecation/deprecation.factor

@@ -1,5 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays assocs compiler.units debugger init io
+USING: accessors arrays assocs combinators.short-circuit
+compiler.units debugger init io
 io.streams.null kernel namespaces prettyprint sequences
 source-files.errors summary tools.crossref
 tools.crossref.private tools.errors words ;
@@ -41,7 +42,7 @@ T{ error-type
 
 : check-deprecations ( usage -- )
     dup word? [
-        dup "forgotten" word-prop
+        dup { [ "forgotten" word-prop ] [ deprecated? ] } 1||
         [ clear-deprecation-note ] [
             dup def>> uses [ deprecated? ] filter
             [ clear-deprecation-note ] [ >array deprecation-note ] if-empty

basis/tools/disassembler/udis/udis.factor

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

basis/tools/disassembler/utils/utils.factor

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

core/sequences/sequences.factor

@@ -98,9 +98,9 @@ M: f like drop [ f ] when-empty ; inline
 
 INSTANCE: f immutable-sequence
 
-! Integers support the sequence protocol
-M: integer length ; inline
-M: integer nth-unsafe drop ; inline
+! Integers used to support the sequence protocol
+M: integer length ; inline deprecated
+M: integer nth-unsafe drop ; inline deprecated
 
 INSTANCE: integer immutable-sequence
 

extra/benchmark/struct-arrays/struct-arrays.factor

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

extra/benchmark/terrain-generation/terrain-generation.factor

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