New functions for performing type inference.

Arithmetic operators *,+,/,- now have simple optimizers.
Fixed several "bugs" in the C code to let ECL compile with GCC 4.0

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

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;

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

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;

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)

src/c/dpp.c

@@ -67,6 +67,7 @@
 
 */
 
+#include <stdlib.h>
 #include <stdio.h>
 #include <ctype.h>
 #include <string.h>

src/c/ffi.d

@@ -12,6 +12,7 @@
     See file '../Copyright' for full details.
 */
 
+#include <string.h>
 #include "ecl.h"
 
 cl_object

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)

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

src/c/load.d

@@ -13,6 +13,7 @@
     See file '../Copyright' for full details.
 */
 
+#include <string.h>
 #include "ecl.h"
 #include "ecl-inl.h"
 #include "internal.h"

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},

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

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

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

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

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

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

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)

src/doc/install.in.html

@@ -3,8 +3,8 @@
 <p>You should read the <a href="#configure">Autoconf based configuration</a>
 if you use ECL on a unix-like platform, such as
 <ul>
-<li>Linux, NetBSD, FreeBSD, Sola.
-<li>OSX (See <a href="#osx">below</a>)
+<li>Linux, NetBSD, FreeBSD, Solaris 9
+<li>Mac OSX (See <a href="#osx">below</a>)
 <li>Cygwin or Mingw32 on Windows.
 </ul>
 
@@ -33,9 +33,9 @@ and finish the compilation.
 </pre>
 The previous step creates a directory with the name <b>build</b>, and
 stores a bunch of makefiles in it. <b>Note:</b> If you are building
-under Solaris, you should rather use
+under Solaris 9, you should rather use
 <pre>
-	./configure --enable-slow-config
+	./configure --enable-slow-config --with-system-gmp=no
 </pre>
 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:
 
 <h3><a name="osx">Mac OSX</a></h3>
 
-<p>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 <a
-href="configure">Autoconf</a> section.
+<p>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.
 
-<p>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 <tt>configure</tt> to use a different compiler, as in
+<p>For compiling with GCC 3.3 (shipped with XCode >= 2) you
+must instruct <tt>configure</tt> to use a different compiler, as in
 <pre>
 $ CC=gcc-3.3 ./configure --prefix=/opt/local
 </pre>

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