~ chicken-core (chicken-5) 29ea42afe7e2e3d743cc526619f4f36c4eedd50f
commit 29ea42afe7e2e3d743cc526619f4f36c4eedd50f
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Wed Oct 12 22:07:23 2016 +0200
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Fri Oct 28 13:19:32 2016 +1300
Replace fudges with readily available variables.
C_BINARY_VERSION was defined in chicken-{install,uninstall,status}
already.
C_enable_repl wasn't static, so added it to chicken.h, after which
we can use that directly in ##sys#break-on-error definition.
dload, ptables, gchooks and cross-chicken features can be determined
through their corresponding #defined values. Everywhere else, we can
just check if the feature is defined.
This adds a new #:gchooks feature for consistency with other "spec"
printing aspects.
C_getpid() is now directly used from a foreign-lambda.
repository-path simply checks C_private_repository_path() result, which
is defined to return c-string. This may be NULL, which maps to #f
already, making fudge 22 completely unnecessary.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/chicken-install.scm b/chicken-install.scm
index 853827b4..48132262 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -140,7 +140,7 @@
(if *prefix*
(make-pathname
*prefix*
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+ (sprintf "lib/chicken/~a" C_BINARY_VERSION))
(repository-path)))))
(define (get-prefix #!optional runtime)
diff --git a/chicken-status.scm b/chicken-status.scm
index c2a9615d..02162619 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -56,7 +56,7 @@
(if *prefix*
(make-pathname
*prefix*
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+ (sprintf "lib/chicken/~a" C_BINARY_VERSION))
(repository-path)))))
(define (grep rx lst)
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 7de0a74f..13cd11a0 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -54,7 +54,7 @@
(if *prefix*
(make-pathname
*prefix*
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+ (sprintf "lib/chicken/~a" C_BINARY_VERSION))
(repository-path)))))
(define *force* #f)
diff --git a/chicken.h b/chicken.h
index 2740d91d..bdb0522a 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1758,6 +1758,7 @@ C_varextern C_TLS jmp_buf C_restart;
C_varextern C_TLS void *C_restart_address;
C_varextern C_TLS int C_entry_point_status;
C_varextern C_TLS int C_gui_mode;
+C_varextern C_TLS int C_enable_repl;
C_varextern C_TLS void *C_restart_trampoline;
C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
diff --git a/csc.scm b/csc.scm
index 822947da..c9d626d6 100644
--- a/csc.scm
+++ b/csc.scm
@@ -88,7 +88,7 @@
(define chicken-prefix (get-environment-variable "CHICKEN_PREFIX"))
(define arguments (command-line-arguments))
(define host-mode (member "-host" arguments))
-(define cross-chicken (##sys#fudge 39))
+(define cross-chicken (feature? #:cross-chicken))
(define (prefix str dir default)
(if chicken-prefix
diff --git a/csi.scm b/csi.scm
index e329136a..bda48032 100644
--- a/csi.scm
+++ b/csi.scm
@@ -446,8 +446,11 @@ EOF
(with-output-to-port (if (pair? port) (car port) (current-output-port))
(lambda ()
(gc)
- (let ([sinfo (##sys#symbol-table-info)]
- [minfo (memory-statistics)] )
+ (let ((sinfo (##sys#symbol-table-info))
+ (minfo (memory-statistics))
+ (interrupts (foreign-value "C_interrupts_enabled" bool))
+ (fixed-heap (foreign-value "C_heap_size_is_fixed" bool))
+ (downward-stack (foreign-value "C_STACK_GROWS_DOWNWARD" bool)))
(define (shorten n) (/ (truncate (* n 100)) 100))
(printf "Features:~%~%")
(let ((fs (sort (map keyword->string ##sys#features) string<?))
@@ -495,13 +498,13 @@ EOF
(shorten (vector-ref sinfo 1))
(vector-ref sinfo 2)
(vector-ref minfo 0)
- (if (##sys#fudge 17) " (fixed)" "")
+ (if fixed-heap " (fixed)" "")
(vector-ref minfo 1)
(vector-ref minfo 2)
- (if (= 1 (##sys#fudge 18)) "downward" "upward")
+ (if downward-stack "downward" "upward")
(argv))
(##sys#write-char-0 #\newline ##sys#standard-output)
- (when (##sys#fudge 14) (display "interrupts are enabled\n"))
+ (when interrupts (display "interrupts are enabled\n"))
(##core#undefined) ) ) ) ) ) )
diff --git a/eval.scm b/eval.scm
index 86d8c21d..1b72164e 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1002,7 +1002,7 @@
(define dload?
(and (not ##sys#dload-disabled)
- (##sys#fudge 24)))
+ (feature? #:dload)))
(define fname
(cond ((port? input) #f)
@@ -1179,14 +1179,13 @@
(define repository-path
(make-parameter
- (if (##sys#fudge 22) ; private repository?
- (foreign-value "C_private_repository_path()" c-string)
- (or (get-environment-variable repository-environment-variable)
- (chicken-prefix
- (##sys#string-append
- "lib/chicken/"
- (##sys#number->string (##sys#fudge 42))))
- install-egg-home))))
+ (or (foreign-value "C_private_repository_path()" c-string)
+ (get-environment-variable repository-environment-variable)
+ (chicken-prefix
+ (##sys#string-append
+ "lib/chicken/"
+ (##sys#number->string binary-version)))
+ install-egg-home)))
(define ##sys#repository-path repository-path)
@@ -1202,7 +1201,7 @@
(let ((p0 (string-append path "/" p)))
(or (and rp
(not ##sys#dload-disabled)
- (##sys#fudge 24) ; dload?
+ (feature? #:dload)
(file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
(file-exists? (##sys#string-append p0 source-file-extension)))))
(let loop ((paths (##sys#append
@@ -1407,12 +1406,12 @@
(define (test fname)
(test-extensions
fname
- (cond ((pair? exts) exts) ; specific list of extensions
- ((not (##sys#fudge 24)) ; no dload -> source only
+ (cond ((pair? exts) exts) ; specific list of extensions
+ ((not (feature? #:dload)) ; no dload -> source only
(list source-file-extension))
- ((not exts) ; prefer compiled
+ ((not exts) ; prefer compiled
(list ##sys#load-dynamic-extension source-file-extension))
- (else ; prefer source
+ (else ; prefer source
(list source-file-extension ##sys#load-dynamic-extension)))))
(or (test (make-relative-pathname source fname))
(let loop ((paths (if repo
diff --git a/files.scm b/files.scm
index 4a086f09..2a97df2b 100644
--- a/files.scm
+++ b/files.scm
@@ -161,13 +161,14 @@ EOF
(##sys#check-string ext 'create-temporary-file)
(let loop ()
(let* ((n (##core#inline "C_random_fixnum" #x10000))
+ (getpid (foreign-lambda int "C_getpid"))
(pn (make-pathname
(tempdir)
(string-append
temp-prefix
(number->string n 16)
"."
- (##sys#number->string (##sys#fudge 33))) ; PID
+ (##sys#number->string (getpid)))
ext)) )
(if (file-exists? pn)
(loop)
@@ -176,13 +177,14 @@ EOF
(lambda ()
(let loop ()
(let* ((n (##core#inline "C_random_fixnum" #x10000))
+ (getpid (foreign-lambda int "C_getpid"))
(pn (make-pathname
(tempdir)
(string-append
temp-prefix
(number->string n 16)
"."
- (##sys#number->string (##sys#fudge 33)))))) ; PID
+ (##sys#number->string (getpid))))))
(if (file-exists? pn)
(loop)
(let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 'create-temporary-directory))))
diff --git a/library.scm b/library.scm
index 7c6f8289..8d47654e 100644
--- a/library.scm
+++ b/library.scm
@@ -150,6 +150,30 @@ signal_debug_event(C_word mode, C_word msg, C_word args)
C_debugger(&cell, 3, av);
return C_SCHEME_UNDEFINED;
}
+
+#ifdef NO_DLOAD2
+# define HAVE_DLOAD 0
+#else
+# define HAVE_DLOAD 1
+#endif
+
+#ifdef C_ENABLE_PTABLES
+# define HAVE_PTABLES 1
+#else
+# define HAVE_PTABLES 0
+#endif
+
+#ifdef C_GC_HOOKS
+# define HAVE_GCHOOKS 1
+#else
+# define HAVE_GCHOOKS 0
+#endif
+
+#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
+# define IS_CROSS_CHICKEN 1
+#else
+# define IS_CROSS_CHICKEN 0
+#endif
EOF
) )
@@ -4394,10 +4418,10 @@ EOF
(if full
(let ((spec (string-append
(if (feature? #:64bit) " 64bit" "")
- (if (##sys#fudge 24) " dload" "")
- (if (##sys#fudge 28) " ptables" "")
- (if (##sys#fudge 32) " gchooks" "")
- (if (##sys#fudge 39) " cross" "") ) ) )
+ (if (feature? #:dload) " dload" "")
+ (if (feature? #:ptables) " ptables" "")
+ (if (feature? #:gchooks) " gchooks" "")
+ (if (feature? #:cross-chicken) " cross" ""))))
(string-append
"Version " ##sys#build-version
(if ##sys#build-branch (string-append " (" ##sys#build-branch ")") "")
@@ -4445,9 +4469,14 @@ EOF
(check (machine-type))
(check (machine-byte-order)) )
-(when (##sys#fudge 24) (set! ##sys#features (cons #:dload ##sys#features)))
-(when (##sys#fudge 28) (set! ##sys#features (cons #:ptables ##sys#features)))
-(when (##sys#fudge 39) (set! ##sys#features (cons #:cross-chicken ##sys#features)))
+(when (foreign-value "HAVE_DLOAD" bool)
+ (set! ##sys#features (cons #:dload ##sys#features)))
+(when (foreign-value "HAVE_PTABLES" bool)
+ (set! ##sys#features (cons #:ptables ##sys#features)))
+(when (foreign-value "HAVE_GCHOOKS" bool)
+ (set! ##sys#features (cons #:gchooks ##sys#features)))
+(when (foreign-value "IS_CROSS_CHICKEN" bool)
+ (set! ##sys#features (cons #:cross-chicken ##sys#features)))
(when (fx= (foreign-value "C_WORD_SIZE" int) 64)
(set! ##sys#features (cons #:64bit ##sys#features)))
@@ -4569,7 +4598,7 @@ EOF
;;; Default handlers
-(define ##sys#break-on-error (##sys#fudge 25))
+(define ##sys#break-on-error (foreign-value "C_enable_repl" bool))
(define-foreign-variable _ex_software int "EX_SOFTWARE")
diff --git a/posix-common.scm b/posix-common.scm
index 0c85f00b..40449597 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -684,7 +684,7 @@ EOF
;;; Processes
-(define (current-process-id) (##sys#fudge 33))
+(define current-process-id (foreign-lambda int "C_getpid"))
(define (process-sleep n)
(##sys#check-fixnum n 'process-sleep)
diff --git a/posixunix.scm b/posixunix.scm
index b73df203..d5b731ad 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1119,7 +1119,7 @@ EOF
(fetch))
(if (fx>= bufpos buflen)
#!eof
- (let ((limit (or limit (fx- (##sys#fudge 21) bufpos))))
+ (let ((limit (or limit (fx- most-positive-fixnum bufpos))))
(receive (next line full-line?)
(##sys#scan-buffer-line
buf
diff --git a/runtime.c b/runtime.c
index 99be6877..3f8859ec 100644
--- a/runtime.c
+++ b/runtime.c
@@ -4872,7 +4872,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_mk_bool(debug_mode);
case C_fix(14): /* interrupts enabled? */
- return C_mk_bool(C_interrupts_enabled);
+ panic(C_text("(##sys#fudge 14) [interrupts enabled] is obsolete"));
case C_fix(15): /* symbol-gc enabled? */
panic(C_text("(##sys#fudge 15) [symbolgc] is obsolete"));
@@ -4881,10 +4881,10 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
panic(C_text("(##sys#fudge 16) [current wall clock milliseconds] not implemented"));
case C_fix(17): /* fixed heap? */
- return(C_mk_bool(C_heap_size_is_fixed));
+ panic(C_text("(##sys#fudge 17) [fixed heap] is obsolete"));
case C_fix(18): /* stack direction */
- return(C_fix(C_STACK_GROWS_DOWNWARD));
+ panic(C_text("(##sys#fudge 18) [stack direction] is obsolete"));
case C_fix(19): /* number of locatives */
for(i = j = 0; i < locative_table_count; ++i)
@@ -4895,23 +4895,19 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
panic(C_text("(##sys#fudge 20) [?] is obsolete"));
case C_fix(21): /* largest fixnum */
- return C_fix(C_MOST_POSITIVE_FIXNUM);
+ panic(C_text("(##sys#fudge 21) [largest fixnum] is obsolete"));
case C_fix(22): /* does this process use a private egg-repository? */
- return C_mk_bool(private_repository != NULL);
+ panic(C_text("(##sys#fudge 22) [private repo?] is obsolete"));
case C_fix(23): /* seconds since process startup */
panic(C_text("(##sys#fudge 23) [startuptime] is obsolete"));
case C_fix(24): /* dynamic loading available? */
-#ifdef NO_DLOAD2
- return C_SCHEME_FALSE;
-#else
- return C_SCHEME_TRUE;
-#endif
+ panic(C_text("(##sys#fudge 24) [dload] is obsolete"));
case C_fix(25): /* REPL on error? XXX Is this used anywhere? */
- return C_mk_bool(C_enable_repl);
+ panic(C_text("(##sys#fudge 25) [enable repl on error] is obsolete"));
case C_fix(26): /* number of untriggered finalizers */
return C_fix(live_finalizer_count);
@@ -4920,11 +4916,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(allocated_finalizer_count);
case C_fix(28): /* are procedure-tabled enabled? */
-#ifdef C_ENABLE_PTABLES
- return C_SCHEME_TRUE;
-#else
- return C_SCHEME_FALSE;
-#endif
+ panic(C_text("(##sys#fudge 28) [ptables] is obsolete"));
case C_fix(29): /* size of ring-buffer used to hold trace entries */
panic(C_text("(##sys#fudge 29) [trace buffer size] is obsolete"));
@@ -4938,14 +4930,10 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(tgc);
case C_fix(32): /* are GC-hooks enabled? */
-#ifdef C_GC_HOOKS
- return C_SCHEME_TRUE;
-#else
- return C_SCHEME_FALSE;
-#endif
+ panic(C_text("(##sys#fudge 32) [gchooks] is obsolete"));
case C_fix(33): /* return process-ID */
- return C_fix(C_getpid());
+ panic(C_text("(##sys#fudge 33) [getpid] is obsolete"));
case C_fix(34): /* effective maximum for procedure arguments */
panic(C_text("(##sys#fudge 34) [apply-argument-limit] is obsolete"));
@@ -4963,11 +4951,7 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
panic(C_text("(##sys#fudge 38) [old svn rev.] is obsolete"));
case C_fix(39): /* is this a cross-chicken? */
-#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
- return C_SCHEME_TRUE;
-#else
- return C_SCHEME_FALSE;
-#endif
+ panic(C_text("(##sys#fudge 39) [cross-chicken] is obsolete"));
case C_fix(40): /* many arguments supported? */
panic(C_text("(##sys#fudge 40) [manyargs] is obsolete"));
@@ -4976,17 +4960,13 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
return C_fix(C_MAJOR_VERSION);
case C_fix(42): /* binary version number */
-#ifdef C_BINARY_VERSION
- return C_fix(C_BINARY_VERSION);
-#else
- return C_fix(0);
-#endif
+ panic(C_text("(##sys#fudge 42) [binary version] is obsolete"));
case C_fix(43): /* minor CHICKEN version */
return C_fix(C_MINOR_VERSION);
case C_fix(44): /* whether debugger is active */
- return C_mk_bool(C_debugging);
+ panic(C_text("(##sys#fudge 44) [debugging] is obsolete"));
case C_fix(45): /* Whether we're currently profiling */
return C_mk_bool(profiling);
diff --git a/scripts/mini-salmonella.scm b/scripts/mini-salmonella.scm
index 4bd62a57..7761789a 100644
--- a/scripts/mini-salmonella.scm
+++ b/scripts/mini-salmonella.scm
@@ -33,7 +33,7 @@
(unless *eggdir* (usage 1))
-(define *binary-version* (##sys#fudge 42))
+(define-foreign-variable *binary-version* int "C_BINARY_VERSION")
(define *repository* (make-pathname *prefix* (conc "lib/chicken/" *binary-version*)))
(define *snapshot* (directory *repository*))
diff --git a/setup-api.scm b/setup-api.scm
index 5d009eb0..8dc73f8a 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -88,6 +88,7 @@
(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
(define *sudo* #f)
(define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
+(define *binary-version* (foreign-value "C_BINARY_VERSION" int))
(define *registered-programs* '())
(define *windows*
@@ -517,7 +518,7 @@
(if p ; installation-prefix changed: use it
(make-pathname
p
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+ (sprintf "lib/chicken/~a" *binary-version*))
(repository-path)))) ; otherwise use repo-path
(repository-path))) )
(ensure-directory p #t)
diff --git a/tcp.scm b/tcp.scm
index 81b10888..83c48b45 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -446,7 +446,7 @@ EOF
(read-input))
(if (fx>= bufindex buflen)
#!eof
- (let ((limit (or limit (fx- (##sys#fudge 21) bufindex))))
+ (let ((limit (or limit (fx- most-positive-fixnum bufindex))))
(receive (next line full-line?)
(##sys#scan-buffer-line
buf
Trap