source: project/chicken/branches/hygienic/misc/setup-api.scm @ 11401

Last change on this file since 11401 was 11401, checked in by felix winkelmann, 12 years ago

working mini-setup; csi describe and report tweaks; wrong handling of require-extension with core libs (import case)

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