From 7cf0670a47c4a92b13a0d154685a3dcddfea1947 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Fran=C3=A7ois-Ren=C3=A9=20Rideau?= <fare@tunes.org>
Date: Tue, 26 Sep 2023 02:02:41 -0400
Subject: [PATCH] Fix :std/source (#930)

Add a test for good measure
---
 src/std/source-test.ss | 17 +++++++++++++++++
 src/std/source.ss      | 29 ++++++++++++++++++++++++-----
 src/std/stxutil.ss     |  9 ---------
 3 files changed, 41 insertions(+), 14 deletions(-)
 create mode 100644 src/std/source-test.ss

diff --git a/src/std/source-test.ss b/src/std/source-test.ss
new file mode 100644
index 000000000..5ca63f9a0
--- /dev/null
+++ b/src/std/source-test.ss
@@ -0,0 +1,17 @@
+(export #t)
+(import :std/source
+        :std/test)
+
+(def source-test
+  (test-suite "test :std/source"
+    (test-case "simple tests"
+      (check-equal? (this-source-position) ;; <-- marks the position of this-source-position itself
+                    #x00150007) ;; Line 8 (7 counting from from 0), column 21, in Gambit encoding.
+      (check-equal? (path-strip-directory (this-source-file))
+                    "source-test.ss")
+      (check-equal? (path-directory (this-source-path "blah"))
+                    (path-directory (this-source-file)))
+      (check-equal? (this-source-directory)
+                    (path-directory (this-source-file)))
+      (check-equal? (bytes->string (subu8vector (this-source-content "source-test.ss") 0 11))
+                    "(export #t)"))))
diff --git a/src/std/source.ss b/src/std/source.ss
index 58cd2d3aa..61b4c2278 100644
--- a/src/std/source.ss
+++ b/src/std/source.ss
@@ -1,4 +1,4 @@
-(export #t)
+(export #t (for-syntax #t))
 
 (import (for-syntax :std/stxutil
                     :std/misc/path
@@ -10,6 +10,27 @@
 ;;; The second value is a fixnum, either non-negative (+ (* 65536 column) line),
 ;;; or if the previous formula had overflows, negative file position.
 
+(begin-syntax
+  (def (stx-source-file stx)
+    (alet (loc (stx-source stx))
+      (vector-ref loc 0)))
+
+  (def (stx-source-position stx)
+    (alet (loc (stx-source stx))
+      (vector-ref loc 1)))
+
+  (def (stx-source-directory stx)
+    (alet (file (stx-source-file stx))
+      (path-directory file)))
+
+  (def (stx-source-path stx . relpath)
+    (alet (dir (stx-source-directory stx))
+      (apply subpath dir relpath)))
+
+  (def (stx-source-content stx . relpath)
+    (alet (path (apply stx-source-path stx relpath))
+      (read-file-u8vector path))))
+
 (defsyntax-call (this-source-location ctx)
   (stx-source ctx))
 
@@ -23,9 +44,7 @@
   (stx-source-directory ctx))
 
 (defsyntax-call (this-source-path ctx relpath)
-  (alet (dir (stx-source-directory ctx)) (apply subpath dir relpath)))
+  (stx-source-path ctx relpath))
 
 (defsyntax-call (this-source-content ctx relpath)
-  (alet (dir (stx-source-directory ctx))
-    (alet (path (apply subpath dir ctx relpath))
-      (read-file-u8vector path))))
+  (stx-source-content ctx relpath))
diff --git a/src/std/stxutil.ss b/src/std/stxutil.ss
index 93075a743..9ba32cd9e 100644
--- a/src/std/stxutil.ss
+++ b/src/std/stxutil.ss
@@ -45,12 +45,3 @@
                              (x (maybe-intern-symbol (stringify x)))))
 (def maybe-keywordify (case-lambda ((x) (if (keyword? x) x (maybe-intern-keyword (stringify x))))
                               (x (maybe-intern-keyword (stringify x)))))
-
-(def (stx-source-file stx)
-  (alet (loc (stx-source stx)) (vector-ref loc 0)))
-
-(def (stx-source-position stx)
-  (alet (loc (stx-source stx)) (vector-ref loc 1)))
-
-(def (stx-source-directory stx)
-  (alet (file (stx-source-file stx)) (path-directory file)))