source: project/chicken/trunk/setup-api.scm @ 12301

Last change on this file since 12301 was 12301, checked in by felix winkelmann, 13 years ago

merged changes from cmi branch

File size: 22.7 KB
Line 
1;;;; setup-api.scm - build + installation API for eggs
2;
3; Copyright (c) 2008, The Chicken Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27(require-library srfi-1 regex utils posix srfi-13 extras ports data-structures files)
28
29
30(module setup-api
31
32    (move-file 
33     (run execute)
34     compile
35     make make/proc
36     host-extension
37     install-extension install-program install-script
38     setup-verbose-flag
39     setup-install-flag installation-prefix chicken-prefix 
40     find-library find-header 
41     program-path remove-file* 
42     patch yes-or-no? abort-setup qs
43     setup-root-directory create-directory/parents
44     test-compile try-compile copy-file run-verbose
45     required-chicken-version required-extension-version cross-chicken
46     sudo-install keep-intermediates)
47
48  (import scheme chicken foreign
49          regex utils posix ports extras data-structures
50          srfi-1 srfi-13 files)
51
52;;; Constants, variables and parameters
53
54#>
55#ifndef C_INSTALL_BIN_HOME
56# define C_INSTALL_BIN_HOME   NULL
57#endif
58
59#ifndef C_INSTALL_SHARE_HOME
60# define C_INSTALL_SHARE_HOME   NULL
61#endif
62
63#ifndef C_INSTALL_CC
64# ifdef _MSC_VER
65#  define C_INSTALL_CC                "cl"
66# else
67#  ifdef __GNUC__
68#   define C_INSTALL_CC                "gcc"
69#  else
70#   define C_INSTALL_CC                "cc"
71#  endif
72# endif
73#endif
74
75#ifndef C_TARGET_CC
76# define C_TARGET_CC  C_INSTALL_CC
77#endif
78
79#ifndef C_TARGET_CXX
80# define C_TARGET_CXX  C_INSTALL_CXX
81#endif
82
83#ifndef C_TARGET_CFLAGS
84# define C_TARGET_CFLAGS  C_INSTALL_CFLAGS
85#endif
86
87#ifndef C_TARGET_MORE_LIBS
88# define C_TARGET_MORE_LIBS  C_INSTALL_LIB_HOME
89#endif
90
91#ifndef C_TARGET_LIB_HOME
92# define C_TARGET_LIB_HOME  C_INSTALL_LIB_HOME
93#endif
94
95#ifndef C_CHICKEN_PROGRAM
96# define C_CHICKEN_PROGRAM   "chicken"
97#endif
98
99#ifndef C_CSC_PROGRAM
100# define C_CSC_PROGRAM   "csc"
101#endif
102
103#ifndef C_CSI_PROGRAM
104# define C_CSI_PROGRAM   "csi"
105#endif
106
107#ifndef C_CHICKEN_BUG_PROGRAM
108# define C_CHICKEN_BUG_PROGRAM   "chicken-bug"
109#endif
110<#
111
112
113(define-constant setup-file-extension "setup-info")
114
115(define *installed-executables* 
116  `(("chicken" . ,(foreign-value "C_CHICKEN_PROGRAM" c-string))
117    ("csc" . ,(foreign-value "C_CSC_PROGRAM" c-string))
118    ("csi" . ,(foreign-value "C_CSI_PROGRAM" c-string))
119    ("chicken-bug" . ,(foreign-value "C_CHICKEN_BUG_PROGRAM" c-string))))
120
121(define *cc* (foreign-value "C_TARGET_CC" c-string))
122(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
123(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
124(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
125(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
126
127(define *major-version* (##sys#fudge 41))
128
129(define *sudo* #f)
130
131(define *windows*
132  (and (eq? (software-type) 'windows) 
133       (build-platform) ) )
134
135(define *windows-shell* (or (eq? *windows* 'mingw32)
136                            (eq? *windows* 'msvc)))
137
138(register-feature! 'chicken-setup)
139
140(define host-extension (make-parameter #f))
141
142(define *chicken-bin-path*
143  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
144        (make-pathname p "bin") )
145      (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
146
147(define *doc-path*
148  (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
149        (make-pathname p "share/chicken/doc") )
150      (make-pathname
151       (foreign-value "C_INSTALL_SHARE_HOME" c-string) 
152       "doc")))
153
154(define chicken-prefix
155  (or (getenv "CHICKEN_PREFIX")
156      (let ((m (string-match "(.*)/bin/?" *chicken-bin-path*)))
157        (if m
158            (cadr m)
159            "/usr/local") ) ) )
160
161(define (cross-chicken) (##sys#fudge 39))
162
163(define *copy-command* (if *windows-shell* 'copy "cp -r"))
164(define *remove-command* (if *windows-shell* "del /Q /S" "rm -fr"))
165(define *move-command* (if *windows-shell* 'move 'mv))
166(define *chmod-command* "chmod")
167(define *ranlib-command* "ranlib")
168(define *csc-options* '())
169(define *base-directory* (current-directory))
170
171(define setup-root-directory      (make-parameter *base-directory*))
172(define setup-verbose-flag        (make-parameter #f))
173(define setup-install-flag        (make-parameter #t))
174(define program-path (make-parameter *chicken-bin-path*))
175(define keep-intermediates (make-parameter #f))
176
177(define (sudo-install)
178  (set! *copy-command* "sudo cp -r")
179  (set! *remove-command* "sudo rm -fr")
180  (set! *move-command* "sudo mv")
181  (set! *chmod-command* "sudo chmod")
182  (set! *ranlib-command* "sudo ranlib"))
183
184; Convert a string with a version (such as "1.22.0") to a list of the
185; numbers (such as (1 22 0)). If one of the version components cannot
186; be converted to a number, then it is kept as a string.
187
188#;(define (version-string->numbers string)
189  (map (lambda (x) (or (string->number x) (->string x)))
190       (string-split string ".")))
191
192; Given two lists with numbers corresponding to a software version (as returned
193; by version-string->numbers), check if the first is greater than the second.
194
195(define (version-numbers> a b)
196  (cond ((null? a) #f)
197        ((null? b)  #t)
198        ((and (pair? a) (pair? b))
199         (let ((a1 (car a))
200               (an (cdr a))
201               (b1 (car b))
202               (bn (cdr b)))
203          (cond ((and (number? a1) (number? b1))
204                 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
205                ((and (string? a1) (string? b1)) 
206                 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
207                (else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn))))) )
208        (else (error 'version-numbers> "invalid revisions: " a b))))
209
210(define create-directory-0
211  (let ([create-directory create-directory])
212    (lambda (dir)
213      (let loop ([dir dir])
214        (when (and dir (not (directory? dir)))
215          (loop (pathname-directory dir))
216          (create-directory dir))) ) ) )
217
218(define create-directory/parents
219  (let ()
220    (define (verb dir)
221      (when (setup-verbose-flag) (printf "  creating directory `~a'~%~!" dir)) )
222    (if *windows-shell*
223        (lambda (dir)
224          (verb dir)
225          (create-directory-0 dir) ) 
226        (lambda (dir)
227          (verb dir)
228          (system* "mkdir -p ~a" (qs dir) ) ) ) ) )
229
230(define (qs str)
231  (string-concatenate
232   (map (lambda (c)
233          (if (or (char-whitespace? c)
234                  (memq c '(#\# #\" #\' #\` # #\~ #\& #\% #\$ #\! #\* #\; #\< #\> #\\
235                            #\( #\) #\[ #\] #\{ #\})))
236              (string #\\ c)
237              (string c)))
238        (string->list str))))
239
240(define abort-setup 
241  (make-parameter exit))
242
243(define (yes-or-no? str . default)
244  (let ((def (optional default #f)))
245    (let loop ()
246      (printf "~%~A (yes/no/abort) " str)
247      (when def (printf "[~A] " def))
248      (flush-output)
249      (let ((ln (read-line)))
250        (cond ((eof-object? ln) (set! ln "abort"))
251              ((and def (string=? "" ln)) (set! ln def)) )
252        (cond ((string-ci=? "yes" ln) #t)
253              ((string-ci=? "no" ln) #f)
254              ((string-ci=? "abort" ln) ((abort-setup)))
255              (else
256               (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
257               (loop) ) ) ) ) ) )
258
259(define (patch which rx subst)
260  (when (setup-verbose-flag) (printf "patching ~A ...~%" which))
261  (if (list? which)
262      (with-output-to-file (cadr which)
263       (lambda ()
264         (with-input-from-file (car which)
265           (lambda ()
266             (let loop ()
267               (let ((ln (read-line)))
268                 (unless (eof-object? ln)
269                   (write-line (string-substitute rx subst ln #t)) 
270                   (loop) ) ) ) ) ) ) )
271      (let ((tmp (create-temporary-file)))
272        (patch (list tmp tmp) rx subst)
273        (system* "~A ~A ~A" *move-command* (qs tmp)
274                 (qs which)))))
275
276(define run-verbose (make-parameter #t))
277
278(define (fixpath prg)
279  (cond ((string=? prg "csc")
280         (string-intersperse 
281          (cons* (qs 
282                  (make-pathname 
283                   *chicken-bin-path*
284                   (cdr (assoc prg *installed-executables*))))
285                 "-feature" "compiling-extension"
286                 (if (host-extension) "-host" "")
287                 *csc-options*) 
288          " ") )
289        ((assoc prg *installed-executables*) =>
290         (lambda (a) (qs (make-pathname *chicken-bin-path* (cdr a)))))
291        (else prg) ) )
292
293(define (fixmaketarget file)
294  (if (and (equal? "so" (pathname-extension file))
295           (not (string=? "so" ##sys#load-dynamic-extension)) )
296      (pathname-replace-extension file ##sys#load-dynamic-extension)
297      file) )
298
299(define (execute explist)
300  (define (smooth lst)
301    (let ((slst (map ->string lst)))
302      (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
303  (for-each
304   (lambda (cmd)
305     (when (run-verbose) (printf "  ~A~%~!" cmd))
306     (system* "~a" cmd) )
307   (map smooth explist) ) )
308
309(define-syntax run
310  (syntax-rules ()
311    ((_ exp ...)
312     (execute (list `exp ...)))))
313
314(define-syntax compile
315  (syntax-rules ()
316    ((_ exp ...)
317     (run (csc exp ...)))))
318
319
320;;; "make" functionality
321
322(define (make:find-matching-line str spec)
323  (let ((match? (lambda (s) (string=? s str))))
324    (let loop ((lines spec))
325      (cond
326       ((null? lines) #f)
327       (else (let* ((line (car lines))
328                    (names (if (string? (car line))
329                               (list (car line))
330                               (car line))))
331               (if (any match? names)
332                   line
333                   (loop (cdr lines)))))))))
334
335(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
336(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
337
338(define (make:check-spec spec)
339  (and (or (list? spec) (make:form-error "specification is not a list" spec))
340       (or (pair? spec) (make:form-error "specification is an empty list" spec))
341       (every
342        (lambda (line)
343          (and (or (and (list? line) (<= 2 (length line) 3))
344                   (make:form-error "list is not a list with 2 or 3 parts" line))
345               (or (or (string? (car line))
346                       (and (list? (car line))
347                            (every string? (car line))))
348                   (make:form-error "line does not start with a string or list of strings" line))
349               (let ((name (car line)))
350                 (or (list? (cadr line))
351                     (make:line-error "second part of line is not a list" (cadr line) name)
352                     (every (lambda (dep)
353                               (or (string? dep)
354                                   (make:form-error "dependency item is not a string" dep)))
355                             (cadr line)))
356                 (or (null? (cddr line))
357                     (procedure? (caddr line))
358                     (make:line-error "command part of line is not a thunk" (caddr line) name)))))
359        spec)))
360
361(define (make:check-argv argv)
362  (or (string? argv)
363      (every string? argv)
364      (error "argument is not a string or string list" argv)))
365
366(define (make:make/proc/helper spec argv)
367  (when (vector? argv) (set! argv (vector->list argv)))
368  (make:check-spec spec)
369  (make:check-argv argv)
370  (letrec ((made '())
371           (exn? (condition-predicate 'exn))
372           (exn-message (condition-property-accessor 'exn 'message))
373           (make-file
374            (lambda (s indent)
375              (let* ((line (make:find-matching-line s spec))
376                     (s2 (fixmaketarget s)) 
377                     (date (and (file-exists? s2)
378                                (file-modification-time s2))))
379                (when (setup-verbose-flag)
380                  (printf "make: ~achecking ~a~%" indent s2))
381                (if line
382                    (let ((deps (cadr line)))
383                      (for-each (let ((new-indent (string-append " " indent)))
384                                  (lambda (d) (make-file d new-indent)))
385                                deps)
386                      (let ((reason
387                             (or (not date)
388                                 (any (lambda (dep)
389                                          (let ((dep2 (fixmaketarget dep)))
390                                            (unless (file-exists? dep2)
391                                              (error (sprintf "dependancy ~a was not made~%" dep2)))
392                                            (and (> (file-modification-time dep2) date)
393                                                 dep2)) )
394                                        deps))))
395                        (when reason
396                          (let ((l (cddr line)))
397                            (unless (null? l)
398                              (set! made (cons s made))
399                              (when (setup-verbose-flag)
400                                (printf "make: ~amaking ~a~a~%"
401                                        indent
402                                        s2
403                                        (cond
404                                         ((not date)
405                                          (string-append " because " s2 " does not exist"))
406                                         ((string? reason)
407                                          (string-append " because " reason " changed"))
408                                         (else
409                                          (string-append (sprintf " just because (reason: ~a date: ~a)" 
410                                                                  reason date)))) ) )
411                              (handle-exceptions exn
412                                  (begin
413                                    (printf "make: Failed to make ~a: ~a~%"
414                                            (car line)
415                                            (if (exn? exn)
416                                                (exn-message exn)
417                                                exn))
418                                    (signal exn) )
419                                ((car l))))))))
420                    (unless date
421                      (error (sprintf "don't know how to make ~a" s2))))))))
422    (cond
423     ((string? argv) (make-file argv ""))
424     ((null? argv) (make-file (caar spec) ""))
425     (else (for-each (lambda (f) (make-file f "")) argv)))
426    (when (setup-verbose-flag)
427      (for-each (lambda (item)
428                  (printf "make: made ~a~%" item))
429        (reverse made)))) )
430
431(define make/proc
432  (case-lambda
433   ((spec) (make:make/proc/helper spec '()))
434   ((spec argv)
435    (make:make/proc/helper
436     spec
437     (if (vector? argv)
438         (vector->list argv)
439         argv) ) ) ) )
440
441(define-syntax make
442  (lambda (form r c)
443    (##sys#check-syntax 'make form '(_ _ . #(_ 0 1)))
444    (let ((spec (cadr form))
445          (%list (r 'list))
446          (%lambda (r 'lambda)))
447      (let ((form-error (lambda (s . p) (apply error s spec p))))
448        (and (or (list? spec) (form-error "illegal specification (not a sequence)"))
449             (or (pair? spec) (form-error "empty specification"))
450             (every
451              (lambda (line)
452                (and (or (and (list? line) (>= (length line) 2))
453                         (form-error "clause does not have at least 2 parts" line))
454                     (let ((name (car line)))
455                       (or (list? (cadr line))
456                           (make:line-error "second part of clause is not a sequence" (cadr line) name)))))
457              spec))
458        `(,(r 'make/proc)
459          (list ,@(map (lambda (line)
460                         `(,%list ,(car line)
461                                  (,%list ,@(cadr line))
462                                  ,@(let ((l (cddr line)))
463                                      (if (null? l)
464                                          '()
465                                          `((,%lambda () ,@l))))))
466                       spec))
467          ,@(if (null? (cddr form))
468                '('())
469                (cddr form)))))))
470
471
472;;; Processing setup scripts
473
474(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
475  (make-pathname rpath fn setup-file-extension) )
476
477(define installation-prefix
478  (make-parameter (or (getenv "CHICKEN_INSTALL_PREFIX") #f)))
479
480(define (with-ext filename ext)
481  (if (and (equal? (pathname-extension filename) ext)
482           (file-exists? filename) )
483      filename
484      (let ((f2 (pathname-replace-extension filename ext)))
485        (and (file-exists? f2) f2) ) ) )
486
487(define (write-info id files info)
488  (let ((info `((files ,@files) 
489                ,@info)) )
490    (when (setup-verbose-flag) (printf "writing info ~A -> ~S ...~%" id info))
491    (let* ((sid (->string id))
492           (setup-file (make-setup-info-pathname sid (repo-path #t))))
493      (cond (*sudo*
494             (let ((tmp (create-temporary-file)))
495               (with-output-to-file tmp (cut pp info))
496               (run (,*move-command* ,(qs tmp) ,(qs setup-file)))))
497            (else (with-output-to-file setup-file (cut pp info))))
498      (unless *windows-shell* (run (,*chmod-command* a+r ,(qs setup-file)))))))
499
500(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
501  (let ((from (if (pair? from) (car from) from))
502        (to (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
503              (if (and prefix (not (string-prefix? prefix to-path)))
504                  (make-pathname prefix to-path) to-path))))
505    (ensure-directory to)
506    (cond ((or (glob? from) (file-exists? from))
507           (begin
508             (run (,*copy-command* ,(qs from) ,(qs to))) 
509             to))
510          (err (error "file does not exist" from))
511          (else (warning "file does not exist" from)))))
512
513(define (move-file from to)
514  (let ((from  (if (pair? from) (car from) from))
515        (to    (if (pair? from) (make-pathname to (cadr from)) to)))
516    (ensure-directory to)
517    (run (,*move-command* ,(qs from) ,(qs to)) ) ) )
518
519(define (remove-file* dir)
520  (run (,*remove-command* ,(qs dir)) ) )
521
522(define (make-dest-pathname path file)
523  (if (list? file)
524      (make-dest-pathname path (cadr file))
525      (if (absolute-pathname? file)
526          file
527          (make-pathname path file) ) ) )
528
529(define (check-filelist flist)
530  (map (lambda (f)
531         (cond ((string? f) f)
532               ((and (list? f) (every string? f)) f)
533               ((and (pair? f) (list (car f) (cdr f))))
534               (else (error "invalid file-specification" f)) ) )
535       flist) )
536
537(define (translate-extension f #!optional default)
538  (pathname-replace-extension f
539   (let ((ext (pathname-extension f)))
540     (cond ((not ext) default)
541           ((equal? "so" ext) ##sys#load-dynamic-extension)
542           ((equal? "a" ext) (if *windows-shell* "lib" "a"))
543           (else ext)))))
544
545
546;;; Installation
547
548(define (install-extension id files #!optional (info '()))
549  (when (setup-install-flag)
550    (let* ((files (check-filelist (if (list? files) files (list files))))
551           (rpath (repo-path))
552           (rpathd (repo-path #t))
553           (dests (map (lambda (f)
554                         (let ((from (if (pair? f) (car f) f))
555                               (to (make-dest-pathname rpathd f)) )
556                           (when (and (not *windows*) 
557                                      (equal? "so" (pathname-extension to)))
558                             (run (,*remove-command* ,(qs to)) ))
559                           (copy-file from to)
560                           (unless *windows-shell*
561                             (run (,*chmod-command* a+r ,(qs to))))
562                           (and-let* ((static (assq 'static info)))
563                             (when (and (eq? (software-version) 'macosx)
564                                        (equal? (cadr static) from) 
565                                        (equal? (pathname-extension to) "a"))
566                               (run (,*ranlib-command* ,(qs to)) ) ))
567                           (make-dest-pathname rpath f)))
568                       files) ) )
569      (and-let* ((docs (assq 'documentation info)))
570        (print "\n* Installing documentation files in " *doc-path* ":")
571        (for-each
572         (lambda (f)
573           (copy-file f (make-pathname *doc-path* f) #f) )
574         (cdr docs))
575        (newline))
576      (and-let* ((exs (assq 'examples info)))
577        (print "\n* Installing example files in " *doc-path* ":")
578        (for-each
579         (lambda (f)
580           (let ((destf (make-pathname *doc-path* f)))
581             (copy-file f destf #f)
582             (unless *windows-shell*
583               (run (chmod a+rx ,destf)) ) ))
584         (cdr exs))
585        (newline))
586      (write-info id dests info) ) ) )
587
588(define (install-program id files #!optional (info '()))
589  (define (exify f)
590    (translate-extension
591     f
592     (if *windows-shell* "exe" #f) ) )
593  (when (setup-install-flag)
594    (let* ((files (check-filelist (if (list? files) files (list files))))
595           (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
596                   (installation-prefix)))
597           (files (if *windows*
598                      (map (lambda (f)
599                             (if (list? f) 
600                                 (list (exify (car f)) (exify (cadr f)))
601                                 (exify f) ) )
602                           files)
603                      files) ) 
604           (dests (map (lambda (f)
605                         (let ((from (if (pair? f) (car f) f))
606                               (to (make-dest-pathname ppath f)) )
607                           (copy-file from to) 
608                           (unless *windows-shell*
609                                   (run (,*chmod-command* a+r ,(qs to))))
610                           to) )
611                       files) ) )
612      (write-info id dests info) ) ) )
613
614(define (install-script id files #!optional (info '()))
615  (when (setup-install-flag)
616    (let* ((files (check-filelist (if (list? files) files (list files))))
617           (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
618                   (installation-prefix)))
619           (pfiles (map (lambda (f)
620                          (let ((from (if (pair? f) (car f) f))
621                                (to (make-dest-pathname ppath f)) )
622                            (copy-file from to) 
623                            (unless *windows-shell*
624                                    (run (,*chmod-command* a+r ,(qs to))))
625                            to) )
626                        files) ) )
627      (unless *windows-shell*
628        (run (,*chmod-command* a+rx ,(string-intersperse pfiles " "))) )
629      (write-info id pfiles info) ) ) )
630
631
632;;; More helper stuff
633
634(define (repo-path #!optional ddir?)
635  (let ((p (if (and ddir? (installation-prefix))
636               (make-pathname (installation-prefix) (repository-path))
637               (repository-path))) )
638    (ensure-directory p)
639    p) )
640
641(define (ensure-directory path)
642  (and-let* ((dir (pathname-directory path)))
643    (if (file-exists? dir)
644        (unless (directory? dir)
645          (error "can not create directory: a file with the same name already exists") )
646        (begin
647          (create-directory dir)
648          (unless *windows-shell*
649                  (run (,*chmod-command* a+x ,(qs dir))))))))
650
651(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "") 
652                     (verb (setup-verbose-flag)) (compile-only #f))
653  (let* ((fname (create-temporary-file "c"))
654         (oname (pathname-replace-extension fname "o"))
655         (r (begin
656              (with-output-to-file fname (cut display code))
657              (system 
658               (let ((cmd (conc
659                           cc " "
660                           (if compile-only "-c" "") " "
661                           cflags " " *target-cflags* " "
662                           fname " "
663                           (if compile-only
664                               "" 
665                               (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
666                           " >/dev/null "
667                           (if verb "" "2>&1") ) ) )
668                 (when verb (print cmd " ..."))
669                 cmd) ) ) ) )
670    (when verb (print (if (zero? r) "succeeded." "failed.")))
671    (system (sprintf "~A ~A" *remove-command* (qs fname)))
672    (zero? r) ) )
673
674(define (required-chicken-version v)
675  (when (string-ci<? (chicken-version) (->string v))
676    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
677
678(define (upgrade-message ext msg)
679  (error
680   (sprintf
681    "the required extension `~s' ~a - please run~%~%  chicken-setup ~a~%~%and repeat the current installation operation."
682    ext msg ext) ) )
683
684(define (required-extension-version . args)
685  (let loop ((args args))
686    (cond ((null? args) #f)
687          ((and (list? args) (>= (length args) 2))
688           (let* ((ext (car args))
689                  (version (cadr args))
690                  (more (cddr args))
691                  (info (extension-information ext))
692                  (version (->string version)) )
693             (if info
694                 (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
695                   (cond ((not ver) (upgrade-message ext "has no associated version information"))
696                         ((string-ci<? (->string ver) version)
697                          (upgrade-message 
698                           ext
699                           (sprintf "is older than ~a, which is what this extension requires"
700                                    version) ) )
701                         (else (loop more)) ) ) 
702                 (upgrade-message ext "is not installed") ) ) )
703          (else
704           (error 'required-extension-information "bad argument format" args)) ) ) )
705
706(define test-compile try-compile)
707
708(define (find-library name proc)
709  (test-compile 
710   (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
711   ldflags: (conc "-l" name) ) )
712
713(define (find-header name)
714  (test-compile
715   (sprintf "#include <~a>\nint main() { return 0; }\n" name)
716   compile-only: #t) )
717
718)
Note: See TracBrowser for help on using the repository browser.