exnsrc.ss is now a module; works with v4 now
svn: r16189
This commit is contained in:
Eli Barzilay
parent
50ce45e621
commit
e17ae5ce02
|
|
@ -1,3 +1,4 @@
|
|||
#lang scheme
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -7,47 +8,49 @@ propeties (the latter in curly braces), strings are contracts/comments.
|
|||
|
||||
|#
|
||||
|
||||
#cs
|
||||
(provide info)
|
||||
(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")]
|
||||
"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")
|
||||
(continuation [] "attempt to cross a continuation barrier")
|
||||
(variable [variable_field_check
|
||||
(id "symbol" "the variable's identifier")]
|
||||
"unbound/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")
|
||||
(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"))
|
||||
(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")
|
||||
(continuation [] "attempt to cross a continuation barrier")
|
||||
(variable [variable_field_check
|
||||
(id "symbol" "the variable's identifier")]
|
||||
"unbound/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")
|
||||
(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")
|
||||
"raised by a custom input port's special-reading procedure")
|
||||
|#
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,21 @@
|
|||
#!/bin/sh
|
||||
#|
|
||||
if [ "$PLTHOME" = "" ] ; then PLTHOME=/usr/local/lib/plt ; export PLTHOME ; fi
|
||||
exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
|
||||
if [ "$PLTHOME" = "" ]; then
|
||||
exec mzscheme -um "$0" "$@"
|
||||
else
|
||||
exec ${PLTHOME}/bin/mzscheme -um $0 "$@"
|
||||
fi
|
||||
|#
|
||||
|
||||
(define doc? (and (= (vector-length argv) 1)
|
||||
(string=? (vector-ref argv 0) "doc")))
|
||||
#lang scheme
|
||||
|
||||
(define l (read))
|
||||
(provide main)
|
||||
(define (main [arg #f])
|
||||
(if (equal? arg "doc") (print-doc) (print-header)))
|
||||
|
||||
(require "exnsrc.ss")
|
||||
|
||||
(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))
|
||||
|
|
@ -99,13 +107,7 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
|
|||
(add1 depth)))
|
||||
(cdddr v)))))]))
|
||||
|
||||
(define l (make-struct-list l
|
||||
#f
|
||||
#f
|
||||
""
|
||||
0
|
||||
0))
|
||||
|
||||
(set! l (make-struct-list l #f #f "" 0 0))
|
||||
|
||||
(define (symbol-length s)
|
||||
(string-length (symbol->string s)))
|
||||
|
|
@ -116,192 +118,168 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
|
|||
(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")
|
||||
(define (print-doc)
|
||||
(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"))
|
||||
|
||||
(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")))
|
||||
(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"))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user