Changeset 11643


Ignore:
Timestamp:
02/08/09 13:14:20 (13 years ago)
Author:
vvoutilainen
Message:

Remove duplication from p1-flet and p1-labels.

File:
1 edited

Legend:

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

    r11473 r11643  
    391391                  (if (eq state '&optional) "optional" "keyword")))))))))
    392392
     393(defmacro with-local-functions-for-flet/labels
     394    (form local-functions-var lambda-name lambda-list-var name-var body-var body1 body2)
     395  `(progn (incf (compiland-children *current-compiland*) (length (cadr ,form)))
     396    (let ((*visible-variables* *visible-variables*)
     397    (*local-functions* *local-functions*)
     398    (*current-compiland* *current-compiland*)
     399    (,local-functions-var '()))
     400      (dolist (definition (cadr ,form))
     401        (let ((,name-var (car definition))
     402        (,lambda-list-var (cadr definition)))
     403    (validate-name-and-lambda-list ,name-var ,lambda-list-var ,lambda-name)
     404 
     405    (let* ((,body-var (cddr definition))
     406           (compiland (make-compiland :name ,name-var
     407              :parent *current-compiland*)))
     408      ,@body1)))
     409      (setf ,local-functions-var (nreverse ,local-functions-var))
     410      ,@body2)))
     411
    393412(defun p1-flet (form)
    394   (incf (compiland-children *current-compiland*) (length (cadr form)))
    395   (let ((*visible-variables* *visible-variables*)
    396         (*local-functions* *local-functions*)
    397         (*current-compiland* *current-compiland*)
    398         (local-functions '()))
    399     (dolist (definition (cadr form))
    400       (let ((name (car definition))
    401             (lambda-list (cadr definition)))
    402         (validate-name-and-lambda-list name lambda-list 'FLET)
    403         (let* ((body (cddr definition))
    404                (compiland (make-compiland :name name
    405                                           :parent *current-compiland*))
    406                (local-function (make-local-function :name name
    407                                                     :compiland compiland)))
    408           (multiple-value-bind (body decls) (parse-body body)
    409             (let* ((block-name (fdefinition-block-name name))
    410                    (lambda-expression
    411                     `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))
    412                    (*visible-variables* *visible-variables*)
    413                    (*local-functions* *local-functions*)
    414                    (*current-compiland* compiland))
    415               (setf (compiland-lambda-expression compiland) lambda-expression)
    416               (setf (local-function-inline-expansion local-function)
    417                     (generate-inline-expansion block-name lambda-list body))
    418               (p1-compiland compiland)))
    419           (when *closure-variables*
    420             (let ((variable (make-variable :name (gensym))))
    421               (setf (local-function-variable local-function) variable)
    422               (push variable *all-variables*)))
    423           (push local-function local-functions))))
    424     (setf local-functions (nreverse local-functions))
    425     ;; Make the local functions visible.
    426     (dolist (local-function local-functions)
    427       (push local-function *local-functions*)
    428       (let ((variable (local-function-variable local-function)))
    429         (when variable
    430           (push variable *visible-variables*))))
    431     (with-saved-compiler-policy
    432       (process-optimization-declarations (cddr form))
    433       (list* (car form) local-functions (p1-body (cddr form))))))
     413  (with-local-functions-for-flet/labels
     414      form local-functions 'FLET lambda-list name body
     415      ((let ((local-function (make-local-function :name name
     416             :compiland compiland)))
     417   (multiple-value-bind (body decls) (parse-body body)
     418     (let* ((block-name (fdefinition-block-name name))
     419      (lambda-expression
     420       `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))
     421      (*visible-variables* *visible-variables*)
     422      (*local-functions* *local-functions*)
     423      (*current-compiland* compiland))
     424       (setf (compiland-lambda-expression compiland) lambda-expression)
     425       (setf (local-function-inline-expansion local-function)
     426       (generate-inline-expansion block-name lambda-list body))
     427       (p1-compiland compiland)))
     428   (when *closure-variables*
     429     (let ((variable (make-variable :name (gensym))))
     430       (setf (local-function-variable local-function) variable)
     431       (push variable *all-variables*)))
     432   (push local-function local-functions)))
     433      ;; Make the local functions visible.
     434      ((dolist (local-function local-functions)
     435   (push local-function *local-functions*)
     436   (let ((variable (local-function-variable local-function)))
     437     (when variable
     438       (push variable *visible-variables*))))
     439       (with-saved-compiler-policy
     440     (process-optimization-declarations (cddr form))
     441   (list* (car form) local-functions (p1-body (cddr form)))))))
     442
    434443
    435444(defun p1-labels (form)
    436   (incf (compiland-children *current-compiland*) (length (cadr form)))
    437   (let ((*visible-variables* *visible-variables*)
    438         (*local-functions* *local-functions*)
    439         (*current-compiland* *current-compiland*)
    440         (local-functions '()))
    441     (dolist (definition (cadr form))
    442       (let ((name (car definition))
    443             (lambda-list (cadr definition)))
    444         (validate-name-and-lambda-list name lambda-list 'LABELS)
    445         (let* ((body (cddr definition))
    446                (compiland (make-compiland :name name
    447                                           :parent *current-compiland*))
    448                (variable (make-variable :name (gensym)))
    449                (local-function (make-local-function :name name
    450                                                     :compiland compiland
    451                                                     :variable variable)))
    452           (multiple-value-bind (body decls) (parse-body body)
    453             (setf (compiland-lambda-expression compiland)
    454                   `(lambda ,lambda-list ,@decls (block ,name ,@body))))
    455           (push variable *all-variables*)
    456           (push local-function local-functions))))
    457     (setf local-functions (nreverse local-functions))
    458     ;; Make the local functions visible.
    459     (dolist (local-function local-functions)
    460       (push local-function *local-functions*)
    461       (push (local-function-variable local-function) *visible-variables*))
    462     (dolist (local-function local-functions)
    463       (let ((*visible-variables* *visible-variables*)
    464             (*current-compiland* (local-function-compiland local-function)))
    465         (p1-compiland (local-function-compiland local-function))))
    466     (list* (car form) local-functions (p1-body (cddr form)))))
     445  (with-local-functions-for-flet/labels
     446      form local-functions 'LABELS lambda-list name body
     447      ((let* ((variable (make-variable :name (gensym)))
     448        (local-function (make-local-function :name name
     449               :compiland compiland
     450               :variable variable)))
     451   (multiple-value-bind (body decls) (parse-body body)
     452     (setf (compiland-lambda-expression compiland)
     453     `(lambda ,lambda-list ,@decls (block ,name ,@body))))
     454   (push variable *all-variables*)
     455   (push local-function local-functions)))
     456      ;; Make the local functions visible.
     457      ((dolist (local-function local-functions)
     458   (push local-function *local-functions*)
     459   (push (local-function-variable local-function) *visible-variables*))
     460       (dolist (local-function local-functions)
     461   (let ((*visible-variables* *visible-variables*)
     462         (*current-compiland* (local-function-compiland local-function)))
     463     (p1-compiland (local-function-compiland local-function))))
     464       (list* (car form) local-functions (p1-body (cddr form))))))
    467465
    468466(defknown p1-funcall (t) t)
Note: See TracChangeset for help on using the changeset viewer.