diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..763850a64509315f435b83c048a00f3e40b2f3aa
--- /dev/null
+++ b/clim/drag-and-drop.lisp
@@ -0,0 +1,291 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-internals)
+
+"Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+
+;;; Direct manipulation ("click and drag", "drag and drop") translators
+
+(defclass drag-and-drop-translator (presentation-translator)
+    ((destination-type :initarg :destination-type
+		       :reader presentation-translator-destination-type)
+     (feedback :initform nil :initarg :feedback
+	       :reader presentation-translator-feedback)
+     (highlighting :initform nil :initarg :highlighting
+		   :reader presentation-translator-highlighting)
+     ;; The body, tester, and documentation supplied by the programmer.
+     ;; DEFINE-DRAG-AND-DROP-TRANSLATOR uses the other body, tester,
+     ;; and documentaiton slots for its own purposes
+     (real-body :initarg :real-body
+		:reader presentation-translator-real-body)
+     (real-tester :initform nil :initarg :real-tester
+		  :reader presentation-translator-real-tester)
+     (real-documentation :initform nil :initarg :real-documentation
+			 :reader presentation-translator-real-documentation)))
+
+(defmethod print-object ((object drag-and-drop-translator) stream)
+  (if *print-escape*
+      (print-unreadable-object (object stream :type t :identity t)
+	(with-slots (name from-type destination-type to-type) object
+	  (format stream "~S (~S x ~S -> ~S)"
+	    name from-type destination-type to-type)))
+      (print-unreadable-object (object stream :type t :identity t)
+	(with-slots (name from-type to-type) object
+	  (format stream "~S" name)))))
+
+(defmacro define-drag-and-drop-translator
+	  (name
+	   (from-type to-type destination-type command-table
+	    &key (gesture ':select) tester
+		 documentation (menu t) priority
+		 feedback highlighting)
+	   arglist
+	   &body body)
+  #+Genera (declare (zwei:indentation 1 3 3 1))
+  (with-warnings-for-definition name define-presentation-translator
+    (multiple-value-bind (body-function body-name)
+	(write-translator-function (cons arglist body) name 'real-body
+				   '(destination-object destination-presentation))
+      (multiple-value-bind (tester-function tester-name)
+	  (when tester
+	    (write-translator-function tester name 'real-tester
+				       '(destination-object destination-presentation)))
+	(multiple-value-bind (doc-function doc-name)
+	    (if (stringp documentation)
+		(values nil documentation)
+	        (when documentation
+		  (write-translator-function 
+		    documentation name 'real-doc
+		    '(destination-object destination-presentation stream))))
+	  (multiple-value-bind (feedback-function feedback-name)
+	      (if (symbolp feedback)
+		  (values nil (or feedback 'frame-drag-and-drop-feedback))
+		  (write-drag-and-drop-function 
+		    feedback name 'feedback
+		    '(frame presentation stream initial-x initial-y new-x new-y state)))
+	    (multiple-value-bind (highlighting-function highlighting-name)
+		(if (symbolp highlighting)
+		    (values nil (or highlighting 'frame-drag-and-drop-highlighting))
+		    (write-drag-and-drop-function
+		      highlighting name 'highlighting
+		      '(frame presentation stream state)))
+	      `(progn
+		 (define-presentation-translator-1 ,name
+		     (,from-type ,to-type ,command-table
+		      :gesture ,gesture
+		      :tester nil
+		      :tester-definitive t
+		      :documentation "Drag presentation"
+		      :pointer-documentation "Drag presentation"
+		      :menu ,menu
+		      :priority ,priority
+		      :translator-class drag-and-drop-translator
+		      :destination-type ',destination-type
+		      :real-body ',body-name
+		      :feedback ',feedback-name
+		      :highlighting ',highlighting-name
+		      ,@(when tester `(:real-tester ',tester-name))
+		      ,@(when documentation `(:real-documentation ',doc-name)))
+		     ,*translator-function-arglist*
+		   (invoke-drag-and-drop-translator ,@*translator-function-arglist*))
+		 ,body-function
+		 ,tester-function
+		 ,doc-function
+		 ,feedback-function
+		 ,highlighting-function))))))))
+
+(defun write-drag-and-drop-function (function translator-name clause-name args)
+  (let ((function-name (gensymbol translator-name clause-name))
+	(arglist (first function))
+	(body (rest function)))
+    (multiple-value-bind (arglist ignores)
+	(canonicalize-and-match-lambda-lists args arglist)
+      (values `(defun ,function-name ,arglist
+		 ,@(and ignores `((declare (ignore ,@ignores))))
+		 ,@body)
+	      function-name))))
+
+;; All the drag-and-drop translators that satisfy the current from-type,
+;; to-type, and gesture will get here.  However, the translator now being
+;; run is not necessarily the right one.  What we do here is to track the 
+;; pointer until the destination presentation has been reached, choose the
+;; correct translator and run it.
+(defun invoke-drag-and-drop-translator (object presentation context-type
+					frame event window x y)
+  (let* ((command-table (frame-command-table frame))
+	 (translators
+	   (let ((all-translators
+		   (find-presentation-translators
+		     (presentation-type presentation) context-type command-table)))
+	     ;; This find all translators that could conceivably apply
+	     (mapcan #'(lambda (translator)
+			 (when (and (typep translator 'drag-and-drop-translator)
+				    (test-presentation-translator
+				      translator presentation context-type
+				      frame window x y :event event))
+			   (list translator)))
+		     all-translators)))
+	 (destination-types
+	   ;; So we can let TRACKING-POINTER do the work of finding applicable
+	   ;; destination presentations...
+	   (mapcar #'presentation-translator-destination-type translators))
+	 ;; Get the feedback and highlighting functions
+	 ;;--- This should really check to make sure that the feedback and
+	 ;;--- highlighting functions are the same for the set of translators
+	 (feedback
+	   (and translators (presentation-translator-feedback (first translators))))
+	 (highlighting
+	   (and translators (presentation-translator-highlighting (first translators))))
+	 (initial-x x)
+	 (initial-y y)
+	 last-x last-y
+	 (from-presentation presentation)
+	 ;; The presentation we finally landed on, and the event used
+	 (destination nil)
+	 (destination-event nil)
+	 ;; Defeat the normal gesture processing stuff
+	 (*input-wait-handler* nil)
+	 (*input-wait-test* nil)
+	 (*pointer-button-press-handler* nil))
+    (read-gesture :stream window :timeout 0)	;eat the initial mouse click
+    (unhighlight-highlighted-presentation window)
+    (when (null translators)
+      (return-from invoke-drag-and-drop-translator nil))
+    (flet ((find-translator (destination)
+	     (let* ((translator
+		      (find (presentation-type destination) translators
+			    :key #'presentation-translator-destination-type
+			    :test #'presentation-subtypep))
+		    (tester
+		      (and translator (presentation-translator-real-tester translator))))
+	       (when (or (null tester)
+			 (funcall tester
+				  object presentation context-type
+				  frame event window x y
+				  (presentation-object destination) destination))
+		 translator))))
+      (declare (dynamic-extent #'find-translator))
+      (macrolet ((feedback (x y state)
+		   `(funcall feedback frame from-presentation window 
+				      initial-x initial-y ,x ,y ,state))
+		 (highlight (presentation state)
+		   `(when ,presentation
+		      (funcall highlighting frame ,presentation window 
+					    ,state))))
+	(block drag-presentation
+	  (tracking-pointer (window :context-type `((or ,@destination-types))
+				    :multiple-window t :highlight nil)
+	    (:presentation-button-press (presentation event)
+	     (highlight destination :unhighlight)
+	     (setq destination presentation
+		   destination-event event)
+	     (return-from drag-presentation))
+	    (:pointer-button-press (event)
+	     (highlight destination :unhighlight)
+	     (setq destination nil
+		   destination-event event)
+	     (return-from drag-presentation))
+	    (:presentation (presentation window x y)
+	     (when last-x
+	       (feedback last-x last-y :unhighlight))
+	     (setq last-x x
+		   last-y y)
+	     (feedback x y :highlight)
+	     (when (not (eq presentation destination))
+	       (highlight destination :unhighlight)
+	       (setq destination presentation)
+	       (highlight presentation :highlight)
+	       #+++ignore				;--- documentation
+	       (let ((translator (find-translator destination)))
+		 (when translator
+		   (let ((documentation
+			   (presentation-translator-real-documentation translator)))
+		     (if (stringp documentation)
+			 (write-string documentation doc-stream)
+		         (funcall documentation 
+				  (presentation-object presentation) presentation context-type
+				  frame event window x y
+				  (presentation-object destination) destination
+				  doc-stream)))))))
+	    (:pointer-motion (window x y)
+	     (highlight destination :unhighlight)
+	     (setq destination nil)
+	     (when last-x
+	       (feedback last-x last-y :unhighlight))
+	     (setq last-x x
+		   last-y y)
+	     (feedback x y :highlight))))
+	(when last-x
+	  (feedback last-x last-y :unhighlight)))
+      ;; The user has put down the presentation, figure out what to do
+      ;;--- What if there is more than one translator?
+      (let ((translator (find-translator destination)))
+	(when translator
+	  (multiple-value-bind (result-object result-type options)
+	      (funcall (presentation-translator-real-body translator)
+		       object presentation context-type
+		       frame event window x y
+		       (presentation-object destination) destination)
+	    (setq result-type (or result-type (evacuate-list context-type)))
+	    ;; Find the tag to throw to, and do so
+	    (dolist (this-context *input-context*)
+	      (let* ((context-type (input-context-type this-context))
+		     (tag (input-context-tag this-context)))
+		(when (presentation-subtypep result-type context-type)
+		  (throw tag
+		    (values result-object
+			    result-type
+			    (or destination-event event)
+			    options)))))))))))
+
+;; NEW-X and NEW-Y are in stream coordinates.
+(defmethod frame-drag-and-drop-feedback ((frame application-frame) presentation stream
+					 initial-x initial-y new-x new-y state)
+  (declare (ignore initial-x initial-y state))	;we'll just use XOR
+  (multiple-value-bind (width height) (bounding-rectangle-size presentation)
+    (with-output-recording-options (stream :record nil)
+      (with-identity-transformation (stream)
+	(draw-rectangle* stream new-x new-y (+ new-x width) (+ new-y height)
+			 :filled nil :ink +flipping-ink+ :line-dashes #(4 4))))))
+
+(defmethod frame-drag-and-drop-highlighting ((frame application-frame) presentation stream
+					     state)
+  (ecase state
+    (:highlight
+      (set-highlighted-presentation stream presentation))
+    (:unhighlight
+      (unhighlight-highlighted-presentation stream))))
+
+;; Used to extract all presentations of a certain type in a "surrounded region"
+#+++ignore
+(defun presentations-of-type-in-region (type stream region &optional (sort t))
+  (let ((collection nil))
+    (labels ((collect (record x-offset y-offset)
+	       (if (presentationp record)
+		   (when (presentation-typep (presentation-object record) type)
+		     (pushnew record collection))
+		 (multiple-value-bind (xoff yoff)
+		     (output-record-start-cursor-position record)
+		   (map-over-output-records-overlapping-region #'collect
+		     record region (+ x-offset xoff) (+ y-offset yoff))))))
+      (declare (dynamic-extent #'collect))
+      (collect (stream-output-history stream) 0 0)
+      (when (and collection sort)
+	(setq collection (sort-presentations-by-position collection)))
+      collection)))
+
+#+++ignore
+(defun sort-presentations-by-position (presentations)
+  (flet ((position-lessp (p1 p2)
+	   (unless (eq (output-record-parent p1) (output-record-parent p2))
+	     ;;--- Convert to absolute coordinates if they don't share parents
+	     )
+	   (multiple-value-bind (x1 y1) (bounding-rectangle-position p1)
+	     (multiple-value-bind (x2 y2) (bounding-rectangle-position p2)
+	       (if (= y1 y2)
+		   (< x1 x2)
+		   (< y1 y2))))))
+    (declare (dynamic-extent #'position-lessp))
+    (sort presentations #'position-lessp)))
+
diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..5680c2a6e18e2a9fb38fb53ad4032faa6711b977
--- /dev/null
+++ b/clim/noting-progress.lisp
@@ -0,0 +1,138 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+(in-package :clim-internals)
+
+"Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
+
+
+(defvar *progress-notes* ())
+(defvar *current-progress-note*)
+
+(defclass progress-note ()
+    ((name   :accessor progress-note-name :initarg :name)
+     (stream :initarg :stream)
+     (frame  :initarg :frame)
+     (numerator   :initform 0)
+     (denominator :initform 1)
+     ;; Keep the flicker down as much as possible
+     (name-displayed :initform nil)
+     (bar-length :initform 0)))
+    
+(define-constructor make-progress-note progress-note (name stream frame)
+  :name name :stream stream :frame frame)
+
+(defmethod (setf progress-note-name) :after (name (note progress-note))
+  (declare (ignore name))
+  (with-slots (name-displayed bar-length frame) note
+    (setq name-displayed nil
+	  bar-length 0)
+    (frame-manager-display-progress-note (frame-manager frame) note)))
+
+(defun add-progress-note (name stream)
+  (check-type name string)
+  (when (or (null stream) (eq stream 't))
+    (setq stream (frame-pointer-documentation-output *application-frame*)))
+  (let ((note (make-progress-note name stream *application-frame*)))
+    (without-interrupts
+      (push note *progress-notes*))
+    note))
+
+(defun remove-progress-note (note)
+  (frame-manager-clear-progress-note (frame-manager (slot-value note 'frame)) note)
+  (without-interrupts
+    (setq *progress-notes* (delete note *progress-notes*))))
+
+(defmethod progress-note-fraction-done ((note progress-note))
+  (with-slots (numerator denominator) note
+    (/ numerator denominator)))
+
+(defmacro noting-progress ((stream name &optional (note-var '*current-progress-note*))
+			   &body body)
+  (check-type note-var symbol)
+  `(let (,note-var)
+     (unwind-protect
+	 (progn
+	   (setq ,note-var (add-progress-note ,name ,stream))
+	   ,@body)
+       (remove-progress-note ,note-var))))
+
+(defun note-progress (numerator &optional (denominator 1) (note *current-progress-note*))
+  (when note
+    (when (and (= denominator 1) (rationalp numerator))
+      (let ((num   (numerator   numerator))
+	    (denom (denominator numerator)))
+	(setq numerator   num 
+	      denominator denom)))
+    (setf (slot-value note 'numerator) numerator
+	  (slot-value note 'denominator) denominator))
+  (frame-manager-display-progress-note (frame-manager (slot-value note 'frame)) note)
+  nil)
+
+(defun note-progress-in-phases (numerator
+				&optional (denominator 1)
+					  (phase-number 1) (n-phases 1)
+					  (note *current-progress-note*))
+  (note-progress (+ (* denominator (1- phase-number)) numerator)
+		 (* denominator n-phases)
+		 note)
+  nil)
+
+(defmacro dolist-noting-progress ((var listform name
+				   &optional stream (note-var '*current-progress-note*))
+				  &body body)
+  (let ((count-var '#:count)
+	(total-var '#:total)
+	(list-var '#:list))
+    `(noting-progress (,stream ,name ,note-var)
+       (let* ((,list-var ,listform)
+	      (,total-var (length ,list-var))
+	      (,count-var 0))
+	 (dolist (,var ,list-var)
+	   ,@body
+	   (incf ,count-var)
+	   (note-progress ,count-var ,total-var))))))
+
+(defmacro dotimes-noting-progress ((var countform name
+				    &optional stream (note-var '*current-progress-note*))
+				   &body body)
+  (let ((count-var '#:count))
+    `(let ((,count-var ,countform))
+       (noting-progress (,stream ,name ,note-var)
+	 (dotimes (,var ,count-var)
+	   ,@body
+	   ;; We want the progress bar to advance after the first iteration
+	   ;; even though DOTIMES is zero-based, so add one to the numerator.
+	   (note-progress (1+ ,var) ,count-var))))))
+
+
+(defmethod frame-manager-clear-progress-note 
+	   ((framem standard-frame-manager) (note progress-note))
+  (with-slots (stream) note
+    (when stream
+      (window-clear stream))))
+
+(defmethod frame-manager-display-progress-note
+	   ((framem standard-frame-manager) (note progress-note))
+  (with-slots (name stream numerator denominator name-displayed bar-length) note
+    (when stream
+      (let* ((stream-width (bounding-rectangle-width stream))
+	     (line-height  (stream-line-height stream))
+	     (new-bar-length (floor (* stream-width numerator) denominator)))
+	(unless name-displayed
+	  (window-clear stream))
+	(with-output-recording-options (stream :record nil)
+	  (with-end-of-line-action (stream :allow)
+	    (with-end-of-page-action (stream :allow)
+	      (unless name-displayed
+		(stream-set-cursor-position stream 0 0)
+		(write-string name stream)
+		(setq name-displayed t))
+	      (when (< new-bar-length bar-length)
+		(draw-line* stream 
+			    0 (+ line-height 2) bar-length (+ line-height 2)
+			    :line-thickness 2 :ink +background-ink+))
+	      (draw-line* stream
+			  0 (+ line-height 2) new-bar-length (+ line-height 2)
+			  :line-thickness 2)
+	      (setq bar-length new-bar-length)
+	      (force-output stream))))))))