diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index 930a39dfdf..7d95c8ce8a 100644 --- a/extra/editors/editors.factor +++ b/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 -source-files ; +inspector continuations tuples tools.crossref tools.browser +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 dup [ - \ no-edit-hook construct-empty throw - ] if ; + edit-hook get [ + >r >r ?resource-path r> r> call + ] [ + no-edit-hook edit-location + ] if* ; : edit ( defspec -- ) where [ first2 edit-location ] when* ; diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 199f0cb136..d6c44659a5 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/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 -arrays namespaces splitting ; +USING: lazy-lists promises kernel sequences strings math +arrays splitting ; IN: parser-combinators ! Parser combinator protocol -GENERIC: (parse) ( input parser -- list ) +GENERIC: parse ( input parser -- list ) -M: promise (parse) ( input parser -- list ) - force (parse) ; - -: parse ( input parser -- promise ) - (parse) ; +M: promise parse ( input parser -- list ) + force 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 ) - token-parser-string swap over ?head-slice [ - <parse-result> 1list - ] [ - 2drop nil - ] if ; +M: token-parser parse ( input parser -- list ) + token-parser-string swap over ?head-slice [ + <parse-result> 1list + ] [ + 2drop nil + ] if ; TUPLE: satisfy-parser quot ; C: satisfy satisfy-parser ( quot -- parser ) -M: satisfy-parser (parse) ( input parser -- list ) - #! A parser that succeeds if the predicate, - #! when passed the first character in the input, returns - #! true. - over empty? [ - 2drop nil - ] [ - satisfy-parser-quot >r unclip-slice dup r> call [ - swap <parse-result> 1list +M: satisfy-parser parse ( input parser -- list ) + #! A parser that succeeds if the predicate, + #! when passed the first character in the input, returns + #! true. + over empty? [ + 2drop nil ] [ - 2drop nil - ] if - ] if ; + satisfy-parser-quot >r unclip-slice dup r> call [ + swap <parse-result> 1list + ] [ + 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 ) - #! A parser that parses the empty string. It - #! does not consume any input and always returns - #! an empty list as the parse tree with the - #! unmodified input. - drop "" swap <parse-result> 1list ; +M: epsilon-parser parse ( input parser -- list ) + #! A parser that parses the empty string. It + #! does not consume any input and always returns + #! an empty list as the parse tree with the + #! unmodified input. + drop "" swap <parse-result> 1list ; TUPLE: succeed-parser result ; C: succeed succeed-parser ( result -- parser ) -M: succeed-parser (parse) ( input parser -- list ) - #! A parser that always returns 'result' as a - #! successful parse with no input consumed. - succeed-parser-result swap <parse-result> 1list ; +M: succeed-parser parse ( input parser -- list ) + #! A parser that always returns 'result' as a + #! successful parse with no input consumed. + succeed-parser-result swap <parse-result> 1list ; TUPLE: fail-parser ; C: fail fail-parser ( -- parser ) -M: fail-parser (parse) ( input parser -- list ) - #! A parser that always fails and returns - #! an empty list of successes. - 2drop nil ; +M: fail-parser parse ( input parser -- list ) + #! A parser that always fails and returns + #! an empty list of successes. + 2drop nil ; TUPLE: and-parser parsers ; : <&> ( parser1 parser2 -- parser ) - over and-parser? [ - >r and-parser-parsers r> add - ] [ - 2array - ] if \ and-parser construct-boa ; + over and-parser? [ + >r and-parser-parsers r> add + ] [ + 2array + ] if and-parser construct-boa ; : and-parser-parse ( list p1 -- list ) - swap [ - dup parse-result-unparsed rot parse - [ - >r parse-result-parsed r> - [ parse-result-parsed 2array ] keep - parse-result-unparsed <parse-result> - ] lmap-with - ] lmap-with lconcat ; + swap [ + dup parse-result-unparsed rot parse + [ + >r parse-result-parsed r> + [ parse-result-parsed 2array ] keep + parse-result-unparsed <parse-result> + ] lmap-with + ] lmap-with lconcat ; -M: and-parser (parse) ( input parser -- list ) - #! Parse 'input' by sequentially combining the - #! two parsers. First parser1 is applied to the - #! input then parser2 is applied to the rest of - #! the input strings from the first parser. - and-parser-parsers unclip swapd parse [ [ and-parser-parse ] reduce ] 2curry promise ; +M: and-parser parse ( input parser -- list ) + #! Parse 'input' by sequentially combining the + #! two parsers. First parser1 is applied to the + #! input then parser2 is applied to the rest of + #! the input strings from the first parser. + 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 ) - #! Return the combined list resulting from the parses - #! of parser1 and parser2 being applied to the same - #! input. This implements the choice parsing operator. - [ or-parser-p1 ] keep or-parser-p2 >r dupd parse swap r> parse lappend ; +M: or-parser parse ( input parser1 -- list ) + #! Return the combined list resulting from the parses + #! of parser1 and parser2 being applied to the same + #! input. This implements the choice parsing operator. + [ 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 - #! from the original string. - dup empty? [ - dup first blank? [ 1 tail-slice left-trim-slice ] when - ] unless ; + #! Return a new string without any leading whitespace + #! from the original string. + dup empty? [ + dup first blank? [ 1 tail-slice left-trim-slice ] when + ] 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 ) - #! Skip all leading whitespace from the input then call - #! the parser on the remaining input. - >r left-trim-slice r> sp-parser-p1 parse ; +M: sp-parser parse ( input parser -- list ) + #! Skip all leading whitespace from the input then call + #! the parser on the remaining input. + >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 ) - #! Calls the given parser on the input removes - #! from the results anything where the remaining - #! input to be parsed is not empty. So ensures a - #! fully parsed input string. - just-parser-p1 parse [ parse-result-unparsed empty? ] lsubset ; +M: just-parser parse ( input parser -- result ) + #! Calls the given parser on the input removes + #! from the results anything where the remaining + #! input to be parsed is not empty. So ensures a + #! fully parsed input string. + 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 ) - #! Calls the parser on the input. For each successfull - #! parse the quot is call with the parse result on the stack. - #! The result of that quotation then becomes the new parse result. - #! This allows modification of parse tree results (like - #! converting strings to integers, etc). - [ apply-parser-p1 ] keep apply-parser-quot - -rot parse [ - [ parse-result-parsed swap call ] keep - parse-result-unparsed <parse-result> - ] lmap-with ; +M: apply-parser parse ( input parser -- result ) + #! Calls the parser on the input. For each successfull + #! parse the quot is call with the parse result on the stack. + #! The result of that quotation then becomes the new parse result. + #! This allows modification of parse tree results (like + #! converting strings to integers, etc). + [ apply-parser-p1 ] keep apply-parser-quot + -rot parse [ + [ parse-result-parsed swap call ] keep + parse-result-unparsed <parse-result> + ] lmap-with ; TUPLE: some-parser p1 ; C: some some-parser ( p1 -- parser ) -M: some-parser (parse) ( input parser -- result ) - #! Calls the parser on the input, guarantees - #! the parse is complete (the remaining input is empty), - #! picks the first solution and only returns the parse - #! tree since the remaining input is empty. - some-parser-p1 just parse-1 ; - +M: some-parser parse ( input parser -- result ) + #! Calls the parser on the input, guarantees + #! the parse is complete (the remaining input is empty), + #! picks the first solution and only returns the parse + #! tree since the remaining input is empty. + some-parser-p1 just parse-1 ; : <& ( parser1 parser2 -- parser ) - #! Same as <&> except discard the results of the second parser. - <&> [ first ] <@ ; + #! Same as <&> except discard the results of the second parser. + <&> [ first ] <@ ; : &> ( parser1 parser2 -- parser ) - #! Same as <&> except discard the results of the first parser. - <&> [ second ] <@ ; + #! Same as <&> except discard the results of the first parser. + <&> [ second ] <@ ; : <:&> ( parser1 parser2 -- result ) - #! Same as <&> except flatten the result. - <&> [ dup second swap first [ % , ] { } make ] <@ ; + #! Same as <&> except flatten the result. + <&> [ first2 add ] <@ ; : <&:> ( parser1 parser2 -- result ) - #! Same as <&> except flatten the result. - <&> [ dup second swap first [ , % ] { } make ] <@ ; + #! Same as <&> except flatten the result. + <&> [ first2 swap add* ] <@ ; : <:&:> ( parser1 parser2 -- result ) - #! Same as <&> except flatten the result. - <&> [ dup second swap first [ % % ] { } make ] <@ ; + #! Same as <&> except flatten the result. + <&> [ first2 append ] <@ ; LAZY: <*> ( parser -- parser ) - dup <*> <&:> { } succeed <|> ; + dup <*> <&:> { } succeed <|> ; : <+> ( parser -- parser ) - #! Return a parser that accepts one or more occurences of the original - #! parser. - dup <*> <&:> ; + #! Return a parser that accepts one or more occurences of the original + #! parser. + dup <*> <&:> ; LAZY: <?> ( parser -- parser ) - #! Return a parser that optionally uses the parser - #! if that parser would be successfull. - [ 1array ] <@ f succeed <|> ; + #! Return a parser that optionally uses the parser + #! if that parser would be successfull. + [ 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 ) - #! Transform a parser into a parser that only yields - #! the first possibility. - only-first-parser-p1 parse 1 swap ltake ; +LAZY: only-first ( parser -- parser ) + only-first-parser construct-boa ; + +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 - #! containing all matching parses. Does not return - #! partial matches. Useful for efficiency since that's - #! usually the effect you want and cuts down on backtracking - #! required. - <*> only-first ; + #! Like <*> but only return one possible result + #! containing all matching parses. Does not return + #! partial matches. Useful for efficiency since that's + #! usually the effect you want and cuts down on backtracking + #! required. + <*> only-first ; LAZY: <!+> ( parser -- parser ) - #! Like <+> but only return one possible result - #! containing all matching parses. Does not return - #! partial matches. Useful for efficiency since that's - #! usually the effect you want and cuts down on backtracking - #! required. - <+> only-first ; + #! Like <+> but only return one possible result + #! containing all matching parses. Does not return + #! partial matches. Useful for efficiency since that's + #! usually the effect you want and cuts down on backtracking + #! required. + <+> only-first ; LAZY: <!?> ( parser -- parser ) - #! Like <?> but only return one possible result - #! containing all matching parses. Does not return - #! partial matches. Useful for efficiency since that's - #! usually the effect you want and cuts down on backtracking - #! required. - <?> only-first ; + #! Like <?> but only return one possible result + #! containing all matching parses. Does not return + #! partial matches. Useful for efficiency since that's + #! usually the effect you want and cuts down on backtracking + #! required. + <?> 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, - #! given a parser for the opening symbol, the - #! closing symbol, and the body. - <& &> ; + #! Parse a construct enclosed by two symbols, + #! given a parser for the opening symbol, the + #! 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 - #! items themselves, return a parser that parses - #! lists of those items. The parse tree is an - #! array of the parsed items. - nonempty-list-of { } succeed <|> ; + #! Given a parser for the separator and for the + #! items themselves, return a parser that parses + #! lists of those items. The parse tree is an + #! array of the parsed items. + nonempty-list-of { } succeed <|> ; LAZY: surrounded-by ( parser start end -- parser' ) - [ token ] 2apply swapd pack ; + [ token ] 2apply swapd pack ; diff --git a/extra/peg/peg-docs.factor b/extra/peg/peg-docs.factor new file mode 100644 index 0000000000..40743132f3 --- /dev/null +++ b/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" } ; + diff --git a/extra/peg/peg-tests.factor b/extra/peg/peg-tests.factor new file mode 100644 index 0000000000..7648819a8c --- /dev/null +++ b/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 \ No newline at end of file diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor new file mode 100644 index 0000000000..1fb8e7860d --- /dev/null +++ b/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 ; diff --git a/extra/raptor/config.factor b/extra/raptor/config.factor index ecdbf98f17..29e26d4381 100644 --- a/extra/raptor/config.factor +++ b/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 diff --git a/extra/raptor/cronjobs.factor b/extra/raptor/cronjobs.factor index 894e8e5ce7..91263a31d9 100644 --- a/extra/raptor/cronjobs.factor +++ b/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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor index e6f960cd8d..ef5359c313 100644 --- a/extra/raptor/raptor.factor +++ b/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 ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index d24d60cef6..e97f292416 100644 --- a/extra/tools/annotations/annotations.factor +++ b/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 ; diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index d2d7685f45..b7a59f5c28 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/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 ; diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 2b1a5ba331..5984e3decd 100755 --- a/extra/ui/x11/x11.factor +++ b/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 ; diff --git a/extra/x/x.factor b/extra/x/x.factor index e55dc3f5cd..8d9f869fa3 100644 --- a/extra/x/x.factor +++ b/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 diff --git a/extra/xml/data/data.factor b/extra/xml/data/data.factor index 56e34b7db2..1850171537 100644 --- a/extra/xml/data/data.factor +++ b/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 diff --git a/misc/factor.el b/misc/factor.el index 88af0a6dab..985e10e285 100644 --- a/misc/factor.el +++ b/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")) \ No newline at end of file