Changeset 11139
 Timestamp:
 Oct 17, 2008, 5:35:56 PM (12 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

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