#!/bin/sh
string=? ; if [ "$PLTHOME" = "" ] ; then PLTHOME=/usr/local/lib/plt ; export PLTHOME ; fi
string=? ; exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"

(define doc? (and (= (vector-length argv) 1)
		  (string=? (vector-ref argv 0) "doc")))

(define l (read))

(define-struct ex (define string base doc args parent parent-def numtotal depth mark))
(define-struct fld (name type doc))

(define max-exn-args 0)

(define (make-an-ex sym parent parent-def parent-name totalargs args doc depth mark)
  (let* ([s (symbol->string sym)]
	 [name (string-append parent-name 
			      (if (string=? "" parent-name) "" ":") 
			      s)]
	 [count (+ totalargs (length args))])
    (when (> count max-exn-args)
	  (set! max-exn-args count))
    (make-ex (string-append "MZ"
			    (list->string
			     (let loop ([l (string->list name)])
			       (cond
				[(null? l) '()]
				[(or (char=? (car l) #\:)
				     (char=? (car l) #\/)
				     (char=? (car l) #\-))
				 (cons #\_ (loop (cdr l)))]
				[else
				 (cons (char-upcase (car l))
				       (loop (cdr l)))]))))
	     name
	     sym
	     doc
	     args
	     parent
	     parent-def
	     count
	     depth
	     mark)))

(define (make-arg-list args)
  (if (null? args)
      '()
      (cons (make-fld (car args) (cadr args) (caddr args))
	    (make-arg-list (cdddr args)))))

(define (make-struct-list v parent parent-def parent-name totalargs depth)
  (cond
   [(null? v) '()]
   [else
    (let*-values ([(s mark)
		  (let* ([s (symbol->string (car v))]
			 [c (string-ref s 0)])
		    (if (or (char=? #\* c)
			    (char=? #\+ c))
			(values (string->symbol (substring s 1 (string-length s))) c)
			(values (car v) #f)))]
		 [(e) (make-an-ex s parent parent-def parent-name totalargs 
				  (make-arg-list (cadr v))
				  (caddr v) depth mark)])
      (cons e
       (apply append
	      (map
	       (lambda (v)
		 (make-struct-list v 
				   e
				   (ex-define e)
				   (ex-string e)
				   (ex-numtotal e)
				   (add1 depth)))
	       (cdddr v)))))]))

(define l (make-struct-list l
			    #f
			    #f
			    ""
			    0
			    0))


(define (symbol-length s)
  (string-length (symbol->string s)))

(if doc?
    (begin
      (printf "% This file was generated by makeexn~n")

      (for-each
       (lambda (e)
	 (let ([tab
		(let loop ([d (ex-depth e)])
		  (cond
		   [(zero? d) ""]
		   [(= d 1) "{\\exninset}"]
		   [else
		    (string-append "\\>"
				   (loop (sub1 d)))]))])
	   (display tab)
	   (printf "\\exntype{~a}{~a}{~a}{~a} " 
		   (ex-base e)
		   (ex-string e)
		   (case (ex-mark e)
		     ((#f) "$\\bullet$")
		     ((#\+) "$\\bullet$")
		     ((#\*) "$\\bullet$"))
		   (let ([make-var (lambda (f)
				     (let ([type (let ([s (fld-type f)])
						   (if (string=? s "value")
						       "v"
						       s))]
					   [name (fld-name f)])
				       (cond
					[(eq? name 'value) "v"]
					[(regexp-match "port" type) type]
					[else (format "~a-~a" name type)])))])
		     (let loop ([e e][s #f])
		       (let* ([p (ex-parent e)]
			      [s (if p (loop p s) s)])
			 (let loop ([l (ex-args e)][s s])
			   (cond
			    [(null? l) s]
			    [s (loop (cdr l) (string-append s " " (make-var (car l))))]
			    [else (loop (cdr l) (make-var (car l)))]))))))
	   
	   (if (eq? (ex-doc e) '-)
	       (printf "\\exnusenone{~a} " tab)
	       (printf "\\exnuse{~a}{~a}{~a} " tab (ex-doc e)
		       (- 6.3 (* 0.08 (symbol-length (ex-base e))) (* 0.25 (ex-depth e)))))
	   
	   (let ([args (ex-args e)]
		 [print-one
		  (lambda (f)
		    (printf "\\exnfield{~a}{~a} \\exnfuse{~s}{~a \\exnftype{~a}} " 
			    (fld-name f) (ex-string e)
			    (- 5.4 (* 0.08 (symbol-length (fld-name f))) (* 0.25 (ex-depth e))) (fld-doc f) 
			    (fld-type f)))])
	     (unless (null? args)
		     (printf "\\exnbeginfields{~a} " tab)
		     (print-one (car args))
		     (for-each (lambda (f)
				 (printf "\\exnnextfield{~a}" tab)
				 (print-one f))
			       (cdr args))
		     (printf "\\exnendfields{~a}" tab)))
	   (printf "\\\\~n")))
       l))
    (begin
      (printf "/* This file was generated by makeexn */~n")

      (printf "#ifndef _MZEXN_DEFINES~n")
      (printf "#define _MZEXN_DEFINES~n~n")
      (printf "enum {~n")
      (for-each
       (lambda (e)
	 (printf "  ~a,~n" (ex-define e)))
       l)
      (printf "  MZEXN_OTHER~n};~n~n")
      (printf "#endif~n~n")
      
      
      (printf "#ifdef _MZEXN_TABLE~n~n")
      (printf "#define MZEXN_MAXARGS ~a~n~n" max-exn-args)
	
      (printf "#ifdef GLOBAL_EXN_ARRAY~n")

      (printf "static exn_rec exn_table[] = {~n")
      (let loop ([l l])
	(let ([e (car l)])
	  
	  (printf "  { ~a, NULL, NULL, 0 }" 
		  (ex-numtotal e))
	  
	  (unless (null? (cdr l))
		  (printf ",~n")
		  (loop (cdr l)))))
      (printf "~n};~n")

      (printf "#else~n")
      (printf "static exn_rec *exn_table;~n")      
      (printf "#endif~n")

      (printf "~n#endif~n~n")

      (printf "#ifdef _MZEXN_PRESETUP~n~n")
      (printf "#ifndef GLOBAL_EXN_ARRAY~n")
      (printf "  exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);~n")
      (let loop ([l l])
	(let ([e (car l)])
	  
	  (printf "  exn_table[~a].args = ~a;~n"
		  (ex-define e)
		  (ex-numtotal e))
	  (unless (null? (cdr l))
		  (loop (cdr l)))))
      (printf "#endif~n")
      (printf "~n#endif~n~n")      
      
      (printf "#ifdef _MZEXN_DECL_FIELDS~n~n")
      
      (for-each
       (lambda (e)
	 (let ([l (ex-args e)])
	   (unless (null? l)
		   (printf "static const char *~a_FIELDS[~s] = { \"~a\"" 
			   (ex-define e)
			   (length l) 
			   (fld-name (car l)))
		   (for-each
		    (lambda (field)
		      (printf ", \"~a\"" (fld-name field)))
		    (cdr l))
		   (printf " };~n"))))
       l)

      (printf "~n#endif~n~n")
      
      (printf "#ifdef _MZEXN_SETUP~n~n")
      
      (for-each
       (lambda (e)
	 (printf "  SETUP_STRUCT(~a, ~a, ~s, ~a, ~a)~n"
		 (ex-define e)
		 (let ([p (ex-parent-def e)])
		   (if p
		       (format "EXN_PARENT(~a)" p)
		       'NULL))
		 (ex-string e)
		 (length (ex-args e))
		 (if (null? (ex-args e))
		     "NULL"
		     (format "~a_FIELDS" (ex-define e)))))
       l)

      (printf "~n#endif~n")))
