From 3b40a1acde316eb3ebc639df71f10f3b7ffaaa18 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Wed, 12 Oct 2016 22:07:23 +0200 Subject: [PATCH 6/9] 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. --- chicken-install.scm | 2 +- chicken-status.scm | 2 +- chicken-uninstall.scm | 2 +- chicken.h | 1 + csc.scm | 2 +- csi.scm | 13 ++++++++----- eval.scm | 27 +++++++++++++------------- files.scm | 6 ++++-- library.scm | 45 ++++++++++++++++++++++++++++++++++++-------- posix-common.scm | 2 +- posixunix.scm | 3 ++- runtime.c | 46 +++++++++++++-------------------------------- scripts/mini-salmonella.scm | 2 +- setup-api.scm | 3 ++- tcp.scm | 3 ++- 15 files changed, 88 insertions(+), 71 deletions(-) diff --git a/chicken-install.scm b/chicken-install.scm index 853827b..4813226 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 c2a9615..0216261 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 7de0a74..13cd11a 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 2740d91..bdb0522 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 822947d..c9d626d 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 e329136..bda4803 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) stringstring (##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 4a086f0..2a97df2 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 7c6f828..90cbf15 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 0c85f00..4044959 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 b73df20..96f30e5 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -1119,7 +1119,8 @@ 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 99be687..3f8859e 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 4bd62a5..7761789 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 5d009eb..8dc73f8 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 81b1088..7748e67 100644 --- a/tcp.scm +++ b/tcp.scm @@ -446,7 +446,8 @@ 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 -- 2.1.4