anchor.diff:  ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
   
   ;;;  (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
  +;;;  (c) copyright 2000 by Robert Strandh (strandh@labri.u-bordeaux.fr)
   
   ;;; This library is free software; you can redistribute it and/or
   ;;; modify it under the terms of the GNU Library General Public
  
positive.code: 			  (partial-command-parser *partial-command-parser*)
  			  use-keystrokes)
    (read stream))
  
negative.code: 
  (in-package :CLIM-INTERNALS)
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Command tables
  
  (defgeneric command-table-name (command-table))
  (defgeneric command-table-inherit-from (command-table))
  
  ;;; According to the specification, command menu items are stored as
  ;;; lists.  This way seems better, and I hope nothing will break.
  (defclass menu-item ()
    ((name :initarg :name :reader command-menu-item-name)
     (type :initarg :type :reader command-menu-item-type)
     (value :initarg :value :reader command-menu-item-value)
     (documentation :initarg :documentation)
     (text-style :initarg :text-style :initform nil)
     (keystroke :initarg :keystroke :initform nil)))
  
  (defun command-menu-item-options (menu-item)
    (with-slots (documentation text-style) menu-item
      (list ':documetation documentation ':text-style text-style)))
  
  (defclass command-table ()
    ((name :initarg :name :reader command-table-name)
     (inherit-from :initarg :inherit-from
  		 :initform '()
  		 :reader command-table-inherit-from)
     (commands :initarg :commands :initform (make-hash-table :test #'eq))
     (command-line-names :initform (make-hash-table :test #'equal))
     (presentation-translators :initform '())
     (keystroke-accelerators :initform (make-hash-table :test #'equal))
     (menu :initarg :menu :initform '())))
  
  (defun command-table-p (object)
    (typep object 'command-table))
  
  (defclass standard-command-table (command-table)
    ())
     
  (defparameter *command-tables* (make-hash-table :test #'eq))
  
  (define-condition command-table-error (error)
    ())
  
  (define-condition command-table-not-found (command-table-error)
    ())
  
  (define-condition command-table-already-exists (command-table-error)
    ())
  
  (define-condition command-not-present (command-table-error)
    ())
  
  (define-condition command-not-accessible (command-table-error)
    ())
  
  (define-condition command-already-present (command-table-error)
    ())
  
  (defun find-command-table (name &key (errorp t))
    (cond ((command-table-p name) name)
  	((gethash name *command-tables*))
  	(errorp (error 'command-table-not-found))
  	(t nil)))
  
  (defun make-command-table (name &key inherit-from menu (errorp t))
    (if (and errorp (gethash name *command-tables*))
        (error 'command-table-already-exists)
        (setf (gethash name *command-tables*)
  	    (make-instance 'standard-command-table
  	      :name name
  	      :inherit-from inherit-from
  	      :menu (mapcar
  		     #'(lambda (item)
  			 (destructuring-bind
  			  (name type value &key keystroke documentation text-style)
  			  item
  			  (make-instance 'menu-item
  			    :name name :type type :value value
  			    :documentation documentation
  			    :text-style text-style
  			    :keystroke keystroke)))
  		     menu)))))
  
  (make-command-table 'global-command-table)
  (make-command-table 'user-command-table)
  
  (defmacro define-command-table (name &key inherit-from menu)
    (let ((inherit (cond (inherit-from)
  		       (t '(clim-global-command-table)))))
      `(make-command-table ',name
  			 :inherit-from ',inherit
  			 :menu ',menu
  			 :errorp nil)))
  
  (defun generate-name (symbol)
    (let ((name (symbol-name symbol)))
      (string-capitalize
       (substitute
        #\Space #\-
        (subseq name (string/= "COM-" name))))))
  
  (defun remove-command-from-command-table (command-name
  					  command-table
  					  &key (errorp t))
    (let ((table (find-command-table command-table)))
      (with-slots (commands command-line-names keystroke-accelerators menu) table
        (if (and errorp (not (gethash command-name commands)))
  	  (error 'command-not-present)
  	  (progn 
  	    (maphash #'(lambda (key value)
  			 (when (eq value command-name)
  			   (remhash key command-line-names)))
  		     command-line-names)
  	    (maphash #'(lambda (key value)
  			 (when (eq value command-name)
  			   (remhash key keystroke-accelerators)))
  		     keystroke-accelerators)
  	    (setf menu
  		  (delete-if #'(lambda (item)
  				 (with-slots (type value) item
  				   (and (eq type ':command)
  					(or (eq value command-name)
  					    (and (consp value)
  						 (eq (car value) command-name))))))
  			     menu))
  	    (remhash command-name commands))))))
  
  (defun add-command-to-command-table (command-name
  				     command-table
  				     &key name menu keystroke (errorp t))
    (let ((table (find-command-table command-table)))
      (with-slots (commands command-line-names keystroke-accelerators menu) table
        (if (and errorp (gethash command-name commands))
  	  (error 'command-already-present)
  	  (progn (remove-command-from-command-table command-name command-table
  						    :errorp nil)
  		 (setf (gethash command-name commands) t)
  		 (when name
  		   (let ((command-line-name
  			  (if (stringp name)
  			      name
  			      (generate-name command-name))))
  		     (setf (gethash command-name commands) command-line-name)
  		     (setf (gethash command-line-name command-line-names)
  			   command-name)))
  		 (when menu
  		   (let ((menu-item-name
  			  (cond ((stringp menu) menu)
  				((and (eq menu t) (stringp name)) name)
  				((eq menu t) (generate-name command-name))
  				((consp menu) (car menu)))))
  		     (apply #'add-menu-item-to-command-table
  			    command-table
  			    menu-item-name
  			    :command command-name
  			    (if (consp menu)
  				(cdr menu)
  				'()))))
  		 (when keystroke
  		   (setf (gethash keystroke keystroke-accelerators) command-name)))))))
  						  
  
  (defun apply-with-command-table-inheritance (fun command-table)
    (funcall fun command-table)
    (mapc #'(lambda (inherited-command-table)
  	    (apply-with-command-table-inheritance
  	     fun (find-command-table inherited-command-table)))
  	(command-table-inherit-from command-table)))
  
  (defmacro do-command-table-inheritance ((command-table-var command-table) &body body)
    `(apply-with-command-table-inheritance
      #'(lambda (,command-table-var)
  	,@body)
      (find-command-table ,command-table)))
  
  (defun map-over-command-table-commands (function command-table &key (inherited t))
    (if inherited
        (apply-with-command-table-inheritance
         #'(lambda (table)
  	   (maphash #'(lambda (key val)
  			(declare (ignore val))
  			(funcall function key))
  		    (slot-value table 'commands)))
         (find-command-table command-table))
        (maphash #'(lambda (key val)
  		   (declare (ignore val))
  		   (funcall function key))
  	       (slot-value (find-command-table command-table) 'commands))))
  
  (defun map-over-command-table-names (function command-table &key (inherited t))
    (if inherited
        (apply-with-command-table-inheritance
         #'(lambda (table)
  	   (maphash function (slot-value table 'command-line-names)))
         (find-command-table command-table))
        (maphash function (slot-value (find-command-table command-table)
  				    'command-line-names))))
  
  (defun command-present-in-command-table-p (command-name command-table)
    (let ((table (find-command-table command-table)))
      (if (gethash command-name (slot-value table 'commands))
  	table
  	nil)))
  
  (defun command-accessible-in-command-table-p (command-name command-table)
    (or (command-present-in-command-table-p command-name command-table)
        (some #'(lambda (table)
  		(command-accessible-in-command-table-p
  		 command-name
  		 (find-command-table table)))
  	    (command-table-inherit-from command-table))))
  
  (defun find-command-from-command-line-name (name command-table &key (errorp t))
    (apply-with-command-table-inheritance
     #'(lambda (table)
         (maphash #'(lambda (key value)
  		    (when (string-equal key name)
  		      (return-from find-command-from-command-line-name
  				   (values value table))))
  		(slot-value table 'command-line-names)))
     (find-command-table command-table))
    (if errorp
        (error 'command-not-accessible)))
  
  (defun command-line-name-for-command (command-name command-table &key (errorp t))
    (do-command-table-inheritance (table command-table)
      (let ((command-line-name (gethash command-name (slot-value table 'commands))))
        (when (stringp command-line-name)
  	(return-from command-line-name-for-command command-line-name))))
    (cond ((eq errorp :create) (generate-name command-name))
  	(errorp (error 'command-not-accessible))
  	(t nil)))
  
  (defun find-menu-item (menu-name command-table &key (errorp t))
    (let* ((table (find-command-table command-table))
  	 (mem (member menu-name (slot-value table 'menu)
  		      :key #'command-menu-item-name :test #'string-equal)))
      (cond (mem (values (car mem) command-table))
  	  (errorp (error 'command-not-accessible))
  	  (t nil))))
  
  (defun remove-menu-item-from-command-table (command-table string &key (errorp t))
    (let ((table (find-command-table command-table))
  	(item (find-menu-item string command-table :errorp nil)))
      (with-slots (menu) table
        (if (and errorp (not item))
  	  (error 'command-not-present)
  	  (setf menu (delete string menu
  			     :key #'command-menu-item-name
  			     :test #'string-equal))))))
  
  (defun add-menu-item-to-command-table (command-table
  				       string type value
  				       &key documentation (after :end)
  				       keystroke text-style (errorp t))
    (let* ((table (find-command-table command-table))
  	 (item (find-menu-item string command-table :errorp nil)))
      (with-slots (menu) table
        (cond ((and errorp item) (error 'command-already-present))
  	    (t (when item
  		 (remove-menu-item-from-command-table command-table string))
  	       (let ((new-item (make-instance 'menu-item
  				 :name string :type type :value value
  				 :keystroke keystroke
  				 :documentation documentation
  				 :text-style text-style)))
  		 (case after
  		   (:start (push new-item menu))
  		   ((:end nil) (setf menu (nconc menu (list new-item))))
  		   (:sort (setf menu (sort (cons new-item menu)
  					   #'string-lessp
  					   :key #'command-menu-item-name)))
  		   (t (push new-item
  			    (cdr (member after menu
  					 :key #'command-menu-item-name
  					 :test #'string-equal))))))
  	       (when keystroke
  		 (add-keystroke-to-command-table command-table keystroke
  						 type value)))))))
  
  (defun map-over-command-table-menu-items (function command-table)
    (mapc #'(lambda (item)
  	    (with-slots (name keystroke) item
  	      (funcall function name keystroke item)))
  	(slot-value (find-command-table command-table) 'menu)))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  ;;; Commands
  
  (defmacro define-command (name args &body body)
    `(defun ,name ,(loop for arg in args
  		     collect (first arg))
  