Changeset 20915 in project


Ignore:
Timestamp:
10/21/10 01:03:18 (11 years ago)
Author:
Kon Lovett
Message:

Deprecated copy-file-to-directory. More use of const.

Location:
release/4/setup-helper
Files:
4 edited
1 copied

Legend:

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

    r20260 r20915  
    1717;;; Support
    1818
     19;; Simple type error report
     20
     21(define (sh:error-type loc obj)
     22  (##sys#signal-hook #:type-error loc "bad argument type" obj) )
     23
    1924;; Filename Support
     25
     26(define-constant CHICKEN-SOURCE-EXTENSION "scm")
     27(define-constant CHICKEN-IMPORT-EXTENSION "import")
     28(define-constant CHICKEN-INLINE-EXTENSION "inline")
     29(define-constant HTML-EXTENSION "html")
     30(define-constant STATIC-ARCHIVE-EXTENSION "a")
     31(define-constant OBJECT-BINARY-EXTENSION "o")
     32(cond-expand
     33  (windows
     34    (define-constant EXECUTABLE-EXTENSION "exe")
     35    (define-constant DIRECTORY-SEPARATOR "\\") )
     36  (else
     37    (define-constant EXECUTABLE-EXTENSION #f)
     38    (define-constant DIRECTORY-SEPARATOR "/") ) )
    2039
    2140(define (installation-chicken-home)
    2241  (if (not (installation-prefix)) (chicken-home)
    23     (make-pathname (installation-prefix) "share/chicken") ) )
     42    (make-pathname `(,(installation-prefix) "share") "chicken") ) )
    2443
    2544(define (installation-repository-path)
     45  ;A sub-dir using the current binary version number.
     46  ;(Note that this is only indirectly related to the
     47  ;Chicken version number.)
    2648  (make-pathname
    27     (installation-prefix)
    28     (sprintf "lib/chicken/~a" (##sys#fudge 42))) )
     49    `(,(installation-prefix) "lib" "chicken")
     50    (number->string (##sys#fudge 42))) )
     51
     52(define (directory-separator? obj)
     53  (let ((obj
     54          (cond
     55            ;not a good idea but ...
     56            ((symbol? obj)  (symbol->string obj))
     57            ((char? obj)    (string obj))
     58            ((string? obj)  obj)
     59            (else
     60              (sh:error-type 'directory-separator? obj) ) ) ) )
     61    (string=? obj DIRECTORY-SEPARATOR) ) )
    2962
    3063(define (filename bn #!optional en)
    3164  (make-pathname #f (->string bn) (and en (->string en))) )
    3265
    33 (define (make-directory dir)
    34   (cond
    35     ((string? dir)  dir)
    36     ((symbol? dir)  (symbol->string dir))
    37     ((pair? dir)
    38       (let ((len (length dir)))
    39         (if (= 1 len) (->string (car dir))
    40             (make-pathname
    41               (map ->string (take dir (sub1 len)))
    42               (->string (last dir))) ) ) )
    43     (else
    44       (warning 'make-directory "unknown argument" dir) ) ) )
    45 
    46 (define (document-filename bn) (filename bn "html"))
    47 
    48 (define (source-filename bn) (filename bn "scm"))
     66(define (make-directory-name dir)
     67  (let ((dir (if (symbol? dir) (symbol->string dir) dir)))
     68    (cond
     69      ((string? dir)
     70        (let ((end (sub1 (string-length dir))))
     71          (if (not (directory-separator? (string-ref dir end))) dir
     72              (substring dir 0 end) ) ) )
     73      ((pair? dir)
     74        (let ((len (length dir)))
     75          (if (= 1 len) (->string (car dir))
     76              ;Ensures no trailing directory separator.
     77              (make-pathname
     78                (map ->string (take dir (sub1 len)))
     79                (->string (last dir))) ) ) )
     80      (else
     81        (sh:error-type 'make-directory-name dir) ) ) ) )
     82
     83(define (document-filename bn)
     84  (filename bn HTML-EXTENSION) )
     85
     86(define (source-filename bn)
     87  (filename bn CHICKEN-SOURCE-EXTENSION) )
    4988
    5089(define (shared-library-filename bn)
     
    5493  (filename bn ##sys#load-dynamic-extension) )
    5594
    56 (define (static-library-filename bn) (filename bn "a"))
    57 
    58 (define (static-filename bn) (filename bn "o"))
    59 
    60 (define (import-filename bn) (filename bn "import"))
     95(define (static-library-filename bn)
     96  (filename bn STATIC-ARCHIVE-EXTENSION) )
     97
     98(define (static-filename bn)
     99  (filename bn OBJECT-BINARY-EXTENSION) )
     100
     101(define (import-filename bn)
     102  (filename bn CHICKEN-IMPORT-EXTENSION) )
    61103
    62104(define (source-import-filename bn)
     
    66108  (shared-filename (import-filename bn)) )
    67109
    68 (define (inline-filename bn) (filename bn "inline"))
     110(define (inline-filename bn)
     111  (filename bn CHICKEN-INLINE-EXTENSION) )
    69112
    70113(define (program-filename bn)
    71  (filename bn (and (eq? 'windows (software-type)) "exe")) )
     114 (filename bn EXECUTABLE-EXTENSION) )
     115
     116(define (make-home-pathname bn)
     117  (make-pathname (installation-chicken-home) bn) )
    72118
    73119(define (make-repository-pathname bn)
     
    76122;; File Support
    77123
     124(define (copy-file-relative fn dn)
     125  ;This subverts the "installation-prefix" relative insurance.
     126  ;(and uses the builtin to-path creation "feature").
     127  (copy-file `(,fn ,fn) dn #t dn) )
     128
     129(define (copy-file-absolute fn dn)
     130  ;Keeps the "installation-prefix" relative insurance.
     131  ;(and uses the builtin to-path creation "feature").
     132  (copy-file `(,fn ,fn) dn) )
     133
    78134(define (copy-file-to-directory fn dn)
    79   (copy-file (list fn fn) dn #t dn) )
     135  (copy-file-relative fn dn) )
    80136
    81137(define (copy-to-repository fn)
    82   (copy-file-to-directory fn (installation-repository-path)) )
     138  (copy-file-relative fn (installation-repository-path)) )
    83139
    84140(define (copy-to-home fn)
    85   (copy-file-to-directory fn (installation-chicken-home)) )
     141  (copy-file-relative fn (installation-chicken-home)) )
    86142
    87143;; Single File Install Support
     
    97153;; SRFI-29 Bundle Support
    98154
    99 (define install-srfi-29-bundle)
    100 (let ((*srfi-29-bundles-directory*
    101         (make-repository-pathname "srfi-29-bundles")))
    102   (define (srfi-29-bundle-directory spec)
    103     (if (null? spec) *srfi-29-bundles-directory*
    104         (make-directory (append (list *srfi-29-bundles-directory*) spec)) ) )
    105   (set! install-srfi-29-bundle
    106     (lambda (nam . spec)
    107       (when (setup-install-mode)
    108         (unless (directory? *srfi-29-bundles-directory*)
    109           (error "missing SRFI-29 bundles directory; please install SRFI-29") )
    110         (let* ((spec (map ->string spec))
    111                (nam (->string nam))
    112                (dir (srfi-29-bundle-directory spec)) )
    113           (copy-file (make-pathname (append '(".") spec) nam)
    114                      (make-pathname dir nam)
    115                      #t) ) ) ) ) )
     155(define (srfi-29-bundles-home)
     156  (make-repository-pathname "srfi-29-bundles") )
     157
     158(define (make-srfi-29-bundle-directory-name spec)
     159  (if (null? spec) (srfi-29-bundles-home)
     160    (make-directory-name
     161      (append (list (srfi-29-bundles-home)) spec)) ) )
     162
     163(define (install-srfi-29-bundle nam . spec)
     164  (when (setup-install-mode)
     165    (unless (directory? (srfi-29-bundles-home))
     166      (error "missing SRFI-29 bundles directory; please install SRFI-29") )
     167    (let* ((spec (map ->string spec))
     168           (nam (->string nam))
     169           (dir (make-srfi-29-bundle-directory-name spec)) )
     170      ;Explicit curdir ('.') because problems in the past.
     171      (copy-file
     172        (make-pathname (append '(".") spec) nam)
     173        (make-pathname dir nam)
     174        #t
     175        dir) ) ) )
    116176
    117177;; Compile Support
    118178
    119 (define cc-path-options
    120   (cond-expand
    121     (macosx    '(-I/opt/local/include -L/opt/local/lib -I/sw/include -L/sw/lib))
    122     (else      '())))
    123 
    124 ; Bad idea to make `-local' the default for a module compile (but not an import compile)
    125 ; since it means something like `fluid-let' cannot be used on an exported binding.
     179#;
     180(define include-path-options
     181  (make-parameter
     182    (cond-expand
     183      (macosx    '(-I/opt/local/include -I/sw/include))
     184      (else      '()))))
     185
     186#;
     187(define library-path-options
     188  (make-parameter
     189    (cond-expand
     190      (macosx    '(-L/opt/local/lib -L/sw/lib))
     191      (else      '()))))
     192
     193;Bad idea to make `-local' the default for a module compile (but not an import
     194;compile) since it means something like `fluid-let' cannot be used on an
     195;exported binding.
    126196
    127197(define default-static-compile-options
  • release/4/setup-helper/tags/1.3.0/setup-helper.setup

    r20261 r20915  
    77(install-in-home "setup-helper.scm")
    88
    9 (install-extension-tag (extension-name) (extension-version "1.2.0"))
     9(install-extension-tag (extension-name) (extension-version "1.3.0"))
  • release/4/setup-helper/trunk/setup-helper.scm

    r20260 r20915  
    1717;;; Support
    1818
     19;; Simple type error report
     20
     21(define (sh:error-type loc obj)
     22  (##sys#signal-hook #:type-error loc "bad argument type" obj) )
     23
    1924;; Filename Support
     25
     26(define-constant CHICKEN-SOURCE-EXTENSION "scm")
     27(define-constant CHICKEN-IMPORT-EXTENSION "import")
     28(define-constant CHICKEN-INLINE-EXTENSION "inline")
     29(define-constant HTML-EXTENSION "html")
     30(define-constant STATIC-ARCHIVE-EXTENSION "a")
     31(define-constant OBJECT-BINARY-EXTENSION "o")
     32(cond-expand
     33  (windows
     34    (define-constant EXECUTABLE-EXTENSION "exe")
     35    (define-constant DIRECTORY-SEPARATOR "\\") )
     36  (else
     37    (define-constant EXECUTABLE-EXTENSION #f)
     38    (define-constant DIRECTORY-SEPARATOR "/") ) )
    2039
    2140(define (installation-chicken-home)
    2241  (if (not (installation-prefix)) (chicken-home)
    23     (make-pathname (installation-prefix) "share/chicken") ) )
     42    (make-pathname `(,(installation-prefix) "share") "chicken") ) )
    2443
    2544(define (installation-repository-path)
     45  ;A sub-dir using the current binary version number.
     46  ;(Note that this is only indirectly related to the
     47  ;Chicken version number.)
    2648  (make-pathname
    27     (installation-prefix)
    28     (sprintf "lib/chicken/~a" (##sys#fudge 42))) )
     49    `(,(installation-prefix) "lib" "chicken")
     50    (number->string (##sys#fudge 42))) )
     51
     52(define (directory-separator? obj)
     53  (let ((obj
     54          (cond
     55            ;not a good idea but ...
     56            ((symbol? obj)  (symbol->string obj))
     57            ((char? obj)    (string obj))
     58            ((string? obj)  obj)
     59            (else
     60              (sh:error-type 'directory-separator? obj) ) ) ) )
     61    (string=? obj DIRECTORY-SEPARATOR) ) )
    2962
    3063(define (filename bn #!optional en)
    3164  (make-pathname #f (->string bn) (and en (->string en))) )
    3265
    33 (define (make-directory dir)
    34   (cond
    35     ((string? dir)  dir)
    36     ((symbol? dir)  (symbol->string dir))
    37     ((pair? dir)
    38       (let ((len (length dir)))
    39         (if (= 1 len) (->string (car dir))
    40             (make-pathname
    41               (map ->string (take dir (sub1 len)))
    42               (->string (last dir))) ) ) )
    43     (else
    44       (warning 'make-directory "unknown argument" dir) ) ) )
    45 
    46 (define (document-filename bn) (filename bn "html"))
    47 
    48 (define (source-filename bn) (filename bn "scm"))
     66(define (make-directory-name dir)
     67  (let ((dir (if (symbol? dir) (symbol->string dir) dir)))
     68    (cond
     69      ((string? dir)
     70        (let ((end (sub1 (string-length dir))))
     71          (if (not (directory-separator? (string-ref dir end))) dir
     72              (substring dir 0 end) ) ) )
     73      ((pair? dir)
     74        (let ((len (length dir)))
     75          (if (= 1 len) (->string (car dir))
     76              ;Ensures no trailing directory separator.
     77              (make-pathname
     78                (map ->string (take dir (sub1 len)))
     79                (->string (last dir))) ) ) )
     80      (else
     81        (sh:error-type 'make-directory-name dir) ) ) ) )
     82
     83(define (document-filename bn)
     84  (filename bn HTML-EXTENSION) )
     85
     86(define (source-filename bn)
     87  (filename bn CHICKEN-SOURCE-EXTENSION) )
    4988
    5089(define (shared-library-filename bn)
     
    5493  (filename bn ##sys#load-dynamic-extension) )
    5594
    56 (define (static-library-filename bn) (filename bn "a"))
    57 
    58 (define (static-filename bn) (filename bn "o"))
    59 
    60 (define (import-filename bn) (filename bn "import"))
     95(define (static-library-filename bn)
     96  (filename bn STATIC-ARCHIVE-EXTENSION) )
     97
     98(define (static-filename bn)
     99  (filename bn OBJECT-BINARY-EXTENSION) )
     100
     101(define (import-filename bn)
     102  (filename bn CHICKEN-IMPORT-EXTENSION) )
    61103
    62104(define (source-import-filename bn)
     
    66108  (shared-filename (import-filename bn)) )
    67109
    68 (define (inline-filename bn) (filename bn "inline"))
     110(define (inline-filename bn)
     111  (filename bn CHICKEN-INLINE-EXTENSION) )
    69112
    70113(define (program-filename bn)
    71  (filename bn (and (eq? 'windows (software-type)) "exe")) )
     114 (filename bn EXECUTABLE-EXTENSION) )
     115
     116(define (make-home-pathname bn)
     117  (make-pathname (installation-chicken-home) bn) )
    72118
    73119(define (make-repository-pathname bn)
     
    76122;; File Support
    77123
     124(define (copy-file-relative fn dn)
     125  ;This subverts the "installation-prefix" relative insurance.
     126  ;(and uses the builtin to-path creation "feature").
     127  (copy-file `(,fn ,fn) dn #t dn) )
     128
     129(define (copy-file-absolute fn dn)
     130  ;Keeps the "installation-prefix" relative insurance.
     131  ;(and uses the builtin to-path creation "feature").
     132  (copy-file `(,fn ,fn) dn) )
     133
    78134(define (copy-file-to-directory fn dn)
    79   (copy-file (list fn fn) dn #t dn) )
     135  (copy-file-relative fn dn) )
    80136
    81137(define (copy-to-repository fn)
    82   (copy-file-to-directory fn (installation-repository-path)) )
     138  (copy-file-relative fn (installation-repository-path)) )
    83139
    84140(define (copy-to-home fn)
    85   (copy-file-to-directory fn (installation-chicken-home)) )
     141  (copy-file-relative fn (installation-chicken-home)) )
    86142
    87143;; Single File Install Support
     
    97153;; SRFI-29 Bundle Support
    98154
    99 (define install-srfi-29-bundle)
    100 (let ((*srfi-29-bundles-directory*
    101         (make-repository-pathname "srfi-29-bundles")))
    102   (define (srfi-29-bundle-directory spec)
    103     (if (null? spec) *srfi-29-bundles-directory*
    104         (make-directory (append (list *srfi-29-bundles-directory*) spec)) ) )
    105   (set! install-srfi-29-bundle
    106     (lambda (nam . spec)
    107       (when (setup-install-mode)
    108         (unless (directory? *srfi-29-bundles-directory*)
    109           (error "missing SRFI-29 bundles directory; please install SRFI-29") )
    110         (let* ((spec (map ->string spec))
    111                (nam (->string nam))
    112                (dir (srfi-29-bundle-directory spec)) )
    113           (copy-file (make-pathname (append '(".") spec) nam)
    114                      (make-pathname dir nam)
    115                      #t) ) ) ) ) )
     155(define (srfi-29-bundles-home)
     156  (make-repository-pathname "srfi-29-bundles") )
     157
     158(define (make-srfi-29-bundle-directory-name spec)
     159  (if (null? spec) (srfi-29-bundles-home)
     160    (make-directory-name
     161      (append (list (srfi-29-bundles-home)) spec)) ) )
     162
     163(define (install-srfi-29-bundle nam . spec)
     164  (when (setup-install-mode)
     165    (unless (directory? (srfi-29-bundles-home))
     166      (error "missing SRFI-29 bundles directory; please install SRFI-29") )
     167    (let* ((spec (map ->string spec))
     168           (nam (->string nam))
     169           (dir (make-srfi-29-bundle-directory-name spec)) )
     170      ;Explicit curdir ('.') because problems in the past.
     171      (copy-file
     172        (make-pathname (append '(".") spec) nam)
     173        (make-pathname dir nam)
     174        #t
     175        dir) ) ) )
    116176
    117177;; Compile Support
    118178
    119 (define cc-path-options
    120   (cond-expand
    121     (macosx    '(-I/opt/local/include -L/opt/local/lib -I/sw/include -L/sw/lib))
    122     (else      '())))
    123 
    124 ; Bad idea to make `-local' the default for a module compile (but not an import compile)
    125 ; since it means something like `fluid-let' cannot be used on an exported binding.
     179#;
     180(define include-path-options
     181  (make-parameter
     182    (cond-expand
     183      (macosx    '(-I/opt/local/include -I/sw/include))
     184      (else      '()))))
     185
     186#;
     187(define library-path-options
     188  (make-parameter
     189    (cond-expand
     190      (macosx    '(-L/opt/local/lib -L/sw/lib))
     191      (else      '()))))
     192
     193;Bad idea to make `-local' the default for a module compile (but not an import
     194;compile) since it means something like `fluid-let' cannot be used on an
     195;exported binding.
    126196
    127197(define default-static-compile-options
  • release/4/setup-helper/trunk/setup-helper.setup

    r20261 r20915  
    77(install-in-home "setup-helper.scm")
    88
    9 (install-extension-tag (extension-name) (extension-version "1.2.0"))
     9(install-extension-tag (extension-name) (extension-version "1.3.0"))
Note: See TracChangeset for help on using the changeset viewer.