Changeset 11921


Ignore:
Timestamp:
Apr 9, 2009, 9:41:28 PM (11 years ago)
Author:
rme
Message:

Merge r11805 through r11809 (format control string checker) from trunk.

Location:
release/1.3/source
Files:
9 edited

Legend:

Unmodified
Added
Removed
  • release/1.3/source/cocoa-ide/cocoa-utils.lisp

    r9752 r11921  
    281281    (#_NSLog (ccl::%make-nsstring (double-%-in string)))))
    282282
     283(pushnew '(log-debug . 0) ccl::*format-arg-functions* :test #'equal)
     284
    283285(defun nslog-condition (c)
    284286  (let* ((rep (format nil "~a" c)))
  • release/1.3/source/compiler/nx-basic.lisp

    r11781 r11921  
    595595    (:result-ignored . "Function result ignored in call to ~s")
    596596    (:duplicate-definition . report-compile-time-duplicate-definition)
     597    (:format-error . "~:{~@?~%~}")
    597598    (:program-error . "~a")
    598599    (:unsure . "Nonspecific warning")))
  • release/1.3/source/compiler/nx.lisp

    r11747 r11921  
    204204    (:result-ignored . style-warning)
    205205    (:lambda . style-warning)
     206    (:format-error . style-warning)
    206207    (:unused . style-warning)))
    207208
  • release/1.3/source/compiler/nx0.lisp

    r11747 r11921  
    19001900        (list (%nx1-operator typed-form) type form)))))
    19011901
     1902(defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0)
     1903                                 (y-or-n-p . 0) (yes-or-no-p . 0)
     1904                                 (signal-simple-program-error . 0)
     1905                                 (signal-simple-condition . 1)
     1906                                 (signal-reader-error . 1)
     1907                                 (%method-combination-error . 0)
     1908                                 (%invalid-method-error . 1)
     1909                                 (nx-compile-time-error . 0)
     1910                                 (nx-error . 0)
     1911                                 (compiler-bug . 0)))
     1912
     1913#-BOOTSTRAPPED (unless (fboundp 'nx1-check-format-call) (fset 'nx1-check-format-call (lambda (&rest x) (declare (ignore x)))))
     1914
    19021915;;; Wimpy.
    19031916(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p)
     
    19191932        (nx1-whine :undefined-function sym))
    19201933      (setq whined t))
     1934    (when (and args-p
     1935               (not spread-p)
     1936               (setq somedef (cdr (assq sym *format-arg-functions*)))
     1937               (setq somedef (nthcdr somedef args))
     1938               (stringp (car somedef)))
     1939      (when (nx1-check-format-call (car somedef) (cdr somedef) env)
     1940        (setq whined t)))
    19211941    (when (and args-p (setq somedef (or lexenv-def defenv-def global-def)))
    19221942      (multiple-value-bind (deftype reason)
  • release/1.3/source/compiler/optimizers.lisp

    r11687 r11921  
    19311931(define-compiler-macro format (&environment env &whole call stream string &rest args)
    19321932  (if (stringp string)
    1933     (cond ((string-equal string "~a")
     1933    (cond ((and (string-equal string "~a") args (null (cdr args)))
    19341934           (destructuring-bind (object) args
    19351935             (cond ((null stream)
     
    19421942                           (format-to-string stream ,string object)
    19431943                           (progn (princ object (and (neq stream t) stream)) nil)))))))
    1944           ((string-equal string "~s")
     1944          ((and (string-equal string "~s") args (null (cdr args)))
    19451945           (destructuring-bind (object) args
    19461946             (cond ((null stream)
  • release/1.3/source/level-1/l1-format.lisp

    r10942 r11921  
    321321
    322322(defun format-no-flags (colon atsign)
    323   (when (or colon atsign) (format-error "Flags not allowed")))
     323  (cond ((and colon atsign)
     324         (format-error "Flags not allowed"))
     325        (colon
     326         (format-error ": flag not allowed"))
     327        (atsign
     328         (format-error "@ flag not allowed"))))
    324329
    325330;Redefined later
     
    340345;Final version
    341346(defformat #\% format-% (stream colon atsign &optional repeat-count)
     347  (format-no-flags colon atsign)
    342348  (cond ((or (not repeat-count)
    343             (and repeat-count (fixnump repeat-count)
    344                  (> repeat-count -1)))
    345          (format-no-flags colon atsign)
     349             (and (fixnump repeat-count)
     350                  (> repeat-count -1)))
    346351         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream)))
    347352        (t (format-error "Bad repeat-count."))))
     
    350355(defformat #\& format-& (stream colon atsign &optional repeat-count)
    351356  (format-no-flags colon atsign)
    352   (unless (eq repeat-count 0)
    353     (fresh-line stream)
    354     (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream))))
     357  (cond ((or (not repeat-count)
     358             (and (fixnump repeat-count)
     359                  (> repeat-count -1)))
     360         (unless (eq repeat-count 0)
     361           (fresh-line stream)
     362           (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream))))
     363        (t (format-error "Bad repeat-count."))))
    355364
    356365;Final version
    357366(defformat #\~ format-~ (stream colon atsign &optional repeat-count)
    358367  (format-no-flags colon atsign)
    359   (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream)))
     368  (cond ((or (not repeat-count)
     369             (and (fixnump repeat-count)
     370                  (> repeat-count -1)))
     371         (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream)))
     372        (t (format-error "Bad repeat-count."))))
    360373
    361374;Final version
     
    382395                   (list-length *format-arguments*)))
    383396         (to (if atsign
    384                (or count 0) ; absolute
     397               (progn
     398                 (format-no-flags colon nil)
     399                 (or count 0)) ; absolute
    385400               (progn
    386401                 (when (null count)(setq count 1))
     
    408423            (not (whitespacep (schar s i))))
    409424        (setq *format-index* (1- i)))))
    410        
     425
    411426(defun nthcdr-no-overflow (count list)
    412   "If cdr beyond end of list return :error" 
    413427  (if (or (> count (list-length list)) (< count 0))
    414     nil ;:error
     428    (format-error "non-existent target for ~*")
    415429    (nthcdr count list)))
    416430
  • release/1.3/source/lib/format.lisp

    r11644 r11921  
    3838  "Saved arglist from top-level FORMAT call for ~* and ~@*")
    3939
     40(defvar *format-arguments-variance* nil
     41  "Non-NIL only during compile-time scanning of a format string, in which case it is the
     42number of additional elements at the front of *format-arguments* that may be already used
     43up at runtime.  I.e. the actual *format-arguments* may be anything between *format-arguments*
     44and (nthcdr *format-arguments-variance* *format-arguments*)")
    4045
    4146(def-standard-initial-binding *format-stream-stack* nil "A stack of string streams for collecting FORMAT output")
     
    4651(defvar *format-justification-semi* nil
    4752  "Has a ~<...~:;...~> been seen?")
     53
     54(defvar *format-colon-rest* nil
     55  )
    4856
    4957;;; prevent circle checking rest args. Really EVIL when dynamic-extent
     
    198206
    199207(defun format-get-parameter (ch)
    200   "Might someday want to add proper format error checking for negative
    201       parameters"
    202   (let (neg-parm)
    203     (when (eq ch #\-)(setq neg-parm ch)
    204           (setq ch (format-nextchar)))
    205     (case ch
    206       (#\# (format-nextchar) (length *format-arguments*))
    207       ((#\V #\v)
    208        (prog1 (pop-format-arg) (format-nextchar)))
    209       (#\' (prog1 (format-nextchar) (format-nextchar)))
    210       (t (cond ((setq ch (digit-char-p ch))
    211                 (do ((number ch (%i+ ch (%i* number 10))))
     208  (case ch
     209    (#\# (format-nextchar)
     210     (let ((n (or *format-arguments-variance* 0))
     211           (len (length *format-arguments*)))
     212       (declare (fixnum n len))
     213       (if (eql n 0)
     214         len
     215         `(the (integer ,(- len n) ,len) (length *format-arguments*)))))
     216    ((#\V #\v)
     217     (prog1 (pop-format-arg) (format-nextchar)))
     218    (#\' (prog1 (format-nextchar) (format-nextchar)))
     219    (t (cond ((or (eq ch #\-) (eq ch #\+) (digit-char-p ch))
     220              (let ((neg-parm (eq ch #\-)))
     221                (unless (setq ch (digit-char-p ch))
     222                  (unless (setq ch (digit-char-p (format-nextchar)))
     223                    (format-error "Illegal parameter")))
     224                (do ((number ch (+ ch (* number 10))))
    212225                    ((not (setq ch (digit-char-p (format-nextchar))))
    213                      (if neg-parm (- number) number))))
    214                (t nil))))))
     226                     (if neg-parm (- number) number)))))
     227             (t nil)))))
    215228
    216229(defun format-skip-parameter (ch) ; only caller is parse-format-operation
     
    223236      (#\' (format-nextchar) (format-nextchar))
    224237      (#\,)
    225       (t (cond (T ;(or (eq ch #\-)(digit-char-p ch)) ; t
    226                 (while (digit-char-p (format-nextchar))))
    227                (t nil))))))
    228 
     238      (t (when (or (eq ch #\-) (eq ch #\+)) (format-nextchar))
     239         (while (digit-char-p (format-nextchar)))))))
     240
     241(defun format-no-semi (char &optional colon atsign)
     242  (when *format-justification-semi*
     243    (format-error "~~~:[~;:~]~:[~;@~]~c illegal in this context" colon atsign char))
     244  (setq *format-pprint* t))
    229245
    230246;;; Parses a format directive, including flags and parameters.  On entry,
     
    251267                 (setq ch (format-nextchar))
    252268                 (format-skip-parameter ch)))))
    253     ; allow either order - (also allows :: or @@)
     269    ; allow either order
    254270    (case ch
    255       (#\: (setq colon t))
    256       (#\@ (setq atsign t)))
    257     (when (or colon atsign)
    258       (case (setq ch (format-nextchar))
    259         (#\: (setq colon t)
    260          (setq ch (format-nextchar)))
    261         (#\@ (setq atsign t)
    262          (setq ch (format-nextchar)))))
     271      (#\: (setq colon t ch (format-nextchar))
     272           (when (eq ch #\@)
     273             (setq atsign t ch (format-nextchar))))
     274      (#\@ (setq atsign t ch (format-nextchar))
     275           (when (eq ch #\:)
     276             (setq colon t ch (format-nextchar)))))
    263277    (values (if (consp parms) (nreverse parms) parms)
    264278            colon
     
    318332          ((#\} #\> #\) #\])
    319333           (format-error "No matching bracket")))))))
     334
     335(defun format-find-command-no-params (command-list &key (colon t) (atsign t))
     336  (multiple-value-bind (prev tilde parms colon-flag atsign-flag command)
     337                       (format-find-command command-list)
     338    (with-format-parameters parms ()
     339      (format-no-flags (and (not colon) colon-flag) (and (not atsign) atsign-flag)))
     340    (values prev tilde command colon-flag atsign-flag)))
    320341
    321342;;; This is the FORMAT top-level function.
     
    355376                     (*format-arguments* format-arguments)
    356377                     (*format-colon-rest* 'error)) ; what should this be??
    357                  (declare (special *format-original-arguments* *format-arguments*
    358                                    *format-control-string* *format-colon-rest*))
    359378                 (do-sub-format stream))))))
    360379        nil))))
     
    378397      (error "~%~:{~@?~%~}" (nreverse errorp)))))
    379398
     399
     400
    380401;;; This function does the real work of format.  The segment of the control
    381402;;; string between indiced START (inclusive) and END (exclusive) is processed
     
    392413
    393414(without-duplicate-definition-warnings
    394  (defun pop-format-arg (&aux (args *format-arguments*)(xp *logical-block-xp*))
     415 (defun pop-format-arg (&aux (args *format-arguments*) (xp *logical-block-xp*) (av *format-arguments-variance*))
     416   (when (and (null args) (null xp))
     417     (format-error "Missing argument"))
    395418   (when xp
    396      (if (pprint-pop-check+ args xp)    ; gets us level and length stuff in logical block
    397        (throw 'logical-block nil)))           
    398    (if (and (null args)(null xp))       ; what if its 3?
    399      (format-error "Missing argument")
     419     (if (null av)
     420       (when (pprint-pop-check+ args xp)    ; gets us level and length stuff in logical block
     421         (throw 'logical-block nil))
     422       ;; Could record that might exit here, but nobody cares.
     423       #+no (note-format-scan-option *logical-block-options*)))
     424   (if (or (null av) (eql av 0))
    400425     (progn
    401426       (setq *format-arguments* (cdr args))
    402        (%car args)))))
     427       (%car args))
     428     (let ((types (loop for x in args as i from 0 below av
     429                    collect (nx-form-type x))))
     430       (when (eql av (length args))
     431         (setq *format-arguments-variance* (1- av)))
     432       (setq *format-arguments* (cdr args))
     433       `(the (or ,@types) (car *format-arguments*))))))
    403434
    404435; SUB-FORMAT is now defined in L1-format.lisp
     
    410441
    411442(defformat #\W format-write (stream colon atsign)
    412   (if *format-justification-semi*
    413       (format-error "~~W illegal in this context"))
    414   (setq *format-pprint* t)
     443  (format-no-semi #\W)
    415444  (let ((arg (pop-format-arg)))
    416445    (cond (atsign
     
    429458  (declare (dynamic-extent parms))
    430459  (declare (ignore atsign))
    431   (if *format-justification-semi*
    432       (format-error "~~I illegal in this context"))
    433   (setq *format-pprint* t)
     460  (format-no-semi #\I)
    434461  (with-format-parameters parms ((n 0))
    435462    (pprint-indent (if colon :current :block) n stream)))
    436463
    437464(defformat #\_ format-conditional-newline (stream colon atsign)
    438   (if *format-justification-semi*
    439       (format-error "~~_ illegal in this context"))
    440   (setq *format-pprint* t)
     465  (format-no-semi #\_)
    441466  (let ((option
    442467         (cond (atsign
     
    452477  (declare (dynamic-extent parms))
    453478  (when colon
    454       (if *format-justification-semi*
    455           (format-error "~~:T illegal in this context"))
    456       (setq *format-pprint* t))
     479    (format-no-semi #\T t))
    457480  (with-format-parameters parms ((colnum 1) (colinc 1))
    458481    (cond ((or (typep stream 'xp-stream) (xp-structure-p stream))
     
    498521          package)
    499522      (cond (cpos
    500              (setq package (find-package (string-upcase (%substr string ipos cpos))))
     523             (setq package (or (find-package (string-upcase (%substr string ipos cpos)))
     524                               (format-error "Unknown package")))
    501525             (when (eql #\: (schar string (%i+ 1 cpos)))
    502526               (setq cpos (%i+ cpos 1)))
     
    505529      (let ((thing (intern (string-upcase (%substr string ipos epos)) package)))
    506530        (setq *format-index* epos) ; or 1+ epos?
    507         (apply thing stream (pop-format-arg) colon atsign parms)))))
     531        (apply thing stream (pop-format-arg) colon atsign parms)))))
    508532
    509533;;; Conditional case conversion  ~( ... ~)
     
    512536(defformat #\( format-capitalization (stream colon atsign)
    513537  (format-nextchar)
    514   (multiple-value-bind
    515    (prev tilde end-parms end-colon end-atsign)
    516    (format-find-command '(#\)))
    517    (when (or end-parms end-colon end-atsign)
    518          (format-error "Flags or parameters not allowed"))
     538  (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\)))
    519539   (let* (finished
    520540          (string (with-format-string-output stream
     
    542562(defformat #\( format-capitalization (stream colon atsign)
    543563  (format-nextchar)
    544   (multiple-value-bind
    545     (prev tilde end-parms end-colon end-atsign)
    546     (format-find-command '(#\)))
    547     (when (or end-parms end-colon end-atsign)
    548       (format-error "Flags or parameters not allowed"))
     564  (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\)))
    549565    (let (catchp)
    550566      (cond ((typep stream 'xp-stream)
     
    586602;;; Up and Out (Escape)  ~^
    587603
    588 (defformat #\^ format-escape (stream colon atsign &rest parms)
    589   (declare (special *format-colon-rest*)) ; worry about this later??
     604(defformat #\^ format-escape (stream colon atsign &optional p1 p2 p3)
    590605  (declare (ignore stream))
    591   (declare (dynamic-extent parms))
    592606  (when atsign
    593607    (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon))
    594   (setq parms (remove-if #'null parms))
    595   (when
    596     (cond ((null parms)
    597            (null (if colon *format-colon-rest* *format-arguments*)))
    598           ((null (cdr parms))
    599            (let ((p (car parms)))
    600              (typecase p
    601                (number     (zerop p))
    602                (character  (null p))
    603                (t          nil))))
    604           ((null (cddr parms))
    605            (equal (car parms)(cadr parms)))
    606           (t (let ((first (car parms))(second (cadr parms))(third (caddr parms)))
    607                (typecase second
    608                  (integer
    609                   (<= first second third))
    610                  (character
    611                   (char< first second third))
    612                  (t nil)))))  ; shouldnt this be an error??
     608  (when (cond (p3 (etypecase p2
     609                    (real
     610                     (<= p1 p2 p3))
     611                    (character
     612                     (char< p1 p2 p3))))
     613              (p2 (equal p1 p2))
     614              (p1 (eql p1 0))
     615              (t (null (if colon *format-colon-rest* *format-arguments*))))
    613616    (throw 'format-escape (if colon 'format-colon-escape t))))
    614617
     
    625628    (do ((count 0 (1+ count)))
    626629        ((= count test)
    627          (multiple-value-bind (prev tilde parms colon atsign cmd)
    628                               (format-find-command '(#\; #\]))
    629            (declare (ignore colon))
    630            (when (or atsign parms)
    631              (format-error "Atsign flag or parameters not allowed"))
     630         (multiple-value-bind (prev tilde cmd colon atsign)
     631                              (format-find-command-no-params '(#\; #\]) :atsign nil)
     632           (declare (ignore colon atsign))
    632633           (sub-format stream prev tilde)
    633634           (unless (eq cmd #\])
    634635             (format-find-command '(#\])))))
    635       (multiple-value-bind (prev tilde parms colon atsign cmd)
    636                            (format-find-command '(#\; #\]))
    637         (declare (ignore prev tilde))
    638         (when (or atsign parms)
    639           (format-error "Atsign flag or parameters not allowed"))
     636      (multiple-value-bind (prev tilde cmd colon atsign)
     637                           (format-find-command-no-params '(#\; #\]) :atsign nil)
     638        (declare (ignore prev tilde atsign))
    640639        (when (eq cmd #\]) (return))
     640        (format-nextchar)
    641641        (when colon
    642           (format-nextchar)
    643           (multiple-value-bind (prev tilde parms colon atsign cmd)
    644                                (format-find-command '(#\; #\]))
    645             (declare (ignore parms colon atsign))
     642          (multiple-value-bind (prev tilde cmd colon atsign)
     643                               (format-find-command-no-params '(#\; #\]))
     644            (declare (ignore colon atsign))
    646645            (sub-format stream prev tilde)
    647646            (unless (eq cmd #\])
    648               (format-find-command '(#\]))))
    649           (return))
    650         (format-nextchar)))))
     647              (format-find-command-no-params '(#\]))))
     648          (return))))))
    651649
    652650
     
    654652
    655653(defun format-funny-condition (stream)
    656   (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
    657     (when (or colon atsign parms)
    658       (format-error "Flags or arguments not allowed"))
     654  (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\]))
    659655    (if *format-arguments*
    660656      (if (car *format-arguments*)
     
    667663
    668664(defun format-boolean-condition (stream)
    669   (multiple-value-bind
    670     (prev tilde parms colon atsign command)
    671     (format-find-command '(#\; #\]))
    672     (when (or parms colon atsign)
    673       (format-error "Flags or parameters not allowed"))
     665  (multiple-value-bind (prev tilde command) (format-find-command-no-params '(#\; #\]))
    674666    (when (eq command #\])
    675667      (format-error "Two clauses separated by ~~; are required for ~~:["))
    676668    (format-nextchar)
    677669    (if (pop-format-arg)
    678       (multiple-value-bind (prev tilde parms colon atsign)
    679           (format-find-command '(#\]))
    680         (when (or colon atsign parms)
    681           (format-error "Flags or parameters not allowed"))
     670      (multiple-value-bind (prev tilde)
     671          (format-find-command-no-params '(#\]) :colon nil :atsign nil)
    682672        (sub-format stream prev tilde))
    683673      (progn
    684674        (sub-format stream prev tilde)
    685         (format-find-command '(#\]))))))
    686 
    687 
    688 (defformat #\[ format-condition (stream colon atsign &rest parms)
    689   (declare (dynamic-extent parms))
    690   (when parms
    691     (let ((p (pop parms)))
    692       (if p (push p *format-arguments*)))
    693     (unless (null parms)
    694       (format-error "Too many parameters to ~~[")))
     675        (format-find-command-no-params '(#\]))))))
     676
     677
     678(defformat #\[ format-condition (stream colon atsign &optional p)
     679  (when p (push p *format-arguments*))
    695680  (format-nextchar)
    696681  (cond (colon
     
    709694  (with-format-parameters parms ((max-iter -1))
    710695    (format-nextchar)
    711     (multiple-value-bind (prev tilde end-parms end-colon end-atsign)
    712                          (format-find-command '(#\}))
    713       (when (or end-atsign end-parms)
    714         (format-error "Illegal terminator for ~~{"))
     696    (multiple-value-bind (prev tilde end-cmd end-colon end-atsign)
     697                         (format-find-command-no-params '(#\}) :atsign nil)
     698      (declare (ignore end-cmd end-atsign))
    715699      (if (= prev tilde)
    716700        ;; Use an argument as the control string if ~{~} is empty
     
    763747                                (*format-arguments* args)
    764748                                (*format-original-arguments* args))
    765                            (declare (special *format-colon-rest*))
    766749                           (unless (listp *format-arguments*)
    767750                             (report-bad-arg *format-arguments* 'list))
     
    798781(defun format-get-trailing-segments ()
    799782  (format-nextchar)
    800   (multiple-value-bind (prev tilde colon atsign parms cmd)
     783  (multiple-value-bind (prev tilde parms colon atsign cmd)
    801784                       (format-find-command '(#\; #\>) nil T)
    802     (when colon
    803       (format-error "~~:; allowed only after first segment in ~~<"))
    804     (when (or atsign parms)
    805       (format-error "Flags and parameters not allowed"))
     785    (with-format-parameters parms ()
     786      (when colon
     787        (format-error "~~:; allowed only after first segment in ~~<"))
     788      (format-no-flags nil atsign))
    806789    (let ((str (catch 'format-escape
    807790                 (with-format-string-output stream
     
    909892(defformat #\< format-justification (stream colon atsign &rest parms)
    910893  (declare (dynamic-extent parms))
    911   (multiple-value-bind (start tilde eparms ecolon eatsign)
    912                        (format-find-command '(#\>)) ; bumps format-index
    913     (declare (ignore tilde eparms))
     894  (multiple-value-bind (start tilde ecmd ecolon eatsign)
     895                       (format-find-command-no-params '(#\>)) ; bumps format-index
     896    (declare (ignore tilde ecmd))
    914897    (cond
    915898     (ecolon
     
    945928                (when special-arg
    946929                  (if *format-pprint*
    947                       (format-error "Justification illegal in this context."))
     930                      (format-error "Justification illegal in this context"))
    948931                  (setq *format-justification-semi* t)
    949932                  (with-format-parameters special-parms ((spare 0)
     
    973956                        (return t))
    974957                       (t (return nil))))))))
    975     (if *format-justification-semi*
    976       (format-error "~<...~:> illegal in this context."))
    977     (setq *format-pprint* t)
     958    (format-no-semi #\<)
    978959    (let ((format-string *format-control-string*)
    979960          (prefix (if colon "(" ""))
     
    13771358        (setq *format-index* (1- i)))))
    13781359
    1379 (defun format-newline (stream colon atsign &rest parms)
    1380   (declare (dynamic-extent parms))
    1381   (when parms
    1382     (format-error "Parameters not allowed"))
    1383   (cond (colon
    1384          (when atsign (format-error "~:@<newline> is undefined")))
    1385         (atsign (terpri stream) (format-eat-whitespace))
    1386         (t (format-eat-whitespace))))
     1360(defun format-newline (stream colon atsign parms)
     1361  (with-format-parameters parms ()
     1362    (cond (colon
     1363           (when atsign
     1364             (format-error "~:@<newline> is undefined")))
     1365          (atsign (terpri stream) (format-eat-whitespace))
     1366          (t (format-eat-whitespace)))))
    13871367 
    13881368(defformat  #\newline format-newline (stream colon atsign &rest parms)
    1389   (apply #'format-newline stream colon atsign parms))
     1369  (declare (dynamic-extent parms))
     1370  (format-newline stream colon atsign parms))
    13901371
    13911372(defformat #\return format-newline (stream colon atsign &rest parms)
    1392   (apply #'format-newline stream colon atsign parms))
     1373  (declare (dynamic-extent parms))
     1374  (format-newline stream colon atsign parms))
    13931375
    13941376;;; Indirection  ~?
    13951377
    1396 (defformat #\? format-indirection (stream colon atsign &rest parms)
    1397   (declare (dynamic-extent parms))
    1398   (when (or colon parms)
    1399     (format-error "Flags or parameters not allowed"))
     1378(defformat #\? format-indirection (stream colon atsign)
     1379  (format-no-flags colon nil)
    14001380  (let ((string (pop-format-arg)))
    14011381    (unless (or (stringp string)(functionp string))
     
    21872167          (format *query-io* "Please answer yes or no.")))))
    21882168
     2169
     2170
     2171;; Compile-time format-scanning support.
     2172;;
     2173;; All this assumes it's called from the compiler, but it has to be kept in sync with code
     2174;; here more than with the code in the compiler, so keep it in here.
     2175
     2176(defun note-format-scan-option (cell)
     2177  (when cell
     2178    (if (null (cdr cell))
     2179      (setf (car cell) *format-arguments* (cdr cell) *format-arguments-variance*)
     2180      (let* ((new-args *format-arguments*)
     2181             (new-var *format-arguments-variance*)
     2182             (new-max (length new-args))
     2183             (old-args (car cell))
     2184             (old-var (cdr cell))
     2185             (old-max (length old-args))
     2186             (min (min (- new-max new-var) (- old-max old-var))))
     2187        (if (>= new-max old-max)
     2188          (setf (car cell) new-args (cdr cell) (- new-max min))
     2189          (setf (cdr cell) (- old-max min))))))
     2190  cell)
     2191
     2192(defmacro with-format-scan-options ((var) &body body)
     2193  (let ((cell (gensym)))
     2194    ;; CELL is used to record range of arg variations that should be deferred til the end
     2195    ;; of BODY because they represent possible non-local exits.
     2196    `(let* ((,cell (cons nil nil))
     2197            (,var ,cell))
     2198       (declare (dynamic-extent ,cell))
     2199       (prog1
     2200           (progn
     2201             ,@body)
     2202         (setq *format-arguments* (car ,cell)
     2203               *format-arguments-variance* (cdr ,cell))))))
     2204
     2205(defvar *format-escape-options* nil)
     2206
     2207(defun nx1-check-format-call (control-string format-arguments &optional (env *nx-lexical-environment*))
     2208  "Format-arguments are expressions that will evaluate to the actual arguments.
     2209  Pre-scan process the format string, nx1-whine if find errors"
     2210  (let* ((*nx-lexical-environment* env)
     2211         (*format-top-level* t)
     2212         (*logical-block-xp* nil)
     2213         (*format-pprint* nil)
     2214         (*format-justification-semi* nil))
     2215    (let ((error (catch 'format-error
     2216                   (format-scan control-string format-arguments 0)
     2217                   nil)))
     2218      (when error
     2219        (setf (cadar error) (concatenate 'string (cadar error) " in format string:"))
     2220        (nx1-whine :format-error (nreverse error))
     2221        t))))
     2222
     2223(defun format-scan (string args var)
     2224  (let ((*format-original-arguments* args)
     2225        (*format-arguments* args)
     2226        (*format-arguments-variance* var)
     2227        (*format-colon-rest* 'error)
     2228        (*format-control-string* (ensure-simple-string string)))
     2229    (with-format-scan-options (*format-escape-options*)
     2230      (catch 'format-escape
     2231        (sub-format-scan 0 (length *format-control-string*))
     2232        (note-format-scan-option *format-escape-options*)))
     2233    #+no
     2234    (when (> (length *format-arguments*) *format-arguments-variance*)
     2235      (format-error "Too many format arguments"))))
     2236
     2237(defun sub-format-scan (i end)
     2238  (let ((*format-index* i)
     2239        (*format-length* end)
     2240        (string *format-control-string*))
     2241    (loop while (setq *format-index* (position #\~ string :start *format-index* :end end)) do
     2242      (multiple-value-bind (params colon atsign char) (parse-format-operation t)
     2243        (setq char (char-upcase char))
     2244        (let ((code (%char-code char)))
     2245          (unless (and (< -1 code (length *format-char-table*))
     2246                       (svref *format-char-table* code))
     2247            (format-error "Unknown directive ~c" char)))
     2248        (format-scan-directive char colon atsign params)
     2249        (incf *format-index*)))))
     2250
     2251(defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*))
     2252  (unless transformed (setq form (nx-transform form env)))
     2253  (if (constantp form)
     2254    (typep (eval-constant form) type env)
     2255    (multiple-value-bind (win-p sure-p) (subtypep (nx-form-type form env) `(not ,type) env)
     2256      (not (and win-p sure-p)))))
     2257
     2258(defun format-require-type (form type &optional description)
     2259  (unless (nx-could-be-type form type)
     2260    (format-error "~a must be of type ~s" (or description form) type)))
     2261
     2262
     2263(defun format-scan-directive (char colon atsign parms)
     2264  (ecase char
     2265    ((#\% #\& #\~ #\|)
     2266     (with-format-parameters parms ((repeat-count 1))
     2267       (format-no-flags colon atsign)
     2268       (format-require-type repeat-count '(integer 0))))
     2269    ((#\newline #\return)
     2270     (with-format-parameters parms ()
     2271       (when (and atsign colon) (format-error "~:@<newline> is undefined"))
     2272       (unless colon
     2273         (format-eat-whitespace))))
     2274    ((#\P)
     2275     (with-format-parameters parms ()
     2276       (when colon
     2277         (loop with end = *format-arguments*
     2278            for list on *format-original-arguments*
     2279            when (eq (cdr list) end) return (setq *format-arguments* list)
     2280            finally (if (> (or *format-arguments-variance* 0) 0)
     2281                        (decf *format-arguments-variance*)
     2282                        (format-error "No previous argument"))))
     2283       (pop-format-arg)))
     2284    ((#\A #\S)
     2285     (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
     2286       (format-require-type mincol 'integer "mincol (first parameter)")
     2287       (format-require-type colinc '(integer 1) "colinc (second parameter)")
     2288       (format-require-type minpad 'integer "minpad (third parameter)")
     2289       (format-require-type padchar '(or (integer 0 #.char-code-limit) character) "padchar (fourth parameter)"))
     2290     (pop-format-arg))
     2291    ((#\I)
     2292     (with-format-parameters parms ((n 0))
     2293       (format-no-flags nil atsign)
     2294       (format-no-semi char)
     2295       (format-require-type n 'real)))
     2296    ((#\_)
     2297     (with-format-parameters parms ()
     2298       (format-no-semi char)))
     2299    ((#\T)
     2300     (with-format-parameters parms ((colnum 1) (colinc 1))
     2301       (when colon
     2302         (format-no-semi char t))
     2303       (format-require-type colnum 'integer "colnum (first parameter)")
     2304       (format-require-type colinc 'integer "colinc (second parameter)")))
     2305    ((#\W)
     2306     (with-format-parameters parms ()
     2307       (format-no-semi #\W))
     2308     (pop-format-arg))
     2309    ((#\C)
     2310     (with-format-parameters parms ())
     2311     (format-require-type (pop-format-arg) '(or character fixnum (string 1))))
     2312    ((#\D #\B #\O #\X #\R)
     2313     (when (eql char #\R)
     2314       (let ((radix (pop parms)))
     2315         (when radix
     2316           (format-require-type radix '(integer 2 36)))))
     2317     (with-format-parameters parms ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
     2318       (format-require-type mincol 'integer "mincol (first parameter)")
     2319       (format-require-type padchar 'character "padchar (second parameter)")
     2320       (format-require-type commachar 'character "comma char (third parameter)")
     2321       (format-require-type commainterval 'integer "comma interval (fourth parameter)"))
     2322     (pop-format-arg))
     2323    ((#\F)
     2324     (format-no-flags colon nil)
     2325     (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
     2326       (format-require-type w '(or null (integer 0)) "w (first parameter)")
     2327       (format-require-type d '(or null (integer 0)) "d (second parameter)")
     2328       (format-require-type k '(or null integer) "k (third parameter)")
     2329       (format-require-type ovf '(or null character) "overflowchar (fourth parameter)")
     2330       (format-require-type pad '(or null character) "padchar (fifth parameter)"))
     2331     (pop-format-arg))
     2332    ((#\E #\G)
     2333     (format-no-flags colon nil)
     2334     (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil))
     2335       (format-require-type w '(or null (integer 0)) "w (first parameter)")
     2336       (format-require-type d '(or null (integer 0)) "d (second parameter)")
     2337       (format-require-type e '(or null (integer 0)) "e (third parameter)")
     2338       (format-require-type k '(or null integer) "k (fourth parameter)")
     2339       (format-require-type ovf '(or null character) "overflowchar (fifth parameter)")
     2340       (format-require-type pad '(or null character) "padchar (sixth parameter)")
     2341       (format-require-type marker '(or null character) "exponentchar (seventh parameter)"))
     2342     (pop-format-arg))
     2343    ((#\$)
     2344     (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space))
     2345       (format-require-type d '(or null (integer 0)) "d (first parameter)")
     2346       (format-require-type n '(or null (integer 0)) "n (second parameter)")
     2347       (format-require-type w '(or null (integer 0)) "w (third parameter)")
     2348       (format-require-type pad '(or null character) "pad (fourth parameter)"))
     2349     (format-require-type (pop-format-arg) 'real))
     2350    ((#\*)
     2351     (with-format-parameters parms ((count nil))
     2352       (when count
     2353         (format-require-type count 'integer "count parameter"))
     2354       (if (typep (setq count (nx-transform count)) '(or null integer))
     2355         (format-scan-goto colon atsign count)
     2356         ;; Else can't tell how much going back or forth, could be anywhere.
     2357         (setq *format-arguments* *format-original-arguments*
     2358               *format-arguments-variance* (length *format-arguments*)))))
     2359    ((#\?)
     2360     (with-format-parameters parms ()
     2361       (format-no-flags colon nil))
     2362     (let ((string (pop-format-arg)))
     2363       (format-require-type string '(or string function))
     2364       (if atsign
     2365         (setq *format-arguments-variance* (length *format-arguments*))
     2366         (let ((arg (pop-format-arg)))
     2367           (format-require-type arg 'list)))))
     2368    ((#\/)
     2369     (let* ((string *format-control-string*)
     2370            (ipos (1+ *format-index*))
     2371            (epos (format-find-char #\/ ipos *format-length*)))
     2372       (when (not epos) (format-error "Unmatched ~~/"))
     2373       (let* ((cpos (format-find-char #\: ipos epos))
     2374              (name (if cpos
     2375                      (prog1
     2376                          (string-upcase (%substr string ipos cpos))
     2377                        (when (eql #\: (schar string (%i+ 1 cpos)))
     2378                          (setq cpos (%i+ cpos 1)))
     2379                        (setq ipos (%i+ cpos 1)))
     2380                      "CL-USER"))
     2381              (package (find-package name))
     2382              (sym (and package (find-symbol (string-upcase (%substr string ipos epos)) package)))
     2383              (arg (pop-format-arg)))
     2384         (setq *format-index* epos) ; or 1+ epos?
     2385         ;; TODO: should we complain if the symbol doesn't exit?  Perhaps it will be defined
     2386         ;; later, and to detect that would need to intern it.  What if the package doesn't exist?
     2387         ;; Would need to extend :undefined-function warnings to handle previously-undefined package.
     2388         (when sym
     2389           (when (nth-value 1 (nx1-call-result-type sym (list* '*standard-output* arg colon atsign parms)))
     2390             ;; Whined, just get out now.
     2391             (throw 'format-error nil))))))
     2392    ((#\[)
     2393     (when (and colon atsign) (format-error  "~~:@[ undefined"))
     2394     (format-nextchar)
     2395     (cond (colon
     2396            (format-scan-boolean-condition parms))
     2397           (atsign
     2398            (format-scan-funny-condition parms))
     2399           (t (format-scan-untagged-condition parms))))
     2400    ((#\()
     2401     (with-format-parameters parms ()
     2402       (format-nextchar)
     2403       (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\)))
     2404         (with-format-parameters parms () (format-no-flags colon atsign))
     2405         (sub-format-scan prev tilde))))
     2406    ((#\^)
     2407     (format-no-flags nil atsign)
     2408     (with-format-parameters parms ((p1 nil) (p2 nil) (p3 nil))
     2409       (let ((val (nx-transform (cond (p3
     2410                                       (if (every (lambda (p) (nx-could-be-type p 'real)) parms)
     2411                                         ;; If the params could also be chars, don't know enough to constant fold
     2412                                         ;; anyway, so this test will do.
     2413                                         `(< ,p1 ,p2 ,p3)
     2414                                         (if (every (lambda (p) (nx-could-be-type p 'character)) parms)
     2415                                           `(char< ,p1 ,p2 ,p3)
     2416                                           ;; At least one can't be real, at least one can't be char.
     2417                                           (format-error "Wrong type of parameters for three-way comparison"))))
     2418                                      (p2 `(equal ,p1 ,p2))
     2419                                      (p1 `(eq ,p1 0))
     2420                                      (t (null (if colon *format-colon-rest* *format-arguments*)))))))
     2421         (when val
     2422           (note-format-scan-option *format-escape-options*)
     2423           (unless (nx-could-be-type val 'null t)
     2424             (throw 'format-escape t))))))
     2425    ((#\{)
     2426     (with-format-parameters parms ((max-iter -1))
     2427       (format-require-type max-iter 'integer "max-iter parameter")
     2428       (format-nextchar)
     2429       (multiple-value-bind (prev tilde end-parms end-colon end-atsign) (format-find-command '(#\}))
     2430         (declare (ignore end-colon))
     2431         (with-format-parameters end-parms () (format-no-flags nil end-atsign))
     2432         (when (= prev tilde)
     2433           ;; Use an argument as the control string if ~{~} is empty
     2434           (let ((string (pop-format-arg)))
     2435             (unless (nx-could-be-type string '(or string function))
     2436               (format-error "Control string is not a string or function"))))
     2437         ;; Could try to actually scan the iteration if string is a compile-time string,
     2438         ;; by that seems unlikely.
     2439         (if atsign
     2440           (setq *format-arguments-variance* (length *format-arguments*))
     2441           (format-require-type (pop-format-arg) 'list)))))
     2442    ((#\<)
     2443     (multiple-value-bind (start tilde eparms ecolon eatsign) (format-find-command '(#\>))
     2444       (declare (ignore tilde eparms eatsign))
     2445       (setq *format-index* start)
     2446       (if ecolon
     2447         (format-logical-block-scan colon atsign parms)
     2448         (format-justification-scan colon atsign parms))))
     2449    ))
     2450
     2451(defun format-justification-scan (colon atsign parms)
     2452  (declare (ignore colon atsign))
     2453  (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
     2454    (format-require-type mincol 'integer "mincol (first parameter)")
     2455    (format-require-type colinc '(integer 1) "colinc (second parameter)")
     2456    (format-require-type minpad 'integer "minpad (third parameter)")
     2457    (format-require-type padchar `(or character (integer 0 #.char-code-limit)) "padchar (fourth parameter)"))
     2458  (let ((first-parms nil) (first-colon nil) (count 0))
     2459    (with-format-scan-options (*format-escape-options*)
     2460      (loop
     2461         (format-nextchar)
     2462         (multiple-value-bind (prev tilde parms colon atsign cmd)
     2463             (format-find-command '(#\; #\>) nil T)
     2464           (if (and (eql count 0) (eql cmd #\;) colon)
     2465             (progn
     2466               (format-no-flags nil atsign)
     2467               (setq first-colon t)
     2468               (setq *format-index* tilde)
     2469               (setq first-parms (nth-value 2 (format-find-command '(#\; #\>) t T))))
     2470             (with-format-parameters parms ()
     2471               (format-no-flags colon atsign)))
     2472           (when (catch 'format-escape
     2473                   (sub-format-scan prev tilde)
     2474                   nil)
     2475             (unless (eq cmd #\>) (format-find-command '(#\>) nil t))
     2476             (return))
     2477           (incf count)
     2478           (when (eq cmd #\>)
     2479             (return))))
     2480      (note-format-scan-option *format-escape-options*))
     2481    (when first-colon
     2482      (when *format-pprint*
     2483        (format-error "Justification illegal in this context"))
     2484      (setq *format-justification-semi* t)
     2485      (with-format-parameters first-parms ((spare 0) (linel 0))
     2486        (format-require-type spare 'integer "spare (first parameter)")
     2487        (format-require-type linel 'integer "line length (second parameter)")))))
     2488     
     2489
     2490
     2491(defun format-logical-block-scan (colon atsign params)
     2492  (declare (ignore colon))
     2493  (with-format-parameters params ()
     2494    (format-no-semi #\<))
     2495    ;; First section can be termined by ~@;
     2496  (let ((format-string *format-control-string*)
     2497        (prefix "")
     2498        (suffix "")
     2499        (body-string nil))
     2500    (multiple-value-bind (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command  '(#\; #\>))
     2501      (setq body-string (%substr format-string (1+ start1) tilde))
     2502      (with-format-parameters parms1 ())
     2503      (when (eq cmd #\;)
     2504        (format-no-flags colon1 nil)
     2505        (setq prefix body-string)
     2506        (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)))
     2507        (with-format-parameters parms1 ())
     2508        (setq body-string (%substr format-string (1+ start1) tilde))
     2509        (when (eq cmd #\;)
     2510          (format-no-flags colon1 atsign1)
     2511          (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command  '(#\; #\>)))
     2512          (with-format-parameters parms1 ())
     2513          (setq suffix (%substr format-string (1+ start1) tilde))
     2514          (when (eq cmd #\;)
     2515            (format-error "Too many sections")))))
     2516    (flet ((format-check-simple (str where)
     2517             (when (and str (or (%str-member #\~ str) (%str-member #\newline str)))
     2518               (format-error "~A must be simple" where))))
     2519      (format-check-simple prefix "Prefix")
     2520      (format-check-simple suffix "Suffix"))
     2521    (if atsign
     2522      (let ((*logical-block-p* t))
     2523        (format-scan body-string *format-arguments* *format-arguments-variance*)
     2524        (setq *format-arguments* nil *format-arguments-variance* 0))
     2525      ;; If no atsign, we just use up an arg.  Don't bother trying to scan it, unlikely to be a constant.
     2526      (when *format-arguments*
     2527        (pop-format-arg)))))
     2528
     2529
     2530(defun format-scan-untagged-condition (parms)
     2531  (with-format-parameters parms ((index nil))
     2532    (unless index (setq index (pop-format-arg)))
     2533    (format-require-type index 'integer)
     2534    (with-format-scan-options (cond-options)
     2535      (loop with default = nil do
     2536           (multiple-value-bind (prev tilde parms colon atsign cmd)
     2537               (format-find-command '(#\; #\]))
     2538             (when (and default (eq cmd #\;))
     2539               (format-error "~:; must be the last clause"))
     2540             (with-format-parameters parms ()
     2541               (format-no-flags (if (eq cmd #\]) colon) atsign)
     2542               (when colon (setq default t)))
     2543             (format-scan-optional-clause prev tilde cond-options)
     2544             (when (eq cmd #\])
     2545               (unless default    ;; Could just skip the whole thing
     2546                 (note-format-scan-option cond-options))
     2547               (return))
     2548             (format-nextchar))))))
     2549
     2550(defun format-scan-funny-condition (parms)
     2551  (with-format-parameters parms ())
     2552  (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
     2553    (with-format-parameters parms ()
     2554      (format-no-flags colon atsign))
     2555    (when (null *format-arguments*) (pop-format-arg)) ;; invoke std error
     2556    (with-format-scan-options (cond-options)
     2557      (let ((arg (nx-transform (car *format-arguments*))))
     2558        (when (nx-could-be-type arg 'null t)
     2559          (let ((*format-arguments* *format-arguments*)
     2560                (*format-arguments-variance* *format-arguments-variance*))
     2561            (when (eql *format-arguments-variance* (length *format-arguments*))
     2562              (decf *format-arguments-variance*))
     2563            (pop *format-arguments*)
     2564            (note-format-scan-option cond-options)))
     2565        (when arg
     2566          (format-scan-optional-clause prev tilde cond-options))))))
     2567
     2568
     2569(defun format-scan-boolean-condition (parms)
     2570  (with-format-parameters parms ())
     2571  (multiple-value-bind (prev tilde parms colon atsign cmd) (format-find-command '(#\; #\]))
     2572    (when (eq cmd #\])
     2573      (format-error "Two clauses separated by ~~; are required for ~~:["))
     2574    (with-format-parameters parms () (format-no-flags colon atsign))
     2575    (format-nextchar)
     2576    (with-format-scan-options (cond-options)
     2577      (let ((arg (nx-transform (pop-format-arg))))
     2578        (when (nx-could-be-type arg 'null t)
     2579          (format-scan-optional-clause prev tilde cond-options))
     2580        (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\]))
     2581          (with-format-parameters parms () (format-no-flags colon atsign))
     2582          (when arg
     2583            (format-scan-optional-clause prev tilde cond-options)))))))
     2584
     2585
     2586(defun format-scan-optional-clause (start end cond-option)
     2587  (let ((*format-arguments* *format-arguments*)
     2588        (*format-arguments-variance* *format-arguments-variance*))
     2589    ;; Let the branch points collect in outer *format-escape-options*, but don't
     2590    ;; throw there because need to consider the other clauses.
     2591    (catch 'format-escape
     2592      (sub-format-scan start end)
     2593      (note-format-scan-option cond-option)
     2594      nil)))
     2595
     2596(defun format-scan-goto (colon atsign count)
     2597  (if atsign
     2598    (progn
     2599      (format-no-flags colon nil)
     2600      (setq *format-arguments*
     2601            (nthcdr-no-overflow (or count 0) *format-original-arguments*))
     2602      (setq *format-arguments-variance* 0))
     2603    (progn
     2604      (when (null count)(setq count 1))
     2605      (when colon (setq count (- count)))
     2606      (cond ((> count 0)
     2607             (when (> count (length *format-arguments*))
     2608               (format-error "Target position for ~~* out of bounds"))
     2609             (setq *format-arguments* (nthcdr count *format-arguments*))
     2610             (when *format-arguments-variance*
     2611               (setq *format-arguments-variance*
     2612                     (min *format-arguments-variance* (length *format-arguments*)))))
     2613            ((< count 0)
     2614             (let* ((orig *format-original-arguments*)
     2615                    (pos (+ (- (length orig) (length *format-arguments*)) count))
     2616                    (max-pos (+ pos (or *format-arguments-variance* 0))))
     2617               (when (< max-pos 0)
     2618                 (format-error "Target position for ~~* out of bounds"))
     2619               (if (< pos 0)
     2620                 (setq *format-arguments* orig
     2621                       *format-arguments-variance* max-pos)
     2622                 (setq *format-arguments* (nthcdr pos orig)))))))))
     2623
  • release/1.3/source/library/loop.lisp

    r11856 r11921  
    871871(defun loop-warn (format-string &rest format-args)
    872872  (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
     873
     874(pushnew '(loop-error . 0) ccl::*format-arg-functions* :test #'equal)
     875(pushnew '(loop-warn . 0) ccl::*format-arg-functions* :test #'equal)
    873876
    874877
  • release/1.3/source/library/parse-ffi.lisp

    r11524 r11921  
    14161416  (apply #'error format args))
    14171417
     1418(pushnew '(c-parse-error . 1) ccl::*format-arg-functions* :test #'equal)
     1419
    14181420(defun macro-definition-of-token (x)
    14191421  (declare (ignore x)))
Note: See TracChangeset for help on using the changeset viewer.