Changeset 6617

Timestamp:

May 28, 2007, 12:43:25 AM (18 years ago)

Author:

Gary Byers

Message:

ARG-NAMES-FROM-MAP.

File:

• branches/ide-1.0/ccl/lib/arglist.lisp (modified) (2 diffs)

branches/ide-1.0/ccl/lib/arglist.lisp

@@ -56 +56 @@
               (ignore-errors (values (read stream nil eof))))
             (when errorp
-              #+help-file ; %HEL temporarily avoiding reference to help file
-              (if use-help-file
-                (return-from %arglist 
-                  (%arglist sym include-bindings temp-cons-p nil)))
               (push '&rest res)
               (push ':unparseable res)
@@ -171 +167 @@
             (values (nreverse res) t))
           (values nil (zerop ncells)))))))
+
+(defun arg-names-from-map (lfun)
+  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
+                             optinit lexprp
+                             ncells nclosed)
+      (function-args lfun)
+    (declare (ignore optinit ncells allow-other-keys))
+    (collect ((req)
+              (opt)
+              (keys))
+      (let* ((rest nil)
+             (map (car (function-symbol-map lfun))))
+        (if map
+          (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0)))
+                (idx (- (length map) nclosed)))
+            (unless (zerop total)
+              (progn
+                (dotimes (x nreq)
+                  (declare (fixnum x))
+                  (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x))))
+                (when (neq nopt 0)
+                  (dotimes (x (the fixnum nopt))
+                    (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)))))
+                (when nkeys
+                  (dotimes (i (the fixnum nkeys))
+                    (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))
+                (when (or restp lexprp)
+                  (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))))))
+        (values (not (null map)) (req) (opt) rest (keys))))))
+              
+              
+
 
 (defvar *req-arg-names*