abcl
abcl copied to clipboard
armedbear
Format unexpected behavior
(format t "~:<~W ~(~W~)~:>" '(a b))
=> b(A )
When remove ~(~) directive, the output is the expected one.
(format t "~:<~W ~W~:>" '(a b))
=> (A B)
This behavior is made by the stream's mismatching.
(pprint-logical-block (*standard-output* ; <---
nil :prefix "(" :suffix ")")
(write 'a)
(write-char #\space)
(write 'b :stream *error-output*)) ; <---
=> B(A )
The code that is generated by formatter is below.
(macroexpand-1 '(formatter "~:<~W ~(~W~)~:>"))
#'(LAMBDA (STREAM &OPTIONAL
(#:FORMAT-ARG-92645
(ERROR 'FORMAT::FORMAT-ERROR
:COMPLAINT
"required argument missing"
:CONTROL-STRING
"~:<~W ~(~W~)~:>"
:OFFSET
2))
&REST FORMAT::ARGS)
(BLOCK NIL
(LET ((FORMAT::ARG #:FORMAT-ARG-92645))
(PPRINT-LOGICAL-BLOCK (STREAM FORMAT::ARG :PREFIX "(" :SUFFIX
")")
(LET ((FORMAT::ARGS FORMAT::ARG)
(FORMAT::ORIG-ARGS FORMAT::ARG))
(DECLARE (IGNORABLE FORMAT::ARGS
FORMAT::ORIG-ARGS))
(BLOCK NIL
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
4)
STREAM)
(WRITE-STRING " " STREAM)
(LET ((STREAM ; <---
(SYSTEM::MAKE-CASE-FROB-STREAM (IF (TYPEP STREAM
'XP::XP-STRUCTURE)
(XP::BASE-STREAM STREAM)
STREAM)
:DOWNCASE)))
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
9)
STREAM)))))))
FORMAT::ARGS)
The inner variable STREAM that is bound by the return value of system::make-case-frob-stream is the point.
Using cl:write instead of system:output-object resolve the issue.
#'(LAMBDA (STREAM &OPTIONAL
(FORMAT-ARG-92645
(ERROR 'FORMAT::FORMAT-ERROR
:COMPLAINT
"required argument missing"
:CONTROL-STRING
"~:<~W ~(~W~)~:>"
:OFFSET
2))
&REST FORMAT::ARGS)
(BLOCK NIL
(LET ((FORMAT::ARG FORMAT-ARG-92645))
(PPRINT-LOGICAL-BLOCK (STREAM FORMAT::ARG :PREFIX "(" :SUFFIX
")")
(LET ((FORMAT::ARGS FORMAT::ARG)
(FORMAT::ORIG-ARGS FORMAT::ARG))
(DECLARE (IGNORABLE FORMAT::ARGS
FORMAT::ORIG-ARGS))
(BLOCK NIL
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
4)
STREAM)
(WRITE-STRING " " STREAM)
;;;
(write (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>" 9)
:stream stream
:case :downcase))))))
FORMAT::ARGS)
(funcall * nil '(a b))
=> (A b)
So I think where we should fix is here and here.
Fortunately, I found *print-case* works for system:output-object too.
#'(LAMBDA (STREAM &OPTIONAL
(FORMAT-ARG-92645
(ERROR 'FORMAT::FORMAT-ERROR
:COMPLAINT
"required argument missing"
:CONTROL-STRING
"~:<~W ~(~W~)~:>"
:OFFSET
2))
&REST FORMAT::ARGS)
(BLOCK NIL
(LET ((FORMAT::ARG FORMAT-ARG-92645))
(PPRINT-LOGICAL-BLOCK (STREAM FORMAT::ARG :PREFIX "(" :SUFFIX
")")
(LET ((FORMAT::ARGS FORMAT::ARG)
(FORMAT::ORIG-ARGS FORMAT::ARG))
(DECLARE (IGNORABLE FORMAT::ARGS
FORMAT::ORIG-ARGS))
(BLOCK NIL
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
4)
STREAM)
(WRITE-STRING " " STREAM)
(let ((*print-case* :downcase)) ; <---
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
9)
STREAM)))))))
FORMAT::ARGS)
(funcall * nil '(a b))
=> (A b)
The patches may be like below.
(def-complex-format-directive #\( (colonp atsignp params directives)
(let ((close (find-directive directives #\) nil)))
(unless close
(error 'format-error
:complaint "no corresponding close parenthesis"))
(let* ((posn (position close directives))
(before (subseq directives 0 posn))
(after (nthcdr (1+ posn) directives)))
(values
(expand-bind-defaults () params
`(let ((*print-case* ,(if colonp
(if atsignp
:upcase
:capitalize)
(if atsignp
:capitalize-first
:downcase))))
,@(expand-directive-list before)))
after))))
(def-complex-format-interpreter #\( (colonp atsignp params directives)
(let ((close (find-directive directives #\) nil)))
(unless close
(error 'format-error
:complaint "no corresponding close paren"))
(interpret-bind-defaults () params
(let* ((posn (position close directives))
(before (subseq directives 0 posn))
(after (nthcdr (1+ posn) directives))
(*print-case* (if colonp
(if atsignp
:upcase
:capitalize)
(if atsignp
:capitalize-first
:downcase))))
(setf args (interpret-directive-list stream before orig-args args))
after))))
Sorry for without any testing. The code above may break something.
Oh, I'm sorry, I had forgotten about the case printing the string.
*print-case* does not fit for it.
Hmmm.
force-output works!
(LAMBDA (STREAM &OPTIONAL
(FORMAT-ARG-149897
(ERROR 'FORMAT::FORMAT-ERROR
:COMPLAINT
"required argument missing"
:CONTROL-STRING
"~:<~W ~(~W~)~:>"
:OFFSET
2))
&REST FORMAT::ARGS)
(BLOCK NIL
(LET ((FORMAT::ARG FORMAT-ARG-149897))
(PPRINT-LOGICAL-BLOCK (STREAM FORMAT::ARG :PREFIX "(" :SUFFIX
")")
(LET ((FORMAT::ARGS FORMAT::ARG)
(FORMAT::ORIG-ARGS FORMAT::ARG))
(DECLARE (IGNORABLE FORMAT::ARGS
FORMAT::ORIG-ARGS))
(BLOCK NIL
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
4)
STREAM)
(WRITE-STRING " " STREAM)
(force-output stream) ; <---
(LET ((STREAM
(SYSTEM::MAKE-CASE-FROB-STREAM (IF (TYPEP STREAM
'XP::XP-STRUCTURE)
(XP::BASE-STREAM STREAM)
STREAM)
:DOWNCASE)))
(SYSTEM:OUTPUT-OBJECT (FORMAT::EXPANDER-PPRINT-NEXT-ARG "~:<~W ~(~W~)~:>"
9)
STREAM)))))))
FORMAT::ARGS)
(funcall * nil '(a b)) => (A b)