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

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

removed some dead code

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