Changeset 15756 in project


Ignore:
Timestamp:
09/06/09 20:10:07 (10 years ago)
Author:
Kon Lovett
Message:

Forgot to convert bundle dir elms into strings.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/setup-helper/trunk/setup-helper.scm

    r14216 r15756  
    2020;; Filename Support
    2121
    22 (define (filename bn . en)
    23   (make-pathname #f (->string bn) (and (not (null? en)) (->string (car en)))) )
    24 
    25 (define (document-filename bn)
    26   (filename bn "html") )
    27 
    28 (define (source-filename bn)
    29   (filename bn "scm") )
    30 
    31 (define (shared-library-filename bn)
    32   (filename bn ##sys#load-library-extension) )
    33 
    34 (define (shared-filename bn)
    35   (filename bn ##sys#load-dynamic-extension) )
    36 
    37 (define (static-library-filename bn)
    38   (filename bn "a") )
    39 
    40 (define (static-filename bn)
    41   (filename bn "o") )
    42 
    43 (define (import-filename bn)
    44   (filename bn "import") )
    45 
    46 (define (source-import-filename bn)
    47   (source-filename (import-filename bn)) )
    48 
    49 (define (shared-import-filename bn)
    50   (shared-filename (import-filename bn)) )
    51 
    52 (define (inline-filename bn)
    53   (filename bn "inline") )
    54 
    55 (define (program-filename bn)
    56   (filename bn (and (eq? 'windows (software-type)) "exe")) )
    57 
    58 (define (make-repository-pathname bn)
    59   (make-pathname (repository-path) bn) )
     22(define (filename bn #!optional en) (make-pathname #f (->string bn) (and en (->string en))))
     23
     24(define (make-directory dir)
     25  (cond ((string? dir)  dir)
     26        ((symbol? dir)  (symbol->string dir))
     27        ((pair? dir)
     28          (let ((len (length dir)))
     29            (if (= 1 len) (->string (car dir))
     30                (make-pathname (map ->string (take dir (sub1 len))) (->string (last dir))) ) ) )
     31        (else
     32          (warning 'make-directory "unknown argument" dir) ) ) )
     33
     34(define (document-filename bn) (filename bn "html"))
     35
     36(define (source-filename bn) (filename bn "scm"))
     37
     38(define (shared-library-filename bn) (filename bn ##sys#load-library-extension))
     39
     40(define (shared-filename bn) (filename bn ##sys#load-dynamic-extension))
     41
     42(define (static-library-filename bn) (filename bn "a"))
     43
     44(define (static-filename bn) (filename bn "o"))
     45
     46(define (import-filename bn) (filename bn "import"))
     47
     48(define (source-import-filename bn) (source-filename (import-filename bn)))
     49
     50(define (shared-import-filename bn) (shared-filename (import-filename bn)))
     51
     52(define (inline-filename bn) (filename bn "inline"))
     53
     54(define (program-filename bn) (filename bn (and (eq? 'windows (software-type)) "exe")))
     55
     56(define (make-repository-pathname bn) (make-pathname (repository-path) bn))
    6057
    6158;; File Support
    6259
    63 (define (copy-file-to-directory fn dn)
    64   (copy-file fn (make-pathname dn fn)) )
    65 
    66 (define (copy-to-repository fn)
    67   (copy-file-to-directory fn (repository-path)) )
    68 
    69 (define (copy-to-home fn)
    70   (copy-file-to-directory fn (chicken-home)) )
     60(define (copy-file-to-directory fn dn) (copy-file fn (make-pathname dn fn)))
     61
     62(define (copy-to-repository fn) (copy-file-to-directory fn (repository-path)))
     63
     64(define (copy-to-home fn) (copy-file-to-directory fn (chicken-home)))
    7165
    7266;; SRFI-29 Bundle Support
    7367
    7468(define install-srfi-29-bundle)
    75 
    7669(let ((*srfi-29-bundles-directory* (make-repository-pathname "srfi-29-bundles")))
    7770  (define (srfi-29-bundle-directory spec)
    78     (if (null? spec)
    79         *srfi-29-bundles-directory*
    80         (let ((dir (append (list *srfi-29-bundles-directory*) (take spec (sub1 (length spec)))))
    81               (nam (last spec)))
    82           (make-pathname dir nam) ) ) )
     71    (if (null? spec) *srfi-29-bundles-directory*
     72        (make-directory (append (list *srfi-29-bundles-directory*) spec)) ) )
    8373  (set! install-srfi-29-bundle
    8474    (lambda (nam . spec)
    8575      (unless (directory? *srfi-29-bundles-directory*)
    8676        (error "missing SRFI-29 bundles directory; please install SRFI-29") )
    87       (let ((bundle-dir (srfi-29-bundle-directory spec)))
    88         (unless (directory? bundle-dir) (create-directory/parents bundle-dir)) )
    89       (let* ((namstr (->string nam))
    90              (bundle-src (make-pathname (append '(".") spec) namstr))
    91              (bundle-dst (make-pathname (append (list *srfi-29-bundles-directory*) spec) namstr)))
    92         (copy-file bundle-src bundle-dst) ) ) ) )
     77      (let* ((spec (map ->string spec))
     78             (nam (->string nam))
     79             (dir (srfi-29-bundle-directory spec)) )
     80        (copy-file (make-pathname (append '(".") spec) nam)
     81                   (make-pathname dir nam)
     82                   #t) ) ) ) )
    9383
    9484;; Compile Support
     
    206196  (install-shared+static-extension-module nam ver options: install-options files: files) )
    207197
    208 ;;
     198;; Empty "Conglomerate" Extension Support
    209199
    210200(define (install-extension-tag nam ver) (install-extension nam '() `((version ,ver))))
Note: See TracChangeset for help on using the changeset viewer.