source: release/1.6/source/level-1/l1-format.lisp @ 14712

Last change on this file since 14712 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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