using scribble/text now
svn: r16192
This commit is contained in:
Eli Barzilay
parent
bb148a3e1b
commit
b50c10efa2
|
|
@ -7,60 +7,62 @@ else
|
|||
fi
|
||||
|#
|
||||
|
||||
#lang scheme
|
||||
#lang at-exp scheme
|
||||
|
||||
(provide main)
|
||||
(define (main [arg #f])
|
||||
(if (equal? arg "doc") (print-doc) (print-header)))
|
||||
|
||||
(require "exnsrc.ss")
|
||||
(require "exnsrc.ss" scribble/text)
|
||||
|
||||
(define l info)
|
||||
|
||||
(define-struct ex (define string base doc args props guard parent parent-def numtotal depth mark))
|
||||
(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)
|
||||
(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))])
|
||||
[name (string-append parent-name
|
||||
(if (string=? "" parent-name) "" ":")
|
||||
s)]
|
||||
[count (+ totalargs (length args))])
|
||||
(when (> count max-exn-args)
|
||||
(set! max-exn-args count))
|
||||
(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)))
|
||||
(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)))]
|
||||
(make-arg-list (cdr args)))]
|
||||
[else
|
||||
(make-arg-list (cdr args))]))
|
||||
|
||||
|
|
@ -69,7 +71,7 @@ fi
|
|||
[(null? args) '()]
|
||||
[(symbol? (cadar args))
|
||||
(cons (apply make-prop (car args))
|
||||
(make-prop-list (cdr args)))]
|
||||
(make-prop-list (cdr args)))]
|
||||
[else
|
||||
(make-prop-list (cdr args))]))
|
||||
|
||||
|
|
@ -78,34 +80,34 @@ fi
|
|||
[(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)])
|
||||
(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)))))]))
|
||||
(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))
|
||||
|
||||
|
|
@ -113,10 +115,9 @@ fi
|
|||
(string-length (symbol->string s)))
|
||||
|
||||
(define (clean-help-desk-type type)
|
||||
(regexp-replace*
|
||||
"or-{\\\\scmfalse}"
|
||||
(regexp-replace* " " type "-")
|
||||
"or-#f"))
|
||||
(regexp-replace* "or-{\\\\scmfalse}"
|
||||
(regexp-replace* " " type "-")
|
||||
"or-#f"))
|
||||
|
||||
(define (print-doc)
|
||||
(printf "% This file was generated by makeexn~n")
|
||||
|
|
@ -133,7 +134,7 @@ fi
|
|||
(string-append (format "\\exn~atab{}" pre)
|
||||
(loop (sub1 d)))])))])
|
||||
(display (tab ""))
|
||||
(printf "\\exntype{~a}{~a}{~a}{~a} "
|
||||
(printf "\\exntype{~a}{~a}{~a}{~a} "
|
||||
(ex-base e)
|
||||
(ex-string e)
|
||||
(case (ex-mark e)
|
||||
|
|
@ -158,18 +159,18 @@ fi
|
|||
[(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} "
|
||||
(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)
|
||||
(- 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 ""))
|
||||
|
|
@ -186,100 +187,91 @@ fi
|
|||
(display "\\end{exntable}\n"))
|
||||
|
||||
(define (print-header)
|
||||
(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"))
|
||||
@(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
|
||||
@||})
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user