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

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

@@ -1,4 +1,4 @@
-USING: kernel math tools.test combinators.short-circuit ;
+USING: kernel math tools.test combinators.short-circuit accessors ;
 IN: combinators.short-circuit.tests
 
 [ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
@@ -22,4 +22,19 @@ IN: combinators.short-circuit.tests
 : compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
 
 [ 30 ] [ 10 20 compiled-|| ] unit-test
-[ 2 ] [ 1 1 compiled-|| ] unit-test
+[ 2 ] [ 1 1 compiled-|| ] unit-test
+
+! && and || should be row-polymorphic both when compiled and when interpreted
+
+: row-&& ( -- ? )
+    f t { [ drop dup ] } 1&& nip ;
+
+[ f ] [ row-&& ] unit-test
+[ f ] [ \ row-&& def>> call ] unit-test
+
+: row-|| ( -- ? )
+    f t { [ drop dup ] } 1|| nip ;
+
+[ f ] [ row-|| ] unit-test
+[ f ] [ \ row-|| def>> call ] unit-test
+

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

@@ -1,11 +1,19 @@
 USING: kernel combinators quotations arrays sequences assocs
-generalizations macros fry ;
+generalizations macros fry math ;
 IN: combinators.short-circuit
 
+<PRIVATE
+
+MACRO: keeping ( n quot -- quot' )
+    swap dup 1 +
+    '[ _ _ nkeep _ nrot ] ;
+
+PRIVATE>
+
 MACRO: n&& ( quots n -- quot )
     [
         [ [ f ] ] 2dip swap [
-            [ '[ drop _ ndup @ dup not ] ]
+            [ '[ drop _ _ keeping dup not ] ]
             [ drop '[ drop _ ndrop f ] ]
             2bi 2array
         ] with map
@@ -27,7 +35,7 @@ PRIVATE>
 MACRO: n|| ( quots n -- quot )
     [
         [ [ f ] ] 2dip swap [
-            [ '[ drop _ ndup @ dup ] ]
+            [ '[ drop _ _ keeping dup ] ]
             [ drop '[ _ nnip ] ]
             2bi 2array
         ] with map

basis/core-foundation/arrays/arrays.factor

@@ -15,7 +15,8 @@ FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* v
 FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
 
 : CF>array ( alien -- array )
-    dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
+    dup CFArrayGetCount
+    [ CFArrayGetValueAtIndex ] with { } map-integers ;
 
 : <CFArray> ( seq -- alien )
     f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable

basis/debugger/debugger.factor

@@ -50,7 +50,7 @@ M: string error. print ;
 
 : restart. ( restart n -- )
     [
-        1 + dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
+        1 + dup 3 <= [ ":" % # "      " % ] [ # " :res  " % ] if
         name>> %
     ] "" make print ;
 

basis/help/apropos/apropos.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry help.markup help.topics io
 kernel make math math.parser namespaces sequences sorting
@@ -19,6 +19,8 @@ TUPLE: more-completions seq ;
 
 CONSTANT: max-completions 5
 
+M: more-completions valid-article? drop t ;
+
 M: more-completions article-title
     seq>> length number>string " results" append ;
 
@@ -60,6 +62,8 @@ TUPLE: apropos search ;
 
 C: <apropos> apropos
 
+M: apropos valid-article? drop t ;
+
 M: apropos article-title
     search>> "Search results for “" "”" surround ;
 

basis/help/help.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays io io.styles kernel namespaces make
 parser prettyprint sequences words words.symbol assocs
@@ -48,6 +48,8 @@ M: predicate word-help* drop \ $predicate ;
 : all-errors ( -- seq )
     all-words [ error? ] filter sort-articles ;
 
+M: word valid-article? drop t ;
+
 M: word article-name name>> ;
 
 M: word article-title

basis/help/home/home.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays compiler.units fry hashtables help.topics io
 kernel math namespaces sequences sets help.vocabs
@@ -21,7 +21,8 @@ M: apropos add-recent-where recent-searches ;
 M: object add-recent-where f ;
 
 : $recent ( element -- )
-    first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
+    first get [ valid-article? ] filter <reversed>
+    [ nl ] [ 1array $pretty-link ] interleave ;
 
 : $recent-searches ( element -- )
     drop recent-searches get [ <$link> ] map $list ;

basis/help/topics/topics.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.x
 USING: accessors arrays definitions generic assocs
 io kernel namespaces make prettyprint prettyprint.sections
@@ -38,6 +38,7 @@ SYMBOL: article-xref
 
 article-xref [ H{ } clone ] initialize
 
+GENERIC: valid-article? ( topic -- ? )
 GENERIC: article-name ( topic -- string )
 GENERIC: article-title ( topic -- string )
 GENERIC: article-content ( topic -- content )
@@ -49,6 +50,7 @@ TUPLE: article title content loc ;
 : <article> ( title content -- article )
     f \ article boa ;
 
+M: article valid-article? drop t ;
 M: article article-name title>> ;
 M: article article-title title>> ;
 M: article article-content content>> ;
@@ -61,12 +63,14 @@ M: no-article summary
 : article ( name -- article )
     articles get ?at [ no-article ] unless ;
 
+M: object valid-article? articles get key? ;
 M: object article-name article article-name ;
 M: object article-title article article-title ;
 M: object article-content article article-content ;
 M: object article-parent article-xref get at ;
 M: object set-article-parent article-xref get set-at ;
 
+M: link valid-article? name>> valid-article? ;
 M: link article-name name>> article-name ;
 M: link article-title name>> article-title ;
 M: link article-content name>> article-content ;
@@ -74,6 +78,7 @@ M: link article-parent name>> article-parent ;
 M: link set-article-parent name>> set-article-parent ;
 
 ! Special case: f help
+M: f valid-article? drop t ;
 M: f article-name drop \ f article-name ;
 M: f article-title drop \ f article-title ;
 M: f article-content drop \ f article-content ;

basis/help/vocabs/vocabs.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes classes.builtin
 classes.intersection classes.mixin classes.predicate
@@ -278,6 +278,8 @@ INSTANCE: vocab topic
 
 INSTANCE: vocab-link topic
 
+M: vocab-spec valid-article? drop t ;
+
 M: vocab-spec article-title vocab-name " vocabulary" append ;
 
 M: vocab-spec article-name vocab-name ;
@@ -289,6 +291,8 @@ M: vocab-spec article-parent drop "vocab-index" ;
 
 M: vocab-tag >link ;
 
+M: vocab-tag valid-article? drop t ;
+
 M: vocab-tag article-title
     name>> "Vocabularies tagged “" "”" surround ;
 
@@ -303,6 +307,8 @@ M: vocab-tag summary article-title ;
 
 M: vocab-author >link ;
 
+M: vocab-author valid-article? drop t ;
+
 M: vocab-author article-title
     name>> "Vocabularies by " prepend ;
 

basis/json/reader/reader.factor

@@ -1,18 +1,13 @@
 ! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs combinators io io.streams.string json
-kernel math math.floats.parser math.parser prettyprint sequences
+kernel math math.parser prettyprint sequences strings vectors ;
-strings vectors ;
 IN: json.reader
 
 <PRIVATE
 : value ( char -- num char )
     1string " \t\r\n,:}]" read-until
-    [
+    [ append string>number ] dip ;
-        append
-        [ string>float ]
-        [ [ "eE." index ] any? [ >integer ] unless ] bi
-    ] dip ;
 
 DEFER: j-string
 

basis/math/floats/parser/parser.factor

@@ -1,14 +0,0 @@
-! Copyright (C) 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax ;
-IN: math.floats.parser
-
-<PRIVATE
-
-LIBRARY: libc
-FUNCTION: double strtod ( char* nptr, char** endptr ) ;
-
-PRIVATE>
-
-: string>float ( str -- n/f ) f <void*> strtod ;
-

basis/math/functions/functions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel math.constants math.private math.bits
-math.libm combinators math.order sequences ;
+math.libm combinators fry math.order sequences ;
 IN: math.functions
 
 : >fraction ( a/b -- a b )
@@ -13,12 +13,13 @@ IN: math.functions
 GENERIC: sqrt ( x -- y ) foldable
 
 M: real sqrt
-    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
+    >float dup 0.0 <
+    [ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
 
 : factor-2s ( n -- r s )
     #! factor an integer into 2^r * s
     dup 0 = [ 1 ] [
-        0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
+        [ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
     ] if ; inline
 
 <PRIVATE
@@ -26,13 +27,13 @@ M: real sqrt
 GENERIC# ^n 1 ( z w -- z^w ) foldable
 
 : (^n) ( z w -- z^w )
-    make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
+    make-bits 1 [ [ over * ] when [ sq ] dip ] reduce nip ; inline
 
 M: integer ^n
     [ factor-2s ] dip [ (^n) ] keep rot * shift ;
 
 M: ratio ^n
-    [ >fraction ] dip [ ^n ] curry bi@ / ;
+    [ >fraction ] dip '[ _ ^n ] bi@ / ;
 
 M: float ^n (^n) ;
 
@@ -62,7 +63,7 @@ M: float exp fexp ; inline
 
 M: real exp >float exp ; inline
 
-M: complex exp >rect swap exp swap polar> ; inline
+M: complex exp >rect [ exp ] dip polar> ; inline
 
 <PRIVATE
 
@@ -84,10 +85,9 @@ M: complex exp >rect swap exp swap polar> ; inline
 : 0^ ( x -- z )
     [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
 
-: (^mod) ( n x y -- z )
+: (^mod) ( x y n -- z )
-    make-bits 1 [
+    [ make-bits 1 ] dip dup
-        [ dupd * pick mod ] when [ sq over mod ] dip
+    '[ [ over * _ mod ] when [ sq _ mod ] dip ] reduce nip ; inline
-    ] reduce 2nip ; inline
 
 : (gcd) ( b a x y -- a d )
     over zero? [
@@ -125,11 +125,8 @@ ERROR: non-trivial-divisor n ;
     [ non-trivial-divisor ] if ; foldable
 
 : ^mod ( x y n -- z )
-    over 0 < [
+    over 0 <
-        [ [ neg ] dip ^mod ] keep mod-inv
+    [ [ [ neg ] dip ^mod ] keep mod-inv ] [ (^mod) ] if ; foldable
-    ] [
-        -rot (^mod)
-    ] if ; foldable
 
 GENERIC: absq ( x -- y ) foldable
 

basis/ui/backend/cocoa/tools/tools.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax cocoa cocoa.nibs cocoa.application
 cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.runtime
 cocoa.subclassing core-foundation core-foundation.strings
 help.topics kernel memory namespaces parser system ui
 ui.tools.browser ui.tools.listener ui.backend.cocoa eval
-locals vocabs.refresh ;
+locals listener vocabs.refresh ;
 FROM: alien.c-types => int void ;
 IN: ui.backend.cocoa.tools
 
@@ -82,12 +82,20 @@ CLASS: {
     "evalInListener:userData:error:"
     void
     { id SEL id id id }
-    [ nip [ eval-listener f ] do-service 2drop ]
+    [
+        nip
+        [ eval-listener f ] do-service
+        2drop
+    ]
 } {
     "evalToString:userData:error:"
     void
     { id SEL id id id }
-    [ nip [ eval>string ] do-service 2drop ]
+    [
+        nip
+        [ [ (eval>string) ] with-interactive-vocabs ] do-service
+        2drop
+    ]
 } ;
 
 : register-services ( -- )

basis/ui/text/core-text/core-text.factor

@@ -1,11 +1,10 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors alien core-graphics.types core-text
-core-text.fonts kernel hashtables namespaces sequences
+core-text.fonts kernel hashtables namespaces sequences ui.text
-ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
+ui.text.private destructors combinators core-foundation
-opengl.textures destructors combinators core-foundation
+core-foundation.strings math math.vectors init colors
-core-foundation.strings math math.vectors init colors colors.constants
+colors.constants cache arrays images ;
-cache arrays images ;
 IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
@@ -18,13 +17,8 @@ M: core-text-renderer string-dim
 M: core-text-renderer flush-layout-cache
     cached-lines get purge-cache ;
 
-: rendered-line ( font string -- texture )
+M: core-text-renderer string>image ( font string -- image loc )
-    world get world-text-handle [
+    cached-line [ image>> ] [ loc>> ] bi ;
-        cached-line [ image>> ] [ loc>> ] bi <texture>
-    ] 2cache ;
-
-M: core-text-renderer draw-string ( font string -- )
-    rendered-line draw-texture ;
 
 M: core-text-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [

basis/ui/text/pango/pango.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs cache kernel math math.vectors
+USING: accessors assocs cache kernel math math.vectors
-namespaces opengl.textures pango.cairo pango.layouts ui.gadgets.worlds
+namespaces pango.cairo pango.layouts ui.text ui.text.private
-ui.text ui.text.private pango sequences ;
+pango sequences ;
 IN: ui.text.pango
 
 SINGLETON: pango-renderer
@@ -14,13 +14,8 @@ M: pango-renderer string-dim
 M: pango-renderer flush-layout-cache
     cached-layouts get purge-cache ;
 
-: rendered-layout ( font string -- texture )
+M: pango-renderer string>image ( font string -- image loc )
-    world get world-text-handle [
+    cached-layout [ image>> ] [ text-position vneg ] bi ;
-        cached-layout [ image>> ] [ text-position vneg ] bi <texture>
-    ] 2cache ;
-
-M: pango-renderer draw-string ( font string -- )
-    rendered-layout draw-texture ;
 
 M: pango-renderer x>offset ( x font string -- n )
     cached-layout swap x>line-offset ;

basis/ui/text/text-docs.factor

@@ -1,5 +1,5 @@
 IN: ui.text
-USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
+USING: help.markup help.syntax kernel ui.text.private strings math fonts images ;
 
 HELP: string-width
 { $values { "font" font } { "string" string } { "w" "a positive integer" } }
@@ -48,6 +48,10 @@ HELP: line-metrics
 { $values { "font" font } { "string" string } { "metrics" line-metrics } }
 { $contract "Outputs a " { $link metrics } " object with text measurements." } ;
 
+HELP: string>image
+{ $values { "font" font } { "string" string } { "image" image } { "loc" "a pair of real numbers" } }
+{ $description "Renders a line of text into an image." } ;
+
 ARTICLE: "text-rendering" "Rendering text"
 "The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X, Uniscribe on Windows and Pango on X11."
 { $subsections "fonts" }
@@ -64,7 +68,7 @@ ARTICLE: "text-rendering" "Rendering text"
     offset>x
 }
 "Rendering text:"
-{ $subsections draw-text }
+{ $subsections draw-text string>image }
 "Low-level text protocol for UI backends:"
 { $subsections
     string-width

basis/ui/text/text-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts math accessors kernel sequences ;
+USING: tools.test ui.text images fonts math arrays accessors kernel
+sequences ;
 IN: ui.text.tests
 
 [ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
@@ -20,3 +21,5 @@ IN: ui.text.tests
 [ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
 
 [ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
+
+[ t ] [ serif-font "Hello world" string>image [ image? ] [ pair? ] bi* and ] unit-test

basis/ui/text/text.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order cache opengl
+USING: kernel arrays assocs sequences math math.order cache
-opengl.gl strings fonts colors accessors namespaces
+opengl opengl.gl opengl.textures strings fonts colors accessors
-ui.gadgets.worlds ;
+namespaces ui.gadgets.worlds ;
 IN: ui.text
 
 <PRIVATE
@@ -29,8 +29,6 @@ M: object string-width string-dim first ;
 
 M: object string-height string-dim second ;
 
-HOOK: draw-string font-renderer ( font string -- )
-
 HOOK: free-fonts font-renderer ( world -- )
 
 : combine-text-dim ( dim1 dim2 -- dim3 )
@@ -59,6 +57,22 @@ HOOK: font-metrics font-renderer ( font -- metrics )
 
 HOOK: line-metrics font-renderer ( font string -- metrics )
 
+HOOK: string>image font-renderer ( font string -- image loc )
+
+<PRIVATE
+
+: string-empty? ( obj -- ? )
+    dup selection? [ string>> ] when empty? ;
+
+: draw-string ( font string -- )
+    dup string-empty? [ 2drop ] [
+        world get world-text-handle
+        [ string>image <texture> ] 2cache
+        draw-texture
+    ] if ;
+
+PRIVATE>
+
 GENERIC: draw-text ( font text -- )
 
 M: string draw-text draw-string ;

basis/ui/text/uniscribe/uniscribe.factor

@@ -1,8 +1,7 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache kernel math math.vectors sequences fonts
+USING: accessors assocs cache kernel math math.vectors sequences
-namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
+fonts namespaces ui.text ui.text.private windows.uniscribe ;
-windows.uniscribe ;
 IN: ui.text.uniscribe
 
 SINGLETON: uniscribe-renderer
@@ -14,14 +13,8 @@ M: uniscribe-renderer string-dim
 M: uniscribe-renderer flush-layout-cache
     cached-script-strings get purge-cache ;
 
-: rendered-script-string ( font string -- texture )
+M: uniscribe-renderer string>image ( font string -- image loc )
-    world get world-text-handle
+    cached-script-string image>> { 0 0 } ;
-    [ cached-script-string image>> { 0 0 } <texture> ]
-    2cache ;
-
-M: uniscribe-renderer draw-string ( font string -- )
-    dup dup selection? [ string>> ] when empty?
-    [ 2drop ] [ rendered-script-string draw-texture ] if ;
 
 M: uniscribe-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [

core/classes/algebra/algebra-tests.factor

@@ -211,12 +211,6 @@ MIXIN: empty-mixin
 
 [ f ] [ null class-not null class= ] unit-test
 
-! class<=>
-
-[ +lt+ ] [ sequence object class<=> ] unit-test
-[ +gt+ ] [ object sequence class<=> ] unit-test
-[ +eq+ ] [ integer integer class<=> ] unit-test
-
 ! smallest-class etc
 [ real ] [ { real sequence } smallest-class ] unit-test
 [ real ] [ { sequence real } smallest-class ] unit-test

core/classes/algebra/algebra.factor

@@ -57,13 +57,6 @@ M: anonymous-complement classoid? class>> classoid? ;
         [ [ rank-class ] bi@ < ]
     } cond ;
 
-: class<=> ( first second -- ? )
-    {
-        { [ 2dup class<= not ] [ 2drop +gt+ ] }
-        { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
-        [ [ rank-class ] bi@ <=> ]
-    } cond ;
-
 : class= ( first second -- ? )
     [ class<= ] [ swap class<= ] 2bi and ;
 

core/math/integers/integers-tests.factor

@@ -220,7 +220,7 @@ unit-test
     1 random zero? [ >bignum ] when ;
 
 [ t ] [
-    1000 [
+    10000 [
         drop
         random-integer
         random-integer

core/math/integers/integers.factor

@@ -119,30 +119,26 @@ M: bignum (log2) bignum-log2 ; inline
 : scale-denonimator ( den -- scaled-den scale' )
     dup twos neg [ shift ] keep ; inline
 
-: pre-scale ( num den -- scale shifted-num scaled-den )
+: pre-scale ( num den -- mantissa den' scale )
     2dup [ log2 ] bi@ -
-    [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi*
+    [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi* ; inline
-    -rot ; inline
 
 ! Second step: loop
-: shift-mantissa ( scale mantissa -- scale' mantissa' )
+: /f-loop ( mantissa den scale -- fraction-and-guard rem scale' )
-    [ 1 + ] [ 2/ ] bi* ; inline
+    [ 2over /i log2 53 > ]
-
+    [ [ 2/ ] [ ] [ 1 + ] tri* ] while
-: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
+    [ /mod ] dip ; inline
-    [ 2dup /i log2 53 > ]
-    [ [ shift-mantissa ] dip ]
-    while /mod ; inline
 
 ! Third step: post-scaling
 : unscaled-float ( mantissa -- n )
     52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
 
-: scale-float ( scale mantissa -- float' )
+: scale-float ( mantissa scale -- float' )
-    [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
+    dup 0 < [ neg 2^ recip ] [ 2^ ] if * ; inline
 
-: post-scale ( scale mantissa -- n )
+: post-scale ( mantissa scale -- n )
-    2/ dup log2 52 > [ shift-mantissa ] when
+    [ 2/ ] dip over log2 52 > [ [ 2/ ] [ 1 + ] bi* ] when
-    unscaled-float scale-float ; inline
+    [ unscaled-float ] dip scale-float ; inline
 
 ! Main word
 : /f-abs ( m n -- f )
@@ -153,8 +149,8 @@ M: bignum (log2) bignum-log2 ; inline
             drop 1/0.
         ] [
             pre-scale
-            /f-loop over odd?
+            /f-loop
-            [ zero? [ 1 + ] unless ] [ drop ] if
+            [ over odd? [ zero? [ 1 + ] unless ] [ drop ] if ] dip
             post-scale
         ] if-zero
     ] if ; inline

core/sequences/sequences-tests.factor

@@ -1,4 +1,4 @@
-USING: arrays kernel math namespaces sequences kernel.private
+USING: arrays kernel math math.order namespaces sequences kernel.private
 sequences.private strings sbufs tools.test vectors assocs
 generic vocabs.loader ;
 IN: sequences.tests
@@ -300,3 +300,12 @@ USE: make
 
 [ t ] [ 0 array-capacity? ] unit-test
 [ f ] [ -1 array-capacity? ] unit-test
+
+[ +lt+ ] [ { 0 0 0 } { 1 1 1 } <=> ] unit-test
+[ +lt+ ] [ { 0 0 0 } { 0 1 1 } <=> ] unit-test
+[ +lt+ ] [ { 0 0 0 } { 0 0 0 0 } <=> ] unit-test
+[ +gt+ ] [ { 1 1 1 } { 0 0 0 } <=> ] unit-test
+[ +gt+ ] [ { 0 1 1 } { 0 0 0 } <=> ] unit-test
+[ +gt+ ] [ { 0 0 0 0 } { 0 0 0 } <=> ] unit-test
+[ +eq+ ] [ { } { } <=> ] unit-test
+[ +eq+ ] [ { 1 2 3 } { 1 2 3 } <=> ] unit-test

core/sequences/sequences.factor

@@ -91,6 +91,8 @@ M: sequence set-nth-unsafe set-nth ; inline
 : change-nth-unsafe ( i seq quot -- )
     [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
 
+PRIVATE>
+
 ! The f object supports the sequence protocol trivially
 M: f length drop 0 ; inline
 M: f nth-unsafe nip ; inline
@@ -98,20 +100,18 @@ M: f like drop [ f ] when-empty ; inline
 
 INSTANCE: f immutable-sequence
 
-PRIVATE>
+! Integer sequences
-
-! In the future, this will replace integer sequences
 TUPLE: iota { n integer read-only } ;
 
 : iota ( n -- iota ) \ iota boa ; inline
 
-<PRIVATE
-
 M: iota length n>> ; inline
 M: iota nth-unsafe drop ; inline
 
 INSTANCE: iota immutable-sequence
 
+<PRIVATE
+
 : first-unsafe ( seq -- first )
     0 swap nth-unsafe ; inline
 
@@ -586,13 +586,13 @@ PRIVATE>
     [ empty? not ] filter ;
 
 : mismatch ( seq1 seq2 -- i )
-    [ min-length iota ] 2keep
+    [ min-length ] 2keep
     [ 2nth-unsafe = not ] 2curry
-    find drop ; inline
+    find-integer ; inline
 
 M: sequence <=>
-    2dup mismatch
+    [ mismatch ] 2keep pick
-    [ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
+    [ 2nth-unsafe <=> ] [ [ length ] compare nip ] if ;
 
 : sequence= ( seq1 seq2 -- ? )
     2dup [ length ] bi@ =

extra/game/models/collada/collada.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Erik Charlebois
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs grouping hashtables kernel locals
-math math.floats.parser math.parser sequences sequences.deep
+math math.parser sequences sequences.deep
 specialized-arrays.instances.alien.c-types.float
 specialized-arrays.instances.alien.c-types.uint splitting xml
 xml.data xml.traversal math.order namespaces combinators images
@@ -23,7 +23,7 @@ SYMBOLS: up-axis unit-ratio ;
     " \t\n" split harvest [ string>number ] map ;
 
 : string>floats ( string -- float-seq )
-    " \t\n" split harvest [ string>float ] map ;
+    " \t\n" split harvest [ string>number ] map ;
 
 : x/ ( tag child-name -- child-tag )
     [ tag-named ]

extra/game/models/obj/obj-docs.factor

@@ -22,9 +22,9 @@ HELP: md
 { $values { "material-dictionary" assoc } }
 { $description "Convenience word for accessing the material dictionary while parsing primitives. " } ;
 
-HELP: strings>floats
+HELP: strings>numbers
-{ $values { "strings" sequence } { "floats" sequence } }
+{ $values { "strings" sequence } { "numbers" sequence } }
-{ $description "Convert a sequence of strings to a sequence of floats." } ;
+{ $description "Convert a sequence of strings to a sequence of numbers." } ;
 
 HELP: strings>faces
 { $values { "strings" sequence } { "faces" sequence } }

extra/game/models/obj/obj.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2010 Erik Charlebois
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings.ascii math.parser math.floats.parser
+USING: io io.encodings.ascii math.parser sequences splitting
-sequences splitting kernel assocs io.files combinators
+kernel assocs io.files combinators math.order math namespaces
-math.order math namespaces arrays sequences.deep accessors
+arrays sequences.deep accessors
 specialized-arrays.instances.alien.c-types.float
 specialized-arrays.instances.alien.c-types.uint game.models
 game.models.util gpu.shaders images game.models.loader
@@ -36,8 +36,8 @@ TUPLE: material
 : cm ( -- current-material ) current-material get ; inline
 : md ( -- material-dictionary ) material-dictionary get ; inline
 
-: strings>floats ( strings -- floats )
+: strings>numbers ( strings -- numbers )
-    [ string>float ] map ;
+    [ string>number ] map ;
 
 : strings>faces ( strings -- faces )
     [ "/" split [ string>number ] map ] map ;
@@ -54,22 +54,22 @@ TUPLE: material
                 [ material new swap >>name current-material set ]
                 [ cm swap md set-at ] bi
             ] }
-            { "Ka"       [ 3 head [ string>float ] map cm (>>ambient-reflectivity)  ] }
+            { "Ka"       [ 3 head strings>numbers cm (>>ambient-reflectivity)  ] }
-            { "Kd"       [ 3 head [ string>float ] map cm (>>diffuse-reflectivity)  ] }
+            { "Kd"       [ 3 head strings>numbers cm (>>diffuse-reflectivity)  ] }
-            { "Ks"       [ 3 head [ string>float ] map cm (>>specular-reflectivity) ] }
+            { "Ks"       [ 3 head strings>numbers cm (>>specular-reflectivity) ] }
-            { "Tf"       [ 3 head [ string>float ] map cm (>>transmission-filter)   ] }
+            { "Tf"       [ 3 head strings>numbers cm (>>transmission-filter)   ] }
-            { "d"        [ first string>float cm          (>>dissolve)              ] }
+            { "d"        [ first string>number cm    (>>dissolve)              ] }
-            { "Ns"       [ first string>float cm          (>>specular-exponent)     ] }
+            { "Ns"       [ first string>number cm    (>>specular-exponent)     ] }
-            { "Ni"       [ first string>float cm          (>>refraction-index)      ] }
+            { "Ni"       [ first string>number cm    (>>refraction-index)      ] }
-            { "map_Ka"   [ first cm                       (>>ambient-map)           ] }
+            { "map_Ka"   [ first cm                  (>>ambient-map)           ] }
-            { "map_Kd"   [ first cm                       (>>diffuse-map)           ] }
+            { "map_Kd"   [ first cm                  (>>diffuse-map)           ] }
-            { "map_Ks"   [ first cm                       (>>specular-map)          ] }
+            { "map_Ks"   [ first cm                  (>>specular-map)          ] }
-            { "map_Ns"   [ first cm                       (>>specular-exponent-map) ] }
+            { "map_Ns"   [ first cm                  (>>specular-exponent-map) ] }
-            { "map_d"    [ first cm                       (>>dissolve-map)          ] }
+            { "map_d"    [ first cm                  (>>dissolve-map)          ] }
-            { "map_bump" [ first cm                       (>>bump-map)              ] }
+            { "map_bump" [ first cm                  (>>bump-map)              ] }
-            { "bump"     [ first cm                       (>>bump-map)              ] }
+            { "bump"     [ first cm                  (>>bump-map)              ] }
-            { "disp"     [ first cm                       (>>displacement-map)      ] }
+            { "disp"     [ first cm                  (>>displacement-map)      ] }
-            { "refl"     [ first cm                       (>>reflection-map)        ] }
+            { "refl"     [ first cm                  (>>reflection-map)        ] }
             [ 2drop ]
         } case
     ] unless-empty ;
@@ -137,9 +137,9 @@ VERTEX-FORMAT: obj-vertex-format
         [ rest ] [ first ] bi
         {
             { "mtllib" [ first read-mtl material-dictionary set ] }
-            { "v"      [ strings>floats 3 head vp [ push* ] change ] }
+            { "v"      [ strings>numbers 3 head vp [ push* ] change ] }
-            { "vt"     [ strings>floats 2 head vt [ push* ] change ] }
+            { "vt"     [ strings>numbers 2 head vt [ push* ] change ] }
-            { "vn"     [ strings>floats 3 head vn [ push* ] change ] }
+            { "vn"     [ strings>numbers 3 head vn [ push* ] change ] }
             { "usemtl" [ push-current-model first md at current-material set ] }
             { "f"      [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
             [ 2drop ]

extra/mason/release/archive/archive.factor

@@ -9,14 +9,14 @@ IN: mason.release.archive
 : base-name ( -- string )
     [ "factor-" % platform % "-" % stamp get % ] "" make ;
 
-: extension ( -- extension )
+: extension ( os -- extension )
-    target-os get {
+    {
         { "winnt" [ ".zip" ] }
         { "macosx" [ ".dmg" ] }
         [ drop ".tar.gz" ]
     } case ;
 
-: archive-name ( -- string ) base-name extension append ;
+: archive-name ( -- string ) base-name target-os get extension append ;
 
 :: make-windows-archive ( archive-name -- )
     { "zip" "-r" archive-name "factor" } short-running-process ;

extra/mason/server/notify/notify.factor

@@ -1,46 +1,9 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.smart command-line db
+USING: accessors calendar combinators combinators.smart
-db.sqlite db.tuples db.types io io.encodings.utf8 io.files
+command-line db.tuples io io.encodings.utf8 io.files kernel
-present kernel namespaces sequences calendar ;
+mason.server namespaces present sequences ;
-IN: mason.notify.server
+IN: mason.server.notify
-
-CONSTANT: +starting+ "starting"
-CONSTANT: +make-vm+ "make-vm"
-CONSTANT: +boot+ "boot"
-CONSTANT: +test+ "test"
-CONSTANT: +clean+ "status-clean"
-CONSTANT: +dirty+ "status-dirty"
-CONSTANT: +error+ "status-error"
-
-TUPLE: builder
-host-name os cpu
-clean-git-id clean-timestamp
-last-release release-git-id
-last-git-id last-timestamp last-report
-current-git-id current-timestamp
-status ;
-
-builder "BUILDERS" {
-    { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
-    { "os" "OS" TEXT +user-assigned-id+ }
-    { "cpu" "CPU" TEXT +user-assigned-id+ }
-    
-    { "clean-git-id" "CLEAN_GIT_ID" TEXT }
-    { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
-
-    { "last-release" "LAST_RELEASE" TEXT }
-    { "release-git-id" "RELEASE_GIT_ID" TEXT }
-    
-    { "last-git-id" "LAST_GIT_ID" TEXT }
-    { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
-    { "last-report" "LAST_REPORT" TEXT }
-
-    { "current-git-id" "CURRENT_GIT_ID" TEXT }
-    ! Can't name it CURRENT_TIMESTAMP because of bug in db library
-    { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
-    { "status" "STATUS" TEXT }
-} define-persistent
 
 SYMBOLS: host-name target-os target-cpu message message-arg ;
 
@@ -96,13 +59,11 @@ SYMBOLS: host-name target-os target-cpu message message-arg ;
         { "release" [ message-arg get release ] }
     } case ;
 
-: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
-
 : handle-update ( command-line timestamp -- )
-    mason-db [
+    [
         [ parse-args find-builder ] dip >>current-timestamp
         [ update-builder ] [ update-tuple ] bi
-    ] with-db ;
+    ] with-mason-db ;
 
 CONSTANT: log-file "resource:mason.log"
 

extra/mason/server/release/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/mason/server/release/release.factor

@@ -0,0 +1,81 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar db db.tuples grouping io
+io.encodings.ascii io.launcher kernel locals make
+mason.release.archive mason.server namespaces sequences ;
+IN: mason.server.release
+
+! Host to upload binary package to.
+SYMBOL: upload-host
+
+! Username to log in.
+SYMBOL: upload-username
+
+! Directory with binary packages.
+SYMBOL: upload-directory
+
+: platform ( builder -- string )
+    [ os>> ] [ cpu>> ] bi "-" glue ;
+
+: package-name ( builder -- string )
+    [ platform ] [ last-release>> ] bi "/" glue ;
+
+: release-name ( version builder -- string )
+    [
+        "releases/" %
+        [ platform % "/" % ]
+        [ "factor-" % platform % "-" % % ]
+        [ os>> extension % ]
+        tri
+    ] "" make ;
+
+: release-command ( version builder -- command )
+    [
+        "ln -s " %
+        [ nip package-name % " " % ] [ release-name % ] 2bi
+    ] { } make ;
+
+TUPLE: release
+host-name os cpu
+last-release release-git-id ;
+
+:: <release> ( version builder -- release )
+    release new
+        builder host-name>> >>host-name
+        builder os>> >>os
+        builder cpu>> >>cpu
+        builder release-git-id>> >>release-git-id
+        version builder release-name >>last-release ;
+
+: execute-on-server ( string -- )
+    [ "ssh" , upload-host get , "-l" , upload-username get , ] { } make
+    <process>
+        swap >>command
+        30 seconds >>timeout
+    ascii [ write ] with-process-writer ;
+
+: release-script ( version builders -- string )
+    upload-directory get "cd " "\n" surround prepend
+    [ release-command ] with map "\n" join ;
+
+: create-releases ( version builders -- )
+    release-script execute-on-server ;
+
+: update-releases ( version builders -- )
+    [
+        release new delete-tuples
+        [ <release> insert-tuple ] with each
+    ] with-transaction ;
+
+: check-releases ( builders -- )
+    [ release-git-id>> ] map all-equal?
+    [ "Not all builders are up to date" throw ] unless ;
+
+: do-release ( version -- )
+    [
+        builder new select-tuples
+        [ nip check-releases ]
+        [ create-releases ]
+        [ update-releases ]
+        2tri
+    ] with-mason-db ;

extra/mason/server/server.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.sqlite db.tuples db.types kernel ;
+IN: mason.server
+
+CONSTANT: +starting+ "starting"
+CONSTANT: +make-vm+ "make-vm"
+CONSTANT: +boot+ "boot"
+CONSTANT: +test+ "test"
+CONSTANT: +clean+ "status-clean"
+CONSTANT: +dirty+ "status-dirty"
+CONSTANT: +error+ "status-error"
+
+TUPLE: builder
+host-name os cpu
+clean-git-id clean-timestamp
+last-release release-git-id
+last-git-id last-timestamp last-report
+current-git-id current-timestamp
+status ;
+
+builder "BUILDERS" {
+    { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+    { "os" "OS" TEXT +user-assigned-id+ }
+    { "cpu" "CPU" TEXT +user-assigned-id+ }
+    
+    { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+    { "clean-timestamp" "CLEAN_TIMESTAMP" TIMESTAMP }
+
+    { "last-release" "LAST_RELEASE" TEXT }
+    { "release-git-id" "RELEASE_GIT_ID" TEXT }
+    
+    { "last-git-id" "LAST_GIT_ID" TEXT }
+    { "last-timestamp" "LAST_TIMESTAMP" TIMESTAMP }
+    { "last-report" "LAST_REPORT" TEXT }
+
+    { "current-git-id" "CURRENT_GIT_ID" TEXT }
+    ! Can't name it CURRENT_TIMESTAMP because of bug in db library
+    { "current-timestamp" "CURR_TIMESTAMP" TIMESTAMP }
+    { "status" "STATUS" TEXT }
+} define-persistent
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: with-mason-db ( quot -- )
+    [ mason-db ] dip with-db ; inline

extra/webapps/mason/mason.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators db db.tuples furnace.actions
 http.server.responses http.server.dispatchers kernel mason.platform
-mason.notify.server mason.report math.order sequences sorting
+mason.server mason.report math.order sequences sorting
 splitting xml.syntax xml.writer io.pathnames io.encodings.utf8
 io.files present validators html.forms furnace.db urls ;
 FROM: assocs => at keys values ;
@@ -181,4 +181,3 @@ CONSTANT: cpus
     <download-binary-action> "download" add-responder
     <download-grid-action> "grid" add-responder
     mason-db <db-persistence> ;
-

misc/fuel/README

@@ -99,6 +99,7 @@ beast.
     |-----------------+------------------------------------------------------------|
     | C-cz            | switch to listener (run-factor)                            |
     | C-co            | cycle between code, tests and docs files                   |
+    | C-ct            | run the unit tests for a vocabulary                        |
     | C-cr            | switch to listener and refresh all loaded vocabs           |
     | C-cs            | switch to other factor buffer (fuel-switch-to-buffer)      |
     | C-x4s           | switch to other factor buffer in other window              |

misc/fuel/fuel-completion.el

@@ -190,13 +190,13 @@ terminates a current completion."
 
 (defvar fuel-completion--vocab-history nil)
 
-(defun fuel-completion--read-vocab (refresh)
+(defun fuel-completion--read-vocab (refresh &optional init-input)
   (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
         (vocabs (fuel-completion--vocabs refresh))
         (prompt "Vocabulary name: "))
     (if vocabs
-        (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history)
+        (completing-read prompt vocabs nil nil init-input fuel-completion--vocab-history)
-      (read-string prompt nil fuel-completion--vocab-history))))
+      (read-string prompt init-input fuel-completion--vocab-history))))
 
 (defun fuel-completion--complete-symbol ()
   "Complete the symbol at point.

misc/fuel/fuel-listener.el

@@ -192,6 +192,13 @@ With prefix, you're teletransported to the listener's buffer."
     (comint-send-string nil "\"Refreshing loaded vocabs...\" write nl flush")
     (comint-send-string nil " refresh-all \"Done!\" write nl flush\n")))
 
+(defun fuel-test-vocab (vocab)
+  "Run the unit tests for the specified vocabulary."
+  (interactive (list (fuel-completion--read-vocab nil (fuel-syntax--current-vocab))))
+  (comint-send-string (fuel-listener--process)
+                      (concat "\"" vocab "\" reload nl flush\n"
+                              "\"" vocab "\" test nl flush\n")))
+
 
 ;;; Completion support
 

misc/fuel/fuel-mode.el

@@ -191,6 +191,7 @@ interacting with a factor listener is at your disposal.
 (fuel-mode--key-1 ?k 'fuel-run-file)
 (fuel-mode--key-1 ?l 'fuel-run-file)
 (fuel-mode--key-1 ?r 'fuel-refresh-all)
+(fuel-mode--key-1 ?t 'fuel-test-vocab)
 (fuel-mode--key-1 ?z 'run-factor)
 (fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
 (define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)

misc/fuel/fuel-syntax.el

@@ -50,7 +50,8 @@
     "DEFER:"
     "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
     "f" "FORGET:" "FROM:" "FUNCTION:"
-    "GENERIC#" "GENERIC:"
+    "GAME:" "GENERIC#" "GENERIC:"
+    "GLSL-SHADER:" "GLSL-PROGRAM:"
     "HELP:" "HEX:" "HOOK:"
     "IN:" "initial:" "INSTANCE:" "INTERSECTION:"
     "LIBRARY:"
@@ -60,10 +61,10 @@
     "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
-    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
+    "SINGLETON:" "SINGLETONS:" "SLOT:" "STRING:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
-    "TUPLE:" "t" "t?" "TYPEDEF:"
+    "TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::"
-    "UNION:" "USE:" "USING:"
+    "UNIFORM-TUPLE:" "UNION:" "USE:" "USING:"
-    "VARS:"))
+    "VARS:" "VERTEX-FORMAT:"))
 
 (defconst fuel-syntax--parsing-words-regex
   (regexp-opt fuel-syntax--parsing-words 'words))
@@ -110,7 +111,7 @@
   (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
           (regexp-opt
            '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
-             "SYMBOL" "SYNTAX" "RENAME"))))
+             "SYMBOL" "SYNTAX" "TYPED" "RENAME"))))
 
 (defconst fuel-syntax--alias-definition-regex
   "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@@ -159,8 +160,11 @@
                                            "MEMO" "MEMO:" "METHOD"
                                            "SYNTAX"
                                            "PREDICATE" "PRIMITIVE"
-                                           "STRUCT" "TAG" "TUPLE" "UNION-STRUCT"
+                                           "STRUCT" "TAG" "TUPLE"
-                                           "UNION"))
+                                           "TYPED" "TYPED:"
+                                           "UNIFORM-TUPLE"
+                                           "UNION-STRUCT" "UNION"
+                                           "VERTEX-FORMAT"))
 
 (defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
                                               "HELP"
@@ -185,7 +189,7 @@
                 "CONSTANT:" "C:"
                 "DEFER:"
                 "FORGET:"
-                "GENERIC:" "GENERIC#"
+                "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:" 
                 "HEX:" "HOOK:"
                 "IN:" "INSTANCE:"
                 "LIBRARY:"