Merge in the latest changes from master branch

contrib/sockets/package.lisp

@@ -0,0 +1,24 @@
+;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
+;; $Id$
+
+;; This file is based on SBCL's SB-BSD-SOCKET module and has been
+;; heavily modified to work with ECL by Julian Stecklina.
+;; Port to Windows Sockets contributed by M. Goffioul.
+
+;; You may do whatever you want with this file. (PUBLIC DOMAIN)
+
+;; Trivial stuff is copied from SBCL's SB-BSD-SOCKETS, which is also
+;; in the public domain.
+
+(defpackage "SB-BSD-SOCKETS"
+  (:use "CL" "FFI" "SI")
+  (:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS"
+	   "SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
+	   "SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
+	   "SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM"
+	   "GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET"
+	   "SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET"
+	   "SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE"
+	   "SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE"
+	   "HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE"
+	   "HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND"))

contrib/sockets/sockets.lisp

@@ -10,18 +10,6 @@
 ;; Trivial stuff is copied from SBCL's SB-BSD-SOCKETS, which is also
 ;; in the public domain.
 
-(defpackage "SB-BSD-SOCKETS"
-  (:use "CL" "FFI" "SI")
-  (:export "GET-HOST-BY-NAME" "GET-HOST-BY-ADDRESS"
-	   "SOCKET-BIND" "SOCKET-ACCEPT" "SOCKET-CONNECT"
-	   "SOCKET-PEERNAME" "SOCKET-NAME" "SOCKET-LISTEN"
-	   "SOCKET-RECEIVE" "SOCKET-CLOSE" "SOCKET-MAKE-STREAM"
-	   "GET-PROTOCOL-BY-NAME" "MAKE-INET-ADDRESS" "LOCAL-SOCKET"
-	   "SOCKET" "INET-SOCKET" "SOCKET-FILE-DESCRIPTOR" #+:win32 "NAMED-PIPE-SOCKET"
-	   "SOCKET-FAMILY" "SOCKET-PROTOCOL" "SOCKET-TYPE"
-	   "SOCKET-ERROR" "NAME-SERVICE-ERROR" "NON-BLOCKING-MODE"
-	   "HOST-ENT-NAME" "HOST-ENT-ALIASES" "HOST-ENT-ADDRESS-TYPE"
-	   "HOST-ENT-ADDRESSES" "HOST-ENT" "HOST-ENT-ADDRESS" "SOCKET-SEND"))
 (in-package "SB-BSD-SOCKETS")
 
 ;; Obviously this requires the one or other form of BSD compatible

src/CHANGELOG

@@ -64,6 +64,12 @@ ECL 9.1.0:
  - A bug in the bytecodes compiler prevented ECL's debugger from inspecting the
    stack when there were local functions.
 
+ - Fixed problems with C/C++ forward declarations of static arrays in compiled
+   code that prevented ECL from building with a C++ compiler.
+
+ - The CLX module now adds itself to *MODULES* and also requires SOCKETS
+   automatically on startup.
+
 * AMOP:
 
  - In DEFCLASS, the :TYPE of slots was ignored.
@@ -77,6 +83,8 @@ ECL 9.1.0:
  - With null safety settings, the slot accessors for structures with
    specialized vector types were not properly compiled.
 
+ - DEFSTRUCT :INCLUDE did not work with read only slots.
+
 * Visible changes:
 
  - New function (EXT:HEAP-SIZE &optional NEW-MAX-HEAP-SIZE) can change the      
@@ -104,6 +112,11 @@ ECL 9.1.0:
    and 64 bits. They depend on the existence of the ecl_[u]int*_t macros
    mentioned before.
 
+ - Two new constants, a C macro ECL_VERSION_NUMBER, and Lisp constant
+   EXT:+ECL-VERSION-NUMBER+, allow determining the version of ECL with
+   a greater granurality. The constant is a decimal number, yymmaa,
+   matching the ECL versioning scheme.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/c/file.d

@@ -80,8 +80,6 @@ const struct ecl_file_ops *stream_dispatch_table(cl_object strm);
 
 static int flisten(FILE *);
 static int file_listen(int);
-static void io_stream_begin_write(cl_object strm);
-static void io_stream_begin_read(cl_object strm);
 static cl_object ecl_off_t_to_integer(ecl_off_t offset);
 static ecl_off_t ecl_integer_to_off_t(cl_object offset);
 
@@ -97,10 +95,12 @@ static void unread_error(cl_object strm);
 static void unread_twice(cl_object strm);
 static void io_error(cl_object strm);
 static void character_size_overflow(cl_object strm, ecl_character c);
+#ifdef ECL_UNICODE
 static void unsupported_character(cl_object strm);
 static void malformed_character(cl_object strm);
 static void too_long_utf8_sequence(cl_object strm);
 static void invalid_codepoint(cl_object strm, cl_fixnum c);
+#endif
 static void wrong_file_handler(cl_object strm);
 
 /**********************************************************************
@@ -121,13 +121,6 @@ not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n)
 	return 0;
 }
 
-static cl_index
-not_binary_write_byte8(cl_object strm, unsigned char *c, cl_index n)
-{
-	not_a_binary_stream(strm);
-	return 0;
-}
-
 static cl_index
 not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n)
 {
@@ -202,19 +195,6 @@ not_character_write_char(cl_object strm, ecl_character c)
 	return c;
 }
 
-static void
-not_character_unread_char(cl_object strm, ecl_character c)
-{
-	not_a_character_stream(strm);
-}
-
-static int
-not_character_listen(cl_object strm)
-{
-	not_a_character_stream(strm);
-	return -1;
-}
-
 static void
 not_input_clear_input(cl_object strm)
 {
@@ -3204,7 +3184,7 @@ io_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n)
 		ecl_fseeko(IO_STREAM_FILE(strm), 0, SEEK_CUR);
 	}
 	strm->stream.last_op = -1;
-	return input_stream_read_byte8(strm, c, n);
+	return output_stream_write_byte8(strm, c, n);
 }
 
 static void io_stream_force_output(cl_object strm);
@@ -3219,7 +3199,7 @@ io_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n)
 		io_stream_force_output(strm);
 	}
 	strm->stream.last_op = +1;
-	return output_stream_write_byte8(strm, c, n);
+	return input_stream_read_byte8(strm, c, n);
 }
 
 static int

src/c/main.d

@@ -293,7 +293,15 @@ _ecl_alloc_env()
 	if (output == MAP_FAILED)
 		ecl_internal_error("Unable to allocate environment structure.");
 #else
-	output = ecl_alloc(sizeof(*output));
+	static struct cl_env_struct first_env;
+	if (!ecl_get_option(ECL_OPT_BOOTED)) {
+		/* We have not set up any environment. Hence, we cannot call ecl_alloc()
+		 * because it will need to stop interrupts and currently we rely on
+		 * the environment for that */
+		output = &first_env;
+	} else {
+		output = ecl_alloc(sizeof(*output));
+	}
 #endif
 	/*
 	 * An uninitialized environment _always_ disables interrupts. They

src/c/symbols_list.h

@@ -1771,5 +1771,7 @@ cl_symbols[] = {
 
 {EXT_ "FILL-ARRAY-WITH-ELT", EXT_ORDINARY, si_fill_array_with_elt, 4, OBJNULL},
 
+{EXT_ "+ECL-VERSION-NUMBER+", EXT_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_VERSION_NUMBER)},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

src/c/symbols_list2.h

@@ -1771,5 +1771,7 @@ cl_symbols[] = {
 
 {EXT_ "FILL-ARRAY-WITH-ELT","si_fill_array_with_elt"},
 
+{EXT_ "+ECL-VERSION-NUMBER+",NULL},
+
 /* Tag for end of list */
 {NULL,NULL}};

src/c/threads.d

@@ -647,15 +647,8 @@ init_threads(cl_env_ptr env)
 	pthread_mutexattr_destroy(&attr);
 #endif
 
-	process = ecl_alloc_object(t_process);
-	process->process.active = 1;
-	process->process.name = @'si::top-level';
-	process->process.function = Cnil;
-	process->process.args = Cnil;
-	process->process.thread = pthread_self();
-	process->process.env = env;
-
-	env->own_process = process;
+	/* We have to set the environment before any allocation takes place,
+	 * so that the interrupt handling code works. */
 #if !defined(WITH___THREAD)
 # if defined(ECL_WINDOWS_THREADS)
 	cl_env_key = TlsAlloc();
@@ -665,6 +658,16 @@ init_threads(cl_env_ptr env)
 #endif
 	ecl_set_process_env(env);
 
+	process = ecl_alloc_object(t_process);
+	process->process.active = 1;
+	process->process.name = @'si::top-level';
+	process->process.function = Cnil;
+	process->process.args = Cnil;
+	process->process.thread = pthread_self();
+	process->process.env = env;
+
+	env->own_process = process;
+
 	cl_core.processes = ecl_list1(process);
 
 #ifdef ECL_WINDOWS_THREADS

src/clx/demo/hello.lisp

@@ -2,13 +2,13 @@
 
 (in-package :xlib)
 
-(defun hello-world (host &rest args &key (string "Hello World") (font "fixed"))
+(defun hello-world (&optional host &rest args &key (string "Hello World") (font "fixed"))
   ;; CLX demo, says STRING using FONT in its own window on HOST
   (let ((display nil)
 	(abort t))
     (unwind-protect
 	(progn 
-	  (setq display (open-display host))
+	  (setq display (if host (open-display host) (open-default-display)))
 	  (multiple-value-prog1
 	    (let* ((screen (display-default-screen display))
 		   (black (screen-black-pixel screen))

src/clx/dependent.lisp

@@ -1827,7 +1827,7 @@
 ;;;	You are STRONGLY encouraged to write a specialized version
 ;;;	of buffer-write-default that does block transfers.
 
-#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp)
+#-(or Genera explorer excl lcl3.0 Minima CMU sbcl clisp ecl)
 (defun buffer-write-default (vector display start end)
   ;; The default buffer write function for use with common-lisp streams
   (declare (type buffer-bytes vector)

src/clx/package.lisp

@@ -227,10 +227,11 @@
 #+clx-ansi-common-lisp
 (common-lisp:in-package :common-lisp-user)
 
-#+(and ecl (not stage1))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+#+ecl
+(eval-when (#-stage1 :compile-toplevel :load-toplevel #-stage1 :execute)
   (require 'sockets))
 
+
 #+clx-ansi-common-lisp
 (defpackage xlib
   (:use common-lisp)

src/cmp/cmpcbk.lsp

@@ -98,6 +98,7 @@
     (wt-nl1 "{")
     (when return-p
       (wt-nl return-type-name " output;"))
+    (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
     (wt-nl "cl_object aux;")
     (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
     (loop for n from 0

src/cmp/cmptop.lsp

@@ -222,7 +222,11 @@
       (wt-nl1 "static cl_object " c-name "(cl_narg narg, ...)"
 	      "{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
 
-  (output-cfuns *compiler-output1*)
+  (wt-nl-h "#ifdef __cplusplus")
+  (wt-nl-h "}")
+  (wt-nl-h "#endif")
+
+  (output-cfuns *compiler-output2*)
 
   (setq *compiler-phase* 't3)
 
@@ -232,10 +236,6 @@
     (dolist (x *callbacks*)
       (apply #'t3-defcallback x)))
 
-  (wt-nl-h "#ifdef __cplusplus")
-  (wt-nl-h "}")
-  (wt-nl-h "#endif")
-
   (wt-nl top-output-string))
 
 (defun c1eval-when (args)

src/compile.lsp.in

@@ -175,7 +175,8 @@
 
 #+WANTS-SOCKETS
 (build-module "sockets"
-	      '("ext:sockets;sockets.lisp")
+	      '("ext:sockets;package.lisp"
+		"ext:sockets;sockets.lisp")
 	      :dir "build:ext;"
 	      :prefix "EXT")
 
@@ -205,29 +206,37 @@
 ;;;
 
 #+WANTS-CLX
-(let ((+clx-src-files+ '("src:clx;package.lisp"
-			 "src:clx;depdefs.lisp"
-			 "src:clx;clx.lisp"
-			 "src:clx;dependent.lisp"
-			 "src:clx;macros.lisp"
-			 "src:clx;bufmac.lisp"
-			 "src:clx;buffer.lisp"
-			 "src:clx;display.lisp"
-			 "src:clx;gcontext.lisp"
-			 "src:clx;input.lisp"
-			 "src:clx;requests.lisp"
-			 "src:clx;fonts.lisp"
-			 "src:clx;graphics.lisp"
-			 "src:clx;text.lisp"
-			 "src:clx;attributes.lisp"
-			 "src:clx;translate.lisp"
-			 "src:clx;keysyms.lisp"
-			 "src:clx;manager.lisp"
-			 "src:clx;image.lisp"
-			 "src:clx;resource.lisp"))
-      #+:msvc
-      (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150")))
-  (pushnew :clx-ansi-common-lisp *features*)
+(let* ((*features* (cons :clx-ansi-common-lisp *features*))
+       (+clx-src-files+ '("src:clx;package.lisp"
+                          "src:clx;depdefs.lisp"
+                          "src:clx;clx.lisp"
+                          "src:clx;dependent.lisp"
+                          "src:clx;macros.lisp"
+                          "src:clx;bufmac.lisp"
+                          "src:clx;buffer.lisp"
+                          "src:clx;display.lisp"
+                          "src:clx;gcontext.lisp"
+                          "src:clx;input.lisp"
+                          "src:clx;requests.lisp"
+                          "src:clx;fonts.lisp"
+                          "src:clx;graphics.lisp"
+                          "src:clx;text.lisp"
+                          "src:clx;attributes.lisp"
+                          "src:clx;translate.lisp"
+                          "src:clx;keysyms.lisp"
+                          "src:clx;manager.lisp"
+                          "src:clx;image.lisp"
+                          "src:clx;resource.lisp"
+			  "build:clx;module.lisp"))
+       #+:msvc
+       (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150")))
+  (let ((filename "build:clx;module.lisp"))
+    (ensure-directories-exist filename)
+    (with-open-file (s filename :direction :output :if-exists :overwrite
+		       :if-does-not-exist :create)
+     (print '(provide :clx) s)))
+  (unless (find-package "SB-BSD-SOCKETS")
+    (load "ext:sockets;package.lisp"))
   (mapcar #'load +clx-src-files+)
   (build-module "clx" +clx-src-files+ :dir "build:clx;" :prefix "CLX"))
 

src/h/config.h.in

@@ -40,6 +40,9 @@
 # define ECL_API
 #endif
 
+/* Decimal number made with the formula yymmvv */
+#define ECL_VERSION_NUMBER @ECL_VERSION_NUMBER@
+
 /*
  * FEATURES LINKED IN
  */
@@ -393,7 +396,7 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
 #endif
 
 #if defined(ECL_THREADS)
-# if defined(darwin) || defined(freebsd) || defined(gnu) || defined(openbsd)
+# if defined(darwin) || defined(freebsd) || defined(gnu) || defined(openbsd) || defined(netbsd)
 #  define PTHREAD_MUTEX_ERRORCHECK_NP PTHREAD_MUTEX_ERRORCHECK
 #  define PTHREAD_MUTEX_RECURSIVE_NP PTHREAD_MUTEX_RECURSIVE
 #  define PTHREAD_MUTEX_NORMAL_NP PTHREAD_MUTEX_NORMAL

src/lsp/defstruct.lsp

@@ -212,10 +212,10 @@
 ;;;  and returns a list of the form:
 ;;;        (slot-name default-init slot-type read-only offset accessor-name)
 
-(defun parse-slot-description (slot-description offset)
+(defun parse-slot-description (slot-description offset &optional read-only)
   (declare (si::c-local))
   (let* ((slot-type 'T)
-	 slot-name default-init read-only)
+	 slot-name default-init)
     (cond ((atom slot-description)
            (setq slot-name slot-description))
           ((endp (cdr slot-description))
@@ -243,29 +243,30 @@
 ;;;  with the new descriptions which are specified in the
 ;;;  :include defstruct option.
 
-(defun overwrite-slot-descriptions (news olds)
+(defun overwrite-slot-descriptions (new-slots old-slots)
   (declare (si::c-local))
-  (when olds
-      (let ((sds (member (caar olds) news :key #'car)))
-        (cond (sds
-               (when (and (null (cadddr (car sds)))
-                          (cadddr (car olds)))
-                     ;; If read-only is true in the old
-                     ;;  and false in the new, signal an error.
-                     (error "~S is an illegal include slot-description."
-                            sds))
-               (cons (list (caar sds)
-                           (cadar sds)
-                           (caddar sds)
-                           (cadddr (car sds))
-                           ;; The offset if from the old.
-                           (car (cddddr (car olds)))
-			   (cadr (cddddr (car olds))))
-                     (overwrite-slot-descriptions news (cdr olds))))
-              (t
-               (cons (car olds)
-                     (overwrite-slot-descriptions news (cdr olds))))))))
-
+  (do* ((output '())
+        (old-slots old-slots (rest old-slots)))
+       ((null old-slots)
+        (nreverse output))
+    (let* ((old-slot (first old-slots))
+           (slot-name (first old-slot))
+           (new-slot (first (member slot-name new-slots :key #'car))))
+      (if (null new-slot)
+          (setf new-slot old-slot)
+          (let* ((old-read-only (fourth old-slot))
+                 (new-read-only (fourth new-slot)))
+            (cond ((and (null new-read-only)
+                        old-read-only)
+                   (error "Tried to turn a read only slot ~A into writtable."
+                          slot-name))
+                  ((eq new-read-only :unknown)
+                   (setf new-read-only old-read-only)))
+            (setf new-slot (copy-list new-slot)
+                  (fourth new-slot) new-read-only
+                  (fifth new-slot) (fifth old-slot) ; preserve offset
+                  (sixth new-slot) (sixth old-slot))))
+      (push new-slot output))))
 
 (defun define-structure (name conc-name type named slots slot-descriptions
 			 copier include print-function print-object constructors
@@ -456,7 +457,7 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
            (setq slot-descriptions
                  (append (overwrite-slot-descriptions
                           (mapcar #'(lambda (sd)
-                                      (parse-slot-description sd 0))
+                                      (parse-slot-description sd 0 :unknown))
                                   (cdr include))
                           (get-sysprop (car include) 'STRUCTURE-SLOT-DESCRIPTIONS))
                          slot-descriptions))))