[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Sep 11 20:13:33 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv12218
Modified Files:
syntax.lisp rectangle.lisp pane.lisp packages.lisp
lisp-syntax.lisp lisp-syntax-swine.lisp groups.lisp
fundamental-syntax.lisp climacs.asd base.lisp
Added Files:
utils.lisp
Log Message:
Added utils.lisp file and CLIMACS-UTILS package so it's no longer
necessary to hand-roll `with-gensyms', `once-only' and other helpful
macros.
--- /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 21:43:56 1.71
+++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/11 20:13:32 1.72
@@ -207,13 +207,13 @@
of the option."
;; The name is converted to a keyword symbol which is used for all
;; further identification.
- (let ((name-symbol (gensym))
- (symbol (intern (string-upcase option-name)
- (find-package :keyword))))
- `(defmethod eval-option ((,syntax-symbol ,syntax)
- (,name-symbol (eql ,symbol))
- ,value-symbol)
- , at body)))
+ (with-gensyms (name)
+ (let ((symbol (intern (string-upcase option-name)
+ (find-package :keyword))))
+ `(defmethod eval-option ((,syntax-symbol ,syntax)
+ (,name (eql ,symbol))
+ ,value-symbol)
+ , at body))))
(defgeneric current-attributes-for-syntax (syntax)
(:method-combination append)
--- /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/09 18:21:40 1.2
+++ /project/climacs/cvsroot/climacs/rectangle.lisp 2006/09/11 20:13:32 1.3
@@ -54,18 +54,16 @@
columns `startcol' and `endcol'. If `force-start' or `force-end' is
non-NIL, the line will be padded with space characters in order to put
`start-mark' or `end-mark' at their specified columns respectively."
- (let ((mark-val-sym (gensym))
- (startcol-val-sym (gensym))
- (endcol-val-sym (gensym)))
+ (once-only (mark startcol endcol)
`(progn
- (let ((,mark-val-sym ,mark)
- (,startcol-val-sym ,startcol)
- (,endcol-val-sym ,endcol))
- (move-to-column ,mark-val-sym ,startcol-val-sym ,force-start)
- (let ((,start-mark (clone-mark ,mark-val-sym)))
- (let ((,end-mark (clone-mark ,mark-val-sym)))
- (move-to-column ,end-mark ,endcol-val-sym ,force-end)
- , at body))))))
+ (let ((,mark ,mark)
+ (,startcol ,startcol)
+ (,endcol ,endcol))
+ (move-to-column ,mark ,startcol ,force-start)
+ (let ((,start-mark (clone-mark ,mark)))
+ (let ((,end-mark (clone-mark ,mark)))
+ (move-to-column ,end-mark ,endcol ,force-end)
+ , at body))))))
(defun extract-and-delete-rectangle-line (mark startcol endcol)
"For the line that `mark' is in, delete and return the string
--- /project/climacs/cvsroot/climacs/pane.lisp 2006/09/02 21:43:56 1.52
+++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/11 20:13:32 1.53
@@ -110,21 +110,21 @@
will be evaluated whenever a complete list of buffers is
needed (to set up all buffers to prepare for undo, and to check
them all for changes after `body' has run)."
- (let ((buffer-sym (gensym)))
- `(progn
- (dolist (,buffer-sym ,get-buffers-exp)
- (setf (undo-accumulate ,buffer-sym) '()))
- (unwind-protect (progn , at body)
- (dolist (,buffer-sym ,get-buffers-exp)
- (cond ((null (undo-accumulate ,buffer-sym)) nil)
- ((null (cdr (undo-accumulate ,buffer-sym)))
- (add-undo (car (undo-accumulate ,buffer-sym))
- (undo-tree ,buffer-sym)))
- (t
- (add-undo (make-instance 'compound-record
- :buffer ,buffer-sym
- :records (undo-accumulate ,buffer-sym))
- (undo-tree ,buffer-sym)))))))))
+ (with-gensyms (buffer)
+ `(progn
+ (dolist (,buffer ,get-buffers-exp)
+ (setf (undo-accumulate ,buffer) '()))
+ (unwind-protect (progn , at body)
+ (dolist (,buffer ,get-buffers-exp)
+ (cond ((null (undo-accumulate ,buffer)) nil)
+ ((null (cdr (undo-accumulate ,buffer)))
+ (add-undo (car (undo-accumulate ,buffer))
+ (undo-tree ,buffer)))
+ (t
+ (add-undo (make-instance 'compound-record
+ :buffer ,buffer
+ :records (undo-accumulate ,buffer))
+ (undo-tree ,buffer)))))))))
(defmethod flip-undo-record :around ((record climacs-undo-record))
(with-slots (buffer) record
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/09/06 20:07:21 1.117
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/11 20:13:32 1.118
@@ -26,6 +26,14 @@
(in-package :cl-user)
+(defpackage :climacs-utils
+ (:use :clim-lisp)
+ (:export #:with-gensyms
+ #:once-only
+ #:unlisted
+ #:fully-unlisted
+ #:listed))
+
(defpackage :climacs-buffer
(:use :clim-lisp :flexichain :binseq)
(:export #:buffer #:standard-buffer
@@ -76,7 +84,7 @@
(:documentation "An implementation of a kill ring."))
(defpackage :climacs-base
- (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer)
+ (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer :climacs-utils)
(:export #:as-offsets
#:do-buffer-region
#:do-buffer-region-lines
@@ -118,7 +126,7 @@
#:add-abbrev))
(defpackage :climacs-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-utils)
(:export #:syntax #:define-syntax #:*default-syntax*
#:eval-option
#:define-option-for-syntax
@@ -170,7 +178,7 @@
(defpackage :climacs-pane
(:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
- :climacs-syntax :flexichain :undo :esa-buffer :esa-io)
+ :climacs-syntax :flexichain :undo :esa-buffer :esa-io :climacs-utils)
(:export #:climacs-buffer #:needs-saving
#:filepath #:file-saved-p #:file-write-time
#:read-only-p #:buffer-read-only
@@ -378,7 +386,8 @@
(defpackage :climacs-core
(:use :clim-lisp :climacs-base :climacs-buffer :climacs-fundamental-syntax
:climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
- :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io)
+ :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io
+ :climacs-utils)
(:export #:display-string
#:object-equal
#:object=
@@ -484,7 +493,7 @@
(defpackage :climacs-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :climacs-fundamental-syntax :flexichain :climacs-pane :climacs-gui
- :climacs-motion :climacs-editing :climacs-core)
+ :climacs-motion :climacs-editing :climacs-core :climacs-utils)
(:export #:lisp-string
#:edit-definition))
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 08:55:21 1.113
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/11 20:13:32 1.114
@@ -28,21 +28,6 @@
;;;
;;; Convenience functions and macros:
-(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 usable-package (package-designator)
"Return a usable package based on `package-designator'."
(or (find-package package-designator)
--- /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 08:55:21 1.5
+++ /project/climacs/cvsroot/climacs/lisp-syntax-swine.lisp 2006/09/11 20:13:32 1.6
@@ -741,33 +741,29 @@
(preceding-operand-sym (or preceding-operand (gensym)))
(operands-sym (or operands (gensym)))
(form-sym (or form (gensym)))
- (operand-indices-sym (or preceding-operand-indices (gensym)))
- ;; My kingdom for with-gensyms (or once-only)!
- (mark-value-sym (gensym))
- (syntax-value-sym (gensym)))
- `(let* ((,mark-value-sym ,mark-or-offset)
- (,syntax-value-sym ,syntax)
- (,form-sym
- ;; Find a form with a valid (fboundp) operator.
- (let ((immediate-form
- (preceding-form ,mark-value-sym ,syntax-value-sym)))
- (unless (null immediate-form)
- (or (find-applicable-form ,syntax-value-sym immediate-form)
- ;; If nothing else can be found, and `arg-form'
- ;; is the operator of its enclosing form, we use
- ;; the enclosing form.
- (when (eq (first-form (children (parent immediate-form))) immediate-form)
- (parent immediate-form))))))
- ;; If we cannot find a form, there's no point in looking
- ;; up any of this stuff.
- (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym)))
- (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym))))
- (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym
- ,operator-sym ,operands-sym))
- (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym)
- (when ,form-sym (find-operand-info ,syntax-value-sym ,mark-value-sym ,form-sym))
- (declare (ignorable ,preceding-operand-sym ,operand-indices-sym))
- , at body))))
+ (operand-indices-sym (or preceding-operand-indices (gensym))))
+ (once-only (mark-or-offset syntax)
+ `(declare (ignorable ,mark-or-offset ,syntax))
+ `(let* ((,form-sym
+ ;; Find a form with a valid (fboundp) operator.
+ (let ((immediate-form
+ (preceding-form ,mark-or-offset ,syntax)))
+ (unless (null immediate-form)
+ (or (find-applicable-form ,syntax immediate-form)
+ ;; If nothing else can be found, and `arg-form'
+ ;; is the operator of its enclosing form, we use
+ ;; the enclosing form.
+ (when (eq (first-form (children (parent immediate-form))) immediate-form)
+ (parent immediate-form))))))
+ ;; If we cannot find a form, there's no point in looking
+ ;; up any of this stuff.
+ (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax)))
+ (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax))))
+ (declare (ignorable ,form-sym ,operator-sym ,operands-sym))
+ (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym)
+ (when ,form-sym (find-operand-info ,syntax ,mark-or-offset ,form-sym))
+ (declare (ignorable ,preceding-operand-sym ,operand-indices-sym))
+ , at body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/climacs/cvsroot/climacs/groups.lisp 2006/09/08 18:12:03 1.2
+++ /project/climacs/cvsroot/climacs/groups.lisp 2006/09/11 20:13:32 1.3
@@ -273,22 +273,20 @@
`body' has run. Also, `buffers' will be bound to a list of the
buffers containing the files designated by `group' while `body'
is run."
- (let ((buffers-before-sym (gensym))
- (buffers-after-sym (gensym))
- (buffer-diff-sym (gensym))
- (group-val-sym (gensym)))
- `(let ((,buffers-before-sym (buffers *application-frame*))
- (,group-val-sym ,group))
- (ensure-group-buffers ,group-val-sym)
- (let* ((,buffers-after-sym (buffers *application-frame*))
- (,buffer-diff-sym (set-difference ,buffers-after-sym
- ,buffers-before-sym))
- (,buffers (group-buffers ,group-val-sym)))
- (unwind-protect (progn , at body)
- (unless ,keep
- (loop for buffer in ,buffer-diff-sym
+ (with-gensyms (buffers-before buffers-after buffer-diff)
+ (once-only (group keep)
+ `(let ((,buffers-before (buffers *application-frame*))
+ (,group ,group))
+ (ensure-group-buffers ,group)
+ (let* ((,buffers-after (buffers *application-frame*))
+ (,buffer-diff (set-difference ,buffers-after
+ ,buffers-before))
+ (,buffers (group-buffers ,group)))
+ (unwind-protect (progn , at body)
+ (unless ,keep
+ (loop for buffer in ,buffer-diff
do (save-buffer buffer)
- do (kill-buffer buffer))))))))
+ do (kill-buffer buffer)))))))))
(defmacro define-group (name (group-arg &rest args) &body body)
"Define a persistent group named `name'. `Body' should return a
@@ -297,25 +295,25 @@
the first element bound to the result of evaluating the second
element. The second element will be evaluated when the group is
selected to be the active group by the user."
- (let ((name-val-sym (gensym))
- (group-val-sym (gensym)))
- `(let ((,name-val-sym ,name))
- (assert (stringp ,name-val-sym))
- (setf (gethash ,name-val-sym *persistent-groups*)
- (make-instance 'custom-group
- :name ,name-val-sym
- :pathname-lister #'(lambda (,group-val-sym)
- (destructuring-bind
- (&key ,@(mapcar #'(lambda (arg)
- `((,arg ,arg)))
- (mapcar #'first args)))
- (value-plist ,group-val-sym)
- (let ((,group-arg ,group-val-sym))
- , at body)))
- :select-response #'(lambda (group)
- (declare (ignorable group))
- ,@(loop for (name form) in args
- collect `(setf (getf (value-plist group) ',name) ,form))))))))
+ (with-gensyms (group)
+ (once-only (name)
+ `(let ((,name ,name))
+ (assert (stringp ,name))
+ (setf (gethash ,name *persistent-groups*)
+ (make-instance 'custom-group
+ :name ,name
+ :pathname-lister #'(lambda (,group)
+ (destructuring-bind
+ (&key ,@(mapcar #'(lambda (arg)
+ `((,arg ,arg)))
+ (mapcar #'first args)))
+ (value-plist ,group)
+ (let ((,group-arg ,group))
+ , at body)))
+ :select-response #'(lambda (group)
+ (declare (ignorable group))
+ ,@(loop for (name form) in args
+ collect `(setf (getf (value-plist group) ',name) ,form)))))))))
(define-group "Current Directory Files" (group)
(declare (ignore group))
--- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/02 21:43:56 1.5
+++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/11 20:13:32 1.6
@@ -1,4 +1,4 @@
-;;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*-
+;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*-
;;; (c) copyright 2005 by
;;; Robert Strandh (strandh at labri.fr)
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/09/06 20:07:21 1.54
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/09/11 20:13:32 1.55
@@ -55,6 +55,7 @@
(:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq"))))
(:file "packages" :depends-on ("cl-automaton" "Persistent"))
+ (:file "utils" :depends-on ("packages"))
(:file "buffer" :depends-on ("packages"))
(:file "motion" :depends-on ("packages" "buffer" "syntax"))
(:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring"))
@@ -62,9 +63,9 @@
:pathname #p"Persistent/persistent-buffer.lisp"
:depends-on ("packages" "buffer" "Persistent"))
- (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring"))
+ (:file "base" :depends-on ("packages" "utils" "buffer" "persistent-buffer" "kill-ring"))
(:file "abbrev" :depends-on ("packages" "buffer" "base"))
- (:file "syntax" :depends-on ("packages" "buffer" "base"))
+ (:file "syntax" :depends-on ("packages" "utils" "buffer" "base"))
(:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion"))
(:file "delegating-buffer" :depends-on ("packages" "buffer"))
(:file "kill-ring" :depends-on ("packages"))
@@ -72,7 +73,7 @@
(:file "persistent-undo"
:pathname #p"Persistent/persistent-undo.lisp"
:depends-on ("packages" "buffer" "persistent-buffer" "undo"))
- (:file "pane" :depends-on ("packages" "syntax" "buffer" "base"
+ (:file "pane" :depends-on ("packages" "utils" "syntax" "buffer" "base"
"persistent-undo" "persistent-buffer" "abbrev"
"delegating-buffer" "undo"))
(:file "fundamental-syntax" :depends-on ("packages" "syntax" "buffer" "pane"
@@ -83,7 +84,7 @@
(:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
(:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base"
"pane"))
- (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane"
+ (:file "lisp-syntax" :depends-on ("packages" "utils" "syntax" "buffer" "base" "pane"
"window-commands" "gui"))
(:file "lisp-syntax-swine" :depends-on ("lisp-syntax"))
(:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands"
@@ -91,7 +92,7 @@
#.(if (find-swank)
'(:file "lisp-syntax-swank" :depends-on ("lisp-syntax"))
(values))
- (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
+ (:file "gui" :depends-on ("packages" "utils" "syntax" "base" "buffer" "undo" "pane"
"kill-ring" "text-syntax"
"abbrev" "editing" "motion"))
(:file "io" :depends-on ("packages" "gui"))
--- /project/climacs/cvsroot/climacs/base.lisp 2006/09/04 07:05:21 1.60
+++ /project/climacs/cvsroot/climacs/base.lisp 2006/09/11 20:13:32 1.61
@@ -71,8 +71,7 @@
at the beginning of the line and `body' will be executed. Note
that the iteration will always start from the mark specifying
the earliest position in the buffer."
- (let ((mark-sym (gensym))
- (mark2-sym (gensym)))
+ (with-gensyms (mark-sym mark2-sym)
`(progn
(let* ((,mark-sym (clone-mark ,mark1))
(,mark2-sym (clone-mark ,mark2)))
--- /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 NONE
+++ /project/climacs/cvsroot/climacs/utils.lisp 2006/09/11 20:13:33 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-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 :climacs-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)))
More information about the Climacs-cvs
mailing list