(dotimes (i (- exp))
(write-char #\0 stream))
(let ((start (max 0 (min length exp))))
- (write-string string stream
- :start start))))
+ (write-string string stream
+ :start start))))
(let* ((string (get-output-stream-string stream))
(length (length string))
(position (position #\. string)))
(defun scale-exponent (original-x)
(let* ((x (coerce original-x 'long-float)))
(multiple-value-bind (sig exponent)
- (decode-float x)
+ (decode-float x)
(declare (ignore sig))
(if (= x 0.0l0)
(values (float 0.0l0 original-x) 1)
(values (float z original-x) ex))))))))))
\f
(defstruct (format-directive
- #-ecl(:print-function %print-format-directive)
- #+ecl :named
- #+ecl(:type vector))
+ #-ecl(:print-function %print-format-directive)
+ #+ecl :named
+ #+ecl(:type vector))
(string t :type simple-string)
(start 0 :type (and unsigned-byte fixnum))
(end 0 :type (and unsigned-byte fixnum))
(end (length string))
(result nil))
(loop
- (let ((next-directive (or (position #\~ string :start index) end)))
- (when (> next-directive index)
- (push (subseq string index next-directive) result))
- (when (= next-directive end)
- (return))
- (let ((directive (parse-directive string next-directive)))
- (push directive result)
- (setf index (format-directive-end directive)))))
+ (let ((next-directive (or (position #\~ string :start index) end)))
+ (when (> next-directive index)
+ (push (subseq string index next-directive) result))
+ (when (= next-directive end)
+ (return))
+ (let ((directive (parse-directive string next-directive)))
+ (push directive result)
+ (setf index (format-directive-end directive)))))
(nreverse result)))
(defun parse-directive (string start)
:offset start)
(schar string posn))))
(loop
- (let ((char (get-char)))
- (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
- (multiple-value-bind
- (param new-posn)
- (parse-integer string :start posn :junk-allowed t)
- (push (cons posn param) params)
- (setf posn new-posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return)))))
- ((or (char= char #\v) (char= char #\V))
- (push (cons posn :arg) params)
- (incf posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return))))
- ((char= char #\#)
- (push (cons posn :remaining) params)
- (incf posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return))))
- ((char= char #\')
- (incf posn)
- (push (cons posn (get-char)) params)
- (incf posn)
- (case (get-char)
- (#\,)
- ((#\: #\@)
- (decf posn))
- (t
- (return))))
- ((char= char #\,)
- (push (cons posn nil) params))
- ((char= char #\:)
- (if colonp
- (error 'format-error
- :complaint "Too many colons supplied."
- :control-string string
- :offset posn)
- (setf colonp t)))
- ((char= char #\@)
- (if atsignp
- (error 'format-error
- :complaint "Too many at-signs supplied."
- :control-string string
- :offset posn)
- (setf atsignp t)))
- (t
- (when (char= (schar string (1- posn)) #\,)
- (push (cons (1- posn) nil) params))
- (return))))
- (incf posn))
+ (let ((char (get-char)))
+ (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
+ (multiple-value-bind
+ (param new-posn)
+ (parse-integer string :start posn :junk-allowed t)
+ (push (cons posn param) params)
+ (setf posn new-posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return)))))
+ ((or (char= char #\v) (char= char #\V))
+ (push (cons posn :arg) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\#)
+ (push (cons posn :remaining) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\')
+ (incf posn)
+ (push (cons posn (get-char)) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\,)
+ (push (cons posn nil) params))
+ ((char= char #\:)
+ (if colonp
+ (error 'format-error
+ :complaint "Too many colons supplied."
+ :control-string string
+ :offset posn)
+ (setf colonp t)))
+ ((char= char #\@)
+ (if atsignp
+ (error 'format-error
+ :complaint "Too many at-signs supplied."
+ :control-string string
+ :offset posn)
+ (setf atsignp t)))
+ (t
+ (when (char= (schar string (1- posn)) #\,)
+ (push (cons (1- posn) nil) params))
+ (return))))
+ (incf posn))
(let ((char (get-char)))
(when (char= char #\/)
(let ((closing-slash (position #\/ string :start (1+ posn))))
:control-string string
:offset posn))))
(make-format-directive
- :string string :start start :end (1+ posn)
- :character (char-upcase char)
- :colonp colonp :atsignp atsignp
- :params (nreverse params))))))
+ :string string :start start :end (1+ posn)
+ :character (char-upcase char)
+ :colonp colonp :atsignp atsignp
+ :params (nreverse params))))))
\f
;;;; Specials used to communicate information.
(write-string directive stream)
(interpret-directive-list stream (cdr directives) orig-args args))
(#-ecl format-directive #+ecl vector
- (multiple-value-bind
- (new-directives new-args)
- (let ((function
- (svref *format-directive-interpreters*
- (char-code (format-directive-character
- directive))))
- (*default-format-error-offset*
- (1- (format-directive-end directive))))
- (unless function
- (error 'format-error
- :complaint "Unknown format directive."))
(multiple-value-bind
- (new-directives new-args)
- (funcall function stream directive
- (cdr directives) orig-args args)
- (values new-directives new-args)))
- (interpret-directive-list stream new-directives
- orig-args new-args)))))
+ (new-directives new-args)
+ (let ((function
+ (svref *format-directive-interpreters*
+ (char-code (format-directive-character
+ directive))))
+ (*default-format-error-offset*
+ (1- (format-directive-end directive))))
+ (unless function
+ (error 'format-error
+ :complaint "Unknown format directive."))
+ (multiple-value-bind
+ (new-directives new-args)
+ (funcall function stream directive
+ (cdr directives) orig-args args)
+ (values new-directives new-args)))
+ (interpret-directive-list stream new-directives
+ orig-args new-args)))))
args))
\f
#+formatter
(progn
-(defmacro formatter (control-string)
- `#',(%formatter control-string))
-
-(defun %formatter (control-string)
- (declare (si::c-local))
- (block nil
- (catch 'need-orig-args
- (let* ((*simple-args* nil)
- (*only-simple-args* t)
- (guts (expand-control-string control-string))
- (args nil))
- (dolist (arg *simple-args*)
- (push `(,(car arg)
- (error
- 'format-error
- :complaint "Required argument missing"
- :control-string ,control-string
- :offset ,(cdr arg)))
- args))
- (return `(lambda (stream &optional ,@args &rest args)
- ,guts
- args))))
- (let ((*orig-args-available* t)
- (*only-simple-args* nil))
- `(lambda (stream &rest orig-args)
- (let ((args orig-args))
- ,(expand-control-string control-string)
- args)))))
-
-(defun expand-control-string (string)
- (declare (si::c-local))
- (let* ((string (etypecase string
- (simple-string
- string)
- (string
- (coerce string 'simple-string))))
- (*output-layout-mode* nil)
- (*default-format-error-control-string* string)
- (directives (tokenize-control-string string)))
- `(block nil
- ,@(expand-directive-list directives))))
-
-(defun expand-directive-list (directives)
- (declare (si::c-local))
- (let ((results nil)
- (remaining-directives directives))
- (loop
- (unless remaining-directives
- (return))
- (multiple-value-bind
- (form new-directives)
- (expand-directive (car remaining-directives)
- (cdr remaining-directives))
- (push form results)
- (setf remaining-directives new-directives)))
- (reverse results)))
-
-(defun expand-directive (directive more-directives)
- (declare (si::c-local))
- (etypecase directive
- (simple-string
- (values `(write-string ,directive stream)
- more-directives))
- (format-directive
- (let ((expander
- (aref *format-directive-expanders*
- (char-code (format-directive-character directive))))
- (*default-format-error-offset*
- (1- (format-directive-end directive))))
- (if expander
- (funcall expander directive more-directives)
- (error 'format-error
- :complaint "Unknown directive."))))))
-
-(defun expand-next-arg (&optional offset)
- (declare (si::c-local))
- (if (or *orig-args-available* (not *only-simple-args*))
- `(,*expander-next-arg-macro*
- ,*default-format-error-control-string*
- ,(or offset *default-format-error-offset*))
- (let ((symbol (gensym "FORMAT-ARG-")))
- (push (cons symbol (or offset *default-format-error-offset*))
- *simple-args*)
- symbol)))
-
-(defun need-hairy-args ()
- (declare (si::c-local))
- (when *only-simple-args*
- ))
-
-\f
+ (defmacro formatter (control-string)
+ `#',(%formatter control-string))
+
+ (defun %formatter (control-string)
+ (declare (si::c-local))
+ (block nil
+ (catch 'need-orig-args
+ (let* ((*simple-args* nil)
+ (*only-simple-args* t)
+ (guts (expand-control-string control-string))
+ (args nil))
+ (dolist (arg *simple-args*)
+ (push `(,(car arg)
+ (error
+ 'format-error
+ :complaint "Required argument missing"
+ :control-string ,control-string
+ :offset ,(cdr arg)))
+ args))
+ (return `(lambda (stream &optional ,@args &rest args)
+ ,guts
+ args))))
+ (let ((*orig-args-available* t)
+ (*only-simple-args* nil))
+ `(lambda (stream &rest orig-args)
+ (let ((args orig-args))
+ ,(expand-control-string control-string)
+ args)))))
+
+ (defun expand-control-string (string)
+ (declare (si::c-local))
+ (let* ((string (etypecase string
+ (simple-string
+ string)
+ (string
+ (coerce string 'simple-string))))
+ (*output-layout-mode* nil)
+ (*default-format-error-control-string* string)
+ (directives (tokenize-control-string string)))
+ `(block nil
+ ,@(expand-directive-list directives))))
+
+ (defun expand-directive-list (directives)
+ (declare (si::c-local))
+ (let ((results nil)
+ (remaining-directives directives))
+ (loop
+ (unless remaining-directives
+ (return))
+ (multiple-value-bind
+ (form new-directives)
+ (expand-directive (car remaining-directives)
+ (cdr remaining-directives))
+ (push form results)
+ (setf remaining-directives new-directives)))
+ (reverse results)))
+
+ (defun expand-directive (directive more-directives)
+ (declare (si::c-local))
+ (etypecase directive
+ (simple-string
+ (values `(write-string ,directive stream)
+ more-directives))
+ (format-directive
+ (let ((expander
+ (aref *format-directive-expanders*
+ (char-code (format-directive-character directive))))
+ (*default-format-error-offset*
+ (1- (format-directive-end directive))))
+ (if expander
+ (funcall expander directive more-directives)
+ (error 'format-error
+ :complaint "Unknown directive."))))))
+
+ (defun expand-next-arg (&optional offset)
+ (declare (si::c-local))
+ (if (or *orig-args-available* (not *only-simple-args*))
+ `(,*expander-next-arg-macro*
+ ,*default-format-error-control-string*
+ ,(or offset *default-format-error-offset*))
+ (let ((symbol (gensym "FORMAT-ARG-")))
+ (push (cons symbol (or offset *default-format-error-offset*))
+ *simple-args*)
+ symbol)))
+
+ (defun need-hairy-args ()
+ (declare (si::c-local))
+ (when *only-simple-args*
+ ))
+
+ \f
;;;; Format directive definition macros and runtime support.
-(defmacro expander-next-arg (string offset)
- `(if args
- (pop args)
- (error 'format-error
- :complaint "No more arguments."
- :control-string ,string
- :offset ,offset)))
-
-(defmacro expander-pprint-next-arg (string offset)
- `(progn
- (when (null args)
- (error 'format-error
- :complaint "No more arguments."
- :control-string ,string
- :offset ,offset))
- (pprint-pop)
- (pop args)))
-);#+formatter
+ (defmacro expander-next-arg (string offset)
+ `(if args
+ (pop args)
+ (error 'format-error
+ :complaint "No more arguments."
+ :control-string ,string
+ :offset ,offset)))
+
+ (defmacro expander-pprint-next-arg (string offset)
+ `(progn
+ (when (null args)
+ (error 'format-error
+ :complaint "No more arguments."
+ :control-string ,string
+ :offset ,offset))
+ (pprint-pop)
+ (pop args)))
+ );#+formatter
(eval-when (:compile-toplevel :execute)
;;; This macro is used to extract the next argument from the current arg list.
;;; This is the version used by format directive interpreters.
;;;
-(defmacro next-arg (&optional offset)
- `(progn
- (when (null args)
- (error 'format-error
- :complaint "No more arguments."
- ,@(when offset
- `(:offset ,offset))))
- (when *logical-block-popper*
- (funcall *logical-block-popper*))
- (pop args)))
-
-(defmacro def-complex-format-directive (char lambda-list &body body)
- #+formatter
- (let* ((name (or (char-name char) (string char)))
- (defun-name (intern (concatenate 'string name "-FORMAT-DIRECTIVE-EXPANDER")))
- (directive (gensym))
- (directives (if lambda-list (car (last lambda-list)) (gensym))))
- `(%set-format-directive-expander ,char
- (ext::lambda-block ,defun-name (,directive ,directives)
- ,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
- (butlast lambda-list))
- ,@body))
- `((declare (ignore ,directive ,directives))
- ,@body))))))
-
-(defmacro def-format-directive (char lambda-list &body body)
- #+formatter
- (let ((directives (gensym))
- (declarations nil)
- (body-without-decls body))
- (loop
- (let ((form (car body-without-decls)))
- (unless (and (consp form) (eq (car form) 'declare))
- (return))
- (push (pop body-without-decls) declarations)))
- (setf declarations (reverse declarations))
- `(def-complex-format-directive ,char (,@lambda-list ,directives)
- ,@declarations
- (values (progn ,@body-without-decls)
- ,directives))))
-
-(defmacro expand-bind-defaults (specs params &body body)
- (once-only ((params params))
- (if specs
- (collect ((expander-bindings) (runtime-bindings))
- (dolist (spec specs)
- (destructuring-bind (var default) spec
- (let ((symbol (gensym)))
- (expander-bindings
- `(,var ',symbol))
- (runtime-bindings
- `(list ',symbol
- (let* ((param-and-offset (pop ,params))
- (offset (car param-and-offset))
- (param (cdr param-and-offset)))
- (case param
- (:arg `(or ,(expand-next-arg offset)
- ,,default))
- (:remaining
- (setf *only-simple-args* nil)
- '(length args))
- ((nil) ,default)
- (t param))))))))
- `(let ,(expander-bindings)
- `(let ,(list ,@(runtime-bindings))
- ,@(if ,params
+ (defmacro next-arg (&optional offset)
+ `(progn
+ (when (null args)
+ (error 'format-error
+ :complaint "No more arguments."
+ ,@(when offset
+ `(:offset ,offset))))
+ (when *logical-block-popper*
+ (funcall *logical-block-popper*))
+ (pop args)))
+
+ (defmacro def-complex-format-directive (char lambda-list &body body)
+ #+formatter
+ (let* ((name (or (char-name char) (string char)))
+ (defun-name (intern (concatenate 'string name "-FORMAT-DIRECTIVE-EXPANDER")))
+ (directive (gensym))
+ (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ `(%set-format-directive-expander ,char
+ (ext::lambda-block ,defun-name (,directive ,directives)
+ ,@(if lambda-list
+ `((let ,(mapcar #'(lambda (var)
+ `(,var
+ (,(intern (concatenate
+ 'string
+ "FORMAT-DIRECTIVE-"
+ (symbol-name var))
+ (symbol-package 'foo))
+ ,directive)))
+ (butlast lambda-list))
+ ,@body))
+ `((declare (ignore ,directive ,directives))
+ ,@body))))))
+
+ (defmacro def-format-directive (char lambda-list &body body)
+ #+formatter
+ (let ((directives (gensym))
+ (declarations nil)
+ (body-without-decls body))
+ (loop
+ (let ((form (car body-without-decls)))
+ (unless (and (consp form) (eq (car form) 'declare))
+ (return))
+ (push (pop body-without-decls) declarations)))
+ (setf declarations (reverse declarations))
+ `(def-complex-format-directive ,char (,@lambda-list ,directives)
+ ,@declarations
+ (values (progn ,@body-without-decls)
+ ,directives))))
+
+ (defmacro expand-bind-defaults (specs params &body body)
+ (once-only ((params params))
+ (if specs
+ (collect ((expander-bindings) (runtime-bindings))
+ (dolist (spec specs)
+ (destructuring-bind (var default) spec
+ (let ((symbol (gensym)))
+ (expander-bindings
+ `(,var ',symbol))
+ (runtime-bindings
+ `(list ',symbol
+ (let* ((param-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg `(or ,(expand-next-arg offset)
+ ,,default))
+ (:remaining
+ (setf *only-simple-args* nil)
+ '(length args))
+ ((nil) ,default)
+ (t param))))))))
+ `(let ,(expander-bindings)
+ `(let ,(list ,@(runtime-bindings))
+ ,@(if ,params
+ (error 'format-error
+ :complaint
+ "Too many parameters, expected no more than ~D"
+ :arguments (list ,(length specs))
+ :offset (caar ,params)))
+ ,,@body)))
+ `(progn
+ (when ,params
+ (error 'format-error
+ :complaint "Too many parameters, expected no more than 0"
+ :offset (caar ,params)))
+ ,@body))))
+
+ (defmacro def-complex-format-interpreter (char lambda-list &body body)
+ (let ((directive (gensym))
+ (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ `(%set-format-directive-interpreter ,char
+ (lambda (stream ,directive ,directives orig-args args)
+ (declare (ignorable stream orig-args args))
+ ,@(if lambda-list
+ `((let ,(mapcar #'(lambda (var)
+ `(,var
+ (,(intern (concatenate
+ 'string
+ "FORMAT-DIRECTIVE-"
+ (symbol-name var))
+ (symbol-package 'foo))
+ ,directive)))
+ (butlast lambda-list))
+ (values (progn ,@body) args)))
+ `((declare (ignore ,directive ,directives))
+ ,@body))))))
+
+ (defmacro def-format-interpreter (char lambda-list &body body)
+ (let ((directives (gensym)))
+ `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
+ ,@body
+ ,directives)))
+
+ (defmacro interpret-bind-defaults (specs params &body body)
+ (once-only ((params params))
+ (collect ((bindings))
+ (dolist (spec specs)
+ (destructuring-bind (var default) spec
+ (bindings `(,var (let* ((param-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg (or (next-arg offset) ,default))
+ (:remaining (length args))
+ ((nil) ,default)
+ (t param)))))))
+ `(let* ,(bindings)
+ (when ,params
(error 'format-error
:complaint
- "Too many parameters, expected no more than ~D"
+ "Too many parameters, expected no more than ~D"
:arguments (list ,(length specs))
:offset (caar ,params)))
- ,,@body)))
- `(progn
- (when ,params
- (error 'format-error
- :complaint "Too many parameters, expected no more than 0"
- :offset (caar ,params)))
- ,@body))))
-
-(defmacro def-complex-format-interpreter (char lambda-list &body body)
- (let ((directive (gensym))
- (directives (if lambda-list (car (last lambda-list)) (gensym))))
- `(%set-format-directive-interpreter ,char
- (lambda (stream ,directive ,directives orig-args args)
- (declare (ignorable stream orig-args args))
- ,@(if lambda-list
- `((let ,(mapcar #'(lambda (var)
- `(,var
- (,(intern (concatenate
- 'string
- "FORMAT-DIRECTIVE-"
- (symbol-name var))
- (symbol-package 'foo))
- ,directive)))
- (butlast lambda-list))
- (values (progn ,@body) args)))
- `((declare (ignore ,directive ,directives))
- ,@body))))))
-
-(defmacro def-format-interpreter (char lambda-list &body body)
- (let ((directives (gensym)))
- `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
- ,@body
- ,directives)))
-
-(defmacro interpret-bind-defaults (specs params &body body)
- (once-only ((params params))
- (collect ((bindings))
- (dolist (spec specs)
- (destructuring-bind (var default) spec
- (bindings `(,var (let* ((param-and-offset (pop ,params))
- (offset (car param-and-offset))
- (param (cdr param-and-offset)))
- (case param
- (:arg (or (next-arg offset) ,default))
- (:remaining (length args))
- ((nil) ,default)
- (t param)))))))
- `(let* ,(bindings)
- (when ,params
- (error 'format-error
- :complaint
- "Too many parameters, expected no more than ~D"
- :arguments (list ,(length specs))
- :offset (caar ,params)))
- ,@body))))
+ ,@body))))
-); eval-when
+ ); eval-when
#+formatter
(defun %set-format-directive-expander (char fn)
(if params
(expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
(padchar #\space))
- params
- `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
- ,mincol ,colinc ,minpad ,padchar))
+ params
+ `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
+ ,mincol ,colinc ,minpad ,padchar))
`(princ ,(if colonp
`(or ,(expand-next-arg) "()")
(expand-next-arg))
(if params
(interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
(padchar #\space))
- params
- (format-princ stream (next-arg) colonp atsignp
- mincol colinc minpad padchar))
+ params
+ (format-princ stream (next-arg) colonp atsignp
+ mincol colinc minpad padchar))
(princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
(cond (params
(expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
(padchar #\space))
- params
- `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
- ,mincol ,colinc ,minpad ,padchar)))
+ params
+ `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
+ ,mincol ,colinc ,minpad ,padchar)))
(colonp
`(let ((arg ,(expand-next-arg)))
(if arg
(cond (params
(interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
(padchar #\space))
- params
- (format-prin1 stream (next-arg) colonp atsignp
- mincol colinc minpad padchar)))
+ params
+ (format-prin1 stream (next-arg) colonp atsignp
+ mincol colinc minpad padchar)))
(colonp
(let ((arg (next-arg)))
(if arg
(def-format-directive #\C (colonp atsignp params)
(expand-bind-defaults () params
- (if colonp
- `(format-print-named-character ,(expand-next-arg) stream)
- (if atsignp
- `(prin1 ,(expand-next-arg) stream)
- `(write-char ,(expand-next-arg) stream)))))
+ (if colonp
+ `(format-print-named-character ,(expand-next-arg) stream)
+ (if atsignp
+ `(prin1 ,(expand-next-arg) stream)
+ `(write-char ,(expand-next-arg) stream)))))
(def-format-interpreter #\C (colonp atsignp params)
(interpret-bind-defaults () params
- (if colonp
- (format-print-named-character (next-arg) stream)
- (if atsignp
- (prin1 (next-arg) stream)
- (write-char (next-arg) stream)))))
+ (if colonp
+ (format-print-named-character (next-arg) stream)
+ (if atsignp
+ (prin1 (next-arg) stream)
+ (write-char (next-arg) stream)))))
;;; "printing" as defined in the ANSI CL glossary, which is normative.
(defun char-printing-p (char)
(def-format-directive #\W (colonp atsignp params)
(check-output-layout-mode 1)
(expand-bind-defaults () params
- (if (or colonp atsignp)
- `(let (,@(when colonp
- '((*print-pretty* t)))
- ,@(when atsignp
- '((*print-level* nil)
- (*print-length* nil))))
- (write-object ,(expand-next-arg) stream))
- `(write-object ,(expand-next-arg) stream))))
+ (if (or colonp atsignp)
+ `(let (,@(when colonp
+ '((*print-pretty* t)))
+ ,@(when atsignp
+ '((*print-level* nil)
+ (*print-length* nil))))
+ (write-object ,(expand-next-arg) stream))
+ `(write-object ,(expand-next-arg) stream))))
(def-format-interpreter #\W (colonp atsignp params)
(check-output-layout-mode 1)
(interpret-bind-defaults () params
- (let ((*print-pretty* (or colonp *print-pretty*))
- (*print-level* (and atsignp *print-level*))
- (*print-length* (and atsignp *print-length*)))
- (write-object (next-arg) stream))))
+ (let ((*print-pretty* (or colonp *print-pretty*))
+ (*print-level* (and atsignp *print-level*))
+ (*print-length* (and atsignp *print-length*)))
+ (write-object (next-arg) stream))))
\f
;;;; Integer outputting.
(declare (si::c-local))
(let ((length (length string)))
(multiple-value-bind (commas extra)
- (truncate (1- length) commainterval)
+ (truncate (1- length) commainterval)
(let ((new-string (make-string (+ length commas)))
(first-comma (1+ extra)))
(replace new-string string :end1 first-comma :end2 first-comma)
(defun expand-format-integer (base colonp atsignp params)
(if (or colonp atsignp params)
(expand-bind-defaults
- ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
- params
- `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
- ,base ,mincol ,padchar ,commachar
- ,commainterval))
+ ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
+ params
+ `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
+ ,base ,mincol ,padchar ,commachar
+ ,commainterval))
`(write ,(expand-next-arg) :stream stream :base ,base :radix nil
:escape nil)))
(eval-when (:compile-toplevel :execute)
-(defmacro interpret-format-integer (base)
- `(if (or colonp atsignp params)
- (interpret-bind-defaults
- ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
- params
- (format-print-integer stream (next-arg) colonp atsignp ,base mincol
- padchar commachar commainterval))
- (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
-)
+ (defmacro interpret-format-integer (base)
+ `(if (or colonp atsignp params)
+ (interpret-bind-defaults
+ ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
+ params
+ (format-print-integer stream (next-arg) colonp atsignp ,base mincol
+ padchar commachar commainterval))
+ (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
+ )
(def-format-directive #\D (colonp atsignp params)
(expand-format-integer 10 colonp atsignp params))
(def-format-directive #\R (colonp atsignp params)
(expand-bind-defaults
- ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
- (commainterval 3))
- params
- (let ((n-arg (gensym)))
- `(let ((,n-arg ,(expand-next-arg)))
- (if ,base
- (format-print-integer stream ,n-arg ,colonp ,atsignp
- ,base ,mincol
- ,padchar ,commachar ,commainterval)
- ,(if atsignp
- (if colonp
- `(format-print-old-roman stream ,n-arg)
- `(format-print-roman stream ,n-arg))
- (if colonp
- `(format-print-ordinal stream ,n-arg)
- `(format-print-cardinal stream ,n-arg))))))))
+ ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+ (commainterval 3))
+ params
+ (let ((n-arg (gensym)))
+ `(let ((,n-arg ,(expand-next-arg)))
+ (if ,base
+ (format-print-integer stream ,n-arg ,colonp ,atsignp
+ ,base ,mincol
+ ,padchar ,commachar ,commainterval)
+ ,(if atsignp
+ (if colonp
+ `(format-print-old-roman stream ,n-arg)
+ `(format-print-roman stream ,n-arg))
+ (if colonp
+ `(format-print-ordinal stream ,n-arg)
+ `(format-print-cardinal stream ,n-arg))))))))
(def-format-interpreter #\R (colonp atsignp params)
(interpret-bind-defaults
- ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
- (commainterval 3))
- params
- (if base
+ ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+ (commainterval 3))
+ params
+ (if base
(format-print-integer stream (next-arg) colonp atsignp base mincol
padchar commachar commainterval)
(if atsignp
(defconstant cardinal-tens
#(nil nil "twenty" "thirty" "forty"
- "fifty" "sixty" "seventy" "eighty" "ninety"))
+ "fifty" "sixty" "seventy" "eighty" "ninety"))
(defconstant cardinal-teens
#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
(defconstant ordinal-ones
#(nil "first" "second" "third" "fourth"
- "fifth" "sixth" "seventh" "eighth" "ninth")
+ "fifth" "sixth" "seventh" "eighth" "ninth")
"Table of ordinal ones-place digits in English")
(defconstant ordinal-tens
#(nil "tenth" "twentieth" "thirtieth" "fortieth"
- "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
+ "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
"Table of ordinal tens-place digits in English")
(defun format-print-small-cardinal (stream n)
(declare (si::c-local))
(multiple-value-bind
- (hundreds rem) (truncate n 100)
+ (hundreds rem) (truncate n 100)
(when (plusp hundreds)
(write-string (svref cardinal-ones hundreds) stream)
(write-string " hundred" stream)
(write-char #\space stream)))
(when (plusp rem)
(multiple-value-bind (tens ones)
- (truncate rem 10)
- (cond ((< 1 tens)
- (write-string (svref cardinal-tens tens) stream)
- (when (plusp ones)
- (write-char #\- stream)
- (write-string (svref cardinal-ones ones) stream)))
- ((= tens 1)
- (write-string (svref cardinal-teens ones) stream))
- ((plusp ones)
- (write-string (svref cardinal-ones ones) stream)))))))
+ (truncate rem 10)
+ (cond ((< 1 tens)
+ (write-string (svref cardinal-tens tens) stream)
+ (when (plusp ones)
+ (write-char #\- stream)
+ (write-string (svref cardinal-ones ones) stream)))
+ ((= tens 1)
+ (write-string (svref cardinal-teens ones) stream))
+ ((plusp ones)
+ (write-string (svref cardinal-ones ones) stream)))))))
(defun format-print-cardinal (stream n)
#-formatter
(write-string "negative " stream))
(let ((number (abs n)))
(multiple-value-bind
- (top bot) (truncate number 100)
+ (top bot) (truncate number 100)
(unless (zerop top)
(format-print-cardinal stream (- number bot)))
(when (and (plusp top) (plusp bot))
(write-char #\space stream))
(multiple-value-bind
- (tens ones) (truncate bot 10)
+ (tens ones) (truncate bot 10)
(cond ((= bot 12) (write-string "twelfth" stream))
((= tens 1)
(write-string (svref cardinal-teens ones) stream);;;RAD
(write-char cur-char stream)
(- i (- cur-val cur-sub-val)))
(t i))))))
- ((zerop start))))
+ ((zerop start))))
\f
;;;; Plural.
(def-format-directive #\P (colonp atsignp params end)
(expand-bind-defaults () params
- (let ((arg (cond
- ((not colonp)
- (expand-next-arg))
- (*orig-args-available*
- `(if (eq orig-args args)
- (error 'format-error
- :complaint "No previous argument."
- :offset ,(1- end))
- (do ((arg-ptr orig-args (cdr arg-ptr)))
- ((eq (cdr arg-ptr) args)
- (car arg-ptr)))))
- (*only-simple-args*
- (unless *simple-args*
- (error 'format-error
- :complaint "No previous argument."))
- (caar *simple-args*))
- (t
- (throw 'need-orig-args nil)))))
- (if atsignp
- `(write-string (if (eql ,arg 1) "y" "ies") stream)
- `(unless (eql ,arg 1) (write-char #\s stream))))))
+ (let ((arg (cond
+ ((not colonp)
+ (expand-next-arg))
+ (*orig-args-available*
+ `(if (eq orig-args args)
+ (error 'format-error
+ :complaint "No previous argument."
+ :offset ,(1- end))
+ (do ((arg-ptr orig-args (cdr arg-ptr)))
+ ((eq (cdr arg-ptr) args)
+ (car arg-ptr)))))
+ (*only-simple-args*
+ (unless *simple-args*
+ (error 'format-error
+ :complaint "No previous argument."))
+ (caar *simple-args*))
+ (t
+ (throw 'need-orig-args nil)))))
+ (if atsignp
+ `(write-string (if (eql ,arg 1) "y" "ies") stream)
+ `(unless (eql ,arg 1) (write-char #\s stream))))))
(def-format-interpreter #\P (colonp atsignp params)
(interpret-bind-defaults () params
- (let ((arg (if colonp
- (if (eq orig-args args)
- (error 'format-error
- :complaint "No previous argument.")
- (do ((arg-ptr orig-args (cdr arg-ptr)))
- ((eq (cdr arg-ptr) args)
- (car arg-ptr))))
- (next-arg))))
- (if atsignp
- (write-string (if (eql arg 1) "y" "ies") stream)
- (unless (eql arg 1) (write-char #\s stream))))))
+ (let ((arg (if colonp
+ (if (eq orig-args args)
+ (error 'format-error
+ :complaint "No previous argument.")
+ (do ((arg-ptr orig-args (cdr arg-ptr)))
+ ((eq (cdr arg-ptr) args)
+ (car arg-ptr))))
+ (next-arg))))
+ (if atsignp
+ (write-string (if (eql arg 1) "y" "ies") stream)
+ (unless (eql arg 1) (write-char #\s stream))))))
\f
;;;; Floating point noise.
:complaint
"Cannot specify the colon modifier with this directive."))
(expand-bind-defaults ((w nil) (d nil) (k 0) (ovf nil) (pad #\space)) params
- `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
+ `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
(def-format-interpreter #\F (colonp atsignp params)
(when colonp
"Cannot specify the colon modifier with this directive."))
(interpret-bind-defaults ((w nil) (d nil) (k 0) (ovf nil) (pad #\space))
params
- (format-fixed stream (next-arg) w d k ovf pad atsignp)))
+ (format-fixed stream (next-arg) w d k ovf pad atsignp)))
(defun format-fixed (stream number w d k ovf pad atsign)
#-formatter
(defun format-fixed-aux (stream number w d k ovf pad atsign)
(declare (si::c-local))
(cond
- ((or (not (or w d k))
- #-ecl
- (and (floatp number)
- (or (float-infinity-p number)
- (float-nan-p number))))
- (prin1 number stream)
- nil)
- (t
- (let ((spaceleft w))
- (when (and w (or atsign
- (minusp number)))
- (decf spaceleft))
- (multiple-value-bind (str len lpoint tpoint)
- (sys::flonum-to-string (abs number) spaceleft d k)
- ;; if caller specifically requested no fraction digits, suppress the
- ;; trailing zero
- (when (eql d 0)
- (setq tpoint nil))
- (when w
- (decf spaceleft len)
- ;; obligatory trailing zero (unless explicitly cut with ,d)
- (when tpoint
- (decf spaceleft))
- ;; optional leading zero
- (when lpoint
- (if (or (> spaceleft 0)
- (eql d 0))
- (decf spaceleft)
- (setq lpoint nil))))
- (cond ((and w (< spaceleft 0) ovf)
- ;;field width overflow
- (dotimes (i w)
- (write-char ovf stream))
- t)
- (t
- (when w (dotimes (i spaceleft) (write-char pad stream)))
- (if (minusp number)
- (write-char #\- stream)
- (if atsign (write-char #\+ stream)))
- (when lpoint (write-char #\0 stream))
- (write-string str stream)
- (when tpoint (write-char #\0 stream))
- nil)))))))
+ ((or (not (or w d k))
+ #-ecl
+ (and (floatp number)
+ (or (float-infinity-p number)
+ (float-nan-p number))))
+ (prin1 number stream)
+ nil)
+ (t
+ (let ((spaceleft w))
+ (when (and w (or atsign
+ (minusp number)))
+ (decf spaceleft))
+ (multiple-value-bind (str len lpoint tpoint)
+ (sys::flonum-to-string (abs number) spaceleft d k)
+ ;; if caller specifically requested no fraction digits, suppress the
+ ;; trailing zero
+ (when (eql d 0)
+ (setq tpoint nil))
+ (when w
+ (decf spaceleft len)
+ ;; obligatory trailing zero (unless explicitly cut with ,d)
+ (when tpoint
+ (decf spaceleft))
+ ;; optional leading zero
+ (when lpoint
+ (if (or (> spaceleft 0)
+ (eql d 0))
+ (decf spaceleft)
+ (setq lpoint nil))))
+ (cond ((and w (< spaceleft 0) ovf)
+ ;;field width overflow
+ (dotimes (i w)
+ (write-char ovf stream))
+ t)
+ (t
+ (when w (dotimes (i spaceleft) (write-char pad stream)))
+ (if (minusp number)
+ (write-char #\- stream)
+ (if atsign (write-char #\+ stream)))
+ (when lpoint (write-char #\0 stream))
+ (write-string str stream)
+ (when tpoint (write-char #\0 stream))
+ nil)))))))
(def-format-directive #\E (colonp atsignp params)
(when colonp
:complaint
"Cannot specify the colon modifier with this directive."))
(expand-bind-defaults
- ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
- params
- `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
- ,atsignp)))
+ ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
+ params
+ `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
+ ,atsignp)))
(def-format-interpreter #\E (colonp atsignp params)
(when colonp
:complaint
"Cannot specify the colon modifier with this directive."))
(interpret-bind-defaults
- ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
- params
- (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
+ ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
+ params
+ (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
(defun format-exponential (stream number w d e k ovf pad marker atsign)
#-formatter
:complaint
"Cannot specify the colon modifier with this directive."))
(expand-bind-defaults
- ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil))
- params
- `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
+ ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil))
+ params
+ `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
(def-format-interpreter #\G (colonp atsignp params)
(when colonp
:complaint
"Cannot specify the colon modifier with this directive."))
(interpret-bind-defaults
- ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil))
- params
- (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
+ ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil))
+ params
+ (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
(defun format-general (stream number w d e k ovf pad marker atsign)
#-formatter
(def-format-directive #\$ (colonp atsignp params)
(expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
- `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
- ,atsignp)))
+ `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
+ ,atsignp)))
(def-format-interpreter #\$ (colonp atsignp params)
(interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
- (format-dollars stream (next-arg) d n w pad colonp atsignp)))
+ (format-dollars stream (next-arg) d n w pad colonp atsignp)))
(defun format-dollars (stream number d n w pad colon atsign)
#-formatter
(let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
(signlen (length signstr)))
(multiple-value-bind (str strlen ig2 ig3 pointplace)
- (sys::flonum-to-string (abs number) nil d)
+ (sys::flonum-to-string (abs number) nil d)
(declare (ignore ig2 ig3))
(when colon (write-string signstr stream))
(dotimes (i (- w signlen (max 0 (- n pointplace)) strlen))
"Cannot specify either colon or atsign for this directive."))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (terpri stream)))
+ `(dotimes (i ,count)
+ (terpri stream)))
'(terpri stream)))
(def-format-interpreter #\% (colonp atsignp params)
:complaint
"Cannot specify either colon or atsign for this directive."))
(interpret-bind-defaults ((count 1)) params
- (dotimes (i count)
- (terpri stream))))
+ (dotimes (i count)
+ (terpri stream))))
(def-format-directive #\& (colonp atsignp params)
(when (or colonp atsignp)
"Cannot specify either colon or atsign for this directive."))
(if params
(expand-bind-defaults ((count 1)) params
- `(progn
- (fresh-line stream)
- (dotimes (i (1- ,count))
- (terpri stream))))
+ `(progn
+ (fresh-line stream)
+ (dotimes (i (1- ,count))
+ (terpri stream))))
'(fresh-line stream)))
(def-format-interpreter #\& (colonp atsignp params)
:complaint
"Cannot specify either colon or atsign for this directive."))
(interpret-bind-defaults ((count 1)) params
- (fresh-line stream)
- (dotimes (i (1- count))
- (terpri stream))))
+ (fresh-line stream)
+ (dotimes (i (1- count))
+ (terpri stream))))
(def-format-directive #\| (colonp atsignp params)
(when (or colonp atsignp)
"Cannot specify either colon or atsign for this directive."))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (write-char #\page stream)))
+ `(dotimes (i ,count)
+ (write-char #\page stream)))
'(write-char #\page stream)))
(def-format-interpreter #\| (colonp atsignp params)
:complaint
"Cannot specify either colon or atsign for this directive."))
(interpret-bind-defaults ((count 1)) params
- (dotimes (i count)
- (write-char #\page stream))))
+ (dotimes (i count)
+ (write-char #\page stream))))
(def-format-directive #\~ (colonp atsignp params)
(when (or colonp atsignp)
"Cannot specify either colon or atsign for this directive."))
(if params
(expand-bind-defaults ((count 1)) params
- `(dotimes (i ,count)
- (write-char #\~ stream)))
+ `(dotimes (i ,count)
+ (write-char #\~ stream)))
'(write-char #\~ stream)))
(def-format-interpreter #\~ (colonp atsignp params)
:complaint
"Cannot specify either colon or atsign for this directive."))
(interpret-bind-defaults ((count 1)) params
- (dotimes (i count)
- (write-char #\~ stream))))
+ (dotimes (i count)
+ (write-char #\~ stream))))
(def-complex-format-directive #\newline (colonp atsignp params directives)
(when (and colonp atsignp)
:complaint
"Cannot specify both colon and atsign for this directive."))
(values (expand-bind-defaults () params
- (if atsignp
- '(write-char #\newline stream)
- nil))
+ (if atsignp
+ '(write-char #\newline stream)
+ nil))
(if (and (not colonp)
directives
(simple-string-p (car directives)))
:complaint
"Cannot specify both colon and atsign for this directive."))
(interpret-bind-defaults () params
- (when atsignp
- (write-char #\newline stream)))
+ (when atsignp
+ (write-char #\newline stream)))
(if (and (not colonp)
directives
(simple-string-p (car directives)))
:complaint
"Cannot specify both colon and atsign for this directive."))
(values (expand-bind-defaults () params
- (if atsignp
- '(write-char #\newline stream)
- nil))
+ (if atsignp
+ '(write-char #\newline stream)
+ nil))
(if (and (not colonp)
directives
(simple-string-p (car directives)))
:complaint
"Cannot specify both colon and atsign for this directive."))
(interpret-bind-defaults () params
- (when atsignp
- (write-char #\newline stream)))
+ (when atsignp
+ (write-char #\newline stream)))
(if (and (not colonp)
directives
(simple-string-p (car directives)))
(check-output-layout-mode 1)
(if colonp
(expand-bind-defaults ((n 1) (m 1)) params
- `(pprint-tab ,(if atsignp :section-relative :section)
- ,n ,m stream))
+ `(pprint-tab ,(if atsignp :section-relative :section)
+ ,n ,m stream))
(if atsignp
(expand-bind-defaults ((colrel 1) (colinc 1)) params
- `(format-relative-tab stream ,colrel ,colinc))
+ `(format-relative-tab stream ,colrel ,colinc))
(expand-bind-defaults ((colnum 1) (colinc 1)) params
- `(format-absolute-tab stream ,colnum ,colinc)))))
+ `(format-absolute-tab stream ,colnum ,colinc)))))
(def-format-interpreter #\T (colonp atsignp params)
(check-output-layout-mode 1)
(if colonp
(interpret-bind-defaults ((n 1) (m 1)) params
- (pprint-tab (if atsignp :section-relative :section) n m stream))
+ (pprint-tab (if atsignp :section-relative :section) n m stream))
(if atsignp
(interpret-bind-defaults ((colrel 1) (colinc 1)) params
- (format-relative-tab stream colrel colinc))
+ (format-relative-tab stream colrel colinc))
(interpret-bind-defaults ((colnum 1) (colinc 1)) params
- (format-absolute-tab stream colnum colinc)))))
+ (format-absolute-tab stream colnum colinc)))))
(defun output-spaces (stream n)
(declare (si::c-local))
(let ((spaces #.(make-string 100 :initial-element #\space)))
(loop
- (when (< n (length spaces))
- (return))
- (write-string spaces stream)
- (decf n (length spaces)))
+ (when (< n (length spaces))
+ (return))
+ (write-string spaces stream)
+ (decf n (length spaces)))
(write-string spaces stream :end n)))
(defun format-relative-tab (stream colrel colinc)
(def-format-directive #\_ (colonp atsignp params)
(check-output-layout-mode 1)
(expand-bind-defaults () params
- `(pprint-newline ,(if colonp
- (if atsignp
- :mandatory
- :fill)
- (if atsignp
- :miser
- :linear))
- stream)))
+ `(pprint-newline ,(if colonp
+ (if atsignp
+ :mandatory
+ :fill)
+ (if atsignp
+ :miser
+ :linear))
+ stream)))
(def-format-interpreter #\_ (colonp atsignp params)
(check-output-layout-mode 1)
(interpret-bind-defaults () params
- (pprint-newline (if colonp
- (if atsignp
- :mandatory
- :fill)
- (if atsignp
- :miser
- :linear))
- stream)))
+ (pprint-newline (if colonp
+ (if atsignp
+ :mandatory
+ :fill)
+ (if atsignp
+ :miser
+ :linear))
+ stream)))
(def-format-directive #\I (colonp atsignp params)
(check-output-layout-mode 1)
(error 'format-error
:complaint "Cannot specify the at-sign modifier."))
(expand-bind-defaults ((n 0)) params
- `(pprint-indent ,(if colonp :current :block) ,n stream)))
+ `(pprint-indent ,(if colonp :current :block) ,n stream)))
(def-format-interpreter #\I (colonp atsignp params)
(check-output-layout-mode 1)
(error 'format-error
:complaint "Cannot specify the at-sign modifier."))
(interpret-bind-defaults ((n 0)) params
- (pprint-indent (if colonp :current :block) n stream)))
+ (pprint-indent (if colonp :current :block) n stream)))
\f
;;;; *
(error 'format-error
:complaint "Cannot specify both colon and at-sign.")
(expand-bind-defaults ((posn 0)) params
- (unless *orig-args-available*
- (throw 'need-orig-args nil))
- `(if (<= 0 ,posn (length orig-args))
- (setf args (nthcdr ,posn orig-args))
- (error 'format-error
- :complaint "Index ~D out of bounds. Should have been ~
+ (unless *orig-args-available*
+ (throw 'need-orig-args nil))
+ `(if (<= 0 ,posn (length orig-args))
+ (setf args (nthcdr ,posn orig-args))
+ (error 'format-error
+ :complaint "Index ~D out of bounds. Should have been ~
between 0 and ~D."
- :arguments (list ,posn (length orig-args))
- :offset ,(1- end)))))
+ :arguments (list ,posn (length orig-args))
+ :offset ,(1- end)))))
(if colonp
(expand-bind-defaults ((n 1)) params
- (unless *orig-args-available*
- (throw 'need-orig-args nil))
- `(do ((cur-posn 0 (1+ cur-posn))
- (arg-ptr orig-args (cdr arg-ptr)))
- ((eq arg-ptr args)
- (let ((new-posn (- cur-posn ,n)))
- (if (<= 0 new-posn (length orig-args))
- (setf args (nthcdr new-posn orig-args))
- (error 'format-error
- :complaint
- "Index ~D out of bounds. Should have been ~
+ (unless *orig-args-available*
+ (throw 'need-orig-args nil))
+ `(do ((cur-posn 0 (1+ cur-posn))
+ (arg-ptr orig-args (cdr arg-ptr)))
+ ((eq arg-ptr args)
+ (let ((new-posn (- cur-posn ,n)))
+ (if (<= 0 new-posn (length orig-args))
+ (setf args (nthcdr new-posn orig-args))
+ (error 'format-error
+ :complaint
+ "Index ~D out of bounds. Should have been ~
between 0 and ~D."
- :arguments
- (list new-posn (length orig-args))
- :offset ,(1- end)))))))
+ :arguments
+ (list new-posn (length orig-args))
+ :offset ,(1- end)))))))
(if params
(expand-bind-defaults ((n 1)) params
- (setf *only-simple-args* nil)
- `(dotimes (i ,n)
- ,(expand-next-arg)))
+ (setf *only-simple-args* nil)
+ `(dotimes (i ,n)
+ ,(expand-next-arg)))
(expand-next-arg)))))
(def-format-interpreter #\* (colonp atsignp params)
(error 'format-error
:complaint "Cannot specify both colon and at-sign.")
(interpret-bind-defaults ((posn 0)) params
- (if (<= 0 posn (length orig-args))
- (setf args (nthcdr posn orig-args))
- (error 'format-error
- :complaint "Index ~D out of bounds. Should have been ~
+ (if (<= 0 posn (length orig-args))
+ (setf args (nthcdr posn orig-args))
+ (error 'format-error
+ :complaint "Index ~D out of bounds. Should have been ~
between 0 and ~D."
- :arguments (list posn (length orig-args))))))
+ :arguments (list posn (length orig-args))))))
(if colonp
(interpret-bind-defaults ((n 1)) params
- (do ((cur-posn 0 (1+ cur-posn))
- (arg-ptr orig-args (cdr arg-ptr)))
- ((eq arg-ptr args)
- (let ((new-posn (- cur-posn n)))
- (if (<= 0 new-posn (length orig-args))
- (setf args (nthcdr new-posn orig-args))
- (error 'format-error
- :complaint
- "Index ~D out of bounds. Should have been ~
+ (do ((cur-posn 0 (1+ cur-posn))
+ (arg-ptr orig-args (cdr arg-ptr)))
+ ((eq arg-ptr args)
+ (let ((new-posn (- cur-posn n)))
+ (if (<= 0 new-posn (length orig-args))
+ (setf args (nthcdr new-posn orig-args))
+ (error 'format-error
+ :complaint
+ "Index ~D out of bounds. Should have been ~
between 0 and ~D."
- :arguments
- (list new-posn (length orig-args))))))))
+ :arguments
+ (list new-posn (length orig-args))))))))
(interpret-bind-defaults ((n 1)) params
- (dotimes (i n)
- (next-arg))))))
+ (dotimes (i n)
+ (next-arg))))))
\f
;;;; Indirection.
(error 'format-error
:complaint "Cannot specify the colon modifier."))
(expand-bind-defaults () params
- `(handler-bind
- ((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string ,string
- :offset ,(1- end)))))
- ,(if atsignp
- (if *orig-args-available*
- `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args))
- (throw 'need-orig-args nil))
- `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg))))))
+ `(handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
+ ,(if atsignp
+ (if *orig-args-available*
+ `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args))
+ (throw 'need-orig-args nil))
+ `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg))))))
(def-format-interpreter #\? (colonp atsignp params string end)
(when colonp
(error 'format-error
:complaint "Cannot specify the colon modifier."))
(interpret-bind-defaults () params
- (handler-bind
- ((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
- (if atsignp
- (setf args (formatter-aux stream (next-arg) orig-args args))
- (formatter-aux stream (next-arg) (next-arg))))))
+ (handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
+ (if atsignp
+ (setf args (formatter-aux stream (next-arg) orig-args args))
+ (formatter-aux stream (next-arg) (next-arg))))))
\f
;;;; Capitalization.
(after (nthcdr (1+ posn) directives)))
(values
(expand-bind-defaults () params
- #-ecl
- `(let ((stream (make-case-frob-stream stream
- ,(if colonp
- (if atsignp
- :upcase
- :capitalize)
- (if atsignp
- :capitalize-first
- :downcase)))))
- ,@(expand-directive-list before))
- #+ecl
- `(let ((string (make-array 10 :element-type 'character
- :fill-pointer 0 :adjustable t)))
- (unwind-protect
- (with-output-to-string (stream string)
- ,@(expand-directive-list before))
- (princ (,(if colonp
- (if atsignp 'nstring-upcase 'nstring-capitalize)
- (if atsignp 'nstring-capitalize-first 'nstring-downcase))
- string)
- stream))))
+ #-ecl
+ `(let ((stream (make-case-frob-stream stream
+ ,(if colonp
+ (if atsignp
+ :upcase
+ :capitalize)
+ (if atsignp
+ :capitalize-first
+ :downcase)))))
+ ,@(expand-directive-list before))
+ #+ecl
+ `(let ((string (make-array 10 :element-type 'character
+ :fill-pointer 0 :adjustable t)))
+ (unwind-protect
+ (with-output-to-string (stream string)
+ ,@(expand-directive-list before))
+ (princ (,(if colonp
+ (if atsignp 'nstring-upcase 'nstring-capitalize)
+ (if atsignp 'nstring-capitalize-first 'nstring-downcase))
+ string)
+ stream))))
after))))
(def-complex-format-interpreter #\( (colonp atsignp params directives)
(error 'format-error
:complaint "No corresponding close paren."))
(interpret-bind-defaults () params
- #-ecl
- (let* ((posn (position close directives))
- (before (subseq directives 0 posn))
- (after (nthcdr (1+ posn) directives))
- (stream (make-case-frob-stream stream
- (if colonp
- (if atsignp
- :upcase
- :capitalize)
- (if atsignp
- :capitalize-first
- :downcase)))))
- (setf args (interpret-directive-list stream before orig-args args))
- after)
- #+ecl
- (let* ((posn (position close directives))
- (before (subseq directives 0 posn))
- (jumped t)
- (after (nthcdr (1+ posn) directives))
- (string (make-array 10 :element-type 'character
- :adjustable t :fill-pointer 0)))
- (unwind-protect
- (with-output-to-string (stream string)
- (setf args (interpret-directive-list stream before orig-args args)))
- (princ (funcall
- (if colonp
- (if atsignp 'nstring-upcase 'nstring-capitalize)
- (if atsignp 'nstring-capitalize-first 'nstring-downcase))
- string) stream))
- after))))
+ #-ecl
+ (let* ((posn (position close directives))
+ (before (subseq directives 0 posn))
+ (after (nthcdr (1+ posn) directives))
+ (stream (make-case-frob-stream stream
+ (if colonp
+ (if atsignp
+ :upcase
+ :capitalize)
+ (if atsignp
+ :capitalize-first
+ :downcase)))))
+ (setf args (interpret-directive-list stream before orig-args args))
+ after)
+ #+ecl
+ (let* ((posn (position close directives))
+ (before (subseq directives 0 posn))
+ (jumped t)
+ (after (nthcdr (1+ posn) directives))
+ (string (make-array 10 :element-type 'character
+ :adjustable t :fill-pointer 0)))
+ (unwind-protect
+ (with-output-to-string (stream string)
+ (setf args (interpret-directive-list stream before orig-args args)))
+ (princ (funcall
+ (if colonp
+ (if atsignp 'nstring-upcase 'nstring-capitalize)
+ (if atsignp 'nstring-capitalize-first 'nstring-downcase))
+ string) stream))
+ after))))
(def-complex-format-directive #\) ()
(error 'format-error
(last-semi-with-colon-p nil)
(remaining directives))
(loop
- (let ((close-or-semi (find-directive remaining #\] t)))
- (unless close-or-semi
- (error 'format-error
- :complaint "No corresponding close bracket."))
- (let ((posn (position close-or-semi remaining)))
- (push (subseq remaining 0 posn) sublists)
- (setf remaining (nthcdr (1+ posn) remaining))
- (when (char= (format-directive-character close-or-semi) #\])
- (return))
- (setf last-semi-with-colon-p
- (format-directive-colonp close-or-semi)))))
+ (let ((close-or-semi (find-directive remaining #\] t)))
+ (unless close-or-semi
+ (error 'format-error
+ :complaint "No corresponding close bracket."))
+ (let ((posn (position close-or-semi remaining)))
+ (push (subseq remaining 0 posn) sublists)
+ (setf remaining (nthcdr (1+ posn) remaining))
+ (when (char= (format-directive-character close-or-semi) #\])
+ (return))
+ (setf last-semi-with-colon-p
+ (format-directive-colonp close-or-semi)))))
(values sublists last-semi-with-colon-p remaining)))
(def-complex-format-directive #\[ (colonp atsignp params directives)
(multiple-value-bind
- (sublists last-semi-with-colon-p remaining)
+ (sublists last-semi-with-colon-p remaining)
(parse-conditional-directive directives)
(values
(if atsignp
:complaint
"Can only specify one section")
(expand-bind-defaults () params
- (expand-maybe-conditional (car sublists)))))
+ (expand-maybe-conditional (car sublists)))))
(if colonp
(if (= (length sublists) 2)
(expand-bind-defaults () params
- (expand-true-false-conditional (car sublists)
- (cadr sublists)))
+ (expand-true-false-conditional (car sublists)
+ (cadr sublists)))
(error 'format-error
:complaint
"Must specify exactly two sections."))
(expand-bind-defaults ((index nil)) params
- (setf *only-simple-args* nil)
- (let* ((clauses nil)
- (case `(or ,index ,(expand-next-arg))))
- (when last-semi-with-colon-p
- (push `(t ,@(expand-directive-list (pop sublists)))
- clauses))
- (let ((count (length sublists)))
- (dolist (sublist sublists)
- (push `(,(decf count)
- ,@(expand-directive-list sublist))
- clauses)))
- `(case ,case ,@clauses)))))
+ (setf *only-simple-args* nil)
+ (let* ((clauses nil)
+ (case `(or ,index ,(expand-next-arg))))
+ (when last-semi-with-colon-p
+ (push `(t ,@(expand-directive-list (pop sublists)))
+ clauses))
+ (let ((count (length sublists)))
+ (dolist (sublist sublists)
+ (push `(,(decf count)
+ ,@(expand-directive-list sublist))
+ clauses)))
+ `(case ,case ,@clauses)))))
remaining)))
#+formatter
,@(expand-directive-list false)))))
(if *only-simple-args*
(multiple-value-bind
- (true-guts true-args true-simple)
+ (true-guts true-args true-simple)
(let ((*simple-args* *simple-args*)
(*only-simple-args* t))
(values (expand-directive-list true)
*simple-args*
*only-simple-args*))
(multiple-value-bind
- (false-guts false-args false-simple)
+ (false-guts false-args false-simple)
(let ((*simple-args* *simple-args*)
(*only-simple-args* t))
(values (expand-directive-list false)
(def-complex-format-interpreter #\[ (colonp atsignp params directives)
(multiple-value-bind
- (sublists last-semi-with-colon-p remaining)
+ (sublists last-semi-with-colon-p remaining)
(parse-conditional-directive directives)
(setf args
(if atsignp
(if colonp
(error 'format-error
:complaint
- "Cannot specify both the colon and at-sign modifiers.")
+ "Cannot specify both the colon and at-sign modifiers.")
(if (cdr sublists)
(error 'format-error
:complaint
"Can only specify one section")
(interpret-bind-defaults () params
- (let ((prev-args args)
- (arg (next-arg)))
- (if arg
- (interpret-directive-list stream
- (car sublists)
- orig-args
- prev-args)
- args)))))
+ (let ((prev-args args)
+ (arg (next-arg)))
+ (if arg
+ (interpret-directive-list stream
+ (car sublists)
+ orig-args
+ prev-args)
+ args)))))
(if colonp
(if (= (length sublists) 2)
(interpret-bind-defaults () params
- (if (next-arg)
- (interpret-directive-list stream (car sublists)
- orig-args args)
- (interpret-directive-list stream (cadr sublists)
- orig-args args)))
+ (if (next-arg)
+ (interpret-directive-list stream (car sublists)
+ orig-args args)
+ (interpret-directive-list stream (cadr sublists)
+ orig-args args)))
(error 'format-error
:complaint
"Must specify exactly two sections."))
(interpret-bind-defaults ((index (next-arg))) params
- (let* ((default (and last-semi-with-colon-p
- (pop sublists)))
- (last (1- (length sublists)))
- (sublist
- (if (<= 0 index last)
- (nth (- last index) sublists)
- default)))
- (interpret-directive-list stream sublist orig-args
- args))))))
+ (let* ((default (and last-semi-with-colon-p
+ (pop sublists)))
+ (last (1- (length sublists)))
+ (sublist
+ (if (<= 0 index last)
+ (nth (- last index) sublists)
+ default)))
+ (interpret-directive-list stream sublist orig-args
+ args))))))
remaining))
(def-complex-format-directive #\; ()
(error 'format-error
:complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
`(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
- `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
- (,arg2 (eql ,arg1 ,arg2))
- (,arg1 (eql ,arg1 0))
- (t ,(if colonp
- '(null outside-args)
- (progn
- (setf *only-simple-args* nil)
- '(null args))))))
+ `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
+ (,arg2 (eql ,arg1 ,arg2))
+ (,arg1 (eql ,arg1 0))
+ (t ,(if colonp
+ '(null outside-args)
+ (progn
+ (setf *only-simple-args* nil)
+ '(null args))))))
,(if colonp
'(return-from outside-loop nil)
'(return))))
(error 'format-error
:complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
(when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
- (cond (arg3 (<= arg1 arg2 arg3))
- (arg2 (eql arg1 arg2))
- (arg1 (eql arg1 0))
- (t (if colonp
- (null *outside-args*)
- (null args)))))
+ (cond (arg3 (<= arg1 arg2 arg3))
+ (arg2 (eql arg1 arg2))
+ (arg1 (eql arg1 0))
+ (t (if colonp
+ (null *outside-args*)
+ (null args)))))
(throw (if colonp 'up-up-and-out 'up-and-out)
- args)))
+ args)))
\f
;;;; Iteration.
(lambda (condition)
(error 'format-error
:complaint
- "~A~%while processing indirect format string:"
+ "~A~%while processing indirect format string:"
:args (list condition)
:print-banner nil
:control-string ,string
(when atsignp
(setf *only-simple-args* nil))
`(loop
- ,@(unless closed-with-colon
- '((when (null args)
- (return))))
- ,@(when count
- `((when (and ,count (minusp (decf ,count)))
- (return))))
- ,@(if colonp
- (let ((*expander-next-arg-macro* 'expander-next-arg)
- (*only-simple-args* nil)
- (*orig-args-available* t))
- `((let* ((orig-args ,(expand-next-arg))
- (outside-args args)
- (args orig-args))
- (declare (ignorable orig-args outside-args args))
- (block nil
- ,@(compute-insides)))))
- (compute-insides))
- ,@(when closed-with-colon
- '((when (null args)
- (return))))))
+ ,@(unless closed-with-colon
+ '((when (null args)
+ (return))))
+ ,@(when count
+ `((when (and ,count (minusp (decf ,count)))
+ (return))))
+ ,@(if colonp
+ (let ((*expander-next-arg-macro* 'expander-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ `((let* ((orig-args ,(expand-next-arg))
+ (outside-args args)
+ (args orig-args))
+ (declare (ignorable orig-args outside-args args))
+ (block nil
+ ,@(compute-insides)))))
+ (compute-insides))
+ ,@(when closed-with-colon
+ '((when (null args)
+ (return))))))
(compute-block (count)
(if colonp
`(block outside-loop
(compute-block count)
`(let* ((orig-args ,(expand-next-arg))
(args orig-args))
- (declare (ignorable orig-args args))
- ,(let ((*expander-next-arg-macro* 'expander-next-arg)
- (*only-simple-args* nil)
- (*orig-args-available* t))
- (compute-block count))))))
+ (declare (ignorable orig-args args))
+ ,(let ((*expander-next-arg-macro* 'expander-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ (compute-block count))))))
(values (if params
(expand-bind-defaults ((count nil)) params
- (if (zerop posn)
- `(let ((inside-string ,(expand-next-arg)))
- ,(compute-bindings count))
- (compute-bindings count)))
+ (if (zerop posn)
+ `(let ((inside-string ,(expand-next-arg)))
+ ,(compute-bindings count))
+ (compute-bindings count)))
(if (zerop posn)
`(let ((inside-string ,(expand-next-arg)))
- ,(compute-bindings nil))
+ ,(compute-bindings nil))
(compute-bindings nil)))
(nthcdr (1+ posn) directives))))))
(def-complex-format-interpreter #\{
- (colonp atsignp params string end directives)
+ (colonp atsignp params string end directives)
(let ((close (find-directive directives #\} nil)))
(unless close
(error 'format-error
:complaint
"No corresponding close brace."))
(interpret-bind-defaults ((max-count nil)) params
- (let* ((closed-with-colon (format-directive-colonp close))
- (posn (position close directives))
- (insides (if (zerop posn)
- (next-arg)
- (subseq directives 0 posn)))
- (*up-up-and-out-allowed* colonp))
- (labels
- ((do-guts (orig-args args)
- (if (zerop posn)
- (handler-bind
- ((format-error
- #'(lambda (condition)
- (error 'format-error
- :complaint
- "~A~%while processing indirect format string:"
- :arguments (list condition)
- :print-banner nil
- :control-string string
- :offset (1- end)))))
- (formatter-aux stream insides orig-args args))
- (interpret-directive-list stream insides
- orig-args args)))
- (bind-args (orig-args args)
- (if colonp
- (let* ((arg (next-arg))
- (*logical-block-popper* nil)
- (*outside-args* args))
- (catch 'up-and-out
- (do-guts arg arg))
- args)
- (do-guts orig-args args)))
- (do-loop (orig-args args)
- (catch (if colonp 'up-up-and-out 'up-and-out)
- (loop
- (when (and (not closed-with-colon) (null args))
- (return))
- (when (and max-count (minusp (decf max-count)))
- (return))
- (setf args (bind-args orig-args args))
- (when (and closed-with-colon (null args))
- (return)))
- args)))
- (if atsignp
- (setf args (do-loop orig-args args))
- (let ((arg (next-arg))
- (*logical-block-popper* nil))
- (do-loop arg arg)))
- (nthcdr (1+ posn) directives))))))
+ (let* ((closed-with-colon (format-directive-colonp close))
+ (posn (position close directives))
+ (insides (if (zerop posn)
+ (next-arg)
+ (subseq directives 0 posn)))
+ (*up-up-and-out-allowed* colonp))
+ (labels
+ ((do-guts (orig-args args)
+ (if (zerop posn)
+ (handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
+ (formatter-aux stream insides orig-args args))
+ (interpret-directive-list stream insides
+ orig-args args)))
+ (bind-args (orig-args args)
+ (if colonp
+ (let* ((arg (next-arg))
+ (*logical-block-popper* nil)
+ (*outside-args* args))
+ (catch 'up-and-out
+ (do-guts arg arg))
+ args)
+ (do-guts orig-args args)))
+ (do-loop (orig-args args)
+ (catch (if colonp 'up-up-and-out 'up-and-out)
+ (loop
+ (when (and (not closed-with-colon) (null args))
+ (return))
+ (when (and max-count (minusp (decf max-count)))
+ (return))
+ (setf args (bind-args orig-args args))
+ (when (and closed-with-colon (null args))
+ (return)))
+ args)))
+ (if atsignp
+ (setf args (do-loop orig-args args))
+ (let ((arg (next-arg))
+ (*logical-block-popper* nil))
+ (do-loop arg arg)))
+ (nthcdr (1+ posn) directives))))))
(def-complex-format-directive #\} ()
(error 'format-error
(def-complex-format-directive #\< (colonp atsignp params string end directives)
(multiple-value-bind
- (segments first-semi close remaining)
+ (segments first-semi close remaining)
(parse-format-justification directives)
(values
(if (format-directive-colonp close)
(multiple-value-bind
- (prefix per-line-p insides suffix)
+ (prefix per-line-p insides suffix)
(parse-format-logical-block segments colonp first-semi
close params string end)
(expand-format-logical-block prefix per-line-p insides
:complaint "~D illegal directive~:P found inside justification block"
:arguments (list count)))
(expand-format-justification segments colonp atsignp
- first-semi params)))
+ first-semi params)))
remaining)))
(def-complex-format-interpreter #\<
- (colonp atsignp params string end directives)
+ (colonp atsignp params string end directives)
(multiple-value-bind
- (segments first-semi close remaining)
+ (segments first-semi close remaining)
(parse-format-justification directives)
(setf args
(if (format-directive-colonp close)
(multiple-value-bind
- (prefix per-line-p insides suffix)
+ (prefix per-line-p insides suffix)
(parse-format-logical-block segments colonp first-semi
close params string end)
(interpret-format-logical-block stream orig-args args
(close nil)
(remaining directives))
(collect ((segments))
- (loop
- (let ((close-or-semi (find-directive remaining #\> t)))
- (unless close-or-semi
- (error 'format-error
- :complaint "No corresponding close bracket."))
- (let ((posn (position close-or-semi remaining)))
- (segments (subseq remaining 0 posn))
- (setf remaining (nthcdr (1+ posn) remaining)))
- (when (char= (format-directive-character close-or-semi)
- #\>)
- (setf close close-or-semi)
- (return))
- (unless first-semi
- (setf first-semi close-or-semi))))
- (values (segments) first-semi close remaining))))
+ (loop
+ (let ((close-or-semi (find-directive remaining #\> t)))
+ (unless close-or-semi
+ (error 'format-error
+ :complaint "No corresponding close bracket."))
+ (let ((posn (position close-or-semi remaining)))
+ (segments (subseq remaining 0 posn))
+ (setf remaining (nthcdr (1+ posn) remaining)))
+ (when (char= (format-directive-character close-or-semi)
+ #\>)
+ (setf close close-or-semi)
+ (return))
+ (unless first-semi
+ (setf first-semi close-or-semi))))
+ (values (segments) first-semi close remaining))))
#+formatter
(defun expand-format-justification (segments colonp atsignp first-semi params)
(when newline-segment-p
(check-output-layout-mode 2))
(expand-bind-defaults
- ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
- params
- `(let ((segments nil)
- ,@(when newline-segment-p
- '((newline-segment nil)
- (extra-space 0)
- (line-len 72))))
- (block nil
- ,@(when newline-segment-p
- `((setf newline-segment
- (with-output-to-string (stream)
- ,@(expand-directive-list (pop segments))))
- ,(expand-bind-defaults
+ ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+ params
+ `(let ((segments nil)
+ ,@(when newline-segment-p
+ '((newline-segment nil)
+ (extra-space 0)
+ (line-len 72))))
+ (block nil
+ ,@(when newline-segment-p
+ `((setf newline-segment
+ (with-output-to-string (stream)
+ ,@(expand-directive-list (pop segments))))
+ ,(expand-bind-defaults
((extra 0)
(line-len '(or #-ecl (sys::line-length stream) 72)))
(format-directive-params first-semi)
- `(setf extra-space ,extra line-len ,line-len))))
- ,@(mapcar #'(lambda (segment)
- `(push (with-output-to-string (stream)
- ,@(expand-directive-list segment))
- segments))
- segments))
- (format-justification stream
- ,@(if newline-segment-p
- '(newline-segment extra-space line-len)
- '(nil 0 0))
- segments ,colonp ,atsignp
- ,mincol ,colinc ,minpad ,padchar)))))
+ `(setf extra-space ,extra line-len ,line-len))))
+ ,@(mapcar #'(lambda (segment)
+ `(push (with-output-to-string (stream)
+ ,@(expand-directive-list segment))
+ segments))
+ segments))
+ (format-justification stream
+ ,@(if newline-segment-p
+ '(newline-segment extra-space line-len)
+ '(nil 0 0))
+ segments ,colonp ,atsignp
+ ,mincol ,colinc ,minpad ,padchar)))))
(defun interpret-format-justification
- (stream orig-args args segments colonp atsignp first-semi params)
+ (stream orig-args args segments colonp atsignp first-semi params)
(declare (si::c-local))
(interpret-bind-defaults
- ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
- params
- (let ((newline-string nil)
- (strings nil)
- (extra-space 0)
- (line-len 0))
- (setf args
- (catch 'up-and-out
- (when (and first-semi (format-directive-colonp first-semi))
- (check-output-layout-mode 2)
- (interpret-bind-defaults
- ((extra 0)
- (len (or #-ecl (sys::line-length stream) 72)))
- (format-directive-params first-semi)
- (setf newline-string
- (with-output-to-string (stream)
- (setf args
- (interpret-directive-list stream
- (pop segments)
- orig-args
- args))))
- (setf extra-space extra)
- (setf line-len len)))
- (dolist (segment segments)
- (push (with-output-to-string (stream)
+ ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+ params
+ (let ((newline-string nil)
+ (strings nil)
+ (extra-space 0)
+ (line-len 0))
+ (setf args
+ (catch 'up-and-out
+ (when (and first-semi (format-directive-colonp first-semi))
+ (check-output-layout-mode 2)
+ (interpret-bind-defaults
+ ((extra 0)
+ (len (or #-ecl (sys::line-length stream) 72)))
+ (format-directive-params first-semi)
+ (setf newline-string
+ (with-output-to-string (stream)
(setf args
- (interpret-directive-list stream segment
- orig-args args)))
- strings))
- args))
- (format-justification stream newline-string extra-space line-len strings
- colonp atsignp mincol colinc minpad padchar)))
+ (interpret-directive-list stream
+ (pop segments)
+ orig-args
+ args))))
+ (setf extra-space extra)
+ (setf line-len len)))
+ (dolist (segment segments)
+ (push (with-output-to-string (stream)
+ (setf args
+ (interpret-directive-list stream segment
+ orig-args args)))
+ strings))
+ args))
+ (format-justification stream newline-string extra-space line-len strings
+ colonp atsignp mincol colinc minpad padchar)))
args)
(defun format-justification (stream newline-prefix extra-space line-len strings
(do-padding t)))))
(defun parse-format-logical-block
- (segments colonp first-semi close params string end)
+ (segments colonp first-semi close params string end)
(declare (si::c-local))
(check-output-layout-mode 1)
(when params
:complaint "No parameters can be supplied with ~~<...~~:>."
:offset (caar params)))
(multiple-value-bind
- (prefix insides suffix)
+ (prefix insides suffix)
(multiple-value-bind (prefix-default suffix-default)
- (if colonp (values "(" ")") (values "" ""))
+ (if colonp (values "(" ")") (values "" ""))
(flet ((extract-string (list prefix-p)
(let ((directive (find-if #'format-directive-p list)))
(if directive
:arguments (list prefix-p)
:offset (1- (format-directive-end directive)))
(apply #'concatenate 'string list)))))
- (case (length segments)
- (0 (values prefix-default nil suffix-default))
- (1 (values prefix-default (car segments) suffix-default))
- (2 (values (extract-string (car segments) t)
- (cadr segments) suffix-default))
- (3 (values (extract-string (car segments) t)
- (cadr segments)
- (extract-string (caddr segments) nil)))
- (t
- (error 'format-error
- :complaint "Too many segments for ~~<...~~:>.")))))
+ (case (length segments)
+ (0 (values prefix-default nil suffix-default))
+ (1 (values prefix-default (car segments) suffix-default))
+ (2 (values (extract-string (car segments) t)
+ (cadr segments) suffix-default))
+ (3 (values (extract-string (car segments) t)
+ (cadr segments)
+ (extract-string (caddr segments) nil)))
+ (t
+ (error 'format-error
+ :complaint "Too many segments for ~~<...~~:>.")))))
(when (format-directive-atsignp close)
(setf insides
(add-fill-style-newlines insides
(let ((end (length literal))
(posn 0))
(collect ((results))
- (loop
- (let ((blank (position #\space literal :start posn)))
- (when (null blank)
- (results (subseq literal posn))
- (return))
- (let ((non-blank (or (position #\space literal :start blank
- :test #'char/=)
- end)))
- (results (subseq literal posn non-blank))
- (results (make-format-directive
- :string string :character #\_
- :start (+ offset non-blank) :end (+ offset non-blank)
- :colonp t :atsignp nil :params nil))
- (setf posn non-blank))
- (when (= posn end)
- (return))))
- (results))))
+ (loop
+ (let ((blank (position #\space literal :start posn)))
+ (when (null blank)
+ (results (subseq literal posn))
+ (return))
+ (let ((non-blank (or (position #\space literal :start blank
+ :test #'char/=)
+ end)))
+ (results (subseq literal posn non-blank))
+ (results (make-format-directive
+ :string string :character #\_
+ :start (+ offset non-blank) :end (+ offset non-blank)
+ :colonp t :atsignp nil :params nil))
+ (setf posn non-blank))
+ (when (= posn end)
+ (return))))
+ (results))))
#+formatter
(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
`(let ((arg ,(if atsignp 'args (expand-next-arg))))
,@(when atsignp
- (setf *only-simple-args* nil)
- '((setf args nil)))
+ (setf *only-simple-args* nil)
+ '((setf args nil)))
(pprint-logical-block
(stream arg
,(if per-line-p :per-line-prefix :prefix) ,prefix
:suffix ,suffix)
(let ((args arg)
,@(unless atsignp
- `((orig-args arg))))
+ `((orig-args arg))))
(declare (ignorable args ,@(unless atsignp '(orig-args))))
(block nil
,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
(*only-simple-args* nil)
(*orig-args-available* t))
- (expand-directive-list insides)))))))
+ (expand-directive-list insides)))))))
(defun interpret-format-logical-block
- (stream orig-args args prefix per-line-p insides suffix atsignp)
+ (stream orig-args args prefix per-line-p insides suffix atsignp)
(declare (si::c-local))
(let ((arg (if atsignp args (next-arg))))
(if per-line-p
(def-format-directive #\/ (string start end colonp atsignp params)
(let ((symbol (extract-user-function-name string start end)))
(collect ((param-names) (bindings))
- (dolist (param-and-offset params)
- (let ((param (cdr param-and-offset)))
- (let ((param-name (gensym)))
- (param-names param-name)
- (bindings `(,param-name
- ,(case param
- (:arg (expand-next-arg))
- (:remaining '(length args))
- (t param)))))))
- `(let ,(bindings)
- (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
- ,@(param-names))))))
+ (dolist (param-and-offset params)
+ (let ((param (cdr param-and-offset)))
+ (let ((param-name (gensym)))
+ (param-names param-name)
+ (bindings `(,param-name
+ ,(case param
+ (:arg (expand-next-arg))
+ (:remaining '(length args))
+ (t param)))))))
+ `(let ,(bindings)
+ (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
+ ,@(param-names))))))
(def-format-interpreter #\/ (string start end colonp atsignp params)
(let ((symbol (extract-user-function-name string start end)))
(collect ((args))
- (dolist (param-and-offset params)
- (let ((param (cdr param-and-offset)))
- (case param
- (:arg (let ((x (next-arg))) (when x (args x))))
- (:remaining (args (length args)))
- (t (args param)))))
- (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))
+ (dolist (param-and-offset params)
+ (let ((param (cdr param-and-offset)))
+ (case param
+ (:arg (let ((x (next-arg))) (when x (args x))))
+ (:remaining (args (length args)))
+ (t (args param)))))
+ (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))
(defun extract-user-function-name (string start end)
(declare (si::c-local))
;;;
;;; This is called from FORMAT deftransforms.
;;;
-(defun min/max-format-arguments-count (string)
- #-formatter
- (declare (si::c-local))
- (handler-case
- (catch 'give-up
- ;; For the side effect of validating the control string.
- (%formatter string)
- (%min/max-format-args (tokenize-control-string string)))
- (format-error (e)
- (format nil "~a" e))))
-
-(defun %min/max-format-args (directives)
- #-formatter
- (declare (si::c-local))
- (let ((min-req 0) (max-req 0))
- (flet ((incf-both (&optional (n 1))
- (incf min-req n)
- (incf max-req n)))
- (loop
- (let ((dir (pop directives)))
- (when (null dir)
- (return (values min-req max-req)))
- (when (format-directive-p dir)
- (incf-both (count :arg (format-directive-params dir) :key #'cdr))
- (let ((c (format-directive-character dir)))
- (cond ((find c "ABCDEFGORSWX$/")
- (incf-both))
- ((char= c #\P)
- (unless (format-directive-colonp dir)
- (incf-both)))
- ((or (find c "IT%&|_<>();") (char= c #\newline)))
- ((char= c #\[)
- (multiple-value-bind (min max remaining)
- (%min/max-conditional-args dir directives)
- (setq directives remaining)
- (incf min-req min)
- (incf max-req max)))
- ((char= c #\{)
- (multiple-value-bind (min max remaining)
- (%min/max-iteration-args dir directives)
- (setq directives remaining)
- (incf min-req min)
- (incf max-req max)))
- ((char= c #\?)
- (cond ((format-directive-atsignp dir)
- (incf min-req)
- (setq max-req most-positive-fixnum))
- (t (incf-both 2))))
- (t (throw 'give-up nil))))))))))
+ (defun min/max-format-arguments-count (string)
+ #-formatter
+ (declare (si::c-local))
+ (handler-case
+ (catch 'give-up
+ ;; For the side effect of validating the control string.
+ (%formatter string)
+ (%min/max-format-args (tokenize-control-string string)))
+ (format-error (e)
+ (format nil "~a" e))))
+
+ (defun %min/max-format-args (directives)
+ #-formatter
+ (declare (si::c-local))
+ (let ((min-req 0) (max-req 0))
+ (flet ((incf-both (&optional (n 1))
+ (incf min-req n)
+ (incf max-req n)))
+ (loop
+ (let ((dir (pop directives)))
+ (when (null dir)
+ (return (values min-req max-req)))
+ (when (format-directive-p dir)
+ (incf-both (count :arg (format-directive-params dir) :key #'cdr))
+ (let ((c (format-directive-character dir)))
+ (cond ((find c "ABCDEFGORSWX$/")
+ (incf-both))
+ ((char= c #\P)
+ (unless (format-directive-colonp dir)
+ (incf-both)))
+ ((or (find c "IT%&|_<>();") (char= c #\newline)))
+ ((char= c #\[)
+ (multiple-value-bind (min max remaining)
+ (%min/max-conditional-args dir directives)
+ (setq directives remaining)
+ (incf min-req min)
+ (incf max-req max)))
+ ((char= c #\{)
+ (multiple-value-bind (min max remaining)
+ (%min/max-iteration-args dir directives)
+ (setq directives remaining)
+ (incf min-req min)
+ (incf max-req max)))
+ ((char= c #\?)
+ (cond ((format-directive-atsignp dir)
+ (incf min-req)
+ (setq max-req most-positive-fixnum))
+ (t (incf-both 2))))
+ (t (throw 'give-up nil))))))))))
;;;
;;; ANSI: if arg is out of range, no clause is selected. That means
;;; the minimum number of args required for the interior of ~[~] is
;;; always zero.
;;;
-(defun %min/max-conditional-args (conditional directives)
- #-formatter
- (declare (si::c-local))
- (multiple-value-bind (sublists last-semi-with-colon-p remaining)
- (parse-conditional-directive directives)
- (declare (ignore last-semi-with-colon-p))
- (let ((sub-max (loop for s in sublists maximize
- (nth-value 1 (%min/max-format-args s))))
- (min-req 1)
- max-req)
- (cond ((format-directive-atsignp conditional)
- (setq max-req (max 1 sub-max)))
- ((loop for p in (format-directive-params conditional)
- thereis (or (integerp (cdr p))
- (memq (cdr p) '(:remaining :arg))))
- (setq min-req 0)
- (setq max-req sub-max))
- (t
- (setq max-req (1+ sub-max))))
- (values min-req max-req remaining))))
-
-(defun %min/max-iteration-args (iteration directives)
- #-formatter
- (declare (si::c-local))
- (let* ((close (find-directive directives #\} nil))
- (posn (position close directives))
- (remaining (nthcdr (1+ posn) directives)))
- (if (format-directive-atsignp iteration)
- (values (if (zerop posn) 1 0) most-positive-fixnum remaining)
- (let ((nreq (if (zerop posn) 2 1)))
- (values nreq nreq remaining)))))
-)
+ (defun %min/max-conditional-args (conditional directives)
+ #-formatter
+ (declare (si::c-local))
+ (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+ (parse-conditional-directive directives)
+ (declare (ignore last-semi-with-colon-p))
+ (let ((sub-max (loop for s in sublists maximize
+ (nth-value 1 (%min/max-format-args s))))
+ (min-req 1)
+ max-req)
+ (cond ((format-directive-atsignp conditional)
+ (setq max-req (max 1 sub-max)))
+ ((loop for p in (format-directive-params conditional)
+ thereis (or (integerp (cdr p))
+ (memq (cdr p) '(:remaining :arg))))
+ (setq min-req 0)
+ (setq max-req sub-max))
+ (t
+ (setq max-req (1+ sub-max))))
+ (values min-req max-req remaining))))
+
+ (defun %min/max-iteration-args (iteration directives)
+ #-formatter
+ (declare (si::c-local))
+ (let* ((close (find-directive directives #\} nil))
+ (posn (position close directives))
+ (remaining (nthcdr (1+ posn) directives)))
+ (if (format-directive-atsignp iteration)
+ (values (if (zerop posn) 1 0) most-positive-fixnum remaining)
+ (let ((nreq (if (zerop posn) 2 1)))
+ (values nreq nreq remaining)))))
+ )
Repositories / ecl.git / commitdiff