;; 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 -- -- ;;;;