Modernize cfg-parser from mzscheme to Racket libraries.

original commit: 4ff4c677bd354cb1a26adf0c3e0e4de03a7a3939

collects/algol60/cfg-parser.rkt

@@ -1,4 +1,4 @@
-
+#lang racket/base
 ;; This module implements a parser form like the parser-tools's
 ;; `parser', except that it works on an arbitrary CFG (returning
 ;; the first sucecssful parse).
@@ -28,40 +28,39 @@
 ;; parser uses `parser' so that it doesn't have to know anything about
 ;; tokens.
 
-(module cfg-parser mzscheme
-  (require parser-tools/yacc
-	   parser-tools/lex
-           mzlib/list
-           mzlib/etc)
-  (require-for-syntax syntax/boundmap
-                      mzlib/list
-		      parser-tools/private-lex/token-syntax)
 
-  (provide cfg-parser)
+(require parser-tools/yacc
+         parser-tools/lex)
+
+(require (for-syntax racket/base
+                     syntax/boundmap
+                     parser-tools/private-lex/token-syntax))
 
-  ;; A raw token, wrapped so that we can recognize it:
-  (define-struct tok (name orig-name val start end))
+(provide cfg-parser)
 
-  ;; Represents the thread scheduler:
-  (define-struct tasks (active active-back waits multi-waits cache progress?))
+;; A raw token, wrapped so that we can recognize it:
+(define-struct tok (name orig-name val start end))
 
-  (define-for-syntax make-token-identifier-mapping make-hash-table)
-  (define-for-syntax token-identifier-mapping-get
+;; Represents the thread scheduler:
+(define-struct tasks (active active-back waits multi-waits cache progress?))
+
+(define-for-syntax make-token-identifier-mapping make-hasheq)
+(define-for-syntax token-identifier-mapping-get
   (case-lambda 
     [(t tok)
-      (hash-table-get t (syntax-e tok))]
+     (hash-ref t (syntax-e tok))]
     [(t tok fail)
-      (hash-table-get t (syntax-e tok) fail)]))
-  (define-for-syntax token-identifier-mapping-put!
+     (hash-ref t (syntax-e tok) fail)]))
+(define-for-syntax token-identifier-mapping-put!
   (lambda (t tok v)
-      (hash-table-put! t (syntax-e tok) v)))
-  (define-for-syntax token-identifier-mapping-map
+    (hash-set! t (syntax-e tok) v)))
+(define-for-syntax token-identifier-mapping-map
   (lambda (t f)
-      (hash-table-map t f)))
+    (hash-map t f)))
 
-  ;; Used to calculate information on the grammar, such as whether
-  ;; a particular non-terminal is "simple" instead of recursively defined.
-  (define-for-syntax (nt-fixpoint nts proc nt-ids patss)
+;; Used to calculate information on the grammar, such as whether
+;; a particular non-terminal is "simple" instead of recursively defined.
+(define-for-syntax (nt-fixpoint nts proc nt-ids patss)
   (define (ormap-all val f as bs)
     (cond
       [(null? as) val]
@@ -81,10 +80,10 @@
                      nt-ids patss)
       (loop))))
 
-  ;; Tries parse-a followed by parse-b. If parse-a is not simple,
-  ;; then after parse-a succeeds once, we parallelize parse-b
-  ;; and trying a second result for parse-a.
-  (define (parse-and simple-a? parse-a parse-b
+;; Tries parse-a followed by parse-b. If parse-a is not simple,
+;; then after parse-a succeeds once, we parallelize parse-b
+;; and trying a second result for parse-a.
+(define (parse-and simple-a? parse-a parse-b
                    stream depth end success-k fail-k 
                    max-depth tasks)
   (letrec ([mk-got-k
@@ -124,16 +123,16 @@
              fail-k
              max-depth tasks)))
 
-  ;; Parallel or for non-terminal alternatives
-  (define (parse-parallel-or parse-a parse-b stream depth end success-k fail-k max-depth tasks)
+;; Parallel or for non-terminal alternatives
+(define (parse-parallel-or parse-a parse-b stream depth end success-k fail-k max-depth tasks)
   (parallel-or (lambda (success-k fail-k max-depth tasks)
                  (parse-a stream depth end success-k fail-k max-depth tasks))
                (lambda (success-k fail-k max-depth tasks)
                  (parse-b stream depth end success-k fail-k max-depth tasks))
                success-k fail-k max-depth tasks))
 
-  ;; Generic parallel-or
-  (define (parallel-or parse-a parse-b success-k fail-k max-depth tasks)
+;; Generic parallel-or
+(define (parallel-or parse-a parse-b success-k fail-k max-depth tasks)
   (define answer-key (gensym))
   (letrec ([gota-k
             (lambda (val stream depth max-depth tasks next-k)
@@ -192,9 +191,9 @@
                                    fail-k #f))])
         (get-first max-depth tasks success-k fail-k)))))
 
-  ;; Non-terminal alternatives where the first is "simple" can be done
-  ;; sequentially, which is simpler
-  (define (parse-or parse-a parse-b
+;; Non-terminal alternatives where the first is "simple" can be done
+;; sequentially, which is simpler
+(define (parse-or parse-a parse-b
                   stream depth end success-k fail-k max-depth tasks)
   (letrec ([mk-got-k
             (lambda (success-k fail-k)
@@ -214,9 +213,9 @@
              (mk-fail-k success-k fail-k)
              max-depth tasks)))
 
-  ;; Starts a thread
-  (define queue-task
-    (opt-lambda (tasks t [progress? #t])
+;; Starts a thread
+(define queue-task
+  (lambda (tasks t [progress? #t])
     (make-tasks (tasks-active tasks)
                 (cons t (tasks-active-back tasks))
                 (tasks-waits tasks)
@@ -224,9 +223,9 @@
                 (tasks-cache tasks)
                 (or progress? (tasks-progress? tasks)))))
 
-  ;; Reports an answer to a waiting thread:
-  (define (report-answer answer-key max-depth tasks val)
-    (let ([v (hash-table-get (tasks-waits tasks) answer-key (lambda () #f))])
+;; Reports an answer to a waiting thread:
+(define (report-answer answer-key max-depth tasks val)
+  (let ([v (hash-ref (tasks-waits tasks) answer-key (lambda () #f))])
     (if v
         (let ([tasks (make-tasks (cons (v val)
                                        (tasks-active tasks))
@@ -235,7 +234,7 @@
                                  (tasks-multi-waits tasks)
                                  (tasks-cache tasks)
                                  #t)])
-            (hash-table-remove! (tasks-waits tasks) answer-key)
+          (hash-remove! (tasks-waits tasks) answer-key)
           (swap-task max-depth tasks))
         ;; We have an answer ready too fast; wait
         (swap-task max-depth
@@ -244,10 +243,10 @@
                                  (report-answer answer-key max-depth tasks val))
                                #f)))))
 
-  ;; Reports an answer to multiple waiting threads:
-  (define (report-answer-all answer-key max-depth tasks val k)
-    (let ([v (hash-table-get (tasks-multi-waits tasks) answer-key (lambda () null))])
-      (hash-table-remove! (tasks-multi-waits tasks) answer-key)
+;; Reports an answer to multiple waiting threads:
+(define (report-answer-all answer-key max-depth tasks val k)
+  (let ([v (hash-ref (tasks-multi-waits tasks) answer-key (lambda () null))])
+    (hash-remove! (tasks-multi-waits tasks) answer-key)
     (let ([tasks (make-tasks (append (map (lambda (a) (a val)) v)
                                      (tasks-active tasks))
                              (tasks-active-back tasks)
@@ -257,10 +256,10 @@
                              #t)])
       (k max-depth tasks))))
 
-  ;; Waits for an answer; if `multi?' is #f, this is sole waiter, otherwise
-  ;;  there might be many. Use wither #t or #f (and `report-answer' or 
-  ;;  `report-answer-all', resptively) consistently for a particular answer key.
-  (define (wait-for-answer multi? max-depth tasks answer-key success-k fail-k deadlock-k)
+;; Waits for an answer; if `multi?' is #f, this is sole waiter, otherwise
+;;  there might be many. Use wither #t or #f (and `report-answer' or 
+;;  `report-answer-all', resptively) consistently for a particular answer key.
+(define (wait-for-answer multi? max-depth tasks answer-key success-k fail-k deadlock-k)
   (let ([wait (lambda (val)
                 (lambda (max-depth tasks)
                   (if val
@@ -270,10 +269,10 @@
                             (success-k val stream depth max-depth tasks next-k)))
                       (deadlock-k max-depth tasks))))])
     (if multi?
-          (hash-table-put! (tasks-multi-waits tasks) answer-key
-                           (cons wait (hash-table-get (tasks-multi-waits tasks) answer-key
+        (hash-set! (tasks-multi-waits tasks) answer-key
+                         (cons wait (hash-ref (tasks-multi-waits tasks) answer-key
                                                     (lambda () null))))
-          (hash-table-put! (tasks-waits tasks) answer-key wait))
+        (hash-set! (tasks-waits tasks) answer-key wait))
     (let ([tasks (make-tasks (tasks-active tasks)
                              (tasks-active-back tasks)
                              (tasks-waits tasks)
@@ -282,8 +281,8 @@
                              #t)])
       (swap-task max-depth tasks))))
 
-  ;; Swap thread
-  (define (swap-task max-depth tasks)
+;; Swap thread
+(define (swap-task max-depth tasks)
   ;; Swap in first active:
   (if (null? (tasks-active tasks))
       (if (tasks-progress? tasks)
@@ -295,17 +294,17 @@
                                  (tasks-cache tasks)
                                  #f))
           ;; No progress, so issue failure for all multi-waits
-            (if (zero? (hash-table-count (tasks-multi-waits tasks)))
+          (if (zero? (hash-count (tasks-multi-waits tasks)))
               (error 'swap-task "Deadlock")
               (swap-task max-depth
                          (make-tasks (apply
                                       append
-                                        (hash-table-map (tasks-multi-waits tasks)
+                                      (hash-map (tasks-multi-waits tasks)
                                                       (lambda (k l)
                                                         (map (lambda (v) (v #f)) l))))
                                      (tasks-active-back tasks)
                                      (tasks-waits tasks)
-                                       (make-hash-table)
+                                     (make-hasheq)
                                      (tasks-cache tasks)
                                      #t))))
       (let ([t (car (tasks-active tasks))]
@@ -317,35 +316,35 @@
                                (tasks-progress? tasks))])
         (t max-depth tasks))))
 
-  ;; Finds the symbolic representative of a token class
-  (define-for-syntax (map-token toks tok)
+;; Finds the symbolic representative of a token class
+(define-for-syntax (map-token toks tok)
   (car (token-identifier-mapping-get toks tok)))
 
-  (define no-pos-val (make-position #f #f #f))
-  (define-for-syntax no-pos 
+(define no-pos-val (make-position #f #f #f))
+(define-for-syntax no-pos 
   (let ([npv ((syntax-local-certifier) #'no-pos-val)])
     (lambda (stx) npv)))
-  (define-for-syntax at-tok-pos
+(define-for-syntax at-tok-pos
   (lambda (sel expr)
     (lambda (stx)
       #`(let ([v #,expr]) (if v (#,sel v) no-pos-val)))))
 
-  ;; Builds a matcher for a particular alternative
-  (define-for-syntax (build-match nts toks pat handle $ctx)
+;; Builds a matcher for a particular alternative
+(define-for-syntax (build-match nts toks pat handle $ctx)
   (let loop ([pat pat]
              [pos 1])
     (if (null? pat)
         #`(success-k #,handle stream depth max-depth tasks 
                      (lambda (success-k fail-k max-depth tasks)
                        (fail-k max-depth tasks)))
-          (let ([id (datum->syntax-object (car pat)
+        (let ([id (datum->syntax (car pat)
                                         (string->symbol (format "$~a" pos)))]
-		[id-start-pos (datum->syntax-object (car pat)
+              [id-start-pos (datum->syntax (car pat)
                                                   (string->symbol (format "$~a-start-pos" pos)))]
-		[id-end-pos (datum->syntax-object (car pat)
+              [id-end-pos (datum->syntax (car pat)
                                                 (string->symbol (format "$~a-end-pos" pos)))]
               [n-end-pos (and (null? (cdr pat))
-                                (datum->syntax-object (car pat) '$n-end-pos))])
+                              (datum->syntax (car pat) '$n-end-pos))])
           (cond
             [(bound-identifier-mapping-get nts (car pat) (lambda () #f))
              ;; Match non-termimal
@@ -390,14 +389,14 @@
                            #,(loop (cdr pat) (add1 pos)))))
                      (fail-k max-depth tasks)))])))))
 
-  ;; Starts parsing to match a non-terminal. There's a minor
-  ;; optimization that checks for known starting tokens. Otherwise,
-  ;; use the cache, block if someone else is already trying the match,
-  ;; and cache the result if it's computed.
-  ;; The cache maps nontermial+startingpos+iteration to a result, where
-  ;; the iteration is 0 for the first match attempt, 1 for the second,
-  ;; etc.
-  (define (parse-nt/share key min-cnt init-tokens stream depth end max-depth tasks success-k fail-k k)
+;; Starts parsing to match a non-terminal. There's a minor
+;; optimization that checks for known starting tokens. Otherwise,
+;; use the cache, block if someone else is already trying the match,
+;; and cache the result if it's computed.
+;; The cache maps nontermial+startingpos+iteration to a result, where
+;; the iteration is 0 for the first match attempt, 1 for the second,
+;; etc.
+(define (parse-nt/share key min-cnt init-tokens stream depth end max-depth tasks success-k fail-k k)
   (if (and (positive? min-cnt)
            (pair? stream)
            (not (memq (tok-name (car stream)) init-tokens)))
@@ -416,13 +415,13 @@
               [old-stream stream])
           #;(printf "Loop ~a\n" table-key)
           (cond
-              [(hash-table-get (tasks-cache tasks) table-key (lambda () #f))
+            [(hash-ref (tasks-cache tasks) table-key (lambda () #f))
              => (lambda (result)
                   #;(printf "Reuse ~a\n" table-key)
                   (result success-k fail-k max-depth tasks))]
             [else
              #;(printf "Try ~a ~a\n" table-key (map tok-name stream))
-                 (hash-table-put! (tasks-cache tasks) table-key
+             (hash-set! (tasks-cache tasks) table-key
                               (lambda (success-k fail-k max-depth tasks)
                                 #;(printf "Wait ~a ~a\n" table-key answer-key)
                                 (wait-for-answer #t max-depth tasks answer-key success-k fail-k
@@ -436,7 +435,7 @@
                            ;; Check whether we already have a result that consumed the same amount:
                            (let ([result-key (vector #f key old-depth depth)])
                              (cond
-                                   [(hash-table-get (tasks-cache tasks) result-key (lambda () #f))
+                               [(hash-ref (tasks-cache tasks) result-key (lambda () #f))
                                 ;; Go for the next-result
                                 (result-loop max-depth
                                              tasks
@@ -456,8 +455,8 @@
                                                       tasks
                                                       (lambda (end max-depth tasks success-k fail-k)
                                                         (next-k success-k fail-k max-depth tasks))))])
-                                      (hash-table-put! (tasks-cache tasks) result-key #t)
-                                      (hash-table-put! (tasks-cache tasks) table-key
+                                  (hash-set! (tasks-cache tasks) result-key #t)
+                                  (hash-set! (tasks-cache tasks) table-key
                                                    (lambda (success-k fail-k max-depth tasks)
                                                      (success-k val stream depth max-depth tasks next-k)))
                                   (report-answer-all answer-key
@@ -469,7 +468,7 @@
                         [new-fail-k
                          (lambda (max-depth tasks)
                            #;(printf "Failure ~a\n" table-key)
-                               (hash-table-put! (tasks-cache tasks) table-key
+                           (hash-set! (tasks-cache tasks) table-key
                                             (lambda (success-k fail-k max-depth tasks)
                                               (fail-k max-depth tasks)))
                            (report-answer-all answer-key
@@ -480,7 +479,7 @@
                                                 (fail-k max-depth tasks))))])
                  (k end max-depth tasks new-got-k new-fail-k)))])))))
 
-  (define-syntax (cfg-parser stx)
+(define-syntax (cfg-parser stx)
   (syntax-case stx ()
     [(_ clause ...)
      (let ([clauses (syntax->list #'(clause ...))])
@@ -752,12 +751,15 @@
                               success-k
                               fail-k
                               0 (make-tasks null null 
-                                        (make-hash-table) (make-hash-table)
-                                        (make-hash-table 'equal) #t)))))))))]))
+                                            (make-hasheq) (make-hasheq)
+                                            (make-hash) #t)))))))))]))
 
-#|
-  ;; Tests used during development
 
+(module* test racket/base
+  (require (submod "..")
+           parser-tools/lex)
+  
+  ;; Tests used during development
   (define-tokens non-terminals (PLUS MINUS STAR BAR COLON EOF))
   
   (define lex
@@ -767,8 +769,10 @@
      ["*" (token-STAR '*)]
      ["|" (token-BAR '||)]
      [":" (token-COLON '|:|)]
+     [whitespace (lex input-port)]
      [(eof) (token-EOF 'eof)]))
   
+  
   (define parse
     (cfg-parser
      (tokens non-terminals)
@@ -792,11 +796,10 @@
     (let ([p (open-input-string #;"+*|-|-*|+**" #;"-|+*|+**" 
                                 #;"+*|+**|-" #;"-|-*|-|-*"
                                 #;"-|-*|-|-**|-|-*|-|-**"
-	      "-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***\
-               |-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|\
+                                "-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|-|-*|-|-**|-|-*|-|-***
+               |-|-*|-|-**|-|-*|-|-*****|-|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-****|
                -|-*|-|-**|-|-*|-|-***|-|-*|-|-**|-|-*|-|-*****"
                                 ;; This one fails:
                                 #;"+*")])
       (time (parse (lambda () (lex p))))))
-|#
-  )
+  (result))

collects/parser-tools/private-lex/token.rkt

@@ -83,7 +83,7 @@
   (define-syntax define-tokens (make-define-tokens #f))
   (define-syntax define-empty-tokens (make-define-tokens #t))
 
-  (define-struct position (offset line col))
-  (define-struct position-token (token start-pos end-pos))
+  (define-struct position (offset line col) #f)
+  (define-struct position-token (token start-pos end-pos) #f)
   )
 

collects/parser-tools/private-yacc/graph.rkt

@@ -12,7 +12,7 @@
   ;; We use a hash-table to represent the result function 'a -> 'b set, so
   ;; the values of type 'a must be comparable with eq?.
   (define (digraph nodes edges f- union fail)
-    (letrec (
+    (letrec [
              ;; Will map elements of 'a to 'b sets
              (results (make-hash-table))
              (f (lambda (x) (hash-table-get results x fail)))
@@ -51,7 +51,7 @@
                         (set-N p +inf.0)
                         (hash-table-put! results p (f x))
                         (if (not (eq? x p))
-			    (loop (pop)))))))))
+                            (loop (pop))))))))]
       (for-each (lambda (x)
                   (if (= 0 (get-N x))
                       (traverse x)))
@@ -59,8 +59,3 @@
       f))
 
 )
-
-
-
-
-

collects/parser-tools/private-yacc/lalr.rkt

@@ -134,7 +134,6 @@
                (f (map follow l)))
           (apply bitwise-ior (cons 0 f))))))
 
-
   (define (print-DR dr a g)
     (print-input-st-sym dr "DR" a g print-output-terms))
   (define (print-Read Read a g)
@@ -230,7 +229,7 @@
   ;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
   ;; A specialization of digraph in the file graph.rkt
   (define (digraph-tk->terml nodes edges f- num-states)
-    (letrec (
+    (letrec [
              ;; Will map elements of trans-key to term sets represented as bit vectors
              (results (init-tk-map num-states))
              
@@ -269,13 +268,10 @@
                       (set-N p +inf.0)
                       (set-f p (get-f x))
                       (unless (equal? x p)
-                        (loop (pop)))))))))
+                        (loop (pop))))))))]
       (for-each (lambda (x)
                   (when (= 0 (get-N x))
                     (traverse x)))
                 nodes)
       get-f))
 )
-
-
-