mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-05 17:20:18 +02:00
Code Activity

Move R5RS promises implementation to Scheme

Browse source 
* 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).
This commit is contained in:
Andy Wingo 2025-06-17 09:41:33 +02:00
parent 2f95b31ef5
commit 63317ff480
22 changed files with 155 additions and 213 deletions
Download patch file Download diff file Expand all files Collapse all files

1
am/bootstrap.am
View file

@ -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 \

1
libguile.h
View file

@ -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"

4
libguile/Makefile.am
View file

@ -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 \

46
libguile/deprecated.c
View file

@ -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

4
libguile/deprecated.h
View file

@ -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);

2
libguile/init.c
View file

@ -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 */

135
libguile/promises.c
View file

@ -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");
}

53
libguile/promises.h
View file

@ -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 */

2
libguile/scm.h
View file

@ -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

3
module/ice-9/boot-9.scm
View file

@ -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)

13
module/ice-9/deprecated.scm
View file

@ -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)

3
module/ice-9/null.scm
View file

@ -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

74
module/ice-9/promises.scm Normal file
View file

@ -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))

3
module/ice-9/safe-r5rs.scm
View file

@ -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

2
module/ice-9/sandbox.scm
View file

@ -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

1
module/language/bytecode.scm
View file

@ -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

1
module/language/cps/guile-vm/reify-primitives.scm
View file

@ -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)

1
module/language/elisp/parser.scm
View file

@ -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))

8
module/rnrs/r5rs.scm
View file

@ -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
delay force)
quotient remainder modulo)
(only (ice-9 promises) delay force)
(only (ice-9 r5rs) scheme-report-environment)
(only (ice-9 safe-r5rs) null-environment)))

3
test-suite/tests/00-initial-env.test
View file

@ -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

1
test-suite/tests/eval.test
View file

@ -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))

7
test-suite/tests/r4rs.test
View file

@ -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 (test-suite guile-test))
#:use-module (ice-9 promises)
#:use-module (test-suite lib)
#:use-module (test-suite guile-test))
;;;; ============= NOTE =============