Use the new define-parameter for booting STklos

Thus, parameters can be passed to help, with or without quote. This should close the (very old) issue #291
egallesio · Oct 8, 2023 · 13810e6 · 13810e6
1 parent 312f7f6
commit 13810e6
Show file tree

Hide file tree

Showing 9 changed files with 122 additions and 125 deletions.
diff --git a/lib/bonus.stk b/lib/bonus.stk
@@ -430,20 +430,18 @@ doc>
 doc>
 |#
 
-(define command-line
-  (let* ((script-file (key-get *%system-state-plist* :script-file ""))
-         (cmd-line    (cons (if (equal? script-file "")
-                                ""
-                                (key-get *%system-state-plist* :program-name ""))
-                            (key-get *%system-state-plist* :argv '()))))
-    (define (verify-setter val)
-      (if (and (list? val)
-               (not (null? val))
-               (every string? val))
-          val
-          (error "bad command line ~S" val)))
-
-    (make-parameter cmd-line verify-setter)))
+(define-parameter command-line
+  (let ((script-file (key-get *%system-state-plist* :script-file "")))
+    (cons (if (equal? script-file "")
+              ""
+              (key-get *%system-state-plist* :program-name ""))
+          (key-get *%system-state-plist* :argv '())))
+  (lambda (val)
+    (if (and (list? val)
+             (not (null? val))
+             (every string? val))
+        val
+        (error 'command-line "bad command line ~S" val))))
 
 
 #|

diff --git a/lib/compflags.stk b/lib/compflags.stk
@@ -30,7 +30,8 @@
 ;;      Compiler parameters ...
 ;; ----------------------------------------------------------------------
 
-(export compiler:time-display
+(export define-parameter
+        compiler:time-display
         compiler:gen-line-number
         compiler:warn-use-undefined
         compiler:warn-use-undefined-postpone
@@ -167,20 +168,19 @@ doc>
  * |n| must be a positive integer.
 doc>
 |#
-(define compiler:time-display                   (make-parameter #t))
-(define compiler:gen-line-number                (make-parameter #f))
-(define compiler:warn-use-undefined             (make-parameter #f))
-(define compiler:warn-use-undefined-postpone    (make-parameter #t))
-(define compiler:show-assembly-code             (make-parameter #f))
-(define compiler:keep-formals                   (make-parameter #f))
-(define compiler:keep-source                    (make-parameter #f))
-(define compiler:unroll-iterations
-  (make-parameter 4
-                  (lambda (v)
-                    (unless (and (fixnum? v) (positive? v))
-                      (error 'compiler:unroll-iterations
-                             "must be a positive fixnum. It was ~s" v))
-                    v)))
+(define-parameter compiler:time-display                   #t)
+(define-parameter compiler:gen-line-number                #f)
+(define-parameter compiler:warn-use-undefined             #f)
+(define-parameter compiler:warn-use-undefined-postpone    #t)
+(define-parameter compiler:show-assembly-code             #f)
+(define-parameter compiler:keep-formals                   #f)
+(define-parameter compiler:keep-source                    #f)
+(define-parameter compiler:unroll-iterations 4
+  (lambda (v)
+    (unless (and (fixnum? v) (positive? v))
+      (error 'compiler:unroll-iterations
+             "must be a positive fixnum. It was ~s" v))
+    v))
 
 ;; ----------------------------------------------------------------------
 ;;      %compiler-set-flags ...

diff --git a/lib/compiler.stk b/lib/compiler.stk
@@ -230,19 +230,20 @@
 ;; ======================================================================
 
 (define compiler:inline-common-functions
-  (let ((inlined *inline-symbols*))
-    (make-parameter #t
-                    (lambda (v)
-                      (set! *inline-symbols* (if v inlined '()))
-                      (not (null? *inline-symbols*))))))
-
-(define compiler-current-module
-  (make-parameter (current-module)
-                  (lambda (new)
-                    (unless (module? new)
-                      (error 'compiler-current-module "bad module parameter ~s" new))
-                    (add-file-module-list! new)
-                    new)))
+  (let* ((inlined *inline-symbols*)
+         (res     (make-parameter #t
+                                  (lambda (v)
+                                    (set! *inline-symbols* (if v inlined '()))
+                                    (not (null? *inline-symbols*))))))
+    (%set-parameter-name! res 'compiler:inline-common-functions)
+    res))
+
+(define-parameter compiler-current-module (current-module)
+  (lambda (new)
+    (unless (module? new)
+      (error 'compiler-current-module "bad module parameter ~s" new))
+    (add-file-module-list! new)
+    new))
 
 
 ;; ----------------------------------------------------------------------

diff --git a/lib/load.stk b/lib/load.stk
@@ -50,15 +50,15 @@
 ;;
 ;; stklos-conf-file: returns an absolute name for the given configuration file
 ;;
-(define %stklos-conf-dir
-  (make-parameter (let ((old-path (make-path (getenv "HOME") ".stklos"))
-                        (xdg-conf (getenv "XDG_CONFIG_HOME")))
-                    (or (getenv "STKLOS_CONFDIR")
-                        (if (file-exists? old-path)
-                            old-path
-                            (make-path (or xdg-conf "~/.config")
-                                       "stklos"))))
-                  expand-file-name))
+(define-parameter %stklos-conf-dir
+  (let ((old-path (make-path (getenv "HOME") ".stklos"))
+        (xdg-conf (getenv "XDG_CONFIG_HOME")))
+    (or (getenv "STKLOS_CONFDIR")
+        (if (file-exists? old-path)
+            old-path
+            (make-path (or xdg-conf "~/.config")
+                       "stklos"))))
+  expand-file-name)
 
 (define (%stklos-conf-file name)
   (make-path (%stklos-conf-dir) name))
@@ -118,19 +118,18 @@ doc>
  * current list of paths.
 doc>
 |#
-(define load-path
-  (make-parameter *load-path*
-                  (lambda (new-path)
-                    ;; Sanity check
-                    (unless (list? new-path)
-                      (error 'load-path "bad list of path names ~S" new-path))
-                    (for-each (lambda (x)
-                                (unless (string? x)
-                                  (error 'load-path "bad path name ~S" x)))
-                              new-path)
-                    ;; Set the load path
-                    (set! *load-path* new-path)
-                    new-path)))
+(define-parameter load-path *load-path*
+  (lambda (new-path)
+    ;; Sanity check
+    (unless (list? new-path)
+      (error 'load-path "bad list of path names ~S" new-path))
+    (for-each (lambda (x)
+                (unless (string? x)
+                  (error 'load-path "bad path name ~S" x)))
+              new-path)
+    ;; Set the load path
+    (set! *load-path* new-path)
+    new-path))
 
 #|
 <doc EXT load-suffixes
@@ -144,19 +143,18 @@ doc>
  * until the file can be loaded.
 doc>
 |#
-(define load-suffixes
-  (make-parameter *load-suffixes*
-                  (lambda (new)
-                    ;; Sanity check
-                    (unless (list? new)
-                      (error 'load-path "bad list of suffixes ~S" new))
-                    (for-each (lambda (x)
-                                (unless (string? x)
-                                  (error 'load-path "bad path name ~S" x)))
-                              new)
-                    ;; Set the load suffixes
-                    (set! *load-suffixes* new)
-                    new)))
+(define-parameter load-suffixes *load-suffixes*
+  (lambda (new)
+    ;; Sanity check
+    (unless (list? new)
+      (error 'load-path "bad list of suffixes ~S" new))
+    (for-each (lambda (x)
+                (unless (string? x)
+                  (error 'load-path "bad path name ~S" x)))
+              new)
+    ;; Set the load suffixes
+    (set! *load-suffixes* new)
+    new))
 
 #|
 <doc EXT load-verbose
@@ -169,20 +167,19 @@ doc>
  * is set to `#f`, no message is printed.
 doc>
 |#
-(define load-verbose
-  (make-parameter *load-verbose*
-                  (lambda (x) (set! *load-verbose* (and x #t)) *load-verbose*)))
+(define-parameter load-verbose *load-verbose*
+  (lambda (x) (set! *load-verbose* (and x #t)) *load-verbose*))
 
 
 #|
 <doc EXT current-loading-file
  * (current-loading-file)
  *
- * Returns the path of the file that is currently being load.
+ * Returns the path of the file that is currently being loaded.
 doc>
 |#
-(define current-loading-file
-  (make-parameter #f))
+(define-parameter current-loading-file #f)
+
 
 
 ;=============================================================================
@@ -365,7 +362,7 @@ doc>
 (define provided?       #f)
 (define require/provide #f)
 
-(define warning-when-not-provided (make-parameter #t))
+(define-parameter warning-when-not-provided #t)  ;; FIXME: document it
 
 
 #| HACK: FIXME:

diff --git a/lib/readline.stk b/lib/readline.stk
@@ -129,7 +129,7 @@
 
 ;; The parameter rl-completer-function contains the function used
 ;; to complete strings It defaults to default-complete-function
-(define rl-completer-function (make-parameter default-complete-function))
+(define-parameter rl-completer-function default-complete-function)
 
 #|
   As an example, here is another completer function. This one tries to find

diff --git a/lib/repl.stk b/lib/repl.stk
@@ -99,13 +99,12 @@ doc>
      (minimal     . (:error  (bold red)
                      :prompt  underline))))
 
-(define repl-theme
-  (make-parameter #f
-                  (lambda (theme)
-                    (if (symbol? theme)
-                        (let ((val (assoc theme *repl-themes*)))
-                          (if val (cdr val) '()))
-                        theme))))
+(define-parameter repl-theme #f
+  (lambda (theme)
+    (if (symbol? theme)
+        (let ((val (assoc theme *repl-themes*)))
+          (if val (cdr val) '()))
+        theme)))
 
 (define (get-repl-color key)
   (key-get (repl-theme) key ""))
@@ -326,12 +325,12 @@ doc>
 ;; ----------------------------------------------------------------------
 ;;      repl-prompt ...
 ;; ----------------------------------------------------------------------
-(define repl-prompt (make-parameter ""))
+(define-parameter repl-prompt "")
 
 ;; ----------------------------------------------------------------------
 ;;      repl-prompt-use-color? ...
 ;; ----------------------------------------------------------------------
-(define repl-prompt-use-color? (make-parameter #t))
+(define-parameter repl-prompt-use-color? #t)
 
 ;; ----------------------------------------------------------------------
 ;;      make-prompt ...
@@ -350,7 +349,7 @@ doc>
 ;; ----------------------------------------------------------------------
 ;;      repl-make-prompt ...
 ;; ----------------------------------------------------------------------
-(define repl-make-prompt (make-parameter make-prompt))
+(define-parameter repl-make-prompt make-prompt)
 
 ;; ----------------------------------------------------------------------
 ;;      display-prompt ...
@@ -362,7 +361,7 @@ doc>
 ;; ----------------------------------------------------------------------
 ;;      repl-display-prompt ...
 ;; ----------------------------------------------------------------------
-(define repl-display-prompt (make-parameter display-prompt))
+(define-parameter repl-display-prompt display-prompt)
 
 
 #|
@@ -379,13 +378,13 @@ doc>
  * `stklosrc` file.
 doc>
 |#
-(define repl-show-startup-message
-  (make-parameter (key-get *%system-state-plist* #:startup-message #t)))
+(define-parameter repl-show-startup-message
+  (key-get *%system-state-plist* #:startup-message #t))
 
 ;; ----------------------------------------------------------------------
 ;;      main-repl-hook ...
 ;; ----------------------------------------------------------------------
-(define main-repl-hook (make-parameter void))
+(define-parameter main-repl-hook void)
 
 ;; ----------------------------------------------------------------------
 ;;      repl-change-default-ports ...

diff --git a/lib/runtime-macros.stk b/lib/runtime-macros.stk
@@ -106,24 +106,3 @@
                                  ',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/lib/runtime.stk b/lib/runtime.stk
@@ -166,6 +166,29 @@ doc>
 ;; ----------------------------------------------------------------------
 ;;      parameters
 ;; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+;; 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)")))
+
+
+
 #|
 <doc EXT stklos-debug-level
  * (stklos-debug-level)
@@ -176,15 +199,15 @@ doc>
  * |stklos(1)| command.
 doc>
 |#
-(define stklos-debug-level
-  (make-parameter 0))
+(define-parameter stklos-debug-level 0
+  (lambda (x)
+    (if (integer? x) x (error 'stklos-debug-level "bad integer" x))))
 
 ;; ----------------------------------------------------------------------
 ;;      management of globals ...
 ;; ----------------------------------------------------------------------
 ;; This should be in compiler module but it a nightmare with bootstrap.
-(define compiler-known-globals
-  (make-parameter '()))
+(define-parameter compiler-known-globals '())
 
 (define (register-new-global! symbol)
   (let ((lst (compiler-known-globals)))

diff --git a/lib/thread.stk b/lib/thread.stk
@@ -116,7 +116,7 @@ doc>
  * `#t`.
 doc>
 |#
-(define thread-handler-error-show (make-parameter #t))
+(define-parameter thread-handler-error-show #t)
 
 
 (define (thread-sleep! timeout)