Changeset 11805
- Timestamp:
- 04/30/09 06:03:30 (14 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 2 edited
-
compiler-pass1.lisp (modified) (6 diffs)
-
precompiler.lisp (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r11804 r11805 470 470 ,@body)))))) 471 471 472 (defun rewrite-lambda (form) 473 (setf form (rewrite-aux-vars form)) 474 (let* ((lambda-list (cadr form))) 475 (if (not (or (memq '&optional lambda-list) 476 (memq '&key lambda-list))) 477 ;; no need to rewrite: no arguments with possible initforms anyway 478 form 479 (multiple-value-bind (body decls doc) 480 (parse-body (cddr form)) 481 (let (state let-bindings new-lambda-list 482 (non-constants 0)) 483 (do* ((vars lambda-list (cdr vars)) 484 (var (car vars) (car vars))) 485 ((endp vars)) 486 (push (car vars) new-lambda-list) 487 (let ((replacement (gensym))) 488 (flet ((parse-compound-argument (arg) 489 "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, 490 SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." 491 (destructuring-bind 492 (name &optional (initform nil initform-supplied-p) 493 (supplied-p nil supplied-p-supplied-p)) 494 (if (listp arg) arg (list arg)) 495 (if (listp name) 496 (values (cadr name) (car name) 497 initform initform-supplied-p 498 supplied-p supplied-p-supplied-p) 499 (values name (make-keyword name) 500 initform initform-supplied-p 501 supplied-p supplied-p-supplied-p))))) 502 (case var 503 (&optional (setf state :optional)) 504 (&key (setf state :key)) 505 ((&whole &environment &rest &body &allow-other-keys) 506 ;; do nothing special 507 ) 508 (t 509 (cond 510 ((atom var) 511 (setf (car new-lambda-list) 512 (if (eq state :key) 513 (list (list (make-keyword var) replacement)) 514 replacement)) 515 (push (list var replacement) let-bindings)) 516 ((constantp (second var)) 517 ;; so, we must have a consp-type var we're looking at 518 ;; and it has a constantp initform 519 (multiple-value-bind 520 (name keyword initform initform-supplied-p 521 supplied-p supplied-p-supplied-p) 522 (parse-compound-argument var) 523 (let ((var-form (if (eq state :key) 524 (list keyword replacement) 525 replacement)) 526 (supplied-p-replacement (gensym))) 527 (setf (car new-lambda-list) 528 (cond 529 ((not initform-supplied-p) 530 (list var-form)) 531 ((not supplied-p-supplied-p) 532 (list var-form initform)) 533 (t 534 (list var-form initform 535 supplied-p-replacement)))) 536 (push (list name replacement) let-bindings) 537 ;; if there was a 'supplied-p' variable, it might 538 ;; be used in the declarations. Since those will be 539 ;; moved below the LET* block, we need to move the 540 ;; supplied-p parameter too. 541 (when supplied-p-supplied-p 542 (push (list supplied-p supplied-p-replacement) 543 let-bindings))))) 544 (t 545 (incf non-constants) 546 ;; this is either a keyword or an optional argument 547 ;; with a non-constantp initform 548 (multiple-value-bind 549 (name keyword initform initform-supplied-p 550 supplied-p supplied-p-supplied-p) 551 (parse-compound-argument var) 552 (declare (ignore initform-supplied-p)) 553 (let ((var-form (if (eq state :key) 554 (list keyword replacement) 555 replacement)) 556 (supplied-p-replacement (gensym))) 557 (setf (car new-lambda-list) 558 (list var-form nil supplied-p-replacement)) 559 (push (list name `(if ,supplied-p-replacement 560 ,replacement ,initform)) 561 let-bindings) 562 (when supplied-p-supplied-p 563 (push (list supplied-p supplied-p-replacement) 564 let-bindings))))))))))) 565 (if (zerop non-constants) 566 ;; there was no reason to rewrite... 567 form 568 (let ((rv 569 `(lambda ,(nreverse new-lambda-list) 570 ,@(when doc (list doc)) 571 (let* ,(nreverse let-bindings) 572 ,@decls ,@body)))) 573 rv))))))) 574 472 575 (defun p1-flet (form) 473 576 (with-local-functions-for-flet/labels … … 478 581 (let* ((block-name (fdefinition-block-name name)) 479 582 (lambda-expression 480 (rewrite- aux-vars583 (rewrite-lambda 481 584 `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))) 482 585 (*visible-variables* *visible-variables*) … … 506 609 (multiple-value-bind (body decls) (parse-body body) 507 610 (setf (compiland-lambda-expression compiland) 508 (rewrite- aux-vars611 (rewrite-lambda 509 612 `(lambda ,lambda-list ,@decls (block ,name ,@body))))) 510 613 (push variable *all-variables*) … … 567 670 (setf (compiland-lambda-expression compiland) 568 671 ;; if there still was a doc-string present, remove it 569 (rewrite- aux-vars672 (rewrite-lambda 570 673 `(lambda ,lambda-list ,@decls ,@body))) 571 674 (let ((*visible-variables* *visible-variables*) … … 597 700 "P1-LAMBDA: can't handle optional argument with non-constant initform."))))))) 598 701 (p1-function (list 'FUNCTION 599 (rewrite- aux-varsform)))))702 (rewrite-lambda form))))) 600 703 601 704 (defun p1-eval-when (form) … … 914 1017 (let ((form (compiland-lambda-expression compiland))) 915 1018 (aver (eq (car form) 'LAMBDA)) 916 (setf form (rewrite- aux-varsform))1019 (setf form (rewrite-lambda form)) 917 1020 (process-optimization-declarations (cddr form)) 918 1021 -
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
r11801 r11805 552 552 (precompile-psetf form)) 553 553 554 (defun maybe-rewrite-lambda (form)555 (let* ((lambda-list (cadr form)))556 (if (not (or (memq '&optional lambda-list)557 (memq '&key lambda-list)))558 ;; no need to rewrite: no arguments with possible initforms anyway559 form560 (multiple-value-bind (body decls doc)561 (parse-body (cddr form))562 (let (state let-bindings new-lambda-list563 (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 (setf new-lambda-list568 (append (reverse vars) new-lambda-list)))569 (push (car vars) new-lambda-list)570 (let ((replacement (gensym)))571 (flet ((parse-compound-argument (arg)572 "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P,573 SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument."574 (destructuring-bind575 (name &optional (initform nil initform-supplied-p)576 (supplied-p nil supplied-p-supplied-p))577 (if (listp arg) arg (list arg))578 (if (listp name)579 (values (cadr name) (car name)580 initform initform-supplied-p581 supplied-p supplied-p-supplied-p)582 (values name (make-keyword name)583 initform initform-supplied-p584 supplied-p supplied-p-supplied-p)))))585 (case var586 (&optional (setf state :optional))587 (&key (setf state :key))588 ((&whole &environment &rest &body &allow-other-keys)589 ;; do nothing special590 )591 (t592 (cond593 ((atom var)594 (setf (car new-lambda-list)595 (if (eq state :key)596 (list (list (make-keyword var) replacement))597 replacement))598 (push (list var replacement) let-bindings))599 ((constantp (second var))600 ;; so, we must have a consp-type var we're looking at601 ;; and it has a constantp initform602 (multiple-value-bind603 (name keyword initform initform-supplied-p604 supplied-p supplied-p-supplied-p)605 (parse-compound-argument var)606 (let ((var-form (if (eq state :key)607 (list keyword replacement)608 replacement))609 (supplied-p-replacement (gensym)))610 (setf (car new-lambda-list)611 (cond612 ((not initform-supplied-p)613 (list var-form))614 ((not supplied-p-supplied-p)615 (list var-form initform))616 (t617 (list var-form initform618 supplied-p-replacement))))619 (push (list name replacement) let-bindings)620 ;; if there was a 'supplied-p' variable, it might621 ;; be used in the declarations. Since those will be622 ;; moved below the LET* block, we need to move the623 ;; supplied-p parameter too.624 (when supplied-p-supplied-p625 (push (list supplied-p supplied-p-replacement)626 let-bindings)))))627 (t628 (incf non-constants)629 ;; this is either a keyword or an optional argument630 ;; with a non-constantp initform631 (multiple-value-bind632 (name keyword initform initform-supplied-p633 supplied-p supplied-p-supplied-p)634 (parse-compound-argument var)635 (declare (ignore initform-supplied-p))636 (let ((var-form (if (eq state :key)637 (list keyword replacement)638 replacement))639 (supplied-p-replacement (gensym)))640 (setf (car new-lambda-list)641 (list var-form nil supplied-p-replacement))642 (push (list name `(if ,supplied-p-replacement643 ,replacement ,initform))644 let-bindings)645 (when supplied-p-supplied-p646 (push (list supplied-p supplied-p-replacement)647 let-bindings)))))))))))648 (if (zerop non-constants)649 ;; there was no reason to rewrite...650 form651 (let ((rv652 `(lambda ,(nreverse new-lambda-list)653 ,@(when doc (list doc))654 (let* ,(nreverse let-bindings)655 ,@decls ,@body))))656 rv)))))))657 554 658 555 (defun precompile-lambda-list (form) … … 679 576 680 577 (defun precompile-lambda (form) 681 (setq form (maybe-rewrite-lambda form))682 578 (let ((body (cddr form)) 683 579 (precompiled-lambda-list … … 690 586 (defun precompile-named-lambda (form) 691 587 (let ((lambda-form (list* 'LAMBDA (caddr form) (cdddr form)))) 692 (setf lambda-form (maybe-rewrite-lambda lambda-form))693 588 (let ((body (cddr lambda-form)) 694 589 (precompiled-lambda-list … … 842 737 (defun precompile-local-function-def (def) 843 738 (let ((name (car def)) 844 (arglist (cadr def))845 739 (body (cddr def))) 846 740 ;; Macro names are shadowed by local functions. 847 741 (environment-add-function-definition *compile-file-environment* name body) 848 ( list* name arglist (mapcar #'precompile1 body))))742 (cdr (precompile-named-lambda (list* 'NAMED-LAMBDA def))))) 849 743 850 744 (defun precompile-local-functions (defs)
Note: See TracChangeset
for help on using the changeset viewer.
