[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Mon Jul 24 14:18:59 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv28595
Added Files:
core.lisp
Log Message:
Added core.lisp - needed for my previous patch. Oops.
--- /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 NONE
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 1.1
;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-
;;; (c) copyright 2004-2005 by
;;; Robert Strandh (strandh at labri.fr)
;;; (c) copyright 2004-2005 by
;;; Elliott Johnson (ejohnson at fasl.info)
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr)
;;; (c) copyright 2005 by
;;; Aleksandar Bakic (a_bakic at yahoo.com)
;;; (c) copyright 2006 by
;;; Troels Henriksen (athas at sigkill.dk)
(in-package :climacs-core)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Misc stuff
(defun possibly-fill-line ()
(let* ((pane (current-window))
(buffer (buffer pane)))
(when (auto-fill-mode pane)
(let* ((fill-column (auto-fill-column pane))
(point (point pane))
(offset (offset point))
(tab-width (tab-space-count (stream-default-view pane)))
(syntax (syntax buffer)))
(when (>= (buffer-display-column buffer offset tab-width)
(1- fill-column))
(fill-line point
(lambda (mark)
(syntax-line-indentation mark tab-width syntax))
fill-column
tab-width
(syntax buffer)))))))
(defun insert-character (char)
(let* ((window (current-window))
(point (point window)))
(unless (constituentp char)
(possibly-expand-abbrev point))
(when (whitespacep (syntax (buffer window)) char)
(possibly-fill-line))
(if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point)))
(progn
(delete-range point)
(insert-object point char))
(insert-object point char))))
(defun back-to-indentation (mark syntax)
(beginning-of-line mark)
(loop until (end-of-line-p mark)
while (whitespacep syntax (object-after mark))
do (forward-object mark)))
(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil))
(let ((mark2 (clone-mark mark)))
(loop until (beginning-of-line-p mark)
while (whitespacep syntax (object-before mark))
do (backward-object mark))
(unless backward-only-p
(loop until (end-of-line-p mark2)
while (whitespacep syntax (object-after mark2))
do (forward-object mark2)))
(delete-region mark mark2)))
(defun goto-position (mark pos)
(setf (offset mark) pos))
(defun goto-line (mark line-number)
(loop with m = (clone-mark (low-mark (buffer mark))
:right)
initially (beginning-of-buffer m)
do (end-of-line m)
until (end-of-buffer-p m)
repeat (1- line-number)
do (incf (offset m))
(end-of-line m)
finally (beginning-of-line m)
(setf (offset mark) (offset m))))
(defun indent-current-line (pane point)
(let* ((buffer (buffer pane))
(view (stream-default-view pane))
(tab-space-count (tab-space-count view))
(indentation (syntax-line-indentation point
tab-space-count
(syntax buffer))))
(indent-line point indentation (and (indent-tabs-mode buffer)
tab-space-count))))
(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\)))
(cond ((> count 0)
(loop while (and (not (end-of-buffer-p mark))
(whitespacep syntax (object-after mark)))
do (forward-object mark)))
((< count 0)
(setf count (- count))
(loop repeat count do (backward-expression mark syntax))))
(unless (or (beginning-of-buffer-p mark)
(whitespacep syntax (object-before mark)))
(insert-object mark #\Space))
(insert-object mark open)
(let ((here (clone-mark mark)))
(loop repeat count
do (forward-expression here syntax))
(insert-object here close)
(unless (or (end-of-buffer-p here)
(whitespacep syntax (object-after here)))
(insert-object here #\Space))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Character case
(defun downcase-word (mark &optional (n 1))
"Convert the next N words to lowercase, leaving mark after the last word."
(let ((syntax (syntax (buffer mark))))
(loop repeat n
do (forward-to-word-boundary mark syntax)
(let ((offset (offset mark)))
(forward-word mark syntax 1 nil)
(downcase-region offset mark)))))
(defun upcase-word (mark syntax &optional (n 1))
"Convert the next N words to uppercase, leaving mark after the last word."
(loop repeat n
do (forward-to-word-boundary mark syntax)
(let ((offset (offset mark)))
(forward-word mark syntax 1 nil)
(upcase-region offset mark))))
(defun capitalize-word (mark &optional (n 1))
"Capitalize the next N words, leaving mark after the last word."
(let ((syntax (syntax (buffer mark))))
(loop repeat n
do (forward-to-word-boundary mark syntax)
(let ((offset (offset mark)))
(forward-word mark syntax 1 nil)
(capitalize-region offset mark)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Indentation
(defun indent-region (pane mark1 mark2)
"Indent all lines in the region delimited by `mark1' and `mark2'
according to the rules of the active syntax in `pane'."
(let* ((buffer (buffer pane))
(view (clim:stream-default-view pane))
(tab-space-count (tab-space-count view))
(tab-width (and (indent-tabs-mode buffer)
tab-space-count))
(syntax (syntax buffer)))
(do-buffer-region-lines (line mark1 mark2)
(let ((indentation (syntax-line-indentation
line
tab-space-count
syntax)))
(indent-line line indentation tab-width))
;; We need to update the syntax every time we perform an
;; indentation, so that subsequent indentations will be
;; correctly indented (this matters in list forms). FIXME: This
;; should probably happen automatically.
(update-syntax buffer syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Auto fill
(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax
&optional (compress-whitespaces t))
"Breaks the contents of line pointed to by MARK up to MARK into
multiple lines such that none of them is longer than FILL-COLUMN. If
COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the
decision is made to break the line at a point. For now, the
compression means just the deletion of trailing whitespaces."
(let ((begin-mark (clone-mark mark)))
(beginning-of-line begin-mark)
(loop with column = 0
with line-beginning-offset = (offset begin-mark)
with walking-mark = (clone-mark begin-mark)
while (mark< walking-mark mark)
as object = (object-after walking-mark)
do (case object
(#\Space
(setf (offset begin-mark) (offset walking-mark))
(incf column))
(#\Tab
(setf (offset begin-mark) (offset walking-mark))
(incf column (- tab-width (mod column tab-width))))
(t
(incf column)))
(when (and (>= column fill-column)
(/= (offset begin-mark) line-beginning-offset))
(when compress-whitespaces
(let ((offset (buffer-search-backward
(buffer begin-mark)
(offset begin-mark)
#(nil)
:test #'(lambda (o1 o2)
(declare (ignore o2))
(not (whitespacep syntax o1))))))
(when offset
(delete-region begin-mark (1+ offset)))))
(insert-object begin-mark #\Newline)
(incf (offset begin-mark))
(let ((indentation
(funcall syntax-line-indentation-function begin-mark)))
(indent-line begin-mark indentation tab-width))
(beginning-of-line begin-mark)
(setf line-beginning-offset (offset begin-mark))
(setf (offset walking-mark) (offset begin-mark))
(setf column 0))
(incf (offset walking-mark)))))
(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax
&optional (compress-whitespaces t))
"Fill the region delimited by `mark1' and `mark2'. `Mark1' must be
mark<= `mark2.'"
(let* ((buffer (buffer mark1)))
(do-buffer-region (object offset buffer
(offset mark1) (offset mark2))
(when (eql object #\Newline)
(setf object #\Space)))
(when (>= (buffer-display-column buffer (offset mark2) tab-width)
(1- fill-column))
(fill-line mark2
syntax-line-indentation-function
fill-column
tab-width
compress-whitespaces
syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Indentation
(defgeneric indent-line (mark indentation tab-width)
(:documentation "Indent the line containing mark with indentation
spaces. Use tabs and spaces if tab-width is not nil, otherwise use
spaces only."))
(defun indent-line* (mark indentation tab-width left)
(let ((mark2 (clone-mark mark)))
(beginning-of-line mark2)
(loop until (end-of-buffer-p mark2)
as object = (object-after mark2)
while (or (eql object #\Space) (eql object #\Tab))
do (delete-range mark2 1))
(loop until (zerop indentation)
do (cond ((and tab-width (>= indentation tab-width))
(insert-object mark2 #\Tab)
(when left ; spaces must follow tabs
(forward-object mark2))
(decf indentation tab-width))
(t
(insert-object mark2 #\Space)
(decf indentation))))))
(defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
(indent-line* mark indentation tab-width t))
(defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
(indent-line* mark indentation tab-width nil))
(defun delete-indentation (mark)
(beginning-of-line mark)
(unless (beginning-of-buffer-p mark)
(delete-range mark -1)
(loop until (end-of-buffer-p mark)
while (buffer-whitespacep (object-after mark))
do (delete-range mark 1))
(loop until (beginning-of-buffer-p mark)
while (buffer-whitespacep (object-before mark))
do (delete-range mark -1))
(when (and (not (beginning-of-buffer-p mark))
(constituentp (object-before mark)))
(insert-object mark #\Space))))
More information about the Climacs-cvs
mailing list