From 2adc9cb85d2e8f97f20a3346d7c2f454ea214ea7 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 3 Jan 2009 20:36:53 -0500
Subject: [PATCH] Applied patch for "make-hard-link".  Thanks to Andreas
 Rottmann.

---
 scheme/ikarus.posix.ss | 31 +++++++++++++++++++------------
 scheme/last-revision   |  2 +-
 scheme/makefile.ss     |  1 +
 src/ikarus-runtime.c   |  8 ++++++++
 4 files changed, 29 insertions(+), 13 deletions(-)

diff --git a/scheme/ikarus.posix.ss b/scheme/ikarus.posix.ss
index 7821ab4..db8fd04 100644
--- a/scheme/ikarus.posix.ss
+++ b/scheme/ikarus.posix.ss
@@ -21,7 +21,7 @@
     nanosleep getenv setenv unsetenv env environ file-ctime file-mtime
     current-directory file-regular? file-directory? file-readable?
     file-writable? file-executable? file-size rename-file
-    file-symbolic-link? make-symbolic-link directory-list
+    file-symbolic-link? make-symbolic-link make-hard-link directory-list
     make-directory delete-directory change-mode kill strerror
     wstatus-pid wstatus-exit-status wstatus-received-signal)
 
@@ -32,7 +32,7 @@
       delete-file getenv setenv unsetenv env environ file-ctime file-mtime
       current-directory file-regular? file-directory?
       file-readable? file-writable? file-executable? file-size
-      rename-file file-symbolic-link? make-symbolic-link
+      rename-file file-symbolic-link? make-symbolic-link make-hard-link
       directory-list make-directory delete-directory change-mode
       kill strerror wstatus-pid wstatus-exit-status
       wstatus-received-signal))
@@ -278,16 +278,23 @@
         (unless (eq? r #t)
           (raise/strerror who r path)))))
   
-  (define make-symbolic-link
-    (lambda (to path)
-      (define who 'make-symbolic-link)
-      (unless (and (string? to) (string? path))
-        (die who "not a string" (if (string? to) path to)))
-      (let ([r (foreign-call "ikrt_symlink" 
-                 (string->utf8 to) (string->utf8 path))])
-        (unless (eq? r #t)
-          (raise/strerror who r path)))))
-
+  (define ($make-link to path who proc)
+    (unless (and (string? to) (string? path))
+      (die who "not a string" (if (string? to) path to)))
+    (let ([r (proc (string->utf8 to) (string->utf8 path))])
+      (unless (eq? r #t)
+        (raise/strerror who r path))))
+  
+  (define (make-symbolic-link to path)
+    ($make-link to path 'make-symbolic-link
+                (lambda (u-to u-path)
+                  (foreign-call "ikrt_symlink" u-to u-path))))
+  
+  (define (make-hard-link to path)
+    ($make-link to path 'make-hard-link
+                (lambda (u-to u-path)
+                  (foreign-call "ikrt_link" u-to u-path))))
+  
   (define ($file-time x who proc)
     (unless (string? x) 
       (die who "not a string" x))
diff --git a/scheme/last-revision b/scheme/last-revision
index e6a6560..46c3a05 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1739
+1740
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 9c0716d..af7370a 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -1273,6 +1273,7 @@
     [delete-directory                            i]
     [change-mode                                 i]
     [make-symbolic-link                          i]
+    [make-hard-link                              i]
     [file-ctime                                  i]
     [file-mtime                                  i]
     [file-size                                   i]
diff --git a/src/ikarus-runtime.c b/src/ikarus-runtime.c
index ce0a633..f6bffe9 100644
--- a/src/ikarus-runtime.c
+++ b/src/ikarus-runtime.c
@@ -679,6 +679,14 @@ ikrt_symlink(ikptr to, ikptr path /*, ikpcb* pcb */){
   return ik_errno_to_code();
 }
 
+ikptr
+ikrt_link(ikptr to, ikptr path /*, ikpcb* pcb */){
+  int r = link((char*)(to+off_bytevector_data), (char*)(path+off_bytevector_data));
+  if(r == 0){
+    return true_object;
+  }
+  return ik_errno_to_code();
+}
 
 ikptr 
 ik_system(ikptr str){