Ignore:
Timestamp:
12/06/04 17:48:28 (17 years ago)
Author:
piso
Message:

Incorporated recent SBCL updates.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/format.lisp

    r8213 r8214  
    22;;;
    33;;; Copyright (C) 2004 Peter Graves
    4 ;;; $Id: format.lisp,v 1.23 2004-12-06 16:45:38 piso Exp $
     4;;; $Id: format.lisp,v 1.24 2004-12-06 17:48:28 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    11311131              (values (expand-directive-list sublist)
    11321132                      *simple-args*))
    1133     (cond ((eq *simple-args* (cdr new-args))
     1133    (cond ((and new-args (eq *simple-args* (cdr new-args)))
    11341134     (setf *simple-args* new-args)
    11351135     `(when ,(caar new-args)
     
    12261226      (labels
    12271227        ((compute-insides ()
    1228                           (if (zerop posn)
    1229                               (if *orig-args-available*
    1230                                   `((handler-bind
    1231                                       ((format-error
    1232                                         (lambda (condition)
    1233                                           (error 'format-error
    1234                                                  :complaint
    1235                                                  "~A~%while processing indirect format string:"
    1236                                                  :args (list condition)
    1237                                                  :print-banner nil
    1238                                                  :control-string ,string
    1239                                                  :offset ,(1- end)))))
    1240                                       (setf args
    1241                                             (%format stream inside-string orig-args args))))
    1242                                   (throw 'need-orig-args nil))
    1243                               (let ((*up-up-and-out-allowed* colonp))
    1244                                 (expand-directive-list (subseq directives 0 posn)))))
    1245          (compute-loop-aux (count)
    1246                            (when atsignp
    1247                              (setf *only-simple-args* nil))
    1248                            `(loop
    1249                               ,@(unless closed-with-colon
    1250                                   '((when (null args)
    1251                                       (return))))
    1252                               ,@(when count
    1253                                   `((when (and ,count (minusp (decf ,count)))
    1254                                       (return))))
    1255                               ,@(if colonp
    1256                                     (let ((*expander-next-arg-macro* 'expander-next-arg)
    1257                                           (*only-simple-args* nil)
    1258                                           (*orig-args-available* t))
    1259                                       `((let* ((orig-args ,(expand-next-arg))
    1260                                                (outside-args args)
    1261                                                (args orig-args))
    1262                                           (declare (ignorable orig-args outside-args args))
    1263                                           (block nil
    1264                                             ,@(compute-insides)))))
    1265                                     (compute-insides))
    1266                               ,@(when closed-with-colon
    1267                                   '((when (null args)
    1268                                       (return))))))
    1269          (compute-loop ()
    1270                        (if params
    1271                            (expand-bind-defaults ((count nil)) params
    1272                                                  (compute-loop-aux count))
    1273                            (compute-loop-aux nil)))
    1274          (compute-block ()
    1275                         (if colonp
    1276                             `(block outside-loop
    1277                                ,(compute-loop))
    1278                             (compute-loop)))
    1279          (compute-bindings ()
    1280                            (if atsignp
    1281                                (compute-block)
    1282                                `(let* ((orig-args ,(expand-next-arg))
    1283                                        (args orig-args))
    1284                                   (declare (ignorable orig-args args))
    1285                                   ,(let ((*expander-next-arg-macro* 'expander-next-arg)
    1286                                          (*only-simple-args* nil)
    1287                                          (*orig-args-available* t))
    1288                                      (compute-block))))))
    1289   (values (if (zerop posn)
    1290         `(let ((inside-string ,(expand-next-arg)))
    1291            ,(compute-bindings))
    1292         (compute-bindings))
     1228           (if (zerop posn)
     1229               (if *orig-args-available*
     1230                   `((handler-bind
     1231                       ((format-error
     1232                         (lambda (condition)
     1233                           (error 'format-error
     1234                                  :complaint
     1235                                  "~A~%while processing indirect format string:"
     1236                                  :args (list condition)
     1237                                  :print-banner nil
     1238                                  :control-string ,string
     1239                                  :offset ,(1- end)))))
     1240                       (setf args
     1241                             (%format stream inside-string orig-args args))))
     1242                   (throw 'need-orig-args nil))
     1243               (let ((*up-up-and-out-allowed* colonp))
     1244                 (expand-directive-list (subseq directives 0 posn)))))
     1245         (compute-loop (count)
     1246           (when atsignp
     1247             (setf *only-simple-args* nil))
     1248           `(loop
     1249              ,@(unless closed-with-colon
     1250                  '((when (null args)
     1251                      (return))))
     1252              ,@(when count
     1253                  `((when (and ,count (minusp (decf ,count)))
     1254                      (return))))
     1255              ,@(if colonp
     1256                    (let ((*expander-next-arg-macro* 'expander-next-arg)
     1257                          (*only-simple-args* nil)
     1258                          (*orig-args-available* t))
     1259                      `((let* ((orig-args ,(expand-next-arg))
     1260                               (outside-args args)
     1261                               (args orig-args))
     1262                          (declare (ignorable orig-args outside-args args))
     1263                          (block nil
     1264                            ,@(compute-insides)))))
     1265                    (compute-insides))
     1266              ,@(when closed-with-colon
     1267                  '((when (null args)
     1268                      (return))))))
     1269         (compute-block (count)
     1270           (if colonp
     1271               `(block outside-loop
     1272                  ,(compute-loop count))
     1273               (compute-loop count)))
     1274         (compute-bindings (count)
     1275            (if atsignp
     1276                (compute-block count)
     1277                `(let* ((orig-args ,(expand-next-arg))
     1278                        (args orig-args))
     1279                   (declare (ignorable orig-args args))
     1280                   ,(let ((*expander-next-arg-macro* 'expander-next-arg)
     1281                          (*only-simple-args* nil)
     1282                          (*orig-args-available* t))
     1283                      (compute-block count))))))
     1284  (values (if params
     1285                    (expand-bind-defaults ((count nil)) params
     1286                                          (if (zerop posn)
     1287                                              `(let ((inside-string ,(expand-next-arg)))
     1288                                                 ,(compute-bindings count))
     1289                                              (compute-bindings count)))
     1290                    (if (zerop posn)
     1291                        `(let ((inside-string ,(expand-next-arg)))
     1292                           ,(compute-bindings nil))
     1293                        (compute-bindings nil)))
    12931294    (nthcdr (1+ posn) directives))))))
    12941295
Note: See TracChangeset for help on using the changeset viewer.