diff --git a/clim/activities.lisp b/clim/activities.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..a4a8123c96717439fe687321e0216b611d226121
--- /dev/null
+++ b/clim/activities.lisp
@@ -0,0 +1,243 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1991, 1992 Franz, Inc.  All rights reserved."
+
+
+
+(defclass activity () 
+	  ((frames :initform nil :accessor activity-frames)
+	   (pretty-name :accessor activity-pretty-name)
+	   (top-level-process :initform nil)
+	   (active-frame :initform nil :initarg :initial-frame :accessor activity-active-frame)
+	   (input-buffer :initform (make-locking-queue) :accessor activity-input-buffer)
+	   (auto-select :initform nil :initarg :auto-select :accessor activity-auto-select)
+	   ))
+
+(defmethod initialize-instance :after ((activity activity) &key pretty-name)
+  (setf (activity-pretty-name activity)
+    (or pretty-name (title-capitalize (string (type-of activity))))))
+
+(defmethod run-activity-top-level :around ((activity activity) &key &allow-other-keys)
+  (with-simple-restart (activity-exit "Exit activity ~A" (activity-pretty-name activity))
+    (loop
+      (with-simple-restart (nil "~A top level" (activity-pretty-name activity))
+	(loop
+	  #-CCL-2
+	  (return-from run-activity-top-level (call-next-method))
+	  #+CCL-2
+	  (let ((results (multiple-value-list (call-next-method))))
+	    (return-from run-activity-top-level (values-list results))))))))
+
+(defmethod activity-exit ((activity activity))
+  (invoke-restart 'activity-exit))
+
+(defmethod run-activity-top-level ((activity activity) &key &allow-other-keys)
+  (with-slots (top-level-process) activity
+    (when top-level-process
+      (cerror "Bludgeon ahead, assuming the risk"
+	      "The process ~S is already running the top-level function for frame ~S"
+	      top-level-process activity))
+    (unwind-protect
+	(progn
+	  (setq top-level-process (current-process))
+	  (default-activity-top-level activity))
+      (setq top-level-process nil))))
+
+(defvar *activity* nil)
+
+(defmethod default-activity-top-level ((activity activity))
+  (unless (activity-active-frame activity)
+    (setf (activity-active-frame activity)
+          (or (car (active-frames activity))
+	      (start-initial-application-frame activity))))
+  (loop
+    (let ((*activity* activity)
+	  (*original-stream* nil)
+	  (*input-wait-test* nil)
+	  (*input-wait-handler* nil)
+	  (*pointer-button-press-handler* nil)
+	  (*numeric-argument* nil)
+	  (*delimiter-gestures* nil)
+	  (*activation-gestures* nil)
+	  (*accelerator-gestures* nil)
+	  (*accelerator-numeric-argument* nil)
+	  (*input-context* nil)
+	  (*accept-help* nil)
+	  (*assume-all-commands-enabled* nil)
+	  (*command-parser* 'command-line-command-parser)
+	  (*command-unparser* 'command-line-command-unparser)
+	  (*partial-command-parser*
+	   'command-line-read-remaining-arguments-for-partial-command) 
+	  ;; Start these out nowhere
+	  ;;-- Surely these are bound by the frame top level
+	  ;; (*standard-output* nil)
+	  ;; (*standard-input* nil)
+	  ;; (*query-io* nil)
+	  (*pointer-documentation-output* nil))
+      (loop
+	(with-simple-restart (nil "~A top level" (activity-pretty-name activity))
+	  (catch 'window-resynchronize
+	    (unless (activity-active-frame activity)
+	      (setf (activity-active-frame activity)
+		(car (activity-frames activity))))
+	    (unless (activity-active-frame activity)
+	      (activity-exit activity))
+	    (let* ((frame (activity-active-frame activity))
+		   (*application-frame* frame)
+		   (top-level (frame-top-level frame)))
+	      (unwind-protect
+		  (loop
+		    (catch 'layout-changed
+		      (with-frame-manager ((frame-manager frame))
+			(setf (slot-value frame 'top-level-process)
+			  (slot-value activity 'top-level-process))
+			(if (atom top-level)
+			    (funcall top-level frame)
+			  (apply (first top-level) frame (rest top-level))))
+		      (break "do something")))
+		(setf (slot-value frame 'top-level-process) nil)))))))))
+
+
+;;;--- 
+
+(defclass activity-frame (standard-application-frame)
+	  ((activity :initform nil :accessor frame-activity :initarg :activity)))
+
+
+
+(defgeneric activity-quit (activity)
+  (:documentation "Closes all frames and exits the top-level-loop")
+  (:method ((activity activity))
+   (dolist (frame (frame-manager-frames activity))
+     (close-application-frame activity frame))))
+
+(defgeneric start-initial-application-frame (activity)
+  (:documentation 
+   "Starts the initial application, when the activity is startet up. ~
+    There is no default method, so subclasses MUST implement this."))
+
+(defgeneric start-application-frame (activity &rest frame-options)
+  (:documentation 
+   "Starts an application frame and registers it in the activity. ~
+    The frame is exposed, so appropriate handlers will probably make it ~
+    the active frame. This function must be run inside a command to ~
+    synchronize the command loop."))
+
+(defgeneric close-application-frame (activity frame)
+  (:documentation 
+   "Closes the application-frame frame and de-registers it in the activity. ~
+    The frame is de-exposed, so appropriate handlers will probably make another ~
+    frame the active frame. This function must be run inside a command to ~
+    synchronize the command loop."))
+
+(defmethod start-application-frame ((activity activity) &rest frame-options)
+  (let* ((frame (apply #'make-application-frame 
+                       (append frame-options
+                               (list :input-buffer (activity-input-buffer activity)
+				     :activity activity)))))
+    (enable-frame frame)
+    (push frame (activity-frames activity))
+    frame))
+
+
+(defmethod close-application-frame  ((activity activity) (frame activity-frame))
+  ;; do we have to take care of the input-buffer that it will not be reused by
+  ;; some magic resource mechanism?
+  (disable-frame frame)
+  (setf (activity-frames activity) (remove frame (activity-frames activity)))
+  (setf (frame-activity frame) nil)
+  (when (eq frame (activity-active-frame activity))
+    (if (activity-frames activity)
+	(setf (activity-active-frame activity) nil)
+      (activity-exit activity))))
+
+
+;;;
+;;; callbacks from the window manager
+;;;
+
+
+(defgeneric activity-frame-window-select (activity-frame)
+  (:documentation 
+   "This function is called when the window manager of the host's display server ~
+    selects the (a?) window of the frame activity-frame. Methods can specialize ~
+    on this callback to provide customized behavior -- e.g. dependent from the ~
+    state of the CP throw out of the command loop or not. (see example code). ~
+    The default method sets activity-frame as the active frame and throws to ~
+    the tag 'window-resynchronize to restart the command loop.")
+  (:method  ((frame activity-frame))
+	    ;;--- We should think about exporting the cp-state and so
+	    ;;--- give the the application more of a chance.
+	    (let ((activity (frame-activity frame)))
+	      (when (and (frame-activity frame) 
+			 (activity-auto-select activity)
+			 *input-buffer-empty* *reading-frame-command*)
+		(select-activity-active-frame activity frame)))))
+
+(defun select-activity-active-frame (activity frame)
+  ;;-- Mark current frame in need of throwing
+  (setf (activity-active-frame activity) frame)
+  (throw 'window-resynchronize :window-resynchronize))
+
+(defmethod activity-frame-window-select :around ((activity-frame activity-frame))
+  (unless (eq activity-frame (activity-active-frame (frame-activity activity-frame)))
+    (call-next-method)))
+
+(defmethod receive-gesture :after ((stream top-level-sheet)
+				   (gesture pointer-enter-event))
+  (unless (eq (pointer-boundary-event-kind gesture) :inferior)
+    (let ((frame (pane-frame stream)))
+      (when (typep frame 'activity-frame)
+	(activity-frame-window-select frame)))))
+
+(defgeneric activity-frame-window-close (activity-frame)
+  (:documentation
+   "This function is called when the window manager of the host's display server ~
+    closes the (a?) window of the frame activity-frame. Methods can specialize ~
+    on this callback to provide customized behavior. ~
+    The default method calls close-application-frame on the frame's activity and ~
+    the frame as arguments.")
+  (:method  ((frame activity-frame))
+            (when (frame-activity frame)
+              (close-application-frame (frame-activity frame) frame)
+	      ;; we dont want throw out from here, dont we?
+	      ;;-- Mark current frame in need of throwing
+              ;(throw 'window-resynchronize :window-resynchronize)
+              )))
+
+(defmethod frame-exit ((frame activity-frame))
+  (activity-frame-window-close frame))
+
+
+(defmethod redisplay-frame-panes ((frame activity-frame) &rest options)
+  ;; First display all the :accept-values panes, then display the rest.
+  ;; We do this to ensure that all side-effects from :accept-values panes
+  ;; have taken place.
+  (apply #'redisplay-activity-panes (frame-activity frame) options))
+
+(defmethod redisplay-activity-panes ((activity activity) &key force-p)
+  (dolist (frame (activity-frames activity))
+    (map-over-sheets #'(lambda (sheet)
+			 (when (typep sheet 'accept-values-pane)
+			   (redisplay-frame-pane frame sheet :force-p force-p)))
+		     (frame-top-level-sheet frame)))
+  (dolist (frame (activity-frames activity))
+    (map-over-sheets #'(lambda (sheet)
+			 (when (and (typep sheet 'clim-stream-pane)
+				    (not (typep sheet 'accept-values-pane)))
+			   (redisplay-frame-pane frame sheet :force-p force-p)))
+		     (frame-top-level-sheet frame))))
+
+(defmethod disable-frame :after ((frame activity-frame))
+  (let ((activity (frame-activity frame)))
+    (when (and activity (eq (activity-active-frame frame) frame))
+      (setf (activity-active-frame frame) nil)
+      ;;--- Need to resynchronize at this point
+      ;;--- We should set flag in frame so that the default top level
+      ;;--- notices this and exits or throws
+      )))
diff --git a/demo/demo-activity.lisp b/demo/demo-activity.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..bffbee6ab3ae4b34d8006fc7e8a7f89cd0717fea
--- /dev/null
+++ b/demo/demo-activity.lisp
@@ -0,0 +1,76 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: clim-demo; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1991, 1992 Franz, Inc.  All rights reserved."
+
+
+
+(defclass demo-activity (activity)
+  nil)
+
+
+(define-application-frame demo-app (activity-frame)
+			  ()
+  (:panes
+   (interactor :interactor)
+    (display :application))
+  (:pointer-documentation t)
+  (:layouts
+   (default (vertically () (1/2 interactor) (:fill display)))))
+
+(define-demo-app-command (com-activity-exit :menu t :name "Exit")
+                            ()
+  (activity-frame-window-close *application-frame*))
+
+(defvar *untitled-count* 1
+  "Counter for naming new, untitled document windows")
+
+;;; This method must be implemented by subclasses of activity
+(defmethod start-initial-application-frame ((activity demo-activity))
+  (start-application-frame activity
+                           'demo-app 
+                           :width 200
+                           :height 200
+                           :pretty-name "Initial"))
+
+
+(define-demo-app-command (com-new :menu t :name t)
+                            ((name 'string 
+                                   :prompt "Name of Window"
+                                   :default (format nil "Untitled-~A" *untitled-count*)
+                                   :display-default t
+                                   :documentation "A Title String"))
+  (start-application-frame (frame-activity *application-frame*)
+                           'demo-app
+                           :width 200
+                           :height 200
+                           :pretty-name name)
+  (incf *untitled-count*))
+
+
+(define-demo-app-command (com-select-frame :name t :menu t) 
+    ((frame `((member ,@(activity-frames *activity*)) :name-key ,#'frame-pretty-name)))
+  (select-activity-active-frame *activity* frame))
+
+(define-demo-app-command (com-funky-add :name t :menu t) 
+                            ((n 'number))
+ (flet ((print-random-sum (stream n)
+           (let ((sum (+ n (random 20) -10)))
+             (with-output-as-presentation (stream sum 'number)
+               (format stream "~%~A plus ~A gives ~A" n (- sum n) sum)))))
+   (print-random-sum (get-frame-pane *application-frame* 'display) n)))
+
+;; This one gives a nicer pointer doc than the default one by  the
+;; :gesture option of define-command
+
+(define-presentation-to-command-translator add-number
+        (number com-funky-add demo-app
+                :pointer-documentation ((stream object)
+                                (format stream "Add something to ~A" object)))
+        (object)
+  `(,object))
+