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

rackety

Browse Source 
original commit: ed3bf9a3c0f839fd25375439be170d46d5a49e09
tokens
John Clements 12 years ago
parent ab0f7537de
commit f59e16a02e
3 changed files with 256 additions and 233 deletions
Show Stats Download Patch File Download Diff File

148
pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt
Unescape Escape View File

@ -1,37 +1,38 @@
(module stx mzscheme
(require "util.rkt"
syntax/id-table)
(provide parse)
#lang racket
(define (bad-args stx num)
(raise-syntax-error
#f
(format "incorrect number of arguments (should have ~a)" num)
stx))
;; char-range-arg: syntax-object syntax-object -> nat
;; If c contains is a character or length 1 string, returns the integer
;; for the character. Otherwise raises a syntax error.
(define (char-range-arg stx containing-stx)
(let ((c (syntax-e stx)))
(cond
((char? c) (char->integer c))
((and (string? c) (= (string-length c) 1))
(char->integer (string-ref c 0)))
(else
(raise-syntax-error
#f
"not a char or single-char string"
containing-stx stx)))))
(test-block ()
((char-range-arg #'#\1 #'here) (char->integer #\1))
((char-range-arg #'"1" #'here) (char->integer #\1)))
(require "util.rkt"
syntax/id-table)
(provide parse)
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm stx)
(syntax-disarm stx orig-insp))
(define (bad-args stx num)
(raise-syntax-error
#f
(format "incorrect number of arguments (should have ~a)" num)
stx))
;; char-range-arg: syntax-object syntax-object -> nat
;; If c contains is a character or length 1 string, returns the integer
;; for the character. Otherwise raises a syntax error.
(define (char-range-arg stx containing-stx)
(let ((c (syntax-e stx)))
(cond
((char? c) (char->integer c))
((and (string? c) (= (string-length c) 1))
(char->integer (string-ref c 0)))
(else
(raise-syntax-error
#f
"not a char or single-char string"
containing-stx stx)))))
(module+ test
(check-equal? (char-range-arg #'#\1 #'here) (char->integer #\1))
(check-equal? (char-range-arg #'"1" #'here) (char->integer #\1)))
(define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference)))
(define (disarm stx)
(syntax-disarm stx orig-insp))
;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt)
;; checks for errors and generates the plain s-exp form for s
@ -170,41 +171,50 @@
(and (= 2 (length s-re)) (char-set? (cadr s-re))))
(else #f))))
(else #f)))
(test-block ()
((char-set? #\a) #t)
((char-set? "12") #f)
((char-set? "1") #t)
((char-set? '(repetition 1 2 #\1)) #f)
((char-set? '(repetition 1 1 "12")) #f)
((char-set? '(repetition 1 1 "1")) #t)
((char-set? '(union "1" "2" "3")) #t)
((char-set? '(union "1" "" "3")) #f)
((char-set? '(intersection "1" "2" (union "3" "4"))) #t)
((char-set? '(intersection "1" "")) #f)
((char-set? '(complement "1")) #f)
((char-set? '(concatenation "1" "2")) #f)
((char-set? '(concatenation "" "2")) #f)
((char-set? '(concatenation "1")) #t)
((char-set? '(concatenation "12")) #f)
((char-set? '(char-range #\1 #\2)) #t)
((char-set? '(char-complement #\1)) #t))
(module+ test
(require rackunit))
(module+ test
(check-equal? (char-set? #\a) #t)
(check-equal? (char-set? "12") #f)
(check-equal? (char-set? "1") #t)
(check-equal? (char-set? '(repetition 1 2 #\1)) #f)
(check-equal? (char-set? '(repetition 1 1 "12")) #f)
(check-equal? (char-set? '(repetition 1 1 "1")) #t)
(check-equal? (char-set? '(union "1" "2" "3")) #t)
(check-equal? (char-set? '(union "1" "" "3")) #f)
(check-equal? (char-set? '(intersection "1" "2" (union "3" "4"))) #t)
(check-equal? (char-set? '(intersection "1" "")) #f)
(check-equal? (char-set? '(complement "1")) #f)
(check-equal? (char-set? '(concatenation "1" "2")) #f)
(check-equal? (char-set? '(concatenation "" "2")) #f)
(check-equal? (char-set? '(concatenation "1")) #t)
(check-equal? (char-set? '(concatenation "12")) #f)
(check-equal? (char-set? '(char-range #\1 #\2)) #t)
(check-equal? (char-set? '(char-complement #\1)) #t))
(test-block ()
((parse #'#\a) #\a)
((parse #'"1") "1")
((parse #'(repetition 1 1 #\1)) '(repetition 1 1 #\1))
((parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1))
((parse #'(union #\1 (union "2") (union)))
'(union #\1 (union "2") (union)))
((parse #'(intersection #\1 (intersection "2") (intersection)))
'(intersection #\1 (intersection "2") (intersection)))
((parse #'(complement (union #\1 #\2)))
'(complement (union #\1 #\2)))
((parse #'(concatenation "1" "2" (concatenation)))
'(concatenation "1" "2" (concatenation)))
((parse #'(char-range "1" #\1)) '(char-range #\1 #\1))
((parse #'(char-range #\1 "1")) '(char-range #\1 #\1))
((parse #'(char-range "1" "3")) '(char-range #\1 #\3))
((parse #'(char-complement (union "1" "2")))
'(char-complement (union "1" "2"))))
)
;; yikes... these test cases all have the wrong arity, now.
;; and by "now", I mean it's been broken since before we
;; moved to git.
(module+ test
(check-equal? (parse #'#\a null) #\a)
(check-equal? (parse #'"1" null) "1")
(check-equal? (parse #'(repetition 1 1 #\1) null)
'(repetition 1 1 #\1))
(check-equal? (parse #'(repetition 0 +inf.0 #\1) null) '(repetition 0 +inf.0 #\1))
(check-equal? (parse #'(union #\1 (union "2") (union)) null)
'(union #\1 (union "2") (union)))
(check-equal? (parse #'(intersection #\1 (intersection "2") (intersection))
null)
'(intersection #\1 (intersection "2") (intersection)))
(check-equal? (parse #'(complement (union #\1 #\2))
null)
'(complement (union #\1 #\2)))
(check-equal? (parse #'(concatenation "1" "2" (concatenation)) null)
'(concatenation "1" "2" (concatenation)))
(check-equal? (parse #'(char-range "1" #\1) null) '(char-range #\1 #\1))
(check-equal? (parse #'(char-range #\1 "1") null) '(char-range #\1 #\1))
(check-equal? (parse #'(char-range "1" "3") null) '(char-range #\1 #\3))
(check-equal? (parse #'(char-complement (union "1" "2")) null)
'(char-complement (union "1" "2"))))
; )

126
pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt
Unescape Escape View File

@ -1,67 +1,69 @@
(module unicode-chars mzscheme
(require "util.rkt")
(provide (all-defined))
;; mapped-chars : (listof (list nat nat bool))
(define mapped-chars (make-known-char-range-list))
;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat))
(define (get-chars-for char-x? mapped-chars)
(cond
((null? mapped-chars) null)
(else
(let* ((range (car mapped-chars))
(low (car range))
(high (cadr range))
(x (char-x? low)))
(cond
((caddr range)
(if x
(cons (cons low high)
(get-chars-for char-x? (cdr mapped-chars)))
(get-chars-for char-x? (cdr mapped-chars))))
(else
(let loop ((range-start low)
(i (car range))
(parity x))
(cond
((> i high)
(if parity
(cons (cons range-start high) (get-chars-for char-x? (cdr mapped-chars)))
(get-chars-for char-x? (cdr mapped-chars))))
((eq? parity (char-x? i))
(loop range-start (add1 i) parity))
(parity
(cons (cons range-start (sub1 i)) (loop i (add1 i) #f)))
(else
(loop i (add1 i) #t))))))))))
#lang racket
(define (compute-ranges x?)
(delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars)))
(define alphabetic-ranges (compute-ranges char-alphabetic?)) ;; 325
(define lower-case-ranges (compute-ranges char-lower-case?)) ;; 405
(define upper-case-ranges (compute-ranges char-upper-case?)) ;; 380
(define title-case-ranges (compute-ranges char-title-case?)) ;; 10
(define numeric-ranges (compute-ranges char-numeric?)) ;; 47
(define symbolic-ranges (compute-ranges char-symbolic?)) ;; 153
(define punctuation-ranges (compute-ranges char-punctuation?)) ;; 86
(define graphic-ranges (compute-ranges char-graphic?)) ;; 401
(define whitespace-ranges (compute-ranges char-whitespace?)) ;; 10
(define blank-ranges (compute-ranges char-blank?)) ;; 9
#;(define hexadecimal-ranges (compute-ranges char-hexadecimal?))
(define iso-control-ranges (compute-ranges char-iso-control?)) ;; 2
(require "util.rkt")
(provide (all-defined-out))
;; mapped-chars : (listof (list nat nat bool))
(define mapped-chars (make-known-char-range-list))
;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat))
(define (get-chars-for char-x? mapped-chars)
(cond
((null? mapped-chars) null)
(else
(let* ((range (car mapped-chars))
(low (car range))
(high (cadr range))
(x (char-x? low)))
(cond
((caddr range)
(if x
(cons (cons low high)
(get-chars-for char-x? (cdr mapped-chars)))
(get-chars-for char-x? (cdr mapped-chars))))
(else
(let loop ((range-start low)
(i (car range))
(parity x))
(cond
((> i high)
(if parity
(cons (cons range-start high) (get-chars-for char-x? (cdr mapped-chars)))
(get-chars-for char-x? (cdr mapped-chars))))
((eq? parity (char-x? i))
(loop range-start (add1 i) parity))
(parity
(cons (cons range-start (sub1 i)) (loop i (add1 i) #f)))
(else
(loop i (add1 i) #t))))))))))
(test-block ()
((get-chars-for odd? '()) '())
((get-chars-for odd? '((1 4 #f) (8 13 #f))) '((1 . 1) (3 . 3) (9 . 9) (11 . 11) (13 . 13)))
((get-chars-for (lambda (x)
(odd? (quotient x 10)))
'((1 5 #t) (17 19 #t) (21 51 #f)))
'((17 . 19) (30 . 39) (50 . 51))))
(define (compute-ranges x?)
(delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars)))
(define alphabetic-ranges (compute-ranges char-alphabetic?)) ;; 325
(define lower-case-ranges (compute-ranges char-lower-case?)) ;; 405
(define upper-case-ranges (compute-ranges char-upper-case?)) ;; 380
(define title-case-ranges (compute-ranges char-title-case?)) ;; 10
(define numeric-ranges (compute-ranges char-numeric?)) ;; 47
(define symbolic-ranges (compute-ranges char-symbolic?)) ;; 153
(define punctuation-ranges (compute-ranges char-punctuation?)) ;; 86
(define graphic-ranges (compute-ranges char-graphic?)) ;; 401
(define whitespace-ranges (compute-ranges char-whitespace?)) ;; 10
(define blank-ranges (compute-ranges char-blank?)) ;; 9
#;(define hexadecimal-ranges (compute-ranges char-hexadecimal?))
(define iso-control-ranges (compute-ranges char-iso-control?)) ;; 2
(module+ test
(require rackunit)
(check-equal? (get-chars-for odd? '()) '())
(check-equal? (get-chars-for odd? '((1 4 #f) (8 13 #f)))
'((1 . 1) (3 . 3) (9 . 9) (11 . 11) (13 . 13)))
(check-equal? (get-chars-for (lambda (x)
(odd? (quotient x 10)))
'((1 5 #t) (17 19 #t) (21 51 #f)))
'((17 . 19) (30 . 39) (50 . 51))))
)

215
pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt
Unescape Escape View File

@ -1,14 +1,16 @@
(module util mzscheme
(require mzlib/list)
(provide (all-defined))
#lang racket
(define max-char-num #x10FFFF)
(define-struct lex-abbrev (get-abbrev))
(define-struct lex-trans (f))
#;(define-syntax test-block
(provide (all-defined-out))
(define max-char-num #x10FFFF)
(define-struct lex-abbrev (get-abbrev))
(define-struct lex-trans (f))
(module+ test
(require rackunit))
#;(define-syntax test-block
(syntax-rules ()
((_ defs (code right-ans) ...)
(let* defs
@ -17,100 +19,109 @@
(printf "Test failed: ~e gave ~e. Expected ~e\n"
'code real-ans 'right-ans))) ...))))
(define-syntax test-block
(syntax-rules ()
((_ x ...) (void))))
;; A cache is (X ( -> Y) -> Y)
;; make-cache : -> cache
;; table map Xs to Ys. If key is mapped, its value is returned.
;; Otherwise, build is invoked and its result is placed in the table and
;; returned.
;; Xs are compared with equal?
(define (make-cache)
(let ((table (make-hash-table 'equal)))
(lambda (key build)
(hash-table-get table key
(lambda ()
(let ((new (build)))
(hash-table-put! table key new)
new))))))
(test-block ((cache (make-cache)))
((cache '(s 1 2) (lambda () 9)) 9)
((cache '(s 2 1) (lambda () 8)) 8)
((cache '(s 1 2) (lambda () 1)) 9)
((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 22)) 22)
((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 1)) 22))
(define-syntax test-block
(syntax-rules ()
((_ x ...) (void))))
;; make-counter : -> -> nat
;; makes a function that returns a higher number by 1, each time
;; it is called.
(define (make-counter)
(let ((counter 0))
(lambda ()
(begin0
counter
(set! counter (add1 counter))))))
(test-block ((c (make-counter))
(d (make-counter)))
((c) 0)
((d) 0)
((c) 1)
((d) 1)
((c) 2))
;; remove-dups : (list-of X) (X -> number) -> (list-of X)
;; removes the entries from l that have the same index as a
;; previous entry. l must be grouped by indexes.
(define (remove-dups l index acc)
(cond
((null? l) (reverse acc))
((null? acc) (remove-dups (cdr l) index (cons (car l) acc)))
((= (index (car acc)) (index (car l)))
(remove-dups (cdr l) index acc))
(else
(remove-dups (cdr l) index (cons (car l) acc)))))
(test-block ()
((remove-dups '((1 2) (2 2) (1 3) (1 4) (100 4) (0 5)) cadr null)
'((1 2) (1 3) (1 4) (0 5)))
((remove-dups null error null) null))
;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X)
;; Sorts l according to index and removes the entries with duplicate
;; indexes.
(define (do-simple-equiv l index)
(let ((ordered (sort l (lambda (a b) (< (index a) (index b))))))
(remove-dups ordered index null)))
(test-block ()
((do-simple-equiv '((2 2) (1 4) (1 2) (100 4) (1 3) (0 5)) cadr)
'((2 2) (1 3) (1 4) (0 5)))
((do-simple-equiv null error) null))
;; A cache is (X ( -> Y) -> Y)
;; make-cache : -> cache
;; table map Xs to Ys. If key is mapped, its value is returned.
;; Otherwise, build is invoked and its result is placed in the table and
;; returned.
;; Xs are compared with equal?
(define (make-cache)
(let ((table (make-hash)))
(lambda (key build)
(hash-ref table key
(lambda ()
(let ((new (build)))
(hash-set! table key new)
new))))))
(module+ test
(define cache (make-cache))
(check-equal? (cache '(s 1 2) (lambda () 9)) 9)
(check-equal? (cache '(s 2 1) (lambda () 8)) 8)
(check-equal? (cache '(s 1 2) (lambda () 1)) 9)
(check-equal? (cache (cons 's (cons 0 (cons +inf.0 10)))
(lambda () 22)) 22)
(check-equal? (cache (cons 's (cons 0 (cons +inf.0 10)))
(lambda () 1)) 22))
;; make-counter : -> -> nat
;; makes a function that returns a higher number by 1, each time
;; it is called.
(define (make-counter)
(let ((counter 0))
(lambda ()
(begin0
counter
(set! counter (add1 counter))))))
(module+ test
(define c (make-counter))
(define d (make-counter))
(check-equal? (c) 0)
(check-equal? (d) 0)
(check-equal? (c) 1)
(check-equal? (d) 1)
(check-equal? (c) 2))
;; remove-dups : (list-of X) (X -> number) -> (list-of X)
;; removes the entries from l that have the same index as a
;; previous entry. l must be grouped by indexes.
(define (remove-dups l index acc)
(cond
((null? l) (reverse acc))
((null? acc) (remove-dups (cdr l) index (cons (car l) acc)))
((= (index (car acc)) (index (car l)))
(remove-dups (cdr l) index acc))
(else
(remove-dups (cdr l) index (cons (car l) acc)))))
(module+ test
(check-equal? (remove-dups '((1 2) (2 2) (1 3) (1 4)
(100 4) (0 5)) cadr null)
'((1 2) (1 3) (1 4) (0 5)))
(check-equal? (remove-dups null error null) null))
;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X)
;; Sorts l according to index and removes the entries with duplicate
;; indexes.
(define (do-simple-equiv l index)
(let ((ordered (sort l (lambda (a b) (< (index a) (index b))))))
(remove-dups ordered index null)))
(module+ test
(check-equal? (do-simple-equiv '((2 2) (1 4) (1 2)
(100 4) (1 3) (0 5))
cadr)
'((2 2) (1 3) (1 4) (0 5)))
(check-equal? (do-simple-equiv null error) null))
;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) ->
;; (list-of X)
;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
;; list.
(define (replace l pred? get acc)
(cond
((null? l) acc)
((pred? (car l)) (replace (cdr l) pred? get (append (get (car l)) acc)))
(else (replace (cdr l) pred? get (cons (car l) acc)))))
;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) ->
;; (list-of X)
;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
;; list.
(define (replace l pred? get acc)
(cond
((null? l) acc)
((pred? (car l)) (replace (cdr l) pred? get (append (get (car l)) acc)))
(else (replace (cdr l) pred? get (cons (car l) acc)))))
(test-block ()
((replace null void (lambda () (list 1)) null) null)
((replace '(1 2 3 4 3 5)
(lambda (x) (= x 3))
(lambda (x) (list 1 2 3))
null)
'(5 1 2 3 4 1 2 3 2 1)))
(module+ test
(check-equal? (replace null void (lambda () (list 1)) null) null)
(check-equal? (replace '(1 2 3 4 3 5)
(lambda (x) (= x 3))
(lambda (x) (list 1 2 3))
null)
'(5 1 2 3 4 1 2 3 2 1)))
)

Write Preview
Loading…
Cancel
Save