diff --git a/lib/bonus.stk b/lib/bonus.stk index 0f70a5dae..23a49e23d 100644 --- 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 index d57122c83..6380ade5f 100644 --- 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 index b37c365f0..49964f80e 100644 --- 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 index 5a421297e..e0b63f347 100644 --- 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)) #| * 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)) #| * 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*)) #| |# -(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 index 959df8d12..3dfa0fbb5 100644 --- 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 index a36f8b171..dee0eb449 100644 --- 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 index e97af2e1c..2bc7aa621 100644 --- a/lib/runtime-macros.stk +++ b/lib/runtime-macros.stk @@ -106,24 +106,3 @@ ',keywords ',clauses ',ellipsis)))))) - -;; ---------------------------------------------------------------------- -;; define-parameter -;; ---------------------------------------------------------------------- -#| - -|# -(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 index 296081b76..e9643a1fd 100644 --- a/lib/runtime.stk +++ b/lib/runtime.stk @@ -166,6 +166,29 @@ doc> ;; ---------------------------------------------------------------------- ;; parameters ;; ---------------------------------------------------------------------- +;; ---------------------------------------------------------------------- +;; define-parameter +;; ---------------------------------------------------------------------- +#| + +|# +(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)"))) + + + #| * |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 index e453c2159..87d176c6f 100644 --- 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)