[mcclim-cvs] CVS mcclim/ESA
thenriksen
thenriksen at common-lisp.net
Wed Nov 8 01:10:16 UTC 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 at 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)
, at 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)))
, at 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 , at 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 , at save-old-values-setf-form)
(unwind-protect
(progn (setf , at new-values-set-form)
,update-form
(progn , at body))
(setf , at 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 ()
, at body)))
;;; XXX This is currently broken with respect to declarations
(defmacro letf* ((&rest forms) &body body)
(if (null forms)
`(locally
, at body)
`(letf (,(car forms))
(letf* (,(cdr forms))
, at 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)))
, at 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 at labri.fr)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at 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 at 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]
More information about the Mcclim-cvs
mailing list