using scribble/text now
svn: r16192
This commit is contained in:
Eli Barzilay
parent
bb148a3e1b
commit
b50c10efa2
|
|
@ -7,23 +7,25 @@ else
|
||||||
fi
|
fi
|
||||||
|#
|
|#
|
||||||
|
|
||||||
#lang scheme
|
#lang at-exp scheme
|
||||||
|
|
||||||
(provide main)
|
(provide main)
|
||||||
(define (main [arg #f])
|
(define (main [arg #f])
|
||||||
(if (equal? arg "doc") (print-doc) (print-header)))
|
(if (equal? arg "doc") (print-doc) (print-header)))
|
||||||
|
|
||||||
(require "exnsrc.ss")
|
(require "exnsrc.ss" scribble/text)
|
||||||
|
|
||||||
(define l info)
|
(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 fld (name type doc))
|
||||||
(define-struct prop (scheme-name c-name value))
|
(define-struct prop (scheme-name c-name value))
|
||||||
|
|
||||||
(define max-exn-args 0)
|
(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)]
|
(let* ([s (symbol->string sym)]
|
||||||
[name (string-append parent-name
|
[name (string-append parent-name
|
||||||
(if (string=? "" parent-name) "" ":")
|
(if (string=? "" parent-name) "" ":")
|
||||||
|
|
@ -113,8 +115,7 @@ fi
|
||||||
(string-length (symbol->string s)))
|
(string-length (symbol->string s)))
|
||||||
|
|
||||||
(define (clean-help-desk-type type)
|
(define (clean-help-desk-type type)
|
||||||
(regexp-replace*
|
(regexp-replace* "or-{\\\\scmfalse}"
|
||||||
"or-{\\\\scmfalse}"
|
|
||||||
(regexp-replace* " " type "-")
|
(regexp-replace* " " type "-")
|
||||||
"or-#f"))
|
"or-#f"))
|
||||||
|
|
||||||
|
|
@ -186,100 +187,91 @@ fi
|
||||||
(display "\\end{exntable}\n"))
|
(display "\\end{exntable}\n"))
|
||||||
|
|
||||||
(define (print-header)
|
(define (print-header)
|
||||||
(printf "/* This file was generated by makeexn */~n")
|
@(compose output list){
|
||||||
(printf "#ifndef _MZEXN_DEFINES~n")
|
/* This file was generated by makeexn */
|
||||||
(printf "#define _MZEXN_DEFINES~n~n")
|
#ifndef _MZEXN_DEFINES
|
||||||
(printf "enum {~n")
|
#define _MZEXN_DEFINES
|
||||||
(for-each (lambda (e) (printf " ~a,~n" (ex-define e)))
|
enum {
|
||||||
l)
|
@(add-newlines (for/list ([e l]) @list{ @(ex-define e),}))
|
||||||
(printf " MZEXN_OTHER~n};~n~n")
|
MZEXN_OTHER
|
||||||
(printf "#endif~n~n")
|
};
|
||||||
(printf "#ifdef _MZEXN_TABLE~n~n")
|
#endif
|
||||||
(printf "#define MZEXN_MAXARGS ~a~n~n" max-exn-args)
|
|
||||||
(printf "#ifdef GLOBAL_EXN_ARRAY~n")
|
#ifdef _MZEXN_TABLE
|
||||||
(printf "static exn_rec exn_table[] = {~n")
|
|
||||||
(let loop ([ll l])
|
#define MZEXN_MAXARGS @max-exn-args
|
||||||
|
|
||||||
|
#ifdef GLOBAL_EXN_ARRAY
|
||||||
|
static exn_rec exn_table[] = {
|
||||||
|
@(let loop ([ll l])
|
||||||
(let ([e (car ll)])
|
(let ([e (car ll)])
|
||||||
(printf " { ~a, NULL, NULL, 0, NULL, ~a }"
|
(cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @;
|
||||||
(ex-numtotal e)
|
@(if (ex-parent e)
|
||||||
(if (ex-parent e)
|
|
||||||
(let loop ([pos 0][ll l])
|
(let loop ([pos 0][ll l])
|
||||||
(if (eq? (car ll) (ex-parent e))
|
(if (eq? (car ll) (ex-parent e))
|
||||||
pos
|
pos
|
||||||
(loop (add1 pos) (cdr ll))))
|
(loop (add1 pos) (cdr ll))))
|
||||||
-1))
|
-1) }}
|
||||||
(unless (null? (cdr ll))
|
(if (null? (cdr ll))
|
||||||
(printf ",~n")
|
'()
|
||||||
(loop (cdr ll)))))
|
(cons ",\n" (loop (cdr ll)))))))
|
||||||
(printf "~n};~n")
|
};
|
||||||
(printf "#else~n")
|
#else
|
||||||
(printf "static exn_rec *exn_table;~n")
|
static exn_rec *exn_table;
|
||||||
(printf "#endif~n")
|
#endif
|
||||||
(printf "~n#endif~n~n")
|
|
||||||
(printf "#ifdef _MZEXN_PRESETUP~n~n")
|
#endif
|
||||||
(printf "#ifndef GLOBAL_EXN_ARRAY~n")
|
|
||||||
(printf " exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);~n")
|
#ifdef _MZEXN_PRESETUP
|
||||||
(let loop ([l l])
|
|
||||||
(let ([e (car l)])
|
#ifndef GLOBAL_EXN_ARRAY
|
||||||
(printf " exn_table[~a].args = ~a;~n"
|
exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);
|
||||||
(ex-define e)
|
@(add-newlines
|
||||||
(ex-numtotal e))
|
(for/list ([e l])
|
||||||
(unless (null? (cdr l))
|
@list{ exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"}))
|
||||||
(loop (cdr l)))))
|
#endif
|
||||||
(printf "#endif~n")
|
|
||||||
(printf "~n#endif~n~n")
|
#endif
|
||||||
(printf "#ifdef _MZEXN_DECL_FIELDS~n~n")
|
|
||||||
(for-each
|
#ifdef _MZEXN_DECL_FIELDS
|
||||||
(lambda (e)
|
@(add-newlines
|
||||||
(let ([l (ex-args e)])
|
(for*/list ([e l] [l (in-value (ex-args e))] #:when (pair? l))
|
||||||
(unless (null? l)
|
(define fields
|
||||||
(printf "static const char *~a_FIELDS[~s] = { \"~a\""
|
(add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", "))
|
||||||
(ex-define e) (length l) (fld-name (car l)))
|
@list{ static const char *@(ex-define e)_FIELDS[@(length l)] = @;
|
||||||
(for-each
|
{ @fields };
|
||||||
(lambda (field)
|
}))
|
||||||
(printf ", \"~a\"" (fld-name field)))
|
#endif
|
||||||
(cdr l))
|
|
||||||
(printf " };~n"))))
|
#ifdef _MZEXN_DECL_PROPS
|
||||||
l)
|
@(add-newlines
|
||||||
(printf "~n#endif~n~n")
|
(for*/list ([e l] [l (in-value (ex-props e))] #:when (pair? l))
|
||||||
(printf "#ifdef _MZEXN_DECL_PROPS~n~n")
|
(define (acons x y l)
|
||||||
(for-each
|
@list{scheme_make_pair(scheme_make_pair(@x, @y), @l)})
|
||||||
(lambda (e)
|
@list{# define @(ex-define e)_PROPS @;
|
||||||
(let ([l (ex-props e)])
|
@(let loop ([l l])
|
||||||
(unless (null? l)
|
|
||||||
(printf "#define ~a_PROPS " (ex-define e))
|
|
||||||
(let loop ([l l])
|
|
||||||
(if (null? 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"
|
"scheme_null"
|
||||||
(format "~a_PROPS" (ex-define e)))
|
(acons (prop-c-name (car l)) (prop-value (car l))
|
||||||
(if (ex-guard e)
|
(loop (cdr l)))))}))
|
||||||
(format "scheme_make_prim(~a)" (ex-guard e))
|
#endif
|
||||||
"NULL")))
|
|
||||||
l)
|
#ifdef _MZEXN_SETUP
|
||||||
(printf "~n#endif~n"))
|
@(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