ilisp / cmulisp.lisp

Diff from to

cmulisp.lisp

 ;;; cmulisp.lisp --
 
 ;;; This file is part of ILISP.
-;;; Version: 5.8
+;;; Version: 5.10.1
 ;;;
 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
 ;;;               1993, 1994 Ivan Vasquez
 ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
-;;;               1996 Marco Antoniotti and Rick Campbell
+;;;               1996-2000 Marco Antoniotti and Rick Campbell
 ;;;
 ;;; Other authors' names for which this Copyright notice also holds
 ;;; may appear later in this file.
 ;;;
-;;; Send mail to 'ilisp-request@naggum.no' to be included in the
-;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP
+;;; Send mail to 'majordomo@cons.org' to be included in the
+;;; ILISP mailing list. 'ilisp@cons.org' is the general ILISP
 ;;; mailing list were bugs and improvements are discussed.
 ;;;
 ;;; ILISP is freely redistributable under the terms found in the file
 ;;; Normally, errors which occur while in the debugger are just ignored, unless
 ;;; the user issues the "flush" command, which toggles this behavior.
 ;;;
-(setq debug:*flush-debug-errors* nil)  ;; allow multiple error levels.
+(setq debug:*flush-debug-errors* nil)  ; allow multiple error levels.
 
 ;;; This implementation of "POP" simply looks for the first restart that says
 ;;; "Return to debug level n" or "Return to top level." and executes it.
 ;;;
 (debug::def-debug-command "POP" #+:new-compiler ()
-    ;; find the first "Return to ..." restart
-    (if (not (boundp 'debug::*debug-restarts*))
-	(error "You're not in the debugger; how can you call this!?")
-	(labels ((find-return-to (restart-list num)
+  ;; find the first "Return to ..." restart
+  (if (not (boundp 'debug::*debug-restarts*))
+      (error "You're not in the debugger; how can you call this!?")
+      (labels ((find-return-to (restart-list num)
 		 (let ((first
 			(member-if
 			 #'(lambda (restart)
-			     (string= (funcall
-				       (conditions::restart-report-function restart)
-				       nil)
-				      "Return to " :end1 10))
-			  restart-list)))
+			     (string=
+			      (funcall
+			       (conditions::restart-report-function restart)
+			       nil)
+			      "Return to " :end1 10))
+			 restart-list)))
 		   (cond ((zerop num) (car first))
-			 ((cdr first) (find-return-to (cdr first) (1- num)))))))
+			 ((cdr first)
+			  (find-return-to (cdr first) (1- num)))))))
 	(let* ((level (debug::read-if-available 1))
 	       (first-return-to (find-return-to 
 				 debug::*debug-restarts* (1- level))))
   "Deduce how to get the \"right\" function object and return it."
   (let ((fun (or (macro-function sym)
 		 (and (fboundp sym) (symbol-function sym)))))
-    (cond (fun
-	   (when (and (= (lisp::get-type fun) #.vm:closure-header-type)
-		      (not (eval:interpreted-function-p fun)))
-	     (setq fun (lisp::%closure-function fun)))
-	   fun)
-	  (t
-	   (error "Unknown function ~a.  Check package." sym)
-	   nil))))
+    (unless fun
+      (error "Unknown function ~a.  Check package." sym))
 
+    (if (and (= (lisp::get-type fun) #.vm:closure-header-type)
+	     (not (eval:interpreted-function-p fun)))
+	(lisp::%closure-function fun)
+	fun)))
 
+(defun extract-function-info-from-name (sym)
+  (let ((mf (macro-function sym)))
+    (if mf
+	(values mf :macro)
+	(if (fboundp sym)
+	    (values (symbol-function sym) :function)
+	    (values nil nil)))))
 
 (export '(arglist source-file cmulisp-trace))
 
 ;;;%% arglist - return arglist of function
+;;;
+;;; 19991219 Marco Antoniotti
+;;; New version is patterned after DESCRIBE-FUNCTION in the
+;;; 'describe.lisp' file of CMUCL.
 
 (defun arglist (symbol package)
   (ilisp-errors
-   (let* ((x (ilisp-find-symbol symbol package))
+   (let* ((package-name (if (packagep package)
+			    (package-name package)
+			    package))
+	  (x (ilisp-find-symbol symbol package-name))
+	  )
+     (flet ((massage-arglist (args)
+	      (typecase args
+		(string (if (or (null args) (string= args "()"))
+			    ""
+			    args))
+		(list (format nil "~S" args))
+		(t ""))))
+
+       (multiple-value-bind (func kind)
+	   (extract-function-info-from-name x)
+	 ;; (print func *trace-output*)
+	 ;; (print kind *trace-output*)
+	 (if (and func kind)
+	     (case (lisp::get-type func)
+	       ((#.vm:closure-header-type
+		 #.vm:function-header-type
+		 #.vm:closure-function-header-type)
+		(massage-arglist
+		 (funcall #+CMU17 #'lisp::%function-arglist
+			  #-CMU17 #'lisp::%function-header-arglist
+			  func)))
+
+	       (#.vm:funcallable-instance-header-type
+		(typecase func
+		  (kernel:byte-function
+		   "Byte compiled function or macro, no arglist available.")
+		  (kernel:byte-closure
+		   "Byte compiled closure, no arglist available.")
+		  ((or generic-function pcl:generic-function)
+		   (pcl::generic-function-pretty-arglist func))
+		  (eval:interpreted-function
+		   (massage-arglist (eval::interpreted-function-arglist func)))
+		
+		  (t (print 99 *trace-output*) "No arglist available.")
+		  ))			; typecase
+	       (t "No arglist available.")) ; case
+	     "Unknown function - no arglist available." ; For the time
+					; being I just
+					; return this
+					; value. Maybe
+					; an error would
+					; be better.
+	     ))))))
+
+#| Original version.
+(defun arglist (symbol package)
+  (ilisp-errors
+   (let* ((package-name (if (packagep package)
+			    (package-name package)
+			    package))
+	  (x (ilisp-find-symbol symbol package-name))
 	  (fun (get-correct-fn-object x)))
      (values
       (cond ((eval:interpreted-function-p fun) 
 	     (pcl::generic-function-pretty-arglist fun))
 	    ((compiled-function-p fun)
 	     (let ((string-or-nil
-		    (#+CMU17 lisp::%function-arglist
-		     #-CMU17 lisp::%function-header-arglist
+		    (funcall #+CMU17 #'lisp::%function-arglist
+			     #-CMU17 #'lisp::%function-header-arglist
 		     fun)))
 	       (if string-or-nil
 		   (read-from-string string-or-nil)
 		   "No argument info.")))
 	    (t (error "Unknown type of function")))))))
+|#
 
 
 ;;; source-file symbol package type --
    (let ((real-symbol (ilisp-find-symbol symbol package)))
      (setq breakp (read-from-string breakp))
      (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
+
+;;; end of file -- cmulisp.lisp --
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.