Changeset 13472 for trunk/abcl/src/org


Ignore:
Timestamp:
08/12/11 20:39:58 (10 years ago)
Author:
ehuelsmann
Message:

Miscelaneous improvements, mostly by moving code around.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13470 r13472  
    718718                   non-local-p t)))
    719719      (make-jump-node form non-local-p tag-block tag))))
    720 
    721 (defun validate-function-name (name)
    722   (unless (or (symbolp name) (setf-function-name-p name))
    723     (compiler-error "~S is not a valid function name." name)))
    724 
    725 (defmacro with-local-functions-for-flet/labels
    726     (form local-functions-var lambda-list-var name-var body-var body1 body2)
    727   `(let ((*visible-variables* *visible-variables*)
    728          (*local-functions* *local-functions*)
    729          (parent-compiland *current-compiland*)
    730          (,local-functions-var '()))
    731      (dolist (definition (cadr ,form))
    732        (let ((,name-var (car definition))
    733              (,lambda-list-var (cadr definition)))
    734          (validate-function-name ,name-var)
    735          (let* ((,body-var (cddr definition))
    736                 (compiland (make-compiland :name ,name-var
    737                                            :parent parent-compiland)))
    738            (push compiland (compiland-children parent-compiland))
    739            ,@body1)))
    740      (setf ,local-functions-var (nreverse ,local-functions-var))
    741      ;; Make the local functions visible.
    742      (dolist (local-function ,local-functions-var)
    743        (push local-function *local-functions*)
    744        (let ((variable (local-function-variable local-function)))
    745          (when variable
    746            (push variable *visible-variables*))))
    747      ,@body2))
    748720
    749721(defun split-decls (forms specific-vars)
     
    902874                rv)))))))
    903875
     876(defun validate-function-name (name)
     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*)
     883         (*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
    904904(defun p1-flet (form)
    905905  (with-local-functions-for-flet/labels
     
    911911     (let* ((block-name (fdefinition-block-name name))
    912912      (lambda-expression
    913        (rewrite-lambda `(lambda ,lambda-list ,@decls (block ,block-name ,@body))))
    914       (*visible-variables* *visible-variables*)
    915       (*local-functions* *local-functions*)
    916       (*current-compiland* compiland))
     913       (rewrite-lambda `(lambda ,lambda-list
     914                                      ,@decls
     915                                      (block ,block-name ,@body)))))
    917916       (setf (compiland-lambda-expression compiland) lambda-expression)
    918917       (setf (local-function-definition local-function)
    919918       (copy-tree definition))
    920        ;(setf (local-function-inline-expansion local-function)
    921        ;(generate-inline-expansion block-name lambda-list body))
    922919       (p1-compiland compiland)))
    923920   (push local-function local-functions)))
     
    961958   (push local-function local-functions)))
    962959      ((dolist (local-function local-functions)
    963    (let ((*visible-variables* *visible-variables*)
    964          (*current-compiland* (local-function-compiland local-function)))
     960   (let ((*visible-variables* *visible-variables*))
    965961     (p1-compiland (local-function-compiland local-function))))
    966962       (let* ((block (make-labels-node))
     
    13291325(defun p1-compiland (compiland)
    13301326;;   (format t "p1-compiland name = ~S~%" (compiland-name compiland))
    1331   (let ((form (compiland-lambda-expression compiland)))
     1327  (let ((*current-compiland* compiland)
     1328        (*local-functions* *local-functions*)
     1329        (*visible-variables* *visible-variables*)
     1330        (form (compiland-lambda-expression compiland)))
    13321331    (aver (eq (car form) 'LAMBDA))
    13331332    (setf form (rewrite-lambda form))
    1334     (process-optimization-declarations (cddr form))
    1335 
    1336     (let* ((lambda-list (cadr form))
    1337            (body (cddr form))
    1338            (*visible-variables* *visible-variables*)
    1339            (closure (make-closure `(lambda ,lambda-list nil) nil))
    1340            (syms (sys::varlist closure))
    1341            (vars nil)
    1342            compiland-result)
    1343       (dolist (sym syms)
    1344         (let ((var (make-variable :name sym
    1345                                   :special-p (special-variable-p sym))))
    1346           (push var vars)
    1347           (push var *all-variables*)
    1348           (push var *visible-variables*)))
    1349       (setf (compiland-arg-vars compiland) (nreverse vars))
    1350       (let ((free-specials (process-declarations-for-vars body vars nil)))
    1351         (setf (compiland-free-specials compiland) free-specials)
    1352         (dolist (var free-specials)
    1353           (push var *visible-variables*)))
    1354       (setf compiland-result
    1355             (list* 'LAMBDA lambda-list (p1-body body)))
    1356       (setf (compiland-%single-valued-p compiland)
    1357             (single-valued-p compiland-result))
    1358       (setf (compiland-p1-result compiland)
    1359             compiland-result))))
     1333    (with-saved-compiler-policy
     1334      (process-optimization-declarations (cddr form))
     1335
     1336      (let* ((lambda-list (cadr form))
     1337             (body (cddr form))
     1338             (closure (make-closure `(lambda ,lambda-list nil) nil))
     1339             (syms (sys::varlist closure))
     1340             (vars nil)
     1341             compiland-result)
     1342        (dolist (sym syms)
     1343          (let ((var (make-variable :name sym
     1344                                    :special-p (special-variable-p sym))))
     1345            (push var vars)
     1346            (push var *all-variables*)
     1347            (push var *visible-variables*)))
     1348        (setf (compiland-arg-vars compiland) (nreverse vars))
     1349        (let ((free-specials (process-declarations-for-vars body vars nil)))
     1350          (setf (compiland-free-specials compiland) free-specials)
     1351          (dolist (var free-specials)
     1352            (push var *visible-variables*)))
     1353        (setf compiland-result
     1354              (list* 'LAMBDA lambda-list (p1-body body)))
     1355        (setf (compiland-%single-valued-p compiland)
     1356              (single-valued-p compiland-result))
     1357        (setf (compiland-p1-result compiland)
     1358              compiland-result)))))
    13601359
    13611360(provide "COMPILER-PASS1")
Note: See TracChangeset for help on using the changeset viewer.