From e4370c6dfd8ef616defddb115402b385e2ec567d Mon Sep 17 00:00:00 2001
From: mathieu2em <math.per@hotmail.com>
Date: Tue, 23 Jul 2019 10:57:26 -0400
Subject: fix #1 ##decompile now tried before using the procedure's list

---
 scheme/gambit/geiser/gambit.scm | 78 ++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 77 insertions(+), 1 deletion(-)

(limited to 'scheme/gambit')

diff --git a/scheme/gambit/geiser/gambit.scm b/scheme/gambit/geiser/gambit.scm
index ee3d78a..d8cae00 100644
--- a/scheme/gambit/geiser/gambit.scm
+++ b/scheme/gambit/geiser/gambit.scm
@@ -38,7 +38,83 @@
         ((not (symbol? (car ids)))
          (geiser:autodoc (cdr ids)))
         (else
-         (list (##procedure-search (car ids))))))
+         (geiser:new-autodoc (car ids)))))
+         ;;(list (##procedure-search (car ids))))))
+
+;; (cadr (##decompile method)) format is
+;;(#!optional (param1 (macro-absent-obj)) (param2 (macro-absent-obj)) #!rest others)
+;; !! method-name -> procedure
+
+;;
+(define (geiser:new-autodoc method-name)
+  (define (get-required lst)
+    (let loop ((lst lst)
+               (result '()))
+      (cond ((not (pair? lst))
+             ;;(pp (cons (reverse result) '()))
+             ;;(pp "-----NEXT1-- not pair--")
+             (cons (reverse result) '()))
+            ((eq? (car lst) #!optional)
+             ;;(pp (cons (reverse result) (cdr lst)))
+             ;;(pp "-----NEXT1---opt--")
+             (cons (reverse result) (cdr lst)))
+            ((eq? (car lst) #!key)
+             ;;(pp (cons (reverse result) lst))
+             ;;(pp "-----NEXT1--key---")
+             (cons (reverse result) lst))
+            (else (loop (cdr lst) (cons (car lst) result))))))
+  
+  (define (get-optional lst)
+    ;;(pp "getopt")
+    ;;(pp lst)
+    ;;(pp "----")
+    (let loop ((lst lst)
+               (result '()))
+      (cond ((or (not (pair? lst))
+                 (eq? (car lst) #!key))
+             ;;(pp (cons (reverse result)
+             ;;      (if (pair? lst)
+             ;;          (cdr lst)
+             ;;          '())))
+             ;;(pp "------next2----key or emptylist--")
+             (cons (reverse result)
+                   (if (pair? lst)
+                       (cdr lst)
+                       '())))
+            ((eq? (car lst) #!rest)
+             ;;(pp (cons (reverse (cons '... result)) '()))
+             ;;(pp "-------next2---- rest--")
+             (cons (reverse (cons '... result)) '()))
+            (else 
+             (loop (cdr lst) (cons (if (pair? (car lst)) (caar lst) (car lst)) result))))))
+
+  (define (get-key lst)
+    (let loop ((lst lst)
+               (result '()))
+      (cond ((not (pair? lst))
+             result)
+            ((eq? (car lst) #!rest)
+             (reverse (cons '... result)))
+            (else (loop (cdr lst) (cons (car lst) result))))))
+  
+ 
+  (let ((proc (##global-var-ref (##make-global-var method-name))))
+    (if (procedure? proc)
+        (let ((method-tester (##decompile proc)))
+          ;;(pp (cadr method-tester))
+          ;;(pp "---NEXT---")
+          (if (pair? method-tester)
+              (let* ((method (cadr method-tester))
+                     (required (get-required method))
+                     (optional (get-optional (cdr required)))
+                     (key (get-key (cdr optional))))
+                (list `(,method-name
+                        ("args" (("required" ,@(car required))
+                                 ("optional" ,@(car optional))
+                                 ("key"      ,@key)))
+                        ("module"))))
+              (list (##procedure-search method-name))))
+        (list (##procedure-search method-name)))))
 
 (define (geiser:module-completions prefix . rest)
   (define (environment-symbols)
-- 
cgit v1.2.3