chicken-setup.scm

Scheme跨平台编译器

;;;; chicken-setup
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
  (run-time-macros)
  (uses srfi-1 regex utils files posix ports tcp match srfi-18 srfi-13)
  (export move-file run:execute make/proc uninstall-extension
	  install-extension install-program install-script setup-verbose-flag
	  setup-install-flag installation-prefix chicken-prefix find-library
	  find-header program-path remove-file* patch yes-or-no?
	  setup-build-directory setup-root-directory create-directory
	  test-compile try-compile copy-file run-verbose
	  required-chicken-version required-extension-version cross-chicken
	  ##sys#current-source-filename host-extension) )


;;; Constants, variables and parameters

#>
#ifndef C_INSTALL_BIN_HOME
# define C_INSTALL_BIN_HOME   NULL
#endif

#ifndef C_INSTALL_CC
# ifdef _MSC_VER
#  define C_INSTALL_CC                "cl"
# else
#  ifdef __GNUC__
#   define C_INSTALL_CC                "gcc"
#  else
#   define C_INSTALL_CC                "cc"
#  endif
# endif
#endif

#ifndef C_TARGET_CC
# define C_TARGET_CC  C_INSTALL_CC
#endif

#ifndef C_TARGET_CXX
# define C_TARGET_CXX  C_INSTALL_CXX
#endif

#ifndef C_TARGET_CFLAGS
# define C_TARGET_CFLAGS  C_INSTALL_CFLAGS
#endif

#ifndef C_TARGET_MORE_LIBS
# define C_TARGET_MORE_LIBS  C_INSTALL_LIB_HOME
#endif

#ifndef C_TARGET_LIB_HOME
# define C_TARGET_LIB_HOME  C_INSTALL_LIB_HOME
#endif

#ifndef C_CHICKEN_PROGRAM
# define C_CHICKEN_PROGRAM   "chicken"
#endif

#ifndef C_CSC_PROGRAM
# define C_CSC_PROGRAM   "csc"
#endif

#ifndef C_CSI_PROGRAM
# define C_CSI_PROGRAM   "csi"
#endif

#ifndef C_CHICKEN_PROFILE_PROGRAM
# define C_CHICKEN_PROFILE_PROGRAM   "chicken-profile"
#endif

#ifndef C_CHICKEN_SETUP_PROGRAM
# define C_CHICKEN_SETUP_PROGRAM   "chicken-setup"
#endif

#ifndef C_CHICKEN_BUG_PROGRAM
# define C_CHICKEN_BUG_PROGRAM   "chicken-bug"
#endif
<#


(define-constant setup-file-extension "setup-info")
(define-constant remote-repository-name "repository")

(include "chicken-more-macros.scm")


(define-constant long-options
'("-help" "-uninstall" "-list" "-run" "-repository" "-program-path"
  "-version" "-script" "-fetch" "-host" "-proxy" "-keep" "-verbose"
  "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval"
  "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" 
  "-svn" "-svn-trunk" "-local" "-revision" "-host-extension" 
  "-build-prefix" "-download-path" "-install-prefix") )


(define-constant short-options
  '(#\h #\u #\l #\r #\R #\P #\V #\s #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t 
	#f #f #f #f #f #f #f #f) )

(define *installed-executables* 
  `(("chicken" . ,(foreign-value "C_CHICKEN_PROGRAM" c-string))
    ("csc" . ,(foreign-value "C_CSC_PROGRAM" c-string))
    ("csi" . ,(foreign-value "C_CSI_PROGRAM" c-string))
    ("chicken-profile" . ,(foreign-value "C_CHICKEN_PROFILE_PROGRAM" c-string))
    ("chicken-setup" . ,(foreign-value "C_CHICKEN_SETUP_PROGRAM" c-string))
    ("chicken-bug" . ,(foreign-value "C_CHICKEN_BUG_PROGRAM" c-string))))


(define *cc* (foreign-value "C_TARGET_CC" c-string))
(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))

(define *major-version* (##sys#fudge 41))
(define *default-eggdir* (conc "eggs/" *major-version*))

(define *windows*
  (and (eq? (software-type) 'windows) 
       (build-platform) ) )

(define *windows-shell* (or (eq? *windows* 'mingw32)
                            (eq? *windows* 'msvc)))
(define *debug* #f)

(register-feature! 'chicken-setup)

(define chicken-bin-path
  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
	(make-pathname p "bin") )
      (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )

(define chicken-prefix
  (or (getenv "CHICKEN_PREFIX")
      (match (string-match "(.*)/bin/?" chicken-bin-path)
	     ((_ p) p)
	     (_ "/usr/local") ) ) ) 

(define example-path 
  (make-parameter
   (or (and-let* ((p chicken-prefix))
	 (make-pathname p "/share/chicken/examples") )
       "/usr/local/share/chicken/examples")))

(define program-path (make-parameter chicken-bin-path))

(define setup-build-prefix
  (make-parameter
   (or (getenv "CHICKEN_TMPDIR") (getenv "TMPDIR")
       (getenv "TMP") (getenv "TEMP")
       ((lambda (user) 
	  (and user  (file-write-access? "/tmp") 
	       (conc "/tmp/chicken-setup-" *major-version* "-" user))) 
	(getenv "USER"))
       ((lambda (home user) 
	  (and home user  (conc home "/tmp/chicken-setup-" *major-version* "-" user))) 
	(getenv "HOME") (getenv "USER"))
       (current-directory))))

(define setup-download-directory  (make-parameter (make-pathname (setup-build-prefix) "downloads")))
(define setup-root-directory      (make-parameter #f))
(define setup-build-directory     (make-parameter #f))
(define setup-verbose-flag        (make-parameter #f))
(define setup-install-flag        (make-parameter #t))

(define (cross-chicken) (##sys#fudge 39))
(define host-extension (make-parameter #f))

(define *copy-command* (if *windows-shell* 'copy "cp -r"))
(define *remove-command* (if *windows-shell* "del /Q /S" "rm -fr"))
(define *move-command* (if *windows-shell* 'move 'mv))
(define *gzip-program* 'gzip)
(define *tar-program* 'tar)

(define *fetch-only* #f)
(define *builddir-created* #f)
(define *keep-stuff* #f)
(define *csc-options* '())
(define *abort-hook* #f)
(define *dont-ask* #f)
(define *rebuild-doc-index* #f)
(define *repository-tree* #f)
(define *last-decent-host* #f)
(define *proxy-host* #f)
(define *proxy-port* #f)
(define *base-directory* (current-directory))
(define *fetch-tree-only* #f)
(define *svn-repository* #f)
(define *svn-trunk* #f)
(define *local-repository* #f)
(define *repository-hosts* (list (list "www.call-with-current-continuation.org" *default-eggdir* 80)))
(define *revision* #f)
(define *run-tests* #f)
(define *fetched-eggs* '())


; Convert a string with a version (such as "1.22.0") to a list of the
; numbers (such as (1 22 0)). If one of the version components cannot
; be converted to a number, then it is kept as a string.

(define (version-string->numbers string)
  (map (lambda (x) (or (string->number x) (->string x))) 
       (string-split string ".")))

(define (numbers->version-string numbers)
  (string-intersperse (map ->string numbers) "."))

; Given two lists with numbers corresponding to a software version (as returned
; by version-string->numbers), check if the first is greater than the second.

(define (version-numbers> a b)
  (match (list a b)
	 ((() _)   #f)
	 ((_  ())  #t)
	 (((a1 . an) (b1 . bn))
	  (cond ((and (number? a1) (number? b1))
		 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
		((and (string? a1) (string? b1))  
		 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
		(else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn)))))
	 (else (error 'version-numbers> "invalid revisions: " a b))))

;;; File-system routines

(define create-directory
  (let ()
    (define (verb dir)
      (when (setup-verbose-flag) (printf "  creating directory `~a'~%~!" dir)) )
    (if *windows-shell*
	(lambda (dir)
	  (verb dir)
          (system* "mkdir ~a" (quotewrap dir)))
	(lambda (dir)
	  (verb dir)
	  (system* "mkdir -p ~a" (quotewrap dir) ) ) ) ) )



;;; Helper stuff

(define (quotewrapped? str)
  (and (string? str) (string-prefix? "\"" str) (string-suffix? "\"" str) ))

(define (quotewrap str)
  (cond ((quotewrapped? str) str)
	((or (string-any char-whitespace? str)
	     (and *windows-shell* (string-any (lambda (c) (char=? c #\/)) str)))
	 (string-append "\"" str "\""))
	(else str)))

(define (abort-setup)
  (*abort-hook* #f) )

(define (yes-or-no? str . default)
  (let ((def (:optional default #f)))
    (let loop ()
      (printf "~%~A (yes/no/abort) " str)
      (when def (printf "[~A] " def))
      (flush-output)
      (let ((ln (read-line)))
	(cond ((eof-object? ln) (set! ln "abort"))
	      ((and def (string=? "" ln)) (set! ln def)) )
	(cond ((string-ci=? "yes" ln) #t)
	      ((string-ci=? "no" ln) #f)
	      ((string-ci=? "abort" ln) (abort-setup))
	      (else
	       (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
	       (loop) ) ) ) ) ) )

(define (patch which rx subst)
  (when (setup-verbose-flag) (printf "patching ~A ...~%" which))
  (match which
    ((from to) 
     (with-output-to-file to
       (lambda ()
	 (with-input-from-file from
	   (lambda ()
	     (let loop ()
	       (let ((ln (read-line)))
		 (unless (eof-object? ln)
		   (write-line (string-substitute rx subst ln #t)) 
		   (loop) ) ) ) ) ) ) ) )
    (both
     (let ((tmp (create-temporary-file)))
       (patch (list both tmp) rx subst)
       (system* "~A ~A ~A" *move-command* (quotewrap tmp) (quotewrap both) ) ) ) ) )

(define run-verbose (make-parameter #t))

(define (fixpath prg)
  (cond ((string=? prg "csc")
	 (string-intersperse 
	  (cons* (quotewrap 
		  (make-pathname 
		   chicken-bin-path
		   (cdr (assoc prg *installed-executables*))))
		 "-feature" "compiling-extension"
		 *csc-options*) 
	  " ") )
	((assoc prg *installed-executables*) =>
	 (lambda (a) (quotewrap (make-pathname chicken-bin-path (cdr a)))))
	(else prg) ) )

(define (fixmaketarget file)
  (if (and (equal? "so" (pathname-extension file))
	   (not (string=? "so" ##sys#load-dynamic-extension)) )
      (pathname-replace-extension file ##sys#load-dynamic-extension)
      file) )

(define (run:execute explist)
  (define (smooth lst)
    (let ((slst (map ->string lst)))
      (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
  (for-each
   (lambda (cmd)
     (when (run-verbose) (printf "  ~A~%~!" cmd))
     (system* "~a" cmd) )
   (map smooth explist) ) )

(define-macro (run . explist)
  `(run:execute (list ,@(map (lambda (x) (list 'quasiquote x)) explist))) )

(define-macro (compile . explist)
  `(run (csc ,@explist) ) )


;;; "make" functionality

(define (make:find-matching-line str spec)
  (let ((match? (lambda (s) (string=? s str))))
    (let loop ((lines spec))
      (cond
       ((null? lines) #f)
       (else (let* ((line (car lines))
		    (names (if (string? (car line))
			       (list (car line))
			       (car line))))
	       (if (any match? names)
		   line
		   (loop (cdr lines)))))))))

(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))

(define (make:check-spec spec)
  (and (or (list? spec) (make:form-error "specification is not a list" spec))
       (or (pair? spec) (make:form-error "specification is an empty list" spec))
       (every
	(lambda (line)
	  (and (or (and (list? line) (<= 2 (length line) 3))
		   (make:form-error "list is not a list with 2 or 3 parts" line))
	       (or (or (string? (car line))
		       (and (list? (car line))
			    (every string? (car line))))
		   (make:form-error "line does not start with a string or list of strings" line))
	       (let ((name (car line)))
		 (or (list? (cadr line))