Merge branch 'master' into uniscribe
U-SLAVA-DFB8FF805\Slava
commit
745a435475
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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", "" };
|
||||
*/
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "lo.h"
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "hi.h"
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "hi.h"
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
/*
|
||||
# lol
|
||||
*/
|
||||
|
|
@ -0,0 +1 @@
|
|||
foo.h ftw
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#define FOO_H "foo.h"
|
||||
#include FOO_H
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#if 4 > (5 - 4++)
|
||||
#error "Umm"
|
||||
#endif
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#if 10
|
||||
#error "Umm"
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests whether #define and #ifdef/#endif work in the positive case.
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#define YO
|
||||
#ifdef YO
|
||||
yo
|
||||
#endif
|
||||
|
||||
#define YO2
|
||||
#ifndef YO2
|
||||
yo2
|
||||
#endif
|
||||
|
||||
#ifdef YO3
|
||||
yo3
|
||||
#endif
|
||||
|
||||
#ifndef YO4
|
||||
yo4
|
||||
#endif
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests whether #define and #ifdef/#endif work in the positive case.
|
||||
|
|
@ -0,0 +1 @@
|
|||
#error "BOO"
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#warning "omg"
|
||||
#warning "lol"
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#define TABSIZE 100
|
||||
|
||||
int table[TABSIZE];
|
||||
|
|
@ -0,0 +1 @@
|
|||
#define max(a, b) ((a) > (b) ? (a) : (b))
|
||||
|
|
@ -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() };
|
||||
|
|
@ -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)
|
||||
|
|
@ -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(,,) };
|
||||
|
||||
|
|
@ -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 ;
|
||||
<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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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> ]]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue