From 1cf5cd5ab8d38288acdba1efb0817945384c4b62 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Thu, 5 Dec 1991 05:08:33 +0000 Subject: [PATCH] Fixed lots of bugs introduced with rewrite. --- code/format.lisp | 542 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 370 insertions(+), 172 deletions(-) diff --git a/code/format.lisp b/code/format.lisp index 53625a88d..38b4145b3 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.18 1991/12/02 23:58:27 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.19 1991/12/05 05:08:33 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -19,7 +19,7 @@ (in-package "FORMAT") (use-package "EXT") -(import 'kernel:index) +(use-package "KERNEL") (in-package "LISP") (export '(format formatter)) @@ -38,10 +38,10 @@ (defun %print-format-directive (struct stream depth) (declare (ignore depth)) - (format stream "#<~A>" - (subseq (format-directive-string struct) - (format-directive-start struct) - (format-directive-end struct)))) + (print-unreadable-object (struct stream) + (write-string (format-directive-string struct) stream + :start (format-directive-start struct) + :end (format-directive-end struct)))) (defvar *format-directive-expanders* (make-array char-code-limit :initial-element nil)) @@ -170,7 +170,30 @@ :colonp colonp :atsignp atsignp :params (nreverse params)))))) + +;;;; Specials used to communicate information. + +;;; *UP-UP-AND-OUT-ALLOWED* -- internal. +;;; +;;; Used both by the expansion stuff and the interpreter stuff. When it is +;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. +;;; +(defvar *up-up-and-out-allowed* nil) +;;; *LOGICAL-BLOCK-POPPER* -- internal. +;;; +;;; Used by the interpreter stuff. When it non-NIL, its a function that will +;;; invoke PPRINT-POP in the right lexical environemnt. +;;; +(defvar *logical-block-popper* nil) + +;;; *EXPANDER-NEXT-ARG-MACRO* and *PREVIOUS-NEXT-ARG-MACRO* -- internal. +;;; +;;; Used the the expander stuff. In expand-directive, splice in a macrolet +;;; of next-arg that invokes this macro. This is bindable so that ~<...~:> +;;; can change it. +;;; +(defvar *expander-next-arg-macro* 'expander-next-arg) ;;;; FORMAT @@ -222,7 +245,8 @@ string-or-fun) (string (coerce string-or-fun 'simple-string)))) - (*default-format-error-control-string* string)) + (*default-format-error-control-string* string) + (*logical-block-popper* nil)) (interpret-directive-list stream (tokenize-control-string string) orig-args args))))) @@ -266,9 +290,6 @@ ,(expand-control-string control-string) args))) -(eval-when (compile load eval) - (defvar *current-directive-offset* nil)) - (defun expand-control-string (string) (let* ((string (etypecase string (simple-string @@ -277,9 +298,8 @@ (coerce string 'simple-string)))) (*default-format-error-control-string* string) (directives (tokenize-control-string string))) - `(let ((*default-format-error-control-string* ',string)) - (block nil - ,@(expand-directive-list directives))))) + `(block nil + ,@(expand-directive-list directives)))) (defun expand-directive-list (directives) (let ((results nil) @@ -300,37 +320,61 @@ (format-directive (let ((expander (aref *format-directive-expanders* - (char-code (format-directive-character directive))))) + (char-code (format-directive-character directive)))) + (*default-format-error-offset* + (1- (format-directive-end directive)))) (if expander - (let* ((offset (1- (format-directive-end directive))) - (*default-format-error-offset* offset)) - (multiple-value-bind - (form directives) - (funcall expander directive more-directives) - (values `(compiler-let - ((*current-directive-offset* ',offset)) - ,form) - directives))) + (funcall expander directive more-directives) (error 'format-error - :complaint "Unknown directive." - :control-string (format-directive-string directive) - :offset (1- (format-directive-end directive)))))) + :complaint "Unknown directive.")))) (simple-string (values `(write-string ,directive stream) more-directives)))) +(defun expand-next-arg (&optional offset) + `(,*expander-next-arg-macro* + ,*default-format-error-control-string* + ,(or offset *default-format-error-offset*))) + + ;;;; 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))) + (eval-when (compile eval) +;;; NEXT-ARG -- internal. +;;; +;;; 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) - `(if args - (pop args) + `(progn + (when (null args) (error 'format-error :complaint "No more arguments." - ,@(when (or offset *current-directive-offset*) - `(:offset ,(or offset *current-directive-offset*)))))) + ,@(when offset + `(:offset ,offset)))) + (when *logical-block-popper* + (funcall *logical-block-popper*)) + (pop args))) (defmacro def-complex-format-directive (char lambda-list &body body) (let ((defun-name (intern (format nil "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER" @@ -371,31 +415,39 @@ (defmacro expand-bind-defaults (specs params &body body) (once-only ((params params)) - (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 (next-arg ,offset) ,,default)) - (:remaining '(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))))) + (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 '(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 ((defun-name @@ -508,15 +560,20 @@ (def-format-directive #\A (colonp atsignp params) (if params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) params - `(format-princ stream (next-arg) ',colonp ',atsignp + `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp ,mincol ,colinc ,minpad ,padchar)) - `(princ ,(if colonp '(or (next-arg) "()") '(next-arg)) stream))) + `(princ ,(if colonp + `(or ,(expand-next-arg) "()") + (expand-next-arg)) + stream))) (def-format-interpreter #\A (colonp atsignp params) (if params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) params (format-princ stream (next-arg) colonp atsignp mincol colinc minpad padchar)) @@ -531,21 +588,23 @@ (def-format-directive #\S (colonp atsignp params) (cond (params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) params - `(format-prin1 stream (next-arg) ,colonp ,atsignp + `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp ,mincol ,colinc ,minpad ,padchar))) (colonp - `(let ((arg (next-arg))) + `(let ((arg ,(expand-next-arg))) (if arg (prin1 arg stream) (princ "()" stream)))) (t - '(prin1 (next-arg) stream)))) + `(prin1 ,(expand-next-arg) stream)))) (def-format-interpreter #\S (colonp atsignp params) (cond (params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) + (padchar #\space)) params (format-prin1 stream (next-arg) colonp atsignp mincol colinc minpad padchar))) @@ -560,10 +619,10 @@ (def-format-directive #\C (colonp atsignp params) (expand-bind-defaults () params (if colonp - '(format-print-named-character (next-arg) stream) + `(format-print-named-character ,(expand-next-arg) stream) (if atsignp - '(prin1 (next-arg) stream) - '(write-char (next-arg) stream))))) + `(prin1 ,(expand-next-arg) stream) + `(write-char ,(expand-next-arg) stream))))) (def-format-interpreter #\C (colonp atsignp params) (interpret-bind-defaults () params @@ -586,18 +645,21 @@ (def-format-directive #\W (colonp atsignp params) (expand-bind-defaults () params - `(write (next-arg) :stream stream - ,@(when colonp - '(:pretty t)) - ,@(when atsignp - '(:level nil :length nil))))) + (if (or colonp atsignp) + `(let (,@(when colonp + '((*print-pretty* t))) + ,@(when atsignp + '((*print-level* nil) + (*print-length* nil)))) + (output-object ,(expand-next-arg) stream)) + `(output-object ,(expand-next-arg) stream)))) (def-format-interpreter #\W (colonp atsignp params) (interpret-bind-defaults () params (let ((*print-pretty* (or colonp *print-pretty*)) (*print-level* (and atsignp *print-level*)) (*print-length* (and atsignp *print-length*))) - (write (next-arg) :stream stream)))) + (output-object (next-arg) stream)))) ;;;; Integer outputting. @@ -643,9 +705,11 @@ (expand-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))) + `(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))) (defmacro interpret-format-integer (base) `(if (or colonp atsignp params) @@ -686,15 +750,16 @@ ((base 10) (mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) params - `(format-print-integer stream (next-arg) ,colonp ,atsignp ,base ,mincol + `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp + ,base ,mincol ,padchar ,commachar ,commainterval)) (if atsignp (if colonp - '(format-print-old-roman stream (next-arg)) - '(format-print-roman stream (next-arg))) + `(format-print-old-roman stream ,(expand-next-arg)) + `(format-print-roman stream ,(expand-next-arg))) (if colonp - '(format-print-ordinal stream (next-arg)) - '(format-print-cardinal stream (next-arg)))))) + `(format-print-ordinal stream ,(expand-next-arg)) + `(format-print-cardinal stream ,(expand-next-arg)))))) (def-format-interpreter #\R (colonp atsignp params) (if params @@ -860,7 +925,7 @@ (do ((arg-ptr orig-args (cdr arg-ptr))) ((eq (cdr arg-ptr) args) (car arg-ptr)))) - '(next-arg)))) + (expand-next-arg)))) (if atsignp `(write-string (if (eql ,arg 1) "y" "ies") stream) `(unless (eql ,arg 1) (write-char #\s stream)))))) @@ -888,14 +953,15 @@ :complaint "Cannot specify the colon modifier with this directive.")) (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params - `(format-fixed stream (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 (error 'format-error :complaint "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params + (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + params (format-fixed stream (next-arg) w d k ovf pad atsignp))) (defun format-fixed (stream number w d k ovf pad atsign) @@ -961,7 +1027,7 @@ (expand-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 + `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) (def-format-interpreter #\E (colonp atsignp params) @@ -1055,7 +1121,7 @@ (expand-bind-defaults ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil)) params - `(format-general stream (next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) + `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) (def-format-interpreter #\G (colonp atsignp params) (when colonp @@ -1111,7 +1177,8 @@ (def-format-directive #\$ (colonp atsignp params) (expand-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 ,(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 @@ -1289,23 +1356,25 @@ (write-string spaces stream :end n))) (defun format-relative-tab (stream colrel colinc) - (let* ((cur (lisp::charpos stream)) - (spaces (if (and cur (plusp colinc)) - (- (* (ceiling (+ cur colrel) colinc) colinc) cur) - colrel))) - (output-spaces stream spaces))) + (if (pp:pretty-stream-p stream) + (pprint-tab :line-relative colrel colinc stream) + (let* ((cur (lisp::charpos stream)) + (spaces (if (and cur (plusp colinc)) + (- (* (ceiling (+ cur colrel) colinc) colinc) cur) + colrel))) + (output-spaces stream spaces)))) (defun format-absolute-tab (stream colnum colinc) - (let ((cur (lisp::charpos stream))) - (cond ((null cur) - (write-string " " stream)) - ((< cur colnum) - (output-spaces stream (- colnum cur))) - (t - (unless (zerop colinc) - (let ((rem (rem cur colinc))) - (unless (zerop rem) - (output-spaces stream (- colinc rem))))))))) + (if (pp:pretty-stream-p stream) + (pprint-tab :line colnum colinc stream) + (let ((cur (lisp::charpos stream))) + (cond ((null cur) + (write-string " " stream)) + ((< cur colnum) + (output-spaces stream (- colnum cur))) + (t + (unless (zerop colinc) + (output-spaces stream (- colinc (rem cur colinc))))))))) (def-format-directive #\_ (colonp atsignp params) (expand-bind-defaults () params @@ -1377,8 +1446,8 @@ (if params (expand-bind-defaults ((n 1)) params `(dotimes (i ,n) - (next-arg))) - '(next-arg))))) + ,(expand-next-arg))) + (expand-next-arg))))) (def-format-interpreter #\* (colonp atsignp params) (if atsignp @@ -1429,8 +1498,8 @@ :control-string ,string :offset ,(1- end))))) ,(if atsignp - '(setf args (%format stream (next-arg) orig-args args)) - '(%format stream (next-arg) (next-arg)))))) + `(setf args (%format stream ,(expand-next-arg) orig-args args)) + `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) (def-format-interpreter #\? (colonp atsignp params string end) (when colonp @@ -1540,14 +1609,14 @@ "Can only specify one section") (expand-bind-defaults () params `(let ((prev-args args) - (arg (next-arg))) + (arg ,(expand-next-arg))) (when arg (setf args prev-args) ,@(expand-directive-list (car sublists))))))) (if colonp (if (= (length sublists) 2) (expand-bind-defaults () params - `(if (next-arg) + `(if ,(expand-next-arg) (progn ,@(expand-directive-list (car sublists))) (progn @@ -1555,7 +1624,7 @@ (error 'format-error :complaint "Must specify exactly two sections.")) - (expand-bind-defaults ((index '(next-arg))) params + (expand-bind-defaults ((index (expand-next-arg))) params (let ((clauses nil)) (when last-semi-with-colon-p (push `(t ,@(expand-directive-list (pop sublists))) @@ -1636,7 +1705,6 @@ ;;;; Up-and-out. -(defvar *up-up-and-out-allowed* nil) (defvar *outside-args*) (def-format-directive #\^ (colonp atsignp params) @@ -1690,60 +1758,67 @@ :complaint "No corresponding close brace.")) (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives)) - (insides - (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))))) - (setf args (%format stream inside-string orig-args args)))) - (let ((*up-up-and-out-allowed* colonp)) - (expand-directive-list (subseq directives 0 posn)))))) - (flet ((compute-loop (count) - `(loop - ,@(unless closed-with-colon - '((when (null args) - (return)))) - ,@(when count - `((when (and ,count (minusp (decf ,count))) - (return)))) - ,@(if colonp - `((let* ((orig-args (next-arg)) + (posn (position close directives))) + (labels + ((compute-insides () + (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))))) + (setf args + (%format stream inside-string orig-args args)))) + (let ((*up-up-and-out-allowed* colonp)) + (expand-directive-list (subseq directives 0 posn))))) + (compute-loop-aux (count) + `(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)) + `((let* ((orig-args ,(expand-next-arg)) (outside-args args) (args orig-args)) (declare (ignorable orig-args outside-args args)) (block nil - ,@insides))) - insides) - ,@(when closed-with-colon - '((when (null args) - (return))))))) - (let ((loop - (if params - (expand-bind-defaults ((count nil)) params - (compute-loop count)) - (compute-loop nil)))) - (setf loop - `(block ,(if colonp 'outside-loop nil) - ,loop)) - (unless atsignp - (setf loop - `(let* ((orig-args (next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,loop))) - (when (zerop posn) - (setf loop - `(let ((inside-string (next-arg))) - ,loop))) - (values loop (nthcdr (1+ posn) directives))))))) + ,@(compute-insides))))) + (compute-insides)) + ,@(when closed-with-colon + '((when (null args) + (return)))))) + (compute-loop () + (if params + (expand-bind-defaults ((count nil)) params + (compute-loop-aux count)) + (compute-loop-aux nil))) + (compute-block () + (if colonp + `(block outside-loop + ,(compute-loop)) + (compute-loop))) + (compute-bindings () + (if atsignp + (compute-block) + (let ((*expander-next-arg-macro* 'expander-next-arg)) + `(let* ((orig-args ,(expand-next-arg)) + (args orig-args)) + (declare (ignorable orig-args args)) + ,(compute-block)))))) + (values (if (zerop posn) + `(let ((inside-string ,(expand-next-arg))) + ,(compute-bindings)) + (compute-bindings)) + (nthcdr (1+ posn) directives)))))) (def-complex-format-interpreter #\{ (colonp atsignp params string end directives) @@ -1778,6 +1853,7 @@ (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) @@ -1796,7 +1872,8 @@ args))) (if atsignp (setf args (do-loop orig-args args)) - (let ((arg (next-arg))) + (let ((arg (next-arg)) + (*logical-block-popper* nil)) (do-loop arg arg))) (nthcdr (1+ posn) directives)))))) @@ -1812,27 +1889,36 @@ ;;;; Justification. -(def-complex-format-directive #\< (colonp atsignp params directives) +(def-complex-format-directive #\< (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (values (if (format-directive-colonp close) - (expand-format-logical-block segments colonp atsignp - first-semi close params) + (multiple-value-bind + (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 + suffix atsignp)) (expand-format-justification segments colonp atsignp first-semi params)) remaining))) -(def-complex-format-interpreter #\< (colonp atsignp params directives) +(def-complex-format-interpreter #\< + (colonp atsignp params string end directives) (multiple-value-bind (segments first-semi close remaining) (parse-format-justification directives) (setf args (if (format-directive-colonp close) - (interpret-format-logical-block stream orig-args args - segments colonp atsignp - first-semi close params) + (multiple-value-bind + (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 + prefix per-line-p insides + suffix atsignp)) (interpret-format-justification stream orig-args args segments colonp atsignp first-semi params))) @@ -1963,6 +2049,118 @@ (when pad-right (do-padding))))) +(defun parse-format-logical-block + (segments colonp first-semi close params string end) + (when params + (error 'format-error + :complaint "No parameters can be supplied with ~~<...~~:>." + :offset (caar params))) + (multiple-value-bind + (prefix insides suffix) + (multiple-value-bind (prefix-default suffix-default) + (if colonp (values "(" ")") (values nil nil)) + (flet ((extract-string (list prefix-p) + (let ((directive (find-if #'format-directive-p list))) + (if directive + (error 'format-error + :complaint + "Cannot include format directives inside the ~ + ~:[suffix~;prefix~] segment of ~~<...~~:>" + :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 ~~<...~~:>."))))) + (when (format-directive-atsignp close) + (setf insides + (add-fill-style-newlines insides + string + (if first-semi + (format-directive-end first-semi) + end)))) + (values prefix + (and first-semi (format-directive-atsignp first-semi)) + insides + suffix))) + +(defun add-fill-style-newlines (list string offset) + (if list + (let ((directive (car list))) + (if (simple-string-p directive) + (nconc (add-fill-style-newlines-aux directive string offset) + (add-fill-style-newlines (cdr list) + string + (+ offset (length directive)))) + (cons directive + (add-fill-style-newlines (cdr list) + string + (format-directive-end directive))))) + nil)) + +(defun add-fill-style-newlines-aux (literal string offset) + (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)))) + +(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) + `(let ((arg ,(if atsignp 'args (expand-next-arg)))) + ,@(when atsignp + '((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)))) + (declare (ignorable args ,@(unless atsignp '(orig-args)))) + (block nil + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)) + (expand-directive-list insides))))))) + +(defun interpret-format-logical-block + (stream orig-args args prefix per-line-p insides suffix atsignp) + (let ((arg (if atsignp args (next-arg)))) + (if per-line-p + (pprint-logical-block + (stream arg :per-line-prefix prefix :suffix suffix) + (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg))) + (pprint-logical-block (stream arg :prefix prefix :suffix suffix) + (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) + (interpret-directive-list stream insides + (if atsignp orig-args arg) + arg))))) + (if atsignp nil args)) + (def-complex-format-directive #\> () (error 'format-error :complaint "No corresponding open bracket.")) @@ -1978,11 +2176,11 @@ (param-names param-name) (bindings `(,param-name ,(case param - (:arg '(next-arg)) + (:arg (expand-next-arg)) (:remaining '(length args)) (t param)))))) `(let ,(bindings) - (,symbol stream (next-arg) ,colonp ,atsignp + (,symbol stream ,(expand-next-arg) ,colonp ,atsignp ,@(param-names)))))) (def-format-interpreter #\/ (string start end colonp atsignp params) @@ -2010,7 +2208,7 @@ (first-colon (position #\: name)) (last-colon (if first-colon (position #\: name :from-end t))) (package-name (if last-colon - (subseq name (1+ last-colon)) + (subseq name 0 first-colon) "USER")) (package (find-package package-name))) (unless package @@ -2018,7 +2216,7 @@ :complaint "No package named ``~A''." :arguments (list package-name))) (intern (if first-colon - (subseq name 0 first-colon) + (subseq name (1+ first-colon)) name) package)))) -- GitLab