Run `resyntax` over everything

codegen/flatten.rkt

@@ -7,10 +7,10 @@
          prim-rule)
 
 (define (make-fresh-name)
-  (let ([n 0])
-    (λ ()
-      (set! n (add1 n))
-      (string->symbol (format "%rule~a" n)))))
+  (define n 0)
+  (λ ()
+    (set! n (add1 n))
+    (string->symbol (format "%rule~a" n))))
 
 (define default-fresh-name (make-fresh-name))
 
@@ -161,10 +161,10 @@
 ;; Then the pattern-inference process treats them separately.
 (define (pattern->hash-key a-pat)
   (let loop ([x a-pat])
-    (let ([maybe-stx-list (syntax->list x)])
-      (if maybe-stx-list
-          (cons (syntax-property x 'hide) (map loop maybe-stx-list))
-          (syntax->datum x)))))
+    (define maybe-stx-list (syntax->list x))
+    (if maybe-stx-list
+        (cons (syntax-property x 'hide) (map loop maybe-stx-list))
+        (syntax->datum x))))
 
 
 ;; Returns true if the pattern looks primitive

codegen/runtime.rkt

@@ -147,11 +147,10 @@
         (lex:position-line start-pos)
         (lex:position-col start-pos)
         (lex:position-offset start-pos)
-        (if (and (number? (lex:position-offset end-pos))
-                 (number? (lex:position-offset start-pos)))
-            (- (lex:position-offset end-pos)
-               (lex:position-offset start-pos))
-            #f)))
+        (and (and (number? (lex:position-offset end-pos))
+                  (number? (lex:position-offset start-pos)))
+             (- (lex:position-offset end-pos)
+                (lex:position-offset start-pos)))))
 
 #|
 MB: the next three functions control the parse tree output.

parser-tools/cfg-parser.rkt

@@ -70,13 +70,14 @@
   (let loop ()
     (when (ormap-all #f
                      (λ (nt pats)
-                       (let ([old (bound-identifier-mapping-get nts nt)])
-                         (let ([new (proc nt pats old)])
-                           (if (equal? old new)
-                               #f
-                               (begin
-                                 (bound-identifier-mapping-put! nts nt new)
-                                 #t)))))
+                       (define old (bound-identifier-mapping-get nts nt))
+                       (define new (proc nt pats old))
+                       (cond
+                         [(equal? old new)
+                          #f]
+                         [else
+                          (bound-identifier-mapping-put! nts nt new)
+                          #t]))
                      nt-ids patss)
       (loop))))
 
@@ -334,13 +335,11 @@
                                         null))
                       #,(loop (cdr pat) (add1 pos)))))
                 stream last-consumed-token depth 
-                #,(let ([cnt (apply +
-                                    (map (λ (item)
-                                           (cond
-                                             [(bound-identifier-mapping-get nts item (λ () #f))
-                                              => (λ (l) (car l))]
-                                             [else 1]))
-                                         (cdr pat)))])
+                #,(let ([cnt (for/sum ([item (in-list (cdr pat))])
+                               (cond
+                                 [(bound-identifier-mapping-get nts item (λ () #f))
+                                  => (λ (l) (car l))]
+                                 [else 1]))])
                     #`(- end #,cnt))
                 success-k fail-k max-depth tasks)]
             [else
@@ -523,56 +522,56 @@
                                   (nt-fixpoint
                                    nts
                                    (λ (nt pats old-list)
-                                     (let ([new-cnt
-                                            (apply min (for/list ([pat (in-list pats)])
-                                                                 (for/sum ([elem (in-list pat)])
-                                                                          (car (bound-identifier-mapping-get
-                                                                                nts elem  (λ () (list 1)))))))])
-                                       (if (new-cnt . > . (car old-list))
-                                           (cons new-cnt (cdr old-list))
-                                           old-list)))
+                                     (define new-cnt
+                                       (apply min (for/list ([pat (in-list pats)])
+                                                    (for/sum ([elem (in-list pat)])
+                                                      (car (bound-identifier-mapping-get
+                                                            nts elem  (λ () (list 1))))))))
+                                     (if (new-cnt . > . (car old-list))
+                                         (cons new-cnt (cdr old-list))
+                                         old-list))
                                    nt-ids patss)
                                   ;; Compute set of toks that must appear at the beginning
                                   ;;  for a non-terminal
                                   (nt-fixpoint
                                    nts
                                    (λ (nt pats old-list)
-                                     (let ([new-list
-                                            (apply
-                                             append
-                                             (for/list ([pat (in-list pats)])
-                                                       (let loop ([pat pat])
-                                                         (if (pair? pat)
-                                                             (let ([l (bound-identifier-mapping-get 
-                                                                       nts
-                                                                       (car pat)
-                                                                       (λ ()
-                                                                         (list 1 (map-token toks (car pat)))))])
-                                                               ;; If the non-terminal can match 0 things,
-                                                               ;;  then it might match something from the
-                                                               ;;  next pattern element. Otherwise, it must
-                                                               ;;  match the first element:
-                                                               (if (zero? (car l))
-                                                                   (append (cdr l) (loop (cdr pat)))
-                                                                   (cdr l)))
-                                                             null))))])
-                                       (let ([new (filter (λ (id)
-                                                            (andmap (λ (id2)
-                                                                      (not (eq? id id2)))
-                                                                    (cdr old-list)))
-                                                          new-list)])
-                                         (if (pair? new)
-                                             ;; Drop dups in new list:
-                                             (let ([new (let loop ([new new])
-                                                          (if (null? (cdr new))
-                                                              new
-                                                              (if (ormap (λ (id)
-                                                                           (eq? (car new) id))
-                                                                         (cdr new))
-                                                                  (loop (cdr new))
-                                                                  (cons (car new) (loop (cdr new))))))])
-                                               (cons (car old-list) (append new (cdr old-list))))
-                                             old-list))))
+                                     (define new-list
+                                       (apply
+                                        append
+                                        (for/list ([pat (in-list pats)])
+                                          (let loop ([pat pat])
+                                            (if (pair? pat)
+                                                (let ([l (bound-identifier-mapping-get 
+                                                          nts
+                                                          (car pat)
+                                                          (λ ()
+                                                            (list 1 (map-token toks (car pat)))))])
+                                                  ;; If the non-terminal can match 0 things,
+                                                  ;;  then it might match something from the
+                                                  ;;  next pattern element. Otherwise, it must
+                                                  ;;  match the first element:
+                                                  (if (zero? (car l))
+                                                      (append (cdr l) (loop (cdr pat)))
+                                                      (cdr l)))
+                                                null)))))
+                                     (define new
+                                       (filter (λ (id)
+                                                 (andmap (λ (id2)
+                                                           (not (eq? id id2)))
+                                                         (cdr old-list)))
+                                               new-list))
+                                     (if (pair? new)
+                                         ;; Drop dups in new list:
+                                         (let ([new (let loop ([new new])
+                                                      (cond
+                                                        [(null? (cdr new)) new]
+                                                        [(ormap (λ (id)
+                                                                  (eq? (car new) id))
+                                                                (cdr new)) (loop (cdr new))]
+                                                        [else (cons (car new) (loop (cdr new)))]))])
+                                           (cons (car old-list) (append new (cdr old-list))))
+                                         old-list))
                                    nt-ids patss)
                                   ;; Determine left-recursive clauses:
                                   (for-each (λ (nt pats)

parser-tools/lex-sre.rkt

@@ -83,12 +83,12 @@
     [(_ RANGE ...)
      (let ([chars
             (apply append (for/list ([r (in-list (syntax->list #'(RANGE ...)))])
-                                 (let ([x (syntax-e r)])
-                                   (cond
-                                     [(char? x) (list x)]
-                                     [(string? x) (string->list x)]
-                                     [else
-                                      (raise-syntax-error #f "not a char or string" stx r)]))))])
+                            (define x (syntax-e r))
+                            (cond
+                              [(char? x) (list x)]
+                              [(string? x) (string->list x)]
+                              [else
+                               (raise-syntax-error #f "not a char or string" stx r)])))])
        (unless (even? (length chars))
          (raise-syntax-error #f "not given an even number of characters" stx))
        #`(/-only-chars #,@chars))]))

parser-tools/lex.rkt

@@ -127,7 +127,7 @@
                            [(ACT ...) (map (λ (a) (wrap-action a src-loc-style)) acts)]
                            [(ACT-NAME ...) (vector->list action-names)]
                            [SPEC-ACT-STX (wrap-action spec-act src-loc-style)]
-                           [HAS-COMMENT-ACT?-STX (if (syntax-e spec-comment-act) #t #f)]
+                           [HAS-COMMENT-ACT?-STX (and (syntax-e spec-comment-act) #t)]
                            [SPEC-COMMENT-ACT-STX (wrap-action spec-comment-act src-loc-style)]
                            [EOF-ACT-STX (wrap-action eof-act src-loc-style)])
                (syntax/loc stx (let ([NAME ACT] ...)
@@ -200,7 +200,7 @@
      (define r1 (vector-ref el 0))
      (define r2 (vector-ref el 1))
      (cond
-       [(and (>= char r1) (<= char r2)) (vector-ref el 2)]
+       [(<= r1 char r2) (vector-ref el 2)]
        [(< char r1) (get-next-state-helper char min try table)]
        [else (get-next-state-helper char (add1 try) max table)])]))
                
@@ -351,18 +351,16 @@
      (with-syntax ([(CHAR ...) (string->list (syntax-e #'STR))])
        #'(union CHAR ...))]))
 
-(define-syntax provide-lex-keyword
-  (syntax-rules ()
-    [(_ ID ...)
-     (begin
-       (define-syntax-parameter ID
-         (make-set!-transformer
-          (λ (stx)
-            (raise-syntax-error
-             'provide-lex-keyword
-             (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID)
-             stx))))
-       ...
-       (provide ID ...))]))
+(define-syntax-rule (provide-lex-keyword ID ...)
+  (begin
+    (define-syntax-parameter ID
+      (make-set!-transformer
+       (λ (stx)
+         (raise-syntax-error
+          'provide-lex-keyword
+          (format "use of a lexer keyword (~a) is not in an appropriate lexer action" 'ID)
+          stx))))
+    ...
+    (provide ID ...)))
   
 (provide-lex-keyword start-pos end-pos lexeme lexeme-srcloc input-port return-without-pos return-without-srcloc)

parser-tools/private-lex/deriv.rkt

@@ -279,14 +279,12 @@
   (printf "number of states: ~a\n" (dfa-num-states x))
   (printf "start state: ~a\n" (dfa-start-state x))
   (printf "final states: ~a\n" (map car (dfa-final-states/actions x)))
-  (for-each (λ (trans)
-              (printf "state: ~a\n" (car trans))
-              (for-each (λ (rule)
-                          (printf "  -~a-> ~a\n"
-                                  (is:integer-set-contents (car rule))
-                                  (cdr rule)))
-                        (cdr trans)))
-            (dfa-transitions x)))
+  (for ([trans (in-list (dfa-transitions x))])
+    (printf "state: ~a\n" (car trans))
+    (for ([rule (in-list (cdr trans))])
+      (printf "  -~a-> ~a\n"
+              (is:integer-set-contents (car rule))
+              (cdr rule)))))
  
 (define (build-test-dfa rs)
   (define c (make-cache))

parser-tools/private-lex/front.rkt

@@ -10,12 +10,10 @@
   
 (provide build-lexer)
   
-(define-syntax time-label
-  (syntax-rules ()
-    ((_ l e ...)
-     (begin
-       (printf "~a: " l)
-       (time (begin e ...))))))
+(define-syntax-rule (time-label l e ...)
+  (begin
+    (printf "~a: " l)
+    (time (begin e ...))))
   
 ;; A table is either
 ;; - (vector-of (union #f nat))
@@ -89,7 +87,7 @@
        (vector-set! no-look (car trans) #f))
   no-look)
       
-(test-block ((d1 (dfa 1 1 (list) (list)))
+(test-block ((d1 (dfa 1 1 '() '()))
              (d2 (dfa 4 1 (list (cons 2 2) (cons 3 3))
                            (list (cons 1 (list (cons (is:make-range 49 50) 1)
                                                (cons (is:make-range 51) 2)))

parser-tools/private-lex/re.rkt

@@ -81,7 +81,8 @@
     [`(intersection ,rs ...)
      (build-and (flatten-res (map (λ (r) (->re r cache)) rs)
                              andR? andR-res (λ (a b)
-                                              (let-values (((i _ __) (loc:split a b))) i))
+                                              (define-values (i _ __) (loc:split a b))
+                                              i)
                              cache)
                 cache)]
     [`(complement ,r) (build-neg (->re r cache) cache)]
@@ -316,9 +317,9 @@
                                                      orR? orR-res is:union c))))
              (isc (is:make-range (char->integer #\1) (char->integer #\7))))
             ((flatten-res `(,r1 ,r2) andR? andR-res (λ (x y)
-                                                      (let-values (((i _ __)
-                                                                    (is:split x y)))
-                                                        i))
+                                                      (define-values (i _ __)
+                                                        (is:split x y))
+                                                      i)
                           c)
              (list z)))
   

parser-tools/private-lex/stx.rkt

@@ -36,86 +36,86 @@
   (let loop ([stx stx]
              ;; seen-lex-abbrevs: id-table
              [seen-lex-abbrevs (make-immutable-free-id-table)])
-    (let ([recur (λ (s)
-                   (loop (syntax-rearm s stx)
-                         seen-lex-abbrevs))]
-          [recur/abbrev (λ (s id)
-                          (loop (syntax-rearm s stx)
-                                (free-id-table-set seen-lex-abbrevs id id)))])
-      (syntax-case (disarm stx) (repetition union intersection complement concatenation
-                                            char-range char-complement)
-        [_
-         (identifier? stx)
-         (let ([expansion (syntax-local-value/record stx (λ (v) #t))])
-           (unless (lex-abbrev? expansion)
-             (raise-syntax-error 'regular-expression
-                                 "undefined abbreviation"
-                                 stx))
-           ;; Check for cycles.
-           (when (free-id-table-ref seen-lex-abbrevs stx (λ () #f))
-             (raise-syntax-error 'regular-expression
-                                 "illegal lex-abbrev cycle detected"
-                                 stx
-                                 #f
-                                 (list (free-id-table-ref seen-lex-abbrevs stx))))
-           (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
-        [_
-         (or (char? (syntax-e stx)) (string? (syntax-e stx)))
-         (syntax-e stx)]
-        [(repetition ARG ...)
-         (let ([arg-list (syntax->list #'(ARG ...))])
-           (unless (= 3 (length arg-list))
-             (bad-args stx 2))
-           (define low (syntax-e (car arg-list)))
-           (define high (syntax-e (cadr arg-list)))
-           (define re (caddr arg-list))
-           (unless (and (number? low) (exact? low) (integer? low) (>= low 0))
-             (raise-syntax-error #f "not a non-negative exact integer" stx (car arg-list)))
-           (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0))
-                       (eqv? high +inf.0))
-             (raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list)))
-           (unless (<= low high)
-             (raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx))
-           `(repetition ,low ,high ,(recur re)))]
-        [(union RE ...)
-         `(union ,@(map recur (syntax->list #'(RE ...))))]
-        [(intersection RE ...)
-         `(intersection ,@(map recur (syntax->list #'(RE ...))))]
-        [(complement RE ...)
-         (let ([re-list (syntax->list #'(RE ...))])
-           (unless (= 1 (length re-list))
-             (bad-args stx 1))
-           `(complement ,(recur (car re-list))))]
-        [(concatenation RE ...)
-         `(concatenation ,@(map recur (syntax->list #'(RE ...))))]
-        [(char-range ARG ...)
-         (let ((arg-list (syntax->list #'(ARG ...))))
-           (unless (= 2 (length arg-list))
-             (bad-args stx 2))
-           (let ([i1 (char-range-arg (car arg-list) stx)]
-                 [i2 (char-range-arg (cadr arg-list) stx)])
-             (if (<= i1 i2)
-                 `(char-range ,(integer->char i1) ,(integer->char i2))
-                 (raise-syntax-error #f "the first argument does not precede or equal second argument" stx))))]
-        [(char-complement ARG ...)
-         (let ([arg-list (syntax->list #'(ARG ...))])
-           (unless (= 1 (length arg-list))
-             (bad-args stx 1))
-           (define parsed (recur (car arg-list)))
-           (unless (char-set? parsed)
-             (raise-syntax-error #f "not a character set" stx (car arg-list)))
-           `(char-complement ,parsed))]
-        ((OP form ...)
-         (identifier? #'OP)
-         (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
-           (cond
-             [(lex-trans? expansion)
-              (recur ((lex-trans-f expansion) (disarm stx)))]
-             [expansion
-              (raise-syntax-error 'regular-expression "not a lex-trans" stx)]
-             [else
-              (raise-syntax-error 'regular-expression "undefined operator" stx)])))
-        [_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)]))))
+    (define (recur s)
+      (loop (syntax-rearm s stx)
+            seen-lex-abbrevs))
+    (define (recur/abbrev s id)
+      (loop (syntax-rearm s stx)
+            (free-id-table-set seen-lex-abbrevs id id)))
+    (syntax-case (disarm stx) (repetition union intersection complement concatenation
+                                          char-range char-complement)
+      [_
+       (identifier? stx)
+       (let ([expansion (syntax-local-value/record stx (λ (v) #t))])
+         (unless (lex-abbrev? expansion)
+           (raise-syntax-error 'regular-expression
+                               "undefined abbreviation"
+                               stx))
+         ;; Check for cycles.
+         (when (free-id-table-ref seen-lex-abbrevs stx (λ () #f))
+           (raise-syntax-error 'regular-expression
+                               "illegal lex-abbrev cycle detected"
+                               stx
+                               #f
+                               (list (free-id-table-ref seen-lex-abbrevs stx))))
+         (recur/abbrev ((lex-abbrev-get-abbrev expansion)) stx))]
+      [_
+       (or (char? (syntax-e stx)) (string? (syntax-e stx)))
+       (syntax-e stx)]
+      [(repetition ARG ...)
+       (let ([arg-list (syntax->list #'(ARG ...))])
+         (unless (= 3 (length arg-list))
+           (bad-args stx 2))
+         (define low (syntax-e (car arg-list)))
+         (define high (syntax-e (cadr arg-list)))
+         (define re (caddr arg-list))
+         (unless (and (number? low) (exact? low) (integer? low) (>= low 0))
+           (raise-syntax-error #f "not a non-negative exact integer" stx (car arg-list)))
+         (unless (or (and (number? high) (exact? high) (integer? high) (>= high 0))
+                     (eqv? high +inf.0))
+           (raise-syntax-error #f "not a non-negative exact integer or +inf.0" stx (cadr arg-list)))
+         (unless (<= low high)
+           (raise-syntax-error #f "the first argument is not less than or equal to the second argument" stx))
+         `(repetition ,low ,high ,(recur re)))]
+      [(union RE ...)
+       `(union ,@(map recur (syntax->list #'(RE ...))))]
+      [(intersection RE ...)
+       `(intersection ,@(map recur (syntax->list #'(RE ...))))]
+      [(complement RE ...)
+       (let ([re-list (syntax->list #'(RE ...))])
+         (unless (= 1 (length re-list))
+           (bad-args stx 1))
+         `(complement ,(recur (car re-list))))]
+      [(concatenation RE ...)
+       `(concatenation ,@(map recur (syntax->list #'(RE ...))))]
+      [(char-range ARG ...)
+       (let ((arg-list (syntax->list #'(ARG ...))))
+         (unless (= 2 (length arg-list))
+           (bad-args stx 2))
+         (define i1 (char-range-arg (car arg-list) stx))
+         (define i2 (char-range-arg (cadr arg-list) stx))
+         (if (<= i1 i2)
+             `(char-range ,(integer->char i1) ,(integer->char i2))
+             (raise-syntax-error #f "the first argument does not precede or equal second argument" stx)))]
+      [(char-complement ARG ...)
+       (let ([arg-list (syntax->list #'(ARG ...))])
+         (unless (= 1 (length arg-list))
+           (bad-args stx 1))
+         (define parsed (recur (car arg-list)))
+         (unless (char-set? parsed)
+           (raise-syntax-error #f "not a character set" stx (car arg-list)))
+         `(char-complement ,parsed))]
+      ((OP form ...)
+       (identifier? #'OP)
+       (let* ([expansion (syntax-local-value/record #'OP (λ (v) #t))])
+         (cond
+           [(lex-trans? expansion)
+            (recur ((lex-trans-f expansion) (disarm stx)))]
+           [expansion
+            (raise-syntax-error 'regular-expression "not a lex-trans" stx)]
+           [else
+            (raise-syntax-error 'regular-expression "undefined operator" stx)])))
+      [_ (raise-syntax-error 'regular-expression "not a char, string, identifier, or (op args ...)" stx)])))
        
 
   

parser-tools/private-lex/util.rkt

@@ -32,12 +32,9 @@
 ;; returned.
 ;; Xs are compared with equal?
 (define (make-cache)
-  (let ([table (make-hash)])
-    (λ (key build)
-      (hash-ref table key (λ ()
-                            (let ([new (build)])
-                              (hash-set! table key new)
-                              new))))))
+  (define table (make-hash))
+  (λ (key build)
+    (hash-ref! table key build)))
 
 (module+ test
   (define cache (make-cache))
@@ -94,7 +91,7 @@
 ;; Sorts l according to index and removes the entries with duplicate
 ;; indexes.
 (define (do-simple-equiv l index)
-  (define ordered (sort l (λ (a b) (< (index a) (index b)))))
+  (define ordered (sort l < #:key index))
   (remove-dups ordered index null))
 
 (module+ test

parser-tools/private-yacc/grammar.rkt

@@ -88,11 +88,11 @@
  
 ;; print-item: LR-item ->
 (define (item->string it)
-  (define print-sym (λ (i)
-                      (let ((gs (vector-ref (prod-rhs (item-prod it)) i)))
-                        (cond
-                          ((term? gs) (format "~a " (term-sym gs)))
-                          (else (format "~a " (non-term-sym gs)))))))
+  (define (print-sym i)
+    (define gs (vector-ref (prod-rhs (item-prod it)) i))
+    (cond
+      ((term? gs) (format "~a " (term-sym gs)))
+      (else (format "~a " (non-term-sym gs)))))
   (string-append
    (format "~a -> " (non-term-sym (prod-lhs (item-prod it))))
    (let loop ((i 0))

parser-tools/private-yacc/graph.rkt

@@ -31,14 +31,13 @@
     (define d (depth))
     (set-N x d)
     (hash-set! results x (f- x))
-    (for-each (λ (y)
-                (when (= 0 (get-N y))
-                  (traverse y))
-                (hash-set! results
-                           x
-                           (union (f x) (f y)))
-                (set-N x (min (get-N x) (get-N y))))
-              (edges x))
+    (for ([y (in-list (edges x))])
+      (when (= 0 (get-N y))
+        (traverse y))
+      (hash-set! results
+                 x
+                 (union (f x) (f y)))
+      (set-N x (min (get-N x) (get-N y))))
     (when (= d (get-N x))
       (let loop ([p (pop)])
         (set-N p +inf.0)

parser-tools/private-yacc/input-file-parser.rkt

@@ -219,12 +219,11 @@
           p
           #f
           (let loop ([i (sub1 (vector-length p))])
-            (if (>= i 0)
-                (let ([gs (vector-ref p i)])
-                  (if (term? gs)
-                      (term-prec gs)
-                      (loop (sub1 i))))
-                #f))
+            (and (>= i 0)
+                 (let ([gs (vector-ref p i)])
+                   (if (term? gs)
+                       (term-prec gs)
+                       (loop (sub1 i))))))
           (parse-action #'PROD-RHS #'ACTION)))]
       [(PROD-RHS (PREC TERM) ACTION)
        (identifier? #'TERM)

parser-tools/private-yacc/lalr.rkt

@@ -140,35 +140,29 @@
   (printf "~a:\n" name)
   (send a for-each-state
         (λ (state)
-          (for-each
-           (λ (non-term)
-             (let ([res (f (trans-key state non-term))])
-               (when (not (null? res))
-                 (printf "~a(~a, ~a) = ~a\n"
-                         name
-                         state
-                         (gram-sym-symbol non-term)
-                         (print-output res)))))
-           (send g get-non-terms))))
+          (for ([non-term (in-list (send g get-non-terms))])
+            (define res (f (trans-key state non-term)))
+            (when (not (null? res))
+              (printf "~a(~a, ~a) = ~a\n"
+                      name
+                      state
+                      (gram-sym-symbol non-term)
+                      (print-output res))))))
   (newline))
 
 (define (print-input-st-prod f name a g print-output)
   (printf "~a:\n" name)
   (send a for-each-state
         (λ (state)
-          (for-each
-           (λ (non-term)
-             (for-each
-              (λ (prod)
-                (let ([res (f state prod)])
-                  (when (not (null? res))
-                    (printf "~a(~a, ~a) = ~a\n"
-                            name
-                            (kernel-index state)
-                            (prod-index prod)
-                            (print-output res)))))
-              (send g get-prods-for-non-term non-term)))
-           (send g get-non-terms)))))
+          (for ([non-term (in-list (send g get-non-terms))])
+            (for ([prod (in-list (send g get-prods-for-non-term non-term))])
+              (define res (f state prod))
+              (when (not (null? res))
+                (printf "~a(~a, ~a) = ~a\n"
+                        name
+                        (kernel-index state)
+                        (prod-index prod)
+                        (print-output res))))))))
   
 (define (print-output-terms r)
   (map gram-sym-symbol r))
@@ -232,12 +226,11 @@
     (let ([d (depth)])
       (set-N x d)
       (set-f x (f- x))
-      (for-each (λ (y)
-                  (when (= 0 (get-N y))
-                    (traverse y))
-                  (set-f x (bitwise-ior (get-f x) (get-f y)))
-                  (set-N x (min (get-N x) (get-N y))))
-                (edges x))
+      (for ([y (in-list (edges x))])
+        (when (= 0 (get-N y))
+          (traverse y))
+        (set-f x (bitwise-ior (get-f x) (get-f y)))
+        (set-N x (min (get-N x) (get-N y))))
       (when (= d (get-N x))
         (let loop ([p (pop)])
           (set-N p +inf.0)

parser-tools/private-yacc/lr0.rkt

@@ -30,13 +30,13 @@
     (cond
       [(null? sorted) null]
       [(null? (cdr sorted)) sorted]
+      [(and (= (non-term-index (trans-key-gs (car sorted)))
+               (non-term-index (trans-key-gs (cadr sorted))))
+            (= (kernel-index (trans-key-st (car sorted)))
+               (kernel-index (trans-key-st (cadr sorted)))))
+       (loop (cdr sorted))]
       [else
-       (if (and (= (non-term-index (trans-key-gs (car sorted)))
-                   (non-term-index (trans-key-gs (cadr sorted))))
-                (= (kernel-index (trans-key-st (car sorted)))
-                   (kernel-index (trans-key-st (cadr sorted)))))
-           (loop (cdr sorted))
-           (cons (car sorted) (loop (cdr sorted))))])))
+       (cons (car sorted) (loop (cdr sorted)))])))
 
 
 ;; build-transition-table : int (listof (cons/c trans-key X) ->

parser-tools/private-yacc/table.rkt

@@ -147,13 +147,13 @@
   (define RR-conflicts 0)
   (define table (table-map
                  (λ (gs actions)
-                   (let-values ([(action SR? RR?)
-                                 (resolve-conflict actions)])
-                     (when SR?
-                       (set! SR-conflicts (add1 SR-conflicts)))
-                     (when RR?
-                       (set! RR-conflicts (add1 RR-conflicts)))
-                     action))
+                   (define-values (action SR? RR?)
+                     (resolve-conflict actions))
+                   (when SR?
+                     (set! SR-conflicts (add1 SR-conflicts)))
+                   (when RR?
+                     (set! RR-conflicts (add1 RR-conflicts)))
+                   action)
                  grouped-table))
   (unless suppress
     (when (> SR-conflicts 0)
@@ -237,15 +237,11 @@
                  (bit-vector-for-each 
                   (λ (term-index)
                     (unless (start-item? item)
-                      (let ((r (hash-ref reduce-cache item-prod
-                                         (λ ()
-                                           (let ((r (reduce item-prod)))
-                                             (hash-set! reduce-cache item-prod r)
-                                             r)))))
-                        (table-add! table
-                                    (kernel-index state)
-                                    (vector-ref term-vector term-index)
-                                    r))))
+                      (define r (hash-ref! reduce-cache item-prod (λ () (reduce item-prod))))
+                      (table-add! table
+                                  (kernel-index state)
+                                  (vector-ref term-vector term-index)
+                                  r)))
                   (get-lookahead state item-prod))))))
 
   (define grouped-table (resolve-prec-conflicts table))

parser-tools/yacc-to-scheme.rkt

@@ -114,9 +114,9 @@
   (regexp-match "%%" i)
   (begin0
     (let ([gram ((parse-grammar enter-term enter-empty-term enter-non-term)
-                 (λ () 
-                   (let ((t (get-token-grammar i)))
-                     t)))])
+                 (λ ()
+                   (define t (get-token-grammar i))
+                   t))])
       `(begin
          (define-tokens t ,(sort (hash-map terms (λ (k v) k)) symbol<?))
          (define-empty-tokens et ,(sort (hash-map eterms (λ (k v) k)) symbol<?))

parser-tools/yacc.rkt

@@ -78,14 +78,14 @@
               (for ([sym (in-list symbols)]
                     #:unless (identifier? sym))
                 (raise-syntax-error #f "End token must be a symbol" stx sym))
-              (let ([d (duplicate-list? (map syntax-e symbols))])
-                (when d
-                  (raise-syntax-error #f (format "Duplicate end token definition for ~a" d) stx arg))
-                (when (null? symbols)
-                  (raise-syntax-error #f "end declaration must contain at least 1 token" stx arg))
-                (when end
-                  (raise-syntax-error #f "Multiple end declarations" stx))
-                (set! end symbols)))]
+              (define d (duplicate-list? (map syntax-e symbols)))
+              (when d
+                (raise-syntax-error #f (format "Duplicate end token definition for ~a" d) stx arg))
+              (when (null? symbols)
+                (raise-syntax-error #f "end declaration must contain at least 1 token" stx arg))
+              (when end
+                (raise-syntax-error #f "Multiple end declarations" stx))
+              (set! end symbols))]
            [(precs DECLS ...)
             (if precs
                 (raise-syntax-error #f "Multiple precs declarations" stx)
@@ -113,38 +113,38 @@
          (raise-syntax-error #f "missing end declaration" stx))
        (unless start
          (raise-syntax-error #f "missing start declaration" stx))
-       (let-values ([(table all-term-syms actions check-syntax-fix)
-                     (build-parser (if debug debug "")
-                                   src-pos
-                                   suppress
-                                   tokens
-                                   start
-                                   end
-                                   precs
-                                   grammar)])
-         (when (and yacc-output (not (string=? yacc-output "")))
-           (with-handlers [(exn:fail:filesystem?
-                            (λ (e) (eprintf "Cannot write yacc-output to file \"~a\"\n" yacc-output)))]
-             (call-with-output-file yacc-output
-               (λ (port)
-                 (display-yacc (syntax->datum grammar) 
-                               tokens 
-                               (map syntax->datum start)
-                               (and precs (syntax->datum precs))
-                               port))
-               #:exists 'truncate)))
-         (with-syntax ([check-syntax-fix check-syntax-fix]
-                       [err error]
-                       [ends end]
-                       [starts start]
-                       [debug debug]
-                       [table (convert-parse-table table)]
-                       [all-term-syms all-term-syms]
-                       [actions actions]
-                       [src-pos src-pos])
-           #'(begin
-               check-syntax-fix
-               (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos)))))]
+       (define-values (table all-term-syms actions check-syntax-fix)
+         (build-parser (if debug debug "")
+                       src-pos
+                       suppress
+                       tokens
+                       start
+                       end
+                       precs
+                       grammar))
+       (when (and yacc-output (not (string=? yacc-output "")))
+         (with-handlers [(exn:fail:filesystem?
+                          (λ (e) (eprintf "Cannot write yacc-output to file \"~a\"\n" yacc-output)))]
+           (call-with-output-file yacc-output
+             (λ (port)
+               (display-yacc (syntax->datum grammar) 
+                             tokens 
+                             (map syntax->datum start)
+                             (and precs (syntax->datum precs))
+                             port))
+             #:exists 'truncate)))
+       (with-syntax ([check-syntax-fix check-syntax-fix]
+                     [err error]
+                     [ends end]
+                     [starts start]
+                     [debug debug]
+                     [table (convert-parse-table table)]
+                     [all-term-syms all-term-syms]
+                     [actions actions]
+                     [src-pos src-pos])
+         #'(begin
+             check-syntax-fix
+             (parser-body debug err (quote starts) (quote ends) table all-term-syms actions src-pos))))]
     [_ (raise-syntax-error #f "parser must have the form (parser args ...)" stx)]))
   
 (define (reduce-stack stack num ret-vals src-pos)
@@ -237,31 +237,29 @@
                                      stack)]
                               [else
                                ;; (printf "discard input:~a\n" tok)
-                               (let-values ([(tok val start-pos end-pos)
-                                             (extract (get-token))])
-                                 (remove-input tok val start-pos end-pos))])))))
+                               (call-with-values (λ () (extract (get-token))) remove-input)])))))
               (let remove-states ()
-                (let ([a (find-action stack 'error #f start-pos end-pos)])
-                  (cond
-                    [(runtime-shift? a)
-                     ;; (printf "shift:~a\n" (runtime-shift-state a))
-                     (set! stack 
-                           (cons
-                            (stack-frame (runtime-shift-state a) 
-                                              #f 
-                                              start-pos
-                                              end-pos)
-                            stack))
-                     (remove-input tok val start-pos end-pos)]
-                    [else
-                     ;; (printf "discard state:~a\n" (car stack))
-                     (cond
-                       [(< (length stack) 2)
-                        (raise-read-error "parser: Cannot continue after error"
-                                          #f #f #f #f #f)]
-                       [else
-                        (set! stack (cdr stack))
-                        (remove-states)])])))))
+                (define a (find-action stack 'error #f start-pos end-pos))
+                (cond
+                  [(runtime-shift? a)
+                   ;; (printf "shift:~a\n" (runtime-shift-state a))
+                   (set! stack 
+                         (cons
+                          (stack-frame (runtime-shift-state a) 
+                                       #f 
+                                       start-pos
+                                       end-pos)
+                          stack))
+                   (remove-input tok val start-pos end-pos)]
+                  [else
+                   ;; (printf "discard state:~a\n" (car stack))
+                   (cond
+                     [(< (length stack) 2)
+                      (raise-read-error "parser: Cannot continue after error"
+                                        #f #f #f #f #f)]
+                     [else
+                      (set! stack (cdr stack))
+                      (remove-states)])]))))
             
           (define (find-action stack tok val start-pos end-pos)
             (unless (hash-ref all-term-syms tok #f)
@@ -278,55 +276,55 @@
               (error 'get-token "expected a nullary procedure, got ~e" get-token))
             (let parsing-loop ([stack (make-empty-stack start-number)]
                                [ip (get-token)])
-              (let-values ([(tok val start-pos end-pos) (extract ip)])
-                (let ([action (find-action stack tok val start-pos end-pos)])
-                  (cond
-                    [(runtime-shift? action)
-                     ;; (printf "shift:~a\n" (runtime-shift-state action))
-                     (parsing-loop (cons (stack-frame (runtime-shift-state action)
-                                                           val
-                                                           start-pos
-                                                           end-pos)
-                                         stack)
-                                   (get-token))]
-                    [(runtime-reduce? action)
-                     ;; (printf "reduce:~a\n" (runtime-reduce-prod-num action))
-                     (let-values ([(new-stack args)
-                                   (reduce-stack stack 
-                                                 (runtime-reduce-rhs-length action)
-                                                 null
-                                                 src-pos)])
-                       (let ([goto 
-                              (runtime-goto-state
-                               (hash-ref 
-                                (vector-ref table (stack-frame-state (car new-stack)))
-                                (runtime-reduce-lhs action)))])
-                         (parsing-loop 
-                          (cons
-                           (if src-pos
-                               (stack-frame
-                                goto 
-                                (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
-                                (if (null? args) start-pos (cadr args))
-                                (if (null? args) 
-                                    end-pos
-                                    (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1))))
-                               (stack-frame
-                                goto 
-                                (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
-                                #f
-                                #f))
-                           new-stack)
-                          ip)))]
-                    [(runtime-accept? action)
-                     ;; (printf "accept\n")
-                     (stack-frame-value (car stack))]
-                    [else 
+              (define-values (tok val start-pos end-pos) (extract ip))
+              (define action (find-action stack tok val start-pos end-pos))
+              (cond
+                [(runtime-shift? action)
+                 ;; (printf "shift:~a\n" (runtime-shift-state action))
+                 (parsing-loop (cons (stack-frame (runtime-shift-state action)
+                                                  val
+                                                  start-pos
+                                                  end-pos)
+                                     stack)
+                               (get-token))]
+                [(runtime-reduce? action)
+                 ;; (printf "reduce:~a\n" (runtime-reduce-prod-num action))
+                 (let-values ([(new-stack args)
+                               (reduce-stack stack 
+                                             (runtime-reduce-rhs-length action)
+                                             null
+                                             src-pos)])
+                   (define goto 
+                     (runtime-goto-state
+                      (hash-ref 
+                       (vector-ref table (stack-frame-state (car new-stack)))
+                       (runtime-reduce-lhs action))))
+                   (parsing-loop 
+                    (cons
                      (if src-pos
-                         (err #t tok val start-pos end-pos)
-                         (err #t tok val))
-                     (parsing-loop (fix-error stack tok val start-pos end-pos get-token)
-                                   (get-token))]))))))
+                         (stack-frame
+                          goto 
+                          (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
+                          (if (null? args) start-pos (cadr args))
+                          (if (null? args) 
+                              end-pos
+                              (list-ref args (- (* (runtime-reduce-rhs-length action) 3) 1))))
+                         (stack-frame
+                          goto 
+                          (apply (vector-ref actions (runtime-reduce-prod-num action)) args)
+                          #f
+                          #f))
+                     new-stack)
+                    ip))]
+                [(runtime-accept? action)
+                 ;; (printf "accept\n")
+                 (stack-frame-value (car stack))]
+                [else 
+                 (if src-pos
+                     (err #t tok val start-pos end-pos)
+                     (err #t tok val))
+                 (parsing-loop (fix-error stack tok val start-pos end-pos get-token)
+                               (get-token))]))))
     (cond
       [(null? (cdr starts)) (make-parser 0)]
       [else

private/colorer.rkt

@@ -38,8 +38,8 @@
   (define-syntax-rule (values->list EXPR) (call-with-values (λ () EXPR) list))
   (define (apply-colorer str)
     (for/list ([annotation (in-port (λ (p)
-                                      (let ([xs (values->list (color-brag p))])
-                                        (if (eof-object? (car xs)) eof xs)))
+                                      (define xs (values->list (color-brag p)))
+                                      (if (eof-object? (car xs)) eof xs))
                                     (open-input-string str))])
       annotation))
 

rules/parser.rkt

@@ -169,7 +169,7 @@
                         [(list all min range? max) (let* ([min (if min (string->number min) 0)]
                                                           [max (cond
                                                                  [(and range? max) (string->number max)]
-                                                                 [(and (not range?) (not max)) (if (zero? min)
+                                                                 [(not (or range? max)) (if (zero? min)
                                                                                                    #f ; {} -> {0,}
                                                                                                    min)] ; {3} -> {3,3}
                                                                  [else #f])])
@@ -298,8 +298,7 @@
                            (pos-line start-pos)
                            (pos-col start-pos)
                            (pos-offset start-pos)
-                           (if (and (number? (pos-offset end-pos))
-                                    (number? (pos-offset start-pos)))
-                               (- (pos-offset end-pos)
-                                  (pos-offset start-pos))
-                               #f))))))))
+                           (and (and (number? (pos-offset end-pos))
+                                     (number? (pos-offset start-pos)))
+                                (- (pos-offset end-pos)
+                                   (pos-offset start-pos))))))))))

rules/stx.rkt

@@ -14,21 +14,19 @@
                           (pos-line (lhs-id-start (rule-lhs a-rule)))
                           (pos-col (lhs-id-start (rule-lhs a-rule)))
                           (pos-offset (lhs-id-start (rule-lhs a-rule)))
-                          (if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
-                                   (number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
-                              (- (pos-offset (lhs-id-end (rule-lhs a-rule)))
-                                 (pos-offset (lhs-id-start (rule-lhs a-rule))))
-                              #f)))
+                          (and (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
+                                    (number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
+                               (- (pos-offset (lhs-id-end (rule-lhs a-rule)))
+                                  (pos-offset (lhs-id-start (rule-lhs a-rule)))))))
      'hide-or-splice-lhs-id (lhs-id-splice (rule-lhs a-rule))))
   (define pattern-stx (pattern->stx source (rule-pattern a-rule)))
   (define line (pos-line (rule-start a-rule)))
   (define column (pos-col (rule-start a-rule)))
   (define position (pos-offset (rule-start a-rule)))
-  (define span (if (and (number? (pos-offset (rule-start a-rule)))
-                        (number? (pos-offset (rule-end a-rule))))
-                   (- (pos-offset (rule-end a-rule))
-                      (pos-offset (rule-start a-rule)))
-                   #f))
+  (define span (and (and (number? (pos-offset (rule-start a-rule)))
+                         (number? (pos-offset (rule-end a-rule))))
+                    (- (pos-offset (rule-end a-rule))
+                       (pos-offset (rule-start a-rule)))))
   (datum->syntax #f
                  `(rule ,id-stx ,pattern-stx)
                  (list source line column position span)))

tests/test-flatten.rkt

@@ -8,10 +8,10 @@
 
 
   (define (make-fresh-name)
-    (let ([n 0])
-      (lambda ()
-        (set! n (add1 n))
-        (string->symbol (format "r~a" n)))))
+    (define n 0)
+    (lambda ()
+      (set! n (add1 n))
+      (string->symbol (format "r~a" n))))
 
 
   ;; Simple literals

token.rkt

@@ -46,16 +46,16 @@
       'token
       (λ (this)
         (append (list (token-type this))
-                (if (token-value this) (list (token-value this)) (list))
+                (if (token-value this) (list (token-value this)) '())
                 (if (token-location this)
                     (list
                      (sequence-markup
                       (list (unquoted-printing-string "#:location") (token-location this))))
-                    (list))
+                    '())
                 (if (token-skip? this)
                     (list
                      (sequence-markup (list (unquoted-printing-string "#:skip?") (token-skip? this))))
-                    (list))))))])
+                    '())))))])
 
 
 (define (source-location #:source [source #false]