ref: baaa888c574e075222ad70b002fe6a140a19098b
dir: flite/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)