1#lang racket/base
2(require racket/cmdline)
3
4(define list-mode (make-parameter #f))
5(define assign-mode (make-parameter #f))
6(define exports-mode (make-parameter #f))
7(define winex-mode (make-parameter #f))
8(define gwinex-mode (make-parameter #f))
9(define gcalert-mode (make-parameter #f))
10(define precisegc-mode (make-parameter #f))
11
12(command-line
13 #:once-each
14 [("--list") "list mode" (list-mode #t)]
15 [("--assign") "assign mode" (assign-mode #t)]
16 [("--exports") "export mode" (exports-mode #t)]
17 [("--winex") "windows export mode" (winex-mode #t)]
18 [("--gwinex") "windows GC exports mode " (gwinex-mode #t)]
19 [("--precisegc") "precise GC mode" (precisegc-mode #t)])
20
21(when (list-mode)
22  (gcalert-mode #t))
23
24(when (or (assign-mode)
25          (exports-mode)
26          (winex-mode)
27          (gwinex-mode))
28  (list-mode #t))
29
30(define (balance s)
31  (for/fold ([parens 0]) ([c (in-string s)])
32    (case c
33      [(#\() (+ parens 1)]
34      [(#\)) (- parens 1)]
35      [else parens])))
36
37(define exported
38  (let loop ()
39    (let ([l (read-line)])
40      (cond
41       [(equal? l "/* SKIP */")
42        (let loop ()
43          (let ([l (read-line)])
44            (unless (equal? l "/* START */")
45              (loop))))
46        (unless (list-mode)
47          (printf "typedef struct {\n"))
48        (let loop ([exported null])
49          (let ([l (read-line)])
50            (cond
51             [(eof-object? l) (reverse exported)]
52             [(regexp-match #rx"^/[*]" l)
53              (unless (list-mode) (displayln l))
54              (loop exported)]
55             [(regexp-match #rx"^#" l)
56              (unless (list-mode) (displayln l))
57              (loop (cons l exported))]
58             [(regexp-match? #rx"^ *$" l)
59              (loop exported)]
60             [else
61              (let* ([l (regexp-replace #rx"^extern " l "")]
62                     [l (regexp-replace #rx"^XFORM_NONGCING " l "")]
63                     [l (regexp-replace #rx"^XFORM_NONGCING_NONALIASING " l "")]
64                     [l (regexp-replace #rx"^MZ_EXTERN " l "")]
65                     [l (regexp-replace #rx"^MZ_NORETURN " l "")]
66                     [l (regexp-replace #rx"^THREAD_LOCAL " l "")]
67                     [l2 (regexp-replace #rx"^volatile " l "")]
68                     [volatile (if (equal? l l2) "" "volatile ")]
69                     [l l2]
70                     [l2 (regexp-replace #rx"^const " l "")]
71                     [const (if (equal? l l2) "" "const ")]
72                     [l l2]
73                     [l2 (regexp-replace #rx"^struct " l "")]
74                     [const (if (equal? l l2) const "struct ")]
75                     [l l2]
76                     [l2 (regexp-replace #rx"^unsigned " l "")]
77                     [unsigned (if (equal? l l2) "" "unsigned ")]
78                     [l l2]
79                     [star (if (regexp-match? #rx"\\[1?\\];$" l)
80                               "*"
81                               "")]
82                     [m (regexp-match "([a-zA-Z0-9_]*) ([*]*)([a-zA-Z0-9_]*)(.*)" l)])
83                (unless (list-mode)
84                  (if (equal? "(" (substring (list-ref m 4) 0 1))
85                      (apply printf "~a~a~a ~a(*~a)~a\n"
86                             const unsigned (cdr m))
87                      (printf "~a~a~a~a ~a~a~a;\n"
88                              const volatile unsigned (cadr m) star (caddr m) (cadddr m))))
89                (when (positive? (balance (list-ref m 4)))
90                  (let loop ()
91                    (let ([l (read-line)])
92                      (unless (list-mode)
93                        (displayln l))
94                      (unless (regexp-match #rx"[)];" l)
95                        (loop)))))
96                (loop (cons (list-ref m 3) exported)))])))]
97       [else
98        (unless (list-mode)
99          (displayln l))
100        (loop)]))))
101
102(unless (list-mode)
103  (printf "#ifndef SCHEME_EX_INLINE\n} Scheme_Extension_Table;\n#endif\n"))
104
105(when (exports-mode)
106  (printf "#!..\n"))
107(when (or (winex-mode)
108          (gwinex-mode))
109  (printf "EXPORTS\n"))
110
111(when (list-mode)
112  (for/fold ([suspend? #f] [else-suspend? #f]) ([l (in-list exported)])
113    (cond
114     [(equal? "#" (substring l 0 1))
115      (if (or (exports-mode)
116              (winex-mode)
117              (gwinex-mode))
118          (cond
119           [(regexp-match? #rx"#ifdef MZ_REAL_THREADS" l)
120            (values #t #f)]
121           [(regexp-match? #rx"#ifndef MZ_REAL_THREADS" l)
122            (values #f #t)]
123           [(regexp-match? #rx"#ifdef MACINTOSH_EVENTS" l)
124            (values #t #f)]
125           [(regexp-match? #rx"#ifdef USE_MAC_FILE_TOOLBOX" l)
126            (values #t #f)]
127           [(regexp-match? #rx"#ifdef USE_MAC_CARBON_FILE_TOOLBOX" l)
128            (values #t #f)]
129           [(regexp-match? #rx"#ifdef MZ_USE_SINGLE_FLOATS" l)
130            (values #t #f)]
131           [(regexp-match? #rx"#ifdef MZ_LONG_DOUBLE" l)
132            (values #t #f)]
133           [(and (exports-mode)
134                 (regexp-match? #rx"#ifdef USE_MZ_SETJMP" l))
135            (values #t #f)]
136           [(regexp-match? #px"#\\s*ifdef MZ_PRECISE_GC" l)
137            (if (precisegc-mode)
138                (values #f #t)
139                (values #t #f))]
140           [(regexp-match? #rx"#ifndef LINK_EXTENSIONS_BY_TABLE" l)
141            (values #f #t)]
142           [(regexp-match? #px"#\\s*else" l)
143            (values else-suspend? #f)]
144           [(regexp-match? #px"#\\s*endif" l)
145            (values #f #f)]
146           [else
147            (values suspend? else-suspend?)])
148          (begin
149            (displayln l)
150            (values suspend? else-suspend?)))]
151     [else
152      (cond
153       [(assign-mode)
154        (printf "  scheme_extension_table->~a = ~a;\n" l l)]
155       [(exports-mode)
156        (unless suspend? (printf "~a\n" l))]
157       [(or (winex-mode) (gwinex-mode))
158        (unless suspend?
159          (when (or
160                 (and (winex-mode) (regexp-match #rx"^scheme_" l))
161                 (and (gwinex-mode) (regexp-match #rx"^GC_" l)))
162            (printf " ~a" l)
163            (when (ormap (lambda (rx)
164                           (regexp-match? rx l))
165                         '(#rx"scheme_current_thread"
166                              #rx"scheme_fuel_counter"
167                              #rx"scheme_eof"
168                              #rx"scheme_null"
169                              #rx"scheme_true"
170                              #rx"scheme_false"
171                              #rx"scheme_void"
172                              #rx"scheme_undefined"
173                              #rx"scheme_null"))
174              (printf " DATA"))
175            (printf "\n")))]
176       [else
177        (printf "#define ~a (scheme_extension_table->~a)\n" l l)])
178      (values suspend? else-suspend?)]))
179  (void))
180
181(when (gcalert-mode)
182  (printf "#ifdef MZ_PRECISE_GC\n");
183  (printf "#pragma GC_VARIABLE_STACK_THOUGH_TABLE\n")
184  (printf "#endif\n"))
185