| blob | ae2e0bc687cfc7de58bb0eaf4d50563c6364cae6 |
1 ;;;============================================================================
3 ;;; File: "main.scm", Time-stamp: <2009-08-03 13:04:49 feeley>
5 ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
7 ;;;----------------------------------------------------------------------------
9 (##define-macro (macro-initialization-file)
10 ".gambcini")
12 (define-prim (##main-gsi/gsc)
14 (define (in-homedir filename)
15 (let ((homedir (##path-expand "~")))
16 (##string-append homedir filename)))
18 (define (process-initialization-file)
20 (define (try filename)
21 (##string?
22 (##load filename
23 (lambda (script-line script-path) #f)
24 #f
25 #f
26 #f)))
28 (or (try (macro-initialization-file))
29 (try (in-homedir (macro-initialization-file)))))
31 (define (read-source-from-string str name)
32 (let ((port
33 (##open-input-string str)))
34 (if name
35 (macro-port-name-set!
36 port
37 (lambda (port) name)))
38 (let* ((rt
39 (macro-character-port-input-readtable port))
40 (x
41 (##read-all-as-a-begin-expr-from-port
42 port
43 rt
44 ##wrap-datum
45 ##unwrap-datum
46 (macro-readtable-start-syntax rt)
47 #f)))
48 (##vector-ref x 1))))
50 (define (interpreter-interactive-or-batch-mode arguments)
51 (let loop ((lst arguments)
52 (batch-mode? #f))
53 (if (##pair? lst)
54 (let ((file
55 (##car lst))
56 (rest
57 (##cdr lst)))
58 (if (option? file)
59 (let ((option-name (convert-option file)))
60 (cond ((##string=? option-name "")
61 (##repl-debug #f #t)
62 (loop rest
63 #t))
64 ((##string=? option-name "e")
65 (if (##pair? rest)
66 (let ((src (read-source-from-string
67 (##car rest)
68 #f)))
69 (##eval-top src ##interaction-cte)
70 (loop (##cdr rest)
71 #t))
72 (begin
73 (warn-missing-argument-for-option "e")
74 (loop rest
75 #t))))
76 (else
77 (warn-unknown-option option-name)
78 (loop rest
79 batch-mode?))))
80 (let* ((starter
81 #f)
82 (script-callback
83 (lambda (script-line script-path)
84 (if script-line
85 (let ((language-and-tail
86 (##extract-language-and-tail
87 script-line)))
88 (set! starter
89 (if language-and-tail
90 (let ((language (##car language-and-tail)))
91 (##readtable-setup-for-language!
92 (##current-readtable)
93 language)
94 (##start-main language))
95 ##exit))
96 (set! ##processed-command-line
97 (##cons script-path rest)))))))
99 (##load file
100 script-callback
101 #t
102 #t
103 #f)
105 (if starter
106 (starter)
107 (loop rest
108 #t)))))
109 (if (##not batch-mode?)
110 (##repl-debug-main)
111 (##exit)))))
113 (define (compiler-batch-mode options arguments)
115 (define (c-file? file)
116 (##string=? (##path-extension file) ".c"))
118 (define (obj-file? file)
119 (##string=? (##path-extension file) ##os-obj-extension-string-saved))
121 (let* ((opts (##map ##car options))
122 (sym-opts (##map ##string->symbol opts))
123 (c-opt? (##memq 'c sym-opts))
124 (link-opt? (##memq 'link sym-opts))
125 (exe-opt? (##memq 'exe sym-opts))
126 (obj-opt? (##memq 'obj sym-opts))
127 (dynamic-opt? (##memq 'dynamic sym-opts)))
128 (if (##fixnum.< 1 (##fixnum.+
129 (if c-opt? 1 0)
130 (if link-opt? 1 0)
131 (if exe-opt? 1 0)
132 (if obj-opt? 1 0)
133 (if dynamic-opt? 1 0)))
134 (warn-mutually-exclusive-options)
135 (let ((type
136 (cond (c-opt? 'c)
137 (link-opt? 'link)
138 (exe-opt? 'exe)
139 (obj-opt? 'obj)
140 (else 'dyn)))) ;; dynamic is default
141 (let loop1 ((lst arguments)
142 (nb-output-files 0))
143 (if (##pair? lst)
145 (let ((file (##car lst))
146 (rest (##cdr lst)))
147 (cond ((option? file)
148 (let ((option-name (convert-option file)))
149 (cond ((##string=? option-name "")
150 (loop1 rest
151 nb-output-files))
152 ((##string=? option-name "e")
153 (loop1 (if (##pair? rest)
154 (##cdr rest)
155 rest)
156 nb-output-files))
157 (else
158 (warn-unknown-option option-name)
159 (loop1 rest
160 nb-output-files)))))
161 ((c-file? file)
162 (loop1 rest
163 (if (and (##eq? type 'obj)
164 (c#targ-generated-c-file? file))
165 (##fixnum.+ nb-output-files 1)
166 nb-output-files)))
167 ((obj-file? file)
168 (loop1 rest
169 nb-output-files))
170 (else
171 (loop1 rest
172 (##fixnum.+ nb-output-files 1)))))
174 (let* ((output
175 (let ((x (##assoc "o" options)))
176 (cond ((##not x)
177 #f)
178 ((and (##not (##memq type '(link exe)))
179 (##fixnum.< 1 nb-output-files)
180 (let ((outdir (##path-normalize (##cdr x))))
181 (##equal?
182 outdir
183 (##path-strip-trailing-directory-separator
184 outdir))))
185 (warn-multiple-output-files-and-o-option)
186 #f)
187 (else
188 (##cdr x)))))
189 (pre
190 (##assoc "prelude" options))
191 (post
192 (##assoc "postlude" options))
193 (cc-options
194 (let ((x (##assoc "cc-options" options)))
195 (if x
196 (##cdr x)
197 "")))
198 (ld-options-prelude
199 (let ((x (##assoc "ld-options-prelude" options)))
200 (if x
201 (##cdr x)
202 "")))
203 (ld-options
204 (let ((x (##assoc "ld-options" options)))
205 (if x
206 (##cdr x)
207 ""))))
209 (if (or pre post)
210 (set! c#wrap-program
211 (lambda (program)
212 (let ((path
213 (##container->path
214 (##locat-container
215 (##source-locat program)))))
216 (##sourcify
217 (##cons (##sourcify 'begin program)
218 (##append
219 (if pre
220 (let ((pre-src
221 (read-source-from-string
222 (##cdr pre)
223 (and path
224 (##string-append
225 path
226 ".prelude")))))
227 (##list pre-src))
228 '())
229 (##cons program
230 (if post
231 (let ((post-src
232 (read-source-from-string
233 (##cdr post)
234 (and path
235 (##string-append
236 path
237 ".postlude")))))
238 (##list post-src))
239 '()))))
240 program)))))
242 (let ((rev-gen-c-files '())
243 (rev-obj-files '())
244 (rev-tmp-files '()))
246 (define (add-gen-c-file gen-c-file)
247 (set! rev-gen-c-files
248 (##cons gen-c-file
249 rev-gen-c-files)))
251 (define (add-obj-file obj-file)
252 (set! rev-obj-files
253 (##cons obj-file
254 rev-obj-files)))
256 (define (add-tmp-file tmp-file)
257 (set! rev-tmp-files
258 (##cons tmp-file
259 rev-tmp-files)))
261 (define (cleanup)
262 (##for-each
263 ##delete-file
264 (##reverse rev-tmp-files)))
266 (define (exit-abnormally)
267 (cleanup)
268 (##exit-abnormally))
270 (define (handling file)
271 (if (##fixnum.< 1 nb-output-files)
272 (##repl
273 (lambda (first output-port)
274 (##write-string file output-port)
275 (##write-string ":\n" output-port)
276 #t))))
278 (define (do-compile-file file sym-opts output)
279 (handling file)
280 (or (if output
281 (compile-file
282 file
283 options: sym-opts
284 output: output
285 cc-options: cc-options
286 ld-options-prelude: ld-options-prelude
287 ld-options: ld-options)
288 (compile-file
289 file
290 options: sym-opts
291 cc-options: cc-options
292 ld-options-prelude: ld-options-prelude
293 ld-options: ld-options))
294 (exit-abnormally)))
296 (define (do-compile-file-to-c file sym-opts output)
297 (handling file)
298 (or (if output
299 (compile-file-to-c
300 file
301 options: sym-opts
302 output: output)
303 (compile-file-to-c
304 file
305 options: sym-opts))
306 (exit-abnormally)))
308 (define (do-build-executable obj-files output-filename)
309 (or (##build-executable
310 obj-files
311 options
312 output-filename
313 cc-options
314 ld-options-prelude
315 ld-options)
316 (exit-abnormally)))
318 (let loop2 ((lst arguments))
319 (if (##pair? lst)
321 (let ((file (##car lst))
322 (rest (##cdr lst)))
323 (if (option? file)
324 (let ((option-name (convert-option file)))
325 (cond ((##string=? option-name "")
326 (##repl-debug #f #t)
327 (loop2 rest))
328 ((##string=? option-name "e")
329 (if (##pair? rest)
330 (let ((src (read-source-from-string
331 (##car rest)
332 #f)))
333 (##eval-top src ##interaction-cte)
334 (loop2 (##cdr rest)))
335 (loop2 rest)))
336 (else
337 (loop2 rest))))
338 (let ((root (##path-strip-extension file)))
339 (cond ((c-file? file)
340 (if (##memq type '(exe obj))
341 (let ((obj-file
342 (do-compile-file
343 file
344 (##cons 'obj sym-opts)
345 (and output
346 (##eq? type 'obj)))))
347 (add-obj-file obj-file)
348 (if (##eq? type 'exe)
349 (add-tmp-file obj-file))))
350 (if (and (##memq type '(link exe))
351 (c#targ-generated-c-file? file))
352 (add-gen-c-file file))
353 (loop2 rest))
354 ((obj-file? file)
355 (add-obj-file file)
356 (loop2 rest))
357 (else
358 (case type
359 ((dyn)
360 (let ((dyn-obj-file
361 (do-compile-file
362 file
363 sym-opts
364 output)))
365 #f))
366 ((obj)
367 (let ((obj-file
368 (do-compile-file
369 file
370 (##cons 'obj sym-opts)
371 output)))
372 (add-obj-file obj-file)))
373 ((link exe c)
374 (let ((gen-c-file
375 (do-compile-file-to-c
376 file
377 sym-opts
378 (and output
379 (##eq? type 'c)))))
380 (add-gen-c-file gen-c-file)
381 (if (##eq? type 'exe)
382 (let ((obj-file
383 (do-compile-file
384 gen-c-file
385 (##cons 'obj sym-opts)
386 #f)))
387 (add-obj-file obj-file)
388 (add-tmp-file obj-file)
389 (add-tmp-file gen-c-file))))))
390 (loop2 rest))))))
392 (let* ((flat?
393 (##memq 'flat sym-opts))
394 (base
395 (let ((x (##assoc "l" options)))
396 (cond ((##not x)
397 #f)
398 ((or (##not (##eq? type 'link))
399 flat?)
400 (warn-no-incremental-link)
401 #f)
402 (else
403 (##cdr x))))))
405 (if (##memq type '(link exe))
407 (if (##pair? rev-gen-c-files)
408 (let* ((roots
409 (##map ##path-strip-extension
410 (##reverse rev-gen-c-files)))
411 (link-file
412 (if flat?
413 (if (and output
414 (##eq? type 'link))
415 (link-flat roots
416 output: output)
417 (link-flat roots))
418 (if (and output
419 (##eq? type 'link))
420 (if base
421 (link-incremental
422 roots
423 output: output
424 base: base)
425 (link-incremental
426 roots
427 output: output))
428 (if base
429 (link-incremental
430 roots
431 base: base)
432 (link-incremental
433 roots))))))
434 (add-gen-c-file link-file)
435 (if (##eq? type 'exe)
436 (let ((obj-link-file
437 (do-compile-file
438 link-file
439 (##cons 'obj sym-opts)
440 #f)))
441 (add-obj-file obj-link-file)
442 (add-tmp-file obj-link-file)
443 (if (##not (##memq 'keep-c options))
444 (add-tmp-file link-file))
445 (let* ((obj-files
446 (##reverse rev-obj-files))
447 (executable-file
448 (do-build-executable
449 obj-files
450 (let ((expanded-output
451 (and output
452 (##path-normalize output))))
453 (if (and expanded-output
454 (##equal? expanded-output
455 (##path-strip-trailing-directory-separator
456 expanded-output)))
457 expanded-output
458 (##string-append
459 (##car (##reverse roots))
460 ##os-exe-extension-string-saved))))))
461 executable-file)))))
463 (if flat?
464 (warn-flat-and-not-link-or-exe)))
466 (cleanup)
467 (##exit))))))))))))
469 (define (warn-missing-argument-for-option opt)
470 (##repl
471 (lambda (first output-port)
472 (##write-string
473 "*** WARNING -- Missing argument for option \""
474 output-port)
475 (##write-string opt output-port)
476 (##write-string "\"\n" output-port)
477 #t)))
479 (define (warn-unknown-option opt)
480 (##repl
481 (lambda (first output-port)
482 (##write-string
483 "*** WARNING -- Unknown or improperly placed option: "
484 output-port)
485 (##write opt output-port)
486 (##newline output-port)
487 #t)))
489 (define (warn-multiple-output-files-and-o-option)
490 (##repl
491 (lambda (first output-port)
492 (##write-string
493 "*** WARNING -- Multiple output files: non-directory \"o\" option ignored\n"
494 output-port)
495 #t)))
497 (define (warn-no-incremental-link)
498 (##repl
499 (lambda (first output-port)
500 (##write-string
501 "*** WARNING -- No incremental link: \"l\" option ignored\n"
502 output-port)
503 #t)))
505 (define (warn-flat-and-not-link-or-exe)
506 (##repl
507 (lambda (first output-port)
508 (##write-string
509 "*** WARNING -- \"link\" or \"exe\" options were not specified: \"flat\" option ignored\n"
510 output-port)
511 #t)))
513 (define (warn-mutually-exclusive-options)
514 (##repl
515 (lambda (first output-port)
516 (##write-string
517 "*** WARNING -- The options \"c\", \"link\", \"dynamic\", \"exe\" and \"obj\" are mutually exclusive\n"
518 output-port)
519 #t)))
521 (define (option? arg)
522 (and (##fixnum.< 0 (##string-length arg))
523 (##char=? (##string-ref arg 0) #\-)))
525 (define (convert-option arg)
526 (##substring arg 1 (##string-length arg)))
528 (define (split-command-line
529 arguments
530 options-with-no-args
531 options-with-args
532 cont)
533 (let loop1 ((args arguments)
534 (rev-options '()))
535 (if (and (##pair? args)
536 (option? (##car args)))
538 (let ((opt (convert-option (##car args)))
539 (rest (##cdr args)))
540 (cond ((##member opt options-with-no-args)
541 (loop1 rest
542 (##cons (##cons opt #f) rev-options)))
543 ((##member opt options-with-args)
544 (if (##pair? rest)
545 (loop1 (##cdr rest)
546 (##cons (##cons opt (##car rest)) rev-options))
547 (begin
548 (warn-missing-argument-for-option opt)
549 (loop1 rest rev-options))))
550 (else
551 (cont (##reverse rev-options) args))))
553 (cont (##reverse rev-options) args))))
555 (##load-support-libraries)
557 (let ((language-and-tail
558 (##extract-language-and-tail (##car ##processed-command-line))))
560 (if language-and-tail
561 (let ((language (##car language-and-tail)))
562 (##readtable-setup-for-language! (##current-readtable) language)))
564 (split-command-line
565 (##cdr ##processed-command-line)
566 '("f" "i" "v")
567 '()
568 (lambda (main-options arguments)
569 (let ((skip-initialization-file?
570 (##assoc "f" main-options))
571 (force-interpreter?
572 (or language-and-tail
573 (##assoc "i" main-options)))
574 (version?
575 (##assoc "v" main-options)))
576 (if version?
577 (begin
578 (##write-string (##system-version-string) ##stdout-port)
579 (##write-string " " ##stdout-port)
580 (##write (##system-stamp) ##stdout-port)
581 (##write-string " " ##stdout-port)
582 (##write-string ##os-system-type-string-saved ##stdout-port)
583 (##write-string " " ##stdout-port)
584 (##write ##os-configure-command-string-saved ##stdout-port)
585 (##newline ##stdout-port)
586 (##exit))
587 (split-command-line
588 arguments
589 (if (interpreter-or force-interpreter?)
590 '()
591 '("c" "dynamic" "exe" "obj" "link" "flat"
592 "warnings" "verbose" "report" "expansion" "gvm"
593 "check" "force" "keep-c"
594 "debug" "debug-location" "debug-source" "debug-environments"
595 "track-scheme"))
596 (if (interpreter-or force-interpreter?)
597 '()
598 '("o" "l" "prelude" "postlude"
599 "cc-options" "ld-options-prelude" "ld-options"))
600 (lambda (known-options arguments)
602 (if (##not skip-initialization-file?)
603 (process-initialization-file))
605 (if (or (##null? arguments)
606 (interpreter-or force-interpreter?))
607 (interpreter-interactive-or-batch-mode arguments)
608 (compiler-batch-mode known-options arguments))))))))))
610 (##main-set! ##main-gsi/gsc)
612 (define-prim (main . args) ;; predefine main procedure so scripts don't have to
613 0)
615 (##namespace (""))
617 ;;;============================================================================