From 1dd8f4247e7e44543e13f86080246f62a6d19dc2 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 17 Feb 2009 21:10:02 +0100 Subject: [PATCH 01/13] DEFSTRUCT :INCLUDE did not work with read only slots. --- src/CHANGELOG | 2 ++ src/lsp/defstruct.lsp | 49 ++++++++++++++++++++++--------------------- 2 files changed, 27 insertions(+), 24 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index f5a4ca427..6685c43c2 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -71,6 +71,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 diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 281c8bad2..358f41c33 100644 --- a/src/lsp/defstruct.lsp +++ b/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 (fifth old-slot)) + (new-read-only (fifth 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 From a2d2add97fec92e780077c5e34e490010e11f23c Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 17 Feb 2009 21:21:15 +0100 Subject: [PATCH 02/13] Missing bits from the previous fix for DEFSTRUCT --- src/lsp/defstruct.lsp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp index 358f41c33..40f78d914 100644 --- a/src/lsp/defstruct.lsp +++ b/src/lsp/defstruct.lsp @@ -254,8 +254,8 @@ (new-slot (first (member slot-name new-slots :key #'car)))) (if (null new-slot) (setf new-slot old-slot) - (let* ((old-read-only (fifth old-slot)) - (new-read-only (fifth new-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." @@ -457,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)))) From 12b0c0a70c155c936242330a3bbe9c9f844c4b7f Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 10:48:31 +0100 Subject: [PATCH 03/13] We have to set the proces environment _before_ allocating the process object. Otherwise the code for interrupt handling will not work. --- src/c/threads.d | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/c/threads.d b/src/c/threads.d index 8c2b5f0be..509c750cb 100644 --- a/src/c/threads.d +++ b/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 From 464c440a5941d1d637d3d40c8cea50b6ab0c246f Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 10:56:07 +0100 Subject: [PATCH 04/13] The allocation of the first environment will not succeed if we rely on ecl_alloc(), because it needs a working cl_env_p to block interrupts. --- src/c/main.d | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/c/main.d b/src/c/main.d index fa4f41602..7e34641cc 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -219,7 +219,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 From c81e2080ecb44e89833dc22f0d069c89ce549f24 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 11:35:33 +0100 Subject: [PATCH 05/13] PTHREAD_*_NP are also missing from NetBSD. --- src/h/config.h.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/h/config.h.in b/src/h/config.h.in index ef9fec4a2..c884603de 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -382,7 +382,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 From 21747e54da8a1f0adfa48292e5b71cb823c292be Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 11:58:14 +0100 Subject: [PATCH 06/13] Missing definition for cl_env_copy. --- src/cmp/cmpcbk.lsp | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index 63e789df4..ad2f29bb1 100644 --- a/src/cmp/cmpcbk.lsp +++ b/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 From 16849b5eb3c3ce93de9bd2067a43a77a4f1bdfa4 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 14:13:53 +0100 Subject: [PATCH 07/13] In C++ it is not possible to forward-declare a static array. We thus have to change the code for building the compiler_cfuns[] array in compiled code. --- src/CHANGELOG | 3 +++ src/cmp/cmptop.lsp | 43 +++++++++++++++++++++---------------------- 2 files changed, 24 insertions(+), 22 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 6685c43c2..aa3f1964c 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -58,6 +58,9 @@ ECL 9.1.0: - READ-DELIMITED-LIST interpreted the value of :RECURSIVEP the wrong way. + - Fixed problems with C/C++ forward declarations of static arrays in compiled + code that prevented ECL from building with a C++ compiler. + * AMOP: - In DEFCLASS, the :TYPE of slots was ignored. diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 62811b5ea..c38d68f0e 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -198,12 +198,6 @@ (wt-nl-h "static cl_object VV[VM];") (wt-nl-h "#endif")))) - (let ((n-cfuns (length *global-cfuns-array*))) - (wt-nl-h "#define compiler_cfuns_size " n-cfuns) - (if (zerop n-cfuns) - (wt-nl-h "#define compiler_cfuns NULL") - (wt-nl-h "static const struct ecl_cfun compiler_cfuns[" n-cfuns "];"))) - (dolist (l *linking-calls*) (let* ((c-name (fourth l)) (var-name (fifth l))) @@ -222,7 +216,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 +230,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) @@ -702,17 +696,22 @@ (close-inline-blocks))) (defun output-cfuns (stream) - (format stream "~%#ifndef compiler_cfuns~ -~%static const struct ecl_cfun compiler_cfuns[] = {~ -~%~t/*t,m,narg,padding,name,entry,block*/"); - (loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*) - do (let* ((cfun (fun-cfun fun)) - (minarg (fun-minarg fun)) - (maxarg (fun-maxarg fun)) - (narg (if (= minarg maxarg) maxarg nil))) - (format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),(cl_objectfn)~A,MAKE_FIXNUM(~D)}," - (or narg -1) (second loc) cfun (second fname-loc)))) - (format stream "~%};~%#endif")) + (let ((n-cfuns (length *global-cfuns-array*))) + (wt-nl-h "#define compiler_cfuns_size " n-cfuns) + (if (zerop n-cfuns) + (wt-nl-h "#define compiler_cfuns NULL") + (progn + (format stream "~%static const struct ecl_cfun compiler_cfuns[~D] = {~ +~%~t/*t,m,narg,padding,name,entry,block*/" + (length *global-cfuns-array*)) + (loop for (loc fname-loc fun) in (nreverse *global-cfuns-array*) + do (let* ((cfun (fun-cfun fun)) + (minarg (fun-minarg fun)) + (maxarg (fun-maxarg fun)) + (narg (if (= minarg maxarg) maxarg nil))) + (format stream "~%{0,0,~D,0,MAKE_FIXNUM(~D),(cl_objectfn)~A,MAKE_FIXNUM(~D)}," + (or narg -1) (second loc) cfun (second fname-loc)))) + (format stream "~%};"))))) ;;; ---------------------------------------------------------------------- From 402e59f82f13306e66199395370eaeff8cb541c2 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 23 Feb 2009 21:45:02 +0100 Subject: [PATCH 08/13] New decimal constants ECL_VERSION_NUMBER (C/C++) and EXT:+ECL-VERSION-NUMBER+ (Lisp) --- src/CHANGELOG | 5 +++++ src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/configure | 10 +++++++--- src/configure.in | 10 +++++++--- src/h/config.h.in | 3 +++ 6 files changed, 26 insertions(+), 6 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index aa3f1964c..1aa9f13de 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -87,6 +87,11 @@ ECL 9.1.0: now stored using an (ARRAY (SIGNED-BYTE 32)). This saves memory on systems with 64-bit pointers. + - 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 *** diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 81b234c8a..b830f028b 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1749,5 +1749,7 @@ cl_symbols[] = { {EXT_ "HEAP-SIZE", EXT_ORDINARY, si_heap_size, -1, OBJNULL}, #endif +{EXT_ "+ECL-VERSION-NUMBER+", EXT_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_VERSION_NUMBER)}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 5c0b4df50..89b4c1c75 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1749,5 +1749,7 @@ cl_symbols[] = { {EXT_ "HEAP-SIZE","si_heap_size"}, #endif +{EXT_ "+ECL-VERSION-NUMBER+",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/configure b/src/configure index f41a5b906..09d7a8147 100755 --- a/src/configure +++ b/src/configure @@ -654,6 +654,7 @@ CL_FIXNUM_TYPE EGREP GREP XMKMF +ECL_VERSION_NUMBER SONAME_LDFLAGS SONAME SONAME1 @@ -5162,6 +5163,9 @@ fi { $as_echo "$as_me:$LINENO: checking for soname flags" >&5 $as_echo_n "checking for soname flags... " >&6; } +PACKAGE_MAJOR=`echo ${PACKAGE_VERSION} | sed -e 's,\(.*\)\..*\..*,\1,g'` +PACKAGE_MINOR=`echo ${PACKAGE_VERSION} | sed -e 's,.*\.\(.*\)\..*,\1,g'` +PACKAGE_LEAST=`echo ${PACKAGE_VERSION} | sed -e 's,.*\..*\.\(.*\),\1,g'` if test "${enable_soname}" != yes; then SONAME='' SONAME1='' @@ -5172,9 +5176,6 @@ if test "${enable_soname}" != yes; then { $as_echo "$as_me:$LINENO: result: none" >&5 $as_echo "none" >&6; } else - PACKAGE_MAJOR=`echo ${PACKAGE_VERSION} | sed -e 's,\(.*\)\..*\..*,\1,g'` - PACKAGE_MINOR=`echo ${PACKAGE_VERSION} | sed -e 's,.*\.\(.*\)\..*,\1,g'` - PACKAGE_LEAST=`echo ${PACKAGE_VERSION} | sed -e 's,.*\..*\.\(.*\),\1,g'` i="${PACKAGE_MAJOR}.${PACKAGE_MINOR}.${PACKAGE_LEAST}" SONAME3=`echo $SONAME | sed "s,.SOVERSION,.$i,g"` i="${PACKAGE_MAJOR}.${PACKAGE_MINOR}" @@ -5192,6 +5193,9 @@ fi +ECL_VERSION_NUMBER=$(($PACKAGE_MAJOR * 10000 + $PACKAGE_MINOR * 100 + $PACKAGE_LEAST)) + + if test "${with_fpe}" != yes; then cat >>confdefs.h <<\_ACEOF #define ECL_AVOID_FPE_H 1 diff --git a/src/configure.in b/src/configure.in index ec16be599..3f4a1a2b0 100644 --- a/src/configure.in +++ b/src/configure.in @@ -397,6 +397,9 @@ dnl ---------------------------------------------------------------------- dnl SONAME is only active when SONAME_LDFLAGS and SONAME are non nil dnl AC_MSG_CHECKING(for soname flags) +PACKAGE_MAJOR=`echo ${PACKAGE_VERSION} | sed -e 's,\(.*\)\..*\..*,\1,g'` +PACKAGE_MINOR=`echo ${PACKAGE_VERSION} | sed -e 's,.*\.\(.*\)\..*,\1,g'` +PACKAGE_LEAST=`echo ${PACKAGE_VERSION} | sed -e 's,.*\..*\.\(.*\),\1,g'` if test "${enable_soname}" != yes; then SONAME='' SONAME1='' @@ -406,9 +409,6 @@ if test "${enable_soname}" != yes; then SONAME_LDFLAGS='' AC_MSG_RESULT([none]) else - PACKAGE_MAJOR=`echo ${PACKAGE_VERSION} | sed -e 's,\(.*\)\..*\..*,\1,g'` - PACKAGE_MINOR=`echo ${PACKAGE_VERSION} | sed -e 's,.*\.\(.*\)\..*,\1,g'` - PACKAGE_LEAST=`echo ${PACKAGE_VERSION} | sed -e 's,.*\..*\.\(.*\),\1,g'` i="${PACKAGE_MAJOR}.${PACKAGE_MINOR}.${PACKAGE_LEAST}" SONAME3=`echo $SONAME | sed "s,.SOVERSION,.$i,g"` i="${PACKAGE_MAJOR}.${PACKAGE_MINOR}" @@ -425,6 +425,10 @@ AC_SUBST(SONAME1) AC_SUBST(SONAME) AC_SUBST(SONAME_LDFLAGS) +dnl Related to that, the package version number +ECL_VERSION_NUMBER=$(($PACKAGE_MAJOR * 10000 + $PACKAGE_MINOR * 100 + $PACKAGE_LEAST)) +AC_SUBST(ECL_VERSION_NUMBER) + dnl ---------------------------------------------------------------------- dnl Deactivate floating point exceptions if asked to if test "${with_fpe}" != yes; then diff --git a/src/h/config.h.in b/src/h/config.h.in index c884603de..ebfb9978a 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -39,6 +39,9 @@ # define ECL_API #endif +/* Decimal number made with the formula yymmvv */ +#define ECL_VERSION_NUMBER @ECL_VERSION_NUMBER@ + /* * FEATURES LINKED IN */ From af158f819aefe7b0d38a054c8fb232b6edc6893d Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Feb 2009 12:45:54 +0100 Subject: [PATCH 09/13] CLX registers itself with *MODULES* and requires SOCKETS. Split SOCKETS's package definition into a different file so that CLX can load it before being compiled. --- contrib/sockets/package.lisp | 24 ++++++++++++++++ contrib/sockets/sockets.lisp | 12 -------- src/CHANGELOG | 3 ++ src/clx/package.lisp | 5 ++-- src/compile.lsp.in | 55 ++++++++++++++++++++---------------- 5 files changed, 61 insertions(+), 38 deletions(-) create mode 100644 contrib/sockets/package.lisp diff --git a/contrib/sockets/package.lisp b/contrib/sockets/package.lisp new file mode 100644 index 000000000..7f0f0223d --- /dev/null +++ b/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")) diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 1bc055751..467d8e01a 100644 --- a/contrib/sockets/sockets.lisp +++ b/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 diff --git a/src/CHANGELOG b/src/CHANGELOG index 1aa9f13de..a439f6bd1 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -61,6 +61,9 @@ ECL 9.1.0: - 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. diff --git a/src/clx/package.lisp b/src/clx/package.lisp index af010bed4..04f91135b 100644 --- a/src/clx/package.lisp +++ b/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) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 7a9bf783a..284594715 100644 --- a/src/compile.lsp.in +++ b/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,35 @@ ;;; #+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"))) + (with-open-file (s "build:clx;module.lisp" :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")) From b119ac598fbc6d853b11f1295f2a4451497c747d Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Feb 2009 15:05:54 +0100 Subject: [PATCH 10/13] A missing conditional caused buffer-read-default to be defined twice. --- src/clx/dependent.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/clx/dependent.lisp b/src/clx/dependent.lisp index 55c8bc51a..8ffbf01cc 100644 --- a/src/clx/dependent.lisp +++ b/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) From 9f0c747feadf77709c122e40974f46bffb9140f5 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Feb 2009 15:06:35 +0100 Subject: [PATCH 11/13] Use default display when HOST = NIL --- src/clx/demo/hello.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/clx/demo/hello.lisp b/src/clx/demo/hello.lisp index a3fbd88d8..8b1a710dd 100644 --- a/src/clx/demo/hello.lisp +++ b/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)) From 314e849c6a0cae9155d837d081409a3c3cba87ef Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Feb 2009 15:07:09 +0100 Subject: [PATCH 12/13] Remove unused definitions. Fix io_file_read/write. --- src/c/file.d | 28 ++++------------------------ 1 file changed, 4 insertions(+), 24 deletions(-) diff --git a/src/c/file.d b/src/c/file.d index 79c69fabb..ad13ec270 100644 --- a/src/c/file.d +++ b/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 From cd8ad462ae2166554ef81bc3948ef8c97bdb56d4 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Tue, 24 Feb 2009 16:49:41 +0100 Subject: [PATCH 13/13] Ensure that the CLX directory exists before creating module.lsp --- src/compile.lsp.in | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 284594715..28645d734 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -230,9 +230,11 @@ "build:clx;module.lisp")) #+:msvc (c::*cc-flags* (concatenate 'string c::*cc-flags* " -Zm150"))) - (with-open-file (s "build:clx;module.lisp" :direction :output :if-exists :overwrite - :if-does-not-exist :create) - (print '(provide :clx) s)) + (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+)