~ chicken-core (chicken-5) efbd0df9d2b6294220b8be3a9aae46a13cade8dc
commit efbd0df9d2b6294220b8be3a9aae46a13cade8dc
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Feb 13 12:28:35 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Feb 13 12:28:35 2010 +0100
private repository path handling, new option to csc
diff --git a/chicken.h b/chicken.h
index 37f0d631..5ed9a615 100644
--- a/chicken.h
+++ b/chicken.h
@@ -893,6 +893,7 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_readlink readlink
# define C_getcwd getcwd
# define C_access access
+# define C_getpid getpid
# ifdef __linux__
extern double round(double);
extern double trunc(double);
@@ -1307,9 +1308,21 @@ extern double trunc(double);
#define C_end_of_main
+#ifdef C_PRIVATE_REPOSITORY
+# define C_private_repository C_use_private_repository()
+#else
+# define C_private_repository
+#endif
+
/* left for backwards-compatibility */
#define C_gui_nongui_marker
+#ifdef C_GUI
+# define C_set_gui_mode C_gui_mode = 1
+#else
+# define C_set_gui_mode
+#endif
+
#if !defined(C_EMBEDDED) && !defined(C_SHARED)
# if (defined(C_WINDOWS_GUI) || defined(C_GUI)) && defined(_WIN32)
# define C_main_entry_point \
@@ -1317,10 +1330,14 @@ extern double trunc(double);
{ \
C_gui_mode = 1; \
return CHICKEN_main(0, NULL, (void *)C_toplevel); \
- } \
- C_end_of_main
+ } C_end_of_main
# else
-# define C_main_entry_point int main(int argc, char *argv[]) { return CHICKEN_main(argc, argv, (void*)C_toplevel); } C_end_of_main
+# define C_main_entry_point \
+ int main(int argc, char *argv[]) \
+ { \
+ C_set_gui_mode; \
+ return CHICKEN_main(argc, argv, (void*)C_toplevel); \
+ } C_end_of_main
# endif
#else
# define C_main_entry_point
@@ -1528,6 +1545,8 @@ C_fctexport C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos) C_reg
C_fctexport void C_do_register_finalizer(C_word x, C_word proc);
C_fctexport int C_do_unregister_finalizer(C_word x);
C_fctexport C_word C_dbg_hook(C_word x);
+C_fctexport void C_use_private_repository();
+C_fctexport C_char *C_private_repository_path();
C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
C_fctexport void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) C_noret;
diff --git a/csc.scm b/csc.scm
index d4187989..a85017a9 100644
--- a/csc.scm
+++ b/csc.scm
@@ -462,6 +462,7 @@ Usage: ~a FILENAME | OPTION ...
-keep-shadowed-macros do not remove shadowed macro
-host compile for host when configured for
cross-compiling
+ -private-repository load extensions from executable path
Options can be collapsed if unambiguous, so
@@ -615,20 +616,21 @@ EOF
(set! static-extensions (append static-extensions (list (car rest))))
(t-options "-static-extension" (car rest))
(set! rest (cdr rest)) ]
+ ((-private-repository)
+ (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))
[(-gui
-windows |-W|) ;DEPRECATED
(set! gui #t)
+ (set! compile-options (cons "-DC_GUI" compile-options))
(when (or msvc mingw)
(cond
(mingw
(set! link-options
(cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"
- link-options))
- (set! compile-options (cons "-DC_GUI" compile-options)))
+ link-options)))
(msvc
(set! link-options
- (cons* "kernel32.lib" "user32.lib" "gdi32.lib" link-options))
- (set! compile-options (cons "-DC_GUI" compile-options)))) ) ]
+ (cons* "kernel32.lib" "user32.lib" "gdi32.lib" link-options)))))]
[(-framework)
(check s rest)
(when osx
@@ -949,18 +951,12 @@ EOF
(quotewrap (make-pathname home "mac.r"))))
(define (create-mac-bundle prg dname)
- (unless (directory-exists? dname)
- (create-directory dname))
- (let ((d (make-pathname dname "Contents")))
- (unless (directory-exists? d)
- (create-directory d))
- (let ((d (make-pathname d "MacOS")))
- (unless (directory-exists? d)
- (create-directory d))
- (let ((pl (make-pathname d "Info.plist")))
- (unless (file-exists? pl)
- (with-output-to-file pl
- (cut print #<#EOF
+ (let ((d (make-pathname dname "Contents/MacOS")))
+ (command "mkdir -p ~a" (qs (normalize-pathname d)))
+ (let ((pl (make-pathname d "Info.plist")))
+ (unless (file-exists? pl)
+ (with-output-to-file pl
+ (cut print #<#EOF
<?xml version="1.0" encoding="UTF-8"?>
<plist version="1.0">
<dict>
@@ -970,7 +966,7 @@ EOF
</plist>
EOF
)))
- d))))
+ d)))
;;; Run it:
diff --git a/eval.scm b/eval.scm
index 6e53e671..5543a48a 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1098,13 +1098,19 @@
[else p] ) ) ) ) ) ) )
(define ##sys#repository-path
- (make-parameter
- (or (get-environment-variable repository-environment-variable)
- (##sys#chicken-prefix
- (##sys#string-append
- "lib/chicken/"
- (##sys#number->string (##sys#fudge 42))) )
- install-egg-home) ) )
+ (let ((rpath
+ (if (##sys#fudge 22) ; private repository?
+ (foreign-value "C_private_repository_path()" c-string)
+ (or (get-environment-variable repository-environment-variable)
+ (##sys#chicken-prefix
+ (##sys#string-append
+ "lib/chicken/"
+ (##sys#number->string (##sys#fudge 42))) )
+ install-egg-home))))
+ (lambda (#!optional val)
+ (if val
+ (set! rpath val)
+ rpath))))
(define repository-path ##sys#repository-path)
diff --git a/library.scm b/library.scm
index 2f781ac0..fe823d0b 100644
--- a/library.scm
+++ b/library.scm
@@ -3405,12 +3405,6 @@ EOF
(define ##sys#pathname-directory-separator #\/) ; DEPRECATED
-;;; Access executable path
-
-(define ##sys#path-to-executable
- (foreign-lambda c-string "C_executable_path"))
-
-
;;; Feature identifiers:
(define ##sys#->feature-id
diff --git a/posixunix.scm b/posixunix.scm
index ad3c3146..5d3806d2 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -160,7 +160,6 @@ static C_TLS struct stat C_statbuf;
#define C_fork fork
#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))
-#define C_getpid getpid
#define C_getppid getppid
#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))
#define C_getuid getuid
@@ -177,7 +176,7 @@ static C_TLS struct stat C_statbuf;
#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))
#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))
#define C_symlink(o, n) C_fix(symlink(C_data_pointer(o), C_data_pointer(n)))
-#define C_readlink(f, b) C_fix(readlink(C_data_pointer(f), C_data_pointer(b), FILENAME_MAX))
+#define C_do_readlink(f, b) C_fix(readlink(C_data_pointer(f), C_data_pointer(b), FILENAME_MAX))
#define C_getpwnam(n) C_mk_bool((C_user = getpwnam((char *)C_data_pointer(n))) != NULL)
#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)
#ifdef HAVE_GRP_H
@@ -197,7 +196,7 @@ static C_TLS struct stat C_statbuf;
#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))
#define C_alarm alarm
#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
-#define C_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
+#define C_test_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
#define C_close(fd) C_fix(close(C_unfix(fd)))
#define C_sleep sleep
@@ -1487,7 +1486,7 @@ EOF
(let ()
(define (check filename acc loc)
(##sys#check-string filename loc)
- (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
+ (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
(unless r (##sys#update-errno))
r) )
(set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
@@ -1538,7 +1537,7 @@ EOF
[buf (make-string (fx+ _filename_max 1))] )
(lambda (fname #!optional canonicalize)
(##sys#check-string fname 'read-symbolic-link)
- (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
+ (let ([len (##core#inline "C_do_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
(when (fx< len 0)
(posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
(let ((pathname (substring buf 0 len)))
diff --git a/runtime.c b/runtime.c
index 34dec46d..44f2aae3 100644
--- a/runtime.c
+++ b/runtime.c
@@ -381,6 +381,7 @@ static C_TLS size_t
heapspace2_size;
static C_TLS C_char
buffer[ STRING_BUFFER_SIZE ],
+ *private_repository,
*current_module_name,
*save_string;
static C_TLS C_SYMBOL_TABLE
@@ -4061,7 +4062,8 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
case C_fix(21):
return C_fix(C_MOST_POSITIVE_FIXNUM);
- /* 22 */
+ case C_fix(22):
+ return C_mk_bool(private_repository != NULL);
case C_fix(23):
return C_fix(C_startup_time_seconds);
@@ -8735,35 +8737,34 @@ C_decode_literal(C_word **ptr, C_char *str)
}
-C_char *
-C_executable_path()
+void
+C_use_private_repository()
{
#ifdef __linux__
- char linkname[64]; /* /proc/<pid>/exe */
+ C_char linkname[64]; /* /proc/<pid>/exe */
pid_t pid;
int ret;
+ private_repository = NULL;
pid = C_getpid();
C_sprintf(linkname, "/proc/%i/exe", pid);
ret = C_readlink(linkname, buffer, STRING_BUFFER_SIZE - 1);
if(ret == -1 || ret >= STRING_BUFFER_SIZE - 1)
- return NULL;
+ return;
buffer[ ret ] = '\0';
- return buffer;
-#elseif defined(_WIN32) && !defined(__CYGWIN__)
+#elif defined(_WIN32) && !defined(__CYGWIN__)
int n = GetModuleFileName(NULL, buffer, STRING_BUFFER_SIZE - 1);
if(n == 0 || n >= STRING_BUFFER_SIZE - 1)
- return NULL;
+ return;
buffer[ n ] = '\0';
- return buffer;
-#else
- int i, j, k;
- char *fname = C_main_argv[ 0 ];
- char *path, *dname;
+#elif defined(__unix__) || defined(C_XXXBSD)
+ int i, j, k, l;
+ C_char *fname = C_main_argv[ 0 ];
+ C_char *path, *dname;
/* found on stackoverflow.com: */
@@ -8777,44 +8778,84 @@ C_executable_path()
/* absolute path */
if(*fname == '/') {
fname[ i ] = '\0';
- return fname;
+ C_strcpy(buffer, fname);
}
+ else {
+ /* try current dir */
+ if(C_getcwd(buffer, STRING_BUFFER_SIZE - 1) == NULL)
+ return;
- /* try current dir */
- if(C_getcwd(buffer, STRING_BUFFER_SIZE - 1) == NULL)
- return NULL;
-
- j = C_strlen(buffer);
- C_strcat(buffer, "/");
- C_strcat(buffer, fname);
+ j = C_strlen(buffer);
+ C_strcat(buffer, "/");
+ C_strcat(buffer, fname);
- if(C_access(buffer, F_OK) == 0) {
- buffer[ j ] = '\0';
- return buffer;
- }
+ if(C_access(buffer, F_OK) == 0) {
+ buffer[ j ] = '\0';
+ return buffer;
+ }
- /* walk PATH */
- path = C_getenv("PATH");
+ /* walk PATH */
+ path = C_getenv("PATH");
- if(path == NULL) return NULL;
-
- for(j = k = 0; path[ k ] != '\0'; ++k) {
- if(path[ k ] == ':') {
- C_strncpy(buffer, path + j, k - j);
- buffer[ k - j ] = '\0';
- C_strcat(buffer, "/");
- C_strcat(buffer, fname);
-
- if(C_access(buffer, F_OK))
- /*XXX resolve symlinks */
- return buffer;
-
- j = k + 1;
+ if(path == NULL) return;
+
+ for(l = j = k = 0; !l; ++k) {
+ switch(path[ k ]) {
+
+ case '\0':
+ if(k == 0) return; /* empty PATH */
+ else l = 1;
+ /* fall through */
+
+ case ':':
+ C_strncpy(buffer, path + j, k - j);
+ buffer[ k - j ] = '\0';
+ C_strcat(buffer, "/");
+ C_strcat(buffer, fname);
+
+ if(C_access(buffer, F_OK)) {
+ dname = C_strdup(buffer);
+ l = C_readlink(dname, buffer, C_STRING_BUFFER_SIZE - 1);
+
+ if(l == -1) {
+ /* not a symlink (we ignore other errors here */
+ dname[ k - j ] = '\0';
+ }
+ else {
+ while(l > 0 && buffer[ l ] != '/') --l;
+
+ C_free(dname);
+ buffer[ l ] = '\0';
+ }
+
+ goto finish;
+ }
+ else j = k + 1;
+
+ break;
+
+ default: ;
+ }
}
+
+ return;
}
- /* give up */
- return NULL;
-}
+ finish:
+#else
+ return;
#endif
+ if(debug_mode)
+ C_printf(C_text("[debug] using private repository at `%s'\n"),
+ buffer);
+
+ private_repository = C_strdup(buffer);
+}
+
+
+C_char *
+C_private_repository_path()
+{
+ return private_repository;
}
+
Trap