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

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

@ -1,4 +1,5 @@
(module stx mzscheme #lang racket
(require "util.rkt" (require "util.rkt"
syntax/id-table) syntax/id-table)
@ -24,9 +25,9 @@
#f #f
"not a char or single-char string" "not a char or single-char string"
containing-stx stx))))) containing-stx stx)))))
(test-block () (module+ test
((char-range-arg #'#\1 #'here) (char->integer #\1)) (check-equal? (char-range-arg #'#\1 #'here) (char->integer #\1))
((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 (define orig-insp (variable-reference->module-declaration-inspector
(#%variable-reference))) (#%variable-reference)))
@ -170,41 +171,50 @@
(and (= 2 (length s-re)) (char-set? (cadr s-re)))) (and (= 2 (length s-re)) (char-set? (cadr s-re))))
(else #f)))) (else #f))))
(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))
(test-block () (module+ test
((parse #'#\a) #\a) (require rackunit))
((parse #'"1") "1") (module+ test
((parse #'(repetition 1 1 #\1)) '(repetition 1 1 #\1)) (check-equal? (char-set? #\a) #t)
((parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1)) (check-equal? (char-set? "12") #f)
((parse #'(union #\1 (union "2") (union))) (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))
;; 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))) '(union #\1 (union "2") (union)))
((parse #'(intersection #\1 (intersection "2") (intersection))) (check-equal? (parse #'(intersection #\1 (intersection "2") (intersection))
null)
'(intersection #\1 (intersection "2") (intersection))) '(intersection #\1 (intersection "2") (intersection)))
((parse #'(complement (union #\1 #\2))) (check-equal? (parse #'(complement (union #\1 #\2))
null)
'(complement (union #\1 #\2))) '(complement (union #\1 #\2)))
((parse #'(concatenation "1" "2" (concatenation))) (check-equal? (parse #'(concatenation "1" "2" (concatenation)) null)
'(concatenation "1" "2" (concatenation))) '(concatenation "1" "2" (concatenation)))
((parse #'(char-range "1" #\1)) '(char-range #\1 #\1)) (check-equal? (parse #'(char-range "1" #\1) null) '(char-range #\1 #\1))
((parse #'(char-range #\1 "1")) '(char-range #\1 #\1)) (check-equal? (parse #'(char-range #\1 "1") null) '(char-range #\1 #\1))
((parse #'(char-range "1" "3")) '(char-range #\1 #\3)) (check-equal? (parse #'(char-range "1" "3") null) '(char-range #\1 #\3))
((parse #'(char-complement (union "1" "2"))) (check-equal? (parse #'(char-complement (union "1" "2")) null)
'(char-complement (union "1" "2")))) '(char-complement (union "1" "2"))))
) ; )

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

@ -1,12 +1,12 @@
(module unicode-chars mzscheme #lang racket
(require "util.rkt") (require "util.rkt")
(provide (all-defined)) (provide (all-defined-out))
;; mapped-chars : (listof (list nat nat bool)) ;; mapped-chars : (listof (list nat nat bool))
(define mapped-chars (make-known-char-range-list)) (define mapped-chars (make-known-char-range-list))
;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat)) ;; get-chars-for-x : (nat -> bool) (listof (list nat nat bool)) -> (listof (cons nat nat))
(define (get-chars-for char-x? mapped-chars) (define (get-chars-for char-x? mapped-chars)
(cond (cond
@ -56,12 +56,14 @@
(test-block () (module+ test
((get-chars-for odd? '()) '()) (require rackunit)
((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 odd? '()) '())
((get-chars-for (lambda (x) (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))) (odd? (quotient x 10)))
'((1 5 #t) (17 19 #t) (21 51 #f))) '((1 5 #t) (17 19 #t) (21 51 #f)))
'((17 . 19) (30 . 39) (50 . 51)))) '((17 . 19) (30 . 39) (50 . 51))))
)

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

@ -1,13 +1,15 @@
(module util mzscheme #lang racket
(require mzlib/list)
(provide (all-defined)) (provide (all-defined-out))
(define max-char-num #x10FFFF) (define max-char-num #x10FFFF)
(define-struct lex-abbrev (get-abbrev)) (define-struct lex-abbrev (get-abbrev))
(define-struct lex-trans (f)) (define-struct lex-trans (f))
(module+ test
(require rackunit))
#;(define-syntax test-block #;(define-syntax test-block
(syntax-rules () (syntax-rules ()
((_ defs (code right-ans) ...) ((_ defs (code right-ans) ...)
@ -29,19 +31,23 @@
;; returned. ;; returned.
;; Xs are compared with equal? ;; Xs are compared with equal?
(define (make-cache) (define (make-cache)
(let ((table (make-hash-table 'equal))) (let ((table (make-hash)))
(lambda (key build) (lambda (key build)
(hash-table-get table key (hash-ref table key
(lambda () (lambda ()
(let ((new (build))) (let ((new (build)))
(hash-table-put! table key new) (hash-set! table key new)
new)))))) new))))))
(test-block ((cache (make-cache)))
((cache '(s 1 2) (lambda () 9)) 9) (module+ test
((cache '(s 2 1) (lambda () 8)) 8) (define cache (make-cache))
((cache '(s 1 2) (lambda () 1)) 9) (check-equal? (cache '(s 1 2) (lambda () 9)) 9)
((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 22)) 22) (check-equal? (cache '(s 2 1) (lambda () 8)) 8)
((cache (cons 's (cons 0 (cons +inf.0 10))) (lambda () 1)) 22)) (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))
@ -54,13 +60,15 @@
(begin0 (begin0
counter counter
(set! counter (add1 counter)))))) (set! counter (add1 counter))))))
(test-block ((c (make-counter))
(d (make-counter))) (module+ test
((c) 0) (define c (make-counter))
((d) 0) (define d (make-counter))
((c) 1) (check-equal? (c) 0)
((d) 1) (check-equal? (d) 0)
((c) 2)) (check-equal? (c) 1)
(check-equal? (d) 1)
(check-equal? (c) 2))
;; remove-dups : (list-of X) (X -> number) -> (list-of X) ;; remove-dups : (list-of X) (X -> number) -> (list-of X)
@ -75,11 +83,12 @@
(else (else
(remove-dups (cdr l) index (cons (car l) acc))))) (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))
(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) ;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X)
;; Sorts l according to index and removes the entries with duplicate ;; Sorts l according to index and removes the entries with duplicate
@ -88,11 +97,12 @@
(let ((ordered (sort l (lambda (a b) (< (index a) (index b)))))) (let ((ordered (sort l (lambda (a b) (< (index a) (index b))))))
(remove-dups ordered index null))) (remove-dups ordered index null)))
(test-block () (module+ test
((do-simple-equiv '((2 2) (1 4) (1 2) (100 4) (1 3) (0 5)) cadr) (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))) '((2 2) (1 3) (1 4) (0 5)))
((do-simple-equiv null error) null)) (check-equal? (do-simple-equiv null error) null))
;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) -> ;; replace : (list-of X) (X -> bool) (X -> (list-of X)) (list-of X) ->
;; (list-of X) ;; (list-of X)
@ -104,13 +114,14 @@
((pred? (car l)) (replace (cdr l) pred? get (append (get (car 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))))) (else (replace (cdr l) pred? get (cons (car l) acc)))))
(test-block ()
((replace null void (lambda () (list 1)) null) null) (module+ test
((replace '(1 2 3 4 3 5) (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) (= x 3))
(lambda (x) (list 1 2 3)) (lambda (x) (list 1 2 3))
null) null)
'(5 1 2 3 4 1 2 3 2 1))) '(5 1 2 3 4 1 2 3 2 1)))
)

Write Preview
Loading…
Cancel
Save