Changeset 13473
- Timestamp:
- 08/12/11 22:31:54 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r13472 r13473 876 876 (defun validate-function-name (name) 877 877 (unless (or (symbolp name) (setf-function-name-p name)) 878 (compiler-error "~S is not a valid function name." name))) 879 880 (defmacro with-local-functions-for-flet/labels 881 (form local-functions-var lambda-list-var name-var body-var body1 body2) 882 `(let ((*visible-variables* *visible-variables*) 878 (compiler-error "~S is not a valid function name." name)) 879 name) 880 881 (defun construct-flet/labels-function (definition variable-name) 882 (let* ((name (car definition)) 883 (block-name (fdefinition-block-name (validate-function-name name))) 884 (lambda-list (cadr definition)) 885 (compiland (make-compiland :name name :parent *current-compiland*)) 886 (local-function (make-local-function :name name :compiland compiland))) 887 (push compiland (compiland-children *current-compiland*)) 888 (when variable-name 889 (setf (local-function-variable local-function) 890 (make-variable :name variable-name))) 891 (multiple-value-bind 892 (body decls) 893 (parse-body (cddr definition)) 894 (setf (local-function-definition local-function) 895 (copy-tree (cdr definition))) 896 (setf (compiland-lambda-expression compiland) 897 (rewrite-lambda `(lambda ,lambda-list 898 ,@decls 899 (block ,block-name 900 ,@body))))) 901 local-function)) 902 903 (defun p1-flet (form) 904 (let* ((local-functions 905 (mapcar #'(lambda (definition) 906 (construct-flet/labels-function definition nil)) 907 (cadr form))) 908 (*local-functions* *local-functions*)) 909 (dolist (local-function local-functions) 910 (p1-compiland (local-function-compiland local-function))) 911 (dolist (local-function local-functions) 912 (push local-function *local-functions*)) 913 (with-saved-compiler-policy 914 (process-optimization-declarations (cddr form)) 915 (let* ((block (make-flet-node)) 916 (*block* block) 917 (*blocks* (cons block *blocks*)) 918 (body (cddr form)) 919 (*visible-variables* *visible-variables*)) 920 (setf (flet-free-specials block) 921 (process-declarations-for-vars body nil block)) 922 (dolist (special (flet-free-specials block)) 923 (push special *visible-variables*)) 924 (setf body (p1-body body) ;; affects the outcome of references-needed-p 925 (flet-form block) 926 (list* (car form) 927 (remove-if #'(lambda (fn) 928 (and (inline-p (local-function-name fn)) 929 (not (local-function-references-needed-p fn)))) 930 local-functions) 931 body)) 932 block)))) 933 934 935 (defun p1-labels (form) 936 (let* ((local-functions 937 (mapcar #'(lambda (definition) 938 (construct-flet/labels-function definition (gensym))) 939 (cadr form))) 883 940 (*local-functions* *local-functions*) 884 (parent-compiland *current-compiland*) 885 (,local-functions-var '())) 886 (dolist (definition (cadr ,form)) 887 (let ((,name-var (car definition)) 888 (,lambda-list-var (cadr definition))) 889 (validate-function-name ,name-var) 890 (let* ((,body-var (cddr definition)) 891 (compiland (make-compiland :name ,name-var 892 :parent parent-compiland))) 893 (push compiland (compiland-children parent-compiland)) 894 ,@body1))) 895 (setf ,local-functions-var (nreverse ,local-functions-var)) 896 ;; Make the local functions visible. 897 (dolist (local-function ,local-functions-var) 898 (push local-function *local-functions*) 899 (let ((variable (local-function-variable local-function))) 900 (when variable 901 (push variable *visible-variables*)))) 902 ,@body2)) 903 904 (defun p1-flet (form) 905 (with-local-functions-for-flet/labels 906 form local-functions lambda-list name body 907 ((let ((local-function (make-local-function :name name 908 :compiland compiland)) 909 (definition (cons lambda-list body))) 910 (multiple-value-bind (body decls) (parse-body body) 911 (let* ((block-name (fdefinition-block-name name)) 912 (lambda-expression 913 (rewrite-lambda `(lambda ,lambda-list 914 ,@decls 915 (block ,block-name ,@body))))) 916 (setf (compiland-lambda-expression compiland) lambda-expression) 917 (setf (local-function-definition local-function) 918 (copy-tree definition)) 919 (p1-compiland compiland))) 920 (push local-function local-functions))) 921 ((with-saved-compiler-policy 922 (process-optimization-declarations (cddr form)) 923 (let* ((block (make-flet-node)) 924 (*block* block) 925 (*blocks* (cons block *blocks*)) 926 (body (cddr form)) 927 (*visible-variables* *visible-variables*)) 928 (setf (flet-free-specials block) 929 (process-declarations-for-vars body nil block)) 930 (dolist (special (flet-free-specials block)) 931 (push special *visible-variables*)) 932 (let ((body (p1-body (cddr form)))) 933 (setf (flet-form block) 934 (list* (car form) 935 (remove-if (lambda (fn) 936 (and (inline-p (local-function-name fn)) 937 (not (local-function-references-needed-p fn)))) 938 local-functions) 939 body))) 940 block))))) 941 942 943 (defun p1-labels (form) 944 (with-local-functions-for-flet/labels 945 form local-functions lambda-list name body 946 ((let* ((variable (make-variable :name (gensym))) 947 (local-function (make-local-function :name name 948 :compiland compiland 949 :variable variable)) 950 (block-name (fdefinition-block-name name))) 951 (setf (local-function-definition local-function) 952 (copy-tree (cons lambda-list body))) 953 (multiple-value-bind (body decls) (parse-body body) 954 (setf (compiland-lambda-expression compiland) 955 (rewrite-lambda 956 `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))) 957 (push variable *all-variables*) 958 (push local-function local-functions))) 959 ((dolist (local-function local-functions) 960 (let ((*visible-variables* *visible-variables*)) 961 (p1-compiland (local-function-compiland local-function)))) 962 (let* ((block (make-labels-node)) 963 (*block* block) 964 (*blocks* (cons block *blocks*)) 965 (body (cddr form)) 966 (*visible-variables* *visible-variables*)) 967 (setf (labels-free-specials block) 968 (process-declarations-for-vars body nil block)) 969 (dolist (special (labels-free-specials block)) 970 (push special *visible-variables*)) 971 (setf (labels-form block) 972 (list* (car form) local-functions (p1-body (cddr form)))) 973 block)))) 941 (*visible-variables* *visible-variables*)) 942 (dolist (local-function local-functions) 943 (push local-function *local-functions*) 944 (let ((variable (local-function-variable local-function))) 945 (push variable *all-variables*) 946 (push variable *visible-variables*))) 947 (dolist (local-function local-functions) 948 (p1-compiland (local-function-compiland local-function))) 949 (let* ((block (make-labels-node)) 950 (*block* block) 951 (*blocks* (cons block *blocks*)) 952 (body (cddr form)) 953 (*visible-variables* *visible-variables*)) 954 (setf (labels-free-specials block) 955 (process-declarations-for-vars body nil block)) 956 (dolist (special (labels-free-specials block)) 957 (push special *visible-variables*)) 958 (setf (labels-form block) 959 (list* (car form) local-functions (p1-body (cddr form)))) 960 block))) 974 961 975 962 (defknown p1-funcall (t) t)
Note: See TracChangeset
for help on using the changeset viewer.