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

Contents of /mcclim/text-formatting.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide 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 adejneka 1.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 mikemac 1.4 (in-package :clim-internals)
21 adejneka 1.1
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 moore 1.2 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 adejneka 1.3 :initform '(#\Space))
62 moore 1.2 (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 thenriksen 1.10 (defmethod stream-write-string :around ((stream filling-stream) string
84 ahefner 1.11 &optional (start 0) end)
85     (dotimes (i (- (or end (length string)) start))
86 thenriksen 1.10 (stream-write-char stream (aref string (+ i start)))))
87    
88 moore 1.2 ;;; 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 thenriksen 1.10 (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var))
102 moore 1.2 (let ((,stream (make-instance
103     'filling-stream
104     :stream ,stream
105 adejneka 1.3 ,@(and fill-width `(:fill-width ,fill-var))
106 moore 1.2 ,@(and break-characters
107 adejneka 1.3 `(:break-characters ,break-var))
108 moore 1.2 ,@(and after-line-break
109 adejneka 1.3 `(:after-line-break ,after-var)))))
110 thenriksen 1.10 ,(unless (null after-line-break-initially)
111     `(when ,initially-var
112     (write-string ,after-var ,stream)))
113 moore 1.2 ,@body))
114     ,@args)))
115    
116 hefner1 1.5 ;;; 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 hefner1 1.6 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 hefner1 1.5
151 tmoore 1.9 (defmacro indenting-output ((stream indent &key (move-cursor t)) &body body)
152     (when (eq stream t)
153 hefner1 1.5 (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