← Back to branch summary

~ubuntu-branches/ubuntu/feisty/libctl/feisty

« back to all changes in this revision

Viewing changes to base/include.scm

  • Committer: Bazaar Package Importer
  • Author(s): Josselin Mouette
  • Date: 2002-04-17 10:36:45 UTC
  • Revision ID: james.westby@ubuntu.com-20020417103645-29vomjspk4yf4olw
Tags: upstream-2.1
Import upstream version 2.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
base/include.scm
 
1
; libctl: flexible Guile-based control files for scientific software 
 
2
; Copyright (C) 1998, 1999, 2000, 2001, 2002, Steven G. Johnson
 
3
;
 
4
; This library is free software; you can redistribute it and/or
 
5
; modify it under the terms of the GNU Lesser General Public
 
6
; License as published by the Free Software Foundation; either
 
7
; version 2 of the License, or (at your option) any later version.
 
8
;
 
9
; This library is distributed in the hope that it will be useful,
 
10
; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
12
; Lesser General Public License for more details.
 
13
; 
 
14
; You should have received a copy of the GNU Lesser General Public
 
15
; License along with this library; if not, write to the
 
16
; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 
17
; Boston, MA  02111-1307, USA.
 
18
;
 
19
; Steven G. Johnson can be contacted at stevenj@alum.mit.edu.
 
20
 
 
21
; ****************************************************************
 
22
; File inclusion.
 
23
 
 
24
; Here, we supply an (include "<filename>") utility that is similar to
 
25
; C's #include "<filename>".  We need this because Guile's load
 
26
; function is broken--it doesn't allow you to use relative paths.  If
 
27
; you use (load "<filename>"), the filename is interpreted relative to
 
28
; the path of the top-level Guile invocation, which may not be the
 
29
; same as the path of the current Scheme file.  Our include function
 
30
; remembers the path of the current file and loads relative to this.
 
31
 
 
32
(define (string-suffix? suff s)
 
33
  (if (> (string-length suff) (string-length s))
 
34
      #f
 
35
      (string=? suff (substring s (- (string-length s)
 
36
                                     (string-length suff))
 
37
                                (string-length s)))))
 
38
 
 
39
(define (string-find-previous-char s c)
 
40
  (if (= (string-length s) 0)
 
41
      #f
 
42
      (let ((last-index (- (string-length s) 1)))
 
43
        (if (eq? (string-ref s last-index) c)
 
44
            last-index
 
45
            (string-find-previous-char (substring s 0 last-index) c)))))
 
46
 
 
47
(define (strip-trailing-slashes s)
 
48
  (if (string-suffix? "/" s)
 
49
      (strip-trailing-slashes (substring s 0 (- (string-length s) 1)))
 
50
      s))
 
51
 
 
52
(define (pathname-absolute? s)
 
53
  (and (> (string-length s) 0) (eq? (string-ref s 0) #\/)))
 
54
 
 
55
(define (split-pathname s)
 
56
  (let ((s2 (strip-trailing-slashes s)))
 
57
    (let ((last-slash (string-find-previous-char s2 #\/)))
 
58
      (if (not last-slash)
 
59
          (cons "" s2)
 
60
          (cons (substring s2 0 (+ 1 last-slash))
 
61
                (substring s2 (+ 1 last-slash) (string-length s2)))))))
 
62
 
 
63
(define include-dir "")
 
64
 
 
65
(define (include pathname)
 
66
  (let ((save-include-dir include-dir)
 
67
        (pathpair (split-pathname pathname)))
 
68
    (if (pathname-absolute? (car pathpair))
 
69
        (begin
 
70
          (set! include-dir (car pathpair))
 
71
          (load pathname))
 
72
        (begin
 
73
          (set! include-dir (string-append include-dir (car pathpair)))
 
74
          (load (string-append include-dir (cdr pathpair)))))
 
75
    (set! include-dir save-include-dir)))
 
76
 
 
77
(define (fix-path pathname)
 
78
  (if (pathname-absolute? pathname)
 
79
      pathname
 
80
      (string-append include-dir pathname)))
 
81
 
 
82
; ****************************************************************