Added syntax define-parameter

(define-parameter var val [thunk]) is equivalent to (define var (make-paramater val [thunk])), but it also adds a name to the created parameter, which can be useful for debugging
egallesio · Oct 7, 2023 · 312f7f6 · 312f7f6
1 parent 0b8684c
commit 312f7f6
Show file tree

Hide file tree

Showing 4 changed files with 42 additions and 9 deletions.
diff --git a/doc/HTML/stklos-ref.html b/doc/HTML/stklos-ref.html
@@ -14540,7 +14540,7 @@ <h4 id="_system_information">4.13.5. System Information</h4>
 </div>
 <div class="listingblock">
 <div class="content">
-<pre class="rouge highlight"><code data-lang="scheme"><span class="p">(</span><span class="nf">features</span><span class="p">)</span> <span class="nv">=&gt;</span> <span class="p">(</span><span class="nf">STklos</span> <span class="nv">STklos-2</span><span class="o">.</span><span class="mf">00.24</span> <span class="nv">exact-complex</span>
+<pre class="rouge highlight"><code data-lang="scheme"><span class="p">(</span><span class="nf">features</span><span class="p">)</span> <span class="nv">=&gt;</span> <span class="p">(</span><span class="nf">STklos</span> <span class="nv">STklos-2</span><span class="o">.</span><span class="mf">00.38</span> <span class="nv">exact-complex</span>
                <span class="nv">ieee-float</span> <span class="nv">full-unicode</span> <span class="nv">ratios</span> <span class="nv">little-endian</span> <span class="o">...</span><span class="p">)</span></code></pre>
 </div>
 </div>

diff --git a/doc/refman/stdproc.adoc b/doc/refman/stdproc.adoc
@@ -938,6 +938,7 @@ you plan to port your program on another system.
 See SRFI document for more information.
 
 {{insertdoc 'make-parameter}}
+{{insertdoc 'define-parameter}}
 {{insertdoc 'parameterize}}
 {{insertdoc 'parameter?}}
 

diff --git a/lib/runtime-macros.stk b/lib/runtime-macros.stk
@@ -106,3 +106,24 @@
                                  ',keywords
                                  ',clauses
                                  ',ellipsis))))))
+
+;; ----------------------------------------------------------------------
+;; define-parameter
+;; ----------------------------------------------------------------------
+#|
+<doc EXT-SYNTAX define-parameter
+ * (define-parameter var val)
+ * (define-parameter var val thunk)
+ *
+ * This form is a shortcut to define a new parameter named |var|. It also adds
+ * a name to the created parameter object, which can be useful for debugging.
+doc>
+|#
+(define-macro (define-parameter name . args)
+  (if (<= 1 (length args) 2)
+      (let ((tmp (gensym 'param)))
+        `(define ,name (let ((,tmp (make-parameter ,@args)))
+                         (%set-parameter-name! ,tmp ',name)
+                         ,tmp)))
+      (syntax-error 'define-parameter
+               "bad number of arguments (must be 2 or 3)")))
diff --git a/src/parameter.c b/src/parameter.c
@@ -33,7 +33,7 @@ struct parameter_obj {
   int C_type;           /* 0: parameter is expressed in Scheme                    */
                         /* 1: Converter is expressed in C rather than in Scheme   */
                         /* 2: idem and getter is a procedure to call to get value */
-  SCM name;
+  SCM name;             /* #f, a string or a symbol */
   SCM value;
   SCM converter;
   SCM (*getter)(void);  /* Used only for type 2 parameter objects */
@@ -58,16 +58,16 @@ struct parameter_obj {
  *
 \*===========================================================================*/
 
-static void error_bad_parameter(SCM obj)
+
+static inline void verify_parameter(SCM obj)
 {
-  STk_error("bad parameter ~S", obj);
+  if (!PARAMETERP(obj)) STk_error("bad parameter ~S", obj);
 }
 
 
 SCM STk_get_parameter(SCM param)
 {
-  if (!PARAMETERP(param)) error_bad_parameter(param);
-
+  verify_parameter(param);
   return (PARAMETER_C_TYPE(param) == 2) ?
     PARAMETER_GETTER(param)():
     PARAMETER_VALUE(param);
@@ -77,7 +77,7 @@ SCM STk_set_parameter(SCM param, SCM value)
 {
   SCM conv, new;
 
-  if (!PARAMETERP(param)) error_bad_parameter(param);
+  verify_parameter(param);
 
   conv = PARAMETER_CONV(param);
 
@@ -140,7 +140,7 @@ static void print_parameter(SCM param, SCM port, int _UNUSED(mode))
 
   STk_fprintf(port, "#[parameter ");
   if (name != STk_false)
-    STk_fprintf(port, "%s]", STRING_CHARS(name));
+    STk_fprintf(port, "%s]", STRINGP(name)? STRING_CHARS(name): SYMBOL_PNAME(name));
   else
     STk_fprintf(port, "%lx]", param);
 }
@@ -153,13 +153,23 @@ static void print_parameter(SCM param, SCM port, int _UNUSED(mode))
 
 DEFINE_PRIMITIVE("%parameter-name", parameter_name, subr1, (SCM obj))
 {
-  if (!PARAMETERP(obj)) error_bad_parameter(obj);
+  verify_parameter(obj);
   {
     SCM name = PARAMETER_NAME(obj);
     return SYMBOLP(name) ? STk_Cstring2string(SYMBOL_PNAME(name)) : name;
   }
 }
 
+DEFINE_PRIMITIVE("%set-parameter-name!", set_parameter_name, subr2, (SCM obj, SCM n))
+{
+  verify_parameter(obj);
+  if (!SYMBOLP(n) && !STRINGP(n)) STk_error("bad parameter name ~S", n);
+  PARAMETER_NAME(obj) = n;
+  return STk_void;
+}
+
+
+
 /*
 <doc EXT make-parameter
  * (make-parameter init)
@@ -265,6 +275,7 @@ int STk_init_parameter(void)
   ADD_PRIMITIVE(make_parameter);
   ADD_PRIMITIVE(parameterp);
   ADD_PRIMITIVE(parameter_name);
+  ADD_PRIMITIVE(set_parameter_name);
 
   return TRUE;
 }