Split up huge parser vocabulary

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

core/classes/classes.factor

@@ -65,6 +65,15 @@ GENERIC: rank-class ( class -- n )
 
 GENERIC: reset-class ( class -- )
 
+M: class reset-class
+    {
+        "class"
+        "metaclass"
+        "superclass"
+        "members"
+        "participants"
+    } reset-props ;
+
 M: word reset-class drop ;
 
 GENERIC: implementors ( class/classes -- seq )

core/classes/intersection/intersection.factor

@@ -27,7 +27,4 @@ M: intersection-class update-class define-intersection-predicate ;
     [ drop update-classes ]
     2bi ;
 
-M: intersection-class reset-class
-    { "class" "metaclass" "participants" } reset-props ;
-
 M: intersection-class rank-class drop 2 ;

core/classes/mixin/mixin.factor

@@ -7,7 +7,7 @@ IN: classes.mixin
 PREDICATE: mixin-class < union-class "mixin" word-prop ;
 
 M: mixin-class reset-class
-    { "class" "metaclass" "members" "mixin" } reset-props ;
+    [ call-next-method ] [ { "mixin" } reset-props ] bi ;
 
 M: mixin-class rank-class drop 3 ;
 

core/classes/parser/parser.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser words kernel classes compiler.units lexer ;
+IN: classes.parser
+
+: save-class-location ( class -- )
+    location remember-class ;
+
+: 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 ;

core/classes/predicate/predicate.factor

@@ -24,11 +24,8 @@ PREDICATE: predicate-class < class
     ] 3tri ;
 
 M: predicate-class reset-class
-    {
+    [ call-next-method ]
-        "class"
+    [ { "predicate-definition" } reset-props ]
-        "metaclass"
+    bi ;
-        "predicate-definition"
-        "superclass"
-    } reset-props ;
 
 M: predicate-class rank-class drop 1 ;

core/classes/tuple/parser/parser-docs.factor

@@ -0,0 +1,14 @@
+IN: classes.tuple.parser
+USING: strings help.markup help.syntax ;
+
+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 -- ) ... ;"
+    }
+} ;

core/classes/tuple/parser/parser.factor

@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sets namespaces sequences inspector parser
+lexer combinators words classes.parser classes.tuple ;
+IN: classes.tuple.parser
+
+: 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 ;

core/classes/tuple/tuple.factor

@@ -217,13 +217,9 @@ M: tuple-class reset-class
             [ writer-word method forget ] 2bi
         ] with each
     ] [
-        {
+        [ call-next-method ]
-            "class"
+        [ { "layout" "slots" } reset-props ]
-            "metaclass"
+        bi
-            "superclass"
-            "layout"
-            "slots"
-        } reset-props
     ] bi ;
 
 M: tuple-class rank-class drop 0 ;

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 ;

core/continuations/continuations-docs.factor

@@ -1,6 +1,6 @@
 USING: help.markup help.syntax kernel kernel.private
-continuations.private parser vectors arrays namespaces
+continuations.private vectors arrays namespaces
-assocs words quotations ;
+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:"
+    "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
-    { $see with-parser }
+    { $see with-lexer }
 } ;
 
 HELP: throw-restarts

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
+combinators kernel.private math namespaces sequences
-words system layouts math.order accessors ;
+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 ;

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

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

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 [
+            <effect>
+        ] [
+            "Stack effect declaration must contain --" throw
+        ] if
+    ] [
+        "Stack effect declaration must not contain ( or ((" throw
+    ] if ;

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

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: <lexer>
+{ $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: <lexer-error>
+{ $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 <lexer> }
+"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 } ;

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
+
+: <lexer> ( 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 <vector> swap (parse-tokens) >array ;
+
+TUPLE: lexer-error line column line-text error ;
+
+: <lexer-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 <string>
+    [ 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 [ <lexer-error> rethrow ] recover ; inline
+
+SYMBOL: lexer-factory
+
+[ <lexer> ] lexer-factory set-global

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

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 <lexer> }
-"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: <lexer>
-{ $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: <parse-error>
-{ $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." } ;
+{ $errors "Throws a " { $link lexer-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 ;
 
 HELP: parse-base
 { $values { "base" "an integer between 2 and 36" } { "parsed" integer } }

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

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
+io.encodings.utf8 source-files classes hashtables
-compiler.errors compiler.units accessors sets ;
+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
-
-: <lexer> ( text -- lexer )
-    lexer new-lexer ;
-
 : location ( -- loc )
-    file get lexer get lexer-line 2dup and
+    file get lexer get line>> 2dup and
-    [ >r source-file-path r> 2array ] [ 2drop f ] if ;
+    [ >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 <pathname> pprint
-    ] [
-        "<interactive>" 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 ;
-
-: <parse-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 <string> 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 <vector> 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 ] [ <parse-error> rethrow ] recover ;
-
 : (parse-lines) ( lexer -- quot )
-    [ f parse-until ] with-parser ;
+    [ f parse-until >quotation ] with-lexer ;
-
-SYMBOL: lexer-factory
-
-[ <lexer> ] lexer-factory set-global
 
 : parse-lines ( lines -- quot )
     lexer-factory get call (parse-lines) ;
 
-! Parsing word utilities
-: parse-effect ( end -- effect )
-    parse-tokens dup { "(" "((" } intersect empty? [
-        { "--" } split1 dup [
-            <effect>
-        ] [
-            "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
+ERROR: bad-number ;
-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 ;
 
 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 -- )

core/source-files/source-files.factor

@@ -75,11 +75,36 @@ M: pathname forget*
 
 SYMBOL: file
 
+TUPLE: source-file-error file error ;
+
+: <source-file-error> ( msg -- error )
+    \ source-file-error new
+        file get >>file
+        swap >>error ;
+
+: file. ( file -- ) path>> <pathname> 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
+            <source-file-error> rethrow
+        ] recover
     ] with-scope ; inline

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 ;

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 ;

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
+definitions generic hashtables kernel math namespaces parser
-namespaces parser sequences strings sbufs vectors words
+lexer sequences strings strings.parser sbufs vectors
-quotations io assocs splitting classes.tuple generic.standard
+words quotations io assocs splitting classes.tuple
-generic.math classes io.files vocabs float-arrays
+generic.standard generic.math generic.parser classes io.files
-classes.union classes.intersection classes.mixin
+vocabs float-arrays classes.parser classes.union
-classes.predicate classes.singleton compiler.units
+classes.intersection classes.mixin classes.predicate
-combinators debugger ;
+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

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

extra/bootstrap/unicode/unicode.factor

@@ -1,4 +1,4 @@
-USING: parser kernel namespaces ;
+USING: strings.parser kernel namespaces ;
 
 USE: unicode.breaks
 USE: unicode.case

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

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
 

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" } "." } ;

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
+USING: parser lexer kernel namespaces sequences definitions
-inspector continuations tools.crossref tools.vocabs 
+io.files inspector continuations tools.crossref tools.vocabs io
-io prettyprint source-files assocs vocabs vocabs.loader
+prettyprint source-files assocs vocabs vocabs.loader io.backend
-io.backend splitting accessors ;
+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
+GENERIC: error-line ( error -- line )
-    dup error>> find-parse-error [ ] [ ] ?if ;
 
-M: condition find-parse-error
+M: lexer-error error-line line>> ;
-    error>> find-parse-error ;
 
-M: object find-parse-error
+M: source-file-error error-file file>> path>> ;
-    drop f ;
+
+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 [
+    error get [ error-file ] [ error-line ] bi
-        [ file>> path>> ] [ line>> ] bi edit-location
+    2dup and [ edit-location ] [ 2drop ] if ;
-    ] when* ;
 
 : edit-each ( seq -- )
     [

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 ;

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"

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

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 )
     <template-lexer> [
-        V{ } clone lexer get parse-%> f (parse-until)
+        V{ } clone lexer get parse-%> f (parse-until) >quotation
-    ] with-parser ;
+    ] with-lexer ;
 
 : parse-template ( string -- quot )
     [

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

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

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 }
+{ $subsection mac-roman } ;
-"Words used in defining these"
-{ $subsection 8-bit }
-{ $subsection define-8-bit-encoding } ;
 
 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" } ;

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
+sequences.private effects effects.parser generic generic.parser
-locals.backend memoize ;
+compiler.units accessors locals.backend memoize lexer ;
 IN: locals
 
 ! Inspired by

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
 

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

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

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 )

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 ;

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
 

extra/qualified/qualified.factor

@@ -1,5 +1,7 @@
-USING: kernel sequences assocs hashtables parser vocabs words namespaces
+! Copyright (C) 2007, 2008 Daniel Ehrenberg.
-vocabs.loader debugger sets ;
+! 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 -- )

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

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
 

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
 

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:

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
+parser lexer strings.parser tools.deploy.config vocabs sequences
-memory kernel.private continuations io prettyprint
+words words.private memory kernel.private continuations io
-vocabs.loader debugger system strings sets ;
+prettyprint vocabs.loader debugger system strings sets ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: classes
 QUALIFIED: command-line

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
 

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 ;

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

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 ] }
+        [ letter? ]
-        { [ dup LETTER? ] [ t ] }
+        [ LETTER? ]
-        { [ dup digit? ] [ t ] }
+        [ digit? ]
-        { [ dup "/_-." member? ] [ t ] }
+        [ "/_-." member? ]
-        [ f ]
+    } 1|| ; foldable
-    } cond nip ; foldable
 
 <PRIVATE
 

extra/vars/vars.factor

@@ -2,7 +2,7 @@
 
 ! Thanks to Mackenzie Straight for the idea
 
-USING: kernel parser words namespaces sequences quotations ;
+USING: kernel parser lexer words namespaces sequences quotations ;
 
 IN: vars
 

extra/xml/generator/generator.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel xml.data xml.utilities assocs splitting
-sequences parser quotations sequences.lib xml.utilities ;
+sequences parser lexer quotations sequences.lib xml.utilities ;
 IN: xml.generator
 
 : comment, ( string -- ) <comment> , ;
@@ -36,7 +36,7 @@ IN: xml.generator
     [ \ contained*, parsed ] [
         scan-word \ [ =
         [ POSTPONE: [ \ tag*, parsed ]
-        [ "Expected [ missing" <parse-error> throw ] if
+        [ "Expected [ missing" throw ] if
     ] if ;
 
 DEFER: >>

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
 

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?

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