Raymond Toy pushed to branch issue-240-subsetp-with-hash-table at cmucl / cmucl

Commits:

9 changed files:

Changes:

  • benchmarks/cl-bench/files/math.lisp
    1 1 
     ;;; math.lisp -- various numerical operations
    2 2 
     ;;
    3 
    -;; Time-stamp: <2004-01-05 emarsden>
    3 
    +;; Time-stamp: <2023-08-12 07:34:28 toy>
    4 4 
     ;;
    5 5 
     ;; some basic mathematical benchmarks
    6 6
    ... ... @@ -56,7 +56,7 @@
    56 56 
     ;; calculate the "level" of a point in the Mandebrot Set, which is the
    57 57 
     ;; number of iterations taken to escape to "infinity" (points that
    58 58 
     ;; don't escape are included in the Mandelbrot Set). This version is
    59 
    -;; intended to test performance when programming in nave math-style.
    59 
    +;; intended to test performance when programming in naive math-style.
    60 60 
     (defun mset-level/complex (c)
    61 61 
       (declare (type complex c))
    62 62 
       (loop :for z = #c(0 0) :then (+ (* z z) c)

  • bin/clean-target.sh
    ... ... @@ -48,10 +48,10 @@ CORE='-o -name "*.core"'
    48 48
    49 49 
     if [ -n "$KEEP" ]; then
    50 50 
         case $KEEP in
    51 
    -      lib) GREP='egrep -v'
    51 
    +      lib) GREP='grep -Ev'
    52 52 
     	   PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library' ;;
    53 53 
           core) CORE='' ;;
    54 
    -      all) GREP='egrep -v'
    54 
    +      all) GREP='grep -Ev'
    55 55 
     	   PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library|(asdf|defsystem)'
    56 56 
     	   CORE='' ;;
    57 57 
         esac

  • bin/make-extra-dist.sh
    ... ... @@ -94,12 +94,12 @@ install ${GROUP} ${OWNER} -m 0755 $TARGET/motif/server/motifd \
    94 94
    95 95 
     # Install the contrib stuff.  Create the directories and then copy the files.
    96 96
    97 
    -for d in `(cd src; find contrib -type d -print | egrep -v "CVS|asdf|defsystem")`
    97 
    +for d in `(cd src; find contrib -type d -print | grep -E -v "CVS|asdf|defsystem")`
    98 98 
     do
    99 99 
         install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d
    100 100 
     done
    101 101
    102 
    -for f in `(cd src/contrib; find . -type f -print | egrep -v "CVS|asdf|defsystem|unix")`
    102 
    +for f in `(cd src/contrib; find . -type f -print | grep -E -v "CVS|asdf|defsystem|unix")`
    103 103 
     do
    104 104 
         FILE=`basename $f`
    105 105 
         DIR=`dirname $f`
    ... ... @@ -108,13 +108,13 @@ done
    108 108
    109 109 
     # Install all the locale data.
    110 110
    111 
    -for d in `(cd src/i18n/; find locale -type d -print | egrep -v CVS)`
    111 
    +for d in `(cd src/i18n/; find locale -type d -print | grep -E -v CVS)`
    112 112 
     do
    113 113 
         install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d
    114 114 
     done
    115 115
    116 116 
     # Install mo files.
    117 
    -for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')`
    117 
    +for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')`
    118 118 
     do
    119 119 
         FILE=`basename $f`
    120 120 
         DIR=`dirname $f`
    ... ... @@ -122,7 +122,7 @@ do
    122 122 
     done
    123 123
    124 124 
     # Install po files.  (Do we really need to distribute the po files?)
    125 
    -#for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')`
    125 
    +#for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')`
    126 126 
     #do
    127 127 
     #    FILE=`basename $f`
    128 128 
     #    DIR=`dirname $f`

  • src/code/c-call.lisp
    ... ... @@ -19,7 +19,7 @@
    19 19
    20 20 
     (intl:textdomain "cmucl")
    21 21
    22 
    -(export '(char short int long long-long unsigned-char unsigned-short unsigned-int
    22 
    +(export '(char short int long long-long signed-char unsigned-char unsigned-short unsigned-int
    23 23 
     	  unsigned-long unsigned-long-long float double c-string void))
    24 24
    25 25
    ... ... @@ -30,6 +30,8 @@
    30 30 
     (def-alien-type int (integer 32))
    31 31 
     (def-alien-type long (integer #-alpha 32 #+alpha 64))
    32 32 
     (def-alien-type long-long (integer 64))
    33 
    +;; The same as c-call:char, for convenience with C signed-char.
    34 
    +(def-alien-type signed-char (integer 8))
    33 35
    34 36 
     (def-alien-type unsigned-char (unsigned 8))
    35 37 
     (def-alien-type unsigned-short (unsigned 16))

  • src/code/list.lisp
    ... ... @@ -749,15 +749,9 @@
    749 749 
     (defparameter *min-list-length-for-hashtable*
    750 750 
       15)
    751 751
    752 
    -(defparameter *allow-hashtable-for-set-functions*
    753 
    -  nil)
    754 
    -
    755 752 
     ;; Convert a list to a hashtable.  The hashtable does not handle
    756 753 
     ;; duplicated values in the list.  Returns the hashtable.
    757 754 
     (defun list-to-hashtable (list key test test-not)
    758 
    -  (unless *allow-hashtable-for-set-functions*
    759 
    -    (return-from list-to-hashtable nil))
    760 
    -
    761 755 
       ;; Don't currently support test-not when converting a list to a hashtable
    762 756 
       (unless test-not
    763 757 
         (let ((hash-test (let ((test-fn (if (and (symbolp test)
    ... ... @@ -979,17 +973,25 @@
    979 973 
     	      (rplacd splicex (cdr x)))
    980 974 
     	  (setq splicex x)))))
    981 975
    976 
    +(defvar *allow-hashtable-for-set-functions* t)
    977 
    +
    982 978 
     (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
    983 979 
       "Returns T if every element in list1 is also in list2."
    984 980 
       (declare (inline member))
    985 981 
       (when (and testp notp)
    986 982 
         (error "Test and test-not both supplied."))
    987 983
    988 
    -  (let ((hashtable (list-to-hashtable list2 key test test-not)))
    984 
    +  ;; SUBSETP is used early in TYPE-INIT where hash tables aren't
    985 
    +  ;; available yet, so we can't use hashtables then.  LISPINIT will
    986 
    +  ;; take care to disable this for the kernel.core.  SAVE will set
    987 
    +  ;; this to true it's safe to use hash tables for SUBSETP.
    988 
    +  (let ((hashtable (when *allow-hashtable-for-set-functions*
    989 
    +                     (list-to-hashtable list2 key test test-not))))
    989 990 
         (cond (hashtable
    990 991 
     	   (dolist (item list1)
    991 992 
     	     (unless (nth-value 1 (gethash (apply-key key item) hashtable))
    992 
    -	       (return-from subsetp nil))))
    993 
    +	       (return-from subsetp nil)))
    994 
    +           t)
    993 995 
     	  ((null hashtable)
    994 996 
     	   (dolist (item list1)
    995 997 
     	     (unless (with-set-keys (member (apply-key key item) list2))
    ... ... @@ -1110,7 +1112,10 @@
    1110 1112 
     	(setf (car l) (cdar l)))
    1111 1113 
           (setq res (apply function (nreverse args)))
    1112 1114 
           (case accumulate
    1113 
    -	(:nconc (setq temp (last (nconc temp res))))
    1115 
    +	(:nconc (when res
    1116 
    +		  (let ((next-temp (last res)))
    1117 
    +		    (rplacd temp res)
    1118 
    +		    (setq temp next-temp))))
    1114 1119 
     	(:list (rplacd temp (list res))
    1115 1120 
     	       (setq temp (cdr temp)))))))
    1116 1121

  • src/compiler/seqtran.lisp
    ... ... @@ -36,12 +36,18 @@
    36 36 
     	  (ecase accumulate
    37 37 
     	    (:nconc
    38 38 
     	     (let ((temp (gensym))
    39 
    -		   (map-result (gensym)))
    39 
    +		   (map-result (gensym))
    40 
    +		   (res (gensym))
    41 
    +		   (next-temp (gensym)))
    40 42 
     	       `(let ((,map-result (list nil)))
    41 43 
     		  (declare (dynamic-extent ,map-result))
    42 44 
     		  (do-anonymous ((,temp ,map-result) . ,(do-clauses))
    43 45 
     				 (,endtest (cdr ,map-result))
    44 
    -		    (setq ,temp (last (nconc ,temp ,call)))))))
    46 
    +		    (let ((,res ,call))
    47 
    +		      (when ,res
    48 
    +			(let ((,next-temp (last ,res)))
    49 
    +			  (rplacd ,temp ,res)
    50 
    +			  (setq ,temp ,next-temp))))))))
    45 51 
     	    (:list
    46 52 
     	     (let ((temp (gensym))
    47 53 
     		   (map-result (gensym)))

  • src/general-info/release-21f.md
    ... ... @@ -25,6 +25,7 @@ public domain.
    25 25 
         * ~~#154~~ piglatin translation does not work anymore
    26 26 
     	* ~~#171~~ Readably print `(make-pathname :name :unspecfic)`
    27 27 
     	* ~~#242~~ Fix bug in `alien-funcall` with `c-call:char` as result type
    28 
    +    * ~~#244~~ Add `c-call:signed-char`
    28 29 
         * ~~#248~~ Print MOVS instruction with correct case
    29 30 
       * Other changes:
    30 31 
       * Improvements to the PCL implementation of CLOS:

  • tests/list.lisp
    1 
    +(defpackage "LIST-TESTS"
    2 
    +  (:use "COMMON-LISP"
    3 
    +	"LISP-UNIT"))
    4 
    +
    5 
    +(in-package "LIST-TESTS")
    6 
    +
    7 
    +(define-test mapcan-empty-list-returns-nil
    8 
    +  (locally (declare (notinline mapcan))
    9 
    +    (assert-equal '() (mapcan #'identity '())))
    10 
    +  (locally (declare (inline mapcan))
    11 
    +    (assert-equal '() (mapcan #'identity '()))))
    12 
    +
    13 
    +(define-test mapcon-empty-list-returns-nil
    14 
    +  (locally (declare (notinline mapcon))
    15 
    +    (assert-equal '() (mapcon #'identity '())))
    16 
    +  (locally (declare (inline mapcon))
    17 
    +    (assert-equal '() (mapcon #'identity '()))))
    18 
    +
    19 
    +(define-test mapcan-accumulate-non-nil-signals-type-error
    20 
    +  (locally (declare (notinline mapcan))
    21 
    +    (assert-error 'type-error (mapcan #'identity (list 42))))
    22 
    +  (locally (declare (inline mapcan))
    23 
    +    (assert-error 'type-error (mapcan #'identity (list 42)))))
    24 
    +
    25 
    +(define-test mapcon-accumulate-non-nil-signals-type-error
    26 
    +  (locally (declare (notinline mapcan))
    27 
    +    (assert-error 'type-error (mapcon #'car (list 42))))
    28 
    +  (locally (declare (inline mapcan))
    29 
    +    (assert-error 'type-error (mapcon #'car (list 42)))))
    30 
    +
    31 
    +(define-test mapcan-accumulate-nil-returns-nil
    32 
    +  (locally (declare (notinline mapcan))
    33 
    +    (assert-equal '() (mapcan (constantly nil) '(1)))
    34 
    +    (assert-equal '() (mapcan (constantly nil) '(1 2)))
    35 
    +    (assert-equal '() (mapcan (constantly nil) '(1 2 3))))
    36 
    +  (locally (declare (inline mapcan))
    37 
    +    (assert-equal '() (mapcan (constantly nil) '(1)))
    38 
    +    (assert-equal '() (mapcan (constantly nil) '(1 2)))
    39 
    +    (assert-equal '() (mapcan (constantly nil) '(1 2 3)))))
    40 
    +
    41 
    +(define-test mapcon-accumulate-nil-returns-nil
    42 
    +  (locally (declare (notinline mapcon))
    43 
    +    (assert-equal '() (mapcon (constantly nil) '(1)))
    44 
    +    (assert-equal '() (mapcon (constantly nil) '(1 2)))
    45 
    +    (assert-equal '() (mapcon (constantly nil) '(1 2 3))))
    46 
    +  (locally (declare (inline mapcon))
    47 
    +    (assert-equal '() (mapcon (constantly nil) '(1)))
    48 
    +    (assert-equal '() (mapcon (constantly nil) '(1 2)))
    49 
    +    (assert-equal '() (mapcon (constantly nil) '(1 2 3)))))
    50 
    +
    51 
    +(define-test mapcan-accumulate-one-list-returns-same-list
    52 
    +  (locally (declare (notinline mapcan))
    53 
    +    (let ((list1 (list 1)))
    54 
    +      (assert-eq list1 (mapcan (constantly list1) '(nil)))))
    55 
    +  (locally (declare (inline mapcan))
    56 
    +    (let ((list1 (list 1)))
    57 
    +      (assert-eq list1 (mapcan (constantly list1) '(nil))))))
    58 
    +
    59 
    +(define-test mapcon-accumulate-one-list-returns-same-list
    60 
    +  (locally (declare (notinline mapcon))
    61 
    +    (let ((list1 (list 1)))
    62 
    +      (assert-eq list1 (mapcon (constantly list1) '(nil)))))
    63 
    +  (locally (declare (inline mapcon))
    64 
    +    (let ((list1 (list 1)))
    65 
    +      (assert-eq list1 (mapcon (constantly list1) '(nil))))))
    66 
    +
    67 
    +(define-test mapcan-accumulate-two-lists-returns-same-lists
    68 
    +  (locally (declare (notinline mapcan))
    69 
    +    (let* ((list1 (list 1))
    70 
    +	   (list2 (list 2))
    71 
    +	   (list12 (mapcan #'identity (list list1 list2))))
    72 
    +      (assert-eq list1 list12)
    73 
    +      (assert-eq list2 (cdr list12))))
    74 
    +  (locally (declare (inline mapcan))
    75 
    +    (let* ((list1 (list 1))
    76 
    +	   (list2 (list 2))
    77 
    +	   (list12 (mapcan #'identity (list list1 list2))))
    78 
    +      (assert-eq list1 list12)
    79 
    +      (assert-eq list2 (cdr list12)))))
    80 
    +
    81 
    +(define-test mapcon-accumulate-two-lists-returns-same-lists
    82 
    +  (locally (declare (notinline mapcon))
    83 
    +    (let* ((list1 (list 1))
    84 
    +	   (list2 (list 2))
    85 
    +	   (list12 (mapcon #'car (list list1 list2))))
    86 
    +      (assert-eq list1 list12)
    87 
    +      (assert-eq list2 (cdr list12))))
    88 
    +  (locally (declare (inline mapcon))
    89 
    +    (let* ((list1 (list 1))
    90 
    +	   (list2 (list 2))
    91 
    +	   (list12 (mapcon #'car (list list1 list2))))
    92 
    +      (assert-eq list1 list12)
    93 
    +      (assert-eq list2 (cdr list12)))))
    94 
    +
    95 
    +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists
    96 
    +  (locally (declare (notinline mapcan))
    97 
    +    (let* ((list1 (list 1))
    98 
    +	   (list2 (list 2))
    99 
    +	   (list12 (mapcan #'identity (list nil list1 list2))))
    100 
    +      (assert-eq list1 list12)
    101 
    +      (assert-eq list2 (cdr list12)))
    102 
    +    (let* ((list1 (list 1))
    103 
    +	   (list2 (list 2))
    104 
    +	   (list12 (mapcan #'identity (list list1 nil list2))))
    105 
    +      (assert-eq list1 list12)
    106 
    +      (assert-eq list2 (cdr list12)))
    107 
    +    (let* ((list1 (list 1))
    108 
    +	   (list2 (list 2))
    109 
    +	   (list12 (mapcan #'identity (list list1 list2 nil))))
    110 
    +      (assert-eq list1 list12)
    111 
    +      (assert-eq list2 (cdr list12))))
    112 
    +  (locally (declare (inline mapcan))
    113 
    +    (let* ((list1 (list 1))
    114 
    +	   (list2 (list 2))
    115 
    +	   (list12 (mapcan #'identity (list nil list1 list2))))
    116 
    +      (assert-eq list1 list12)
    117 
    +      (assert-eq list2 (cdr list12)))
    118 
    +    (let* ((list1 (list 1))
    119 
    +	   (list2 (list 2))
    120 
    +	   (list12 (mapcan #'identity (list list1 nil list2))))
    121 
    +      (assert-eq list1 list12)
    122 
    +      (assert-eq list2 (cdr list12)))
    123 
    +    (let* ((list1 (list 1))
    124 
    +	   (list2 (list 2))
    125 
    +	   (list12 (mapcan #'identity (list list1 list2 nil))))
    126 
    +      (assert-eq list1 list12)
    127 
    +      (assert-eq list2 (cdr list12)))))
    128 
    +
    129 
    +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists
    130 
    +  (locally (declare (notinline mapcon))
    131 
    +    (let* ((list1 (list 1))
    132 
    +	   (list2 (list 2))
    133 
    +	   (list12 (mapcon #'car (list nil list1 list2))))
    134 
    +      (assert-eq list1 list12)
    135 
    +      (assert-eq list2 (cdr list12)))
    136 
    +    (let* ((list1 (list 1))
    137 
    +	   (list2 (list 2))
    138 
    +	   (list12 (mapcon #'car (list list1 nil list2))))
    139 
    +      (assert-eq list1 list12)
    140 
    +      (assert-eq list2 (cdr list12)))
    141 
    +    (let* ((list1 (list 1))
    142 
    +	   (list2 (list 2))
    143 
    +	   (list12 (mapcon #'car (list list1 list2 nil))))
    144 
    +      (assert-eq list1 list12)
    145 
    +      (assert-eq list2 (cdr list12))))
    146 
    +  (locally (declare (inline mapcon))
    147 
    +    (let* ((list1 (list 1))
    148 
    +	   (list2 (list 2))
    149 
    +	   (list12 (mapcon #'car (list nil list1 list2))))
    150 
    +      (assert-eq list1 list12)
    151 
    +      (assert-eq list2 (cdr list12)))
    152 
    +    (let* ((list1 (list 1))
    153 
    +	   (list2 (list 2))
    154 
    +	   (list12 (mapcon #'car (list list1 nil list2))))
    155 
    +      (assert-eq list1 list12)
    156 
    +      (assert-eq list2 (cdr list12)))
    157 
    +    (let* ((list1 (list 1))
    158 
    +	   (list2 (list 2))
    159 
    +	   (list12 (mapcon #'car (list list1 list2 nil))))
    160 
    +      (assert-eq list1 list12)
    161 
    +      (assert-eq list2 (cdr list12)))))
    162 
    +
    163 
    +(define-test mapcan-accumulate-same-list-twice-returns-circular-list
    164 
    +  (locally (declare (notinline mapcan))
    165 
    +    (let ((list12 (list 1 2)))
    166 
    +      ;; check that list12 equals #1=(1 2 . #1#)
    167 
    +      (assert-eq list12 (mapcan (constantly list12) '(nil nil)))
    168 
    +      (assert-eql 1 (elt list12 0))
    169 
    +      (assert-eql 2 (elt list12 1))
    170 
    +      (assert-eq (nthcdr 2 list12) list12)))
    171 
    +  (locally (declare (inline mapcan))
    172 
    +    (let ((list12 (list 1 2)))
    173 
    +      ;; check that list12 equals #1=(1 2 . #1#)
    174 
    +      (assert-eq list12 (mapcan (constantly list12) '(nil nil)))
    175 
    +      (assert-eql 1 (elt list12 0))
    176 
    +      (assert-eql 2 (elt list12 1))
    177 
    +      (assert-eq (nthcdr 2 list12) list12))))
    178 
    +
    179 
    +(define-test mapcon-accumulate-same-list-twice-returns-circular-list
    180 
    +  (locally (declare (notinline mapcon))
    181 
    +    (let ((list12 (list 1 2)))
    182 
    +      ;; check that list12 equals #1=(1 2 . #1#)
    183 
    +      (assert-eq list12 (mapcon (constantly list12) '(nil nil)))
    184 
    +      (assert-eql 1 (elt list12 0))
    185 
    +      (assert-eql 2 (elt list12 1))
    186 
    +      (assert-eq (nthcdr 2 list12) list12)))
    187 
    +  (locally (declare (notinline mapcon))
    188 
    +    (let ((list12 (list 1 2)))
    189 
    +      ;; check that list12 equals #1=(1 2 . #1#)
    190 
    +      (assert-eq list12 (mapcon (constantly list12) '(nil nil)))
    191 
    +      (assert-eql 1 (elt list12 0))
    192 
    +      (assert-eql 2 (elt list12 1))
    193 
    +      (assert-eq (nthcdr 2 list12) list12))))

  • tests/run-tests.lisp
    ... ... @@ -110,9 +110,10 @@
    110 110 
         (format t " ~5D tests failed~%" failed)
    111 111 
         (format t " ~5D tests with execution errors~%" execute-errors)
    112 112 
         (format t "~5,3f% of the tests passed~%"
    113 
    -	    (float (* 100
    114 
    -		      (- 1 (/ (+ failed execute-errors)
    115 
    -			      (+ passed failed execute-errors))))))
    113 
    +	    (let ((total (+ passed failed execute-errors)))
    114 
    +	      (if (zerop total)
    115 
    +		  0.0
    116 
    +		  (* 100.0 (- 1.0 (/ (- total passed) total))))))
    116 117 
         ;; Print some info about any failed tests.  Then exit.  We want to
    117 118 
         ;; set the exit code so that any scripts runnning this can
    118 119 
         ;; determine if there were any test failures.

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help