*** empty log message ***

original commit: dc2758d4ddd339d1c509d67da9362ae660764e04

collects/parser-tools/private-lex/token-syntax.ss

@@ -15,7 +15,7 @@
 	runtime
 	`(begin
 	   (define-syntax ,(syntax name)
-	     (make-terminals-def ',(syntax (terms ...))))
+	     (make-terminals-def (quote-syntax ,(syntax (terms ...)))))
 	   ,@(map
 	      (lambda (n)
                 (if (eq? (syntax-object->datum n) 'error)

collects/parser-tools/private-yacc/input-file-parser.ss

@@ -6,7 +6,7 @@
   
   (require "yacc-helper.ss" "../private-lex/token-syntax.ss" "grammar.ss" (lib "list.ss"))
 
-  (provide parse-input)
+  (provide parse-input get-term-list)
 
   ;; get-args: num * syntax-object -> syntax-object list
   (define (get-args x act src-pos)
@@ -110,28 +110,22 @@
   (define (get-terms-from-def term-syn)
     (let ((t (syntax-local-value term-syn (lambda () #f))))
       (cond
-       ((terminals-def? t) (terminals-def-t t))
+       ((terminals-def? t) (syntax->list (terminals-def-t t)))
        (else
 	(raise-syntax-error 
          'parser-tokens
          "undefined token group"
          term-syn)))))
 
-  ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar
+  ;; get-term-list: syntax-object -> syntax-object list
-  (define (parse-input start ends term-defs prec-decls prods runtime src-pos)
+  (define (get-term-list so)
-    (let* ((counter 0)
+    (syntax-case* so (tokens)
-           
-           (start-sym (syntax-object->datum start))
-                          
-           
-           (list-of-terms
-            (syntax-case* term-defs (tokens)
       (lambda (a b)
         (eq? (syntax-object->datum a) (syntax-object->datum b)))
       ((tokens term-def ...)
        (andmap identifier? (syntax->list (syntax (term-def ...))))
        (remove-duplicates
-                (cons 'error
+        (cons (datum->syntax-object #f 'error)
               (apply append
                      (map get-terms-from-def 
                           (syntax->list (syntax (term-def ...))))))))
@@ -139,7 +133,15 @@
        (raise-syntax-error
         'parser-tokens
         "Token declaration must be (tokens symbol ...)"
-                term-defs))))
+        so))))
+  
+  ;; parse-input: syntax-object * syntax-object list * syntax-object^4 * boolean-> grammar
+  (define (parse-input start ends term-defs prec-decls prods runtime src-pos)
+    (let* ((counter 0)
+           
+           (start-sym (syntax-object->datum start))
+
+           (list-of-terms (map syntax-object->datum (get-term-list term-defs)))
 
            (end-terms
             (map

collects/parser-tools/private-yacc/parser-builder.ss

@@ -8,6 +8,20 @@
   
   (provide build-parser)
   
+  (define (fix-check-syntax start terms prods)
+    (syntax-case prods ()
+      ((_ (bind ((bound ...) x ...) ...) ...)
+       (let ((binds (syntax->list (syntax (bind ...))))
+             (bounds (cons start 
+                           (apply append (map syntax->list 
+                                              (apply append (map syntax->list 
+                                                                 (syntax->list (syntax (((bound ...) ...) ...)))))))))
+             (terms (get-term-list terms)))
+         `(if #f (let ,(map (lambda (bind)
+                              `(,bind void))
+                            (append terms binds))
+                   (void ,@bounds)))))))
+  
   (define (build-parser filename src-pos suppress error-expr input-terms start end assocs prods runtime src)
     (let* ((grammar (parse-input start end input-terms assocs prods runtime src-pos))
            (table (build-table grammar filename suppress))
@@ -195,5 +209,5 @@
                                #f #f #f #f #f)))))))))))
       (datum->syntax-object
        runtime
-       parser-code
+       `(begin #|,(fix-check-syntax start input-terms prods)|# ,parser-code)
        src))))

collects/parser-tools/private-yacc/yacc-helper.ss

@@ -28,7 +28,9 @@
 		      (dl? (cdr l)))))))
       (dl? l)))
 
-  ;; remove-duplicates: symbol list -> symbol list
+  (require (lib "pretty.ss"))
+  
+  ;; remove-duplicates: syntax-object list -> syntax-object list
   ;; removes the duplicates from the lists
   (define (remove-duplicates sl)
     (let ((t (make-hash-table)))
@@ -36,10 +38,10 @@
 		(lambda (sl)
 		  (cond
 		   ((null? sl) sl)
-		   ((hash-table-get t (car sl) (lambda () #f))
+		   ((hash-table-get t (syntax-object->datum (car sl)) (lambda () #f))
 		    (x (cdr sl)))
 		   (else 
-		    (hash-table-put! t (car sl) #t)
+		    (hash-table-put! t (syntax-object->datum (car sl)) #t)
 		    (cons (car sl) (x (cdr sl))))))))
 	(x sl))))