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
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 )
[ drop update-classes ]
2bi ;
-M: intersection-class reset-class
- { "class" "metaclass" "participants" } reset-props ;
-
M: intersection-class rank-class drop 2 ;
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 ;
--- /dev/null
+! 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 ;
] 3tri ;
M: predicate-class reset-class
- {
- "class"
- "metaclass"
- "predicate-definition"
- "superclass"
- } reset-props ;
+ [ call-next-method ]
+ [ { "predicate-definition" } reset-props ]
+ bi ;
M: predicate-class rank-class drop 1 ;
--- /dev/null
+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 -- ) ... ;"
+ }
+} ;
--- /dev/null
+! 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 ;
[ 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 ;
: 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 ;
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"
"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
! 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.
! 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 ;
--- /dev/null
+! 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
--- /dev/null
+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 ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+
--- /dev/null
+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 } ;
--- /dev/null
+! 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
! 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
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
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"
{ $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 }
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 } "." } ;
{ $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." } ;
{ $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." }
{ $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." }
{ $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 } }
[ 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
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
-
-: <lexer> ( 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
: 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.
"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 ;
: 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 -- )
: 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
] ?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
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 ] }
: 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 ;
-
-SYMBOL: lexer-factory
-
-[ <lexer> ] 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 [
- <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
: (:) ( -- 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 -- )
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
--- /dev/null
+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 ;
--- /dev/null
+! 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 ;
! 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
-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
-USING: parser kernel namespaces ;
+USING: strings.parser kernel namespaces ;
USE: unicode.breaks
USE: unicode.case
! 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 -- )
! 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
-USING: help.markup help.syntax parser vocabs.loader ;
+USING: help.markup help.syntax parser source-files vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
{ $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" } "." } ;
! 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 ;
: 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 -- )
[
! 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 ;
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"
! 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
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
: parse-template-lines ( lines -- quot )
<template-lexer> [
- 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 )
[
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
" " 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>
dup "content-type" header [
parse-content-type
[ >>content-type ]
- [ name>encoding binary or >>content-charset ] bi*
+ [ >>content-charset ] bi*
] when* ;
: read-response ( -- response )
{ $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" } ;
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
! 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
-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
-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
! 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 )
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 ;
! 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
-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 -- )
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
! 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
-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
! 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:
! 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
-USING: kernel sequences slots parser words classes
+USING: kernel sequences slots parser lexer words classes
slots.private mirrors ;
IN: tuple-syntax
! 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
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 )
drop parse-lines-interactive
] [
2nip
- dup parse-error? [
+ dup lexer-error? [
dup error>> unexpected-eof? [ drop f ] when
] when
] recover ;
-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
! 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
#! 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
<PRIVATE
! Thanks to Mackenzie Straight for the idea
-USING: kernel parser words namespaces sequences quotations ;
+USING: kernel parser lexer words namespaces sequences quotations ;
IN: vars
! 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> , ;
[ \ contained*, parsed ] [
scan-word \ [ =
[ POSTPONE: [ \ tag*, parsed ]
- [ "Expected [ missing" <parse-error> throw ] if
+ [ "Expected [ missing" throw ] if
] if ;
DEFER: >>
! 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
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?
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
projects / factor.git / commitdiff