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

* 'master' of git://factorcode.org/git/factor:
  Fix UI pane selection
  use unicode instead of ascii again
  Fix up 'demos' vocab
  beginnings of a c preprocessor -- needs #if, #elif, #else
  Tabs are blank (better unicode whitespace support coming soon)
  fix take-rest for out of bounds
  Partial fix for pane selection
  ensure-port outputs a new URL instead of mutating its input
  FUEL: Font lock and no indentation for EBNF: ... ;EBNF forms.

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/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,31 +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 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 ;

basis/unicode/categories/categories-tests.factor

@@ -12,3 +12,8 @@ IN: unicode.categories.tests
 [ "Lo" ] [ HEX: 3450 category ] unit-test
 [ "Lo" ] [ HEX: 4DB5 category ] unit-test
 [ "Cs" ] [ HEX: DD00 category ] unit-test
+[ t ] [ CHAR: \t blank? ] unit-test
+[ t ] [ CHAR: \s blank? ] unit-test
+[ t ] [ CHAR: \r blank? ] unit-test
+[ t ] [ CHAR: \n blank? ] unit-test
+[ f ] [ CHAR: a blank? ] unit-test

basis/unicode/categories/categories.factor

@@ -3,7 +3,7 @@
 USING: unicode.categories.syntax sequences unicode.data ;
 IN: unicode.categories
 
-CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
+CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
 CATEGORY: letter Ll | "Other_Lowercase" property? ;
 CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
 CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;

basis/urls/urls-docs.factor

@@ -65,9 +65,8 @@ HELP: derive-url
 } ;
 
 HELP: ensure-port
-{ $values { "url" url } }
+{ $values { "url" url } { "url'" url } }
-{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
+{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
-{ $side-effects "url" }
 { $examples
     { $example
         "USING: accessors prettyprint urls ;"

basis/urls/urls.factor

@@ -175,8 +175,8 @@ PRIVATE>
     ] [ protocol>> ] bi
     secure-protocol? [ >secure-addr ] when ;
 
-: ensure-port ( url -- url )
+: ensure-port ( url -- url' )
-    dup protocol>> '[ _ protocol-port or ] change-port ;
+    clone dup protocol>> '[ _ protocol-port or ] change-port ;
 
 ! Literal syntax
 SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;

extra/c/preprocessor/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/c/preprocessor/preprocessor-tests.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors ;
+IN: c.preprocessor.tests
+
+[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
+[ include-nested-too-deeply? ] must-fail-with
+
+[ "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

extra/c/preprocessor/preprocessor.factor

@@ -0,0 +1,155 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+IN: c.preprocessor
+
+: initial-library-paths ( -- seq )
+    V{ "/usr/include" } clone ;
+
+TUPLE: preprocessor-state library-paths symbol-table
+include-nesting include-nesting-max processing-disabled?
+ifdef-nesting warnings ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+    preprocessor-state new
+        initial-library-paths >>library-paths
+        H{ } clone >>symbol-table
+        0 >>include-nesting
+        200 >>include-nesting-max
+        0 >>ifdef-nesting
+        V{ } clone >>warnings ;
+
+DEFER: preprocess-file
+
+ERROR: unknown-c-preprocessor state-parser name ;
+
+ERROR: bad-include-line line ;
+
+ERROR: header-file-missing path ;
+
+:: read-standard-include ( preprocessor-state path -- )
+    preprocessor-state dup library-paths>>
+    [ path append-path exists? ] find nip
+    [
+        dup [
+            path append-path
+            preprocess-file
+        ] with-directory
+    ] [
+        ! path header-file-missing
+        drop
+    ] if* ;
+
+:: read-local-include ( preprocessor-state path -- )
+    current-directory get path append-path dup :> full-path
+    dup exists? [
+        [ preprocessor-state ] dip preprocess-file
+    ] [
+        ! full-path header-file-missing
+        drop
+    ] if ;
+
+: handle-include ( preprocessor-state state-parser -- )
+    skip-whitespace advance dup previous {
+        { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
+        { CHAR: " [ CHAR: " take-until-object read-local-include ] }
+        [ bad-include-line ]
+    } case ;
+
+: (readlns) ( -- )
+    readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
+
+: readlns ( -- string ) [ (readlns) ] { } make concat ;
+
+: handle-define ( preprocessor-state state-parser -- )
+    [ take-token ] [ take-rest ] bi 
+    "\\" ?tail [ readlns append ] when
+    spin symbol-table>> set-at ;
+
+: handle-undef ( preprocessor-state state-parser -- )
+    take-token swap symbol-table>> delete-at ;
+
+: handle-ifdef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ drop ] [ t >>processing-disabled? drop ] if ;
+
+: handle-ifndef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ t >>processing-disabled? drop ]
+    [ drop ] if ; 
+
+: handle-endif ( preprocessor-state state-parser -- )
+    drop [ 1 - ] change-ifdef-nesting drop ;
+
+: handle-error ( preprocessor-state state-parser -- )
+    skip-whitespace
+    nip take-rest throw ;
+
+: handle-warning ( preprocessor-state state-parser -- )
+    skip-whitespace
+    take-rest swap warnings>> push ;
+
+: parse-directive ( preprocessor-state state-parser string -- )
+    {
+        { "warning" [ handle-warning ] }
+        { "error" [ handle-error ] }
+        { "include" [ handle-include ] }
+        { "define" [ handle-define ] }
+        { "undef" [ handle-undef ] }
+        { "ifdef" [ handle-ifdef ] }
+        { "ifndef" [ handle-ifndef ] }
+        { "endif" [ handle-endif ] }
+        { "if" [ 2drop ] }
+        { "elif" [ 2drop ] }
+        { "else" [ 2drop ] }
+        { "pragma" [ 2drop ] }
+        { "include_next" [ 2drop ] }
+        [ unknown-c-preprocessor ]
+    } case ;
+
+: parse-directive-line ( preprocessor-state state-parser -- )
+    advance dup take-token
+    pick processing-disabled?>> [
+        "endif" = [
+            drop f >>processing-disabled?
+            [ 1 - ] change-ifdef-nesting
+            drop
+         ] [ 2drop ] if
+    ] [
+        parse-directive
+    ] if ;
+
+: preprocess-line ( preprocessor-state state-parser -- )
+    skip-whitespace dup current CHAR: # =
+    [ parse-directive-line ]
+    [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
+
+: preprocess-lines ( preprocessor-state -- )
+    readln 
+    [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+    [ drop ] if* ;
+
+ERROR: include-nested-too-deeply ;
+
+: check-nesting ( preprocessor-state -- preprocessor-state )
+    [ 1 + ] change-include-nesting
+    dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
+        include-nested-too-deeply
+    ] when ;
+
+: preprocess-file ( preprocessor-state path -- )
+    [ check-nesting ] dip
+    [ utf8 [ preprocess-lines ] with-file-reader ]
+    [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
+
+: start-preprocess-file ( path -- preprocessor-state string )
+    dup parent-directory [
+        [
+            [ <preprocessor-state> dup ] dip preprocess-file
+        ] with-string-writer
+    ] with-directory ;

extra/c/tests/test1/README

@@ -0,0 +1 @@
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.

extra/c/tests/test1/hi.h

@@ -0,0 +1 @@
+#include "lo.h"

extra/c/tests/test1/lo.h

@@ -0,0 +1 @@
+#include "hi.h"

extra/c/tests/test1/test1.c

@@ -0,0 +1 @@
+#include "hi.h"

extra/c/tests/test2/README

@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.

extra/c/tests/test2/test2.c

@@ -0,0 +1,17 @@
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif

extra/c/tests/test3/README

@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.

extra/c/tests/test3/test3.c

@@ -0,0 +1 @@
+#error "BOO"

extra/c/tests/test4/test4.c

@@ -0,0 +1,2 @@
+#warning "omg"
+#warning "lol"

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/html/parser/state/state-tests.factor

@@ -93,3 +93,9 @@ IN: html.parser.state.tests
 
 [ "abcd e \\\"f g" ]
 [ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <state-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test

extra/html/parser/state/state.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
 unicode.case unicode.categories locals combinators.short-circuit
-make combinators ;
+make combinators io splitting ;
 
 IN: html.parser.state
 
@@ -74,8 +74,12 @@ TUPLE: state-parser sequence n ;
 : skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
+: take-rest-slice ( state-parser -- sequence/f )
+    [ sequence>> ] [ n>> ] bi
+    2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
 : take-rest ( state-parser -- sequence )
-    [ drop f ] take-until ; inline
+    [ take-rest-slice ] [ sequence>> like ] bi ;
 
 : take-until-object ( state-parser obj -- sequence )
     '[ current _ = ] take-until ;
@@ -111,3 +115,6 @@ TUPLE: state-parser sequence n ;
 
 : take-token ( state-parser -- string/f )
     CHAR: \ CHAR: " take-token* ;
+
+: write-full ( state-parser -- ) sequence>> write ;
+: write-rest ( state-parser -- ) take-rest write ;

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"))