1#lang racket/base 2 3(define re:start "^START ([a-z_]+);") 4(define re:end "^END ([a-z_]+);") 5 6(define re:form "^([a-zA-Z0-9_]+) [{]") 7 8(define re:mark "^ mark:") 9(define re:size "^ size:") 10(define re:size-or-more "^ (?:size|more):") 11(define re:fixup-start "^ fixup:") 12(define re:close "^}") 13 14(define re:const-size (regexp "^[ \t]*gcBYTES_TO_WORDS[(]sizeof[(][A-Za-z0-9_]*[)][)];[ \t]*$")) 15 16(define (do-form name) 17 (let ([read-lines 18 (lambda (re:done) 19 (let loop () 20 (let ([l (read-line)]) 21 (if (eof-object? l) 22 (error 'mkmark.rkt "unexpected EOF") 23 (cond 24 [(regexp-match re:done l) 25 null] 26 [(or (regexp-match re:mark l) 27 (regexp-match re:size-or-more l) 28 (regexp-match re:fixup-start l)) 29 (error 'mkmark.rkt "unexpected label: ~a at ~a" l 30 (file-position (current-input-port)))] 31 [(regexp-match re:close l) 32 (error 'mkmark.rkt "unexpected close")] 33 [else (cons l (loop))])))))] 34 [print-lines (lambda (l [skip-rx #f] [skip-alt-bracket #f]) 35 (let loop ([l l] [skip? #f]) 36 (cond 37 [(null? l) (void)] 38 [(and skip-rx (regexp-match? skip-rx (car l))) 39 (when skip-alt-bracket 40 (if skip? 41 (printf "#endif\n") 42 (printf "#ifdef ~a\n" skip-alt-bracket))) 43 (loop (cdr l) (not skip?))] 44 [(and skip? (not skip-alt-bracket)) 45 (loop (cdr l) #t)] 46 [(regexp-match? #rx"(START|END)_[A-Z_]+_ONLY;" (car l)) 47 (loop (cdr l) skip?)] 48 [else 49 (printf "~a\n" (car l)) 50 (loop (cdr l) skip?)])))]) 51 (let ([prefix (read-lines re:mark)] 52 [mark (read-lines re:size-or-more)] 53 [fixup (if (regexp-match-peek re:fixup-start (current-input-port)) 54 (begin 55 (regexp-match re:fixup-start (current-input-port)) 56 (read-lines re:size)) 57 null)] 58 [size (read-lines re:close)]) 59 60 (define (print-size size) 61 (printf "# ifdef GC_NO_SIZE_NEEDED_FROM_PROCS\n") 62 (printf " return 0;\n") 63 (printf "# else\n") 64 (printf " return\n") 65 (print-lines size) 66 (printf "# endif\n")) 67 68 (printf "static int ~a_SIZE(void *p, struct NewGC *gc) {\n" name) 69 (printf "#ifndef GC_NO_SIZE_NEEDED_FROM_PROCS\n") 70 (print-lines prefix) 71 (print-lines size) 72 (printf "#else\n") 73 (printf " return 0;\n") 74 (printf "#endif\n") 75 (printf "}\n\n") 76 77 (printf "static int ~a_MARK(void *p, struct NewGC *gc) {\n" name) 78 (printf "#ifndef GC_NO_MARK_PROCEDURE_NEEDED\n") 79 (print-lines prefix) 80 (print-lines (map (lambda (s) 81 (regexp-replace* 82 "FIXUP_ONLY[(]([^;]*;)[)]" 83 (regexp-replace* 84 "FIXUP2_TYPED_NOW[(][^,]*," 85 s 86 "MARK2(") 87 "")) 88 mark) 89 #rx"FIXUP_ONLY") 90 (print-size size) 91 (printf "#endif\n") 92 (printf "}\n\n") 93 94 (printf "static int ~a_FIXUP(void *p, struct NewGC *gc) {\n" name) 95 (printf "#ifndef GC_NO_FIXUP_PROCEDURE_NEEDED\n") 96 (print-lines prefix) 97 (print-lines (map (lambda (s) 98 (regexp-replace* 99 "FIXUP_ONLY[(]([^;]*;)[)]" 100 (regexp-replace* 101 "MARK(?!_ONLY)" 102 s 103 "FIXUP") 104 "\\1")) 105 (append 106 mark 107 fixup)) 108 #rx"MARK_ONLY") 109 (print-size size) 110 (printf "#endif\n") 111 (printf "}\n\n") 112 113 (printf "#define ~a_IS_ATOMIC ~a\n" 114 name 115 (if (null? mark) 116 "1" 117 "0")) 118 119 (printf "#define ~a_IS_CONST_SIZE ~a\n\n" 120 name 121 (if (and (= 1 (length size)) 122 (regexp-match re:const-size (car size))) 123 "1" 124 "0"))))) 125 126(let loop () 127 (let ([l (read-line)]) 128 (unless (eof-object? l) 129 (cond 130 [(regexp-match re:start l) 131 => (lambda (m) 132 (let ([who (cadr m)] 133 [so (open-output-bytes)]) 134 (parameterize ([current-output-port so]) 135 (printf "/* >>>> Generated by mkmark.rkt from mzmarksrc.c <<<< */\n") 136 (let file-loop () 137 (let ([l (read-line)]) 138 (if (eof-object? l) 139 (error 'mkmark.rkt "unexpected EOF") 140 (cond 141 [(regexp-match re:end l) 142 => (lambda (m) (void))] 143 [(regexp-match re:form l) 144 => (lambda (m) 145 (do-form (cadr m)) 146 (file-loop))] 147 [else (printf "~a\n" l) 148 (file-loop)]))))) 149 (let* ([b (get-output-bytes so)] 150 [file (build-path 151 (vector-ref (current-command-line-arguments) 0) 152 (format "mzmark_~a.inc" who))] 153 [so2 (open-output-bytes)]) 154 (when (file-exists? file) 155 (call-with-input-file* 156 file 157 (lambda (i) 158 (let loop () 159 (let ([s (read-bytes 4096 i)]) 160 (unless (eof-object? s) 161 (write-bytes s so2) 162 (loop))))))) 163 (let ([b2 (get-output-bytes so2)]) 164 (unless (equal? b b2) 165 (printf "Writing ~a\n" file) 166 (call-with-output-file* 167 file 168 #:exists 'truncate/replace 169 (lambda (o) 170 (write-bytes b o))))))) 171 (loop))] 172 [else (loop)])))) 173