~ chicken-core (master) /chicken.scm

  1;;;; chicken.scm - The CHICKEN Scheme compiler (loader/main-module)
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer. 
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution. 
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission. 
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare
 29  (uses chicken-syntax chicken-ffi-syntax 
 30	srfi-4 extras data-structures
 31	lolevel ; unused, but loaded to make foldable bindings available
 32	support compiler optimizer lfa2 compiler-syntax scrutinizer
 33	batch-driver c-platform c-backend user-pass))
 34
 35(module chicken.compiler.chicken ()
 36
 37(import scheme
 38	chicken.base
 39	chicken.compiler.batch-driver
 40	chicken.compiler.c-platform
 41	chicken.compiler.support
 42	chicken.compiler.user-pass
 43	chicken.fixnum
 44	chicken.process-context
 45	chicken.string)
 46
 47(include "tweaks")
 48(include "mini-srfi-1.scm")
 49
 50;;; Prefix argument list with default options:
 51
 52(define compiler-arguments
 53  (let ((args (cdr (argv))))
 54    (if (null? args)
 55        '()
 56        (append (take args 1) ; Leave source filename argument first.
 57                (string-split (or (get-environment-variable "CHICKEN_OPTIONS") ""))
 58                (drop args 1)))))
 59
 60
 61;;; Process command-line options:
 62; 
 63; - remove runtime-options ("-:...")
 64; - filter out source-filename
 65; - convert options into symbols (without the initial hyphens)
 66
 67(define (process-command-line args)
 68  (let loop ((args args) (options '()) (filename #f))
 69    (if (null? args)
 70	(values filename (reverse options))
 71	(let* ((arg (car args))
 72	       (len (string-length arg))
 73	       (char0 (string-ref arg 0)) )
 74	  (if (and (char=? #\- char0) (> len 1))
 75	      (if (and (> len 1) (char=? #\: (string-ref arg 1)))
 76		  (loop (cdr args) options filename)
 77		  (loop (cdr args) (cons (string->symbol (substring arg 1 len)) options) filename) )
 78	      (if filename
 79		  (loop (cdr args) (cons arg options) filename)
 80		  (loop (cdr args) options arg) ) ) ) ) ) )
 81
 82
 83;;; Run compiler with command-line options:
 84
 85(receive (filename options) ((or (user-options-pass) process-command-line) compiler-arguments)
 86  ;; TODO: Perhaps option parsing should be moved to batch-driver?
 87  (let loop ((os options))
 88    (unless (null? os)
 89      (let ((o (car os))
 90	    (rest (cdr os)) )
 91	(cond ((eq? 'optimize-level o)
 92	       (let ((level (string->number (car rest))))
 93		 (case level
 94		   ((0) 
 95		    (set! options
 96		      (cons* 'no-compiler-syntax 'no-usual-integrations options)) )
 97		   ((1)
 98		    (set! options
 99		      (cons* 'optimize-leaf-routines
100                             'merge-reusable-closures
101			     options)) )
102		   ((2)
103		    (set! options 
104		      (cons* 'optimize-leaf-routines
105			     'inline
106                             'merge-reusable-closures
107                             'merge-shareable-closures
108			     'lfa2
109			     options)) ) 
110		   ((3)
111		    (set! options
112		      (cons* 'optimize-leaf-routines
113			     'inline
114			     'inline-global
115			     'local
116                             'merge-reusable-closures
117                             'merge-shareable-closures
118			     'lfa2
119			     'specialize
120			     options) ) )
121		   ((4)
122		    (set! options
123		      (cons* 'optimize-leaf-routines
124			     'inline 
125			     'inline-global
126			     'specialize
127                             'merge-reusable-closures
128                             'merge-shareable-closures
129			     'lfa2
130			     'local 
131                             'unsafe
132			     options) ) )
133		   (else
134		    (when (>= level 5)
135		      (set! options 
136			(cons* 'disable-interrupts 
137			       'no-trace
138			       'unsafe
139			       'block
140			       'specialize
141			       'optimize-leaf-routines 
142			       'no-lambda-info
143			       'inline
144			       'inline-global
145			       'lfa2
146                               'merge-reusable-closures
147                               'merge-shareable-closures
148			       options) ) ) ) )
149		 (loop (cdr rest)) ) )
150	      ((eq? 'debug-level o)
151	       (case (string->number (car rest))
152		 ((0) (set! options (cons* 'no-lambda-info 'no-trace options)))
153		 ((1) (set! options (cons 'no-trace options)))
154		 ((2)) ; default behaviour
155		 ((3) (set! options (cons 'debug-info options)))
156		 (else (quit-compiling "invalid debug level: ~a" (car rest))))
157	       (loop (cdr rest)))
158	      ((memq o valid-compiler-options) (loop rest))
159	      ((memq o valid-compiler-options-with-argument)
160	       (if (pair? rest)
161		   (loop (cdr rest))
162		   (quit-compiling "missing argument to `-~s' option" o) ) )
163	      (else
164	       (warning 
165		"invalid compiler option (ignored)" 
166		(if (string? o) o (conc "-" o)) )
167	       (loop rest) ) ) ) ) )
168  (apply compile-source-file filename compiler-arguments options)
169  (exit)))