#!/bin/sh
#|
if [ "$PLTHOME" = "" ]; then
  exec racket -um "$0" "$@"
else
  exec ${PLTHOME}/bin/racket -um $0 "$@"
fi
|#

#lang at-exp racket/base
(require racket/pretty)

(provide main)
(define (main [arg #f] [filename #f])
  (if (equal? arg "kernstruct")
      (gen-kernstruct filename)
      (print-header)))

(require scribble/text)

#|

Initial symbols are struct types. A non-initial symbol is a struct
type without fields or subtypes. Square brackets are struct fields and
propeties (the latter in curly braces), strings are contracts/comments.

|#

(define info '

(exn [exn_field_check
      (message "immutable string" "error message")
      (continuation-marks "mark set"
                          "value returned by \\scmfirst{current-continuation-marks} immediately before the exception is raised")] 
     -
     (fail [] "exceptions that represent errors"
           (contract [] "inappropriate run-time use of a function or syntactic form"
                     (arity []
                            "application with the wrong number of arguments")
                     (divide-by-zero [] "divide by zero")
                     (non-fixnum-result [] "arithmetic produced a non-fixnum result")
                     (continuation [] "attempt to cross a continuation barrier")
                     (variable [variable_field_check
                                (id "symbol" "the variable's identifier")]
                               "not-yet-defined global or module variable"))
           (syntax [syntax_field_check
                    (exprs "immutable list of syntax objects" "illegal expression(s)")
                    {exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}]
                   "syntax error, but not a \\scmfirst{read} error"
                   (unbound []
                            "unbound module variable"))
           (read [read_field_check
                  (srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error")
                  {exn:source scheme_source_property  |scheme_make_prim(extract_read_locations)|}]
                 "\\rawscm{read} parsing error"
                 (eof [] "unexpected end-of-file")
                 (non-char [] "unexpected non-character"))
           (filesystem [] "error manipulating a filesystem object"
                       (exists [] "attempt to create a file that exists already")
                       (version [] "version mismatch loading an extension"))
           (network [] "TCP and UDP errors")
           (out-of-memory [] "out of memory")
           (unsupported [] "unsupported feature")
           (user [] "for end users"))

     (break [break_field_check
             (continuation "escape continuation" "resumes from the break")]
            "asynchronous break signal"))

)

#|
Not an exception in the above sense:
     (special-comment [width "non-negative exact integer" "width of the special comment in port positions"]
        "raised by a custom input port's special-reading procedure")
|#

(define l info)

(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)))))]))

(set! l (make-struct-list l #f #f "" 0 0))


(define (gen-kernstruct filename)
  (define preamble '(module kernstruct '#%kernel
                      (#%require (for-syntax '#%kernel))
                      (#%require "define.rkt")
                      (#%require (for-syntax "struct-info.rkt"))
                      
                      (#%provide (all-defined))

                      (define-values-for-syntax (make-self-ctr-struct-info)
                        (letrec-values ([(struct: make- ? ref set!)
                                         (make-struct-type 'self-ctor-struct-info struct:struct-info
                                                           1 0 #f
                                                           (list (cons prop:procedure
                                                                       (lambda (v stx)
                                                                         (let-values ([(id) ((ref v 0))])
                                                                           (if (symbol? (syntax-e stx))
                                                                               id
                                                                               (datum->syntax stx
                                                                                              (cons id (cdr (syntax-e stx)))
                                                                                              stx
                                                                                              stx))))))
                                                           (current-inspector) #f '(0))])
                          make-))))
  
  (define (sss . args)
    (string->symbol (apply string-append (map (λ (x) (if (symbol? x) (symbol->string x) x)) args))))
  
  (define (non-parent x)
    (or (equal? #f x) (equal? #t x)))
  
  (define (gen-ds name-string fields parent)
    (let* ([name (sss name-string)]
           [kern-name (sss "kernel:" name)]
           [sn (sss "struct:" name)]
           [mn (sss "make-" name)]
           [pn (sss name "?")]
           [fds `(list ,@(map (λ (x) `(quote-syntax ,x)) fields))]
           [fdsset! `'(,@(map (λ (x) #f) fields))]
           [prnt (if (non-parent parent) #t `(quote-syntax ,parent))])
      `(begin
         (#%require (rename '#%kernel ,kern-name ,name))
         (define ,mn ,kern-name)
         (define-syntax ,name (make-self-ctr-struct-info 
                               (λ () (list (quote-syntax ,sn)
                                           (quote-syntax ,mn)
                                           (quote-syntax ,pn)                              
                                           ,fds
                                           ,fdsset! ,prnt))
                               (λ () (quote-syntax ,kern-name)))))))
  
  (define (parent-sym x)
    (let ([parent (ex-parent x)])
      (if (non-parent parent)
          parent
          (string->symbol (ex-string parent)))))
  
  (define (fields exn)
    (define (field-name exn fld)
      (sss  (ex-string exn) "-"  (fld-name fld)))
    (if (non-parent exn)
        null
        (append (reverse (map (λ (field) (field-name exn field)) (ex-args exn))) (fields (ex-parent exn)))))
  
  
  (define exceptions (map (λ (x) (gen-ds (ex-string x) (fields x) (parent-sym x))) l))
  (define structs (map (λ (x) (apply gen-ds x))
                       '((arity-at-least (arity-at-least-value) #t)
                         (date (date-time-zone-offset date-dst? date-year-day date-week-day date-year 
                                 date-month date-day date-hour date-minute date-second) #t)
                         (date* (date*-time-zone-name date*-nanosecond
                                 date-time-zone-offset date-dst? date-year-day date-week-day date-year 
                                 date-month date-day date-hour date-minute date-second) #t)
                         (srcloc (srcloc-span srcloc-position srcloc-column srcloc-line srcloc-source) #t))))
  
  (with-output-to-file filename #:exists 'replace
    (λ ()
      (printf ";; This file was generated by makeexn\n")
      (printf ";;----------------------------------------------------------------------\n")
      (printf ";; record for static info produced by structs defined in c\n")
      (pretty-write (append preamble exceptions structs)))))

(define (print-header)
  @(compose output list){
    /* This file was generated by makeexn */
    #ifndef _MZEXN_DEFINES
    #define _MZEXN_DEFINES
    enum {
    @(add-newlines (for/list ([e l]) @list{  @(ex-define e),}))
      MZEXN_OTHER
    };
    #endif

    #ifdef _MZEXN_TABLE

    #define MZEXN_MAXARGS @max-exn-args

    #ifdef GLOBAL_EXN_ARRAY
    static exn_rec exn_table[] = {
    @(let loop ([ll l])
       (let ([e (car ll)])
         (cons @list{  { @(ex-numtotal e), NULL, NULL, 0, NULL, @;
                         @(if (ex-parent e)
                            (let loop ([pos 0][ll l])
                              (if (eq? (car ll) (ex-parent e))
                                pos
                                (loop (add1 pos) (cdr ll))))
                            -1) }}
               (if (null? (cdr ll))
                 '()
                 (cons ",\n" (loop (cdr ll)))))))
    };
    #else
    static exn_rec *exn_table;
    #endif

    #endif

    #ifdef _MZEXN_PRESETUP

    #ifndef GLOBAL_EXN_ARRAY
      exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);
    @(add-newlines
      (for/list ([e l])
        @list{  exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"}))
    #endif

    #endif

    #ifdef _MZEXN_DECL_FIELDS
    @(add-newlines
      (for*/list ([e l] [l (in-value (ex-args e))] #:when (pair? l))
        (define fields
          (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", "))
        @list{  static const char *@(ex-define e)_FIELDS[@(length l)] = @;
                 { @fields };
              }))
    #endif

    #ifdef _MZEXN_DECL_PROPS
    @(add-newlines
      (for*/list ([e l] [l (in-value (ex-props e))] #:when (pair? l))
        (define (acons x y l)
          @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)})
        @list{#  define @(ex-define e)_PROPS @;
              @(let loop ([l l])
                 (if (null? l)
                   "scheme_null"
                   (acons (prop-c-name (car l)) (prop-value (car l))
                          (loop (cdr l)))))}))
    #endif

    #ifdef _MZEXN_SETUP
    @(add-newlines
      (for/list ([e l])
        @list{  SETUP_STRUCT(@(ex-define e), @;
                             @(let ([p (ex-parent-def e)])
                                (if p @list{EXN_PARENT(@p)} 'NULL)), @;
                             "@(ex-string e)", @;
                             @(length (ex-args e)), @;
                             @(if (null? (ex-args e))
                                'NULL
                                @list{@(ex-define e)_FIELDS}), @;
                             @(if (null? (ex-props e))
                                'scheme_null
                                @list{@(ex-define e)_PROPS}), @;
                             @(if (ex-guard e)
                                @list{scheme_make_prim(@(ex-guard e))}
                                'NULL))}))
    #endif
    @||})
