mbutterick
/
brag
1
0
Fork 0
Code Issues 3 Pull Requests 1 Projects Releases Wiki Activity

next

Browse Source
pull/2/head
Matthew Butterick 7 years ago
parent dfbca937b4
commit 7832b5a89d
369 changed files with 12526 additions and 0 deletions
Show Stats Download Patch File Download Diff File

11
br-parser-tools/br-parser-tools-doc/LICENSE.txt
Unescape Escape View File

@ -0,0 +1,11 @@
parser-tools-doc
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

769
br-parser-tools/br-parser-tools-doc/br-parser-tools/br-parser-tools.scrbl
Unescape Escape View File

@ -0,0 +1,769 @@
#lang scribble/doc
@(require scribble/manual scribble/struct scribble/xref scribble/bnf
(for-label scheme/base
scheme/contract
br-parser-tools/lex
(prefix-in : br-parser-tools/lex-sre)
br-parser-tools/yacc
br-parser-tools/cfg-parser))
@title{Parser Tools: @exec{lex} and @exec{yacc}-style Parsing (Beautiful Racket edition)}
@author["Scott Owens (99%)" "Matthew Butterick (1%)"]
This documentation assumes familiarity with @exec{lex} and @exec{yacc}
style lexer and parser generators.
@table-of-contents[]
@; ----------------------------------------------------------------------
@section{Lexers}
@section-index["lex"]
@section-index["scanning"]
@section-index["scanner"]
@defmodule[br-parser-tools/lex]
@; ----------------------------------------
@subsection{Creating a Lexer}
@defform/subs[#:literals (repetition union intersection complement concatenation
char-range char-complement
eof special special-comment)
(lexer [trigger action-expr] ...)
([trigger re
(eof)
(special)
(special-comment)]
[re id
string
character
(repetition lo hi re)
(union re ...)
(intersection re ...)
(complement re)
(concatenation re ...)
(char-range char char)
(char-complement re)
(id datum ...)])]{
Produces a function that takes an input-port, matches the
@racket[re] patterns against the buffer, and returns the result of
executing the corresponding @racket[action-expr]. When multiple
patterns match, a lexer will choose the longest match, breaking
ties in favor of the rule appearing first.
@margin-note{The implementation of @racketmodname[syntax-color/racket-lexer]
contains a lexer for the @racketmodname[racket] language.
In addition, files in the @filepath{examples} sub-directory
of the @filepath{br-parser-tools} collection contain
simpler example lexers.}
An @racket[re] is matched as follows:
@itemize[
@item{@racket[id] --- expands to the named @deftech{lexer abbreviation};
abbreviations are defined via @racket[define-lex-abbrev] or supplied by modules
like @racketmodname[br-parser-tools/lex-sre].}
@item{@racket[string] --- matches the sequence of characters in @racket[string].}
@item{@racket[character] --- matches a literal @racket[character].}
@item{@racket[(repetition lo hi re)] --- matches @racket[re] repeated between @racket[lo]
and @racket[hi] times, inclusive; @racket[hi] can be @racket[+inf.0] for unbounded repetitions.}
@item{@racket[(union re ...)] --- matches if any of the sub-expressions match}
@item{@racket[(intersection re ...)] --- matches if all of the @racket[re]s match.}
@item{@racket[(complement re)] --- matches anything that @racket[re] does not.}
@item{@racket[(concatenation re ...)] --- matches each @racket[re] in succession.}
@item{@racket[(char-range char char)] --- matches any character between the two (inclusive);
a single character string can be used as a @racket[char].}
@item{@racket[(char-complement re)] --- matches any character not matched by @racket[re].
The sub-expression must be a set of characters @racket[re].}
@item{@racket[(id datum ...)] --- expands the @deftech{lexer macro} named @racket[id]; macros
are defined via @racket[define-lex-trans].}
]
Note that both @racket[(concatenation)] and @racket[""] match the
empty string, @racket[(union)] matches nothing,
@racket[(intersection)] matches any string, and
@racket[(char-complement (union))] matches any single character.
The regular expression language is not designed to be used directly,
but rather as a basis for a user-friendly notation written with
regular expression macros. For example,
@racketmodname[br-parser-tools/lex-sre] supplies operators from Olin
Shivers's SREs, and @racketmodname[br-parser-tools/lex-plt-v200] supplies
(deprecated) operators from the previous version of this library.
Since those libraries provide operators whose names match other Racket
bindings, such as @racket[*] and @racket[+], they normally must be
imported using a prefix:
@racketblock[
(require (prefix-in : br-parser-tools/lex-sre))
]
The suggested prefix is @racket[:], so that @racket[:*] and
@racket[:+] are imported. Of course, a prefix other than @racket[:]
(such as @racket[re-]) will work too.
Since negation is not a common operator on regular expressions, here
are a few examples, using @racket[:] prefixed SRE syntax:
@itemize[
@item{@racketblock0[(complement "1")]
Matches all strings except the string @racket["1"], including
@racket["11"], @racket["111"], @racket["0"], @racket["01"],
@racket[""], and so on.}
@item{@racketblock0[(complement (:* "1"))]
Matches all strings that are not sequences of @racket["1"],
including @racket["0"], @racket["00"], @racket["11110"],
@racket["0111"], @racket["11001010"] and so on.}
@item{@racketblock0[(:& (:: any-string "111" any-string)
(complement (:or (:: any-string "01") (:+ "1"))))]
Matches all strings that have 3 consecutive ones, but not those that
end in @racket["01"] and not those that are ones only. These
include @racket["1110"], @racket["0001000111"] and @racket["0111"]
but not @racket[""], @racket["11"], @racket["11101"], @racket["111"]
and @racket["11111"].}
@item{@racketblock0[(:: "/*" (complement (:: any-string "*/" any-string)) "*/")]
Matches Java/C block comments. @racket["/**/"],
@racket["/******/"], @racket["/*////*/"], @racket["/*asg4*/"] and so
on. It does not match @racket["/**/*/"], @racket["/* */ */"] and so
on. @racket[(:: any-string "*/" any-string)] matches any string
that has a @racket["*/"] in is, so @racket[(complement (:: any-string "*/"
any-string))] matches any string without a @racket["*/"] in it.}
@item{@racketblock0[(:: "/*" (:* (complement "*/")) "*/")]
Matches any string that starts with @racket["/*"] and ends with
@racket["*/"], including @racket["/* */ */ */"].
@racket[(complement "*/")] matches any string except @racket["*/"].
This includes @racket["*"] and @racket["/"] separately. Thus
@racket[(:* (complement "*/"))] matches @racket["*/"] by first
matching @racket["*"] and then matching @racket["/"]. Any other
string is matched directly by @racket[(complement "*/")]. In other
words, @racket[(:* (complement "xx"))] = @racket[any-string]. It is
usually not correct to place a @racket[:*] around a
@racket[complement].}
]
The following binding have special meaning inside of a lexer
action:
@itemize[
@item{@racket[start-pos] --- a @racket[position] struct for the first character matched.}
@item{@racket[end-pos] --- a @racket[position] struct for the character after the last character in the match.}
@item{@racket[lexeme] --- the matched string.}
@item{@racket[input-port] --- the input-port being
processed (this is useful for matching input with multiple
lexers).}
@item{@racket[(return-without-pos x)] and @racket[(return-without-srcloc x)] are functions (continuations) that
immediately return the value of @racket[x] from the lexer. This useful
in a src-pos or src-loc lexer to prevent the lexer from adding source
information. For example:
@racketblock[
(define get-token
(lexer-srcloc
...
((comment) (get-token input-port))
...))
]
would wrap the source location information for the comment around
the value of the recursive call. Using
@racket[((comment) (return-without-srcloc (get-token input-port)))]
will cause the value of the recursive call to be returned without
wrapping position around it.}
]
The lexer raises an @racket[exn:fail:read] exception if none of the
regular expressions match the input. Hint: If @racket[(any-char
_custom-error-behavior)] is the last rule, then there will always
be a match, and @racket[_custom-error-behavior] is executed to
handle the error situation as desired, only consuming the first
character from the input buffer.
In addition to returning characters, input
ports can return @racket[eof-object]s. Custom input ports can
also return a @racket[special-comment] value to indicate a
non-textual comment, or return another arbitrary value (a
special). The non-@racket[re] @racket[trigger] forms handle these
cases:
@itemize[
@item{The @racket[(eof)] rule is matched when the input port
returns an @racket[eof-object] value. If no @racket[(eof)]
rule is present, the lexer returns the symbol @racket['eof]
when the port returns an @racket[eof-object] value.}
@item{The @racket[(special-comment)] rule is matched when the
input port returns a @racket[special-comment] structure. If no
@racket[special-comment] rule is present, the lexer
automatically tries to return the next token from the input
port.}
@item{The @racket[(special)] rule is matched when the input
port returns a value other than a character,
@racket[eof-object], or @racket[special-comment] structure. If
no @racket[(special)] rule is present, the lexer returns
@racket[(void)].}]
End-of-files, specials, special-comments and special-errors cannot
be parsed via a rule using an ordinary regular expression
(but dropping down and manipulating the port to handle them
is possible in some situations).
Since the lexer gets its source information from the port, use
@racket[port-count-lines!] to enable the tracking of line and
column information. Otherwise, the line and column information
will return @racket[#f].
When peeking from the input port raises an exception (such as by
an embedded XML editor with malformed syntax), the exception can
be raised before all tokens preceding the exception have been
returned.
Each time the racket code for a lexer is compiled (e.g. when a
@filepath{.rkt} file containing a @racket[lexer] form is loaded),
the lexer generator is run. To avoid this overhead place the
lexer into a module and compile the module to a @filepath{.zo}
bytecode file.}
@defform[(lexer-src-pos (trigger action-expr) ...)]{
Like @racket[lexer], but for each @racket[_action-result] produced by
an @racket[action-expr], returns @racket[(make-position-token
_action-result start-pos end-pos)] instead of simply
@racket[_action-result].}
@defform[(lexer-srcloc (trigger action-expr) ...)]{
Like @racket[lexer], but for each @racket[_action-result] produced by
an @racket[action-expr], returns @racket[(make-srcloc-token
_action-result lexeme-srcloc)] instead of simply
@racket[_action-result].}
@deftogether[(
@defidform[start-pos]
@defidform[end-pos]
@defidform[lexeme]
@defidform[lexeme-srcloc]
@defidform[input-port]
@defidform[return-without-pos]
@defidform[return-without-srcloc]
)]{
Use of these names outside of a @racket[lexer] action is a syntax
error.}
@defstruct[position ([offset exact-positive-integer?]
[line exact-positive-integer?]
[col exact-nonnegative-integer?])]{
Instances of @racket[position] are bound to @racket[start-pos] and
@racket[end-pos]. The @racket[offset] field contains the offset of
the character in the input. The @racket[line] field contains the
line number of the character. The @racket[col] field contains the
offset in the current line.}
@defstruct[position-token ([token any/c]
[start-pos position?]
[end-pos position?])]{
Lexers created with @racket[lexer-src-pos] return instances of @racket[position-token].}
@defstruct[srcloc-token ([token any/c]
[srcloc srcloc?])]{
Lexers created with @racket[lexer-srcloc] return instances of @racket[srcloc-token].}
@defparam[file-path source any/c]{
A parameter that the lexer uses as the source location if it
raises a @racket[exn:fail:read] error. Setting this parameter allows
DrRacket, for example, to open the file containing the error.}
@defparam[lexer-file-path source any/c]{
Alias for @racket[file-path].}
@; ----------------------------------------
@subsection{Lexer Abbreviations and Macros}
@defform[(char-set string)]{
A @tech{lexer macro} that matches any character in @racket[string].}
@defidform[any-char]{A @tech{lexer abbreviation} that matches any character.}
@defidform[any-string]{A @tech{lexer abbreviation} that matches any string.}
@defidform[nothing]{A @tech{lexer abbreviation} that matches no string.}
@deftogether[(
@defidform[alphabetic]
@defidform[lower-case]
@defidform[upper-case]
@defidform[title-case]
@defidform[numeric]
@defidform[symbolic]
@defidform[punctuation]
@defidform[graphic]
@defidform[whitespace]
@defidform[blank]
@defidform[iso-control]
)]{
@tech{Lexer abbreviations} that match @racket[char-alphabetic?]
characters, @racket[char-lower-case?] characters, etc.}
@defform[(define-lex-abbrev id re)]{
Defines a @tech{lexer abbreviation} by associating a regular
expression to be used in place of the @racket[id] in other
regular expression. The definition of name has the same scoping
properties as a other syntactic binding (e.g., it can be exported
from a module).}
@defform[(define-lex-abbrevs (id re) ...)]{
Like @racket[define-lex-abbrev], but defines several @tech{lexer
abbreviations}.}
@defform[(define-lex-trans id trans-expr)]{
Defines a @tech{lexer macro}, where @racket[trans-expr] produces a
transformer procedure that takes one argument. When @racket[(id
_datum ...)] appears as a regular expression, it is replaced with
the result of applying the transformer to the expression.}
@; ----------------------------------------
@subsection{Lexer SRE Operators}
@defmodule[br-parser-tools/lex-sre]
@; Put the docs in a macro, so that we can bound the scope of
@; the import of `*', etc.:
@(define-syntax-rule (lex-sre-doc)
(...
(begin
(require (for-label br-parser-tools/lex-sre))
@defform[(* re ...)]{
Repetition of @racket[re] sequence 0 or more times.}
@defform[(+ re ...)]{
Repetition of @racket[re] sequence 1 or more times.}
@defform[(? re ...)]{
Zero or one occurrence of @racket[re] sequence.}
@defform[(= n re ...)]{
Exactly @racket[n] occurrences of @racket[re] sequence, where
@racket[n] must be a literal exact, non-negative number.}
@defform[(>= n re ...)]{
At least @racket[n] occurrences of @racket[re] sequence, where
@racket[n] must be a literal exact, non-negative number.}
@defform[(** n m re ...)]{
Between @racket[n] and @racket[m] (inclusive) occurrences of
@racket[re] sequence, where @racket[n] must be a literal exact,
non-negative number, and @racket[m] must be literally either
@racket[#f], @racket[+inf.0], or an exact, non-negative number; a
@racket[#f] value for @racket[m] is the same as @racket[+inf.0].}
@defform[(or re ...)]{
Same as @racket[(union re ...)].}
@deftogether[(
@defform[(: re ...)]
@defform[(seq re ...)]
)]{
Both forms concatenate the @racket[re]s.}
@defform[(& re ...)]{
Intersects the @racket[re]s.}
@defform[(- re ...)]{
The set difference of the @racket[re]s.}
@defform[(~ re ...)]{
Character-set complement, which each @racket[re] must match exactly
one character.}
@defform[(/ char-or-string ...)]{
Character ranges, matching characters between successive pairs of
characters.}
)))
@(lex-sre-doc)
@; ----------------------------------------
@subsection{Lexer Legacy Operators}
@defmodule[br-parser-tools/lex-plt-v200]
@(define-syntax-rule (lex-v200-doc)
(...
(begin
(require (for-label br-parser-tools/lex-plt-v200))
@t{The @racketmodname[br-parser-tools/lex-plt-v200] module re-exports
@racket[*], @racket[+], @racket[?], and @racket[&] from
@racketmodname[br-parser-tools/lex-sre]. It also re-exports
@racket[:or] as @racket[:], @racket[::] as @racket[|@|], @racket[:~]
as @racket[^], and @racket[:/] as @racket[-].}
@defform[(epsilon)]{
A @tech{lexer macro} that matches an empty sequence.}
@defform[(~ re ...)]{
The same as @racket[(complement re ...)].})))
@(lex-v200-doc)
@; ----------------------------------------
@subsection{Tokens}
Each @racket[_action-expr] in a @racket[lexer] form can produce any
kind of value, but for many purposes, producing a @deftech{token}
value is useful. Tokens are usually necessary for inter-operating with
a parser generated by @racket[br-parser-tools/parser], but tokens may not
be the right choice when using @racket[lexer] in other situations.
@defform[(define-tokens group-id (token-id ...))]{
Binds @racket[group-id] to the group of tokens being defined. For
each @racket[token-id], a function
@racketidfont{token-}@racket[token-id] is created that takes any
value and puts it in a token record specific to @racket[token-id].
The token value is inspected using @racket[token-id] and
@racket[token-value].
A token cannot be named @racketidfont{error}, since
@racketidfont{error} it has special use in the parser.}
@defform[(define-empty-tokens group-id (token-id ...) )]{
Like @racket[define-tokens], except a each token constructor
@racketidfont{token-}@racket[token-id] takes no arguments and returns
@racket[(@#,racket[quote] token-id)].}
@defproc[(token-name [t (or/c token? symbol?)]) symbol?]{
Returns the name of a token that is represented either by a symbol
or a token structure.}
@defproc[(token-value [t (or/c token? symbol?)]) any/c]{
Returns the value of a token that is represented either by a symbol
or a token structure, returning @racket[#f] for a symbol token.}
@defproc[(token? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[val] is a
token structure, @racket[#f] otherwise.}
@; ----------------------------------------------------------------------
@section{LALR(1) Parsers}
@section-index["yacc"]
@defmodule[br-parser-tools/yacc]
@defform/subs[#:literals (grammar tokens start end precs src-pos
suppress debug yacc-output prec)
(parser clause ...)
([clause (grammar (non-terminal-id
((grammar-id ...) maybe-prec expr)
...)
...)
(tokens group-id ...)
(start non-terminal-id ...)
(end token-id ...)
(@#,racketidfont{error} expr)
(precs (assoc token-id ...) ...)
(src-pos)
(suppress)
(debug filename)
(yacc-output filename)]
[maybe-prec code:blank
(prec token-id)]
[assoc left right nonassoc])]{
Creates a parser. The clauses may be in any order, as long as there
are no duplicates and all non-@italic{OPTIONAL} declarations are
present:
@itemize[
@item{@racketblock0[(grammar (non-terminal-id
((grammar-id ...) maybe-prec expr)
...)
...)]
Declares the grammar to be parsed. Each @racket[grammar-id] can
be a @racket[token-id] from a @racket[group-id] named in a
@racket[tokens] declaration, or it can be a
@racket[non-terminal-id] declared in the @racket[grammar]
declaration. The optional @racket[prec] declaration works with
the @racket[precs] declaration. The @racket[expr] is a
``semantic action,'' which is evaluated when the input is found
to match its corresponding production.
Each action is Racket code that has the same scope as its
parser's definition, except that the variables @racket[$1], ...,
@racketidfont{$}@math{i} are bound, where @math{i} is the number
of @racket[grammar-id]s in the corresponding production. Each
@racketidfont{$}@math{k} is bound to the result of the action
for the @math{k}@superscript{th} grammar symbol on the right of
the production, if that grammar symbol is a non-terminal, or the
value stored in the token if the grammar symbol is a terminal.
If the @racket[src-pos] option is present in the parser, then
variables @racket[$1-start-pos], ...,
@racketidfont{$}@math{i}@racketidfont{-start-pos} and
@racket[$1-end-pos], ...,
@racketidfont{$}@math{i}@racketidfont{-end-pos} and are also
available, and they refer to the position structures
corresponding to the start and end of the corresponding
@racket[grammar-symbol]. Grammar symbols defined as empty-tokens
have no @racketidfont{$}@math{k} associated, but do have
@racketidfont{$}@math{k}@racketidfont{-start-pos} and
@racketidfont{$}@math{k}@racketidfont{-end-pos}.
Also @racketidfont{$n-start-pos} and @racketidfont{$n-end-pos}
are bound to the largest start and end positions, (i.e.,
@racketidfont{$}@math{i}@racketidfont{-start-pos} and
@racketidfont{$}@math{i}@racketidfont{-end-pos}).
An @deftech{error production} can be defined by providing
a production of the form @racket[(error α)], where α is a
string of grammar symbols, possibly empty.
All of the productions for a given non-terminal must be grouped
with it. That is, no @racket[non-terminal-id] may appear twice
on the left hand side in a parser.}
@item{@racket[(tokens group-id ...)]
Declares that all of the tokens defined in each
@racket[group-id]---as bound by @racket[define-tokens] or
@racket[define-empty-tokens]---can be used by the parser in the
@racket[grammar] declaration.}
@item{@racket[(start non-terminal-id ...)]
Declares a list of starting non-terminals for the grammar.}
@item{@racket[(end token-id ...)]
Specifies a set of tokens from which some member must follow any
valid parse. For example, an EOF token would be specified for a
parser that parses entire files and a newline token for a parser
that parses entire lines individually.}
@item{@racket[(@#,racketidfont{error} expr)]
The @racket[expr] should evaluate to a function which will be
executed for its side-effect whenever the parser encounters an
error.
If the @racket[src-pos] declaration is present, the function
should accept 5 arguments,:
@racketblock[(lambda (tok-ok? tok-name tok-value _start-pos _end-pos)
....)]
Otherwise it should accept 3:
@racketblock[(lambda (tok-ok? tok-name tok-value)
....)]
The first argument will be @racket[#f] if and only if the error
is that an invalid token was received. The second and third
arguments will be the name and the value of the token at which
the error was detected. The fourth and fifth arguments, if
present, provide the source positions of that token.}
@item{@racket[(precs (assoc token-id ...) ...)]
@italic{OPTIONAL}
Precedence declarations to resolve shift/reduce and
reduce/reduce conflicts as in @exec{yacc}/@exec{bison}. An
@racket[assoc] must be one of @racket[left], @racket[right] or
@racket[nonassoc]. States with multiple shift/reduce or
reduce/reduce conflicts (or some combination thereof) are not
resolved with precedence.}
@item{@racket[(src-pos)] @italic{OPTIONAL}
Causes the generated parser to expect input in the form
@racket[(make-position-token _token _start-pos _end-pos)] instead
of simply @racket[_token]. Include this option when using the
parser with a lexer generated with @racket[lexer-src-pos].}
@item{@racket[(debug filename)] @italic{OPTIONAL}
Causes the parser generator to write the LALR table to the file
named @racket[filename] (unless the file exists), where
@racket[filename] is a literal string. Additionally, if a debug
file is specified, when a running generated parser encounters a
parse error on some input file, after the user specified error
expression returns, the complete parse stack is printed to
assist in debugging the grammar of that particular parser. The
numbers in the stack printout correspond to the state numbers in
the LALR table file.}
@item{@racket[(yacc-output filename)] @italic{OPTIONAL}
Causes the parser generator to write a grammar file in
approximately the syntax of @exec{yacc}/@exec{bison}. The file
might not be a valid @exec{yacc} file, because the Racket
grammar can use symbols that are invalid in C.}
@item{@racket[(suppress)] @italic{OPTIONAL}
Causes the parser generator not to report shift/reduce or
reduce/reduce conflicts.}
]
The result of a @racket[parser] expression with one @racket[start]
non-terminal is a function, @racket[_parse], that takes one
argument. This argument must be a zero argument function,
@racket[_gen], that produces successive tokens of the input each
time it is called. If desired, the @racket[_gen] may return
symbols instead of tokens, and the parser will treat symbols as
tokens of the corresponding name (with @racket[#f] as a value, so
it is usual to return symbols only in the case of empty tokens).
The @racket[_parse] function returns the value associated with the
parse tree by the semantic actions. If the parser encounters an
error, after invoking the supplied error function, it will try to
use @tech{error production}s to continue parsing. If it cannot, it
raises @racket[exn:fail:read].
If multiple non-terminals are provided in @racket[start], the
@racket[parser] expression produces a list of parsing functions,
one for each non-terminal in the same order. Each parsing function
is like the result of a parser expression with only one
@racket[start] non-terminal,
Each time the Racket code for a @racket[parser] is compiled
(e.g. when a @filepath{.rkt} file containing a @racket[parser] form
is loaded), the parser generator is run. To avoid this overhead
place the parser into a module and compile the module to a
@filepath{.zo} bytecode file.}
@section{Context-Free Parsers}
@section-index["cfg-parser"]
@defmodule[br-parser-tools/cfg-parser]{The @racketmodname[br-parser-tools/cfg-parser]
library provides a parser generator that is an alternative to that of
@racketmodname[br-parser-tools/yacc].}
@defform/subs[#:literals (grammar tokens start end precs src-pos
suppress debug yacc-output prec)
(cfg-parser clause ...)
([clause (grammar (non-terminal-id
((grammar-id ...) maybe-prec expr)
...)
...)
(tokens group-id ...)
(start non-terminal-id ...)
(end token-id ...)
(@#,racketidfont{error} expr)
(src-pos)])]{
Creates a parser similar to that of @racket[parser]. Unlike @racket[parser],
@racket[cfg-parser], can consume arbitrary and potentially ambiguous context-free
grammars. Its interface is a subset of @racketmodname[br-parser-tools/yacc], with
the following differences:
@itemize[
@item{@racket[(start non-terminal-id)]
Unlike @racket[parser], @racket[cfg-parser] only allows for
a single non-terminal-id.}
@item{The @racket[cfg-parser] form does not support the @racket[precs],
@racket[suppress], @racket[debug], or @racket[yacc-output]
options of @racket[parser].}
]
}
@; ----------------------------------------------------------------------
@section{Converting @exec{yacc} or @exec{bison} Grammars}
@defmodule[br-parser-tools/yacc-to-scheme]
@defproc[(trans [file path-string?]) any/c]{
Reads a C @exec{yacc}/@exec{bison} grammar from @racket[file] and
produces an s-expression that represents a Racket parser for use with
@racket[parser].
This function is intended to assist in the manual conversion of
grammars for use with @racket[parser], and not as a fully automatic
conversion tool. It is not entirely robust. For example, if the C
actions in the original grammar have nested blocks, the tool will fail.
Annotated examples are in the @filepath{examples} subdirectory of the
@filepath{br-parser-tools} collection.}
@; ----------------------------------------------------------------------
@index-section[]

1
br-parser-tools/br-parser-tools-doc/br-parser-tools/compiled/br-parser-tools_scrbl.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("e40ef6f4ad8e94b16dd696e0e56aff8797e08366" . "20628650cd070c4f9b3a47399bfc46ffabd56006") (collects #"br-parser-tools" #"cfg-parser.rkt") (collects #"br-parser-tools" #"lex-plt-v200.rkt") (collects #"br-parser-tools" #"lex-sre.rkt") (collects #"br-parser-tools" #"lex.rkt") (collects #"br-parser-tools" #"yacc.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"scheme" #"base.rkt") (collects #"scheme" #"contract.rkt") (collects #"scribble" #"bnf.rkt") (collects #"scribble" #"doc" #"lang" #"reader.rkt") (collects #"scribble" #"doclang.rkt") (collects #"scribble" #"manual.rkt") (collects #"scribble" #"struct.rkt") (collects #"scribble" #"xref.rkt"))

BIN
br-parser-tools/br-parser-tools-doc/br-parser-tools/compiled/br-parser-tools_scrbl.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-doc/br-parser-tools/compiled/info_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("4594481ac3bf7a1dfb75324c86a180c4a121ab41" . "64293529315a4e5ca67bc9da08b943f520e0d704") (collects #"info" #"main.rkt") (collects #"setup" #"infotab.rkt"))

BIN
br-parser-tools/br-parser-tools-doc/br-parser-tools/compiled/info_rkt.zo
View File

Binary file not shown.

3
br-parser-tools/br-parser-tools-doc/br-parser-tools/info.rkt
Unescape Escape View File

@ -0,0 +1,3 @@
#lang info
(define scribblings '(("br-parser-tools.scrbl" (multi-page) (parsing-library))))

14
br-parser-tools/br-parser-tools-doc/info.rkt
Unescape Escape View File

@ -0,0 +1,14 @@
#lang info
(define collection 'multi)
(define deps '("base"))
(define build-deps '("scheme-lib"
"racket-doc"
"syntax-color-doc"
"br-parser-tools-lib"
"scribble-lib"))
(define update-implies '("br-parser-tools-lib"))
(define pkg-desc "documentation part of \"br-parser-tools\"")
(define pkg-authors '(mflatt))

11
br-parser-tools/br-parser-tools-lib/LICENSE.txt
Unescape Escape View File

@ -0,0 +1,11 @@
parser-tools-lib
Copyright (c) 2010-2014 PLT Design Inc.
This package is distributed under the GNU Lesser General Public
License (LGPL). This means that you can link this package into proprietary
applications, provided you follow the rules stated in the LGPL. You
can also modify this package; if you distribute a modified version,
you must distribute it under the terms of the LGPL, which in
particular means that you must release the source code for the
modified software. See http://www.gnu.org/copyleft/lesser.html
for more information.

982
br-parser-tools/br-parser-tools-lib/br-parser-tools/cfg-parser.rkt
Unescape Escape View File

@ -0,0 +1,982 @@
#lang racket/base
;; This module implements a parser form like the br-parser-tools's
;; `parser', except that it works on an arbitrary CFG (returning
;; the first sucecssful parse).
;; I'm pretty sure that this is an implementation of Earley's
;; algorithm.
;; To a first approximation, it's a backtracking parser. Alternative
;; for a non-terminal are computed in parallel, and multiple attempts
;; to compute the same result block until the first one completes. If
;; you get into deadlock, such as when trying to match
;; <foo> := <foo>
;; then it means that there's no successful parse, so everything
;; that's blocked fails.
;; A cache holds the series of results for a particular non-terminal
;; at a particular starting location. (A series is used, instead of a
;; sinlge result, for backtracking.) Otherwise, the parser uses
;; backtracking search. Backtracking is implemented through explicit
;; success and failure continuations. Multiple results for a
;; particular nonterminal and location are kept only when they have
;; different lengths. (Otherwise, in the spirit of finding one
;; successful parse, only the first result is kept.)
;; The br-parser-tools's `parse' is used to transform tokens in the
;; grammar to tokens specific to this parser. In other words, this
;; parser uses `parser' so that it doesn't have to know anything about
;; tokens.
;;
(require br-parser-tools/yacc
br-parser-tools/lex)
(require (for-syntax racket/base
syntax/boundmap
br-parser-tools/private-lex/token-syntax))
(provide cfg-parser)
;; A raw token, wrapped so that we can recognize it:
(define-struct tok (name orig-name val start end))
;; Represents the thread scheduler:
(define-struct tasks (active active-back waits multi-waits cache progress?))
(define-for-syntax make-token-identifier-mapping make-hasheq)
(define-for-syntax token-identifier-mapping-get
(case-lambda
[(t tok)
(hash-ref t (syntax-e tok))]
[(t tok fail)
(hash-ref t (syntax-e tok) fail)]))
(define-for-syntax token-identifier-mapping-put!
(lambda (t tok v)
(hash-set! t (syntax-e tok) v)))
(define-for-syntax token-identifier-mapping-map
(lambda (t f)
(hash-map t f)))
;; Used to calculate information on the grammar, such as whether
;; a particular non-terminal is "simple" instead of recursively defined.
(define-for-syntax (nt-fixpoint nts proc nt-ids patss)
(define (ormap-all val f as bs)
(cond
[(null? as) val]
[else (ormap-all (or (f (car as) (car bs)) val)
f
(cdr as) (cdr bs))]))
(let loop ()
(when (ormap-all #f
(lambda (nt pats)
(let ([old (bound-identifier-mapping-get nts nt)])
(let ([new (proc nt pats old)])
(if (equal? old new)
#f
(begin
(bound-identifier-mapping-put! nts nt new)
#t)))))
nt-ids patss)
(loop))))
;; Tries parse-a followed by parse-b. If parse-a is not simple,
;; then after parse-a succeeds once, we parallelize parse-b
;; and trying a second result for parse-a.
(define (parse-and simple-a? parse-a parse-b
stream last-consumed-token depth end success-k fail-k
max-depth tasks)
(letrec ([mk-got-k
(lambda (success-k fail-k)
(lambda (val stream last-consumed-token depth max-depth tasks next1-k)
(if simple-a?
(parse-b val stream last-consumed-token depth end
(mk-got2-k success-k fail-k next1-k)
(mk-fail2-k success-k fail-k next1-k)
max-depth tasks)
(parallel-or
(lambda (success-k fail-k max-depth tasks)
(parse-b val stream last-consumed-token depth end
success-k fail-k
max-depth tasks))
(lambda (success-k fail-k max-depth tasks)
(next1-k (mk-got-k success-k fail-k)
fail-k max-depth tasks))
success-k fail-k max-depth tasks))))]
[mk-got2-k
(lambda (success-k fail-k next1-k)
(lambda (val stream last-consumed-token depth max-depth tasks next-k)
(success-k val stream last-consumed-token depth max-depth tasks
(lambda (success-k fail-k max-depth tasks)
(next-k (mk-got2-k success-k fail-k next1-k)
(mk-fail2-k success-k fail-k next1-k)
max-depth tasks)))))]
[mk-fail2-k
(lambda (success-k fail-k next1-k)
(lambda (max-depth tasks)
(next1-k (mk-got-k success-k fail-k)
fail-k
max-depth
tasks)))])
(parse-a stream last-consumed-token depth end
(mk-got-k success-k fail-k)
fail-k
max-depth tasks)))
;; Parallel or for non-terminal alternatives
(define (parse-parallel-or parse-a parse-b stream last-consumed-token depth end success-k fail-k max-depth tasks)
(parallel-or (lambda (success-k fail-k max-depth tasks)
(parse-a stream last-consumed-token depth end success-k fail-k max-depth tasks))
(lambda (success-k fail-k max-depth tasks)
(parse-b stream last-consumed-token depth end success-k fail-k max-depth tasks))
success-k fail-k max-depth tasks))
;; Generic parallel-or
(define (parallel-or parse-a parse-b success-k fail-k max-depth tasks)
(define answer-key (gensym))
(letrec ([gota-k
(lambda (val stream last-consumed-token depth max-depth tasks next-k)
(report-answer answer-key
max-depth
tasks
(list val stream last-consumed-token depth next-k)))]
[faila-k
(lambda (max-depth tasks)
(report-answer answer-key
max-depth
tasks
null))])
(let* ([tasks (queue-task
tasks
(lambda (max-depth tasks)
(parse-a gota-k
faila-k
max-depth tasks)))]
[tasks (queue-task
tasks
(lambda (max-depth tasks)
(parse-b gota-k
faila-k
max-depth tasks)))]
[queue-next (lambda (next-k tasks)
(queue-task tasks
(lambda (max-depth tasks)
(next-k gota-k
faila-k
max-depth tasks))))])
(letrec ([mk-got-one
(lambda (immediate-next? get-nth success-k)
(lambda (val stream last-consumed-token depth max-depth tasks next-k)
(let ([tasks (if immediate-next?
(queue-next next-k tasks)
tasks)])
(success-k val stream last-consumed-token depth max-depth
tasks
(lambda (success-k fail-k max-depth tasks)
(let ([tasks (if immediate-next?
tasks
(queue-next next-k tasks))])
(get-nth max-depth tasks success-k fail-k)))))))]
[get-first
(lambda (max-depth tasks success-k fail-k)
(wait-for-answer #f max-depth tasks answer-key
(mk-got-one #t get-first success-k)
(lambda (max-depth tasks)
(get-second max-depth tasks success-k fail-k))
#f))]
[get-second
(lambda (max-depth tasks success-k fail-k)
(wait-for-answer #f max-depth tasks answer-key
(mk-got-one #f get-second success-k)
fail-k #f))])
(get-first max-depth tasks success-k fail-k)))))
;; Non-terminal alternatives where the first is "simple" can be done
;; sequentially, which is simpler
(define (parse-or parse-a parse-b
stream last-consumed-token depth end success-k fail-k max-depth tasks)
(letrec ([mk-got-k
(lambda (success-k fail-k)
(lambda (val stream last-consumed-token depth max-depth tasks next-k)
(success-k val stream last-consumed-token depth
max-depth tasks
(lambda (success-k fail-k max-depth tasks)
(next-k (mk-got-k success-k fail-k)
(mk-fail-k success-k fail-k)
max-depth tasks)))))]
[mk-fail-k
(lambda (success-k fail-k)
(lambda (max-depth tasks)
(parse-b stream last-consumed-token depth end success-k fail-k max-depth tasks)))])
(parse-a stream last-consumed-token depth end
(mk-got-k success-k fail-k)
(mk-fail-k success-k fail-k)
max-depth tasks)))
;; Starts a thread
(define queue-task
(lambda (tasks t [progress? #t])
(make-tasks (tasks-active tasks)
(cons t (tasks-active-back tasks))
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
(or progress? (tasks-progress? tasks)))))
;; Reports an answer to a waiting thread:
(define (report-answer answer-key max-depth tasks val)
(let ([v (hash-ref (tasks-waits tasks) answer-key (lambda () #f))])
(if v
(let ([tasks (make-tasks (cons (v val)
(tasks-active tasks))
(tasks-active-back tasks)
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
#t)])
(hash-remove! (tasks-waits tasks) answer-key)
(swap-task max-depth tasks))
;; We have an answer ready too fast; wait
(swap-task max-depth
(queue-task tasks
(lambda (max-depth tasks)
(report-answer answer-key max-depth tasks val))
#f)))))
;; Reports an answer to multiple waiting threads:
(define (report-answer-all answer-key max-depth tasks val k)
(let ([v (hash-ref (tasks-multi-waits tasks) answer-key (lambda () null))])
(hash-remove! (tasks-multi-waits tasks) answer-key)
(let ([tasks (make-tasks (append (map (lambda (a) (a val)) v)
(tasks-active tasks))
(tasks-active-back tasks)
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
#t)])
(k max-depth tasks))))
;; Waits for an answer; if `multi?' is #f, this is sole waiter, otherwise
;; there might be many. Use wither #t or #f (and `report-answer' or
;; `report-answer-all', resptively) consistently for a particular answer key.
(define (wait-for-answer multi? max-depth tasks answer-key success-k fail-k deadlock-k)
(let ([wait (lambda (val)
(lambda (max-depth tasks)
(if val
(if (null? val)
(fail-k max-depth tasks)
(let-values ([(val stream last-consumed-token depth next-k) (apply values val)])
(success-k val stream last-consumed-token depth max-depth tasks next-k)))
(deadlock-k max-depth tasks))))])
(if multi?
(hash-set! (tasks-multi-waits tasks) answer-key
(cons wait (hash-ref (tasks-multi-waits tasks) answer-key
(lambda () null))))
(hash-set! (tasks-waits tasks) answer-key wait))
(let ([tasks (make-tasks (tasks-active tasks)
(tasks-active-back tasks)
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
#t)])
(swap-task max-depth tasks))))
;; Swap thread
(define (swap-task max-depth tasks)
;; Swap in first active:
(if (null? (tasks-active tasks))
(if (tasks-progress? tasks)
(swap-task max-depth
(make-tasks (reverse (tasks-active-back tasks))
null
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
#f))
;; No progress, so issue failure for all multi-waits
(if (zero? (hash-count (tasks-multi-waits tasks)))
(error 'swap-task "Deadlock")
(swap-task max-depth
(make-tasks (apply
append
(hash-map (tasks-multi-waits tasks)
(lambda (k l)
(map (lambda (v) (v #f)) l))))
(tasks-active-back tasks)
(tasks-waits tasks)
(make-hasheq)
(tasks-cache tasks)
#t))))
(let ([t (car (tasks-active tasks))]
[tasks (make-tasks (cdr (tasks-active tasks))
(tasks-active-back tasks)
(tasks-waits tasks)
(tasks-multi-waits tasks)
(tasks-cache tasks)
(tasks-progress? tasks))])
(t max-depth tasks))))
;; Finds the symbolic representative of a token class
(define-for-syntax (map-token toks tok)
(car (token-identifier-mapping-get toks tok)))
(define no-pos-val (make-position #f #f #f))
(define-for-syntax no-pos
(let ([npv ((syntax-local-certifier) #'no-pos-val)])
(lambda (stx) npv)))
(define-for-syntax at-tok-pos
(lambda (sel expr)
(lambda (stx)
#`(let ([v #,expr]) (if v (#,sel v) no-pos-val)))))
;; Builds a matcher for a particular alternative
(define-for-syntax (build-match nts toks pat handle $ctx)
(let loop ([pat pat]
[pos 1])
(if (null? pat)
#`(success-k #,handle stream last-consumed-token depth max-depth tasks
(lambda (success-k fail-k max-depth tasks)
(fail-k max-depth tasks)))
(let ([id (datum->syntax (car pat)
(string->symbol (format "$~a" pos)))]
[id-start-pos (datum->syntax (car pat)
(string->symbol (format "$~a-start-pos" pos)))]
[id-end-pos (datum->syntax (car pat)
(string->symbol (format "$~a-end-pos" pos)))]
[n-end-pos (and (null? (cdr pat))
(datum->syntax (car pat) '$n-end-pos))])
(cond
[(bound-identifier-mapping-get nts (car pat) (lambda () #f))
;; Match non-termimal
#`(parse-and
;; First part is simple? (If so, we don't have to parallelize the `and'.)
#,(let ([l (bound-identifier-mapping-get nts (car pat) (lambda () #f))])
(or (not l)
(andmap values (caddr l))))
#,(car pat)
(let ([original-stream stream])
(lambda (#,id stream last-consumed-token depth end success-k fail-k max-depth tasks)
(let-syntax ([#,id-start-pos (at-tok-pos #'(if (eq? original-stream stream)
tok-end
tok-start)
#'(if (eq? original-stream stream)
last-consumed-token
(and (pair? original-stream)
(car original-stream))))]
[#,id-end-pos (at-tok-pos #'tok-end #'last-consumed-token)]
#,@(if n-end-pos
#`([#,n-end-pos (at-tok-pos #'tok-end #'last-consumed-token)])
null))
#,(loop (cdr pat) (add1 pos)))))
stream last-consumed-token depth
#,(let ([cnt (apply +
(map (lambda (item)
(cond
[(bound-identifier-mapping-get nts item (lambda () #f))
=> (lambda (l) (car l))]
[else 1]))
(cdr pat)))])
#`(- end #,cnt))
success-k fail-k max-depth tasks)]
[else
;; Match token
(let ([tok-id (map-token toks (car pat))])
#`(if (and (pair? stream)
(eq? '#,tok-id (tok-name (car stream))))
(let* ([stream-a (car stream)]
[#,id (tok-val stream-a)]
[last-consumed-token (car stream)]
[stream (cdr stream)]
[depth (add1 depth)])
(let ([max-depth (max max-depth depth)])
(let-syntax ([#,id-start-pos (at-tok-pos #'tok-start #'stream-a)]
[#,id-end-pos (at-tok-pos #'tok-end #'stream-a)]
#,@(if n-end-pos
#`([#,n-end-pos (at-tok-pos #'tok-end #'stream-a)])
null))
#,(loop (cdr pat) (add1 pos)))))
(fail-k max-depth tasks)))])))))
;; Starts parsing to match a non-terminal. There's a minor
;; optimization that checks for known starting tokens. Otherwise,
;; use the cache, block if someone else is already trying the match,
;; and cache the result if it's computed.
;; The cache maps nontermial+startingpos+iteration to a result, where
;; the iteration is 0 for the first match attempt, 1 for the second,
;; etc.
(define (parse-nt/share key min-cnt init-tokens stream last-consumed-token depth end max-depth tasks success-k fail-k k)
(if (and (positive? min-cnt)
(pair? stream)
(not (memq (tok-name (car stream)) init-tokens)))
;; No such leading token; give up
(fail-k max-depth tasks)
;; Run pattern
(let loop ([n 0]
[success-k success-k]
[fail-k fail-k]
[max-depth max-depth]
[tasks tasks]
[k k])
(let ([answer-key (gensym)]
[table-key (vector key depth n)]
[old-depth depth]
[old-stream stream])
#;(printf "Loop ~a\n" table-key)
(cond
[(hash-ref (tasks-cache tasks) table-key (lambda () #f))
=> (lambda (result)
#;(printf "Reuse ~a\n" table-key)
(result success-k fail-k max-depth tasks))]
[else
#;(printf "Try ~a ~a\n" table-key (map tok-name stream))
(hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks)
#;(printf "Wait ~a ~a\n" table-key answer-key)
(wait-for-answer #t max-depth tasks answer-key success-k fail-k
(lambda (max-depth tasks)
#;(printf "Deadlock ~a ~a\n" table-key answer-key)
(fail-k max-depth tasks)))))
(let result-loop ([max-depth max-depth][tasks tasks][k k])
(letrec ([orig-stream stream]
[new-got-k
(lambda (val stream last-consumed-token depth max-depth tasks next-k)
;; Check whether we already have a result that consumed the same amount:
(let ([result-key (vector #f key old-depth depth)])
(cond
[(hash-ref (tasks-cache tasks) result-key (lambda () #f))
;; Go for the next-result
(result-loop max-depth
tasks
(lambda (end max-depth tasks success-k fail-k)
(next-k success-k fail-k max-depth tasks)))]
[else
#;(printf "Success ~a ~a\n" table-key
(map tok-name (let loop ([d old-depth][s old-stream])
(if (= d depth)
null
(cons (car s) (loop (add1 d) (cdr s)))))))
(let ([next-k (lambda (success-k fail-k max-depth tasks)
(loop (add1 n)
success-k
fail-k
max-depth
tasks
(lambda (end max-depth tasks success-k fail-k)
(next-k success-k fail-k max-depth tasks))))])
(hash-set! (tasks-cache tasks) result-key #t)
(hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks)
(success-k val stream last-consumed-token depth max-depth tasks next-k)))
(report-answer-all answer-key
max-depth
tasks
(list val stream last-consumed-token depth next-k)
(lambda (max-depth tasks)
(success-k val stream last-consumed-token depth max-depth tasks next-k))))])))]
[new-fail-k
(lambda (max-depth tasks)
#;(printf "Failure ~a\n" table-key)
(hash-set! (tasks-cache tasks) table-key
(lambda (success-k fail-k max-depth tasks)
(fail-k max-depth tasks)))
(report-answer-all answer-key
max-depth
tasks
null
(lambda (max-depth tasks)
(fail-k max-depth tasks))))])
(k end max-depth tasks new-got-k new-fail-k)))])))))
(define-syntax (cfg-parser stx)
(syntax-case stx ()
[(_ clause ...)
(let ([clauses (syntax->list #'(clause ...))])
(let-values ([(start grammar cfg-error parser-clauses src-pos?)
(let ([all-toks (apply
append
(map (lambda (clause)
(syntax-case clause (tokens)
[(tokens t ...)
(apply
append
(map (lambda (t)
(let ([v (syntax-local-value t (lambda () #f))])
(cond
[(terminals-def? v)
(map (lambda (v)
(cons v #f))
(syntax->list (terminals-def-t v)))]
[(e-terminals-def? v)
(map (lambda (v)
(cons v #t))
(syntax->list (e-terminals-def-t v)))]
[else null])))
(syntax->list #'(t ...))))]
[_else null]))
clauses))]
[all-end-toks (apply
append
(map (lambda (clause)
(syntax-case clause (end)
[(end t ...)
(syntax->list #'(t ...))]
[_else null]))
clauses))])
(let loop ([clauses clauses]
[cfg-start #f]
[cfg-grammar #f]
[cfg-error #f]
[src-pos? #f]
[parser-clauses null])
(if (null? clauses)
(values cfg-start
cfg-grammar
cfg-error
(reverse parser-clauses)
src-pos?)
(syntax-case (car clauses) (start error grammar src-pos)
[(start tok)
(loop (cdr clauses) #'tok cfg-grammar cfg-error src-pos? parser-clauses)]
[(error expr)
(loop (cdr clauses) cfg-start cfg-grammar #'expr src-pos? parser-clauses)]
[(grammar [nt [pat handle0 handle ...] ...] ...)
(let ([nts (make-bound-identifier-mapping)]
[toks (make-token-identifier-mapping)]
[end-toks (make-token-identifier-mapping)]
[nt-ids (syntax->list #'(nt ...))]
[patss (map (lambda (stx)
(map syntax->list (syntax->list stx)))
(syntax->list #'((pat ...) ...)))])
(for-each (lambda (nt)
(bound-identifier-mapping-put! nts nt (list 0)))
nt-ids)
(for-each (lambda (t)
(token-identifier-mapping-put! end-toks t #t))
all-end-toks)
(for-each (lambda (t)
(unless (token-identifier-mapping-get end-toks (car t) (lambda () #f))
(let ([id (gensym (syntax-e (car t)))])
(token-identifier-mapping-put! toks (car t)
(cons id (cdr t))))))
all-toks)
;; Compute min max size for each non-term:
(nt-fixpoint
nts
(lambda (nt pats old-list)
(let ([new-cnt
(apply
min
(map (lambda (pat)
(apply
+
(map (lambda (elem)
(car
(bound-identifier-mapping-get nts
elem
(lambda () (list 1)))))
pat)))
pats))])
(if (new-cnt . > . (car old-list))
(cons new-cnt (cdr old-list))
old-list)))
nt-ids patss)
;; Compute set of toks that must appear at the beginning
;; for a non-terminal
(nt-fixpoint
nts
(lambda (nt pats old-list)
(let ([new-list
(apply
append
(map (lambda (pat)
(let loop ([pat pat])
(if (pair? pat)
(let ([l (bound-identifier-mapping-get
nts
(car pat)
(lambda ()
(list 1 (map-token toks (car pat)))))])
;; If the non-terminal can match 0 things,
;; then it might match something from the
;; next pattern element. Otherwise, it must
;; match the first element:
(if (zero? (car l))
(append (cdr l) (loop (cdr pat)))
(cdr l)))
null)))
pats))])
(let ([new (filter (lambda (id)
(andmap (lambda (id2)
(not (eq? id id2)))
(cdr old-list)))
new-list)])
(if (pair? new)
;; Drop dups in new list:
(let ([new (let loop ([new new])
(if (null? (cdr new))
new
(if (ormap (lambda (id)
(eq? (car new) id))
(cdr new))
(loop (cdr new))
(cons (car new) (loop (cdr new))))))])
(cons (car old-list) (append new (cdr old-list))))
old-list))))
nt-ids patss)
;; Determine left-recursive clauses:
(for-each (lambda (nt pats)
(let ([l (bound-identifier-mapping-get nts nt)])
(bound-identifier-mapping-put! nts nt (list (car l)
(cdr l)
(map (lambda (x) #f) pats)))))
nt-ids patss)
(nt-fixpoint
nts
(lambda (nt pats old-list)
(list (car old-list)
(cadr old-list)
(map (lambda (pat simple?)
(or simple?
(let ([l (map (lambda (elem)
(bound-identifier-mapping-get
nts
elem
(lambda () #f)))
pat)])
(andmap (lambda (i)
(or (not i)
(andmap values (caddr i))))
l))))
pats (caddr old-list))))
nt-ids patss)
;; Build a definition for each non-term:
(loop (cdr clauses)
cfg-start
(map (lambda (nt pats handles $ctxs)
(define info (bound-identifier-mapping-get nts nt))
(list nt
#`(let ([key (gensym '#,nt)])
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
(parse-nt/share
key #,(car info) '#,(cadr info) stream last-consumed-token depth end
max-depth tasks
success-k fail-k
(lambda (end max-depth tasks success-k fail-k)
#,(let loop ([pats pats]
[handles (syntax->list handles)]
[$ctxs (syntax->list $ctxs)]
[simple?s (caddr info)])
(if (null? pats)
#'(fail-k max-depth tasks)
#`(#,(if (or (null? (cdr pats))
(car simple?s))
#'parse-or
#'parse-parallel-or)
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
#,(build-match nts
toks
(car pats)
(car handles)
(car $ctxs)))
(lambda (stream last-consumed-token depth end success-k fail-k max-depth tasks)
#,(loop (cdr pats)
(cdr handles)
(cdr $ctxs)
(cdr simple?s)))
stream last-consumed-token depth end success-k fail-k max-depth tasks)))))))))
nt-ids
patss
(syntax->list #'(((begin handle0 handle ...) ...) ...))
(syntax->list #'((handle0 ...) ...)))
cfg-error
src-pos?
(list*
(with-syntax ([((tok tok-id . $e) ...)
(token-identifier-mapping-map toks
(lambda (k v)
(list* k
(car v)
(if (cdr v)
#f
'$1))))]
[(pos ...)
(if src-pos?
#'($1-start-pos $1-end-pos)
#'(#f #f))])
#`(grammar (start [() null]
[(atok start) (cons $1 $2)])
(atok [(tok) (make-tok 'tok-id 'tok $e pos ...)] ...)))
#`(start start)
parser-clauses)))]
[(grammar . _)
(raise-syntax-error
#f
"bad grammar clause"
stx
(car clauses))]
[(src-pos)
(loop (cdr clauses)
cfg-start
cfg-grammar
cfg-error
#t
(cons (car clauses) parser-clauses))]
[_else
(loop (cdr clauses)
cfg-start
cfg-grammar
cfg-error
src-pos?
(cons (car clauses) parser-clauses))]))))])
#`(let ([orig-parse (parser
[error (lambda (a b c)
(error 'cfg-parser "unexpected ~a token: ~a" b c))]
. #,parser-clauses)]
[error-proc #,cfg-error])
(letrec #,grammar
(lambda (get-tok)
(let ([tok-list (orig-parse get-tok)])
(letrec ([success-k
(lambda (val stream last-consumed-token depth max-depth tasks next)
(if (null? stream)
val
(next success-k fail-k max-depth tasks)))]
[fail-k (lambda (max-depth tasks)
(define (call-error-proc tok-ok? tok-name tok-value start-pos end-pos)
(cond
[(procedure-arity-includes? error-proc 5)
(error-proc tok-ok? tok-name tok-value start-pos end-pos)]
[else
(error-proc tok-ok? tok-name tok-value)]))
(cond
[(null? tok-list)
(if error-proc
(call-error-proc #t
'no-tokens
#f
(make-position #f #f #f)
(make-position #f #f #f))
(error
'cfg-parse
"no tokens"))]
[else
(let ([bad-tok (list-ref tok-list
(min (sub1 (length tok-list))
max-depth))])
(if error-proc
(call-error-proc #t
(tok-orig-name bad-tok)
(tok-val bad-tok)
(tok-start bad-tok)
(tok-end bad-tok))
(error
'cfg-parse
"failed at ~a"
(tok-val bad-tok))))]))])
(#,start tok-list
;; we simulate a token at the very beginning with zero width
;; for use with the position-generating code (*-start-pos, *-end-pos).
(if (null? tok-list)
(tok #f #f #f
(position 1
#,(if src-pos? #'1 #'#f)
#,(if src-pos? #'0 #'#f))
(position 1
#,(if src-pos? #'1 #'#f)
#,(if src-pos? #'0 #'#f)))
(tok (tok-name (car tok-list))
(tok-orig-name (car tok-list))
(tok-val (car tok-list))
(tok-start (car tok-list))
(tok-start (car tok-list))))
0
(length tok-list)
success-k
fail-k
0
(make-tasks null null
(make-hasheq) (make-hasheq)
(make-hash) #t)))))))))]))
(module* test racket/base
(require (submod "..")
br-parser-tools/lex
racket/block
racket/generator
rackunit)
;; Test: parsing regular expressions.
;; Here is a test case on locations:
(block
(define-tokens regexp-tokens (ANCHOR STAR OR LIT LPAREN RPAREN EOF))
(define lex (lexer-src-pos ["|" (token-OR lexeme)]
["^" (token-ANCHOR lexeme)]
["*" (token-STAR lexeme)]
[(repetition 1 +inf.0 alphabetic) (token-LIT lexeme)]
["(" (token-LPAREN lexeme)]
[")" (token-RPAREN lexeme)]
[whitespace (return-without-pos (lex input-port))]
[(eof) (token-EOF 'eof)]))
(define -parse (cfg-parser
(tokens regexp-tokens)
(start top)
(end EOF)
(src-pos)
(grammar [top [(maybe-anchor regexp)
(cond [$1
`(anchored ,$2 ,(pos->sexp $1-start-pos) ,(pos->sexp $2-end-pos))]
[else
`(unanchored ,$2 ,(pos->sexp $1-start-pos) ,(pos->sexp $2-end-pos))])]]
[maybe-anchor [(ANCHOR) #t]
[() #f]]
[regexp [(regexp STAR) `(star ,$1 ,(pos->sexp $1-start-pos) ,(pos->sexp $2-end-pos))]
[(regexp OR regexp) `(or ,$1 ,$3 ,(pos->sexp $1-start-pos) ,(pos->sexp $3-end-pos))]
[(LPAREN regexp RPAREN) `(group ,$2 ,(pos->sexp $1-start-pos) ,(pos->sexp $3-end-pos))]
[(LIT) `(lit ,$1 ,(pos->sexp $1-start-pos) ,(pos->sexp $1-end-pos))]])))
(define (pos->sexp pos)
(position-offset pos))
(define (parse s)
(define ip (open-input-string s))
(port-count-lines! ip)
(-parse (lambda () (lex ip))))
(check-equal? (parse "abc")
'(unanchored (lit "abc" 1 4) 1 4))
(check-equal? (parse "a | (b*) | c")
'(unanchored (or (or (lit "a" 1 2)
(group (star (lit "b" 6 7) 6 8) 5 9)
1 9)
(lit "c" 12 13)
1 13)
1 13)))
;; Check that cfg-parser can accept error functions of 3 arguments:
(block
(define-tokens non-terminals (ONE ZERO EOF))
(define parse
(cfg-parser (tokens non-terminals)
(start ones)
(end EOF)
(error (lambda (tok-ok tok-name tok-val)
(error (format "~a ~a ~a" tok-ok tok-name tok-val))))
(grammar [ones [() null]
[(ONE ones) (cons $1 $2)]])))
(define (sequence->tokenizer s)
(define-values (more? next) (sequence-generate s))
(lambda ()
(cond [(more?) (next)]
[else (token-EOF 'eof)])))
(check-exn #rx"#t ZERO zero"
(lambda () (parse (sequence->tokenizer (list (token-ZERO "zero")))))))
;; Check that cfg-parser can accept error functions of 5 arguments:
(block
(define-tokens non-terminals (ONE ZERO EOF))
(define parse
(cfg-parser (tokens non-terminals)
(start ones)
(src-pos)
(end EOF)
(error (lambda (tok-ok tok-name tok-val start-pos end-pos)
(error (format "~a ~a ~a ~a ~a"
tok-ok tok-name tok-val
(position-offset start-pos)
(position-offset end-pos)))))
(grammar [ones [() null]
[(ONE ones) (cons $1 $2)]])))
(define (sequence->tokenizer s)
(define-values (more? next) (sequence-generate s))
(lambda ()
(cond [(more?) (next)]
[else (position-token (token-EOF 'eof)
(position #f #f #f)
(position #f #f #f))])))
(check-exn #rx"#t ZERO zero 2 3"
(lambda ()
(parse
(sequence->tokenizer
(list (position-token
(token-ZERO "zero")
(position 2 2 5)
(position 3 2 6))))))))
;; Tests used during development
(define-tokens non-terminals (PLUS MINUS STAR BAR COLON EOF))
(define lex
(lexer
["+" (token-PLUS '+)]
["-" (token-MINUS '-)]
["*" (token-STAR '*)]
["|" (token-BAR '||)]
[":" (token-COLON '|:|)]
[whitespace (lex input-port)]
[(eof) (token-EOF 'eof)]))
(define parse
(cfg-parser
(tokens non-terminals)
(start <program>)
(end EOF)
(error (lambda (a b stx)
(error 'parse "failed at ~s" stx)))
(grammar [<program> [(PLUS) "plus"]
[(<minus-program> BAR <minus-program>) (list $1 $2 $3)]
[(<program> COLON) (list $1)]]
[<minus-program> [(MINUS) "minus"]
[(<program> STAR) (cons $1 $2)]]
[<simple> [(<alts> <alts> <alts> MINUS) "yes"]]
[<alts> [(PLUS) 'plus]
[(MINUS) 'minus]]
[<random> [() '0]
[(<random> PLUS) (add1 $1)]
[(<random> PLUS) (add1 $1)]])))
(let ([p (open-input-string #;"+*|-|-*|+**" #;"-|+*|+**"
#;"+*|+**|-" #;"-|-*|-|-*"
#;"-|-*|-|-**|-|-*|-|-**"
"-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***
|-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|
-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-*****"
;; This one fails:
#;"+*")])
(check-equal? (parse (lambda () (lex p)))
'((((((((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *)
||
(((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *))
.
*)
||
(((((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *)
||
(((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *))
.
*))
.
*)
||
(((((((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *)
||
(((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *))
.
*)
||
(((((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *)
||
(((((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *) || (((("minus" || "minus") . *) || (("minus" || "minus") . *)) . *)) . *))
.
*))
.
*)))))

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/cfg-parser_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("1da87ebbdbd287c3141d81b344c83a22fdcaead1" . "913322440977cfa44185506acee3ea9ca2d4426d") (collects #"br-parser-tools" #"lex.rkt") (collects #"br-parser-tools" #"private-lex" #"token-syntax.rkt") (collects #"br-parser-tools" #"yacc.rkt") (collects #"racket" #"base.rkt") (collects #"racket" #"block.rkt") (collects #"racket" #"generator.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt") (collects #"syntax" #"boundmap.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/cfg-parser_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/lex-sre_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("31789e05e19e6122c7619af755b6438bc1872e9b" . "b19638aea3046717541136642402ab336892a3aa") (collects #"br-parser-tools" #"lex.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/lex-sre_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/lex_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("fa9d915c4fb46de94fa89c9eac68c0a0fe32cd40" . "6eb29578f87766fcd1ee8209b3edc21c1081b8e4") (collects #"br-parser-tools" #"private-lex" #"actions.rkt") (collects #"br-parser-tools" #"private-lex" #"front.rkt") (collects #"br-parser-tools" #"private-lex" #"token.rkt") (collects #"br-parser-tools" #"private-lex" #"unicode-chars.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzlib" #"stxparam.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"boundmap.rkt") (collects #"syntax" #"define.rkt") (collects #"syntax" #"readerr.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/lex_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/yacc_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("100e497a060ad40147465b34990a741797ddb6c0" . "4a109ffd564a7614c177351282958ab6cc95da13") (collects #"br-parser-tools" #"private-lex" #"token.rkt") (collects #"br-parser-tools" #"private-yacc" #"grammar.rkt") (collects #"br-parser-tools" #"private-yacc" #"parser-actions.rkt") (collects #"br-parser-tools" #"private-yacc" #"parser-builder.rkt") (collects #"br-parser-tools" #"private-yacc" #"yacc-helper.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzlib" #"etc.rkt") (collects #"mzlib" #"pretty.rkt") (collects #"scheme" #"base.rkt") (collects #"scheme" #"runtime-config.rkt") (collects #"syntax" #"readerr.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/errortrace/yacc_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/lex-sre_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("31789e05e19e6122c7619af755b6438bc1872e9b" . "0a9e246cdda8f6239b7422f687b6513aa57dfb7f") (collects #"br-parser-tools" #"lex.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/lex-sre_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/lex_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("340fcc1fd30e6afc450a6027068d0e71ff42234e" . "57d5de7788049c0521682559da14c2475e4e08b5") (collects #"br-parser-tools" #"private-lex" #"actions.rkt") (collects #"br-parser-tools" #"private-lex" #"front.rkt") (collects #"br-parser-tools" #"private-lex" #"token.rkt") (collects #"br-parser-tools" #"private-lex" #"unicode-chars.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzlib" #"stxparam.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"boundmap.rkt") (collects #"syntax" #"define.rkt") (collects #"syntax" #"readerr.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/drracket/lex_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/info_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("0160a40a20d9e0d2a9dc08e0d3b6407cd43b669f" . "64293529315a4e5ca67bc9da08b943f520e0d704") (collects #"info" #"main.rkt") (collects #"setup" #"infotab.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/info_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex-plt-v200_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("1c73d195a19fdaccf7ef3b12cf2e3b5d7fa49f8f" . "38b5833add35ba09a9b03d9a3edef53637cc159c") (collects #"br-parser-tools" #"lex-sre.rkt") (collects #"br-parser-tools" #"lex.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex-plt-v200_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex-sre_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("31789e05e19e6122c7619af755b6438bc1872e9b" . "6c5a05919183e8d1de083eff2db1966f6ae5ccb6") (collects #"br-parser-tools" #"lex.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex-sre_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("340fcc1fd30e6afc450a6027068d0e71ff42234e" . "8cc42f47b45f7984d90feb68df53180d93bdefeb") (collects #"br-parser-tools" #"private-lex" #"actions.rkt") (collects #"br-parser-tools" #"private-lex" #"front.rkt") (collects #"br-parser-tools" #"private-lex" #"token.rkt") (collects #"br-parser-tools" #"private-lex" #"unicode-chars.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzlib" #"stxparam.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"boundmap.rkt") (collects #"syntax" #"define.rkt") (collects #"syntax" #"readerr.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/lex_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/yacc-to-scheme_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("d5abd58a5a7bfc4bc558dd51bd60ad27bf7d5be9" . "1ff2a8b025cffabf443820bc20e3a0c286570369") (collects #"br-parser-tools" #"lex-sre.rkt") (collects #"br-parser-tools" #"lex.rkt") (collects #"br-parser-tools" #"yacc.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"readerr.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/yacc-to-scheme_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/yacc_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("100e497a060ad40147465b34990a741797ddb6c0" . "35e63de458cf673b37751cb8bdcb77a583578019") (collects #"br-parser-tools" #"private-lex" #"token.rkt") (collects #"br-parser-tools" #"private-yacc" #"grammar.rkt") (collects #"br-parser-tools" #"private-yacc" #"parser-actions.rkt") (collects #"br-parser-tools" #"private-yacc" #"parser-builder.rkt") (collects #"br-parser-tools" #"private-yacc" #"yacc-helper.rkt") (collects #"mzlib" #"etc.rkt") (collects #"mzlib" #"pretty.rkt") (collects #"scheme" #"base.rkt") (collects #"scheme" #"runtime-config.rkt") (collects #"syntax" #"readerr.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/compiled/yacc_rkt.zo
View File

Binary file not shown.

89
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/calc.rkt
Unescape Escape View File

@ -0,0 +1,89 @@
#lang scheme
;; An interactive calculator inspired by the calculator example in the bison manual.
;; Import the parser and lexer generators.
(require br-parser-tools/yacc
br-parser-tools/lex
(prefix-in : br-parser-tools/lex-sre))
(define-tokens value-tokens (NUM VAR FNCT))
(define-empty-tokens op-tokens (newline = OP CP + - * / ^ EOF NEG))
;; A hash table to store variable values in for the calculator
(define vars (make-hash))
(define-lex-abbrevs
(lower-letter (:/ "a" "z"))
(upper-letter (:/ #\A #\Z))
;; (:/ 0 9) would not work because the lexer does not understand numbers. (:/ #\0 #\9) is ok too.
(digit (:/ "0" "9")))
(define calcl
(lexer
[(eof) 'EOF]
;; recursively call the lexer on the remaining input after a tab or space. Returning the
;; result of that operation. This effectively skips all whitespace.
[(:or #\tab #\space) (calcl input-port)]
;; (token-newline) returns 'newline
[#\newline (token-newline)]
;; Since (token-=) returns '=, just return the symbol directly
[(:or "=" "+" "-" "*" "/" "^") (string->symbol lexeme)]
["(" 'OP]
[")" 'CP]
["sin" (token-FNCT sin)]
[(:+ (:or lower-letter upper-letter)) (token-VAR (string->symbol lexeme))]
[(:+ digit) (token-NUM (string->number lexeme))]
[(:: (:+ digit) #\. (:* digit)) (token-NUM (string->number lexeme))]))
(define calcp
(parser
(start start)
(end newline EOF)
(tokens value-tokens op-tokens)
(error (lambda (a b c) (void)))
(precs (right =)
(left - +)
(left * /)
(left NEG)
(right ^))
(grammar
(start [() #f]
;; If there is an error, ignore everything before the error
;; and try to start over right after the error
[(error start) $2]
[(exp) $1])
(exp [(NUM) $1]
[(VAR) (hash-ref vars $1 (lambda () 0))]
[(VAR = exp) (begin (hash-set! vars $1 $3)
$3)]
[(FNCT OP exp CP) ($1 $3)]
[(exp + exp) (+ $1 $3)]
[(exp - exp) (- $1 $3)]
[(exp * exp) (* $1 $3)]
[(exp / exp) (/ $1 $3)]
[(- exp) (prec NEG) (- $2)]
[(exp ^ exp) (expt $1 $3)]
[(OP exp CP) $2]))))
;; run the calculator on the given input-port
(define (calc ip)
(port-count-lines! ip)
(letrec ((one-line
(lambda ()
(let ((result (calcp (lambda () (calcl ip)))))
(when result
(printf "~a\n" result)
(one-line))))))
(one-line)))
(calc (open-input-string "x=1\n(x + 2 * 3) - (1+2)*3"))

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/compiled/calc_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("e3352df1b72626dc220a94ee0bd16f165519bade" . "3c46fc3eda107e037940fbfb68032106839316da") (collects #"br-parser-tools" #"lex-sre.rkt") (collects #"br-parser-tools" #"lex.rkt") (collects #"br-parser-tools" #"yacc.rkt") (collects #"scheme" #"main.rkt") (collects #"scheme" #"runtime-config.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/compiled/calc_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/compiled/read_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("05c4bd3fd622dd1b33ebd5eec53f3018b9d64055" . "9a6409107f8f3a3566e2c5a71cb5bbf5b38f014e") (collects #"br-parser-tools" #"lex-sre.rkt") (collects #"br-parser-tools" #"lex.rkt") (collects #"br-parser-tools" #"yacc.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"readerr.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/compiled/read_rkt.zo
View File

Binary file not shown.

242
br-parser-tools/br-parser-tools-lib/br-parser-tools/examples/read.rkt
Unescape Escape View File

@ -0,0 +1,242 @@
;; This implements the equivalent of racket's read-syntax for R5RS scheme.
;; It has not been thoroughly tested. Also it will read an entire file into a
;; list of syntax objects, instead of returning one syntax object at a time
(module read mzscheme
(require br-parser-tools/lex
(prefix : br-parser-tools/lex-sre)
br-parser-tools/yacc
syntax/readerr)
(define-tokens data (DATUM))
(define-empty-tokens delim (OP CP HASHOP QUOTE QUASIQUOTE UNQUOTE UNQUOTE-SPLICING DOT EOF))
(define scheme-lexer
(lexer-src-pos
;; Skip comments, without accumulating extra position information
[(:or scheme-whitespace comment) (return-without-pos (scheme-lexer input-port))]
["#t" (token-DATUM #t)]
["#f" (token-DATUM #f)]
[(:: "#\\" any-char) (token-DATUM (caddr (string->list lexeme)))]
["#\\space" (token-DATUM #\space)]
["#\\newline" (token-DATUM #\newline)]
[(:or (:: initial (:* subsequent)) "+" "-" "...") (token-DATUM (string->symbol lexeme))]
[#\" (token-DATUM (list->string (get-string-token input-port)))]
[#\( 'OP]
[#\) 'CP]
[#\[ 'OP]
[#\] 'CP]
["#(" 'HASHOP]
[num2 (token-DATUM (string->number lexeme 2))]
[num8 (token-DATUM (string->number lexeme 8))]
[num10 (token-DATUM (string->number lexeme 10))]
[num16 (token-DATUM (string->number lexeme 16))]
["'" 'QUOTE]
["`" 'QUASIQUOTE]
["," 'UNQUOTE]
[",@" 'UNQUOTE-SPLICING]
["." 'DOT]
[(eof) 'EOF]))
(define get-string-token
(lexer
[(:~ #\" #\\) (cons (car (string->list lexeme))
(get-string-token input-port))]
[(:: #\\ #\\) (cons #\\ (get-string-token input-port))]
[(:: #\\ #\") (cons #\" (get-string-token input-port))]
[#\" null]))
(define-lex-abbrevs
[letter (:or (:/ "a" "z") (:/ #\A #\Z))]
[digit (:/ #\0 #\9)]
[scheme-whitespace (:or #\newline #\return #\tab #\space #\vtab)]
[initial (:or letter (char-set "!$%&*/:<=>?^_~@"))]
[subsequent (:or initial digit (char-set "+-.@"))]
[comment (:: #\; (:* (:~ #\newline)) #\newline)]
;; See ${PLTHOME}/collects/syntax-color/racket-lexer.rkt for an example of
;; using regexp macros to avoid the cut and paste.
; [numR (:: prefixR complexR)]
; [complexR (:or realR
; (:: realR "@" realR)
; (:: realR "+" urealR "i")
; (:: realR "-" urealR "i")
; (:: realR "+i")
; (:: realR "-i")
; (:: "+" urealR "i")
; (:: "-" urealR "i")
; (:: "+i")
; (:: "-i"))]
; [realR (:: sign urealR)]
; [urealR (:or uintegerR (:: uintegerR "/" uintegerR) decimalR)]
; [uintegerR (:: (:+ digitR) (:* #\#))]
; [prefixR (:or (:: radixR exactness)
; (:: exactness radixR))]
[num2 (:: prefix2 complex2)]
[complex2 (:or real2
(:: real2 "@" real2)
(:: real2 "+" ureal2 "i")
(:: real2 "-" ureal2 "i")
(:: real2 "+i")
(:: real2 "-i")
(:: "+" ureal2 "i")
(:: "-" ureal2 "i")
(:: "+i")
(:: "-i"))]
[real2 (:: sign ureal2)]
[ureal2 (:or uinteger2 (:: uinteger2 "/" uinteger2))]
[uinteger2 (:: (:+ digit2) (:* #\#))]
[prefix2 (:or (:: radix2 exactness)
(:: exactness radix2))]
[radix2 "#b"]
[digit2 (:or "0" "1")]
[num8 (:: prefix8 complex8)]
[complex8 (:or real8
(:: real8 "@" real8)
(:: real8 "+" ureal8 "i")
(:: real8 "-" ureal8 "i")
(:: real8 "+i")
(:: real8 "-i")
(:: "+" ureal8 "i")
(:: "-" ureal8 "i")
(:: "+i")
(:: "-i"))]
[real8 (:: sign ureal8)]
[ureal8 (:or uinteger8 (:: uinteger8 "/" uinteger8))]
[uinteger8 (:: (:+ digit8) (:* #\#))]
[prefix8 (:or (:: radix8 exactness)
(:: exactness radix8))]
[radix8 "#o"]
[digit8 (:/ "0" "7")]
[num10 (:: prefix10 complex10)]
[complex10 (:or real10
(:: real10 "@" real10)
(:: real10 "+" ureal10 "i")
(:: real10 "-" ureal10 "i")
(:: real10 "+i")
(:: real10 "-i")
(:: "+" ureal10 "i")
(:: "-" ureal10 "i")
(:: "+i")
(:: "-i"))]
[real10 (:: sign ureal10)]
[ureal10 (:or uinteger10 (:: uinteger10 "/" uinteger10) decimal10)]
[uinteger10 (:: (:+ digit10) (:* #\#))]
[prefix10 (:or (:: radix10 exactness)
(:: exactness radix10))]
[radix10 (:? "#d")]
[digit10 digit]
[decimal10 (:or (:: uinteger10 suffix)
(:: #\. (:+ digit10) (:* #\#) suffix)
(:: (:+ digit10) #\. (:* digit10) (:* #\#) suffix)
(:: (:+ digit10) (:+ #\#) #\. (:* #\#) suffix))]
[num16 (:: prefix16 complex16)]
[complex16 (:or real16
(:: real16 "@" real16)
(:: real16 "+" ureal16 "i")
(:: real16 "-" ureal16 "i")
(:: real16 "+i")
(:: real16 "-i")
(:: "+" ureal16 "i")
(:: "-" ureal16 "i")
"+i"
"-i")]
[real16 (:: sign ureal16)]
[ureal16 (:or uinteger16 (:: uinteger16 "/" uinteger16))]
[uinteger16 (:: (:+ digit16) (:* #\#))]
[prefix16 (:or (:: radix16 exactness)
(:: exactness radix16))]
[radix16 "#x"]
[digit16 (:or digit (:/ #\a #\f) (:/ #\A #\F))]
[suffix (:or "" (:: exponent-marker sign (:+ digit10)))]
[exponent-marker (:or "e" "s" "f" "d" "l")]
[sign (:or "" "+" "-")]
[exactness (:or "" "#i" "#e")])
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
;; A macro to build the syntax object
(define-syntax (build-so stx)
(syntax-case stx ()
((_ value start end)
(with-syntax ((start-pos (datum->syntax-object
(syntax end)
(string->symbol
(format "$~a-start-pos"
(syntax-object->datum (syntax start))))))
(end-pos (datum->syntax-object
(syntax end)
(string->symbol
(format "$~a-end-pos"
(syntax-object->datum (syntax end))))))
(source (datum->syntax-object
(syntax end)
'source-name)))
(syntax
(datum->syntax-object
#f
value
(list source
(position-line start-pos)
(position-col start-pos)
(position-offset start-pos)
(- (position-offset end-pos)
(position-offset start-pos)))
stx-for-original-property))))))
(define (scheme-parser source-name)
(parser
(src-pos)
(start s)
(end EOF)
(error (lambda (a name val start end)
(raise-read-error
"read-error"
source-name
(position-line start)
(position-col start)
(position-offset start)
(- (position-offset end)
(position-offset start)))))
(tokens data delim)
(grammar
(s [(sexp-list) (reverse $1)])
(sexp [(DATUM) (build-so $1 1 1)]
[(OP sexp-list CP) (build-so (reverse $2) 1 3)]
[(HASHOP sexp-list CP) (build-so (list->vector (reverse $2)) 1 3)]
[(QUOTE sexp) (build-so (list 'quote $2) 1 2)]
[(QUASIQUOTE sexp) (build-so (list 'quasiquote $2) 1 2)]
[(UNQUOTE sexp) (build-so (list 'unquote $2) 1 2)]
[(UNQUOTE-SPLICING sexp) (build-so (list 'unquote-splicing $2) 1 2)]
[(OP sexp-list DOT sexp CP) (build-so (append (reverse $2) $4) 1 5)])
(sexp-list [() null]
[(sexp-list sexp) (cons $2 $1)]))))
(define (rs sn ip)
(port-count-lines! ip)
((scheme-parser sn) (lambda () (scheme-lexer ip))))
(define readsyntax
(case-lambda ((sn) (rs sn (current-input-port)))
((sn ip) (rs sn ip))))
(provide (rename readsyntax read-syntax))
)

3
br-parser-tools/br-parser-tools-lib/br-parser-tools/info.rkt
Unescape Escape View File

@ -0,0 +1,3 @@
#lang info
(define compile-omit-paths '("private-lex/error-tests.rkt"))

24
br-parser-tools/br-parser-tools-lib/br-parser-tools/lex-plt-v200.rkt
Unescape Escape View File

@ -0,0 +1,24 @@
(module lex-plt-v200 mzscheme
(require br-parser-tools/lex
(prefix : br-parser-tools/lex-sre))
(provide epsilon
~
(rename :* *)
(rename :+ +)
(rename :? ?)
(rename :or :)
(rename :& &)
(rename :: @)
(rename :~ ^)
(rename :/ -))
(define-lex-trans epsilon
(syntax-rules ()
((_) "")))
(define-lex-trans ~
(syntax-rules ()
((_ re) (complement re)))))

119
br-parser-tools/br-parser-tools-lib/br-parser-tools/lex-sre.rkt
Unescape Escape View File

@ -0,0 +1,119 @@
(module lex-sre mzscheme
(require br-parser-tools/lex)
(provide (rename sre-* *)
(rename sre-+ +)
?
(rename sre-= =)
(rename sre->= >=)
**
(rename sre-or or)
:
seq
&
~
(rename sre-- -)
(rename sre-/ /)
/-only-chars)
(define-lex-trans sre-*
(syntax-rules ()
((_ re ...)
(repetition 0 +inf.0 (union re ...)))))
(define-lex-trans sre-+
(syntax-rules ()
((_ re ...)
(repetition 1 +inf.0 (union re ...)))))
(define-lex-trans ?
(syntax-rules ()
((_ re ...)
(repetition 0 1 (union re ...)))))
(define-lex-trans sre-=
(syntax-rules ()
((_ n re ...)
(repetition n n (union re ...)))))
(define-lex-trans sre->=
(syntax-rules ()
((_ n re ...)
(repetition n +inf.0 (union re ...)))))
(define-lex-trans **
(syntax-rules ()
((_ low #f re ...)
(** low +inf.0 re ...))
((_ low high re ...)
(repetition low high (union re ...)))))
(define-lex-trans sre-or
(syntax-rules ()
((_ re ...)
(union re ...))))
(define-lex-trans :
(syntax-rules ()
((_ re ...)
(concatenation re ...))))
(define-lex-trans seq
(syntax-rules ()
((_ re ...)
(concatenation re ...))))
(define-lex-trans &
(syntax-rules ()
((_ re ...)
(intersection re ...))))
(define-lex-trans ~
(syntax-rules ()
((_ re ...)
(char-complement (union re ...)))))
;; set difference
(define-lex-trans (sre-- stx)
(syntax-case stx ()
((_)
(raise-syntax-error #f
"must have at least one argument"
stx))
((_ big-re re ...)
(syntax (& big-re (complement (union re ...)))))))
(define-lex-trans (sre-/ stx)
(syntax-case stx ()
((_ range ...)
(let ((chars
(apply append (map (lambda (r)
(let ((x (syntax-e r)))
(cond
((char? x) (list x))
((string? x) (string->list x))
(else
(raise-syntax-error
#f
"not a char or string"
stx
r)))))
(syntax->list (syntax (range ...)))))))
(unless (even? (length chars))
(raise-syntax-error
#f
"not given an even number of characters"
stx))
#`(/-only-chars #,@chars)))))
(define-lex-trans /-only-chars
(syntax-rules ()
((_ c1 c2)
(char-range c1 c2))
((_ c1 c2 c ...)
(union (char-range c1 c2)
(/-only-chars c ...)))))
)

412
br-parser-tools/br-parser-tools-lib/br-parser-tools/lex.rkt
Unescape Escape View File

@ -0,0 +1,412 @@
(module lex mzscheme
;; Provides the syntax used to create lexers and the functions needed to
;; create and use the buffer that the lexer reads from. See docs.
(require-for-syntax mzlib/list
syntax/stx
syntax/define
syntax/boundmap
"private-lex/util.rkt"
"private-lex/actions.rkt"
"private-lex/front.rkt"
"private-lex/unicode-chars.rkt")
(require mzlib/stxparam
syntax/readerr
"private-lex/token.rkt")
(provide lexer lexer-src-pos lexer-srcloc define-lex-abbrev define-lex-abbrevs define-lex-trans
;; Dealing with tokens and related structures
define-tokens define-empty-tokens token-name token-value token?
(struct position (offset line col))
(struct position-token (token start-pos end-pos))
(struct srcloc-token (token srcloc))
;; File path for highlighting errors while lexing
file-path
lexer-file-path ;; alternate name
;; Lex abbrevs for unicode char sets. See mzscheme manual section 3.4.
any-char any-string nothing alphabetic lower-case upper-case title-case
numeric symbolic punctuation graphic whitespace blank iso-control
;; A regular expression operator
char-set)
;; wrap-action: syntax-object src-pos? -> syntax-object
(define-for-syntax (wrap-action action src-loc-style)
(with-syntax ((action-stx
(cond
[(eq? src-loc-style 'lexer-src-pos)
#`(let/ec ret
(syntax-parameterize
([return-without-pos (make-rename-transformer #'ret)])
(make-position-token #,action start-pos end-pos)))]
[(eq? src-loc-style 'lexer-srcloc)
#`(let/ec ret
(syntax-parameterize
([return-without-srcloc (make-rename-transformer #'ret)])
(make-srcloc-token #,action lexeme-srcloc)))]
[else action])))
(syntax/loc action
(lambda (start-pos-p end-pos-p lexeme-p input-port-p)
(define lexeme-srcloc-p (make-srcloc (object-name input-port-p)
(position-line start-pos-p)
(position-col start-pos-p)
(position-offset start-pos-p)
(and (number? (position-offset end-pos-p))
(number? (position-offset start-pos-p))
(- (position-offset end-pos-p)
(position-offset start-pos-p)))))
(syntax-parameterize
([start-pos (make-rename-transformer #'start-pos-p)]
[end-pos (make-rename-transformer #'end-pos-p)]
[lexeme (make-rename-transformer #'lexeme-p)]
[input-port (make-rename-transformer #'input-port-p)]
[lexeme-srcloc (make-rename-transformer #'lexeme-srcloc-p)])
action-stx)))))
(define-for-syntax (make-lexer-trans src-loc-style)
(lambda (stx)
(syntax-case stx ()
((_ re-act ...)
(begin
(for-each
(lambda (x)
(syntax-case x ()
((re act) (void))
(_ (raise-syntax-error #f
"not a regular expression / action pair"
stx
x))))
(syntax->list (syntax (re-act ...))))
(let* ((spec/re-act-lst
(syntax->list (syntax (re-act ...))))
(eof-act
(get-special-action spec/re-act-lst #'eof #''eof))
(spec-act
(get-special-action spec/re-act-lst #'special #'(void)))
(spec-comment-act
(get-special-action spec/re-act-lst #'special-comment #'#f))
(ids (list #'special #'special-comment #'eof))
(re-act-lst
(filter
(lambda (spec/re-act)
(syntax-case spec/re-act ()
(((special) act)
(not (ormap
(lambda (x)
(and (identifier? #'special)
(module-or-top-identifier=? (syntax special) x)))
ids)))
(_ #t)))
spec/re-act-lst))
(name-lst (map (lambda (x) (datum->syntax-object #f (gensym))) re-act-lst))
(act-lst (map (lambda (x) (stx-car (stx-cdr x))) re-act-lst))
(re-actname-lst (map (lambda (re-act name)
(list (stx-car re-act)
name))
re-act-lst
name-lst)))
(when (null? spec/re-act-lst)
(raise-syntax-error (or src-loc-style 'lexer) "expected at least one action" stx))
(let-values (((trans start action-names no-look disappeared-uses)
(build-lexer re-actname-lst)))
(when (vector-ref action-names start) ;; Start state is final
(unless (and
;; All the successor states are final
(andmap (lambda (x) (vector-ref action-names (vector-ref x 2)))
(vector->list (vector-ref trans start)))
;; Each character has a successor state
(let loop ((check 0)
(nexts (vector->list (vector-ref trans start))))
(cond
((null? nexts) #f)
(else
(let ((next (car nexts)))
(and (= (vector-ref next 0) check)
(let ((next-check (vector-ref next 1)))
(or (>= next-check max-char-num)
(loop (add1 next-check) (cdr nexts))))))))))
(eprintf "Warning: lexer at ~a can accept the empty string.\n" stx)))
(with-syntax ((start-state-stx start)
(trans-table-stx trans)
(no-lookahead-stx no-look)
((name ...) name-lst)
((act ...) (map (lambda (a)
(wrap-action a src-loc-style))
act-lst))
((act-name ...) (vector->list action-names))
(spec-act-stx
(wrap-action spec-act src-loc-style))
(has-comment-act?-stx
(if (syntax-e spec-comment-act) #t #f))
(spec-comment-act-stx
(wrap-action spec-comment-act src-loc-style))
(eof-act-stx (wrap-action eof-act src-loc-style)))
(syntax-property
(syntax/loc stx
(let ([name act] ...)
(let ([proc
(lexer-body start-state-stx
trans-table-stx
(vector act-name ...)
no-lookahead-stx
spec-act-stx
has-comment-act?-stx
spec-comment-act-stx
eof-act-stx)])
;; reverse eta to get named procedures:
(lambda (port) (proc port)))))
'disappeared-use
disappeared-uses)))))))))
(define-syntax lexer (make-lexer-trans #f))
(define-syntax lexer-src-pos (make-lexer-trans 'lexer-src-pos))
(define-syntax lexer-srcloc (make-lexer-trans 'lexer-srcloc))
(define-syntax (define-lex-abbrev stx)
(syntax-case stx ()
((_ name re)
(identifier? (syntax name))
(syntax/loc stx
(define-syntax name
(make-lex-abbrev (lambda () (quote-syntax re))))))
(_
(raise-syntax-error
#f
"form should be (define-lex-abbrev name re)"
stx))))
(define-syntax (define-lex-abbrevs stx)
(syntax-case stx ()
((_ x ...)
(with-syntax (((abbrev ...)
(map
(lambda (a)
(syntax-case a ()
((name re)
(identifier? (syntax name))
(syntax/loc a (define-lex-abbrev name re)))
(_ (raise-syntax-error
#f
"form should be (define-lex-abbrevs (name re) ...)"
stx
a))))
(syntax->list (syntax (x ...))))))
(syntax/loc stx (begin abbrev ...))))
(_
(raise-syntax-error
#f
"form should be (define-lex-abbrevs (name re) ...)"
stx))))
(define-syntax (define-lex-trans stx)
(syntax-case stx ()
((_ name-form body-form)
(let-values (((name body)
(normalize-definition (syntax (define-syntax name-form body-form)) #'lambda)))
#`(define-syntax #,name
(let ((func #,body))
(unless (procedure? func)
(raise-syntax-error 'define-lex-trans "expected a procedure as the transformer, got ~e" func))
(unless (procedure-arity-includes? func 1)
(raise-syntax-error 'define-lex-trans "expected a procedure that accepts 1 argument as the transformer, got ~e" func))
(make-lex-trans func)))))
(_
(raise-syntax-error
#f
"form should be (define-lex-trans name transformer)"
stx))))
(define (get-next-state-helper char min max table)
(if (>= min max)
#f
(let* ((try (quotient (+ min max) 2))
(el (vector-ref table try))
(r1 (vector-ref el 0))
(r2 (vector-ref el 1)))
(cond
((and (>= char r1) (<= char r2)) (vector-ref el 2))
((< char r1) (get-next-state-helper char min try table))
(else (get-next-state-helper char (add1 try) max table))))))
(define (get-next-state char table)
(if table
(get-next-state-helper char 0 (vector-length table) table)
#f))
(define (lexer-body start-state trans-table actions no-lookahead special-action
has-special-comment-action? special-comment-action eof-action)
(letrec ((lexer
(lambda (ip)
(let ((first-pos (get-position ip))
(first-char (peek-char-or-special ip 0)))
;(printf "(peek-char-or-special port 0) = ~e\n" first-char)
(cond
((eof-object? first-char)
(do-match ip first-pos eof-action (read-char-or-special ip)))
((special-comment? first-char)
(read-char-or-special ip)
(cond
(has-special-comment-action?
(do-match ip first-pos special-comment-action #f))
(else (lexer ip))))
((not (char? first-char))
(do-match ip first-pos special-action (read-char-or-special ip)))
(else
(let lexer-loop (
;; current-state
(state start-state)
;; the character to transition on
(char first-char)
;; action for the longest match seen thus far
;; including a match at the current state
(longest-match-action
(vector-ref actions start-state))
;; how many bytes precede char
(length-bytes 0)
;; how many characters have been read
;; including the one just read
(length-chars 1)
;; how many characters are in the longest match
(longest-match-length 0))
(let ((next-state
(cond
((not (char? char)) #f)
(else (get-next-state (char->integer char)
(vector-ref trans-table state))))))
(cond
((not next-state)
(check-match ip first-pos longest-match-length
length-chars longest-match-action))
((vector-ref no-lookahead next-state)
(let ((act (vector-ref actions next-state)))
(check-match ip
first-pos
(if act length-chars longest-match-length)
length-chars
(if act act longest-match-action))))
(else
(let* ((act (vector-ref actions next-state))
(next-length-bytes (+ (char-utf-8-length char) length-bytes))
(next-char (peek-char-or-special ip next-length-bytes)))
#;(printf "(peek-char-or-special port ~e) = ~e\n"
next-length-bytes next-char)
(lexer-loop next-state
next-char
(if act
act
longest-match-action)
next-length-bytes
(add1 length-chars)
(if act
length-chars
longest-match-length)))))))))))))
(lambda (ip)
(unless (input-port? ip)
(raise-argument-error
'lexer
"input-port?"
0
ip))
(lexer ip))))
(define (check-match lb first-pos longest-match-length length longest-match-action)
(unless longest-match-action
(let* ((match (read-string length lb))
(end-pos (get-position lb)))
(raise-read-error
(format "lexer: No match found in input starting with: ~a" match)
(file-path)
(position-line first-pos)
(position-col first-pos)
(position-offset first-pos)
(- (position-offset end-pos) (position-offset first-pos)))))
(let ((match (read-string longest-match-length lb)))
;(printf "(read-string ~e port) = ~e\n" longest-match-length match)
(do-match lb first-pos longest-match-action match)))
(define file-path (make-parameter #f))
(define lexer-file-path file-path)
(define (do-match ip first-pos action value)
#;(printf "(action ~a ~a ~a ~a)\n"
(position-offset first-pos) (position-offset (get-position ip)) value ip)
(action first-pos (get-position ip) value ip))
(define (get-position ip)
(let-values (((line col off) (port-next-location ip)))
(make-position off line col)))
(define-syntax (create-unicode-abbrevs stx)
(syntax-case stx ()
((_ ctxt)
(with-syntax (((ranges ...) (map (lambda (range)
`(union ,@(map (lambda (x)
`(char-range ,(integer->char (car x))
,(integer->char (cdr x))))
range)))
(list (force alphabetic-ranges)
(force lower-case-ranges)
(force upper-case-ranges)
(force title-case-ranges)
(force numeric-ranges)
(force symbolic-ranges)
(force punctuation-ranges)
(force graphic-ranges)
(force whitespace-ranges)
(force blank-ranges)
(force iso-control-ranges))))
((names ...) (map (lambda (sym)
(datum->syntax-object (syntax ctxt) sym #f))
'(alphabetic
lower-case
upper-case
title-case
numeric
symbolic
punctuation
graphic
whitespace
blank
iso-control))))
(syntax (define-lex-abbrevs (names ranges) ...))))))
(define-lex-abbrev any-char (char-complement (union)))
(define-lex-abbrev any-string (intersection))
(define-lex-abbrev nothing (union))
(create-unicode-abbrevs #'here)
(define-lex-trans (char-set stx)
(syntax-case stx ()
((_ str)
(string? (syntax-e (syntax str)))
(with-syntax (((char ...) (string->list (syntax-e (syntax str)))))
(syntax (union char ...))))))
(define-syntax provide-lex-keyword
(syntax-rules ()
[(_ id ...)
(begin
(define-syntax-parameter id
(make-set!-transformer
(lambda (stx)
(raise-syntax-error
#f
(format "use of a lexer keyword (~a) is not in an appropriate lexer action"
'id)
stx))))
...
(provide id ...))]))
(provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc)
)

16
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/actions.rkt
Unescape Escape View File

@ -0,0 +1,16 @@
#lang scheme/base
(provide (all-defined-out))
(require syntax/stx)
;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object
;; Returns the first action from a rule of the form ((which-special) action)
(define (get-special-action rules which-special none)
(cond
((null? rules) none)
(else
(syntax-case (car rules) ()
(((special) act)
(and (identifier? #'special) (module-or-top-identifier=? (syntax special) which-special))
(syntax act))
(_ (get-special-action (cdr rules) which-special none))))))

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/actions_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("f095138d7dfc29ae18c12d7daf44f1c9b74ab56d" . "f0c7dd306804eb5e8da06235651b07296b23b36d") (collects #"scheme" #"base.rkt") (collects #"scheme" #"runtime-config.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/actions_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/deriv_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("1edbe8de6053f0e8735c4d7777b345672d547c86" . "980e8a36193a9253ed01c61fc421729123f6b314") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/deriv_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/actions_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("f095138d7dfc29ae18c12d7daf44f1c9b74ab56d" . "f0c7dd306804eb5e8da06235651b07296b23b36d") (collects #"scheme" #"base.rkt") (collects #"scheme" #"runtime-config.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/actions_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/deriv_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("1edbe8de6053f0e8735c4d7777b345672d547c86" . "44623f82f80a88e2fe5683fec412332baf6a8ed3") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/deriv_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/actions_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("f095138d7dfc29ae18c12d7daf44f1c9b74ab56d" . "4c8c1a7dddb28b104057c25eaf86b1a95e60048c") (collects #"errortrace" #"errortrace-key.rkt") (collects #"scheme" #"base.rkt") (collects #"scheme" #"runtime-config.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/actions_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/deriv_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("1edbe8de6053f0e8735c4d7777b345672d547c86" . "02238d6deec4e15d91f05091ef67f522127eb47b") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/deriv_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/front_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("560290907963aeb1a4cc1e997b45b3113174dcc2" . "8b3fb56340e1383a464e9e09b878c80c8588c8db") (collects #"br-parser-tools" #"private-lex" #"deriv.rkt") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"stx.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/front_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/re_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c35e7c257a2700b22560bd1ef8fa4ec0d85440cf" . "b1551c6be564899f5570915abe65bd6754d6ee02") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"scheme" #"match.rkt") (indirect collects #"racket" #"match" #"gen-match.rkt") (indirect collects #"racket" #"match" #"parse.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/re_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/stx_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c716d0316e7115d4b50b04c3f923b22c43068fb2" . "de91880596de9c821e9e2c4828b024d42f6a199c") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt") (collects #"syntax" #"id-table.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/stx_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/token-syntax_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("15ddc4ae61da4856338c06fe3f3aca89043495ec" . "1bd4c8735758355b04c6e172aa61084639448a7c") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/token-syntax_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/token_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c47b01af4f27383fafb3cea5d0e14b2b92da094b" . "9988c5c353bec4edf7eafa42e08d630b02a9328a") (collects #"br-parser-tools" #"private-lex" #"token-syntax.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/token_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/unicode-chars_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("11fb7e214dfb048796bfcbca53932424123137a2" . "b3606fa90704340e1a962ec5048ec3b01f440e06") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/unicode-chars_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/util_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("54744a008c8ffd6704fc954ca59351a6f19774a4" . "5b3e3294fee47f7377adc85735ab90b85321865e") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/errortrace/util_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/front_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("560290907963aeb1a4cc1e997b45b3113174dcc2" . "53517572cdb75487afeb2fff3000f8f73fc998aa") (collects #"br-parser-tools" #"private-lex" #"deriv.rkt") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"stx.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/front_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/re_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c35e7c257a2700b22560bd1ef8fa4ec0d85440cf" . "b2bb34be5f7b01ff900aa10ee415738b2a19b0a0") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"scheme" #"match.rkt") (indirect collects #"racket" #"match" #"gen-match.rkt") (indirect collects #"racket" #"match" #"parse.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/re_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/stx_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c716d0316e7115d4b50b04c3f923b22c43068fb2" . "b47d873be742873e79b0099de8845e32143ab4d5") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt") (collects #"syntax" #"id-table.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/stx_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/token-syntax_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("15ddc4ae61da4856338c06fe3f3aca89043495ec" . "46a0cffdba2f82aa32f0fd32a5783621a6a78323") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/token-syntax_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/token_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c47b01af4f27383fafb3cea5d0e14b2b92da094b" . "5a9e9888caac8c6df5e32eab1eb77a9522bb1097") (collects #"br-parser-tools" #"private-lex" #"token-syntax.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/token_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/unicode-chars_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("11fb7e214dfb048796bfcbca53932424123137a2" . "d1e63a1cc4d040c9bbc9481d0d8c6d890f9d2952") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/unicode-chars_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/util_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("54744a008c8ffd6704fc954ca59351a6f19774a4" . "04b200a056cd736ad4bd3d7221f381755cf94607") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/drracket/util_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/front_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("560290907963aeb1a4cc1e997b45b3113174dcc2" . "11a0fde414e54b53f7c8a690972c091191515617") (collects #"br-parser-tools" #"private-lex" #"deriv.rkt") (collects #"br-parser-tools" #"private-lex" #"re.rkt") (collects #"br-parser-tools" #"private-lex" #"stx.rkt") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"syntax" #"stx.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/front_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/re_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c35e7c257a2700b22560bd1ef8fa4ec0d85440cf" . "8309136e8195b423615deebdf156b1cf77168dfe") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"mzlib" #"integer-set.rkt") (collects #"mzlib" #"list.rkt") (collects #"mzscheme" #"main.rkt") (collects #"scheme" #"match.rkt") (indirect collects #"racket" #"match" #"gen-match.rkt") (indirect collects #"racket" #"match" #"parse.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/re_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/stx_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c716d0316e7115d4b50b04c3f923b22c43068fb2" . "01788f46755b7f7a3e2f5a04be22246525bde728") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt") (collects #"syntax" #"id-table.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/stx_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/token-syntax_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("15ddc4ae61da4856338c06fe3f3aca89043495ec" . "46a0cffdba2f82aa32f0fd32a5783621a6a78323") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/token-syntax_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/token_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("c47b01af4f27383fafb3cea5d0e14b2b92da094b" . "5a9e9888caac8c6df5e32eab1eb77a9522bb1097") (collects #"br-parser-tools" #"private-lex" #"token-syntax.rkt") (collects #"mzscheme" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/token_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/unicode-chars_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("11fb7e214dfb048796bfcbca53932424123137a2" . "c85260e8066b06a6c7e3ad05f21848a935912ffc") (collects #"br-parser-tools" #"private-lex" #"util.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/unicode-chars_rkt.zo
View File

Binary file not shown.

1
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/util_rkt.dep
Unescape Escape View File

@ -0,0 +1 @@
("6.8.0.2" ("54744a008c8ffd6704fc954ca59351a6f19774a4" . "04b200a056cd736ad4bd3d7221f381755cf94607") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt"))

BIN
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/compiled/util_rkt.zo
View File

Binary file not shown.

339
br-parser-tools/br-parser-tools-lib/br-parser-tools/private-lex/deriv.rkt
Unescape Escape View File

@ -0,0 +1,339 @@
(module deriv mzscheme
(require mzlib/list
(prefix is: mzlib/integer-set)
"re.rkt"
"util.rkt")
(provide build-dfa print-dfa (struct dfa (num-states start-state final-states/actions transitions)))
(define e (build-epsilon))
(define z (build-zero))
;; Don't do anything with this one but extract the chars
(define all-chars (->re `(char-complement (union)) (make-cache)))
;; get-char-groups : re bool -> (list-of char-setR?)
;; Collects the char-setRs in r that could be used in
;; taking the derivative of r.
(define (get-char-groups r found-negation)
(cond
((or (eq? r e) (eq? r z)) null)
((char-setR? r) (list r))
((concatR? r)
(if (re-nullable? (concatR-re1 r))
(append (get-char-groups (concatR-re1 r) found-negation)
(get-char-groups (concatR-re2 r) found-negation))
(get-char-groups (concatR-re1 r) found-negation)))
((repeatR? r)
(get-char-groups (repeatR-re r) found-negation))
((orR? r)
(apply append (map (lambda (x) (get-char-groups x found-negation)) (orR-res r))))
((andR? r)
(apply append (map (lambda (x) (get-char-groups x found-negation)) (andR-res r))))
((negR? r)
(if found-negation
(get-char-groups (negR-re r) #t)
(cons all-chars (get-char-groups (negR-re r) #t))))))
(test-block ((c (make-cache))
(r1 (->re #\1 c))
(r2 (->re #\2 c)))
((get-char-groups e #f) null)
((get-char-groups z #f) null)
((get-char-groups r1 #f) (list r1))
((get-char-groups (->re `(concatenation ,r1 ,r2) c) #f)
(list r1))
((get-char-groups (->re `(concatenation ,e ,r2) c) #f)
(list r2))
((get-char-groups (->re `(concatenation (repetition 0 +inf.0 ,r1) ,r2) c) #f)
(list r1 r2))
((get-char-groups (->re `(repetition 0 +inf.0 ,r1) c) #f)
(list r1))
((get-char-groups
(->re `(union (repetition 0 +inf.0 ,r1)
(concatenation (repetition 0 +inf.0 ,r2) "3") "4") c) #f)
(list r1 r2 (->re "3" c) (->re "4" c)))
((get-char-groups (->re `(complement ,r1) c) #f)
(list all-chars r1))
((get-char-groups
(->re `(intersection (repetition 0 +inf.0 ,r1)
(concatenation (repetition 0 +inf.0 ,r2) "3") "4") c) #f)
(list r1 r2 (->re "3" c) (->re "4" c)))
)
(define loc:member? is:member?)
;; deriveR : re char cache -> re
(define (deriveR r c cache)
(cond
((or (eq? r e) (eq? r z)) z)
((char-setR? r)
(if (loc:member? c (char-setR-chars r)) e z))
((concatR? r)
(let* ((r1 (concatR-re1 r))
(r2 (concatR-re2 r))
(d (build-concat (deriveR r1 c cache) r2 cache)))
(if (re-nullable? r1)
(build-or (list d (deriveR r2 c cache)) cache)
d)))
((repeatR? r)
(build-concat (deriveR (repeatR-re r) c cache)
(build-repeat (sub1 (repeatR-low r))
(sub1 (repeatR-high r))
(repeatR-re r) cache)
cache))
((orR? r)
(build-or (map (lambda (x) (deriveR x c cache))
(orR-res r))
cache))
((andR? r)
(build-and (map (lambda (x) (deriveR x c cache))
(andR-res r))
cache))
((negR? r)
(build-neg (deriveR (negR-re r) c cache) cache))))
(test-block ((c (make-cache))
(a (char->integer #\a))
(b (char->integer #\b))
(r1 (->re #\a c))
(r2 (->re `(repetition 0 +inf.0 #\a) c))
(r3 (->re `(repetition 0 +inf.0 ,r2) c))
(r4 (->re `(concatenation #\a ,r2) c))
(r5 (->re `(repetition 0 +inf.0 ,r4) c))
(r6 (->re `(union ,r5 #\a) c))
(r7 (->re `(concatenation ,r2 ,r2) c))
(r8 (->re `(complement ,r4) c))
(r9 (->re `(intersection ,r2 ,r4) c)))
((deriveR e a c) z)
((deriveR z a c) z)
((deriveR r1 b c) z)
((deriveR r1 a c) e)
((deriveR r2 a c) r2)
((deriveR r2 b c) z)
((deriveR r3 a c) r2)
((deriveR r3 b c) z)
((deriveR r4 a c) r2)
((deriveR r4 b c) z)
((deriveR r5 a c) (->re `(concatenation ,r2 ,r5) c))
((deriveR r5 b c) z)
((deriveR r6 a c) (->re `(union (concatenation ,r2 ,r5) "") c))
((deriveR r6 b c) z)
((deriveR r7 a c) (->re `(union (concatenation ,r2 ,r2) ,r2) c))
((deriveR r7 b c) z)
((deriveR r8 a c) (->re `(complement, r2) c))
((deriveR r8 b c) (->re `(complement ,z) c))
((deriveR r9 a c) r2)
((deriveR r9 b c) z)
((deriveR (->re `(repetition 1 2 "ab") c) a c)
(->re `(concatenation "b" (repetition 0 1 "ab")) c)))
;; An re-action is (cons re action)
;; derive : (list-of re-action) char cache -> (union (list-of re-action) #f)
;; applies deriveR to all the re-actions's re parts.
;; Returns #f if the derived state is equivalent to z.
(define (derive r c cache)
(let ((new-r (map (lambda (ra)
(cons (deriveR (car ra) c cache) (cdr ra)))
r)))
(if (andmap (lambda (x) (eq? z (car x)))
new-r)
#f
new-r)))
(test-block ((c (make-cache))
(r1 (->re #\1 c))
(r2 (->re #\2 c)))
((derive null (char->integer #\1) c) #f)
((derive (list (cons r1 1) (cons r2 2)) (char->integer #\1) c)
(list (cons e 1) (cons z 2)))
((derive (list (cons r1 1) (cons r2 2)) (char->integer #\3) c) #f))
;; get-final : (list-of re-action) -> (union #f syntax-object)
;; An re that accepts e represents a final state. Return the
;; action from the first final state or #f if there is none.
(define (get-final res)
(cond
((null? res) #f)
((re-nullable? (caar res)) (cdar res))
(else (get-final (cdr res)))))
(test-block ((c->i char->integer)
(c (make-cache))
(r1 (->re #\a c))
(r2 (->re #\b c))
(b (list (cons z 1) (cons z 2) (cons z 3) (cons e 4) (cons z 5)))
(a (list (cons r1 1) (cons r2 2))))
((derive null (c->i #\a) c) #f)
((derive a (c->i #\a) c) (list (cons e 1) (cons z 2)))
((derive a (c->i #\b) c) (list (cons z 1) (cons e 2)))
((derive a (c->i #\c) c) #f)
((derive (list (cons (->re `(union " " "\n" ",") c) 1)
(cons (->re `(concatenation (repetition 0 1 "-")
(repetition 1 +inf.0 (char-range "0" "9"))) c) 2)
(cons (->re `(concatenation "-" (repetition 1 +inf.0 "-")) c) 3)
(cons (->re "[" c) 4)
(cons (->re "]" c) 5)) (c->i #\[) c)
b)
((get-final a) #f)
((get-final (list (cons e 1) (cons e 2))) 1)
((get-final b) 4))
;; A state is (make-state (list-of re-action) nat)
(define-struct state (spec index))
;; get->key : re-action -> (list-of nat)
;; states are indexed by the list of indexes of their res
(define (get-key s)
(map (lambda (x) (re-index (car x))) s))
(define loc:partition is:partition)
;; compute-chars : (list-of state) -> (list-of char-set)
;; Computed the sets of equivalent characters for taking the
;; derivative of the car of st. Only one derivative per set need to be taken.
(define (compute-chars st)
(cond
((null? st) null)
(else
(loc:partition (map char-setR-chars
(apply append (map (lambda (x) (get-char-groups (car x) #f))
(state-spec (car st)))))))))
(test-block ((c (make-cache))
(c->i char->integer)
(r1 (->re `(char-range #\1 #\4) c))
(r2 (->re `(char-range #\2 #\3) c)))
((compute-chars null) null)
((compute-chars (list (make-state null 1))) null)
((map is:integer-set-contents
(compute-chars (list (make-state (list (cons r1 1) (cons r2 2)) 2))))
(list (is:integer-set-contents (is:make-range (c->i #\2) (c->i #\3)))
(is:integer-set-contents (is:union (is:make-range (c->i #\1))
(is:make-range (c->i #\4)))))))
;; A dfa is (make-dfa int int
;; (list-of (cons int syntax-object))
;; (list-of (cons int (list-of (cons char-set int)))))
;; Each transitions is a state and a list of chars with the state to transition to.
;; The finals and transitions are sorted by state number, and duplicate free.
(define-struct dfa (num-states start-state final-states/actions transitions) (make-inspector))
(define loc:get-integer is:get-integer)
;; build-dfa : (list-of re-action) cache -> dfa
(define (build-dfa rs cache)
(let* ((transitions (make-hash-table))
(get-state-number (make-counter))
(start (make-state rs (get-state-number))))
(cache (cons 'state (get-key rs)) (lambda () start))
(let loop ((old-states (list start))
(new-states null)
(all-states (list start))
(cs (compute-chars (list start))))
(cond
((and (null? old-states) (null? new-states))
(make-dfa (get-state-number) (state-index start)
(sort (filter (lambda (x) (cdr x))
(map (lambda (state)
(cons (state-index state) (get-final (state-spec state))))
all-states))
(lambda (a b) (< (car a) (car b))))
(sort (hash-table-map transitions
(lambda (state trans)
(cons (state-index state)
(map (lambda (t)
(cons (car t)
(state-index (cdr t))))
trans))))
(lambda (a b) (< (car a) (car b))))))
((null? old-states)
(loop new-states null all-states (compute-chars new-states)))
((null? cs)
(loop (cdr old-states) new-states all-states (compute-chars (cdr old-states))))
(else
(let* ((state (car old-states))
(c (car cs))
(new-re (derive (state-spec state) (loc:get-integer c) cache)))
(cond
(new-re
(let* ((new-state? #f)
(new-state (cache (cons 'state (get-key new-re))
(lambda ()
(set! new-state? #t)
(make-state new-re (get-state-number)))))
(new-all-states (if new-state? (cons new-state all-states) all-states)))
(hash-table-put! transitions
state
(cons (cons c new-state)
(hash-table-get transitions state
(lambda () null))))
(cond
(new-state?
(loop old-states (cons new-state new-states) new-all-states (cdr cs)))
(else
(loop old-states new-states new-all-states (cdr cs))))))
(else (loop old-states new-states all-states (cdr cs))))))))))
(define (print-dfa x)
(printf "number of states: ~a\n" (dfa-num-states x))
(printf "start state: ~a\n" (dfa-start-state x))
(printf "final states: ~a\n" (map car (dfa-final-states/actions x)))
(for-each (lambda (trans)
(printf "state: ~a\n" (car trans))
(for-each (lambda (rule)
(printf " -~a-> ~a\n"
(is:integer-set-contents (car rule))
(cdr rule)))
(cdr trans)))
(dfa-transitions x)))
(define (build-test-dfa rs)
(let ((c (make-cache)))
(build-dfa (map (lambda (x) (cons (->re x c) 'action))
rs)
c)))
#|
(define t1 (build-test-dfa null))
(define t2 (build-test-dfa `(#\a)))
(define t3 (build-test-dfa `(#\a #\b)))
(define t4 (build-test-dfa `((repetition 0 +inf.0 #\a)
(repetition 0 +inf.0 (concatenation #\a #\b)))))
(define t5 (build-test-dfa `((concatenation (repetition 0 +inf.0 (union #\0 #\1)) #\1))))
(define t6 (build-test-dfa `((repetition 0 +inf.0 (repetition 0 +inf.0 #\a))
(repetition 0 +inf.0 (concatenation #\b (repetition 1 +inf.0 #\b))))))
(define t7 (build-test-dfa `((concatenation (repetition 0 +inf.0 #\a) (repetition 0 +inf.0 #\b)
(repetition 0 +inf.0 #\c) (repetition 0 +inf.0 #\d)
(repetition 0 +inf.0 #\e)))))
(define t8
(build-test-dfa `((concatenation (repetition 0 +inf.0 (union #\a #\b)) #\a (union #\a #\b)
(union #\a #\b) (union #\a #\b) (union #\a #\b)))))
(define t9 (build-test-dfa `((concatenation "/*"
(complement (concatenation (intersection) "*/" (intersection)))
"*/"))))
(define t11 (build-test-dfa `((complement "1"))))
(define t12 (build-test-dfa `((concatenation (intersection (concatenation (repetition 0 +inf.0 "a") "b")
(concatenation "a" (repetition 0 +inf.0 "b")))
"ab"))))
(define x (build-test-dfa `((union " " "\n" ",")
(concatenation (repetition 0 1 "-") (repetition 1 +inf.0 (char-range "0" "9")))
(concatenation "-" (repetition 1 +inf.0 "-"))
"["
"]")))
(define y (build-test-dfa
`((repetition 1 +inf.0
(union (concatenation "|" (repetition 0 +inf.0 (char-complement "|")) "|")
(concatenation "|" (repetition 0 +inf.0 (char-complement "|"))))))))
(define t13 (build-test-dfa `((intersection (concatenation (intersection) "111" (intersection))
(complement (union (concatenation (intersection) "01")
(repetition 1 +inf.0 "1")))))))
(define t14 (build-test-dfa `((complement "1"))))
|#
)

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save