From f759815a8cff8aef2ded177de677ce68e0812427 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Tue, 26 May 2009 13:39:32 +0300
Subject: [PATCH] - Ikarus now recognizes IKARUS_FASL_DIRECTORY (and the
 corresponding   fasl-directory parameter) that works as follows:   - if
 IKARUS_FASL_DIRECTORY is set to "", no fasl files are produced.   - if
 IKARUS_FASL_DIRECTORY is set to something other than "", the     string is
 used as a directory in which fasl files are placed.   - if
 IKARUS_FASL_DIRECTORY is unset, the directory     $HOME/.ikarus/precompiled
 is used for fasl output.   - library file names are cannonicalized using
 file-real-path.   - the fasl file (if produced) is the result of     
 (string-append (fasl-directory) (file-real-path filename) ext)     where ext
 is either ".ikarus-32bit-fasl" or ".ikarus-64bit-fasl".

- The old behavior (placing the fasl files in the same place as the
  library files) can be achieved by setting IKARUS_FASL_DIRECTORY='/'.
---
 scheme/ikarus.load.ss  | 38 +++++++++++++++++++++++++++++---------
 scheme/ikarus.posix.ss |  7 ++++++-
 scheme/last-revision   |  2 +-
 scheme/makefile.ss     |  1 +
 4 files changed, 37 insertions(+), 11 deletions(-)

diff --git a/scheme/ikarus.load.ss b/scheme/ikarus.load.ss
index f834755..528e764 100644
--- a/scheme/ikarus.load.ss
+++ b/scheme/ikarus.load.ss
@@ -15,11 +15,11 @@
 
 
 (library (ikarus load)
-  (export load load-r6rs-script)
+  (export load load-r6rs-script fasl-directory)
   (import 
-    (except (ikarus) load load-r6rs-script)
+    (except (ikarus) fasl-directory load load-r6rs-script)
     (only (ikarus.compiler) compile-core-expr)
-    (only (psyntax library-manager) 
+    (only (psyntax library-manager)
       serialize-all current-precompiled-library-loader)
     (only (psyntax expander) compile-r6rs-top-level)
     (only (ikarus.reader.annotated) read-script-source-file))
@@ -31,13 +31,28 @@
       [(<= (fixnum-width) 32) ".ikarus-32bit-fasl"]
       [else                   ".ikarus-64bit-fasl"]))
 
+  (define fasl-directory 
+    (make-parameter 
+      (cond
+        [(getenv "IKARUS_FASL_DIRECTORY")]
+        [(getenv "HOME") =>
+         (lambda (s)
+           (string-append s "/.ikarus/precompiled"))]
+        [else ""])
+      (lambda (s)
+        (if (string? s)
+            s
+            (die 'fasl-directory "not a string" s)))))
+      
   (define (fasl-path filename)
-    (string-append filename fasl-extension))
+    (let ([d (fasl-directory)])
+      (and (not (string=? d ""))
+        (string-append d (file-real-path filename) fasl-extension))))
 
   (define (load-serialized-library filename sk)
     (let ([ikfasl (fasl-path filename)])
       (cond
-        [(not (file-exists? ikfasl)) #f]
+        [(or (not ikfasl) (not (file-exists? ikfasl))) #f]
         [(< (file-mtime ikfasl) (file-mtime filename))
          (fprintf (current-error-port)
             "WARNING: not using fasl file ~s because it is older \
@@ -62,10 +77,15 @@
 
   (define (do-serialize-library filename contents)
     (let ([ikfasl (fasl-path filename)])
-      (fprintf (current-error-port) "Serializing ~s ...\n" ikfasl)
-      (let ([p (open-file-output-port ikfasl (file-options no-fail))])
-        (fasl-write (make-serialized-library contents) p)
-        (close-output-port p))))
+      (cond
+        [(not ikfasl) (void)]
+        [else
+         (fprintf (current-error-port) "Serializing ~s ...\n" ikfasl)
+         (let-values ([(dir name) (split-file-name ikfasl)])
+           (make-directory* dir))
+         (let ([p (open-file-output-port ikfasl (file-options no-fail))])
+           (fasl-write (make-serialized-library contents) p)
+           (close-output-port p))])))
 
   (define load-handler
     (lambda (x)
diff --git a/scheme/ikarus.posix.ss b/scheme/ikarus.posix.ss
index 411090e..b0463c1 100644
--- a/scheme/ikarus.posix.ss
+++ b/scheme/ikarus.posix.ss
@@ -368,7 +368,12 @@
       (die who "not a string" x))
     (let ([v (foreign-call "ikrt_realpath" (string->utf8 x))])
       (cond
-        [(bytevector? v) (utf8->string v)]
+        [(bytevector? v) 
+         (let ([s (utf8->string v)])
+           (when (or (string=? s "")
+                     (not (char=? (string-ref s 0) #\/)))
+             (error who "unexpected value returned from OS" s x))
+           s)]
         [else (raise/strerror who v x)])))
 
   (define (getenv key)
diff --git a/scheme/last-revision b/scheme/last-revision
index f6f1900..6310a81 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1793
+1794
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index cf8fabe..756f00e 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -620,6 +620,7 @@
     [error@fxsub1                                ]
     [fasl-write                                  i]
     [fasl-read                                   i]
+    [fasl-directory                              i]
     [lambda                                      i r ba se ne]
     [and                                         i r ba se ne]
     [begin                                       i r ba se ne]