Changeset 11797
- Timestamp:
- 04/29/09 19:11:44 (14 years ago)
- File:
-
- 1 edited
-
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
r11796 r11797 554 554 (defun maybe-rewrite-lambda (form) 555 555 (let* ((lambda-list (cadr form))) 556 (multiple-value-bind (body decls doc) 557 (parse-body (cddr form)) 558 (let (state let-bindings new-lambda-list 559 (non-constants 0)) 560 (do* ((vars lambda-list (cdr vars)) 561 (var (car vars) (car vars))) 562 ((endp vars)) 563 (push (car vars) new-lambda-list) 564 (let ((replacement (gensym))) 565 (flet ((parse-compound-argument (arg) 566 "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, 556 (if (not (or (memq '&optional lambda-list) 557 (memq '&key lambda-list))) 558 ;; no need to rewrite: no arguments with possible initforms anyway 559 form 560 (multiple-value-bind (body decls doc) 561 (parse-body (cddr form)) 562 (let (state let-bindings new-lambda-list 563 (non-constants 0)) 564 (do* ((vars lambda-list (cdr vars)) 565 (var (car vars) (car vars))) 566 ((or (endp vars) (eq '&aux (car vars)))) 567 (push (car vars) new-lambda-list) 568 (let ((replacement (gensym))) 569 (flet ((parse-compound-argument (arg) 570 "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, 567 571 SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." 568 (destructuring-bind 569 (name &optional (initform nil initform-supplied-p) 570 (supplied-p nil supplied-p-supplied-p)) 571 (if (listp arg) arg (list arg)) 572 (if (listp name) 573 (values (cadr name) (car name) 574 initform initform-supplied-p 575 supplied-p supplied-p-supplied-p) 576 (values name (make-keyword name) 577 initform initform-supplied-p 578 supplied-p supplied-p-supplied-p))))) 579 (case var 580 (&optional (setf state :optional)) 581 (&key (setf state :key)) 582 ((&whole &environment &rest &body &allow-other-keys) 583 ;; do nothing special 584 ) 585 (t 586 (cond 587 ((atom var) 588 (setf (car new-lambda-list) 589 (if (eq state :key) 590 (list (list (make-keyword var) replacement)) 591 replacement)) 592 (push (list var replacement) let-bindings)) 593 ((constantp (second var)) 594 ;; so, we must have a consp-type var we're looking at 595 ;; and it has a constantp initform 596 (multiple-value-bind 597 (name keyword initform initform-supplied-p 598 supplied-p supplied-p-supplied-p) 599 (parse-compound-argument var) 600 (let ((var-form (if (eq state :key) 601 (list keyword replacement) 602 replacement)) 603 (supplied-p-replacement (gensym))) 572 (destructuring-bind 573 (name &optional (initform nil initform-supplied-p) 574 (supplied-p nil supplied-p-supplied-p)) 575 (if (listp arg) arg (list arg)) 576 (if (listp name) 577 (values (cadr name) (car name) 578 initform initform-supplied-p 579 supplied-p supplied-p-supplied-p) 580 (values name (make-keyword name) 581 initform initform-supplied-p 582 supplied-p supplied-p-supplied-p))))) 583 (case var 584 (&optional (setf state :optional)) 585 (&key (setf state :key)) 586 ((&whole &environment &rest &body &allow-other-keys) 587 ;; do nothing special 588 ) 589 (t 590 (cond 591 ((atom var) 604 592 (setf (car new-lambda-list) 605 (cond 606 ((not initform-supplied-p) 607 (list var-form)) 608 ((not supplied-p-supplied-p) 609 (list var-form initform)) 610 (t 611 (list var-form initform 612 supplied-p-replacement)))) 613 (push (list name replacement) let-bindings) 614 ;; if there was a 'supplied-p' variable, it might 615 ;; be used in the declarations. Since those will be 616 ;; moved below the LET* block, we need to move the 617 ;; supplied-p parameter too. 618 (when supplied-p-supplied-p 619 (push (list supplied-p supplied-p-replacement) 620 let-bindings))))) 621 (t 622 (incf non-constants) 623 ;; this is either a keyword or an optional argument 624 ;; with a non-constantp initform 625 (multiple-value-bind 626 (name keyword initform initform-supplied-p 627 supplied-p supplied-p-supplied-p) 628 (parse-compound-argument var) 629 (declare (ignore initform-supplied-p)) 630 (let ((var-form (if (eq state :key) 631 (list keyword replacement) 632 replacement)) 633 (supplied-p-replacement (gensym))) 634 (setf (car new-lambda-list) 635 (list var-form nil supplied-p-replacement)) 636 (push (list name `(if ,supplied-p-replacement 637 ,replacement ,initform)) 638 let-bindings) 639 (when supplied-p-supplied-p 640 (push (list supplied-p supplied-p-replacement) 641 let-bindings))))))))))) 642 (if (zerop non-constants) 643 ;; there was no reason to rewrite... 644 form 645 (let ((rv 646 `(lambda ,(nreverse new-lambda-list) 647 ,@(when doc (list doc)) 648 (let* ,(nreverse let-bindings) 649 ,@decls ,@body)))) 650 rv)))))) 593 (if (eq state :key) 594 (list (list (make-keyword var) replacement)) 595 replacement)) 596 (push (list var replacement) let-bindings)) 597 ((constantp (second var)) 598 ;; so, we must have a consp-type var we're looking at 599 ;; and it has a constantp initform 600 (multiple-value-bind 601 (name keyword initform initform-supplied-p 602 supplied-p supplied-p-supplied-p) 603 (parse-compound-argument var) 604 (let ((var-form (if (eq state :key) 605 (list keyword replacement) 606 replacement)) 607 (supplied-p-replacement (gensym))) 608 (setf (car new-lambda-list) 609 (cond 610 ((not initform-supplied-p) 611 (list var-form)) 612 ((not supplied-p-supplied-p) 613 (list var-form initform)) 614 (t 615 (list var-form initform 616 supplied-p-replacement)))) 617 (push (list name replacement) let-bindings) 618 ;; if there was a 'supplied-p' variable, it might 619 ;; be used in the declarations. Since those will be 620 ;; moved below the LET* block, we need to move the 621 ;; supplied-p parameter too. 622 (when supplied-p-supplied-p 623 (push (list supplied-p supplied-p-replacement) 624 let-bindings))))) 625 (t 626 (incf non-constants) 627 ;; this is either a keyword or an optional argument 628 ;; with a non-constantp initform 629 (multiple-value-bind 630 (name keyword initform initform-supplied-p 631 supplied-p supplied-p-supplied-p) 632 (parse-compound-argument var) 633 (declare (ignore initform-supplied-p)) 634 (let ((var-form (if (eq state :key) 635 (list keyword replacement) 636 replacement)) 637 (supplied-p-replacement (gensym))) 638 (setf (car new-lambda-list) 639 (list var-form nil supplied-p-replacement)) 640 (push (list name `(if ,supplied-p-replacement 641 ,replacement ,initform)) 642 let-bindings) 643 (when supplied-p-supplied-p 644 (push (list supplied-p supplied-p-replacement) 645 let-bindings))))))))))) 646 (if (zerop non-constants) 647 ;; there was no reason to rewrite... 648 form 649 (let ((rv 650 `(lambda ,(nreverse new-lambda-list) 651 ,@(when doc (list doc)) 652 (let* ,(nreverse let-bindings) 653 ,@decls ,@body)))) 654 rv))))))) 651 655 652 656 (defun precompile-lambda-list (form)
Note: See TracChangeset
for help on using the changeset viewer.
