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

Commits: f577eda6 by Raymond Toy at 2023-07-23T22:38:00+00:00 Fix #244: Add c-call:signed-char

- - - - - 0411c386 by Raymond Toy at 2023-07-23T22:38:01+00:00 Merge branch 'issue-244-c-call-signed-char' into 'master'

Fix #244: Add c-call:signed-char

Closes #244

See merge request cmucl/cmucl!157 - - - - - 3e8b0a12 by Raymond Toy at 2023-07-26T13:43:15+00:00 Fix #245: Replace egrep with grep -E

- - - - - 24152f4d by Raymond Toy at 2023-07-26T13:43:15+00:00 Merge branch 'issue-245-replace-egrep-with-grep' into 'master'

Fix #245: Replace egrep with grep -E

Closes #245

See merge request cmucl/cmucl!158 - - - - - 5b27393f by Carl Shapiro at 2023-07-30T21:15:48-07:00 Guard against a division by zero in test run reports

- - - - - a7300f03 by Carl Shapiro at 2023-07-31T05:28:58+00:00 Merge branch 'zero-tests' into 'master'

Guard against a division by zero when reporting test results

See merge request cmucl/cmucl!161 - - - - - 33f11724 by Raymond Toy at 2023-08-12T07:34:55-07:00 Replace latin-1 character Latin_Small_Letter_I_With_Diaeresis

In files/math.lisp, the word "naive" is spelled using the character \Latin_Small_Letter_I_With_Diaeresis. However, when compiling locally with a UTF-8 encoding (which is the default), this is invalid. The letter needs to be encoded as 2 octets. I'm too lazy to figure out how to get emacs to insert the correct encoded character so I'm replacing it with a simple "i". This makes the file pure ASCII, so it should work fine with a UTF-8 encoding.

- - - - - a8ced15b by Carl Shapiro at 2023-08-14T04:45:23+00:00 Address #196: Fix issues with mapping and nconc accumulation

- - - - - 310e41eb by Carl Shapiro at 2023-08-14T04:45:41+00:00 Merge branch 'mapcan' into 'master'

Address #196: Fix issues with mapping and nconc accumulation

See merge request cmucl/cmucl!162 - - - - - 19a305de by Raymond Toy at 2023-08-16T14:28:11+00:00 Address #240: Speed up set-difference

- - - - - 9d593e3a by Raymond Toy at 2023-08-16T14:28:55+00:00 Merge branch 'issue-240-set-diff-with-hash-table' into 'master'

Address #240: Speed up set-difference

Closes #240

See merge request cmucl/cmucl!153 - - - - - d22817cb by Raymond Toy at 2023-08-16T09:28:39-07:00 Merge branch 'master' into issue-240-subsetp-with-hash-table

- - - - - a4c90a8b by Raymond Toy at 2023-08-16T12:52:55-07:00 Fix up bad merge and disable hashtable only for subsetp

We mistakenly removed *allow-hashtable-for-set-functions* when merging with master. Put it all back. However, modify it so we only disable hashtables for subsetp because that's the only function (so far) that is used in TYPE-INIT where hashtables aren't available yet.

- - - - -

9 changed files:

- benchmarks/cl-bench/files/math.lisp - bin/clean-target.sh - bin/make-extra-dist.sh - src/code/c-call.lisp - src/code/list.lisp - src/compiler/seqtran.lisp - src/general-info/release-21f.md - + tests/list.lisp - tests/run-tests.lisp

Changes:

===================================== benchmarks/cl-bench/files/math.lisp ===================================== @@ -1,6 +1,6 @@ ;;; math.lisp -- various numerical operations ;; -;; Time-stamp: <2004-01-05 emarsden> +;; Time-stamp: <2023-08-12 07:34:28 toy> ;; ;; some basic mathematical benchmarks

@@ -56,7 +56,7 @@ ;; calculate the "level" of a point in the Mandebrot Set, which is the ;; number of iterations taken to escape to "infinity" (points that ;; don't escape are included in the Mandelbrot Set). This version is -;; intended to test performance when programming in naïve math-style. +;; intended to test performance when programming in naive math-style. (defun mset-level/complex (c) (declare (type complex c)) (loop :for z = #c(0 0) :then (+ (* z z) c)

===================================== bin/clean-target.sh ===================================== @@ -48,10 +48,10 @@ CORE='-o -name "*.core"'

if [ -n "$KEEP" ]; then case $KEEP in - lib) GREP='egrep -v' + lib) GREP='grep -Ev' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library' ;; core) CORE='' ;; - all) GREP='egrep -v' + all) GREP='grep -Ev' PATTERN='(gray-streams|gray-compat|simple-streams|iodefs|external-formats|clx|hemlock|clm)-library|(asdf|defsystem)' CORE='' ;; esac

===================================== bin/make-extra-dist.sh ===================================== @@ -94,12 +94,12 @@ install ${GROUP} ${OWNER} -m 0755 $TARGET/motif/server/motifd \

# Install the contrib stuff. Create the directories and then copy the files.

-for d in `(cd src; find contrib -type d -print | egrep -v "CVS|asdf|defsystem")` +for d in `(cd src; find contrib -type d -print | grep -E -v "CVS|asdf|defsystem")` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done

-for f in `(cd src/contrib; find . -type f -print | egrep -v "CVS|asdf|defsystem|unix")` +for f in `(cd src/contrib; find . -type f -print | grep -E -v "CVS|asdf|defsystem|unix")` do FILE=`basename $f` DIR=`dirname $f` @@ -108,13 +108,13 @@ done

# Install all the locale data.

-for d in `(cd src/i18n/; find locale -type d -print | egrep -v CVS)` +for d in `(cd src/i18n/; find locale -type d -print | grep -E -v CVS)` do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/$d done

# Install mo files. -for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` +for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')` do FILE=`basename $f` DIR=`dirname $f` @@ -122,7 +122,7 @@ do done

# Install po files. (Do we really need to distribute the po files?) -#for f in `(cd $TARGET/i18n; find locale -type f -print | egrep -v 'CVS|~.*~|.*~')` +#for f in `(cd $TARGET/i18n; find locale -type f -print | grep -E -v 'CVS|~.*~|.*~')` #do # FILE=`basename $f` # DIR=`dirname $f`

===================================== src/code/c-call.lisp ===================================== @@ -19,7 +19,7 @@

(intl:textdomain "cmucl")

-(export '(char short int long long-long unsigned-char unsigned-short unsigned-int +(export '(char short int long long-long signed-char unsigned-char unsigned-short unsigned-int unsigned-long unsigned-long-long float double c-string void))  @@ -30,6 +30,8 @@ (def-alien-type int (integer 32)) (def-alien-type long (integer #-alpha 32 #+alpha 64)) (def-alien-type long-long (integer 64)) +;; The same as c-call:char, for convenience with C signed-char. +(def-alien-type signed-char (integer 8))

(def-alien-type unsigned-char (unsigned 8)) (def-alien-type unsigned-short (unsigned 16))

===================================== src/code/list.lisp ===================================== @@ -749,15 +749,9 @@ (defparameter *min-list-length-for-hashtable* 15)

-(defparameter *allow-hashtable-for-set-functions* - nil) - ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. (defun list-to-hashtable (list key test test-not) - (unless *allow-hashtable-for-set-functions* - (return-from list-to-hashtable nil)) - ;; Don't currently support test-not when converting a list to a hashtable (unless test-not (let ((hash-test (let ((test-fn (if (and (symbolp test) @@ -979,17 +973,25 @@ (rplacd splicex (cdr x))) (setq splicex x)))))

+(defvar *allow-hashtable-for-set-functions* t) + (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns T if every element in list1 is also in list2." (declare (inline member)) (when (and testp notp) (error "Test and test-not both supplied."))

- (let ((hashtable (list-to-hashtable list2 key test test-not))) + ;; SUBSETP is used early in TYPE-INIT where hash tables aren't + ;; available yet, so we can't use hashtables then. LISPINIT will + ;; take care to disable this for the kernel.core. SAVE will set + ;; this to true it's safe to use hash tables for SUBSETP. + (let ((hashtable (when *allow-hashtable-for-set-functions* + (list-to-hashtable list2 key test test-not)))) (cond (hashtable (dolist (item list1) (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (return-from subsetp nil)))) + (return-from subsetp nil))) + t) ((null hashtable) (dolist (item list1) (unless (with-set-keys (member (apply-key key item) list2)) @@ -1110,7 +1112,10 @@ (setf (car l) (cdar l))) (setq res (apply function (nreverse args))) (case accumulate - (:nconc (setq temp (last (nconc temp res)))) + (:nconc (when res + (let ((next-temp (last res))) + (rplacd temp res) + (setq temp next-temp)))) (:list (rplacd temp (list res)) (setq temp (cdr temp)))))))

===================================== src/compiler/seqtran.lisp ===================================== @@ -36,12 +36,18 @@ (ecase accumulate (:nconc (let ((temp (gensym)) - (map-result (gensym))) + (map-result (gensym)) + (res (gensym)) + (next-temp (gensym))) `(let ((,map-result (list nil))) (declare (dynamic-extent ,map-result)) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) (,endtest (cdr ,map-result)) - (setq ,temp (last (nconc ,temp ,call))))))) + (let ((,res ,call)) + (when ,res + (let ((,next-temp (last ,res))) + (rplacd ,temp ,res) + (setq ,temp ,next-temp)))))))) (:list (let ((temp (gensym)) (map-result (gensym)))

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

===================================== tests/list.lisp ===================================== @@ -0,0 +1,193 @@ +(defpackage "LIST-TESTS" + (:use "COMMON-LISP" + "LISP-UNIT")) + +(in-package "LIST-TESTS") + +(define-test mapcan-empty-list-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan #'identity '()))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan #'identity '())))) + +(define-test mapcon-empty-list-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon #'identity '()))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon #'identity '())))) + +(define-test mapcan-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcan #'identity (list 42))))) + +(define-test mapcon-accumulate-non-nil-signals-type-error + (locally (declare (notinline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42)))) + (locally (declare (inline mapcan)) + (assert-error 'type-error (mapcon #'car (list 42))))) + +(define-test mapcan-accumulate-nil-returns-nil + (locally (declare (notinline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcan)) + (assert-equal '() (mapcan (constantly nil) '(1))) + (assert-equal '() (mapcan (constantly nil) '(1 2))) + (assert-equal '() (mapcan (constantly nil) '(1 2 3))))) + +(define-test mapcon-accumulate-nil-returns-nil + (locally (declare (notinline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3)))) + (locally (declare (inline mapcon)) + (assert-equal '() (mapcon (constantly nil) '(1))) + (assert-equal '() (mapcon (constantly nil) '(1 2))) + (assert-equal '() (mapcon (constantly nil) '(1 2 3))))) + +(define-test mapcan-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil))))) + (locally (declare (inline mapcan)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcan (constantly list1) '(nil)))))) + +(define-test mapcon-accumulate-one-list-returns-same-list + (locally (declare (notinline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil))))) + (locally (declare (inline mapcon)) + (let ((list1 (list 1))) + (assert-eq list1 (mapcon (constantly list1) '(nil)))))) + +(define-test mapcan-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcan)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcan #'identity (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcon-accumulate-two-lists-skips-nil-returns-same-lists + (locally (declare (notinline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12)))) + (locally (declare (inline mapcon)) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list nil list1 list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 nil list2)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))) + (let* ((list1 (list 1)) + (list2 (list 2)) + (list12 (mapcon #'car (list list1 list2 nil)))) + (assert-eq list1 list12) + (assert-eq list2 (cdr list12))))) + +(define-test mapcan-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (inline mapcan)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcan (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12)))) + +(define-test mapcon-accumulate-same-list-twice-returns-circular-list + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))) + (locally (declare (notinline mapcon)) + (let ((list12 (list 1 2))) + ;; check that list12 equals #1=(1 2 . #1#) + (assert-eq list12 (mapcon (constantly list12) '(nil nil))) + (assert-eql 1 (elt list12 0)) + (assert-eql 2 (elt list12 1)) + (assert-eq (nthcdr 2 list12) list12))))

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

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/27f80806c1b7101455e05c9...