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

basis/calendar/calendar.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
-strings system vocabs.loader threads accessors combinators
+    kernel locals math math.functions math.order namespaces sequences strings
-locals classes.tuple math.order summary combinators.short-circuit ;
+    summary system threads vocabs.loader ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )
-    dup 100 mod zero? 400 4 ? mod zero? ;
+    dup 100 divisor? 400 4 ? divisor? ;
 
 M: timestamp leap-year? ( timestamp -- ? )
     year>> leap-year? ;
@@ -348,7 +348,7 @@ M: duration time-
     #! good for any date since October 15, 1582
     [
         dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+        [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
         [ 1+ 3 * 5 /i + ] keep 2 * +
     ] dip 1+ + 7 mod ;
 

basis/help/html/html.factor

@@ -60,7 +60,7 @@ M: topic url-of topic>filename ;
 : help>html ( topic -- xml )
     [ article-title ]
     [ drop help-stylesheet ]
-    [ [ help ] with-html-writer ]
+    [ [ print-topic ] with-html-writer ]
     tri simple-page ;
           
 : generate-help-file ( topic -- )

basis/help/tips/tips-docs.factor

@@ -20,6 +20,8 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
 
 TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
 
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ;
+
 HELP: TIP:
 { $syntax "TIP: content ;" }
 { $values { "content" "a markup element" } }

basis/math/functions/functions-docs.factor

@@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions"
 "Tests:"
 { $subsection power-of-2? }
 { $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;
 
 ARTICLE: "arithmetic-functions" "Arithmetic functions"
 "Computing additive and multiplicative inverses:"
@@ -269,6 +270,11 @@ HELP: gcd
 { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
 { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
 
+HELP: divisor?
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
+
 HELP: mod-inv
 { $values { "x" integer } { "n" integer } { "y" integer } }
 { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }

basis/math/functions/functions-tests.factor

@@ -32,13 +32,13 @@ IN: math.functions.tests
 
 [ 1.0 ] [ 0 cosh ] unit-test
 [ 0.0 ] [ 1 acosh ] unit-test
-            
+
 [ 1.0 ] [ 0 cos ] unit-test
 [ 0.0 ] [ 1 acos ] unit-test
-            
+
 [ 0.0 ] [ 0 sinh ] unit-test
 [ 0.0 ] [ 0 asinh ] unit-test
-            
+
 [ 0.0 ] [ 0 sin ] unit-test
 [ 0.0 ] [ 0 asin ] unit-test
 
@@ -97,11 +97,17 @@ IN: math.functions.tests
 
 : verify-gcd ( a b -- ? )
     2dup gcd
-    [ rot * swap rem ] dip = ; 
+    [ rot * swap rem ] dip = ;
 
 [ t ] [ 123 124 verify-gcd ] unit-test
 [ t ] [ 50 120 verify-gcd ] unit-test
 
+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
 [ 3 ] [ 5 7 mod-inv ] unit-test
 [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
 
@@ -150,4 +156,4 @@ IN: math.functions.tests
     1067811677921310779
     2135623355842621559
     [ >bignum ] tri@ ^mod
-] unit-test
+] unit-test

basis/math/functions/functions.factor

@@ -111,6 +111,9 @@ PRIVATE>
 : lcm ( a b -- c )
     [ * ] 2keep gcd nip /i ; foldable
 
+: divisor? ( m n -- ? )
+    mod 0 = ;
+
 : mod-inv ( x n -- y )
     [ nip ] [ gcd 1 = ] 2bi
     [ dup 0 < [ + ] [ nip ] if ]
@@ -198,7 +201,7 @@ M: real sin fsin ;
 
 GENERIC: sinh ( x -- y ) foldable
 
-M: complex sinh 
+M: complex sinh
     >float-rect
     [ [ fsinh ] [ fcos ] bi* * ]
     [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;

basis/math/primes/factors/factors.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -11,7 +11,7 @@ IN: math.primes.factors
     swap ;
 
 : write-factor ( n d -- n' d' )
-    2dup mod zero? [
+    2dup divisor? [
         [ [ count-factor ] keep swap 2array , ] keep
         ! If the remainder is a prime number, increase d so that
         ! the caller stops looking for factors.

basis/ui/gadgets/gadgets.factor

@@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
 CONSTANT: vertical { 0 1 }
 
 TUPLE: gadget < rect
+id
 pref-dim
 parent
 children
@@ -28,7 +29,7 @@ model ;
 
 M: gadget equal? 2drop f ;
 
-M: gadget hashcode* drop gadget hashcode* ;
+M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
 
 M: gadget model-changed 2drop ;
 

basis/ui/gadgets/panes/panes.factor

@@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ;
 : pane-caret&mark ( pane -- caret mark )
     [ caret>> ] [ mark>> ] bi ; inline
 
-: selected-children ( pane -- seq )
+: selected-subtree ( pane -- seq )
     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
 
 M: pane gadget-selection? pane-caret&mark and ;
 
 M: pane gadget-selection ( pane -- string/f )
-    selected-children gadget-text ;
+    selected-subtree gadget-text ;
 
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
@@ -72,32 +72,12 @@ M: pane gadget-selection ( pane -- string/f )
     [ >>last-line ] [ 1 track-add ] bi
     dup prepare-last-line ; inline
 
-GENERIC: draw-selection ( loc obj -- )
+M: pane selected-children
-
-: if-fits ( rect quot -- )
-    [ clip get origin get vneg offset-rect over contains-rect? ] dip
-    [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
-    swap offset-rect [
-        rect-bounds gl-fill-rect
-    ] if-fits ;
-
-M: node draw-selection ( loc node -- )
-    2dup value>> swap offset-rect [
-        drop 2dup
-        [ value>> loc>> v+ ] keep
-        children>> [ draw-selection ] with each
-    ] if-fits 2drop ;
-
-M: pane draw-gadget*
     dup gadget-selection? [
-        [ selection-color>> gl-color ]
+        [ selected-subtree leaves ]
-        [
+        [ selection-color>> ]
-            [ loc>> vneg ] keep selected-children
+        bi
-            [ draw-selection ] with each
+    ] [ drop f f ] if ;
-        ] bi
-    ] [ drop ] if ;
 
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;

basis/ui/render/render.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math.rectangles math.vectors namespaces kernel accessors
-combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl opengl.glu colors
 colors.constants ui.gadgets ui.pens ;
 IN: ui.render
 
@@ -55,21 +55,57 @@ SYMBOL: origin
 
 GENERIC: draw-children ( gadget -- )
 
+! For gadget selection
+SYMBOL: selected-gadgets
+
+SYMBOL: selection-background
+
+GENERIC: selected-children ( gadget -- assoc/f selection-background )
+
+M: gadget selected-children drop f f ;
+
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+<PRIVATE
+
+: draw-selection-background ( gadget -- )
+    selection-background get background set
+    selection-background get gl-color
+    [ { 0 0 } ] dip dim>> gl-fill-rect ;
+
+: draw-standard-background ( object -- )
+    dup interior>> dup [ draw-interior ] [ 2drop ] if ;
+
+: draw-background ( gadget -- )
+    origin get [
+        [
+            dup selected-gadgets get key?
+            [ draw-selection-background ]
+            [ draw-standard-background ] if
+        ] [ draw-gadget* ] bi
+    ] with-translation ;
+
+: draw-border ( object -- )
+    dup boundary>> dup [
+        origin get [ draw-boundary ] with-translation
+    ] [ 2drop ] if ;
+
+PRIVATE>
+
 : (draw-gadget) ( gadget -- )
     dup loc>> origin get v+ origin [
-        [
+        [ draw-background ] [ draw-children ] [ draw-border ] tri
-            origin get [
-                [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
-                [ draw-gadget* ]
-                bi
-            ] with-translation
-        ]
-        [ draw-children ]
-        [
-            dup boundary>> dup [
-                origin get [ draw-boundary ] with-translation
-            ] [ 2drop ] if
-        ] tri
     ] with-variable ;
 
 : >absolute ( rect -- rect )
@@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- )
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
-! For text rendering
-SYMBOL: background
-
-SYMBOL: foreground
-
-GENERIC: gadget-background ( gadget -- color )
-
-M: gadget gadget-background dup interior>> pen-background ;
-
-GENERIC: gadget-foreground ( gadget -- color )
-
-M: gadget gadget-foreground dup interior>> pen-foreground ;
-
 M: gadget draw-children
-    [ visible-children ]
+    dup children>> [
-    [ gadget-background ]
+        {
-    [ gadget-foreground ] tri [
+            [ visible-children ]
-        [ foreground set ] when*
+            [ selected-children ]
-        [ background set ] when*
+            [ gadget-background ]
-        [ draw-gadget ] each
+            [ gadget-foreground ]
-    ] with-scope ;
+        } cleave [
+            
+            {
+                [ [ selected-gadgets set ] when* ]
+                [ [ selection-background set ] when* ]
+                [ [ background set ] when* ]
+                [ [ foreground set ] when* ]
+            } spread
+            [ draw-gadget ] each
+        ] with-scope
+    ] [ drop ] if ;
 
 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 

basis/ui/traverse/traverse.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces make sequences kernel math arrays io
-ui.gadgets generic combinators ;
+ui.gadgets generic combinators fry sets ;
 IN: ui.traverse
 
 TUPLE: node value children ;
@@ -85,3 +85,13 @@ M: node gadget-text*
 
 : gadget-at-path ( parent path -- gadget )
     [ swap nth-gadget ] each ;
+
+GENERIC# leaves* 1 ( tree assoc -- )
+
+M: node leaves* [ children>> ] dip leaves* ;
+
+M: array leaves* '[ _ leaves* ] each ;
+
+M: gadget leaves* conjoin ;
+
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;

extra/c/preprocessor/preprocessor-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test c.preprocessor kernel accessors ;
+USING: tools.test c.preprocessor kernel accessors multiline ;
 IN: c.preprocessor.tests
 
 [ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
@@ -9,8 +9,18 @@ IN: c.preprocessor.tests
 [ "yo\n\n\n\nyo4\n" ]
 [ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
 
+/*
 [ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
 [ "\"BOO\"" = ] must-fail-with
+*/
 
 [ V{ "\"omg\"" "\"lol\"" } ]
 [ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
+
+
+/*
+f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1); 
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1); 
+int i[] = { 1, 23, 4, 5, }; 
+char c[2][6] = { "hello", "" }; 
+*/

extra/c/preprocessor/preprocessor.factor

@@ -3,24 +3,41 @@
 USING: html.parser.state io io.encodings.utf8 io.files
 io.streams.string kernel combinators accessors io.pathnames
 fry sequences arrays locals namespaces io.directories
-assocs math splitting make ;
+assocs math splitting make unicode.categories
+combinators.short-circuit ;
 IN: c.preprocessor
 
 : initial-library-paths ( -- seq )
     V{ "/usr/include" } clone ;
 
+: initial-symbol-table ( -- hashtable )
+    H{
+        { "__APPLE__" "" }
+        { "__amd64__" "" }
+        { "__x86_64__" "" }
+    } clone ;
+
 TUPLE: preprocessor-state library-paths symbol-table
 include-nesting include-nesting-max processing-disabled?
-ifdef-nesting warnings ;
+ifdef-nesting warnings errors
+pragmas
+include-nexts
+ifs elifs elses ;
 
 : <preprocessor-state> ( -- preprocessor-state )
     preprocessor-state new
         initial-library-paths >>library-paths
-        H{ } clone >>symbol-table
+        initial-symbol-table >>symbol-table
         0 >>include-nesting
         200 >>include-nesting-max
         0 >>ifdef-nesting
-        V{ } clone >>warnings ;
+        V{ } clone >>warnings
+        V{ } clone >>errors
+        V{ } clone >>pragmas
+        V{ } clone >>include-nexts
+        V{ } clone >>ifs
+        V{ } clone >>elifs
+        V{ } clone >>elses ;
 
 DEFER: preprocess-file
 
@@ -64,8 +81,13 @@ ERROR: header-file-missing path ;
 
 : readlns ( -- string ) [ (readlns) ] { } make concat ;
 
+: take-define-identifier ( state-parser -- string )
+    skip-whitespace
+    [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
 : handle-define ( preprocessor-state state-parser -- )
-    [ take-token ] [ take-rest ] bi 
+    [ take-define-identifier ]
+    [ skip-whitespace take-rest ] bi 
     "\\" ?tail [ readlns append ] when
     spin symbol-table>> set-at ;
 
@@ -86,9 +108,25 @@ ERROR: header-file-missing path ;
 : handle-endif ( preprocessor-state state-parser -- )
     drop [ 1 - ] change-ifdef-nesting drop ;
 
+: handle-if ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    skip-whitespace take-rest swap ifs>> push ;
+
+: handle-elif ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap elifs>> push ;
+
+: handle-else ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap elses>> push ;
+
+: handle-pragma ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap pragmas>> push ;
+
+: handle-include-next ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap include-nexts>> push ;
+
 : handle-error ( preprocessor-state state-parser -- )
-    skip-whitespace
+    skip-whitespace take-rest swap errors>> push ;
-    nip take-rest throw ;
+    ! nip take-rest throw ;
 
 : handle-warning ( preprocessor-state state-parser -- )
     skip-whitespace
@@ -104,11 +142,11 @@ ERROR: header-file-missing path ;
         { "ifdef" [ handle-ifdef ] }
         { "ifndef" [ handle-ifndef ] }
         { "endif" [ handle-endif ] }
-        { "if" [ 2drop ] }
+        { "if" [ handle-if ] }
-        { "elif" [ 2drop ] }
+        { "elif" [ handle-elif ] }
-        { "else" [ 2drop ] }
+        { "else" [ handle-else ] }
-        { "pragma" [ 2drop ] }
+        { "pragma" [ handle-pragma ] }
-        { "include_next" [ 2drop ] }
+        { "include_next" [ handle-include-next ] }
         [ unknown-c-preprocessor ]
     } case ;
 

extra/c/tests/test10/test10.c

@@ -0,0 +1,3 @@
+/*
+# lol
+*/

extra/c/tests/test11/foo.h

@@ -0,0 +1 @@
+foo.h ftw

extra/c/tests/test11/test11.c

@@ -0,0 +1,2 @@
+#define FOO_H "foo.h"
+#include FOO_H

extra/c/tests/test12/test12.c

@@ -0,0 +1,3 @@
+#if 4 > (5 - 4++)
+#error "Umm"
+#endif

extra/c/tests/test13/test13.c

@@ -0,0 +1,2 @@
+#if 10
+#error "Umm"

extra/c/tests/test14/test14.c

@@ -0,0 +1,15 @@
+#if 4 > (1 + 2) 
+good
+#endif
+
+#if 4 > 1 + 2
+good
+#endif
+
+#if (4 > 1) - 1
+bad
+#endif
+
+#if (4 > 1) - 2
+good
+#endif

extra/c/tests/test5/test5.c

@@ -0,0 +1,3 @@
+#define TABSIZE 100
+
+int table[TABSIZE];

extra/c/tests/test6/test6.c

@@ -0,0 +1 @@
+#define max(a, b) ((a) > (b) ? (a) : (b))

extra/c/tests/test7/test7.c

@@ -0,0 +1,19 @@
+#define x 3 
+#define f(a) f(x * (a)) 
+#undef x 
+#define x 2 
+#define g f 
+#define z z[0] 
+#define h g(~ 
+#define m(a) a(w) 
+#define w 0,1 
+#define t(a) a 
+#define p() int 
+#define q(x) x 
+#define r(x,y) x ## y 
+#define str(x) # x 
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1); 
+g(x+(3,4)-w) | h 5) & m 
+(f)^m(m); 
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) }; 
+char c[2][6] = { str(hello), str() }; 

extra/c/tests/test8/test8.c

@@ -0,0 +1,15 @@
+#define str(s) #s 
+#define xstr(s) str(s) 
+#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \ 
+x ## s, x ## t) 
+#define INCFILE(n) vers ## n 
+#define glue(a, b) a## b 
+#define xglue(a, b) glue(a, b) 
+#define HIGHLOW "hello" 
+#define LOW LOW ", world" 
+debug(1, 2); 
+fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away 
+== 0) str(: @\n), s); 
+#include xstr(INCFILE(2).h) 
+glue(HIGH, LOW); 
+xglue(HIGH, LOW) 

extra/c/tests/test9/test9.c

@@ -0,0 +1,4 @@
+#define t(x,y,z) x ## y ## z 
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), 
+t(10,,), t(,11,), t(,,12), t(,,) }; 
+

extra/demos/demos.factor

@@ -1,22 +1,16 @@
-
+USING: kernel fry sequences vocabs.loader help.vocabs ui
-USING: kernel fry sequences
+ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
-       vocabs.loader help.vocabs
+ui.gadgets.scrollers ui.tools.listener accessors ;
-       ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
-       ui.tools.listener
-       accessors ;
-
 IN: demos
 
 : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
 
 : <run-vocab-button> ( vocab-name -- button )
-  dup '[ drop [ _ run ] call-listener ] <border-button> ;
+    dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
 
 : <demo-runner> ( -- gadget )
-  <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
+    <pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
 
-: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
+: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 MAIN: demos

extra/descriptive/descriptive.factor

@@ -1,13 +1,16 @@
 USING: words kernel sequences locals locals.parser
 locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays ;
+summary definitions generalizations arrays prettyprint debugger io ;
 IN: descriptive
 
 ERROR: descriptive-error args underlying word ;
 
-M: descriptive-error summary
+M: descriptive-error error.
-    word>> "The " swap name>> " word encountered an error."
+    "The word " write dup word>> pprint " encountered an error." print
-    3append ;
+    "Arguments:" print
+    dup args>> stack.
+    "Error:" print
+    underlying>> error. ;
 
 <PRIVATE
 

extra/peg/pl0/pl0.factor

@@ -6,20 +6,20 @@ IN: peg.pl0
 
 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
 
-EBNF: pl0 
+EBNF: pl0
 
-block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }? 
+block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }?
-               { "VAR" ident { "," ident }* ";" }? 
+               { "VAR" ident { "," ident }* ";" }?
-               { "PROCEDURE" ident ";" { block ";" }? }* statement 
+               { "PROCEDURE" ident ";" { block ";" }? }* statement
-statement   =  {  ident ":=" expression 
+statement   =  {  ident ":=" expression
-                | "CALL" ident 
+                | "CALL" ident
-                | "BEGIN" statement { ";" statement }* "END" 
+                | "BEGIN" statement { ";" statement }* "END"
-                | "IF" condition "THEN" statement 
+                | "IF" condition "THEN" statement
-                | "WHILE" condition "DO" statement }?  
+                | "WHILE" condition "DO" statement }?
 condition   =  { "ODD" expression }
              | { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-expression  = {"+" | "-"}? term { {"+" | "-"} term }* 
+expression  = {"+" | "-"}? term { {"+" | "-"} term }*
-term        = factor { {"*" | "/"} factor }* 
+term        = factor { {"*" | "/"} factor }*
 factor      = ident | number | "(" expression ")"
 ident       = (([a-zA-Z])+)   => [[ >string ]]
 digit       = ([0-9])         => [[ digit> ]]

extra/project-euler/001/001-tests.factor

@@ -4,3 +4,4 @@ IN: project-euler.001.tests
 [ 233168 ] [ euler001 ] unit-test
 [ 233168 ] [ euler001a ] unit-test
 [ 233168 ] [ euler001b ] unit-test
+[ 233168 ] [ euler001c ] unit-test

extra/project-euler/001/001.factor

@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
 IN: project-euler.001
 
 ! http://projecteuler.net/index.php?section=problems&id=1
@@ -51,4 +51,11 @@ PRIVATE>
 ! [ euler001b ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials
 
+
+: euler001c ( -- answer )
+    1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+
+! [ euler001c ] 100 ave-time
+! 0 ms ave run time - 0.06 SD (100 trials)
+
 SOLUTION: euler001

extra/project-euler/004/004.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
+USING: hashtables kernel math math.functions math.ranges project-euler.common
-    sorting sets ;
+    sequences sorting sets ;
 IN: project-euler.004
 
 ! http://projecteuler.net/index.php?section=problems&id=4
@@ -21,7 +21,7 @@ IN: project-euler.004
 <PRIVATE
 
 : source-004 ( -- seq )
-    100 999 [a,b] [ 10 mod 0 = not ] filter ;
+    100 999 [a,b] [ 10 divisor? not ] filter ;
 
 : max-palindrome ( seq -- palindrome )
     natural-sort [ palindrome? ] find-last nip ;

extra/project-euler/014/014.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges
+USING: combinators.short-circuit kernel make math math.functions math.ranges
-sequences project-euler.common ;
+    sequences project-euler.common ;
 IN: project-euler.014
 
 ! http://projecteuler.net/index.php?section=problems&id=14
@@ -59,7 +59,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
+    1- 3 { [ divisor? ] [ / even? ] } 2&& ;
 
 PRIVATE>
 

extra/project-euler/033/033.factor

@@ -33,7 +33,7 @@ IN: project-euler.033
     10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
 
 : safe? ( ax xb -- ? )
-    [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
+    [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;
 
 : ax/xb ( ax xb -- z/f )
     2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;

extra/project-euler/043/043.factor

@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.combinatorics math.parser
+USING: combinators.short-circuit kernel math math.functions math.combinatorics
-    math.ranges project-euler.common sequences sets sorting ;
+    math.parser math.ranges project-euler.common sequences sets sorting ;
 IN: project-euler.043
 
 ! http://projecteuler.net/index.php?section=problems&id=43
@@ -36,7 +36,7 @@ IN: project-euler.043
 <PRIVATE
 
 : subseq-divisible? ( n index seq -- ? )
-    [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+    [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
 
 : interesting? ( seq -- ? )
     {

extra/project-euler/049/049-tests.factor

@@ -0,0 +1,4 @@
+USING: project-euler.049 tools.test ;
+IN: project-euler.049.tests
+
+[ 296962999629 ] [ euler049 ] unit-test

extra/project-euler/049/049.factor

@@ -0,0 +1,74 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays fry hints kernel math math.combinatorics
+    math.functions math.parser math.primes project-euler.common sequences sets ;
+IN: project-euler.049
+
+! http://projecteuler.net/index.php?section=problems&id=49
+
+! DESCRIPTION
+! -----------
+
+! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+! increases by 3330, is unusual in two ways: (i) each of the three terms are
+! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
+
+! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
+! exhibiting this property, but there is one other 4-digit increasing sequence.
+
+! What 12-digit number do you form by concatenating the three terms in this
+! sequence?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+    10 <byte-array> [
+        '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+    ] keep ;
+
+HINTS: count-digits fixnum ;
+
+: permutations? ( n m -- ? )
+    [ count-digits ] bi@ = ;
+
+: collect-permutations ( seq -- seq )
+    [ V{ } clone ] [ dup ] bi* [
+        dupd '[ _ permutations? ] filter
+        [ diff ] keep pick push
+    ] each drop ;
+
+: potential-sequences ( -- seq )
+    1000 9999 primes-between
+    collect-permutations [ length 3 >= ] filter ;
+
+: arithmetic-terms ( m n -- seq )
+    2dup [ swap - ] keep + 3array ;
+
+: (find-unusual-terms) ( n seq -- seq/f )
+    [ [ arithmetic-terms ] with map ] keep
+    '[ _ [ peek ] dip member? ] find nip ;
+
+: find-unusual-terms ( seq -- seq/? )
+    unclip-slice over (find-unusual-terms) [
+        nip
+    ] [
+        dup length 3 >= [ find-unusual-terms ] [ drop f ] if
+    ] if* ;
+
+: 4digit-concat ( seq -- str )
+    0 [ [ 10000 * ] dip + ] reduce ;
+
+PRIVATE>
+
+: euler049 ( -- answer )
+    potential-sequences [ find-unusual-terms ] map sift
+    [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
+
+! [ euler049 ] 100 ave-time
+! 206 ms ave run time - 10.25 SD (100 trials)
+
+SOLUTION: euler049

extra/project-euler/052/052.factor

@@ -1,8 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math
+USING: combinators.short-circuit kernel math math.functions
-    project-euler.common sequences sorting
+    project-euler.common sequences sorting grouping ;
-    grouping ;
 IN: project-euler.052
 
 ! http://projecteuler.net/index.php?section=problems&id=52
@@ -31,7 +30,7 @@ IN: project-euler.052
     [ number>digits natural-sort ] map all-equal? ;
 
 : candidate? ( n -- ? )
-    { [ odd? ] [ 3 mod 0 = ] } 1&& ;
+    { [ odd? ] [ 3 divisor? ] } 1&& ;
 
 : next-all-same ( x n -- n )
     dup candidate? [

extra/project-euler/common/common.factor

@@ -44,7 +44,7 @@ IN: project-euler.common
 
 : (sum-divisors) ( n -- sum )
     dup sqrt >integer [1,b] [
-        [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
+        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
     ] { } make sum ;
 
@@ -57,7 +57,7 @@ PRIVATE>
     >lower [ CHAR: a - 1+ ] sigma ;
 
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
-    swap [ swap [ 2array ] with map ] with map concat ;
+    [ [ 2array ] with map ] curry map concat ;
 
 : log10 ( m -- n )
     log 10 log / ;
@@ -75,6 +75,9 @@ PRIVATE>
 : number>digits ( n -- seq )
     [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
 
+: number-length ( n -- m )
+    log10 floor 1+ >integer ;
+
 : nth-triangle ( n -- n )
     dup 1+ * 2 / ;
 
@@ -117,7 +120,7 @@ PRIVATE>
     factor-2s dup [ 1+ ]
     [ perfect-square? -1 0 ? ]
     [ dup sqrt >fixnum [1,b] ] tri* [
-        dupd mod 0 = [ [ 2 + ] dip ] when
+        dupd divisor? [ [ 2 + ] dip ] when
     ] each drop * ;
 
 ! These transforms are for generating primitive Pythagorean triples
@@ -134,4 +137,3 @@ SYNTAX: SOLUTION:
     [ drop in get vocab (>>main) ]
     [ [ . ] swap prefix (( -- )) define-declared ]
     2bi ;
-

extra/project-euler/project-euler.factor

@@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
     project-euler.037 project-euler.038 project-euler.039 project-euler.040
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
-    project-euler.052 project-euler.053 project-euler.055 project-euler.056
+    project-euler.049 project-euler.052 project-euler.053 project-euler.055
-    project-euler.057 project-euler.059 project-euler.067 project-euler.071
+    project-euler.056 project-euler.057 project-euler.059 project-euler.067
-    project-euler.073 project-euler.075 project-euler.076 project-euler.079
+    project-euler.071 project-euler.073 project-euler.075 project-euler.076
-    project-euler.092 project-euler.097 project-euler.099 project-euler.100
+    project-euler.079 project-euler.092 project-euler.097 project-euler.099
-    project-euler.116 project-euler.117 project-euler.134 project-euler.148
+    project-euler.100 project-euler.116 project-euler.117 project-euler.134
-    project-euler.150 project-euler.151 project-euler.164 project-euler.169
+    project-euler.148 project-euler.150 project-euler.151 project-euler.164
-    project-euler.173 project-euler.175 project-euler.186 project-euler.190
+    project-euler.169 project-euler.173 project-euler.175 project-euler.186
-    project-euler.203 project-euler.215 ;
+    project-euler.190 project-euler.203 project-euler.215 ;
 IN: project-euler
 
 <PRIVATE

misc/fuel/fuel-font-lock.el

@@ -58,6 +58,7 @@
   (number constant  "integers and floats")
   (ratio constant  "ratios")
   (declaration keyword "declaration words")
+  (ebnf-form constant "EBNF: ... ;EBNF form")
   (parsing-word keyword  "parsing words")
   (setter-word function-name "setter words (>>foo)")
   (getter-word function-name "getter words (foo>>)")
@@ -75,7 +76,9 @@
 (defun fuel-font-lock--syntactic-face (state)
   (if (nth 3 state) 'factor-font-lock-string
     (let ((c (char-after (nth 8 state))))
-      (cond ((or (char-equal c ?\ ) (char-equal c ?\n))
+      (cond ((or (char-equal c ?\ )
+                 (char-equal c ?\n)
+                 (char-equal c ?E))
              (save-excursion
                (goto-char (nth 8 state))
                (beginning-of-line)
@@ -85,6 +88,8 @@
                       'factor-font-lock-symbol)
                      ((looking-at-p "C-ENUM:\\( \\|\n\\)")
                       'factor-font-lock-constant)
+                     ((looking-at-p "E")
+                      'factor-font-lock-ebnf-form)
                      (t 'default))))
             ((or (char-equal c ?U) (char-equal c ?C))
              'factor-font-lock-parsing-word)

misc/fuel/fuel-syntax.el

@@ -48,7 +48,7 @@
     "B" "BIN:"
     "C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
     "DEFER:"
-    "ERROR:" "EXCLUDE:"
+    "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
     "f" "FORGET:" "FROM:" "FUNCTION:"
     "GENERIC#" "GENERIC:"
     "HELP:" "HEX:" "HOOK:"
@@ -254,6 +254,8 @@
     ("\\_<<\\(\"\\)\\_>" (1 "<b"))
     ("\\_<\\(\"\\)>\\_>" (1 ">b"))
     ;; Multiline constructs
+    ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
+    ("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
     ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))
     ("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))

vm/platform.h

@@ -96,7 +96,7 @@
 			#if defined(FACTOR_X86)
 				#include "os-solaris-x86.32.h"
 			#elif defined(FACTOR_AMD64)
-				#incluide "os-solaris-x86.64.h"
+				#include "os-solaris-x86.64.h"
 			#else
 				#error "Unsupported Solaris flavor"
 			#endif