/[mcclim]/mcclim/text-formatting.lisp
ViewVC logotype

Contents of /mcclim/text-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sun Nov 30 22:26:21 2008 UTC (5 years, 4 months ago) by ahefner
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +2 -2 lines
Fix bug in stream-write-string on filling-streams which caused an error
if the END keyword is nil, observable when climacs attempts to print a
lisp arglist (strange this wasn't observed earlier, though).
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 (in-package :clim-internals)
21
22 (defun format-textual-list (sequence printer
23 &key stream separator conjunction
24 suppress-separator-before-conjunction
25 suppress-space-after-conjunction)
26 "Outputs the SEQUENCE of items as a \"textual list\" into
27 STREAM. PRINTER is a function of an item and a stream. Between each
28 two items the string SEPARATOR is placed. If the string CONJUCTION is
29 supplied, it is placed before the last item.
30
31 SUPPRESS-SEPARATOR-BEFORE-CONJUNCTION and
32 SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard."
33 (orf stream *standard-output*)
34 (orf separator ", ")
35 (let* ((length (length sequence))
36 (n-rest length))
37 (map-repeated-sequence nil 1
38 (lambda (item)
39 (funcall printer item stream)
40 (decf n-rest)
41 (cond ((> n-rest 1)
42 (princ separator stream))
43 ((= n-rest 1)
44 (if conjunction
45 (progn
46 (unless suppress-separator-before-conjunction
47 (princ separator stream))
48 (princ conjunction stream)
49 (unless suppress-space-after-conjunction
50 (princ #\space stream)))
51 (princ separator stream)))))
52 sequence)))
53
54 ;;; filling-output support
55
56 (defclass filling-stream (standard-encapsulating-stream
57 extended-output-stream
58 output-recording-stream)
59 ((fill-width :accessor fill-width :initarg :fill-width)
60 (break-characters :accessor break-characters :initarg :break-characters
61 :initform '(#\Space))
62 (after-line-break :accessor after-line-break :initarg :after-line-break)))
63
64 ;;; parse-space is from table-formatting.lisp
65
66 (defmethod initialize-instance :after ((obj filling-stream)
67 &key (fill-width '(80 :character)))
68 (setf (fill-width obj) (parse-space (encapsulating-stream-stream obj)
69 fill-width
70 :horizontal)))
71
72 (defmethod stream-write-char :around ((stream filling-stream) char)
73 (let ((under-stream (encapsulating-stream-stream stream)))
74 (if (and (member char (break-characters stream) :test #'char=)
75 (> (stream-cursor-position under-stream) (fill-width stream)))
76 (progn
77 (stream-write-char under-stream #\newline)
78 (when (slot-boundp stream 'after-line-break)
79 (write-string (after-line-break stream)
80 (encapsulating-stream-stream stream))))
81 (call-next-method))))
82
83 (defmethod stream-write-string :around ((stream filling-stream) string
84 &optional (start 0) end)
85 (dotimes (i (- (or end (length string)) start))
86 (stream-write-char stream (aref string (+ i start)))))
87
88 ;;; All the monkey business with the lambda form has to do with capturing the
89 ;;; keyword arguments of the macro while preserving the user's evaluation order.
90
91 (defmacro filling-output ((stream &rest args &key fill-width break-characters
92 after-line-break after-line-break-initially)
93 &body body)
94 (when (eq stream t)
95 (setq stream '*standard-output*))
96 (with-gensyms (fill-var break-var after-var initially-var)
97 `((lambda (&key ((:fill-width ,fill-var))
98 ((:break-characters ,break-var))
99 ((:after-line-break ,after-var))
100 ((:after-line-break-initially ,initially-var)))
101 (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var))
102 (let ((,stream (make-instance
103 'filling-stream
104 :stream ,stream
105 ,@(and fill-width `(:fill-width ,fill-var))
106 ,@(and break-characters
107 `(:break-characters ,break-var))
108 ,@(and after-line-break
109 `(:after-line-break ,after-var)))))
110 ,(unless (null after-line-break-initially)
111 `(when ,initially-var
112 (write-string ,after-var ,stream)))
113 ,@body))
114 ,@args)))
115
116 ;;; indenting-output
117
118 (defclass indenting-output-stream (standard-encapsulating-stream
119 extended-output-stream
120 output-recording-stream)
121 ((indentation :accessor indentation)))
122
123 (defmethod initialize-instance :after ((obj indenting-output-stream)
124 &key (indent-spec 0) &allow-other-keys)
125 (setf (indentation obj) (parse-space (encapsulating-stream-stream obj)
126 indent-spec
127 :horizontal)))
128
129 (defmethod stream-write-char :around ((stream indenting-output-stream) char)
130 (let ((under-stream (encapsulating-stream-stream stream)))
131 (when (stream-start-line-p under-stream)
132 (stream-increment-cursor-position under-stream (indentation stream) nil))
133 (call-next-method)))
134
135 (defmethod stream-write-string :around ((stream indenting-output-stream)
136 string &optional (start 0) end)
137 (let ((under-stream (encapsulating-stream-stream stream))
138 (end (or end (length string))))
139 (flet ((foo (start end)
140 (when (stream-start-line-p under-stream)
141 (stream-increment-cursor-position under-stream (indentation stream) nil))
142 (stream-write-string under-stream string start end)))
143 (let ((seg-start start))
144 (loop for i from start below end do
145 (when (char= #\Newline
146 (char string i))
147 (foo seg-start (1+ i))
148 (setq seg-start (1+ i))))
149 (foo seg-start end)))))
150
151 (defmacro indenting-output ((stream indent &key (move-cursor t)) &body body)
152 (when (eq stream t)
153 (setq stream '*standard-output*))
154 (with-gensyms (old-x old-y)
155 `(multiple-value-bind (,old-x ,old-y)
156 (stream-cursor-position ,stream)
157 (let ((,stream (make-instance
158 'indenting-output-stream
159 :stream ,stream
160 :indent-spec ,indent)))
161 ,@body)
162 (unless ,move-cursor
163 (setf (stream-cursor-position ,stream)
164 (values ,old-x ,old-y))))))

  ViewVC Help
Powered by ViewVC 1.1.5