;;;;
;;;; stklos-genlex.stk	-- generate a lexical analyser using SIlex
;;;;
;;;; Copyright © 2003-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 12-Dec-2003 11:29 (eg)
;;;; Last file update:  2-Jun-2007 10:38 (eg)
;;;;

(require "pp")
(include "../lib/SILex.d/silex.scm")

(define *runtime-file* "lex-rt")

;; ----------------------------------------------------------------------
;; 	generate-header ...
;; ----------------------------------------------------------------------
(define (generate-header out)
  (format out ";; This file has been generated. (DON'T EDIT)\n")
  (format out ";; generated on ~A\n\n" (date))
  (format out "(require ~S)\n\n" *runtime-file*))

;; ----------------------------------------------------------------------
;; 	build-constructor ...
;; ----------------------------------------------------------------------
(define (build-constructor name expr)
  (let ((name (if (string? name) (string->symbol name) name)))
    `(define ,name
       (lambda (%%input)
	 (letrec ((%%self (make <lex> :input %%input :table ,(caddr expr)))
		  (lexer-get-line #f)
		  (lexer-getc     #f)
		  (lexer-ungetc   #f))
	   (set! lexer-get-line (slot-ref %%self 'line))
	   (set! lexer-getc     (slot-ref %%self 'line))
	   (set! lexer-ungetc   (slot-ref %%self 'line))
	   %%self)))))

;; ----------------------------------------------------------------------
;; 	lex-generate ...
;; ----------------------------------------------------------------------
(define (lex-generate input output name)
  (let ((tmp (temporary-file-name))
	(out (open-file output "w")))
    (unless out
      (error "cannot open output file ~S" output))

    ;; Generate the tables in a temporary file
    (let ((res (lex-tables input (format "~A" name) tmp 'code 'counters 'line)))

      (when res
	;; Generate the header of the output file
	(generate-header out)

	;; Copy the content of the temporary file
	(let* ((in   (open-input-file tmp))
	       (expr (read in))
	       (res  (build-constructor name expr)))

	  (pp res :port out)
	  (newline out))

	;; Remove temporary file
	(remove-file tmp))
      ;; Close output
      (close-port out)

      ;; Return value is the status code of the program
      (if res 0 1))))

;; ----------------------------------------------------------------------
;; 	lex-expand ...
;; ----------------------------------------------------------------------
(define (lex-expand input output)
  (let ((in  (open-file input "r"))
	(out (open-file output "w")))
    (unless in  (error "cannot open input file ~S" input))
    (unless out (error "cannot open output file ~S" output))

    ;; Copy the input file and expand only the define-regular-grammar calls
    (let Loop ((expr (read in)))
      (cond
	((eof-object? expr)
	   (close-output-port out))
	((and (list? expr)
	      (eq? (car expr) 'define-regular-grammar)
	      (= (length expr) 5))
	   (pp (macro-expand expr) :port out)
	   (newline out)
	   (Loop (read in)))
	(else
	 (write expr out)
	 (newline out)
	 (Loop (read in)))))))

;; ----------------------------------------------------------------------
;; 	main ...
;; ----------------------------------------------------------------------
(define (main args)
  (case (length args)
    ((3) (begin (lex-expand (cadr args) (caddr args))
		0))
    ((4) (lex-generate (cadr args)
		       (caddr args)
		       (cadddr args)))
    (else (let ((prog (basename (program-name))))
	    (die (string-append
		  "Usage: " prog "<lex-file> <output-file> <constructor>\n"
		  "       " prog "<src-file> <output-file>\n"))))))