;;;;
;;;; stklos-genlex.stk  -- generate a lexical analyser using SIlex
;;;;
;;;; Copyright © 2003-2021 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)
;;;;

(require "pretty-print")
(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 (create-temp-file))
        (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"))))))
