]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge branch 'master' into uniscribe
authorU-SLAVA-DFB8FF805\Slava <Slava@slava-dfb8ff805.(none)>
Thu, 2 Apr 2009 18:19:30 +0000 (13:19 -0500)
committerU-SLAVA-DFB8FF805\Slava <Slava@slava-dfb8ff805.(none)>
Thu, 2 Apr 2009 18:19:30 +0000 (13:19 -0500)
38 files changed:
basis/help/tips/tips-docs.factor
basis/ui/gadgets/gadgets.factor
basis/ui/gadgets/panes/panes.factor
basis/ui/render/render.factor
basis/ui/traverse/traverse.factor
basis/unicode/categories/categories-tests.factor
basis/unicode/categories/categories.factor
extra/c/preprocessor/authors.txt [new file with mode: 0644]
extra/c/preprocessor/preprocessor-tests.factor [new file with mode: 0644]
extra/c/preprocessor/preprocessor.factor [new file with mode: 0644]
extra/c/tests/test1/README [new file with mode: 0644]
extra/c/tests/test1/hi.h [new file with mode: 0644]
extra/c/tests/test1/lo.h [new file with mode: 0644]
extra/c/tests/test1/test1.c [new file with mode: 0644]
extra/c/tests/test10/test10.c [new file with mode: 0644]
extra/c/tests/test11/foo.h [new file with mode: 0644]
extra/c/tests/test11/test11.c [new file with mode: 0644]
extra/c/tests/test12/test12.c [new file with mode: 0644]
extra/c/tests/test13/test13.c [new file with mode: 0644]
extra/c/tests/test14/test14.c [new file with mode: 0644]
extra/c/tests/test2/README [new file with mode: 0644]
extra/c/tests/test2/test2.c [new file with mode: 0644]
extra/c/tests/test3/README [new file with mode: 0644]
extra/c/tests/test3/test3.c [new file with mode: 0644]
extra/c/tests/test4/test4.c [new file with mode: 0644]
extra/c/tests/test5/test5.c [new file with mode: 0644]
extra/c/tests/test6/test6.c [new file with mode: 0644]
extra/c/tests/test7/test7.c [new file with mode: 0644]
extra/c/tests/test8/test8.c [new file with mode: 0644]
extra/c/tests/test9/test9.c [new file with mode: 0644]
extra/demos/demos.factor
extra/descriptive/descriptive.factor
extra/html/parser/state/state-tests.factor
extra/html/parser/state/state.factor
extra/peg/pl0/pl0.factor
misc/fuel/fuel-font-lock.el
misc/fuel/fuel-syntax.el
vm/platform.h

index 750eff7a52b7d8b1fda97ef0ba5c1427f5873434..48ed65b3189f840ba85e0ce874497d4e3a1f6255 100644 (file)
@@ -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" } }
index adcfdfb00d195c58bc8973d280b4cbf0401b3209..bc07006d623d8c5efffb4a531b41c105b23cdd0f 100644 (file)
@@ -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 ;
 
index 41e983eb28b9ae9c3d200ac35b6bbf15539398e2..6f6e7ee95f52da0029c088c6712b5d62c77e00d4 100644 (file)
@@ -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 -- )
-
-: 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*
+M: pane selected-children
     dup gadget-selection? [
-        [ selection-color>> gl-color ]
-        [
-            [ loc>> vneg ] keep selected-children
-            [ draw-selection ] with each
-        ] bi
-    ] [ drop ] if ;
+        [ selected-subtree leaves ]
+        [ selection-color>> ]
+        bi
+    ] [ drop f f ] if ;
 
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
index 4c8f7c24e5a7f251159122c92529ac282d13a42b..09c26fd2711d2255a7030b815c172e016df0f444 100755 (executable)
@@ -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 [
-        [
-            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
+        [ draw-background ] [ draw-children ] [ draw-border ] 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 ]
-    [ gadget-background ]
-    [ gadget-foreground ] tri [
-        [ foreground set ] when*
-        [ background set ] when*
-        [ draw-gadget ] each
-    ] with-scope ;
+    dup children>> [
+        {
+            [ visible-children ]
+            [ selected-children ]
+            [ gadget-background ]
+            [ gadget-foreground ]
+        } 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 }
 
index 63c656205c9d410fcc1a17b5d759aae3d82aa324..9df084210dfdacea63ab361169543653f64ac0d6 100644 (file)
@@ -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 ;
\ No newline at end of file
index 1e718cf9b7c76dbac78e681771eda8e575ba24b3..0970df7ad8c6618b55cdd5c3e09e2433ba2b3e13 100644 (file)
@@ -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
index 126c03c8698c431e5fea9b32be446675122f1948..4ca5c9a90e74bbd9723b14277376a20f4a430654 100644 (file)
@@ -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 ;
diff --git a/extra/c/preprocessor/authors.txt b/extra/c/preprocessor/authors.txt
new file mode 100644 (file)
index 0000000..b4bd0e7
--- /dev/null
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor
new file mode 100644 (file)
index 0000000..ba0531d
--- /dev/null
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors multiline ;
+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
+
+
+/*
+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", "" }; 
+*/
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
new file mode 100644 (file)
index 0000000..f7cd10a
--- /dev/null
@@ -0,0 +1,193 @@
+! 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 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 errors
+pragmas
+include-nexts
+ifs elifs elses ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+    preprocessor-state new
+        initial-library-paths >>library-paths
+        initial-symbol-table >>symbol-table
+        0 >>include-nesting
+        200 >>include-nesting-max
+        0 >>ifdef-nesting
+        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
+
+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 ;
+
+: take-define-identifier ( state-parser -- string )
+    skip-whitespace
+    [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+: handle-define ( preprocessor-state state-parser -- )
+    [ take-define-identifier ]
+    [ skip-whitespace 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-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 take-rest swap errors>> push ;
+    ! 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" [ handle-if ] }
+        { "elif" [ handle-elif ] }
+        { "else" [ handle-else ] }
+        { "pragma" [ handle-pragma ] }
+        { "include_next" [ handle-include-next ] }
+        [ 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 ;
diff --git a/extra/c/tests/test1/README b/extra/c/tests/test1/README
new file mode 100644 (file)
index 0000000..9987313
--- /dev/null
@@ -0,0 +1 @@
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
diff --git a/extra/c/tests/test1/hi.h b/extra/c/tests/test1/hi.h
new file mode 100644 (file)
index 0000000..c9f337c
--- /dev/null
@@ -0,0 +1 @@
+#include "lo.h"
diff --git a/extra/c/tests/test1/lo.h b/extra/c/tests/test1/lo.h
new file mode 100644 (file)
index 0000000..d59fdd2
--- /dev/null
@@ -0,0 +1 @@
+#include "hi.h"
diff --git a/extra/c/tests/test1/test1.c b/extra/c/tests/test1/test1.c
new file mode 100644 (file)
index 0000000..d59fdd2
--- /dev/null
@@ -0,0 +1 @@
+#include "hi.h"
diff --git a/extra/c/tests/test10/test10.c b/extra/c/tests/test10/test10.c
new file mode 100644 (file)
index 0000000..7f38e70
--- /dev/null
@@ -0,0 +1,3 @@
+/*
+# lol
+*/
diff --git a/extra/c/tests/test11/foo.h b/extra/c/tests/test11/foo.h
new file mode 100644 (file)
index 0000000..381b753
--- /dev/null
@@ -0,0 +1 @@
+foo.h ftw
diff --git a/extra/c/tests/test11/test11.c b/extra/c/tests/test11/test11.c
new file mode 100644 (file)
index 0000000..1b05118
--- /dev/null
@@ -0,0 +1,2 @@
+#define FOO_H "foo.h"
+#include FOO_H
diff --git a/extra/c/tests/test12/test12.c b/extra/c/tests/test12/test12.c
new file mode 100644 (file)
index 0000000..2da127b
--- /dev/null
@@ -0,0 +1,3 @@
+#if 4 > (5 - 4++)
+#error "Umm"
+#endif
diff --git a/extra/c/tests/test13/test13.c b/extra/c/tests/test13/test13.c
new file mode 100644 (file)
index 0000000..13c48ff
--- /dev/null
@@ -0,0 +1,2 @@
+#if 10
+#error "Umm"
diff --git a/extra/c/tests/test14/test14.c b/extra/c/tests/test14/test14.c
new file mode 100644 (file)
index 0000000..1697ea1
--- /dev/null
@@ -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
diff --git a/extra/c/tests/test2/README b/extra/c/tests/test2/README
new file mode 100644 (file)
index 0000000..4244828
--- /dev/null
@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.
diff --git a/extra/c/tests/test2/test2.c b/extra/c/tests/test2/test2.c
new file mode 100644 (file)
index 0000000..4cc4191
--- /dev/null
@@ -0,0 +1,17 @@
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif
diff --git a/extra/c/tests/test3/README b/extra/c/tests/test3/README
new file mode 100644 (file)
index 0000000..4244828
--- /dev/null
@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.
diff --git a/extra/c/tests/test3/test3.c b/extra/c/tests/test3/test3.c
new file mode 100644 (file)
index 0000000..8d08e83
--- /dev/null
@@ -0,0 +1 @@
+#error "BOO"
diff --git a/extra/c/tests/test4/test4.c b/extra/c/tests/test4/test4.c
new file mode 100644 (file)
index 0000000..5acd20d
--- /dev/null
@@ -0,0 +1,2 @@
+#warning "omg"
+#warning "lol"
diff --git a/extra/c/tests/test5/test5.c b/extra/c/tests/test5/test5.c
new file mode 100644 (file)
index 0000000..4c16964
--- /dev/null
@@ -0,0 +1,3 @@
+#define TABSIZE 100
+
+int table[TABSIZE];
diff --git a/extra/c/tests/test6/test6.c b/extra/c/tests/test6/test6.c
new file mode 100644 (file)
index 0000000..3b0353a
--- /dev/null
@@ -0,0 +1 @@
+#define max(a, b) ((a) > (b) ? (a) : (b))
diff --git a/extra/c/tests/test7/test7.c b/extra/c/tests/test7/test7.c
new file mode 100644 (file)
index 0000000..4d5e66b
--- /dev/null
@@ -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() }; 
diff --git a/extra/c/tests/test8/test8.c b/extra/c/tests/test8/test8.c
new file mode 100644 (file)
index 0000000..bc1e273
--- /dev/null
@@ -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) 
diff --git a/extra/c/tests/test9/test9.c b/extra/c/tests/test9/test9.c
new file mode 100644 (file)
index 0000000..86940cf
--- /dev/null
@@ -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(,,) }; 
+
index 8c55945105bce4d266a70bb4ad0eb01a740252ef..dfd73f1236d84f758dd6589c03c75c1b95d1fe1e 100644 (file)
@@ -1,22 +1,16 @@
-
-USING: kernel fry sequences
-       vocabs.loader help.vocabs
-       ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
-       ui.tools.listener
-       accessors ;
-
+USING: kernel fry sequences vocabs.loader help.vocabs ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
+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 ;
-
-: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
+    <pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
 
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
 
 MAIN: demos
\ No newline at end of file
index ba3438e37d41751b3d3ad5b1bcadb3bd53e770ee..ceadc9fe6e311d09294d9523703f8c3f2d8193ba 100755 (executable)
@@ -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
-    word>> "The " swap name>> " word encountered an error."
-    3append ;
+M: descriptive-error error.
+    "The word " write dup word>> pprint " encountered an error." print
+    "Arguments:" print
+    dup args>> stack.
+    "Error:" print
+    underlying>> error. ;
 
 <PRIVATE
 
index 63916a3c1c57a86e32261fe0c1689c4c901011b8..75db1a373ecbea5bd56bbb156d96f09e27394831 100644 (file)
@@ -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
index 86adb0f91438d9e6c720c0f8d12bf4428b412274..5f845ce8101954a24336960ec6a35128235e0216 100644 (file)
@@ -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 ;
index eff923dc011eba44d708613286efc92679c34e9d..179e03f1cfbc2bd4ff0e69b2173393db94114b57 100644 (file)
@@ -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 }* ";" }? 
-               { "VAR" ident { "," ident }* ";" }? 
-               { "PROCEDURE" ident ";" { block ";" }? }* statement 
-statement   =  {  ident ":=" expression 
-                | "CALL" ident 
-                | "BEGIN" statement { ";" statement }* "END" 
-                | "IF" condition "THEN" statement 
-                | "WHILE" condition "DO" statement }?  
+block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }?
+               { "VAR" ident { "," ident }* ";" }?
+               { "PROCEDURE" ident ";" { block ";" }? }* statement
+statement   =  {  ident ":=" expression
+                | "CALL" ident
+                | "BEGIN" statement { ";" statement }* "END"
+                | "IF" condition "THEN" statement
+                | "WHILE" condition "DO" statement }?
 condition   =  { "ODD" expression }
              | { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-expression  = {"+" | "-"}? term { {"+" | "-"} term }* 
-term        = factor { {"*" | "/"} factor }* 
+expression  = {"+" | "-"}? term { {"+" | "-"} term }*
+term        = factor { {"*" | "/"} factor }*
 factor      = ident | number | "(" expression ")"
 ident       = (([a-zA-Z])+)   => [[ >string ]]
 digit       = ([0-9])         => [[ digit> ]]
index 5961d9e86fbddacbc5d1080c2020ebc7e59d92df..bc1bb900ce450804cc71e273940eceacff2c7cec 100644 (file)
@@ -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)
index 4cff58ae3b33837a0252680fce0ca75af488ebdf..7aba6282d6c423211f80a710d5657a2df29c01c4 100644 (file)
@@ -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:"
     ("\\_<<\\(\"\\)\\_>" (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"))
index 21336e88bb334247baac661822152311db9a63cb..70804542b4fc318b65a1605d396256484ec6c972 100644 (file)
@@ -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