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

[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] Remove unused function testing alien funcalls
by Raymond Toy (＠rtoy) 16 Jun '23

16 Jun '23

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: a7a7029b by Raymond Toy at 2023-06-16T06:41:00-07:00 Remove unused function testing alien funcalls In restructuring the tests, I forgot to remove a function for testing alien funcalls. Remove it now. - - - - - 1 changed file: - tests/issues.lisp Changes: ===================================== tests/issues.lisp ===================================== @@ -991,12 +991,6 @@ ;; load-foreign apparently returns NIL if it succeeds. (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*))))) -(defun return-unsigned-int (x) - ((alien:alien-funcall - (alien:extern-alien "int_to_unsigned_int" - (function c-call:unsigned-int c-call:unsigned-int)) - n))) - (define-test issue.242.test-alien-return-signed-char (:tag :issues) (flet ((fun (n) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a7a7029baf371e6c0f6f623… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/a7a7029baf371e6c0f6f623… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] Remove debugging stuff and add comment
by Raymond Toy (＠rtoy) 16 Jun '23

16 Jun '23

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: 3107832c by Raymond Toy at 2023-06-16T06:38:26-07:00 Remove debugging stuff and add comment - - - - - 1 changed file: - bin/run-tests.sh Changes: ===================================== bin/run-tests.sh ===================================== @@ -47,8 +47,9 @@ function cleanup { trap cleanup EXIT -echo $PWD -ls tests/*.c +# 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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3107832c9f11f35abc93903… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/3107832c9f11f35abc93903… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] 2 commits: Add tests for unsigned return types
by Raymond Toy (＠rtoy) 16 Jun '23

16 Jun '23

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: d7f0d936 by Raymond Toy at 2023-06-16T06:29:46-07:00 Add tests for unsigned return types - - - - - 10a18a52 by Raymond Toy at 2023-06-16T06:35:11-07:00 Add comment on what :naturalize-gen method does Since I can never remember, add a comment for what the `:naturalize-gen` alien method is for. - - - - - 2 changed files: - src/code/alieneval.lisp - tests/issues.lisp Changes: ===================================== src/code/alieneval.lisp ===================================== @@ -170,7 +170,10 @@ (alien-rep nil :type (or null function)) (extract-gen nil :type (or null function)) (deposit-gen nil :type (or null function)) - (naturalize-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? (arg-tn nil :type (or null function)) ===================================== tests/issues.lisp ===================================== @@ -1036,3 +1036,39 @@ n))) (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) (assert-equal x (fun x))))) + +(define-test issue.242.test-alien-return-unsigned-char + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_char" + (function c-call:unsigned-char c-call:int)) + n)) + (expected (n) + (ldb (byte 8 0) n))) + (dolist (x '(99 -99 1023 -1023)) + (assert-equal (expected x) (fun x))))) + +(define-test issue.242.test-alien-return-unsigned-short + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_short" + (function c-call:unsigned-short c-call:int)) + n)) + (expected (n) + (ldb (byte 16 0) n))) + (dolist (x '(1023 -1023 100000 -100000)) + (assert-equal (expected x) (fun x))))) + +(define-test issue.242.test-alien-return-unsigned-int + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_int" + (function c-call:unsigned-int c-call:int)) + n)) + (expected (n) + (ldb (byte 32 0) n))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal (expected x) (fun x))))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2cc3c60e2692a1709fcf48… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/2cc3c60e2692a1709fcf48… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] 2 commits: Fix bug in sign-extension.
by Raymond Toy (＠rtoy) 16 Jun '23

16 Jun '23

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: de5d0be0 by Raymond Toy at 2023-06-15T20:54:26-07:00 Fix bug in sign-extension. Stupidly forgot to handle the case where the value is positive. We accidentally returned nil. - - - - - 2cc3c60e by Raymond Toy at 2023-06-15T20:58:27-07:00 Add tests for different foreign integer return types Add a C file, test-return.c, that has functions that return different length integer types. Compile it in run-tests.sh so that the tests can load it. Add tests that we get the right values from the functions. Only the signed integer types are tested right now. We need to add the unsigned tests. - - - - - 4 changed files: - bin/run-tests.sh - src/code/alieneval.lisp - tests/issues.lisp - + tests/test-return.c Changes: ===================================== bin/run-tests.sh ===================================== @@ -47,6 +47,10 @@ function cleanup { trap cleanup EXIT +echo $PWD +ls tests/*.c +(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 ===================================== @@ -649,16 +649,19 @@ ;; Mask out any unwanted bits. Important if the C code returns ;; values in %al, or %ax (if (alien-integer-type-signed type) - (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)))) - (16 `(let ((val (ldb (byte 16 0) ,alien))) - (if (> val #x7fff) - (- val #x10000)))) - (t alien)) + (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) ,alien)) (16 `(ldb (byte 16 0) ,alien)) ===================================== tests/issues.lisp ===================================== @@ -986,3 +986,53 @@ ;; 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*))))) + +(defun return-unsigned-int (x) + ((alien:alien-funcall + (alien:extern-alien "int_to_unsigned_int" + (function c-call:unsigned-int c-call:unsigned-int)) + n))) + +(define-test issue.242.test-alien-return-signed-char + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_signed_char" + (function c-call:char c-call:int)) + n)) + (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))))) + +(define-test issue.242.test-alien-return-signed-short + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_short" + (function c-call:short c-call:int)) + n)) + (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))))) + +(define-test issue.242.test-alien-return-signed-int + (:tag :issues) + (flet ((fun (n) + (alien:alien-funcall + (alien:extern-alien "int_to_int" + (function c-call:int c-call:int)) + n))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal x (fun x))))) ===================================== tests/test-return.c ===================================== @@ -0,0 +1,36 @@ +signed char +int_to_signed_char(int x) +{ + return (signed char) x; +} + +signed short +int_to_short(int x) +{ + return (signed short) x; +} + +int +int_to_int(int x) +{ + return (int) x; +} + +unsigned char +int_to_unsigned_char(int x) +{ + return (signed char) x; +} + +unsigned short +int_to_unsigned_short(int x) +{ + return (signed short) x; +} + +unsigned int +int_to_unsigned_int(int x) +{ + return (int) x; +} + View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5391d9a0e25c687937e86… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/d5391d9a0e25c687937e86… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] Handle the signed integer case for alien integers
by Raymond Toy (＠rtoy) 15 Jun '23

15 Jun '23

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: d5391d9a by Raymond Toy at 2023-06-15T15:53:13-07:00 Handle the signed integer case for alien integers Mask out integer bits that we don't care about, and then sign-extend the result, as needed. - - - - - 1 changed file: - src/code/alieneval.lisp Changes: ===================================== src/code/alieneval.lisp ===================================== @@ -648,10 +648,21 @@ (def-alien-type-method (integer :naturalize-gen) (type alien) ;; Mask out any unwanted bits. Important if the C code returns ;; values in %al, or %ax - (case (alien-integer-type-bits type) - (8 `(ldb (byte 8 0) ,alien)) - (16 `(ldb (byte 16 0) ,alien)) - (t alien))) + (if (alien-integer-type-signed type) + (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)))) + (16 `(let ((val (ldb (byte 16 0) ,alien))) + (if (> val #x7fff) + (- val #x10000)))) + (t alien)) + (case (alien-integer-type-bits type) + (8 `(ldb (byte 8 0) ,alien)) + (16 `(ldb (byte 16 0) ,alien)) + (t alien)))) ;; signed numbers <= 32 bits need to be sign extended. ;; I really should use the movsxd instruction, but I don't View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5391d9a0e25c687937e86f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/d5391d9a0e25c687937e86f… 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: Make hashtable support multiset for list1
by Raymond Toy (＠rtoy) 15 Jun '23

15 Jun '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 42fd6d23 by Raymond Toy at 2023-06-15T15:23:03-07:00 Make hashtable support multiset for list1 It's important that for list1 the hashtable support multisets since list1 can be. This is needed so duplicates in list1 show up in the output. This variant was from @cshapiro. - - - - - 85c8c1df by Raymond Toy at 2023-06-15T15:26:43-07:00 Reverse the output Reverse the output for the case when list1 is longer so that the order of the items matches the order of the input. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -770,15 +770,16 @@ (return (values length list2)))))) (when (< len 15) (return-from list-to-hashtable (values nil nil))) - (flet ((build-hash (len list) - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list) - (setf (gethash (apply-key key item) hashtable) item)) - hashtable))) - (cond ((eq shorter-list list2) - (values (build-hash len list2) list2)) - ((eq shorter-list list1) - (values (build-hash len list1) list1)))))))) + (cond ((eq shorter-list list2) + (let ((hashtable (make-hash-table :test test :size len))) + (dolist (item list2) + (setf (gethash (apply-key key item) hashtable) item)) + (values hashtable list2))) + ((eq shorter-list list1) + (let ((hashtable (make-hash-table :test test :size len))) + (dolist (item list1) + (push item (gethash (apply-key key item) hashtable))) + (values hashtable list1)))))))) ;;; UNION -- Public. ;;; @@ -870,14 +871,17 @@ (dolist (item list1) (unless (gethash (apply-key key item) hashtable) (push item diff))) - diff)) + (nreverse diff))) ((eq shorter-list list1) ;; list1 was placed in the hash table. (dolist (item list2) - (when (gethash (apply-key key item) hashtable) + (unless (eq hashtable (gethash (apply-key key item) hashtable hashtable)) (remhash item hashtable))) - (loop for item being the hash-values of hashtable - collect item))))) + (let ((result '())) + (maphash #'(lambda (key value) + (declare (ignore key)) + (setq result (nconc result value))) + hashtable)))))) (defun nset-difference (list1 list2 &key key View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5e47bcfc5129d5d7b47b11… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/5e47bcfc5129d5d7b47b11… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-242-c-call-char-result-wrong
by Raymond Toy (＠rtoy) 15 Jun '23

15 Jun '23

Raymond Toy pushed new branch issue-242-c-call-char-result-wrong at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-242-c-call-char-res… 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] Refactoring of list to hashtable to its own function
by Raymond Toy (＠rtoy) 14 Jun '23

14 Jun '23

Raymond Toy pushed to branch issue-240-set-diff-with-hash-table at cmucl / cmucl Commits: 5e47bcfc by Raymond Toy at 2023-06-14T09:08:48-07:00 Refactoring of list to hashtable to its own function Move the code for converting a list to a hash table to its own function. Also support using a key function. Update set-difference to use this new function. - - - - - 1 changed file: - src/code/list.lisp Changes: ===================================== src/code/list.lisp ===================================== @@ -745,6 +745,41 @@ (cons item list))) +;; Convert a list to a hashtable. Given 2 lists, find the shorter of +;; the two lists and add the shorter list to a hashtable. +(defun list-to-hashtable (list1 list2 &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))))) + (unless hash-test + (return-from list-to-hashtable (values nil nil))) + (multiple-value-bind (len shorter-list) + (do ((length 0 (1+ length)) + (l1 list1 (cdr l1)) + (l2 list2 (cdr l2))) + ((cond ((null l1) + (return (values length list1))) + ((null l2) + (return (values length list2)))))) + (when (< len 15) + (return-from list-to-hashtable (values nil nil))) + (flet ((build-hash (len list) + (let ((hashtable (make-hash-table :test test :size len))) + (dolist (item list) + (setf (gethash (apply-key key item) hashtable) item)) + hashtable))) + (cond ((eq shorter-list list2) + (values (build-hash len list2) list2)) + ((eq shorter-list list1) + (values (build-hash len list1) list1)))))))) + ;;; UNION -- Public. ;;; ;;; This function assumes list2 is the result, adding to it from list1 as @@ -812,53 +847,37 @@ (setq list1 (Cdr list1)))) res)) -(defun set-difference (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) +(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)) (if (and testp notp) (error "Test and test-not both supplied.")) - (flet ((default-impl (list1 list2) - (if (null list2) + (multiple-value-bind (hashtable shorter-list) + (list-to-hashtable list1 list2 :key key :test test :test-not test-not) + (cond ((null hashtable) + ;; Default implementation because we didn't create the hash + ;; table. + (if (null list2) list1 (let ((res nil)) (dolist (elt list1) (if (not (with-set-keys (member (apply-key key elt) list2))) (push elt res))) - res)))) - (cond ((and testp (null key) - (member test (list #'eq #'eql #'equal #'equalp))) - (multiple-value-bind (len shorter-list) - (do ((length 0 (1+ length)) - (l1 list1 (cdr l1)) - (l2 list2 (cdr l2))) - ((cond ((null l1) - (return (values length list1))) - ((null l2) - (return (values length list2)))))) - (when (< len 20) - (return-from set-difference (default-impl list1 list2))) - (flet ((build-hash (len list) - (let ((hashtable (make-hash-table :test test :size len))) - (dolist (item list) - (setf (gethash item hashtable) t)) - hashtable))) - (cond ((eq shorter-list list2) - (let ((hashtable (build-hash len list2)) - diff) - (dolist (item list1) - (unless (gethash item hashtable) - (push item diff))) - diff)) - ((eq shorter-list list1) - (let ((hashtable (build-hash len list1))) - (dolist (item list2) - (when (gethash item hashtable) - (remhash item hashtable))) - (loop for item being the hash-keys of hashtable - collect item))))))) - (t - (default-impl list1 list2))))) + res))) + ((eq shorter-list list2) + ;; list2 was placed in hash table. + (let (diff) + (dolist (item list1) + (unless (gethash (apply-key key item) hashtable) + (push item diff))) + diff)) + ((eq shorter-list list1) + ;; list1 was placed in the hash table. + (dolist (item list2) + (when (gethash (apply-key key item) hashtable) + (remhash item hashtable))) + (loop for item being the hash-values of hashtable + collect item))))) (defun nset-difference (list1 list2 &key key View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5e47bcfc5129d5d7b47b110… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/5e47bcfc5129d5d7b47b110… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-240-set-diff-with-hash-table
by Raymond Toy (＠rtoy) 13 Jun '23

13 Jun '23

Raymond Toy pushed new branch issue-240-set-diff-with-hash-table at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-240-set-diff-with-h… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-154-piglatin-translation-doesnt-work-anymore] make the additional command part of a single command line invocation
by Jon Boone (＠jboone) 08 Jun '23

08 Jun '23

Jon Boone pushed to branch issue-154-piglatin-translation-doesnt-work-anymore at cmucl / cmucl Commits: 11ec47e8 by Jon Boone at 2023-06-07T22:33:48-04:00 make the additional command part of a single command line invocation - - - - - 1 changed file: - src/lisp/GNUmakefile Changes: ===================================== src/lisp/GNUmakefile ===================================== @@ -106,7 +106,7 @@ LOCALE_DIRS = $(patsubst %, i18n/locale/%/LC_MESSAGES, $(LOCALES)) # FreeBSD, it moves the line to after the Language-Team line. This # makes things messy. Hence, sort and diff. translations: - echo "making translations" + echo "making translations"; \ for pot in ../../src/i18n/locale/*.pot; do \ for po in $(LOCALE_DIRS); do \ d=`dirname $$pot`; \ View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/11ec47e882e6c08e12a47a7… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/11ec47e882e6c08e12a47a7… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0