;Dorai Sitaram
;Nov 18, 1999

(module mistie *

(import scheme chicken)
(use extras utils files srfi-1)

;;(declare (run-time-macros))

(define mistie-read-ctl-seq
  (lambda ()
    (let loop ((r '()))
      (let ((c (peek-char)))
        (if (or (eof-object? c)
                (not (char-alphabetic? c)))
            (if (null? r) #f
                (list->string (reverse r)))
            (loop (cons (read-char) r)))))))

;

(define-record-type mistie-frame
  (make-mistie-frame char-types ctl-seqs)
  mistie-frame?
  (char-types mistie-frame-char-types set-mistie-frame-char-types!)
  (ctl-seqs mistie-frame-ctl-seqs set-mistie-frame-ctl-seqs!) )

(define mistie-global-frame (make-mistie-frame '() '()))

(define mistie-env (list mistie-global-frame)) 

(define mistie-push-frame
  (lambda ()
    (set! mistie-env
      (cons (make-mistie-frame '() '())
        mistie-env))))

(define mistie-pop-frame
  (lambda ()
    (if (> (length mistie-env) 1)
        (set! mistie-env (cdr mistie-env))
        (error 'mistie-pop-frame))))

(define mistie-def-char-type
  (lambda (ct p)
    (let ((f (car mistie-env)))
      (set-mistie-frame-char-types! f
        (cons (cons ct p)
          (mistie-frame-char-types f))))))

(define mistie-def-char
  (lambda (char p)
    (mistie-def-char-type
      (lambda (c)
        (eqv? c char))
      (lambda (c) (p)))))

(define mistie-def-ctl-seq
  (lambda (t p)
    (let ((f (car mistie-env)))
      (set-mistie-frame-ctl-seqs! f
        (cons (cons t p)
          (mistie-frame-ctl-seqs f)))))) 

(define mistie-lookup-char
  (lambda (c)
    (any
      (lambda (f)
        (any
          (lambda (b)
            (and ((car b) c) (cdr b)))
          (mistie-frame-char-types f)))
      mistie-env)))

(define mistie-lookup-ctl-seq
  (lambda (x)
    (any
      (lambda (f)
        (let ((b (assv x (mistie-frame-ctl-seqs f))))
          (and b (cdr b))))
      mistie-env)))

;

(define mistie-escape-char #f)

;

(define-syntax mistie-call-maybe
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((proc (cadr expr))
           (args (cddr expr)))
       `(if (##sys#symbol-has-toplevel-binding? ',proc)
            (,proc ,@args))))))

;

(define mistie-everyjob
  (lambda ()
    #t))

(define mistie-exit? #f)

(define mistie-exit
  (lambda _
    (set! mistie-exit? #t)))

(mistie-def-char-type eof-object?
  mistie-exit)

;

(define mistie-translate/internal
  (lambda ()
    (let loop ()
      (let ((c (read-char)))
        (cond ((eqv? c mistie-escape-char) 
               (let ((x (mistie-read-ctl-seq)))
                 (cond ((not x) 
                        (write-char c)
                        (let ((d (read-char)))
                          (unless (eof-object? d)
                            (write-char d))))
                       ((mistie-lookup-ctl-seq (string->symbol x)) 
                        => (lambda (p) (p)))
                       (else (write-char c)
                         (display x)))))
              ((mistie-lookup-char c)
               => (lambda (p) (p c)))
              (else (write-char c)))
        (unless mistie-exit?
          (loop))))))

(define (mistie-translate)
  (condition-case
      (mistie-translate/internal)
    (exn ()
      (print-error-message
       exn
       (current-error-port)
       (sprintf "mistie: error in ~A:~A" (port-name) (port-position)))
      (print-call-chain (current-error-port))
      (exit 1))))

(define mistie-jobname "mistieput")

(define (mistie-main #!optional f)
  (parameterize ((current-input-port (current-input-port)))
    (let ((in-file-port #f))
      (when f
	(set! mistie-jobname f)
	(set! in-file-port (open-input-file f))
	(current-input-port in-file-port))
      (mistie-everyjob)
      (mistie-translate)
      (when in-file-port (close-input-port in-file-port))) ) )

(define mistie-path (make-parameter (make-pathname (chicken-home) "mistie")))

(define (mistie-load . fs)
  (for-each
   (lambda (f)
     (load (or (file-exists? f) (file-exists? (make-pathname (mistie-path) f))
	       (error "can not find file" f) ) ) )
   fs) )

)