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/2e46d4581f00c9d3a1df8b3...