`include' relative to current file

[Andy Wingo]

Thoughts on this patch?  It fixes SLIB in CVS, which now does an
(include "guile-2.init") in the Guile 2.x case.

To test, check out Slib from CVS, then (load
"/path/to/slib/guile.init").

Andy

>From 856d0ef6e7a5236da36c2fae13271e643580507d Mon Sep 17 00:00:00 2001
From: Andy Wingo <address@hidden>
Date: Sun, 20 Jan 2013 20:26:59 +0100
Subject: [PATCH] `include' relative paths relative to including file

* module/ice-9/psyntax.scm (include): Like `load', interpret relative
  paths as being relative to the file that does the `include'.
---
 module/ice-9/psyntax.scm |   25 +++++++++++++++++--------
 1 file changed, 17 insertions(+), 8 deletions(-)

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6c264a6..d41a0eb 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,7 +1,7 @@
 ;;;; -*-scheme-*-
 ;;;;
 ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011,
-;;;;   2012 Free Software Foundation, Inc.
+;;;;   2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -2935,9 +2935,15 @@
 
 (define-syntax include
   (lambda (x)
+    (define (absolute-path? path)
+      (string-prefix? "/" path))
+
     (define read-file
-      (lambda (fn k)
-        (let ((p (open-input-file fn)))
+      (lambda (fn dir k)
+        (let ((p (open-input-file
+                  (if (absolute-path? fn)
+                      fn
+                      (in-vicinity dir fn)))))
           (let f ((x (read p))
                   (result '()))
             (if (eof-object? x)
@@ -2946,11 +2952,14 @@
                   (reverse result))
                 (f (read p)
                    (cons (datum->syntax k x) result)))))))
-    (syntax-case x ()
-      ((k filename)
-       (let ((fn (syntax->datum #'filename)))
-         (with-syntax (((exp ...) (read-file fn #'filename)))
-           #'(begin exp ...)))))))
+    (let* ((src (syntax-source x))
+           (file (and src (assq-ref src 'filename)))
+           (dir (and (string? file) (dirname file))))
+      (syntax-case x ()
+        ((k filename)
+         (let ((fn (syntax->datum #'filename)))
+           (with-syntax (((exp ...) (read-file fn dir #'filename)))
+             #'(begin exp ...))))))))
 
 (define-syntax include-from-path
   (lambda (x)
-- 
1.7.10.4

-- 
http://wingolog.org/