rackety

original commit: ed3bf9a3c0f839fd25375439be170d46d5a49e09

pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/stx.rkt

@@ -1,37 +1,38 @@
-(module stx mzscheme
+#lang racket
-  (require "util.rkt"
-           syntax/id-table)
-  
-  (provide parse)
 
-  (define (bad-args stx num)
+(require "util.rkt"
-    (raise-syntax-error
+         syntax/id-table)
-     #f
+
-     (format "incorrect number of arguments (should have ~a)" num)
+(provide parse)
-     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)))
   
-  (define orig-insp (variable-reference->module-declaration-inspector
+(define (bad-args stx num)
-                     (#%variable-reference)))
+  (raise-syntax-error
-  (define (disarm stx)
+   #f
-    (syntax-disarm stx orig-insp))
+   (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)
+  (module+ test
-              ((char-set? "12") #f)
+    (require rackunit))
-              ((char-set? "1") #t)
+  (module+ test
-              ((char-set? '(repetition 1 2 #\1)) #f)
+    (check-equal? (char-set? #\a) #t)
-              ((char-set? '(repetition 1 1 "12")) #f)
+    (check-equal? (char-set? "12") #f)
-              ((char-set? '(repetition 1 1 "1")) #t)
+    (check-equal? (char-set? "1") #t)
-              ((char-set? '(union "1" "2" "3")) #t)
+    (check-equal? (char-set? '(repetition 1 2 #\1)) #f)
-              ((char-set? '(union "1" "" "3")) #f)
+    (check-equal? (char-set? '(repetition 1 1 "12")) #f)
-              ((char-set? '(intersection "1" "2" (union "3" "4"))) #t)
+    (check-equal? (char-set? '(repetition 1 1 "1")) #t)
-              ((char-set? '(intersection "1" "")) #f)
+    (check-equal? (char-set? '(union "1" "2" "3")) #t)
-              ((char-set? '(complement "1")) #f)
+    (check-equal? (char-set? '(union "1" "" "3")) #f)
-              ((char-set? '(concatenation "1" "2")) #f)
+    (check-equal? (char-set? '(intersection "1" "2" (union "3" "4"))) #t)
-              ((char-set? '(concatenation "" "2")) #f)
+    (check-equal? (char-set? '(intersection "1" "")) #f)
-              ((char-set? '(concatenation "1")) #t)
+    (check-equal? (char-set? '(complement "1")) #f)
-              ((char-set? '(concatenation "12")) #f)
+    (check-equal? (char-set? '(concatenation "1" "2")) #f)
-              ((char-set? '(char-range #\1 #\2)) #t)
+    (check-equal? (char-set? '(concatenation "" "2")) #f)
-              ((char-set? '(char-complement #\1)) #t))
+    (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 ()
+  ;; yikes... these test cases all have the wrong arity, now.
-              ((parse #'#\a) #\a)
+  ;; and by "now", I mean it's been broken since before we 
-              ((parse #'"1") "1")
+  ;; moved to git. 
-              ((parse #'(repetition 1 1 #\1)) '(repetition 1 1 #\1))
+  (module+ test
-              ((parse #'(repetition 0 +inf.0 #\1)) '(repetition 0 +inf.0 #\1))
+    (check-equal? (parse #'#\a null) #\a)
-              ((parse #'(union #\1 (union "2") (union)))
+    (check-equal? (parse #'"1" null) "1")
-               '(union #\1 (union "2") (union)))
+    (check-equal? (parse #'(repetition 1 1 #\1) null)
-              ((parse #'(intersection #\1 (intersection "2") (intersection)))
+     '(repetition 1 1 #\1))
-               '(intersection #\1 (intersection "2") (intersection)))
+    (check-equal? (parse #'(repetition 0 +inf.0 #\1) null) '(repetition 0 +inf.0 #\1))
-              ((parse #'(complement (union #\1 #\2)))
+    (check-equal? (parse #'(union #\1 (union "2") (union)) null)
-               '(complement (union #\1 #\2)))
+     '(union #\1 (union "2") (union)))
-              ((parse #'(concatenation "1" "2" (concatenation)))
+    (check-equal? (parse #'(intersection #\1 (intersection "2") (intersection))
-               '(concatenation "1" "2" (concatenation)))
+            null)
-              ((parse #'(char-range "1" #\1)) '(char-range #\1 #\1))
+     '(intersection #\1 (intersection "2") (intersection)))
-              ((parse #'(char-range #\1 "1")) '(char-range #\1 #\1))
+    (check-equal? (parse #'(complement (union #\1 #\2))
-              ((parse #'(char-range "1" "3")) '(char-range #\1 #\3))
+            null)
-              ((parse #'(char-complement (union "1" "2")))
+     '(complement (union #\1 #\2)))
-               '(char-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"))))
+;  )

pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/unicode-chars.rkt

@@ -1,67 +1,69 @@
-(module unicode-chars mzscheme
+#lang racket
-  (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))))))))))
 
-  (define (compute-ranges x?)
+(require "util.rkt")
-    (delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars)))
+
-  
+(provide (all-defined-out))
-  (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
 
+;; 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 ()
+(define (compute-ranges x?)
-              ((get-chars-for odd? '()) '())
+  (delay (get-chars-for (lambda (x) (x? (integer->char x))) mapped-chars)))
-              ((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)
+(define alphabetic-ranges   (compute-ranges char-alphabetic?))  ;; 325
-                                (odd? (quotient x 10)))
+(define lower-case-ranges   (compute-ranges char-lower-case?))  ;; 405
-                              '((1 5 #t) (17 19 #t) (21 51 #f)))
+(define upper-case-ranges   (compute-ranges char-upper-case?))  ;; 380
-               '((17 . 19) (30 . 39) (50 . 51))))
+(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))))
   
-  )
+

pkgs/parser-tools-pkgs/parser-tools-lib/parser-tools/private-lex/util.rkt

@@ -1,14 +1,16 @@
-(module util mzscheme
+#lang racket
-  (require mzlib/list)
-  
-  (provide (all-defined))
 
-  (define max-char-num #x10FFFF)
+(provide (all-defined-out))
-  
+
-  (define-struct lex-abbrev (get-abbrev))
+(define max-char-num #x10FFFF)
-  (define-struct lex-trans (f))
+
-  
+(define-struct lex-abbrev (get-abbrev))
-  #;(define-syntax test-block
+(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
+(define-syntax test-block
-    (syntax-rules ()
+  (syntax-rules ()
-      ((_ x ...) (void))))
+    ((_ 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))
-              
 
-  
-  ;; 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)
+;; A cache is (X ( -> Y) -> Y)
-  ;; removes the entries from l that have the same index as a
+;; make-cache : -> cache
-  ;; previous entry.  l must be grouped by indexes.
+;; table map Xs to Ys.  If key is mapped, its value is returned.
-  (define (remove-dups l index acc)
+;; Otherwise, build is invoked and its result is placed in the table and
-    (cond
+;; returned.
-      ((null? l) (reverse acc))
+;; Xs are compared with equal?
-      ((null? acc) (remove-dups (cdr l) index (cons (car l) acc)))
+(define (make-cache)
-      ((= (index (car acc)) (index (car l)))
+  (let ((table (make-hash)))
-       (remove-dups (cdr l) index acc))
+    (lambda (key build)
-      (else 
+      (hash-ref table key
-       (remove-dups (cdr l) index (cons (car l) acc)))))
+                (lambda ()
-
+                  (let ((new (build)))
-  (test-block ()
+                    (hash-set! table key new)
-              ((remove-dups '((1 2) (2 2) (1 3) (1 4) (100 4) (0 5)) cadr null)
+                    new))))))
-               '((1 2) (1 3) (1 4) (0 5)))
+
-              ((remove-dups null error null) null))
+(module+ test
-  
+  (define cache (make-cache))
-  
+  (check-equal? (cache '(s 1 2) (lambda () 9)) 9)
-  ;; do-simple-equiv : (list-of X) (X -> nat) -> (list-of X)
+  (check-equal? (cache '(s 2 1) (lambda () 8)) 8)
-  ;; Sorts l according to index and removes the entries with duplicate
+  (check-equal? (cache '(s 1 2) (lambda () 1)) 9)
-  ;; indexes.
+  (check-equal? (cache (cons 's (cons 0 (cons +inf.0 10)))
-  (define (do-simple-equiv l index)
+                       (lambda () 22)) 22)
-    (let ((ordered (sort l (lambda (a b) (< (index a) (index b))))))
+  (check-equal? (cache (cons 's (cons 0 (cons +inf.0 10)))
-      (remove-dups ordered index null)))
+                       (lambda () 1)) 22))
-
+
-  (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)))
+;; make-counter : -> -> nat
-              ((do-simple-equiv null error) null))
+;; 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) ->
+(module+ test
-  ;;           (list-of X)
+  (check-equal? (replace null void (lambda () (list 1)) null) null)
-  ;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
+  (check-equal? (replace '(1 2 3 4 3 5)
-  ;; list.
+                         (lambda (x) (= x 3))
-  (define (replace l pred? get acc)
+                         (lambda (x) (list 1 2 3))
-    (cond
+                         null)
-      ((null? l) acc)
+                '(5 1 2 3 4 1 2 3 2 1)))
-      ((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)))
   
   
-    )
+