diff --git a/libguile/eq.c b/libguile/eq.c index f85ad43d7..bbcd158d4 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -393,6 +393,7 @@ scm_equal_p (SCM x, SCM y) case scm_tc16_continuation: case scm_tc16_directory: case scm_tc16_syntax_transformer: + case scm_tc16_random_state: return SCM_BOOL_F; default: abort (); diff --git a/libguile/goops.c b/libguile/goops.c index c8d504bab..5825c3732 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -142,6 +142,8 @@ static SCM class_condition_variable; static SCM class_mutex; static SCM class_continuation; static SCM class_directory; +static SCM class_macro; +static SCM class_random_state; static struct scm_ephemeron_table *vtable_class_map; static SCM pre_goops_vtables = SCM_EOL; @@ -352,7 +354,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc16_directory: return class_directory; case scm_tc16_syntax_transformer: - return class_unknown; + return class_macro; + case scm_tc16_random_state: + return class_random_state; default: abort (); } @@ -992,6 +996,8 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_mutex = scm_variable_ref (scm_c_lookup ("")); class_continuation = scm_variable_ref (scm_c_lookup ("")); class_directory = scm_variable_ref (scm_c_lookup ("")); + class_macro = scm_variable_ref (scm_c_lookup ("")); + class_random_state = scm_variable_ref (scm_c_lookup ("")); create_smob_classes (); create_struct_classes (); diff --git a/libguile/print.c b/libguile/print.c index 729d3de01..45d8c9d00 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -755,6 +755,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc16_syntax_transformer: scm_i_print_syntax_transformer (exp, port, pstate); break; + case scm_tc16_random_state: + scm_puts ("#', port); + break; default: abort (); } diff --git a/libguile/random.c b/libguile/random.c index 2bd34a1a0..58b0496ec 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -46,7 +46,6 @@ #include "numbers.h" #include "numbers.h" #include "pairs.h" -#include "smob.h" #include "srfi-4.h" #include "stime.h" #include "strings.h" @@ -185,6 +184,7 @@ scm_c_make_rstate (const char *seed, int n) state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size, "random-state"); + state->tag = scm_tc16_random_state; state->rng = &scm_the_rng; state->normal_next = 0.0; state->rng->init_rstate (state, seed, n); @@ -198,6 +198,7 @@ scm_c_rstate_from_datum (SCM datum) state = scm_gc_malloc_pointerless (scm_the_rng.rstate_size, "random-state"); + state->tag = scm_tc16_random_state; state->rng = &scm_the_rng; state->normal_next = 0.0; state->rng->from_datum (state, datum); @@ -255,7 +256,7 @@ scm_c_exp1 (scm_t_rstate *state) return - log (scm_c_uniform01 (state)); } -unsigned char scm_masktab[256]; +static unsigned char scm_masktab[256]; static inline uint32_t scm_i_mask32 (uint32_t m) @@ -371,19 +372,6 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) return ret; } -/* - * Scheme level representation of random states. - */ - -scm_t_bits scm_tc16_rstate; - -static SCM -make_rstate (scm_t_rstate *state) -{ - SCM_RETURN_NEWSMOB (scm_tc16_rstate, state); -} - - /* * Scheme level interface. */ @@ -444,7 +432,8 @@ SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0, if (SCM_UNBNDP (state)) state = SCM_VARIABLE_REF (scm_var_random_state); SCM_VALIDATE_RSTATE (1, state); - return make_rstate (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE (state))); + return scm_from_random_state + (SCM_RSTATE (state)->rng->copy_rstate (SCM_RSTATE (state))); } #undef FUNC_NAME @@ -478,7 +467,7 @@ SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0, SCM_OUT_OF_RANGE (1, seed); } - res = make_rstate (scm_c_make_rstate (c_str, len)); + res = scm_from_random_state (scm_c_make_rstate (c_str, len)); free (c_str); scm_remember_upto_here_1 (seed); @@ -493,7 +482,7 @@ SCM_DEFINE (scm_datum_to_random_state, "datum->random-state", 1, 0, 0, "been obtained from @code{random-state->datum}.") #define FUNC_NAME s_scm_datum_to_random_state { - return make_rstate (scm_c_rstate_from_datum (datum)); + return scm_from_random_state (scm_c_rstate_from_datum (datum)); } #undef FUNC_NAME @@ -759,7 +748,7 @@ random_state_of_last_resort (void) buf[i] = scm_to_int (scm_logand (seed, SCM_I_MAKINUM (255))); seed = scm_ash (seed, SCM_I_MAKINUM (-8)); } - state = make_rstate (scm_c_make_rstate ((char *) buf, len)); + state = scm_from_random_state (scm_c_make_rstate ((char *) buf, len)); free (buf); } return state; @@ -807,7 +796,7 @@ source of entropy, appropriate for use in non-security-critical applications.") { unsigned char buf[32]; if (read_dev_urandom (buf, sizeof(buf))) - return make_rstate (scm_c_make_rstate ((char *) buf, sizeof(buf))); + return scm_from_random_state (scm_c_make_rstate ((char *) buf, sizeof(buf))); else return random_state_of_last_resort (); } @@ -829,8 +818,6 @@ scm_init_random () }; scm_the_rng = rng; - scm_tc16_rstate = scm_make_smob_type ("random-state", 0); - for (m = 1; m <= 0x100; m <<= 1) for (i = m >> 1; i < m; ++i) scm_masktab[i] = m - 1; diff --git a/libguile/random.h b/libguile/random.h index e3bb321c3..9994cc82b 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -1,7 +1,7 @@ #ifndef SCM_RANDOM_H #define SCM_RANDOM_H -/* Copyright 1999-2001,2006,2008,2010,2018 +/* Copyright 1999-2001,2006,2008,2010,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -38,6 +38,7 @@ */ typedef struct scm_t_rstate { + scm_t_bits tag; struct scm_t_rng *rng; double normal_next; /* For scm_c_normal01 */ /* Custom fields follow here */ @@ -73,15 +74,32 @@ SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m); /* * Scheme level interface */ -SCM_API scm_t_bits scm_tc16_rstate; -#define SCM_RSTATEP(obj) SCM_SMOB_PREDICATE (scm_tc16_rstate, obj) -#define SCM_RSTATE(obj) ((scm_t_rstate *) SCM_SMOB_DATA (obj)) +static inline int +scm_is_random_state (SCM x) +{ + return SCM_HAS_TYP16 (x, scm_tc16_random_state); +} + +static inline struct scm_t_rstate * +scm_to_random_state (SCM x) +{ + if (!scm_is_random_state (x)) + abort (); + return (struct scm_t_rstate *) SCM_UNPACK_POINTER (x); +} + +static inline SCM +scm_from_random_state (struct scm_t_rstate *x) +{ + return SCM_PACK_POINTER (x); +} + +#define SCM_RSTATEP(obj) scm_is_random_state (obj) +#define SCM_RSTATE(obj) scm_to_random_state (obj) #define SCM_VALIDATE_RSTATE(pos, v) \ SCM_MAKE_VALIDATE_MSG (pos, v, RSTATEP, "random-generator-state") -SCM_API unsigned char scm_masktab[256]; - SCM_API SCM scm_var_random_state; SCM_API SCM scm_random (SCM n, SCM state); SCM_API SCM scm_copy_random_state (SCM state); diff --git a/libguile/scm.h b/libguile/scm.h index 8e2903917..10aa0d2c8 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -514,9 +514,8 @@ typedef uintptr_t scm_t_bits; #define scm_tc16_continuation 0x037f #define scm_tc16_directory 0x047f #define scm_tc16_syntax_transformer 0x057f +#define scm_tc16_random_state 0x067f /* -#define scm_tc16_promise 0x0e7f -#define scm_tc16_random_state 0x0f7f #define scm_tc16_regexp 0x107f */ diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 5d5121652..89cc69da1 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -71,7 +71,8 @@ - + + ;; Numbers. @@ -79,14 +80,12 @@ ;; Unknown. - ;; Particular SMOB data types. All SMOB types have - ;; corresponding classes, which may be obtained via class-of, - ;; once you have an instance. Perhaps FIXME to provide a - ;; smob-type-name->class procedure. - - - - + ;; Particular SMOB or record data types. All SMOB types + ;; have corresponding classes, which may be obtained via + ;; class-of, once you have an instance. Perhaps FIXME to + ;; provide a smob-type-name->class procedure. + + ;; Modules. @@ -1088,6 +1087,8 @@ slots as we go." (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) +(define-standard-class ()) +(define-standard-class ()) (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) @@ -3535,12 +3536,7 @@ var{initargs}." ;;; {SMOB and port classes} ;;; -(define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) -(define (find-subclass ')) -(define (find-subclass ')) -(define (find-subclass ')) ;; used to be a SMOB type, albeit not exported even to ;; C. However now it's a record type, though still private. Cross our