Changeset 9520


Ignore:
Timestamp:
May 16, 2008, 1:37:32 AM (11 years ago)
Author:
gb
Message:

Make %CALL-ENCAPSULATED-GF handle different patterns of dcode/prototypes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/lib/encapsulate.lisp

    r9431 r9520  
    140140; she works now - does the equivalent of the original gf - called from traced def
    141141(defun %%call-encapsulated-gf (thing args)
    142   ; (print 'one)(print thing)(print args)
    143   ; thing is gf . %%1st-arg-dcode
    144   ; args is ok
     142  ;; (print 'one)(print thing)(print args)
     143  ;; thing is gf . %%1st-arg-dcode
     144  ;; args is ok
    145145  (let* ((dcode (cdr thing))
    146          (proto (assq dcode dcode-proto-alist))  ; <<
    147          (dt (%gf-dispatch-table (car thing))))
    148     (if proto ; assume all of these special dudes want args individually
     146         (proto (cdr (assq dcode dcode-proto-alist))))  ; <<
     147    ;; There are only 3 trampoline prototypes that pass a dispatch
     148    ;; table; of these, *GF-PROTO* passes the dispatch table and
     149    ;; args (lexpr or list), while the other two pass the dispatch
     150    ;; table and either 1 or 2 additional args.
     151    (if proto
     152      ;; If the dcode has an entry on dcode-proto-alist, assume
     153      ;; that it wants the dispatch table as its first arg.
     154      (let* ((dt (%gf-dispatch-table (car thing))))
     155        (if (eq proto *gf-proto*)
     156          ;; The dcode wants all of the args that the gf was called
     157          ;; with all incoming args collected into a list or lexpr, as
     158          ;; well as the dt.
     159          (funcall dcode dt args)
     160          ;; The one-arg or two-arg trampoline would have already
     161          ;; ensured that the GF was called with the right number
     162          ;; of fixed args, but we haven't been down that path yet.
     163          ;; There are only the 1-arg and 2-arg cases to check.
     164          (let* ((nargs (if (listp args) (length args) (%lexpr-count args))))
     165            (declare (fixnum nargs))
     166            (if (eq proto *gf-proto-one-arg*)
     167              (if (= nargs 1)
     168                (funcall dcode dt (if (listp args) (car args) (%lexpr-ref args 1 0)))
     169                (error (if (< nargs 1) 'too-few-arguments 'too-many-arguments)
     170                       :nargs nargs
     171                       :fn (%gf-dispatch-table-gf dt)))
     172              (if (= nargs 2)
     173                (funcall dcode
     174                         dt
     175                         (if (listp args) (car args) (%lexpr-ref args 2 0))
     176                         (if (listp args) (cadr args) (%lexpr-ref args 2 1)))
     177
     178                (error (if (< nargs 2) 'too-few-arguments 'too-many-arguments)
     179                       :nargs nargs
     180                       :fn (%gf-dispatch-table-gf dt)))))))
    149181      (if (listp args)
    150         (apply dcode dt args)
    151         (%apply-lexpr dcode dt args))
    152       (funcall dcode dt args))))
     182        (apply dcode args)
     183        (%apply-lexpr dcode args)))))
    153184   
    154 
    155 
    156                      ; (apply encapsulation args)
    157185
    158186
Note: See TracChangeset for help on using the changeset viewer.