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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • 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 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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.