- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] 2 commits: Make +min-list-length-for-hashtable+ a defparameter again
by Raymond Toy (＠rtoy) 27 Jul '23

27 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 96e66071 by Raymond Toy at 2023-07-26T18:59:10-07:00 Make +min-list-length-for-hashtable+ a defparameter again Rename it using the `*foo*` convention too. It's super-convenient to be able to set this for testing, which we do in the existing test suite for this. It's also convenient to be able to do this when doing timing tests so we can compare what happens when the list version is used vs when the hashtable is used. - - - - - 7ab5d243 by Raymond Toy at 2023-07-26T19:00:59-07:00 Add some additional tests for set-difference Add a test where a key is given to make sure that hashtable works correctly with a key Add a test where both a test and a test-not is given. This must signal an error. - - - - - 2 changed files: - src/code/list.lisp - tests/sets.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -746,7 +746,7 @@ ;; The minimum length of a list before we can use a hashtable. This ;; was determined experimentally. -(defconstant +min-list-length-for-hashtable+ +(defparameter *min-list-length-for-hashtable* 15) ;; Convert a list to a hashtable. The hashtable does not handle @@ -767,7 +767,7 @@ ;; If the list is too short, the hashtable makes things ;; slower. We also need to balance memory usage. (let ((len (length list))) - (when (< len +min-list-length-for-hashtable+) + (when (< len *min-list-length-for-hashtable*) (return-from list-to-hashtable nil)) (let ((hashtable (make-hash-table :test hash-test :size len))) (dolist (item list) @@ -855,7 +855,7 @@ (cond (hashtable ;; list2 was placed in hash table. (let ((res nil)) - (dolist (item list1) + (doli st (item list1) (unless (nth-value 1 (gethash (apply-key key item) hashtable)) (push item res))) res)) ===================================== tests/sets.lisp ===================================== @@ -72,3 +72,20 @@ (set-difference '("a" "b" "b" "C") '("c" "D" "e" "f" "g" "h") :test #'equalp)))) + +;; Simple test that we handle a key correctly +(define-test set-diff.hash-eql-with-key + (let ((lisp::*min-list-length-for-hashtable* 2)) + (assert-equal '((3 "b") (2 "b")) + (set-difference '((1 "a") (2 "b") (3 "b")) + '((1 "a") (4 "c") (5 "d")) + :key #'first)))) + +(define-test set-diff.test-and-test-not + (assert-error 'simple-error + (set-difference '(1 2) + '(3 4) + :test 'eql + :test-not 'eql))) + + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3fbae4d018b9bc6891effd… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/3fbae4d018b9bc6891effd… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] 2 commits: Revert change that converted cond to case
by Raymond Toy (＠rtoy) 27 Jul '23

27 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: d6aae1fe by Raymond Toy at 2023-07-26T18:35:56-07:00 Revert change that converted cond to case The use of `case` insted of `cond` didn't work as we naively expected. Change it back to using `cond`. - - - - - 3fbae4d0 by Raymond Toy at 2023-07-26T18:40:57-07:00 Fix args to list-to-hashtable Originally, we had the args in the order `test`, `test-not`, and `key`. We really should have `key`, `test`, and `test-not`. That's how set-difference was calling `list-to-hashtable`, and it make more sense for the args to be in this order. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -751,14 +751,17 @@ ;; Convert a list to a hashtable. The hashtable does not handle ;; duplicated values in the list. Returns the hashtable. -(defun list-to-hashtable (list test test-not key) +(defun list-to-hashtable (list key test test-not) ;; Don't currently support test-not when converting a list to a hashtable (unless test-not - (let ((hash-test (case test - ((#'eq 'eq) 'eq) - ((#'eql 'eq) 'eql) - ((#'equal 'equal) 'equal) - ((#'equalp 'equalp) 'equalp)))) + (let ((hash-test (let ((test-fn (if (and (symbolp test) + (fboundp test)) + (fdefinition test) + test))) + (cond ((eql test-fn #'eq) 'eq) + ((eql test-fn #'eql) 'eql) + ((eql test-fn #'equal) 'equal) + ((eql test-fn #'equalp) 'equalp))))) (unless hash-test (return-from list-to-hashtable nil)) ;; If the list is too short, the hashtable makes things View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c09004a15331d191b5dcfe… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/c09004a15331d191b5dcfe… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] Make min-list-length-for-hashtable a defconstant
by Raymond Toy (＠rtoy) 26 Jul '23

26 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: c09004a1 by Raymond Toy at 2023-07-26T14:34:09-07:00 Make min-list-length-for-hashtable a defconstant Update name to use `+foo+` convention for constants. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -744,8 +744,9 @@ list (cons item list))) -;; The minimum length of a list before we can use a hashtable -(defparameter *min-list-length-for-hashtable* +;; The minimum length of a list before we can use a hashtable. This +;; was determined experimentally. +(defconstant +min-list-length-for-hashtable+ 15) ;; Convert a list to a hashtable. The hashtable does not handle @@ -763,7 +764,7 @@ ;; If the list is too short, the hashtable makes things ;; slower. We also need to balance memory usage. (let ((len (length list))) - (when (< len *min-list-length-for-hashtable*) + (when (< len +min-list-length-for-hashtable+) (return-from list-to-hashtable nil)) (let ((hashtable (make-hash-table :test hash-test :size len))) (dolist (item list) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c09004a15331d191b5dcfe7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/c09004a15331d191b5dcfe7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] Apply suggestions from review, cleaning up some oddities.
by Raymond Toy (＠rtoy) 26 Jul '23

26 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 42e2d9be by Raymond Toy at 2023-07-26T07:26:06-07:00 Apply suggestions from review, cleaning up some oddities. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -750,28 +750,25 @@ ;; 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 key) +(defun list-to-hashtable (list test test-not key) ;; 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) - (fboundp test)) - (fdefinition test) - test))) - (case test-fn - (#'eq 'eq) - (#'eql 'eql) - (#'equal 'equal) - (#'equalp 'equalp))))) + (let ((hash-test (case test + ((#'eq 'eq) 'eq) + ((#'eql 'eq) 'eql) + ((#'equal 'equal) 'equal) + ((#'equalp 'equalp) 'equalp)))) (unless hash-test (return-from list-to-hashtable nil)) ;; If the list is too short, the hashtable makes things ;; slower. We also need to balance memory usage. - (when (< (length list) *min-list-length-for-hashtable*) - (return-from list-to-hashtable nil)) - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list) - (setf (gethash (apply-key key item) hashtable) item)) - hashtable)))) + (let ((len (length list))) + (when (< len *min-list-length-for-hashtable*) + (return-from list-to-hashtable nil)) + (let ((hashtable (make-hash-table :test hash-test :size len))) + (dolist (item list) + (setf (gethash (apply-key key item) hashtable) item)) + hashtable))))) ;;; UNION -- Public. ;;; @@ -850,21 +847,21 @@ (return-from set-difference list1)) (let ((hashtable - (list-to-hashtable list2 :key key :test test :test-not test-not))) + (list-to-hashtable list2 key test test-not))) (cond (hashtable ;; list2 was placed in hash table. - (let (diff) + (let ((res nil)) (dolist (item list1) (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item diff))) - diff)) + (push item res))) + res)) ((null hashtable) ;; Default implementation because we didn't create the hash ;; table. (let ((res nil)) - (dolist (elt list1) - (if (not (with-set-keys (member (apply-key key elt) list2))) - (push elt res))) + (dolist (item list1) + (if (not (with-set-keys (member (apply-key key item) list2))) + (push item res))) res))))) (defun nset-difference (list1 list2 &key key View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/42e2d9be8f524234b178c1c… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/42e2d9be8f524234b178c1c… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #245: Replace egrep with grep -E
by Raymond Toy (＠rtoy) 26 Jul '23

26 Jul '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 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 - - - - - 2 changed files: - bin/clean-target.sh - bin/make-extra-dist.sh Changes: ===================================== 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` View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0411c386ebc48eb35f94e2… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0411c386ebc48eb35f94e2… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] Update set-diff tests
by Raymond Toy (＠rtoy) 24 Jul '23

24 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 12f6ff0e by Raymond Toy at 2023-07-24T15:35:18-07:00 Update set-diff tests The hash table returns the results in the same order as the list version. - - - - - 1 changed file: - tests/sets.lisp Changes: ===================================== tests/sets.lisp ===================================== @@ -12,12 +12,12 @@ (let ((lisp::*min-list-length-for-hashtable* 2)) (assert-equal '(2 2 1) (set-difference '(1 2 2 3) '(3 4))) - (assert-equal '(1 2 2) + (assert-equal '(2 2 1) (set-difference '(1 2 2 3) '(3 4 5 6 7 8))) (assert-equal '(2 2 1) (set-difference '(1 2 2 3) '(3 4) :test #'eql)) - (assert-equal '(1 2 2) + (assert-equal '(2 2 1) (set-difference '(1 2 2 3) '(3 4 5 6 7 8) :test #'eql)))) @@ -26,11 +26,11 @@ (let ((lisp::*min-list-length-for-hashtable* 2)) (assert-equal '(b b a) (set-difference '(a b b c) '(c d e) :test 'eq)) - (assert-equal '(a b b) + (assert-equal '(b b a) (set-difference '(a b b c) '(c d e f g h) :test 'eq)) (assert-equal '(b b a) (set-difference '(a b b c) '(c d e) :test #'eq)) - (assert-equal '(a b b) + (assert-equal '(b b a) (set-difference '(a b b c) '(c d e f g h) :test #'eq)))) (define-test set-diff.hash-equal @@ -40,7 +40,7 @@ (set-difference '("a" "b" "b" "c") '("c" "d" "e") :test 'equal)) - (assert-equal '("a" "b" "b") + (assert-equal '("b" "b" "a") (set-difference '("a" "b" "b" "c") '("c" "d" "e" "f" "g" "h") :test 'equal)) @@ -48,7 +48,7 @@ (set-difference '("a" "b" "b" "c") '("c" "d" "e") :test #'equal)) - (assert-equal '("a" "b" "b") + (assert-equal '("b" "b" "a") (set-difference '("a" "b" "b" "c") '("c" "d" "e" "f" "g" "h") :test #'equal)))) @@ -60,7 +60,7 @@ (set-difference '("a" "b" "b" "c") '("C" "d" "e") :test 'equalp)) - (assert-equal '("a" "b" "b") + (assert-equal '("b" "b" "a") (set-difference '("a" "b" "b" "C") '("c" "D" "e" "f" "g" "h") :test 'equalp)) @@ -68,7 +68,7 @@ (set-difference '("a" "b" "b" "c") '("C" "d" "e") :test #'equalp)) - (assert-equal '("a" "b" "b") + (assert-equal '("b" "b" "a") (set-difference '("a" "b" "b" "C") '("c" "D" "e" "f" "g" "h") :test #'equalp)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/12f6ff0e193bbe277e9d427… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/12f6ff0e193bbe277e9d427… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-240-set-diff-with-hash-table] 15 commits: Fix typo in docstring for EQUAL
by Raymond Toy (＠rtoy) 24 Jul '23

24 Jul '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 1fcdbdb2 by Raymond Toy at 2023-06-19T14:17:30-07:00 Fix typo in docstring for EQUAL - - - - - 4e433b83 by Raymond Toy at 2023-07-05T06:40:08-07:00 Set LANG in build.sh For some reason, on my Mac system, LANG isn't set and sometimes git messages are in Korean. So for consistency, set LANG in build.sh to a known value that should work everywhere. - - - - - da69492b by Raymond Toy at 2023-07-17T15:07:01+00:00 Fix #234: Make :ascii external format builtin. - - - - - 635d07ca by Raymond Toy at 2023-07-17T15:07:04+00:00 Merge branch 'issue-234-make-ascii-format-builtin' into 'master' Fix #234: Make :ascii external format builtin. Closes #234 See merge request cmucl/cmucl!155 - - - - - 0a35575a by Raymond Toy at 2023-07-17T15:07:47+00:00 Fix #242: Mask out unwanted bits for integer results - - - - - 5d4b0622 by Raymond Toy at 2023-07-17T15:07:49+00:00 Merge branch 'issue-242-c-call-char-result-wrong' into 'master' Fix #242: Mask out unwanted bits for integer results Closes #242 See merge request cmucl/cmucl!154 - - - - - bdd7294f by Raymond Toy at 2023-07-21T19:15:10+00:00 Fix #171: Readably print pathnames with :unspecific - - - - - 4bce99fc by Raymond Toy at 2023-07-21T19:15:11+00:00 Merge branch 'issue-171-readable-unspecific-pathnames' into 'master' Fix #171: Readably print pathnames with :unspecific Closes #171 See merge request cmucl/cmucl!134 - - - - - d37a3150 by Raymond Toy at 2023-07-22T00:19:38+00:00 Fix #248: Disassemble MOVS inst nicely - - - - - 95dfdcf3 by Raymond Toy at 2023-07-22T00:19:39+00:00 Merge branch 'issue-248-disassemble-movs-nicely' into 'master' Fix #248: Disassemble MOVS inst nicely Closes #248 See merge request cmucl/cmucl!156 - - - - - 8c6e050a by Raymond Toy at 2023-07-21T18:06:08-07:00 Remove extraneous debugging print Introduced in commit [0a35575aa0] for debugging and we forgot to remove it. - - - - - a85ad7cf by Raymond Toy at 2023-07-23T12:18:48-07:00 Update release notes with closed issues Should have been updated when the issue was closed, but we forgot. Update now. - - - - - d5c23293 by Raymond Toy at 2023-07-23T15:07:27-07:00 Update cmucl.pot Forgot to update cmucl.pot in previous commits/merges that changed docstrings for various things. Update it now. - - - - - 1b54eed9 by Raymond Toy at 2023-07-23T17:18:18-07:00 Merge branch 'master' into issue-240-set-diff-with-hash-table - - - - - f44c4b81 by Raymond Toy at 2023-07-24T14:51:30-07:00 Clean up set-diff code Remove unused functions having to do with hashing the first list. Modify list-to-hashtable to only want one list to be hashed and only returning one value (the hashtable). Manually inline set-diff-hash2. Apply Carl's suggest to use ecase instead of cond. Update tests because the hash table returns the results in the same order as the list version. - - - - - 15 changed files: - bin/build.sh - bin/run-tests.sh - src/code/alieneval.lisp - src/code/extfmts.lisp - src/code/fd-stream-comp.lisp - src/code/list.lisp - src/code/pathname.lisp - src/code/pred.lisp - src/compiler/x86/c-call.lisp - src/compiler/x86/insts.lisp - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot - tests/issues.lisp - tests/pathname.lisp - + tests/test-return.c Changes: ===================================== bin/build.sh ===================================== @@ -110,6 +110,8 @@ case `uname -s` in esac ;; esac +export LANG=en_US.UTF-8 + buildit () { if echo $INTERACTIVE_BUILD | grep $BUILD > /dev/null; then ===================================== bin/run-tests.sh ===================================== @@ -47,6 +47,11 @@ function cleanup { trap cleanup EXIT +# Compile up the C file that is used for testing alien funcalls to +# functions that return integer types of different lengths. We use +# gcc since clang isn't always available. +(cd tests; gcc -m32 -O3 -c test-return.c) + if [ $# -eq 0 ]; then # No args so run all the tests $LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)' ===================================== src/code/alieneval.lisp ===================================== @@ -170,6 +170,9 @@ (alien-rep nil :type (or null function)) (extract-gen nil :type (or null function)) (deposit-gen nil :type (or null function)) + ;; + ;; Method that accepts the alien type and the alien value. The + ;; method converts the alien value into an appropriate lisp value. (naturalize-gen nil :type (or null function)) (deport-gen nil :type (or null function)) ;; Cast? @@ -646,8 +649,26 @@ #-amd64 (def-alien-type-method (integer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) + ;; Mask out any unwanted bits. Important if the C code returns + ;; values in %al, or %ax + (if (alien-integer-type-signed type) + (let ((val (gensym "VAL-"))) + (case (alien-integer-type-bits type) + ;; First, get just the low part of the alien and then + ;; sign-extend it appropriately. + (8 `(let ((,val (ldb (byte 8 0) ,alien))) + (if (> ,val #x7f) + (- ,val #x100) + ,val))) + (16 `(let ((,val (ldb (byte 16 0) ,alien))) + (if (> ,val #x7fff) + (- ,val #x10000) + ,val))) + (t alien))) + (case (alien-integer-type-bits type) + (8 `(ldb (byte 8 0) (truly-the (unsigned-byte 32) ,alien))) + (16 `(ldb (byte 16 0) (truly-the (unsigned-byte 32) ,alien))) + (t alien)))) ;; signed numbers <= 32 bits need to be sign extended. ;; I really should use the movsxd instruction, but I don't @@ -694,8 +715,8 @@ (def-alien-type-class (boolean :include integer :include-args (signed))) -(def-alien-type-translator boolean (&optional (bits vm:word-bits)) - (make-alien-boolean-type :bits bits :signed nil)) +(def-alien-type-translator boolean (&optional (bits 8)) + (make-alien-boolean-type :bits bits :signed t)) (def-alien-type-method (boolean :unparse) (type) `(boolean ,(alien-boolean-type-bits type))) @@ -705,8 +726,10 @@ `(member t nil)) (def-alien-type-method (boolean :naturalize-gen) (type alien) - (declare (ignore type)) - `(not (zerop ,alien))) + ;; Mask out any unwanted bits. Important if the C code returns + ;; values in %al, or %ax + `(not (zerop (ldb (byte ,(alien-boolean-type-bits type) 0) + ,alien)))) (def-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type)) ===================================== src/code/extfmts.lisp ===================================== @@ -461,15 +461,18 @@ (format t "~&~A~%" (intl:gettext (or (ef-documentation ef) ""))))))))) +(defconstant +builtin-external-formats+ '(:utf-8 :iso8859-1 :ascii) + "List of external formats that are builtin so that they don't need to + be loaded on first use.") + (defun %find-external-format (name) ;; avoid loading files, etc., early in the boot sequence - (when (or (eq name :iso8859-1) - (and (eq name :default) (eq *default-external-format* :iso8859-1))) - (return-from %find-external-format - (gethash :iso8859-1 *external-formats*))) - (when (eq name :utf-8) + (when (and (eq name :default) + (eq *default-external-format* :iso8859-1)) + (setf name :iso8859-1)) + (when (member name +builtin-external-formats+ :test 'eq) (return-from %find-external-format - (gethash :utf-8 *external-formats*))) + (gethash name *external-formats*))) (when (zerop (hash-table-count *external-format-aliases*)) (setf (gethash :latin1 *external-format-aliases*) :iso8859-1) @@ -1188,6 +1191,8 @@ character and illegal outputs are replaced by a question mark.") ,(subst (ef-name ef) ef (function-lambda-expression (aref (ef-cache ef) slot)))))) +;;; Builtin external formats. + ;; A safe UTF-8 external format. Any illegal UTF-8 sequences on input ;; are replaced with the Unicode REPLACEMENT CHARACTER (U+FFFD), or ;; signals an error as appropriate. @@ -1303,3 +1308,29 @@ replacement character.") ((< ,code #x10000) (utf8 ,code 2)) ((< ,code #x110000) (utf8 ,code 3)) (t (error "How did this happen? Codepoint U+~X is illegal" ,code)))))) + +(define-external-format :ascii (:size 1 :documentation +"US ASCII 7-bit encoding. Illegal input sequences are replaced with +the Unicode replacment character. Illegal output characters are +replaced with a question mark.") + () + (octets-to-code (state input unput error c) + `(let ((,c ,input)) + (values (if (< ,c #x80) + ,c + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Invalid octet #x~4,'0X for ASCII" ,c 1)) + +replacement-character-code+)) + 1))) + (code-to-octets (code state output error) + `(,output (if (> ,code #x7F) + (if ,error + (locally + ;; No warnings about fdefinition + (declare (optimize (ext:inhibit-warnings 3))) + (funcall ,error "Cannot output codepoint #x~X to ASCII stream" ,code)) + #x3F) + ,code)))) ===================================== src/code/fd-stream-comp.lisp ===================================== @@ -28,6 +28,7 @@ (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-de+) (stream::precompile-ef-slot :iso8859-1 #.stream::+ef-osc+) +;; :utf-8 is builtin. Important since it's the default now. (stream::precompile-ef-slot :utf-8 #.stream::+ef-cin+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-cout+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-sout+) @@ -36,3 +37,13 @@ (stream::precompile-ef-slot :utf-8 #.stream::+ef-en+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-de+) (stream::precompile-ef-slot :utf-8 #.stream::+ef-osc+) + +;; :ascii is builtin. +(stream::precompile-ef-slot :ascii #.stream::+ef-cin+) +(stream::precompile-ef-slot :ascii #.stream::+ef-cout+) +(stream::precompile-ef-slot :ascii #.stream::+ef-sout+) +(stream::precompile-ef-slot :ascii #.stream::+ef-os+) +(stream::precompile-ef-slot :ascii #.stream::+ef-so+) +(stream::precompile-ef-slot :ascii #.stream::+ef-en+) +(stream::precompile-ef-slot :ascii #.stream::+ef-de+) +(stream::precompile-ef-slot :ascii #.stream::+ef-osc+) ===================================== src/code/list.lisp ===================================== @@ -748,64 +748,30 @@ (defparameter *min-list-length-for-hashtable* 15) -(defun init-hashtable-list1 (list1 len &key key test) - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list1) - (push item (gethash (apply-key key item) hashtable))) - (values hashtable list1))) - -(defun init-hashtable-list2 (list2 len &key key test) - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list2) - (setf (gethash (apply-key key item) hashtable) item)) - (values hashtable list2))) - -;; Convert a list to a hashtable. Given 2 lists, find the shorter of -;; the two lists and add the shorter list to a hashtable. Returns the -;; hashtable and the shorter list. -(defun list-to-hashtable (list1 list2 &key test test-not key) +;; 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 key) ;; 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) (fboundp test)) (fdefinition test) test))) - (cond ((eql test-fn #'eq) 'eq) - ((eql test-fn #'eql) 'eql) - ((eql test-fn #'equal) 'equal) - ((eql test-fn #'equalp) 'equalp))))) + (case test-fn + (#'eq 'eq) + (#'eql 'eql) + (#'equal 'equal) + (#'equalp 'equalp))))) (unless hash-test - (return-from list-to-hashtable (values nil nil))) - (multiple-value-bind (len shorter-list) - ;; Find the list with the shorter length. If they're they - ;; same, we prefer the second list to the first list since - ;; the hashtable implementation is slightly simplier. - (do ((length 0 (1+ length)) - (l1 list1 (cdr l1)) - (l2 list2 (cdr l2))) - ((cond ((endp l2) - (return (values length list2))) - #+nil - ((endp l1) - (return (values length list1)))))) - ;; If the list is too short, the hashtable makes things - ;; slower. We also need to balance memory usage. - (when (< len *min-list-length-for-hashtable*) - (return-from list-to-hashtable (values nil nil))) - (cond ((eq shorter-list list2) - #+nil - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list2) - (setf (gethash (apply-key key item) hashtable) item)) - (values hashtable list2)) - (init-hashtable-list2 list2 len :key key :test test)) - ((eq shorter-list list1) - #+nil - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list1) - (push item (gethash (apply-key key item) hashtable))) - (values hashtable list1)) - (init-hashtable-list1 list1 len :key key :test test))))))) + (return-from list-to-hashtable nil)) + ;; If the list is too short, the hashtable makes things + ;; slower. We also need to balance memory usage. + (when (< (length list) *min-list-length-for-hashtable*) + (return-from list-to-hashtable nil)) + (let ((hashtable (make-hash-table :test test :size len))) + (dolist (item list) + (setf (gethash (apply-key key item) hashtable) item)) + hashtable)))) ;;; UNION -- Public. ;;; @@ -874,24 +840,6 @@ (setq list1 (Cdr list1)))) res)) -(defun set-diff-hash2 (list1 hashtable &key key) - (let (diff) - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item diff))) - diff)) - -(defun set-diff-hash1 (list2 hashtable &key key) - (dolist (item list2) - (unless (eq hashtable (gethash (apply-key key item) hashtable hashtable)) - (remhash item hashtable))) - (let ((result '())) - (maphash #'(lambda (key value) - (declare (ignore key)) - (setq result (nconc result value))) - hashtable) - result)) - (defun set-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) "Returns the elements of list1 which are not in list2." (declare (inline member)) @@ -901,40 +849,23 @@ (when (null list2) (return-from set-difference list1)) - (multiple-value-bind (hashtable shorter-list) - (list-to-hashtable list1 list2 :key key :test test :test-not test-not) - (cond ((null hashtable) + (let ((hashtable + (list-to-hashtable list2 :key key :test test :test-not test-not))) + (cond (hashtable + ;; list2 was placed in hash table. + (let (diff) + (dolist (item list1) + (unless (nth-value 1 (gethash (apply-key key item) hashtable)) + (push item diff))) + diff)) + ((null hashtable) ;; Default implementation because we didn't create the hash ;; table. (let ((res nil)) (dolist (elt list1) (if (not (with-set-keys (member (apply-key key elt) list2))) (push elt res))) - res)) - ((eq shorter-list list2) - ;; list2 was placed in hash table. - #+nil - (let (diff) - (dolist (item list1) - (unless (nth-value 1 (gethash (apply-key key item) hashtable)) - (push item diff))) - diff) - (set-diff-hash2 list1 hashtable :key key)) - ((eq shorter-list list1) - ;; list1 was placed in the hash table. - #+nil - (dolist (item list2) - (unless (eq hashtable (gethash (apply-key key item) hashtable hashtable)) - (remhash item hashtable))) - #+nil - (let ((result '())) - (maphash #'(lambda (key value) - (declare (ignore key)) - (setq result (nconc result value))) - hashtable) - result) - (set-diff-hash1 list2 hashtable :key key))))) - + res))))) (defun nset-difference (list1 list2 &key key (test #'eql testp) (test-not nil notp)) ===================================== src/code/pathname.lisp ===================================== @@ -121,58 +121,73 @@ (defun %print-pathname (pathname stream depth) (declare (ignore depth)) (let* ((host (%pathname-host pathname)) + (device (%pathname-device pathname)) + (directory (%pathname-directory pathname)) + (name (%pathname-name pathname)) + (type (%pathname-type pathname)) + (version (%pathname-version pathname)) + (unspecific-p (or (eq device :unspecific) + (eq name :unspecific) + (eq type :unspecific) + (eq version :unspecific))) (namestring (if host (handler-case (namestring pathname) (error nil)) nil))) - (cond (namestring + ;; A pathname with :UNSPECIFIC components has a namestring that + ;; ignores :UNSPECIFIC (and NIL). Thus the namestring exists, but + ;; we want to use our special syntax to print the pathname + ;; readably when :UNSPECIFIC occurs. + (cond ((and namestring (not unspecific-p)) (if (or *print-escape* *print-readably*) (format stream "#P~S" namestring) (format stream "~A" namestring))) (t - (let ((device (%pathname-device pathname)) - (directory (%pathname-directory pathname)) - (name (%pathname-name pathname)) - (type (%pathname-type pathname)) - (version (%pathname-version pathname))) - (cond ((every #'(lambda (d) - (or (stringp d) - (symbolp d))) - (cdr directory)) - ;; A CMUCL extension. If we have an unprintable - ;; pathname, convert it to a form that would be - ;; suitable as args to MAKE-PATHNAME to recreate - ;; the pathname. - ;; - ;; We don't handle search-lists because we don't - ;; currently have a readable syntax for - ;; search-lists. - (collect ((result)) - (unless (eq host *unix-host*) - (result :host) - (result (if host - (pathname-host pathname) - nil))) - (when device - (result :device) - (result device)) - (when directory - (result :directory) - (result directory)) - (when name - (result :name) - (result name)) - (when type - (result :type) - (result type)) - (when version - (result :version) - (result version)) - (format stream "#P~S" (result)))) - (*print-readably* - (error 'print-not-readable :object pathname)) - (t - (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~ + (cond ((and + ;; We only use the extension if the pathname does + ;; not contain a pattern object which doesn't print + ;; readably. Search-lists, which are part of the + ;; directory component, are excluded too. + (not (typep name 'pattern)) + (not (typep type 'pattern)) + (every #'(lambda (d) + (or (stringp d) + (symbolp d))) + (cdr directory))) + ;; A CMUCL extension. If we have an unprintable + ;; pathname, convert it to a form that would be + ;; suitable as args to MAKE-PATHNAME to recreate + ;; the pathname. + ;; + ;; We don't handle search-lists because we don't + ;; currently have a readable syntax for + ;; search-lists. + (collect ((result)) + (unless (eq host *unix-host*) + (result :host) + (result (if host + (pathname-host pathname) + nil))) + (when device + (result :device) + (result device)) + (when directory + (result :directory) + (result directory)) + (when name + (result :name) + (result name)) + (when type + (result :type) + (result type)) + (when version + (result :version) + (result version)) + (format stream "#P~S" (result)))) + (*print-readably* + (error 'print-not-readable :object pathname)) + (t + (funcall (formatter "#<Unprintable pathname,~:_ Host=~S,~:_ Device=~S,~:_ ~ Directory=~S,~:_ Name=~S,~:_ Type=~S,~:_ Version=~S>") stream (%pathname-host pathname) ===================================== src/code/pred.lisp ===================================== @@ -387,8 +387,8 @@ (defun equal (x y) "Returns T if X and Y are EQL or if they are structured components whose elements are EQUAL. Strings and bit-vectors are EQUAL if they - are the same length and have indentical components. Other arrays must be - EQ to be EQUAL." + are the same length and have identical components. Other arrays + must be EQ to be EQUAL." (cond ((eql x y) t) ((consp x) (and (consp y) ===================================== src/compiler/x86/c-call.lisp ===================================== @@ -141,59 +141,77 @@ (alien-function-type-result-type type) (make-result-state)))))) -(deftransform %alien-funcall ((function type &rest args)) - (assert (c::constant-continuation-p type)) +(defun %alien-funcall-aux (function type &rest args) + (declare (ignorable function type args)) (let* ((type (c::continuation-value type)) (arg-types (alien-function-type-arg-types type)) (result-type (alien-function-type-result-type type))) (assert (= (length arg-types) (length args))) - (if (or (some #'(lambda (type) - (and (alien-integer-type-p type) - (> (alien::alien-integer-type-bits type) 32))) - arg-types) - (and (alien-integer-type-p result-type) - (> (alien::alien-integer-type-bits result-type) 32))) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (cond ((and (alien-integer-type-p type) - (> (alien::alien-integer-type-bits type) 32)) - (new-args `(logand ,arg #xffffffff)) - (new-args `(ash ,arg -32)) - (new-arg-types (parse-alien-type '(unsigned 32))) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32))) - (new-arg-types (parse-alien-type '(unsigned 32))))) - (t - (new-args arg) - (new-arg-types type))))) - (cond ((and (alien-integer-type-p result-type) - (> (alien::alien-integer-type-bits result-type) 32)) - (let ((new-result-type - (let ((alien::*values-type-okay* t)) - (parse-alien-type - (if (alien-integer-type-signed result-type) - '(values (unsigned 32) (signed 32)) - '(values (unsigned 32) (unsigned 32))))))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind (low high) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type new-result-type) - ,@(new-args)) - (logior low (ash high 32)))))) + (unless (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (/= (alien::alien-integer-type-bits result-type) 32))) + (c::give-up)) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32)) + (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (new-arg-types (parse-alien-type '(unsigned 32))) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))))) (t - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))))) - (c::give-up)))) + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (< (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(signed 32) + '(unsigned 32))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args))))) + ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (low high) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))))) + +(deftransform %alien-funcall ((function type &rest args)) + (assert (c::constant-continuation-p type)) + (apply #'%alien-funcall-aux function type args)) (define-vop (foreign-symbol-code-address) (:translate #+linkage-table foreign-symbol-code-address ===================================== src/compiler/x86/insts.lisp ===================================== @@ -744,7 +744,12 @@ ;; set by a prefix instruction (or (disassem:dstate-get-prop dstate 'word-width) *default-operand-size*))) - (princ (schar (symbol-name word-width) 0) stream))))) + ;; Make sure the print case is honored when + ;; printing out the width. + (princ (ecase word-width + (:word 'w) + (:dword 'd)) + stream))))) ;;;; Disassembler instruction formats. ===================================== src/general-info/release-21f.md ===================================== @@ -23,6 +23,9 @@ public domain. * Bug fixes: * Gitlab tickets: * ~~#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 + * ~~#248~~ Print MOVS instruction with correct case * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1593,8 +1593,8 @@ msgstr "" msgid "" "Returns T if X and Y are EQL or if they are structured components\n" " whose elements are EQUAL. Strings and bit-vectors are EQUAL if they\n" -" are the same length and have indentical components. Other arrays must be\n" -" EQ to be EQUAL." +" are the same length and have identical components. Other arrays\n" +" must be EQ to be EQUAL." msgstr "" #: src/code/pred.lisp @@ -9148,6 +9148,12 @@ msgstr "" msgid "~&Could not find external format ~S~%" msgstr "" +#: src/code/extfmts.lisp +msgid "" +"List of external formats that are builtin so that they don't need to\n" +" be loaded on first use." +msgstr "" + #: src/code/extfmts.lisp msgid "External-format aliasing depth exceeded." msgstr "" @@ -9288,6 +9294,13 @@ msgid "" "replacement character." msgstr "" +#: src/code/extfmts.lisp +msgid "" +"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" +"the Unicode replacment character. Illegal output characters are\n" +"replaced with a question mark." +msgstr "" + #: src/code/fd-stream.lisp msgid "" "List of available buffers. Each buffer is an sap pointing to\n" @@ -21325,12 +21338,6 @@ msgstr "" msgid " Gray Streams Protocol Support" msgstr "" -msgid "" -"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" -"the Unicode replacment character. Illegal output characters are\n" -"replaced with a question mark." -msgstr "" - msgid "" "MAC-ROMAN is an 8-bit character encoding for Western European\n" "languages including English.\n" ===================================== tests/issues.lisp ===================================== @@ -997,3 +997,111 @@ ;; This is the condition from the CLHS entry for enough-namestring (assert-equal (merge-pathnames enough defaults) (merge-pathnames (parse-namestring pathname nil defaults) defaults)))))) + +(define-test issue.242-load-foreign + ;; load-foreign apparently returns NIL if it succeeds. + (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*))))) + +(alien:def-alien-variable "test_arg" c-call:int) + +(define-test issue.242.test-alien-return-signed-char + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_signed_char" + (function c-call:char)))) + (sign-extend (n) + (let ((n (ldb (byte 8 0) n))) + (if (> n #x7f) + (- n #x100) + n)))) + (dolist (x '(99 -99 1023 -1023)) + (assert-equal (sign-extend x) (fun x) x)))) + +(define-test issue.242.test-alien-return-signed-short + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_short" + (function c-call:short)))) + (sign-extend (n) + (let ((n (ldb (byte 16 0) n))) + (if (> n #x7fff) + (- n #x10000) + n)))) + (dolist (x '(1023 -1023 100000 -100000)) + (assert-equal (sign-extend x) (fun x) x)))) + +(define-test issue.242.test-alien-return-signed-int + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_int" + (function c-call:int))))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal x (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-char + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_char" + (function c-call:unsigned-char)))) + (expected (n) + (ldb (byte 8 0) n))) + (dolist (x '(99 -99 1023 -1023)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-short + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_short" + (function c-call:unsigned-short)))) + (expected (n) + (ldb (byte 16 0) n))) + (dolist (x '(1023 -1023 100000 -100000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-int + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_int" + (function c-call:unsigned-int)))) + (expected (n) + (ldb (byte 32 0) n))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-bool + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_bool" + (function c-call:char)))) + (expected (n) + (if (zerop n) + 0 + 1))) + (dolist (x '(0 1 1000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-bool.2 + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_bool" + (function alien:boolean)))) + (expected (n) + (not (zerop n)))) + (dolist (x '(0 1 1000)) + (assert-equal (expected x) (fun x) x)))) ===================================== tests/pathname.lisp ===================================== @@ -83,3 +83,31 @@ and type = (pathname-type f) do (assert-true (and (null name) (null type)) f)))) + + + +;; Test that pathnames with :unspecific components are printed using +;; our extension to make :unspecific explicit. +(define-test issue.171.unspecific + (:tag :issues) + (flet ((output (path) + (with-output-to-string (s) + (write path :stream s)))) + (dolist (test + (list + (list (make-pathname :name "foo" :type :unspecific) + "#P(:NAME \"foo\" :TYPE :UNSPECIFIC)" + "foo") + (list (make-pathname :name :unspecific :type "foo") + "#P(:NAME :UNSPECIFIC :TYPE \"foo\")" + ".foo") + (list (make-pathname :name "foo" :type "txt" :version :unspecific) + "#P(:NAME \"foo\" :TYPE \"txt\" :VERSION :UNSPECIFIC)" + "foo.txt") + (list (make-pathname :device :unspecific) + "#P(:DEVICE :UNSPECIFIC)" + ""))) + (destructuring-bind (pathname printed-value namestring) + test + (assert-equal printed-value (output pathname)) + (assert-equal namestring (namestring pathname)))))) ===================================== tests/test-return.c ===================================== @@ -0,0 +1,45 @@ +#include <stdbool.h> + +int test_arg; + +signed char +int_to_signed_char() +{ + return (signed char) test_arg; +} + +short +int_to_short() +{ + return (short) test_arg; +} + +int +int_to_int() +{ + return (int) test_arg; +} + +unsigned char +int_to_unsigned_char() +{ + return (unsigned char) test_arg; +} + +unsigned short +int_to_unsigned_short() +{ + return (unsigned short) test_arg; +} + +unsigned int +int_to_unsigned_int() +{ + return (unsigned int) test_arg; +} + +_Bool int_to_bool() +{ + return (_Bool) test_arg; +} + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2e46d4581f00c9d3a1df8b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2e46d4581f00c9d3a1df8b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #244: Add c-call:signed-char
by Raymond Toy (＠rtoy) 23 Jul '23

23 Jul '23

Raymond Toy pushed to branch master 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 - - - - - 2 changed files: - src/code/c-call.lisp - src/general-info/release-21f.md Changes: ===================================== 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/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: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5c232939ef12742a7e661… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5c232939ef12742a7e661… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-244-c-call-signed-char] 3 commits: Update release notes with closed issues
by Raymond Toy (＠rtoy) 23 Jul '23

23 Jul '23

Raymond Toy pushed to branch issue-244-c-call-signed-char at cmucl / cmucl Commits: a85ad7cf by Raymond Toy at 2023-07-23T12:18:48-07:00 Update release notes with closed issues Should have been updated when the issue was closed, but we forgot. Update now. - - - - - d5c23293 by Raymond Toy at 2023-07-23T15:07:27-07:00 Update cmucl.pot Forgot to update cmucl.pot in previous commits/merges that changed docstrings for various things. Update it now. - - - - - 8b5c27cd by Raymond Toy at 2023-07-23T15:09:59-07:00 Merge branch 'master' into issue-244-c-call-signed-char - - - - - 2 changed files: - src/general-info/release-21f.md - src/i18n/locale/cmucl.pot Changes: ===================================== src/general-info/release-21f.md ===================================== @@ -23,8 +23,10 @@ public domain. * Bug fixes: * Gitlab tickets: * ~~#154~~ piglatin translation does not work anymore - * ~~#248~~ Print `MOVS` instruction with correct case + * ~~#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: * Changes to building procedure: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1593,8 +1593,8 @@ msgstr "" msgid "" "Returns T if X and Y are EQL or if they are structured components\n" " whose elements are EQUAL. Strings and bit-vectors are EQUAL if they\n" -" are the same length and have indentical components. Other arrays must be\n" -" EQ to be EQUAL." +" are the same length and have identical components. Other arrays\n" +" must be EQ to be EQUAL." msgstr "" #: src/code/pred.lisp @@ -9148,6 +9148,12 @@ msgstr "" msgid "~&Could not find external format ~S~%" msgstr "" +#: src/code/extfmts.lisp +msgid "" +"List of external formats that are builtin so that they don't need to\n" +" be loaded on first use." +msgstr "" + #: src/code/extfmts.lisp msgid "External-format aliasing depth exceeded." msgstr "" @@ -9288,6 +9294,13 @@ msgid "" "replacement character." msgstr "" +#: src/code/extfmts.lisp +msgid "" +"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" +"the Unicode replacment character. Illegal output characters are\n" +"replaced with a question mark." +msgstr "" + #: src/code/fd-stream.lisp msgid "" "List of available buffers. Each buffer is an sap pointing to\n" @@ -21325,12 +21338,6 @@ msgstr "" msgid " Gray Streams Protocol Support" msgstr "" -msgid "" -"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" -"the Unicode replacment character. Illegal output characters are\n" -"replaced with a question mark." -msgstr "" - msgid "" "MAC-ROMAN is an 8-bit character encoding for Western European\n" "languages including English.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f348f645dc3dd3e80f722f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/f348f645dc3dd3e80f722f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update cmucl.pot
by Raymond Toy (＠rtoy) 23 Jul '23

23 Jul '23

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d5c23293 by Raymond Toy at 2023-07-23T15:07:27-07:00 Update cmucl.pot Forgot to update cmucl.pot in previous commits/merges that changed docstrings for various things. Update it now. - - - - - 1 changed file: - src/i18n/locale/cmucl.pot Changes: ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -1593,8 +1593,8 @@ msgstr "" msgid "" "Returns T if X and Y are EQL or if they are structured components\n" " whose elements are EQUAL. Strings and bit-vectors are EQUAL if they\n" -" are the same length and have indentical components. Other arrays must be\n" -" EQ to be EQUAL." +" are the same length and have identical components. Other arrays\n" +" must be EQ to be EQUAL." msgstr "" #: src/code/pred.lisp @@ -9148,6 +9148,12 @@ msgstr "" msgid "~&Could not find external format ~S~%" msgstr "" +#: src/code/extfmts.lisp +msgid "" +"List of external formats that are builtin so that they don't need to\n" +" be loaded on first use." +msgstr "" + #: src/code/extfmts.lisp msgid "External-format aliasing depth exceeded." msgstr "" @@ -9288,6 +9294,13 @@ msgid "" "replacement character." msgstr "" +#: src/code/extfmts.lisp +msgid "" +"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" +"the Unicode replacment character. Illegal output characters are\n" +"replaced with a question mark." +msgstr "" + #: src/code/fd-stream.lisp msgid "" "List of available buffers. Each buffer is an sap pointing to\n" @@ -21325,12 +21338,6 @@ msgstr "" msgid " Gray Streams Protocol Support" msgstr "" -msgid "" -"US ASCII 7-bit encoding. Illegal input sequences are replaced with\n" -"the Unicode replacment character. Illegal output characters are\n" -"replaced with a question mark." -msgstr "" - msgid "" "MAC-ROMAN is an 8-bit character encoding for Western European\n" "languages including English.\n" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5c232939ef12742a7e6611… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5c232939ef12742a7e6611… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0