Move R5RS promises implementation to Scheme

* am/bootstrap.am (SOURCES):
* module/ice-9/promises.scm: New file.
* libguile/promises.h:
* libguile/promises.c: Delete.
* libguile/deprecated.h:
* libguile/deprecated.c: Add promises shims.
* libguile/init.c:
* libguile/Makefile.am:
* libguile.h: Remove promises mentions.
* module/ice-9/deprecated.scm: Add shims to include promises in the
default environment.
* module/ice-9/null.scm:
* module/ice-9/safe-r5rs.scm:
* module/ice-9/sandbox.scm:
* module/language/bytecode.scm:
* module/language/cps/guile-vm/reify-primitives.scm:
* module/language/elisp/parser.scm:
* module/rnrs/r5rs.scm:
* test-suite/tests/00-initial-env.test:
* test-suite/tests/eval.test:
* test-suite/tests/r4rs.test: Import (ice-9 promises).

am/bootstrap.am

@@ -175,6 +175,7 @@ SOURCES =					\
   ice-9/ports.scm				\
   ice-9/posix.scm				\
   ice-9/pretty-print.scm			\
+  ice-9/promises.scm				\
   ice-9/q.scm					\
   ice-9/r5rs.scm				\
   ice-9/rdelim.scm				\

libguile.h

@@ -80,7 +80,6 @@ extern "C" {
 #include "libguile/posix.h"
 #include "libguile/print.h"
 #include "libguile/procprop.h"
-#include "libguile/promises.h"
 #include "libguile/procs.h"
 #include "libguile/r6rs-ports.h"
 #include "libguile/random.h"

libguile/Makefile.am

@@ -201,7 +201,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =				\
 	procprop.c				\
 	procs.c					\
 	programs.c				\
-	promises.c				\
 	r6rs-ports.c				\
 	random.c				\
 	rdelim.c				\
@@ -307,7 +306,6 @@ DOT_X_FILES =					\
 	procprop.x				\
 	procs.x					\
 	programs.x				\
-	promises.x				\
 	r6rs-ports.x				\
 	random.x				\
 	rdelim.x				\
@@ -400,7 +398,6 @@ DOT_DOC_FILES = 				\
 	print.doc				\
 	procprop.doc				\
 	procs.doc				\
-	promises.doc				\
 	r6rs-ports.doc				\
 	random.doc				\
 	rdelim.doc				\
@@ -651,7 +648,6 @@ modinclude_HEADERS =				\
 	print.h					\
 	procprop.h				\
 	procs.h					\
-	promises.h				\
 	pthread-threads.h			\
 	r6rs-ports.h				\
 	random.h				\

libguile/deprecated.c

@@ -641,6 +641,52 @@ scm_get_print_state (SCM port)
   return SCM_BOOL_F;
 }
 
+
+
+static SCM make_promise_var;
+static SCM force_var;
+static SCM promise_p_var;
+
+static void
+init_promise_vars (void)
+{
+  make_promise_var = scm_c_public_lookup ("ice-9 promises", "make-promise");
+  force_var = scm_c_public_lookup ("ice-9 promises", "force");
+  promise_p_var = scm_c_public_lookup ("ice-9 promises", "promise?");
+}
+
+static void
+init_promise_functions (void)
+{
+  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+  scm_c_issue_deprecation_warning
+    ("Using the SCM promise functions from C is deprecated.  Invoke"
+     "force, etc. from (ice-9 promises) or (srfi srfi-45) instead.");
+  scm_i_pthread_once (&once, init_promise_vars);
+}
+
+SCM
+scm_make_promise (SCM thunk)
+{
+  init_promise_functions ();
+  return scm_call_1 (scm_variable_ref (make_promise_var), thunk);
+}
+
+SCM
+scm_promise_p (SCM x)
+{
+  init_promise_functions ();
+  return scm_call_1 (scm_variable_ref (promise_p_var), x);
+}
+
+SCM
+scm_force (SCM promise)
+{
+  init_promise_functions ();
+  return scm_call_1 (scm_variable_ref (force_var), promise);
+}
+
+
 
 
 void

libguile/deprecated.h

@@ -109,6 +109,10 @@ SCM_DEPRECATED SCM scm_get_print_state (SCM port);
 #define SCM_COERCE_OUTPORT(p) (scm_coerce_outport (p))
 #define SCM_VALIDATE_OPORT_VALUE(pos, port) SCM_VALIDATE_OPOUTPORT(pos, port)
 
+SCM_DEPRECATED SCM scm_make_promise (SCM thunk);
+SCM_DEPRECATED SCM scm_force (SCM x);
+SCM_DEPRECATED SCM scm_promise_p (SCM x);
+
 /* Deprecated declarations go here.  */
 
 void scm_i_init_deprecated (void);

libguile/init.c

@@ -106,7 +106,6 @@
 #include "procprop.h"
 #include "procs.h"
 #include "programs.h"
-#include "promises.h"
 #ifdef ENABLE_REGEX
 #include "regex-posix.h"
 #endif
@@ -393,7 +392,6 @@ scm_i_init_guile (struct gc_stack_addr base)
   scm_init_hash ();
   scm_init_hashtab ();
   scm_init_deprecation ();
-  scm_init_promises ();         /* requires smob_prehistory */
   scm_init_stime ();
   scm_init_gc ();		/* Requires hooks and `get_internal_run_time' */
   scm_init_gc_protect_object ();  /* requires threads_prehistory */

libguile/promises.c

@@ -1,135 +0,0 @@
-/* Copyright 1995-2011,2018,2025
-     Free Software Foundation, Inc.
-
-   This file is part of Guile.
-
-   Guile is free software: you can redistribute it and/or modify it
-   under the terms of the GNU Lesser General Public License as published
-   by the Free Software Foundation, either version 3 of the License, or
-   (at your option) any later version.
-
-   Guile is distributed in the hope that it will be useful, but WITHOUT
-   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
-   License for more details.
-
-   You should have received a copy of the GNU Lesser General Public
-   License along with Guile.  If not, see
-   <https://www.gnu.org/licenses/>.  */
-
-
-
-#ifdef HAVE_CONFIG_H
-#  include <config.h>
-#endif
-
-#include <alloca.h>
-
-#include "alist.h"
-#include "async.h"
-#include "continuations.h"
-#include "debug.h"
-#include "deprecation.h"
-#include "dynwind.h"
-#include "eq.h"
-#include "eval.h"
-#include "feature.h"
-#include "fluids.h"
-#include "goops.h"
-#include "gsubr.h"
-#include "hash.h"
-#include "hashtab.h"
-#include "list.h"
-#include "macros.h"
-#include "memoize.h"
-#include "modules.h"
-#include "ports.h"
-#include "print.h"
-#include "procprop.h"
-#include "procs.h"
-#include "programs.h"
-#include "smob.h"
-#include "stackchk.h"
-#include "strings.h"
-#include "threads.h"
-#include "throw.h"
-#include "values.h"
-
-#include "promises.h"
-
-
-
-
-scm_t_bits scm_tc16_promise;
-
-SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, 
-	    (SCM thunk),
-	    "Create a new promise object.\n\n"
-            "@code{make-promise} is a procedural form of @code{delay}.\n"
-            "These two expressions are equivalent:\n"
-            "@lisp\n"
-	    "(delay @var{exp})\n"
-	    "(make-promise (lambda () @var{exp}))\n"
-            "@end lisp\n")
-#define FUNC_NAME s_scm_make_promise
-{
-  SCM_VALIDATE_THUNK (1, thunk);
-  SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
-		       SCM_UNPACK (thunk),
-		       SCM_UNPACK (scm_make_recursive_mutex ()));
-}
-#undef FUNC_NAME
-
-static int 
-promise_print (SCM exp, SCM port, scm_print_state *pstate)
-{
-  scm_puts ("#<promise ", port);
-  scm_write (SCM_PROMISE_DATA (exp), port);
-  scm_putc ('>', port);
-  return !0;
-}
-
-SCM_DEFINE (scm_force, "force", 1, 0, 0, 
-	    (SCM promise),
-	    "If @var{promise} has not been computed yet, compute and\n"
-	    "return @var{promise}, otherwise just return the previously computed\n"
-	    "value.")
-#define FUNC_NAME s_scm_force
-{
-  SCM_VALIDATE_SMOB (1, promise, promise);
-  scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
-  if (!SCM_PROMISE_COMPUTED_P (promise))
-    {
-      SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
-      if (!SCM_PROMISE_COMPUTED_P (promise))
-	{
-	  SCM_SET_PROMISE_DATA (promise, ans);
-	  SCM_SET_PROMISE_COMPUTED (promise);
-	}
-    }
-  scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
-  return SCM_PROMISE_DATA (promise);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0, 
-            (SCM obj),
-	    "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
-	    "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
-#define FUNC_NAME s_scm_promise_p
-{
-  return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
-}
-#undef FUNC_NAME
-
-void 
-scm_init_promises ()
-{
-  scm_tc16_promise = scm_make_smob_type ("promise", 0);
-  scm_set_smob_print (scm_tc16_promise, promise_print);
-
-#include "promises.x"
-
-  scm_add_feature ("delay");
-}

libguile/promises.h

@@ -1,53 +0,0 @@
-#ifndef SCM_PROMISES_H
-#define SCM_PROMISES_H
-
-/* Copyright 1995-1996,1998-2004,2008-2009,2018
-     Free Software Foundation, Inc.
-
-   This file is part of Guile.
-
-   Guile is free software: you can redistribute it and/or modify it
-   under the terms of the GNU Lesser General Public License as published
-   by the Free Software Foundation, either version 3 of the License, or
-   (at your option) any later version.
-
-   Guile is distributed in the hope that it will be useful, but WITHOUT
-   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
-   License for more details.
-
-   You should have received a copy of the GNU Lesser General Public
-   License along with Guile.  If not, see
-   <https://www.gnu.org/licenses/>.  */
-
-
-
-#include "libguile/smob.h"
-
-
-
-/* {Promises}
- */
-
-#define SCM_F_PROMISE_COMPUTED (1L << 0)
-#define SCM_PROMISE_COMPUTED_P(promise) \
-  (SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
-#define SCM_SET_PROMISE_COMPUTED(promise) \
-  SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
-#define SCM_PROMISE_MUTEX     SCM_SMOB_OBJECT_2
-#define SCM_PROMISE_DATA      SCM_SMOB_OBJECT
-#define SCM_SET_PROMISE_DATA  SCM_SET_SMOB_OBJECT
-
-
-SCM_API scm_t_bits scm_tc16_promise;
-
-
-
-SCM_API SCM scm_make_promise (SCM thunk);
-SCM_API SCM scm_force (SCM x);
-SCM_API SCM scm_promise_p (SCM x);
-
-SCM_INTERNAL void scm_init_promises (void);
-
-
-#endif  /* SCM_PROMISES_H */

libguile/scm.h

@@ -515,8 +515,6 @@ typedef uintptr_t scm_t_bits;
 #define scm_tc16_directory		0x047f
 #define scm_tc16_syntax_transformer	0x057f
 /*
-#define scm_tc16_malloc			0x0b7f
-#define scm_tc16_port_with_print_state	0x0d7f
 #define scm_tc16_promise		0x0e7f
 #define scm_tc16_random_state		0x0f7f
 #define scm_tc16_regexp			0x107f

module/ice-9/boot-9.scm

@@ -661,9 +661,6 @@ If returning early, return the return value of F."
                  (set! dummy #f)  ; blackhole dummy
                  v))))))))
 
-(define-syntax-rule (delay exp)
-  (make-promise (lambda () exp)))
-
 (define-syntax with-fluids
   (lambda (stx)
     (define (emit-with-fluids bindings body)

module/ice-9/deprecated.scm

@@ -23,6 +23,7 @@
   #:use-module (ice-9 weak-tables)
   #:use-module (ice-9 arrays)
   #:use-module (ice-9 scm-style-repl)
+  #:use-module (ice-9 promises)
   #:use-module (system repl hooks)
   #:use-module (system repl reader)
   #:use-module (srfi srfi-14)
@@ -134,7 +135,11 @@
             (reset-hook!* . reset-hook!)
             (run-hook* . run-hook)
             (hook->list* . hook->list)
-            module-defined-hook))
+            module-defined-hook
+            (make-promise* . make-promise)
+            (promise? . promise?)
+            (delay* . delay)
+            (force* . force)))
 
 (define-syntax define-deprecated/stx
   (lambda (stx)
@@ -374,3 +379,9 @@
    (lambda (m)
      (run-hook module-defined-hook m)
      (prev m))))
+
+(define-deprecated-trampolines (ice-9 promises)
+  (promise? x)
+  (make-promise thunk)
+  (force promise))
+(define-deprecated*/stx (ice-9 promises) delay)

module/ice-9/null.scm

@@ -1,4 +1,4 @@
-;;;; 	Copyright (C) 2000, 2001, 2006, 2019 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2000, 2001, 2006, 2019, 2025 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
@@ -18,6 +18,7 @@
 ;;;; The null environment - only syntactic bindings
 
 (define-module (ice-9 null)
+  #:use-module (ice-9 promises)
   #:re-export-syntax (define quote lambda if set!
 
 		       cond case => _ ... else

module/ice-9/promises.scm

@@ -0,0 +1,74 @@
+;;; Copyright (C) 2025 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 License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;;
+;;; Code:
+
+
+(define-module (ice-9 promises)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 threads)
+  ;; FIXME: #:export instead of #:replace when deprecated code removed
+  #:replace (make-promise
+             force
+             delay
+             promise?))
+
+(define-record-type <promise>
+  (%make-promise computed? data lock)
+  %promise?
+  (computed? promise-computed? set-promise-computed?!)
+  (data promise-data set-promise-data!)
+  (lock promise-lock))
+
+(define (make-promise thunk)
+  	    
+  "Create a new promise object.
+
+@code{make-promise} is a procedural form of @code{delay}.
+
+These two expressions are equivalent:
+@lisp
+(delay @var{exp})
+(make-promise (lambda () @var{exp}))
+@end lisp"
+  (%make-promise #f thunk (make-recursive-mutex)))
+
+(define-syntax-rule (delay exp)
+  (make-promise (lambda () exp)))
+
+(define (force promise)
+  "If @var{promise} has not been computed yet, compute and return
+@var{promise}, otherwise just return the previously computed value."
+  (with-mutex (promise-lock promise)
+    (if (promise-computed? promise)
+        (promise-data promise)
+        (let* ((thunk (promise-data promise))
+               (ans (thunk)))
+          (if (promise-computed? promise)
+              (promise-data promise)
+              (begin
+                (set-promise-computed?! promise #t)
+                (set-promise-data! promise ans)
+                ans))))))
+
+(define (promise? x)
+  "Return true if @var{obj} is a promise, i.e. a delayed
+computation (@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report
+on Scheme})."
+  (%promise? x))

module/ice-9/safe-r5rs.scm

@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2000-2001,2004,2006,2008-2010,2019
+;;;; Copyright (C) 2000-2001,2004,2006,2008-2010,2019,2025
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -24,6 +24,7 @@
   #:use-module (ice-9 ports)
   #:use-module ((guile) #:select ((_ . ^_)
                                   (... . ^...)))
+  #:use-module (ice-9 promises)
   #:re-export (quote
                quasiquote
                unquote unquote-splicing

module/ice-9/sandbox.scm

@@ -1257,7 +1257,7 @@ allocation limit is exceeded, an exception will be thrown to the
      vector-set!)))
 
 (define promise-bindings
-  '(((guile)
+  '(((ice-9 promises)
      force
      delay
      make-promise

module/language/bytecode.scm

@@ -20,6 +20,7 @@
 
 (define-module (language bytecode)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 promises)
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export (instruction-list
             builtin-name->index

module/language/cps/guile-vm/reify-primitives.scm

@@ -26,6 +26,7 @@
 
 (define-module (language cps guile-vm reify-primitives)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 promises)
   #:use-module ((language tree-il primitives)
                 #:select ((primitive-module . tree-il:primitive-module)))
   #:use-module (language cps)

module/language/elisp/parser.scm

@@ -20,6 +20,7 @@
 
 (define-module (language elisp parser)
   #:use-module (ice-9 source-properties)
+  #:use-module (ice-9 promises)
   #:use-module (language elisp lexer)
   #:export (read-elisp))
 

module/rnrs/r5rs.scm

@@ -1,6 +1,6 @@
 ;;; r5rs.scm --- The R6RS / R5RS compatibility library
 
-;;      Copyright (C) 2010 Free Software Foundation, Inc.
+;;      Copyright (C) 2010, 2025 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
@@ -26,9 +26,7 @@
 
 	  null-environment scheme-report-environment)
   (import (only (guile) exact->inexact inexact->exact
-			
+			quotient remainder modulo)
-			quotient remainder modulo
+          (only (ice-9 promises) delay force)
-			
-			delay force)
           (only (ice-9 r5rs) scheme-report-environment)
           (only (ice-9 safe-r5rs) null-environment)))

test-suite/tests/00-initial-env.test

@@ -1,6 +1,6 @@
 ;;;; 00-initial-env.test --- Roots.      -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2010, 2025 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
@@ -17,6 +17,7 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (the-initial-env)
+  #:use-module (ice-9 promises)
   #:use-module (test-suite lib))
 
 ;;; A set of tests to run early.  The file name is to have `check-guile' pick

test-suite/tests/eval.test

@@ -24,6 +24,7 @@
   :use-module (ice-9 documentation)
   :use-module (ice-9 exceptions)
   :use-module (ice-9 guardians)
+  :use-module (ice-9 promises)
   :use-module (ice-9 local-eval))
 
 

test-suite/tests/r4rs.test

@@ -1,5 +1,5 @@
 ;;;; r4rs.test --- tests for R4RS compliance      -*- scheme -*-
-;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006, 2023 Free Software Foundation, Inc.
+;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 2006, 2023, 2025 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
@@ -16,8 +16,9 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-suite test-r4rs)
-  :use-module (test-suite lib)
+  #:use-module (ice-9 promises)
-  :use-module (test-suite guile-test))
+  #:use-module (test-suite lib)
+  #:use-module (test-suite guile-test))
 
 
 ;;;; ============= NOTE =============