Changeset 11788
- Timestamp:
- 04/27/09 20:24:57 (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
r11787 r11788 613 613 (multiple-value-bind (body decls doc) 614 614 (parse-body (cddr form)) 615 (let (state let-bindings symbolsnew-lambda-list615 (let (state let-bindings new-lambda-list 616 616 (non-constants 0)) 617 617 (do* ((vars lambda-list (cdr vars)) … … 620 620 (push (car vars) new-lambda-list) 621 621 (let ((replacement (gensym))) 622 (flet ((parse-compound-argument (arg) 623 "Returns the values NAME, KEYWORD, INITFORM, INITFORM-P, 624 SUPPLIED-P and SUPPLIED-P-P assuming ARG is a compound argument." 625 (destructuring-bind 626 (name &optional (initform nil initform-supplied-p) 627 (supplied-p nil supplied-p-supplied-p)) 628 (if (listp arg) arg (list arg)) 629 (if (listp name) 630 (values (cadr name) (car name) 631 initform initform-supplied-p 632 supplied-p supplied-p-supplied-p) 633 (values name (make-keyword name) 634 initform initform-supplied-p 635 supplied-p supplied-p-supplied-p))))) 622 636 (case var 623 637 (&optional (setf state :optional)) 624 638 (&key (setf state :key)) 625 639 ((&whole &environment &rest &body &allow-other-keys) 626 ;; do nothing 640 ;; do nothing special 627 641 ) 628 642 (t 629 (when (and (atom var)630 (eq state :key))631 (setf var (list var)))632 643 (cond 633 ((and (atom var) 634 (neq state :key)) 635 (setf (car new-lambda-list) replacement) 636 (push (list var replacement) 637 let-bindings)) ;; do nothing 638 (t ;; "(x (some-function))" "((:x q) (some-function))" 639 ;; or even "(x (some-function) x-supplied-p)" 640 (destructuring-bind 641 (name &optional (initform nil initform-supplied-p) 642 (supplied-p nil supplied-p-supplied-p)) 643 var 644 (when (and initform-supplied-p 645 (not (constantp initform))) 646 (incf non-constants)) 647 (let* ((symbol (if (listp name) (second name) name)) 648 (keyword (if (listp name) (car name) 649 (intern (symbol-name symbol) 650 (find-package "KEYWORD")))) 651 (supplied-p-replacement 652 (if supplied-p-supplied-p 653 supplied-p (gensym)))) 644 ((atom var) 645 (setf (car new-lambda-list) 646 (if (eq state :key) 647 (list (list (make-keyword var) replacement)) 648 replacement)) 649 (push (list var replacement) let-bindings)) 650 ((constantp (second var)) 651 ;; so, we must have a consp-type var we're looking at 652 ;; and it has a constantp initform 653 (multiple-value-bind 654 (name keyword initform initform-supplied-p 655 supplied-p supplied-p-supplied-p) 656 (parse-compound-argument var) 657 (let ((var-form (if (eq state :key) 658 (list keyword replacement) 659 replacement)) 660 (supplied-p-replacement (gensym))) 654 661 (setf (car new-lambda-list) 655 `(,(if (eq state :key) 656 (list keyword replacement) replacement) 657 nil ,supplied-p-replacement)) 658 (push `(,symbol (if ,supplied-p-replacement 659 ,replacement ,initform)) 660 let-bindings) 661 (push symbol symbols))))))))) 662 (cond 663 ((not initform-supplied-p) 664 (list var-form)) 665 ((not supplied-p-supplied-p) 666 (list var-form initform)) 667 (t 668 (list var-form initform 669 supplied-p-replacement)))) 670 (push (list name replacement) let-bindings) 671 ;; if there was a 'supplied-p' variable, it might 672 ;; be used in the declarations. Since those will be 673 ;; moved below the LET* block, we need to move the 674 ;; supplied-p parameter too. 675 (when supplied-p-supplied-p 676 (push (list supplied-p supplied-p-replacement) 677 let-bindings))))) 678 (t 679 (incf non-constants) 680 ;; this is either a keyword or an optional argument 681 ;; with a non-constantp initform 682 (multiple-value-bind 683 (name keyword initform initform-supplied-p 684 supplied-p supplied-p-supplied-p) 685 (parse-compound-argument var) 686 (declare (ignore initform-supplied-p)) 687 (let ((var-form (if (eq state :key) 688 (list keyword replacement) 689 replacement)) 690 (supplied-p-replacement (gensym))) 691 (setf (car new-lambda-list) 692 (list var-form nil supplied-p-replacement)) 693 (push (list name `(if ,supplied-p-replacement 694 ,replacement ,initform)) 695 let-bindings) 696 (when supplied-p-supplied-p 697 (push (list supplied-p supplied-p-replacement) 698 let-bindings))))))))))) 662 699 (if (zerop non-constants) 663 700 ;; there was no reason to rewrite... 664 701 form 665 `(lambda ,(nreverse new-lambda-list) 666 ,@(when doc (list doc)) 667 (let* ,(nreverse let-bindings) 668 ,@decls ,@body))))))) 702 (let ((rv 703 `(lambda ,(nreverse new-lambda-list) 704 ,@(when doc (list doc)) 705 (let* ,(nreverse let-bindings) 706 ,@decls ,@body)))) 707 rv)))))) 669 708 670 709 (defun precompile-lambda (form) … … 1190 1229 (parse-body body) 1191 1230 (let* ((block-name (fdefinition-block-name name)) 1192 (lambda-expression `(named-lambda ,name ,lambda-list ,@decls ,@(when doc `(,doc)) 1193 (block ,block-name ,@body)))) 1231 (lambda-expression 1232 `(named-lambda ,name ,lambda-list 1233 ,@decls 1234 ,@(when doc `(,doc)) 1235 (block ,block-name ,@body)))) 1194 1236 (cond ((and (boundp 'jvm::*file-compilation*) 1195 1237 ;; when JVM.lisp isn't loaded yet, this variable isn't bound … … 1207 1249 (%defun ',name ,lambda-expression) 1208 1250 ,@(when doc 1209 1251 `((%set-documentation ',name 'function ,doc)))))))))
Note: See TracChangeset
for help on using the changeset viewer.