diff --git a/src/CHANGELOG b/src/CHANGELOG index bce2e5f1b..5cf8b73c4 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -116,6 +116,8 @@ ECL 0.9g in which the DEFMETHOD is enclosed. This makes it now possible to write (defmethod foo (x) (defmethod bar ((f (eql x))))) + - Fixes in the C code to comply with gcc 4.0. + * ANSI compatibility: - Several functions that signaled type-errors did not set the right values diff --git a/src/c/alloc.d b/src/c/alloc.d index 95557914b..ee5a3a7e5 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -381,6 +381,7 @@ ONCE_MORE: obj->cblock.data_text = NULL; obj->cblock.data_text_size = 0; obj->cblock.links = Cnil; + obj->cblock.next = Cnil; break; case t_foreign: obj->foreign.tag = Cnil; diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index e44a7290f..d84f7cdf2 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -115,8 +115,10 @@ cl_alloc_object(cl_type t) obj->cblock.links = Cnil; obj->cblock.name = Cnil; obj->cblock.next = Cnil; - obj->cblock.data_text = obj->cblock.data = NULL; - obj->cblock.data_text_size = obj->cblock.data_size = 0; + obj->cblock.data_text = NULL; + obj->cblock.data = NULL; + obj->cblock.data_text_size = NULL; + obj->cblock.data_size = 0; obj->cblock.handle = NULL; #endif #ifdef ENABLE_THREADS diff --git a/src/c/compiler.d b/src/c/compiler.d index 5b2ee7ca4..ad2f1e9d2 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2492,7 +2492,7 @@ si_make_lambda(cl_object name, cl_object rest) } @(defun si::eval-with-env (form &optional (env Cnil) (stepping Cnil)) - volatile struct cl_compiler_env *old_c_env = ENV; + struct cl_compiler_env *old_c_env = ENV; struct cl_compiler_env new_c_env; volatile cl_index handle; struct ihs_frame ihs; diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 73bc37eed..705d79acf 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -733,7 +733,7 @@ si_bc_split(cl_object b) if (type_of(b) != t_bytecodes) @(return Cnil Cnil) vector = cl_alloc_simple_vector(b->bytecodes.code_size, aet_b8); - vector->vector.self.b8 = b->bytecodes.code; + vector->vector.self.b8 = (uint8_t*)b->bytecodes.code; data = cl_alloc_simple_vector(b->bytecodes.data_size, aet_object); data->vector.self.t = b->bytecodes.data; @(return b->bytecodes.lex vector data) diff --git a/src/c/dpp.c b/src/c/dpp.c index 0d2145dd6..c2c11ec07 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -67,6 +67,7 @@ */ +#include #include #include #include diff --git a/src/c/ffi.d b/src/c/ffi.d index 5545e450f..d418fb68b 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -12,6 +12,7 @@ See file '../Copyright' for full details. */ +#include #include "ecl.h" cl_object diff --git a/src/c/file.d b/src/c/file.d index 833921dc0..eff9fde91 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -1519,7 +1519,7 @@ si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) stream = stream->stream.object1; goto AGAIN; } else { - unsigned char *p; + char *p; for (p= seq->vector.self.ch; start < end; start++) { ecl_write_char(p[start], stream); } @@ -1602,7 +1602,7 @@ si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) stream = stream->stream.object0; goto AGAIN; } else { - unsigned char *p; + char *p; for (p = seq->vector.self.ch; start < end; start++) { int c = ecl_read_char(stream); if (c == EOF) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 88b73fe89..aa92ba10f 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -860,7 +860,8 @@ interpret(cl_object bytecodes, void *pc) { case OP_PFCALL: { cl_fixnum n = GET_OPARG(vector); cl_object fun = cl_env.stack_top[-n-1]; - cl_env.stack_top[-1] = interpret_funcall(n, fun); + cl_object reg0 = interpret_funcall(n, fun); + cl_env.stack_top[-1] = reg0; break; } diff --git a/src/c/load.d b/src/c/load.d index 69a4921c8..294efc14d 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -13,6 +13,7 @@ See file '../Copyright' for full details. */ +#include #include "ecl.h" #include "ecl-inl.h" #include "internal.h" diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 2291c022d..79e1ead12 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -934,7 +934,7 @@ cl_symbols[] = { {"VARIABLE", CL_ORDINARY, NULL, -1, OBJNULL}, {"VECTOR", CL_ORDINARY, ECL_NAME(cl_vector), -1, OBJNULL}, {"VECTOR-POP", CL_ORDINARY, ECL_NAME(cl_vector_pop), -1, OBJNULL}, -{"VECTOR-PUSH", CL_ORDINARY, ECL_NAME(cl_vector_push), -1, OBJNULL}, +{"VECTOR-PUSH", CL_ORDINARY, ECL_NAME(cl_vector_push), 2, OBJNULL}, {"VECTOR-PUSH-EXTEND", CL_ORDINARY, ECL_NAME(cl_vector_push_extend), -1, OBJNULL}, {"VECTORP", CL_ORDINARY, cl_vectorp, 1, OBJNULL}, {"WARN", CL_ORDINARY, NULL, -1, OBJNULL}, diff --git a/src/clos/method.lsp b/src/clos/method.lsp index 7d68262c7..b3f616894 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -462,7 +462,7 @@ (error 'simple-program-error "Syntax error in method specializer ~A" arg)) ((constantp (setf arg (second arg))) - `(eql ,arg)) + `(eql ,(eval arg))) (t (list 'eql (list 'si::unquote arg)))) specializers)) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 88930463f..c60ce79a2 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -120,25 +120,17 @@ *function-declarations*) (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))) -(defun get-arg-types (fname &aux x) - (if (setq x (assoc fname *function-declarations*)) - (second x) - (get-sysprop fname 'PROCLAIMED-ARG-TYPES))) +(defun get-arg-types (fname) + (let ((x (assoc fname *function-declarations*))) + (if x + (second x) + (get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) (defun get-return-type (fname) - (let* ((x (assoc fname *function-declarations*)) - (type1 (if x (caddr x) (get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) - (cond (type1 - (let ((type (get-sysprop fname 'RETURN-TYPE))) - (cond (type - (cond ((setq type (type-and type type1)) type) - (t - (cmpwarn - "The return type of ~s was badly declared." - fname)))) - (t type1)))) - (t (get-sysprop fname 'RETURN-TYPE))) - )) + (let ((x (assoc fname *function-declarations*))) + (if x + (second x) + (get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) (defun get-local-arg-types (fun &aux x) (if (setq x (assoc fun *function-declarations*)) @@ -155,7 +147,7 @@ (get-sysprop fun 'PROCLAIMED-ARG-TYPES) (if found (let ((minarg (length x))) - (if (eq (last x) '*) + (if (eq (first (last x)) '*) (setf minarg (1- minarg) maxarg call-arguments-limit) (setf maxarg minarg)) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 2630a6aab..276a3b251 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -101,29 +101,7 @@ (defun c1call-global (fname args) (let* ((forms (c1args* args)) - (return-type (or (get-return-type fname) '(VALUES &REST T)))) - (let ((arg-types (get-arg-types fname))) - ;; Add type information to the arguments. - (when arg-types - (do ((fl forms (cdr fl)) - (fl1 nil) - (al args (cdr al))) - ((endp fl) - (setq forms (nreverse fl1))) - (cond ((endp arg-types) (push (car fl) fl1)) - (t (push (and-form-type (car arg-types) (car fl) (car al) - :safe "In a call to ~a" fname) - fl1) - (pop arg-types)))))) - (let ((arg-types (get-sysprop fname 'ARG-TYPES))) - ;; Check argument types. - (when arg-types - (do ((fl forms (cdr fl)) - (al args (cdr al))) - ((or (endp arg-types) (endp fl))) - (and-form-type (car arg-types) (car fl) (car al) :safe - "In a call to ~a" fname) - (pop arg-types)))) + (return-type (propagate-types fname forms args))) (make-c1form* 'CALL-GLOBAL :sp-change (function-may-change-sp fname) :type return-type diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp new file mode 100644 index 000000000..ce58b4f38 --- /dev/null +++ b/src/cmp/cmpnum.lsp @@ -0,0 +1,49 @@ +;;;; CMPNUM -- Optimizer for numerical expressions. + +;;;; Copyright (c) 2005, Juan Jose Garcia Ripoll +;;;; +;;;; ECoLisp is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +(in-package "COMPILER") + +(defun simplify-arithmetic (operator args whole) + (let ((l (length args))) + (cond ((every #'numberp args) + (apply operator args)) + ((> l 2) + (simplify-arithmetic + operator + (list* (simplify-arithmetic operator (list (first args) (second args)) nil) + (cddr args)) + nil)) + ((= l 2) + (or whole (list* operator args))) + ((= l 1) + (if (or (eq operator '*) (eq operator '+)) + (first args) + (or whole (list* operator args)))) + ((eq operator '*) + 1) + ((eq operator '+) + 0) + (t + (error 'simple-program-error :format-error "Wrong number of arguments for operator ~a in ~a" + :format-args (list operators (or whole (list* operator args)))))))) + +(define-compiler-macro * (&whole all &rest args) + (simplify-arithmetic '* args all)) + +(define-compiler-macro + (&whole all &rest args) + (simplify-arithmetic '+ args all)) + +(define-compiler-macro / (&whole all &rest args) + (simplify-arithmetic '/ args all)) + +(define-compiler-macro - (&whole all &rest args) + (simplify-arithmetic '- args all)) + diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 698cb434e..b8fc33f94 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -68,10 +68,11 @@ ((SIMPLE-ARRAY ARRAY) (cond ((endp type-args) '(ARRAY *)) ; Beppe ((eq '* (car type-args)) t) - (t (let ((element-type (upgraded-array-element-type (car type-args)))) - (if (and (cdr type-args) - (not (eq (second type-args) '*)) - (= (length (second type-args)) 1)) + (t (let ((element-type (upgraded-array-element-type (car type-args))) + (dimensions (if (cdr type-args) (second type-args) '*))) + (if (and (not (eq dimensions '*)) + (or (numberp dimensions) + (= (length dimensions) 1))) (case element-type (BASE-CHAR 'STRING) (BIT 'BIT-VECTOR) @@ -355,3 +356,41 @@ (every* #'subtypep (values-type-required v1) (values-type-required v2)) (every* #'subtypep (values-type-optional v1) (values-type-optional v2)) (subtypep (values-type-rest v1) (values-type-rest v2)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; TYPE PROPAGATORS +;;; + +(in-package "COMPILER") + +(defun simple-type-propagator (fname &rest form-types) + (let ((arg-types (get-arg-types fname)) + (return-type (or (get-return-type fname) '(VALUES &REST T)))) + (values arg-types return-type))) + +(defun propagate-types (fname forms lisp-forms) + (multiple-value-bind (arg-types return-type) + (apply (or (get-sysprop fname 'C1TYPE-PROPAGATOR) + #'simple-type-propagator) + fname + forms) + (when arg-types + (do ((fl forms (rest fl)) + (al lisp-forms (rest al)) + (i 1 (1+ i))) + ((endp fl)) + (unless (endp arg-types) + ;; Check the type of the arguments. + (let ((new (and-form-type (pop arg-types) (first fl) (first al) + :safe "In the argument ~d of a call to ~a" i fname))) + ;; In unsafe mode, we assume that the type of the + ;; argument is going to be the right one. + (when (zerop *safety*) + (setf (car fl) new)))))) + return-type)) + +(defmacro def-type-propagator (fname lambda-list &body body) + `(put-sysprop ',fname 'C1TYPE-PROPAGATOR + #'(ext:lambda-block ,fname ,lambda-list ,body))) + diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 2a1756a29..b59b7b89a 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -28,6 +28,7 @@ "src:cmp;cmpwt.lsp" "src:cmp;cmpffi.lsp" "src:cmp;cmpct.lsp" + "src:cmp;cmpnum.lsp" "build:cmp;cmpcfg.lsp" "src:cmp;cmpmain.lsp")) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index c86d017df..0b402613c 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -48,11 +48,11 @@ &key no-sp-change predicate no-side-effects) (unless (or (null arg-types) (equal arg-types '(*))) - (put-sysprop name 'arg-types + (put-sysprop name 'proclaimed-arg-types (mapcar #'(lambda (x) (if (eql x '*) '* (type-filter x))) arg-types))) (when (and return-type (not (eq 'T return-type))) - (put-sysprop name 'return-type + (put-sysprop name 'proclaimed-return-type (if (eql return-type '*) '* (type-filter return-type t)))) (when no-sp-change (put-sysprop name 'no-sp-change t)) @@ -861,15 +861,15 @@ (def-inline log :always (fixnum-float) :double "log((double)(#0))") (def-inline log :always (fixnum-float) :float "(float)log((double)(#0))") -(proclaim-function sqrt (t) t :no-side-effects t) +(proclaim-function sqrt (number) number :no-side-effects t) (def-inline sqrt :always (fixnum-float) :double "sqrt((double)(#0))") (def-inline sqrt :always (fixnum-float) :float "(float)sqrt((double)(#0))") -(proclaim-function sin (t) t :no-side-effects t) +(proclaim-function sin (number) number :no-side-effects t) (def-inline sin :always (fixnum-float) :double "sin((double)(#0))") (def-inline sin :always (fixnum-float) :float "(float)sin((double)(#0))") -(proclaim-function cos (t) t :no-side-effects t) +(proclaim-function cos (number) number :no-side-effects t) (def-inline cos :always (fixnum-float) :double "cos((double)(#0))") (def-inline cos :always (fixnum-float) :float "(float)cos((double)(#0))") @@ -967,7 +967,7 @@ type_of(#0)==t_string|| type_of(#0)==t_bitvector") (proclaim-function vector-push (t vector) fixnum :no-sp-change t) -(proclaim-function vector-push-extend (t vector) fixnum :no-sp-change t) +(proclaim-function vector-push-extend (t vector *) fixnum :no-sp-change t) (proclaim-function simple-string-p (t) t :predicate t) (proclaim-function simple-bit-vector-p (t) t :predicate t) (proclaim-function simple-vector-p (t) t :predicate t) diff --git a/src/doc/install.in.html b/src/doc/install.in.html index 0be4b7b84..334cf891c 100644 --- a/src/doc/install.in.html +++ b/src/doc/install.in.html @@ -3,8 +3,8 @@

You should read the Autoconf based configuration if you use ECL on a unix-like platform, such as

    -
  • Linux, NetBSD, FreeBSD, Sola. -
  • OSX (See below) +
  • Linux, NetBSD, FreeBSD, Solaris 9 +
  • Mac OSX (See below)
  • Cygwin or Mingw32 on Windows.
@@ -33,9 +33,9 @@ and finish the compilation. The previous step creates a directory with the name build, and stores a bunch of makefiles in it. Note: If you are building -under Solaris, you should rather use +under Solaris 9, you should rather use 
-	./configure --enable-slow-config
+	./configure --enable-slow-config --with-system-gmp=no
because otherwise ECL will fail to detect the 64-bit capabilities of the operating system. @@ -97,13 +97,13 @@ Toolkit 2003, you should follow these before building ECL:

Mac OSX

-

ECL is known to build and work on all versions of OSX, including -Tiger. The steps for building ECL are the ones shown in the Autoconf section. +

ECL now compiles with GCC 4.0. You need not specify any particular +options. But if you still experience some strange behaviour, try +compiling with a previous version of the compiler before reporting the +bug. -

There is a caveat, though, which is that ECL currently cannot be built -using GCC 4.0. Hence, if you have OSX Tiger (>= 10.4) and XCode (>= 2) you -should instruct configure to use a different compiler, as in +

For compiling with GCC 3.3 (shipped with XCode >= 2) you +must instruct configure to use a different compiler, as in 

 $ CC=gcc-3.3 ./configure --prefix=/opt/local
diff --git a/src/h/external.h b/src/h/external.h index 1b065ea6b..7614fc304 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -445,7 +445,7 @@ extern void FEreader_error(const char *s, cl_object stream, int narg, ...) /*__a extern void FEerror(const char *s, int narg, ...) /*__attribute__((noreturn))*/; extern void FEcannot_open(cl_object fn) /*__attribute__((noreturn))*/; extern void FEend_of_file(cl_object strm) /*__attribute__((noreturn))*/; -extern void FEclosed_stream(cl_object strm) __attribute__ ((noreturn)); +extern void FEclosed_stream(cl_object strm) /*__attribute__ ((noreturn))*/; extern void FEwrong_type_argument(cl_object type, cl_object value) /*__attribute__((noreturn))*/; extern void FEwrong_num_arguments(cl_object fun) /*__attribute__((noreturn))*/; extern void FEwrong_num_arguments_anonym(void) /*__attribute__((noreturn))*/; @@ -1482,7 +1482,7 @@ extern cl_object cl_bit_andc2 _ARGS((cl_narg narg, cl_object V1, cl_object V2, . extern cl_object cl_bit_orc1 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); extern cl_object cl_bit_orc2 _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); extern cl_object cl_bit_not _ARGS((cl_narg narg, cl_object V1, ...)); -extern cl_object cl_vector_push _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); +extern cl_object cl_vector_push _ARGS((cl_object V1, cl_object V2)); extern cl_object cl_vector_push_extend _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); extern cl_object cl_vector_pop _ARGS((cl_narg narg, cl_object V1, ...)); extern cl_object cl_adjust_array _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));