Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 117 lines (102 sloc) 4.788 kB
6014184 * Implemented FORMAT-TEXTUAL-LIST.
Alexey Dejneka authored
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 ;;; TODO:
21 ;;;
22 ;;; - INDENTING-OUTPUT
23 ;;;
24 ;;; - FILLING-OUTPUT
25
26 (in-package :CLIM-INTERNALS)
27
28 (defun format-textual-list (sequence printer
29 &key stream separator conjunction
30 suppress-separator-before-conjunction
31 suppress-space-after-conjunction)
32 "Outputs the SEQUENCE of items as a \"textual list\" into
33 STREAM. PRINTER is a function of an item and a stream. Between each
34 two items the string SEPARATOR is placed. If the string CONJUCTION is
35 supplied, it is placed before the last item.
36
37 SUPPRESS-SEPARATOR-BEFORE-CONJUNCTION and
38 SUPPRESS-SPACE-AFTER-CONJUNCTION are non-standard."
39 (orf stream *standard-output*)
40 (orf separator ", ")
41 (let* ((length (length sequence))
42 (n-rest length))
43 (map-repeated-sequence nil 1
44 (lambda (item)
45 (funcall printer item stream)
46 (decf n-rest)
47 (cond ((> n-rest 1)
48 (princ separator stream))
49 ((= n-rest 1)
50 (if conjunction
51 (progn
52 (unless suppress-separator-before-conjunction
53 (princ separator stream))
54 (princ conjunction stream)
55 (unless suppress-space-after-conjunction
56 (princ #\space stream)))
57 (princ separator stream)))))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
58 sequence)))
59
60 ;;; filling-output support
61
62 (defclass filling-stream (standard-encapsulating-stream
63 extended-output-stream
64 output-recording-stream)
65 ((fill-width :accessor fill-width :initarg :fill-width)
66 (break-characters :accessor break-characters :initarg :break-characters
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
67 :initform '(#\Space))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
68 (after-line-break :accessor after-line-break :initarg :after-line-break)))
69
70 ;;; parse-space is from table-formatting.lisp
71
72 (defmethod initialize-instance :after ((obj filling-stream)
73 &key (fill-width '(80 :character)))
74 (setf (fill-width obj) (parse-space (encapsulating-stream-stream obj)
75 fill-width
76 :horizontal)))
77
78 (defmethod stream-write-char :around ((stream filling-stream) char)
79 (let ((under-stream (encapsulating-stream-stream stream)))
80 (if (and (member char (break-characters stream) :test #'char=)
81 (> (stream-cursor-position under-stream) (fill-width stream)))
82 (progn
83 (stream-write-char under-stream #\newline)
84 (when (slot-boundp stream 'after-line-break)
85 (write-string (after-line-break stream)
86 (encapsulating-stream-stream stream))))
87 (call-next-method))))
88
89 ;;; All the monkey business with the lambda form has to do with capturing the
90 ;;; keyword arguments of the macro while preserving the user's evaluation order.
91
92 (defmacro filling-output ((stream &rest args &key fill-width break-characters
93 after-line-break after-line-break-initially)
94 &body body)
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
95 (declare (ignore after-line-break-initially))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
96 (when (eq stream t)
97 (setq stream '*standard-output*))
98 (with-gensyms (fill-var break-var after-var initially-var)
99 `((lambda (&key ((:fill-width ,fill-var))
100 ((:break-characters ,break-var))
101 ((:after-line-break ,after-var))
102 ((:after-line-break-initially ,initially-var)))
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
103 (declare (ignorable ,fill-var ,break-var ,after-var))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
104 (let ((,stream (make-instance
105 'filling-stream
106 :stream ,stream
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
107 ,@(and fill-width `(:fill-width ,fill-var))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
108 ,@(and break-characters
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
109 `(:break-characters ,break-var))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
110 ,@(and after-line-break
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
111 `(:after-line-break ,after-var)))))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
112 (when ,initially-var
022387d Merged in a slightly modified patch by Fred Gilham for FILLING-OUTPUT.
Alexey Dejneka authored
113 (write-string ,after-var ,stream))
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
114 ,@body))
115 ,@args)))
116
Something went wrong with that request. Please try again.