1(module compile-unit racket/base
2  (require racket/unit
3           racket/system
4           "private/dirs.rkt"
5           "private/stdio.rkt"
6           "private/cmdargs.rkt")
7
8  (require "compile-sig.rkt")
9
10  (provide dynext:compile@)
11
12  (define-unit dynext:compile@
13      (import)
14      (export dynext:compile^)
15
16      (define (get-unix-compile)
17	(or (find-executable-path "gcc" #f)
18	    (find-executable-path "cc" #f)))
19
20      (define (get-windows-compile)
21	(or (find-executable-path "cl.exe" #f)
22	    (find-executable-path "gcc.exe" #f)
23	    (find-executable-path "bcc32.exe" #f)))
24
25      (define current-extension-compiler
26	(make-parameter
27	 (or (let ([p (or (getenv "MZSCHEME_DYNEXT_COMPILER")
28			  (getenv "CC"))])
29	       (and p
30		    (if (absolute-path? p)
31			(string->path p)
32			(find-executable-path p #f))))
33	     (case (system-type)
34	       [(unix macosx) (get-unix-compile)]
35	       [(windows) (get-windows-compile)]
36	       [else #f]))
37	 (lambda (v)
38	   (when v
39	     (if (path-string? v)
40		 (unless (and (file-exists? v)
41			      (memq 'execute (file-or-directory-permissions v)))
42		   (error 'current-extension-compiler
43			  "compiler not found or not executable: ~s" v))
44		 (raise-type-error 'current-extension-compiler "path, valid-path string, or #f" v)))
45	   v)))
46
47      (define win-gcc?
48	(let ([c (current-extension-compiler)])
49	  (and c (regexp-match #"gcc.exe$" (path->bytes c)))))
50      (define win-borland?
51	(let ([c (current-extension-compiler)])
52	  (and c (regexp-match #"bcc32.exe$" (path->bytes c)))))
53      (define unix-cc?
54	(let ([c (current-extension-compiler)])
55	  (and c (regexp-match #"[^g]cc$" (path->bytes c)))))
56
57      (define (add-variant-flags l)
58	(append l (list (lambda ()
59			  (if (eq? '3m (specific-compile-variant))
60			      '("-DMZ_PRECISE_GC")
61			      null)))))
62
63      (define gcc-cpp-flags
64	(add-variant-flags (case (string->symbol (path->string (system-library-subpath #f)))
65			     [(parisc-hpux) '("-D_HPUX_SOURCE")]
66			     [(ppc-macosx x86_64-macosx) '("-DOS_X")]
67			     [(i386-macosx) '("-DOS_X" "-m32")]
68			     [(ppc-darwin x86_64-darwin) '("-DOS_X" "-DXONX")]
69			     [(i386-darwin) '("-DOS_X" "-DXONX" "-m32")]
70			     [else null])))
71
72      (define gcc-compile-flags (append '("-c" "-O2" "-fPIC")
73					(case (string->symbol (path->string (system-library-subpath #f)))
74					  [(i386-macosx i386-darwin) '("-m32" "-fno-common")]
75					  [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")]
76					  [(win32\\i386) '("-DAS_MSVC_EXTENSION")]
77					  [else null])
78					gcc-cpp-flags))
79
80      (define unix-cpp-flags
81	(add-variant-flags (case (string->symbol (path->string (system-library-subpath #f)))
82			     [(parisc-hpux) '("-D_HPUX_SOURCE")]
83			     [else gcc-cpp-flags])))
84
85      (define unix-compile-flags (case (string->symbol (path->string (system-library-subpath #f)))
86				   [(parisc-hpux) (append '("-c" "-O2" "-Aa" "+z" "+e")
87							  unix-cpp-flags)]
88				   [else gcc-compile-flags]))
89
90      (define msvc-compile-flags
91	(add-variant-flags '("/c" "/MT" "/O2")))
92
93      (define (make-flags-guard who)
94	(lambda (l)
95	  (unless (and (list? l) (andmap (lambda (s) (or (path-string? s)
96							 (and (procedure? s) (procedure-arity-includes? s 0))))
97					 l))
98	    (raise-type-error who "list of paths/strings and thunks" l))
99	  l))
100
101      (define (get-env-compile-flags)
102	(let ([v (or (getenv "MZSCHEME_DYNEXT_COMPILER_FLAGS")
103		     (getenv "CFLAGS"))])
104	  (if v
105	      (split-command-line-args v)
106	      null)))
107
108      (define current-extension-compiler-flags
109	(make-parameter
110	 (append
111	  (get-env-compile-flags)
112	  (case (system-type)
113	    [(unix macosx) (if unix-cc?
114			       unix-compile-flags
115			       gcc-compile-flags)]
116	    [(windows) (if (or win-gcc? win-borland?)
117			   gcc-compile-flags
118			   msvc-compile-flags)]
119	    [(macos) '()]))
120	 (make-flags-guard 'current-extension-compiler-flags)))
121
122      (define current-extension-preprocess-flags
123	(make-parameter
124	 (case (system-type)
125	   [(unix macosx) (cons "-E" (if unix-cc?
126					 unix-cpp-flags
127					 gcc-cpp-flags))]
128	   [(windows) (if (or win-gcc? win-borland?)
129			  (cons "-E" gcc-cpp-flags)
130			  '("/E"))]
131	   [(macos) '()])
132	 (make-flags-guard 'current-extension-preprocess-flags)))
133
134      (define compile-variant (make-parameter
135			       'normal
136			       (lambda (s)
137				 (unless (memq s '(normal cgc 3m))
138				   (raise-type-error 'compile-variant "'normal, 'cgc, or '3m" s))
139				 s)))
140
141      (define (specific-compile-variant)
142        (let ([v (compile-variant)])
143          (if (eq? v 'normal)
144              (system-type 'gc)
145              v)))
146
147      (define (expand-for-compile-variant l)
148	(apply append (map (lambda (s) (if (path-string? s) (list s) (s))) l)))
149
150      (define current-make-extra-extension-compiler-flags
151	(make-parameter
152	 (lambda () (case (specific-compile-variant)
153		      [(3m) '("-DMZ_PRECISE_GC")]
154		      [else null]))
155	 (lambda (p)
156	   (unless (and (procedure? p) (procedure-arity-includes? p 0))
157	     (raise-type-error 'current-make-extra-extension-compiler-flags "procedure (arity 0)" p))
158	   p)))
159
160      (define (path-string->string s)
161	(if (string? s) s (path->string s)))
162
163      (define unix-compile-include-strings (lambda (s)
164					     (list (string-append "-I" (path-string->string s)))))
165      (define msvc-compile-include-strings (lambda (s)
166					     (list (string-append "/I" (path-string->string s)))))
167
168      (define current-make-compile-include-strings
169	(make-parameter
170	 (case (system-type)
171	   [(unix macosx) unix-compile-include-strings]
172	   [(windows) (if (or win-gcc? win-borland?)
173			  unix-compile-include-strings
174			  msvc-compile-include-strings)]
175	   [(macos) unix-compile-include-strings])
176	 (lambda (p)
177	   (unless (procedure-arity-includes? p 1)
178	     (raise-type-error 'current-make-compile-include-strings "procedure of arity 1" p))
179	   p)))
180
181      (define current-make-compile-input-strings
182	(make-parameter
183	 (lambda (s) (list (path-string->string s)))
184	 (lambda (p)
185	   (unless (procedure-arity-includes? p 1)
186	     (raise-type-error 'current-make-compile-input-strings "procedure of arity 1" p))
187	   p)))
188
189      (define unix-compile-output-strings (lambda (s) (list "-o" (path-string->string s))))
190      (define msvc-compile-output-strings (lambda (s) (list (string-append "/Fo" (path-string->string s)))))
191
192      (define current-make-compile-output-strings
193	(make-parameter
194	 (case (system-type)
195	   [(unix macosx) unix-compile-output-strings]
196	   [(windows) (if (or win-gcc? win-borland?)
197			  unix-compile-output-strings
198			  msvc-compile-output-strings)]
199	   [(macos) unix-compile-output-strings])
200	 (lambda (p)
201	   (unless (procedure-arity-includes? p 1)
202	     (raise-type-error 'current-make-compile-output-strings "procedure of arity 1" p))
203	   p)))
204
205      (define (get-standard-compilers)
206	(case (system-type)
207	  [(unix macosx) '(gcc cc)]
208	  [(windows) '(gcc msvc borland)]
209	  [(macos) '(cw)]))
210
211      (define (use-standard-compiler name)
212	(define (bad-name name)
213	  (error 'use-standard-compiler "unknown compiler: ~a" name))
214	(case (system-type)
215	  [(unix macosx)
216	   (case name
217	     [(cc gcc) (let* ([n (if (eq? name 'gcc) "gcc" "cc")]
218			      [f (find-executable-path n n)])
219			 (unless f
220			   (error 'use-standard-compiler "cannot find ~a" n))
221			 (current-extension-compiler f))
222	      (current-extension-compiler-flags (add-variant-flags
223						 (if (eq? name 'gcc)
224						     gcc-compile-flags
225						     unix-compile-flags)))
226	      (current-make-compile-include-strings unix-compile-include-strings)
227	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
228	      (current-make-compile-output-strings unix-compile-output-strings)]
229	     [else (bad-name name)])]
230	  [(windows)
231	   (case name
232	     [(gcc) (let ([f (find-executable-path "gcc.exe" #f)])
233		      (unless f
234			(error 'use-standard-compiler "cannot find gcc.exe"))
235		      (current-extension-compiler f))
236	      (current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
237	      (current-make-compile-include-strings unix-compile-include-strings)
238	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
239	      (current-make-compile-output-strings unix-compile-output-strings)]
240	     [(borland) (let ([f (find-executable-path "bcc32.exe" #f)])
241			  (unless f
242			    (error 'use-standard-compiler "cannot find bcc32.exe"))
243			  (current-extension-compiler f))
244	      (current-extension-compiler-flags (add-variant-flags gcc-compile-flags))
245	      (current-make-compile-include-strings unix-compile-include-strings)
246	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
247	      (current-make-compile-output-strings unix-compile-output-strings)]
248	     [(msvc) (let ([f (find-executable-path "cl.exe" #f)])
249		       (unless f
250			 (error 'use-standard-compiler "cannot find MSVC's cl.exe"))
251		       (current-extension-compiler f))
252	      (current-extension-compiler-flags (add-variant-flags msvc-compile-flags))
253	      (current-make-compile-include-strings msvc-compile-include-strings)
254	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
255	      (current-make-compile-output-strings msvc-compile-output-strings)]
256	     [else (bad-name name)])]
257	  [(macos)
258	   (case name
259	     [(cw) (current-extension-compiler #f)
260	      (current-extension-compiler-flags (add-variant-flags unix-compile-flags))
261	      (current-make-compile-include-strings unix-compile-include-strings)
262	      (current-make-compile-input-strings (lambda (s) (list (path-string->string s))))
263	      (current-make-compile-output-strings unix-compile-output-strings)]
264	     [else (bad-name name)])]))
265
266      (define-values (my-process* stdio-compile)
267	(let-values ([(p* do-stdio) (get-stdio)])
268	  (values
269	   p*
270	   (lambda (start-process quiet?)
271	     (do-stdio start-process quiet? (lambda (s) (error 'compile-extension "~a" s)))))))
272
273      (define (make-compile-extension current-extension-compiler-flags)
274	(lambda (quiet? in out includes)
275	  (let ([c (current-extension-compiler)])
276	    (if c
277		(stdio-compile (lambda (quiet?)
278				 (let ([command (append
279						 (list c)
280						 (expand-for-compile-variant
281						  (current-extension-compiler-flags))
282						 (apply append
283							(map
284							 (lambda (s)
285							   ((current-make-compile-include-strings) s))
286							 includes))
287						 ((current-make-compile-include-strings) (include-dir))
288						 ((current-make-compile-input-strings) in)
289						 ((current-make-compile-output-strings) out))])
290				   (unless quiet?
291				     (printf "compile-extension: ~a\n" command))
292				   (apply my-process* command)))
293			       quiet?)
294		(error 'compile-extension "can't find an installed C compiler")))))
295
296      (define compile-extension (make-compile-extension
297				 current-extension-compiler-flags))
298      (define preprocess-extension (make-compile-extension
299				    current-extension-compiler-flags))))
300
301