suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

exnsrc.ss is now a module; works with v4 now

Browse Source 
svn: r16189
This commit is contained in:
Eli Barzilay 2009-09-30 17:00:55 +00:00
parent 50ce45e621
commit e17ae5ce02
2 changed files with 214 additions and 233 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
src/mzscheme/src/exnsrc.ss
View File

@ -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 (exn [exn_field_check
(message "immutable string" "error message") (message "immutable string" "error message")
(continuation-marks "mark set" (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" (fail [] "exceptions that represent errors"
(contract [] "inappropriate run-time use of a function or syntactic form" (contract [] "inappropriate run-time use of a function or syntactic form"
(arity [] (arity []
"application with the wrong number of arguments") "application with the wrong number of arguments")
(divide-by-zero [] "divide by zero") (divide-by-zero [] "divide by zero")
(continuation [] "attempt to cross a continuation barrier") (continuation [] "attempt to cross a continuation barrier")
(variable [variable_field_check (variable [variable_field_check
(id "symbol" "the variable's identifier")] (id "symbol" "the variable's identifier")]
"unbound/not-yet-defined global or module variable")) "unbound/not-yet-defined global or module variable"))
(syntax [syntax_field_check (syntax [syntax_field_check
(exprs "immutable list of syntax objects" "illegal expression(s)") (exprs "immutable list of syntax objects" "illegal expression(s)")
{exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}] {exn:source scheme_source_property |scheme_make_prim(extract_syntax_locations)|}]
"syntax error, but not a \\scmfirst{read} error") "syntax error, but not a \\scmfirst{read} error")
(read [read_field_check (read [read_field_check
(srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error") (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)|}] {exn:source scheme_source_property |scheme_make_prim(extract_read_locations)|}]
"\\rawscm{read} parsing error" "\\rawscm{read} parsing error"
(eof [] "unexpected end-of-file") (eof [] "unexpected end-of-file")
(non-char [] "unexpected non-character")) (non-char [] "unexpected non-character"))
(filesystem [] "error manipulating a filesystem object" (filesystem [] "error manipulating a filesystem object"
(exists [] "attempt to create a file that exists already") (exists [] "attempt to create a file that exists already")
(version [] "version mismatch loading an extension")) (version [] "version mismatch loading an extension"))
(network [] "TCP and UDP errors") (network [] "TCP and UDP errors")
(out-of-memory [] "out of memory") (out-of-memory [] "out of memory")
(unsupported [] "unsupported feature") (unsupported [] "unsupported feature")
(user [] "for end users")) (user [] "for end users"))
(break [break_field_check
(continuation "escape continuation" "resumes from the break")]
"asynchronous break signal"))
(break [break_field_check
(continuation "escape continuation" "resumes from the break")]
"asynchronous break signal"))
)
#| #|
Not an exception in the above sense: Not an exception in the above sense:
(special-comment [width "non-negative exact integer" "width of the special comment in port positions"] (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")
|# |#

378
src/mzscheme/src/makeexn
View File

@ -1,13 +1,21 @@
#!/bin/sh #!/bin/sh
#| #|
if [ "$PLTHOME" = "" ] ; then PLTHOME=/usr/local/lib/plt ; export PLTHOME ; fi if [ "$PLTHOME" = "" ]; then
exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@" exec mzscheme -um "$0" "$@"
else
exec ${PLTHOME}/bin/mzscheme -um $0 "$@"
fi
|# |#
(define doc? (and (= (vector-length argv) 1) #lang scheme
(string=? (vector-ref argv 0) "doc")))
(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 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))
@ -99,13 +107,7 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
(add1 depth))) (add1 depth)))
(cdddr v)))))])) (cdddr v)))))]))
(define l (make-struct-list l (set! l (make-struct-list l #f #f "" 0 0))
#f
#f
""
0
0))
(define (symbol-length s) (define (symbol-length s)
(string-length (symbol->string s))) (string-length (symbol->string s)))
@ -116,192 +118,168 @@ exec ${PLTHOME}/bin/mzscheme -gqr $0 "$@"
(regexp-replace* " " type "-") (regexp-replace* " " type "-")
"or-#f")) "or-#f"))
(if doc? (define (print-doc)
(begin (printf "% This file was generated by makeexn~n")
(printf "% This file was generated by makeexn~n") (display "\\begin{exntable}\n")
(display "\\begin{exntable}\n") (for-each
(for-each (lambda (e)
(lambda (e) (let ([tab
(let ([tab (lambda (pre)
(lambda (pre) (let loop ([d (ex-depth e)])
(let loop ([d (ex-depth e)]) (cond
(cond [(zero? d) ""]
[(zero? d) ""] [(= d 1) (format "\\exn~ainset{}" pre)]
[(= d 1) (format "\\exn~ainset{}" pre)] [else
[else (string-append (format "\\exn~atab{}" pre)
(string-append (format "\\exn~atab{}" pre) (loop (sub1 d)))])))])
(loop (sub1 d)))])))]) (display (tab ""))
(display (tab "")) (printf "\\exntype{~a}{~a}{~a}{~a} "
(printf "\\exntype{~a}{~a}{~a}{~a} " (ex-base e)
(ex-base e) (ex-string e)
(ex-string e) (case (ex-mark e)
(case (ex-mark e) ((#f) "$\\bullet$")
((#f) "$\\bullet$") ((#\+) "$\\bullet$")
((#\+) "$\\bullet$") ((#\*) "$\\bullet$"))
((#\*) "$\\bullet$")) (let ([make-var (lambda (f)
(let ([make-var (lambda (f) (let ([type (let ([s (fld-type f)])
(let ([type (let ([s (fld-type f)]) (if (string=? s "value")
(if (string=? s "value") "v"
"v" s))]
s))] [name (fld-name f)])
[name (fld-name f)]) (cond
(cond [(eq? name 'value) "v"]
[(eq? name 'value) "v"] [(regexp-match "port" type) type]
[(regexp-match "port" type) type] [else (format "~a-~a" name (clean-help-desk-type type))])))])
[else (format "~a-~a" name (clean-help-desk-type type))])))]) (let loop ([e e][s #f])
(let loop ([e e][s #f]) (let* ([p (ex-parent e)]
(let* ([p (ex-parent e)] [s (if p (loop p s) s)])
[s (if p (loop p s) s)]) (let loop ([l (ex-args e)][s s])
(let loop ([l (ex-args e)][s s]) (cond
(cond [(null? l) s]
[(null? l) s] [s (loop (cdr l) (string-append s " " (make-var (car l))))]
[s (loop (cdr l) (string-append s " " (make-var (car l))))] [else (loop (cdr l) (make-var (car l)))]))))))
[else (loop (cdr l) (make-var (car l)))]))))))
(if (eq? (ex-doc e) '-)
(if (eq? (ex-doc e) '-) (printf "\\exnusenone{~a} " (tab ""))
(printf "\\exnusenone{~a} " (tab "")) (printf "\\exnuse{~a}{~a}{~a} " (tab "") (ex-doc e)
(printf "\\exnuse{~a}{~a}{~a} " (tab "") (ex-doc e) (- 6.3 (* 0.08 (symbol-length (ex-base e))) (* 0.25 (ex-depth e)))))
(- 6.3 (* 0.08 (symbol-length (ex-base e))) (* 0.25 (ex-depth e)))))
(let ([args (ex-args e)]
(let ([args (ex-args e)] [print-one
[print-one (lambda (f)
(lambda (f) (printf "\\exnfield{~a}{~a}{~s}{~a}{~a} "
(printf "\\exnfield{~a}{~a}{~s}{~a}{~a} " (fld-name f) (ex-string e)
(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)))])
(fld-type f)))]) (unless (null? args)
(unless (null? args) (printf "\\exnbeginfields{~a} " (tab ""))
(printf "\\exnbeginfields{~a} " (tab "")) (print-one (car args))
(print-one (car args)) (for-each (lambda (f)
(for-each (lambda (f) (printf "\\exnnextfield{~a}" (tab ""))
(printf "\\exnnextfield{~a}" (tab "")) (print-one f))
(print-one f)) (cdr args))
(cdr args)) (printf "\\exnendfields{~a}" (tab ""))))
(printf "\\exnendfields{~a}" (tab "")))) (printf "\\exnendline{}")
(printf "\\exnendline{}") (display (tab "close"))
(display (tab "close")) (newline)))
(newline))) l)
l) (display "\\end{exntable}\n"))
(display "\\end{exntable}\n"))
(begin
(printf "/* This file was generated by makeexn */~n")
(printf "#ifndef _MZEXN_DEFINES~n") (define (print-header)
(printf "#define _MZEXN_DEFINES~n~n") (printf "/* This file was generated by makeexn */~n")
(printf "enum {~n") (printf "#ifndef _MZEXN_DEFINES~n")
(for-each (printf "#define _MZEXN_DEFINES~n~n")
(lambda (e) (printf "enum {~n")
(printf " ~a,~n" (ex-define e))) (for-each (lambda (e) (printf " ~a,~n" (ex-define e)))
l) l)
(printf " MZEXN_OTHER~n};~n~n") (printf " MZEXN_OTHER~n};~n~n")
(printf "#endif~n~n") (printf "#endif~n~n")
(printf "#ifdef _MZEXN_TABLE~n~n")
(printf "#define MZEXN_MAXARGS ~a~n~n" max-exn-args)
(printf "#ifdef _MZEXN_TABLE~n~n") (printf "#ifdef GLOBAL_EXN_ARRAY~n")
(printf "#define MZEXN_MAXARGS ~a~n~n" max-exn-args) (printf "static exn_rec exn_table[] = {~n")
(let loop ([ll l])
(printf "#ifdef GLOBAL_EXN_ARRAY~n") (let ([e (car ll)])
(printf " { ~a, NULL, NULL, 0, NULL, ~a }"
(printf "static exn_rec exn_table[] = {~n") (ex-numtotal e)
(let loop ([ll l]) (if (ex-parent e)
(let ([e (car ll)]) (let loop ([pos 0][ll l])
(if (eq? (car ll) (ex-parent e))
(printf " { ~a, NULL, NULL, 0, NULL, ~a }" pos
(ex-numtotal e) (loop (add1 pos) (cdr ll))))
(if (ex-parent e) -1))
(let loop ([pos 0][ll l]) (unless (null? (cdr ll))
(if (eq? (car ll) (ex-parent e)) (printf ",~n")
pos (loop (cdr ll)))))
(loop (add1 pos) (cdr ll)))) (printf "~n};~n")
-1)) (printf "#else~n")
(printf "static exn_rec *exn_table;~n")
(unless (null? (cdr ll)) (printf "#endif~n")
(printf ",~n") (printf "~n#endif~n~n")
(loop (cdr ll))))) (printf "#ifdef _MZEXN_PRESETUP~n~n")
(printf "~n};~n") (printf "#ifndef GLOBAL_EXN_ARRAY~n")
(printf " exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);~n")
(printf "#else~n") (let loop ([l l])
(printf "static exn_rec *exn_table;~n") (let ([e (car l)])
(printf "#endif~n") (printf " exn_table[~a].args = ~a;~n"
(ex-define e)
(printf "~n#endif~n~n") (ex-numtotal e))
(unless (null? (cdr l))
(printf "#ifdef _MZEXN_PRESETUP~n~n") (loop (cdr l)))))
(printf "#ifndef GLOBAL_EXN_ARRAY~n") (printf "#endif~n")
(printf " exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER);~n") (printf "~n#endif~n~n")
(let loop ([l l]) (printf "#ifdef _MZEXN_DECL_FIELDS~n~n")
(let ([e (car l)]) (for-each
(lambda (e)
(printf " exn_table[~a].args = ~a;~n" (let ([l (ex-args e)])
(ex-define e) (unless (null? l)
(ex-numtotal e)) (printf "static const char *~a_FIELDS[~s] = { \"~a\""
(unless (null? (cdr l)) (ex-define e) (length l) (fld-name (car l)))
(loop (cdr l))))) (for-each
(printf "#endif~n") (lambda (field)
(printf "~n#endif~n~n") (printf ", \"~a\"" (fld-name field)))
(cdr l))
(printf "#ifdef _MZEXN_DECL_FIELDS~n~n") (printf " };~n"))))
l)
(for-each (printf "~n#endif~n~n")
(lambda (e) (printf "#ifdef _MZEXN_DECL_PROPS~n~n")
(let ([l (ex-args e)]) (for-each
(unless (null? l) (lambda (e)
(printf "static const char *~a_FIELDS[~s] = { \"~a\"" (let ([l (ex-props e)])
(ex-define e) (unless (null? l)
(length l) (printf "#define ~a_PROPS " (ex-define e))
(fld-name (car l))) (let loop ([l l])
(for-each (if (null? l)
(lambda (field) (printf "scheme_null")
(printf ", \"~a\"" (fld-name field))) (begin
(cdr l)) (printf "scheme_make_pair(")
(printf " };~n")))) (printf "scheme_make_pair(~a, ~a), "
l) (prop-c-name (car l))
(prop-value (car l)))
(printf "~n#endif~n~n") (loop (cdr l))
(printf ")"))))
(printf "#ifdef _MZEXN_DECL_PROPS~n~n") (printf "~n"))))
l)
(for-each (printf "~n#endif~n~n")
(lambda (e) (printf "#ifdef _MZEXN_SETUP~n~n")
(let ([l (ex-props e)]) (for-each
(unless (null? l) (lambda (e)
(printf "#define ~a_PROPS " (ex-define e)) (printf " SETUP_STRUCT(~a, ~a, ~s, ~a, ~a, ~a, ~a)~n"
(let loop ([l l]) (ex-define e)
(if (null? l) (let ([p (ex-parent-def e)])
(printf "scheme_null") (if p
(begin (format "EXN_PARENT(~a)" p)
(printf "scheme_make_pair(") #cs'NULL))
(printf "scheme_make_pair(~a, ~a), " (ex-string e)
(prop-c-name (car l)) (length (ex-args e))
(prop-value (car l))) (if (null? (ex-args e))
(loop (cdr l)) "NULL"
(printf ")")))) (format "~a_FIELDS" (ex-define e)))
(printf "~n")))) (if (null? (ex-props e))
l) "scheme_null"
(format "~a_PROPS" (ex-define e)))
(printf "~n#endif~n~n") (if (ex-guard e)
(format "scheme_make_prim(~a)" (ex-guard e))
(printf "#ifdef _MZEXN_SETUP~n~n") "NULL")))
l)
(for-each (printf "~n#endif~n"))
(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")))