csc.scm

Scheme跨平台编译器

		(set! verbose #t)
		(set! dry-run #t)]
	       [(-s -shared -dynamic)
		(shared-build #f) ]
	       [(-dll -library)
		(shared-build #t) ]
	       [(-compiler)
		(check s rest)
		(set! translator (car rest))
		(set! rest (cdr rest)) ]
	       [(-cc)
		(check s rest)
		(set! compiler (car rest))
		(set! rest (cdr rest)) ]
	       [(-cxx)
		(check s rest)
		(set! c++-compiler (car rest))
		(set! rest (cdr rest)) ]
	       [(-ld)
		(check s rest)
		(set! linker (car rest))
		(set! rest (cdr rest)) ]
	       [(|-I|)
		(check s rest)
		(set! rest (cons* "-include-path" (car rest) (cdr rest))) ]
	       [(|-C|)
		(check s rest)
		(set! compile-options (append compile-options (string-split (car rest))))
		(set! rest (cdr rest)) ]
	       [(-strip)
		(set! link-options (append link-options (list "-s")))]
	       [(|-L|)
		(check s rest)
		(set! link-options (append link-options (string-split (car rest))))
		(set! rest (cdr rest)) ]
	       [(-unsafe-libraries)
		(t-options arg)
		(set! library-files unsafe-library-files)
		(set! shared-library-files unsafe-shared-library-files) ]
	       [(-rpath)
		(check s rest)
		(when (eq? 'gnu (build-platform))
		  (set! link-options (append link-options (list (string-append "-Wl,-R" (car rest)))))
		  (set! rest (cdr rest)) ) ]
	       [(-host) #f]
	       [(-) 
		(set! target-filename (make-pathname #f "a" executable-extension))
		(set! scheme-files (append scheme-files '("-")))]
	       [else
		(when (memq s '(-unsafe -benchmark-mode))
		  (when (eq? s '-benchmark-mode)
		    (set! library-files unsafe-library-files)
		    (set! shared-library-files unsafe-shared-library-files) ) )
		(when (eq? s '-to-stdout) 
		  (set! to-stdout #t)
		  (set! translate-only #t) )
		(when (memq s '(-optimize-level -benchmark-mode))
		  (set! compilation-optimization-options best-compilation-optimization-options)
		  (set! linking-optimization-options best-linking-optimization-options) )
		(cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]
		      [(memq s simple-options) (t-options arg)]
		      [(memq s complex-options) 
		       (check s rest)
		       (let* ([n (car rest)]
			      [ns (string->number n)] )
			 (t-options arg n)
			 (set! rest (cdr rest)) ) ]
		      [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))
		       (t-options arg) ]
		      [(and (> (string-length arg) 1)
			    (char=? #\- (string-ref arg 0)) )
		       (cond [(char=? #\l (string-ref arg 1))
			      (set! link-options (append link-options (list arg))) ]
 			     [(char=? #\L (string-ref arg 1))
 			      (set! link-options (append link-options (list arg))) ]
 			     [(char=? #\I (string-ref arg 1))
 			      (set! compile-options (append compile-options (list arg))) ]
			     [(char=? #\D (string-ref arg 1))
			      (t-options "-feature" (substring arg 2)) ]
			     [(char=? #\F (string-ref arg 1))
			      (when osx
				(set! compile-options (append compile-options (list arg))) ) ]
			     [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))
			      (set! link-options (append link-options (list arg))) ]
			     [(> (string-length arg) 2)
 			      (let ([opts (cdr (string->list arg))])
 				(if (null? (lset-difference char=? opts short-options))
 				    (set! rest
 				      (append (map (lambda (o) (string-append "-" (string o))) opts) rest) )
 				    (quit "invalid option `~A'" arg) ) ) ]
			     [else (quit "invalid option `~A'" s)] ) ]
		      [(file-exists? arg)
		       (let-values ([(dirs name ext) (decompose-pathname arg)])
			 (cond [(not ext) (set! scheme-files (append scheme-files (list arg)))]
			       [(member ext '("h" "c"))
				(set! c-files (append c-files (list arg))) ]
			       [(member ext '("cpp" "C" "cc" "cxx" "hpp"))
				(when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))
				(set! cpp-mode #t)
				(set! c-files (append c-files (list arg))) ]
			       [(member ext '("m" "M" "mm"))
				(set! objc-mode #t)
				(set! c-files (append c-files (list arg))) ]
			       [(or (string=? ext object-extension)
				    (string=? ext library-extension) )
				(set! object-files (append object-files (list arg))) ]
			       [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]
		      [else
		       (let ([f2 (string-append arg ".scm")])
			 (if (file-exists? f2)
			     (set! rest (cons f2 rest))
			     (quit "file `~A' does not exist" arg) ) ) ] ) ] )
	     (loop rest) ) ] ) ) )


;;; Translate all Scheme files:

(define (run-translation)
  (for-each
   (lambda (f)
     (let ([cscf (pathname-replace-extension f "csc")])
       (when (and (file-exists? cscf)
		  (let ([x (with-input-from-file cscf read-line)])
		    (or (eof-object? x) (string=? "#%eof" x)) ) )
	 ($delete-file cscf) )
       (let ([fc (pathname-replace-extension
		  (if (= 1 (length scheme-files))
		      target-filename
		      f)
		  (cond (cpp-mode "cpp")
			(objc-mode "m")
			(else "c") ) ) ] )
	 (unless (zero?
		  ($system 
		   (string-intersperse 
		    (cons* translator (cleanup-filename f) 
			   (append 
			    (if to-stdout 
				'("-to-stdout")
				`("-output-file" ,(cleanup-filename fc)) )
			    (if (or static static-libs static-extensions)
				(map (lambda (e) (conc "-uses " e)) required-extensions)
				'() )
			    (map quote-option (append translate-options translation-optimization-options)) ) )
		    " ") ) )
	   (exit last-exit-code) )
	 (set! c-files (append (list fc) c-files))
	 (set! generated-c-files (append (list fc) generated-c-files))
	 (when (file-exists? cscf)
	   (with-input-from-file cscf
	     (lambda ()
	       (read-line)
	       (for-each
		(match-lambda
 		  [('post-process commands ...)
 		   (for-each $system commands) ]
 		  [('c-options opts ...)
 		   (set! compile-options (append compile-options opts)) ]
 		  [('link-options opts ...)
 		   (set! link-options (append link-options opts)) ]
		  [x (error "invalid entry in csc control file" x)] )
		(read-file) ) ) )
	   ($delete-file cscf) ) ) ) )
   scheme-files)
  (unless keep-files (for-each $delete-file generated-scheme-files)) )


;;; Compile all C files:

(define (run-compilation)
  (let ((ofiles '()))
    (for-each
     (lambda (f)
       (let ([fo (pathname-replace-extension f object-extension)])
	 (unless (zero?
		  ($system
		   (string-intersperse
		    (list (cond (cpp-mode c++-compiler)
				(else compiler) )
			  (cleanup-filename f)
			  (string-append compile-output-flag (cleanup-filename fo)) 
			  compile-only-flag
			  (compiler-options) ) ) ) )
	   (exit last-exit-code) )
	 (set! generated-object-files (cons fo generated-object-files))
	 (set! ofiles (cons fo ofiles))))
     c-files)
    (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first
    (unless keep-files (for-each $delete-file generated-c-files)) ) )

(define (compiler-options)
  (string-intersperse
   (map quote-option
	(append
	 (if (or static static-libs) '() nonstatic-compilation-options)
	 compilation-optimization-options
	 compile-options) ) ) )


;;; Link object files and libraries:

(define (run-linking)
  (let ((files (map cleanup-filename
		    (append object-files
			    (nth-value 0 (static-extension-info)) ) ) )
	(target (cleanup-filename target-filename)))
    (unless (zero?
	     ($system
	      (string-intersperse 
	       (cons* (cond (cpp-mode c++-linker)
			    (else linker) )
		      (append
		       files
		       (list (string-append link-output-flag target)
			     (linker-options)
			     (linker-libraries #f) ) ) ) ) ) )
      (exit last-exit-code) )
    (when (and osx (or (not cross-chicken) host-mode))
      (unless (zero? ($system 
		      (string-append
		       "install_name_tool -change libchicken.dylib "
		       (quotewrap 
			(make-pathname
			 (prefix "" "lib"
				 (if host-mode
				     INSTALL_LIB_HOME
				     TARGET_RUN_LIB_HOME))
			 "libchicken.dylib") )
		       " " 
		       target) ) )
	(exit last-exit-code) ) )
    (unless keep-files (for-each $delete-file generated-object-files)) ) )

(define (static-extension-info)
  (let ((rpath (repository-path)))
    (if (or static static-libs static-extensions)
	(let loop ((exts required-extensions) (libs '()) (opts '()))
	  (if (null? exts)
	      (values (reverse libs) (reverse opts))
	      (let ((info (extension-information (car exts))))
		(if info
		    (let ((a (assq 'static info)) 
			  (o (assq 'static-options info)) )
		      (loop (cdr exts) 
			(if a (cons (make-pathname rpath (cadr a)) libs) libs)
			(if o (cons (cadr o) opts) opts) ) ) 
		    (loop (cdr exts) libs opts)) ) ) )
	(values '() '()) ) ) )

(define (linker-options)
  (string-append
   (string-intersperse
    (append linking-optimization-options link-options
	    (nth-value 1 (static-extension-info)) ) )
   (if (and static (not mingw) (not msvc) (not osx)) " -static" "") ) )

(define (linker-libraries #!optional staticexts)
  (string-intersperse
   (append
    (if staticexts (nth-value 0 (static-extension-info)) '())
    (if (or static static-libs)
        (if gui gui-library-files library-files)
        (if gui gui-shared-library-files shared-library-files))
    (if (or static static-libs)
        (list extra-libraries)
        (list extra-shared-libraries)))))


;;; Helper procedures:

(define-constant +hairy-chars+ '(#\\ #\#))

(define (cleanup s)
  (let* ((q #f)
	 (s (list->string
	     (let fold ([s (string->list s)])
	       (if (null? s) 
		   '()
		   (let ([c (car s)])
		     (cond ((memq c +hairy-chars+) (cons* #\\ c (fold (cdr s))))
			   (else
			    (when (char-whitespace? c) (set! q #t))
			    (cons c (fold (cdr s))) ) ) ) ) ) ) ) )
    (if q 
	(string-append "\"" (string-translate* s '(("\"" . "\\\""))) "\"")
	s) ) )

(define (quote-option x)
  (if (any (lambda (c)
	     (or (char-whitespace? c) (memq c +hairy-chars+)) )
	   (string->list x) )
      (cleanup x)
      x) )

(define last-exit-code #f)

(define ($system str)
  (when verbose (print str))
  (set! last-exit-code
    (if dry-run 
	0
	(if (zero? (system str))
	    0
	    1)))
  (unless (zero? last-exit-code)
    (printf "*** Shell command terminated with exit status ~S: ~A~%" last-exit-code str) )
  last-exit-code)

(define ($delete-file str)
  (when verbose 
    (print "rm " str) )
  (unless dry-run (delete-file str) ))


;;; Run it:

(run (append (string-split (or (getenv "CSC_OPTIONS") "")) arguments))