steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2009-04-02 11:59:59 -04:00
parent d6e646389c de357bacdb
commit 5405f530b9
27 changed files with 339 additions and 96 deletions

2
basis/help/tips/tips-docs.factor
View 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" } }

3
basis/ui/gadgets/gadgets.factor
View 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 ;

33
basis/ui/gadgets/panes/panes.factor
View 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,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 ;

101
basis/ui/render/render.factor
View File

@ -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 }

14
basis/ui/traverse/traverse.factor
View 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 ;

5
basis/unicode/categories/categories-tests.factor
View 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

2
basis/unicode/categories/categories.factor
View 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 ;

5
basis/urls/urls-docs.factor
View File

@ -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 ;"

4
basis/urls/urls.factor
View File

@ -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 ;

1
extra/c/preprocessor/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

16
extra/c/preprocessor/preprocessor-tests.factor Normal file
View File

@ -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

155
extra/c/preprocessor/preprocessor.factor Normal file
View File

@ -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 ;

1
extra/c/tests/test1/README Normal file
View File

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

1
extra/c/tests/test1/hi.h Normal file
View File

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

1
extra/c/tests/test1/lo.h Normal file
View File

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

1
extra/c/tests/test1/test1.c Normal file
View File

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

1
extra/c/tests/test2/README Normal file
View File

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

17
extra/c/tests/test2/test2.c Normal file
View File

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

1
extra/c/tests/test3/README Normal file
View File

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

1
extra/c/tests/test3/test3.c Normal file
View File

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

2
extra/c/tests/test4/test4.c Normal file
View File

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

18
extra/demos/demos.factor
View 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 ;
<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

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

11
extra/html/parser/state/state.factor
View 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 ;

22
extra/peg/pl0/pl0.factor
View 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> ]]

7
misc/fuel/fuel-font-lock.el
View 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)

4
misc/fuel/fuel-syntax.el
View 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:"
@ -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"))