Changeset 8668
 Timestamp:
 Mar 6, 2008, 3:40:11 PM (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/working0711/ccl/lib/methodcombination.lisp
r2325 r8668 165 165 166 166 167 ; Need to special case (computeeffectivemethod #'computeeffectivemethod ...) 167 ;;; Need to special case (computeeffectivemethod 168 ;;; #'computeeffectivemethod ...) 168 169 (defmethod computeeffectivemethod ((genericfunction standardgenericfunction) 169 170 (methodcombination standardmethodcombination) … … 231 232 `(,operator ,@(mapcar #'(lambda (m) `(callmethod ,m nil)) primaries))))) 232 233 (makeeffectivemethod 234 genericfunction 233 235 (if arounds 234 236 `(callmethod ,(car arounds) … … 282 284 methods) 283 285 (or (getcombinedmethod methods genericfunction) 284 (destructuringbind ( argsvar. expander)286 (destructuringbind ((argsvar . gfname) . expander) 285 287 (methodcombinationexpander methodcombination) 286 288 (let* ((userform (funcall expander … … 288 290 methods 289 291 (methodcombinationoptions methodcombination))) 292 290 293 (effectivemethod 291 294 (if (functionp userform) 292 295 userform 293 (makeeffectivemethod userform argsvar))))296 (makeeffectivemethod genericfunction userform argsvar gfname)))) 294 297 (putcombinedmethod methods effectivemethod genericfunction))))) 295 298 … … 346 349 (logbitp $lfbitsnextmethbit lfbits)))) 347 350 348 (defun makeeffectivemethod ( form &optional (argssym (makesymbol "ARGS")))351 (defun makeeffectivemethod (gf form &optional (argssym (makesymbol "ARGS")) (gfname (makesymbol "GF"))) 349 352 (setq argssym (requiretype argssym 'symbol)) 350 353 (let (m mf) … … 360 363 nil 361 364 `(lambda (&rest ,argssym) 362 (declare (dynamicextent ,argssym)) 363 (withcallmethodcontext ,argssym 364 ,form)) 365 (declare (dynamicextent ,argssym)) 366 (let* ((,gfname ,gf)) 367 (declare (ignorable ,gfname)) 368 (withcallmethodcontext ,argssym 369 ,form))) 365 370 nil)))) 366 371 … … 436 441 (maphash temp *effectivemethodgfs*)))) 437 442 443 ;;; Support elbizarro arglist partitioning for the long form of 444 ;;; DEFINEMETHODCOMBINATION. 445 (defun nthrequiredgfarg (gf argvals i) 446 (declare (fixnum i)) 447 (let* ((bits (lfunbits gf)) 448 (numreq (ldb $lfbitsnumreq bits))) 449 (declare (fixnum bits numreq)) 450 (if (< i numreq) 451 (nth i argvals)))) 452 453 (defun nthoptgfargpresentp (gf argvals i) 454 (declare (fixnum i)) 455 (let* ((bits (lfunbits gf)) 456 (numreq (ldb $lfbitsnumreq bits)) 457 (numopt (ldb $lfbitsnumopt bits))) 458 (declare (fixnum bits numreq numopt)) 459 (and (< i numopt) 460 (< (the fixum (+ i numreq)) (length argvals))))) 461 462 ;;; This assumes that we've checked for argument presence. 463 (defun nthoptgfarg (gf argvals i) 464 (declare (fixnum i)) 465 (let* ((bits (lfunbits gf)) 466 (numreq (ldb $lfbitsnumreq bits))) 467 (declare (fixnum bits numreq )) 468 (nth (the fixum (+ i numreq)) argvals))) 469 470 (defun gfargumentstail (gf argvals) 471 (let* ((bits (lfunbits gf)) 472 (numreq (ldb $lfbitsnumreq bits)) 473 (numopt (ldb $lfbitsnumopt bits))) 474 (declare (fixnum bits numreq numopt)) 475 (nthcdr (the fixnum (+ numreq numopt)) argvals))) 476 477 (defun gfkeypresentp (gf argvals key) 478 (let* ((tail (gfargumentstail gf argvals)) 479 (missing (cons nil nil))) 480 (declare (dynamicextent missing)) 481 (not (eq missing (getf tail key missing))))) 482 483 ;; Again, this should only be called if GFKEYPRESENTP returns true. 484 (defun gfkeyvalue (gf argvals key) 485 (let* ((tail (gfargumentstail gf argvals))) 486 (getf tail key))) 487 488 489 (defun lfmcbindings (gfform argsform lambdalist) 490 (let* ((reqidx 0) 491 (optidx 0) 492 (state :required)) 493 (collect ((names) 494 (vals)) 495 (dolist (arg lambdalist) 496 (case arg 497 ((&whole &optional &rest &key &allowotherkeys &aux) 498 (setq state arg)) 499 (t 500 (case state 501 (:required 502 (names arg) 503 (vals (list 'quote `(nthrequiredgfarg ,gfform ,argsform ,reqidx))) 504 (incf reqidx)) 505 (&whole 506 (names arg) 507 (vals `,argsform) 508 (setq state :required)) 509 (&optional 510 (let* ((var arg) 511 (val nil) 512 (spvar nil)) 513 (when (listp arg) 514 (setq var (pop arg) 515 val (pop arg) 516 spvar (car arg))) 517 (names var) 518 (vals (list 'quote 519 `(if (nthoptgfargpresentp ,gfform ,argsform ,optidx) 520 (nthoptgfarg ,gfform ,argsform ,optidx) 521 ,val))) 522 (when spvar 523 (names spvar) 524 (vals (list 'quote 525 `(nthoptgfargpresentp ,gfform ,argsform ,optidx)))) 526 (incf optidx))) 527 (&rest 528 (names arg) 529 (vals (list 'quote 530 `(gfargumentstail ,gfform ,argsform)))) 531 (&key 532 (let* ((var arg) 533 (keyword nil) 534 (val nil) 535 (spvar nil)) 536 (if (atom arg) 537 (setq keyword (makesymbol (symbolname arg))) 538 (progn 539 (setq var (car arg)) 540 (if (atom var) 541 (setq keyword (makesymbol (symbolname var))) 542 (setq keyword (car var) var (cadr var))) 543 (setq val (cadr arg) spvar (caddr arg)))) 544 (names var) 545 (vals (list 'quote `(if (gfkeypresentp ,gfform ,argsform ',keyword) 546 (gfkeyvalue ,gfform ,argsform ',keyword) 547 ,val))) 548 (when spvar 549 (names spvar) 550 (vals (list 'quote `(gfkeypresentp ,gfform ,argsform ',keyword)))))) 551 (&allowotherkeys) 552 (&aux 553 (cond ((atom arg) 554 (names arg) 555 (vals nil)) 556 (t 557 (names (car arg)) 558 (vals (list 'quote (cadr arg)))))))))) 559 (values (names) (vals))))) 438 560 ;; 439 561 ;; Long form … … 467 589 (argssym (makesymbol "ARGS")) 468 590 (optionssym (makesymbol "OPTIONS")) 591 (argvars ()) 592 (argvals ()) 469 593 (code `(lambda (,genericfnsymbol ,methodssym ,optionssym) 470 594 ,@(unless gfsymbolspecified? 471 595 `((declare (ignoreifunused ,genericfnsymbol)))) 472 (let* (,@(let* ((n 1) 473 (temp #'(lambda (sym) 474 `(,sym '(nth ,(incf n) ,argssym))))) 475 (declare (dynamicextent temp)) 476 (mapcar temp arguments))) 596 (let* (,@(progn 597 (multiplevaluesetq (argvars argvals) 598 (lfmcbindings genericfnsymbol 599 argssym 600 arguments)) 601 (mapcar #'list argvars argvals))) 602 (declare (ignorable ,@argvars)) 477 603 ,@decls 478 604 (destructuringbind ,lambdalist ,optionssym … … 486 612 ,@body)))))) 487 613 `(%longformdefinemethodcombination 488 ',name (cons ',argssym#',code) ',doc))))))614 ',name (cons (cons ',argssym ',genericfnsymbol) #',code) ',doc)))))) 489 615 490 616 (defun %longformdefinemethodcombination (name argsvar.expander documentation)
Note: See TracChangeset
for help on using the changeset viewer.