TimeKeeper/audio/flite-2.0.0-release/tools/make_lts_rewrite.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                     ;;;
;;;                  Language Technologies Institute                    ;;;
;;;                     Carnegie Mellon University                      ;;;
;;;                         Copyright (c) 2002                          ;;;
;;;                        All Rights Reserved.                         ;;;
;;;                                                                     ;;;
;;; Permission is hereby granted, free of charge, to use and distribute ;;;
;;; this software and its documentation without restriction, including  ;;;
;;; without limitation the rights to use, copy, modify, merge, publish, ;;;
;;; distribute, sublicense, and/or sell copies of this work, and to     ;;;
;;; permit persons to whom this work is furnished to do so, subject to  ;;;
;;; the following conditions:                                           ;;;
;;;  1. The code must retain the above copyright notice, this list of   ;;;
;;;     conditions and the following disclaimer.                        ;;;
;;;  2. Any modifications must be clearly marked as such.               ;;;
;;;  3. Original authors' names are not deleted.                        ;;;
;;;  4. The authors' names are not used to endorse or promote products  ;;;
;;;     derived from this software without specific prior written       ;;;
;;;     permission.                                                     ;;;
;;;                                                                     ;;;
;;; CARNEGIE MELLON UNIVERSITY AND THE CONTRIBUTORS TO THIS WORK        ;;;
;;; DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING     ;;;
;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT  ;;;
;;; SHALL CARNEGIE MELLON UNIVERSITY NOR THE CONTRIBUTORS BE LIABLE     ;;;
;;; FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   ;;;
;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN  ;;;
;;; AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,         ;;;
;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF      ;;;
;;; THIS SOFTWARE.                                                      ;;;
;;;                                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;             Author: Alan W Black (awb@cs.cmu.edu)                   ;;;
;;;               Date: August 2002                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                     ;;;
;;; Generate a C compilable lts rewrite rules.                          ;;;
;;;                                                                     ;;;
;;; From CMU Flite                                                      ;;;
;;;                                                                     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (lts_norm_rule rule)
  (let (q w)

    (mapcar
     (lambda (l)
       (cond
	((string-equal l "[")
	  (set! q (list w))
	  (set! w nil))
	((string-equal l "]")
	  (set! q (cons (reverse w) q))
	  (set! w nil))
	((string-equal l "=")
	  (set! q (cons (reverse w) q))
	  (set! w nil))
	(t
	 (set! w (cons l w)))))
     rule)

    (set! xxx (list
	       (car (cddr q))  ;; reversed left hand side of rules
	       (car (cdr q))   ;; middle condition
	       (flip_stars (car q))         ;; RHS with * reverse
	       (reverse w)))   ;; re-write output
    (format t "%l %l\n" rule xxx)
    xxx))

(define (flip_stars q)
  ;; We want klene star to appear before the object 
  (cond
   ((null q) q)
   ((and (cdr q)
	 (string-equal (cadr q) "*"))
    (cons (cadr q) 
	  (cons (car q) 
		(flip_stars (cddr q)))))
   (t
    (cons (car q) (flip_stars (cdr q))))))

(define (ltsrewritestoC name fname odir)
  "(ltsrewritestoC name idir odir)"

  (let 
    ((ofde (fopen (path-append odir (string-append name ".c")) "w"))
     (ofdh (fopen (path-append odir (string-append name ".h")) "w"))
     (rules (car (load fname t)))
     (ifd))
    (format ofde "/*******************************************************/\n")
    (format ofde "/**  Autogenerated lts rewrite rules for %s     */\n" name)
    (format ofde "/**  from %s    */\n" name)
    (format ofde "/*******************************************************/\n")
    (format ofde "\n")
    (format ofde "#include \"cst_string.h\"\n")
    (format ofde "#include \"cst_val.h\"\n")
    (format ofde "#include \"cst_lts_rewrites.h\"\n")
    (format ofdh "extern const cst_lts_rewrites %s;\n\n" name)

    (cellstovals 
     (format nil "%s_lts_sets" name)
     (car (cdr (cdr rules)))
     ofde)
    (set! eoc_sets cells_count)
    (cellstovals 
     (format nil "%s_lts_rules" name)
     (mapcar
      lts_norm_rule
      (car (cdr (cdr (cdr rules)))))
     ofde)

    (if (equal? eoc_sets 0)
	(format ofde "#define %s_lts_sets 0\n" name)
	(format ofde "#define %s_lts_sets &%s_lts_sets_%04d\n" 
		name name eoc_sets))
    (format ofde "#define %s_lts_rules &%s_lts_rules_%04d\n" 
	    name name cells_count)

    (format ofde "\n")
    (format ofde "const cst_lts_rewrites %s = {\n" name)
    (format ofde "   \"%s\",\n" name)
    (format ofde "   %s_lts_sets,\n" name)
    (format ofde "   %s_lts_rules,\n" name)
    (format ofde "};\n")
    (format ofde "\n")

    (fclose ofde)
    (fclose ofdh)
    ))

(provide 'make_lts_rewrite)