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