#!/bin/sh
#|
if [ "$PLTHOME" = "" ] ; then PLTHOME=/usr/local/lib/plt ; export PLTHOME ; fi
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 props guard parent parent-def numtotal depth mark))
(define-struct fld (name type doc))
(define-struct prop (scheme-name c-name value))

(define max-exn-args 0)

(define (make-an-ex sym parent parent-def parent-name totalargs args props guard 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
	     props
	     guard
	     parent
	     parent-def
	     count
	     depth
	     mark)))

(define (make-arg-list args)
  (cond
   [(null? args) '()]
   [(string? (cadar args))
    (cons (apply make-fld (car args))
	  (make-arg-list (cdr args)))]
   [else
    (make-arg-list (cdr args))]))

(define (make-prop-list args)
  (cond
   [(null? args) '()]
   [(symbol? (cadar args))
    (cons (apply make-prop (car args))
	  (make-prop-list (cdr args)))]
   [else
    (make-prop-list (cdr 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 
				  (if (null? (cadr v))
				      null
				      (make-arg-list (cdadr v)))
				  (if (null? (cadr v))
				      null
				      (make-prop-list (cdadr v)))
				  (if (null? (cadr v))
				      #f
				      (caadr 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)))

(define (clean-help-desk-type type)
  (regexp-replace* 
   "or-{\\\\scmfalse}"
   (regexp-replace* " " type "-")
   "or-#f"))

(if doc?
    (begin
      (printf "% This file was generated by makeexn~n")
      (display "\\begin{exntable}\n")
      (for-each
       (lambda (e)
	 (let ([tab
		(lambda (pre)
		  (let loop ([d (ex-depth e)])
		    (cond
		     [(zero? d) ""]
		     [(= d 1) (format "\\exn~ainset{}" pre)]
		     [else
		      (string-append (format "\\exn~atab{}" pre)
				     (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 (clean-help-desk-type 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}{~s}{~a}{~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 "\\exnendline{}")
	   (display (tab "close"))
	   (newline)))
       l)
      (display "\\end{exntable}\n"))
    (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 ([ll l])
	(let ([e (car ll)])
	  
	  (printf "  { ~a, NULL, NULL, 0, NULL, ~a }" 
		  (ex-numtotal e)
		  (if (ex-parent e)
		      (let loop ([pos 0][ll l])
			(if (eq? (car ll) (ex-parent e))
			    pos
			    (loop (add1 pos) (cdr ll))))
		      -1))
	  
	  (unless (null? (cdr ll))
		  (printf ",~n")
		  (loop (cdr ll)))))
      (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_DECL_PROPS~n~n")
      
      (for-each
       (lambda (e)
	 (let ([l (ex-props e)])
	   (unless (null? l)
	     (printf "#define ~a_PROPS " (ex-define e))
	     (let loop ([l l])
	       (if (null? l)
		   (printf "scheme_null")
		   (begin
		     (printf "scheme_make_pair(")
		     (printf "scheme_make_pair(~a, ~a), "
			     (prop-c-name (car l)) 
			     (prop-value (car l)))
		     (loop (cdr l))
		     (printf ")"))))
	     (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, ~a, ~a)~n"
		 (ex-define e)
		 (let ([p (ex-parent-def e)])
		   (if p
		       (format "EXN_PARENT(~a)" p)
		       #cs'NULL))
		 (ex-string e)
		 (length (ex-args e))
		 (if (null? (ex-args e))
		     "NULL"
		     (format "~a_FIELDS" (ex-define e)))
		 (if (null? (ex-props e))
		     "scheme_null"
		     (format "~a_PROPS" (ex-define e)))
		 (if (ex-guard e)
		     (format "scheme_make_prim(~a)" (ex-guard e))
		     "NULL")))
       l)

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