From: Chris Hanson Date: Sat, 5 Sep 2009 07:04:04 +0000 (-0700) Subject: Add support for MacOSX application bundles. X-Git-Tag: 20100708-Gtk~346^2~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bdfff318e2974b9f0a6df194028573161160a3ef;p=mit-scheme.git Add support for MacOSX application bundles. --- diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 2f97b7111..1747ef2fa 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -378,6 +378,7 @@ darwin*) AC_MSG_ERROR([No MacOSX SDK for version: ${MACOSX}]) fi MACOSX_CFLAGS="${MACOSX_CFLAGS} -isysroot ${MACOSX_SYSROOT}" + MACOSX_CFLAGS="${MACOSX_CFLAGS} -fconstant-cfstrings" AC_MSG_NOTICE([Compiling for MacOSX version ${MACOSX}]) if test "${SCM_ARCH}" = i386; then MACOSX_CFLAGS="-arch i386 ${MACOSX_CFLAGS}" @@ -386,6 +387,7 @@ darwin*) fi CFLAGS="${CFLAGS} ${MACOSX_CFLAGS}" LDFLAGS="${LDFLAGS} ${MACOSX_CFLAGS} -Wl,-syslibroot,${MACOSX_SYSROOT}" + LDFLAGS="${LDFLAGS} -framework CoreFoundation" MODULE_LDFLAGS="${MODULE_LDFLAGS} -bundle -bundle_loader "'${SCHEME_EXE}' ;; netbsd*) diff --git a/src/microcode/option.c b/src/microcode/option.c index 4c71c0b10..ef0159d89 100644 --- a/src/microcode/option.c +++ b/src/microcode/option.c @@ -73,6 +73,10 @@ USA. #endif #define FILE_READABLE(filename) (OS_file_access ((filename), 4)) + +#ifdef __APPLE__ + extern const char * macosx_main_bundle_dir (void); +#endif static bool option_summary; @@ -493,10 +497,9 @@ parse_path_string (const char * path) { const char * start = path; /* It is important that this get_wd be called here to make sure that - the the unix getcwd is called now, before it allocates heap space + the unix getcwd is called now, before it allocates heap space. This is because getcwd forks off a new process and we want to do - that before the scheme process gets too big - */ + that before the scheme process gets too big. */ const char * wd = (get_wd ()); unsigned int lwd = (strlen (wd)); while (1) @@ -791,15 +794,32 @@ read_command_line_options (int argc, const char ** argv) bool band_sizes_valid = false; unsigned long band_constant_size = 0; unsigned long band_heap_size = 0; + const char * default_library_path = DEFAULT_LIBRARY_PATH; parse_standard_options (argc, argv); if (option_library_path != 0) free_parsed_path (option_library_path); +#ifdef __APPLE__ + const char * main_bundle_path = (macosx_main_bundle_dir ()); + if (main_bundle_path != 0) + { + unsigned int n_chars = + ((strlen (main_bundle_path)) + + (strlen (default_library_path)) + + 2); + char * new_path = (OS_malloc (n_chars)); + strcpy (new_path, main_bundle_path); + strcat (new_path, ":"); + strcat (new_path, default_library_path); + xfree (main_bundle_path); + default_library_path = new_path; + } +#endif option_library_path = (parse_path_string (standard_string_option (option_raw_library, LIBRARY_PATH_VARIABLE, - DEFAULT_LIBRARY_PATH))); + default_library_path))); if (option_band_file != 0) { diff --git a/src/microcode/pruxenv.c b/src/microcode/pruxenv.c index e53992199..37baaddb3 100644 --- a/src/microcode/pruxenv.c +++ b/src/microcode/pruxenv.c @@ -36,6 +36,10 @@ extern const char * OS_current_user_home_directory (void); #ifdef HAVE_SOCKETS # include "uxsock.h" #endif + +#ifdef __APPLE__ +# include +#endif DEFINE_PRIMITIVE ("FILE-TIME->STRING", Prim_file_time_to_string, 1, 1, "Convert a file system time stamp into a date/time string.") @@ -236,3 +240,73 @@ DEFINE_PRIMITIVE ("INSTRUCTION-ADDRESS->COMPILED-CODE-BLOCK", PRIMITIVE_RETURN (UNSPECIFIC); #endif } + +#ifdef __APPLE__ +const char * +macosx_main_bundle_dir (void) +{ + CFBundleRef bundle; + CFURLRef url; + UInt8 buffer [4096]; + char * bp; + char * result; + + bundle = (CFBundleGetMainBundle()); + if (bundle == 0) + return (0); + + url = (CFBundleCopyResourceURL + (bundle, (CFSTR ("utabmd")), (CFSTR ("bin")), 0)); + if (url == 0) + return (0); + + if (!CFURLGetFileSystemRepresentation (url, true, buffer, (sizeof (buffer)))) + { + CFRelease (url); + return (0); + } + CFRelease (url); + bp = ((char *) buffer); + + /* Discard everything after the final slash. */ + { + char * slash = (strrchr (bp, '/')); + if (slash != 0) + (*slash) = '\0'; + } + + result = (UX_malloc ((strlen (bp)) + 1)); + if (result != 0) + strcpy (result, bp); + + return (result); +} +#endif + +DEFINE_PRIMITIVE ("MACOSX-MAIN-BUNDLE-DIR", + Prim_macosx_main_bundle_dir, 0, 0, 0) +{ + PRIMITIVE_HEADER (0); +#ifdef __APPLE__ + { + const char * path = (macosx_main_bundle_dir ()); + unsigned int n_words; + SCHEME_OBJECT result; + + if (path == 0) + PRIMITIVE_RETURN (SHARP_F); + n_words = (1 + (STRING_LENGTH_TO_GC_LENGTH (strlen (path)))); + if (GC_NEEDED_P (n_words)) + { + UX_free ((void *) path); + Primitive_GC (n_words); + } + result = (char_pointer_to_string_no_gc (path)); + UX_free ((void *) path); + PRIMITIVE_RETURN (result); + } +#else + error_unimplemented_primitive (); + PRIMITIVE_RETURN (UNSPECIFIC); +#endif +} diff --git a/src/runtime/pathnm.scm b/src/runtime/pathnm.scm index 4f73f0862..47ba8be9f 100644 --- a/src/runtime/pathnm.scm +++ b/src/runtime/pathnm.scm @@ -590,21 +590,21 @@ these rules: ((host-type/operation/init-file-pathname (host/type host)) host))) (define (system-library-pathname pathname #!optional required?) - (let ((pathname* (merge-pathnames pathname (%find-library-directory))) - (required? (if (default-object? required?) #t required?))) - (if (and required? (not (file-exists? pathname*))) - (system-library-pathname - (error:file-operation pathname* - "find" - "file" - "no such file in system library path" - system-library-pathname - (list pathname required?))) - pathname*))) + (if (if (default-object? required?) #t required?) + (or (%find-library-file pathname) + (system-library-pathname + (error:file-operation pathname* + "find" + "file" + "no such file in system library path" + system-library-pathname + (list pathname required?)) + required?)) + (merge-pathnames pathname (%find-library-directory)))) (define (system-library-directory-pathname #!optional pathname required?) (if (if (default-object? pathname) #f pathname) - (let ((dir (system-library-pathname pathname #f))) + (let ((dir (%find-library-file pathname))) (cond ((file-directory? dir) (pathname-as-directory dir)) ((if (default-object? required?) #f required?) @@ -625,6 +625,14 @@ these rules: (or (find-matching-item library-directory-path file-directory?) (error "Can't find library directory.")))) +(define (%find-library-file pathname) + (let loop ((path library-directory-path)) + (and (pair? path) + (let ((p (merge-pathnames pathname (car path)))) + (if (file-exists? p) + p + (loop (cdr path))))))) + (define library-directory-path) (define known-host-types