From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Mon, 15 Apr 2013 05:36:37 +0000 (-0700)
Subject: gtk-screen: Add spawn-edit.
X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~45
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=209b7905c82bdfefb64f329e406c4c2d00f279cf;p=mit-scheme.git

gtk-screen: Add spawn-edit.
---

diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg
index e41a6a5fb..f9be66f5a 100644
--- a/src/gtk-screen/gtk-screen.pkg
+++ b/src/gtk-screen/gtk-screen.pkg
@@ -32,6 +32,7 @@ USA.
   (files "gtk-screen" "gtk-faces")
   (parent (edwin screen))
   (export ()
+	  spawn-edit
 	  set-gtk-screen-hooks!)
   (export (edwin)
 	  ;; edwin-variable$x-cut-to-clipboard
diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index c96f54af2..185cb5f3e 100644
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -704,6 +704,25 @@ USA.
 			   with-gtk-interrupts-enabled
 			   with-gtk-interrupts-disabled))
   unspecific)
+
+(define (spawn-edit . args)
+  (cond (edwin-editor
+	 (error "Edwin is already running."))
+	((let ((types (editor-display-types)))
+	   (and (pair? types)
+		(eq? 'console (display-type/name (car types)))
+		(null? (cdr types))))
+	 (error "Edwin must run on the console."))
+	(else
+	 (call-with-current-continuation
+	  (lambda (continue)
+	    (detach-thread
+	     (create-thread continue
+	       (lambda ()
+		 (set! editor-can-exit? #t)
+		 (set! paranoid-exit? #t)
+		 (apply edit args)
+		 (stop-current-thread)))))))))
 
 (define (update-widgets screen)
   (%trace ";   update-widgets "screen"\n")