Changeset 11138


Ignore:
Timestamp:
Oct 17, 2008, 5:14:25 PM (11 years ago)
Author:
gz
Message:

From working-0711 branch:

from r10653: fixes to handler-case et.al. to fix a possible race condition.
from r9433: use pkg-arg in expansion of with-standard-io-syntax
from r9182: #+ccl-0711 only, don't warn about unreferenced required args in methods
from r8889: allow a doc string in DEF-STANDARD-INITIAL-BINDING
from r8680: don't call NCONC for effect (even though it's well-defined in this case)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/macros.lisp

    r11128 r11138  
    273273                           clauses))
    274274        (cluster (gensym)))   
    275     `(let* (,@fns
    276             (,cluster (list ,@bindings))
    277             (%handlers% (cons ,cluster %handlers%)))
    278        (declare (dynamic-extent ,cluster %handlers%))
    279        ,@decls
    280        (progn
     275    (if (null bindings)
     276      `(progn ,@body)
     277      `(let* (,@fns
     278              (,cluster (list ,@bindings))
     279              (%handlers% (cons ,cluster %handlers%)))
     280         (declare (dynamic-extent ,cluster %handlers%))
     281         ,@decls
    281282         ,@body))))
    282283
     
    317318                 `(block ,block
    318319                    (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test))
    319                            (,cluster (list ,restart-name))
    320                            (%restarts% (cons ,cluster %restarts%)))
    321                       (declare (dynamic-extent ,restart-name ,cluster %restarts%))
    322                       (catch ,cluster (return-from ,block ,form)))
     320                           (,cluster (list ,restart-name)))
     321                      (declare (dynamic-extent ,restart-name ,cluster))
     322                      (catch ,cluster
     323                        (let ((%restarts% (cons ,cluster %restarts%)))
     324                          (declare (dynamic-extent %restarts%))
     325                          (return-from ,block ,form))))
    323326                    ,@body))))
    324327            (t
     
    337340               `(block ,block
    338341                  (let ((,val (let* (,@restarts
    339                                      (,cluster (list ,@(reverse restart-names)))
    340                                      (%restarts% (cons ,cluster %restarts%)))
    341                                 (declare (dynamic-extent ,@restart-names ,cluster %restarts%))
    342                                 (catch ,cluster (return-from ,block ,form)))))
     342                                     (,cluster (list ,@(reverse restart-names))))
     343                                (declare (dynamic-extent ,@restart-names ,cluster))
     344                                (catch ,cluster
     345                                  (let ((%restarts% (cons ,cluster %restarts%)))
     346                                    (declare (dynamic-extent %restarts%))
     347                                    (return-from ,block ,form))))))
    343348                    (case (pop ,val)
    344349                      ,@(nreverse cases))))))))))
     
    411416                 `(block ,block
    412417                    ((lambda ,var ,@body)
    413                       (let* ((,cluster (list ',type))
    414                             (%handlers% (cons ,cluster %handlers%)))
    415                        (declare (dynamic-extent ,cluster %handlers%))
    416                        (catch ,cluster (return-from ,block ,form)))))
     418                      (let* ((,cluster (list ',type)))
     419                        (declare (dynamic-extent ,cluster))
     420                        (catch ,cluster
     421                          (let ((%handlers% (cons ,cluster %handlers%)))
     422                            (declare (dynamic-extent %handlers%))
     423                            (return-from ,block ,form))))))
    417424                 `(block ,block
    418                     (let* ((,cluster (list ',type))
    419                            (%handlers% (cons ,cluster %handlers%)))
    420                       (declare (dynamic-extent ,cluster %handlers%))
    421                       (catch ,cluster (return-from ,block ,form)))
    422                     (locally ,@body))))))
     425                    (let* ((,cluster (list ',type)))
     426                      (declare (dynamic-extent ,cluster))
     427                      (catch ,cluster
     428                        (let ((%handlers% (cons ,cluster %handlers%)))
     429                          (declare (dynamic-extent %handlers%))
     430                          (return-from ,block ,form)))
     431                      (locally ,@body)))))))
    423432          (t (let ((block (gensym)) (cluster (gensym)) (val (gensym))
    424433                   (index -1) handlers cases)
     
    434443                           `(,index (locally ,@body))) cases)))
    435444               `(block ,block
    436                   (let ((,val (let* ((,cluster (list ,@(nreverse handlers)))
    437                                      (%handlers% (cons ,cluster %handlers%)))
    438                                 (declare (dynamic-extent ,cluster %handlers%))
    439                                 (catch ,cluster (return-from ,block ,form)))))
     445                  (let ((,val (let* ((,cluster (list ,@(nreverse handlers))))
     446                                (declare (dynamic-extent ,cluster))
     447                                (catch ,cluster
     448                                  (let ((%handlers% (cons ,cluster %handlers%)))
     449                                    (declare (dynamic-extent %handlers%))
     450                                    (return-from ,block ,form))))))
    440451                    (case (pop ,val)
    441452                      ,@(nreverse cases)))))))))))
     
    459470                                nil
    460471                                nil))
    461           (,cluster (list ,temp))
    462           (%restarts% (cons ,cluster %restarts%)))
    463      (declare (dynamic-extent ,temp ,cluster %restarts%))
    464      (catch ,cluster ,@body)))
     472          (,cluster (list ,temp)))
     473     (declare (dynamic-extent ,temp ,cluster))
     474     (catch ,cluster
     475       (let ((%restarts% (cons ,cluster %restarts%)))
     476         (declare (dynamic-extent %restarts%))
     477         ,@body))))
    465478
    466479;Like with-simple-restart but takes a pre-consed restart.  Not CL.
    467480(defmacro with-restart (restart &body body &aux (cluster (gensym)))
    468   `(let* ((,cluster (list ,restart))
    469           (%restarts% (cons ,cluster %restarts%)))
    470      (declare (dynamic-extent ,cluster %restarts%))
    471      (catch ,cluster ,@body)))
     481  `(let* ((,cluster (list ,restart)))
     482     (declare (dynamic-extent ,cluster))
     483     (catch ,cluster
     484       (let ((%restarts% (cons ,cluster %restarts%)))
     485         (declare (dynamic-extent %restarts%))
     486         ,@body))))
    472487
    473488(defmacro ignore-errors (&rest forms)
     
    676691    ',var))
    677692         
    678 (defmacro def-standard-initial-binding (name &optional (form name) &environment env)
     693(defmacro def-standard-initial-binding (name &optional (form name) (doc nil doc-p) &environment env)
    679694  `(progn
    680695    (eval-when (:compile-toplevel)
    681696      (note-variable-info ',name t ,env))   
    682697    (define-standard-initial-binding ',name #'(lambda () ,form))
     698    ,@(when doc-p
     699           `((set-documentation ',name 'variable ,doc)))
    683700    ',name))
    684701
     
    852869      (if (assoc atom-or-list used-keys)
    853870        (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type)
    854         (nconc used-keys (list (cons atom-or-list t))))
     871        (setq used-keys (nconc used-keys (list (cons atom-or-list t)))))
    855872      `((,(if (typep atom-or-list '(and number (not fixnum)))
    856873              'eql
     
    14831500       *READTABLE*                      the standard readtable"
    14841501  (multiple-value-bind (decls body) (parse-body body env)
    1485     `(let ((*package* (find-package "CL-USER"))
     1502    `(let ((*package* (pkg-arg "COMMON-LISP-USER"))
    14861503           (*print-array* t)
    14871504           (*print-base* 10.)
     
    17741791                   
    17751792
     1793(defvar *warn-about-unreferenced-required-args-in-methods* #+ccl-0711 nil #-ccl-0711 T)
     1794
    17761795(defun parse-defmethod (name args env)
    17771796  (validate-function-name name)
     
    18021821              (t
    18031822               (push p parameters)
     1823               (unless *warn-about-unreferenced-required-args-in-methods*
     1824                 (push p refs))
    18041825               (push t specializers-form)
    18051826               (push t specializers)))))
     
    26142635
    26152636
    2616 
    26172637(defmacro define-toplevel-command (group-name name arglist &body body &environment env)
    26182638  (let* ((key (make-keyword name)))
     
    34693489
    34703490
    3471 
    3472 
    34733491(defmacro do-gc-areas ((area) &body body)
    34743492  (let ((initial-area (gensym)))
     
    35883606         (eintr (symbol-value (read-from-string "#$EINTR"))))
    35893607    `(loop
    3590       (let* ((,res (progn ,@body)))
    3591         (unless (eql ,res (- ,eintr))
    3592           (return ,res))))))
     3608       (let* ((,res (progn ,@body)))
     3609         (unless (eql ,res (- ,eintr))
     3610           (return ,res))))))
    35933611
    35943612(defmacro ff-call-ignoring-eintr (&body body)
     
    35963614         (eintr (symbol-value (read-from-string "#$EINTR"))))
    35973615    `(loop
    3598       (let* ((,res (progn ,@body)))
    3599         (when (< ,res 0)
    3600           (setq ,res (%get-errno)))
    3601         (unless (eql ,res (- ,eintr))
    3602           (return ,res))))))
     3616       (let* ((,res (progn ,@body)))
     3617         (declare (fixnum ,res))
     3618         (when (< ,res 0)
     3619           (setq ,res (%get-errno)))
     3620         (unless (eql ,res (- ,eintr))
     3621           (return ,res))))))
    36033622
    36043623(defmacro basic-stream-ioblock (s)
Note: See TracChangeset for help on using the changeset viewer.