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.db4
Aaron Schaefer
commit
5405f530b9
|
|
@ -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,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 -- )
|
||||
|
||||
: 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*
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -65,9 +65,8 @@ HELP: derive-url
|
|||
} ;
|
||||
|
||||
HELP: ensure-port
|
||||
{ $values { "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." }
|
||||
{ $side-effects "url" }
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $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." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors prettyprint urls ;"
|
||||
|
|
|
|||
|
|
@ -175,8 +175,8 @@ PRIVATE>
|
|||
] [ protocol>> ] bi
|
||||
secure-protocol? [ >secure-addr ] when ;
|
||||
|
||||
: ensure-port ( url -- url )
|
||||
dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
: ensure-port ( url -- url' )
|
||||
clone dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
|
||||
! Literal syntax
|
||||
SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 @@
|
|||
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"
|
||||
|
|
@ -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
|
||||
|
|
@ -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"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue