source: branches/working-0711-perf/ccl/level-1/l1-format.lisp @ 9486

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

Propagate r9464 to here so doesn't get lost in back-merge

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.8 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(defun format (stream control-string &rest format-arguments)
295  (declare (dynamic-extent format-arguments))
296  (when (null stream)
297   (return-from format 
298    (with-output-to-string (x)
299     (apply #'format x control-string format-arguments))))
300  (if (eq stream t)
301    (setq stream *standard-output*)
302    (unless (streamp stream) (report-bad-arg stream 'stream)))
303  (if (functionp control-string)
304    (apply control-string stream format-arguments)
305    (progn
306      (setq control-string (ensure-simple-string control-string))
307      (let* ((*format-original-arguments* format-arguments)
308             (*format-arguments* format-arguments)
309             (*format-control-string* control-string))
310        (catch 'format-escape
311         (sub-format stream 0 (length control-string)))
312        nil))))
313
314(defun format-error (&rest args)
315   (format t "~&FORMAT error at position ~A in control string ~S "
316             *format-index* *format-control-string*)
317   (apply #'error args))
318
319(defun format-no-flags (colon atsign)
320  (when (or colon atsign) (format-error "Flags not allowed")))
321
322;Redefined later
323(defformat #\A format-a (stream colon atsign)
324   (declare (ignore colon atsign))
325   (princ (pop-format-arg) stream))
326
327;Redefined later
328(defformat #\S format-s (stream colon atsign)
329  (declare (ignore colon atsign))
330  (prin1 (pop-format-arg) stream))
331
332;Redefined later
333(defformat #\^ format-escape (stream colon atsign)
334  (declare (ignore stream colon atsign))
335  (throw 'format-escape t))
336
337;Final version
338(defformat #\% format-% (stream colon atsign &optional repeat-count)
339  (cond ((or (not repeat-count)
340            (and repeat-count (fixnump repeat-count)
341                 (> repeat-count -1)))
342         (format-no-flags colon atsign)
343         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream)))
344        (t (format-error "Bad repeat-count."))))
345
346;Final version
347(defformat #\& format-& (stream colon atsign &optional repeat-count)
348  (format-no-flags colon atsign)
349  (unless (eq repeat-count 0)
350    (fresh-line stream)
351    (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream))))
352
353;Final version
354(defformat #\~ format-~ (stream colon atsign &optional repeat-count)
355  (format-no-flags colon atsign)
356  (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream)))
357
358;Final version
359(defformat #\P format-p (stream colon atsign)
360  (when colon
361     (let ((end *format-arguments*) (list *format-original-arguments*))
362        (tagbody loop
363           (if list
364             (when (neq (cdr list) end)
365               (setq list (%cdr list))
366               (go loop))
367             (format-error "No previous argument")))
368        (setq *format-arguments* list)))
369   (%write-string (if (eq (pop-format-arg) 1)
370                    (if atsign "y" "")
371                    (if atsign "ies" "s"))
372                  stream))
373
374;Final version
375(defformat #\* format-* (stream colon atsign &optional count)
376  (declare (ignore stream)(special *circularity-hash-table*))
377  (let* ((orig *format-original-arguments*)
378         (where (- (list-length orig)   ; will error if args circular
379                   (list-length *format-arguments*)))
380         (to (if atsign 
381               (or count 0) ; absolute
382               (progn
383                 (when (null count)(setq count 1))
384                 (when colon (setq count (- count)))
385                 (%i+ where count))))
386         (args (nthcdr-no-overflow to orig)))
387    ; avoid bogus circularity indication
388    (when (and nil (consp args) (<= to where) *circularity-hash-table*)
389      ; copy only from to thru where in case  some real shared structure
390      (let ((l args) new)
391        (dotimes (i (1+  (- where to)))
392          (declare (fixnum i))
393          (push (car l) new)
394          (setq l (cdr l)))
395        (setq args (nreconc new (nthcdr (1+ where) orig))))) ;(copy-list args)))
396    (setq *format-arguments* args)))
397
398; Redefined later.
399(defformat #\Newline format-newline (&rest ignore)
400  (declare (ignore ignore))
401  (do* ((i *format-index* (1+ i))
402        (s *format-control-string*)
403        (n *format-length*))
404       ((or (= i n)
405            (not (whitespacep (schar s i))))
406        (setq *format-index* (1- i)))))
407       
408(defun nthcdr-no-overflow (count list)
409  "If cdr beyond end of list return :error" 
410  (if (or (> count (list-length list)) (< count 0))
411    nil ;:error
412    (nthcdr count list)))
413
414;Redefined later
415(defformat #\X format-x (stream colon atsign)
416  (declare (ignore colon atsign))
417  (let* ((*print-base* 16.)
418         (*print-radix* nil))
419    (prin1 (pop-format-arg) stream)))
420
421;Redefined later
422(defformat #\D format-d (stream colon atsign &rest ignore)
423  (declare (ignore colon atsign ignore))
424  (let* ((*print-base* 10.)
425         (*print-radix* nil))
426    (prin1 (pop-format-arg) stream)))
Note: See TracBrowser for help on using the repository browser.