Modify cfg-parser's treatment of error function so it can consume both arity-3 and arity-5 error functions.

Meant to match the interface provided by parser-tools/yacc's parser.

original commit: 3d1f8b4406a2ae35b0717f757ead805e6bf9d3f4

collects/algol60/cfg-parser.rkt

@@ -1,7 +0,0 @@
-#lang racket/base
-
-;; Legacy module.  cfg-parser used to live in the algol60 collection.
-;; This module re-exports its contents for backwards compatibility.
-
-(require parser-tools/cfg-parser)
-(provide (all-from-out parser-tools/cfg-parser))

collects/parser-tools/cfg-parser.rkt

@@ -744,14 +744,20 @@
                                    val
                                    (next success-k fail-k max-depth tasks)))]
                             [fail-k (lambda (max-depth tasks)
+                                      (define (call-error-proc tok-ok? tok-name tok-value start-pos end-pos)
+                                        (cond
+                                         [(procedure-arity-includes? error-proc 5)
+                                          (error-proc tok-ok? tok-name tok-value start-pos end-pos)]
+                                         [else
+                                          (error-proc tok-ok? tok-name tok-value)]))
                                       (cond
                                        [(null? tok-list)
                                         (if error-proc
-                                            (error-proc #t
-                                                        'no-tokens
-                                                        #f
-                                                        (make-position #f #f #f)
-                                                        (make-position #f #f #f))
+                                            (call-error-proc #t
+                                                             'no-tokens
+                                                             #f
+                                                             (make-position #f #f #f)
+                                                             (make-position #f #f #f))
                                             (error
                                              'cfg-parse
                                              "no tokens"))]
@@ -760,11 +766,11 @@
                                                                  (min (sub1 (length tok-list))
                                                                       max-depth))])
                                           (if error-proc
-                                              (error-proc #t
-                                                          (tok-orig-name bad-tok)
-                                                          (tok-val bad-tok)
-                                                          (tok-start bad-tok)
-                                                          (tok-end bad-tok))
+                                              (call-error-proc #t
+                                                               (tok-orig-name bad-tok)
+                                                               (tok-val bad-tok)
+                                                               (tok-start bad-tok)
+                                                               (tok-end bad-tok))
                                               (error
                                                'cfg-parse
                                                "failed at ~a" 
@@ -799,6 +805,7 @@
   (require (submod "..")
            parser-tools/lex
            racket/block
+           racket/generator
            rackunit)
 
   ;; Test: parsing regular expressions.
@@ -848,6 +855,60 @@
                               1 13)))
   
 
+  ;; Check that cfg-parser can accept error functions of 3 arguments:
+  (block
+   (define-tokens non-terminals (ONE ZERO EOF))
+   (define parse
+     (cfg-parser (tokens non-terminals)
+                 (start ones)
+                 (end EOF)
+                 (error (lambda (tok-ok tok-name tok-val)
+                          (error (format "~a ~a ~a" tok-ok tok-name tok-val))))
+                 (grammar [ones [() null]
+                                [(ONE ones) (cons $1 $2)]])))
+   (define (sequence->tokenizer s)
+     (define-values (more? next) (sequence-generate s))
+     (lambda ()
+       (cond [(more?) (next)]
+             [else (token-EOF 'eof)])))
+   (check-exn #rx"#t ZERO zero" 
+              (lambda () (parse (sequence->tokenizer (list (token-ZERO "zero")))))))
+
+
+
+
+  ;; Check that cfg-parser can accept error functions of 5 arguments:
+  (block
+   (define-tokens non-terminals (ONE ZERO EOF))
+   (define parse
+     (cfg-parser (tokens non-terminals)
+                 (start ones)
+                 (src-pos)
+                 (end EOF)
+                 (error (lambda (tok-ok tok-name tok-val start-pos end-pos)
+                          (error (format "~a ~a ~a ~a ~a" 
+                                         tok-ok tok-name tok-val
+                                         (position-offset start-pos)
+                                         (position-offset end-pos)))))
+                 (grammar [ones [() null]
+                                [(ONE ones) (cons $1 $2)]])))
+   (define (sequence->tokenizer s)
+     (define-values (more? next) (sequence-generate s))
+     (lambda ()
+       (cond [(more?) (next)]
+             [else (position-token (token-EOF 'eof)
+                                   (position #f #f #f)
+                                   (position #f #f #f))])))
+   (check-exn #rx"#t ZERO zero 2 3"
+              (lambda () 
+                (parse 
+                 (sequence->tokenizer 
+                  (list (position-token 
+                         (token-ZERO "zero")
+                         (position 2 2 5) 
+                         (position 3 2 6))))))))
+
+