From c583f0305aac662c860b9506637e109519fea489 Mon Sep 17 00:00:00 2001
From: Darcy Shen <da@liii.pro>
Date: Mon, 5 Aug 2024 11:26:18 +0800
Subject: [PATCH] Implement (delete-file string) => unspecified (#16)

---
 goldfish/scheme/boot.scm   |  7 +++++
 src/goldfish.hpp           | 31 +++++++++++++++++----
 tests/scheme/boot-test.scm | 55 ++++++++++++++++++++++++++++++++++++++
 tests/test_all.scm         | 25 +++--------------
 4 files changed, 91 insertions(+), 27 deletions(-)
 create mode 100644 tests/scheme/boot-test.scm

diff --git a/goldfish/scheme/boot.scm b/goldfish/scheme/boot.scm
index bab6ba6..1668c70 100644
--- a/goldfish/scheme/boot.scm
+++ b/goldfish/scheme/boot.scm
@@ -6,6 +6,13 @@
     (g_file-exists? path)
     (error 'wrong-type-arg "(file-exists? path): path should be string")))
 
+(define (delete-file path)
+  (if (not (string? path))
+    (error 'wrong-type-arg "(delete-file path): path should be string")
+    (if (not (file-exists? path))
+      (error 'read-error (string-append path " does not exist"))
+      (g_delete-file path))))
+
 (define-macro (define-library libname . body) ; |(lib name)| -> environment
   `(define ,(symbol (object->string libname))
      (with-let (sublet (unlet)
diff --git a/src/goldfish.hpp b/src/goldfish.hpp
index a6cb109..9000dd5 100644
--- a/src/goldfish.hpp
+++ b/src/goldfish.hpp
@@ -41,6 +41,7 @@ namespace goldfish {
 using std::filesystem::exists;
 using std::filesystem::filesystem_error;
 using std::filesystem::path;
+using std::filesystem::remove;
 
 // Glues for Goldfish
 static s7_pointer
@@ -62,22 +63,42 @@ f_file_exists (s7_scheme* sc, s7_pointer args) {
   return s7_make_boolean (sc, ret);
 }
 
+static s7_pointer
+f_delete_file (s7_scheme* sc, s7_pointer args) {
+  const char* path_c= s7_string (s7_car (args));
+  auto        p     = path (path_c);
+  try {
+    remove (p);
+  } catch (filesystem_error const& ex) {
+    return s7_error (sc, s7_make_symbol (sc, "io-error"),
+                     s7_make_string (sc, ex.what ()));
+  }
+
+  return s7_make_boolean (sc, s7_make_symbol (sc, "<#unspecified>"));
+}
+
 inline void
 glue_goldfish (s7_scheme* sc) {
   s7_pointer cur_env= s7_curlet (sc);
 
-  const char* s_version= "version";
-  const char* d_version= "(version) => string, return the "
-                         "goldfish version";
+  const char* s_version    = "version";
+  const char* d_version    = "(version) => string";
+  const char* s_file_exists= "g_file-exists?";
+  const char* d_file_exists= "(g_file-exists? string) => boolean";
+  const char* s_delete_file= "g_delete-file";
+  const char* d_delete_file= "(g_delete-file string) => <#unspecified>";
+
   s7_define (sc, cur_env, s7_make_symbol (sc, s_version),
              s7_make_typed_function (sc, s_version, f_version, 0, 0, false,
                                      d_version, NULL));
 
-  const char* s_file_exists= "g_file-exists?";
-  const char* d_file_exists= "(g_file-exists? string) => boolean";
   s7_define (sc, cur_env, s7_make_symbol (sc, s_file_exists),
              s7_make_typed_function (sc, s_file_exists, f_file_exists, 1, 0,
                                      false, d_file_exists, NULL));
+
+  s7_define (sc, cur_env, s7_make_symbol (sc, s_delete_file),
+             s7_make_typed_function (sc, s_delete_file, f_delete_file, 1, 0,
+                                     false, d_delete_file, NULL));
 }
 
 // Glues for (scheme time)
diff --git a/tests/scheme/boot-test.scm b/tests/scheme/boot-test.scm
new file mode 100644
index 0000000..82a397a
--- /dev/null
+++ b/tests/scheme/boot-test.scm
@@ -0,0 +1,55 @@
+;
+; Copyright (C) 2024 The Goldfish Scheme Authors
+;
+; Licensed under the Apache License, Version 2.0 (the "License");
+; you may not use this file except in compliance with the License.
+; You may obtain a copy of the License at
+;
+; http://www.apache.org/licenses/LICENSE-2.0
+;
+; Unless required by applicable law or agreed to in writing, software
+; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+; License for the specific language governing permissions and limitations
+; under the License.
+;
+
+(import (srfi srfi-78)
+        (srfi srfi-1)
+        (liii os))
+
+(check-set-mode! 'report-failed)
+
+(when (not (os-windows?))
+  (check (file-exists? "/tmp") => #t)
+  (check (file-exists? "/not_exists") => #f))
+
+(when (os-linux?)
+  (check (file-exists? "/root") => #t)
+  (check
+    (catch 'read-error
+      (lambda () (file-exists? "/root/.bashrc"))
+      (lambda args #t))
+    => #t))
+
+(when (os-windows?)
+  (check (file-exists? "C:") => #t))
+
+
+(when (os-linux?)
+  (check
+    (catch 'io-error
+      (lambda () (delete-file "/root"))
+      (lambda args #t))
+    => #t))
+
+(when (not (os-windows?))
+  (with-output-to-file "/tmp/test_delete_file"
+    (lambda ()
+      (display "Hello, World!")))
+  (check (file-exists? "/tmp/test_delete_file") => #t)
+  (delete-file "/tmp/test_delete_file")
+  (check (file-exists? "/tmp/test_delete_file") => #f))
+
+(check-report)
+(if (check-failed?) (exit -1))
diff --git a/tests/test_all.scm b/tests/test_all.scm
index 26758e0..1e5a901 100644
--- a/tests/test_all.scm
+++ b/tests/test_all.scm
@@ -14,31 +14,12 @@
 ; under the License.
 ;
 
-(import (srfi srfi-78)
-        (srfi srfi-1)
-        (liii os))
-
-(check-set-mode! 'report-failed)
-
-(when (not (os-windows?))
-  (check (file-exists? "/tmp") => #t)
-  (check (file-exists? "/not_exists") => #f))
-
-(when (os-linux?)
-  (check (file-exists? "/root") => #t)
-  (check
-    (catch 'read-error
-      (lambda () (file-exists? "/root/.bashrc"))
-      (lambda args #t))
-    => #t))
-
-(when (os-windows?)
-  (check (file-exists? "C:") => #t))
-
-(check-report)
+(import (liii os)
+        (srfi srfi-1))
 
 (define (all-tests)
   (list
+    "tests/scheme/boot-test.scm"
     "tests/scheme/case-lambda-test.scm"
     "tests/scheme/process-context-test.scm"
     "tests/srfi/srfi-8-test.scm"