-
Notifications
You must be signed in to change notification settings - Fork 2
/
pjb-cl-intro.lisp
101 lines (91 loc) · 3.98 KB
/
pjb-cl-intro.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
;; Extracting COMMON-LISP argument lists from SBCL
(require 'sb-introspect)
(DEFUN no-package (tree)
(COND ((SYMBOLP tree)
(COND ((CHAR= (CHARACTER "?")
(CHAR (SYMBOL-NAME tree)
(1- (LENGTH (SYMBOL-NAME tree)))))
(INTERN (FORMAT nil "~A-P"
(SUBSEQ (SYMBOL-NAME tree) 0
(1- (LENGTH (SYMBOL-NAME tree)))))))
(t (INTERN (SYMBOL-NAME tree)))))
((ATOM tree) tree)
(t (CONS (no-package (CAR tree)) (no-package (CDR tree))))));;no-package
(DEFPARAMETER +cl-lambda-list-keywords+
'(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE &ENVIRONMENT))
(DEFUN split-lambda-list-on-keywords (lambda-list lambda-list-kind)
"
lambda-list-kind: (member +cl-lambda-list-kinds+)
"
(declare (ignore lambda-list-kind))
(let ((sing-result '())
(env (position '&ENVIRONMENT lambda-list)))
(when env
(push (list '&ENVIRONMENT (elt lambda-list (1+ env))) sing-result)
(setf lambda-list (remove-if (lambda (x) (declare (ignore x)) t)
lambda-list :start env :end (+ env 2))))
(when (eq '&WHOLE (first lambda-list))
(push (subseq lambda-list 0 2) sing-result)
(setf lambda-list (cddr lambda-list)))
(do ((llk '(&MANDATORY &OPTIONAL &KEY &ALLOW-OTHER-KEYS &AUX &REST &BODY))
(args (if (member (first lambda-list) +cl-lambda-list-keywords+)
lambda-list
(cons '&MANDATORY lambda-list))
(cdr args))
(chunk '())
(result '()))
((null args)
(when chunk (push (nreverse chunk) result))
(nreverse (nconc sing-result result)))
(if (member (car args) llk)
(progn
(when chunk (push (nreverse chunk) result))
(setf chunk (list (car args))))
(push (car args) chunk)))));;split-lambda-list-on-keywords
(DEFUN clean-keywords (arglist &optional macro)
(when macro
(setf arglist (mapcar (lambda (x) (if (listp x) (clean-keywords x macro) x))
arglist)))
(let* ((splited (split-lambda-list-on-keywords arglist))
(keys (MEMBER '&KEY splited :key (function first))))
(if keys
(progn (SETF (CDAR keys)
(mapcar
(lambda (x)
(print x)
(if (CONSP x)
(progn
(format t "~A" (SECOND x))
(WHEN (EQUALP (SECOND x) ''character)
(SETF (SECOND x) 'character))
(if (consp (car x)) (CONS (caar x) (CDR x)) x))
x))
(CDAR keys)))
(APPLY (function APPEND) splited))
arglist)));;clean-keywords
(WITH-OPEN-FILE (out (MAKE-PATHNAME :defaults (USER-HOMEDIR-PATHNAME)
:NAME "CL-INTRO" :type "DATA"
:CASE :common)
:direction :output
:if-does-not-exist :create :if-exists :supersede)
(let ((*print-pretty* nil))
;;(FORMAT out ";; -*- mode:Lisp -*-~%")
;;(FORMAT out "(setq *raw-lambda-lists* '(~%")
(dolist (symbol (list-external-symbols "COMMON-LISP"))
(catch :abort
(let ((m nil))
(PRINT
(LIST
(cond ((special-operator-p symbol) :special-operator)
((MACRO-FUNCTION symbol) (setf m t) :macro)
((AND (FBOUNDP symbol)
(typep (symbol-function symbol) 'generic-function))
:generic)
((fboundp symbol) :function)
(t (throw :abort nil)))
symbol
(no-package (sb-introspect:function-arglist symbol)))
out))))
;;(FORMAT out "~&))~%")
))
;;;; cl-intro.lisp -- -- ;;;;