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

Makefile

@@ -149,14 +149,11 @@ macosx.app: factor
 	ln -s Factor.app/Contents/MacOS/factor ./factor
 	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
 
-	install_name_tool \
-		-id @executable_path/../Frameworks/libfreetype.6.dylib \
-		Factor.app/Contents/Frameworks/libfreetype.6.dylib
 	install_name_tool \
 		-change libfactor.dylib \
 		@executable_path/../Frameworks/libfactor.dylib \
 		Factor.app/Contents/MacOS/factor
-
+        
 factor: $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \

basis/calendar/calendar-docs.factor

@@ -165,7 +165,15 @@ HELP: milliseconds
 { $values { "x" number } { "duration" duration } }
 { $description "Creates a duration object with the specified number of milliseconds." } ;
 
-{ years months days hours minutes seconds milliseconds } related-words
+HELP: microseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of microseconds." } ;
+
+HELP: nanoseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description "Creates a duration object with the specified number of nanoseconds." } ;
+
+{ years months days hours minutes seconds milliseconds microseconds nanoseconds } related-words
 
 HELP: leap-year?
 { $values { "obj" object } { "?" "a boolean" } }
@@ -263,7 +271,27 @@ HELP: duration>milliseconds
     }
 } ;
 
-{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds } related-words
+HELP: duration>microseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in microseconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 seconds duration>microseconds ."
+               "6000000"
+    }
+} ;
+
+HELP: duration>nanoseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in nanoseconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 seconds duration>nanoseconds ."
+               "6000000000"
+    }
+} ;
+
+{ duration>years duration>months duration>days duration>hours duration>minutes duration>seconds duration>milliseconds duration>microseconds duration>nanoseconds } related-words
 
 
 HELP: time-
@@ -484,6 +512,12 @@ HELP: time-since-midnight
 { $values { "timestamp" timestamp } { "duration" duration } }
 { $description "Calculates a " { $snippet "duration" } " that represents the elapsed time since midnight of the input " { $snippet "timestamp" } "." } ;
 
+HELP: since-1970
+{ $values
+     { "duration" duration }
+     { "timestamp" timestamp } }
+{ $description "Adds the duration to the beginning of Unix time and returns the result as a timestamp." } ;
+
 ARTICLE: "calendar" "Calendar"
 "The two data types used throughout the calendar library:"
 { $subsection timestamp }
@@ -528,6 +562,8 @@ ARTICLE: "using-durations" "Using durations"
 { $subsection minutes }
 { $subsection seconds }
 { $subsection milliseconds }
+{ $subsection microseconds }
+{ $subsection nanoseconds }
 { $subsection instant }
 "Converting a duration to a number:"
 { $subsection duration>years }
@@ -536,7 +572,9 @@ ARTICLE: "using-durations" "Using durations"
 { $subsection duration>hours }
 { $subsection duration>minutes }
 { $subsection duration>seconds }
-{ $subsection duration>milliseconds } ;
+{ $subsection duration>milliseconds }
+{ $subsection duration>microseconds }
+{ $subsection duration>nanoseconds } ;
 
 ARTICLE: "relative-timestamps" "Relative timestamps"
 "In the future:"

basis/calendar/calendar.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.functions namespaces sequences
 strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary
-combinators.short-circuit ;
+locals classes.tuple math.order summary combinators.short-circuit ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -129,6 +128,8 @@ PRIVATE>
 : minutes ( x -- duration ) instant clone swap >>minute ;
 : seconds ( x -- duration ) instant clone swap >>second ;
 : milliseconds ( x -- duration ) 1000 / seconds ;
+: microseconds ( x -- duration ) 1000000 / seconds ;
+: nanoseconds ( x -- duration ) 1000000000 / seconds ;
 
 GENERIC: leap-year? ( obj -- ? )
 
@@ -261,6 +262,8 @@ M: duration <=> [ duration>years ] compare ;
 : duration>minutes ( duration -- x ) duration>years minutes-per-year * ;
 : duration>seconds ( duration -- x ) duration>years seconds-per-year * ;
 : duration>milliseconds ( duration -- x ) duration>seconds 1000 * ;
+: duration>microseconds ( duration -- x ) duration>seconds 1000000 * ;
+: duration>nanoseconds ( duration -- x ) duration>seconds 1000000000 * ;
 
 GENERIC: time- ( time1 time2 -- time3 )
 
@@ -398,6 +401,9 @@ PRIVATE>
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ;
 
+: since-1970 ( duration -- timestamp )
+    unix-1970 time+ >local-time ;
+
 M: timestamp sleep-until timestamp>millis sleep-until ;
 
 M: duration sleep hence sleep-until ;

basis/calendar/unix/unix.factor

@@ -1,7 +1,17 @@
-USING: alien alien.c-types arrays calendar kernel structs
-math unix.time namespaces system ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax arrays calendar
+kernel math unix unix.time namespaces system ;
 IN: calendar.unix
 
+: timeval>unix-time ( timeval -- timestamp )
+    [ timeval-sec seconds ] [ timeval-usec microseconds ] bi
+    time+ since-1970 ;
+
+: timespec>unix-time ( timeval -- timestamp )
+    [ timespec-sec seconds ] [ timespec-nsec nanoseconds ] bi
+    time+ since-1970 ;
+
 : get-time ( -- alien )
     f time <uint> localtime ;
 

basis/cocoa/application/application-docs.factor

@@ -26,6 +26,10 @@ HELP: with-cocoa
 { $values { "quot" quotation } }
 { $description "Sets up an autorelease pool, initializes the " { $snippet "NSApplication" } " singleton, and calls the quotation." } ;
 
+HELP: cocoa-app
+{ $values { "quot" quotation } }
+{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
+
 HELP: do-event
 { $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
 { $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
@@ -46,13 +50,16 @@ HELP: objc-error
 { $error-description "Thrown by the Objective C runtime when an error occurs, for example, sending a message to an object with an unrecognized selector." } ;
 
 ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
+"Utilities:"
 { $subsection NSApp }
-{ $subsection with-autorelease-pool }
-{ $subsection with-cocoa }
 { $subsection do-event }
 { $subsection add-observer }
 { $subsection remove-observer }
-{ $subsection install-delegate } ;
+{ $subsection install-delegate }
+"Combinators:"
+{ $subsection cocoa-app }
+{ $subsection with-autorelease-pool }
+{ $subsection with-cocoa } ;
 
 IN: cocoa.application
 ABOUT: "cocoa-application-utils"

basis/cocoa/application/application.factor

@@ -30,7 +30,7 @@ IN: cocoa.application
 FUNCTION: void NSBeep ( ) ;
 
 : with-cocoa ( quot -- )
-    [ NSApp drop call ] with-autorelease-pool ;
+    [ NSApp drop call ] with-autorelease-pool ; inline
 
 : next-event ( app -- event )
     0 f CFRunLoopDefaultMode 1
@@ -50,6 +50,13 @@ FUNCTION: void NSBeep ( ) ;
 
 : finish-launching ( -- ) NSApp -> finishLaunching ;
 
+: cocoa-app ( quot -- )
+    [
+        call
+        finish-launching
+        NSApp -> run
+    ] with-cocoa ; inline
+
 : install-delegate ( receiver delegate -- )
     -> alloc -> init -> setDelegate: ;
 

basis/cocoa/cocoa-docs.factor

@@ -16,9 +16,16 @@ HELP: SUPER->
 
 { send super-send POSTPONE: -> POSTPONE: SUPER-> } related-words
 
+HELP: IMPORT:
+{ $syntax "IMPORT: name" }
+{ $description "Makes an Objective C class available for use." } 
+{ $examples
+    { $code "IMPORT: QTMovie" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
+} ;
+
 ARTICLE: "objc-calling" "Calling Objective C code"
 "Before an Objective C class can be used, it must be imported; by default, a small set of common classes are imported automatically, but additional classes can be imported as needed."
-{ $subsection import-objc-class }
+{ $subsection POSTPONE: IMPORT: }
 "Every imported Objective C class has as corresponding class word in the " { $vocab-link "cocoa.classes" } " vocabulary. Class words push the class object in the stack, allowing class methods to be invoked."
 $nl
 "Messages can be sent to classes and instances using a pair of parsing words:"

basis/cocoa/cocoa.factor

@@ -3,7 +3,7 @@
 USING: compiler io kernel cocoa.runtime cocoa.subclassing
 cocoa.messages cocoa.types sequences words vocabs parser
 core-foundation namespaces assocs hashtables compiler.units
-lexer ;
+lexer init ;
 IN: cocoa
 
 : (remember-send) ( selector variable -- )
@@ -27,6 +27,16 @@ SYMBOL: super-sent-messages
     scan dup remember-super-send parsed \ super-send parsed ;
     parsing
 
+SYMBOL: frameworks
+
+frameworks global [ V{ } clone or ] change-at
+
+[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+
+: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ; parsing
+
+: IMPORT: scan [ ] import-objc-class ; parsing
+
 "Compiling Objective C bridge..." print
 
 "cocoa.classes" create-vocab drop

basis/cocoa/messages/messages-docs.factor

@@ -32,11 +32,7 @@ HELP: alien>objc-types
 
 HELP: import-objc-class
 { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( -- )" } } }
-{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." }
-{ $notes "In most cases, the quotation should be " { $link f } "." }
-{ $examples
-    { $code "\"QTMovie\" f import-objc-class" "QTMovie \"My Movie.mov\" <NSString> f -> movieWithFile:error:" }
-} ;
+{ $description "If a class named " { $snippet "name" } " is already known to the Objective C interface, does nothing. Otherwise, first calls the quotation. The quotation should make the class available to the Objective C runtime if necessary, either by loading a framework or defining it directly. After the quotation returns, this word makes the class available to Factor programs by importing methods and creating a class word the class object in the " { $vocab-link "cocoa.classes" } " vocabulary." } ;
 
 HELP: root-class
 { $values { "class" alien } { "root" alien } }

basis/cocoa/messages/messages.factor

@@ -4,7 +4,8 @@ USING: accessors alien alien.c-types alien.strings arrays assocs
 combinators compiler kernel math namespaces make parser
 prettyprint prettyprint.sections quotations sequences strings
 words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private ;
+io.encodings.ascii effects compiler.generator libc libc.private
+parser lexer init core-foundation ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )

basis/colors/colors.factor

@@ -1,48 +1,33 @@
-! Copyright (C) 2003, 2007, 2008 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators sequences arrays classes.tuple accessors colors.hsv ;
-
+USING: kernel accessors ;
 IN: colors
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: color ;
 
 TUPLE: rgba < color red green blue alpha ;
 
-TUPLE: hsva < color hue saturation value alpha ;
-
-TUPLE: gray < color gray alpha ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+C: <rgba> rgba
 
 GENERIC: >rgba ( object -- rgba )
 
 M: rgba >rgba ( rgba -- rgba ) ;
 
-M: hsva >rgba ( hsva -- rgba )
-  { [ hue>> ] [ saturation>> ] [ value>> ] [ alpha>> ] } cleave 4array
-  [ hsv>rgb ] [ peek ] bi suffix first4 rgba boa ;
-
-M: gray >rgba ( gray -- rgba ) [ gray>> dup dup ] [ alpha>> ] bi rgba boa ;
-
 M: color red>>   ( color -- red   ) >rgba red>>   ;
 M: color green>> ( color -- green ) >rgba green>> ;
 M: color blue>>  ( color -- blue  ) >rgba blue>>  ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: black        T{ rgba f 0.0   0.0   0.0   1.0  } ;
-: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ;
-: cyan         T{ rgba f 0     0.941 0.941 1    } ;
-: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ;
-: green        T{ rgba f 0.0   1.0   0.0   1.0  } ;
-: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ;
-: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ;
-: magenta      T{ rgba f 0.941 0     0.941 1    } ;
-: orange       T{ rgba f 0.941 0.627 0     1    } ;
-: purple       T{ rgba f 0.627 0     0.941 1    } ;
-: red          T{ rgba f 1.0   0.0   0.0   1.0  } ;
-: white        T{ rgba f 1.0   1.0   1.0   1.0  } ;
-: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ;
+: black        T{ rgba f 0.0   0.0   0.0   1.0  } ; inline
+: blue         T{ rgba f 0.0   0.0   1.0   1.0  } ; inline
+: cyan         T{ rgba f 0     0.941 0.941 1    } ; inline
+: gray         T{ rgba f 0.6   0.6   0.6   1.0  } ; inline
+: green        T{ rgba f 0.0   1.0   0.0   1.0  } ; inline
+: light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ; inline
+: light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ; inline
+: magenta      T{ rgba f 0.941 0     0.941 1    } ; inline
+: orange       T{ rgba f 0.941 0.627 0     1    } ; inline
+: purple       T{ rgba f 0.627 0     0.941 1    } ; inline
+: red          T{ rgba f 1.0   0.0   0.0   1.0  } ; inline
+: white        T{ rgba f 1.0   1.0   1.0   1.0  } ; inline
+: yellow       T{ rgba f 1.0   1.0   0.0   1.0  } ; inline

basis/colors/gray/gray.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors kernel accessors ;
+IN: colors.gray
+
+TUPLE: gray < color gray alpha ;
+
+C: <gray> gray
+
+M: gray >rgba ( gray -- rgba )
+    [ gray>> dup dup ] [ alpha>> ] bi <rgba> ;

basis/colors/hsv/hsv-tests.factor

@@ -0,0 +1,26 @@
+IN: colors.hsv.tests
+USING: accessors kernel colors colors.hsv tools.test math ;
+
+: hsv>rgb ( h s v -- r g b )
+    [ 360 * ] 2dip
+    1 <hsva> >rgba [ red>> ] [ green>> ] [ blue>> ] tri ;
+
+[ 1/2 1/2 1/2 ] [ 0 0 1/2 hsv>rgb ] unit-test
+
+[ 1/2 1/4 1/4 ] [ 0 1/2 1/2 hsv>rgb ] unit-test
+[ 1/3 2/9 2/9 ] [ 0 1/3 1/3 hsv>rgb ] unit-test
+
+[ 24/125 1/5 4/25 ] [ 1/5 1/5 1/5 hsv>rgb ] unit-test
+[ 29/180 1/6 5/36 ] [ 1/5 1/6 1/6 hsv>rgb ] unit-test
+
+[ 6/25 2/5 38/125 ] [ 2/5 2/5 2/5 hsv>rgb ] unit-test
+[ 8/25 4/5 64/125 ] [ 2/5 3/5 4/5 hsv>rgb ] unit-test
+
+[ 6/25 48/125 3/5 ] [ 3/5 3/5 3/5 hsv>rgb ] unit-test
+[ 0 0 0 ] [ 3/5 1/5 0 hsv>rgb ] unit-test
+
+[ 84/125 4/25 4/5 ] [ 4/5 4/5 4/5 hsv>rgb ] unit-test
+[ 7/15 1/3 1/2 ] [ 4/5 1/3 1/2 hsv>rgb ] unit-test
+
+[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
+[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test

basis/colors/hsv/hsv.factor

@@ -1,41 +1,38 @@
-! Copyright (C) 2007 Eduardo Cavazos
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators arrays sequences math math.functions ;
-
+USING: colors kernel combinators math math.functions accessors ;
 IN: colors.hsv
 
-<PRIVATE
-
-: H ( hsv -- H ) first ;
-
-: S ( hsv -- S ) second ;
-
-: V ( hsv -- V ) third ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: Hi ( hsv -- Hi ) H 60 / floor 6 mod ;
-
-: f ( hsv -- f ) [ H 60 / ] [ Hi ] bi - ;
-
-: p ( hsv -- p ) [ S 1 swap - ] [ V ] bi * ;
-
-: q ( hsv -- q ) [ [ f ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-: t ( hsv -- t ) [ [ f 1 swap - ] [ S ] bi * 1 swap - ] [ V ] bi * ;
-
-PRIVATE>
-
 ! h [0,360)
 ! s [0,1]
 ! v [0,1]
+TUPLE: hsva < color hue saturation value alpha ;
 
-: hsv>rgb ( hsv -- rgb )
-dup Hi
-{ { 0 [ [ V ] [ t ] [ p ] tri ] }
-  { 1 [ [ q ] [ V ] [ p ] tri ] }
-  { 2 [ [ p ] [ V ] [ t ] tri ] }
-  { 3 [ [ p ] [ q ] [ V ] tri ] }
-  { 4 [ [ t ] [ p ] [ V ] tri ] }
-  { 5 [ [ V ] [ p ] [ q ] tri ] } } case 3array ;
+C: <hsva> hsva
+
+<PRIVATE
+
+: Hi ( hsv -- Hi ) hue>> 60 / floor 6 mod ; inline
+
+: f ( hsv -- f ) [ hue>> 60 / ] [ Hi ] bi - ; inline
+
+: p ( hsv -- p ) [ saturation>> 1 swap - ] [ value>> ] bi * ; inline
+
+: q ( hsv -- q ) [ [ f ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+: t ( hsv -- t ) [ [ f 1 swap - ] [ saturation>> ] bi * 1 swap - ] [ value>> ] bi * ; inline
+
+PRIVATE>
+
+M: hsva >rgba ( hsva -- rgba )
+    [
+        dup Hi
+        {
+            { 0 [ [ value>> ] [ t ] [ p ] tri ] }
+            { 1 [ [ q ] [ value>> ] [ p ] tri ] }
+            { 2 [ [ p ] [ value>> ] [ t ] tri ] }
+            { 3 [ [ p ] [ q ] [ value>> ] tri ] }
+            { 4 [ [ t ] [ p ] [ value>> ] tri ] }
+            { 5 [ [ value>> ] [ p ] [ q ] tri ] }
+        } case
+    ] [ alpha>> ] bi <rgba> ;

basis/compiler/generator/fixup/fixup.factor

@@ -13,7 +13,7 @@ TUPLE: frame-required n ;
 
 : frame-required ( n -- ) \ frame-required boa , ;
 
-: stack-frame-size ( code -- n )
+: compute-stack-frame-size ( code -- n )
     no-stack-frame [
         dup frame-required? [ n>> max ] [ drop ] if
     ] reduce ;
@@ -37,7 +37,7 @@ M: label fixup*
 
 : if-stack-frame ( frame-size quot -- )
     swap dup no-stack-frame =
-    [ 2drop ] [ stack-frame swap call ] if ; inline
+    [ 2drop ] [ stack-frame-size swap call ] if ; inline
 
 M: word fixup*
     {
@@ -146,7 +146,7 @@ SYMBOL: literal-table
 : fixup ( code -- literals relocation labels code )
     [
         init-fixup
-        dup stack-frame-size swap [ fixup* ] each drop
+        dup compute-stack-frame-size swap [ fixup* ] each drop
 
         literal-table get >array
         relocation-table get >byte-array

basis/compiler/generator/generator.factor

@@ -296,24 +296,20 @@ M: #return-recursive generate-node
 
 : return-size ( ctype -- n )
     #! Amount of space we reserve for a return value.
-    dup large-struct? [ heap-size ] [ drop 0 ] if ;
+    dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
 
 : alien-stack-frame ( params -- n )
-    alien-parameters parameter-sizes drop ;
+    stack-frame new
+        swap
+        [ return>> return-size >>return ]
+        [ alien-parameters parameter-sizes drop >>params ] bi
+        dup [ params>> ] [ return>> ] bi + >>size
+        dup size>> stack-frame-size >>total-size ;
 
-: alien-invoke-frame ( params -- n )
-    #! Two cells for temporary storage, temp@ and on x86.64,
-    #! small struct return value unpacking
-    [ return>> return-size ] [ alien-stack-frame ] bi
-    + 2 cells + ;
-
-: set-stack-frame ( n -- )
-    dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
-    swap set-stack-frame
+: with-stack-frame ( params quot -- )
+    swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
     call
-    f set-stack-frame ; inline
+    stack-frame off ; inline
 
 GENERIC: reg-size ( register-class -- n )
 
@@ -416,8 +412,8 @@ M: long-long-type flatten-value-type ( type -- types )
     #! parameters. If the C function is returning a structure,
     #! the first parameter is an implicit target area pointer,
     #! so we need to use a different offset.
-    return>> dup large-struct?
-    [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
+    return>> large-struct?
+    [ %prepare-box-struct cell ] [ 0 ] if ;
 
 : objects>registers ( params -- )
     #! Generate code for unboxing a list of C types, then
@@ -476,7 +472,7 @@ M: no-such-symbol compiler-error-type
 
 M: #alien-invoke generate-node
     params>>
-    dup alien-invoke-frame [
+    dup [
         end-basic-block
         %prepare-alien-invoke
         dup objects>registers
@@ -490,7 +486,7 @@ M: #alien-invoke generate-node
 ! #alien-indirect
 M: #alien-indirect generate-node
     params>>
-    dup alien-invoke-frame [
+    dup [
         ! Flush registers
         end-basic-block
         ! Save registers for GC
@@ -556,7 +552,7 @@ TUPLE: callback-context ;
 
 : callback-unwind ( params -- n )
     {
-        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+        { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
         { [ dup return>> large-struct? ] [ drop 4 ] }
         [ drop 0 ]
     } cond ;
@@ -572,7 +568,7 @@ TUPLE: callback-context ;
     dup xt>> dup [
         init-templates
         %prologue-later
-        dup alien-stack-frame [
+        dup [
             [ registers>objects ]
             [ wrap-callback-quot %alien-callback ]
             [ %callback-return ]

basis/compiler/tests/optimizer.factor

@@ -362,3 +362,18 @@ TUPLE: some-tuple x ;
 [ B{ 0 1 2 3 4 5 6 7 } ] [ [ 8 [ ] B{ } map-as ] compile-call ] unit-test
 
 [ 0 ] [ 1234 [ { fixnum } declare -64 shift ] compile-call ] unit-test
+
+! Loop detection problem found by doublec
+SYMBOL: counter
+
+DEFER: loop-bbb
+
+: loop-aaa ( -- )
+    counter inc counter get 2 < [ loop-bbb ] when ; inline recursive
+
+: loop-bbb ( -- )
+    [ loop-aaa ] with-scope ; inline recursive
+
+: loop-ccc ( -- ) loop-bbb ;
+
+[ 0 ] [ 0 counter set loop-ccc counter get ] unit-test

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays ;
+float-arrays system ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -590,6 +590,8 @@ MIXIN: empty-mixin
 
 [ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
 
+[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/simple/simple.factor

@@ -76,13 +76,25 @@ M: #declare propagate-before
 : fold-call ( #call word -- )
     [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
 
-: predicate-output-infos ( info class -- info )
+: predicate-output-infos/literal ( info class -- info )
+    [ literal>> ] dip
+    '[ _ _ instance? <literal-info> ]
+    [ drop object-info ]
+    recover ;
+
+: predicate-output-infos/class ( info class -- info )
     [ class>> ] dip {
         { [ 2dup class<= ] [ t <literal-info> ] }
         { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
         [ object-info ]
     } cond 2nip ;
 
+: predicate-output-infos ( info class -- info )
+    over literal?>>
+    [ predicate-output-infos/literal ]
+    [ predicate-output-infos/class ]
+    if ;
+
 : propagate-predicate ( #call word -- infos )
     #! We need to force the caller word to recompile when the class
     #! is redefined, since now we're making assumptions but the

basis/compiler/tree/recursive/recursive-tests.factor

@@ -148,3 +148,27 @@ DEFER: a'
     [ a' ] build-tree analyze-recursive
     \ b' label-is-loop?
 ] unit-test
+
+DEFER: a''
+
+: b'' ( -- )
+    a'' ; inline recursive
+
+: a'' ( -- )
+    b'' a'' ; inline recursive
+
+[ t ] [
+    [ a'' ] build-tree analyze-recursive
+    \ a'' label-is-not-loop?
+] unit-test
+
+: loop-in-non-loop ( x quot: ( i -- ) -- )
+    over 0 > [
+        [ [ 1 - ] dip loop-in-non-loop ] [ call ] 2bi
+    ] [ 2drop ] if ; inline recursive
+
+[ t ] [
+    [ 10 [ [ drop ] each-integer ] loop-in-non-loop ]
+    build-tree analyze-recursive
+    \ (each-integer) label-is-loop?
+] unit-test

basis/compiler/tree/recursive/recursive.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs namespaces accessors sequences deques
+USING: kernel assocs arrays namespaces accessors sequences deques
 search-deques compiler.tree compiler.tree.combinators ;
 IN: compiler.tree.recursive
 
@@ -50,11 +50,10 @@ GENERIC: collect-loop-info* ( tail? node -- )
     loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
-    nip
     [
         [
             label>>
-            [ loop-stack [ swap suffix ] change ]
+            [ swap 2array loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -62,7 +61,7 @@ M: #recursive collect-loop-info*
         [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
-: current-loop-nesting ( label -- labels )
+: current-loop-nesting ( label -- alist )
     loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
@@ -71,7 +70,10 @@ M: #recursive collect-loop-info*
 M: #call-recursive collect-loop-info*
     label>>
     swap [ dup disqualify-loop ] unless
-    dup current-loop-nesting [ loop-calls get push-at ] with each ;
+    dup current-loop-nesting
+    [ keys [ loop-calls get push-at ] with each ]
+    [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
+    bi ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;