;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Written 05/30/89 08:12:18 by MCCREARY,
;;; Reason: Fixed FORMAT-CTL-OP-MACRO to prevent incorrect optimizations
;;; from being done on multi-arg format directives.
;;; while running on Jules-Verne from band LODA
;;; With SYSTEM 6.2, VIRTUAL-MEMORY 6.1, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.1, TV 6.6, DATALINK 6.0, CHAOSNET 6.0, GC 6.0, MEMORY-AUX 6.0, NVRAM 6.0,
;;;  SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0,
;;;  DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.0, SERIAL 6.0, PRINTER 6.0, MAC-PRINTER-TYPES 6.0, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.3, CLEH 6.0, IP 3.45,
;;;  Experimental BUG 11.6, CLX 6.0, CLUE 6.0, X11M 6.0,  microcode 429, Band Name: Release 6.0 + SLE 5/22

#!C
; From file FORMAT-MACRO.LISP#> COMPILER; MR-X:
#10R FORMAT#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "FORMAT"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; FORMAT-MACRO.#"


(defun format-ctl-op-macro (op args params &aux tem immediate)
  ;; 05/30/89 clm - This used to get it wrong for any multi arg
  ;;                which did not have an eval-immediate property (all but one system
  ;;                defined format directive had this property so the problem did not
  ;;                manifest itself.  Put in the Number-Of-Agruments property because
  ;;                some multi-arg directives may have a constant number of args and so
  ;;                can be optimized, there being no :n-arg type for defformat for n>1.
  (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)
	 (if (get op 'number-of-arguments)
	     (let ((number (get op 'number-of-arguments)))
	       (push `(let ((atsign-flag ',atsign-flag)
			    (colon-flag ',colon-flag))
			(funcall ',tem
				 ,(cons 'list (copy-tree (firstn number args)))
				 ,(copy-tree params)))
		     format-results)
	       (values (nthcdr number args) t))
	     (throw 'impossible 'impossible))))
    ((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)))
))