~ chicken-core (chicken-5) /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			     options)) )
101		   ((2)
102		    (set! options 
103		      (cons* 'optimize-leaf-routines
104			     'inline
105			     ;XXX 'clustering
106			     'lfa2
107			     options)) ) 
108		   ((3)
109		    (set! options
110		      (cons* 'optimize-leaf-routines
111			     'inline
112			     'inline-global
113			     'local
114			     ;XXX 'clustering
115			     'lfa2
116			     'specialize
117			     options) ) )
118		   ((4)
119		    (set! options
120		      (cons* 'optimize-leaf-routines
121			     'inline 
122			     'inline-global
123			     'specialize
124			     ;XXX 'clustering
125			     'lfa2
126			     'local 'unsafe
127			     options) ) )
128		   (else
129		    (when (>= level 5)
130		      (set! options 
131			(cons* 'disable-interrupts 
132			       'no-trace
133			       'unsafe
134			       'block
135			       'specialize
136			       'optimize-leaf-routines 
137			       'no-lambda-info
138			       'inline
139			       'inline-global
140			       'clustering
141			       'lfa2
142			       options) ) ) ) )
143		 (loop (cdr rest)) ) )
144	      ((eq? 'debug-level o)
145	       (case (string->number (car rest))
146		 ((0) (set! options (cons* 'no-lambda-info 'no-trace options)))
147		 ((1) (set! options (cons 'no-trace options)))
148		 ((2)) ; default behaviour
149		 ((3) (set! options (cons 'debug-info options)))
150		 (else (quit-compiling "invalid debug level: ~a" (car rest))))
151	       (loop (cdr rest)))
152	      ((memq o valid-compiler-options) (loop rest))
153	      ((memq o valid-compiler-options-with-argument)
154	       (if (pair? rest)
155		   (loop (cdr rest))
156		   (quit-compiling "missing argument to `-~s' option" o) ) )
157	      (else
158	       (warning 
159		"invalid compiler option (ignored)" 
160		(if (string? o) o (conc "-" o)) )
161	       (loop rest) ) ) ) ) )
162  (apply compile-source-file filename compiler-arguments options)
163  (exit)))