From 4a3418502c34b22d6d8533561cd8476527a831da Mon Sep 17 00:00:00 2001 From: Yuguo Zhang Date: Tue, 8 Aug 2017 13:14:15 +0800 Subject: [PATCH 01/11] minor MSVC version modifications due to C99 compilance, you need msvc 2013 at least to build ECL. --- msvc/ecl/config-internal.h.msvc6 | 2 +- msvc/ecl/config.h.msvc6 | 2 +- src/h/ecl.h | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) 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..af1c67a8d 100755 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -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/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 From 74b673479ecf905b536b725d6c609f95539425b3 Mon Sep 17 00:00:00 2001 From: Yuguo Zhang Date: Tue, 8 Aug 2017 14:10:58 +0800 Subject: [PATCH 02/11] using 16bit unicode on windows platform. because windows using utf16 internally, by using 16bit unicode chararcter, there is no need to convert ecl_character to wchar_t in embedding environment. --- msvc/c/Makefile | 7 +++---- msvc/ecl/config.h.msvc6 | 4 ++-- 2 files changed, 5 insertions(+), 6 deletions(-) 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.h.msvc6 b/msvc/ecl/config.h.msvc6 index af1c67a8d..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; /* From e0fd6ab22cc7c67559ac7064abf2a0631dfe19c0 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 19:28:20 +0200 Subject: [PATCH 03/11] tests: fix tests for vector-push --- src/tests/normal-tests/compiler.lsp | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 7bbdab65f..3c5edca80 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1225,9 +1225,10 @@ ;;; ;;; 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)))) From beefd56f56066bf38f7ba7ab9f4a11a41ae93653 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 19:28:33 +0200 Subject: [PATCH 04/11] tests: add test for artificial fpe --- src/tests/normal-tests/compiler.lsp | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 3c5edca80..0a203fcf1 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1232,3 +1232,14 @@ (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)))))) From 6d8b0e7f623f13bf4a62184cc5738f7a2ef78330 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:21:04 +0200 Subject: [PATCH 05/11] compiler: expand-mapcar: issue error at runtime and compiler warning during compilation. --- src/cmp/cmpmap.lsp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index bcd9ea4e6..16231649d 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) From 45d5176c0ee4311f4bd40dd60ccfa2bd1e5e277e Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:22:12 +0200 Subject: [PATCH 06/11] tests: add test for expansions of mapcar and vector-push --- src/tests/normal-tests/compiler.lsp | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 0a203fcf1..0d558f361 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1243,3 +1243,17 @@ (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)))) From c2af9fe77525ab7b5c155753eeac4e372e31017c Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:23:30 +0200 Subject: [PATCH 07/11] cmp: refactor: expand-vector-push: get rid of one nesting level --- src/cmp/cmparray.lsp | 77 ++++++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 39 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 7cef72ec7..be6276d86 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -90,46 +90,45 @@ ;;; 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)))))))))) + (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) (define-compiler-macro vector-push (&whole whole &rest args &environment env) From 7320c9049c6d10f26b466a5afbf42a0978a94b27 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:32:02 +0200 Subject: [PATCH 08/11] mapcar-expand: fix-typo --- src/cmp/cmpmap.lsp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index 16231649d..fca1186b2 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -21,7 +21,7 @@ (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))) + "Too few arguments to function ~A in form: ~A" ',(first whole) ',whole))) (let ((which (first whole))) (when (eq which 'FUNCALL) (setf whole (rest whole) From 8293fb6eb441f29da5b830f5eb8986f0c07aa2e2 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:44:35 +0200 Subject: [PATCH 09/11] expand-vector-push: reduce complexity (one nesting level less) catch the infinite recursion and do return-form instead of setting `whole'. --- src/cmp/cmparray.lsp | 73 ++++++++++++++++++++++---------------------- 1 file changed, 36 insertions(+), 37 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index be6276d86..b0e602959 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -93,43 +93,42 @@ (defun expand-vector-push (whole env extend &aux (args (rest whole))) (declare (si::c-local)) (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) + (when (or (eq (first args) 'value) ; No infinite recursion + (not (policy-open-code-aref/aset))) + (return-from expand-vector-push 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)))))))) (define-compiler-macro vector-push (&whole whole &rest args &environment env) (expand-vector-push whole env nil)) From bf310ef23a680378d9353249f6f4e8aaba5c69cb Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:55:11 +0200 Subject: [PATCH 10/11] expand-vector-push: further reduce complexity use return-from for catching forms of illegal number of arguments. --- src/cmp/cmparray.lsp | 57 +++++++++++++++++++------------------------- 1 file changed, 24 insertions(+), 33 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index b0e602959..5c5770311 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -95,40 +95,31 @@ (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)) - (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))) + (return-from expand-vector-push + whole)) + (let ((len (length args))) + (when (or (< len 2) + (> len (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 ~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)))))))) + "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)) From ee059366dbce648a654ee858d5351f4980986df0 Mon Sep 17 00:00:00 2001 From: Daniel Kochmanski Date: Thu, 10 Aug 2017 20:58:37 +0200 Subject: [PATCH 11/11] expand-vector-push: simplify error condition assert, that function takes 2 up to 3 (if extended) arguments. --- src/cmp/cmparray.lsp | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 5c5770311..559b236e6 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -97,13 +97,13 @@ (not (policy-open-code-aref/aset))) (return-from expand-vector-push whole)) - (let ((len (length args))) - (when (or (< len 2) - (> len (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)))) + (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)