【@lisp】函数探测器，用于探测未知函数用法的函数。

vitalgg

当前代码暂时支持 字符串，实数 整数 ，图元，图元对象，选择集等。

原理说明：根据错误提示，用 arg0 arg1 ..逐步增加参数，直到参数个数满足函数要求。
再根据错误提示，参数修改参数类型。
最终通过探测时，返回函数及参数类型。

需要更多错误提示信息，以进行改进。期待您的提交。

持续更新中 最终源码见: https://gitee.com/atlisp/atlisp- ... c/ext/probe-fun.lsp
也欢迎到上面的源码网址回复 提交错误信息，我可以更快看到。


说明：本代码所调用的函数均在 @lisp函数库中，请自行查找。
也可以安装@lisp核心，可以自动调用需要的函数。

TODO: 成功后还可以尝试多加个参数进行可变参数的测试。

1. (defun ext:probe-fun (fun / *error* args iter iter-depth)
   
2.   "探测函数的参数个数(最小)及参数类型。"
   
3.   "expr or nil"
   
4.   "(ext:probe-fun 'boole)"
   
5.   (setq args '())
   
6.   (setq iter-depth 0)
   
7.   (setq str "string"
   
8.   intnum (fix 5)
   
9.   num 3.14
   
10.   ent (entity:make-circle '(0 0 0) 100)
    
11.   vlaobj (e2o ent)
    
12.   ss (ssadd ent)
    
13.   pt '(1 1 0)
    
14.   )
    
15.   (defun get-type (x)
    
16.     (cond
    
17.      ((listp x)
    
18.       (cond
    
19.        ((equal x '(1 1 0))
    
20.   'point)
    
21.        (t 'lst)))
    
22.      (t (type x))
    
23.     ))
    
24.   (defun iter ()
    
25.     ;;(princ args)
    
26.     (setq iter-depth (1+ iter-depth))
    
27.     (if (and
    
28.    (vl-catch-all-error-p
    
29.     (setq errobj
    
30.     (vl-catch-all-apply
    
31.      fun
    
32.      (reverse args))))
    
33.    (setq errmsg (vl-catch-all-error-message errobj)))
    
34.   (if (< iter-depth 100)
    
35.       (cond
    
36.        ((wcmatch errmsg "*参数太少*")
    
37.         (setq args  (cons (read (strcat "arg" (itoa (length args)))) args))
    
38.         (iter))
    
39.        ((wcmatch errmsg "参数类型错误*")
    
40.         (@:log "INFO" errmsg)
    
41.         (setq typeerr (string:to-list errmsg " "))
    
42.         (@:log "INFO" (vl-prin1-to-string typeerr))
    
43.         (cond
    
44.          ((wcmatch (cadr typeerr) "stringp*")
    
45.     (setq args (subst str (read (last typeerr)) args)))
    
46.          ((wcmatch (cadr typeerr) "listp*")
    
47.     (setq args (subst '(L I S T) (read (last typeerr)) args)))
    
48.          ((wcmatch (cadr typeerr) "numberp*")
    
49.     (setq args (subst num (read (last typeerr)) args)))
    
50.          ((wcmatch (cadr typeerr) "fixnump*")
    
51.     (setq args (subst intnum (read (last typeerr)) args)))
    
52.          ((wcmatch (cadr typeerr) "lselsetp*")
    
53.     (setq args (subst ss (read (last typeerr)) args)))
    
54.          ((wcmatch (cadr typeerr) "lentity*")
    
55.     (setq args (subst ent (read (last typeerr)) args)))
    
56.          ((wcmatch (cadr typeerr) "VLA-OBJECT*")
    
57.     (setq args (subst vlaobj (read (last typeerr)) args)))
    
58.          ((wcmatch (cadr typeerr) "二维/三维点*")
    
59.     (setq args (subst pt (read (last typeerr)) args)))
    
60.          ;; TODO 参数类型错误扩展
    
61.          )
    
62.         (iter))
    
63.        ((wcmatch errmsg "no function definition*")
    
64.         (setq args (subst 'princ (read (caddr typeerr)) args))
    
65.         (iter))
    
66.        (t
    
67.         (princ errmsg)
    
68.         (princ "  near completed \n")
    
69.         (cons fun (mapcar 'get-type (reverse args)))
    
70.         )))
    
71.       (progn
    
72.   (princ "probe completed!\n")
    
73.   (cons fun (mapcar 'get-type (reverse args)))
    
74.   )
    
75.       )
    
76.     )
    
77.   (iter)
    
78.   )
    

(defun ext:probe-fun (fun / *error* args iter iter-depth)<br />   "探测函数的参数个数(最小)及参数类型。"<br />   "expr or nil"<br />   "(ext:probe-fun 'boole)"<br />   (setq args '())<br />   (setq iter-depth 0)<br />   (setq str "string"<br />   intnum (fix 5)<br />   num 3.14<br />   ent (entity:make-circle '(0 0 0) 100)<br />   vlaobj (e2o ent)<br />   ss (ssadd ent)<br />   pt '(1 1 0)<br />   )<br />   (defun get-type (x)<br />     (cond<br />      ((listp x)<br />       (cond<br />        ((equal x '(1 1 0))<br />   'point)<br />        (t 'lst)))<br />      (t (type x))<br />     ))<br />   (defun iter ()<br />     ;;(princ args)<br />     (setq iter-depth (1+ iter-depth))<br />     (if (and<br />    (vl-catch-all-error-p<br />     (setq errobj<br />     (vl-catch-all-apply<br />      fun<br />      (reverse args))))<br />    (setq errmsg (vl-catch-all-error-message errobj)))<br />   (if (< iter-depth 100)<br />       (cond<br />        ((wcmatch errmsg "*参数太少*")<br />         (setq args  (cons (read (strcat "arg" (itoa (length args)))) args))<br />         (iter))<br />        ((wcmatch errmsg "参数类型错误*")<br />         (@:log "INFO" errmsg)<br />         (setq typeerr (string:to-list errmsg " "))<br />         (@:log "INFO" (vl-prin1-to-string typeerr))<br />         (cond<br />          ((wcmatch (cadr typeerr) "stringp*")<br />     (setq args (subst str (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "listp*")<br />     (setq args (subst '(L I S T) (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "numberp*")<br />     (setq args (subst num (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "fixnump*")<br />     (setq args (subst intnum (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "lselsetp*")<br />     (setq args (subst ss (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "lentity*")<br />     (setq args (subst ent (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "VLA-OBJECT*")<br />     (setq args (subst vlaobj (read (last typeerr)) args)))<br />          ((wcmatch (cadr typeerr) "二维/三维点*")<br />     (setq args (subst pt (read (last typeerr)) args)))<br />          ;; TODO 参数类型错误扩展<br />          )<br />         (iter))<br />        ((wcmatch errmsg "no function definition*")<br />         (setq args (subst 'princ (read (caddr typeerr)) args))<br />         (iter))<br />        (t<br />         (princ errmsg)<br />         (princ "  near completed \n")<br />         (cons fun (mapcar 'get-type (reverse args)))<br />         )))<br />       (progn<br />   (princ "probe completed!\n")<br />   (cons fun (mapcar 'get-type (reverse args)))<br />   )<br />       )<br />     )<br />   (iter)<br />   )<br />

lxl217114

一楼支持，感谢分享

tigcat

感谢张大分享，有了参数，内部函数才有用武之地

vitalgg

tigcat 发表于 2022-8-29 13:31
感谢张大分享，有了参数，内部函数才有用武之地

只是一个框架及简单实现，细节部分还需要再扩展。
需要更多的错误信息分析。