[nongnu] elpa/sweeprolog b6e444bbdc 152/166: FIXED: remove message_hook during cleanup to avoid possible crash

[ELPA Syncer]

branch: elpa/sweeprolog
commit b6e444bbdca1a619d6800f36b3571a62b37b29de
Author: Eshel Yaron <me@eshelyaron.com>
Commit: Eshel Yaron <me@eshelyaron.com>

    FIXED: remove message_hook during cleanup to avoid possible crash
---
 sweep.c       | 86 +++++++++++++++++++++++++++++------------------------------
 sweep.pl      | 74 ++++++++++++++++++++++++++++++++++++++++++++++++--
 sweeprolog.el | 42 ++++++++++++++++++-----------
 3 files changed, 141 insertions(+), 61 deletions(-)

diff --git a/sweep.c b/sweep.c
index 301362b862..a9f804e8b8 100644
--- a/sweep.c
+++ b/sweep.c
@@ -447,6 +447,46 @@ sweep_open_query(emacs_env *env, ptrdiff_t nargs, 
emacs_value *args, void *data)
   return r;
 }
 
+static foreign_t
+sweep_funcall0(term_t f, term_t v) {
+  char * string = NULL;
+  emacs_value r = NULL;
+  size_t      l = -1;
+  term_t      n = PL_new_term_ref();
+
+  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
+    r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 0, NULL);
+    if (value_to_term(current_env, r, n) >= 0) {
+      if (PL_unify(n, v)) {
+        return TRUE;
+      }
+    }
+  }
+  return FALSE;
+}
+
+static foreign_t
+sweep_funcall1(term_t f, term_t a, term_t v) {
+  char * string = NULL;
+  emacs_value e = NULL;
+  emacs_value r = NULL;
+  size_t      l = -1;
+  term_t      n = PL_new_term_ref();
+
+  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
+    e = term_to_value(current_env, a);
+    if (e != NULL) {
+      r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 1, &e);
+      if (value_to_term(current_env, r, n) >= 0) {
+        if (PL_unify(n, v)) {
+          return TRUE;
+        }
+      }
+    }
+  }
+  return FALSE;
+}
+
 static emacs_value
 sweep_initialize(emacs_env *env, ptrdiff_t nargs, emacs_value *args, void 
*data)
 {
@@ -467,6 +507,9 @@ sweep_initialize(emacs_env *env, ptrdiff_t nargs, 
emacs_value *args, void *data)
   if (PL_version_info(PL_VERSION_SYSTEM < 80516))
     PL_action(PL_GMP_SET_ALLOC_FUNCTIONS, FALSE);
 
+  PL_register_foreign("sweep_funcall", 3, sweep_funcall1, 0);
+  PL_register_foreign("sweep_funcall", 2, sweep_funcall0, 0);
+
   r = PL_initialise(nargs, argv);
 
   for (i = 0; i < nargs; i++) {
@@ -505,46 +548,6 @@ static void provide(emacs_env *env, const char *feature) {
   env->funcall(env, Qprovide, 1, (emacs_value[]){Qfeat});
 }
 
-static foreign_t
-sweep_funcall0(term_t f, term_t v) {
-  char * string = NULL;
-  emacs_value r = NULL;
-  size_t      l = -1;
-  term_t      n = PL_new_term_ref();
-
-  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
-    r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 0, NULL);
-    if (value_to_term(current_env, r, n) >= 0) {
-      if (PL_unify(n, v)) {
-        return TRUE;
-      }
-    }
-  }
-  return FALSE;
-}
-
-static foreign_t
-sweep_funcall1(term_t f, term_t a, term_t v) {
-  char * string = NULL;
-  emacs_value e = NULL;
-  emacs_value r = NULL;
-  size_t      l = -1;
-  term_t      n = PL_new_term_ref();
-
-  if (PL_get_nchars(f, &l, &string, CVT_STRING|REP_UTF8)) {
-    e = term_to_value(current_env, a);
-    if (e != NULL) {
-      r = current_env->funcall(current_env, current_env->intern(current_env, 
string), 1, &e);
-      if (value_to_term(current_env, r, n) >= 0) {
-        if (PL_unify(n, v)) {
-          return TRUE;
-        }
-      }
-    }
-  }
-  return FALSE;
-}
-
 int
 emacs_module_init (struct emacs_runtime *runtime)
 {
@@ -627,9 +630,6 @@ This function drops the current instantiation of the query 
variables.",
   emacs_value args_cleanup[] = {symbol_cleanup, func_cleanup};
   env->funcall (env, env->intern (env, "defalias"), 2, args_cleanup);
 
-  PL_register_foreign("sweep_funcall", 3, sweep_funcall1, 0);
-  PL_register_foreign("sweep_funcall", 2, sweep_funcall0, 0);
-
   provide(env, "sweep-module");
 
   return 0;
diff --git a/sweep.pl b/sweep.pl
index b1fba490bb..afaa97150e 100644
--- a/sweep.pl
+++ b/sweep.pl
@@ -55,6 +55,8 @@
             sweep_op_info/2,
             sweep_imenu_index/2,
             sweep_module_path/2,
+            sweep_top_level_server/2,
+            sweep_accept_top_level_client/2,
             write_sweep_module_location/0
           ]).
 
@@ -76,6 +78,7 @@
 
 :- dynamic sweep_current_color/3,
            sweep_open/2,
+           sweep_top_level_thread_buffer/2,
            sweep_source_time/2,
            sweep_current_comment/3.
 
@@ -671,11 +674,12 @@ sweep_path_module(Path0, Module) :-
 
 
 sweep_setup_message_hook(_, _) :-
-    retractall(user:thread_message_hook(_, _, _)),
     asserta((
              user:thread_message_hook(Term, Kind, Lines) :-
                  sweep_message_hook(Term, Kind, Lines)
-             )).
+            ),
+            Ref),
+    at_halt(erase(Ref)).
 
 sweep_message_hook(Term, Kind0, _Lines) :-
     should_handle_message_kind(Kind0, Kind),
@@ -745,3 +749,69 @@ write_sweep_module_location :-
                        Path,
                        [file_type(executable), access(read)]),
     writeln(Path).
+
+sweep_top_level_server(_, Port) :-
+    tcp_socket(ServerSocket),
+    tcp_setopt(ServerSocket, reuseaddr),
+    tcp_bind(ServerSocket, Port),
+    tcp_listen(ServerSocket, 5),
+    thread_create(sweep_top_level_server_loop(ServerSocket), T,
+                  [ alias(sweep_top_level_server)
+                  ]),
+    at_halt((   is_thread(T),
+                thread_property(T, status(running))
+            ->  thread_signal(T, thread_exit(0)),
+                thread_join(T, _)
+            ;   true
+            )).
+
+sweep_top_level_server_loop(ServerSocket) :-
+    thread_get_message(Message),
+    sweep_top_level_server_loop_(Message, ServerSocket).
+
+sweep_top_level_server_loop_(accept(Buffer), ServerSocket) :-
+    !,
+    tcp_accept(ServerSocket, Slave, Peer),
+    tcp_open_socket(Slave, InStream, OutStream),
+    set_stream(InStream, close_on_abort(false)),
+    set_stream(OutStream, close_on_abort(false)),
+    thread_create(sweep_top_level_client(InStream, OutStream, Peer), T, 
[detached(true)]),
+    at_halt((   is_thread(T),
+                thread_property(T, status(running))
+            ->  thread_signal(T, thread_exit(0)),
+                thread_join(T, _)
+            ;   true
+            )),
+    thread_property(T, id(Id)),
+    asserta(sweep_top_level_thread_buffer(Id, Buffer)),
+    sweep_top_level_server_loop(ServerSocket).
+sweep_top_level_server_loop_(_, _).
+
+sweep_top_level_client(InStream, OutStream, ip(127,0,0,1)) :-
+    !,
+    set_prolog_IO(InStream, OutStream, OutStream),
+    set_stream(InStream, tty(true)),
+    set_prolog_flag(tty_control, false),
+    current_prolog_flag(encoding, Enc),
+    set_stream(user_input, encoding(Enc)),
+    set_stream(user_output, encoding(Enc)),
+    set_stream(user_error, encoding(Enc)),
+    set_stream(user_input, newline(detect)),
+    set_stream(user_output, newline(dos)),
+    set_stream(user_error, newline(dos)),
+    call_cleanup(prolog,
+                 ( close(InStream, [force(true)]),
+                   close(OutStream, [force(true)]),
+                   thread_self(Self),
+                   thread_property(Self, id(Id)),
+                   retractall(sweep_top_level_thread_buffer(Id, _))
+                 )).
+sweep_top_level_client(InStream, OutStream, _) :-
+    close(InStream),
+    close(OutStream),
+    thread_self(Self),
+    thread_property(Self, id(Id)),
+    retractall(sweep_top_level_thread_buffer(Id, _)).
+
+sweep_accept_top_level_client(Buffer, _) :-
+    thread_send_message(sweep_top_level_server, accept(Buffer)).
diff --git a/sweeprolog.el b/sweeprolog.el
index e1c3cd9928..523e536b74 100644
--- a/sweeprolog.el
+++ b/sweeprolog.el
@@ -277,9 +277,9 @@ FLAG and VALUE are specified as strings and read as Prolog 
terms."
 
 (defun sweeprolog-start-prolog-server ()
   (sweeprolog-open-query "user"
-                    "prolog_server"
-                    "prolog_server"
-                    nil t)
+                         "sweep"
+                         "sweep_top_level_server"
+                         nil)
   (let ((sol (sweeprolog-next-solution)))
     (sweeprolog-close-query)
     (when (sweeprolog-true-p sol)
@@ -1164,7 +1164,9 @@ module name, F is a functor name and N is its arity."
      ;;  (remove-list-of-text-properties beg end '(font-lock-face)))
      (sweeprolog-grammar-rule-face))
     ("method"              (sweeprolog-method-face))
-    ("class"               (sweeprolog-class-face))))
+    ("class"               (sweeprolog-class-face))
+    ;; (_ (message "%S" arg) nil)
+    ))
 
 (defun sweeprolog--colourise (args)
   "ARGS is a list of the form (BEG LEN . SEM)."
@@ -1173,7 +1175,7 @@ module name, F is a functor name and N is its arity."
              (arg (cddr args))
              (flf (sweeprolog--colour-term-to-face arg)))
     (with-silent-modifications
-      (font-lock--add-text-property beg end 'font-lock-face flf 
(current-buffer) nil))))
+      (put-text-property beg end 'font-lock-face flf))))
 
 (defun sweeprolog-colourise-buffer (&optional buffer)
   (interactive)
@@ -1254,9 +1256,9 @@ buffer to load."
            (end (point-max))
            (contents (buffer-substring-no-properties beg end)))
       (sweeprolog-open-query "user"
-                        "sweep"
-                        "sweep_load_buffer"
-                        (cons contents (buffer-file-name)))
+                             "sweep"
+                             "sweep_load_buffer"
+                             (cons contents (buffer-file-name)))
       (let ((sol (sweeprolog-next-solution)))
         (sweeprolog-close-query)
         (if (sweeprolog-true-p sol)
@@ -1281,14 +1283,22 @@ Interactively, a prefix arg means to prompt for BUFFER."
                                (generate-new-buffer-name 
"*sweeprolog-top-level*"))))))
      (list buffer)))
   (let ((buf (get-buffer-create (or buffer "*sweeprolog-top-level*"))))
-   (with-current-buffer buf
-     (unless (eq major-mode 'sweeprolog-top-level-mode)
-       (sweeprolog-top-level-mode)))
-   (make-comint-in-buffer "sweeprolog-top-level"
-                          buf
-                          (cons "localhost"
-                                sweeprolog-prolog-server-port))
-   (pop-to-buffer buf sweeprolog-top-level-display-action)))
+    (with-current-buffer buf
+      (unless (eq major-mode 'sweeprolog-top-level-mode)
+        (sweeprolog-top-level-mode)))
+    (sweeprolog-open-query "user"
+                           "sweep"
+                           "sweep_accept_top_level_client"
+                           (buffer-name buf))
+    (let ((sol (sweeprolog-next-solution)))
+      (sweeprolog-close-query)
+      (unless (sweeprolog-true-p sol)
+        (error "Failed to create new top-level!")))
+    (make-comint-in-buffer "sweeprolog-top-level"
+                           buf
+                           (cons "localhost"
+                                 sweeprolog-prolog-server-port))
+    (pop-to-buffer buf sweeprolog-top-level-display-action)))
 
 (defun sweeprolog-top-level--post-self-insert-function ()
   (when-let ((pend (cdr comint-last-prompt)))