diff --git a/msvc/c/Makefile b/msvc/c/Makefile index e0b33570f..e4b3204c3 100755 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -20,10 +20,9 @@ THREADS_OBJ= !endif !if "$(ECL_UNICODE)" != "" -ECL_UNICODE_FLAG=21 -ECL_UCD_OBJ = ucd.obj ucd-0000.obj ucd-0016.obj \ - ucd-0032.obj ucd-0048.obj ucd-0064.obj \ - ucd-0080.obj ucd-0096.obj +ECL_UNICODE_FLAG=16 +ECL_UCD_OBJ = ucd16.obj ucd16-0000.obj ucd16-0016.obj \ + ucd16-0032.obj ucd16-0048.obj ucd16-0064.obj !else ECL_UNICODE_FLAG=0 !endif diff --git a/msvc/ecl/config-internal.h.msvc6 b/msvc/ecl/config-internal.h.msvc6 index b405393e7..438c8b30d 100644 --- a/msvc/ecl/config-internal.h.msvc6 +++ b/msvc/ecl/config-internal.h.msvc6 @@ -198,7 +198,7 @@ #endif #define strcasecmp _stricmp -#if defined(_MSC_VER) && (_MSC_VER < 1900) +#if defined(_MSC_VER) && (_MSC_VER < 1800) #define isnan _isnan #endif #define finite _finite diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index cc760a729..2ec93f60e 100755 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -155,11 +155,11 @@ typedef unsigned int cl_hashkey; * The character type */ #ifdef ECL_UNICODE -#define ECL_CHAR_CODE_LIMIT 1114112 /* unicode character code limit */ +#define ECL_CHAR_CODE_LIMIT 65536 /* unicode character code limit */ #else #define ECL_CHAR_CODE_LIMIT 256 /* unicode character code limit */ #endif -typedef int ecl_character; +typedef short ecl_character; typedef unsigned char ecl_base_char; /* @@ -210,7 +210,7 @@ typedef unsigned char ecl_base_char; /* #undef HAVE_FLOAT_COMPLEX */ /* Missing integer types */ -#if _MSC_VER < 1900 +#if _MSC_VER < 1600 typedef signed char int8_t; typedef signed short int16_t; typedef signed int int32_t; diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 7cef72ec7..559b236e6 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -90,47 +90,36 @@ ;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND ;;; -(defun expand-vector-push (whole env extend) +(defun expand-vector-push (whole env extend &aux (args (rest whole))) (declare (si::c-local)) - (let* ((args (rest whole))) - (with-clean-symbols (value vector index dimension) - (unless (or (eq (first args) 'value) ; No infinite recursion - (not (policy-open-code-aref/aset))) - (setf whole - (if (or (< (length args) 2) - (and (not extend) - (> (length args) 2)) - (and extend - (> (length args) 3))) - (progn - (cmpwarn "Wrong number of arguments passed to function ~S" - (symbol-function - (if extend - 'vector-push-extend - 'vector-push))) - `(si::simple-program-error - "Wrong number of arguments passed to function ~S" - (symbol-function - ',(if extend - 'vector-push-extend - 'vector-push)))) - `(let* ((value ,(car args)) - (vector ,(second args))) - (declare (:read-only value vector) - (optimize (safety 0))) - (optional-type-assertion vector vector) - (let ((index (fill-pointer vector)) - (dimension (array-total-size vector))) - (declare (fixnum index dimension) - (:read-only index dimension)) - (cond ((< index dimension) - (sys::fill-pointer-set vector (truly-the fixnum (+ 1 index))) - (sys::aset vector index value) - index) - (t ,(if extend - `(vector-push-extend value vector ,@(cddr args)) - nil)))))))))) - whole) + (with-clean-symbols (value vector index dimension) + (when (or (eq (first args) 'value) ; No infinite recursion + (not (policy-open-code-aref/aset))) + (return-from expand-vector-push + whole)) + (unless (<= 2 + (length args) + (if extend 3 2)) + (cmpwarn "Wrong number of arguments passed to function ~A in form: ~A" (first whole) whole) + (return-from expand-vector-push + `(si::simple-program-error + "Wrong number of arguments passed to function ~A in form: ~A" ',(first whole) ',whole))) + `(let* ((value ,(car args)) + (vector ,(second args))) + (declare (:read-only value vector) + (optimize (safety 0))) + (optional-type-assertion vector vector) + (let ((index (fill-pointer vector)) + (dimension (array-total-size vector))) + (declare (fixnum index dimension) + (:read-only index dimension)) + (cond ((< index dimension) + (sys::fill-pointer-set vector (truly-the fixnum (+ 1 index))) + (sys::aset vector index value) + index) + (t ,(if extend + `(vector-push-extend value vector ,@(cddr args)) + nil))))))) (define-compiler-macro vector-push (&whole whole &rest args &environment env) (expand-vector-push whole env nil)) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index bcd9ea4e6..fca1186b2 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -18,9 +18,10 @@ (defun expand-mapcar (whole) (when (< (length whole) 3) - (si::signal-simple-error - #'program-error nil "Too few arguments to function ~A in form: ~A" - (firt whole) whole)) + (cmpwarn "Too few arguments to function ~A in form: ~A" (first whole) whole) + (return-from expand-mapcar + `(si:simple-program-error + "Too few arguments to function ~A in form: ~A" ',(first whole) ',whole))) (let ((which (first whole))) (when (eq which 'FUNCALL) (setf whole (rest whole) diff --git a/src/h/ecl.h b/src/h/ecl.h index 0515917dd..dc2cb0f44 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -28,7 +28,7 @@ #include /* setjmp and buffers */ #include /* FILE */ /* Microsoft VC++ does not have va_copy() */ -#if ( defined(_MSC_VER) && (_MSC_VER < 1900) ) || !defined(va_copy) +#if ( defined(_MSC_VER) && (_MSC_VER < 1800) ) || !defined(va_copy) #define va_copy(dst, src) \ ((void) memcpy(&(dst), &(src), sizeof(va_list))) #endif diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 7bbdab65f..0d558f361 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1225,9 +1225,35 @@ ;;; ;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/353 (test cmp.0055.invalid-argument-type - (handler-case - (funcall (compile nil - '(lambda () (vector-push)))) - (program-error () t) - (error () nil) - (:no-error (v) (declare (ignore v)) nil))) + (is-true + (handler-case + (funcall (compile nil + '(lambda () (vector-push)))) + (program-error () t) + (error () nil) + (:no-error (v) (declare (ignore v)) nil)))) + +;;; Date 2017-08-10 +;;; Description +;;; +;;; On some platforms (without feenableexcept) compiling code with +;;; constants being infinity cause fpe-exception. +(test cmp.0056.artificial-fpe + (finishes + (funcall (compile nil + '(lambda () + (eql 10d0 ext:double-float-positive-infinity)))))) + +;;; Date 2017-08-10 +;;; Description +;;; +;;; Confirm, that malformed code compiles (errors should be issued +;;; at runtime). +(test cmp.0057.expand + (let (fun) + ;; expand-mapcar + (is (setf fun (compile nil '(lambda () (mapcar))))) + (signals program-error (funcall fun)) + ;; expand-vector-push + (is (setf fun (compile nil '(lambda () (vector-push))))) + (signals program-error (funcall fun))))