[armedbear-cvs] r11453 - trunk/j/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Dec 19 19:46:24 2008
New Revision: 11453

Log:
Condense LAMBDA and NAMED-LAMBDA branches in p1-function main COND into a single one with conditions.

Modified:
   trunk/j/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/j/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/j/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/j/src/org/armedbear/lisp/jvm.lisp	Fri Dec 19 19:46:24 2008
@@ -862,44 +862,31 @@
 (defun p1-function (form)
   (let ((form (copy-tree form))
         local-function)
-    (cond ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
-           (when *current-compiland*
-             (incf (compiland-children *current-compiland*)))
-           (let* ((*current-compiland* *current-compiland*)
-                  (lambda-form (cadr form))
+    (cond ((and (consp (cadr form))
+                (or (eq (caadr form) 'LAMBDA)
+                    (eq (caadr form) 'NAMED-LAMBDA)))
+           (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
+                  (named-lambda-form (when named-lambda-p
+                                       (cadr form)))
+                  (name (when named-lambda-p
+                          (cadr named-lambda-form)))
+                  (lambda-form (if named-lambda-p
+                                   (cons 'LAMBDA (cddr named-lambda-form))
+                                   (cadr form)))
                   (lambda-list (cadr lambda-form))
                   (body (cddr lambda-form))
-                  (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-")
+                  (compiland (make-compiland :name (if named-lambda-p
+                                                       name (gensym "ANONYMOUS-LAMBDA-"))
                                              :lambda-expression lambda-form
                                              :parent *current-compiland*)))
+             (when *current-compiland*
+               (incf (compiland-children *current-compiland*)))
              (multiple-value-bind (body decls)
                  (parse-body body)
                (setf (compiland-lambda-expression compiland)
-                     `(lambda ,lambda-list , at decls , at body))
-               (let ((*visible-variables* *visible-variables*)
-                     (*current-compiland* compiland))
-                 (p1-compiland compiland)))
-             (list 'FUNCTION compiland)))
-          ((and (consp (cadr form)) (eq (caadr form) 'NAMED-LAMBDA))
-           (when *current-compiland*
-             (incf (compiland-children *current-compiland*)))
-           (let* ((*current-compiland* *current-compiland*)
-;;                   (lambda-form (cadr form))
-                  (named-lambda-form (cadr form))
-                  (name (cadr named-lambda-form))
-                  (lambda-form (cons 'LAMBDA (cddr named-lambda-form)))
-                  (lambda-list (cadr lambda-form))
-                  (body (cddr lambda-form))
-                  (compiland (make-compiland :name name
-                                             :lambda-expression lambda-form
-                                             :parent *current-compiland*)))
-;;              (format t "p1-function named-lambda-form = ~S~%" named-lambda-form)
-;;              (format t "p1-function name = ~S~%" name)
-;;              (format t "p1-function lambda-form = ~S~%" lambda-form)
-             (multiple-value-bind (body decls)
-                 (parse-body body)
-               (setf (compiland-lambda-expression compiland)
-                     `(lambda ,lambda-list , at decls (block nil , at body)))
+                     (if named-lambda-p
+                         `(lambda ,lambda-list , at decls (block nil , at body))
+                         `(lambda ,lambda-list , at decls , at body)))
                (let ((*visible-variables* *visible-variables*)
                      (*current-compiland* compiland))
                  (p1-compiland compiland)))
@@ -3827,6 +3814,7 @@
 
 (defknown process-args (t) t)
 (defun process-args (args)
+  ""
   (when args
     (let ((numargs (length args)))
       (let ((must-clear-values nil))