GitLab

at 2023-06-19T14:17:30-07:00

Fix typo in docstring for EQUAL

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.

Fix #234: Make :ascii external format builtin.

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
Fix #242:  Mask out unwanted bits for integer results

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
Fix #171: Readably print pathnames with :unspecific

Merge branch 'issue-171-readable-unspecific-pathnames' into 'master'

Fix #171: Readably print pathnames with :unspecific

Closes #171

See merge request cmucl/cmucl!134
Fix #248: Disassemble MOVS inst nicely

Merge branch 'issue-248-disassemble-movs-nicely' into 'master'

Fix #248: Disassemble MOVS inst nicely

Closes #248

See merge request cmucl/cmucl!156
Remove extraneous debugging print

Introduced in commit [0a35575aa0] for debugging and we forgot to
remove it.

Update release notes with closed issues

Should have been updated when the issue was closed, but we forgot.
Update now.

Update cmucl.pot

Forgot to update cmucl.pot in previous commits/merges that changed
docstrings for various things.  Update it now.

Merge branch 'master' into issue-240-set-diff-with-hash-table

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.

       esac ;;

 esac

+export LANG=en_US.UTF-8

+

 buildit ()

 {

     if echo $INTERACTIVE_BUILD | grep $BUILD > /dev/null; then

 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)'

   (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?

 #-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

 (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)))

   `(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))

 	       (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)

 	 ,(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.

          ((< ,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))))
 (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+)

 (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+)
 (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.

 ;;;

 	  (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))

   (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))

 (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)

 (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)

 					(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

 			  ;; 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.

   * 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:

 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

 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 ""

 "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"

 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"

       ;; 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))))
 	  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))))))
+#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;

+}

+

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

Commits:

15 changed files:

Changes: