#cs
(module table mzscheme

  ;; Routine to build the LALR table
  
  (require "grammar.ss"
	   "lr0.ss"
	   "array2d.ss"
	   "lalr.ss"
	   "parser-actions.ss"
	   (lib "list.ss")
	   (lib "class.ss"))

  (provide build-table)

  
  (define (bit-vector-for-each f bv)
    (letrec ((for-each
              (lambda (bv number)
                (cond
                  ((= 0 bv) (void))
                  ((= 1 (bitwise-and 1 bv))
                   (f number)
                   (for-each (arithmetic-shift bv -1) (add1 number)))
                  (else (for-each (arithmetic-shift bv -1) (add1 number)))))))
      (for-each bv 0)))
                   
  
  ;; print-entry: symbol * action * output-port ->
  ;; prints the action a for lookahead sym to port
  (define (print-entry sym a port)
    (let ((s "\t~a\t\t\t\t\t~a\t~a\n"))
      (cond
       ((shift? a)
	(fprintf port s sym "shift" (shift-state a)))
       ((reduce? a)
	(fprintf port s sym "reduce" (reduce-prod-num a)))
       ((accept? a)
	(fprintf port s sym "accept" ""))
       (a
	(fprintf port s sym "goto" a)))))


  ;; count: ('a -> bool) * 'a list -> num
  ;; counts the number of elements in list that satisfy pred
  (define (count pred list)
    (cond
     ((null? list) 0)
     ((pred (car list)) (+ 1 (count pred (cdr list))))
     (else (count pred (cdr list)))))

  ;; display-parser: 
  ;;   action array2d * term vector * non-term vector * kernel vector * 
  ;;     output-port ->
  ;; Prints out the parser given by table.
  (define (display-parser a table terms non-terms prods port)
    (let* ((num-terms (vector-length terms))
	   (num-non-terms (vector-length non-terms))
	   (SR-conflicts 0)
	   (RR-conflicts 0))
      (for-each
       (lambda (prod)
         (fprintf port 
                  "~a\t~a\t=\t~a~n" 
                  (prod-index prod)
                  (gram-sym-symbol (prod-lhs prod))
                  (map gram-sym-symbol (vector->list (prod-rhs prod)))))
       prods)
      (send a for-each-state
       (lambda (state)
         (fprintf port "State ~a~n" (kernel-index state))
         (for-each (lambda (item)
                     (fprintf port "\t~a~n" (item->string item)))
                   (kernel-items state))
         (newline port)
         (let loop ((j 0))
           (if (< j num-terms)
               (begin
                 (let ((act (array2d-ref 
                             table 
                             (kernel-index state)
                             (+ j num-non-terms))))
                   (cond
                     ((list? act) 
                      (fprintf port "begin conflict:~n")
                      (if (> (count reduce? act) 1)
                          (set! RR-conflicts (add1 RR-conflicts)))
                      (if (> (count shift? act) 0)
                          (set! SR-conflicts (add1 SR-conflicts)))
                      (map (lambda (x) 
                             (print-entry 
                              (gram-sym-symbol (vector-ref terms j))
                              x
                              port))
                           act)
                      (fprintf port "end conflict~n"))
                     (act (print-entry
                           (gram-sym-symbol (vector-ref terms j))
                           act
                           port))))
                 (loop (add1 j)))))
         
         (newline port)
         
         (let loop ((j 0))
           (if (< j num-non-terms)
               (begin
                 (let ((s (array2d-ref table (kernel-index state) j)))
                   (if s
                       (print-entry
                        (gram-sym-symbol (vector-ref non-terms j))
                        s
                        port)))
                 (loop (add1 j)))))
         
         (newline port)))

      (if (> SR-conflicts 0)
	  (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
      (if (> RR-conflicts 0)
	  (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))

  (define (resolve-conflicts a table num-terms num-non-terms suppress)
    (letrec ((SR-conflicts 0)
	     (RR-conflicts 0)
	     (get-action
	      (lambda (entry)
		(cond
		 ((list? entry)
		  (if (> (count shift? entry) 0)
		      (set! SR-conflicts (add1 SR-conflicts)))
		  (if (> (count reduce? entry) 1)
		      (set! RR-conflicts (add1 RR-conflicts)))
		  (let loop ((current-guess (make-reduce +inf.0 -1 -1))
			     (rest entry))
		    (cond
		     ((null? rest) current-guess)
		     ((shift? (car rest)) (car rest))
		     ((< (reduce-prod-num (car rest))
			 (reduce-prod-num current-guess))
		      (loop (car rest) (cdr rest)))
		     (else (loop current-guess (cdr rest))))))
		 (else entry)))))
      (send a for-each-state
       (lambda (state)
         (let loop ((term 0))
           (if (< term num-terms)
               (begin
                 (array2d-set! table (kernel-index state) (+ num-non-terms term)
                               (get-action
                                (array2d-ref table 
                                             (kernel-index state) 
                                             (+ num-non-terms term))))
                 (loop (add1 term)))))))
      (if (not suppress)
          (begin
            (if (> SR-conflicts 0)
                (fprintf (current-error-port) 
                         "~a shift/reduce conflicts~n" 
                         SR-conflicts))
            (if (> RR-conflicts 0)
                (fprintf (current-error-port)
                         "~a reduce/reduce conflicts~n"
                         RR-conflicts))))))
    


  (define (resolve-prec-conflicts a table get-term get-prod
				  num-terms num-non-terms)
    (send a for-each-state
     (lambda (state)
       (let loop ((term 0))
         (if (< term num-terms)
             (begin
               (let ((action (array2d-ref table 
                                          (kernel-index state)
                                          (+ num-non-terms term))))
                 (if (and (list? action)
                          (= 2 (length action))
                          (or (shift? (car action))
                              (shift? (cadr action))))
                     (let* ((shift (if (shift? (car action))
                                       (car action)
                                       (cadr action)))
                            (reduce (if (shift? (car action))
                                        (cadr action)
                                        (car action)))
                            (s-prec (term-prec
                                     (vector-ref get-term
                                                 term)))
                            (r-prec (prod-prec
                                     (vector-ref 
                                      get-prod
                                      (reduce-prod-num reduce)))))
                       (if (and s-prec r-prec)
                           (array2d-set!
                            table
                            (kernel-index state)
                            (+ num-non-terms term)
                            (cond
                              ((< (prec-num s-prec)
                                  (prec-num r-prec))
                               reduce)
                              ((> (prec-num s-prec)
                                  (prec-num r-prec))
                               shift)
                              ((eq? 'left (prec-assoc s-prec))
                               reduce)
                              ((eq? 'right (prec-assoc s-prec))
                               shift)
                              (else #f)))))))
               (loop (add1 term))))))))

  ;; In the result table the first index is the state and the second is the 
  ;; term/non-term index (with the non-terms coming first)
  ;; buile-table: grammar * string -> action2d-array
  (define (build-table g file suppress)
    (let* ((a (time (build-lr0-automaton g)))
           (terms (send g get-terms))
           (non-terms (send g get-non-terms))
           (get-term (list->vector terms))
           (get-non-term (list->vector non-terms))
           (get-prod (list->vector (send g get-prods)))
           (num-terms (vector-length get-term))
           (num-non-terms (vector-length get-non-term))
           (end-term-indexes 
            (map
             (lambda (term)
               (+ num-non-terms (gram-sym-index term)))
             (send g get-end-terms)))
           (num-gram-syms (+ num-terms num-non-terms))
           (table (make-array2d (vector-length (send a get-states)) num-gram-syms #f))
           (array2d-add!
            (lambda (v i1 i2 a)
              (let ((old (array2d-ref v i1 i2)))
                (cond
                  ((not old) (array2d-set! v i1 i2 a))
                  ((list? old) (if (not (member a old))
                                   (array2d-set! v i1 i2 (cons a old))))
                  (else (if (not (equal? a old))
                            (array2d-set! v i1 i2 (list a old))))))))
           (get-lookahead (time (compute-LA a g))))
      (time
       (send a for-each-state
             (lambda (state)
               (let loop ((i 0))
                 (if (< i num-gram-syms)
                     (begin
                       (let* ((s (if (< i num-non-terms)
                                     (vector-ref get-non-term i)
                                     (vector-ref get-term (- i num-non-terms))))
                              (goto
                               (send a run-automaton state s)))
                         (if goto
                             (array2d-set! table 
                                           (kernel-index state) 
                                           i
                                           (cond
                                             ((< i num-non-terms)
                                              (kernel-index goto))
                                             ((member i end-term-indexes)
                                              (make-accept))
                                             (else
                                              (make-shift 
                                               (kernel-index goto)))))))
                       (loop (add1 i)))))
               
               (for-each
                (lambda (item)
                  (let ((item-prod (item-prod item)))
                    (bit-vector-for-each 
                     (lambda (term-index)
                       (array2d-add! table 
                                     (kernel-index state)
                                     (+ num-non-terms term-index)
                                     (cond
                                       ((not (start-item? item))
                                        (make-reduce
                                         (prod-index item-prod)
                                         (gram-sym-index (prod-lhs item-prod))
                                         (vector-length (prod-rhs item-prod)))))))
                     (get-lookahead state item-prod))))
                
                (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
                        (filter (lambda (item)
                                  (not (move-dot-right item)))
                                (kernel-items state)))))))
      
      (resolve-prec-conflicts a table get-term get-prod num-terms
                              num-non-terms)
      
      (if (not (string=? file ""))
          (with-handlers [(exn:i/o:filesystem?
                           (lambda (e)
                             (fprintf 
                              (current-error-port)
                              "Cannot write debug output to file \"~a\".  ~a~n"
                              (exn:i/o:filesystem-pathname e)
                              (exn:i/o:filesystem-detail e))))]
            (call-with-output-file file
              (lambda (port)
                (display-parser a table get-term get-non-term (send g get-prods)
                                port)))))
      (resolve-conflicts a table num-terms num-non-terms suppress)
      table))
)