compat: Add prompts for Mes.

* gash/compat.scm [mes] (make-prompt-tag): Return a fluid.
[mes] (abort-to-prompt): New procedure.
[mes] (call-with-prompt): New procedure.

gash/compat.scm

@@ -92,6 +92,8 @@
           the-eof-object
           noop
           make-prompt-tag
+          call-with-prompt
+          abort-to-prompt
           canonicalize-path
           X_OK
           program-arguments
@@ -152,7 +154,47 @@
   (define (noop . args) #f)
 
   (define* (make-prompt-tag #:optional (stem "prompt"))
-    (list stem))
+    (make-fluid (lambda args (error "Abort to unknown prompt"))))
+
+  (define (abort-to-prompt tag . args)
+    (call-with-current-continuation
+     (lambda (cc)
+       (apply (fluid-ref tag) cc args))))
+
+  (define (call-with-prompt tag thunk handler)
+    ;; We are going to wrap THUNK and HANDLER so that they both adhere
+    ;; to the same interface.  They will both return a list, with the
+    ;; first element being a procedure to apply to the rest of the
+    ;; elements.  Then, in the normal case, we will set the first
+    ;; element to the identity procedure so that it just passes along
+    ;; what THUNK would have returned.  In the case where the thunk
+    ;; aborts to the prompt, we set the first element to HANDLER so that
+    ;; it can be invoked after te stack has been unwound.
+
+    ;; XXX: We should handle multiple values, but Mes has some bugs
+    ;; which makes this difficult.
+
+    ;; This is the normal case: collect the values returned by THUNK,
+    ;; and wrap them with a "handler" procedure ('identity'), which will
+    ;; just return them as-is.
+    (define (return-normally)
+      (cons identity (list (thunk))))
+
+    ;; Here the thunk has aborted to the prompt, so we need to unwind
+    ;; the stack (using KONT), and use HANDLER itself as the handler
+    ;; procedure.
+    (define (make-handler-return kont)
+      (lambda args
+        (kont (cons handler args))))
+
+    ;; This is the part the invokes the handlers described above.
+    (let* ((handler+args (call-with-current-continuation
+                          (lambda (kont)
+                            (with-fluids ((tag (make-handler-return kont)))
+                              (return-normally)))))
+           (handler (car handler+args))
+           (args (cdr handler+args)))
+      (apply handler args)))
 
   ;; XXX: Actually implement this.
   (define (canonicalize-path path) path)