SBCL/CVS HEAD support for arglist functionality
Hannu Koivisto <[email protected]> Sun, 02 Nov 2003 01:48:19 +0200
| Newsgroups | gmane.lisp.ilisp.devel |
|---|---|
| Message-ID | <[email protected]> |
--=-=-= Greetings, ILISP cannot be used (sbcl.lisp doesn't even load/compile) with the CVS HEAD version of SBCL, because the current arglist discovery method relies on internals that have changed. I have modified arglist discovery to support sb-introspect, which is the way to do this in the bleeding edge SBCL versions. Support for older versions is of course still there but hasn't been tested. 2003-10-31 Hannu Koivisto <[email protected]> * sbcl.lisp: * Now tries to require sb-introspect. * (arglist) Modified to support sb-introspect. * cl-ilisp.lisp: * (maybe-function) New function. -- Hannu --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=ilisp-arglist-sbcl-cvs-support.patch Content-Description: patch Index: sbcl.lisp =================================================================== RCS file: /home/azure/.cvs_root/ilisp/sbcl.lisp,v retrieving revision 1.1.1.4 retrieving revision 1.2 diff -U3 -r1.1.1.4 -r1.2 --- sbcl.lisp 5 Apr 2003 19:04:40 -0000 1.1.1.4 +++ sbcl.lisp 31 Oct 2003 23:35:01 -0000 1.2 @@ -11,11 +11,13 @@ ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list ;;; of present and past contributors. ;;; -;;; $Id: sbcl.lisp,v 1.1.1.4 2003/04/05 19:04:40 azure Exp $ +;;; $Id: sbcl.lisp,v 1.2 2003/10/31 23:35:01 azure Exp $ (in-package :ilisp) +(ignore-errors (require :sb-introspect)) + ;; ILISP-specifics for SBCL. Since version 0.7 introduced lots of changes, ;; e.g.(bytecode-)interpreter goes away, and lots of other 'renaming'-changes, ;; take care of that, by testing via the 'magic'-macros: @@ -67,12 +69,12 @@ ;;; 2000-04-02: Martin Atzmueller ;;; better (more bulletproof) arglist code adapted from cmulisp.lisp: -(defun arglist (symbol package) +(defun arglist (symbol-name package) (ilisp-errors (let* ((package-name (if (packagep package) - (package-name package) + (package-name package) package)) - (x (ilisp-find-symbol symbol package-name))) + (symbol (ilisp-find-symbol symbol-name package-name))) (flet ((massage-arglist (args) (typecase args (string (if (or (null args) (string= args "()")) @@ -86,49 +88,60 @@ (format nil "~A" args)) "()")) (t "")))) - (multiple-value-bind (func kind) - (extract-function-info-from-name x) + (extract-function-info-from-name symbol) (if (and func kind) - (case (the-function-if-defined ((#:widetag-of :sb-impl) - (#:get-type :sb-impl)) func) - ;; <3> - ((#.(the-symbol-if-defined ((#:closure-header-widetag :sb-vm) - (#:closure-header-type :sb-vm) - :eval-p t)) - #.(the-symbol-if-defined ((#:simple-fun-header-widetag :sb-vm) - (#:function-header-type :sb-vm) - :eval-p t)) - #.(the-symbol-if-defined ((#:closure-fun-header-widetag - :sb-vm) - (#:closure-function-header-type - :sb-vm) - :eval-p t))) - (massage-arglist - (the-function-if-defined ((#:%simple-fun-arglist :sb-impl) - (#:%function-arglist :sb-impl)) - func))) - (#.(the-symbol-if-defined - ((#:funcallable-instance-header-widetag :sb-vm) - (#:funcallable-instance-header-type :sb-vm) - :eval-p t)) - (typecase func - ;; <2> - (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ())) - "Byte compiled function or macro, no arglist available.") - (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ())) - "Byte compiled closure, no arglist available.") - ((or generic-function sb-pcl::generic-function) - (sb-pcl::generic-function-pretty-arglist func)) - ;; <1> - (#.(the-symbol-if-defined ((#:interpreted-function :sb-eval) ())) - (the-function-if-defined - ((#:interpreted-function-arglist :sb-eval) () - :function-binding-p t) - (massage-arglist (funcall the-function func)))) - (t (print 99 *trace-output*) "No arglist available.") - )) ; typecase - (t "No arglist available.")) ; case + ;; Instruments of darkness + (macrolet ((madness () + (let ((function-arglist-sym + (maybe-function '#:function-arglist '#:sb-introspect))) + (if function-arglist-sym + `(massage-arglist + (,function-arglist-sym func)) + `(case (the-function-if-defined + ((#:widetag-of :sb-impl) + (#:get-type :sb-impl)) + func) + ((,(symbol-value + (the-symbol-if-defined + ((#:closure-header-widetag :sb-vm) + (#:closure-header-type :sb-vm)))) + ,(symbol-value + (the-symbol-if-defined + ((#:simple-fun-header-widetag :sb-vm) + (#:function-header-type :sb-vm)))) + ,(symbol-value + (the-symbol-if-defined + ((#:closure-fun-header-widetag :sb-vm) + (#:closure-function-header-type :sb-vm))))) + (massage-arglist + (the-function-if-defined + ((#:%simple-fun-arglist :sb-impl) + (#:%function-arglist :sb-impl)) + func))) + (,(symbol-value + (the-symbol-if-defined + ((#:funcallable-instance-header-widetag :sb-vm) + (#:funcallable-instance-header-type :sb-vm)))) + (typecase func + (,(the-symbol-if-defined + ((#:byte-function :sb-kernel) ())) + "Byte compiled function or macro, no arglist available.") + (,(the-symbol-if-defined + ((#:byte-closure :sb-kernel) ())) + "Byte compiled closure, no arglist available.") + ((or generic-function sb-pcl::generic-function) + (sb-pcl::generic-function-pretty-arglist func)) + (,(the-symbol-if-defined + ((#:interpreted-function :sb-eval) ())) + (the-function-if-defined + ((#:interpreted-function-arglist :sb-eval) () + :function-binding-p t) + (massage-arglist (funcall the-function func)))) + (t (print 99 *trace-output*) + "No arglist available."))) + (t "No arglist available.")))))) + (madness)) ; "Unknown function - no arglist available." ; For the time ; being I just ; return this Index: cl-ilisp.lisp =================================================================== RCS file: /home/azure/.cvs_root/ilisp/cl-ilisp.lisp,v retrieving revision 1.1.1.14 retrieving revision 1.2 diff -U3 -r1.1.1.14 -r1.2 --- cl-ilisp.lisp 5 Apr 2003 19:04:41 -0000 1.1.1.14 +++ cl-ilisp.lisp 31 Oct 2003 23:34:09 -0000 1.2 @@ -10,7 +10,7 @@ ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list ;;; of present and past contributors. ;;; -;;; $Id: cl-ilisp.lisp,v 1.1.1.14 2003/04/05 19:04:41 azure Exp $ +;;; $Id: cl-ilisp.lisp,v 1.2 2003/10/31 23:34:09 azure Exp $ ;;; Old history log. @@ -80,6 +80,13 @@ (defvar *ilisp-old-result* nil "Used for save/restore of top level values.") (defvar *ilisp-message-addon-string* "ILISP:") + +(defun maybe-function (symbol-name package-name) + (let ((symbol (and (find-package package-name) + (find-symbol (symbol-name symbol-name) + (find-package package-name))))) + (when (fboundp symbol) + symbol))) (defmacro the-symbol-if-defined (((if-symbol if-package) (&optional else-symbol else-package) --=-=-=-- ------------------------------------------------------- This SF.net email is sponsored by: SF.net Giveback Program. Does SourceForge.net help you be more productive? Does it help you create better code? SHARE THE LOVE, and help us help YOU! Click Here: http://sourceforge.net/donate/