[mcclim-cvs] CVS mcclim/ESA - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

8 Nov 2006


      Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv24784/ESA
Added Files:
    utils.lisp packages.lisp esa.lisp esa.asd esa-io.lisp 
    esa-command-parser.lisp esa-buffer.lisp colors.lisp 
Log Message:
Committed ESA.
--- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp	2006/11/08 01:10:16	1.1
;;; -*- Mode: Lisp; Package: ESA-UTILS -*-
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.
;;; Miscellaneous utilities used in Climacs.
(in-package :esa-utils)
;;; Cribbed from Paul Graham
(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms)
     ,@body))
;;; Cribbed from PCL by Seibel
(defmacro once-only ((&rest names) &body body)
  (let ((gensyms (loop for n in names collect (gensym))))
    `(let (,@(loop for g in gensyms collect `(,g (gensym))))
       `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
          ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
                ,@body)))))
(defun unlisted (obj &optional (fn #'first))
  (if (listp obj)
      (funcall fn obj)
      obj))
(defun fully-unlisted (obj &optional (fn #'first))
  (if (listp obj)
      (fully-unlisted (funcall fn obj))
      obj))
(defun listed (obj)
  (if (listp obj)
      obj
      (list obj)))
(defun list-aref (list &rest subscripts)
  (if subscripts
      (apply #'list-aref (nth (first subscripts) list)
             (rest subscripts))
      list))
;;; Cribbed from McCLIM.
(defun check-letf-form (form)
  (assert (and (listp form)
               (= 2 (length form)))))
(defun valueify (list)
  (if (and (consp list)
           (endp (rest list)))
      (first list)
      `(values ,@list)))
(defmacro letf ((&rest forms) &body body &environment env)
  "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the
Forms, SETF the Places to the result of evaluating the Value forms.
The places are SETF-ed in parallel after all of the Values are
evaluated."
  (mapc #'check-letf-form forms)
  (let* (init-let-form save-old-values-setf-form
         new-values-set-form old-values-set-form
         update-form)
    (loop for (place new-value) in forms
       for (vars vals store-vars writer-form reader-form)
         = (multiple-value-list (get-setf-expansion place env))
       for old-value-names = (mapcar (lambda (var)
                                       (declare (ignore var))
                                       (gensym))
                                     store-vars)
       nconc (mapcar #'list vars vals) into temp-init-let-form
       nconc (copy-list store-vars) into temp-init-let-form
       nconc (copy-list old-value-names) into temp-init-let-form
       nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form
       nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form
       nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form
       collect writer-form into temp-update-form
       finally (setq init-let-form temp-init-let-form
                     save-old-values-setf-form temp-save-old-values-setf-form
                     new-values-set-form temp-new-values-set-form
                     old-values-set-form temp-old-values-set-form
                     update-form (cons 'progn temp-update-form)))
    `(let* ,init-let-form
       (setf ,@save-old-values-setf-form)
       (unwind-protect
            (progn (setf ,@new-values-set-form)
                   ,update-form
                   (progn ,@body))
         (setf ,@old-values-set-form)
         ,update-form))))
(defun invoke-with-dynamic-bindings-1 (bindings continuation)
  (let ((old-values (mapcar #'(lambda (elt)
                                (symbol-value (first elt)))
                            bindings)))
    (unwind-protect (progn
                      (mapcar #'(lambda (elt)
                                  (setf (symbol-value (first elt))
                                        (funcall (second elt))))
                              bindings)
                      (funcall continuation))
      (mapcar #'(lambda (elt value)
                  (setf (symbol-value (first elt))
                        value))
              bindings old-values))))
(defmacro invoke-with-dynamic-bindings ((&rest bindings) &body body)
  `(invoke-with-dynamic-bindings-1
    ,(loop for (symbol expression) in bindings
        collect (list `',symbol
                      `#'(lambda ()
                           ,expression)))
    #'(lambda ()
        ,@body)))
;;; XXX This is currently broken with respect to declarations
(defmacro letf* ((&rest forms) &body body)
  (if (null forms)
      `(locally
     ,@body)
      `(letf (,(car forms))
     (letf* (,(cdr forms))
       ,@body))))
(defun display-string (string)
  (with-output-to-string (result)
    (loop for char across string
      do (cond ((graphic-char-p char) (princ char result))
    	((char= char #\Space) (princ char result))
    	(t (prin1 char result))))))
(defun object-equal (x y)
  "Case insensitive equality that doesn't require characters"
  (if (characterp x)
      (and (characterp y) (char-equal x y))
      (eql x y)))
(defun object= (x y)
  "Case sensitive equality that doesn't require characters"
  (if (characterp x)
      (and (characterp y) (char= x y))
      (eql x y)))
(defun no-upper-p (string)
  "Does STRING contain no uppercase characters"
  (notany #'upper-case-p string))
(defun case-relevant-test (string)
  "Returns a test function based on the search-string STRING.
If STRING contains no uppercase characters the test is case-insensitive,
otherwise it is case-sensitive."
  (if (no-upper-p string)
      #'object-equal
      #'object=))
(defun remove-keywords (arg-list keywords)
  (let ((clean-tail arg-list))
    ;; First, determine a tail in which there are no keywords to be removed.
    (loop for arg-tail on arg-list by #'cddr
      for (key) = arg-tail
      do (when (member key keywords :test #'eq)
           (setq clean-tail (cddr arg-tail))))
    ;; Cons up the new arg list until we hit the clean-tail, then nconc that on
    ;; the end.
    (loop for arg-tail on arg-list by #'cddr
      for (key value) = arg-tail
      if (eq arg-tail clean-tail)
        nconc clean-tail
        and do (loop-finish)
      else if (not (member key keywords :test #'eq))
        nconc (list key value)
      end)))
(defmacro with-keywords-removed ((var keywords &optional (new-var var))
    			 &body body)
  "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified
in KEYWORDS removed."
  `(let ((,new-var (remove-keywords ,var ',keywords)))
     ,@body))--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp	2006/11/08 01:10:16	1.1
;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
;;;  (c) copyright 2004-2006 by
;;;           Robert Strandh (strandh@labri.fr)
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas@sigkill.dk)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.
;;; Package definitions for ESA.
(defpackage :esa-utils
  (:use :clim-lisp)
  (:export #:with-gensyms
           #:once-only
           #:unlisted
           #:fully-unlisted
           #:listed
           #:list-aref
           #:letf
           #:letf*
           #:display-string
           #:object-equal
           #:object=
           #:no-upper-p
           #:case-relevant-test
           #:with-keywords-removed
           #:invoke-with-dynamic-bindings-1
           #:invoke-with-dynamic-bindings))
(defpackage :esa
  (:use :clim-lisp :clim :esa-utils)
  (:export #:buffers #:frame-current-buffer #:current-buffer #:*current-buffer*
           #:windows #:frame-current-window #:current-window #:*current-window*
           #:*previous-command*
           #:*minibuffer* #:minibuffer #:minibuffer-pane #:display-message
           #:with-minibuffer-stream
           #:esa-pane-mixin #:previous-command
           #:info-pane #:master-pane
           #:esa-frame-mixin #:recordingp #:executingp
           #:*esa-abort-gestures* #:*numeric-argument-p* #:*current-gesture* #:*command-processor*
           #:unbound-gesture-sequence #:gestures
           #:command-processor #:instant-macro-execution-mixin #:macrorecord-processed-gestures-mixin
           #:asynchronous-command-processor #:command-loop-command-processor
           #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command
           #:*extended-command-prompt*
           #:define-esa-top-level #:esa-top-level #:simple-command-loop
           #:convert-to-gesture #:gesture-name
           #:global-esa-table #:keyboard-macro-table
           #:help-table
       #:help-stream
           #:set-key
           #:find-applicable-command-table
           #:esa-command-parser
           #:esa-partial-command-parser
#:gesture-matches-gesture-name-p #:meta-digit
           #:proper-gesture-p
           #:universal-argument #:meta-minus))
(defpackage :esa-buffer
  (:use :clim-lisp :clim :esa :esa-utils)
  (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream
           #:frame-save-buffer-to-stream #:save-buffer-to-stream
           #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p
           #:esa-buffer-mixin
           #:frame-make-new-buffer #:make-new-buffer
           #:read-only-p))
(defpackage :esa-io
  (:use :clim-lisp :clim :esa :esa-buffer :esa-utils)
  (:export #:frame-find-file #:find-file
           #:frame-find-file-read-only #:find-file-read-only
           #:frame-set-visited-file-name #:set-visited-filename
           #:frame-save-buffer #:save-buffer
           #:frame-write-buffer #:write-buffer
           #:esa-io-table))
#-(or mcclim building-mcclim)
(defpackage :clim-extensions
  (:use :clim-lisp :clim)
  (:export
   #:+blue-violet+
   #:+dark-blue+
   #:+dark-green+
   #:+dark-violet+
   #:+gray50+
   #:+gray85+
   #:+maroon+
   #:+purple+))--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2006/11/08 01:10:16	1.1
;;; -*- Mode: Lisp; Package: ESA -*-
;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh@labri.fr)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.
;;; Emacs-Style Appication
(in-package :esa)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Querying ESAs.
(defgeneric buffers (application-frame)
  (:documentation "Return a list of all the buffers of the application."))
(defgeneric frame-current-buffer (application-frame)
  (:documentation "Return the current buffer of APPLICATION-FRAME.")
  (:method ((frame application-frame))
    nil))
(defvar *current-buffer* nil
  "When a command is being executed, the current buffer.")
(defun current-buffer ()
  "Return the current buffer of `*application-frame*'."
  (frame-current-buffer *application-frame*))
(defgeneric windows (application-frame)
  (:documentation "Return a list of all the windows of the application.")
  (:method ((application-frame application-frame))
    '()))
(defgeneric frame-current-window (application-frame)
  (:documentation "Return the current window of APPLICATION-FRAME.")
  (:method ((frame application-frame))
    (first (windows frame))))
(defvar *current-window* nil
  "When a command is being executed, the current window.")
(defun current-window ()
  "Return the current window of `*application-frame*'."  
  (frame-current-window *application-frame*))
(defvar *previous-command* nil
  "When a command is being executed, the command previously
executed by the current frame.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Info pane, a pane that displays some information about another pane
(defclass info-pane (application-pane)
  ((master-pane :initarg :master-pane :reader master-pane))
  (:default-initargs
      :background +gray85+
      :scroll-bars nil
      :borders nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Minibuffer pane
(defgeneric minibuffer (application-frame)
  (:documentation "Return the minibuffer of
  `application-frame'."))
(defvar *minibuffer* nil
  "The minibuffer pane of the running application.")
(defvar *minimum-message-time* 1
  "The minimum number of seconds a minibuffer message will be
  displayed." )
(defclass minibuffer-pane (application-pane)
  ((message :initform nil
            :accessor message
            :documentation "An output record containing whatever
message is supposed to be displayed in the minibuffer.")
   (message-time :initform 0
                 :accessor message-time
                 :documentation "The universal time at which the
current message was set."))
  (:default-initargs
   :scroll-bars nil
    :display-function 'display-minibuffer
[1505 lines skipped]
--- /project/mcclim/cvsroot/mcclim/ESA/esa.asd	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.asd	2006/11/08 01:10:16	1.1
[1543 lines skipped]
--- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp	2006/11/08 01:10:16	1.1
[1899 lines skipped]
--- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp	2006/11/08 01:10:16	1.1
[2020 lines skipped]
--- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp	2006/11/08 01:10:16	1.1
[2074 lines skipped]
--- /project/mcclim/cvsroot/mcclim/ESA/colors.lisp	2006/11/08 01:10:16	NONE
+++ /project/mcclim/cvsroot/mcclim/ESA/colors.lisp	2006/11/08 01:10:16	1.1
[2108 lines skipped]