Commit 70f4cece authored by Troels Henriksen's avatar Troels Henriksen

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.
parent d9f7bbea
......@@ -71,8 +71,7 @@ The body is executed for each element, with object being the current object
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)))
......
......@@ -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"))
......
;;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*-
;; -*- Mode: Lisp; Package: CLIMACS-FUNDAMENTAL-SYNTAX -*-
;;; (c) copyright 2005 by
;;; Robert Strandh (strandh@labri.fr)
......
......@@ -273,22 +273,20 @@ buffers created by this macro will be saved and killed after
`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 @@ designated by the group. `Args' should be two-element lists, with
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))
......
......@@ -741,33 +741,29 @@ modification will be generated, respectively."
(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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
......
......@@ -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)
......
......@@ -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))
......
......@@ -110,21 +110,21 @@ undo for each buffer. `get-buffers-exp' should be a form, that
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
......
......@@ -54,18 +54,16 @@ part of the line that `mark' is situated in, that lies between the
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
......
......@@ -207,13 +207,13 @@ mandated by file types or attribute lists.")
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)
......
;;; -*- 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)))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment