mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-23 13:01:42 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'develop' of gitlab.com:embeddable-common-lisp/ecl into develop

Browse source
This commit is contained in:
Daniel Kochmański 2017-08-11 12:09:47 +02:00
commit 5ef7413868
7 changed files with 73 additions and 58 deletions
Download patch file Download diff file Expand all files Collapse all files

7
msvc/c/Makefile
View file

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

2
msvc/ecl/config-internal.h.msvc6
View file

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

6
msvc/ecl/config.h.msvc6
View file

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

69
src/cmp/cmparray.lsp
View file

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

7
src/cmp/cmpmap.lsp
View file

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

2
src/h/ecl.h
View file

@ -28,7 +28,7 @@
#include <setjmp.h> /* setjmp and buffers */
#include <stdio.h> /* 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

38
src/tests/normal-tests/compiler.lsp
View file

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