LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760030344. :SYSTEM-TYPE :LOGICAL :VERSION 6. :TYPE "LISP" :NAME "FORMAT-MACRO" :DIRECTORY ("REL3-SOURCE" "COMPILER") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758302518. :AUTHOR "REL3" :LENGTH-IN-BYTES 25530. :LENGTH-IN-BLOCKS 25. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ;; -*- Mode:Common-Lisp; Package:FORMAT; Base:10. -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;;;;; Copyright (C) 1986,1987 Texas Instruments Incorporated. All rights reserved.;; Function for printing or creating nicely formatted strings.;; written by Andrew L. Ressler on September 8, 1982;; copyright LISP MACHINE INC.;; permission granted to anyone to use this or modify it.;; attempt to turn format into a macro facility;; if it can't do it easily it just makes it call format instead.;;  6/25/86 DNG - Modified for use as a compiler optimizer; fixed to be re-entrant;;;updated programming style; fix so (FORMAT T ...) returns NIL.;; 10/13/86 DNG - Suppress some of the lengthier optimizations if SPEED is not ;;more important than space.  Use WARN-ON-ERRORS.;; 11/10/86 DNG - Replace uses of MEMQ; add TRY-INLINE declaration for FORMAT-CTL-REPEAT-CHAR.;; 11/11/86 DNG - Use WRITE-CHAR instead of a WRITE-STRING of length 1.;;Change OPTIMIZE-LETS from T to NIL. ;; 11/14/86 DNG - Quit optimizing when a non-constant parameter is encountered.;;  3/13/87 DNG - Re-introduce a definition for TICL:FORMAT-MACRO for compatibility.(defvar format-results) (defvar alt-eval-immediate)  (defvar final-format-results)(defvar inside-conditional nil)(defvar optimize-lets nil) ; turn this off since it doesn't seem to do anything but waste time(proclaim '(compiler:try-inline format-get-stream format-ctl-repeat-char))(defun speed-over-space-p ()  compiler2:(> (opt-speed optimize-switch)       (opt-space optimize-switch)))(defmacro format-macro (&rest args)  "Like FORMAT, but use in-line code as much as possible."  ;;  3/13/87 DNG   (declare (arglist stream ctl-string &rest args))  (unless (boundp 'compiler2:p1value)    (setq compiler2:p1value t))  (cons (if (if compiler2:compiler-queue compiler2:compiling-common-lisp (common-lisp-on-p))    'common-lisp-format-macro  'zetalisp-format-macro)args))(defmacro zetalisp-format-macro (stream ctl-string &rest args)  (prog (( final-format-results nil ))    (let ((format-arglist args)  (format-ctl-one-arg-prop nil)  (alt-eval-immediate nil)  (loop-arglist nil)  (value))      (setq value    (catch 'impossible      (catch '|FORMAT-:^-POINT|(catch 'format-^-point  (cond    ((stringp ctl-string) (format-ctl-string-macro args ctl-string))    (t (return `(global:format ,stream ,ctl-string ,@args))))))))      (if (eq value 'impossible)(return `(global:format ,stream ,ctl-string ,@args))))    (return     (let*((stream-symbol (gensym))   (result    (cond      ((null stream)       `(let ((format-string (get-format-string))      (*standard-output* 'format-string-stream))  ,@(nreverse final-format-results)  (prog1    (copy-seq (the string format-string))    (return-format-string format-string))))      ((or (eq t stream)  (and (consp stream) (eq (first stream) 'quote) (eq (second stream) t)))       `(progn  ,.(nreverse final-format-results) nil))      (t (si:sublis-eval-once`((,stream-symbol . ,stream))   `(let ((format-string nil)(*standard-output* (format-get-stream ,stream-symbol)))    ,@(nreverse final-format-results)    (and (null ,stream-symbol)(format-return-string-stream ))))))))       (if optimize-lets (setq result (elim-lets result)) result)))))  (compiler2:add-optimizer cli:format common-lisp-format-optimizer)(deff-macro common-lisp-format-macro '(macro . common-lisp-format-optimizer))(defun common-lisp-format-optimizer ( form &optional environment )  (declare (ignore environment))  (let (( stream (second form) )( ctl-string (third form) )( args (cdddr form) )( final-format-results nil ))    (when (and (consp ctl-string)       (eq (first ctl-string) 'quote)       (stringp (second ctl-string)))      (setf ctl-string (second ctl-string)))    (if (or (not (stringp ctl-string))    compiler2:(> (opt-compilation-speed optimize-switch) (opt-speed optimize-switch))    compiler2:(> (opt-safety optimize-switch) (opt-speed-or-space optimize-switch))    (eq 'impossible(let ((format-arglist args)      (format-ctl-one-arg-prop 'format-ctl-common-lisp-one-arg)      (alt-eval-immediate 'common-lisp-eval-immediate)      (loop-arglist nil))  (catch 'impossible    (catch '|FORMAT-:^-POINT|      (catch 'format-^-point(compiler2:warn-on-errors ('bad-format "Error in ~S:" form)  (throw 'impossible    (format-ctl-string-macro args ctl-string)))'impossible))))))(if (eq (first form) 'format)    form  (cons 'format (cdr form)))      (let* ((stream-symbol (gensym))     (result      (cond((or (eq stream 'nil)     (equal stream '(quote nil))) (unless (or (speed-over-space-p) (neq (first form) 'format))   (return-from common-lisp-format-optimizer form)) `(let ((format-string (get-format-string ))(*standard-output* 'format-string-stream))    ,@(nreverse final-format-results)    (prog1      (copy-seq (the string format-string))      (return-format-string format-string))))((or (eq stream 't)     (equal stream '(quote t))     (eq stream '*standard-output*)) `(progn ,@(nreverse final-format-results) nil))((and (or (not (symbolp stream))  (get stream 'special))      (compiler2:expr-type-p stream 'stream)) `(let ((*standard-output* ,stream))    ,@(nreverse final-format-results)    nil))((and (not (speed-over-space-p))      (eq (first form) 'format)) (return-from common-lisp-format-optimizer form))((null compiler2:p1value) (si:sublis-eval-once `((,stream-symbol . ,stream))   `(and ,stream-symbol (let* ((format-string nil)(*standard-output* (format-get-stream ,stream-symbol)))   ,@(nreverse final-format-results)   nil))))(t (si:sublis-eval-once`((,stream-symbol . ,stream))   `(let* ((format-string nil)   (*standard-output* (format-get-stream ,stream-symbol)))    ,@(nreverse final-format-results)    (and (null ,stream-symbol) (format-return-string-stream ))))))))(if optimize-lets    (setq result (elim-lets result))  result)))))(defun format-ctl-string-macro (args ctl-string &aux (format-params nil))  ;; 11/11/86 DNG - Use WRITE-CHAR instead of a WRITE-STRING of length 1.  ;; 11/14/86 DNG - Quit optimizing when a non-constant parameter is encountered.  (unwind-protect (do   ((ctl-index 0) (ctl-length (array-active-length ctl-string)) (tem))   ((>= ctl-index ctl-length))   (setq tem (si:%string-search-char #\~ ctl-string ctl-index ctl-length))   (cond     ((neq tem ctl-index);Put out some literal string      (push(let ((end (if (null tem)       (length ctl-string)     tem)))  (if (= end (1+ ctl-index))      `(write-char ',(char ctl-string ctl-index))    `(write-string ,(subseq (the string ctl-string) ctl-index end))))       final-format-results)      (if (null tem)(return))      (setq ctl-index tem)))   ;; (AREF CTL-STRING CTL-INDEX) is a tilde.   (let ((atsign-flag nil) (colon-flag nil) (format-results nil) (flush-let nil))     (if (null format-params)       (setq format-params (get-format-params)))     (store-array-leader 0 format-params 0)     (multiple-value-setq (tem args)       (format-parse-command args t))     (loop for i from 0 below (length format-params)   do (let ((parm (aref format-params i)))(cond ((numberp parm))      ((constantp parm)       (setf (aref format-params i)     (compiler2:eval-for-target parm)))      ;; else non-constant parameter can only be handled at run-time      (t (throw 'impossible 'impossible)))))     (multiple-value-setq (args flush-let)       (format-ctl-op-macro tem args (g-l-p format-params)))     (when (and (eq (car-safe (first format-results)) 'let)(not (speed-over-space-p)))       (throw 'impossible 'impossible))     (if flush-let       (push (cons 'progn (nreverse format-results)) final-format-results)       (push`(progn           ,@(nreverse format-results))final-format-results))))    (and format-params (return-format-params format-params)))  args)  ;Perform a single formatted output operation on specified args.;Return the remaining args not used up by the operation.(defun format-ctl-op-macro (op args params &aux tem immediate)  (declare (special tem))  (cond    ((null op) (format-error "Undefined FORMAT command.") args);e.g. not interned    ((setq tem   (or (and format-ctl-one-arg-prop (get op format-ctl-one-arg-prop))      (get op 'format-ctl-one-arg)))     (if (setq immediate    (or (and alt-eval-immediate (get op alt-eval-immediate)) (get op 'eval-immediate)))       (progn (funcall immediate (car args) params) (values (cdr args) t))       (progn (push `(let ((atsign-flag ',atsign-flag)      (colon-flag ',colon-flag))  (funcall ',tem ,(copy-tree (first args)) ',(copy-tree params)))       format-results) (cdr args))))    ((setq tem (get op 'format-ctl-no-arg))     (if (setq immediate (get op 'eval-immediate))       (progn (funcall immediate params) (values args t))       (progn (push `(let ((atsign-flag ',atsign-flag)      (colon-flag ',colon-flag))  (funcall ',tem ',(copy-tree params)))       format-results) args)))    ((setq tem (get op 'format-ctl-multi-arg))     (if (setq immediate (get op 'eval-immediate))       (values (funcall immediate args params) t)       (push `(let ((atsign-flag ',atsign-flag)    (colon-flag ',colon-flag))(funcall ',tem ,(copy-tree args) ,(copy-tree params))) format-results)))    ((setq tem (get op 'format-ctl-repeat-char))     (push `(format-ctl-repeat-char ,(copy-tree (or (first params) 1)) ,tem) format-results)     (values args t))    (t (format-error "\"~S\" is not defined as a FORMAT command." op) args)))  (defprop * format-ctl-ignore-macro eval-immediate)  (defun format-ctl-ignore-macro (args params &aux (count (or (car params) 1)))  (cond    (atsign-flag (nthcdr count format-arglist))    (colon-flag     (do ((a format-arglist (cdr a))  (b (nthcdr count format-arglist) (cdr b))) ((null a)  (format-error "Can't back up properly for a ~:*"))       (and (eq b args) (return a))))    (t (nthcdr count args)))) (defprop crlf crlf-macro eval-immediate)  (defun crlf-macro (ignore)  (and atsign-flag (push '(terpri) format-results)))  (defprop % format-ctl-newlines-macro eval-immediate)  (defun format-ctl-newlines-macro (params &aux (count (or (car params) 1)))  (push (if (= count 1)    '(terpri  )    `(write-string ,(make-string count :initial-element  #\NEWLINE) ))format-results))(defprop & format-ctl-fresh-line-macro eval-immediate)  (defun format-ctl-fresh-line-macro (params &aux (count (or (car params) 1)))  (push '(fresh-line) format-results)  (when (> count 1 )    (push `(write-string ,(make-string (1- count) :initial-element #\NEWLINE) )  format-results)))(defprop ? format-?-macro eval-immediate) (defun format-?-macro (&rest ignore)  (throw 'impossible 'impossible)) (defprop |(| |FORMAT-(-MACRO| eval-immediate) (defun |FORMAT-(-MACRO| (&rest ignore)  (throw 'impossible 'impossible)) (defprop x format-ctl-hex-macro common-lisp-eval-immediate) (defun format-ctl-hex-macro (arg params)  (format-ctl-decimal-macro arg params 16)) (defprop d format-ctl-decimal-macro eval-immediate)  (defun format-ctl-decimal-macro (arg params &optional (*print-base* 10);Also called for octal      &aux (width (first params)) (padchar (second params)) (commachar (third params))      (gen-arg (gensym)))  (declare (special tem))  (setq padchar(cond  ((null padchar) #\SPACE)  ((numberp padchar) padchar)  (t (aref (string padchar) 0)))commachar(cond  ((null commachar) #\,)  ((numberp commachar) commachar)  (t (aref (string commachar) 0))))  (if (or width colon-flag)      (push `(let ((atsign-flag ',atsign-flag)       (colon-flag ',colon-flag))       (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))    format-results)      (push`(let ((*print-base* ,*print-base*)       (*nopoint t)       (,gen-arg ,arg))   ,@(if atsign-flag `((if (and (numberp ,gen-arg) (not (minusp ,gen-arg)))       (write-char #\+))) ())   (princ ,gen-arg))   format-results))) (defprop o format-ctl-octal-macro eval-immediate)  (defun format-ctl-octal-macro (arg params)  (format-ctl-decimal-macro arg params 8))  (defprop f format-ctl-f-format-macro eval-immediate)  (defun format-ctl-f-format-macro (arg params)  (push   `(let ((arg ,arg))      (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))      (if (not (floatp arg)),(let ((format-results nil))   (format-ctl-decimal-macro 'arg ())   format-results)(si::print-flonum arg *standard-output* () (small-floatp arg) ,(first params) ())))   format-results))  (defprop e format-ctl-e-format-macro eval-immediate)  (defun format-ctl-e-format-macro (arg params)  (push   `(let ((arg ,arg))      (and (numberp arg) (not (floatp arg)) (setq arg (float arg)))      (if (not (floatp arg)),(let ((format-results nil))   (format-ctl-decimal-macro 'arg ())   format-results)(si::print-flonum arg *standard-output* () (small-floatp arg) ,(first params) t)))   format-results))  (defprop e format-ctl-hairy-macro common-lisp-eval-immediate) (defprop f format-ctl-hairy-macro common-lisp-eval-immediate) (defprop g format-ctl-hairy-macro common-lisp-eval-immediate) (defun format-ctl-hairy-macro (arg &optional params)  (declare (special tem))  (push `(let ((atsign-flag ',atsign-flag)       (colon-flag ',colon-flag))       (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))  format-results))(defprop a format-ctl-ascii-macro eval-immediate)  (defun format-ctl-ascii-macro (arg params &optional prin1p)  (let ((edge (car params))(padchar (cadddr params)))    (declare (special tem))    (if edge(push `(let ((atsign-flag ',atsign-flag)       (colon-flag ',colon-flag)) (funcall ',tem ,(copy-tree arg) ',(copy-tree params)))      format-results)(progn   (cond    ((null padchar) (setq padchar #\SPACE))    ((not (numberp padchar)) (setq padchar (character padchar))))  (cond    (atsign-flag);~@5nA right justifies    (colon-flag     (if prin1p (push   `(prin1 ,arg)   format-results) (push   `(princ ,arg)   format-results)))    (prin1p (push `(prin1 ,arg) format-results))    (t     (push `(princ ,arg)   format-results)))  (cond    ((null atsign-flag))    (colon-flag     (if prin1p (push   `(prin1 ,arg)   format-results) (push   `(princ ,arg)   format-results)))    (prin1p (push `(prin1 ,arg) format-results))    (t     (push `(princ ,arg)   format-results)))))))(defprop s format-ctl-sexp-macro eval-immediate)  (defun format-ctl-sexp-macro (arg params)  (format-ctl-ascii-macro arg params t))  (defprop g format-ctl-goto-macro eval-immediate)  (defun format-ctl-goto-macro (ignore params &aux (count (or (car params) 1)))  (nthcdr count format-arglist))  (defprop p format-ctl-plural-macro eval-immediate)  (defun format-ctl-plural-macro (args ignore)  (and colon-flag (setq args (format-ctl-ignore-macro args ())));crock: COLON-FLAG is set  (if atsign-flag    (push     `(if (equal ,(car args) 1)(write-char #\y)(write-string "ies" ))     format-results)    (push `(or (equal ,(car args) 1) (write-char #\s)) format-results))  (cdr args))  (defprop q format-ctl-apply-macro eval-immediate)  (defun format-ctl-apply-macro (arg params)  (push `(apply ,arg ,params) format-results))  (defun format-ctl-hairy-macro-no-arg (&optional params)  (declare (special tem))  (push `(let ((atsign-flag ',atsign-flag)       (colon-flag ',colon-flag))       (funcall ',tem  ',(copy-tree params)))  format-results));;; PHD 6/30/86, turned TAB optimizer off, there is too much code generated.(defprop t format-ctl-hairy-macro-no-arg  eval-immediate)  (defun format-ctl-tab-macro (params &aux (dest (or (first params) 1)) (extra (or (second params) 1)))  (push   `(let ((ops (send *standard-output* :which-operations))       (incr-ok))   (cond     ((or (setq incr-ok (member :increment-cursorpos ops :test #'eq)) (member :set-cursorpos ops :test #'eq))      (multiple-value-bind (x y)(send *standard-output* :read-cursorpos ,(if colon-flag   :pixel   :character))(let ((new-x       (if (< x ,dest) ,dest ,(if (eql extra 1)    '(1+ x)    `(* (1+ (floor x ,extra)) ,extra)))))  (cond    (incr-ok     (send *standard-output* :increment-cursorpos (- new-x x) 0,(if colon-flag   :pixel   :character)))    (t     (send *standard-output* :set-cursorpos new-x y ,(if colon-flag       :pixel       :character)))))))     (t (write-string  "   "))))    format-results))  (defprop [ format-ctl-start-case-macro eval-immediate)  (defun format-ctl-start-case-macro (args params &aux (arg (car args)))  (let ((inside-conditional t))    (let ((clauses (format-parse-clauses '] t))  (remaining-args 'no-args)  (default nil))      (cond(colon-flag (cond   (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))   (t (pop args))))(atsign-flag (throw 'impossible    'impossible))(t (pop args)))      (push       `(let ((arg       ,(cond  (colon-flag   (cond     (atsign-flag (format-error "~~:@[ is not a defined FORMAT command"))     (t `(if ,arg   1   0))))  (atsign-flag `(if ,arg  0  -1))  ((car params) (car params))  (t arg))))  (cond    . ,(loop for clause on (g-l-p clauses) by #'cdddr for clause-number from 0 as string  = (first clause) as code =  (let* ((final-format-results nil) (arguments (format-ctl-string-macro args string)))    (if (or (eq remaining-args 'no-args) (equal remaining-args arguments))      (setq remaining-args arguments)      (throw 'impossible     'impossible))    (nreverse final-format-results))  collect  (prog1    (if default      `(t . ,code)      `((= ,clause-number arg) . ,code))    (setf default (not (evenp (second clause))))))))       format-results)      remaining-args)))  (defprop ] format-ctl-end-case-macro eval-immediate)  (defun format-ctl-end-case-macro (ignore)  (format-error "Stray ~~] in FORMAT control string"))  (defun elim-lets (tree)  (if (atom tree)      tree    (progn      (setq tree (eliminate-lets tree))      (elim-lets (car tree))      (elim-lets (cdr tree))      tree)))(defun eliminate-lets (tree)  (if (and (consp tree) (consp (first tree)) (consp (second tree)))    (if (and (eq 'let (first (first tree))) (eq 'let (first (second tree))))     ;; then maybe we can eliminate something      (if (equal (second (first tree)) (second (second tree)))       ;; then we can eliminate the lets probably.(progn  (setf (second tree)`(let ,(second (first tree))   ,(third (first tree))   ,(third (second tree))))  (setf (first tree) '(progn)))tree)      tree)    tree))  (defprop \| format-ctl-forms-macro eval-immediate)  (defun format-ctl-forms-macro (params)  ;; 11/10/86 DNG - Use :operation-handled-p operation instead of :which-operations.  (if colon-flag      (push`(if (send *standard-output* :operation-handled-p :clear-screen)     (send *standard-output* :clear-screen)   (format-ctl-repeat-char ,(or (first params) 1) #\PAGE))format-results)    (push `(format-ctl-repeat-char ,(or (first params) 1) #\PAGE)  format-results)))(defprop { format-iterate-over-list-maco eval-immediate)  (defun format-iterate-over-list-maco (&rest ignore)  (throw 'impossible 'impossible))  (defprop ^ format-ctl-terminate-macro eval-immediate)  (defun format-ctl-terminate-macro (&rest ignore)  (throw 'impossible 'impossible))  ;This is not so hairy as to work with ~T, tabs, crs.  I really don't see how to do that.;It makes a list of strings, then decides how much spacing to put in,;then goes back and outputs.(defprop < format-hairy-justification-macro eval-immediate)  (defun format-hairy-justification-macro (&rest ignore)  (throw 'impossible 'impossible))  (comment(defun format-hairy-justification-macro (args params)  (let ((mincol (or (first params) 0))(colinc (or (second params) 1))(minpad (or (third params) 0))(padchar (or (fourth params) #\SPACE))(temp-results nil))    '(let ((newline nil)   (extra 0)   (linewidth nil)   (strings nil)   (string-ncol 0)   (clauses)   (n-padding-points -1)   (total-padding)   (n-pads)   (n-extra-pads))       (push '((w-o (send *standard-output* ':which-operations))) temp-results)       (and colon-flag (setq n-padding-points (1+ n-padding-points)))       (and atsign-flag (setq n-padding-points (1+ n-padding-points)))       (*catch 'format-^-point       (progn (setq clauses (format-parse-clauses '> t)) (do ((specs (g-l-p clauses) (cdddr specs))      (str))     ((null specs))   (multiple-value (args str-code)      (format-ctl-string-to-string args (car specs)))   (push `(setq str ,str-code) temp-results)   (push    '(progn       (setq string-ncol (+ (string-length str) string-ncol))       (setq n-padding-points (1+ n-padding-points))       (setq strings (cons-in-area str strings format-temporary-area)))    temp-results))))       (push '(setq strings (nreverse strings)) temp-results)       (cond ((and (g-l-p clauses) (oddp (cadr (g-l-p clauses))))  (push   `(progn      (setq newline (pop strings))      (and ,(caddr (g-l-p clauses)) (setq extra ,(or (car (g-l-p (caddr (g-l-p clauses)))) 0)       linewidth ,(cadr (g-l-p (caddr (g-l-p clauses))))))      (setq string-ncol (- string-ncol (string-length newline)))      (setq n-padding-points (1- n-padding-points)))   temp-results)))       (push`(progn   (and (zerop n-padding-points) (setq colon-flag t       n-padding-points 1))   (setq total-padding (+ (* n-padding-points minpad) string-ncol))   (setq total-padding (-  (+ mincol     (* colinc (floor (+ (max (- total-padding mincol) 0) (1- colinc)) colinc)))  string-ncol))   (cond     ((and newline (global:memq ':read-cursorpos w-o)   (> (+ (send *standard-output* ':read-cursorpos ':character) string-ncol total-padding extra)      (or linewidth  (and (global:memq ':size-in-characters w-o)       (send *standard-output* ':size-in-characters))  95)))      (write-string newline)))   (multiple-value-setq( n-pads n-extra-pads )(floor total-padding n-padding-points))   (or (zerop n-extra-pads) (setq n-pads (1+ n-pads)))   (do ((strings strings (cdr strings))(pad-before-p colon-flag t))       ((null strings))     (cond       (pad-before-p (format-ctl-repeat-char n-pads ,padchar)(and (zerop (setq n-extra-pads (1- n-extra-pads))) (setq n-pads (1- n-pads)))))     (write-string (first strings) ))   ,@(and atsign-flag `((format-ctl-repeat-char n-pads ,padchar)))   (dolist (str (nreverse strings))     (return-array str))   (and newline (return-array newline))   (format-reclaim-clauses clauses))temp-results)       (push (cons 'let (nreverse temp-results)) format-results)       args))))  (defprop > format-ctl-end-hairy-justification-macro eval-immediate)  (defun format-ctl-end-hairy-justification-macro (ignore)  (format-error "Stray ~~> in FORMAT control string"))  (defprop |(| format-ctl-start-case-convert-macro eval-immediate) (defun format-ctl-start-case-convert-macro (args ignore)  (let* ((clauses (format-parse-clauses '|)| ())) (final-format-results nil) (arguments (format-ctl-string-macro args (aref clauses 0))))    (push     `(let ((case-convert     ,(if colon-flag(if atsign-flag  ''uppercase  ''cap-all-words)(if atsign-flag  ''cap-first-word  ''lowercase)))    (prev-char 0)    (case-converted-stream (if case-convert     case-converted-stream     *standard-output*))    (*standard-output* 'case-convert-stream)),@(nreverse final-format-results))     format-results)    (format-reclaim-clauses clauses)    arguments)) (comment ;;; This function is like FORMAT-CTL-STRING except that instead of sending to ;;; STANDARD-OUTPUT it sends to a string and returns that as its second value. ;;; The returned string is in the temporary area. (defun format-ctl-string-to-string-macro (args str)   (let* ((format-results)  (args-result (format-ctl-string args str)))     (values args-result     `(let ((format-string     (make-array 128 ':area format-temporary-area ':type 'art-string ':leader-list '(0)))    (standard-output 'format-string-stream)),@(nreverse format-results)(adjust-array-size format-string (array-active-length format-string)))))))  the :COLD-LOAD attribute. (PUSH FDEFINE-FILE-PATHNAME COLD-LOAD-FIL