mbutterick
/
br-parser-tools
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

*** empty log message ***

Browse Source 
original commit: 1a0fce2c8e7268db0db111073503721e8fec5131
tokens
Scott Owens 21 years ago
parent 2b433a5596
commit 15a113415c
3 changed files with 118 additions and 89 deletions
Show Stats Download Patch File Download Diff File

16
collects/parser-tools/lex.ss
Unescape Escape View File

@ -3,11 +3,13 @@
;; Provides the syntax used to create lexers and the functions needed to ;; Provides the syntax used to create lexers and the functions needed to
;; create and use the buffer that the lexer reads from. See doc.txt. ;; create and use the buffer that the lexer reads from. See doc.txt.
(require-for-syntax "private-lex/util.ss" (require-for-syntax (lib "define.ss" "syntax")
"private-lex/util.ss"
"private-lex/actions.ss" "private-lex/actions.ss"
"private-lex/front.ss" "private-lex/front.ss"
"private-lex/unicode-chars.ss") "private-lex/unicode-chars.ss")
(require (lib "readerr.ss" "syntax") (require (lib "readerr.ss" "syntax")
(lib "cffi.ss" "compiler") (lib "cffi.ss" "compiler")
"private-lex/token.ss") "private-lex/token.ss")
@ -119,6 +121,18 @@
"Form should be (define-lex-abbrevs (name re) ...)" "Form should be (define-lex-abbrevs (name re) ...)"
stx)))) 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 (make-lex-trans body))))
(_
(raise-syntax-error
#f
"Form should be (define-lex-trans name transformer)"
stx))))
(define (get-next-state-helper char min max table) (define (get-next-state-helper char min max table)
(if (>= min max) (if (>= min max)

184
collects/parser-tools/private-lex/stx.ss
Unescape Escape View File

@ -1,97 +1,111 @@
(module stx mzscheme (module stx mzscheme
(require (lib "stx.ss" "syntax") (require "util.ss")
"util.ss")
(provide parse) (provide parse)
(define (repetition-error stx)
(raise-syntax-error
'regular-expression
"must be (repetition non-negative-exact-integer non-negative-exact-integer-or-+inf.0 re)"
stx))
(define (num-arg-err s expect given) (define (char-range-error stx)
(raise-syntax-error (raise-syntax-error
'regular-expression 'regular-expression
(format "operator expects ~a arguments, given ~a" expect given) "must be (char-range char-or-single-char-string char-or-single-char-string)"
s)) stx))
(define (char-range-arg c stx)
(cond
((char? c) (integer->char c))
((and (string? c (= string-length c 1)))
(integer->char (string-ref c 0)))
(else
(char-range-error stx))))
;; parse : syntax-object -> s-re (see re.ss) ;; parse : syntax-object -> s-re (see re.ss)
;; checks for errors and generates the plain s-exp form for s ;; checks for errors and generates the plain s-exp form for s
(define (parse s) (define (parse stx)
(let ((s-e (syntax-e s))) (syntax-case stx (repetition union intersection complement concatenation
(cond char-range char-complement)
((char? s-e) s-e) (_
((string? s-e) s-e) (identifier? stx)
((symbol? s-e) (let ((expansion (syntax-local-value stx (lambda () #f))))
(let ((expand (syntax-local-value s (lambda () #f)))) (unless (lex-abbrev? expansion)
(unless (lex-abbrev? expand) (raise-syntax-error 'regular-expression
(raise-syntax-error 'regular-expression "undefined abbreviation" s)) "undefined abbreviation"
(parse (lex-abbrev-abbrev expand)))) stx))
((stx-null? s) (parse (lex-abbrev-abbrev expand))))
(raise-syntax-error 'regular-expression "invalid regular expression" s)) (_
((stx-list? s) (or (char? (syntax-e stx)) (string? (syntax-e stx)))
(let* ((ar (stx->list (stx-cdr s))) (syntax-e stx))
(num-args (length ar))) ((repetition arg ...)
(case (syntax-e (stx-car s)) (let ((arg-list (syntax->list (syntax (arg ...)))))
((epsilon) '(epsilon)) (unless (= 3 (length arg-list))
((*) (repetition-error stx))
(unless (= num-args 1) (let ((lo-val (car arg-list))
(num-arg-err s 1 num-args)) (hi-val (cadr arg-list))
`(* ,(parse (car ar)))) (re (caddr arg-list)))
((+) (unless (and (exact? lo-val) (integer? lo-val) (> lo-val 0)
(unless (= num-args 1) (or (and (exact? hi-val) (integer? hi-val) (> hi-val 0))
(num-arg-err s 1 num-args)) (eq? hi-val +inf.0)))
`(+ ,(parse (car ar)))) (repetition-error stx))
((?) `(repetition ,lo-val ,hi-val ,(parse re)))))
(unless (= num-args 1) ((union re ...)
(num-arg-err s 1 num-args)) `(union ,@(map parse (syntax->list (syntax (re ...))))))
`(? ,(parse (car ar)))) ((intersection re ...)
((~) `(intersection ,@(map parse (syntax->list (syntax (re ...))))))
(unless (= num-args 1) ((complement re ...)
(num-arg-err s 1 num-args)) (let ((re-list (syntax->list (syntax (re ...)))))
`(~ ,(parse (car ar)))) (unless (= 1 (length re-list))
((:) `(: ,@(map parse ar))) (raise-syntax-error 'regular-expression
((&) `(& ,@(map parse ar))) "must be (complement re)"
((@) `(@ ,@(map parse ar))) stx))
((-) `(complement ,(parse (car re-list)))))
(unless (= num-args 2) ((concatenation re ...)
(num-arg-err s 2 num-args)) `(concatenation ,@(map parse (syntax->list (syntax (re ...))))))
(let ((c1 (parse (car ar))) ((char-range arg ...)
(c2 (parse (cadr ar)))) (let ((arg-list (syntax->list (syntax (arg ...)))))
(if (and (or (char? c1) (and (string? c1) (= 1 (string-length c1)))) (unless (= 2 (length arg-list))
(or (char? c2) (and (string? c2) (= 1 (string-length c2))))) (char-range-error stx))
(let ((i1 (char->integer (if (char? c1) c1 (string-ref c1 0)))) (let ((i1 (char-range-arg (car arg-list) stx))
(i2 (char->integer (if (char? c2) c2 (string-ref c2 0))))) (i2 (char-range-arg (cadr arg-list) stx)))
(if (<= i1 i2) (if (<= i1 i2)
`(- ,c1 ,c2) `(char-range ,(integer->char i1) ,(integer->char i2))
(raise-syntax-error (raise-syntax-error
'regular-expression 'regular-expression
(format "first argument ~a does not preceed second argument ~a" (format "first argument ~a does not preceed second argument ~a"
c1 c2) (car arg-list) (cdr arg-list))
s))) stx)))))
(raise-syntax-error ((char-complement arg ...)
'regular-expression (let ((arg-list (syntax->list (syntax (arg ...)))))
(format "expects single character arguments, given ~a and ~a" (unless (= 1 (length arg-list))
(syntax-object->datum (car ar)) (raise-syntax-error
(syntax-object->datum (cadr ar))) 'regular-expression
s)))) "must be (char-complement char-set-re)"
((^) stx))
(let ((res (map parse ar))) (let ((parsed (parse (car arg-list))))
(if (not (andmap pure-char? res)) (unless (pure-char? parsed)
(raise-syntax-error (raise-syntax-error
'regular-expression 'regular-expression
(format "must be (char-complement char-set-re)"
"expects single character or character range arguments, given ~a" stx))
(map syntax-object->datum ar)) `(char-complement ,parsed))))
s)) ((op form ...)
`(^ ,@res))) (identifier? (syntax op))
(else (let ((expansion (syntax-local-value (syntax op) (lambda () #f))))
(raise-syntax-error (unless (lex-trans? expansion)
'regular-expression (raise-syntax-error 'regular-expression
"invalid operator" "undefined operator in"
s))))) stx))
(else (parse ((lex-trans-f expansion) stx))))
(raise-syntax-error (_
'regular-expression (raise-syntax-error
"invalid regular expression" 'regular-expression
s))))) "must be char, string, identifier, or (op args ...)"
stx))))
(define (pure-char? s-re) (define (pure-char? s-re)
(cond (cond
@ -100,8 +114,8 @@
((list? s-re) ((list? s-re)
(let ((op (car s-re))) (let ((op (car s-re)))
(case op (case op
((: ^) (andmap pure-char? (cdr s-re))) ((union intersection) (andmap pure-char? (cdr s-re)))
((-) #t) ((char-range char-complement) #t)
(else #f)))) (else #f))))
(else #f))) (else #f)))

1
collects/parser-tools/private-lex/util.ss
Unescape Escape View File

@ -4,6 +4,7 @@
(provide (all-defined)) (provide (all-defined))
(define-struct lex-abbrev (abbrev)) (define-struct lex-abbrev (abbrev))
(define-struct lex-trans (f))
#;(define-syntax test-block #;(define-syntax test-block
(syntax-rules () (syntax-rules ()

Write Preview
Loading…
Cancel
Save