Changeset 11786
 Timestamp:
 04/26/09 07:08:43 (14 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
r11755 r11786 354 354 (declaim (ftype (function (t) t) precompile1)) 355 355 (defun precompile1 (form) 356 ;; (sys::%format t "~S~%" form) 356 357 (cond ((symbolp form) 357 358 (let ((varspec (findvarspec form))) … … 600 601 `(lambda ,lambdalist ,@lambdadecls (let* ,lets ,@letdecls ,@body)))))) 601 602 603 # 604 (defun splitdeclarations (relatedsymbols decls) 605 "Splits IGNORE, IGNORABLE, DYNAMICEXTENT, TYPE, FTYPE and <typespecifier> 606 into the declarations related to `relatedsymbols' and the rest." 607 ;; IGNORE, IGNORABLE and DYNAMICEXTENT have the same format 608 (let (relateddecls otherdecls) 609 (dolist (declform decls) 610 (dolist (decl (cdr declform)) 611 (case (car decl) 612 ((IGNORE IGNORABLE DYNAMICEXTENT SPECIAL) 613 (let (rel oth) 614 615 ...) 616 ((TYPE FTYPE) ;; FUNCTION? 617 ...) 618 ((INLINE NOTINLINE OPTIMIZE DECLARATION) 619 (push decl otherdecls)) 620 (t 621 (if (symbolp (car decl)) ;; a type specifier 622 ... 623 (push decl otherdecls)))))) 624 (values relateddecls otherdecls))) 625 # 626 602 627 (defun mayberewritelambda (form) 603 628 (let* ((lambdalist (cadr form))) … … 607 632 (multiplevaluebind (body decls doc) 608 633 (parsebody (cddr form)) 609 `(lambda ,lambdalist ,@decls ,@(when doc `(,doc)) ,@body)))) 634 (let (state letbindings symbols newlambdalist 635 (nonconstants 0)) 636 (do* ((vars lambdalist (cdr vars)) 637 (var (car vars) (car vars))) 638 ((endp vars)) 639 (push (car vars) newlambdalist) 640 (let ((replacement (gensym))) 641 (case var 642 (&optional (setf state :optional)) 643 (&key (setf state :key)) 644 ((&whole &environment &rest &body &allowotherkeys) 645 ;; do nothing 646 ) 647 (t 648 (when (and (atom var) 649 (eq state :key)) 650 (setf var (list var))) 651 (cond 652 ((and (atom var) 653 (neq state :key)) 654 (setf (car newlambdalist) replacement) 655 (push (list var replacement) 656 letbindings)) ;; do nothing 657 (t ;; "(x (somefunction))" "((:x q) (somefunction))" 658 ;; or even "(x (somefunction) xsuppliedp)" 659 (destructuringbind 660 (name &optional (initform nil initformsuppliedp) 661 (suppliedp nil suppliedpsuppliedp)) 662 var 663 (when (and initformsuppliedp 664 (not (constantp initform))) 665 (incf nonconstants)) 666 (let* ((symbol (if (listp name) (second name) name)) 667 (keyword (if (listp name) (car name) 668 (intern (symbolname symbol) 669 (findpackage "KEYWORD")))) 670 (suppliedpreplacement 671 (if suppliedpsuppliedp 672 suppliedp (gensym)))) 673 (setf (car newlambdalist) 674 `(,(if (eq state :key) 675 (list keyword replacement) replacement) 676 nil ,suppliedpreplacement)) 677 (push `(,symbol (if ,suppliedpreplacement 678 ,replacement ,initform)) 679 letbindings) 680 (push symbol symbols))))))))) 681 (if (zerop nonconstants) 682 ;; there was no reason to rewrite... 683 form 684 `(lambda ,(nreverse newlambdalist) 685 ,@(when doc (list doc)) 686 (let* ,(nreverse letbindings) 687 ,@decls ,@body))))))) 610 688 611 689 (defun precompilelambda (form) 612 690 (setq form (mayberewritelambda form)) 691 ;; (sys::%format t "~S~%" form) 613 692 (let ((body (cddr form)) 614 693 (*inlinedeclarations* *inlinedeclarations*)) … … 805 884 (setf usedp t) 806 885 (return)) 807 ;; Scope of defined function names includes &AUX parameters (LABELS.7B). 808 (let ((auxvars (cdr (memq '&aux (cadr local))))) 809 (when (and auxvars (finduse name auxvars) 886 ;; Scope of defined function names includes 887 ;; &OPTIONAL, &KEY and &AUX parameters 888 ;; (LABELS.7B, LABELS.7C and LABELS.7D). 889 (let ((vars (or 890 (cdr (memq '&optional (cadr local))) 891 (cdr (memq '&key (cadr local))) 892 (cdr (memq '&aux (cadr local)))))) 893 (when (and vars (finduse name vars) 810 894 (setf usedp t) 811 895 (return))))))))
Note: See TracChangeset
for help on using the changeset viewer.