Changeset 11415
- Timestamp:
- Nov 19, 2008, 4:16:57 PM (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/lib/macros.lisp
r11279 r11415 518 518 (value (cadr args))) 519 519 ;This must match get-setf-method . 520 (if (atom form) 521 (progn 522 (unless (symbolp form)(signal-program-error $XNotSym form)) 523 `(setq ,form ,value)) 524 (multiple-value-bind (ftype local-p) 525 (function-information (setq accessor (car form)) ENV) 526 (if local-p 527 (if (eq ftype :function) 528 ;Local function, so don't use global setf definitions. 529 (default-setf form value env) 530 `(setf ,(macroexpand-1 form env) ,value)) 531 (cond 532 ((setq temp (%setf-method accessor)) 533 (if (symbolp temp) 534 `(,temp ,@(cdar args) ,value) 535 (multiple-value-bind (dummies vals storevars setter #|getter|#) 536 (funcall temp form env) 537 (do* ((d dummies (cdr d)) 538 (v vals (cdr v)) 539 (let-list nil)) 540 ((null d) 541 (setq let-list (nreverse let-list)) 542 `(let* ,let-list 543 (declare (ignorable ,@dummies)) 544 (multiple-value-bind ,storevars ,value 545 #|,getter|# 546 ,setter))) 547 (push (list (car d) (car v)) let-list))))) 548 ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env) 549 (and #-bccl (boundp '%structure-refs%) 550 (gethash accessor %structure-refs%))))) 551 (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) 552 (if (consp temp) 553 ;; strip off type, but add in a require-type 554 (let ((type (%car temp))) 555 `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args)) 556 (require-type ,value ',type)))) 557 `(setf ,(defstruct-ref-transform temp (%cdar args)) 558 ,value))) 559 (t 560 (multiple-value-bind (res win) 561 (macroexpand-1 form env) 562 (if win 563 `(setf ,res ,value) 564 (default-setf form value env)))))))))) 520 (cond ((atom form) 521 (progn 522 (unless (symbolp form)(signal-program-error $XNotSym form)) 523 `(setq ,form ,value))) 524 ((eq (car form) 'the) 525 (unless (eql (length form) 3) 526 (error "Bad THE place form in (SETF ~S ~S)" form value)) 527 (destructuring-bind (type place) (cdr form) 528 `(setf ,place (the ,type ,value)))) 529 (t 530 (multiple-value-bind (ftype local-p) 531 (function-information (setq accessor (car form)) ENV) 532 (if local-p 533 (if (eq ftype :function) 534 ;Local function, so don't use global setf definitions. 535 (default-setf form value env) 536 `(setf ,(macroexpand-1 form env) ,value)) 537 (cond 538 ((setq temp (%setf-method accessor)) 539 (if (symbolp temp) 540 `(,temp ,@(cdar args) ,value) 541 (multiple-value-bind (dummies vals storevars setter #|getter|#) 542 (funcall temp form env) 543 (do* ((d dummies (cdr d)) 544 (v vals (cdr v)) 545 (let-list nil)) 546 ((null d) 547 (setq let-list (nreverse let-list)) 548 `(let* ,let-list 549 (declare (ignorable ,@dummies)) 550 (multiple-value-bind ,storevars ,value 551 #|,getter|# 552 ,setter))) 553 (push (list (car d) (car v)) let-list))))) 554 ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env) 555 (and #-bccl (boundp '%structure-refs%) 556 (gethash accessor %structure-refs%))))) 557 (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) 558 (if (consp temp) 559 ;; strip off type, but add in a require-type 560 (let ((type (%car temp))) 561 `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args)) 562 (require-type ,value ',type)))) 563 `(setf ,(defstruct-ref-transform temp (%cdar args)) 564 ,value))) 565 (t 566 (multiple-value-bind (res win) 567 (macroexpand-1 form env) 568 (if win 569 `(setf ,res ,value) 570 (default-setf form value env))))))))))) 565 571 ((oddp temp) 566 572 (signal-program-error "Odd number of args to SETF : ~s." args))
Note: See TracChangeset
for help on using the changeset viewer.