From: Christophe R. <cr...@us...> - 2005-03-08 18:41:44
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv20837/src/pcl Modified Files: compiler-support.lisp ctor.lisp vector.lisp Log Message: 0.8.20.10: Fix ctor/package deletion problems (Tim Daly sbcl-help 2005-03) ... MORE GENERALIZED FUNCTION NAMES Index: compiler-support.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/compiler-support.lisp,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- compiler-support.lisp 13 Jan 2005 10:12:19 -0000 1.11 +++ compiler-support.lisp 8 Mar 2005 18:41:31 -0000 1.12 @@ -85,6 +85,9 @@ (define-internal-pcl-function-name-syntax sb-pcl::slow-method (list) (valid-function-name-p (cadr list))) +(define-internal-pcl-function-name-syntax sb-pcl::ctor (list) + (valid-function-name-p (cadr list))) + (defun sb-pcl::random-documentation (name type) (cdr (assoc type (info :random-documentation :stuff name)))) Index: ctor.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/ctor.lisp,v retrieving revision 1.14 retrieving revision 1.15 diff -u -d -r1.14 -r1.15 --- ctor.lisp 31 Dec 2004 12:30:13 -0000 1.14 +++ ctor.lisp 8 Mar 2005 18:41:31 -0000 1.15 @@ -134,17 +134,8 @@ (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -;;; Keep this a separate function for testing. (defun make-ctor-function-name (class-name initargs) - (let ((*package* *pcl-package*) - (*print-case* :upcase) - (*print-pretty* nil) - (*print-gensym* t)) - (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S" - (package-name (symbol-package class-name)) - (symbol-name class-name) - (plist-keys initargs) - (plist-values initargs :test #'constantp)))) + (list* 'ctor class-name initargs)) ;;; Keep this a separate function for testing. (defun ensure-ctor (function-name class-name initargs) @@ -156,7 +147,7 @@ (without-package-locks ; for (setf symbol-function) (let ((ctor (%make-ctor function-name class-name nil initargs))) (push ctor *all-ctors*) - (setf (symbol-function function-name) ctor) + (setf (fdefinition function-name) ctor) (install-initial-constructor ctor :force-p t) ctor))) @@ -233,7 +224,7 @@ t) (function (&rest t) t)) ,function-name)) - (,function-name ,@value-forms)))))))) + (funcall (function ,function-name) ,@value-forms)))))))) ;;; ************************************************** Index: vector.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v retrieving revision 1.34 retrieving revision 1.35 diff -u -d -r1.34 -r1.35 --- vector.lisp 13 Jan 2005 10:12:19 -0000 1.34 +++ vector.lisp 8 Mar 2005 18:41:32 -0000 1.35 @@ -1151,13 +1151,7 @@ (apply fmf pv-cell nmc (nconc args (list rest)))) (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) - (name `(,(or (get (car fname) 'method-sym) - (setf (get (car fname) 'method-sym) - (let ((str (symbol-name (car fname)))) - (if (string= "FAST-" str :end2 5) - (format-symbol *pcl-package* (subseq str 5)) - (car fname))))) - ,@(cdr fname)))) + (name (cons 'slow-method (cdr fname)))) (set-fun-name method-function name)) (setf (method-function-get method-function :fast-function) fmf) method-function)) |