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

Last change on this file since 12763 was 11805, checked in by gz, 11 years ago

Make the compiler scan format strings for possible errors. ccl::*format-arg-functions* is the alist of functions that should be scanned (so setting this to nil is a way to disable the scanning). The code to actually do the scanning is in format.lisp. It doesn't seem to slow down the compiler in any noticable way. It finds some cases of insufficient args in format strings in ccl sources, I'll fix those in a separate checkin later.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.5 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 (nfunction ,name (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 char)
67  (prog* ((string (require-type *format-control-string* 'simple-string))
68          (length *format-length*)
69          (i *format-index*)
70          (lastpos i))
71    (declare (fixnum i length lastpos) (type simple-string string))
72    (go START)
73    EOF-ERROR
74    (setq *format-index* *format-length*)
75    (format-error "Premature end of control string")
76    START
77    (do* ()
78         ((= i length) (unless (= i lastpos) 
79                         (write-string string stream :start  lastpos :end i)))
80      (setq char (schar string i) i (1+ i))
81      (when (eq char #\~)
82        (let* ((limit (the fixnum (1- i))))
83          (unless (= limit lastpos) 
84            (write-simple-string string stream  lastpos limit)))
85        (let ((params nil) (fn) (colon nil) (atsign nil))
86          (block nil
87            (tagbody
88              NEXT
89              (if (= i length) (go EOF-ERROR))
90              (setq char (schar string i) i (1+ i))
91              (cond ((eq char #\#)
92                     (push (list-length *format-arguments*) params))
93                    ((eq char #\')
94                     (if (= i length) (go EOF-ERROR))
95                     (push (schar string i) params)
96                     (incf i))
97                    ((eq char #\,)
98                     (push nil params)
99                     (go NEXT))
100                    ((or (eq char #\V) (eq char #\v))
101                     (push (pop-format-arg) params))
102                    ((or (eq char #\-) (eq char #\+) (digit-char-p char))
103                     (let ((start (%i- i 1)) n)
104                       (loop
105                         (when (= i length) (go EOF-ERROR))
106                         (unless (digit-char-p (schar string i)) (return))
107                         (incf i))
108                       (when (null (setq n (%parse-number-token string start i)))
109                         (setq *format-index* i)
110                         (format-error "Illegal parameter"))
111                       (push n params)))
112                    (t (return)))
113              (if (= i length) (go EOF-ERROR))
114              (setq char (schar string i) i (1+ i))
115              (when (neq char #\,) (return))
116              (go NEXT)))
117          (cond ((eq char #\:) 
118                 (if (= i length) (go EOF-ERROR))
119                 (setq colon t char (schar string i) i (1+ i))
120                 (when (eq char #\@)
121                   (if (= i length) (go EOF-ERROR))                     
122                   (setq atsign t char (schar string i) i (1+ i))))
123                ((eq char #\@)
124                 (if (= i length) (go EOF-ERROR))
125                 (setq atsign t char (schar string i) i (1+ i))
126                 (when (eq char #\:)
127                   (if (= i length) (go EOF-ERROR))
128                   (setq colon t char (schar string i) i (1+ i)))))
129          (setq *format-index* (%i- i 1))
130          (if (setq fn (svref *format-char-table* (%char-code (char-upcase char))))
131            (apply fn stream colon atsign (nreverse params))
132            (format-error "Unknown directive"))
133          (setq i (%i+ *format-index* 1)
134                lastpos i))))))
135
136
137#||
138(eval-when (load)
139  ;The non-consing version.
140(defun sub-format (stream *format-index* *format-length*)
141  (declare (special *format-index* *format-length*))
142  (old-lap-inline (stream)
143    (preserve_regs #(asave0 asave1 dsave0 dsave1 dsave2))
144    (defreg Control-string asave0 Index dsave0 Length dsave1 NumParams dsave2 Stream asave1)
145    (move.l acc Stream)
146    (move.l (special *format-index*) Index)       ; *format-index*
147    (move.l (special *format-length*) Length)      ; *format-length*
148    (specref *format-control-string*)
149    (move.l acc Control-string)
150
151    ;Make sure everything is in bounds, so don't have to worry about
152    ;boxing, bounds checking, etc.
153start
154    (movereg Control-string arg_z)
155    (jsr_subprim $sp-length)
156    (ccall <= '0 Index Length acc)
157    (cmp.l nilreg acc)
158    (beq done)
159    (move.l Index db)
160    (loop#
161      (if# (eq Length Index)
162        (cmp.l db Index)
163        (beq done)
164        (ccall 'stream-write-string Stream Control-string db Index)
165        (bra done))
166      (move.l Index da)
167      (getint da)
168      (move.l ($ $t_imm_char 0) acc)
169      (move.b (Control-string da.l $v_data) acc)
170      (add.l (fixnum 1) Index)
171      (cmp.b ($ #\~) acc)
172      (beq tilde))
173
174nextchar
175    (if# (eq Length Index)
176      (move.l '"Premature end of format control string" arg_z)
177      (add.w ($ 4) sp)                  ; flush internal bsr.
178      (bra error))
179    (move.l Index da)
180    (getint da)
181    (move.b (Control-string da.l $v_data) acc)
182    (add.l (fixnum 1) Index)
183    (if# (and (ge (cmp.b ($ #\a) acc)) (le (cmp.b ($ #\z) acc)))
184      (sub.b ($ 32) acc))
185    (rts)
186
187tilde
188    (move.l Index da)
189    (sub.l (fixnum 1) da)
190    (if# (not (eq da db))     
191      (ccall 'stream-write-string Stream Control-string db da))
192    (vpush Stream)
193    (vpush nilreg)             ;assume no :
194    (vpush nilreg)             ;assume no @
195    (move.l (fixnum 3) NumParams)
196do-param
197    (bsr nextchar)
198    (if# (or (eq (cmp.b ($ #\+) acc))
199             (eq (cmp.b ($ #\-) acc))
200             (and (ge (cmp.b ($ #\0) acc)) (le (cmp.b ($ #\9) acc))))
201      (move.l Index da)
202      (sub.l (fixnum 1) da)
203      (vpush da)
204      (prog#
205       (bsr nextchar)
206       (until# (or (lt (cmp.b ($ #\0) acc)) (gt (cmp.b ($ #\9) acc)))))
207      (sub.l (fixnum 1) Index)   ;unread the non-digit char
208      (ccall %parse-number-token Control-string vsp@+ Index)
209      (cmp.l nilreg acc)
210      (bne push-param)
211      (move.l '"Illegal format parameter" arg_z)
212      (bra error))
213
214    (if# (eq (cmp.b ($ #\#) acc))
215      (move.l (special *format-arguments*) acc)
216      (jsr_subprim $sp-length)
217      (bra push-param))
218
219    (if# (eq (cmp.b ($ #\') acc))
220      (bsr nextchar)
221      (move.l ($ $t_imm_char 0) acc)
222      (move.b (Control-string da.l $v_data) acc)  ;Get the non-uppercased version...
223      (swap acc)
224      (bra push-param))
225
226    (if# (eq (cmp.b ($ #\,) acc))
227      (sub.l (fixnum 1) Index)   ;Re-read the comma.
228      (move.l nilreg acc)
229      (bra push-param))
230
231    (if# (eq (cmp.b ($ #\V) acc))
232      (ccall 'pop-format-arg)
233      ;(bra push-param)
234     push-param
235      (vpush acc)
236      (add.l (fixnum 1) NumParams)
237      (bsr nextchar)
238      (cmp.b ($ #\,) acc)
239      (beq do-param))
240
241    (move.l NumParams nargs)
242    (vscale.l nargs)
243    (cmp.b ($ #\:) acc)
244    (if# eq
245      (bsr nextchar)
246      (cmp.b ($ #\@) acc)
247      (bne @a)
248      (move.l (a5 $t) (vsp nargs.w -12))
249     else#
250      (cmp.b ($ #\@) acc)
251      (bne @b)
252      (move.l (a5 $t) (vsp nargs.w -12))
253      (bsr nextchar)
254      (cmp.b ($ #\:) acc)
255      (bne @b))
256    (bsr nextchar)
257@a  (move.l (a5 $t) (vsp nargs.w -8))
258@b  (moveq 127 da)
259    (and.w acc da)
260    (bif (ne (cmp.b da acc)) nofun)
261    (lsl.w 2 da)
262    (move.l (special *format-char-table*) atemp0)
263    (move.l (atemp0 da.w $v_data) atemp0)
264    (cmp.l atemp0 nilreg)
265    (beq nofun)
266    (move.l Index da)
267    (sub.l (fixnum 1) da)
268    (move.l da (special *format-index*))
269    (move.l NumParams nargs)
270    (vscale.l nargs)                    ; at least 3 args.
271    (movem.l vsp@+ #(arg_z arg_y arg_x))
272    (jsr_subprim $sp-funcall)
273    (specref '*format-index*)
274    (add.l (fixnum 1) acc)
275    (move.l acc Index)
276    (bra start)
277
278nofun
279    (move.l '"Unknown format directive" acc)
280error
281    (move.l Index (special *format-index*))
282    (fsymevalapply 'format-error 1)
283
284done
285    (restore_regs)
286    ))
287) ;end of eval-when (load)
288
289||#
290
291;;;Interim definitions
292
293;;;This function is shadowed by CCL in order to use ~{ to print error messages.
294(fset 'format 
295      (nlambda bootstrapping-format (stream control-string &rest format-arguments)
296        (declare (dynamic-extent format-arguments))
297        (block format
298          (when (null stream)
299            (return-from format 
300              (with-output-to-string (x)
301                (apply #'format x control-string format-arguments))))
302          (if (eq stream t)
303            (setq stream *standard-output*)
304            (unless (streamp stream) (report-bad-arg stream 'stream)))
305          (if (functionp control-string)
306            (apply control-string stream format-arguments)
307            (progn
308              (setq control-string (ensure-simple-string control-string))
309              (let* ((*format-original-arguments* format-arguments)
310                     (*format-arguments* format-arguments)
311                     (*format-control-string* control-string))
312                (catch 'format-escape
313                  (sub-format stream 0 (length control-string)))
314                nil))))))
315
316(fset 'format-error
317      (nlambda bootstrapping-format-error (&rest args)
318        (format t "~&FORMAT error at position ~A in control string ~S "
319                *format-index* *format-control-string*)
320        (apply #'error args)))
321
322(defun format-no-flags (colon atsign)
323  (cond ((and colon atsign)
324         (format-error "Flags not allowed"))
325        (colon
326         (format-error ": flag not allowed"))
327        (atsign
328         (format-error "@ flag not allowed"))))
329
330;Redefined later
331(defformat #\A format-a (stream colon atsign)
332   (declare (ignore colon atsign))
333   (princ (pop-format-arg) stream))
334
335;Redefined later
336(defformat #\S format-s (stream colon atsign)
337  (declare (ignore colon atsign))
338  (prin1 (pop-format-arg) stream))
339
340;Redefined later
341(defformat #\^ format-escape (stream colon atsign)
342  (declare (ignore stream colon atsign))
343  (throw 'format-escape t))
344
345;Final version
346(defformat #\% format-% (stream colon atsign &optional repeat-count)
347  (format-no-flags colon atsign)
348  (cond ((or (not repeat-count)
349             (and (fixnump repeat-count)
350                  (> repeat-count -1)))
351         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream)))
352        (t (format-error "Bad repeat-count."))))
353
354;Final version
355(defformat #\& format-& (stream colon atsign &optional repeat-count)
356  (format-no-flags colon atsign)
357  (cond ((or (not repeat-count)
358             (and (fixnump repeat-count)
359                  (> repeat-count -1)))
360         (unless (eq repeat-count 0)
361           (fresh-line stream)
362           (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream))))
363        (t (format-error "Bad repeat-count."))))
364
365;Final version
366(defformat #\~ format-~ (stream colon atsign &optional repeat-count)
367  (format-no-flags colon atsign)
368  (cond ((or (not repeat-count)
369             (and (fixnump repeat-count)
370                  (> repeat-count -1)))
371         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream)))
372        (t (format-error "Bad repeat-count."))))
373
374;Final version
375(defformat #\P format-p (stream colon atsign)
376  (when colon
377     (let ((end *format-arguments*) (list *format-original-arguments*))
378        (tagbody loop
379           (if list
380             (when (neq (cdr list) end)
381               (setq list (%cdr list))
382               (go loop))
383             (format-error "No previous argument")))
384        (setq *format-arguments* list)))
385   (%write-string (if (eq (pop-format-arg) 1)
386                    (if atsign "y" "")
387                    (if atsign "ies" "s"))
388                  stream))
389
390;Final version
391(defformat #\* format-* (stream colon atsign &optional count)
392  (declare (ignore stream)(special *circularity-hash-table*))
393  (let* ((orig *format-original-arguments*)
394         (where (- (list-length orig)   ; will error if args circular
395                   (list-length *format-arguments*)))
396         (to (if atsign 
397               (progn
398                 (format-no-flags colon nil)
399                 (or count 0)) ; absolute
400               (progn
401                 (when (null count)(setq count 1))
402                 (when colon (setq count (- count)))
403                 (%i+ where count))))
404         (args (nthcdr-no-overflow to orig)))
405    ; avoid bogus circularity indication
406    (when (and nil (consp args) (<= to where) *circularity-hash-table*)
407      ; copy only from to thru where in case  some real shared structure
408      (let ((l args) new)
409        (dotimes (i (1+  (- where to)))
410          (declare (fixnum i))
411          (push (car l) new)
412          (setq l (cdr l)))
413        (setq args (nreconc new (nthcdr (1+ where) orig))))) ;(copy-list args)))
414    (setq *format-arguments* args)))
415
416; Redefined later.
417(defformat #\Newline format-newline (&rest ignore)
418  (declare (ignore ignore))
419  (do* ((i *format-index* (1+ i))
420        (s *format-control-string*)
421        (n *format-length*))
422       ((or (= i n)
423            (not (whitespacep (schar s i))))
424        (setq *format-index* (1- i)))))
425
426(defun nthcdr-no-overflow (count list)
427  (if (or (> count (list-length list)) (< count 0))
428    (format-error "non-existent target for ~*")
429    (nthcdr count list)))
430
431;Redefined later
432(defformat #\X format-x (stream colon atsign)
433  (declare (ignore colon atsign))
434  (let* ((*print-base* 16.)
435         (*print-radix* nil))
436    (prin1 (pop-format-arg) stream)))
437
438;Redefined later
439(defformat #\D format-d (stream colon atsign &rest ignore)
440  (declare (ignore colon atsign ignore))
441  (let* ((*print-base* 10.)
442         (*print-radix* nil))
443    (prin1 (pop-format-arg) stream)))
Note: See TracBrowser for help on using the repository browser.