1#!/bin/sh 2#| 3if [ "$PLTHOME" = "" ]; then 4 exec racket -um "$0" "$@" 5else 6 exec ${PLTHOME}/bin/racket -um $0 "$@" 7fi 8|# 9 10#lang at-exp racket/base 11(require racket/pretty) 12 13(provide main) 14(define (main [arg #f] [filename #f]) 15 (if (equal? arg "kernstruct") 16 (gen-kernstruct filename) 17 (print-header))) 18 19(require scribble/text) 20 21#| 22 23Initial symbols are struct types. A non-initial symbol is a struct 24type without fields or subtypes. Square brackets are struct fields and 25propeties (the latter in curly braces), strings are contracts/comments. 26 27|# 28 29(define info ' 30 31(exn [exn_field_check 32 (message "immutable string" "error message") 33 (continuation-marks "mark set" 34 "value returned by \\scmfirst{current-continuation-marks} immediately before the exception is raised")] 35 - 36 (fail [] "exceptions that represent errors" 37 (contract [] "inappropriate run-time use of a function or syntactic form" 38 (arity [] 39 "application with the wrong number of arguments") 40 (divide-by-zero [] "divide by zero") 41 (non-fixnum-result [] "arithmetic produced a non-fixnum result") 42 (continuation [] "attempt to cross a continuation barrier") 43 (variable [variable_field_check 44 (id "symbol" "the variable's identifier")] 45 "not-yet-defined global or module variable")) 46 (#:only-kernstruct 47 syntax [syntax_field_check 48 (exprs "immutable list of syntax objects" "illegal expression(s)") 49 {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_syntax_locations, "extract_syntax_locations", 0, -1)|}] 50 "syntax error, but not a \\scmfirst{read} error" 51 (unbound [] 52 "unbound module variable") 53 (missing-module [module_path_field_check_3 54 (path "module path" "module path") 55 {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_3, "extract_module_path_3", 0, -1)|}] 56 "error resolving a module path")) 57 (read [read_field_check 58 (srclocs "immutable list of \\scmk{srcloc}s (see \\SecRef{linecol})" "source location(s) of error") 59 {exn:source scheme_source_property |scheme_make_prim_w_arity(extract_read_locations, "extract_read_locations", 0, -1)|}] 60 "\\rawscm{read} parsing error" 61 (eof [] "unexpected end-of-file") 62 (non-char [] "unexpected non-character")) 63 (filesystem [] "error manipulating a filesystem object" 64 (exists [] "attempt to create a file that exists already") 65 (version [] "version mismatch loading an extension") 66 (errno [errno_field_check 67 (errno "pair of symbol and number" "system error code")] 68 "error with system error code") 69 (#:only-kernstruct 70 missing-module [module_path_field_check_2 71 (path "module path" "module path") 72 {exn:module-path scheme_module_path_property |scheme_make_prim_w_arity(extract_module_path_2, "extract_module_path_2", 0, -1)|}] 73 "error resolving a module path")) 74 (network [] "TCP and UDP errors" 75 (errno [errno_field_check 76 (errno "pair of symbol and number" "system error code")] 77 "error with system error code")) 78 (out-of-memory [] "out of memory") 79 (unsupported [] "unsupported feature") 80 (user [] "for end users")) 81 82 (break [break_field_check 83 (continuation "escape continuation" "resumes from the break")] 84 "asynchronous break signal" 85 (hang-up [] 86 "terminal disconnect") 87 (terminate [] 88 "termination request"))) 89 90) 91 92#| 93Not an exception in the above sense: 94 (special-comment [width "non-negative exact integer" "width of the special comment in port positions"] 95 "raised by a custom input port's special-reading procedure") 96|# 97 98(define l info) 99 100(define-struct ex (define string base doc args props guard parent parent-def 101 numtotal depth mark only-kernstruct?)) 102(define-struct fld (name type doc)) 103(define-struct prop (scheme-name c-name value)) 104 105(define max-exn-args 0) 106 107(define (make-an-ex sym parent parent-def parent-name totalargs args props 108 guard doc depth mark only-kernstruct?) 109 (let* ([s (symbol->string sym)] 110 [name (string-append parent-name 111 (if (string=? "" parent-name) "" ":") 112 s)] 113 [count (+ totalargs (length args))]) 114 (when (and (> count max-exn-args) 115 (not only-kernstruct?)) 116 (set! max-exn-args count)) 117 (make-ex (string-append "MZ" 118 (list->string 119 (let loop ([l (string->list name)]) 120 (cond 121 [(null? l) '()] 122 [(or (char=? (car l) #\:) 123 (char=? (car l) #\/) 124 (char=? (car l) #\-)) 125 (cons #\_ (loop (cdr l)))] 126 [else 127 (cons (char-upcase (car l)) 128 (loop (cdr l)))])))) 129 name 130 sym 131 doc 132 args 133 props 134 guard 135 parent 136 parent-def 137 count 138 depth 139 mark 140 only-kernstruct?))) 141 142(define (make-arg-list args) 143 (cond 144 [(null? args) '()] 145 [(string? (cadar args)) 146 (cons (apply make-fld (car args)) 147 (make-arg-list (cdr args)))] 148 [else 149 (make-arg-list (cdr args))])) 150 151(define (make-prop-list args) 152 (cond 153 [(null? args) '()] 154 [(symbol? (cadar args)) 155 (cons (apply make-prop (car args)) 156 (make-prop-list (cdr args)))] 157 [else 158 (make-prop-list (cdr args))])) 159 160(define (make-struct-list v parent parent-def parent-name totalargs depth only-kernstruct?) 161 (cond 162 [(null? v) '()] 163 [else 164 (let*-values ([(v only-kernstruct?) 165 (if (eq? '#:only-kernstruct (car v)) 166 (values (cdr v) #t) 167 (values v only-kernstruct?))] 168 [(s mark) 169 (let* ([s (symbol->string (car v))] 170 [c (string-ref s 0)]) 171 (if (or (char=? #\* c) 172 (char=? #\+ c)) 173 (values (string->symbol (substring s 1 (string-length s))) c) 174 (values (car v) #f)))] 175 [(e) (make-an-ex s parent parent-def parent-name totalargs 176 (if (null? (cadr v)) 177 null 178 (make-arg-list (cdadr v))) 179 (if (null? (cadr v)) 180 null 181 (make-prop-list (cdadr v))) 182 (if (null? (cadr v)) 183 #f 184 (caadr v)) 185 (caddr v) depth mark 186 only-kernstruct?)]) 187 (cons e 188 (apply append 189 (map 190 (lambda (v) 191 (make-struct-list v 192 e 193 (ex-define e) 194 (ex-string e) 195 (ex-numtotal e) 196 (add1 depth) 197 only-kernstruct?)) 198 (cdddr v)))))])) 199 200(set! l (make-struct-list l #f #f "" 0 0 #f)) 201 202 203(define (gen-kernstruct filename) 204 (define preamble '(module kernstruct '#%kernel 205 (#%require (for-syntax '#%kernel)) 206 (#%require "define.rkt") 207 (#%require (for-syntax "struct-info.rkt")) 208 209 (#%provide (all-defined)) 210 211 (define-values-for-syntax 212 (struct:struct-field-info 213 make-struct-field-info 214 struct-field-info-rec? 215 struct-field-info-ref 216 struct-field-info-set!) 217 (make-struct-type 'struct-field-info struct:struct-info 218 1 0 #f 219 (list (cons prop:struct-field-info 220 (lambda (rec) 221 (struct-field-info-ref rec 0)))))) 222 223 224 (define-values-for-syntax (make-self-ctr-struct-info) 225 (letrec-values ([(struct: make- ? ref set!) 226 (make-struct-type 'self-ctor-struct-info struct:struct-field-info 227 1 0 #f 228 (list (cons prop:procedure 229 (lambda (v stx) 230 (let-values ([(id) ((ref v 0))]) 231 (if (symbol? (syntax-e stx)) 232 id 233 (datum->syntax stx 234 (cons id (cdr (syntax-e stx))) 235 stx 236 stx)))))) 237 (current-inspector) #f '(0))]) 238 make-)))) 239 240 (define (sss . args) 241 (string->symbol (apply string-append (map (λ (x) (if (symbol? x) (symbol->string x) x)) args)))) 242 243 (define (non-parent x) 244 (or (equal? #f x) (equal? #t x))) 245 246 (define (gen-ds name-string fields num-selector parent) 247 (let* ([name (sss name-string)] 248 [kern-name (sss "kernel:" name)] 249 [sn (sss "struct:" name)] 250 [mn (sss "make-" name)] 251 [pn (sss name "?")] 252 [fds `(list ,@(map (λ (x) `(quote-syntax ,x)) fields))] 253 [fdsset! `'(,@(map (λ (x) #f) fields))] 254 [prnt (if (non-parent parent) #t `(quote-syntax ,parent))] 255 [name-length (string-length (symbol->string name))] 256 [field-names (for/list ([fld (take fields num-selector)]) 257 ;; add1 for hyphen 258 (string->symbol (substring (symbol->string fld) (add1 name-length))))]) 259 `(begin 260 (#%require (rename '#%kernel ,kern-name ,name)) 261 (define ,mn ,kern-name) 262 (define-syntax ,name (make-self-ctr-struct-info 263 (λ () (list (quote-syntax ,sn) 264 (quote-syntax ,mn) 265 (quote-syntax ,pn) 266 ,fds 267 ,fdsset! ,prnt)) 268 ',field-names 269 (λ () (quote-syntax ,kern-name))))))) 270 271 (define (parent-sym x) 272 (let ([parent (ex-parent x)]) 273 (if (non-parent parent) 274 parent 275 (string->symbol (ex-string parent))))) 276 277 (define (fields exn) 278 (define (field-name exn fld) 279 (sss (ex-string exn) "-" (fld-name fld))) 280 (if (non-parent exn) 281 null 282 (append (reverse (map (λ (field) (field-name exn field)) (ex-args exn))) (fields (ex-parent exn))))) 283 284 (define exceptions (map (λ (x) (gen-ds (ex-string x) (fields x) (length (ex-args x)) (parent-sym x))) l)) 285 (define structs (map (λ (x) (apply gen-ds x)) 286 '((arity-at-least (arity-at-least-value) 1 #t) 287 (date (date-time-zone-offset date-dst? date-year-day date-week-day date-year 288 date-month date-day date-hour date-minute date-second) 10 #t) 289 (date* (date*-time-zone-name date*-nanosecond 290 date-time-zone-offset date-dst? date-year-day date-week-day date-year 291 date-month date-day date-hour date-minute date-second) 2 date) 292 (srcloc (srcloc-span srcloc-position srcloc-column srcloc-line srcloc-source) 5 #t)))) 293 294 (with-output-to-file filename #:exists 'replace 295 (λ () 296 (printf ";; This file was generated by makeexn\n") 297 (printf ";;----------------------------------------------------------------------\n") 298 (printf ";; record for static info produced by structs defined in c\n") 299 (pretty-write (append preamble exceptions structs))))) 300 301(define (print-header) 302 @(compose output list){ 303 /* This file was generated by makeexn */ 304 #ifndef _MZEXN_DEFINES 305 #define _MZEXN_DEFINES 306 enum { 307 @(add-newlines (for/list ([e l] #:unless (ex-only-kernstruct? e)) @list{ @(ex-define e),})) 308 MZEXN_OTHER 309 }; 310 #endif 311 312 #ifdef _MZEXN_TABLE 313 314 #define MZEXN_MAXARGS @max-exn-args 315 316 #ifdef GLOBAL_EXN_ARRAY 317 static exn_rec exn_table[] = { 318 @(let loop ([ll l]) 319 (let ([e (car ll)]) 320 (if (ex-only-kernstruct? e) 321 (loop (cdr ll)) 322 (cons @list{ { @(ex-numtotal e), NULL, NULL, 0, NULL, @; 323 @(if (ex-parent e) 324 (let loop ([pos 0][ll l]) 325 (cond 326 [(eq? (car ll) (ex-parent e)) 327 pos] 328 [(ex-only-kernstruct? (car ll)) 329 (loop pos (cdr ll))] 330 [else 331 (loop (add1 pos) (cdr ll))])) 332 -1) }} 333 (if (null? (cdr ll)) 334 '() 335 (cons ",\n" (loop (cdr ll)))))))) 336 }; 337 #else 338 static exn_rec *exn_table; 339 #endif 340 341 #endif 342 343 #ifdef _MZEXN_PRESETUP 344 345 #ifndef GLOBAL_EXN_ARRAY 346 exn_table = (exn_rec *)scheme_malloc(sizeof(exn_rec) * MZEXN_OTHER); 347 @(add-newlines 348 (for/list ([e l] #:unless (ex-only-kernstruct? e)) 349 @list{ exn_table[@(ex-define e)].args = @(ex-numtotal e)@";"})) 350 #endif 351 352 #endif 353 354 #ifdef _MZEXN_DECL_FIELDS 355 @(add-newlines 356 (for*/list ([e l] 357 #:unless (ex-only-kernstruct? e) 358 [l (in-value (ex-args e))] 359 #:when (pair? l)) 360 (define fields 361 (add-between (map (lambda (f) @list{"@(fld-name f)"}) l) ", ")) 362 @list{ static const char *@(ex-define e)_FIELDS[@(length l)] = @; 363 { @fields }; 364 })) 365 #endif 366 367 #ifdef _MZEXN_DECL_PROPS 368 @(add-newlines 369 (for*/list ([e l] 370 #:unless (ex-only-kernstruct? e) 371 [l (in-value (ex-props e))] 372 #:when (pair? l)) 373 (define (acons x y l) 374 @list{scheme_make_pair(scheme_make_pair(@x, @y), @l)}) 375 @list{# define @(ex-define e)_PROPS @; 376 @(let loop ([l l]) 377 (if (null? l) 378 "scheme_null" 379 (acons (prop-c-name (car l)) (prop-value (car l)) 380 (loop (cdr l)))))})) 381 #endif 382 383 #ifdef _MZEXN_SETUP 384 @(add-newlines 385 (for/list ([e l] 386 #:unless (ex-only-kernstruct? e)) 387 @list{ SETUP_STRUCT(@(ex-define e), @; 388 @(let ([p (ex-parent-def e)]) 389 (if p @list{EXN_PARENT(@p)} 'NULL)), @; 390 "@(ex-string e)", @; 391 @(length (ex-args e)), @; 392 @(if (null? (ex-args e)) 393 'NULL 394 @list{@(ex-define e)_FIELDS}), @; 395 @(if (null? (ex-props e)) 396 'scheme_null 397 @list{@(ex-define e)_PROPS}), @; 398 @(if (ex-guard e) 399 @list{scheme_make_prim_w_arity(@(ex-guard e), "@(ex-guard e)" , 0, -1)} 400 'NULL))})) 401 #endif 402 @||}) 403