Merge git://factorcode.org/git/factor

extra/editors/editors.factor

@@ -1,21 +1,36 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tuples tools.crossref io prettyprint
+inspector continuations tuples tools.crossref tools.browser 
-source-files ;
+io prettyprint source-files assocs vocabs vocabs.loader ;
 IN: editors
 
 TUPLE: no-edit-hook ;
 
-M: no-edit-hook summary drop "No edit hook is set" ;
+M: no-edit-hook summary
+    drop "You must load one of the below vocabularies before using editor integration:" ;
 
 SYMBOL: edit-hook
 
+: available-editors ( -- seq )
+    "editors" all-child-vocabs
+    values concat [ vocab-name ] map ;
+
+: editor-restarts ( -- alist )
+    available-editors
+    [ "Load " over append swap ] { } map>assoc ;
+
+: no-edit-hook ( -- )
+    \ no-edit-hook construct-empty
+    editor-restarts throw-restarts
+    require ;
+
 : edit-location ( file line -- )
-    >r ?resource-path r>
+    edit-hook get [
-    edit-hook get dup [
+        >r >r ?resource-path r> r> call
-        \ no-edit-hook construct-empty throw
+    ] [
-    ] if ;
+        no-edit-hook edit-location
+    ] if* ;
 
 : edit ( defspec -- )
     where [ first2 edit-location ] when* ;

extra/parser-combinators/parser-combinators.factor

@@ -1,22 +1,23 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: lazy-lists promises kernel sequences strings math io
+USING: lazy-lists promises kernel sequences strings math
-arrays namespaces splitting ;
+arrays splitting ;
 IN: parser-combinators
 
 ! Parser combinator protocol
-GENERIC: (parse) ( input parser -- list )
+GENERIC: parse ( input parser -- list )
 
-M: promise (parse) ( input parser -- list )
+M: promise parse ( input parser -- list )
-  force (parse) ;
+    force parse ;
-
-: parse ( input parser -- promise )
-  (parse) ;
 
 TUPLE: parse-result parsed unparsed ;
 
 : parse-1 ( input parser -- result )
-  parse car parse-result-parsed ;
+    parse dup nil? [
+        "Parse error" throw
+    ] [
+        car parse-result-parsed
+    ] if ;
 
 C: <parse-result> parse-result
 
@@ -24,105 +25,106 @@ TUPLE: token-parser string ;
 
 C: token token-parser ( string -- parser )
 
-M: token-parser (parse) ( input parser -- list )
+M: token-parser parse ( input parser -- list )
-  token-parser-string swap over ?head-slice [
+    token-parser-string swap over ?head-slice [
-    <parse-result> 1list
+        <parse-result> 1list
-  ] [
+    ] [
-    2drop nil
+        2drop nil
-  ] if ;
+    ] if ;
 
 TUPLE: satisfy-parser quot ;
 
 C: satisfy satisfy-parser ( quot -- parser )
 
-M: satisfy-parser (parse) ( input parser -- list )
+M: satisfy-parser parse ( input parser -- list )
-  #! A parser that succeeds if the predicate,
+    #! A parser that succeeds if the predicate,
-  #! when passed the first character in the input, returns
+    #! when passed the first character in the input, returns
-  #! true.
+    #! true.
-  over empty? [
+    over empty? [
-    2drop nil
+        2drop nil
-  ] [
-    satisfy-parser-quot >r unclip-slice dup r> call [
-      swap <parse-result> 1list
     ] [
-      2drop nil
+        satisfy-parser-quot >r unclip-slice dup r> call [
-    ] if
+            swap <parse-result> 1list
-  ] if ;
+        ] [
+            2drop nil
+        ] if
+    ] if ;
 
 LAZY: any-char-parser ( -- parser )
-  [ drop t ] satisfy ;
+    [ drop t ] satisfy ;
 
 TUPLE: epsilon-parser ;
 
 C: epsilon epsilon-parser ( -- parser )
 
-M: epsilon-parser (parse) ( input parser -- list )
+M: epsilon-parser parse ( input parser -- list )
-  #! A parser that parses the empty string. It
+    #! A parser that parses the empty string. It
-  #! does not consume any input and always returns
+    #! does not consume any input and always returns
-  #! an empty list as the parse tree with the
+    #! an empty list as the parse tree with the
-  #! unmodified input.
+    #! unmodified input.
-  drop "" swap <parse-result> 1list ;
+    drop "" swap <parse-result> 1list ;
 
 TUPLE: succeed-parser result ;
 
 C: succeed succeed-parser ( result -- parser )
 
-M: succeed-parser (parse) ( input parser -- list )
+M: succeed-parser parse ( input parser -- list )
-  #! A parser that always returns 'result' as a
+    #! A parser that always returns 'result' as a
-  #! successful parse with no input consumed.
+    #! successful parse with no input consumed.
-  succeed-parser-result swap <parse-result> 1list ;
+    succeed-parser-result swap <parse-result> 1list ;
 
 TUPLE: fail-parser ;
 
 C: fail fail-parser ( -- parser )
 
-M: fail-parser (parse) ( input parser -- list )
+M: fail-parser parse ( input parser -- list )
-  #! A parser that always fails and returns
+    #! A parser that always fails and returns
-  #! an empty list of successes.
+    #! an empty list of successes.
-  2drop nil ;
+    2drop nil ;
 
 TUPLE: and-parser parsers ;
 
 : <&> ( parser1 parser2 -- parser )
-  over and-parser? [
+    over and-parser? [
-    >r and-parser-parsers r> add
+        >r and-parser-parsers r> add
-  ] [
+    ] [
-    2array
+        2array
-  ] if \ and-parser construct-boa ;
+    ] if and-parser construct-boa ;
 
 : and-parser-parse ( list p1  -- list )
-  swap [
+    swap [
-    dup parse-result-unparsed rot parse
+        dup parse-result-unparsed rot parse
-    [
+        [
-      >r parse-result-parsed r>
+            >r parse-result-parsed r>
-      [ parse-result-parsed 2array ] keep
+            [ parse-result-parsed 2array ] keep
-      parse-result-unparsed <parse-result>
+            parse-result-unparsed <parse-result>
-    ] lmap-with
+        ] lmap-with
-  ] lmap-with lconcat ;
+    ] lmap-with lconcat ;
 
-M: and-parser (parse) ( input parser -- list )
+M: and-parser parse ( input parser -- list )
-  #! Parse 'input' by sequentially combining the
+    #! Parse 'input' by sequentially combining the
-  #! two parsers. First parser1 is applied to the
+    #! two parsers. First parser1 is applied to the
-  #! input then parser2 is applied to the rest of
+    #! input then parser2 is applied to the rest of
-  #! the input strings from the first parser.
+    #! the input strings from the first parser.
-  and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ;
+    and-parser-parsers unclip swapd parse
+    [ [ and-parser-parse ] reduce ] 2curry promise ;
 
 TUPLE: or-parser p1 p2 ;
 
 C: <|> or-parser ( parser1 parser2 -- parser )
 
-M: or-parser (parse) ( input parser1 -- list )
+M: or-parser parse ( input parser1 -- list )
-  #! Return the combined list resulting from the parses
+    #! Return the combined list resulting from the parses
-  #! of parser1 and parser2 being applied to the same
+    #! of parser1 and parser2 being applied to the same
-  #! input. This implements the choice parsing operator.
+    #! input. This implements the choice parsing operator.
-  [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
+    [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ;
 
 : left-trim-slice ( string -- string )
-  #! Return a new string without any leading whitespace
+    #! Return a new string without any leading whitespace
-  #! from the original string.
+    #! from the original string.
-  dup empty? [
+    dup empty? [
-    dup first blank? [ 1 tail-slice left-trim-slice ] when
+        dup first blank? [ 1 tail-slice left-trim-slice ] when
-  ] unless ;
+    ] unless ;
 
 TUPLE: sp-parser p1 ;
 
@@ -130,115 +132,115 @@ TUPLE: sp-parser p1 ;
 #! calling the original parser.
 C: sp sp-parser ( p1 -- parser )
 
-M: sp-parser (parse) ( input parser -- list )
+M: sp-parser parse ( input parser -- list )
-  #! Skip all leading whitespace from the input then call
+    #! Skip all leading whitespace from the input then call
-  #! the parser on the remaining input.
+    #! the parser on the remaining input.
-  >r left-trim-slice r> sp-parser-p1 parse ;
+    >r left-trim-slice r> sp-parser-p1 parse ;
 
 TUPLE: just-parser p1 ;
 
 C: just just-parser ( p1 -- parser )
 
-M: just-parser (parse) ( input parser -- result )
+M: just-parser parse ( input parser -- result )
-  #! Calls the given parser on the input removes
+    #! Calls the given parser on the input removes
-  #! from the results anything where the remaining
+    #! from the results anything where the remaining
-  #! input to be parsed is not empty. So ensures a
+    #! input to be parsed is not empty. So ensures a
-  #! fully parsed input string.
+    #! fully parsed input string.
-  just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
+    just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ;
 
 TUPLE: apply-parser p1 quot ;
 
 C: <@ apply-parser ( parser quot -- parser )
 
-M: apply-parser (parse) ( input parser -- result )
+M: apply-parser parse ( input parser -- result )
-  #! Calls the parser on the input. For each successfull
+    #! Calls the parser on the input. For each successfull
-  #! parse the quot is call with the parse result on the stack.
+    #! parse the quot is call with the parse result on the stack.
-  #! The result of that quotation then becomes the new parse result.
+    #! The result of that quotation then becomes the new parse result.
-  #! This allows modification of parse tree results (like
+    #! This allows modification of parse tree results (like
-  #! converting strings to integers, etc).
+    #! converting strings to integers, etc).
-  [ apply-parser-p1 ] keep apply-parser-quot
+    [ apply-parser-p1 ] keep apply-parser-quot
-  -rot parse [
+    -rot parse [
-    [ parse-result-parsed swap call ] keep
+        [ parse-result-parsed swap call ] keep
-    parse-result-unparsed <parse-result>
+        parse-result-unparsed <parse-result>
-  ] lmap-with ;
+    ] lmap-with ;
 
 TUPLE: some-parser p1 ;
 
 C: some some-parser ( p1 -- parser )
 
-M: some-parser (parse) ( input parser -- result )
+M: some-parser parse ( input parser -- result )
-  #! Calls the parser on the input, guarantees
+    #! Calls the parser on the input, guarantees
-  #! the parse is complete (the remaining input is empty),
+    #! the parse is complete (the remaining input is empty),
-  #! picks the first solution and only returns the parse
+    #! picks the first solution and only returns the parse
-  #! tree since the remaining input is empty.
+    #! tree since the remaining input is empty.
-  some-parser-p1 just parse-1 ;
+    some-parser-p1 just parse-1 ;
-
 
 : <& ( parser1 parser2 -- parser )
-  #! Same as <&> except discard the results of the second parser.
+    #! Same as <&> except discard the results of the second parser.
-  <&> [ first ] <@ ;
+    <&> [ first ] <@ ;
 
 : &> ( parser1 parser2 -- parser )
-  #! Same as <&> except discard the results of the first parser.
+    #! Same as <&> except discard the results of the first parser.
-  <&> [ second ] <@ ;
+    <&> [ second ] <@ ;
 
 : <:&> ( parser1 parser2 -- result )
-  #! Same as <&> except flatten the result.
+    #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ % , ] { } make ] <@ ;
+    <&> [ first2 add ] <@ ;
 
 : <&:> ( parser1 parser2 -- result )
-  #! Same as <&> except flatten the result.
+    #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ , % ] { } make ] <@ ;
+    <&> [ first2 swap add* ] <@ ;
 
 : <:&:> ( parser1 parser2 -- result )
-  #! Same as <&> except flatten the result.
+    #! Same as <&> except flatten the result.
-  <&> [ dup second swap first [ % % ] { } make ] <@ ;
+    <&> [ first2 append ] <@ ;
 
 LAZY: <*> ( parser -- parser )
-  dup <*> <&:> { } succeed <|> ;
+    dup <*> <&:> { } succeed <|> ;
 
 : <+> ( parser -- parser )
-  #! Return a parser that accepts one or more occurences of the original
+    #! Return a parser that accepts one or more occurences of the original
-  #! parser.
+    #! parser.
-  dup <*> <&:> ;
+    dup <*> <&:> ;
 
 LAZY: <?> ( parser -- parser )
-  #! Return a parser that optionally uses the parser
+    #! Return a parser that optionally uses the parser
-  #! if that parser would be successfull.
+    #! if that parser would be successfull.
-  [ 1array ] <@ f succeed <|> ;
+    [ 1array ] <@ f succeed <|> ;
 
 TUPLE: only-first-parser p1 ;
-LAZY: only-first ( parser -- parser )
-  \ only-first-parser construct-boa ;
 
-M: only-first-parser (parse) ( input parser -- list )
+LAZY: only-first ( parser -- parser )
-  #! Transform a parser into a parser that only yields
+    only-first-parser construct-boa ;
-  #! the first possibility.
+
-  only-first-parser-p1 parse 1 swap ltake ;
+M: only-first-parser parse ( input parser -- list )
+    #! Transform a parser into a parser that only yields
+    #! the first possibility.
+    only-first-parser-p1 parse 1 swap ltake ;
 
 LAZY: <!*> ( parser -- parser )
-  #! Like <*> but only return one possible result
+    #! Like <*> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <*> only-first ;
+    <*> only-first ;
 
 LAZY: <!+> ( parser -- parser )
-  #! Like <+> but only return one possible result
+    #! Like <+> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <+> only-first ;
+    <+> only-first ;
 
 LAZY: <!?> ( parser -- parser )
-  #! Like <?> but only return one possible result
+    #! Like <?> but only return one possible result
-  #! containing all matching parses. Does not return
+    #! containing all matching parses. Does not return
-  #! partial matches. Useful for efficiency since that's
+    #! partial matches. Useful for efficiency since that's
-  #! usually the effect you want and cuts down on backtracking
+    #! usually the effect you want and cuts down on backtracking
-  #! required.
+    #! required.
-  <?> only-first ;
+    <?> only-first ;
 
 LAZY: <(*)> ( parser -- parser )
     #! Like <*> but take shortest match first.
@@ -251,20 +253,20 @@ LAZY: <(+)> ( parser -- parser )
     dup <(*)> <&:> ;
 
 : pack ( close body open -- parser )
-  #! Parse a construct enclosed by two symbols,
+    #! Parse a construct enclosed by two symbols,
-  #! given a parser for the opening symbol, the
+    #! given a parser for the opening symbol, the
-  #! closing symbol, and the body.
+    #! closing symbol, and the body.
-  <& &> ;
+    <& &> ;
 
 : nonempty-list-of ( items separator -- parser )
-  [ over &> <*> <&:> ] keep <?> tuck pack ;
+    [ over &> <*> <&:> ] keep <?> tuck pack ;
 
 : list-of ( items separator -- parser )
-  #! Given a parser for the separator and for the
+    #! Given a parser for the separator and for the
-  #! items themselves, return a parser that parses
+    #! items themselves, return a parser that parses
-  #! lists of those items. The parse tree is an
+    #! lists of those items. The parse tree is an
-  #! array of the parsed items.
+    #! array of the parsed items.
-  nonempty-list-of { } succeed <|> ;
+    nonempty-list-of { } succeed <|> ;
 
 LAZY: surrounded-by ( parser start end -- parser' )
-  [ token ] 2apply swapd pack ;
+    [ token ] 2apply swapd pack ;

extra/peg/peg-docs.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax peg ;
+
+HELP: parse
+{ $values 
+  { "string" "a string" } 
+  { "parse" "a parser" } 
+  { "result" "a <parse-result> or f" } 
+}
+{ $description 
+    "Given the input string, parse it using the given parser. The result is a <parse-result> object if "
+    "the parse was successful, otherwise it is f." } ;
+
+HELP: token
+{ $values 
+  { "string" "a string" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that matches the given string." } ;
+
+HELP: range
+{ $values 
+  { "min" "a character" } 
+  { "max" "a character" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that matches a single character that lies within the range of characters given, inclusive." }
+{ $example ": digit ( -- parser ) CHAR: 0 CHAR: 9 range ;" } ;
+
+HELP: seq
+{ $values 
+  { "seq" "a sequence of parsers" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that calls all parsers in the given sequence, in order. The parser succeeds if "
+    "all the parsers succeed, otherwise it fails. The AST produced is a sequence of the AST produced by "
+    "the individual parsers." } ;
+
+HELP: choice
+{ $values 
+  { "seq" "a sequence of parsers" } 
+  { "parser" "a parser" } 
+}
+{ $description 
+    "Returns a parser that will try all the parsers in the sequence, in order, until one succeeds. "
+    "The resulting AST is that produced by the successful parser." } ;
+
+HELP: repeat0
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 0 or more instances of the 'p1' parser. The AST produced is "
+    "an array of the AST produced by the 'p1' parser. An empty array indicates 0 instances were "
+    "parsed." } ;
+
+HELP: repeat1
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 1 or more instances of the 'p1' parser. The AST produced is "
+    "an array of the AST produced by the 'p1' parser." } ;
+
+HELP: optional
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "
+    "'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;
+
+HELP: ensure
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser succeeds but does not add anything to the "
+    "AST and does not move the location in the input string. This can be used for lookahead and "
+    "disambiguation, along with the " { $link ensure-not } " word." }
+{ $example "\"0\" token ensure octal-parser" } ;
+
+HELP: ensure-not
+{ $values 
+  { "p1" "a parser" } 
+  { "p2" "a parser" } 
+}
+{ $description 
+    "Returns a parser that succeeds if the 'p1' parser fails but does not add anything to the "
+    "AST and does not move the location in the input string. This can be used for lookahead and "
+    "disambiguation, along with the " { $link ensure } " word." }
+{ $example "\"+\" token \"=\" token ensure-not \"+=\" token 3array seq" } ;
+
+HELP: action
+{ $values 
+  { "p1" "a parser" } 
+  { "quot" "a quotation with stack effect ( ast -- ast )" } 
+}
+{ $description 
+    "Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "
+    "from that parse. The result of the quotation is then used as the final AST. This can be used "
+    "for manipulating the parse tree to produce a AST better suited for the task at hand rather than "
+    "the default AST." }
+{ $example "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;
+

extra/peg/peg-tests.factor

@@ -0,0 +1,139 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
+IN: temporary
+
+{ 0 1 2 } [
+  0 next-id set-global get-next-id get-next-id get-next-id 
+] unit-test
+
+{ f } [
+  "endbegin" "begin" token parse
+] unit-test
+
+{ "begin" "end" } [
+  "beginend" "begin" token parse 
+  { parse-result-ast parse-result-remaining } get-slots
+  >string
+] unit-test
+
+{ f } [
+  "" CHAR: a CHAR: z range parse
+] unit-test
+
+{ f } [
+  "1bcd" CHAR: a CHAR: z range parse
+] unit-test
+
+{ CHAR: a } [
+  "abcd" CHAR: a CHAR: z range parse parse-result-ast
+] unit-test
+
+{ CHAR: z } [
+  "zbcd" CHAR: a CHAR: z range parse parse-result-ast
+] unit-test
+
+{ f } [
+  "bad" "a" token "b" token 2array seq parse
+] unit-test
+
+{ V{ "g" "o" } } [
+  "good" "g" token "o" token 2array seq parse parse-result-ast
+] unit-test
+
+{ "a" } [
+  "abcd" "a" token "b" token 2array choice parse parse-result-ast
+] unit-test
+
+{ "b" } [
+  "bbcd" "a" token "b" token 2array choice parse parse-result-ast
+] unit-test
+
+{ f } [
+  "cbcd" "a" token "b" token 2array choice parse 
+] unit-test
+
+{ f } [
+  "" "a" token "b" token 2array choice parse 
+] unit-test
+
+{ 0 } [
+  "" "a" token repeat0 parse parse-result-ast length
+] unit-test
+
+{ 0 } [
+  "b" "a" token repeat0 parse parse-result-ast length
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+  "aaab" "a" token repeat0 parse parse-result-ast 
+] unit-test
+
+{ f } [
+  "" "a" token repeat1 parse 
+] unit-test
+
+{ f } [
+  "b" "a" token repeat1 parse 
+] unit-test
+
+{ V{ "a" "a" "a" } } [
+  "aaab" "a" token repeat1 parse parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [ 
+  "ab" "a" token optional "b" token 2array seq parse parse-result-ast 
+] unit-test
+
+{ V{ f "b" } } [ 
+  "b" "a" token optional "b" token 2array seq parse parse-result-ast 
+] unit-test
+
+{ f } [ 
+  "cb" "a" token optional "b" token 2array seq parse  
+] unit-test
+
+{ V{ CHAR: a CHAR: b } } [
+  "ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
+] unit-test
+
+{ f } [
+  "bb" "a" token ensure CHAR: a CHAR: z range 2array seq parse 
+] unit-test
+
+{ t } [
+  "a+b" 
+  "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ t } [
+  "a++b" 
+  "a" token "+" token dup ensure-not 2array seq "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ t } [
+  "a+b" 
+  "a" token "+" token "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ f } [
+  "a++b" 
+  "a" token "+" token "++" token 2array choice "b" token 3array seq
+  parse [ t ] [ f ] if
+] unit-test
+
+{ 1 } [
+  "a" "a" token [ drop 1 ] action parse parse-result-ast 
+] unit-test
+
+{ V{ 1 1 } } [
+  "aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast 
+] unit-test
+
+{ f } [
+  "b" "a" token [ drop 1 ] action parse 
+] unit-test

extra/peg/peg.factor

@@ -0,0 +1,176 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences strings namespaces math assocs shuffle vectors combinators.lib ;
+IN: peg
+
+TUPLE: parse-result remaining ast ;
+
+GENERIC: parse ( state parser -- result )
+
+<PRIVATE
+
+SYMBOL: ignore 
+
+: <parse-result> ( remaining ast -- parse-result )
+  parse-result construct-boa ;
+
+SYMBOL: next-id 
+
+: get-next-id ( -- number )
+  next-id get-global 0 or dup 1+ next-id set-global ;
+
+TUPLE: parser id ;
+
+: init-parser ( parser -- parser )
+  get-next-id parser construct-boa over set-delegate ;
+
+TUPLE: token-parser symbol ;
+
+M: token-parser parse ( state parser -- result )
+  token-parser-symbol 2dup head? [
+    dup >r length tail-slice r> <parse-result>
+  ] [
+    2drop f
+  ] if ;
+
+TUPLE: range-parser min max ;
+
+M: range-parser parse ( state parser -- result )
+  over empty? [
+    2drop f
+  ] [
+    0 pick nth dup rot 
+    { range-parser-min range-parser-max } get-slots between? [
+      [ 1 tail-slice ] dip <parse-result>
+    ] [
+      2drop f
+    ] if
+  ] if ;
+
+TUPLE: seq-parser parsers ;
+
+: do-seq-parser ( result parser -- result )
+  [ dup parse-result-remaining ] dip parse [
+    [ parse-result-remaining swap set-parse-result-remaining ] 2keep  
+    parse-result-ast dup ignore = [ drop ] [ swap [ parse-result-ast push ] keep ] if
+  ] [
+    drop f
+  ] if* ;
+
+: (seq-parser) ( result parsers -- result )
+  dup empty? not pick and [
+    unclip swap [ do-seq-parser ] dip (seq-parser)
+  ] [
+    drop   
+  ] if ;
+
+M: seq-parser parse ( state parser -- result )
+  seq-parser-parsers [ V{ } clone <parse-result> ] dip  (seq-parser) ;
+
+TUPLE: choice-parser parsers ;
+  
+: (choice-parser) ( state parsers -- result )
+  dup empty? [
+    2drop f
+  ] [
+    unclip pick swap parse [
+      2nip 
+    ] [
+      (choice-parser)
+    ] if* 
+  ] if ;
+
+M: choice-parser parse ( state parser -- result )
+  choice-parser-parsers (choice-parser) ;
+
+TUPLE: repeat0-parser p1 ;
+
+: (repeat-parser) ( parser result -- result )
+  2dup parse-result-remaining swap parse [
+    [ parse-result-remaining swap set-parse-result-remaining ] 2keep 
+    parse-result-ast swap [ parse-result-ast push ] keep
+    (repeat-parser) 
+ ] [
+    nip
+  ] if* ;
+
+: clone-result ( result -- result )
+  { parse-result-remaining parse-result-ast }
+  get-slots 1vector  <parse-result> ;
+
+M: repeat0-parser parse ( state parser -- result )
+     repeat0-parser-p1 2dup parse [ 
+       nipd clone-result (repeat-parser) 
+     ] [ 
+       drop V{ } clone <parse-result> 
+     ] if* ;
+
+TUPLE: repeat1-parser p1 ;
+
+M: repeat1-parser parse ( state parser -- result )
+   repeat1-parser-p1 tuck parse dup [ clone-result (repeat-parser) ] [ nip ] if ;
+
+TUPLE: optional-parser p1 ;
+
+M: optional-parser parse ( state parser -- result )
+   dupd optional-parser-p1 parse swap f <parse-result> or ;
+
+TUPLE: ensure-parser p1 ;
+
+M: ensure-parser parse ( state parser -- result )
+   dupd ensure-parser-p1 parse [
+     ignore <parse-result>  
+   ] [
+     drop f
+   ] if ;
+
+TUPLE: ensure-not-parser p1 ;
+
+M: ensure-not-parser parse ( state parser -- result )
+   dupd ensure-not-parser-p1 parse [
+     drop f
+   ] [
+     ignore <parse-result>  
+   ] if ;
+
+TUPLE: action-parser p1 quot ;
+
+M: action-parser parse ( state parser -- result )
+   tuck action-parser-p1 parse dup [ 
+     dup parse-result-ast rot action-parser-quot call
+     swap [ set-parse-result-ast ] keep
+   ] [
+     nip
+   ] if ;
+
+PRIVATE>
+
+: token ( string -- parser )
+  token-parser construct-boa init-parser ;      
+
+: range ( min max -- parser )
+  range-parser construct-boa init-parser ;
+
+: seq ( seq -- parser )
+  seq-parser construct-boa init-parser ;
+
+: choice ( seq -- parser )
+  choice-parser construct-boa init-parser ;
+
+: repeat0 ( parser -- parser )
+  repeat0-parser construct-boa init-parser ;
+
+: repeat1 ( parser -- parser )
+  repeat1-parser construct-boa init-parser ;
+
+: optional ( parser -- parser )
+  optional-parser construct-boa init-parser ;
+
+: ensure ( parser -- parser )
+  ensure-parser construct-boa init-parser ;
+
+: ensure-not ( parser -- parser )
+  ensure-not-parser construct-boa init-parser ;
+
+: action ( parser quot -- parser )
+  action-parser construct-boa init-parser ;

extra/raptor/config.factor

@@ -44,7 +44,10 @@ IN: raptor
   ! rcS.d
 
   "mountvirtfs"                     start-service
-  "hostname.sh"			    start-service
+
+  ! "hostname.sh"			    start-service
+  "narodnik"                        set-hostname
+
   "keymap.sh"			    start-service
   "linux-restricted-modules-common" start-service
   "udev"                            start-service

extra/raptor/cronjobs.factor

@@ -6,8 +6,6 @@ IN: raptor
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
-
 : run-script ( path -- ) 1array [ fork-exec-args-wait ] curry in-thread ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

extra/raptor/raptor.factor

@@ -22,6 +22,8 @@ SYMBOL: networking-hook
 : fork-exec-wait ( pathname args -- )
   fork dup 0 = [ drop exec drop ] [ 2nip wait-for-pid drop ] if ;
 
+: fork-exec-args-wait ( args -- ) [ first ] [ ] bi fork-exec-wait ;
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : forever ( quot -- ) [ call ] [ forever ] bi ;
@@ -59,6 +61,10 @@ SYMBOL: swap-devices
 
 : start-networking ( -- ) networking-hook  get call ;
 
+: set-hostname ( name -- ) `{ "/bin/hostname" , } fork-exec-args-wait ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : boot     ( -- ) boot-hook     get call ;
 : reboot   ( -- ) reboot-hook   get call ;
 : shutdown ( -- ) shutdown-hook get call ;

extra/tools/annotations/annotations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words parser io inspector quotations sequences
-prettyprint continuations ;
+prettyprint continuations effects ;
 IN: tools.annotations
 
 : annotate ( word quot -- )
@@ -9,17 +9,29 @@ IN: tools.annotations
     swap define-compound do-parse-hook ;
     inline
 
-: entering ( str -- ) "! Entering: " write print .s flush ;
+: entering ( str -- )
+    "/-- Entering: " write dup .
+    stack-effect [
+        >r datastack r> effect-in length tail* stack.
+    ] [
+        .s
+    ] if* "\\--" print flush ;
 
-: leaving ( str -- ) "! Leaving: " write print .s flush ;
+: leaving ( str -- )
+    "/-- Leaving: " write dup .
+    stack-effect [
+        >r datastack r> effect-out length tail* stack.
+    ] [
+        .s
+    ] if* "\\--" print flush ;
 
-: (watch) ( str def -- def )
+: (watch) ( word def -- def )
     over [ entering ] curry
     rot [ leaving ] curry
     swapd 3append ;
 
 : watch ( word -- )
-    dup word-name swap [ (watch) ] annotate ;
+    dup [ (watch) ] annotate ;
 
 : breakpoint ( word -- )
     [ \ break add* ] annotate ;

extra/ui/tools/operations/operations.factor

@@ -64,6 +64,7 @@ V{ } clone operations set-global
     { +keyboard+ T{ key-down f { C+ } "E" } }
     { +primary+ t }
     { +secondary+ t }
+    { +listener+ t }
 } define-operation
 
 UNION: definition word method-spec link ;
@@ -72,6 +73,7 @@ UNION: editable-definition definition vocab vocab-link ;
 
 [ editable-definition? ] \ edit H{
     { +keyboard+ T{ key-down f { C+ } "E" } }
+    { +listener+ t }
 } define-operation
 
 UNION: reloadable-definition definition pathname ;

extra/ui/x11/x11.factor

@@ -5,7 +5,7 @@ ui.clipboards ui.gadgets.worlds assocs kernel math namespaces
 opengl sequences strings x11.xlib x11.events x11.xim x11.glx
 x11.clipboard x11.constants x11.windows io.utf8 combinators
 debugger system command-line ui.render math.vectors tuples
-opengl.gl ;
+opengl.gl threads ;
 IN: ui.x11
 
 TUPLE: x11-ui-backend ;

extra/x/x.factor

@@ -29,7 +29,8 @@ define-independent-class
 
 <display> "create" !( name <display> -- display ) [
   new-empty swap >>name
-  dup $name dup [ string>char-alien ] [ ] if XOpenDisplay >>ptr
+  dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
+  dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
   dup $ptr XDefaultScreen >>default-screen
   dup $ptr XDefaultRootWindow dupd <window> new >>default-root
   dup $ptr over $default-screen XDefaultGC >>default-gc

extra/xml/data/data.factor

@@ -65,6 +65,8 @@ M: attrs set-at
 
 M: attrs assoc-size length ;
 M: attrs new-assoc drop V{ } new <attrs> ;
+M: attrs assoc-find >r delegate r> assoc-find ;
+M: attrs >alist delegate >alist ;
 
 : >attrs ( assoc -- attrs )
     V{ } assoc-clone-like

misc/factor.el

@@ -113,13 +113,6 @@
 (defvar factor-binary "/scratch/repos/Factor/factor")
 (defvar factor-image "/scratch/repos/Factor/factor.image")
 
-(defun run-factor ()
-  (interactive)
-  (switch-to-buffer
-   (make-comint-in-buffer "factor" nil factor-binary nil
-			  (concat "-i=" factor-image)
-			  "-run=listener")))
-
 (defun factor-telnet-to-port (port)
   (interactive "nPort: ")
   (switch-to-buffer
@@ -166,12 +159,30 @@
   (beginning-of-line)
   (insert "! "))
 
-(defun factor-refresh-all ()
-  (interactive)
-  (comint-send-string "*factor*" "refresh-all\n"))
-
 (define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
 (define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
 (define-key factor-mode-map "\C-c\C-s" 'factor-see)
-(define-key factor-mode-map "\C-ce" 'factor-edit)
+(define-key factor-mode-map "\C-ce"    'factor-edit)
 (define-key factor-mode-map "\C-c\C-h" 'factor-help)
+(define-key factor-mode-map "\C-cc"    'comment-region)
+(define-key factor-mode-map [return]   'newline-and-indent)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; factor-listener-mode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-derived-mode factor-listener-mode comint-mode "Factor Listener")
+
+(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
+
+(defun run-factor ()
+  (interactive)
+  (switch-to-buffer
+   (make-comint-in-buffer "factor" nil factor-binary nil
+			  (concat "-i=" factor-image)
+			  "-run=listener"))
+  (factor-listener-mode))
+
+(defun factor-refresh-all ()
+  (interactive)
+  (comint-send-string "*factor*" "refresh-all\n"))