;;; synfl-tests.el --- tests and examples for synfl

;; Copyright (C) 2004 Stephen J. Turnbull

;; Author: Stephen J. Turnbull <stephen@xemacs.org>
;; Created: 15 April 2004
;; Keywords: font-lock, parsing, tests

;; This file is part of synfl.
;; It is not part of XEmacs.

;; synfl is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License, version 2, as
;; published by the Free Software Foundation.

;; synfl is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with Emacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in GNU Emacs
 
;;; Commentary:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
(require 'synfl)

;; simple-node class
(defconst simple-node-class
  (synfl-node-make-class 'simple-node (+ synfl-node-predefined-size 0)
    :constructor	(lambda (object) ; argument ignored
			  (let ((node (gensym "Node")))
			    (put node :node-class simple-node-class)
			    node))
    :tree-constructor	#'synfl-node-make-tree
    :children		(lambda (node) (get node :children))
    :set-children	(lambda (node children) (put node :children children))
    :symbol		(lambda (node) (get node :symbol))
    :set-symbol		(lambda (node symbol) (put node :symbol symbol)))
  "A node class for making simple trees.")


;; A simple stream for testing
;; A token stream from a list of terminals

(put 'synfl-token-stream-from-terminal-list 'lisp-indent-function 2)
(defun synfl-token-stream-from-terminal-list (name grammar list)
  "Initialize NAME as a token stream for GRAMMAR from LIST.
LIST is a list of terminal symbols (name or object) from some synfl grammar.
Iterates over the list converting names to objects, ie tokens.
Checks that the list contains only terminals from a single grammar.

All of the arguments are used unevaluated."

  (interactive "SName of stream: \nSName of grammar: \nxList of symbols: ")

  (setq grammar (synfl-find-grammar grammar))
  (synfl-token-stream-prepare-terminal-list list grammar)
  ;; fields required by the API
  (put name :synfl-stream-class 'terminal-list-stream)
  (put name :iterate (lambda (stream)
		       (let* ((s (get stream :state)))
			 (if (null s)
			     :eof
			   (prog1 (car s) (put stream :state (cdr s)))))))
  (put name :rewind (lambda (stream)
		      (put stream :state (get stream :state-initial))))
  (put name :token-type #'identity)
  (put name :token-value (lambda (x) nil))
  (put name :token-text #'synfl-name)
  ;; specific to the 'terminal-list-stream class
  (put name :stream-grammar grammar)
  (put name :state-initial list)
  (put name :state list)
  name)


(defun synfl-token-stream-prepare-terminal-list (list grammar)
  "Check that all elements of LIST are terminals from GRAMMAR.
Otherwise signal `wrong-type-argument'.

Convert symbol names to symbol objects of GRAMMAR by side effect.
No useful return values."

  (setq grammar (synfl-find-grammar grammar))

  (let ((l list))
    (while l
      (let ((x (car l)))
	(unless (synfl-terminal-p x)
	  (setq x (synfl-grammar-symbol grammar x)))
	(synfl-check-terminal x)
	(unless (eq grammar (synfl-grammar x))
	  (error 'wrong-type-argument
		 "inconsistent grammars for symbol"
		 (synfl-name x) grammar (synfl-grammar x)))
	(setcar l x)
	(setq l (cdr l))))))


;; testing

(defun synfl-test-print-production (tree production state token stack)
  "Output the production being reduced using `princ'."
  (synfl-production-print production)
  (terpri))


;; an example: Aho, Sethi, Ullman _Compilers_, Example 4.33
;; example -> p. 218, parser tables -> p. 219

(defun synfl-test-asu4-33 ()
  (interactive)

  ;; set up get-input, element lists, and productions
  (setq synfl-grammars (delete (assq 'asu4-33 synfl-grammars) synfl-grammars))

  (synfl-make-grammar 'asu4-33
    '(add mul lpar rpar id)
    '(expr term fact)
    'expr
    '((expr	(expr add term)		synfl-test-print-production)
      (expr	(term)			synfl-test-print-production)
      (term	(term mul fact)		synfl-test-print-production)
      (term	(fact)			synfl-test-print-production)
      (fact	(lpar expr rpar)	synfl-test-print-production)
      (fact	(id)			synfl-test-print-production)))

  ;; load parse table by hand
  (let* ((grammar (synfl-find-grammar 'asu4-33))
	 (atable (list :action-table))
	 (gtable (list :goto-table))
	 (productions (cons nil (get grammar :production))))
    (synfl-set-action atable 'id 0 :shift 5)
    (synfl-set-action atable 'id 4 :shift 5)
    (synfl-set-action atable 'id 6 :shift 5)
    (synfl-set-action atable 'id 7 :shift 5)
    (synfl-set-action atable 'add 1 :shift 6)
    (synfl-set-action atable 'add 2 :reduce (nth 2 productions))
    (synfl-set-action atable 'add 3 :reduce (nth 4 productions))
    (synfl-set-action atable 'add 5 :reduce (nth 6 productions))
    (synfl-set-action atable 'add 8 :shift 6)
    (synfl-set-action atable 'add 9 :reduce (nth 1 productions))
    (synfl-set-action atable 'add 10 :reduce (nth 3 productions))
    (synfl-set-action atable 'add 11 :reduce (nth 5 productions))
    (synfl-set-action atable 'mul 2 :shift 7)
    (synfl-set-action atable 'mul 3 :reduce (nth 4 productions))
    (synfl-set-action atable 'mul 5 :reduce (nth 6 productions))
    (synfl-set-action atable 'mul 9 :shift 7)
    (synfl-set-action atable 'mul 10 :reduce (nth 3 productions))
    (synfl-set-action atable 'mul 11 :reduce (nth 5 productions))
    (synfl-set-action atable 'lpar 0 :shift 4)
    (synfl-set-action atable 'lpar 4 :shift 4)
    (synfl-set-action atable 'lpar 6 :shift 4)
    (synfl-set-action atable 'lpar 7 :shift 4)
    (synfl-set-action atable 'rpar 2 :reduce (nth 2 productions))
    (synfl-set-action atable 'rpar 3 :reduce (nth 4 productions))
    (synfl-set-action atable 'rpar 5 :reduce (nth 6 productions))
    (synfl-set-action atable 'rpar 8 :shift 11)
    (synfl-set-action atable 'rpar 9 :reduce (nth 1 productions))
    (synfl-set-action atable 'rpar 10 :reduce (nth 3 productions))
    (synfl-set-action atable 'rpar 11 :reduce (nth 5 productions))
    (synfl-set-action atable :eof 1 :accept nil)
    (synfl-set-action atable :eof 2 :reduce (nth 2 productions))
    (synfl-set-action atable :eof 3 :reduce (nth 4 productions))
    (synfl-set-action atable :eof 5 :reduce (nth 6 productions))
    (synfl-set-action atable :eof 9 :reduce (nth 1 productions))
    (synfl-set-action atable :eof 10 :reduce (nth 3 productions))
    (synfl-set-action atable :eof 11 :reduce (nth 5 productions))
    (synfl-set-goto gtable 'expr 0 1)
    (synfl-set-goto gtable 'expr 4 8)
    (synfl-set-goto gtable 'term 0 2)
    (synfl-set-goto gtable 'term 4 2)
    (synfl-set-goto gtable 'term 6 9)
    (synfl-set-goto gtable 'fact 0 3)
    (synfl-set-goto gtable 'fact 4 3)
    (synfl-set-goto gtable 'fact 6 3)
    (synfl-set-goto gtable 'fact 7 10)
    (put grammar :action-table atable)
    (put grammar :goto-table gtable)
    )

  (synfl-token-stream-from-terminal-list 'my-stream 'asu4-33
    '(id mul id add id))

  ;; OK, let's do it!
  (with-displaying-temp-buffer "*Parse trace for asu4-33*"

    (synfl-grammar-print 'asu4-33)
    (terpri)
    (synfl-tables-print 'asu4-33)
    (terpri)
    (synfl-stream-print 'my-stream)
    (terpri)

    (princ "Parse trace:\n")
    (synfl-lr-parse 'my-stream 'asu4-33 simple-node-class)))

;;
;; an example: Aho, Sethi, Ullman _Compilers_, Example 4.42
;; example -> p. 231, parser tables -> p. 236
;;
(defun synfl-test-asu4-42 ()
  (interactive)

  ;; set up get-input, element lists, and productions
  (setq synfl-grammars (delete (assq 'asu4-42 synfl-grammars) synfl-grammars))

  (synfl-make-grammar 'asu4-42
    '(c d)
    '(S C)
    'S
    '((S	(C C)		synfl-test-print-production)
      (C	(c C)		synfl-test-print-production)
      (C	(d)		synfl-test-print-production)))

  ;; load parse table by hand
  (let* ((grammar (synfl-find-grammar 'asu4-42))
	 (atable (list :action-table))
	 (gtable (list :goto-table))
	 (productions (cons nil (get grammar :production))))
    (synfl-set-action atable 'c 0 :shift 3)
    (synfl-set-action atable 'c 2 :shift 6)
    (synfl-set-action atable 'c 3 :shift 3)
    (synfl-set-action atable 'c 4 :reduce (nth 3 productions))
    (synfl-set-action atable 'c 6 :shift 6)
    (synfl-set-action atable 'c 8 :reduce (nth 2 productions))
    (synfl-set-action atable 'd 0 :shift 4)
    (synfl-set-action atable 'd 2 :shift 7)
    (synfl-set-action atable 'd 3 :shift 4)
    (synfl-set-action atable 'd 4 :reduce (nth 3 productions))
    (synfl-set-action atable 'd 6 :shift 7)
    (synfl-set-action atable 'd 8 :reduce (nth 2 productions))
    (synfl-set-action atable :eof 1 :accept nil)
    (synfl-set-action atable :eof 5 :reduce (nth 1 productions))
    (synfl-set-action atable :eof 7 :reduce (nth 3 productions))
    (synfl-set-action atable :eof 9 :reduce (nth 2 productions))
    (synfl-set-goto gtable 'S 0 1)
    (synfl-set-goto gtable 'C 0 2)
    (synfl-set-goto gtable 'C 2 5)
    (synfl-set-goto gtable 'C 3 8)
    (synfl-set-goto gtable 'C 6 9)
    (put grammar :action-table atable)
    (put grammar :goto-table gtable)
    )

  (with-displaying-temp-buffer "*Parser tables for asu4-42*"
    (synfl-grammar-print 'asu4-42)
    (terpri)
    (synfl-tables-print 'asu4-42)))


;; an example: Aho, Sethi, Ullman _Compilers_, Example 4.34
;; example for closure and goto operation -> p. 222-224

(defun synfl-test-asu4-34 ()
  (interactive)

  ;; set up get-input, element lists, and productions
  (setq synfl-grammars (delete (assq 'asu4-34 synfl-grammars) synfl-grammars))

  (synfl-make-grammar 'asu4-34
    '(+ * \( \) id)
    '(Ep E T F)
    'Ep
    '((Ep	(E)		synfl-test-print-production)
      (E	(E + T)		synfl-test-print-production)
      (E	(T)		synfl-test-print-production)
      (T	(T * F)		synfl-test-print-production)
      (T	(F)		synfl-test-print-production)
      (F	(\( E \))	synfl-test-print-production)
      (F	(id)		synfl-test-print-production)))

  (with-displaying-temp-buffer "*Grammar, closure, and goto for asu4-34, 35*"
    (synfl-grammar-print 'asu4-34)
    (terpri)
    (princ "Closure of the initial item:\n")
    (mapcar (lambda (x)
	      (synfl-item-print x)
	      (terpri))
	    (reverse
	     (synfl-compute-closure
	      (list (synfl-make-item (car (synfl-grammar-productions
					   (synfl-find-grammar 'asu4-34)))
				     0)))))
    (terpri)
    (let ((items (list (synfl-make-item (car (synfl-grammar-productions
					      (synfl-find-grammar 'asu4-34)))
					1)
		       (synfl-make-item (cadr (synfl-grammar-productions
					       (synfl-find-grammar 'asu4-34)))
					1))))
      (princ "Goto of [")
      (synfl-item-print (car items))
      (princ ", ")
      (synfl-item-print (cadr items))
      (princ "] on +:\n")
      (mapcar (lambda (x)
		(synfl-item-print x)
		(terpri))
	      (reverse
	       (synfl-compute-goto items '+))))
    ))


;; an example: Aho, Sethi, Ullman _Compilers_, Example 4.36
;; example for sets of items construction -> p. 224-6

(defun synfl-test-asu4-36 ()
  (interactive)

  ;; set up get-input, element lists, and productions
  (setq synfl-grammars (delete (assq 'asu4-36 synfl-grammars) synfl-grammars))

  (synfl-make-grammar 'asu4-36
    '(id + * \( \))
    '(E T F)
    'E
    '((E	(E + T)		synfl-test-print-production)
      (E	(T)		synfl-test-print-production)
      (T	(T * F)		synfl-test-print-production)
      (T	(F)		synfl-test-print-production)
      (F	(\( E \))	synfl-test-print-production)
      (F	(id)		synfl-test-print-production)))

  (with-displaying-temp-buffer "*Grammar, items sets, tables for asu4-36*"
    (synfl-grammar-print 'asu4-36)
    (terpri)
    (synfl-collection-print
     (synfl-compute-sets-of-slr-items (synfl-find-grammar 'asu4-36)))
    (terpri)
    (synfl-grammar-print 'asu4-36)
    (terpri)
    (synfl-generate-first 'asu4-36)
    (synfl-generate-follow 'asu4-36)
    (synfl-generate-parser 'asu4-36)
    (synfl-tables-print 'asu4-36)

    (synfl-token-stream-from-terminal-list 'my-stream 'asu4-36
      '(id * id + id))

    (synfl-stream-print 'my-stream)
    (terpri)

    (princ "Parse trace:\n")
    (synfl-lr-parse 'my-stream 'asu4-36 simple-node-class)
  ))
