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

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

@ -1,37 +1,38 @@
(module stx mzscheme #lang racket
(require "util.rkt"
syntax/id-table)
(provide parse) (require "util.rkt"
syntax/id-table)
(define (bad-args stx num) (provide parse)
(raise-syntax-error
#f
(format "incorrect number of arguments (should have ~a)" num)
stx))
;; char-range-arg: syntax-object syntax-object -> nat (define (bad-args stx num)
;; If c contains is a character or length 1 string, returns the integer (raise-syntax-error
;; for the character. Otherwise raises a syntax error. #f
(define (char-range-arg stx containing-stx) (format "incorrect number of arguments (should have ~a)" num)
(let ((c (syntax-e stx))) 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)))
(define orig-insp (variable-reference->module-declaration-inspector ;; char-range-arg: syntax-object syntax-object -> nat
(#%variable-reference))) ;; If c contains is a character or length 1 string, returns the integer
(define (disarm stx) ;; for the character. Otherwise raises a syntax error.
(syntax-disarm stx orig-insp)) (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) ;; 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 ;; 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)))) (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)
'(union #\1 (union "2") (union))) (check-equal? (char-set? '(repetition 1 2 #\1)) #f)
((parse #'(intersection #\1 (intersection "2") (intersection))) (check-equal? (char-set? '(repetition 1 1 "12")) #f)
'(intersection #\1 (intersection "2") (intersection))) (check-equal? (char-set? '(repetition 1 1 "1")) #t)
((parse #'(complement (union #\1 #\2))) (check-equal? (char-set? '(union "1" "2" "3")) #t)
'(complement (union #\1 #\2))) (check-equal? (char-set? '(union "1" "" "3")) #f)
((parse #'(concatenation "1" "2" (concatenation))) (check-equal? (char-set? '(intersection "1" "2" (union "3" "4"))) #t)
'(concatenation "1" "2" (concatenation))) (check-equal? (char-set? '(intersection "1" "")) #f)
((parse #'(char-range "1" #\1)) '(char-range #\1 #\1)) (check-equal? (char-set? '(complement "1")) #f)
((parse #'(char-range #\1 "1")) '(char-range #\1 #\1)) (check-equal? (char-set? '(concatenation "1" "2")) #f)
((parse #'(char-range "1" "3")) '(char-range #\1 #\3)) (check-equal? (char-set? '(concatenation "" "2")) #f)
((parse #'(char-complement (union "1" "2"))) (check-equal? (char-set? '(concatenation "1")) #t)
'(char-complement (union "1" "2")))) (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)))
(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"))))
; )

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

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

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