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

basis/checksums/common/common.factor

@@ -18,4 +18,4 @@ SYMBOL: bytes-read
     ] "" make 64 group ;
 
 : update-old-new ( old new -- )
-    [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
+    [ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

basis/checksums/md5/md5.factor

@@ -14,7 +14,7 @@ IN: checksums.md5
 SYMBOLS: a b c d old-a old-b old-c old-d ;
 
 : T ( N -- Y )
-    sin abs 4294967296 * >bignum ; foldable
+    sin abs 4294967296 * >integer ; foldable
 
 : initialize-md5 ( -- )
     0 bytes-read set

basis/combinators/short-circuit/short-circuit.factor

@@ -3,9 +3,13 @@ locals generalizations macros fry ;
 IN: combinators.short-circuit
 
 MACRO:: n&& ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
+        n
-    [ n nnip ] suffix 1array
+        [ q '[ drop _ ndup @ dup not ] ]
+        [ '[ drop _ ndrop f ] ]
+        bi 2array
+    ] map
+    n '[ _ nnip ] suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
@@ -14,10 +18,13 @@ MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
 MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
 
 MACRO:: n|| ( quots n -- quot )
-    [ f ]
+    [ f ] quots [| q |
-    quots
+        n
-    [| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
+        [ q '[ drop _ ndup @ dup ] ]
-    { [ drop n ndrop t ] [ f ] } suffix 1array
+        [ '[ _ nnip ] ]
+        bi 2array
+    ] map
+    n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
     [ cond ] 3append ;
 
 MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;

basis/locals/locals-tests.factor

@@ -418,6 +418,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
 [ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
 
+[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
+[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
+
+:: FAILdog-1 ( -- b ) { [| c | c ] } ;
+
+\ FAILdog-1 must-infer
+
+:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
+
+\ FAILdog-2 must-infer
+
+[ 3 ] [ 3 [| a | \ a ] call ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]

basis/locals/locals.factor

@@ -206,6 +206,8 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
 
 M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
 
+M: wrapper rewrite-literal? drop t ;
+
 M: hashtable rewrite-literal? drop t ;
 
 M: vector rewrite-literal? drop t ;
@@ -235,12 +237,17 @@ M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 M: tuple rewrite-element
     [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
 
+M: lambda rewrite-element local-rewrite* ;
+
 M: local rewrite-element , ;
 
 M: local-reader rewrite-element , ;
 
 M: word rewrite-element literalize , ;
 
+M: wrapper rewrite-element
+    dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
+
 M: object rewrite-element , ;
 
 M: array local-rewrite* rewrite-element ;
@@ -251,8 +258,10 @@ M: tuple local-rewrite* rewrite-element ;
 
 M: hashtable local-rewrite* rewrite-element ;
 
+M: wrapper local-rewrite* rewrite-element ;
+
 M: word local-rewrite*
-    dup { >r r> } memq?
+    dup { >r r> load-locals get-local drop-locals } memq?
     [ >r/r>-in-lambda-error ] [ call-next-method ] if ;
 
 M: object lambda-rewrite* , ;
@@ -350,10 +359,15 @@ M: wlet local-rewrite*
     word [ over "declared-effect" set-word-prop ] when*
     in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
 
+ERROR: bad-lambda-rewrite output ;
+
+M: bad-lambda-rewrite summary
+    drop "You have found a bug in locals. Please report." ;
+
 : parse-locals-definition ( word -- word quot )
     "(" expect parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
-    lambda-rewrite first ;
+    lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ;
 
 : (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
 

basis/math/bitwise/bitwise.factor

@@ -23,17 +23,12 @@ IN: math.bitwise
 
 : bitroll ( x s w -- y )
     [ wrap ] keep
-    [ shift-mod ]
+    [ shift-mod ] [ [ - ] keep shift-mod ] 3bi bitor ; inline
-    [ [ - ] keep shift-mod ] 3bi bitor ; inline
 
 : bitroll-32 ( n s -- n' ) 32 bitroll ; inline
 
-HINTS: bitroll-32 bignum fixnum ;
-
 : bitroll-64 ( n s -- n' ) 64 bitroll ; inline
 
-HINTS: bitroll-64 bignum fixnum ;
-
 ! 32-bit arithmetic
 : w+ ( int int -- int ) + 32 bits ; inline
 : w- ( int int -- int ) - 32 bits ; inline

basis/opengl/opengl.factor

@@ -71,18 +71,22 @@ MACRO: all-enabled-client-state ( seq quot -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
 
 : (rect-vertices) ( dim -- vertices )
+    #! We use GL_LINE_STRIP with a duplicated first vertex
+    #! instead of GL_LINE_LOOP to work around a bug in Apple's
+    #! X3100 driver.
     {
         [ drop 0.5 0.5 ]
         [ first 0.3 - 0.5 ]
         [ [ first 0.3 - ] [ second 0.3 - ] bi ]
         [ second 0.3 - 0.5 swap ]
-    } cleave 8 narray >c-float-array ;
+        [ drop 0.5 0.5 ]
+    } cleave 10 narray >c-float-array ;
 
 : rect-vertices ( dim -- )
     (rect-vertices) gl-vertex-pointer ;
 
 : (gl-rect) ( -- )
-    GL_LINE_LOOP 0 4 glDrawArrays ;
+    GL_LINE_STRIP 0 5 glDrawArrays ;
 
 : gl-rect ( dim -- )
     rect-vertices (gl-rect) ;
@@ -119,7 +123,16 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : circle-points ( loc dim steps -- points )
     circle-steps unit-circle adjust-points scale-points ;
 
+: close-path ( points -- points' )
+    dup first suffix ;
+
 : circle-vertices ( loc dim steps -- vertices )
+    #! We use GL_LINE_STRIP with a duplicated first vertex
+    #! instead of GL_LINE_LOOP to work around a bug in Apple's
+    #! X3100 driver.
+    circle-points close-path concat >c-float-array ;
+
+: fill-circle-vertices ( loc dim steps -- vertices )
     circle-points concat >c-float-array ;
 
 : (gen-gl-object) ( quot -- id )

basis/ui/gadgets/buttons/buttons.factor

@@ -177,7 +177,7 @@ PRIVATE>
 
 M: radio-paint recompute-pen
     swap dim>>
-    [ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
+    [ { 4 4 } swap { 9 9 } v- circle-steps fill-circle-vertices >>interior-vertices ]
     [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
     drop ;
 
@@ -194,7 +194,7 @@ M: radio-paint draw-interior
 
 M: radio-paint draw-boundary
     [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
-    GL_LINE_LOOP 0 circle-steps glDrawArrays ;
+    GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
 
 :: radio-knob-theme ( gadget -- gadget )
     [let | radio-paint [ black <radio-paint> ] |

basis/ui/gadgets/editors/editors.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays documents io kernel math models
-namespaces make opengl opengl.gl sequences strings io.styles
+namespaces locals fry make opengl opengl.gl sequences strings
-math.vectors sorting colors combinators assocs math.order fry
+io.styles math.vectors sorting colors combinators assocs
-calendar alarms ui.clipboards ui.commands ui.gadgets
+math.order fry calendar alarms ui.clipboards ui.commands
-ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
+ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
+ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
-ui.render ui.gestures math.geometry.rect ;
+ui.gadgets.wrappers ui.render ui.gestures math.geometry.rect ;
 IN: ui.gadgets.editors
 
 TUPLE: editor < gadget
@@ -104,14 +104,20 @@ M: editor ungraft*
     editor-font* "" string-height ;
 
 : y>line ( y editor -- line# )
-    [ line-height / >fixnum ] keep model>> validate-line ;
+    line-height / >fixnum ;
 
-: point>loc ( point editor -- loc )
+:: point>loc ( point editor -- loc )
-    [
+    point second editor y>line {
-        [ first2 ] dip tuck y>line dup ,
+        { [ dup 0 < ] [ drop { 0 0 } ] }
-        [ dup editor-font* ] dip
+        { [ dup editor model>> last-line# > ] [ drop editor model>> doc-end ] }
-        rot editor-line x>offset ,
+        [| n |
-    ] { } make ;
+            n
+            point first
+            editor editor-font*
+            n editor editor-line
+            x>offset 2array
+        ]
+    } cond ;
 
 : clicked-loc ( editor -- loc )
     [ hand-rel ] keep point>loc ;
@@ -141,8 +147,8 @@ M: editor ungraft*
     line-height * ;
 
 : caret-loc ( editor -- loc )
-    [ editor-caret* ] keep 2dup loc>x
+    [ editor-caret* ] keep
-    rot first rot line>y 2array ;
+    [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
 
 : caret-dim ( editor -- dim )
     line-height 0 swap 2array ;
@@ -175,12 +181,16 @@ M: editor ungraft*
     [ font>> ] dip { 0 0 } draw-string ;
 
 : first-visible-line ( editor -- n )
-    clip get rect-loc second origin get second -
+    [
-    swap y>line ;
+        [ clip get rect-loc second origin get second - ] dip
+        y>line
+    ] keep model>> validate-line ;
 
 : last-visible-line ( editor -- n )
-    clip get rect-extent nip second origin get second -
+    [
-    swap y>line 1+ ;
+        [ clip get rect-extent nip second origin get second - ] dip
+        y>line
+    ] keep model>> validate-line 1+ ;
 
 : with-editor ( editor quot -- )
     [
@@ -193,9 +203,8 @@ M: editor ungraft*
     ] with-scope ; inline
 
 : visible-lines ( editor -- seq )
-    \ first-visible-line get
+    [ \ first-visible-line get \ last-visible-line get ] dip
-    \ last-visible-line get
+    control-value <slice> ;
-    rot control-value <slice> ;
 
 : with-editor-translation ( n quot -- )
     [ line-translation origin get v+ ] dip with-translation ;
@@ -313,9 +322,9 @@ M: editor gadget-text* editor-string % ;
 : editor-cut ( editor clipboard -- )
     dupd gadget-copy remove-selection ;
 
-: delete/backspace ( elt editor quot -- )
+: delete/backspace ( editor quot -- )
     over gadget-selection? [
-        drop nip remove-selection
+        drop remove-selection
     ] [
         [ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
         [ drop model>> ]
@@ -323,19 +332,19 @@ M: editor gadget-text* editor-string % ;
     ] if ; inline
 
 : editor-delete ( editor elt -- )
-    swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
+    '[ dupd _ next-elt ] delete/backspace ;
 
 : editor-backspace ( editor elt -- )
-    swap [ over [ rot prev-elt ] dip ] delete/backspace ;
+    '[ over [ _ prev-elt ] dip ] delete/backspace ;
 
 : editor-select-prev ( editor elt -- )
-    swap [ rot prev-elt ] change-caret ;
+    '[ _ prev-elt ] change-caret ;
 
 : editor-prev ( editor elt -- )
     dupd editor-select-prev mark>caret ;
 
 : editor-select-next ( editor elt -- )
-    swap [ rot next-elt ] change-caret ;
+    '[ _ next-elt ] change-caret ;
 
 : editor-next ( editor elt -- )
     dupd editor-select-next mark>caret ;

basis/ui/gadgets/frames/frames-tests.factor

@@ -1,4 +1,17 @@
+USING: accessors kernel namespaces tools.test ui.gadgets
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.labels ;
 IN: ui.gadgets.frames.tests
-USING: ui.gadgets.frames ui.gadgets tools.test ;
 
 [ ] [ <frame> layout ] unit-test
+
+[ t ] [
+    <frame>
+        "Hello world" <label> @top grid-add
+        "Hello world" <label> @center grid-add
+        dup pref-dim "dim1" set
+        { 1000 1000 } >>dim
+        dup layout*
+        dup pref-dim "dim2" set
+        drop
+    "dim1" get "dim2" get =
+] unit-test

basis/ui/gadgets/frames/frames.factor

@@ -1,15 +1,17 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generic kernel math namespaces sequences words
+USING: accessors arrays generic kernel math namespaces sequences
-splitting grouping math.vectors ui.gadgets.grids ui.gadgets
+words splitting grouping math.vectors ui.gadgets.grids
-math.geometry.rect ;
+ui.gadgets math.geometry.rect ;
 IN: ui.gadgets.frames
 
-! A frame arranges gadgets in a 3x3 grid, where the center
+TUPLE: glue < gadget ;
-! gadgets gets left-over space.
-TUPLE: frame < grid ;
 
-: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
+M: glue pref-dim* drop { 0 0 } ;
+
+: <glue> ( -- glue ) glue new-gadget ;
+
+: <frame-grid> ( -- grid ) 9 [ <glue> ] replicate 3 group ;
 
 : @center 1 1 ; inline
 : @left 0 1 ; inline
@@ -22,13 +24,15 @@ TUPLE: frame < grid ;
 : @bottom-left 0 2 ; inline
 : @bottom-right 2 2 ; inline
 
+TUPLE: frame < grid ;
+
 : new-frame ( class -- frame )
     <frame-grid> swap new-grid ; inline
 
 : <frame> ( -- frame )
     frame new-frame ;
 
-: (fill-center) ( n vec -- )
+: (fill-center) ( dim vec -- )
     [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
 
 : fill-center ( dim horiz vert -- )
@@ -36,4 +40,4 @@ TUPLE: frame < grid ;
 
 M: frame layout*
     dup compute-grid
-    [ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;
+    [ [ dim>> ] 2dip fill-center ] [ grid-layout ] 3bi ;

basis/ui/gadgets/menus/menus.factor

@@ -46,7 +46,6 @@ M: menu-glass layout* gadget-child prefer ;
     faint-boundary ;
 
 : <commands-menu> ( hook target commands -- gadget )
-    <filled-pile>
+    [ <filled-pile> ] 3dip
-        -roll
         [ <menu-item> add-gadget ] with with each
     5 <border> menu-theme ;

basis/ui/render/render.factor

@@ -168,24 +168,29 @@ M: gradient draw-interior
     } cleave ;
 
 ! Polygon pen
-TUPLE: polygon color vertex-array count ;
+TUPLE: polygon color
+interior-vertices
+interior-count
+boundary-vertices
+boundary-count ;
 
 : <polygon> ( color points -- polygon )
-    [ concat >c-float-array ] [ length ] bi polygon boa ;
+    dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
-
+    polygon boa ;
-: draw-polygon ( polygon mode -- )
-    swap
-    [ color>> gl-color ]
-    [ vertex-array>> gl-vertex-pointer ]
-    [ 0 swap count>> glDrawArrays ]
-    tri ;
 
 M: polygon draw-boundary
-    GL_LINE_LOOP draw-polygon drop ;
+    nip
+    [ color>> gl-color ]
+    [ boundary-vertices>> gl-vertex-pointer ]
+    [ [ GL_LINE_STRIP 0 ] dip boundary-count>> glDrawArrays ]
+    tri ;
 
 M: polygon draw-interior
-    dup count>> 2 > GL_POLYGON GL_LINES ?
+    nip
-    draw-polygon drop ;
+    [ color>> gl-color ]
+    [ interior-vertices>> gl-vertex-pointer ]
+    [ [ GL_POLYGON 0 ] dip interior-count>> glDrawArrays ]
+    tri ;
 
 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;

basis/ui/tools/listener/listener.factor

@@ -6,9 +6,9 @@ listener debugger threads boxes concurrency.flags math arrays
 generic accessors combinators assocs fry ui.commands ui.gadgets
 ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
 ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
-ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
+ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
-ui.tools.browser ui.tools.interactor ui.tools.inspector
+ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
-ui.tools.workspace ;
+ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
 IN: ui.tools.listener
 
 TUPLE: listener-gadget < track input output ;
@@ -153,9 +153,9 @@ M: engine-word word-completion-string
     dup <listener-input> >>input ;
 
 : <listener-scroller> ( listener -- scroller )
-    <filled-pile>
+    <frame>
-        over output>> add-gadget
+        over output>> @top grid-add
-        swap input>> add-gadget
+        swap input>> @center grid-add
     <scroller> ;
 
 : <listener-gadget> ( -- gadget )

basis/ui/traverse/traverse.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces make sequences kernel math arrays io
 ui.gadgets generic combinators ;
@@ -7,7 +7,7 @@ IN: ui.traverse
 TUPLE: node value children ;
 
 : traverse-step ( path gadget -- path' gadget' )
-    >r unclip r> children>> ?nth ;
+    [ unclip ] dip children>> ?nth ;
 
 : make-node ( quot -- ) { } make node boa , ; inline
 
@@ -43,7 +43,7 @@ TUPLE: node value children ;
     traverse-step traverse-from-path ;
 
 : (traverse-middle) ( frompath topath gadget -- )
-    >r >r first 1+ r> first r> children>> <slice> % ;
+    [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
 
 : traverse-post ( topath gadget -- )
     traverse-step traverse-to-path ;
@@ -59,8 +59,8 @@ TUPLE: node value children ;
 DEFER: (gadget-subtree)
 
 : traverse-child ( frompath topath gadget -- )
-    dup -roll [
+    [ -rot ] keep [
-        >r >r rest-slice r> r> traverse-step (gadget-subtree)
+        [ rest-slice ] 2dip traverse-step (gadget-subtree)
     ] make-node ;
 
 : (gadget-subtree) ( frompath topath gadget -- )

core/combinators/combinators.factor

@@ -45,7 +45,7 @@ ERROR: no-cond ;
     [ rot \ if 3array append [ ] like ] assoc-each ;
 
 : cond>quot ( assoc -- quot )
-    [ dup callable? [ [ t ] swap 2array ] when ] map
+    [ dup pair? [ [ t ] swap 2array ] unless ] map
     reverse [ no-cond ] swap alist>quot ;
 
 ! case

vm/data_gc.c

@@ -885,12 +885,13 @@ void garbage_collection(CELL gen,
 	/* collect objects referenced from older generations */
 	collect_cards();
 
-	if(collecting_gen != TENURED)
+	/* don't scan code heap unless it has pointers to this
+	generation or younger */
+	if(collecting_gen >= last_code_heap_scan)
 	{
-		/* don't scan code heap unless it has pointers to this
+		if(collecting_gen != TENURED)
-		generation or younger */
-		if(collecting_gen >= last_code_heap_scan)
 		{
+		
 			/* if we are doing code GC, then we will copy over
 			literals from any code block which gets marked as live.
 			if we are not doing code GC, just consider all literals
@@ -898,12 +899,12 @@ void garbage_collection(CELL gen,
 			code_heap_scans++;
 
 			collect_literals();
-
-			if(collecting_accumulation_gen_p())
-				last_code_heap_scan = collecting_gen;
-			else
-				last_code_heap_scan = collecting_gen + 1;
 		}
+
+		if(collecting_accumulation_gen_p())
+			last_code_heap_scan = collecting_gen;
+		else
+			last_code_heap_scan = collecting_gen + 1;
 	}
 
 	collect_next_loop(scan,&newspace->here);

vm/os-macosx.m

@@ -25,6 +25,14 @@ NS_ENDHANDLER
 
 void early_init(void)
 {
+	SInt32 version;
+	Gestalt(gestaltSystemVersion,&version);
+	if(version <= 0x1050)
+	{
+		printf("Factor requires Mac OS X 10.5 or later.\n");
+		exit(1);
+	}
+
 	[[NSAutoreleasePool alloc] init];
 }