rackety

original commit: ed3bf9a3c0f839fd25375439be170d46d5a49e09

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

@@ -1,19 +1,20 @@
-(module stx mzscheme
+#lang racket
-  (require "util.rkt"
+
+(require "util.rkt"
          syntax/id-table)
 
-  (provide parse)
+(provide parse)
   
-  (define (bad-args stx num)
+(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
+;; char-range-arg: syntax-object syntax-object -> nat
-  ;; If c contains is a character or length 1 string, returns the integer
+;; If c contains is a character or length 1 string, returns the integer
-  ;; for the character.  Otherwise raises a syntax error.
+;; for the character.  Otherwise raises a syntax error.
-  (define (char-range-arg stx containing-stx)
+(define (char-range-arg stx containing-stx)
   (let ((c (syntax-e stx)))
     (cond
       ((char? c) (char->integer c))
@@ -24,13 +25,13 @@
         #f
         "not a char or single-char string"
         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)))
-  (define (disarm stx)
+(define (disarm stx)
   (syntax-disarm stx orig-insp))
 
   ;; parse : syntax-object (box (list-of syntax-object)) -> s-re (see re.rkt)
@@ -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 ()
+  (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)))
-              ((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))
+    (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"))))
-  )
+;  )

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

@@ -1,14 +1,14 @@
-(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
     ((null? mapped-chars) null)
     (else
@@ -38,30 +38,32 @@
               (else
                (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)))
 
-  (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)))
+                '((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))
+(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 ()
       ((_ defs (code right-ans) ...)
        (let* defs
@@ -17,56 +19,62 @@
              (printf "Test failed: ~e gave ~e.  Expected ~e\n"
                      'code real-ans 'right-ans))) ...))))
 
-  (define-syntax test-block
+(define-syntax test-block
   (syntax-rules ()
     ((_ 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)
-        (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)
+(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))
 
 
 
-  ;; make-counter : -> -> nat
+;; make-counter : -> -> nat
-  ;; makes a function that returns a higher number by 1, each time
+;; makes a function that returns a higher number by 1, each time
-  ;; it is called.
+;; it is called.
-  (define (make-counter)
+(define (make-counter)
   (let ((counter 0))
     (lambda ()
       (begin0
         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)
+
-  ;; removes the entries from l that have the same index as a
+
-  ;; previous entry.  l must be grouped by indexes.
+;; remove-dups : (list-of X) (X -> number) -> (list-of X)
-  (define (remove-dups l index acc)
+;; 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)))
@@ -75,42 +83,45 @@
     (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)
+;; 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
-  ;; indexes.
+;; indexes.
-  (define (do-simple-equiv l index)
+(define (do-simple-equiv l index)
   (let ((ordered (sort l (lambda (a b) (< (index a) (index b))))))
     (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)))
-              ((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)
-  ;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
+;; If (pred? r) for some r in l, splice (get r) in place of r in the resulting
-  ;; list.
+;; list.
-  (define (replace l pred? get acc)
+(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)
+(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) (list 1 2 3))
                          null)
                 '(5 1 2 3 4 1 2 3 2 1)))
   
   
-    )
+