Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 159 lines (141 sloc) 6.554 kb
60141844 » Alexey Dejneka
2002-08-03 * Implemented FORMAT-TEXTUAL-LIST.
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
95dff8a4 » Mike McDonald
2003-03-21 make all of the package names passed to in-package be lowercase keywo…
20 (in-package :clim-internals)
60141844 » Alexey Dejneka
2002-08-03 * Implemented FORMAT-TEXTUAL-LIST.
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)))))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
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
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
61 :initform '(#\Space))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
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 ;;; All the monkey business with the lambda form has to do with capturing the
84 ;;; keyword arguments of the macro while preserving the user's evaluation order.
85
86 (defmacro filling-output ((stream &rest args &key fill-width break-characters
87 after-line-break after-line-break-initially)
88 &body body)
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
89 (declare (ignore after-line-break-initially))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
90 (when (eq stream t)
91 (setq stream '*standard-output*))
92 (with-gensyms (fill-var break-var after-var initially-var)
93 `((lambda (&key ((:fill-width ,fill-var))
94 ((:break-characters ,break-var))
95 ((:after-line-break ,after-var))
96 ((:after-line-break-initially ,initially-var)))
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
97 (declare (ignorable ,fill-var ,break-var ,after-var))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
98 (let ((,stream (make-instance
99 'filling-stream
100 :stream ,stream
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
101 ,@(and fill-width `(:fill-width ,fill-var))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
102 ,@(and break-characters
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
103 `(:break-characters ,break-var))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
104 ,@(and after-line-break
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
105 `(:after-line-break ,after-var)))))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
106 (when ,initially-var
022387d7 » Alexey Dejneka
2002-11-28 Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
107 (write-string ,after-var ,stream))
f1abcc74 » Timothy Moore
2002-11-11 3 sets of additions/changes/fixes:
108 ,@body))
109 ,@args)))
110
cc178bfe » Andy Hefner
2003-04-10 Implemented indenting-output. Also, encapsulating stream hackery,
111 ;;; indenting-output
112
113 (defclass indenting-output-stream (standard-encapsulating-stream
114 extended-output-stream
115 output-recording-stream)
116 ((indentation :accessor indentation)))
117
118 (defmethod initialize-instance :after ((obj indenting-output-stream)
119 &key (indent-spec 0) &allow-other-keys)
120 (setf (indentation obj) (parse-space (encapsulating-stream-stream obj)
121 indent-spec
122 :horizontal)))
123
124 (defmethod stream-write-char :around ((stream indenting-output-stream) char)
125 (let ((under-stream (encapsulating-stream-stream stream)))
126 (when (stream-start-line-p under-stream)
127 (stream-increment-cursor-position under-stream (indentation stream) nil))
128 (call-next-method)))
129
130 (defmethod stream-write-string :around ((stream indenting-output-stream)
eca9fbfb » Andy Hefner
2003-04-15 Indenting-output-stream now uses stream-write-string rather than stre…
131 string &optional (start 0) end)
132 (let ((under-stream (encapsulating-stream-stream stream))
133 (end (or end (length string))))
134 (flet ((foo (start end)
135 (when (stream-start-line-p under-stream)
136 (stream-increment-cursor-position under-stream (indentation stream) nil))
137 (stream-write-string under-stream string start end)))
138 (let ((seg-start start))
139 (loop for i from start below end do
140 (when (char= #\Newline
141 (char string i))
142 (foo seg-start (1+ i))
143 (setq seg-start (1+ i))))
144 (foo seg-start end)))))
cc178bfe » Andy Hefner
2003-04-10 Implemented indenting-output. Also, encapsulating stream hackery,
145
165956b9 » Timothy Moore
2006-03-29 Take out dependencies on case in symbol names. This makes McCLIM sort
146 (defmacro indenting-output ((stream indent &key (move-cursor t)) &body body)
147 (when (eq stream t)
cc178bfe » Andy Hefner
2003-04-10 Implemented indenting-output. Also, encapsulating stream hackery,
148 (setq stream '*standard-output*))
149 (with-gensyms (old-x old-y)
150 `(multiple-value-bind (,old-x ,old-y)
151 (stream-cursor-position ,stream)
152 (let ((,stream (make-instance
153 'indenting-output-stream
154 :stream ,stream
155 :indent-spec ,indent)))
156 ,@body)
157 (unless ,move-cursor
158 (setf (stream-cursor-position ,stream)
159 (values ,old-x ,old-y))))))
Something went wrong with that request. Please try again.