#! /usr/bin/csi -script
;;;; chicken-setup - A management tool for extensions to the CHICKEN Scheme system -*- Scheme -*-
;
; Copyright (c) 2000-2004, Felix L. Winkelmann
; 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.
;
; Send bugs, suggestions and ideas to: 
;
; felix@call-with-current-continuation.org
;
; Felix L. Winkelmann
; Steinweg 1A
; 37130 Gleichen, OT Weissenborn
; Germany


(register-feature! 'chicken-setup)


;;; Parameters:

(define bindir "/usr/bin")
(define cc "i586-alt-linux-gcc")

(define verbose #t)

(define default-core-libraries
  '(syntax-case profiler extras format posix match-support regex lolevel tinyclos tcp
		script-utils srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-25 srfi-37) )

(randomize)


;;; Initialize registry:

(define (initialize-registry!)
  (let ([f (registry-pathname)])
    (when (or (not (file-exists? f))
	      (let loop ()
		(format #t "~%There already exists a registry at ~A.~%~
                        Are you sure you want to overwrite it ? (yes/no) " f)
		(let ([ln (read-line)])
		  (cond [(string=? "yes" ln)
			 (delete-registry)
			 #t]
			[(string=? "no" ln) #f]
			[else (loop)] ) ) ) )
      (with-output-to-file f write-registry-header) 
      (create-registry) ) ) )


;;; Add core library to registry:

(define (register-core-library! . names)
  (for-each def-core-extension names) )


;;; Set registry path:

(define registry-pathname
  (make-parameter
   (make-pathname (##sys#find-registry-path) "REGISTRY") ) )


;;; List extensions:

(define (list-extensions)
  (let ([exts (cddr (load-registry))])
    (print "\nInstalled extensions:\n")
    (for-each
     display-spec
     (sort 
      exts
      (match-lambda*
	[((n1 . _) (n2 . _))
	 (string<? (symbol->string n1) (symbol->string n2)) ] ) ) ) ) )


;;; Output and subprocess routines:

(define (dribble fstr . args)
  (when verbose
    (apply format #t fstr args)) )

(define (run msg fstr . args)
  (let ([cmd (apply format #f fstr args)])
    (when verbose (print msg))
    (system* cmd)) )


;;; Wrap extension according to setup-spec:

(define (wrap-extension spec)
  (let* ([spec (canonicalize-spec spec)]
	 [ext (->string (car spec))] )
    (run (format #f "wrapping extension `~A' ..." ext)
	 "tar --exclude CVS -zcvf ~A.egg ~A.setup ~{ ~A~}"
	 ext ext
	 (spec-toplevel-files spec)) ) )


;;; Extract files from extension:

(define (extract-extension ext)
  (let ([ename (pathname-file (->string ext))])
    (run (format #f "extracting files from extension `~A' ..." ename)
	 "tar -zxvf ~A.egg" ename) ) )


;;; Build shared objects from extracted extension:

(define (build-extension spec)
  (let* ([spec0 (canonicalize-spec spec)]
	 [ext (->string (car spec))] )
    (dribble "building extension `~A' ...~%" ext)
    (let ([opts #f]
	  [copts '()]
	  [lopts '()] 
	  [src #f] 
	  [defd (extension-provided? (car spec))]
	  [specfile (make-pathname (##sys#find-registry-path) (pathname-replace-extension ext "setup"))] )
      (when (null? (glob (string-append ext ".*")))
	(quit "no such file: ~S~%" ext) ) 
      (validate-spec spec0)
      (patch-registry-for-build specfile spec)
      (handle-exceptions ex
	  (begin 
	    (restore-registry-after-build specfile (not defd))
	    (signal ex) )
	(let walk ([spec spec0] [in '(".")])
	  (match spec
	    [(name (props ...) subs ...)
	     (let ([sname (symbol->string name)]
		   [mk #f] )
	       (let walk2 ([ps props]
			   [f (let ([f (make-pathname in sname "scm")])
				(and (file-exists? f) f) ) ] )
		 (match ps
		   [()
		    (when (and f (not src))
		      (build-object! 
		       mk f
		       (pathname-replace-extension f ##sys#load-dynamic-extension)
		       (or opts '("-O2 -d0"))
		       copts lopts) )
		    (fluid-let ([src #f])
		      (for-each (lambda (s) (walk s (append in (list sname)))) subs) ) ]
		   [(('test exps ...) . r)
		    (let loop ([exps exps])
		      (cond [(null? exps) (walk2 r f)]
			    [(eval (car exps)) (loop (cdr exps))]
			    [else (quit "building extension FAILED - test failed:~%~S~%" (car exps))] ) ) ]
		   [(('test-command cmds ...) . r)
		    (let loop ([cmds cmds])
		      (if (null? cmds)
			  (walk2 r f)
			  (let ([r (system (car cmds))])
			    (if (zero? r)
				(loop (cdr cmds))
				(quit "building extension FAILED - command returned with exit status ~S:~%~S~%"
				      r (car cmds) ) ) ) ) ) ]
		   [(('test-chicken-version v) . r)
		    (if (>= (string->number (chicken-version)) v)
			(walk2 r f)
			(quit "building extension FAILED - at least version ~A of Chicken is required~%" v) ) ]
		   [(('when exp) . r)
		    (if (eval exp)
			(walk2 r f)
			(walk2 '() #f) ) ]
		   [(('make cmd) . r)
		    (set! mk cmd)
		    (walk2 r f) ]
		   [(('file fname) . r)
		    (let ([fn (->string fname)])
		      (walk2 r (make-pathname in fn)) ) ]
		   [(('options opts2 ...) . r)
		    (fluid-let ([opts (append (or opts '()) opts2)])
		      (walk2 r f) ) ]
		   [(('c-options opts2 ...) . r)
		    (fluid-let ([copts (append copts opts2)])
		      (walk2 r f) ) ]
		   [(('link-options opts2 ...) . r)
		    (fluid-let ([lopts (append lopts opts2)])
		      (walk2 r f) ) ]
		   [(((or 'syntax 'source)) . r)
		    (fluid-let ([src #t])
		      (walk2 r f) ) ]
		   [(_ . r) (walk2 r f)] ) ) ) ] ) ) )
      (restore-registry-after-build specfile (not defd))) ) )

(define (build-object! cmd fname oname opts copts lopts)
  (let ([d1 (current-directory)]
	[d2 (pathname-directory fname)] )
    (cond [cmd
	   (change-directory d2)
	   (if (string? cmd)
	       (run (string-append "executing: " cmd) cmd)
	       (eval cmd) )
	   (change-directory d1) ]
	  [(or (not (file-exists? oname))
	       (> (file-modification-time fname) (file-modification-time oname)) )
	   (let ([cmd (format #f "~Acsc -s ~A -o ~A ~{~A ~}~{-C ~A ~}~{-L ~A ~}"
			      (let ([bd bindir])
				(if bd (string-append bd "/") "") )
			      fname oname opts copts lopts) ] )
	     (run (format #f "compiling: ~A" cmd)
		  cmd) ) ] ) ) )


;;; Install built extension:

(define (source-file-for-spec spec)
  (or (and-let* ([a (assq 'file (second spec))]) (second a))
      (make-pathname #f (symbol->string (first spec)) "scm") ) )

(define (target-file-for-spec spec)
  (let ((src (source-file-for-spec spec))
	(props (second spec)))
    (and src
	 (if (or (assq 'syntax props)
		 (assq 'source props))
	     src
	     (pathname-replace-extension src ##sys#load-dynamic-extension)))))

(define (install-extension! spec)
  (let* ([spec (canonicalize-spec spec)]
	 [ext (->string (car spec))]
	 [regpath (##sys#find-registry-path)]
	 [instf (extension-provided? (string->symbol ext))] )
    (dribble "installing extension `~A' ...~%" ext)
    (validate-spec spec)
    (let walk ([s spec] [in '()])
      (let ([name (->string (first s))]
	    [props (second s)]
	    [subs (cddr s)])
	(let* ([extfile (target-file-for-spec s)]
	       [extfilepath (make-pathname in extfile)]
	       [extdir (make-pathname (cons regpath in) name)])
	  (when (file-exists? extfilepath)
	    (run (format #f "installing extension `~A' ..." extfile)
		 "cp ~A ~A"
		 extfilepath
		 (make-pathname (cons regpath in) extfile)) )
	  (unless (or (null? subs)
		      (file-exists? extdir))
	    (format #t "creating directory `~A' ...~%" extdir)
	    (create-directory extdir) )
	  (for-each 
	   (lambda (s) (walk s (append in (list name))))
	   subs))))
    (dribble "updating registry ...~%")
    (if instf
	(let* ([fn (pathname-replace-extension ext "setup")]
	       [fp (make-pathname regpath fn)] )
	  (dribble "merging setup specifications ...~%")
	  (let ([spec2 (merge-specs spec (with-input-from-file fp read))])
	    ;;(dribble "writing merged specification `~A' ...~%" fp)
	    (set! registry-cache #f)
	    (with-output-to-file fp (lambda () (pretty-print (car spec2)))) ) )
	(write-extension-spec ext spec) ) ) )


;;; Uninstall registered extension:

(define (uninstall-extension! ext)
  (when (symbol? ext) (set! ext (list ext)))
  (lookup-spec-in-registry
   ext
   (load-registry)
   (##sys#find-registry-path)
   (lambda () 
     (quit "extension not registered: `~S'~%" ext))
   (lambda (spec parent in)
     (let ([extfile (target-file-for-spec spec)])
       (run (format #f "uninstalling extension `~A' ..." ext)
	    "rm -fr ~A ~A"
	    (make-pathname in extfile)
	    (make-pathname in (symbol->string (car spec))) )
       (delete! spec parent eq?) ) ) )
  (when (= 1 (length ext))
    (let ([fn (symbol->string (car ext))])
      (delete-file* (make-pathname (##sys#find-registry-path) fn "setup"))
      (remove-extension-spec fn) ) ) )


;;; Add library (core) modules:

(define (def-core-extension name)
  (dribble "defining core extension `~A' ...~%" name)
  (let* ([r (load-registry)]
	 [s (string->symbol name)]
	 [a (assq s (cddr r))] )
    (if a
	(set-car! (cdr a) '((library)))
	(let ([spec (list s '((library)))])
	  (set-cdr! (cdr r) (cons spec (cddr r)))
	  (write-core-extension-spec name spec) ) ) ) )
 

;;; Operations on setup-specifications:

(define (validate-spec spec)
  (let ([req '()]
	[prov '()] )
    (let walk ([s spec] [path '()])
      (match s
	[((? symbol? name) (props ...) subs ...)
	 (set! prov (cons (append path (list name)) prov))
	 (for-each
	  (match-lambda
	    [('file (? string-like?)) #t]
	    [((or 'options 'c-options 'link-options) (? string-like?) ...) #t]
	    [((or 'comment 'test-command) (? string?) ...) #t]
	    [('test _ ...) #t]
	    [((or 'license 'author 'make 'when 'test-chicken-version 'version) _) #t]
	    [((or 'syntax 'source)) #t]
	    [((or 'homepage 'contact-email 'location) (? string?)) #t]
	    [('provide (? ext-ref? es) ...)
	     (set! prov (append (map (lambda (e) (append path e)) es) prov)) ]
	    [((or 'require 'require-for-syntax) (? ext-ref? xs) ...)
	     (set! req
	       (lset-union equal?
			   req
			   (map (lambda (x) (if (symbol? x)
						(list x)
						x))
				xs))) ]
	    [('require-at-runtime (? ext-ref?) ...) #t]
	    [p (quit "invalid property `~S' in specification: ~S~%" p s)] )
	  props)
	 (let ([path2 (append path (list name))])
	   (for-each (lambda (s) (walk s path2)) subs) ) ]
	[_ (quit "bad node syntax in specification: ~S~%" s)] ) )
    (for-each
     (lambda (x)
       (unless (or (member x prov) (extension-provided? x))
	 (format #t "Warning: required extension `~A' is not available~%" x) ) )
     req) ) )

(define (merge-specs spec1 spec2)
  (define (merge-props props1 props2)
    (lset-union
     (lambda (p1 p2)
       (if (eq? (car p1) (car p2))
	   (or (and (= (length (cdr p1)) (length (cdr p2)))
		    (every equal? (cdr p1) (cdr p2)) )
	       (quit "properties `~S' and `~S' don't match~%" p1 p2) )
	   #f) )
     props1 props2) )
  (define (merge-subs subs1 subs2)
    (let loop ([ss1 subs1] [ss2 subs2])
      (cond [(null? ss1) ss2]
	    [(assq (caar ss1) ss2)
	     => (lambda (s2)
		  (append 
		   (merge-specs (car ss1) s2)
		   (loop (cdr ss1) (delete s2 ss2 eq?)) ) ) ]
	    [else (cons (car ss1) (loop (cdr ss1) ss2))] ) ))
  (match spec1
    [(name1) (merge-specs (list name1 '()) spec2)]
    [(name1 (props1 ...) subs1 ...)
     (match spec2
       [(name2) (merge-specs spec1 (list name2 '()))]
       [(name2 (props2 ...) subs2 ...)
	(if (eq? name1 name2)
	    (list (cons* name1 (merge-props props1 props2) (merge-subs subs1 subs2)))
	    (list spec1 spec2) ) ]
       [_ (list spec1 spec2)] ) ]
    [_ (list spec1 spec2)] ) )

(define (spec-toplevel-files spec)
  (let* ([props (second spec)]
	 [extname (->string (first spec))]
	 [subexts (cddr spec)])
    (remove not
	    (list
	     ; Maybe a file property, or extname.scm:
	     (let ((f (source-file-for-spec spec)))
	       (and (file-exists? f) f))
	     ; Maybe also a directory name:
	     (if (null? subexts)
		 #f
		 extname)))))
 
(define (canonicalize-spec spec)
  (let walk ([s spec])
    (match s
      [(name) (list name '())]
      [(name (props ...) subs ...)
       (cons*
	name props
	(map walk subs) ) ]
      [_ (quit "invalid setup specification: ~S~%" s)] ) ) )

(define (display-spec spec . prefix)
  (let ([author #f]
	[version #f] )
    (let loop ([spec spec] [prefix (:optional prefix '())])
      (when (null? (cdr spec)) (append! spec '(())))
      (match spec
	[(name (props ...) subs ...)
	 (let ([comment #f]
	       [source #f]
	       [req '()]
	       [reqs '()] )
	   (let loop2 ([props props])
	     (match props
	       [()
		(let ([sname (symbol->string name)]
		      [pname (append prefix (list name))] )
		  (format 
		   #t "~48A  ~10A  ~@[Author: ~16A  ~]~@[Version: ~8A~]~%~@[    ~A~%~]"
		   (if (null? (cdr pname)) (car pname) pname)
		   (if source "[syntax]" "")
		   author version 
		   comment)
		  (when (or (pair? req) (pair? reqs))
		    (let ([ur (remove extension-provided? (append req reqs))])
		      (when (pair? ur)
			(format #t " required but not installed:~%")
			(for-each 
			 (lambda (r) 
			   (format #t "   ~46A          ~@[ [!]~]~%" r (not (extension-provided? r))) )
			 ur) ) ) )
		  (for-each (lambda (s) (loop s pname)) subs) ) ]
	       [(('library . _) . _)
		(for-each (lambda (s) (loop s prefix)) subs) ]
	       [(('author a) . r) (fluid-let ([author a]) (loop2 r))]
	       [(('comment c ...) . r) 
		(set! comment (string-intersperse c "\n    "))
		(loop2 r) ]
	       [(('version v) . r) (fluid-let ([version v]) (loop2 r))]
	       [(((or 'syntax 'source)) . r) 
		(set! source #t)
		(loop2 r) ]
	       [(('require exts ...) . r)
		(set! req (append req exts))
		(loop2 r) ]
	       [(('require-for-syntax exts ...) . r)
		(set! reqs (append reqs exts)) 
		(loop2 r) ]
	       [(_ . r) (loop2 r)] ) ) ) ] ) ) ) )


;;; Helper routines:

(define quit-setup-condition
  (make-property-condition 'quit-setup) )

(define quit-setup-condition?
  (condition-predicate 'quit-setup) )

(define (quit fstr . args)
  (apply format #t fstr args)
  (signal quit-setup-condition) )

(define (string-like? x)
  (or (string? x) (symbol? x)) )

(define (ext-ref? x)
  (or (symbol? x) ((list-of ext-ref?) x)) )

(define (file-with-ext-exists? file ext)
  (let ([f (if (equal? ext (pathname-extension file))
	       file
	       (pathname-replace-extension file ext) ) ] )
    (file-exists? f) ) )

(define (single-file? fname)
  (and (not (file-with-ext-exists? fname "setup"))
       (not (file-with-ext-exists? fname "egg"))
       (file-with-ext-exists? fname "scm") ) )

#|
(define (single-binary? fname)
  (and (not (file-with-ext-exists? fname "setup"))
       (not (file-with-ext-exists? fname "scm"))
       (file-with-ext-exists? fname "so") ) )
|#


(define (test-compile code . opts)
  (let ([cflags (or (get-keyword 'cflags opts) "")]
	[ldflags (or (get-keyword 'ldflags opts) "")]
	[verbose (get-keyword 'verbose opts)]
	[ccc (or (get-keyword 'cc opts) cc)]
	[run (get-keyword 'run opts)]
	[compile-only (get-keyword 'compile-only opts)] )
    (let* ([fname (create-temporary-file "c")]
	   [xname (pathname-strip-extension fname)]
	   [oname (pathname-replace-extension fname "o")]
	   [r (handle-exceptions ex -1
		(with-output-to-file fname (cut display code))
		(and (zero?
		      system 
		      (let ([cmd (sprintf "~A ~A ~A ~A -o ~A ~A >/dev/null 2>&1"
					  ccc
					  (if compile-only "-c" "")
					  cflags
					  fname
					  xname
					  (if compile-only "" ldflags) ) ] )
			(when verbose (print cmd))
			cmd) )
		     (or (not run)
			 (begin
			   (when verbose (print xname))
			   (zero? (system xname)) ) ) ) ) ] )
      (system (sprintf "rm -f ~A ~A.*" fname fname))
      r) ) )


;;; Registry operations:

(define (write-registry-header)
  (format #t ";;;; REGISTRY - generated by chicken-setup ~A at ~A~%" 
	(chicken-version)
	(seconds->string (current-seconds)) ) )

(define registry-cache #f)
(define registry-specs '())

(define (extension-provided? x)
  (lookup-spec-in-registry
   x (load-registry) (##sys#find-registry-path)
   (lambda () #f)
   (lambda (_ _ _) #t) ) )

(define (load-registry)
  (or registry-cache
      (and (file-exists? (registry-pathname))
	   (begin
	     ;(dribble "loading registry ~A ...~%" (registry-pathname))
	     (with-input-from-file (registry-pathname)
	       (lambda ()
		 (set! registry-specs (read-file))
		 (set! registry-cache 
		   `(chicken () ,@(map (lambda (f)
					 (with-input-from-file f read) )
				       registry-specs) ) ) ) )
	     registry-cache) ) 
      (begin
	(create-registry)
	(load-registry) ) ) )

(define (create-registry)
  (let ([fp (registry-pathname)])
    (dribble "creating registry at ~A ...~%" fp)
    (with-output-to-file fp
      (lambda ()
	(for-each
	 (lambda (libname)
	   (let ([fpl (make-pathname (##sys#find-registry-path) (symbol->string libname))])
	     (format #t "~S~%" fpl)
	     (with-output-to-file fpl (lambda () (format #t "(~A ((library)))~%" libname))) ) )
	 default-core-libraries) ) ) ) )

(define (delete-registry)
  (let ([fp (registry-pathname)])
    (run (format #f "deleting registry at ~A ...~%" fp)
	 "rm -fr ~A" fp) ) )

(define (patch-registry-for-build specfile spec)
  ;(dribble "writing extension-specification ~A into registry directory (preliminary)...~%" specfile)
  (with-output-to-file specfile (lambda () (pretty-print spec)))
  (run "backing up registry..."
       "cp ~A ~A.backup" (registry-pathname) (registry-pathname) )
  (run (format #f "adding entry for `~A' ..." specfile)
       "echo '\"~A\"' >> ~A" specfile (registry-pathname)) )

(define (restore-registry-after-build specfile rm)
  (when rm 
    (run (format #f "removing temporary extension `~A' ..." specfile)
	 "rm -f ~A" specfile))
  (run "restoring registry"
       "mv ~A.backup ~A" (registry-pathname) (registry-pathname)) )

(define (write-extension-spec name spec)
  (let* ([fn (pathname-replace-extension name "setup")]
	 [fp (make-pathname (##sys#find-registry-path) fn)] )
    (dribble "writing extension-specification ~A into registry directory...~%" fp)
    (with-output-to-file fp (lambda () (pretty-print spec)))
    (run (format #f "adding final entry for `~A' to registry..." fp)
	 "echo '\"~A\"' >> ~A" fp (registry-pathname)) ) )

(define (remove-extension-spec name)
  (let* ([fn (pathname-replace-extension name "setup")]
	 [fp (make-pathname (##sys#find-registry-path) fn)] 
	 [bfile (pathname-replace-extension (registry-pathname) "backup")] )
    (run "backing up registry..."
	 "cp ~A ~A" (registry-pathname) bfile)
    (run (format #f "removing entry for `~A' ..." fp)
	 "grep -v \"~A\" ~A >~A" fp bfile (registry-pathname))
    (dribble "removing backup file...~%")
    (delete-file bfile) ) )

(define (lookup-spec-in-registry ext0 reg basedir err-handler found-handler)
  (let loop ((spec reg)
	     (parent #f)
	     (in '())
	     (ext (if (symbol? ext0)
		      (list ext0)
		      ext0)))
    (cond
     ((null? ext) (found-handler spec
				 parent
				 (cons basedir (reverse (cdr in)))))
     ((assq (car ext) (cddr spec)) =>
      (lambda (subspec)
	(loop subspec
	      spec
	      (cons (->string (car ext)) in)
	      (cdr ext))))
     (else
      (err-handler)))))

(define (write-core-extension-spec name spec)
  (dribble "writing core-extension specification for ~A ...~%" name)
  (let ([path (make-pathname (##sys#find-registry-path) name)])
    (when (file-exists? path)
      (format #t "Warning: core extension ~A is already defined - will be replaced~%" name) )
    (with-output-to-file path 
      (lambda () (format #t "~S~%" spec)) )
    (run (format #f "adding entry for core extension `~A' ..." path)
	 "echo '\"~A\"' >> ~A" path (registry-pathname)) ) )


;;; Check registry data and create if needed:

(define (initialize-setup-stuff)
  (let ([pn (registry-pathname)])
    (format #t "the registry pathname is ~A~%" pn)
    (if (file-exists? pn)
	(list-extensions)
	(let ([pnd (pathname-directory pn)])
	  (if (file-exists? pnd)
	      (if (file-write-access? pnd)
		  (create-registry) 
		  (format #t "~%You don't have write access to the registry directory.~%~
                      You must have write-permissions for `csi -setup' having any effect.~%") )
	      (format #t "~%The directory where the registry has to be created does not exist.~%~
                          Create it first.~%") ) ) ) ) )


;;; Main entry-point from csi:

(define (run-setup-script ext args)
  (command-line-arguments args)
  (let* ([fname (pathname-replace-extension ext "setup")]
	 [sf (single-file? fname)] )
    (when (and (not sf)
	       (not (file-exists? fname)) 
	       (file-exists? (pathname-replace-extension ext "egg")) )
      (extract-extension ext) )
    (handle-exceptions ex
	(if (quit-setup-condition? ex) 
	    (exit 0)
	    (signal ex) )
      (if (or sf (not (file-exists? fname)))
	  (##sys#setup-extensions args (list (string->symbol (pathname-file fname)) '()))
	  (load fname) ) ) ) )


;;; Setup macro support code:

(define (##sys#setup-extensions args spec)
  (let ([mode 'setup])
    (let loop ([args args])
      (if (null? args)
	  (begin
	    (when (and (not (file-exists? (registry-pathname))) (not (eq? mode 'wrap)))
	      (create-registry) )
	    (case mode
	      [(build)
	       (build-extension spec) ]
	      [(install)
	       (install-extension! spec) ]
	      [(setup)
	       (build-extension spec)
	       (install-extension! spec) ]
	      [(uninstall)
	       (uninstall-extension! (car spec)) ]
	      [(wrap)
	       (wrap-extension spec) ] ) )
	  (begin
	    (match (car args)
	      ["-install" (set! mode 'install)]
	      ["-quiet" 
	       (set! verbose #f)
	       (set! mode 'setup) ]
	      ["-build" (set! mode 'build)]
	      ["-wrap" (set! mode 'wrap)]
	      ["-uninstall" (set! mode 'uninstall)]
	      [o (quit "invalid option in extension setup `~A'~%" o)] )
	    (loop (cdr args)) ) ) ) ) )

(define (do-chicken-setup args . specs)
  (for-each (lambda (spec) (##sys#setup-extensions args spec)) specs) )

(define-macro (chicken-setup args . specs)
  `(do-chicken-setup ,args ,@(map (lambda (s) `',s) specs)) )

(define (setup-usage)
  (print #<<EOF
usage: chicken-setup [OPTION] [EXTENSION] [MODE]

  Options:

  -help                show this message and exit
  -version             show version and exit
  -init                (re-) initialize registry

  MODE may be one of the following

  -install             install extension, build if needed
  -build               build extension, extract if needed
  -wrap                create wrapped package
  -uninstall           uninstall extension
EOF
  )
  (exit 0) )

(match (command-line-arguments)
  [() (initialize-setup-stuff)]
  [("-init") (initialize-registry!)]
  [("-help") (setup-usage)]
  [("-version") 
   (display (chicken-version))
   (exit 0) ]
  [(ext . args) (run-setup-script ext args)]
  [_ (error "invalid command-line format for `-setup' option")] )
