diff --git a/code/format.lisp b/code/format.lisp index 7547f45f43bcb44636c48e8958dddab53e8fe8b3..c68b18e7e93695e9b487beb1e8c6d2d8ccbfe454 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.20 1991/12/06 06:01:52 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.21 1991/12/16 10:04:05 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -187,14 +187,38 @@ ;;; (defvar *logical-block-popper* nil) -;;; *EXPANDER-NEXT-ARG-MACRO* and *PREVIOUS-NEXT-ARG-MACRO* -- internal. +;;; *EXPANDER-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 ~<...~:> +;;; Used by the expander stuff. This is bindable so that ~<...~:> ;;; can change it. ;;; (defvar *expander-next-arg-macro* 'expander-next-arg) +;;; *ONLY-SIMPLE-ARGS* -- internal. +;;; +;;; Used by the expander stuff. Initially starts as T, and gets set to NIL +;;; if someone needs to do something strange with the arg list (like use +;;; the rest, or something). +;;; +(defvar *only-simple-args*) + +;;; *ORIG-ARGS-AVAILABLE* -- internal. +;;; +;;; Used by the expander stuff. We do an initial pass with this as NIL. +;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try +;;; again with it bound to T. If this is T, we don't try to do anything +;;; fancy with args. +;;; +(defvar *orig-args-available* nil) + +;;; *SIMPLE-ARGS* -- internal. +;;; +;;; Used by the expander stuff. List of (symbol . offset) for simple args. +;;; +(defvar *simple-args*) + + + ;;;; FORMAT @@ -285,10 +309,29 @@ `#',(%formatter control-string)) (defun %formatter (control-string) - `(lambda (stream &rest orig-args) - (let ((args orig-args)) - ,(expand-control-string control-string) - args))) + (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) (let* ((string (etypecase string @@ -332,10 +375,18 @@ more-directives)))) (defun expand-next-arg (&optional offset) - `(,*expander-next-arg-macro* - ,*default-format-error-control-string* - ,(or offset *default-format-error-offset*))) - + (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 () + (when *only-simple-args* + )) ;;;; Format directive definition macros and runtime support. @@ -430,7 +481,9 @@ (case param (:arg `(or ,(expand-next-arg offset) ,,default)) - (:remaining '(length args)) + (:remaining + (setf *only-simple-args* nil) + '(length args)) ((nil) ,default) (t param)))))))) `(let ,(expander-bindings) @@ -917,15 +970,24 @@ (def-format-directive #\P (colonp atsignp params end) (expand-bind-defaults () params - (let ((arg (if colonp - `(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)))) - (expand-next-arg)))) + (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)))))) @@ -1421,6 +1483,8 @@ (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 @@ -1430,6 +1494,8 @@ :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) @@ -1445,6 +1511,7 @@ :offset ,(1- end))))))) (if params (expand-bind-defaults ((n 1)) params + (setf *only-simple-args* nil) `(dotimes (i ,n) ,(expand-next-arg))) (expand-next-arg))))) @@ -1498,7 +1565,9 @@ :control-string ,string :offset ,(1- end))))) ,(if atsignp - `(setf args (%format stream ,(expand-next-arg) orig-args args)) + (if *orig-args-available* + `(setf args (%format stream ,(expand-next-arg) orig-args args)) + (throw 'need-orig-args nil)) `(%format stream ,(expand-next-arg) ,(expand-next-arg)))))) (def-format-interpreter #\? (colonp atsignp params string end) @@ -1608,23 +1677,17 @@ :complaint "Can only specify one section") (expand-bind-defaults () params - `(let ((prev-args args) - (arg ,(expand-next-arg))) - (when arg - (setf args prev-args) - ,@(expand-directive-list (car sublists))))))) + (expand-maybe-conditional (car sublists))))) (if colonp (if (= (length sublists) 2) (expand-bind-defaults () params - `(if ,(expand-next-arg) - (progn - ,@(expand-directive-list (car sublists))) - (progn - ,@(expand-directive-list (cadr sublists))))) + (expand-true-false-conditional (car sublists) + (cadr sublists))) (error 'format-error :complaint "Must specify exactly two sections.")) (expand-bind-defaults ((index (expand-next-arg))) params + (setf *only-simple-args* nil) (let ((clauses nil)) (when last-semi-with-colon-p (push `(t ,@(expand-directive-list (pop sublists))) @@ -1637,6 +1700,75 @@ `(case ,index ,@clauses))))) remaining))) +(defun expand-maybe-conditional (sublist) + (flet ((hairy () + `(let ((prev-args args) + (arg ,(expand-next-arg))) + (when arg + (setf args prev-args) + ,@(expand-directive-list sublist))))) + (if *only-simple-args* + (multiple-value-bind + (guts new-args) + (let ((*simple-args* *simple-args*)) + (values (expand-directive-list sublist) + *simple-args*)) + (cond ((eq *simple-args* (cdr new-args)) + (setf *simple-args* new-args) + `(when ,(caar new-args) + ,@guts)) + (t + (setf *only-simple-args* nil) + (hairy)))) + (hairy)))) + +(defun expand-true-false-conditional (true false) + (let ((arg (expand-next-arg))) + (flet ((hairy () + `(if ,arg + (progn + ,@(expand-directive-list true)) + (progn + ,@(expand-directive-list false))))) + (if *only-simple-args* + (multiple-value-bind + (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) + (let ((*simple-args* *simple-args*) + (*only-simple-args* t)) + (values (expand-directive-list false) + *simple-args* + *only-simple-args*)) + (if (= (length true-args) (length false-args)) + `(if ,arg + (progn + ,@true-guts) + ,(do ((false false-args (cdr false)) + (true true-args (cdr true)) + (bindings nil (cons `(,(caar false) ,(caar true)) + bindings))) + ((eq true *simple-args*) + (setf *simple-args* true-args) + (setf *only-simple-args* + (and true-simple false-simple)) + (if bindings + `(let ,bindings + ,@false-guts) + `(progn + ,@false-guts))))) + (progn + (setf *only-simple-args* nil) + (hairy))))) + (hairy))))) + + + (def-complex-format-interpreter #\[ (colonp atsignp params directives) (multiple-value-bind (sublists last-semi-with-colon-p remaining) @@ -1718,7 +1850,9 @@ `(when ,(case (length params) (0 (if colonp '(null outside-args) - '(null args))) + (progn + (setf *only-simple-args* nil) + '(null args)))) (1 (expand-bind-defaults ((count 0)) params `(zerop ,count))) (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params @@ -1763,21 +1897,25 @@ (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)))) + (if *orig-args-available* + `((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)))) + (throw 'need-orig-args nil)) (let ((*up-up-and-out-allowed* colonp)) (expand-directive-list (subseq directives 0 posn))))) (compute-loop-aux (count) + (when atsignp + (setf *only-simple-args* nil)) `(loop ,@(unless closed-with-colon '((when (null args) @@ -1786,7 +1924,9 @@ `((when (and ,count (minusp (decf ,count))) (return)))) ,@(if colonp - (let ((*expander-next-arg-macro* 'expander-next-arg)) + (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)) @@ -1810,11 +1950,13 @@ (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)))))) + `(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)))))) (values (if (zerop posn) `(let ((inside-string ,(expand-next-arg))) ,(compute-bindings)) @@ -2132,6 +2274,7 @@ (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))) (pprint-logical-block (stream arg @@ -2142,7 +2285,9 @@ `((orig-args arg)))) (declare (ignorable args ,@(unless atsignp '(orig-args)))) (block nil - ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)) + ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) + (*only-simple-args* nil) + (*orig-args-available* t)) (expand-directive-list insides))))))) (defun interpret-format-logical-block