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) - ,@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) + ,@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) - ,@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) + ,@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 ,@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 ,@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)) - ,@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)) + ,@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 ,@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 ,@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)) - ,@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)) + ,@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@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@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) ,@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)))