*** empty log message ***

original commit: 61c73a6a8496b6340326e3396d29289fd5aacdce

collects/parser-tools/lex.ss

@@ -10,7 +10,7 @@
   (provide lex define-lex-abbrev define-lex-abbrevs
 	   make-lex-buf
 	   get-position position-offset position-line position-col position?
-           define-tokens define-empty-tokens token-value token-name token?)
+           define-tokens define-empty-tokens)
 
 
   (define-syntax lex
@@ -27,9 +27,9 @@
 			   (lambda ()
 			     end-pos)
 			   (lambda ()
-			     (list->string (reverse (filter (lambda (x) 
-							      (char? x))
-							    match))))
+			     (if (char? (car match))
+				 (list->string (reverse match))
+				 (list->string (reverse (cdr match)))))				 
 			   lb)))))
 	      (lambda (lb)
 		(unless (lex-buffer? lb)
@@ -37,7 +37,7 @@
 			       (format 
 				"Lexer expects argument of type lex-buf; given ~a" lb)))
 		(let ((first-pos (get-position lb)))
-		  (let loop (
+		  (let lexer-loop (
 				   ;; current-state
 				   (state start-state)
 				   ;; the character to transition on
@@ -51,6 +51,7 @@
 				   (length 1)
 				   ;; how many characters are in the longest match
 				   (longest-match-length 0)
+				   ;;(end-pos first-pos))
 				   (end-pos first-pos))
 		    (let ((next-state
 			   (cond
@@ -70,16 +71,17 @@
 						longest-match-action
 						length))
 		       (else
-			(loop next-state 
+			(let ((act (vector-ref actions next-state)))
+			  (lexer-loop next-state 
 				      (next-char lb)
-			      (if (vector-ref actions next-state)
-				  (vector-ref actions next-state)
+				      (if act
+					  act
 					  longest-match-action)
 				      (add1 length)
-			      (if (vector-ref actions next-state)
+				      (if act
 					  length
 					  longest-match-length)
-			      pos))))))))))
+				      pos)))))))))))
       (lambda (stx)
 	(syntax-case stx ()
 		     ((_ (re act) ...) 
@@ -224,8 +226,3 @@
 )
 
 
-
-
-
-
-

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

@@ -7,7 +7,7 @@
 
   (provide define-tokens define-empty-tokens token-name token-value token?)
 
-  (define-struct token (name value))
+  (define-struct token (name value) (make-inspector))
 
   (define-syntax define-tokens
     (lambda (stx)

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

@@ -14,7 +14,7 @@
            (table-code 
             `((lambda (table-list)
                 (let ((v (list->vector table-list)))
-                  (let loop ((i 0))
+                  (let build-table-loop ((i 0))
                     (cond
                       ((< i (vector-length v))
                        (let ((vi (vector-ref v i)))
@@ -27,7 +27,7 @@
                                            ((eq? 'r (car vi))
                                             (make-reduce (cadr vi) (caddr vi) (cadddr vi)))
                                            ((eq? 'a (car vi)) (make-accept)))))))
-                       (loop (add1 i)))
+                       (build-table-loop (add1 i)))
                       (else v)))))
               (quote
                ,(map (lambda (action)
@@ -71,26 +71,12 @@
                              (values s v))))
                       (fix-error
                        (lambda (stack ip get-token)
-                         (let remove-states ()
-                           (let ((a (find-action stack 'error)))
-                             (cond
-                               ((shift? a)
-				(printf "shift:~a~n" (shift-state a))
-                                (set! stack (cons (shift-state a) (cons #f stack))))
-                               (else
-                                (printf "discard-state:~a~n" (car stack))
-                                (cond
-                                  ((< (length stack) 3)
-                                   (printf "Unable to shift error token~n")
-                                   #f)
-                                  (else
-                                   (set! stack (cddr stack))
-                                   (remove-states)))))))
-                         (let remove-input ()
+                         (letrec ((remove-input
+				   (lambda ()
 				     (let ((a (find-action stack ip)))
 				       (cond
 					((shift? a)
-                                (printf "shift:~a~n" (shift-state a))
+					 ;; (printf "shift:~a~n" (shift-state a))
 					 (cons (shift-state a)
 					       (cons (if (token? ip)
 							 (token-value ip)
@@ -101,7 +87,25 @@
 									  (token-name ip)
 									  ip))
 					 (set! ip (get-token))
-                                (remove-input)))))))
+					 (remove-input))))))
+				  (remove-states
+				   (lambda ()
+				     (let ((a (find-action stack 'error)))
+				       (cond
+					((shift? a)
+					 ;; (printf "shift:~a~n" (shift-state a))
+					 (set! stack (cons (shift-state a) (cons #f stack)))
+					 (remove-input))				      
+					(else
+					 ;; (printf "discard-state:~a~n" (car stack))
+					 (cond
+					  ((< (length stack) 3)
+					   (printf "Unable to shift error token~n")
+					   #f)					
+					  (else
+					   (set! stack (cddr stack))
+					   (remove-states)))))))))
+			   (remove-states))))
                       
                       (find-action
                        (lambda (stack tok)
@@ -113,7 +117,7 @@
                                                           tok)
                                                       err)))))
                (lambda (get-token)
-                 (let loop ((stack (list 0))
+                 (let parsing-loop ((stack (list 0))
 				    (ip (get-token)))
                    ;;(display stack)
                    ;;(newline)
@@ -126,7 +130,7 @@
                         (let ((val (if (token? ip)
                                        (token-value ip)
                                        #f)))
-                          (loop (cons (shift-state action) (cons val stack))
+                          (parsing-loop (cons (shift-state action) (cons val stack))
                                         (get-token))))
                        ((reduce? action)
                         ;; (printf "reduce:~a~n" (reduce-prod-num action))
@@ -136,7 +140,7 @@
                                                     null)))
                           (let* ((A (reduce-lhs-num action))
                                  (goto (array2d-ref table (car new-stack) A)))
-                            (loop (cons goto 
+                            (parsing-loop (cons goto 
                                                 (cons (apply 
                                                        (vector-ref actions 
                                                                    (reduce-prod-num action))
@@ -150,10 +154,9 @@
                         (err)
                         (let ((new-stack (fix-error stack ip get-token)))
                           (if new-stack
-                              (loop new-stack (get-token))
+                              (parsing-loop new-stack (get-token))
                               (void)))))))))))
       (datum->syntax-object
        runtime
        parser-code
        src))))
-