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"
syntax/id-table)
@ -24,9 +25,9 @@
#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)))
(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)))
@ -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))
(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)))
(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))
;; 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)))
((parse #'(intersection #\1 (intersection "2") (intersection)))
(check-equal? (parse #'(intersection #\1 (intersection "2") (intersection))
null)
'(intersection #\1 (intersection "2") (intersection)))
((parse #'(complement (union #\1 #\2)))
(check-equal? (parse #'(complement (union #\1 #\2))
null)
'(complement (union #\1 #\2)))
((parse #'(concatenation "1" "2" (concatenation)))
(check-equal? (parse #'(concatenation "1" "2" (concatenation)) null)
'(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")))
(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"))))
)
; )

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")
(provide (all-defined))
(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
@ -56,12 +56,14 @@
(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)
(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))))
)

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
(require mzlib/list)
#lang racket
(provide (all-defined))
(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) ...)
@ -29,19 +31,23 @@
;; returned.
;; Xs are compared with equal?
(define (make-cache)
(let ((table (make-hash-table 'equal)))
(let ((table (make-hash)))
(lambda (key build)
(hash-table-get table key
(hash-ref table key
(lambda ()
(let ((new (build)))
(hash-table-put! table key new)
(hash-set! 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))
(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))
@ -54,13 +60,15 @@
(begin0
counter
(set! counter (add1 counter))))))
(test-block ((c (make-counter))
(d (make-counter)))
((c) 0)
((d) 0)
((c) 1)
((d) 1)
((c) 2))
(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)
@ -75,11 +83,12 @@
(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))
(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
@ -88,11 +97,12 @@
(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)
(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)))
((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) ->
;; (list-of X)
@ -104,13 +114,14 @@
((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)
(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