Changeset 7841


Ignore:
Timestamp:
Dec 7, 2007, 5:16:17 PM (13 years ago)
Author:
gb
Message:

Compiler-macro on (apply #'make-instace 'name ...)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/optimizers.lisp

    r7750 r7841  
    319319
    320320(define-compiler-macro apply  (&whole call &environment env fn arg0 &rest args)
    321   (let ((original-fn fn))
    322     (if (and arg0
    323              (null args)
    324              (consp fn)
    325              (eq (%car fn) 'function)
    326              (null (cdr (%cdr fn)))
    327              (consp (setq fn (%cadr fn)))
    328              (eq (%car fn) 'lambda))
    329       (destructuring-bind (lambda-list &body body) (%cdr fn)
    330         `(destructuring-bind ,lambda-list ,arg0 ,@body))
    331       (let ((last (%car (last (push arg0 args)))))
    332         (if (and (consp last) (memq (%car last) '(cons list* list)))
    333           (cons (if (eq (%car last) 'list) 'funcall 'apply)
    334                 (cons
    335                  original-fn
    336                  (nreconc (cdr (reverse args)) (%cdr last))))
    337           call)))))
     321  ;; Special-case (apply #'make-instance 'name ...)
     322  ;; Might be good to make this a little more general, e.g., there
     323  ;; may be other things that can be strength-reduced even if we can't
     324  ;; get rid of the APPLY.
     325  (if (and (consp fn)
     326           (or (eq (car fn) 'quote)
     327               (eq (car fn) 'function))
     328           (consp (cdr fn))
     329           (null (cddr fn))
     330           (eq (cadr fn) 'make-instance)
     331           (consp arg0)
     332           (consp (cdr arg0))
     333           (symbolp (cadr arg0)))
     334    (let* ((name (cadr arg0))
     335           (class-cell (gensym)))
     336      `(let* ((,class-cell (load-time-value (find-class-cell ',name t))))
     337        (apply (class-cell-instantiate ,class-cell) ,class-cell ,@args)))
     338    (let ((original-fn fn))
     339      (if (and arg0
     340               (null args)
     341               (consp fn)
     342               (eq (%car fn) 'function)
     343               (null (cdr (%cdr fn)))
     344               (consp (setq fn (%cadr fn)))
     345               (eq (%car fn) 'lambda))
     346        (destructuring-bind (lambda-list &body body) (%cdr fn)
     347          `(destructuring-bind ,lambda-list ,arg0 ,@body))
     348        (let ((last (%car (last (push arg0 args)))))
     349          (if (and (consp last) (memq (%car last) '(cons list* list)))
     350            (cons (if (eq (%car last) 'list) 'funcall 'apply)
     351                  (cons
     352                   original-fn
     353                   (nreconc (cdr (reverse args)) (%cdr last))))
     354            call))))))
    338355
    339356
Note: See TracChangeset for help on using the changeset viewer.