source: trunk/source/level-1/l1-format.lisp @ 8177

Last change on this file since 8177 was 6940, checked in by gb, 13 years ago

Handling of * format directive when dealing with circularity screws
up other things that expect *FORMAT-ARGUMENTS* to share structure
with *FORMAT-ORIGINAL-ARGUMENTS*.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.7 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; L1-format.lisp
18;
19; This file contains the definition for SUB-FORMAT, the dispatching part
20; of FORMAT. It also contains an interim definition for FORMAT and a few
21; incompletely implemented directives.
22
23(in-package "CCL")
24
25(eval-when (eval compile #-bccl load)  ;Load-time as well so CCL can use it.
26  (defmacro defformat (char name &rest def)
27    `(progn
28       (add-format-char ,char (function (lambda . ,def)))
29       ',name))
30  )
31
32(defparameter *format-char-table* (let* ((x (make-array 128 :initial-element nil))) x))
33
34(defun add-format-char (char def)
35  (unless (and (characterp char) (%i< (%char-code char) 128))
36    (report-bad-arg char 'standard-char))
37  (setf (svref *format-char-table* (%char-code (char-upcase char))) def))
38
39(proclaim '(special *format-original-arguments*   ;For ~*
40                    *format-arguments*            ;For pop-format-arg
41                    *format-control-string*       ;For ~?, ~{
42                    *format-index*
43                    *format-length*
44                    *format-pprint*               ;~I,~W,~_,~:T seen?
45                    *format-justification-semi*   ;~<..~:;..~> seen?
46            ))
47
48(defun pop-format-arg (&aux (args *format-arguments*))
49  (if (null args)
50      (format-error "Missing argument"))
51    (progn
52     (setq *format-arguments* (cdr args))
53     (%car args)))
54 
55;SUB-FORMAT parses (a range of) the control string, finding the directives
56;and applying them to their parameters.
57;Implicit arguments to SUB-FORMAT: *format-control-string*, *format-arguments*,
58;*format-original-arguments*, *standard-output*, *format-char-table*
59;*format-control-string* must be a simple string.
60;Directive functions' arglist should be (colon-p atsign-p &rest params)
61;In addition when the directive is called, *format-index* and *format-length*
62;are bound to start and end pos (in *format-control-string*) of the rest of the
63; control string.  The directive may modify *format-index*, but not
64; *format-control-string* and *format-length*, before returning.
65
66(defun sub-format (stream *format-index* *format-length* &aux (string *format-control-string*) char)
67  (prog* ((length *format-length*) (i *format-index*) (lastpos i))
68    (declare (fixnum i length lastpos))
69    (go START)
70    EOF-ERROR
71    (setq *format-index* *format-length*)
72    (format-error "Premature end of control string")
73    START
74    (do* ()
75         ((= i length) (unless (= i lastpos) 
76                         (write-string string stream :start  lastpos :end i)))
77      (setq char (schar string i) i (1+ i))
78      (when (eq char #\~)
79        (let* ((limit (the fixnum (1- i))))
80          (unless (= limit lastpos) 
81            (write-string string stream :start  lastpos :end limit)))
82        (let ((params nil) (fn) (colon nil) (atsign nil))
83          (block nil
84            (tagbody
85              NEXT
86              (if (= i length) (go EOF-ERROR))
87              (setq char (schar string i) i (1+ i))
88              (cond ((eq char #\#)
89                     (push (list-length *format-arguments*) params))
90                    ((eq char #\')
91                     (if (= i length) (go EOF-ERROR))
92                     (push (schar string i) params)
93                     (incf i))
94                    ((eq char #\,)
95                     (push nil params)
96                     (go NEXT))
97                    ((or (eq char #\V) (eq char #\v))
98                     (push (pop-format-arg) params))
99                    ((or (eq char #\-) (eq char #\+) (digit-char-p char))
100                     (let ((start (%i- i 1)) n)
101                       (loop
102                         (when (= i length) (go EOF-ERROR))
103                         (unless (digit-char-p (schar string i)) (return))
104                         (incf i))
105                       (when (null (setq n (%parse-number-token string start i)))
106                         (setq *format-index* i)
107                         (format-error "Illegal parameter"))
108                       (push n params)))
109                    (t (return)))
110              (if (= i length) (go EOF-ERROR))
111              (setq char (schar string i) i (1+ i))
112              (when (neq char #\,) (return))
113              (go NEXT)))
114          (cond ((eq char #\:) 
115                 (if (= i length) (go EOF-ERROR))
116                 (setq colon t char (schar string i) i (1+ i))
117                 (when (eq char #\@)
118                   (if (= i length) (go EOF-ERROR))                     
119                   (setq atsign t char (schar string i) i (1+ i))))
120                ((eq char #\@)
121                 (if (= i length) (go EOF-ERROR))
122                 (setq atsign t char (schar string i) i (1+ i))
123                 (when (eq char #\:)
124                   (if (= i length) (go EOF-ERROR))
125                   (setq colon t char (schar string i) i (1+ i)))))
126          (setq *format-index* (%i- i 1))
127          (if (setq fn (svref *format-char-table* (%char-code (char-upcase char))))
128            (apply fn stream colon atsign (nreverse params))
129            (format-error "Unknown directive"))
130          (setq i (%i+ *format-index* 1)
131                lastpos i))))))
132
133
134#|
135(eval-when (load)
136  ;The non-consing version.
137(defun sub-format (stream *format-index* *format-length*)
138  (declare (special *format-index* *format-length*))
139  (old-lap-inline (stream)
140    (preserve_regs #(asave0 asave1 dsave0 dsave1 dsave2))
141    (defreg Control-string asave0 Index dsave0 Length dsave1 NumParams dsave2 Stream asave1)
142    (move.l acc Stream)
143    (move.l (special *format-index*) Index)       ; *format-index*
144    (move.l (special *format-length*) Length)      ; *format-length*
145    (specref *format-control-string*)
146    (move.l acc Control-string)
147
148    ;Make sure everything is in bounds, so don't have to worry about
149    ;boxing, bounds checking, etc.
150start
151    (movereg Control-string arg_z)
152    (jsr_subprim $sp-length)
153    (ccall <= '0 Index Length acc)
154    (cmp.l nilreg acc)
155    (beq done)
156    (move.l Index db)
157    (loop#
158      (if# (eq Length Index)
159        (cmp.l db Index)
160        (beq done)
161        (ccall 'stream-write-string Stream Control-string db Index)
162        (bra done))
163      (move.l Index da)
164      (getint da)
165      (move.l ($ $t_imm_char 0) acc)
166      (move.b (Control-string da.l $v_data) acc)
167      (add.l (fixnum 1) Index)
168      (cmp.b ($ #\~) acc)
169      (beq tilde))
170
171nextchar
172    (if# (eq Length Index)
173      (move.l '"Premature end of format control string" arg_z)
174      (add.w ($ 4) sp)                  ; flush internal bsr.
175      (bra error))
176    (move.l Index da)
177    (getint da)
178    (move.b (Control-string da.l $v_data) acc)
179    (add.l (fixnum 1) Index)
180    (if# (and (ge (cmp.b ($ #\a) acc)) (le (cmp.b ($ #\z) acc)))
181      (sub.b ($ 32) acc))
182    (rts)
183
184tilde
185    (move.l Index da)
186    (sub.l (fixnum 1) da)
187    (if# (not (eq da db))     
188      (ccall 'stream-write-string Stream Control-string db da))
189    (vpush Stream)
190    (vpush nilreg)             ;assume no :
191    (vpush nilreg)             ;assume no @
192    (move.l (fixnum 3) NumParams)
193do-param
194    (bsr nextchar)
195    (if# (or (eq (cmp.b ($ #\+) acc))
196             (eq (cmp.b ($ #\-) acc))
197             (and (ge (cmp.b ($ #\0) acc)) (le (cmp.b ($ #\9) acc))))
198      (move.l Index da)
199      (sub.l (fixnum 1) da)
200      (vpush da)
201      (prog#
202       (bsr nextchar)
203       (until# (or (lt (cmp.b ($ #\0) acc)) (gt (cmp.b ($ #\9) acc)))))
204      (sub.l (fixnum 1) Index)   ;unread the non-digit char
205      (ccall %parse-number-token Control-string vsp@+ Index)
206      (cmp.l nilreg acc)
207      (bne push-param)
208      (move.l '"Illegal format parameter" arg_z)
209      (bra error))
210
211    (if# (eq (cmp.b ($ #\#) acc))
212      (move.l (special *format-arguments*) acc)
213      (jsr_subprim $sp-length)
214      (bra push-param))
215
216    (if# (eq (cmp.b ($ #\') acc))
217      (bsr nextchar)
218      (move.l ($ $t_imm_char 0) acc)
219      (move.b (Control-string da.l $v_data) acc)  ;Get the non-uppercased version...
220      (swap acc)
221      (bra push-param))
222
223    (if# (eq (cmp.b ($ #\,) acc))
224      (sub.l (fixnum 1) Index)   ;Re-read the comma.
225      (move.l nilreg acc)
226      (bra push-param))
227
228    (if# (eq (cmp.b ($ #\V) acc))
229      (ccall 'pop-format-arg)
230      ;(bra push-param)
231     push-param
232      (vpush acc)
233      (add.l (fixnum 1) NumParams)
234      (bsr nextchar)
235      (cmp.b ($ #\,) acc)
236      (beq do-param))
237
238    (move.l NumParams nargs)
239    (vscale.l nargs)
240    (cmp.b ($ #\:) acc)
241    (if# eq
242      (bsr nextchar)
243      (cmp.b ($ #\@) acc)
244      (bne @a)
245      (move.l (a5 $t) (vsp nargs.w -12))
246     else#
247      (cmp.b ($ #\@) acc)
248      (bne @b)
249      (move.l (a5 $t) (vsp nargs.w -12))
250      (bsr nextchar)
251      (cmp.b ($ #\:) acc)
252      (bne @b))
253    (bsr nextchar)
254@a  (move.l (a5 $t) (vsp nargs.w -8))
255@b  (moveq 127 da)
256    (and.w acc da)
257    (bif (ne (cmp.b da acc)) nofun)
258    (lsl.w 2 da)
259    (move.l (special *format-char-table*) atemp0)
260    (move.l (atemp0 da.w $v_data) atemp0)
261    (cmp.l atemp0 nilreg)
262    (beq nofun)
263    (move.l Index da)
264    (sub.l (fixnum 1) da)
265    (move.l da (special *format-index*))
266    (move.l NumParams nargs)
267    (vscale.l nargs)                    ; at least 3 args.
268    (movem.l vsp@+ #(arg_z arg_y arg_x))
269    (jsr_subprim $sp-funcall)
270    (specref '*format-index*)
271    (add.l (fixnum 1) acc)
272    (move.l acc Index)
273    (bra start)
274
275nofun
276    (move.l '"Unknown format directive" acc)
277error
278    (move.l Index (special *format-index*))
279    (fsymevalapply 'format-error 1)
280
281done
282    (restore_regs)
283    ))
284) ;end of eval-when (load)
285
286|#
287
288;Interim definitions
289
290;This function is shadowed by CCL in order to use ~{ to print error messages.
291(defun format (stream control-string &rest format-arguments)
292  (declare (dynamic-extent format-arguments))
293  (when (eq stream t) (setq stream *standard-output*))
294  (when (null stream)
295   (return-from format 
296    (with-output-to-string (x)
297     (apply #'format x control-string format-arguments))))
298  (unless (streamp stream) (report-bad-arg stream 'stream))
299  (if (functionp control-string)
300    (apply control-string stream format-arguments)
301    (progn
302      (setq control-string (ensure-simple-string control-string))
303      (let* ((*format-original-arguments* format-arguments)
304             (*format-arguments* format-arguments)
305             (*format-control-string* control-string))
306        (catch 'format-escape
307         (sub-format stream 0 (length control-string)))
308        nil))))
309
310(defun format-error (&rest args)
311   (format t "~&FORMAT error at position ~A in control string ~S "
312             *format-index* *format-control-string*)
313   (apply #'error args))
314
315(defun format-no-flags (colon atsign)
316  (when (or colon atsign) (format-error "Flags not allowed")))
317
318;Redefined later
319(defformat #\A format-a (stream colon atsign)
320   (declare (ignore colon atsign))
321   (princ (pop-format-arg) stream))
322
323;Redefined later
324(defformat #\S format-s (stream colon atsign)
325  (declare (ignore colon atsign))
326  (prin1 (pop-format-arg) stream))
327
328;Redefined later
329(defformat #\^ format-escape (stream colon atsign)
330  (declare (ignore stream colon atsign))
331  (throw 'format-escape t))
332
333;Final version
334(defformat #\% format-% (stream colon atsign &optional repeat-count)
335  (cond ((or (not repeat-count)
336            (and repeat-count (fixnump repeat-count)
337                 (> repeat-count -1)))
338         (format-no-flags colon atsign)
339         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream)))
340        (t (format-error "Bad repeat-count."))))
341
342;Final version
343(defformat #\& format-& (stream colon atsign &optional repeat-count)
344  (format-no-flags colon atsign)
345  (unless (eq repeat-count 0)
346    (fresh-line stream)
347    (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream))))
348
349;Final version
350(defformat #\~ format-~ (stream colon atsign &optional repeat-count)
351  (format-no-flags colon atsign)
352  (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream)))
353
354;Final version
355(defformat #\P format-p (stream colon atsign)
356  (when colon
357     (let ((end *format-arguments*) (list *format-original-arguments*))
358        (tagbody loop
359           (if list
360             (when (neq (cdr list) end)
361               (setq list (%cdr list))
362               (go loop))
363             (format-error "No previous argument")))
364        (setq *format-arguments* list)))
365   (%write-string (if (eq (pop-format-arg) 1)
366                    (if atsign "y" "")
367                    (if atsign "ies" "s"))
368                  stream))
369
370;Final version
371(defformat #\* format-* (stream colon atsign &optional count)
372  (declare (ignore stream)(special *circularity-hash-table*))
373  (let* ((orig *format-original-arguments*)
374         (where (- (list-length orig)   ; will error if args circular
375                   (list-length *format-arguments*)))
376         (to (if atsign 
377               (or count 0) ; absolute
378               (progn
379                 (when (null count)(setq count 1))
380                 (when colon (setq count (- count)))
381                 (%i+ where count))))
382         (args (nthcdr-no-overflow to orig)))
383    ; avoid bogus circularity indication
384    (when (and nil (consp args) (<= to where) *circularity-hash-table*)
385      ; copy only from to thru where in case  some real shared structure
386      (let ((l args) new)
387        (dotimes (i (1+  (- where to)))
388          (declare (fixnum i))
389          (push (car l) new)
390          (setq l (cdr l)))
391        (setq args (nreconc new (nthcdr (1+ where) orig))))) ;(copy-list args)))
392    (setq *format-arguments* args)))
393
394; Redefined later.
395(defformat #\Newline format-newline (&rest ignore)
396  (declare (ignore ignore))
397  (do* ((i *format-index* (1+ i))
398        (s *format-control-string*)
399        (n *format-length*))
400       ((or (= i n)
401            (not (whitespacep (schar s i))))
402        (setq *format-index* (1- i)))))
403       
404(defun nthcdr-no-overflow (count list)
405  "If cdr beyond end of list return :error" 
406  (if (or (> count (list-length list)) (< count 0))
407    nil ;:error
408    (nthcdr count list)))
409
410;Redefined later
411(defformat #\X format-x (stream colon atsign)
412  (declare (ignore colon atsign))
413  (let* ((*print-base* 16.)
414         (*print-radix* nil))
415    (prin1 (pop-format-arg) stream)))
416
417;Redefined later
418(defformat #\D format-d (stream colon atsign &rest ignore)
419  (declare (ignore colon atsign ignore))
420  (let* ((*print-base* 10.)
421         (*print-radix* nil))
422    (prin1 (pop-format-arg) stream)))
Note: See TracBrowser for help on using the repository browser.