diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index def5b02ba0..a756734f7b 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -3,7 +3,8 @@ USING: arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects prettyprint -prettyprint.sections prettyprint.backend assocs combinators ; +prettyprint.sections prettyprint.backend assocs combinators +lexer strings.parser ; IN: alien.syntax r all-slot-names r> intersect ; + +: check-slot-shadowing ( class superclass slots -- ) + shadowed-slots [ + [ + "Definition of slot ``" % + % + "'' in class ``" % + word-name % + "'' shadows a superclass slot" % + ] "" make note. + ] with each ; + +ERROR: invalid-slot-name name ; + +M: invalid-slot-name summary + drop + "Invalid slot name" ; + +: (parse-tuple-slots) ( -- ) + #! This isn't meant to enforce any kind of policy, just + #! to check for mistakes of this form: + #! + #! TUPLE: blahblah foo bing + #! + #! : ... + scan { + { [ dup not ] [ unexpected-eof ] } + { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop ] } + [ , (parse-tuple-slots) ] + } cond ; + +: parse-tuple-slots ( -- seq ) + [ (parse-tuple-slots) ] { } make ; + +: parse-tuple-definition ( -- class superclass slots ) + CREATE-CLASS + scan { + { ";" [ tuple f ] } + { "<" [ scan-word parse-tuple-slots ] } + [ >r tuple parse-tuple-slots r> prefix ] + } case 3dup check-slot-shadowing ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 5ba0b7e69c..b4a2302a9e 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -217,13 +217,9 @@ M: tuple-class reset-class [ writer-word method forget ] 2bi ] with each ] [ - { - "class" - "metaclass" - "superclass" - "layout" - "slots" - } reset-props + [ call-next-method ] + [ { "layout" "slots" } reset-props ] + bi ] bi ; M: tuple-class rank-class drop 0 ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 74e29cfb01..819e0ecb0b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -28,7 +28,4 @@ M: union-class update-class define-union-predicate ; : define-union-class ( class members -- ) [ (define-union-class) ] [ drop update-classes ] 2bi ; -M: union-class reset-class - { "class" "metaclass" "members" } reset-props ; - M: union-class rank-class drop 2 ; diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3cb7d8a71e..f176e6ee19 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax kernel kernel.private -continuations.private parser vectors arrays namespaces -assocs words quotations ; +continuations.private vectors arrays namespaces +assocs words quotations lexer ; IN: continuations ARTICLE: "errors-restartable" "Restartable errors" @@ -169,8 +169,8 @@ HELP: rethrow "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples - "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" - { $see with-parser } + "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:" + { $see with-lexer } } ; HELP: throw-restarts diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index 452a102341..f8e0b0abb0 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generator.fixup io.binary kernel -combinators kernel.private math namespaces parser sequences -words system layouts math.order accessors ; +combinators kernel.private math namespaces sequences +words system layouts math.order accessors +cpu.x86.assembler.syntax ; IN: cpu.x86.assembler ! A postfix assembler for x86 and AMD64. @@ -12,21 +13,6 @@ IN: cpu.x86.assembler ! Beware! ! Register operands -- eg, ECX -<< - -: define-register ( name num size -- ) - >r >r "cpu.x86.assembler" create dup define-symbol r> r> - >r dupd "register" set-word-prop r> - "register-size" set-word-prop ; - -: define-registers ( names size -- ) - >r dup length r> [ define-register ] curry 2each ; - -: REGISTERS: ( -- ) - scan-word ";" parse-tokens swap define-registers ; parsing - ->> - REGISTERS: 8 AL CL DL BL ; REGISTERS: 16 AX CX DX BX SP BP SI DI ; diff --git a/core/cpu/x86/assembler/syntax/syntax.factor b/core/cpu/x86/assembler/syntax/syntax.factor new file mode 100644 index 0000000000..5940663d42 --- /dev/null +++ b/core/cpu/x86/assembler/syntax/syntax.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel words sequences lexer parser ; +IN: cpu.x86.assembler.syntax + +: define-register ( name num size -- ) + >r >r "cpu.x86.assembler" create dup define-symbol r> r> + >r dupd "register" set-word-prop r> + "register-size" set-word-prop ; + +: define-registers ( names size -- ) + >r dup length r> [ define-register ] curry 2each ; + +: REGISTERS: ( -- ) + scan-word ";" parse-tokens swap define-registers ; parsing diff --git a/core/effects/parser/parser-docs.factor b/core/effects/parser/parser-docs.factor new file mode 100644 index 0000000000..6cb39d208d --- /dev/null +++ b/core/effects/parser/parser-docs.factor @@ -0,0 +1,9 @@ +IN: effects.parser +USING: strings effects help.markup help.syntax ; + +HELP: parse-effect +{ $values { "end" string } { "effect" "an instance of " { $link effect } } } +{ $description "Parses a stack effect from the current input line." } +{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } +$parsing-note ; + diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor new file mode 100644 index 0000000000..8f28450de7 --- /dev/null +++ b/core/effects/parser/parser.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: lexer sets sequences kernel splitting effects ; +IN: effects.parser + +: parse-effect ( end -- effect ) + parse-tokens dup { "(" "((" } intersect empty? [ + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if + ] [ + "Stack effect declaration must not contain ( or ((" throw + ] if ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor new file mode 100644 index 0000000000..ba9cd5244c --- /dev/null +++ b/core/generic/parser/parser.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel words generic namespaces inspector ; +IN: generic.parser + +ERROR: not-in-a-method-error ; + +M: not-in-a-method-error summary + drop "call-next-method can only be called in a method definition" ; + +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word bootstrap-word scan-word create-method-in ; + +SYMBOL: current-class +SYMBOL: current-generic + +: with-method-definition ( quot -- parsed ) + [ + >r + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + r> call + ] with-scope ; inline + +: (M:) ( method def -- ) + CREATE-METHOD [ parse-definition ] with-method-definition ; + diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor new file mode 100644 index 0000000000..b61fc82a25 --- /dev/null +++ b/core/lexer/lexer-docs.factor @@ -0,0 +1,114 @@ +IN: lexer +USING: help.markup help.syntax kernel math sequences strings +words quotations ; + +: $parsing-note ( children -- ) + drop + "This word should only be called from parsing words." + $notes ; + +HELP: lexer +{ $var-description "Stores the current " { $link lexer } " instance." } +{ $class-description "An object for tokenizing parser input. It has the following slots:" + { $list + { { $snippet "text" } " - the lines being parsed; an array of strings" } + { { $snippet "line" } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } + { { $snippet "column" } " - the current column position, zero-based" } + } +"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; + +HELP: +{ $values { "text" "a sequence of strings" } { "lexer" lexer } } +{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; + +HELP: next-line +{ $values { "lexer" lexer } } +{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; + +HELP: lexer-error +{ $error-description "Thrown when the lexer encounters invalid input. A lexer error wraps an underlying error together with line and column numbers." } ; + +HELP: +{ $values { "msg" "an error" } { "error" lexer-error } } +{ $description "Creates a new " { $link lexer-error } ", filling in the location information from the current " { $link lexer } "." } ; + +HELP: skip +{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; + +HELP: change-lexer-column +{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } +{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; + +HELP: skip-blank +{ $values { "lexer" lexer } } +{ $contract "Skips whitespace characters." } +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: skip-word +{ $values { "lexer" lexer } } +{ $contract + "Skips until the end of the current token." + $nl + "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." +} +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: still-parsing-line? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; + +HELP: parse-token +{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; + +HELP: scan +{ $values { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } +$parsing-note ; + +HELP: still-parsing? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; + +HELP: parse-tokens +{ $values { "end" string } { "seq" "a new sequence of strings" } } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } +{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +$parsing-note ; + +HELP: unexpected +{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } +{ $description "Throws an " { $link unexpected } " error." } +{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } +{ $examples + "Parsing the following snippet will throw this error:" + { $code "[ 1 2 3 }" } +} ; + +HELP: unexpected-eof +{ $values { "word" "a " { $link word } } } +{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; + +HELP: with-lexer +{ $values { "lexer" lexer } { "quot" quotation } } +{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ; + +HELP: lexer-factory +{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; + + +ARTICLE: "parser-lexer" "The lexer" +"A variable that encapsulate internal parser state:" +{ $subsection lexer } +"Creating a default lexer:" +{ $subsection } +"A word to test of the end of input has been reached:" +{ $subsection still-parsing? } +"A word to advance the lexer to the next line:" +{ $subsection next-line } +"Two generic words to override the lexer's token boundary detection:" +{ $subsection skip-blank } +{ $subsection skip-word } +"Utility combinator:" +{ $subsection with-lexer } ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor new file mode 100644 index 0000000000..3d65fb95ca --- /dev/null +++ b/core/lexer/lexer.factor @@ -0,0 +1,133 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces math words strings +debugger io vectors arrays math.parser combinators inspector +continuations ; +IN: lexer + +TUPLE: lexer text line line-text line-length column ; + +: next-line ( lexer -- ) + dup [ line>> ] [ text>> ] bi ?nth >>line-text + dup line-text>> length >>line-length + [ 1+ ] change-line + 0 >>column + drop ; + +: new-lexer ( text class -- lexer ) + new + 0 >>line + swap >>text + dup next-line ; inline + +: ( text -- lexer ) + lexer new-lexer ; + +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find-from drop + [ r> drop ] [ r> length ] if* ; + +: change-lexer-column ( lexer quot -- ) + swap + [ dup lexer-column swap lexer-line-text rot call ] keep + set-lexer-column ; inline + +GENERIC: skip-blank ( lexer -- ) + +M: lexer skip-blank ( lexer -- ) + [ t skip ] change-lexer-column ; + +GENERIC: skip-word ( lexer -- ) + +M: lexer skip-word ( lexer -- ) + [ + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + ] change-lexer-column ; + +: still-parsing? ( lexer -- ? ) + dup lexer-line swap lexer-text length <= ; + +: still-parsing-line? ( lexer -- ? ) + dup lexer-column swap lexer-line-length < ; + +: (parse-token) ( lexer -- str ) + [ lexer-column ] keep + [ skip-word ] keep + [ lexer-column ] keep + lexer-line-text subseq ; + +: parse-token ( lexer -- str/f ) + dup still-parsing? [ + dup skip-blank + dup still-parsing-line? + [ (parse-token) ] [ dup next-line parse-token ] if + ] [ drop f ] if ; + +: scan ( -- str/f ) lexer get parse-token ; + +ERROR: unexpected want got ; + +GENERIC: expected>string ( obj -- str ) + +M: f expected>string drop "end of input" ; +M: word expected>string word-name ; +M: string expected>string ; + +M: unexpected error. + "Expected " write + dup unexpected-want expected>string write + " but got " write + unexpected-got expected>string print ; + +PREDICATE: unexpected-eof < unexpected + unexpected-got not ; + +: unexpected-eof ( word -- * ) f unexpected ; + +: (parse-tokens) ( accum end -- accum ) + scan 2dup = [ + 2drop + ] [ + [ pick push (parse-tokens) ] [ unexpected-eof ] if* + ] if ; + +: parse-tokens ( end -- seq ) + 100 swap (parse-tokens) >array ; + +TUPLE: lexer-error line column line-text error ; + +: ( msg -- error ) + \ lexer-error new + lexer get + [ line>> >>line ] + [ column>> >>column ] + [ line-text>> >>line-text ] + tri + swap >>error ; + +: lexer-dump ( error -- ) + [ line>> number>string ": " append ] + [ line-text>> dup string? [ drop "" ] unless ] + [ column>> 0 or ] tri + pick length + CHAR: \s + [ write ] [ print ] [ write "^" print ] tri* ; + +M: lexer-error error. + [ lexer-dump ] [ error>> error. ] bi ; + +M: lexer-error summary + error>> summary ; + +M: lexer-error compute-restarts + error>> compute-restarts ; + +M: lexer-error error-help + error>> error-help ; + +: with-lexer ( lexer quot -- newquot ) + [ lexer set ] dip [ rethrow ] recover ; inline + +SYMBOL: lexer-factory + +[ ] lexer-factory set-global diff --git a/core/listener/listener.factor b/core/listener/listener.factor index e00e64f4bc..4e2a8c768e 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math math.parser memory -namespaces parser sequences strings io.styles +namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors ; IN: listener @@ -51,7 +51,7 @@ SYMBOL: error-hook listener-hook get call prompt. [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ] [ - dup parse-error? [ + dup lexer-error? [ error-hook get call ] [ rethrow diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 2ec9f2de54..1aecfbd60d 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel sequences words math strings vectors quotations generic effects classes vocabs.loader definitions io vocabs source-files -quotations namespaces compiler.units assocs ; +quotations namespaces compiler.units assocs lexer ; IN: parser ARTICLE: "vocabulary-search-shadow" "Shadowing word names" @@ -135,25 +135,6 @@ $nl { $subsection "defining-words" } { $subsection "parsing-tokens" } ; -ARTICLE: "parser-lexer" "The lexer" -"Two variables that encapsulate internal parser state:" -{ $subsection file } -{ $subsection lexer } -"Creating a default lexer:" -{ $subsection } -"A word to test of the end of input has been reached:" -{ $subsection still-parsing? } -"A word to advance the lexer to the next line:" -{ $subsection next-line } -"Two generic words to override the lexer's token boundary detection:" -{ $subsection skip-blank } -{ $subsection skip-word } -"A utility used when parsing string literals:" -{ $subsection parse-string } -"The parser can be invoked with a custom lexer:" -{ $subsection (parse-lines) } -{ $subsection with-parser } ; - ARTICLE: "parser-files" "Parsing source files" "The parser can run source files:" { $subsection run-file } @@ -192,25 +173,6 @@ $nl ABOUT: "parser" -: $parsing-note ( children -- ) - drop - "This word should only be called from parsing words." - $notes ; - -HELP: lexer -{ $var-description "Stores the current " { $link lexer } " instance." } -{ $class-description "An object for tokenizing parser input. It has the following slots:" - { $list - { { $link lexer-text } " - the lines being parsed; an array of strings" } - { { $link lexer-line } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } - { { $link lexer-column } " - the current column position, zero-based" } - } -"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; - -HELP: -{ $values { "text" "a sequence of strings" } { "lexer" lexer } } -{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; - HELP: location { $values { "loc" "a " { $snippet "{ path line# }" } " pair" } } { $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ; @@ -226,73 +188,9 @@ HELP: parser-notes? { $values { "?" "a boolean" } } { $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ; -HELP: next-line -{ $values { "lexer" lexer } } -{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; - -HELP: parse-error -{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ; - -HELP: -{ $values { "msg" "an error" } { "error" parse-error } } -{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; - -HELP: skip -{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } -{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; - -HELP: change-lexer-column -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } -{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; - -HELP: skip-blank -{ $values { "lexer" lexer } } -{ $contract "Skips whitespace characters." } -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: skip-word -{ $values { "lexer" lexer } } -{ $contract - "Skips until the end of the current token." - $nl - "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." -} -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: still-parsing-line? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; - -HELP: parse-token -{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; - -HELP: scan -{ $values { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } -$parsing-note ; - -HELP: bad-escape -{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; - HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; -HELP: escape -{ $values { "escape" "a single-character escape" } { "ch" "a character" } } -{ $description "Converts from a single-character escape code and the corresponding character." } -{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; - -HELP: parse-string -{ $values { "str" "a new " { $link string } } } -{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } -{ $errors "Throws an error if the string contains an invalid escape sequence." } -$parsing-note ; - -HELP: still-parsing? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; - HELP: use { $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; @@ -338,12 +236,6 @@ HELP: create-in { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } $parsing-note ; -HELP: parse-tokens -{ $values { "end" string } { "seq" "a new sequence of strings" } } -{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } -{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } -$parsing-note ; - HELP: CREATE { $values { "word" word } } { $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." } @@ -369,31 +261,6 @@ HELP: scan-word { $errors "Throws an error if the token does not name a word, and does not parse as a number." } $parsing-note ; -HELP: invalid-slot-name -{ $values { "name" string } } -{ $description "Throws an " { $link invalid-slot-name } " error." } -{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } -{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" - { $code - "TUPLE: my-mistaken-tuple slot-a slot-b" - "" - ": some-word ( a b c -- ) ... ;" - } -} ; - -HELP: unexpected -{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } -{ $description "Throws an " { $link unexpected } " error." } -{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } -{ $examples - "Parsing the following snippet will throw this error:" - { $code "[ 1 2 3 }" } -} ; - -HELP: unexpected-eof -{ $values { "word" "a " { $link word } } } -{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; - HELP: parse-step { $values { "accum" vector } { "end" word } { "?" "a boolean" } } { $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." } @@ -417,28 +284,15 @@ HELP: parsed { $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." } $parsing-note ; -HELP: with-parser -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( -- accum )" } } { "newquot" "a new " { $link quotation } } } -{ $description "Sets up the parser and calls the quotation. The quotation can make use of parsing words such as " { $link scan } " and " { $link parse-until } ". It must yield a sequence, which is converted to a quotation and output. Any errors thrown by the quotation are wrapped in parse errors." } ; - HELP: (parse-lines) { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-lines { $values { "lines" "a sequence of strings" } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code which has been tokenized into lines. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; - -HELP: lexer-factory -{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; - -HELP: parse-effect -{ $values { "end" string } { "effect" "an instance of " { $link effect } } } -{ $description "Parses a stack effect from the current input line." } -{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } -$parsing-note ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-base { $values { "base" "an integer between 2 and 36" } { "parsed" integer } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 555c6eb32c..eb37d556d0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -485,3 +485,9 @@ must-fail-with [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with + +[ + "IN: parser.tests : blah ; parsing FORGET: blah" eval +] [ + error>> staging-violation? +] must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 129d5ef2ee..44708f11f3 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,38 +4,17 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string vocabs -io.encodings.utf8 source-files classes classes.tuple hashtables -compiler.errors compiler.units accessors sets ; +io.encodings.utf8 source-files classes hashtables +compiler.errors compiler.units accessors sets lexer ; IN: parser -TUPLE: lexer text line line-text line-length column ; - -: next-line ( lexer -- ) - dup [ line>> ] [ text>> ] bi ?nth >>line-text - dup line-text>> length >>line-length - [ 1+ ] change-line - 0 >>column - drop ; - -: new-lexer ( text class -- lexer ) - new - 0 >>line - swap >>text - dup next-line ; inline - -: ( text -- lexer ) - lexer new-lexer ; - : location ( -- loc ) - file get lexer get lexer-line 2dup and - [ >r source-file-path r> 2array ] [ 2drop f ] if ; + file get lexer get line>> 2dup and + [ >r path>> r> 2array ] [ 2drop f ] if ; : save-location ( definition -- ) location remember-definition ; -: save-class-location ( class -- ) - location remember-class ; - SYMBOL: parser-notes t parser-notes set-global @@ -43,13 +22,6 @@ t parser-notes set-global : parser-notes? ( -- ? ) parser-notes get "quiet" get not and ; -: file. ( file -- ) - [ - source-file-path pprint - ] [ - "" write - ] if* ":" write ; - : note. ( str -- ) parser-notes? [ file get file. @@ -61,143 +33,9 @@ t parser-notes set-global "Note: " write dup print ] when drop ; -: skip ( i seq ? -- n ) - over >r - [ swap CHAR: \s eq? xor ] curry find-from drop - [ r> drop ] [ r> length ] if* ; - -: change-lexer-column ( lexer quot -- ) - swap - [ dup lexer-column swap lexer-line-text rot call ] keep - set-lexer-column ; inline - -GENERIC: skip-blank ( lexer -- ) - -M: lexer skip-blank ( lexer -- ) - [ t skip ] change-lexer-column ; - -GENERIC: skip-word ( lexer -- ) - -M: lexer skip-word ( lexer -- ) - [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if - ] change-lexer-column ; - -: still-parsing? ( lexer -- ? ) - dup lexer-line swap lexer-text length <= ; - -: still-parsing-line? ( lexer -- ? ) - dup lexer-column swap lexer-line-length < ; - -: (parse-token) ( lexer -- str ) - [ lexer-column ] keep - [ skip-word ] keep - [ lexer-column ] keep - lexer-line-text subseq ; - -: parse-token ( lexer -- str/f ) - dup still-parsing? [ - dup skip-blank - dup still-parsing-line? - [ (parse-token) ] [ dup next-line parse-token ] if - ] [ drop f ] if ; - -: scan ( -- str/f ) lexer get parse-token ; - -ERROR: bad-escape ; - -M: bad-escape summary drop "Bad escape code" ; - -: escape ( escape -- ch ) - H{ - { CHAR: a CHAR: \a } - { CHAR: e CHAR: \e } - { CHAR: n CHAR: \n } - { CHAR: r CHAR: \r } - { CHAR: t CHAR: \t } - { CHAR: s CHAR: \s } - { CHAR: \s CHAR: \s } - { CHAR: 0 CHAR: \0 } - { CHAR: \\ CHAR: \\ } - { CHAR: \" CHAR: \" } - } at [ bad-escape ] unless* ; - -SYMBOL: name>char-hook - -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at - -: unicode-escape ( str -- ch str' ) - "{" ?head-slice [ - CHAR: } over index cut-slice - >r >string name>char-hook get call r> - rest-slice - ] [ - 6 cut-slice >r hex> r> - ] if ; - -: next-escape ( str -- ch str' ) - "u" ?head-slice [ - unicode-escape - ] [ - unclip-slice escape swap - ] if ; - -: (parse-string) ( str -- m ) - dup [ "\"\\" member? ] find dup [ - >r cut-slice >r % r> rest-slice r> - dup CHAR: " = [ - drop slice-from - ] [ - drop next-escape >r , r> (parse-string) - ] if - ] [ - "Unterminated string" throw - ] if ; - -: parse-string ( -- str ) - lexer get [ - [ swap tail-slice (parse-string) ] "" make swap - ] change-lexer-column ; - -TUPLE: parse-error file line column line-text error ; - -: ( msg -- error ) - \ parse-error new - file get >>file - lexer get line>> >>line - lexer get column>> >>column - lexer get line-text>> >>line-text - swap >>error ; - -: parse-dump ( error -- ) - { - [ file>> file. ] - [ line>> number>string print ] - [ line-text>> dup string? [ print ] [ drop ] if ] - [ column>> 0 or CHAR: \s write ] - } cleave - "^" print ; - -M: parse-error error. - [ parse-dump ] [ error>> error. ] bi ; - -M: parse-error summary - error>> summary ; - -M: parse-error compute-restarts - error>> compute-restarts ; - -M: parse-error error-help - error>> error-help ; - SYMBOL: use SYMBOL: in -: word/vocab% ( word -- ) - "(" % dup word-vocabulary % " " % word-name % ")" % ; - : (use+) ( vocab -- ) vocab-words use get push ; @@ -216,25 +54,8 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -ERROR: unexpected want got ; - -PREDICATE: unexpected-eof < unexpected - unexpected-got not ; - M: parsing-word stack-effect drop (( parsed -- parsed )) ; -: unexpected-eof ( word -- * ) f unexpected ; - -: (parse-tokens) ( accum end -- accum ) - scan 2dup = [ - 2drop - ] [ - [ pick push (parse-tokens) ] [ unexpected-eof ] if* - ] if ; - -: parse-tokens ( end -- seq ) - 100 swap (parse-tokens) >array ; - ERROR: no-current-vocab ; M: no-current-vocab summary ( obj -- ) @@ -248,18 +69,8 @@ M: no-current-vocab summary ( obj -- ) : CREATE ( -- word ) scan create-in ; -: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; - : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -: create-class-in ( word -- word ) - current-vocab create - dup save-class-location - dup predicate-word dup set-word save-location ; - -: CREATE-CLASS ( -- word ) - scan create-class-in ; - : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep @@ -296,62 +107,6 @@ M: no-word-error summary ] ?if ] when ; -: create-method-in ( class generic -- method ) - create-method f set-word dup save-location ; - -: CREATE-METHOD ( -- method ) - scan-word bootstrap-word scan-word create-method-in ; - -: shadowed-slots ( superclass slots -- shadowed ) - >r all-slot-names r> intersect ; - -: check-slot-shadowing ( class superclass slots -- ) - shadowed-slots [ - [ - "Definition of slot ``" % - % - "'' in class ``" % - word-name % - "'' shadows a superclass slot" % - ] "" make note. - ] with each ; - -ERROR: invalid-slot-name name ; - -M: invalid-slot-name summary - drop - "Invalid slot name" ; - -: (parse-tuple-slots) ( -- ) - #! This isn't meant to enforce any kind of policy, just - #! to check for mistakes of this form: - #! - #! TUPLE: blahblah foo bing - #! - #! : ... - scan { - { [ dup not ] [ unexpected-eof ] } - { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } - { [ dup ";" = ] [ drop ] } - [ , (parse-tuple-slots) ] - } cond ; - -: parse-tuple-slots ( -- seq ) - [ (parse-tuple-slots) ] { } make ; - -: parse-tuple-definition ( -- class superclass slots ) - CREATE-CLASS - scan { - { ";" [ tuple f ] } - { "<" [ scan-word parse-tuple-slots ] } - [ >r tuple parse-tuple-slots r> prefix ] - } case 3dup check-slot-shadowing ; - -ERROR: not-in-a-method-error ; - -M: not-in-a-method-error summary - drop "call-next-method can only be called in a method definition" ; - ERROR: staging-violation word ; M: staging-violation summary @@ -362,6 +117,10 @@ M: staging-violation summary dup changed-definitions get key? [ staging-violation ] when execute ; +: scan-object ( -- object ) + scan-word dup parsing-word? + [ V{ } clone swap execute-parsing first ] when ; + : parse-step ( accum end -- accum ? ) scan-word { { [ 2dup eq? ] [ 2drop f ] } @@ -379,37 +138,12 @@ M: staging-violation summary : parsed ( accum obj -- accum ) over push ; -: with-parser ( lexer quot -- newquot ) - swap lexer set - [ call >quotation ] [ rethrow ] recover ; - : (parse-lines) ( lexer -- quot ) - [ f parse-until ] with-parser ; - -SYMBOL: lexer-factory - -[ ] lexer-factory set-global + [ f parse-until >quotation ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; -! Parsing word utilities -: parse-effect ( end -- effect ) - parse-tokens dup { "(" "((" } intersect empty? [ - { "--" } split1 dup [ - - ] [ - "Stack effect declaration must contain --" throw - ] if - ] [ - "Stack effect declaration must not contain ( or ((" throw - ] if ; - -ERROR: bad-number ; - -: parse-base ( parsed base -- parsed ) - scan swap base> [ bad-number ] unless* parsed ; - : parse-literal ( accum end quot -- accum ) >r parse-until r> call parsed ; inline @@ -418,40 +152,14 @@ ERROR: bad-number ; : (:) ( -- word def ) CREATE-WORD parse-definition ; -SYMBOL: current-class -SYMBOL: current-generic - -: with-method-definition ( quot -- parsed ) - [ - >r - [ "method-class" word-prop current-class set ] - [ "method-generic" word-prop current-generic set ] - [ ] tri - r> call - ] with-scope ; inline - -: (M:) ( method def -- ) - CREATE-METHOD [ parse-definition ] with-method-definition ; - -: scan-object ( -- object ) - scan-word dup parsing-word? - [ V{ } clone swap execute first ] when ; - -GENERIC: expected>string ( obj -- str ) - -M: f expected>string drop "end of input" ; -M: word expected>string word-name ; -M: string expected>string ; - -M: unexpected error. - "Expected " write - dup unexpected-want expected>string write - " but got " write - unexpected-got expected>string print ; +ERROR: bad-number ; M: bad-number summary drop "Bad number literal" ; +: parse-base ( parsed base -- parsed ) + scan swap base> [ bad-number ] unless* parsed ; + SYMBOL: bootstrap-syntax : with-file-vocabs ( quot -- ) diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 454f148974..0577dacc85 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -75,11 +75,36 @@ M: pathname forget* SYMBOL: file +TUPLE: source-file-error file error ; + +: ( msg -- error ) + \ source-file-error new + file get >>file + swap >>error ; + +: file. ( file -- ) path>> pprint ; + +M: source-file-error error. + "Error while parsing " write + [ file>> file. nl ] [ error>> error. ] bi ; + +M: source-file-error summary + error>> summary ; + +M: source-file-error compute-restarts + error>> compute-restarts ; + +M: source-file-error error-help + error>> error-help ; + : with-source-file ( name quot -- ) #! Should be called from inside with-compilation-unit. [ swap source-file dup file set source-file-definitions old-definitions set - [ ] [ file get rollback-source-file ] cleanup + [ + file get rollback-source-file + rethrow + ] recover ] with-scope ; inline diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor new file mode 100644 index 0000000000..0aa6d483ca --- /dev/null +++ b/core/strings/parser/parser-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax strings lexer ; +IN: strings.parser + +HELP: bad-escape +{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; + +HELP: escape +{ $values { "escape" "a single-character escape" } { "ch" "a character" } } +{ $description "Converts from a single-character escape code and the corresponding character." } +{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; + +HELP: parse-string +{ $values { "str" "a new " { $link string } } } +{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } +{ $errors "Throws an error if the string contains an invalid escape sequence." } +$parsing-note ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor new file mode 100644 index 0000000000..08421b4a20 --- /dev/null +++ b/core/strings/parser/parser.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel inspector assocs namespaces splitting sequences +strings math.parser lexer ; +IN: strings.parser + +ERROR: bad-escape ; + +M: bad-escape summary drop "Bad escape code" ; + +: escape ( escape -- ch ) + H{ + { CHAR: a CHAR: \a } + { CHAR: e CHAR: \e } + { CHAR: n CHAR: \n } + { CHAR: r CHAR: \r } + { CHAR: t CHAR: \t } + { CHAR: s CHAR: \s } + { CHAR: \s CHAR: \s } + { CHAR: 0 CHAR: \0 } + { CHAR: \\ CHAR: \\ } + { CHAR: \" CHAR: \" } + } at [ bad-escape ] unless* ; + +SYMBOL: name>char-hook + +name>char-hook global [ + [ "Unicode support not available" throw ] or +] change-at + +: unicode-escape ( str -- ch str' ) + "{" ?head-slice [ + CHAR: } over index cut-slice + >r >string name>char-hook get call r> + rest-slice + ] [ + 6 cut-slice >r hex> r> + ] if ; + +: next-escape ( str -- ch str' ) + "u" ?head-slice [ + unicode-escape + ] [ + unclip-slice escape swap + ] if ; + +: (parse-string) ( str -- m ) + dup [ "\"\\" member? ] find dup [ + >r cut-slice >r % r> rest-slice r> + dup CHAR: " = [ + drop slice-from + ] [ + drop next-escape >r , r> (parse-string) + ] if + ] [ + "Unterminated string" throw + ] if ; + +: parse-string ( -- str ) + lexer get [ + [ swap tail-slice (parse-string) ] "" make swap + ] change-lexer-column ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 91a453408d..dfba35f71a 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays bit-arrays byte-arrays byte-vectors -definitions generic hashtables kernel math -namespaces parser sequences strings sbufs vectors words -quotations io assocs splitting classes.tuple generic.standard -generic.math classes io.files vocabs float-arrays -classes.union classes.intersection classes.mixin -classes.predicate classes.singleton compiler.units -combinators debugger ; +definitions generic hashtables kernel math namespaces parser +lexer sequences strings strings.parser sbufs vectors +words quotations io assocs splitting classes.tuple +generic.standard generic.math generic.parser classes io.files +vocabs float-arrays classes.parser classes.union +classes.intersection classes.mixin classes.predicate +classes.singleton classes.tuple.parser compiler.units +combinators debugger effects.parser ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 7d3ef89759..c83d4b5152 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -1,4 +1,4 @@ -USING: parser kernel math sequences namespaces assocs inspector +USING: parser lexer kernel math sequences namespaces assocs inspector words splitting math.parser arrays sequences.next mirrors shuffle compiler.units ; IN: bitfields diff --git a/extra/bootstrap/unicode/unicode.factor b/extra/bootstrap/unicode/unicode.factor index 0476cbf18b..b46e322d7b 100755 --- a/extra/bootstrap/unicode/unicode.factor +++ b/extra/bootstrap/unicode/unicode.factor @@ -1,4 +1,4 @@ -USING: parser kernel namespaces ; +USING: strings.parser kernel namespaces ; USE: unicode.breaks USE: unicode.case diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index f4cfb20591..1dd1e0a264 100755 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: compiler io kernel cocoa.runtime cocoa.subclassing cocoa.messages cocoa.types sequences words vocabs parser -core-foundation namespaces assocs hashtables compiler.units ; +core-foundation namespaces assocs hashtables compiler.units +lexer ; IN: cocoa : (remember-send) ( selector variable -- ) diff --git a/extra/cpu/8080/emulator/emulator.factor b/extra/cpu/8080/emulator/emulator.factor index b0ffb6ae54..aa8dc4f9cf 100755 --- a/extra/cpu/8080/emulator/emulator.factor +++ b/extra/cpu/8080/emulator/emulator.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel math sequences words arrays io io.files namespaces -math.parser assocs quotations parser parser-combinators +math.parser assocs quotations parser lexer parser-combinators tools.time io.encodings.binary sequences.deep symbols combinators ; IN: cpu.8080.emulator diff --git a/extra/editors/editors-docs.factor b/extra/editors/editors-docs.factor index 2b9e4cc021..0f50e40eb4 100644 --- a/extra/editors/editors-docs.factor +++ b/extra/editors/editors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax parser vocabs.loader ; +USING: help.markup help.syntax parser source-files vocabs.loader ; IN: editors ARTICLE: "editor" "Editor integration" @@ -35,4 +35,4 @@ HELP: no-edit-hook { $error-description "Thrown when " { $link edit } " is called when the " { $link edit-hook } " variable is not set. See " { $link "editor" } "." } ; HELP: :edit -{ $description "If the most recent error was a " { $link parse-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ; +{ $description "If the most recent error was a " { $link source-file-error } " thrown while parsing a source file, opens the source file at the failing line in the default editor using the " { $link edit-hook } ". See " { $link "editor" } "." } ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor index ec8313363e..29cbbca90e 100755 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: parser kernel namespaces sequences definitions io.files -inspector continuations tools.crossref tools.vocabs -io prettyprint source-files assocs vocabs vocabs.loader -io.backend splitting accessors ; +USING: parser lexer kernel namespaces sequences definitions +io.files inspector continuations tools.crossref tools.vocabs io +prettyprint source-files assocs vocabs vocabs.loader io.backend +splitting accessors ; IN: editors TUPLE: no-edit-hook ; @@ -35,21 +35,27 @@ SYMBOL: edit-hook : edit-vocab ( name -- ) vocab-source-path 1 edit-location ; -GENERIC: find-parse-error ( error -- error' ) +GENERIC: error-file ( error -- file ) -M: parse-error find-parse-error - dup error>> find-parse-error [ ] [ ] ?if ; +GENERIC: error-line ( error -- line ) -M: condition find-parse-error - error>> find-parse-error ; +M: lexer-error error-line line>> ; -M: object find-parse-error - drop f ; +M: source-file-error error-file file>> path>> ; + +M: source-file-error error-line error>> error-line ; + +M: condition error-file error>> error-file ; + +M: condition error-line error>> error-line ; + +M: object error-file drop f ; + +M: object error-line drop f ; : :edit ( -- ) - error get find-parse-error [ - [ file>> path>> ] [ line>> ] bi edit-location - ] when* ; + error get [ error-file ] [ error-line ] bi + 2dup and [ edit-location ] [ 2drop ] if ; : edit-each ( seq -- ) [ diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index 76615a3de5..ba0ff5bedd 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel prettyprint ui ui.gadgets ui.gadgets.panes -ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors ; +ui.gadgets.scrollers ui.gadgets.theme ui.gestures colors +accessors ; IN: gesture-logger TUPLE: gesture-logger stream ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index dfbb7a12b8..246ad56e51 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -3,7 +3,7 @@ namespaces words sequences classes assocs vocabs kernel arrays prettyprint.backend kernel.private io generic math system strings sbufs vectors byte-arrays bit-arrays float-arrays quotations io.streams.byte-array io.encodings.string -classes.builtin parser ; +classes.builtin parser lexer ; IN: help.handbook ARTICLE: "conventions" "Conventions" diff --git a/extra/html/templates/chloe/syntax/syntax.factor b/extra/html/templates/chloe/syntax/syntax.factor index 7eeb756a39..cfa576d56f 100644 --- a/extra/html/templates/chloe/syntax/syntax.factor +++ b/extra/html/templates/chloe/syntax/syntax.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: html.templates.chloe.syntax USING: accessors kernel sequences combinators kernel namespaces -classes.tuple assocs splitting words arrays memoize parser +classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string unicode.case tuple-syntax mirrors fry math urls multiline xml xml.data xml.writer xml.utilities diff --git a/extra/html/templates/fhtml/fhtml.factor b/extra/html/templates/fhtml/fhtml.factor index 74e5c37ef1..e435fdce5f 100755 --- a/extra/html/templates/fhtml/fhtml.factor +++ b/extra/html/templates/fhtml/fhtml.factor @@ -4,7 +4,7 @@ USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors assocs fry -parser io io.files io.streams.string io.encodings.utf8 +parser lexer io io.files io.streams.string io.encodings.utf8 html.elements html.templates ; IN: html.templates.fhtml @@ -55,8 +55,8 @@ DEFER: <% delimiter : parse-template-lines ( lines -- quot ) [ - V{ } clone lexer get parse-%> f (parse-until) - ] with-parser ; + V{ } clone lexer get parse-%> f (parse-until) >quotation + ] with-lexer ; : parse-template ( string -- quot ) [ diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 522d0c1845..a920d4e67a 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -5,6 +5,12 @@ assocs io.sockets db db.sqlite continuations urls hashtables accessors ; IN: http.tests +[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test + +[ "text/html" utf8 ] [ "text/html; charset=UTF-8" parse-content-type ] unit-test + +[ "application/octet-stream" binary ] [ "application/octet-stream" parse-content-type ] unit-test + : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 diff --git a/extra/http/http.factor b/extra/http/http.factor index 4001301cb1..d5712d5bab 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -211,7 +211,8 @@ TUPLE: post-data raw content content-type ; " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) - ";" split1 parse-content-type-attributes "charset" swap at ; + ";" split1 parse-content-type-attributes "charset" swap at + name>encoding over "text/" head? latin1 binary ? or ; : read-request ( -- request ) @@ -310,7 +311,7 @@ M: response clone dup "content-type" header [ parse-content-type [ >>content-type ] - [ name>encoding binary or >>content-charset ] bi* + [ >>content-charset ] bi* ] when* ; : read-response ( -- response ) diff --git a/extra/io/encodings/8-bit/8-bit-docs.factor b/extra/io/encodings/8-bit/8-bit-docs.factor index 33d629b105..8f5e955998 100644 --- a/extra/io/encodings/8-bit/8-bit-docs.factor +++ b/extra/io/encodings/8-bit/8-bit-docs.factor @@ -24,20 +24,13 @@ ARTICLE: "io.encodings.8-bit" "8-bit encodings" { $subsection koi8-r } { $subsection windows-1252 } { $subsection ebcdic } -{ $subsection mac-roman } -"Words used in defining these" -{ $subsection 8-bit } -{ $subsection define-8-bit-encoding } ; +{ $subsection mac-roman } ; ABOUT: "io.encodings.8-bit" HELP: 8-bit { $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ; -HELP: define-8-bit-encoding -{ $values { "name" string } { "stream" "an input stream" } } -{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ; - HELP: latin1 { $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." } { $see-also "encodings-introduction" } ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index cc6a7d093e..49eec6d652 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -4,8 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math inference.transforms parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets -sequences.private effects generic compiler.units accessors -locals.backend memoize ; +sequences.private effects effects.parser generic generic.parser +compiler.units accessors locals.backend memoize lexer ; IN: locals ! Inspired by diff --git a/extra/match/match.factor b/extra/match/match.factor index 8a174034ba..0ae285d20d 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Based on pattern matching code from Paul Graham's book 'On Lisp'. -USING: parser kernel words namespaces sequences classes.tuple +USING: parser lexer kernel words namespaces sequences classes.tuple combinators macros assocs math effects ; IN: match diff --git a/extra/money/money.factor b/extra/money/money.factor index 54c53e9bec..ba7a0ae04f 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -1,4 +1,4 @@ -USING: io kernel math math.functions math.parser parser +USING: io kernel math math.functions math.parser parser lexer namespaces sequences splitting grouping combinators continuations sequences.lib ; IN: money diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor index 3a4dc6fefb..1b5b6f2393 100644 --- a/extra/mortar/mortar.factor +++ b/extra/mortar/mortar.factor @@ -1,5 +1,5 @@ -USING: kernel io parser words namespaces quotations arrays assocs sequences +USING: kernel io parser lexer words namespaces quotations arrays assocs sequences splitting grouping math shuffle ; IN: mortar diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index ce79bdaf5f..cf671c5609 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces parser kernel sequences words quotations math ; +USING: namespaces parser lexer kernel sequences words quotations math ; IN: multiline : next-line-text ( -- str ) diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index 8f2eee9459..fd547c8b5a 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,6 +1,6 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs -continuations ; +continuations lexer ; IN: opengl.gl.extensions ERROR: unknown-gl-platform ; diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index dced2e5c0c..e951ad8858 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -2,7 +2,7 @@ ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax combinators kernel system namespaces -assocs parser sequences words quotations math.bitfields ; +assocs parser lexer sequences words quotations math.bitfields ; IN: openssl.libssl diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index 5810a03f80..d636cc0152 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -1,5 +1,7 @@ -USING: kernel sequences assocs hashtables parser vocabs words namespaces -vocabs.loader debugger sets ; +! Copyright (C) 2007, 2008 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences assocs hashtables parser lexer +vocabs words namespaces vocabs.loader debugger sets ; IN: qualified : define-qualified ( vocab-name prefix-name -- ) diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index 99e6b887c8..8872338f5d 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -1,5 +1,5 @@ USING: arrays combinators kernel lists math math.parser -namespaces parser parser-combinators parser-combinators.simple +namespaces parser lexer parser-combinators parser-combinators.simple promises quotations sequences combinators.lib strings math.order assocs prettyprint.backend memoize unicode.case unicode.categories ; USE: io diff --git a/extra/semantic-db/semantic-db.factor b/extra/semantic-db/semantic-db.factor index 7d50d384e2..27e8cf1d90 100755 --- a/extra/semantic-db/semantic-db.factor +++ b/extra/semantic-db/semantic-db.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators combinators.cleave combinators.lib continuations db db.tuples db.types db.sqlite kernel math -math.parser namespaces parser sets sequences sequences.deep +math.parser namespaces parser lexer sets sequences sequences.deep sequences.lib strings words destructors ; IN: semantic-db diff --git a/extra/state-machine/state-machine.factor b/extra/state-machine/state-machine.factor index 4c83c64641..b5e8c16b02 100755 --- a/extra/state-machine/state-machine.factor +++ b/extra/state-machine/state-machine.factor @@ -1,4 +1,4 @@ -USING: kernel parser strings math namespaces sequences words io +USING: kernel parser lexer strings math namespaces sequences words io arrays quotations debugger kernel.private sequences.private ; IN: state-machine diff --git a/extra/symbols/symbols.factor b/extra/symbols/symbols.factor index 20cf16e640..6cf8eac6fb 100755 --- a/extra/symbols/symbols.factor +++ b/extra/symbols/symbols.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: parser sequences words kernel classes.singleton ; +USING: parser lexer sequences words kernel classes.singleton +classes.parser ; IN: symbols : SYMBOLS: diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 3df5485f4e..f9b56a1d8d 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: qualified io.streams.c init fry namespaces assocs kernel -parser tools.deploy.config vocabs sequences words words.private -memory kernel.private continuations io prettyprint -vocabs.loader debugger system strings sets ; +parser lexer strings.parser tools.deploy.config vocabs sequences +words words.private memory kernel.private continuations io +prettyprint vocabs.loader debugger system strings sets ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor index cf439f6407..ce717f4211 100755 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -1,4 +1,4 @@ -USING: kernel sequences slots parser words classes +USING: kernel sequences slots parser lexer words classes slots.private mirrors ; IN: tuple-syntax diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 72bd4e43a3..fcd3f9ab22 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents hashtables io io.styles kernel math math.order math.vectors -models namespaces parser prettyprint quotations sequences +models namespaces parser lexer prettyprint quotations sequences strings threads listener classes.tuple ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds ui.gestures definitions calendar concurrency.flags @@ -149,7 +149,7 @@ M: interactor dispose drop ; mark>caret ; : handle-parse-error ( interactor error -- ) - dup parse-error? [ 2dup go-to-error error>> ] when + dup lexer-error? [ 2dup go-to-error error>> ] when swap find-workspace debugger-popup ; : try-parse ( lines interactor -- quot/error/f ) @@ -157,7 +157,7 @@ M: interactor dispose drop ; drop parse-lines-interactive ] [ 2nip - dup parse-error? [ + dup lexer-error? [ dup error>> unexpected-eof? [ drop f ] when ] when ] recover ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index b5ba25db4e..2410779804 100755 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -1,4 +1,4 @@ -USING: unicode.data kernel math sequences parser bit-arrays +USING: unicode.data kernel math sequences parser lexer bit-arrays namespaces sequences.private arrays quotations assocs classes.predicate math.order ; IN: unicode.syntax diff --git a/extra/urls/urls.factor b/extra/urls/urls.factor index 38511de8e8..de661bdd9d 100644 --- a/extra/urls/urls.factor +++ b/extra/urls/urls.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel unicode.categories combinators sequences splitting +USING: kernel unicode.categories combinators combinators.lib +sequences splitting fry namespaces assocs arrays strings io.sockets io.sockets.secure io.encodings.string io.encodings.utf8 -math math.parser accessors mirrors parser +math math.parser accessors mirrors parser strings.parser lexer prettyprint.backend hashtables present ; IN: urls @@ -11,12 +12,11 @@ IN: urls #! In a URL, can this character be used without #! URL-encoding? { - { [ dup letter? ] [ t ] } - { [ dup LETTER? ] [ t ] } - { [ dup digit? ] [ t ] } - { [ dup "/_-." member? ] [ t ] } - [ f ] - } cond nip ; foldable + [ letter? ] + [ LETTER? ] + [ digit? ] + [ "/_-." member? ] + } 1|| ; foldable , ; @@ -36,7 +36,7 @@ IN: xml.generator [ \ contained*, parsed ] [ scan-word \ [ = [ POSTPONE: [ \ tag*, parsed ] - [ "Expected [ missing" throw ] if + [ "Expected [ missing" throw ] if ] if ; DEFER: >> diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor index 87a0242412..c53bbf3b0f 100755 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces sequences words io assocs -quotations strings parser arrays xml.data xml.writer debugger +quotations strings parser lexer arrays xml.data xml.writer debugger splitting vectors sequences.deep ; IN: xml.utilities diff --git a/extra/xmode/loader/syntax/syntax.factor b/extra/xmode/loader/syntax/syntax.factor index b3adf5cb60..4c95a45832 100644 --- a/extra/xmode/loader/syntax/syntax.factor +++ b/extra/xmode/loader/syntax/syntax.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.rules xmode.keyword-map xml.data xml.utilities xml assocs kernel combinators sequences -math.parser namespaces parser xmode.utilities regexp io.files ; +math.parser namespaces parser lexer xmode.utilities regexp io.files ; IN: xmode.loader.syntax SYMBOL: ignore-case? diff --git a/extra/xmode/utilities/utilities.factor b/extra/xmode/utilities/utilities.factor index 2e1d0a2872..d6f9c42799 100644 --- a/extra/xmode/utilities/utilities.factor +++ b/extra/xmode/utilities/utilities.factor @@ -1,5 +1,5 @@ USING: sequences assocs kernel quotations namespaces xml.data -xml.utilities combinators macros parser words ; +xml.utilities combinators macros parser lexer words ; IN: xmode.utilities : implies >r not r> or ; inline