[armedbear-cvs] r14130 - trunk/abcl/src/org/armedbear/lisp

[ehuelsmann at common-lisp.net]

Author: ehuelsmann
Date: Mon Aug 20 11:39:26 2012
New Revision: 14130

Log:
Replace a Java primitive LAMBDA-LIST-NAMES with a lisp function.
Make the returned REQUIRED value from PARSE-LAMBDA-LIST match is docstring.

Modified:
   trunk/abcl/src/org/armedbear/lisp/Closure.java
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Closure.java	Sun Aug 19 06:53:28 2012	(r14129)
+++ trunk/abcl/src/org/armedbear/lisp/Closure.java	Mon Aug 20 11:39:26 2012	(r14130)
@@ -220,16 +220,4 @@
   {
     return arglist.match(args, environment, environment, thread);
   }
-
-  // ### lambda-list-names
-  private static final Primitive LAMBDA_LIST_NAMES =
-      new Primitive("lambda-list-names", PACKAGE_SYS, true)
-    {
-      @Override
-      public LispObject execute(LispObject arg)
-      {
-        Closure closure = new Closure(list(Symbol.LAMBDA, arg, NIL), new Environment());
-        return closure.getVariableList();
-      }
-    };
 }

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Sun Aug 19 06:53:28 2012	(r14129)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Mon Aug 20 11:39:26 2012	(r14130)
@@ -107,7 +107,7 @@
         (&environment (setf state :env))
         (t
          (case state
-           (:req (push arg req))
+           (:req (push (list arg) req))
            (:rest (setf rest (list arg)
                         state :none))
            (:env (setf env (list arg)
@@ -176,7 +176,8 @@
       (let (req-bindings temp-bindings bindings ignorables)
         ;;Required arguments.
         (setf req-bindings
-              (loop :for var :in req :collect `(,var ,(pop-required-argument))))
+              (loop :for (var) :in req
+                 :collect `(,var ,(pop-required-argument))))
 
         ;;Optional arguments.
         (when opt
@@ -758,6 +759,17 @@
     (values (nreverse other-decls)
             (nreverse specific-decls))))
 
+(defun lambda-list-names (lambda-list)
+  "Returns a list of variable names extracted from `lambda-list'."
+  (multiple-value-bind
+        (req opt key key-p rest allow-key-p aux whole env)
+      (parse-lambda-list lambda-list)
+    (declare (ignore key-p allow-key-p))
+    (mapcan (lambda (x)
+              (mapcar #'first x))
+            (list req opt key aux rest whole env))))
+
+
 (defun rewrite-aux-vars (form)
   (let* ((lambda-list (cadr form))
          (aux-p (memq '&AUX lambda-list))