MacOS: utilisation de ToolServer

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2636 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 222 insertions, 72 deletions

diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 9f0f7d866..9e54379ca 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -397,75 +397,68 @@ let build_custom_runtime prim_name exec_name =
           Config.c_libraries)
   | "MacOS" ->
       let c68k = "sc"
-      and libs68k = "\"{libraries}IntEnv.far.o\" " ^
-                    "\"{libraries}MacRuntime.o\" " ^
-                    "\"{clibraries}StdCLib.far.o\" " ^
-                    "\"{libraries}MathLib.far.o\" " ^
-                    "\"{libraries}ToolLibs.o\" " ^
-                    "\"{libraries}Interface.o\""
+      and libs68k = "\"{libraries}IntEnv.far.o\" \
+                     \"{libraries}MacRuntime.o\" \
+                     \"{clibraries}StdCLib.far.o\" \
+                     \"{libraries}MathLib.far.o\" \
+                     \"{libraries}ToolLibs.o\" \
+                     \"{libraries}Interface.o\""
       and link68k = "ilink -compact -state nouse -model far -msg nodup"
       and cppc = "mrc"
-      and libsppc = "\"{sharedlibraries}MathLib\" " ^
-                    "\"{ppclibraries}PPCCRuntime.o\" " ^
-                    "\"{ppclibraries}PPCToolLibs.o\" " ^
-                    "\"{sharedlibraries}StdCLib\" " ^
-                    "\"{ppclibraries}StdCRuntime.o\" " ^
-                    "\"{sharedlibraries}InterfaceLib\" "
+      and libsppc = "\"{sharedlibraries}MathLib\" \
+                     \"{ppclibraries}PPCCRuntime.o\" \
+                     \"{ppclibraries}PPCToolLibs.o\" \
+                     \"{sharedlibraries}StdCLib\" \
+                     \"{ppclibraries}StdCRuntime.o\" \
+                     \"{sharedlibraries}InterfaceLib\""
       and linkppc = "ppclink -d"
       and objs68k = extract ".o" (List.rev !Clflags.ccobjs)
       and objsppc = extract ".x" (List.rev !Clflags.ccobjs)
+      and q_prim_name = Filename.quote prim_name
+      and q_stdlib = Filename.quote Config.standard_library
+      and q_exec_name = Filename.quote exec_name
       in
-      Ccomp.run_command (Printf.sprintf "%s -i \"%s\" %s \"%s\" -o \"%s.o\""
+      Ccomp.run_command (Printf.sprintf "%s -i %s %s %s -o %s.o"
         c68k
-        Config.standard_library
-        (String.concat " " (List.rev !Clflags.ccopts))
-        prim_name
-        prim_name);
-      Ccomp.run_command (Printf.sprintf "%s -i \"%s\" %s \"%s\" -o \"%s.x\""
+        q_stdlib
+        (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts))
+        q_prim_name
+        q_prim_name);
+      Ccomp.run_command (Printf.sprintf "%s -i %s %s %s -o %s.x"
         cppc
-        Config.standard_library
-        (String.concat " " (List.rev !Clflags.ccopts))
-        prim_name
-        prim_name);
-      Ccomp.run_command ("delete -i \""^exec_name^"\"");
+        q_stdlib
+        (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts))
+        q_prim_name
+        q_prim_name);
+      Ccomp.run_command ("delete -i " ^ q_exec_name);
       Ccomp.run_command (Printf.sprintf
-        "%s -t MPST -c 'MPS ' -o \"%s\" \"%s.o\" \"%s\" \"%s\" %s"
+        "%s -t MPST -c 'MPS ' -o %s %s.o %s %s %s"
         link68k
-        exec_name
-        prim_name
-        (String.concat "\" \"" objs68k)
-        (Filename.concat Config.standard_library "libcamlrun.o")
+        q_exec_name
+        q_prim_name
+        (String.concat " " (List.map Filename.quote objs68k))
+        (Filename.quote
+            (Filename.concat Config.standard_library "libcamlrun.o"))
         libs68k);
       Ccomp.command (Printf.sprintf
-        "%s -t MPST -c 'MPS ' -o \"%s\" \"%s.x\" \"%s\" \"%s\" %s"
+        "%s -t MPST -c 'MPS ' -o %s %s.x %s %s %s"
         linkppc
-        exec_name
-        prim_name
-        (String.concat "\" \"" objsppc)
-        (Filename.concat Config.standard_library "libcamlrun.x")
+        q_exec_name
+        q_prim_name
+        (String.concat " " (List.map Filename.quote objsppc))
+        (Filename.quote
+            (Filename.concat Config.standard_library "libcamlrun.x"))
         libsppc)
-  | _ ->
-    fatal_error "Bytelink.build_custom_runtime"
+  | _ -> assert false
 
 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
-  match Sys.os_type with
-    "MacOS" ->
-      Ccomp.run_command (Printf.sprintf
-          "mergefragment -c -t Caml \"%s\"" bytecode_name);
-      Ccomp.run_command (Printf.sprintf
-          "mergefragment \"%s\" \"%s\"" bytecode_name exec_name);
-      Ccomp.run_command (Printf.sprintf
-          "delete -i \"%s\" \"%s\" \"%s.o\" \"%s.x\""
-          bytecode_name prim_name prim_name prim_name)
-  | _ ->
-      let oc =
-        open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in
-      let ic = open_in_bin bytecode_name in
-      copy_file ic oc;
-      close_in ic;
-      close_out oc;
-      remove_file bytecode_name;
-      remove_file prim_name
+  let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in
+  let ic = open_in_bin bytecode_name in
+  copy_file ic oc;
+  close_in ic;
+  close_out oc;
+  remove_file bytecode_name;
+  remove_file prim_name
 
 (* Fix the name of the output file, if the C compiler changes it behind
    our back. *)
diff --git a/byterun/macintosh.c b/byterun/macintosh.c
index ace514237..ac2e02738 100644
--- a/byterun/macintosh.c
+++ b/byterun/macintosh.c
@@ -17,11 +17,16 @@
 #include <stdio.h>
 #include <stdlib.h>
 
+#include <AppleEvents.h>
+#include <CursorCtl.h>
+#include <Errors.h>
 #include <Files.h>
 #include <IntEnv.h>
 #include <MacTypes.h>
+#include <QuickDraw.h>
 #include <TextUtils.h>
 
+#include "misc.h"
 #include "rotatecursor.h"
 
 /* The user interface defaults to MPW tool.  The standalone application
@@ -135,18 +140,136 @@ char *getcwd (char *buf, long size)
   return buf;
 }
 
+pascal Boolean system_idleproc (const EventRecord *event, long *sleepTime,
+                                RgnHandle *mouseRgn)
+{
+  static RgnHandle myregion = NULL;
+  EventRecord evt;
+  
+  if (myregion == NULL){
+    myregion = NewRgn ();
+    SetRectRgn (myregion, -32000, -32000, 32000, 32000);
+  }
+
+  /* XXX standalone appli: process event */
+  *mouseRgn = myregion;
+  *sleepTime = 3;
+  if (EventAvail (keyDownMask, &evt)
+      && (evt.modifiers & cmdKey)
+      && ((evt.message & charCodeMask) == '.')){
+    return true;
+  }else{
+    return false;
+  }
+}
+
+void quote (char *buf, long buflen)
+{
+  long i, j;
+
+  j = 2;
+  for (i = 0; buf[i] != '\0'; i++){
+    if (buf[i] == '\'') j += 3;
+    ++ j;
+  }
+  if (j >= buflen) return;
+
+  buf[j--] = '\0';
+  buf[j--] = '\'';
+  while (i > 0){
+    -- i;
+    buf[j--] = buf[i];
+    if (buf[i] == '\''){
+      buf[j--] = '\'';
+      buf[j--] = '\266';
+      buf[j--] = '\'';
+    }
+  }
+  buf[j] = '\'';                   Assert (j == 0);
+}
+
 int system (char const *cmd)
 {
-  char *filename;
-  FILE *f;
+  char *fmt = "directory %s; %s";
+  char *cmdline;
+  char *buf;
+  #define buf_size 66000
 
-  if (StandAlone) return -1;
+  static AEIdleUPP myIdleProcUPP = NULL;
+  AEAddressDesc serveraddr;
+  AppleEvent myevent, reply;
+  OSType toolserver_sig = 'MPSX';
+  DescType ret_type;
+  OSErr err = noErr;
+  long event_status = 0, ret_size;
+  int result;
 
-  filename = getenv ("ocamlcommands");
-  if (filename == NULL) return 1;
-  f = fopen (filename, "a");
-  if (f == NULL) return 1;
-  fprintf (f, "%s\n", cmd);
-  fclose (f);
+  /* once only */
+  if (myIdleProcUPP == NULL) myIdleProcUPP = NewAEIdleProc (system_idleproc);
+
+  SetCursor (*GetCursor (watchCursor));
+  
+  buf = malloc (buf_size);
+  if (buf == NULL) goto failed_malloc_buf;
+
+  /* Create the command line */
+  getcwd (buf, buf_size);
+  quote (buf, buf_size);
+  cmdline = malloc (strlen (fmt) + strlen (cmd) + strlen (buf) + 1);
+  if (cmdline == NULL) goto failed_malloc_cmdline;
+  sprintf (cmdline, fmt, buf, cmd);
+  
+  /* Send the event and get the reply */
+  err = AECreateDesc (typeApplSignature, &toolserver_sig,
+                      sizeof (toolserver_sig), &serveraddr);
+  if (err != noErr) goto failed_AECreateDesc;
+  err = AECreateAppleEvent ('misc', 'dosc', &serveraddr, kAutoGenerateReturnID,
+                            kAnyTransactionID, &myevent);
+  if (err != noErr) goto failed_AECreateAppleEvent;
+  err = AEPutParamPtr (&myevent, '----', 'TEXT', cmdline, strlen (cmdline));
+  if (err != noErr) goto failed_AEPutParamPtr;
+  err = AESend (&myevent, &reply, kAEWaitReply + kAENeverInteract,
+                kAENormalPriority, kNoTimeOut, myIdleProcUPP, NULL);
+  if (err != noErr) goto failed_AESend;
+  err = AEGetParamPtr (&reply, 'errn', typeLongInteger, &ret_type,
+                       &event_status, sizeof (event_status), &ret_size);
+  if (err != noErr || event_status != noErr) goto failed_script;
+  err = AEGetParamPtr (&reply, 'stat', typeLongInteger, &ret_type,
+                       &event_status, sizeof (event_status), &ret_size);
+  if (err != noErr || event_status != noErr) goto failed_script;
+
+  /* forward stdout and stderr */
+  err = AEGetParamPtr (&reply, 'diag', typeChar, &ret_type,
+                       buf, buf_size, &ret_size);
+  if (err == noErr) ui_write (2, buf, ret_size);
+  err = AEGetParamPtr (&reply, '----', typeChar, &ret_type,
+                       buf, buf_size, &ret_size);
+  if (err == noErr) ui_write (1, buf, ret_size);
+  
+  AEDisposeDesc (&reply);
+  AEDisposeDesc (&myevent);
+  AEDisposeDesc (&serveraddr);
+  free (cmdline);
+  free (buf);
+  RotateCursor (32);
   return 0;
+
+  failed_script:
+    AEDisposeDesc (&reply);
+  failed_AESend:
+  failed_AEPutParamPtr:
+    AEDisposeDesc (&myevent);
+  failed_AECreateAppleEvent:
+    AEDisposeDesc (&serveraddr);
+  failed_AECreateDesc:
+    free (cmdline);
+  failed_malloc_cmdline:
+    free (buf);
+  failed_malloc_buf:
+    if (err != noErr) result = err;
+    else if (event_status != 0) result = event_status;
+    else result = 1;
+    if (result == 0 || result == -1) result = 1;
+    RotateCursor (32);
+    return result;
 }
diff --git a/byterun/macintosh.h b/byterun/macintosh.h
new file mode 100644
index 000000000..48807945a
--- /dev/null
+++ b/byterun/macintosh.h
@@ -0,0 +1,18 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Damien Doligez, projet Para, INRIA Rocquencourt          */
+/*                                                                     */
+/*  Copyright 1999 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License.         */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id$ */
+
+/* MacOS-specific stuff */
+
+#define WIFEXITED(x) 1
+#define WEXITSTATUS(x) (x)
diff --git a/utils/ccomp.ml b/utils/ccomp.ml
index ec7dd7eff..d0599b2f0 100644
--- a/utils/ccomp.ml
+++ b/utils/ccomp.ml
@@ -24,17 +24,33 @@ let command cmdline =
 
 let run_command cmdline = ignore(command cmdline)
 
+let quote = Filename.quote;;
+
 let compile_file name =
-  command
-   (Printf.sprintf
-     "%s -c %s %s -I%s %s"
-     !Clflags.c_compiler
-     (String.concat " " (List.rev !Clflags.ccopts))
-     (String.concat " "
-       (List.map (fun dir -> "-I" ^ dir) 
-                 (List.rev !Clflags.include_dirs)))
-     Config.standard_library
-     name)
+  match Sys.os_type with
+  | "MacOS" ->
+     let qname = quote name in
+     let includes = Config.standard_library :: !Clflags.include_dirs in
+     let args =
+       Printf.sprintf " %s %s -i %s"
+         (String.concat " " (List.rev_map quote !Clflags.ccopts))
+         (String.concat "," (List.rev_map quote includes))
+         qname
+     in
+     run_command ("sc " ^ args ^ " -o " ^ qname ^ ".o");
+     command ("mrc " ^ args ^ " -o " ^ qname ^ ".x")
+  | _ ->
+     command
+       (Printf.sprintf
+         "%s -c %s %s -I%s %s"
+         !Clflags.c_compiler
+         (String.concat " " (List.rev !Clflags.ccopts))
+         (String.concat " "
+           (List.map (fun dir -> "-I" ^ dir) 
+                     (List.rev !Clflags.include_dirs)))
+         Config.standard_library
+         name)
+;;
 
 let create_archive archive file_list =
   Misc.remove_file archive;