[Gcl-commits] gcl ansi-testsdefine-method-combination.lsp ans...

[Camm Maguire]

CVSROOT:        /cvsroot/gcl
Module name:    gcl
Changes by:     Camm Maguire <camm>     06/06/21 13:49:26

Modified files:
        ansi-tests     : define-method-combination.lsp 
                         random-type-prop-tests-08.lsp 
                         random-type-prop.lsp 
        lsp            : gcl_callhash.lsp 
        o              : makefile 

Log message:
        avoid some recompiles

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/ansi-tests/define-method-combination.lsp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/ansi-tests/random-type-prop-tests-08.lsp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/ansi-tests/random-type-prop.lsp?cvsroot=gcl&r1=1.17&r2=1.18
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_callhash.lsp?cvsroot=gcl&r1=1.5&r2=1.6
http://cvs.savannah.gnu.org/viewcvs/gcl/o/makefile?cvsroot=gcl&r1=1.48&r2=1.49

Patches:
Index: ansi-tests/define-method-combination.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/ansi-tests/define-method-combination.lsp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- ansi-tests/define-method-combination.lsp    16 Jul 2003 11:51:14 -0000      
1.5
+++ ansi-tests/define-method-combination.lsp    21 Jun 2006 13:49:25 -0000      
1.6
@@ -4,7 +4,6 @@
 ;;;; Contains: Tests of DEFINE-METHOD-COMBINATION
 
 (in-package :cl-test)
-
 (defclass dmc-class-01a () ())
 (defclass dmc-class-01b (dmc-class-01a) ())
 (defclass dmc-class-01c (dmc-class-01a) ())
@@ -114,7 +113,6 @@
     (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 'a)))
       (remove-method #'dmc-gf-03 meth)))
   :good)
-
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (report-and-ignore-errors
    (define-method-combination times2

Index: ansi-tests/random-type-prop-tests-08.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/ansi-tests/random-type-prop-tests-08.lsp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- ansi-tests/random-type-prop-tests-08.lsp    26 Feb 2006 02:39:18 -0000      
1.5
+++ ansi-tests/random-type-prop-tests-08.lsp    21 Jun 2006 13:49:25 -0000      
1.6
@@ -196,6 +196,88 @@
 ;;; Put count-if-not tests here
        
 
+;;position CM
+
+(def-type-prop-test position.1 'position '(t sequence) 2)
+(def-type-prop-test position.2 'position
+  (list t #'make-random-sequence-type-containing)
+  2)
+(def-type-prop-test position.3 'position
+  (list t #'make-random-sequence-type-containing
+       '(eql :start)
+       #'(lambda (x s k1) (declare (ignore x k1))
+           `(integer 0 ,(length s))))
+  4)
+(def-type-prop-test position.4 'position
+  (list t #'make-random-sequence-type-containing
+       '(eql :end)
+       #'(lambda (x s k1) (declare (ignore x k1))
+           `(integer 0 ,(length s))))
+  4)
+(def-type-prop-test position.5 'position
+  (list t #'make-random-sequence-type-containing
+       '(eql :start)
+       #'(lambda (x s k1) (declare (ignore x k1))
+           `(integer 0 ,(length s)))
+       '(eql :end)
+       #'(lambda (x s k1 start k2) (declare (ignore x k1 k2))
+           `(integer ,start ,(length s))))
+  6)
+
+(def-type-prop-test position.6 'position
+  (list '(or short-float single-float double-float long-float)
+       #'(lambda (f) `(vector (or ,(typecase f
+                                     (short-float 'short-float)
+                                     (single-float 'single-float)
+                                     (double-float 'double-float)
+                                     (long-float 'long-float)
+                                     (t 'float))
+                                  (eql ,f)))))
+  2)
+
+(def-type-prop-test position.7 'position '(bit (vector bit)) 2)
+(def-type-prop-test position.8 'position '((unsigned-byte 2) (vector 
(unsigned-byte 2))) 2)
+(def-type-prop-test position.9 'position '((unsigned-byte 4) (vector 
(unsigned-byte 4))) 2)
+(def-type-prop-test position.10 'position '((unsigned-byte 8) (vector 
(unsigned-byte 8))) 2)
+  
+
+;;; position-if tests
+
+(def-type-prop-test position-if.1 'position-if
+  (list (let ((funs '(numberp rationalp realp floatp complexp
+                     symbolp identity null functionp listp consp
+                      arrayp vectorp simple-vector-p
+                     stringp simple-string-p
+                     bit-vector-p simple-bit-vector-p)))
+         `(member ,@funs ,@(mapcar #'symbol-function funs)))
+       '(or list vector))
+  2)
+
+(def-type-prop-test position-if.2 'position-if
+  (list (let ((funs '(numberp rationalp realp floatp complexp
+                     symbolp identity null functionp listp consp
+                      arrayp vectorp simple-vector-p
+                     stringp simple-string-p
+                     bit-vector-p simple-bit-vector-p)))
+         `(member ,@funs ,@(mapcar #'symbol-function funs)))
+       '(or list vector)
+       '(eql :test)
+       (let ((test-funs '(eq eql equal equalp)))
+         `(member ,@test-funs ,@(mapcar #'symbol-function test-funs))))
+  4)
+
+
+
+
+;;; Put position-if-not tests here
+       
+
+
+
+
+
+
+
 (def-type-prop-test length.1 'length '(sequence) 1)
 
 (def-type-prop-test reverse.1 'reverse '(sequence) 1)

Index: ansi-tests/random-type-prop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/ansi-tests/random-type-prop.lsp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- ansi-tests/random-type-prop.lsp     7 Mar 2006 11:46:16 -0000       1.17
+++ ansi-tests/random-type-prop.lsp     21 Jun 2006 13:49:25 -0000      1.18
@@ -91,6 +91,11 @@
 ;;;
 ;;;
                              
+
+(defvar *fn* nil)
+(defvar *pms* nil)
+(defvar *fm* nil)
+
 (defun do-random-type-prop-tests
   (operator arg-types minargs
            &key
@@ -198,16 +203,16 @@
      (let* ((param-vals (loop for x in is-var?
                              for v in vals
                              when x collect v))
-           (fn (cl:handler-bind
+           (fn (setq *fn* (cl:handler-bind
                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                         (warning #'muffle-warning))
-                (compile nil form)))
+                (compile nil (setq *fm* form)))))
            (result
             (if store-into-cell?
                 (let ((r (make-array nil :element-type upgraded-result-type)))
-                  (apply fn r param-vals)
+                  (apply fn r (setq *pms* param-vals))
                   (aref r))
-              (apply fn param-vals))))
+              (apply fn (setq *pms* param-vals)))))
        (setq *random-type-prop-result*
             (list :upgraded-result-type upgraded-result-type
                   :form form

Index: lsp/gcl_callhash.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_callhash.lsp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- lsp/gcl_callhash.lsp        19 Jun 2006 00:52:08 -0000      1.5
+++ lsp/gcl_callhash.lsp        21 Jun 2006 13:49:26 -0000      1.6
@@ -59,6 +59,10 @@
             (maphash (lambda (x y) 
                        (when (and (fboundp x) (eq (symbol-function x) code) 
(call-src y))
                          (setq new x))) *call-hash-table*)
+;           (when (and (functionp code) (not (eq sym (function-name code))) 
(gethash (function-name code) *call-hash-table*) (not new))
+;             (format t  "setf symbol function ~s ~s~%" sym (function-name 
code)))
+;           (when (string= "MAKE-METHOD-LAMBDA" (symbol-name sym))
+;             (format t  "setf symbol function ~s code ~s~%" sym code))
             (cond (new
                    (let ((nr (find new *needs-recompile* :key 'car)))
                      (when nr (add-recompile sym (cadr nr) (caddr nr) (cadddr 
nr))))
@@ -72,7 +76,9 @@
                    (dolist (l (call-callees new)) 
                      (pushnew sym (call-callers (gethash l 
*call-hash-table*))))
                    (setf (call-callees h) (call-callees new) (call-src h) 
(call-src new)))
-                  ((setf (call-callees h) nil (call-src h) nil))))))))
+                  ((progn
+                     (remove-recompile sym)
+                     (setf (call-callees h) nil (call-src h) nil)))))))))
 
 (defun add-recompile (fn why assumed-sig actual-sig)
   (unless (find fn *needs-recompile* :key 'car)

Index: o/makefile
===================================================================
RCS file: /cvsroot/gcl/gcl/o/makefile,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -b -r1.48 -r1.49
--- o/makefile  21 Dec 2005 21:26:37 -0000      1.48
+++ o/makefile  21 Jun 2006 13:49:26 -0000      1.49
@@ -171,7 +171,6 @@
                             if (!match(a,"^\\.")) print a;}' \
                        k=$(LEADING_UNDERSCORE) |\
                        sort | \
-                       grep -v '[^ \t_]_' |\
                        awk '{A[++k]=$$0} END {for (i=1;i<=k;i++) \
                                printf("MY_PLT(%s)%s\n",A[i],i==k ? "" : 
",");}' >$@
        echo Plt table: