diff --git a/contrib/sockets/sockets.lisp b/contrib/sockets/sockets.lisp index 6bc2a5865..f3f6cbfee 100644 --- a/contrib/sockets/sockets.lisp +++ b/contrib/sockets/sockets.lisp @@ -86,10 +86,14 @@ " { WSADATA wsadata; + cl_object output; + ecl_disable_interrupts(); if (WSAStartup(MAKEWORD(2,2), &wsadata) == NO_ERROR) - @(return) = Ct; + output = Ct; else - @(return) = Cnil; + output = Cnil; + ecl_enable_interrupts(); + @(return output) }") (setf +wsock-initialized+ t) (error "Unable to initialize Windows Socket library")))) @@ -121,10 +125,10 @@ ;; Foreign functions -(defentry ff-socket (:int :int :int) (:int "socket")) -(defentry ff-listen (:int :int) (:int "listen")) -(defentry ff-close (:int) (:int "close")) -#+:wsock (defentry ff-closesocket (:int) (:int "closesocket")) +(defentry ff-socket (:int :int :int) (:int "socket") :no-interrupts t) +(defentry ff-listen (:int :int) (:int "listen") :no-interrupts t) +(defentry ff-close (:int) (:int "close") :no-interrupts t) +#+:wsock (defentry ff-closesocket (:int) (:int "closesocket") :no-interrupts t) ;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100 ;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de> @@ -236,7 +240,9 @@ weird stuff - see gethostbyname(3) for grisly details." vector[1] = fixint(ecl_aref(#0,1)); vector[2] = fixint(ecl_aref(#0,2)); vector[3] = fixint(ecl_aref(#0,3)); + ecl_disable_interrupts(); hostent = gethostbyaddr(vector,4,AF_INET); + ecl_enable_interrupts(); if (hostent != NULL) { char **aliases; @@ -479,9 +485,12 @@ safe_buffer_pointer(cl_object x, cl_index size) ( #4 ? MSG_PEEK : 0 ) | ( #5 ? MSG_WAITALL : 0 ); cl_type type = type_of(#1); + ssize_t len; - ssize_t len = recvfrom(#0, safe_buffer_pointer(#1, #2), - #2, flags, NULL,NULL); + ecl_disable_interrupts(); + len = recvfrom(#0, safe_buffer_pointer(#1, #2), + #2, flags, NULL,NULL); + ecl_enable_interrupts(); if (len >= 0) { if (type == t_vector) { #1->vector.fillp = len; } else if (type == t_base_string) { #1->base_string.fillp = len; } @@ -568,9 +577,12 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, " { struct sockaddr_in sockaddr; - + int output; + ecl_disable_interrupts(); fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4); - @(return) = bind(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + output = bind(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + ecl_enable_interrupts(); + @(return) = output; }" :side-effects t)) (socket-error "bind")))) @@ -582,7 +594,11 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, "{ struct sockaddr_in sockaddr; socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_in); - int new_fd = accept(#0, (struct sockaddr*)&sockaddr, &addr_len); + int new_fd; + + ecl_disable_interrupts(); + new_fd = accept(#0, (struct sockaddr*)&sockaddr, &addr_len); + ecl_enable_interrupts(); @(return 0) = new_fd; @(return 1) = Cnil; @@ -621,9 +637,14 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, " { struct sockaddr_in sockaddr; + int output; + ecl_disable_interrupts(); fill_inet_sockaddr(&sockaddr, #0, #1, #2, #3, #4); - @(return) = connect(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + output = connect(#5,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + ecl_enable_interrupts(); + + @(return) = output; }")) (socket-error "connect")))) @@ -634,7 +655,11 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, "@01;{ struct sockaddr_in name; socklen_t len = sizeof(struct sockaddr_in); - int ret = getpeername(#0,(struct sockaddr*)&name,&len); + int ret; + + ecl_disable_interrupts(); + ret = getpeername(#0,(struct sockaddr*)&name,&len); + ecl_enable_interrupts(); if (ret == 0) { uint32_t ip = ntohl(name.sin_addr.s_addr); @@ -661,7 +686,11 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, "@01;{ struct sockaddr_in name; socklen_t len = sizeof(struct sockaddr_in); - int ret = getsockname(#0,(struct sockaddr*)&name,&len); + int ret; + + ecl_disable_interrupts(); + ret = getsockname(#0,(struct sockaddr*)&name,&len); + ecl_enable_interrupts(); if (ret == 0) { uint32_t ip = ntohl(name.sin_addr.s_addr); @@ -721,11 +750,12 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, struct sockaddr_in sockaddr; ssize_t len; + ecl_disable_interrupts(); fill_inet_sockaddr(&sockaddr, #3, #4, #5, #6, #7); - len = sendto(#0, safe_buffer_pointer(#1,#2), #2, flags,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_in)); + ecl_enable_interrupts(); @(return) = len; } " @@ -744,8 +774,10 @@ static void fill_inet_sockaddr(struct sockaddr_in *sockaddr, int port, ( #7 ? MSG_NOSIGNAL : 0 ) | ( #8 ? MSG_CONFIRM : 0 ); cl_type type = type_of(#1); - - ssize_t len = send(#0, safe_buffer_pointer(#1,#2), #2, flags); + ssize_t len; + ecl_disable_interrupts(); + len = send(#0, safe_buffer_pointer(#1,#2), #2, flags); + ecl_enable_interrupts(); @(return) = len; } " @@ -779,7 +811,7 @@ also known as unix-domain sockets.")) { struct sockaddr_un sockaddr; size_t size; - + int output; #ifdef BSD sockaddr.sun_len = sizeof(struct sockaddr_un); #endif @@ -787,7 +819,11 @@ also known as unix-domain sockets.")) strncpy(sockaddr.sun_path,#1,sizeof(sockaddr.sun_path)); sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = '\0'; - @(return) = bind(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); + ecl_disable_interrupts(); + output = bind(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); + ecl_enable_interrupts(); + + @(return) = output; }")) (socket-error "bind")))) @@ -797,7 +833,10 @@ also known as unix-domain sockets.")) "{ struct sockaddr_un sockaddr; socklen_t addr_len = (socklen_t)sizeof(struct sockaddr_un); - int new_fd = accept(#0, (struct sockaddr *)&sockaddr, &addr_len); + int new_fd; + ecl_disable_interrupts(); + new_fd = accept(#0, (struct sockaddr *)&sockaddr, &addr_len); + ecl_enable_interrupts(); @(return 0) = new_fd; @(return 1) = (new_fd == -1) ? Cnil : make_base_string_copy(sockaddr.sun_path); }") @@ -822,7 +861,7 @@ also known as unix-domain sockets.")) " { struct sockaddr_un sockaddr; - + int output; #ifdef BSD sockaddr.sun_len = sizeof(struct sockaddr_un); #endif @@ -830,7 +869,11 @@ also known as unix-domain sockets.")) strncpy(sockaddr.sun_path,#2,sizeof(sockaddr.sun_path)); sockaddr.sun_path[sizeof(sockaddr.sun_path)-1] = '\0'; - @(return) = connect(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); + ecl_disable_interrupts(); + output = connect(#0,(struct sockaddr*)&sockaddr, sizeof(struct sockaddr_un)); + ecl_enable_interrupts(); + + @(return) = output; }")) (socket-error "connect")))) @@ -841,7 +884,11 @@ also known as unix-domain sockets.")) { struct sockaddr_un name; socklen_t len = sizeof(struct sockaddr_un); - int ret = getpeername(#0,(struct sockaddr*)&name,&len); + int ret; + + ecl_disable_interrupts(); + ret = getpeername(#0,(struct sockaddr*)&name,&len); + ecl_enable_interrupts(); if (ret == 0) { @(return) = make_base_string_copy(name.sun_path); @@ -952,7 +999,9 @@ also known as unix-domain sockets.")) (hnd (c-inline (pipe-name) (:cstring) :int " { - HANDLE hnd = CreateNamedPipe( + HANDLE hnd; + ecl_disable_interrupts(); + hnd = CreateNamedPipe( #0, PIPE_ACCESS_DUPLEX, PIPE_TYPE_BYTE | PIPE_READMODE_BYTE | PIPE_WAIT, @@ -961,6 +1010,7 @@ also known as unix-domain sockets.")) 4096, NMPWAIT_USE_DEFAULT_WAIT, NULL); + ecl_enable_interrupts(); if (hnd == INVALID_HANDLE_VALUE) @(return) = -1; else @@ -977,10 +1027,12 @@ also known as unix-domain sockets.")) " { HANDLE hnd = _get_osfhandle(#0), dupHnd; + ecl_disable_interrupts(); if (ConnectNamedPipe(hnd, NULL) != 0 || GetLastError() == ERROR_PIPE_CONNECTED) { @(return) = #0; } else @(return) = -1; + ecl_enable_interrupts(); }" :one-liner nil))) (cond @@ -1006,7 +1058,9 @@ also known as unix-domain sockets.")) (c-inline (pipe-name) (:cstring) :int " { - HANDLE hnd = CreateFile( + HANDLE hnd; + ecl_disable_interrupts(); + hnd = CreateFile( #0, GENERIC_READ | GENERIC_WRITE, 0, @@ -1018,6 +1072,7 @@ also known as unix-domain sockets.")) @(return) = -1; else @(return) = _open_osfhandle(hnd, O_RDWR); + ecl_enable_interrupts(); }"))) (socket-error "connect") (setf (slot-value socket 'pipe-name) pipe-name)))) @@ -1032,7 +1087,9 @@ also known as unix-domain sockets.")) " { DWORD mode = PIPE_READMODE_BYTE | (#1 == Ct ? PIPE_NOWAIT : PIPE_WAIT); + ecl_disable_interrupts(); @(return) = SetNamedPipeHandleState(_get_osfhandle(#0), &mode, NULL, NULL); + ecl_enable_interrupts(); }" :one-liner nil)) (socket-error "SetNamedPipeHandleState") @@ -1044,12 +1101,14 @@ also known as unix-domain sockets.")) " { DWORD flags; + ecl_disable_interrupts(); if (!GetNamedPipeInfo(_get_osfhandle(#0), &flags, NULL, NULL, NULL)) @(return) = Cnil; if (flags == PIPE_CLIENT_END || DisconnectNamedPipe(_get_osfhandle(#0))) @(return) = Ct; else @(return) = Cnil; + ecl_enable_interrupts(); }" :one-liner nil) (socket-error "DisconnectNamedPipe")) @@ -1078,7 +1137,9 @@ also known as unix-domain sockets.")) " { int blocking_flag = (#1 ? 1 : 0); + ecl_disable_interrupts(); @(return) = ioctlsocket(#0, FIONBIO, (u_long*)&blocking_flag); + ecl_enable_interrupts(); }" #-:wsock " @@ -1086,7 +1147,9 @@ also known as unix-domain sockets.")) int oldflags = fcntl(#0,F_GETFL,NULL); int newflags = (oldflags & ~O_NONBLOCK) | (#1 ? O_NONBLOCK : 0); + ecl_disable_interrupts(); @(return) = fcntl(#0,F_SETFL,newflags); + ecl_enable_interrupts(); }")) (socket-error #-:wsock "fcntl" #+:wsock "ioctlsocket") #-:wsock non-blocking-p @@ -1119,7 +1182,7 @@ also known as unix-domain sockets.")) buffering) (t :int :int :object) t - "si_set_buffering_mode(ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2), #3)" + "si_set_buffering_mode(ecl_make_stream_from_fd(#0,#1,(enum ecl_smmode)#2,8,1), #3)" :one-liner t)) (defmethod socket-make-stream ((socket socket) &rest args &key (buffering-mode NIL)) @@ -1164,6 +1227,7 @@ also known as unix-domain sockets.")) (c-inline (num) (:int) t "{char *lpMsgBuf; cl_object msg; + ecl_disable_interrupts(); FormatMessage( FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM, NULL, @@ -1174,6 +1238,7 @@ also known as unix-domain sockets.")) NULL); msg = make_base_string_copy(lpMsgBuf); LocalFree(lpMsgBuf); + ecl_enable_interrupts(); @(return) = msg;}" :one-liner nil)) @@ -1324,9 +1389,12 @@ GET-NAME-SERVICE-ERRNO") (defun get-sockopt-int (fd const) (let ((ret (c-inline (fd const) (:int :int) t "{ - int sockopt; + int sockopt, ret; socklen_t socklen = sizeof(int); - int ret = getsockopt(#0,SOL_SOCKET,#1,&sockopt,&socklen); + + ecl_disable_interrupts(); + ret = getsockopt(#0,SOL_SOCKET,#1,&sockopt,&socklen); + ecl_enable_interrupts(); @(return) = (ret == 0) ? ecl_make_integer(sockopt) : Cnil; }"))) @@ -1338,9 +1406,12 @@ GET-NAME-SERVICE-ERRNO") (defun get-sockopt-bool (fd const) (let ((ret (c-inline (fd const) (:int :int) t "{ - int sockopt; + int sockopt, ret; socklen_t socklen = sizeof(int); - int ret = getsockopt(#0,SOL_SOCKET,#1,&sockopt,&socklen); + + ecl_disable_interrupts(); + ret = getsockopt(#0,SOL_SOCKET,#1,&sockopt,&socklen); + ecl_enable_interrupts(); @(return) = (ret == 0) ? Ct : Cnil; }"))) @@ -1358,7 +1429,11 @@ GET-NAME-SERVICE-ERRNO") "{ struct timeval tv; socklen_t socklen = sizeof(struct timeval); - int ret = getsockopt(#0,SOL_SOCKET,#1,&tv,&socklen); + int ret; + + ecl_disable_interrupts(); + ret = getsockopt(#0,SOL_SOCKET,#1,&tv,&socklen); + ecl_enable_interrupts(); @(return) = (ret == 0) ? ecl_make_doublefloat((double)tv.tv_sec + ((double)tv.tv_usec) / 1000000.0) : Cnil; @@ -1371,7 +1446,12 @@ GET-NAME-SERVICE-ERRNO") (let ((ret (c-inline (fd const value) (:int :int :int) t "{ int sockopt = #2; - int ret = setsockopt(#0,SOL_SOCKET,#1,&sockopt,sizeof(int)); + int ret; + + ecl_disable_interrupts(); + ret = setsockopt(#0,SOL_SOCKET,#1,&sockopt,sizeof(int)); + ecl_enable_interrupts(); + @(return) = (ret == 0) ? Ct : Cnil; }"))) (if ret @@ -1382,7 +1462,12 @@ GET-NAME-SERVICE-ERRNO") (let ((ret (c-inline (fd const value) (:int :int :object) t "{ int sockopt = (#2 == Cnil) ? 0 : 1; - int ret = setsockopt(#0,SOL_SOCKET,#1,&sockopt,sizeof(int)); + int ret; + + ecl_disable_interrupts(); + ret = setsockopt(#0,SOL_SOCKET,#1,&sockopt,sizeof(int)); + ecl_enable_interrupts(); + @(return) = (ret == 0) ? Ct : Cnil; }"))) (if ret @@ -1397,10 +1482,12 @@ GET-NAME-SERVICE-ERRNO") double tmp = #2; int ret; + ecl_disable_interrupts(); tv.tv_sec = (int)tmp; tv.tv_usec = (int)((tmp-floor(tmp))*1000000.0); - ret = setsockopt(#0,SOL_SOCKET,#1,&tv,sizeof(struct timeval)); + ecl_enable_interrupts(); + @(return) = (ret == 0) ? Ct : Cnil; }"))) (if ret diff --git a/msvc/c/Makefile b/msvc/c/Makefile index f4dd95b07..b4acf7c68 100644 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -5,7 +5,7 @@ top_srcdir = ..\..\src srcdir = ..\..\src\c !if "$(ECL_THREADS)" != "" -THREADS_OBJ= threads_win32.obj +THREADS_OBJ= threads.obj THREADS_FLAGS= -DECL_THREADS !else THREADS_OBJ= diff --git a/msvc/ecl/config.h.msvc6 b/msvc/ecl/config.h.msvc6 index 76436a20d..bd345707a 100644 --- a/msvc/ecl/config.h.msvc6 +++ b/msvc/ecl/config.h.msvc6 @@ -196,13 +196,16 @@ typedef unsigned int uint32_t; /* Assembler implementation of APPLY and friends */ /* #undef ECL_ASM_APPLY */ +/* Stack grows downwards */ +#define ECL_DOWN_STACK 1 + +/* Use mprotect for fast interrupt dispatch */ +/* #undef ECL_USE_MPROTECT */ /* * SYSTEM FEATURES: */ -/* Stack grows downwards */ -#define DOWN_STACK 1 /* Arguments cannot be accessed as array */ /* #undef NO_ARGS_ARRAY */ /* Most significant byte first */ diff --git a/src/CHANGELOG b/src/CHANGELOG index 96c5a48d1..cf9055889 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -70,6 +70,22 @@ ECL 8.9.0: - *DEFAULT-PATHNAME-DEFAULTS* is initialized to the value of EXT:GETCWD. + - In an effort to convert all functions to the ecl_* prefix, we are deprecating + names while keeping the old definitions as macros. Look at external.h for + the list of already deprecated names. + + - ECL builds using thread local storage when configured with --with-__thread and + the feature works on that platform. + + - Functions compiled with (OPTIMIZE (SAFETY >= 2)) have an explicit stack + overflow check. + + - Binary streams now can only read or write bytes whose size is a multiple of 8. + + - ECL now has an implicit memory limit of 128Mb, which can be raised using + ecl_set_option(ECL_OPT_HEAP_SIZE, new_limit). Out of memory conditions are + detected and gracefully handled. + - A new command line option, -debug, enables the debugger whenever an error happens. The converse is -nodebug. @@ -77,6 +93,29 @@ ECL 8.9.0: - A new method, STREAM-FILE-POSITION, has been added to the Gray streams package. +* Streams: + + - ECL has now a new and more easily extensible implementation of streams, based + on C structures with a method dispatch table. Apart from code reuse and better + maintainability, this allows a more sensible design of read/write-sequence. + + - *STANDARD-INPUT*, *{STANDARD,ERROR,TRACE}-OUTPUT* are no longer synonyms to + *TERMINAL-IO* but directly the input or output streams associated to stdin, + stdout and stderr. + + - Internally, ECL allows to work with POSIX file descriptors directly, without + using C streams. + + - POSIX files and C streams now support different external formats. ECL + understands right now :UTF-8, :UCS-2 (bigendian), :UCS-4 (bigendian), + :LATIN-1 and :ISO-8859-1. If built _without_ support for Unicode, only the + last two are available. + + - Readtables now include entries for extended characters. + + - When a string is read, if the characters are base-char, the string is read + as a base-string. + * Embedding: - ECL now implements a more transparent interface for setting and querying @@ -101,6 +140,8 @@ ECL 8.9.0: ECL_OPT_C_STACK_SIZE, ECL_OPT_C_STACK_SAFETY_AREA, ECL_OPT_SIGALTSTACK_SIZE, + ECL_OPT_HEAP_SIZE, + ECL_OPT_HEAP_SAFETY_AREA, ECL_OPT_LIMIT - Two new convenience functions, ecl_defparameter() and ecl_defvar. @@ -172,7 +213,7 @@ ECL 8.9.0: (handler-bind ((ext:stack-overflow #'handle-overflow)) (foo 1)))) - - New function (EXT:SET-STACK-SIZE type size) can resize type = + - New function (EXT:SET-LIMIT type size) can resize type = EXT:BINDING-STACK, EXT:LISP-STACK and EXT:FRAME-STACK. - FLOAT-SIGN returns the right value on negative zeros. @@ -212,6 +253,8 @@ ECL 8.9.0: setting (setf *read-suppress* nil) does not prevent the user from entering new commands. + - The routines for printing symbols expected the names to be base strings. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/aclocal.m4 b/src/aclocal.m4 index 9b117e5db..d7c9f1373 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -600,7 +600,6 @@ AC_TRY_COMPILE(,[static __thread void *data;], ac_cv_ecl___thread=yes, ac_cv_ecl___thread=no)) dnl We deactivate this test because it seems to slow down ECL A LOT!!! -ac_cv_ecl___thread=no ]) dnl ---------------------------------------------------------------------- diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index 70cc5e96a..669d8742c 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -39,10 +39,10 @@ cl_index cl_num_symbols_in_core = 0; -static char * -mangle_name(cl_object output, char *source, int l) +static unsigned char * +mangle_name(cl_object output, unsigned char *source, int l) { - char c; + unsigned char c; while (l--) { c = *(source++); @@ -78,7 +78,7 @@ mangle_name(cl_object output, char *source, int l) @(defun si::mangle-name (symbol &optional as_function) cl_index l; - char c, *source, *dest; + unsigned char c, *source, *dest; cl_object output; cl_object package; cl_object found = Cnil; diff --git a/src/c/alloc.d b/src/c/alloc.d index 0617c172b..430718fbc 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -224,7 +224,7 @@ add_page_to_freelist(cl_ptr p, struct typemanager *tm) } cl_object -cl_alloc_object(cl_type t) +ecl_alloc_object(cl_type t) { register cl_object obj; register struct typemanager *tm; @@ -242,7 +242,7 @@ cl_alloc_object(cl_type t) default:; } - start_critical_section(); + ecl_disable_interrupts(); tm = tm_of(t); ONCE_MORE: obj = tm->tm_free; @@ -435,7 +435,7 @@ ONCE_MORE: printf("\ttype = %d\n", t); ecl_internal_error("alloc botch."); } - end_critical_section(); + ecl_enable_interrupts(); return(obj); CALL_GC: ecl_gc(tm->tm_type); @@ -469,7 +469,7 @@ ecl_cons(cl_object a, cl_object d) register cl_ptr p; struct typemanager *tm=(&tm_table[(int)t_cons]); - start_critical_section(); + ecl_disable_interrupts(); ONCE_MORE: obj = tm->tm_free; @@ -494,7 +494,7 @@ ONCE_MORE: obj->cons.car = a; obj->cons.cdr = d; - end_critical_section(); + ecl_enable_interrupts(); return(obj); CALL_GC: @@ -519,20 +519,20 @@ Use ALLOCATE to expand the space.", } cl_object -cl_alloc_instance(cl_index slots) +ecl_alloc_instance(cl_index slots) { - cl_object i = cl_alloc_object(t_instance); + cl_object i = ecl_alloc_object(t_instance); if (slots >= ECL_SLOTS_LIMIT) FEerror("Limit on instance size exceeded: ~S slots requested.", 1, MAKE_FIXNUM(slots)); /* INV: slots > 0 */ - i->instance.slots = (cl_object*)cl_alloc(sizeof(cl_object) * slots); + i->instance.slots = (cl_object*)ecl_alloc(sizeof(cl_object) * slots); i->instance.length = slots; return i; } void * -cl_alloc(cl_index n) +ecl_alloc(cl_index n) { volatile cl_ptr p; struct contblock **cbpp; @@ -542,7 +542,7 @@ cl_alloc(cl_index n) g = FALSE; n = round_up(n); - start_critical_section(); + ecl_disable_interrupts(); ONCE_MORE: /* Use extra indirection so that cb_pointer can be updated */ for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link) @@ -553,7 +553,7 @@ ONCE_MORE: --ncb; cl_dealloc(p+n, i); - end_critical_section(); + ecl_enable_interrupts(); return(p); } m = round_to_page(n); @@ -587,7 +587,7 @@ Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.", ncbpage += m; cl_dealloc(p+n, LISP_PAGESIZE*m - n); - end_critical_section(); + ecl_enable_interrupts(); return memset(p, 0, n); } @@ -620,16 +620,16 @@ cl_dealloc(void *p, cl_index s) * required for the block. */ void * -cl_alloc_align(cl_index size, cl_index align) +ecl_alloc_align(cl_index size, cl_index align) { void *output; - start_critical_section(); + ecl_disable_interrupts(); align--; if (align) - output = (void*)(((cl_index)cl_alloc(size + align) + align - 1) & ~align); + output = (void*)(((cl_index)ecl_alloc(size + align) + align - 1) & ~align); else - output = cl_alloc(size); - end_critical_section(); + output = ecl_alloc(size); + ecl_enable_interrupts(); return output; } @@ -895,7 +895,7 @@ malloc(size_t size) init_alloc(); x = alloc_simple_base_string(size-1); - x->base_string.self = (char *)cl_alloc(size); + x->base_string.self = (char *)ecl_alloc(size); malloc_list = ecl_cons(x, malloc_list); return(x->base_string.self); } @@ -933,7 +933,7 @@ realloc(void *ptr, size_t size) return(ptr); } else { j = x->base_string.dim; - x->base_string.self = (char *)cl_alloc(size); + x->base_string.self = (char *)ecl_alloc(size); x->base_string.fillp = x->base_string.dim = size; memcpy(x->base_string.self, ptr, j); cl_dealloc(ptr, j); diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index da4375bd3..82320b964 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -37,6 +37,24 @@ static void finalize_queued(); * OBJECT ALLOCATION * **********************************************************/ +void +_ecl_set_max_heap_size(cl_index new_size) +{ + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_set_max_heap_size(cl_core.max_heap_size = new_size); + ecl_enable_interrupts_env(the_env); +} + +static void +out_of_memory(cl_env_ptr the_env) +{ + the_env->string_pool = Cnil; + _ecl_set_max_heap_size(cl_core.max_heap_size + + ecl_get_option(ECL_OPT_HEAP_SAFETY_AREA)); + cl_error(1, @'ext::storage-exhausted'); +} + #ifdef alloc_object #undef alloc_object #endif @@ -44,9 +62,9 @@ static void finalize_queued(); static size_t type_size[t_end]; cl_object -cl_alloc_object(cl_type t) +ecl_alloc_object(cl_type t) { - cl_object obj; + const cl_env_ptr the_env = ecl_process_env(); /* GC_MALLOC already resets objects */ switch (t) { @@ -54,18 +72,6 @@ cl_alloc_object(cl_type t) return MAKE_FIXNUM(0); /* Immediate fixnum */ case t_character: return CODE_CHAR(' '); /* Immediate character */ - case t_codeblock: - obj = (cl_object)GC_MALLOC(sizeof(struct ecl_codeblock)); - obj->cblock.locked = 0; - obj->cblock.links = Cnil; - obj->cblock.name = Cnil; - obj->cblock.next = Cnil; - obj->cblock.data_text = NULL; - obj->cblock.data = NULL; - obj->cblock.data_text_size = 0; - obj->cblock.data_size = 0; - obj->cblock.handle = NULL; - break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: #endif @@ -73,9 +79,17 @@ cl_alloc_object(cl_type t) case t_longfloat: #endif case t_singlefloat: - case t_doublefloat: + case t_doublefloat: { + cl_object obj; + ecl_disable_interrupts_env(the_env); obj = (cl_object)GC_MALLOC_ATOMIC(type_size[t]); + ecl_enable_interrupts_env(the_env); + if (obj != NULL) { + obj->d.t = t; + return obj; + } break; + } case t_bignum: case t_ratio: case t_complex: @@ -109,14 +123,23 @@ cl_alloc_object(cl_type t) case t_condition_variable: #endif case t_foreign: + case t_codeblock: { + cl_object obj; + ecl_disable_interrupts_env(the_env); obj = (cl_object)GC_MALLOC(type_size[t]); + ecl_enable_interrupts_env(the_env); + if (obj != NULL) { + obj->d.t = t; + return obj; + } break; + } default: printf("\ttype = %d\n", t); ecl_internal_error("alloc botch."); } - obj->d.t = t; - return obj; + out_of_memory(the_env); + return OBJNULL; } #ifdef make_cons @@ -126,7 +149,12 @@ cl_alloc_object(cl_type t) cl_object ecl_cons(cl_object a, cl_object d) { - struct ecl_cons *obj = GC_MALLOC(sizeof(struct ecl_cons)); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); + if (obj == NULL) out_of_memory(the_env); #ifdef ECL_SMALL_CONS obj->car = a; obj->cdr = d; @@ -142,7 +170,12 @@ ecl_cons(cl_object a, cl_object d) cl_object ecl_list1(cl_object a) { - struct ecl_cons *obj = GC_MALLOC(sizeof(struct ecl_cons)); + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_cons *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC(sizeof(struct ecl_cons)); + ecl_enable_interrupts_env(the_env); + if (obj == NULL) out_of_memory(the_env); #ifdef ECL_SMALL_CONS obj->car = a; obj->cdr = Cnil; @@ -156,11 +189,11 @@ ecl_list1(cl_object a) } cl_object -cl_alloc_instance(cl_index slots) +ecl_alloc_instance(cl_index slots) { cl_object i; - i = cl_alloc_object(t_instance); - i->instance.slots = (cl_object *)cl_alloc(sizeof(cl_object) * slots); + i = ecl_alloc_object(t_instance); + i->instance.slots = (cl_object *)ecl_alloc(sizeof(cl_object) * slots); i->instance.length = slots; return i; } @@ -168,13 +201,55 @@ cl_alloc_instance(cl_index slots) void * ecl_alloc_uncollectable(size_t size) { - return GC_MALLOC_UNCOLLECTABLE(size); + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = GC_MALLOC_UNCOLLECTABLE(size); + ecl_enable_interrupts_env(the_env); + if (output == NULL) out_of_memory(the_env); + return output; } void ecl_free_uncollectable(void *pointer) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); GC_FREE(pointer); + ecl_enable_interrupts_env(the_env); +} + +void * +ecl_alloc(cl_index n) +{ + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = GC_MALLOC_IGNORE_OFF_PAGE(n); + ecl_enable_interrupts_env(the_env); + if (output == NULL) out_of_memory(the_env); + return output; +} + +void * +ecl_alloc_atomic(cl_index n) +{ + const cl_env_ptr the_env = ecl_process_env(); + void *output; + ecl_disable_interrupts_env(the_env); + output = GC_MALLOC_ATOMIC_IGNORE_OFF_PAGE(n); + ecl_enable_interrupts_env(the_env); + if (output == NULL) out_of_memory(the_env); + return output; +} + +void +ecl_dealloc(void *ptr) +{ + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); + GC_FREE(ptr); + ecl_enable_interrupts_env(the_env); } static int alloc_initialized = FALSE; @@ -214,6 +289,7 @@ init_alloc(void) #endif GC_clear_roots(); GC_disable(); + GC_set_max_heap_size(cl_core.max_heap_size = ecl_get_option(ECL_OPT_HEAP_SIZE)); #define init_tm(x,y,z) type_size[x] = (z) for (i = 0; i < t_end; i++) { @@ -287,20 +363,28 @@ standard_finalizer(cl_object o) cl_close(1, o); break; #ifdef ECL_THREADS - case t_lock: + case t_lock: { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); #if defined(_MSC_VER) || defined(mingw32) CloseHandle(o->lock.mutex); #else pthread_mutex_destroy(&o->lock.mutex); #endif + ecl_enable_interrupts_env(the_env); break; - case t_condition_variable: + } + case t_condition_variable: { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); #if defined(_MSC_VER) || defined(mingw32) CloseHandle(o->condition_variable.cv); #else pthread_cond_destroy(&o->condition_variable.cv); #endif + ecl_enable_interrupts_env(the_env); break; + } #endif default:; } @@ -338,10 +422,13 @@ queueing_finalizer(cl_object o, cl_object finalizer) volatile cl_object aux = ACONS(o, finalizer, Cnil); cl_object l = cl_core.to_be_finalized; if (ATOM(l)) { + const cl_env_ptr the_env = ecl_process_env(); GC_finalization_proc ofn; void *odata; cl_core.to_be_finalized = aux; + ecl_disable_interrupts_env(the_env); GC_register_finalizer_no_order(aux, (GC_finalization_proc*)group_finalizer, NULL, &ofn, &odata); + ecl_enable_interrupts_env(the_env); } else { ECL_RPLACD(aux, ECL_CONS_CDR(l)); ECL_RPLACD(l, aux); @@ -353,9 +440,11 @@ queueing_finalizer(cl_object o, cl_object finalizer) cl_object si_get_finalizer(cl_object o) { + const cl_env_ptr the_env = ecl_process_env(); cl_object output; GC_finalization_proc ofn; void *odata; + ecl_disable_interrupts_env(the_env); GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); if (ofn == 0) { output = Cnil; @@ -365,25 +454,30 @@ si_get_finalizer(cl_object o) output = Cnil; } GC_register_finalizer_no_order(o, ofn, odata, &ofn, &odata); + ecl_enable_interrupts_env(the_env); @(return output) } cl_object si_set_finalizer(cl_object o, cl_object finalizer) { + const cl_env_ptr the_env = ecl_process_env(); GC_finalization_proc ofn; void *odata; + ecl_disable_interrupts_env(the_env); if (finalizer == Cnil) { GC_register_finalizer_no_order(o, (GC_finalization_proc)0, 0, &ofn, &odata); } else { GC_register_finalizer_no_order(o, (GC_finalization_proc)queueing_finalizer, finalizer, &ofn, &odata); } + ecl_enable_interrupts_env(the_env); @(return) } cl_object si_gc_stats(cl_object enable) { + const cl_env_ptr the_env = ecl_process_env(); cl_object old_status = cl_core.gc_stats? Ct : Cnil; cl_core.gc_stats = (enable != Cnil); if (cl_core.bytes_consed == Cnil) { @@ -391,9 +485,9 @@ si_gc_stats(cl_object enable) cl_core.bytes_consed = MAKE_FIXNUM(0); cl_core.gc_counter = MAKE_FIXNUM(0); #else - cl_core.bytes_consed = cl_alloc_object(t_bignum); + cl_core.bytes_consed = ecl_alloc_object(t_bignum); mpz_init2(cl_core.bytes_consed->big.big_num, 128); - cl_core.gc_counter = cl_alloc_object(t_bignum); + cl_core.gc_counter = ecl_alloc_object(t_bignum); mpz_init2(cl_core.gc_counter->big.big_num, 128); #endif } @@ -471,26 +565,15 @@ ecl_mark_env(struct cl_env_struct *env) GC_set_mark_bit((void *)env->bds_org); } #endif -#if 0 - GC_push_all(&(env->lex_env), &(env->lex_env)+1); - GC_push_all(&(env->string_pool), &(env->print_base)); -#if !defined(ECL_CMU_FORMAT) - GC_push_all(&(env->queue), &(env->qh)); -#endif - GC_push_all(env->big_register, env->big_register + 3); - if (env->nvalues) - GC_push_all(env->values, env->values + env->nvalues + 1); -#else /*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/ -#ifdef ECL_THREADS +#if defined(ECL_THREADS) && !defined(ECL_USE_MPROTECT) /* When using threads, "env" is a pointer to memory allocated by ECL. */ GC_push_conditional((void *)env, (void *)(env + 1), 1); GC_set_mark_bit((void *)env); #else - /* When not using threads, "env" is a statically allocated structure. */ + /* When not using threads, "env" is mmaped or statically allocated. */ GC_push_all((void *)env, (void *)(env + 1)); #endif -#endif } static void @@ -499,15 +582,13 @@ stacks_scanner() cl_object l; l = cl_core.libraries; if (l) { - int i; - for (i = 0; i < l->vector.fillp; i++) { - cl_object dll = l->vector.self.t[i]; + for (; l != Cnil; l = ECL_CONS_CDR(l)) { + cl_object dll = ECL_CONS_CAR(l); if (dll->cblock.locked) { GC_push_conditional((void *)dll, (void *)(&dll->cblock + 1), 1); GC_set_mark_bit((void *)dll); } } - GC_set_mark_bit((void *)l->vector.self.t); } GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); @@ -530,71 +611,6 @@ stacks_scanner() (*old_GC_push_other_roots)(); } -/********************************************************** - * MALLOC SUBSTITUTION * - **********************************************************/ - -#if 0 && defined(NEED_MALLOC) -#undef malloc -#undef calloc -#undef free -#undef cfree -#undef realloc - -void * -malloc(size_t size) -{ - return GC_MALLOC(size); -} - -void -free(void *ptr) -{ - GC_free(ptr); -} - -void * -realloc(void *ptr, size_t size) -{ - return GC_realloc(ptr, size); -} - -void * -calloc(size_t nelem, size_t elsize) -{ - char *ptr; - size_t i; - ptr = GC_MALLOC(i = nelem*elsize); - memset(ptr, 0 , i); - return ptr; -} - -void -cfree(void *ptr) -{ - GC_free(ptr); -} - -#define ALLOC_ALIGNED(f, size, align) \ - ((align) <= 4 ? (int)(f)(size) : \ - ((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align)))) - -void * -memalign(size_t align, size_t size) -{ - return (void *)ALLOC_ALIGNED(GC_MALLOC, size, align); -} - -# ifdef WANT_VALLOC -char * -valloc(size_t size) -{ - return memalign(getpagesize(), size); -} -# endif /* WANT_VALLOC */ -#endif /* NEED_MALLOC */ - - /********************************************************** * GARBAGE COLLECTION * **********************************************************/ @@ -602,20 +618,29 @@ valloc(size_t size) void ecl_register_root(cl_object *p) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); GC_add_roots((char*)p, (char*)(p+1)); + ecl_enable_interrupts_env(the_env); } cl_object si_gc(cl_object area) { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); GC_gcollect(); + ecl_enable_interrupts_env(the_env); @(return) } cl_object si_gc_dump() { + const cl_env_ptr the_env = ecl_process_env(); + ecl_disable_interrupts_env(the_env); GC_dump(); + ecl_enable_interrupts_env(the_env); @(return) } diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index d86534c8e..a4fe8eb6e 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -116,8 +116,9 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) cl_index i, size; union ecl_ffi_values output; enum ecl_ffi_tag tag; + cl_env_ptr env = ecl_process_env(); - ECL_BUILD_STACK_FRAME(frame, aux); + ECL_BUILD_STACK_FRAME(env, frame, aux); fun = CAR(cbk_info); rtype = CADR(cbk_info); @@ -207,7 +208,7 @@ ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_typ * nop 90 * nop 90 */ - char *buf = (char*)cl_alloc_atomic_align(sizeof(char)*16, 4); + char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*16, 4); *(char*) (buf+0) = 0x54; *(char*) (buf+1) = 0x68; *(long*) (buf+2) = (long)data; diff --git a/src/c/arch/ffi_x86_64.d b/src/c/arch/ffi_x86_64.d index 56c75c023..b8667e0fe 100644 --- a/src/c/arch/ffi_x86_64.d +++ b/src/c/arch/ffi_x86_64.d @@ -31,7 +31,7 @@ struct ecl_fficall_reg * ecl_fficall_prepare_extra(struct ecl_fficall_reg *registers) { if (registers == 0) { - registers = cl_alloc_atomic_align(sizeof(*registers), sizeof(long)); + registers = ecl_alloc_atomic_align(sizeof(*registers), sizeof(long)); } registers->int_registers_size = 0; registers->fp_registers_size = 0; @@ -165,8 +165,9 @@ ecl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i enum ecl_ffi_tag tag; long i_reg[MAX_INT_REGISTERS]; double f_reg[MAX_FP_REGISTERS]; + cl_env_ptr env = ecl_process_env(); - ECL_BUILD_STACK_FRAME(frame, aux); + ECL_BUILD_STACK_FRAME(env, frame, aux); fun = CAR(cbk_info); rtype = CADR(cbk_info); @@ -276,7 +277,7 @@ ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_convention cc_typ * nop 90 * nop 90 */ - char *buf = (char*)cl_alloc_atomic_align(sizeof(char)*32, 8); + char *buf = (char*)ecl_alloc_atomic_align(sizeof(char)*32, 8); *(char*) (buf+0) = 0x55; *(char*) (buf+1) = 0x54; *(short*)(buf+2) = 0xb848; diff --git a/src/c/array.d b/src/c/array.d index 0bb0cece3..ceec04939 100644 --- a/src/c/array.d +++ b/src/c/array.d @@ -335,12 +335,12 @@ si_make_pure_array(cl_object etype, cl_object dims, cl_object adj, FEerror(":FILL-POINTER may not be specified for an array of rank ~D", 1, MAKE_FIXNUM(r)); } - x = cl_alloc_object(t_array); + x = ecl_alloc_object(t_array); x->array.displaced = Cnil; x->array.self.t = NULL; /* for GC sake */ x->array.rank = r; x->array.elttype = (short)ecl_symbol_to_elttype(etype); - x->array.dims = (cl_index *)cl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); + x->array.dims = (cl_index *)ecl_alloc_atomic_align(sizeof(cl_index)*r, sizeof(cl_index)); for (i = 0, s = 1; i < r; i++, dims = ECL_CONS_CDR(dims)) { j = ecl_fixnum_in_range(@'make-array', "dimension", ECL_CONS_CAR(dims), 0, ADIMLIM); @@ -374,15 +374,15 @@ si_make_vector(cl_object etype, cl_object dim, cl_object adj, aet = ecl_symbol_to_elttype(etype); d = ecl_fixnum_in_range(@'make-array',"dimension",dim,0,ADIMLIM); if (aet == aet_bc) { - x = cl_alloc_object(t_base_string); + x = ecl_alloc_object(t_base_string); } else if (aet == aet_bit) { - x = cl_alloc_object(t_bitvector); + x = ecl_alloc_object(t_bitvector); #ifdef ECL_UNICODE } else if (aet == aet_ch) { - x = cl_alloc_object(t_string); + x = ecl_alloc_object(t_string); #endif } else { - x = cl_alloc_object(t_vector); + x = ecl_alloc_object(t_vector); x->vector.elttype = (short)aet; } x->vector.self.t = NULL; /* for GC sake */ @@ -419,12 +419,11 @@ ecl_array_allocself(cl_object x) cl_index i, d; d = x->array.dim; - start_critical_section(); /* avoid losing elts */ switch (ecl_array_elttype(x)) { /* assign self field only after it has been filled, for GC sake */ case aet_object: { cl_object *elts; - elts = (cl_object *)cl_alloc_align(sizeof(cl_object)*d, sizeof(cl_object)); + elts = (cl_object *)ecl_alloc_align(sizeof(cl_object)*d, sizeof(cl_object)); for (i = 0; i < d; i++) elts[i] = Cnil; x->array.self.t = elts; @@ -433,7 +432,7 @@ ecl_array_allocself(cl_object x) #ifdef ECL_UNICODE case aet_ch: { cl_object *elts; - elts = (cl_object *)cl_alloc_align(sizeof(cl_object)*d, sizeof(cl_object)); + elts = (cl_object *)ecl_alloc_align(sizeof(cl_object)*d, sizeof(cl_object)); for (i = 0; i < d; i++) elts[i] = CODE_CHAR(' '); x->string.self = elts; @@ -441,8 +440,7 @@ ecl_array_allocself(cl_object x) } #endif case aet_bc: { - char *elts; - elts = (char *)cl_alloc_atomic(d+1); + unsigned char *elts = (unsigned char *)ecl_alloc_atomic(d+1); for (i = 0; i < d; i++) elts[i] = ' '; elts[d] = '\0'; @@ -452,7 +450,7 @@ ecl_array_allocself(cl_object x) case aet_bit: { byte *elts; d = (d+(CHAR_BIT-1))/CHAR_BIT; - elts = (byte *)cl_alloc_atomic(d); + elts = (byte *)ecl_alloc_atomic(d); for (i = 0; i < d; i++) elts[i] = '\0'; x->vector.offset = 0; @@ -461,7 +459,7 @@ ecl_array_allocself(cl_object x) } case aet_fix: { cl_fixnum *elts; - elts = (cl_fixnum *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (cl_fixnum *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0; x->array.self.fix = elts; @@ -469,7 +467,7 @@ ecl_array_allocself(cl_object x) } case aet_index: { cl_fixnum *elts; - elts = (cl_fixnum *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (cl_fixnum *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0; x->array.self.fix = elts; @@ -477,7 +475,7 @@ ecl_array_allocself(cl_object x) } case aet_sf: { float *elts; - elts = (float *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (float *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0.0; x->array.self.sf = elts; @@ -485,7 +483,7 @@ ecl_array_allocself(cl_object x) } case aet_df: { double *elts; - elts = (double *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (double *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0.0; x->array.self.df = elts; @@ -493,7 +491,7 @@ ecl_array_allocself(cl_object x) } case aet_b8: { uint8_t *elts; - elts = (uint8_t *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (uint8_t *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0; x->array.self.b8 = elts; @@ -501,14 +499,13 @@ ecl_array_allocself(cl_object x) } case aet_i8: { int8_t *elts; - elts = (int8_t *)cl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); + elts = (int8_t *)ecl_alloc_atomic_align(sizeof(*elts)*d, sizeof(*elts)); for (i = 0; i < d; i++) elts[i] = 0; x->array.self.i8 = elts; break; } } - end_critical_section(); } cl_elttype @@ -738,6 +735,7 @@ cl_adjustable_array_p(cl_object a) cl_object cl_array_displacement(cl_object a) { + const cl_env_ptr the_env = ecl_process_env(); cl_object to_array; cl_index offset; @@ -789,6 +787,7 @@ cl_array_displacement(cl_object a) cl_object cl_svref(cl_object x, cl_object index) { + const cl_env_ptr the_env = ecl_process_env(); cl_index i; while (type_of(x) != t_vector || @@ -806,6 +805,7 @@ cl_svref(cl_object x, cl_object index) cl_object si_svset(cl_object x, cl_object index, cl_object v) { + const cl_env_ptr the_env = ecl_process_env(); cl_index i; while (type_of(x) != t_vector || @@ -823,6 +823,7 @@ si_svset(cl_object x, cl_object index, cl_object v) cl_object cl_array_has_fill_pointer_p(cl_object a) { + const cl_env_ptr the_env = ecl_process_env(); cl_object r; AGAIN: switch (type_of(a)) { @@ -847,6 +848,7 @@ cl_array_has_fill_pointer_p(cl_object a) cl_object cl_fill_pointer(cl_object a) { + const cl_env_ptr the_env = ecl_process_env(); assert_type_vector(a); if (!a->vector.hasfillp) { a = ecl_type_error(@'fill-pointer', "argument", @@ -861,6 +863,7 @@ cl_fill_pointer(cl_object a) cl_object si_fill_pointer_set(cl_object a, cl_object fp) { + const cl_env_ptr the_env = ecl_process_env(); assert_type_vector(a); AGAIN: if (a->vector.hasfillp) { @@ -883,6 +886,7 @@ si_fill_pointer_set(cl_object a, cl_object fp) cl_object si_replace_array(cl_object olda, cl_object newa) { + const cl_env_ptr the_env = ecl_process_env(); cl_object dlist; if (type_of(olda) != type_of(newa) || (type_of(olda) == t_array && olda->array.rank != newa->array.rank)) diff --git a/src/c/assignment.d b/src/c/assignment.d index 1ca072d48..6638724ee 100644 --- a/src/c/assignment.d +++ b/src/c/assignment.d @@ -21,9 +21,10 @@ cl_object cl_set(cl_object var, cl_object val) { + const cl_env_ptr env = ecl_process_env(); if (ecl_symbol_type(var) & stp_constant) FEinvalid_variable("Cannot assign to the constant ~S.", var); - return1(ECL_SETQ(var, val)); + return1(ECL_SETQ(env, var, val)); } @(defun si::fset (fname def &optional macro pprint) @@ -116,6 +117,7 @@ ecl_clear_compiler_properties(cl_object sym) cl_object si_get_sysprop(cl_object sym, cl_object prop) { + cl_env_ptr the_env = ecl_process_env(); cl_object plist = ecl_gethash_safe(sym, cl_core.system_properties, Cnil); prop = ecl_getf(plist, prop, OBJNULL); if (prop == OBJNULL) { diff --git a/src/c/big.d b/src/c/big.d index 393448ccd..297f02d6e 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -76,7 +76,7 @@ big_register_free(cl_object x) cl_object big_register_copy(cl_object old) { - cl_object new_big = cl_alloc_object(t_bignum); + cl_object new_big = ecl_alloc_object(t_bignum); if (old->big.big_dim > BIGNUM_REGISTER_SIZE) { /* The object already has suffered a mpz_realloc() so we can use the pointer */ @@ -115,19 +115,19 @@ big_register_normalize(cl_object x) static cl_object big_alloc(int size) { - volatile cl_object x = cl_alloc_object(t_bignum); + volatile cl_object x = ecl_alloc_object(t_bignum); if (size <= 0) ecl_internal_error("negative or zero size for bignum in big_alloc"); x->big.big_dim = size; x->big.big_size = 0; - x->big.big_limbs = (mp_limb_t *)cl_alloc_atomic_align(size * sizeof(mp_limb_t), sizeof(mp_limb_t)); + x->big.big_limbs = (mp_limb_t *)ecl_alloc_atomic_align(size * sizeof(mp_limb_t), sizeof(mp_limb_t)); return(x); } cl_object bignum1(cl_fixnum val) { - volatile cl_object z = cl_alloc_object(t_bignum); + volatile cl_object z = ecl_alloc_object(t_bignum); mpz_init_set_si(z->big.big_num, val); return(z); } @@ -147,7 +147,7 @@ bignum2(mp_limb_t hi, mp_limb_t lo) cl_object big_copy(cl_object x) { - volatile cl_object y = cl_alloc_object(t_bignum); + volatile cl_object y = ecl_alloc_object(t_bignum); mpz_init_set(y->big.big_num, x->big.big_num); return(y); } @@ -261,13 +261,13 @@ big_normalize(cl_object x) static void * mp_alloc(size_t size) { - return cl_alloc_atomic_align(size, sizeof(mp_limb_t)); + return ecl_alloc_atomic_align(size, sizeof(mp_limb_t)); } static void * mp_realloc(void *ptr, size_t osize, size_t nsize) { - void *p = cl_alloc_atomic_align(nsize, sizeof(mp_limb_t)); + void *p = ecl_alloc_atomic_align(nsize, sizeof(mp_limb_t)); memcpy(p, ptr, osize); return p; } @@ -278,21 +278,21 @@ mp_free(void *ptr, size_t size) char *x = ptr; if (x < (char *)(cl_env.big_register_limbs) || x > (char *)(cl_env.big_register_limbs+2)) - cl_dealloc(x); + ecl_dealloc(x); } -void init_big_registers(void) +void init_big_registers(cl_env_ptr env) { int i; for (i = 0; i < 3; i++) { - cl_env.big_register[i] = cl_alloc_object(t_bignum); - big_register_free(cl_env.big_register[i]); + env->big_register[i] = ecl_alloc_object(t_bignum); + big_register_free(env->big_register[i]); } } void -init_big(void) +init_big(cl_env_ptr env) { - init_big_registers(); + init_big_registers(env); mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); } diff --git a/src/c/big_ll.d b/src/c/big_ll.d index 8927238b2..e8aeef6af 100644 --- a/src/c/big_ll.d +++ b/src/c/big_ll.d @@ -43,7 +43,7 @@ big_register_free(cl_object x) {} cl_object big_register_copy(cl_object old) { - cl_object new_big = cl_alloc_object(t_bignum); + cl_object new_big = ecl_alloc_object(t_bignum); new_big->big.big_num = old->big.big_num; return new_big; } @@ -61,7 +61,7 @@ big_register_normalize(cl_object x) static cl_object big_alloc(int size) { - volatile cl_object x = cl_alloc_object(t_bignum); + volatile cl_object x = ecl_alloc_object(t_bignum); if (size <= 0) ecl_internal_error("negative or zero size for bignum in big_alloc"); x->big.big_num = 0ll; @@ -72,7 +72,7 @@ big_alloc(int size) cl_object bignum1(cl_fixnum val) { - volatile cl_object z = cl_alloc_object(t_bignum); + volatile cl_object z = ecl_alloc_object(t_bignum); z->big.big_num = val; return(z); } @@ -90,7 +90,7 @@ bignum2(cl_fixnum hi, cl_fixnum lo) cl_object big_copy(cl_object x) { - volatile cl_object y = cl_alloc_object(t_bignum); + volatile cl_object y = ecl_alloc_object(t_bignum); y->big.big_num = x->big.big_num; return(y); } @@ -134,7 +134,7 @@ void init_big_registers(void) { int i; for (i = 0; i < 3; i++) { - cl_env.big_register[i] = cl_alloc_object(t_bignum); + cl_env.big_register[i] = ecl_alloc_object(t_bignum); cl_env.big_register[i]->big.big_num = 0ll; } } diff --git a/src/c/cfun.d b/src/c/cfun.d index 1ca06ed4f..e648b1287 100644 --- a/src/c/cfun.d +++ b/src/c/cfun.d @@ -23,7 +23,7 @@ cl_make_cfun(void *c_function, cl_object name, cl_object cblock, int narg) { cl_object cf; - cf = cl_alloc_object(t_cfunfixed); + cf = ecl_alloc_object(t_cfunfixed); cf->cfun.entry = c_function; cf->cfun.name = name; cf->cfun.block = cblock; @@ -38,7 +38,7 @@ cl_make_cfun_va(void *c_function, cl_object name, cl_object cblock) { cl_object cf; - cf = cl_alloc_object(t_cfun); + cf = ecl_alloc_object(t_cfun); cf->cfun.entry = c_function; cf->cfun.name = name; cf->cfun.block = cblock; @@ -51,7 +51,7 @@ cl_make_cclosure_va(void *c_function, cl_object env, cl_object block) { cl_object cc; - cc = cl_alloc_object(t_cclosure); + cc = ecl_alloc_object(t_cclosure); cc->cclosure.entry = c_function; cc->cclosure.env = env; cc->cclosure.block = block; @@ -85,6 +85,7 @@ cl_def_c_function_va(cl_object sym, void *c_function) cl_object si_compiled_function_name(cl_object fun) { + cl_env_ptr the_env = ecl_process_env(); cl_object output; switch(type_of(fun)) { @@ -106,6 +107,7 @@ si_compiled_function_name(cl_object fun) cl_object cl_function_lambda_expression(cl_object fun) { + cl_env_ptr the_env = ecl_process_env(); cl_object output, name = Cnil, lex = Cnil; switch(type_of(fun)) { diff --git a/src/c/character.d b/src/c/character.d index 5e01a1eab..98f839de8 100644 --- a/src/c/character.d +++ b/src/c/character.d @@ -34,9 +34,9 @@ ecl_base_char_code(cl_object c) { #ifdef ECL_UNICODE if (CHARACTERP(c)) { - cl_fixnum c = CHAR_CODE(c); - if (c <= 255) { - return (int)c; + cl_fixnum code = CHAR_CODE(c); + if (code <= 255) { + return (int)code; } } FEtype_error_character(c); @@ -155,8 +155,8 @@ ecl_string_case(cl_object s) { int upcase; cl_index i; - const char *text; - for (i = 0, upcase = 0, text = s->base_string.self; i <= s->base_string.dim; i++) { + const char *text = (char*)s->base_string.self; + for (i = 0, upcase = 0; i <= s->base_string.dim; i++) { if (isupper(text[i])) { if (upcase < 0) return 0; @@ -563,21 +563,10 @@ cl_name_char(cl_object name) c = Cnil; } else { cl_index used_l; - if (type_of(name) == t_base_string) { - cl_index end = name->base_string.fillp; - cl_index real_end = end; - c = ecl_parse_integer(name, 1, end, &real_end, 16); - used_l = real_end; - } else { - /* Unsafe code: what about read errors? - bds_bind(@'*read-base*', MAKE_FIXNUM(16)); - c = cl_funcall(6, @'read-from-string', name, - Cnil, Cnil, @':start', MAKE_FIXNUM(1)); - bds_unwind1(); - used_l = fix(VALUES(0)); - */ - c = Cnil; - } + cl_index end = name->base_string.fillp; + cl_index real_end = end; + c = ecl_parse_integer(name, 1, end, &real_end, 16); + used_l = real_end; if (!FIXNUMP(c) || (used_l == (l - 1))) { c = Cnil; } else { diff --git a/src/c/cinit.d b/src/c/cinit.d index 0bd6153d4..3ccd44438 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -78,22 +78,25 @@ si_find_relative_package(cl_narg narg, cl_object package, ...) static cl_object si_simple_toplevel () { + cl_object output = cl_core.standard_output; cl_object sentence; int i; /* Simple minded top level loop */ - printf(";*** Lisp core booted ****\nECL (Embeddable Common Lisp) %d pages\n", MAXPAGE); - fflush(stdout); + writestr_stream(";*** Lisp core booted ****\n" + "ECL (Embeddable Common Lisp)\n", + output); + ecl_force_output(output); for (i = 1; i "); - sentence = @read(3, Cnil, Cnil, OBJNULL); - if (sentence == OBJNULL) - @(return); - ecl_prin1(si_eval_with_env(1, sentence), Cnil); + writestr_stream("\n> ", output); + sentence = @read(3, Cnil, Cnil, OBJNULL); + if (sentence == OBJNULL) + @(return); + ecl_prin1(si_eval_with_env(1, sentence), output); } } @@ -109,16 +112,16 @@ main(int argc, char **args) si_trap_fpe(Ct, Cnil); #ifdef ECL_CMU_FORMAT - SYM_VAL(@'*load-verbose*') = Cnil; + ECL_SET(@'*load-verbose*', Cnil); #endif - SYM_VAL(@'*package*') = cl_core.system_package; + ECL_SET(@'*package*', cl_core.system_package); - features = SYM_VAL(@'*features*'); + features = ecl_symbol_value(@'*features*'); features = CONS(ecl_make_keyword("ECL-MIN"), features); #ifdef HAVE_UNAME features = CONS(ecl_make_keyword("UNAME"), features); #endif - SYM_VAL(@'*features*') = features; + ECL_SET(@'*features*', features); top_level = _ecl_intern("TOP-LEVEL", cl_core.system_package); cl_def_c_function(top_level, si_simple_toplevel, 0); funcall(1, top_level); diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 377d82218..b0fb022b1 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -169,31 +169,31 @@ ecl_aset_bv(cl_object x, cl_index index, int value) void cl_throw(cl_object tag) { - ecl_frame_ptr fr = frs_sch(tag); - if (fr == NULL) - FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); - ecl_unwind(fr); + ecl_frame_ptr fr = frs_sch(tag); + if (fr == NULL) + FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); + ecl_unwind(ecl_process_env(), fr); } void cl_return_from(cl_object block_id, cl_object block_name) { - ecl_frame_ptr fr = frs_sch(block_id); - if (fr == NULL) - FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", - 2, block_name, block_id); - ecl_unwind(fr); + ecl_frame_ptr fr = frs_sch(block_id); + if (fr == NULL) + FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", + 2, block_name, block_id); + ecl_unwind(ecl_process_env(), fr); } void cl_go(cl_object tag_id, cl_object label) { - ecl_frame_ptr fr = frs_sch(tag_id); - if (fr == NULL) - FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); - VALUES(0)=label; - NVALUES=1; - ecl_unwind(fr); + ecl_frame_ptr fr = frs_sch(tag_id); + if (fr == NULL) + FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); + VALUES(0)=label; + NVALUES=1; + ecl_unwind(ecl_process_env(), fr); } cl_object diff --git a/src/c/compiler.d b/src/c/compiler.d index b9e2b049f..dcaa4f8f9 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -59,12 +59,12 @@ /********************* PRIVATE ********************/ -#define asm_begin() cl_stack_index() -#define asm_clear(h) cl_stack_set_index(h) -#define current_pc() cl_stack_index() -#define set_pc(n) cl_stack_set_index(n) -#define asm_op(o) cl_stack_push((cl_object)((cl_fixnum)(o))) -#define asm_ref(n) (cl_fixnum)(cl_env.stack[n]) +#define asm_begin() ecl_stack_index(ecl_process_env()) +#define asm_clear(h) ecl_stack_set_index(ecl_process_env(), h) +#define current_pc() ecl_stack_index(ecl_process_env()) +#define set_pc(n) ecl_stack_set_index(ecl_process_env(), n) +#define asm_op(o) ecl_stack_push(ecl_process_env(), (cl_object)((cl_fixnum)(o))) +#define asm_ref(n) (cl_fixnum)(ecl_process_env()->stack[n]) static void asm_op2(int op, int arg); static cl_object asm_end(cl_index handle); static cl_index asm_jmp(register int op); @@ -151,25 +151,26 @@ pop_maybe_nil(cl_object *l) { static cl_object asm_end(cl_index beginning) { + cl_env_ptr env = ecl_process_env(); cl_object bytecodes; cl_index code_size, data_size, i; cl_opcode *code; - cl_object file = SYM_VAL(@'*load-truename*'); - cl_object position = cl_cdr(SYM_VAL(@'ext::*source-location*')); + cl_object file = ECL_SYM_VAL(env,@'*load-truename*'); + cl_object position = cl_cdr(ECL_SYM_VAL(env,@'ext::*source-location*')); /* Save bytecodes from this session in a new vector */ code_size = current_pc() - beginning; data_size = ecl_length(ENV->constants); - bytecodes = cl_alloc_object(t_bytecodes); + bytecodes = ecl_alloc_object(t_bytecodes); bytecodes->bytecodes.name = @'si::bytecodes'; bytecodes->bytecodes.code_size = code_size; bytecodes->bytecodes.data_size = data_size; - bytecodes->bytecodes.code = cl_alloc_atomic(code_size * sizeof(cl_opcode)); - bytecodes->bytecodes.data = (cl_object*)cl_alloc(data_size * sizeof(cl_object)); + bytecodes->bytecodes.code = ecl_alloc_atomic(code_size * sizeof(cl_opcode)); + bytecodes->bytecodes.data = (cl_object*)ecl_alloc(data_size * sizeof(cl_object)); bytecodes->bytecodes.file = (file == OBJNULL)? Cnil : file; bytecodes->bytecodes.file_position = (position == OBJNULL)? Cnil : position; for (i = 0, code = (cl_opcode *)bytecodes->bytecodes.code; i < code_size; i++) { - code[i] = (cl_opcode)(cl_fixnum)cl_env.stack[beginning+i]; + code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); } for (i=0; i < data_size; i++) { bytecodes->bytecodes.data[i] = CAR(ENV->constants); @@ -219,6 +220,7 @@ asm_jmp(register int op) { static void asm_complete(register int op, register cl_index pc) { + cl_env_ptr env = ecl_process_env(); cl_fixnum delta = current_pc() - pc; /* [1] */ if (op && (asm_ref(pc-1) != op)) FEprogram_error("Non matching codes in ASM-COMPLETE2", 0); @@ -229,14 +231,14 @@ asm_complete(register int op, register cl_index pc) { unsigned char low = delta & 0xFF; char high = delta >> 8; # ifdef WORDS_BIGENDIAN - cl_env.stack[pc] = (cl_object)(cl_fixnum)high; - cl_env.stack[pc+1] = (cl_object)(cl_fixnum)low; + env->stack[pc] = (cl_object)(cl_fixnum)high; + env->stack[pc+1] = (cl_object)(cl_fixnum)low; # else - cl_env.stack[pc] = (cl_object)(cl_fixnum)low; - cl_env.stack[pc+1] = (cl_object)(cl_fixnum)high; + env->stack[pc] = (cl_object)(cl_fixnum)low; + env->stack[pc+1] = (cl_object)(cl_fixnum)high; # endif #else - cl_env.stack[pc] = (cl_object)(cl_fixnum)delta; + env->stack[pc] = (cl_object)(cl_fixnum)delta; #endif } } @@ -597,7 +599,7 @@ c_var_ref(cl_object var, int allow_symbol_macro, bool ensure_defined) } } if (ensure_defined) { - l = SYM_VAL(@'si::*action-on-undefined-variable*'); + l = ecl_symbol_value(@'si::*action-on-undefined-variable*'); if (l != Cnil) { funcall(3, l, make_simple_base_string("Undefined variable referenced in interpreted code.~%Name: ~A"), var); @@ -1010,16 +1012,17 @@ c_catch(cl_object args, int flags) { static int c_compiler_let(cl_object args, int flags) { cl_object bindings; - cl_index old_bds_top_index = cl_env.bds_top - cl_env.bds_org; + const cl_env_ptr env = ecl_process_env(); + cl_index old_bds_top_index = env->bds_top - env->bds_org; for (bindings = pop(&args); !ecl_endp(bindings); ) { cl_object form = pop(&bindings); cl_object var = pop(&form); cl_object value = pop_maybe_nil(&form); - bds_bind(var, value); + ecl_bds_bind(env, var, value); } flags = compile_body(args, flags); - bds_unwind(old_bds_top_index); + ecl_bds_unwind(env, old_bds_top_index); return flags; } @@ -1946,16 +1949,17 @@ c_values(cl_object args, int flags) { static int compile_form(cl_object stmt, int flags) { - cl_object code_walker = SYM_VAL(@'si::*code-walker*'); + const cl_env_ptr env = ecl_process_env(); + cl_object code_walker = ECL_SYM_VAL(env,@'si::*code-walker*'); compiler_record *l; cl_object function; bool push = flags & FLAG_PUSH; int new_flags; - bds_bind(@'si::*current-form*', stmt); + ecl_bds_bind(env, @'si::*current-form*', stmt); BEGIN: if (code_walker != OBJNULL) { - stmt = funcall(3, SYM_VAL(@'si::*code-walker*'), stmt, + stmt = funcall(3, ECL_SYM_VAL(env,@'si::*code-walker*'), stmt, CONS(ENV->variables, ENV->macros)); } /* @@ -2089,7 +2093,7 @@ for special form ~S.", 1, function); } else if (new_flags & FLAG_PUSH) { FEerror("Internal error in bytecodes compiler", 0); } - bds_unwind1(); + ecl_bds_unwind1(env); return flags; } @@ -2347,7 +2351,7 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context) #define AT_KEYS 3 #define AT_OTHER_KEYS 4 #define AT_AUXS 5 - + const cl_env_ptr the_env = ecl_process_env(); cl_object v, key, init, spp, lambda_list = org_lambda_list; cl_object reqs = Cnil, opts = Cnil, keys = Cnil, rest = Cnil, auxs = Cnil; int nreq = 0, nopt = 0, nkey = 0, naux = 0, stage = 0; @@ -2512,17 +2516,21 @@ ILLEGAL_LAMBDA: static cl_object c_default(cl_index base_pc, cl_object deflt) { cl_type t = type_of(deflt); - if (((t == t_symbol) && (ecl_symbol_type(deflt) & stp_constant) && - !FIXNUMP(SYM_VAL(deflt)))) { - /* FIXME! Shouldn't this happen only in unsafe mode */ - deflt = SYM_VAL(deflt); - } else if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) { - deflt = CADR(deflt); - } else if ((t == t_symbol) || (t == t_list) || (t == t_fixnum)) { + if ((t == t_symbol) && (ecl_symbol_type(deflt) & stp_constant)) { + cl_object value = ecl_symbol_value(deflt); + if (!FIXNUMP(value)) { + /* FIXME! Shouldn't this happen only in unsafe mode */ + return value; + } + } + if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) { + return CADR(deflt); + } + if ((t == t_symbol) || (t == t_list) || (t == t_fixnum)) { cl_index pc = current_pc()-base_pc; compile_form(deflt, FLAG_VALUES); asm_op(OP_EXIT); - deflt = MAKE_FIXNUM(pc); + return MAKE_FIXNUM(pc); } return deflt; } @@ -2558,9 +2566,10 @@ ecl_make_lambda(cl_object name, cl_object lambda) { int nopts, nkeys; cl_index handle; struct cl_compiler_env *old_c_env, new_c_env; + const cl_env_ptr env = ecl_process_env(); - bds_bind(@'si::*current-form*', - @list*(3, @'ext::lambda-block', name, lambda)); + ecl_bds_bind(env, @'si::*current-form*', + @list*(3, @'ext::lambda-block', name, lambda)); old_c_env = ENV; c_new_env(&new_c_env, Cnil, old_c_env); @@ -2662,12 +2671,12 @@ ecl_make_lambda(cl_object name, cl_object lambda) { output = asm_end(handle); output->bytecodes.name = name; output->bytecodes.specials = specials; - output->bytecodes.definition = Null(SYM_VAL(@'si::*keep-definitions*'))? + output->bytecodes.definition = Null(ecl_symbol_value(@'si::*keep-definitions*'))? Cnil : lambda; ENV = old_c_env; - bds_unwind1(); + ecl_bds_unwind1(env); return output; } @@ -2705,7 +2714,7 @@ si_make_lambda(cl_object name, cl_object rest) struct cl_compiler_env new_c_env; c_new_env(&new_c_env, Cnil, 0); - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { lambda = ecl_make_lambda(name,rest); } CL_UNWIND_PROTECT_EXIT { ENV = old_c_env; @@ -2735,7 +2744,7 @@ si_make_lambda(cl_object name, cl_object rest) ENV->lex_env = env; ENV->stepping = stepping != Cnil; handle = asm_begin(); - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { compile_form(form, FLAG_VALUES); asm_op(OP_EXIT); bytecodes = asm_end(handle); @@ -2749,7 +2758,7 @@ si_make_lambda(cl_object name, cl_object rest) /* * Interpret using the given lexical environment. */ - ihs_push(&ihs, bytecodes, Cnil); + ecl_ihs_push(the_env, &ihs, bytecodes, Cnil); VALUES(0) = Cnil; NVALUES = 0; { @@ -2759,7 +2768,7 @@ si_make_lambda(cl_object name, cl_object rest) GC_free(bytecodes->bytecodes.data); GC_free(bytecodes); #endif - ihs_pop(); + ecl_ihs_pop(the_env); return output; } @) diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 47c44e4e0..4f5b582c4 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -64,10 +64,11 @@ disassemble_vars(const char *message, cl_object *data, cl_index step) { static void disassemble_lambda(cl_object bytecodes) { + const cl_env_ptr env = ecl_process_env(); cl_object *data; cl_opcode *vector; - bds_bind(@'*print-pretty*', Cnil); + ecl_bds_bind(env, @'*print-pretty*', Cnil); if (bytecodes->bytecodes.name == OBJNULL || bytecodes->bytecodes.name == @'si::bytecodes') { @@ -109,7 +110,7 @@ NO_ARGS: base = vector = (cl_opcode *)bytecodes->bytecodes.code; disassemble(bytecodes, vector); - bds_unwind1(); + ecl_bds_unwind1(env); } /* -------------------- DISASSEMBLER CORE -------------------- */ @@ -629,6 +630,7 @@ si_bc_disassemble(cl_object v) cl_object si_bc_split(cl_object b) { + const cl_env_ptr the_env = ecl_process_env(); cl_object vector; cl_object data; cl_object lex = Cnil; @@ -649,6 +651,7 @@ si_bc_split(cl_object b) cl_object si_bc_file(cl_object b) { + cl_env_ptr the_env = ecl_process_env(); if (type_of(b) == t_bclosure) { b = b->bclosure.code; } diff --git a/src/c/dpp.c b/src/c/dpp.c index a7f2731d2..55fb619b1 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -636,6 +636,8 @@ put_declaration(void) int i; int simple_varargs; + put_lineno(); + fprintf(out, "\tconst cl_env_ptr the_env = ecl_process_env();\n"); for (i = 0; i < nopt; i++) { put_lineno(); fprintf(out, "\tcl_object %s;\n", optional[i].o_var); @@ -774,10 +776,10 @@ put_return(void) fprintf(out, "cl_object __value%d = %s;\n", i, result[i]); } put_tabs(t); - fprintf(out, "NVALUES = %d;\n", nres); + fprintf(out, "the_env->nvalues = %d;\n", nres); for (i = nres-1; i > 0; i--) { put_tabs(t); - fprintf(out, "VALUES(%d) = __value%d;\n", i, i); + fprintf(out, "the_env->values[%d] = __value%d;\n", i, i); } put_tabs(t); fprintf(out, "return __value0;\n"); diff --git a/src/c/error.d b/src/c/error.d index 10797d5de..0214de3d2 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -46,6 +46,7 @@ FEerror(const char *s, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); funcall(4, @'si::universal-error-handler', Cnil, /* not correctable */ make_constant_base_string(s), /* condition text */ @@ -57,6 +58,7 @@ CEerror(cl_object c, const char *err, int narg, ...) { cl_va_list args; cl_va_start(args, narg, narg, 0); + ecl_enable_interrupts(); return funcall(4, @'si::universal-error-handler', c, /* correctable */ make_constant_base_string(err), /* continue-format-string */ @@ -70,7 +72,7 @@ CEerror(cl_object c, const char *err, int narg, ...) void FEprogram_error(const char *s, int narg, ...) { - cl_object form, real_args, text; + cl_object form, real_args, text; cl_va_list args; cl_va_start(args, narg, narg, 0); text = make_constant_base_string(s); @@ -79,7 +81,7 @@ FEprogram_error(const char *s, int narg, ...) /* When FEprogram_error is invoked from the compiler, we can * provide information about the offending form. */ - cl_object stmt = SYM_VAL(@'si::*current-form*'); + cl_object stmt = ecl_symbol_value(@'si::*current-form*'); if (stmt != Cnil) { real_args = @list(3, stmt, text, real_args); text = make_constant_base_string("In form~%~S~%~?"); @@ -209,11 +211,11 @@ FEinvalid_function_name(cl_object fname) } /* bootstrap version */ -static -@(defun "universal_error_handler" (c err args) -@ +static cl_object +universal_error_handler(cl_narg narg, cl_object c, cl_object err, cl_object args, ...) +{ ecl_internal_error("\nLisp initialization error.\n"); -@) +} void FEillegal_index(cl_object x, cl_object i) @@ -285,18 +287,16 @@ FEwin32_error(const char *msg, int narg, ...) @(defun error (eformat &rest args) @ - funcall(4, @'si::universal-error-handler', - Cnil, - eformat, - cl_grab_rest_args(args)); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', Cnil, eformat, + cl_grab_rest_args(args)); @) @(defun cerror (cformat eformat &rest args) @ - return(funcall(4, @'si::universal-error-handler', - cformat, - eformat, - cl_grab_rest_args(args))); + ecl_enable_interrupts(); + return funcall(4, @'si::universal-error-handler', cformat, eformat, + cl_grab_rest_args(args)); @) void diff --git a/src/c/eval.d b/src/c/eval.d index 1b56a084c..6476e216b 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -22,12 +22,13 @@ cl_object * _ecl_va_sp(cl_narg narg) { - return cl_env.stack_top - narg; + return ecl_process_env()->stack_top - narg; } static cl_object build_funcall_frame(cl_object f, cl_va_list args) { + cl_env_ptr env = ecl_process_env(); cl_index n = args[0].narg; cl_object *p = args[0].sp; f->frame.stack = 0; @@ -36,7 +37,7 @@ build_funcall_frame(cl_object f, cl_va_list args) p = (cl_object*)(args[0].args); #else cl_index i; - p = cl_env.values; + p = env->values; for (i = 0; i < n; i++) { p[i] = va_arg(args[0].args, cl_object); } @@ -46,6 +47,7 @@ build_funcall_frame(cl_object f, cl_va_list args) f->frame.bottom = p; f->frame.top = p + n; f->frame.t = t_frame; + f->frame.env = env; return f; } @@ -210,7 +212,8 @@ si_unlink_symbol(cl_object s) cl_object out; cl_index i; struct ecl_stack_frame frame_aux; - const cl_object frame = ecl_stack_frame_open((cl_object)&frame_aux, + const cl_object frame = ecl_stack_frame_open(ecl_process_env(), + (cl_object)&frame_aux, narg -= 2); for (i = 0; i < narg; i++) { ecl_stack_frame_elt_set(frame, i, lastarg); diff --git a/src/c/ffi.d b/src/c/ffi.d index e6486e1c8..e7a681dbb 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -61,7 +61,7 @@ static unsigned int ecl_foreign_type_size[] = { cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data) { - cl_object output = cl_alloc_object(t_foreign); + cl_object output = ecl_alloc_object(t_foreign); output->foreign.tag = tag == Cnil ? @':void' : tag; output->foreign.size = size; output->foreign.data = (char*)data; @@ -71,10 +71,10 @@ ecl_make_foreign_data(cl_object tag, cl_index size, void *data) cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size) { - cl_object output = cl_alloc_object(t_foreign); + cl_object output = ecl_alloc_object(t_foreign); output->foreign.tag = tag; output->foreign.size = size; - output->foreign.data = (char*)cl_alloc_atomic(size); + output->foreign.data = (char*)ecl_alloc_atomic(size); return output; } @@ -115,7 +115,7 @@ ecl_null_terminated_base_string(cl_object f) cl_object si_allocate_foreign_data(cl_object tag, cl_object size) { - cl_object output = cl_alloc_object(t_foreign); + cl_object output = ecl_alloc_object(t_foreign); cl_index bytes = fixnnint(size); output->foreign.tag = tag; output->foreign.size = bytes; @@ -191,7 +191,7 @@ si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize, if (ndx >= f->foreign.size || (f->foreign.size - ndx) < size) { FEerror("Out of bounds reference into foreign data type ~A.", 1, f); } - output = cl_alloc_object(t_foreign); + output = ecl_alloc_object(t_foreign); output->foreign.tag = tag; output->foreign.size = size; output->foreign.data = f->foreign.data + ndx; @@ -339,7 +339,7 @@ ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value) *(void **)p = ecl_foreign_data_pointer_safe(value); break; case ECL_FFI_CSTRING: - *(char **)p = value == Cnil ? NULL : value->base_string.self; + *(char **)p = value == Cnil ? NULL : (char*)value->base_string.self; break; case ECL_FFI_OBJECT: *(cl_object *)p = value; @@ -424,7 +424,7 @@ si_load_foreign_module(cl_object filename) #ifdef ECL_THREADS mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { #endif output = ecl_library_open(filename, 0); if (output->cblock.handle == NULL) @@ -460,7 +460,7 @@ si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_objec block = (module == @':default' ? module : si_load_foreign_module(module)); var = ecl_null_terminated_base_string(var); - sym = ecl_library_symbol(block, var->base_string.self, 1); + sym = ecl_library_symbol(block, (char*)var->base_string.self, 1); if (sym == NULL) { if (block != @':default') output = ecl_library_error(block); diff --git a/src/c/file.d b/src/c/file.d index a869998d7..2f9c9373a 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -23,6 +23,9 @@ */ #include +#include +#include +#include #include #include #include @@ -53,9 +56,3699 @@ #define ecl_ftello ftello #endif -#define MAKE_BIT_MASK(n) ((1<<(n))-1) +static cl_index ecl_read_byte8(cl_object stream, unsigned char *c, cl_index n); +static cl_index ecl_write_byte8(cl_object stream, unsigned char *c, cl_index n); -static int flisten(FILE *fp); +struct ecl_file_ops *duplicate_dispatch_table(const struct ecl_file_ops *ops); +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); + +static cl_object alloc_stream(); + +static cl_object not_a_file_stream(cl_object fn); +static void not_an_input_stream(cl_object fn); +static void not_an_output_stream(cl_object fn); +static void not_a_character_stream(cl_object s); +static void not_a_binary_stream(cl_object s); +static int restartable_io_error(cl_object strm); +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, int c); +static void wrong_file_handler(cl_object strm); + +/********************************************************************** + * NOT IMPLEMENTED or NOT APPLICABLE OPERATIONS + */ + +static cl_index +not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + not_an_output_stream(strm); + return 0; +} + +static cl_index +not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + not_an_input_stream(strm); + 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) +{ + not_a_binary_stream(strm); + return 0; +} + +static int +not_input_read_char(cl_object strm) +{ + not_an_input_stream(strm); + return -1; +} + +static int +not_output_write_char(cl_object strm, int c) +{ + not_an_output_stream(strm); + return c; +} + +static void +not_input_unread_char(cl_object strm, int c) +{ + not_an_input_stream(strm); +} + +static int +not_input_listen(cl_object strm) +{ + not_an_input_stream(strm); + return -1; +} + +static int +not_character_read_char(cl_object strm) +{ + not_a_character_stream(strm); + return -1; +} + +static int +not_character_write_char(cl_object strm, int c) +{ + not_a_character_stream(strm); + return c; +} + +static void +not_character_unread_char(cl_object strm, int 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) +{ + not_an_input_stream(strm); + return; +} + +static void +not_output_clear_output(cl_object strm) +{ + not_an_output_stream(strm); + return; +} + +static void +not_output_force_output(cl_object strm) +{ + not_an_output_stream(strm); + return; +} + +static void +not_output_finish_output(cl_object strm) +{ + not_an_output_stream(strm); + return; +} + +static cl_object +not_implemented_get_position(cl_object strm) +{ + FEerror("file-position not implemented for stream ~S", 1, strm); + return Cnil; +} + +static cl_object +not_implemented_set_position(cl_object strm, cl_object pos) +{ + FEerror("file-position not implemented for stream ~S", 1, strm); + return Cnil; +} + +/********************************************************************** + * CLOSED STREAM OPS + */ + +static cl_index +closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + FEclosed_stream(strm); +} + +static cl_index +closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + FEclosed_stream(strm); +} + +static int +closed_stream_read_char(cl_object strm) +{ + FEclosed_stream(strm); +} + +static int +closed_stream_write_char(cl_object strm, int c) +{ + FEclosed_stream(strm); + return c; +} + +static void +closed_stream_unread_char(cl_object strm, int c) +{ + FEclosed_stream(strm); +} + +static int +closed_stream_listen(cl_object strm) +{ + FEclosed_stream(strm); +} + +static void +closed_stream_clear_input(cl_object strm) +{ + FEclosed_stream(strm); +} + +#define closed_stream_clear_output closed_stream_clear_input +#define closed_stream_force_output closed_stream_clear_input +#define closed_stream_finish_output closed_stream_clear_input + +static cl_object +closed_stream_length(cl_object strm) +{ + FEclosed_stream(strm); +} + +#define closed_stream_get_position closed_stream_length + +static cl_object +closed_stream_set_position(cl_object strm, cl_object position) +{ + FEclosed_stream(strm); +} + +/********************************************************************** + * GENERIC OPERATIONS + * + * Versions of the methods which are defined in terms of others + */ +/* + * Byte operations for devices that are character based. We assume that + * the character size matches that of the byte. + */ +static cl_index +generic_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + const struct ecl_file_ops *ops = stream_dispatch_table(strm); + cl_index i; + for (i = 0; i < n; i++) { + ops->write_char(strm, c[i]); + } + return n; +} + +static cl_index +generic_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + const struct ecl_file_ops *ops = stream_dispatch_table(strm); + cl_index i; + for (i = 0; i < n; i++) { + c[i] = ops->read_char(strm); + } + return n; +} + +/* + * Character operations for devices which are byte based. We assume that + * the character size matches that of the byte. + */ +static int +generic_read_char(cl_object strm) +{ + int c = strm->stream.unread; + if (c == EOF) { + const struct ecl_file_ops *ops = stream_dispatch_table(strm); + unsigned char aux; + if (ops->read_byte8(strm, &aux, 1) < 1) + c = EOF; + else + c = aux; + } else { + strm->stream.unread = EOF; + } + return c; +} + +static int +generic_peek_char(cl_object strm) +{ + int out = ecl_read_char(strm); + if (out != EOF) ecl_unread_char(out, strm); + return out; +} + +static int +generic_write_char(cl_object strm, int c) +{ + const struct ecl_file_ops *ops = stream_dispatch_table(strm); + if (c > 0xFF) { + character_overflow(strm, c); + } else { + unsigned char aux = c; + ops->write_byte8(strm, &aux, 1); + } + return c; +} + +static void +generic_unread_char(cl_object strm, int c) +{ + if (strm->stream.unread != EOF) { + unread_twice(strm); + } + strm->stream.unread = c; +} + +static void +generic_void(cl_object strm) +{ +} + +static int +generic_always_true(cl_object strm) +{ + return 1; +} + +static int +generic_always_false(cl_object strm) +{ + return 0; +} + +static cl_object +generic_always_nil(cl_object strm) +{ + return Cnil; +} + +static int +generic_column(cl_object strm) +{ + return 0; +} + +static cl_object +generic_set_position(cl_object strm, cl_object pos) +{ + return Cnil; +} + +static cl_object +generic_close(cl_object strm) +{ + struct ecl_file_ops *ops = strm->stream.ops; + if (ecl_input_stream_p(strm)) { + ops->read_byte8 = closed_stream_read_byte8; + ops->read_char = closed_stream_read_char; + ops->unread_char = closed_stream_unread_char; + ops->listen = closed_stream_listen; + ops->clear_input = closed_stream_clear_input; + } + if (ecl_output_stream_p(strm)) { + ops->write_byte8 = closed_stream_write_byte8; + ops->write_char = closed_stream_write_char; + ops->clear_output = closed_stream_clear_output; + ops->force_output = closed_stream_force_output; + ops->finish_output = closed_stream_finish_output; + } + ops->get_position = closed_stream_get_position; + ops->set_position = closed_stream_set_position; + ops->length = closed_stream_length; + ops->close = generic_close; + strm->stream.closed = 1; + return Ct; +} + +static cl_index +generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) +{ + if (start >= end) + return start; + if (data->vector.elttype == aet_bc || +#ifdef ECL_UNICODE + data->vector.elttype == aet_ch || +#endif + (data->vector.elttype == aet_object && CHARACTERP(ecl_elt(data, 0)))) { + for (; start < end; start++) { + ecl_write_char(ecl_char_code(ecl_elt(data, start)), strm); + } + } else { + for (; start < end; start++) { + ecl_write_byte(ecl_elt(data, start), strm); + } + } + return start; +} + +static cl_index +generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) +{ + cl_object expected_type; + if (start >= end) + return start; + expected_type = ecl_stream_element_type(strm); + if (expected_type == @'base-char' || expected_type == @'character') { + for (; start < end; start++) { + cl_fixnum c = ecl_read_char(strm); + if (c == EOF) break; + ecl_elt_set(data, start, CODE_CHAR(c)); + } + } else { + for (; start < end; start++) { + cl_object x = ecl_read_byte(strm); + if (Null(x)) break; + ecl_elt_set(data, start, x); + } + } + return start; +} + +/********************************************************************** + * WIDE CHARACTER SUPPORT + */ + +#ifdef ECL_UNICODE +/* + * UCS-4 BIG ENDIAN + */ + +static int +ucs_4_read_char(cl_object strm) +{ + unsigned char buffer[4]; + int c = strm->stream.unread; + if (c != EOF) { + strm->stream.unread = EOF; + return c; + } + if (strm->stream.ops->read_byte8(strm, buffer, 4) < 4) + return EOF; + return buffer[3]+buffer[2]<<8+buffer[1]<<16+buffer[0]<<24; +} + +static int +ucs_4_write_char(cl_object strm, int c_orig) +{ + int c = c_orig; + unsigned char buffer[4]; + buffer[3] = c & 8; c >>= 8; + buffer[2] = c & 8; c >>= 8; + buffer[1] = c & 8; c >>= 8; + buffer[0] = c; + strm->stream.ops->write_byte8(strm, buffer, 4); + if (c_orig == '\n') + IO_STREAM_COLUMN(strm) = 0; + else if (c_orig == '\t') + IO_STREAM_COLUMN(strm) = (IO_STREAM_COLUMN(strm)&~07) + 8; + else + IO_STREAM_COLUMN(strm)++; + return c_orig; +} + +/* + * UCS-2 BIG ENDIAN + */ + +static int +ucs_2_read_char(cl_object strm) +{ + unsigned char buffer[2]; + int c = strm->stream.unread; + if (c != EOF) { + strm->stream.unread = EOF; + return c; + } + if (strm->stream.ops->read_byte8(strm, buffer, 2) < 4) + return EOF; + return buffer[1]+buffer[0]<<8; +} + +static int +ucs_2_write_char(cl_object strm, int c_orig) +{ + int c = c_orig; + unsigned char buffer[2]; + buffer[1] = c & 8; c >>= 8; + buffer[0] = c & 8; + strm->stream.ops->write_byte8(strm, buffer, 2); + if (c_orig == '\n') + IO_STREAM_COLUMN(strm) = 0; + else if (c_orig == '\t') + IO_STREAM_COLUMN(strm) = (IO_STREAM_COLUMN(strm)&~07) + 8; + else + IO_STREAM_COLUMN(strm)++; + return c_orig; +} + +/* + * UTF-8 + */ + +static int +utf_8_read_char(cl_object strm) +{ + /* In understanding this code: + * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111 + * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111 + */ + int cum = 0; + unsigned char buffer[5]; + int nbytes, i; + cum = strm->stream.unread; + if (cum != EOF) { + strm->stream.unread = EOF; + return cum; + } + if (strm->stream.ops->read_byte8(strm, buffer, 1) < 1) + return EOF; + /*printf(": %04x :", buffer[0]);*/ + if ((buffer[0] & 0x80) == 0) { + return buffer[0]; + } + if ((buffer[0] & 0x40) == 0) + goto MALFORMED; + if ((buffer[0] & 0x20) == 0) { + buffer[0] &= 0x1F; + nbytes = 1; + } else if ((buffer[0] & 0x10) == 0) { + buffer[0] &= 0x0F; + nbytes = 2; + } else if ((buffer[0] & 0x08) == 0) { + buffer[0] &= 0x07; + nbytes = 3; + } else { + FEerror("ECL does not support Unicode characters with more than 21 bits.", 0); + } + if (buffer[0] == 0) { + goto TOO_LONG; + } + if (strm->stream.ops->read_byte8(strm, buffer+1, nbytes) < nbytes) + return EOF; + for (i = 1, cum = buffer[0]; i <= nbytes; i++) { + unsigned char c = buffer[i]; + /*printf(": %04x :", c);*/ + if ((c & 0xC0) != 0x80) + goto MALFORMED; + c &= 0x3F; + if (c == 0) + goto TOO_LONG; + cum = (cum << 6) | c; + } + if (cum >= 0xd800) { + if (cum <= 0xdfff) + goto INVALID_CODE_POINT; + if (cum >= 0xFFFE && cum <= 0xFFFF) + goto INVALID_CODE_POINT; + } + /*printf("; %04x ;", cum);*/ + return cum; + TOO_LONG: + FEerror("In ~A found an UTF-8 encoding which is too large for the given character", + 1, strm); + return EOF; + MALFORMED: + FEerror("Invalid byte found in UTF-8 stream ~A", 1, strm); + return EOF; + INVALID_CODE_POINT: + FEerror("Invalid code point ~D found in ~A", 2, MAKE_FIXNUM(cum), strm); + return EOF; +} + +static int +utf_8_write_char(cl_object strm, int c_orig) +{ + int c = c_orig; + unsigned char buffer[5]; + int nbytes; + if (c < 0) { + FEerror("Not a valid character code ~D written to ~A", 2, + MAKE_FIXNUM(c), strm); + } else if (c <= 0x7F) { + buffer[0] = c; + nbytes = 1; + } else if (c <= 0x7ff) { + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xC0; + /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/ + nbytes = 2; + } else if (c <= 0xFFFF) { + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xE0; + nbytes = 3; + } else if (c <= 0x1FFFFFL) { + buffer[3] = (c & 0x3f) | 0x80; c >>= 6; + buffer[2] = (c & 0x3f) | 0x80; c >>= 6; + buffer[1] = (c & 0x3f) | 0x80; c >>= 6; + buffer[0] = c | 0xF0; + nbytes = 4; + } + strm->stream.ops->write_byte8(strm, buffer, nbytes); + if (c == '\n') + IO_STREAM_COLUMN(strm) = 0; + else if (c == '\t') + IO_STREAM_COLUMN(strm) = (IO_STREAM_COLUMN(strm)&~07) + 8; + else + IO_STREAM_COLUMN(strm)++; + return c_orig; +} +#endif + +/******************************************************************************** + * CLOS STREAMS + */ + +static cl_index +clos_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = funcall(3, @'gray::stream-read-byte', strm); + if (!FIXNUMP(byte)) + break; + c[i] = fix(byte); + } + return i; +} + +static cl_index +clos_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + cl_index i; + for (i = 0; i < n; i++) { + cl_object byte = funcall(3, @'gray::stream-write-byte', strm, + MAKE_FIXNUM(c[i])); + if (!FIXNUMP(byte)) + break; + } + return i; +} + +static int +clos_stream_read_char(cl_object strm) +{ + cl_object output = funcall(3, @'gray::stream-read-char', strm); + return CHAR_CODE(output); +} + +static int +clos_stream_write_char(cl_object strm, int c) +{ + funcall(3, @'gray::stream-write-char', strm, CODE_CHAR(c)); + return c; +} + +static void +clos_stream_unread_char(cl_object strm, int c) +{ + funcall(3, @'gray::stream-unread-char', strm, CODE_CHAR(c)); +} + +#define clos_stream_peek_char generic_peek_char + +static int +clos_stream_listen(cl_object strm) +{ + return !Null(funcall(2, @'gray::stream-listen', strm)); +} + +static void +clos_stream_clear_input(cl_object strm) +{ + funcall(2, @'gray::stream-clear-input', strm); + return; +} + +static void +clos_stream_clear_output(cl_object strm) +{ + funcall(2, @'gray::stream-clear-output', strm); + return; +} + +static void +clos_stream_force_output(cl_object strm) +{ + funcall(2, @'gray::stream-force-output', strm); + return; +} + +static void +clos_stream_finish_output(cl_object strm) +{ + funcall(2, @'gray::stream-finish-output', strm); + return; +} + +static int +clos_stream_input_p(cl_object strm) +{ + return !Null(funcall(2, @'gray::input-stream-p', strm)); +} + +static int +clos_stream_output_p(cl_object strm) +{ + return !Null(funcall(2, @'gray::output-stream-p', strm)); +} + +static int +clos_stream_interactive_p(cl_object strm) +{ + return !Null(funcall(2, @'gray::stream-interactive-p', strm)); + +} + +static cl_object +clos_stream_element_type(cl_object strm) +{ + return funcall(2, @'gray::stream-element-type', strm); +} + +#define clos_stream_length not_a_file_stream +#define clos_stream_get_position not_implemented_get_position +#define clos_stream_set_position not_implemented_set_position + +static int +clos_stream_column(cl_object strm) +{ + cl_object col = funcall(2, @'gray::stream-line-column', strm); + /* FIXME! The Gray streams specifies NIL is a valid + * value but means "unknown". Should we make it + * zero? */ + return Null(col)? 0 : fixnnint(col); +} + +static cl_object +clos_stream_close(cl_object strm) +{ + return funcall(2, @'gray::close', strm); +} + +const struct ecl_file_ops clos_stream_ops = { + clos_stream_write_byte8, + clos_stream_read_byte8, + + clos_stream_read_char, + clos_stream_write_char, + clos_stream_unread_char, + clos_stream_peek_char, + + generic_read_vector, + generic_write_vector, + + clos_stream_listen, + clos_stream_clear_input, + clos_stream_clear_output, + clos_stream_finish_output, + clos_stream_force_output, + + clos_stream_input_p, + clos_stream_output_p, + clos_stream_interactive_p, + clos_stream_element_type, + + clos_stream_length, + clos_stream_get_position, + clos_stream_set_position, + clos_stream_column, + clos_stream_close +}; + +/********************************************************************** + * STRING OUTPUT STREAMS + */ + +#define str_out_read_byte8 not_input_read_byte8 +#define str_out_write_byte8 not_binary_write_byte8 +#define str_out_read_char not_input_read_char +#define str_out_unread_char not_input_unread_char +#define str_out_peek_char generic_peek_char +#define str_out_listen not_input_listen + +static int +str_out_write_char(cl_object strm, int c) +{ + int column = STRING_OUTPUT_COLUMN(strm); + if (c == '\n') + STRING_OUTPUT_COLUMN(strm) = 0; + else if (c == '\t') + STRING_OUTPUT_COLUMN(strm) = (column&~07) + 8; + else + STRING_OUTPUT_COLUMN(strm) = column+1; + ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c); + return c; +} + +#define str_out_clear_input not_input_clear_input +#define str_out_clear_output generic_void +#define str_out_force_output generic_void +#define str_out_finish_output generic_void +#define str_out_input_p generic_always_false +#define str_out_output_p generic_always_true + +static cl_object +str_out_element_type(cl_object strm) +{ + cl_object string = STRING_OUTPUT_STRING(strm); + if (type_of(string) == t_base_string) + return @'base-char'; + return @'character'; +} + +#define str_out_length not_a_file_stream + +static cl_object +str_out_get_position(cl_object strm) +{ + return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp); +} + +static cl_object +str_out_set_position(cl_object strm, cl_object pos) +{ + cl_object string = STRING_OUTPUT_STRING(strm); + cl_fixnum disp; + if (Null(pos)) { + disp = strm->base_string.dim; + } else { + disp = fixnnint(pos); + } + if (disp < string->base_string.fillp) { + string->base_string.fillp = disp; + } else { + disp -= string->base_string.fillp; + while (disp-- > 0) + ecl_write_char(' ', strm); + } + return Ct; +} + +static int +str_out_column(cl_object strm) +{ + return STRING_OUTPUT_COLUMN(strm); +} + +#define str_out_close generic_close + +const struct ecl_file_ops str_out_ops = { + str_out_write_byte8, + str_out_read_byte8, + + str_out_read_char, + str_out_write_char, + str_out_unread_char, + str_out_peek_char, + + generic_read_vector, + generic_write_vector, + + str_out_listen, + str_out_clear_input, + str_out_clear_output, + str_out_finish_output, + str_out_force_output, + + str_out_input_p, + str_out_output_p, + generic_always_false, + str_out_element_type, + + str_out_length, + str_out_get_position, + str_out_set_position, + str_out_column, + str_out_close +}; + + +cl_object +si_make_string_output_stream_from_string(cl_object s) +{ + cl_object strm = alloc_stream(); + if (!ecl_stringp(s) || !s->base_string.hasfillp) + FEerror("~S is not a -string with a fill-pointer.", 1, s); + strm->stream.ops = duplicate_dispatch_table(&str_out_ops); + strm->stream.mode = (short)smm_string_output; + STRING_OUTPUT_STRING(strm) = s; + STRING_OUTPUT_COLUMN(strm) = 0; + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + @(return strm) +} + +cl_object +ecl_make_string_output_stream(cl_index line_length, int extended) +{ +#ifdef ECL_UNICODE + cl_object s = extended? + ecl_alloc_adjustable_extended_string(line_length) : + cl_alloc_adjustable_base_string(line_length); +#else + cl_object s = cl_alloc_adjustable_base_string(line_length); +#endif + return si_make_string_output_stream_from_string(s); +} + +@(defun make-string-output-stream (&key (element_type @'character')) + int extended = 0; +@ + if (element_type == @'base-char') { + (void)0; + } else if (element_type == @'character') { +#ifdef ECL_UNICODE + extended = 1; +#endif + } else if (!Null(funcall(3, @'subtypep', element_type, @'base-char'))) { + (void)0; + } else if (!Null(funcall(3, @'subtypep', element_type, @'character'))) { +#ifdef ECL_UNICODE + extended = 1; +#endif + } else { + FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", + 1, element_type); + } + @(return ecl_make_string_output_stream(128, extended)) +@) + +cl_object +cl_get_output_stream_string(cl_object strm) +{ + cl_object strng; + if (type_of(strm) != t_stream || + (enum ecl_smmode)strm->stream.mode != smm_string_output) + FEerror("~S is not a string-output stream.", 1, strm); + strng = cl_copy_seq(STRING_OUTPUT_STRING(strm)); + STRING_OUTPUT_STRING(strm)->base_string.fillp = 0; + @(return strng) +} + +/********************************************************************** + * STRING INPUT STREAMS + */ + +#define str_in_read_byte8 not_binary_read_byte8 +#define str_in_write_byte8 not_output_write_byte8 + +static int +str_in_read_char(cl_object strm) +{ + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + int c; + if (curr_pos >= STRING_INPUT_LIMIT(strm)) { + c = EOF; + } else { + c = ecl_char(STRING_INPUT_STRING(strm), curr_pos); + STRING_INPUT_POSITION(strm) = curr_pos+1; + } + return c; +} + +#define str_in_write_char not_output_write_char + +static void +str_in_unread_char(cl_object strm, int c) +{ + cl_fixnum curr_pos = STRING_INPUT_POSITION(strm); + if (c <= 0) { + unread_error(strm); + } + STRING_INPUT_POSITION(strm) = curr_pos - 1; +} + +static int +str_in_peek_char(cl_object strm) +{ + cl_index pos = STRING_INPUT_POSITION(strm); + if (pos >= STRING_INPUT_LIMIT(strm)) { + return EOF; + } else { + return ecl_char(STRING_INPUT_STRING(strm), pos); + } +} + +static int +str_in_listen(cl_object strm) +{ + if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm)) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_EOF; +} + +#define str_in_clear_input generic_void +#define str_in_clear_output not_output_clear_output +#define str_in_force_output not_output_force_output +#define str_in_finish_output not_output_finish_output +#define str_in_input_p generic_always_true +#define str_in_output_p generic_always_false + +static cl_object +str_in_element_type(cl_object strm) +{ + cl_object string = STRING_INPUT_STRING(strm); + if (type_of(string) == t_base_string) + return @'base-char'; + return @'character'; +} + +#define str_in_length not_a_file_stream + +static cl_object +str_in_get_position(cl_object strm) +{ + return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm)); +} + +static cl_object +str_in_set_position(cl_object strm, cl_object pos) +{ + cl_fixnum disp; + if (Null(pos)) { + disp = STRING_INPUT_LIMIT(strm); + } else { + disp = fixnnint(pos); + if (disp >= STRING_INPUT_LIMIT(strm)) { + disp = STRING_INPUT_LIMIT(strm); + } + } + STRING_INPUT_POSITION(strm) = disp; + return Ct; +} + +#define str_in_column generic_column +#define str_in_close generic_close + +const struct ecl_file_ops str_in_ops = { + str_in_write_byte8, + str_in_read_byte8, + + str_in_read_char, + str_in_write_char, + str_in_unread_char, + str_in_peek_char, + + generic_read_vector, + generic_write_vector, + + str_in_listen, + str_in_clear_input, + str_in_clear_output, + str_in_finish_output, + str_in_force_output, + + str_in_input_p, + str_in_output_p, + generic_always_false, + str_in_element_type, + + str_in_length, + str_in_get_position, + str_in_set_position, + str_in_column, + str_in_close +}; + +cl_object +ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) +{ + cl_object strm; + + strm = alloc_stream(); + strm->stream.ops = duplicate_dispatch_table(&str_in_ops); + strm->stream.mode = (short)smm_string_input; + STRING_INPUT_STRING(strm) = strng; + STRING_INPUT_POSITION(strm) = istart; + STRING_INPUT_LIMIT(strm) = iend; + strm->stream.format = @':latin-1'; + strm->stream.flags = ECL_STREAM_LATIN_1; + strm->stream.byte_size = 8; + return strm; +} + +@(defun make_string_input_stream (strng &o istart iend) + cl_index s, e; +@ + strng = cl_string(strng); + if (Null(istart)) + s = 0; + else if (!FIXNUMP(istart) || FIXNUM_MINUSP(istart)) + goto E; + else + s = (cl_index)fix(istart); + if (Null(iend)) + e = strng->base_string.fillp; + else if (!FIXNUMP(iend) || FIXNUM_MINUSP(iend)) + goto E; + else + e = (cl_index)fix(iend); + if (e > strng->base_string.fillp || s > e) + goto E; + @(return (ecl_make_string_input_stream(strng, s, e))) + +E: + FEerror("~S and ~S are illegal as :START and :END~%\ +for the string ~S.", + 3, istart, iend, strng); +@) + +/********************************************************************** + * TWO WAY STREAM + */ + +static cl_index +two_way_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + if (strm == cl_core.terminal_io) + ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io)); + return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n); +} + +static cl_index +two_way_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n); +} + +static int +two_way_read_char(cl_object strm) +{ + return ecl_read_char(TWO_WAY_STREAM_INPUT(strm)); +} + +static int +two_way_write_char(cl_object strm, int c) +{ + return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm)); +} + +static void +two_way_unread_char(cl_object strm, int c) +{ + return ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm)); +} + +static int +two_way_peek_char(cl_object strm) +{ + return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm)); +} + +static cl_index +two_way_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) +{ + strm = TWO_WAY_STREAM_INPUT(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); +} + +static cl_index +two_way_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) +{ + strm = TWO_WAY_STREAM_OUTPUT(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); +} + +static int +two_way_listen(cl_object strm) +{ + return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm)); +} + +static void +two_way_clear_input(cl_object strm) +{ + return ecl_clear_input(TWO_WAY_STREAM_INPUT(strm)); +} + +static void +two_way_clear_output(cl_object strm) +{ + return ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm)); +} + +static void +two_way_force_output(cl_object strm) +{ + return ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm)); +} + +static void +two_way_finish_output(cl_object strm) +{ + return ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm)); +} + +#define two_way_input_p generic_always_true +#define two_way_output_p generic_always_true + +static int +two_way_interactive_p(cl_object strm) +{ + return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm)); +} + +static cl_object +two_way_element_type(cl_object strm) +{ + return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm)); +} + +#define two_way_length not_a_file_stream +#define two_way_get_position generic_always_nil +#define two_way_set_position generic_set_position + +static int +two_way_column(cl_object strm) +{ + return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm)); +} + +#define two_way_close generic_close + +const struct ecl_file_ops two_way_ops = { + two_way_write_byte8, + two_way_read_byte8, + + two_way_read_char, + two_way_write_char, + two_way_unread_char, + two_way_peek_char, + + two_way_read_vector, + two_way_write_vector, + + two_way_listen, + two_way_clear_input, + two_way_clear_output, + two_way_finish_output, + two_way_force_output, + + two_way_input_p, + two_way_output_p, + two_way_interactive_p, + two_way_element_type, + + two_way_length, + two_way_get_position, + two_way_set_position, + two_way_column, + two_way_close +}; + + +cl_object +cl_make_two_way_stream(cl_object istrm, cl_object ostrm) +{ + cl_object strm; + if (!ecl_input_stream_p(istrm)) + not_an_input_stream(istrm); + if (!ecl_output_stream_p(ostrm)) + not_an_output_stream(ostrm); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(istrm); + strm->stream.mode = (short)smm_two_way; + strm->stream.ops = duplicate_dispatch_table(&two_way_ops); + TWO_WAY_STREAM_INPUT(strm) = istrm; + TWO_WAY_STREAM_OUTPUT(strm) = ostrm; + @(return strm) +} + +cl_object +cl_two_way_stream_input_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) + FEwrong_type_argument(@'two-way-stream', strm); + @(return TWO_WAY_STREAM_INPUT(strm)) +} + +cl_object +cl_two_way_stream_output_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) + FEwrong_type_argument(@'two-way-stream', strm); + @(return TWO_WAY_STREAM_OUTPUT(strm)) +} + +/********************************************************************** + * BROADCAST STREAM + */ + +#define broadcast_read_byte8 not_input_read_byte8 + +static cl_index +broadcast_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + cl_object l; + cl_index out = n; + for (l = BROADCAST_STREAM_LIST(strm); !ecl_endp(l); l = ECL_CONS_CDR(l)) { + out = ecl_write_byte8(ECL_CONS_CAR(l), c, n); + } + return out; +} + +#define broadcast_read_char not_input_read_char + +static int +broadcast_write_char(cl_object strm, int c) +{ + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !ecl_endp(l); l = ECL_CONS_CDR(l)) { + ecl_write_char(c, ECL_CONS_CAR(l)); + } + return c; +} + +#define broadcast_unread_char not_input_unread_char +#define broadcast_peek_char not_input_read_char +#define broadcast_listen not_input_listen + +/* FIXME! This is legacy behaviour */ +#define broadcast_clear_input broadcast_force_output + +static void +broadcast_clear_output(cl_object strm) +{ + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !ecl_endp(l); l = ECL_CONS_CDR(l)) { + ecl_clear_output(ECL_CONS_CAR(l)); + } +} + +static void +broadcast_force_output(cl_object strm) +{ + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !ecl_endp(l); l = ECL_CONS_CDR(l)) { + ecl_force_output(ECL_CONS_CAR(l)); + } +} + +static void +broadcast_finish_output(cl_object strm) +{ + cl_object l; + for (l = BROADCAST_STREAM_LIST(strm); !ecl_endp(l); l = ECL_CONS_CDR(l)) { + ecl_finish_output(ECL_CONS_CAR(l)); + } +} + +#define broadcast_input_p generic_always_false +#define broadcast_output_p generic_always_true + +static cl_object +broadcast_element_type(cl_object strm) +{ + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return Ct; + return ecl_stream_element_type(ECL_CONS_CAR(l)); +} + +static cl_object +broadcast_length(cl_object strm) +{ + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return MAKE_FIXNUM(0); + return ecl_file_length(ECL_CONS_CAR(l)); +} + +static cl_object +broadcast_get_position(cl_object strm) +{ + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return MAKE_FIXNUM(0); + return ecl_file_position(ECL_CONS_CAR(l)); +} + +static cl_object +broadcast_set_position(cl_object strm, cl_object pos) +{ + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return Cnil; + return ecl_file_position_set(ECL_CONS_CAR(l), pos); +} + +static int +broadcast_column(cl_object strm) +{ + cl_object l = BROADCAST_STREAM_LIST(strm); + if (Null(l)) + return 0; + return ecl_file_column(ECL_CONS_CAR(l)); +} + +#define broadcast_close generic_close + +const struct ecl_file_ops broadcast_ops = { + broadcast_write_byte8, + broadcast_read_byte8, + + broadcast_read_char, + broadcast_write_char, + broadcast_unread_char, + broadcast_peek_char, + + generic_read_vector, + generic_write_vector, + + broadcast_listen, + broadcast_clear_input, + broadcast_clear_output, + broadcast_finish_output, + broadcast_force_output, + + broadcast_input_p, + broadcast_output_p, + generic_always_false, + broadcast_element_type, + + broadcast_length, + broadcast_get_position, + broadcast_set_position, + broadcast_column, + broadcast_close +}; + +@(defun make_broadcast_stream (&rest ap) + cl_object x, streams; + int i; +@ + streams = Cnil; + for (i = 0; i < narg; i++) { + x = cl_va_arg(ap); + if (!ecl_output_stream_p(x)) + not_an_output_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + if (Null(streams)) { + x->stream.format = @':default'; + } else { + x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); + } + x->stream.ops = duplicate_dispatch_table(&broadcast_ops); + x->stream.mode = (short)smm_broadcast; + BROADCAST_STREAM_LIST(x) = cl_nreverse(streams); + @(return x) +@) + +cl_object +cl_broadcast_stream_streams(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_broadcast) + FEwrong_type_argument(@'broadcast-stream', strm); + return cl_copy_list(BROADCAST_STREAM_LIST(strm)); +} + +/********************************************************************** + * ECHO STREAM + */ + +static cl_index +echo_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n); + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out); +} + +static cl_index +echo_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n); +} + +static int +echo_read_char(cl_object strm) +{ + int c = strm->stream.unread; + if (c == EOF) { + c = ecl_read_char(ECHO_STREAM_INPUT(strm)); + if (c != EOF) + ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); + } else { + strm->stream.unread = EOF; + } + return c; +} + +static int +echo_write_char(cl_object strm, int c) +{ + return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm)); +} + +#define echo_unread_char generic_unread_char + +static int +echo_peek_char(cl_object strm) +{ + int c = strm->stream.unread; + if (c == EOF) { + c = ecl_peek_char(ECHO_STREAM_INPUT(strm)); + } + return c; +} + +static int +echo_listen(cl_object strm) +{ + return ecl_listen_stream(ECHO_STREAM_INPUT(strm)); +} + +static void +echo_clear_input(cl_object strm) +{ + return ecl_clear_input(ECHO_STREAM_INPUT(strm)); +} + +static void +echo_clear_output(cl_object strm) +{ + return ecl_clear_output(ECHO_STREAM_OUTPUT(strm)); +} + +static void +echo_force_output(cl_object strm) +{ + return ecl_force_output(ECHO_STREAM_OUTPUT(strm)); +} + +static void +echo_finish_output(cl_object strm) +{ + return ecl_finish_output(ECHO_STREAM_OUTPUT(strm)); +} + +#define echo_input_p generic_always_true +#define echo_output_p generic_always_true + +static cl_object +echo_element_type(cl_object strm) +{ + return ecl_stream_element_type(ECHO_STREAM_INPUT(strm)); +} + +#define echo_length not_a_file_stream +#define echo_get_position generic_always_nil +#define echo_set_position generic_set_position + +static int +echo_column(cl_object strm) +{ + return ecl_file_column(ECHO_STREAM_OUTPUT(strm)); +} + +#define echo_close generic_close + +const struct ecl_file_ops echo_ops = { + echo_write_byte8, + echo_read_byte8, + + echo_read_char, + echo_write_char, + echo_unread_char, + echo_peek_char, + + generic_read_vector, + generic_write_vector, + + echo_listen, + echo_clear_input, + echo_clear_output, + echo_finish_output, + echo_force_output, + + echo_input_p, + echo_output_p, + generic_always_false, + echo_element_type, + + echo_length, + echo_get_position, + echo_set_position, + echo_column, + echo_close +}; + +cl_object +cl_make_echo_stream(cl_object strm1, cl_object strm2) +{ + cl_object strm; + if (!ecl_input_stream_p(strm1)) + not_an_input_stream(strm1); + if (!ecl_output_stream_p(strm2)) + not_an_output_stream(strm2); + strm = alloc_stream(); + strm->stream.format = cl_stream_external_format(strm1); + strm->stream.mode = (short)smm_echo; + strm->stream.ops = duplicate_dispatch_table(&echo_ops); + ECHO_STREAM_INPUT(strm) = strm1; + ECHO_STREAM_OUTPUT(strm) = strm2; + @(return strm) +} + +cl_object +cl_echo_stream_input_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) + FEwrong_type_argument(@'echo-stream', strm); + @(return ECHO_STREAM_INPUT(strm)) +} + +cl_object +cl_echo_stream_output_stream(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) + FEwrong_type_argument(@'echo-stream', strm); + @(return ECHO_STREAM_OUTPUT(strm)) +} + +/********************************************************************** + * CONCATENATED STREAM + */ + +static cl_index +concatenated_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + cl_object l = CONCATENATED_STREAM_LIST(strm); + cl_index out = 0; + while (out < n && !ecl_endp(l)) { + cl_index left = n - out; + cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out); + out += delta; + if (out == n) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return out; +} + +#define concatenated_write_byte8 not_output_write_byte8 + +static int +concatenated_read_char(cl_object strm) +{ + cl_object l = CONCATENATED_STREAM_LIST(strm); + int c = EOF; + while (!ecl_endp(l)) { + c = ecl_read_char(ECL_CONS_CAR(l)); + if (c != EOF) break; + CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l); + } + return c; +} + +#define concatenated_write_char not_output_write_char + +static void +concatenated_unread_char(cl_object strm, int c) +{ + cl_object l = CONCATENATED_STREAM_LIST(strm); + if (Null(l)) + unread_error(strm); + return ecl_unread_char(c, ECL_CONS_CAR(l)); +} + +#define concatenated_peek_char generic_peek_char + +static int +concatenated_listen(cl_object strm) +{ + cl_object l = CONCATENATED_STREAM_LIST(strm); + while (!ecl_endp(l)) { + int f = ecl_listen_stream(ECL_CONS_CAR(l)); + l = ECL_CONS_CDR(l); + if (f == ECL_LISTEN_EOF) { + CONCATENATED_STREAM_LIST(strm) = l; + } else { + return f; + } + } + return ECL_LISTEN_EOF; +} + +#define concatenated_clear_input generic_void +#define concatenated_clear_output not_output_clear_output +#define concatenated_force_output not_output_force_output +#define concatenated_finish_output not_output_finish_output + +#define concatenated_input_p generic_always_true +#define concatenated_output_p generic_always_false +#define concatenated_element_type broadcast_element_type + +#define concatenated_length not_a_file_stream +#define concatenated_get_position generic_always_nil +#define concatenated_set_position generic_set_position +#define concatenated_column generic_column + +#define concatenated_close generic_close + +const struct ecl_file_ops concatenated_ops = { + concatenated_write_byte8, + concatenated_read_byte8, + + concatenated_read_char, + concatenated_write_char, + concatenated_unread_char, + concatenated_peek_char, + + generic_read_vector, + generic_write_vector, + + concatenated_listen, + concatenated_clear_input, + concatenated_clear_output, + concatenated_finish_output, + concatenated_force_output, + + concatenated_input_p, + concatenated_output_p, + generic_always_false, + concatenated_element_type, + + concatenated_length, + concatenated_get_position, + concatenated_set_position, + concatenated_column, + concatenated_close +}; + +@(defun make_concatenated_stream (&rest ap) + cl_object x, streams; + int i; +@ + streams = Cnil; + for (i = 0; i < narg; i++) { + x = cl_va_arg(ap); + if (!ecl_input_stream_p(x)) + not_an_input_stream(x); + streams = CONS(x, streams); + } + x = alloc_stream(); + if (Null(streams)) { + x->stream.format = @':default'; + } else { + x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams)); + } + x->stream.mode = (short)smm_concatenated; + x->stream.ops = duplicate_dispatch_table(&concatenated_ops); + CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams); + @(return x) +@) + +cl_object +cl_concatenated_stream_streams(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_concatenated) + FEwrong_type_argument(@'concatenated-stream', strm); + return cl_copy_list(CONCATENATED_STREAM_LIST(strm)); +} + +/********************************************************************** + * SYNONYM STREAM + */ + +static cl_index +synonym_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n); +} + +static cl_index +synonym_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n); +} + +static int +synonym_read_char(cl_object strm) +{ + return ecl_read_char(SYNONYM_STREAM_STREAM(strm)); +} + +static int +synonym_write_char(cl_object strm, int c) +{ + return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm)); +} + +static void +synonym_unread_char(cl_object strm, int c) +{ + return ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm)); +} + +static int +synonym_peek_char(cl_object strm) +{ + return ecl_peek_char(SYNONYM_STREAM_STREAM(strm)); +} + +static cl_index +synonym_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n) +{ + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->read_vector(strm, data, start, n); +} + +static cl_index +synonym_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n) +{ + strm = SYNONYM_STREAM_STREAM(strm); + return stream_dispatch_table(strm)->write_vector(strm, data, start, n); +} + +static int +synonym_listen(cl_object strm) +{ + return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm)); +} + +static void +synonym_clear_input(cl_object strm) +{ + return ecl_clear_input(SYNONYM_STREAM_STREAM(strm)); +} + +static void +synonym_clear_output(cl_object strm) +{ + return ecl_clear_output(SYNONYM_STREAM_STREAM(strm)); +} + +static void +synonym_force_output(cl_object strm) +{ + return ecl_force_output(SYNONYM_STREAM_STREAM(strm)); +} + +static void +synonym_finish_output(cl_object strm) +{ + return ecl_finish_output(SYNONYM_STREAM_STREAM(strm)); +} + +static int +synonym_input_p(cl_object strm) +{ + return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm)); +} + +static int +synonym_output_p(cl_object strm) +{ + return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm)); +} + +static int +synonym_interactive_p(cl_object strm) +{ + return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm)); +} + +static cl_object +synonym_element_type(cl_object strm) +{ + return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm)); +} + +static cl_object +synonym_length(cl_object strm) +{ + return ecl_file_length(SYNONYM_STREAM_STREAM(strm)); +} + +static cl_object +synonym_get_position(cl_object strm) +{ + return ecl_file_position(SYNONYM_STREAM_STREAM(strm)); +} + +static cl_object +synonym_set_position(cl_object strm, cl_object pos) +{ + return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos); +} + +static int +synonym_column(cl_object strm) +{ + return ecl_file_column(SYNONYM_STREAM_STREAM(strm)); +} + +#define synonym_close generic_close + +const struct ecl_file_ops synonym_ops = { + synonym_write_byte8, + synonym_read_byte8, + + synonym_read_char, + synonym_write_char, + synonym_unread_char, + synonym_peek_char, + + synonym_read_vector, + synonym_write_vector, + + synonym_listen, + synonym_clear_input, + synonym_clear_output, + synonym_finish_output, + synonym_force_output, + + synonym_input_p, + synonym_output_p, + synonym_interactive_p, + synonym_element_type, + + synonym_length, + synonym_get_position, + synonym_set_position, + synonym_column, + synonym_close +}; + +cl_object +cl_make_synonym_stream(cl_object sym) +{ + cl_object x; + + sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); + x = alloc_stream(); + x->stream.ops = duplicate_dispatch_table(&synonym_ops); + x->stream.mode = (short)smm_synonym; + SYNONYM_STREAM_SYMBOL(x) = sym; + @(return x) +} + +cl_object +cl_synonym_stream_symbol(cl_object strm) +{ + if (type_of(strm) != t_stream || strm->stream.mode != smm_synonym) + FEwrong_type_argument(@'synonym-stream', strm); + @(return SYNONYM_STREAM_SYMBOL(strm)) +} + +/********************************************************************** + * POSIX FILE STREAM + */ + +static cl_index +io_file_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + int f = IO_FILE_DESCRIPTOR(strm); + cl_fixnum out; + ecl_disable_interrupts(); + do { + out = read(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm)); + ecl_enable_interrupts(); + return out; +} + +static cl_index +io_file_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + int f = IO_FILE_DESCRIPTOR(strm); + cl_index out; + ecl_disable_interrupts(); + do { + out = write(f, c, sizeof(char)*n); + } while (out < 0 && restartable_io_error(strm)); + ecl_enable_interrupts(); + return out; +} + +#define io_file_read_char generic_read_char + +static int +io_file_write_char(cl_object strm, int c) +{ + if (c > 0xFF) { + character_size_overflow(strm, c); + } + strm->stream.unread = EOF; + if (c == '\n') + IO_FILE_COLUMN(strm) = 0; + else if (c == '\t') + IO_FILE_COLUMN(strm) = (IO_FILE_COLUMN(strm)&~07) + 8; + else + IO_FILE_COLUMN(strm)++; + { + unsigned char aux = c; + io_file_write_byte8(strm, &aux, 1); + } + return c; +} + +#define io_file_unread_char generic_unread_char +#define io_file_peek_char generic_peek_char + +static int +io_file_listen(cl_object strm) +{ + if (strm->stream.unread != EOF) + return ECL_LISTEN_AVAILABLE; + if (strm->stream.flags & ECL_STREAM_MIGHT_SEEK) { + cl_env_ptr the_env = ecl_process_env(); + int f = IO_FILE_DESCRIPTOR(strm); + ecl_off_t disp, new; + ecl_disable_interrupts_env(the_env); + disp = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts_env(the_env); + if (disp != (ecl_off_t)-1) { + ecl_disable_interrupts_env(the_env); + new = lseek(f, 0, SEEK_END); + ecl_enable_interrupts_env(the_env); + lseek(f, disp, SEEK_SET); + if (new == disp) { + return ECL_LISTEN_NO_CHAR; + } else if (new != (ecl_off_t)-1) { + return ECL_LISTEN_AVAILABLE; + } + } + } + return file_listen(IO_FILE_DESCRIPTOR(strm)); +} + +static void +io_file_clear_input(cl_object strm) +{ + int f = IO_FILE_DESCRIPTOR(strm); +#if defined(mingw32) || defined(_MSC_VER) + if (isatty(f)) { + /* Flushes Win32 console */ + if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(fileno(fp)))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } +#endif + while (file_listen(f) == ECL_LISTEN_AVAILABLE) { + io_file_read_char(strm); + } +} + +#define io_file_clear_output generic_void +#define io_file_force_output generic_void +#define io_file_finish_output io_file_force_output +#define io_file_input_p generic_always_true +#define io_file_output_p generic_always_true + +static int +io_file_interactive_p(cl_object strm) +{ + int f = IO_FILE_DESCRIPTOR(strm); + return isatty(f); +} + +static cl_object +io_file_element_type(cl_object strm) +{ + return IO_FILE_ELT_TYPE(strm); +} + +static cl_object +io_file_length(cl_object strm) +{ + int f = IO_FILE_DESCRIPTOR(strm); + cl_object output = ecl_file_len(f); + if (strm->stream.byte_size != 8) { + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, MAKE_FIXNUM(bs/8)); + if (VALUES(1) != MAKE_FIXNUM(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; +} + +static cl_object +io_file_get_position(cl_object strm) +{ + int f = IO_FILE_DESCRIPTOR(strm); + cl_object output; + ecl_off_t offset; + + ecl_disable_interrupts(); + offset = lseek(f, 0, SEEK_CUR); + ecl_enable_interrupts(); + if (offset < 0) + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, MAKE_FIXNUM(strm->stream.byte_size / 8)); + } + return output; +} + +static cl_object +io_file_set_position(cl_object strm, cl_object large_disp) +{ + int f = IO_FILE_DESCRIPTOR(strm); + ecl_off_t disp; + int mode; + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + MAKE_FIXNUM(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + disp = lseek(f, disp, mode); + return (disp == (ecl_off_t)-1)? Cnil : Ct; +} + +static int +io_file_column(cl_object strm) +{ + return IO_FILE_COLUMN(strm); +} + +static cl_object +io_file_close(cl_object strm) +{ + int f = IO_FILE_DESCRIPTOR(strm); + int failed; + if (f == STDOUT_FILENO) + FEerror("Cannot close the standard output", 0); + if (f == STDIN_FILENO) + FEerror("Cannot close the standard input", 0); + ecl_disable_interrupts(); + failed = close(f); + ecl_enable_interrupts(); + if (failed < 0) + FElibc_error("Cannot close stream ~S.", 1, strm); + strm->stream.file = (void*)-1; + return generic_close(strm); +} + +static cl_index +io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end) +{ + cl_elttype t = data->vector.elttype; + if (start >= end) + return start; + if (t == aet_b8 || t == aet_i8 || t == aet_bc) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.ch + start; + return strm->stream.ops->read_byte8(strm, aux, end-start); + } + } else if (t == aet_fix || t == aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->read_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_read_vector(strm, data, start, end); +} + +static cl_index +io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end) +{ + cl_elttype t = data->vector.elttype; + if (start >= end) + return start; + if (t == aet_b8 || t == aet_i8 || t == aet_bc) { + if (strm->stream.byte_size == 8) { + void *aux = data->vector.self.fix + start; + return strm->stream.ops->write_byte8(strm, aux, end-start); + } + } else if (t == aet_fix || t == aet_index) { + if (strm->stream.byte_size == sizeof(cl_fixnum)*8) { + void *aux = data->vector.self.fix + start; + cl_index bytes = (end - start) * sizeof(cl_fixnum); + bytes = strm->stream.ops->write_byte8(strm, aux, bytes); + return start + bytes / sizeof(cl_fixnum); + } + } + return generic_write_vector(strm, data, start, end); +} + +const struct ecl_file_ops io_file_ops = { + io_file_write_byte8, + io_file_read_byte8, + + io_file_read_char, + io_file_write_char, + io_file_unread_char, + io_file_peek_char, + + io_file_read_vector, + io_file_write_vector, + + io_file_listen, + io_file_clear_input, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, + + io_file_input_p, + io_file_output_p, + io_file_interactive_p, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close +}; + +const struct ecl_file_ops output_file_ops = { + io_file_write_byte8, + not_input_read_byte8, + + not_input_read_char, + io_file_write_char, + not_input_unread_char, + not_input_read_char, + + generic_read_vector, + io_file_write_vector, + + not_input_listen, + generic_void, + io_file_clear_output, + io_file_finish_output, + io_file_force_output, + + generic_always_false, + io_file_output_p, + generic_always_false, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + io_file_column, + io_file_close +}; + +const struct ecl_file_ops input_file_ops = { + not_output_write_byte8, + io_file_read_byte8, + + io_file_read_char, + not_output_write_char, + io_file_unread_char, + io_file_peek_char, + + io_file_read_vector, + generic_write_vector, + + io_file_listen, + io_file_clear_input, + generic_void, + generic_void, + generic_void, + + io_file_input_p, + generic_always_false, + io_file_interactive_p, + io_file_element_type, + + io_file_length, + io_file_get_position, + io_file_set_position, + generic_column, + io_file_close +}; + +static void +set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags) +{ + cl_object t; + if (byte_size < 0) { + byte_size = -byte_size; + flags |= ECL_STREAM_SIGNED_BYTES; + t = @'signed-byte'; + } else { + flags &= ~ECL_STREAM_SIGNED_BYTES; + t = @'unsigned-byte'; + } + switch (flags & ECL_STREAM_FORMAT) { + case ECL_STREAM_BINARY: + IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, MAKE_FIXNUM(byte_size)); + stream->stream.format = @':default'; + stream->stream.ops->read_char = not_character_read_char; + stream->stream.ops->write_char = not_character_write_char; + break; + /*case ECL_ISO_8859_1:*/ + case ECL_STREAM_LATIN_1: + IO_STREAM_ELT_TYPE(stream) = @'base-char'; + stream->stream.format = @':latin-1'; + byte_size = 8; + break; +#ifdef ECL_UNICODE + case ECL_STREAM_UTF_8: + IO_STREAM_ELT_TYPE(stream) = @'character'; + byte_size = 8; + stream->stream.format = @':utf-8'; + stream->stream.ops->read_char = utf_8_read_char; + stream->stream.ops->write_char = utf_8_write_char; + break; + case ECL_STREAM_UCS_2: + IO_STREAM_ELT_TYPE(stream) = @'character'; + stream->stream.format = @':ucs-2'; + stream->stream.ops->read_char = ucs_2_read_char; + stream->stream.ops->write_char = ucs_2_write_char; + byte_size = 8*2; + break; + case ECL_STREAM_UCS_4: + IO_STREAM_ELT_TYPE(stream) = @'character'; + stream->stream.format = @':ucs-4'; + stream->stream.ops->read_char = ucs_4_read_char; + stream->stream.ops->write_char = ucs_4_write_char; + byte_size = 8*4; + break; +#endif + default: + FEerror("Invalid external format code ~D", 1, MAKE_FIXNUM(flags)); + } + stream->stream.flags = flags; + stream->stream.byte_size = (byte_size+7)&(~(cl_fixnum)7); +} + +cl_object +ecl_make_file_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, + cl_fixnum byte_size, int flags) +{ + cl_object stream = alloc_stream(); + stream->stream.mode = (short)smm; + stream->stream.closed = 0; +#if defined (ECL_WSOCK) + if (smm == smm_input_wsock || smm == smm_io_wsock) + character_p = 1; +#endif + switch(smm) { + case smm_probe: + case smm_input: + smm = smm_input_file; + case smm_input_file: + stream->stream.ops = duplicate_dispatch_table(&input_file_ops); + break; + case smm_output: + smm = smm_output_file; + case smm_output_file: + stream->stream.ops = duplicate_dispatch_table(&output_file_ops); + break; + case smm_io: + smm = smm_io_file; + case smm_io_file: + stream->stream.ops = duplicate_dispatch_table(&io_file_ops); + break; + default: + FEerror("make_stream: wrong mode", 0); + } + set_stream_elt_type(stream, byte_size, flags); + IO_FILE_FILENAME(stream) = fname; /* not really used */ + IO_FILE_COLUMN(stream) = 0; + stream->stream.file = (void*)fd; + stream->stream.last_op = 0; + si_set_finalizer(stream, Ct); + return stream; +} + +/********************************************************************** + * C STREAMS + */ + +static cl_index +io_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + FILE *f = IO_STREAM_FILE(strm); + cl_index out; + if (strm->stream.mode == smm_io) + io_stream_begin_write(strm); + ecl_disable_interrupts(); + do { + out = fread(c, sizeof(char), n, IO_STREAM_FILE(strm)); + } while (out < n && ferror(f) && restartable_io_error(strm)); + ecl_enable_interrupts(); + return out; +} + +static cl_index +io_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + FILE *f = IO_STREAM_FILE(strm); + cl_index out; + if (strm->stream.mode == smm_io) + io_stream_begin_write(strm); + ecl_disable_interrupts(); + do { + out = fwrite(c, sizeof(char), n, IO_STREAM_FILE(strm)); + } while (out < n && restartable_io_error(strm)); + ecl_enable_interrupts(); + return out; +} + +static int +io_stream_read_char(cl_object strm) +{ + int c = strm->stream.unread; + if (c != EOF) { + strm->stream.unread = EOF; + } else { + FILE *f = IO_STREAM_FILE(strm); + char aux; + ecl_disable_interrupts(); + do { + c = getc(f); + } while ((c == EOF) && ferror(f) && restartable_io_error(strm)); + ecl_enable_interrupts(); + } + return c; +} + +static int +io_stream_write_char(cl_object strm, int c) +{ + FILE *f = IO_STREAM_FILE(strm); + int outcome; + if (c > 0xFF) { + character_size_overflow(strm, c); + } + strm->stream.unread = EOF; + ecl_disable_interrupts(); + do { + char aux = c; + outcome = putc(c, f); + } while (outcome == EOF && restartable_io_error(strm)); + ecl_enable_interrupts(); + if (c == '\n') + IO_STREAM_COLUMN(strm) = 0; + else if (c == '\t') + IO_STREAM_COLUMN(strm) = (IO_STREAM_COLUMN(strm)&~07) + 8; + else + IO_STREAM_COLUMN(strm)++; + return c; +} + +#define io_stream_unread_char generic_unread_char +#define io_stream_peek_char generic_peek_char + +static int +io_stream_listen(cl_object strm) +{ + if (strm->stream.unread != EOF) + return ECL_LISTEN_AVAILABLE; + return flisten(IO_STREAM_FILE(strm)); +} + +static void +io_stream_clear_input(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); +#if defined(mingw32) || defined(_MSC_VER) + if (isatty(fileno(fp))) { + /* Flushes Win32 console */ + if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(fileno(fp)))) + FEwin32_error("FlushConsoleInputBuffer() failed", 0); + /* Do not stop here: the FILE structure needs also to be flushed */ + } +#endif + while (flisten(f) == ECL_LISTEN_AVAILABLE) { + ecl_disable_interrupts(); + getc(f); + ecl_enable_interrupts(); + } +} + +#define io_stream_clear_output generic_void + +static void +io_stream_force_output(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); + ecl_disable_interrupts(); + while ((fflush(f) == EOF) && restartable_io_error(strm)) + (void)0; + ecl_enable_interrupts(); +} + +#define io_stream_finish_output generic_void +#define io_stream_input_p generic_always_true +#define io_stream_output_p generic_always_true + +static int +io_stream_interactive_p(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); + return isatty(fileno(f)); +} + +#define io_stream_element_type io_file_element_type + +static cl_object +io_stream_length(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); + cl_object output = ecl_file_len(fileno(f)); + if (strm->stream.byte_size != 8) { + cl_index bs = strm->stream.byte_size; + output = ecl_floor2(output, MAKE_FIXNUM(bs/8)); + if (VALUES(1) != MAKE_FIXNUM(0)) { + FEerror("File length is not on byte boundary", 0); + } + } + return output; +} + +static cl_object +io_stream_get_position(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); + cl_object output; + ecl_off_t offset; + + ecl_disable_interrupts(); + offset = ecl_ftello(f); + ecl_enable_interrupts(); + if (offset < 0) + io_error(strm); + if (sizeof(ecl_off_t) == sizeof(long)) { + output = ecl_make_integer(offset); + } else { + output = ecl_off_t_to_integer(offset); + } + if (strm->stream.byte_size != 8) { + output = ecl_floor2(output, MAKE_FIXNUM(strm->stream.byte_size / 8)); + } + return output; +} + +static cl_object +io_stream_set_position(cl_object strm, cl_object large_disp) +{ + FILE *f = IO_STREAM_FILE(strm); + ecl_off_t disp; + int mode; + if (Null(large_disp)) { + disp = 0; + mode = SEEK_END; + } else { + if (strm->stream.byte_size != 8) { + large_disp = ecl_times(large_disp, + MAKE_FIXNUM(strm->stream.byte_size / 8)); + } + disp = ecl_integer_to_off_t(large_disp); + mode = SEEK_SET; + } + ecl_disable_interrupts(); + mode = ecl_fseeko(f, disp, mode); + ecl_enable_interrupts(); + return mode? Cnil : Ct; +} + +static int +io_stream_column(cl_object strm) +{ + return IO_STREAM_COLUMN(strm); +} + +static cl_object +io_stream_close(cl_object strm) +{ + FILE *f = IO_STREAM_FILE(strm); + int failed; + if (f == stdout) + FEerror("Cannot close the standard output", 0); + if (f == stdin) + FEerror("Cannot close the standard input", 0); + if (f == NULL) + wrong_file_handler(strm); + if (ecl_output_stream_p(strm)) { + ecl_force_output(strm); + } + ecl_disable_interrupts(); + failed = fclose(f); + ecl_enable_interrupts(); + if (failed) + FElibc_error("Cannot close stream ~S.", 1, strm); +#if !defined(GBC_BOEHM) + ecl_dealloc(strm->stream.buffer); + strm->stream.file = NULL; +#endif + return generic_close(strm); +} + +/* + * Specialized sequence operations + */ + +#define io_stream_read_vector io_file_read_vector +#define io_stream_write_vector io_file_write_vector + +const struct ecl_file_ops io_stream_ops = { + io_stream_write_byte8, + io_stream_read_byte8, + + io_stream_read_char, + io_stream_write_char, + io_stream_unread_char, + io_stream_peek_char, + + io_stream_read_vector, + io_stream_write_vector, + + io_stream_listen, + io_stream_clear_input, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, + + io_stream_input_p, + io_stream_output_p, + io_stream_interactive_p, + io_stream_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close +}; + +const struct ecl_file_ops output_stream_ops = { + io_stream_write_byte8, + not_input_read_byte8, + + not_input_read_char, + io_stream_write_char, + not_input_unread_char, + not_input_read_char, + + generic_read_vector, + io_stream_write_vector, + + not_input_listen, + generic_void, + io_stream_clear_output, + io_stream_finish_output, + io_stream_force_output, + + generic_always_false, + io_stream_output_p, + generic_always_false, + io_stream_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + io_stream_column, + io_stream_close +}; + +const struct ecl_file_ops input_stream_ops = { + not_output_write_byte8, + io_stream_read_byte8, + + io_stream_read_char, + not_output_write_char, + io_stream_unread_char, + io_stream_peek_char, + + io_stream_read_vector, + generic_write_vector, + + io_stream_listen, + io_stream_clear_input, + generic_void, + generic_void, + generic_void, + + io_stream_input_p, + generic_always_false, + io_stream_interactive_p, + io_stream_element_type, + + io_stream_length, + io_stream_get_position, + io_stream_set_position, + generic_column, + io_stream_close +}; + +cl_object +si_set_buffering_mode(cl_object stream, cl_object buffer_mode_symbol) +{ + enum ecl_smmode mode = stream->stream.mode; + int buffer_mode; + + if (type_of(stream) != t_stream) { + FEerror("Cannot set buffer of ~A", 1, stream); + } + if (buffer_mode_symbol == Cnil) { + buffer_mode = _IONBF; + } else if (buffer_mode_symbol == Ct || buffer_mode_symbol == @':fully-buffered') { + buffer_mode = _IOFBF; + } else if (buffer_mode_symbol == @':line-buffered') { + buffer_mode = _IOLBF; + } else { + FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); + } + if (mode == smm_output || mode == smm_io || mode == smm_input) { + FILE *fp = (FILE*)stream->stream.file; + setvbuf(fp, 0, _IONBF, 0); + if (buffer_mode != _IONBF) { + cl_index buffer_size = BUFSIZ; + char *new_buffer = ecl_alloc_atomic(buffer_size); + stream->stream.buffer = new_buffer; + setvbuf(fp, new_buffer, buffer_mode, buffer_size); + } + } + @(return stream) +} + +cl_object +ecl_make_stream_from_FILE(cl_object fname, void *f, enum ecl_smmode smm, + cl_fixnum byte_size, int flags) +{ + cl_object stream; + stream = alloc_stream(); + stream->stream.mode = (short)smm; + stream->stream.closed = 0; +#if defined (ECL_WSOCK) + if (smm == smm_input_wsock || smm == smm_io_wsock) + character_p = 1; +#endif + switch (smm) { + case smm_io: + stream->stream.ops = duplicate_dispatch_table(&io_stream_ops); + break; + case smm_probe: + case smm_input: + stream->stream.ops = duplicate_dispatch_table(&input_stream_ops); + break; + case smm_output: + stream->stream.ops = duplicate_dispatch_table(&output_stream_ops); + break; + default: + FEerror("Not a valid mode ~D for ecl_make_stream_from_FILE", 1, MAKE_FIXNUM(smm)); + } + set_stream_elt_type(stream, byte_size, flags); + IO_STREAM_FILENAME(stream) = fname; /* not really used */ + IO_STREAM_COLUMN(stream) = 0; + stream->stream.file = f; + stream->stream.last_op = 0; + si_set_finalizer(stream, Ct); + return stream; +} + +cl_object +ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, + cl_fixnum byte_size, int flags) +{ + char *mode; /* file open mode */ + FILE *fp; /* file pointer */ + switch(smm) { + case smm_input: + mode = "r"; + break; + case smm_output: + mode = "w"; + break; + case smm_io: + mode = "w+"; + break; +#if defined(ECL_WSOCK) + case smm_input_wsock: + case smm_output_wsock: + case smm_io_wsock: + break; +#endif + default: + FEerror("make_stream: wrong mode", 0); + } + ecl_disable_interrupts(); +#if defined(ECL_WSOCK) + if (smm == smm_input_wsock || smm == smm_output_wsock || smm == smm_io_wsock) + fp = (FILE*)fd; + else + fp = fdopen(fd, mode); +#else + fp = fdopen(fd, mode); +#endif + ecl_enable_interrupts(); + return ecl_make_stream_from_FILE(fname, fp, smm, byte_size, flags); +} + + +int +ecl_stream_to_handle(cl_object s, bool output) +{ + BEGIN: + if (type_of(s) != t_stream) + return -1; + switch ((enum ecl_smmode)s->stream.mode) { + case smm_input: + if (output) return -1; + return fileno((FILE*)s->stream.file); + case smm_input_file: + if (output) return -1; + return (int)s->stream.file; + case smm_output: + if (!output) return -1; + return fileno((FILE*)s->stream.file); + case smm_output_file: + if (!output) return -1; + return (int)s->stream.file; + case smm_io: + return fileno((FILE*)s->stream.file); + case smm_io_file: + return (int)s->stream.file; + case smm_synonym: + s = SYNONYM_STREAM_STREAM(s); + goto BEGIN; + case smm_two_way: + s = output? TWO_WAY_STREAM_OUTPUT(s) : TWO_WAY_STREAM_INPUT(s); + goto BEGIN; + default: + ecl_internal_error("illegal stream mode"); + } +} + +/********************************************************************** + * MEDIUM LEVEL INTERFACE + */ + +struct ecl_file_ops * +duplicate_dispatch_table(const struct ecl_file_ops *ops) +{ + struct ecl_file_ops *new_ops = ecl_alloc_atomic(sizeof(*ops)); + *new_ops = *ops; + return new_ops; +} + +const struct ecl_file_ops * +stream_dispatch_table(cl_object strm) +{ +#ifdef ECL_CLOS_STREAMS + if (ECL_INSTANCEP(strm)) { + return &clos_stream_ops; + } +#endif + if (type_of(strm) != t_stream) + FEtype_error_stream(strm); + return (const struct ecl_file_ops *)strm->stream.ops; +} + +static cl_index +ecl_read_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return stream_dispatch_table(strm)->read_byte8(strm, c, n); +} + +static cl_index +ecl_write_byte8(cl_object strm, unsigned char *c, cl_index n) +{ + return stream_dispatch_table(strm)->write_byte8(strm, c, n); +} + +int +ecl_read_char(cl_object strm) +{ + return stream_dispatch_table(strm)->read_char(strm); +} + +int +ecl_read_char_noeof(cl_object strm) +{ + int c = ecl_read_char(strm); + if (c == EOF) + FEend_of_file(strm); + return c; +} + +cl_object +ecl_read_byte(cl_object strm) +{ + cl_index (*read_byte8)(cl_object, unsigned char *, cl_index); + cl_index bs; +#ifdef ECL_CLOS_STREAMS + if (ECL_INSTANCEP(strm)) { + return funcall(2, @'gray::stream-read-byte', strm); + } +#endif + read_byte8 = stream_dispatch_table(strm)->read_byte8; + bs = strm->stream.byte_size; + if (bs == 8) { + unsigned char c; + if (read_byte8(strm, &c, 1) < 1) + return Cnil; + if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) { + return MAKE_FIXNUM((signed char)c); + } else { + return MAKE_FIXNUM((unsigned char)c); + } + } else { + unsigned char c; + cl_index nb; + cl_object output = MAKE_FIXNUM(0); + for (nb = 0; bs >= 8; bs -= 8, nb += 8) { + cl_object aux; + if (read_byte8(strm, &c, 1) < 1) + return Cnil; + if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)) + aux = MAKE_FIXNUM((signed char)c); + else + aux = MAKE_FIXNUM((unsigned char)c); + output = cl_logior(2, output, cl_ash(aux, MAKE_FIXNUM(nb))); + } + } +} + +void +ecl_write_byte(cl_object c, cl_object strm) +{ + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index bs; + /* + * The first part is only for composite or complex streams. + */ +BEGIN: +#ifdef ECL_CLOS_STREAMS + if (ECL_INSTANCEP(strm)) { + funcall(3, @'gray::stream-write-byte', strm, c); + return; + } +#endif + write_byte8 = stream_dispatch_table(strm)->write_byte8; + bs = strm->stream.byte_size; + if (bs == 8) { + cl_fixnum i = (strm->stream.flags & ECL_STREAM_SIGNED_BYTES)? fixint(c) : fixnnint(c); + unsigned char c = (unsigned char)i; + write_byte8(strm, &c, 1); + } else do { + cl_object b = cl_logand(2, c, MAKE_FIXNUM(0xFF)); + unsigned char aux = (unsigned char)fix(b); + if (write_byte8(strm, &aux, 1) < 1) + break; + c = cl_ash(c, MAKE_FIXNUM(-8)); + bs -= 8; + } while (bs); +} + +int +ecl_write_char(int c, cl_object strm) +{ + return stream_dispatch_table(strm)->write_char(strm, c); +} + +void +ecl_unread_char(int c, cl_object strm) +{ + return stream_dispatch_table(strm)->unread_char(strm, c); +} + +int +ecl_listen_stream(cl_object strm) +{ + return stream_dispatch_table(strm)->listen(strm); +} + +void +ecl_clear_input(cl_object strm) +{ + return stream_dispatch_table(strm)->clear_input(strm); +} + +void +ecl_clear_output(cl_object strm) +{ + return stream_dispatch_table(strm)->clear_output(strm); +} + +void +ecl_force_output(cl_object strm) +{ + return stream_dispatch_table(strm)->force_output(strm); +} + +void +ecl_finish_output(cl_object strm) +{ + return stream_dispatch_table(strm)->finish_output(strm); +} + +int +ecl_file_column(cl_object strm) +{ + return stream_dispatch_table(strm)->column(strm); +} + +cl_object +ecl_file_length(cl_object strm) +{ + return stream_dispatch_table(strm)->length(strm); +} + +cl_object +ecl_file_position(cl_object strm) +{ + return stream_dispatch_table(strm)->get_position(strm); +} + +cl_object +ecl_file_position_set(cl_object strm, cl_object pos) +{ + return stream_dispatch_table(strm)->set_position(strm, pos); +} + +bool +ecl_input_stream_p(cl_object strm) +{ + return stream_dispatch_table(strm)->input_p(strm); +} + +bool +ecl_output_stream_p(cl_object strm) +{ + return stream_dispatch_table(strm)->output_p(strm); +} + +cl_object +ecl_stream_element_type(cl_object strm) +{ + return stream_dispatch_table(strm)->element_type(strm); +} + +int +ecl_interactive_stream_p(cl_object strm) +{ + return stream_dispatch_table(strm)->interactive_p(strm); +} + +/* + * ecl_read_char(s) tries to read a character from the stream S. It outputs + * either the code of the character read, or EOF. Whe compiled with + * CLOS-STREAMS and S is an instance object, STREAM-READ-CHAR is invoked + * to retrieve the character. Then STREAM-READ-CHAR should either + * output the character, or NIL, indicating EOF. + * + * INV: ecl_read_char(strm) checks the type of STRM. + */ +int +ecl_peek_char(cl_object strm) +{ + return stream_dispatch_table(strm)->peek_char(strm); +} + +/*******************************tl*************************************** + * SEQUENCES I/O + */ + +void +writestr_stream(const char *s, cl_object strm) +{ + while (*s != '\0') + ecl_write_char(*s++, strm); +} + +cl_object +cl_file_string_length(cl_object stream, cl_object string) +{ + cl_fixnum l; + /* This is a stupid requirement from the spec. Why returning 1??? + * Why not simply leaving the value unspecified, as with other + * streams one cannot write to??? + */ + if (type_of(stream) == t_stream && + stream->stream.mode == smm_broadcast) { + stream = BROADCAST_STREAM_LIST(stream); + if (ecl_endp(stream)) + @(return MAKE_FIXNUM(1)) + } + switch (type_of(string)) { +#ifdef ECL_UNICODE + case t_string: { + cl_object c = cl_stream_external_format(stream); + cl_index i; + if (c == @':utf-8') + for (i = l = 0; i < string->string.fillp; i++) { + cl_index c = ecl_char(string, i); + l++; + if (c >= 0x7f) l++; + if (c >= 0x7ff) l++; + if (c >= 0xffff) l++; + if (c >= 0x1fffffL) l++; + } + else if (c == @':ucs-2') + l = string->string.fillp * 2; + else if (c == @':ucs-4') + l = string->string.fillp * 4; + else + l = string->string.fillp; + break; + } +#endif + case t_base_string: + l = string->base_string.fillp; + break; + case t_character: + l = 1; + break; + default: + FEwrong_type_argument(@'string', string); + } + @(return MAKE_FIXNUM(l)) +} + +cl_object +si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) +{ + cl_fixnum start,limit,end; + + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == Cnil i.f.f. t = t_symbol */ + limit = ecl_length(seq); + start = ecl_fixnum_in_range(@'write-sequence',"start",s,0,limit); + if (e == Cnil) { + end = limit; + } else { + end = ecl_fixnum_in_range(@'write-sequence',"end",e,0,limit); + } + if (end <= start) { + goto OUTPUT; + } + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + cl_object s = ecl_nthcdr(start, seq); + loop_for_in(s) { + if (start < end) { + cl_object elt = CAR(s); + if (ischar) + ecl_write_char(ecl_char_code(elt), stream); + else + ecl_write_byte(elt, stream); + start++; + } else { + goto OUTPUT; + } + } end_loop_for_in; + } else { + stream_dispatch_table(stream)-> + write_vector(stream, seq, start, end); + } + OUTPUT: + @(return seq); +} + +cl_object +si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) +{ + cl_fixnum start,limit,end; + + /* Since we have called ecl_length(), we know that SEQ is a valid + sequence. Therefore, we only need to check the type of the + object, and seq == Cnil i.f.f. t = t_symbol */ + limit = ecl_length(seq); + start = ecl_fixnum_in_range(@'read-sequence',"start",s,0,limit); + if (e == Cnil) { + end = limit; + } else { + end = ecl_fixnum_in_range(@'read-sequence',"end",e,0,limit); + } + if (end <= start) { + goto OUTPUT; + } + if (LISTP(seq)) { + cl_object elt_type = cl_stream_element_type(stream); + bool ischar = (elt_type == @'base-char') || (elt_type == @'character'); + seq = ecl_nthcdr(start, seq); + loop_for_in(seq) { + if (start >= end) { + goto OUTPUT; + } else { + cl_object c; + if (ischar) { + int i = ecl_read_char(stream); + if (i < 0) goto OUTPUT; + c = CODE_CHAR(i); + } else { + c = ecl_read_byte(stream); + if (c == Cnil) goto OUTPUT; + } + ECL_RPLACA(seq, c); + start++; + } + } end_loop_for_in; + } else { + start = stream_dispatch_table(stream)-> + read_vector(stream, seq, start, end); + } + OUTPUT: + @(return MAKE_FIXNUM(start)) +} + +/********************************************************************** + * LISP LEVEL INTERFACE + */ + +cl_object +si_file_column(cl_object strm) +{ + @(return MAKE_FIXNUM(ecl_file_column(strm))) +} + +cl_object +cl_file_length(cl_object strm) +{ + @(return ecl_file_length(strm)) +} + +@(defun file-position (file_stream &o position) + cl_object output; +@ + if (Null(position)) { + output = ecl_file_position(file_stream); + } else { + if (position == @':start') { + position = MAKE_FIXNUM(0); + } else if (position == @':end') { + position = Cnil; + } + output = ecl_file_position_set(file_stream, position); + } + OUTPUT: + @(return output) +@) + +cl_object +cl_input_stream_p(cl_object strm) +{ + @(return (ecl_input_stream_p(strm) ? Ct : Cnil)) +} + +cl_object +cl_output_stream_p(cl_object strm) +{ + @(return (ecl_output_stream_p(strm) ? Ct : Cnil)) +} + +cl_object +cl_interactive_stream_p(cl_object strm) +{ + @(return (stream_dispatch_table(strm)->interactive_p(strm)? Ct : Cnil)) +} + +cl_object +cl_open_stream_p(cl_object strm) +{ + /* ANSI and Cltl2 specify that open-stream-p should work + on closed streams, and that a stream is only closed + when #'close has been applied on it */ + if (type_of(strm) != t_stream) + FEwrong_type_argument(@'stream', strm); + @(return (strm->stream.closed ? Cnil : Ct)) +} + +cl_object +cl_stream_element_type(cl_object strm) +{ + @(return ecl_stream_element_type(strm)) +} + +cl_object +cl_stream_external_format(cl_object strm) +{ + cl_object output; + cl_type t; + AGAIN: + t= type_of(strm); +#ifdef ECL_CLOS_STREAMS + if (t == t_instance) + output = @':default'; + else +#endif + if (t != t_stream) + FEwrong_type_argument(@'stream', strm); + if (strm->stream.mode == smm_synonym) { + strm = SYNONYM_STREAM_STREAM(strm); + goto AGAIN; + } + output = strm->stream.format; + @(return output) +} + +cl_object +cl_streamp(cl_object strm) +{ +#ifdef ECL_CLOS_STREAMS + if (ECL_INSTANCEP(strm)) { + return funcall(2, @'gray::streamp', strm); + } +#endif + @(return ((type_of(strm) == t_stream) ? Ct : Cnil)) +} + +/********************************************************************** + * OTHER TOOLS + */ + +cl_object +si_copy_stream(cl_object in, cl_object out) +{ + int c; + for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { + ecl_write_char(c, out); + } + ecl_force_output(out); + @(return Ct) +} + + +/********************************************************************** + * FILE OPENING AND CLOSING + */ + +static cl_fixnum +normalize_stream_element_type(cl_object element_type) +{ + cl_fixnum sign = 0; + cl_index size; + if (funcall(3, @'subtypep', element_type, @'unsigned-byte') != Cnil) { + sign = +1; + } else if (funcall(3, @'subtypep', element_type, @'signed-byte') != Cnil) { + sign = -1; + } else { + FEerror("Not a valid stream element type: ~A", 1, element_type); + } + if (CONSP(element_type)) { + if (CAR(element_type) == @'unsigned-byte') + return fixnnint(cl_cadr(element_type)); + if (CAR(element_type) == @'signed-byte') + return -fixnnint(cl_cadr(element_type)); + } + for (size = 1; 1; size++) { + cl_object type; + type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', + MAKE_FIXNUM(size)); + if (funcall(3, @'subtypep', element_type, type) != Cnil) { + return size * sign; + } + } +} + +static int +parse_external_format(cl_object input_format) +{ +#ifdef ECL_UNICODE + if (input_format == @':UTF-8') { + return ECL_STREAM_UTF_8; + } + if (input_format == @':UCS-2') { + return ECL_STREAM_UCS_2; + } + if (input_format == @':UCS-4') { + return ECL_STREAM_UCS_4; + } + if (input_format == @':default') { + return ECL_STREAM_UTF_8; + } +#else + if (input_format == @':UTF-8' || input_format == @':UCS-2' || + input_format == @':UCS-4') { + FEerror("Unsupported external format: ~A", input_format); + } + if (input_format == @':default') { + return ECL_STREAM_LATIN_1; + } +#endif + if (input_format == @':ISO-8859-1') { + return ECL_STREAM_ISO_8859_1; + } + if (input_format == @':LATIN-1') { + return ECL_STREAM_LATIN_1; + } + FEerror("Unknown external format: ~A", 1, input_format); + return ECL_STREAM_DEFAULT_FORMAT; +} + +cl_object +ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, + cl_object if_does_not_exist, cl_fixnum byte_size, + int flags) +{ + cl_env_ptr the_env = &cl_env; + cl_object x; + int f; + mode_t mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH; + cl_object filename = si_coerce_to_filename(fn); + char *fname = (char*)filename->base_string.self; + bool appending = 0; + + ecl_disable_interrupts_env(the_env); + if (smm == smm_input || smm == smm_probe) { + f = open(fname, O_RDONLY, mode); + if (f < 0) { + if (if_does_not_exist == @':error') { + goto CANNOT_OPEN; + } else if (if_does_not_exist == @':create') { + f = open(fname, O_WRONLY|O_CREAT, mode); + if (f < 0) goto CANNOT_OPEN; + close(f); + f = open(fname, O_RDONLY, mode); + if (f < 0) goto CANNOT_OPEN; + } else if (Null(if_does_not_exist)) { + x = Cnil; + goto OUTPUT; + } else { + x = @':if-does-not-exist'; + fn = if_does_not_exist; + goto INVALID_OPTION; + } + } + } else if (smm == smm_output || smm == smm_io) { + int base = (smm == smm_output)? O_WRONLY : O_RDWR; + if (if_exists == @':new_version' && if_does_not_exist == @':create') + goto CREATE; + f = open(fname, O_RDONLY, mode); + if (f >= 0) { + close(f); + if (if_exists == @':error') { + goto CANNOT_OPEN; + } else if (if_exists == @':rename') { + f = ecl_backup_open(fname, base|O_CREAT, mode); + if (f < 0) goto CANNOT_OPEN; + } else if (if_exists == @':rename_and_delete' || + if_exists == @':new_version' || + if_exists == @':supersede') { + f = open(fname, base|O_TRUNC, mode); + if (f < 0) goto CANNOT_OPEN; + } else if (if_exists == @':overwrite' || if_exists == @':append') { + f = open(fname, base, mode); + if (f < 0) goto CANNOT_OPEN; + appending = (if_exists == @':append'); + } else if (Null(if_exists)) { + x = Cnil; + goto OUTPUT; + } else { + x = @':if-exists'; + fn = if_exists; + goto INVALID_OPTION; + } + } else { + if (if_does_not_exist == @':error') { + goto CANNOT_OPEN; + } else if (if_does_not_exist == @':create') { + CREATE: f = open(fname, base | O_CREAT | O_TRUNC, mode); + if (f < 0) goto CANNOT_OPEN; + } else if (Null(if_does_not_exist)) { + x = Cnil; + goto OUTPUT; + } else { + x = @':if-does-not-exist'; + fn = if_does_not_exist; + goto INVALID_OPTION; + } + } + } else { + goto INVALID_MODE; + } + ecl_enable_interrupts_env(the_env); + if (flags & ECL_STREAM_C_STREAM) { + FILE *fp; + switch (smm) { + case smm_input: fp = fdopen(f, OPEN_R); break; + case smm_output: fp = fdopen(f, OPEN_W); break; + case smm_io: fp = fdopen(f, OPEN_RW); break; + } + x = ecl_make_stream_from_FILE(fn, fp, smm, byte_size, flags); + si_set_buffering_mode(x, (flags & ECL_STREAM_FORMAT)? @':line-buffered' : @':fully-buffered'); + } else { + x = ecl_make_file_stream_from_fd(fn, f, smm, byte_size, flags); + } + if (smm == smm_probe) { + cl_close(1, x); + } else { + x->stream.flags |= ECL_STREAM_MIGHT_SEEK; + si_set_finalizer(x, Ct); + /* Set file pointer to the correct position */ + ecl_file_position_set(x, appending? Cnil : MAKE_FIXNUM(0)); + } + OUTPUT: + ecl_enable_interrupts_env(the_env); + return x; + CANNOT_OPEN: + ecl_enable_interrupts_env(the_env); + FEcannot_open(fn); + return Cnil; + INVALID_OPTION: + ecl_enable_interrupts_env(the_env); + FEerror("Invalid value op option ~A: ~A", 2, x, fn); + return Cnil; + INVALID_MODE: + ecl_enable_interrupts_env(the_env); + FEerror("Illegal stream mode ~S", 1, MAKE_FIXNUM(smm)); + return Cnil; +} + +@(defun open (filename + &key (direction @':input') + (element_type @'base-char') + (if_exists Cnil iesp) + (if_does_not_exist Cnil idnesp) + (external_format @':default') + (cstream Cnil) + &aux strm) + enum ecl_smmode smm; + int flags = 0; + cl_fixnum byte_size; +@ + /* INV: ecl_open_stream() checks types */ + if (direction == @':input') { + smm = smm_input; + if (!idnesp) + if_does_not_exist = @':error'; + } else if (direction == @':output') { + smm = smm_output; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':io') { + smm = smm_io; + if (!iesp) + if_exists = @':new_version'; + if (!idnesp) { + if (if_exists == @':overwrite' || + if_exists == @':append') + if_does_not_exist = @':error'; + else + if_does_not_exist = @':create'; + } + } else if (direction == @':probe') { + smm = smm_probe; + if (!idnesp) + if_does_not_exist = Cnil; + } else { + FEerror("~S is an illegal DIRECTION for OPEN.", + 1, direction); + } + if (element_type == @'signed-byte') { + byte_size = -8; + } else if (element_type == @'unsigned-byte') { + byte_size = 8; + } else if (element_type == @':default') { + flags |= parse_external_format(external_format); + byte_size = 0; + } else if (funcall(3, @'subtypep', element_type, @'character') != Cnil) { + flags |= parse_external_format(external_format); + byte_size = 0; + } else { + byte_size = normalize_stream_element_type(element_type); + } + if (byte_size != 0 && external_format != @':default') { + FEerror("Cannot specify an external format for binary streams.", 0); + } + if (!Null(cstream)) { + flags |= ECL_STREAM_C_STREAM; + } + strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, + byte_size, flags); + @(return strm) +@) + + +@(defun close (strm &key (abort @'nil')) +@ + @(return stream_dispatch_table(strm)->close(strm)); +@) + +/********************************************************************** + * BACKEND + */ + +static int +file_listen(int fileno) +{ +#if !defined(mingw32) && !defined(_MSC_VER) +# if defined(HAVE_SELECT) + fd_set fds; + int retv, fd; + struct timeval tv = { 0, 0 }; + FD_ZERO(&fds); + FD_SET(fileno, &fds); + retv = select(fileno + 1, &fds, NULL, NULL, &tv); + if (retv < 0) + FElibc_error("select() returned an error value", 0); + else if (retv > 0) + return ECL_LISTEN_AVAILABLE; + else + return ECL_LISTEN_NO_CHAR; +# elif defined(FIONREAD) + { + long c = 0; + ioctl(fileno, FIONREAD, &c); + return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; + } +# endif /* FIONREAD */ +#else + HANDLE hnd = (HANDLE)_get_osfhandle(fileno); + switch (GetFileType(hnd)) { + case FILE_TYPE_CHAR: { + DWORD dw, dw_read, cm; + if (GetNumberOfConsoleInputEvents(hnd, &dw)) { + if (!GetConsoleMode(hnd, &cm)) + FEwin32_error("GetConsoleMode() failed", 0); + if (dw > 0) { + PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); + int i; + if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) + FEwin32_error("PeekConsoleInput failed()", 0); + if (dw_read > 0) { + if (cm & ENABLE_LINE_INPUT) { + for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); + else if (GetLastError() == ERROR_BROKEN_PIPE) + return ECL_LISTEN_EOF; + else + FEwin32_error("PeekNamedPipe() failed", 0); + break; + } + default: + FEerror("Unsupported Windows file type: ~A", 1, MAKE_FIXNUM(GetFileType(hnd))); + break; + } +#endif + return -3; +} + +static int +flisten(FILE *fp) +{ + int aux; + if (feof(fp)) + return ECL_LISTEN_EOF; +#ifdef FILE_CNT + if (FILE_CNT(fp) > 0) + return ECL_LISTEN_AVAILABLE; +#endif + aux = file_listen(fileno(fp)); + if (aux != -3) + return aux; + /* This code is portable, and implements the expected behavior for regular files. + It will fail on noninteractive streams. */ + { + /* regular file */ + ecl_off_t old_pos = ecl_ftello(fp), end_pos; + if (ecl_fseeko(fp, 0, SEEK_END) != 0) + FElibc_error("fseek() returned an error value", 0); + end_pos = ecl_ftello(fp); + if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) + FElibc_error("fseek() returned an error value", 0); + return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); + } + return !ECL_LISTEN_AVAILABLE; +} /* * When using the same stream for input and output operations, we have to @@ -145,203 +3838,35 @@ ecl_integer_to_off_t(cl_object offset) return output; } -/*---------------------------------------------------------------------- - * ecl_input_stream_p(strm) answers - * if stream strm is an input stream or not. - * It does not check if it really is possible to read - * from the stream, - * but only checks the mode of the stream (sm_mode). - *---------------------------------------------------------------------- - */ -bool -ecl_input_stream_p(cl_object strm) +static cl_object +alloc_stream() { -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) - return !Null(funcall(2, @'gray::input-stream-p', strm)); -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_io_wsock: -#endif - case smm_concatenated: - case smm_two_way: - case smm_echo: - case smm_string_input: - return(TRUE); - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_string_output: - case smm_broadcast: - return(FALSE); - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - default: - ecl_internal_error("illegal stream mode"); - } + cl_object x = ecl_alloc_object(t_stream); + x->stream.closed = 0; + x->stream.file = NULL; + x->stream.object0 = + x->stream.object1 = OBJNULL; + x->stream.int0 = x->stream.int1 = 0; + x->stream.unread = EOF; + x->stream.flags = ECL_STREAM_LATIN_1; + x->stream.byte_size = 8; + x->stream.buffer = NULL; + return x; } -/*---------------------------------------------------------------------- - * ecl_output_stream_p(strm) answers - * if stream strm is an output stream. - * It does not check if it really is possible to write - * to the stream, - * but only checks the mode of the stream (sm_mode). - *---------------------------------------------------------------------- - */ -bool -ecl_output_stream_p(cl_object strm) -{ -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) - return !Null(funcall(2, @'gray::output-stream-p', strm)); -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_input: - case smm_probe: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_concatenated: - case smm_string_input: - return(FALSE); - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_io: - case smm_two_way: - case smm_echo: - case smm_broadcast: - case smm_string_output: - return(TRUE); - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - default: - ecl_internal_error("illegal stream mode"); - } -} - -/* - * In ECL, all streams have element type (UNSIGNED-BYTE 8), (SIGNED-BYTE 8) - * or BASE-CHAR. Nevertheless, READ-CHAR and WRITE-CHAR are allowed in them, - * and they perform more or less as if - * (READ-CHAR) = (CODE-CHAR (READ-BYTE)) - * (WRITE-CHAR c) = (WRITE-BYTE (CHAR-CODE c)) - */ -cl_object -cl_stream_element_type(cl_object strm) -{ - cl_object x; - cl_object output = @'base-char'; -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) - return funcall(2, @'gray::stream-element-type', strm); -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_input: - case smm_output: -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_io: - if (strm->stream.char_stream_p) - output = @'base-char'; - else { - cl_fixnum bs = strm->stream.byte_size; - output = strm->stream.signed_bytes? - @'signed-byte' : @'unsigned-byte'; - if (bs != 8) - output = cl_list(2, output, MAKE_FIXNUM(bs)); - } - break; - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - x = strm->stream.object0; - if (ecl_endp(x)) { - output = @'t'; - break; - } - strm = CAR(x); - goto BEGIN; - - case smm_concatenated: - x = strm->stream.object0; - if (ecl_endp(x)) - break; - strm = CAR(x); - goto BEGIN; - - case smm_two_way: - case smm_echo: - strm = strm->stream.object0; - goto BEGIN; - - case smm_string_input: - case smm_string_output: - break; - - default: - ecl_internal_error("illegal stream mode"); - } - @(return output) -} - -cl_object -cl_stream_external_format(cl_object strm) -{ - cl_object output; - cl_type t = type_of(strm); -#ifdef ECL_CLOS_STREAMS - if (t == t_instance) - output = @':default'; - else -#endif - if (t == t_stream) - output = @':default'; - else - FEwrong_type_argument(@'stream', strm); - @(return output) -} - -/*---------------------------------------------------------------------- - * Error messages - *---------------------------------------------------------------------- +/********************************************************************** + * ERROR MESSAGES */ -static void not_an_input_stream(cl_object fn) /*__attribute__((noreturn))*/; -static void not_an_output_stream(cl_object fn) /*__attribute__((noreturn))*/; -static void wrong_file_handler(cl_object strm) /*__attribute__((noreturn))*/; +static cl_object +not_a_file_stream(cl_object strm) +{ + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not an file stream"), + @':format-arguments', cl_list(1, strm), + @':expected-type', @'file-stream', + @':datum', strm); +} static void not_an_input_stream(cl_object strm) @@ -373,13 +3898,74 @@ not_a_character_stream(cl_object s) @':datum', cl_stream_element_type(s)); } +static void +not_a_binary_stream(cl_object s) +{ + cl_error(9, @'simple-type-error', @':format-control', + make_constant_base_string("~A is not a binary stream"), + @':format-arguments', cl_list(1, s), + @':expected-type', @'integer', + @':datum', cl_stream_element_type(s)); +} + +static void +unread_error(cl_object s) +{ + CEerror(Ct, "Error when using UNREAD-CHAR on stream ~D", 1, s); +} + +static void +unread_twice(cl_object s) +{ + CEerror(Ct, "Used UNREAD-CHAR twice on stream ~D", 1, s); +} + +static void +maybe_clearerr(cl_object strm) +{ + cl_type t = type_of(strm); + if (t == smm_io || t == smm_output || t == smm_input) { + FILE *f = IO_STREAM_FILE(strm); + if (f != NULL) clearerr(f); + } +} + +static int +restartable_io_error(cl_object strm) +{ + cl_env_ptr the_env = ecl_process_env(); + volatile int old_errno = errno; + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); + if (errno == EINTR) { + return 1; + } else { + FElibc_error("Read or write operation to stream ~S signaled an error.", + 1, strm); + return 0; + } +} + static void io_error(cl_object strm) { + cl_env_ptr the_env = ecl_process_env(); + /* ecl_disable_interrupts(); ** done by caller */ + maybe_clearerr(strm); + ecl_enable_interrupts_env(the_env); FElibc_error("Read or write operation to stream ~S signaled an error.", 1, strm); } +static void +character_size_overflow(cl_object strm, int c) +{ + FEerror("Tried to write a character code ~D in a ~A stream.", 0, + MAKE_FIXNUM(c), + cl_stream_external_format(strm)); +} + static void wrong_file_handler(cl_object strm) { @@ -392,2679 +3978,64 @@ wsock_error( const char *err_msg, cl_object strm ) { char *msg; cl_object msg_obj; - FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); - msg_obj = make_base_string_copy( msg ); - LocalFree( msg ); + /* ecl_disable_interrupts(); ** done by caller */ + { + FormatMessage( FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, WSAGetLastError(), 0, ( void* )&msg, 0, NULL ); + msg_obj = make_base_string_copy( msg ); + LocalFree( msg ); + } + ecl_enable_interrupts(); FEerror( err_msg, 2, strm, msg_obj ); } #endif -/*---------------------------------------------------------------------- - * ecl_open_stream(fn, smm, if_exists, if_does_not_exist) - * opens file fn with mode smm. - * Fn is a pathname designator. - *---------------------------------------------------------------------- - */ -cl_object -ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, - cl_object if_does_not_exist, cl_fixnum byte_size, - bool char_stream_p, bool use_header_p) -{ - cl_object x; - FILE *fp; - cl_object filename = si_coerce_to_filename(fn); - char *fname = filename->base_string.self; - bool signed_bytes, appending = FALSE; - uint8_t binary_header = 0, bit_buffer = 0, bits_left = 0; - - if (byte_size < 0) { - signed_bytes = 1; - byte_size = -byte_size; - } else { - signed_bytes = 0; - } - if (char_stream_p && byte_size != 8) { - FEerror("Tried to make a character stream of byte size /= 8.",0); - } - if (smm == smm_input || smm == smm_probe) { - fp = fopen(fname, OPEN_R); - if (fp == NULL) { - if (if_does_not_exist == @':error') - FEcannot_open(fn); - else if (if_does_not_exist == @':create') { - fp = fopen(fname, OPEN_W); - if (fp == NULL) - FEcannot_open(fn); - fclose(fp); - fp = fopen(fname, OPEN_R); - if (fp == NULL) - FEcannot_open(fn); - } else if (Null(if_does_not_exist)) { - return(Cnil); - } else { - FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", - 1, if_does_not_exist); - } - } else if (!char_stream_p && use_header_p) { - /* Read the binary header */ - int c = getc(fp); - if (c != EOF) { - binary_header = c & 0xFF; - if (binary_header & ~7) - FEerror("~S has an invalid binary header ~S", - 2, fn, MAKE_FIXNUM(binary_header)); - } - ecl_fseeko(fp, 0, SEEK_SET); - } - } else if (smm == smm_output || smm == smm_io) { - if (if_exists == @':new_version' && if_does_not_exist == @':create') - goto CREATE; - fp = fopen(fname, OPEN_R); - if (fp != NULL) { - if (!char_stream_p && use_header_p && (if_exists == @':overwrite' || if_exists == @':append')) { - /* Read binary header */ - int c = getc(fp); - if (c != EOF) { - binary_header = c & 0xFF; - if (binary_header & ~7) - FEerror("~S has an invalid binary header ~S", - 2, fn, MAKE_FIXNUM(binary_header)); - if (binary_header != 0 && if_exists == @':append' && - ecl_fseeko(fp, -1, SEEK_END) == 0) { - /* Read the last byte */ - bit_buffer = getc(fp) & 0xFF; - bits_left = binary_header; - } - } - } - fclose(fp); - if (if_exists == @':error') - FEcannot_open(fn); - else if (if_exists == @':rename') { - fp = ecl_backup_fopen(fname, (smm == smm_output) - ? OPEN_W - : OPEN_RW); - if (fp == NULL) - FEcannot_open(fn); - } else if (if_exists == @':rename_and_delete' || - if_exists == @':new_version' || - if_exists == @':supersede') { - fp = fopen(fname, (smm == smm_output) - ? OPEN_W - : OPEN_RW); - if (fp == NULL) - FEcannot_open(fn); - } else if (if_exists == @':overwrite' || if_exists == @':append') { - /* We cannot use "w+b" because it truncates. - We cannot use "a+b" because writes jump to the end. */ - int f = open(filename->base_string.self, (smm == smm_output)? - (O_WRONLY|O_CREAT) : (O_RDWR|O_CREAT)); - if (f < 0) - FEcannot_open(fn); - fp = fdopen(f, (smm == smm_output)? OPEN_W : OPEN_RW); - if (fp == NULL) { - close(f); - FEcannot_open(fn); - } - if (if_exists == @':append') { - ecl_fseeko(fp, 0, SEEK_END); - appending = TRUE; - } - } else if (Null(if_exists)) { - return(Cnil); - } else { - FEerror("~S is an illegal IF-EXISTS option.", - 1, if_exists); - } - } else { - if (if_does_not_exist == @':error') - FEcannot_open(fn); - else if (if_does_not_exist == @':create') { - CREATE: - fp = fopen(fname, (smm == smm_output) - ? OPEN_W - : OPEN_RW); - if (fp == NULL) - FEcannot_open(fn); - } else if (Null(if_does_not_exist)) { - return(Cnil); - } else { - FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", - 1, if_does_not_exist); - } - } - } else { - FEerror("Illegal stream mode ~S", 1, MAKE_FIXNUM(smm)); - } - x = cl_alloc_object(t_stream); - x->stream.mode = (short)smm; - x->stream.closed = 0; - x->stream.file = (void*)fp; - x->stream.char_stream_p = char_stream_p; - /* Michael, touch this to reactivate support for odd bit sizes! */ - if (!use_header_p) { - /* binary header not used, round byte_size to a 8 bits */ - byte_size = (byte_size + 7) & ~7; - /* change header to something detectable */ - binary_header = 0xFF; - } - x->stream.byte_size = byte_size; - x->stream.signed_bytes = signed_bytes; - x->stream.header = binary_header; - x->stream.last_op = 0; - if (bits_left != 0) { - x->stream.bits_left = bits_left; - x->stream.bit_buffer = bit_buffer; - x->stream.buffer_state = -1; - } - x->stream.object1 = fn; - x->stream.int0 = x->stream.int1 = 0; - si_set_buffering_mode(x, char_stream_p? @':line-buffered' : @':fully-buffered'); - if (smm == smm_probe) { - cl_close(1, x); - } else { - si_set_finalizer(x, Ct); - if (!char_stream_p) { - /* Set file pointer to the correct position */ - if (appending) { - if (bits_left != 0) - ecl_fseeko(fp, -1, SEEK_END); - } else { - ecl_fseeko(fp, (use_header_p ? 1 : 0), SEEK_SET); - } - } - } - return(x); -} - -/* Forward definitions */ -static void ecl_write_byte8(int c, cl_object strm); -static int ecl_read_byte8(cl_object strm); -static void flush_output_stream_binary(cl_object strm); - -@(defun close (strm &key (abort @'nil')) - FILE *fp; -@ -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return funcall(2, @'gray::close', strm); - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - /* It is permissible to close a closed file */ - if (strm->stream.closed) - @(return Ct); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_output: - if (fp == stdout) - FEerror("Cannot close the standard output.", 0); - goto DO_CLOSE; - case smm_input: - if (fp == stdin) - FEerror("Cannot close the standard input.", 0); - case smm_io: - case smm_probe: - DO_CLOSE: - if (fp == NULL) - wrong_file_handler(strm); - if (ecl_output_stream_p(strm)) { - ecl_force_output(strm); - if (!strm->stream.char_stream_p && strm->stream.header != 0xFF) { - /* write header */ - if (ecl_fseeko(fp, 0, SEEK_SET) != 0) - io_error(strm); - ecl_write_byte8(strm->stream.header, strm); - } - } - if (fclose(fp) != 0) - FElibc_error("Cannot close stream ~S.", 1, strm); -#if !defined(GBC_BOEHM) - cl_dealloc(strm->stream.buffer); - strm->stream.file = NULL; -#endif - break; -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: - if ( closesocket( ( int )strm->stream.file ) != 0 ) - wsock_error( "Cannot close Windows Socket ~S~%~A.", strm ); -#if !defined(GBC_BOEHM) - cl_dealloc(strm->stream.buffer); - strm->stream.file = NULL; -#endif - break; -#endif - - case smm_two_way: - strm->stream.object0 = OBJNULL; - case smm_synonym: - case smm_broadcast: - case smm_concatenated: - case smm_echo: - case smm_string_input: - case smm_string_output: - /* The elements of a composite stream are not closed. For - composite streams we zero object1. For files we do not, - as it might contain an useful pathname */ - strm->stream.object1 = OBJNULL; - break; - - default: - ecl_internal_error("illegal stream mode"); - } - strm->stream.closed = 1; - strm->stream.file = NULL; - @(return Ct); -@) - -cl_object -ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend) -{ - cl_object strm; - - strm = cl_alloc_object(t_stream); - strm->stream.mode = (short)smm_string_input; - strm->stream.closed = 0; - strm->stream.file = NULL; - strm->stream.object0 = strng; - strm->stream.object1 = OBJNULL; - strm->stream.int0 = istart; - strm->stream.int1 = iend; - strm->stream.char_stream_p = 1; - strm->stream.byte_size = 8; - strm->stream.signed_bytes = 0; - return(strm); -} - -cl_object -ecl_make_string_output_stream(cl_index line_length) -{ - cl_object s = cl_alloc_adjustable_base_string(line_length); - return si_make_string_output_stream_from_string(s); -} - - -/********************************************************************** - * BYTE INPUT/OUTPUT - * - * CLOS streams should handle byte input/output separately. For the - * rest of streams, we decompose each byte into octets and write them - * from the least significant to the most significant one. - */ - -static void -ecl_write_byte8(int c, cl_object strm) -{ - /* - * INV: We only get streams of the following four modes. - */ - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_output: - case smm_io: { - FILE *fp = (FILE *)strm->stream.file; - if (fp == NULL) - wrong_file_handler(strm); - if (putc(c, fp) == EOF) - io_error(strm); - break; - } -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_output_wsock: { - int fp = (int)strm->stream.file; - if ( fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else - { - char ch = ( char )c; - if ( send( fp, &ch, 1, 0 ) == SOCKET_ERROR ) - wsock_error( "Cannot write char to Windows Socket ~S.~%~A", strm ); - } - break; - } -#endif - case smm_string_output: - strm->stream.int0++; - ecl_string_push_extend(strm->stream.object0, c); - break; - default: - ecl_internal_error("illegal stream mode"); - } -} - -void -ecl_write_byte(cl_object c, cl_object strm) -{ - cl_index bs, nb; - cl_object aux; - /* - * The first part is only for composite or complex streams. - */ -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(3, @'gray::stream-write-byte', strm, c); - return; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_write(strm); - case smm_output: -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_output_wsock: -#endif - case smm_string_output: - break; - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - case smm_broadcast: { - cl_object x; - for (x = strm->stream.object0; !ecl_endp(x); x = CDR(x)) - ecl_write_byte(c, CAR(x)); - return; - } - case smm_two_way: - strm->stream.int0++; - strm = strm->stream.object1; - goto BEGIN; - case smm_echo: - strm = strm->stream.object1; - goto BEGIN; - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_concatenated: - case smm_string_input: - not_an_output_stream(strm); - default: - ecl_internal_error("illegal stream mode"); - } - /* - * Here is the real output of the byte. - */ - bs = strm->stream.byte_size; - if (bs == 8) { - cl_fixnum n = fixint(c); - ecl_write_byte8(n & 0xFF, strm); - } else if (bs & 7) { - unsigned char b = strm->stream.bit_buffer; - int bs_ = bs; - cl_object c0 = c; - nb = strm->stream.bits_left; - if (strm->stream.buffer_state == 1) { - /* buffer is prepared for reading: re-read (8-nb) bits and throw the rest */ - int c0; - ecl_fseeko((FILE*)strm->stream.file, -1, SEEK_CUR); - c0 = ecl_read_byte8(strm); - if (c0 == EOF) - /* this should not happen !!! */ - io_error(strm); - ecl_fseeko((FILE*)strm->stream.file, -1, SEEK_CUR); - b = (unsigned char)(c0 & MAKE_BIT_MASK(8-nb)); - nb = (8-nb); - } - do { - b |= (unsigned char)(fixnnint(cl_logand(2, c0, MAKE_FIXNUM(MAKE_BIT_MASK(8-nb)))) << nb); - bs_ -= (8-nb); - c0 = cl_ash(c0, MAKE_FIXNUM(nb-8)); - if (bs_ >= 0) { - ecl_write_byte8(b, strm); - b = nb = 0; - } - } while (bs_ > 0); - strm->stream.bits_left = (bs_ < 0 ? (8+bs_) : 0); - strm->stream.bit_buffer = (bs_ < 0 ? (b & MAKE_BIT_MASK(8+bs_)) : 0); - strm->stream.buffer_state = (bs_ < 0 ? -1 : 0); - } else do { - cl_object b = cl_logand(2, c, MAKE_FIXNUM(0xFF)); - ecl_write_byte8(fix(b), strm); - c = cl_ash(c, MAKE_FIXNUM(-8)); - bs -= 8; - } while (bs); -} - -static int -ecl_read_byte8(cl_object strm) -{ - /* - * INV: We only get streams of the following four modes. - */ - int c; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_input: - case smm_io: { - FILE *fp = (FILE*)strm->stream.file; - if (fp == NULL) - wrong_file_handler(strm); - c = getc(fp); - if (c == EOF && ferror(fp)) - io_error(strm); - break; - } -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: { - int fp = (int)strm->stream.file; - if ( fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else - { - /* check for unread chars first */ - if (CONSP(strm->stream.object0)) { - c = (unsigned char)CHAR_CODE(CAR(strm->stream.object0)); - strm->stream.object0 = CDR(strm->stream.object0); - } else { - char ch; - if ( recv( fp, &ch, 1, 0 ) == SOCKET_ERROR ) - wsock_error( "Cannot read char from Windows socket ~S.~%~A", strm ); - c = ( unsigned char )ch; - } - } - break; - } -#endif - case smm_string_input: - if (strm->stream.int0 >= strm->stream.int1) - c = EOF; - else - c = strm->stream.object0->base_string.self[strm->stream.int0++]; - break; - default: - ecl_internal_error("illegal stream mode"); - } - return c; -} - -cl_object -si_set_buffering_mode(cl_object stream, cl_object buffer_mode_symbol) -{ - enum ecl_smmode mode = stream->stream.mode; - int buffer_mode; - - if (type_of(stream) != t_stream) { - FEerror("Cannot set buffer of ~A", 1, stream); - } - if (buffer_mode_symbol == Cnil) { - buffer_mode = _IONBF; - } else if (buffer_mode_symbol == Ct || buffer_mode_symbol == @':fully-buffered') { - buffer_mode = _IOFBF; - } else if (buffer_mode_symbol == @':line-buffered') { - buffer_mode = _IOLBF; - } else { - FEerror("Not a valid buffering mode: ~A", 1, buffer_mode_symbol); - } - if (mode == smm_output || mode == smm_io || mode == smm_input) { - FILE *fp = (FILE*)stream->stream.file; - char *new_buffer = 0; - setvbuf(fp, 0, _IONBF, 0); - if (buffer_mode != _IONBF) { - char *new_buffer; - cl_index buffer_size = BUFSIZ; - new_buffer = stream->stream.buffer = cl_alloc_atomic(buffer_size); - setvbuf(fp, new_buffer, buffer_mode, buffer_size); - } - } - @(return stream) -} - -static void -flush_output_stream_binary(cl_object strm) -{ - if (strm->stream.buffer_state == -1) { - /* buffer is prepared for writing: flush it */ - unsigned char b = strm->stream.bit_buffer; - cl_index nb = strm->stream.bits_left; - bool do_merging = FALSE; - FILE *fp = (FILE*)strm->stream.file; - - /* do we need to merge with existing byte? */ - ecl_off_t current_offset = ecl_ftello(fp), diff_offset; - if (ecl_fseeko(fp, 0, SEEK_END) != 0) - io_error(strm); - switch ((diff_offset = ecl_ftello(fp)-current_offset)) { - case 0: break; - case 1: - /* (EOF-1): merge only if less bits left than header tells us */ - do_merging = (nb < strm->stream.header); - break; - default: - do_merging = (diff_offset > 1); - break; - } - if (ecl_fseeko(fp, current_offset, SEEK_SET) != 0) - io_error(strm); - - /* do merging, if required */ - if (do_merging){ - if (strm->stream.mode == smm_io) { - /* I/O stream: no need to reopen and I/O sync already triggered */ - int c = ecl_read_byte8(strm); - if (c != EOF) - b |= (unsigned char)(c & ~MAKE_BIT_MASK(nb)); - /* rewind stream */ - if (ecl_fseeko(fp, -1, SEEK_CUR) != 0) - io_error(strm); - } else { - /* write-only stream: need to reopen the file for reading * - * the byte to merge, then reopen it back for writing */ - cl_object fn = si_coerce_to_filename(strm->stream.object1); - if (freopen(fn->base_string.self, OPEN_R, fp) == NULL || - ecl_fseeko(fp, current_offset, SEEK_SET) != 0) - io_error(strm); - /* cannot use ecl_read_byte8 here, because strm hasn't the right mode */ - b |= (unsigned char)(getc(fp) & ~MAKE_BIT_MASK(nb)); - /* need special trick to re-open the file for writing, avoiding truncation */ - fclose(fp); - strm->stream.file = fdopen(open(fn->base_string.self, O_WRONLY), OPEN_W); - if (strm->stream.file == NULL || ecl_fseeko(fp, current_offset, SEEK_SET) != 0) - io_error(strm); - } - } else { - /* No merging occurs -> header must be overwritten */ - strm->stream.header = nb; - } - - /* flush byte w/o changing file pointer */ - ecl_write_byte8(b, strm); - ecl_fseeko(fp, -1, SEEK_CUR); - } -} - -cl_object -ecl_read_byte(cl_object strm) -{ - cl_object c; - cl_index bs, nb; - /* - * In this first part, we identify the composite streams and - * also CLOS streams. - */ -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - cl_object b = funcall(2, @'gray::stream-read-byte', strm); - if (FIXNUMP(b) || type_of(b) == t_bignum) { - return b; - } - return Cnil; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_read(strm); - case smm_input: - case smm_string_input: -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: -#endif - break; - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - case smm_concatenated: { - cl_object strmi = strm->stream.object0; - c = Cnil; - while (!ecl_endp(strmi)) { - c = ecl_read_byte(CAR(strmi)); - if (c != Cnil) - break; - strm->stream.object0 = strmi = CDR(strmi); - } - return c; - } - case smm_two_way: - if (strm == cl_core.terminal_io) - ecl_force_output(cl_core.terminal_io->stream.object1); - strm->stream.int1 = 0; - strm = strm->stream.object0; - goto BEGIN; - case smm_echo: - c = ecl_read_byte(strm->stream.object0); - if (c != Cnil) { - if (strm->stream.int0 == 0) - ecl_write_byte(c, strm->stream.object1); - else /* don't echo twice if it was unread */ - --(strm->stream.int0); - } - return c; - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_broadcast: - case smm_string_output: - not_an_input_stream(strm); - default: - ecl_internal_error("illegal stream mode"); - } - /* - * Here we treat the case of streams for which ecl_read_byte8 works. - */ - bs = strm->stream.byte_size; - if (bs == 8) { - cl_fixnum i = ecl_read_byte8(strm); - if (i == EOF) - return Cnil; - if (strm->stream.signed_bytes) { - unsigned char c = i; - return MAKE_FIXNUM((signed char)c); - } - return MAKE_FIXNUM(i); - } else if (bs & 7) { - unsigned char b = strm->stream.bit_buffer; - nb = strm->stream.bits_left; - if (strm->stream.buffer_state == -1) { - /* buffer is prepared for writing: flush it */ - flush_output_stream_binary(strm); - b = ((unsigned char)ecl_read_byte8(strm)) >> nb; - nb = (8-nb); - } - if (nb >= bs) { - c = MAKE_FIXNUM(b & (unsigned char)MAKE_BIT_MASK(bs)); - strm->stream.bits_left = (nb-bs); - strm->stream.bit_buffer = (strm->stream.bits_left > 0 ? (b >> bs): 0); - } else { - cl_index i; - c = MAKE_FIXNUM(b); - while (nb < bs) { - int c0 = ecl_read_byte8(strm); - if (c0 == EOF) - return Cnil; - b = (unsigned char)(c0 & 0xFF); - for (i=8; i>0 && nb>=1) { - c = cl_logior(2, c, cl_ash(MAKE_FIXNUM(b&0x01), MAKE_FIXNUM(nb))); - } - } - strm->stream.bits_left = i; - strm->stream.bit_buffer = b; - } - strm->stream.buffer_state = (strm->stream.bits_left > 0 ? 1 : 0); - } else { - cl_index bs_ = bs; - c = MAKE_FIXNUM(0); - for (nb = 0; bs_ >= 8; bs_ -= 8, nb += 8) { - cl_fixnum i = ecl_read_byte8(strm); - if (i == EOF) - return Cnil; - c = cl_logior(2, c, cl_ash(MAKE_FIXNUM(i), MAKE_FIXNUM(nb))); - } - } - if (strm->stream.signed_bytes && cl_logbitp(MAKE_FIXNUM(bs-1), c) != Cnil) { - c = cl_logandc1(cl_ash(MAKE_FIXNUM(1), MAKE_FIXNUM(bs-1)), c); - c = ecl_minus(c, cl_ash(MAKE_FIXNUM(1), MAKE_FIXNUM(bs-1))); - } - return c; -} - - -/********************************************************************** - * CHARACTER INPUT/OUTPUT - */ - -/* - * ecl_read_char(s) tries to read a character from the stream S. It outputs - * either the code of the character read, or EOF. Whe compiled with - * CLOS-STREAMS and S is an instance object, STREAM-READ-CHAR is invoked - * to retrieve the character. Then STREAM-READ-CHAR should either - * output the character, or NIL, indicating EOF. - * - * INV: ecl_read_char(strm) checks the type of STRM. - */ -int -ecl_read_char(cl_object strm) -{ - int c; - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - cl_object c = funcall(2, @'gray::stream-read-char', strm); - return CHARACTERP(c)? CHAR_CODE(c) : EOF; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_read(strm); - case smm_input: { - FILE *fp = (FILE*)strm->stream.file; - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if (fp == NULL) - wrong_file_handler(strm); - c = getc(fp); - if (c == EOF && ferror(fp)) - io_error(strm); - break; - } -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: { - int fp = (int)strm->stream.file; - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if ( fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else { - if (CONSP(strm->stream.object0)) { - c = (unsigned char)CHAR_CODE(CAR(strm->stream.object0)); - strm->stream.object0 = CDR(strm->stream.object0); - } else { - char ch; - if ( recv( fp, &ch, 1, 0 ) == SOCKET_ERROR ) - wsock_error( "Cannot read char from Windows socket ~S.~%~A", strm ); - c = ( unsigned char )ch; - } - } - break; - } -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_concatenated: { - cl_object strmi = strm->stream.object0; - c = EOF; - while (!ecl_endp(strmi)) { - c = ecl_read_char(CAR(strmi)); - if (c != EOF) - break; - strm->stream.object0 = strmi = CDR(strmi); - } - break; - } - case smm_two_way: - if (strm == cl_core.terminal_io) - ecl_force_output(cl_core.terminal_io->stream.object1); - strm->stream.int1 = 0; - strm = strm->stream.object0; - goto BEGIN; - - case smm_echo: - c = ecl_read_char(strm->stream.object0); - if (c != EOF) { - if (strm->stream.int0 == 0) - ecl_write_char(c, strm->stream.object1); - else /* don't echo twice if it was unread */ - --(strm->stream.int0); - } - break; - - case smm_string_input: - if (strm->stream.int0 >= strm->stream.int1) - c = EOF; - else - c = strm->stream.object0->base_string.self[strm->stream.int0++]; - break; - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_broadcast: - case smm_string_output: - not_an_input_stream(strm); - - default: - ecl_internal_error("illegal stream mode"); - } - return c; -} - -/* - * ecl_read_char(s) tries to read a character from the stream S. It outputs - * either the code of the character read, or EOF. Whe compiled with - * CLOS-STREAMS and S is an instance object, STREAM-READ-CHAR is invoked - * to retrieve the character. Then STREAM-READ-CHAR should either - * output the character, or NIL, indicating EOF. - * - * INV: ecl_read_char(strm) checks the type of STRM. - */ -int -ecl_peek_char(cl_object strm) -{ - int c; - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - cl_object c = funcall(2, @'gray::stream-peek-char', strm); - return CHARACTERP(c)? CHAR_CODE(c) : EOF; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_read(strm); - case smm_input: - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if (fp == NULL) - wrong_file_handler(strm); - c = getc(fp); - if (c == EOF && ferror(fp)) - io_error(strm); - ungetc(c, fp); - break; - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: { - int fp = strm->stream.file; - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if ( fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else { - if (CONSP(strm->stream.object0)) { - c = (unsigned char)CHAR_CODE(CAR(strm->stream.object0)); - } else { - char ch; - if ( recv( fp, &ch, 1, MSG_PEEK ) == SOCKET_ERROR ) - wsock_error( "Cannot peek char from Windows socket ~S.~%~A", strm ); - c = ( unsigned char )ch; - } - } - break; - } -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_concatenated: { - cl_object strmi = strm->stream.object0; - c = EOF; - while (!ecl_endp(strmi)) { - c = ecl_peek_char(CAR(strmi)); - if (c != EOF) - break; - strm->stream.object0 = strmi = CDR(strmi); - } - break; - } - case smm_two_way: - if (strm == cl_core.terminal_io) - ecl_force_output(cl_core.terminal_io->stream.object1); - strm->stream.int1 = 0; - strm = strm->stream.object0; - goto BEGIN; - - case smm_echo: - c = ecl_peek_char(strm->stream.object0); - break; - - case smm_string_input: - if (strm->stream.int0 >= strm->stream.int1) - c = EOF; - else - c = strm->stream.object0->base_string.self[strm->stream.int0]; - break; - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_broadcast: - case smm_string_output: - not_an_input_stream(strm); - - default: - ecl_internal_error("illegal stream mode"); - } - return c; -} - -int -ecl_read_char_noeof(cl_object strm) -{ - int c = ecl_read_char(strm); - if (c == EOF) - FEend_of_file(strm); - return c; -} - -void -ecl_unread_char(int c, cl_object strm) -{ - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(3, @'gray::stream-unread-char', strm, CODE_CHAR(c)); - return; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - if (strm->stream.last_op < 0) { - goto UNREAD_ERROR; - } - strm->stream.last_op = +1; - case smm_input: - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if (fp == NULL) - wrong_file_handler(strm); - ungetc(c, fp); - if (c == EOF) - io_error(strm); -/* --strm->stream.int0; useless in smm_io, Beppe */ - break; - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: - strm->stream.object0 = CONS(CODE_CHAR((unsigned char)c), strm->stream.object0); - break; -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_concatenated: - if (ecl_endp(strm->stream.object0)) - goto UNREAD_ERROR; - strm = CAR(strm->stream.object0); - goto BEGIN; - - case smm_two_way: - strm = strm->stream.object0; - goto BEGIN; - - case smm_echo: - ecl_unread_char(c, strm->stream.object0); - (strm->stream.int0)++; - break; - - case smm_string_input: - if (strm->stream.int0 <= 0 || (int)strm->stream.object0->base_string.self[strm->stream.int0-1] != c) - goto UNREAD_ERROR; - --strm->stream.int0; - break; - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_broadcast: - case smm_string_output: - not_an_input_stream(strm); - - default: - ecl_internal_error("illegal stream mode"); - } - return; - -UNREAD_ERROR: - FEerror("Cannot unread the stream ~S.", 1, strm); -} - -int -ecl_write_char(int c, cl_object strm) -{ - cl_object x; - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(3, @'gray::stream-write-char', strm, CODE_CHAR(c)); - return c; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_write(strm); - case smm_output: - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if (c == '\n') - strm->stream.int1 = 0; - else if (c == '\t') - strm->stream.int1 = (strm->stream.int1&~07) + 8; - else - strm->stream.int1++; - if (fp == NULL) - wrong_file_handler(strm); - if (putc(c, fp) == EOF) - io_error(strm); - break; - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_output_wsock: - if (!strm->stream.char_stream_p) - not_a_character_stream(strm); - if (c == '\n') - strm->stream.int1 = 0; - else if (c == '\t') - strm->stream.int1 = (strm->stream.int1&~07) + 8; - else - strm->stream.int1++; - if ( ( int )fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else - { - char ch = ( char )c; - if ( send( ( int )fp, &ch, 1, 0 ) == SOCKET_ERROR ) - wsock_error( "Cannot write char to Windows Socket ~S.~%~A", strm ); - } - break; -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - for (x = strm->stream.object0; !ecl_endp(x); x = CDR(x)) - ecl_write_char(c, CAR(x)); - break; - - case smm_two_way: - strm->stream.int0++; - if (c == '\n') - strm->stream.int1 = 0; - else if (c == '\t') - strm->stream.int1 = (strm->stream.int1&~07) + 8; - else - strm->stream.int1++; - strm = strm->stream.object1; - goto BEGIN; - - case smm_echo: - strm = strm->stream.object1; - goto BEGIN; - - case smm_string_output: - strm->stream.int0++; - if (c == '\n') - strm->stream.int1 = 0; - else if (c == '\t') - strm->stream.int1 = (strm->stream.int1&~07) + 8; - else - strm->stream.int1++; - ecl_string_push_extend(strm->stream.object0, c); - break; - - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_concatenated: - case smm_string_input: - not_an_output_stream(strm); - - default: - ecl_internal_error("illegal stream mode"); - } - return(c); -} - -void -writestr_stream(const char *s, cl_object strm) -{ - while (*s != '\0') - ecl_write_char(*s++, strm); -} - -cl_object -si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) -{ - cl_fixnum start,limit,end; - cl_type t; - - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == Cnil i.f.f. t = t_symbol */ - limit = ecl_length(seq); - start = ecl_fixnum_in_range(@'write-sequence',"start",s,0,limit); - if (e == Cnil) { - end = limit; - } else { - end = ecl_fixnum_in_range(@'write-sequence',"end",e,0,limit); - } - if (end <= start) { - goto OUTPUT; - } - t = type_of(seq); - if (t == t_list) { - bool ischar = cl_stream_element_type(stream) == @'base-char'; - cl_object s = ecl_nthcdr(start, seq); - loop_for_in(s) { - if (start < end) { - cl_object elt = CAR(s); - cl_write_byte(ischar? cl_char_code(elt) : elt, - stream); - start++; - } else { - goto OUTPUT; - } - } end_loop_for_in; - goto OUTPUT; - } - if (t != t_base_string && - !(t == t_vector && - (seq->vector.elttype == aet_b8 || seq->vector.elttype == aet_i8))) - { - bool ischar = cl_stream_element_type(stream) == @'base-char'; - while (start < end) { - cl_object elt = ecl_aref(seq, start++); - if (ischar) { - ecl_write_char(ecl_char_code(elt), stream); - } else { - ecl_write_byte(elt, stream); - } - } - goto OUTPUT; - } - AGAIN: - if ((t = type_of(stream)) == t_stream && - (stream->stream.mode == smm_io || - stream->stream.mode == smm_output)) - { - size_t towrite = end - start; - if (stream->stream.mode == smm_io) { - io_stream_begin_write(stream); - } - if (fwrite(seq->vector.self.ch + start, sizeof(char), - towrite, (FILE*)stream->stream.file) < towrite) { - io_error(stream); - } - } else if (t == t_stream && stream->stream.mode == smm_two_way) { - stream = stream->stream.object1; - goto AGAIN; - } else { - char *p; - for (p= seq->vector.self.ch; start < end; start++) { - ecl_write_char(p[start], stream); - } - } - OUTPUT: - @(return seq); -} - -cl_object -si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e) -{ - cl_fixnum start,limit,end; - cl_type t; - - /* Since we have called ecl_length(), we know that SEQ is a valid - sequence. Therefore, we only need to check the type of the - object, and seq == Cnil i.f.f. t = t_symbol */ - limit = ecl_length(seq); - start = ecl_fixnum_in_range(@'read-sequence',"start",s,0,limit); - if (e == Cnil) { - end = limit; - } else { - end = ecl_fixnum_in_range(@'read-sequence',"end",e,0,limit); - } - if (end <= start) { - goto OUTPUT; - } - t = type_of(seq); - if (t == t_list) { - bool ischar = cl_stream_element_type(stream) == @'base-char'; - seq = ecl_nthcdr(start, seq); - loop_for_in(seq) { - if (start >= end) { - goto OUTPUT; - } else { - cl_object c; - if (ischar) { - int i = ecl_read_char(stream); - if (i < 0) goto OUTPUT; - c = CODE_CHAR(i); - } else { - c = ecl_read_byte(stream); - if (c == Cnil) goto OUTPUT; - } - ECL_RPLACA(seq, c); - start++; - } - } end_loop_for_in; - goto OUTPUT; - } - if (t != t_base_string && - !(t == t_vector && - (seq->vector.elttype == aet_b8 || seq->vector.elttype == aet_i8))) - { - bool ischar = cl_stream_element_type(stream) == @'base-char'; - while (start < end) { - cl_object c; - if (ischar) { - int i = ecl_read_char(stream); - if (i < 0) goto OUTPUT; - c = CODE_CHAR(i); - } else { - c = ecl_read_byte(stream); - if (c == Cnil) goto OUTPUT; - } - ecl_aset(seq, start++, c); - } - goto OUTPUT; - } - AGAIN: - if ((t = type_of(stream)) == t_stream && - (stream->stream.mode == smm_io || - stream->stream.mode == smm_input)) - { - size_t toread, n; - if (stream->stream.mode == smm_io) { - io_stream_begin_write(stream); - } - toread = end - start; - n = fread(seq->vector.self.ch + start, sizeof(char), - toread, stream->stream.file); - if (n < toread && ferror((FILE*)stream->stream.file)) - io_error(stream); - start += n; - } else if (t == t_stream && stream->stream.mode == smm_two_way) { - stream = stream->stream.object0; - goto AGAIN; - } else { - char *p; - for (p = seq->vector.self.ch; start < end; start++) { - int c = ecl_read_char(stream); - if (c == EOF) - break; - p[start] = c; - } - } - OUTPUT: - @(return MAKE_FIXNUM(start)) -} - -void -ecl_force_output(cl_object strm) -{ - cl_object x; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(2, @'gray::stream-force-output', strm); - return; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - strm->stream.last_op = 0; - case smm_output: { - FILE *fp = (FILE*)strm->stream.file; - if (fp == NULL) - wrong_file_handler(strm); - if ((strm->stream.byte_size & 7) && strm->stream.buffer_state == -1) { - flush_output_stream_binary(strm); - } - if (fflush(fp) == EOF) - io_error(strm); - break; - } -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_output_wsock: - /* do not do anything (yet) */ - break; -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - for (x = strm->stream.object0; !ecl_endp(x); x = CDR(x)) - ecl_force_output(CAR(x)); - break; - - case smm_two_way: - case smm_echo: - strm = strm->stream.object1; - goto BEGIN; - - case smm_string_output: - break; - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_concatenated: - case smm_string_input: - FEerror("Cannot flush the stream ~S.", 1, strm); - - default: - ecl_internal_error("illegal stream mode"); - } -} - -void -ecl_clear_input(cl_object strm) -{ - cl_object x; - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(2, @'gray::stream-clear-input', strm); - return; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_input: - if (fp == NULL) - wrong_file_handler(strm); -#if defined(mingw32) || defined(_MSC_VER) - if (isatty(fileno(fp))) { - /* Flushes Win32 console */ - if (!FlushConsoleInputBuffer((HANDLE)_get_osfhandle(fileno(fp)))) - FEwin32_error("FlushConsoleInputBuffer() failed", 0); - /* Do not stop here: the FILE structure needs also to be flushed */ - } -#endif - while (flisten(fp) == ECL_LISTEN_AVAILABLE) { - getc(fp); - } - break; - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: - /* flush at least the unread chars */ - strm->stream.object0 = Cnil; - /* do not do anything (yet) */ - printf( "Trying to clear input on windows socket stream!\n" ); - break; -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - for (x = strm->stream.object0; !ecl_endp(x); x = CDR(x)) - ecl_force_output(CAR(x)); - break; - - case smm_two_way: - case smm_echo: - strm = strm->stream.object0; - goto BEGIN; - - case smm_string_output: - case smm_io: - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_concatenated: - case smm_string_input: - break; - - default: - ecl_internal_error("illegal stream mode"); - } -} - -void -ecl_clear_output(cl_object strm) -{ - cl_object x; - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - funcall(2, @'gray::stream-clear-output',strm); - return; - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - fp = (FILE*)strm->stream.file; - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_output: -#if 0 - if (fp == NULL) - wrong_file_handler(strm); - if (ecl_fseeko(fp, 0L, 2) != 0) - io_error(strm); -#endif - break; - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_output_wsock: - /* do not do anything (yet) */ - printf( "Trying to clear output windows socket stream\n!" ); - break; -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - for (x = strm->stream.object0; !ecl_endp(x); x = CDR(x)) - ecl_force_output(CAR(x)); - break; - - case smm_two_way: - case smm_echo: - strm = strm->stream.object1; - goto BEGIN; - - case smm_string_output: - case smm_io: - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_concatenated: - case smm_string_input: - break; - - default: - ecl_internal_error("illegal stream mode"); - } -} - -static int -flisten(FILE *fp) -{ -#ifdef HAVE_SELECT - fd_set fds; - int retv, fd; - struct timeval tv = { 0, 0 }; -#endif -#if defined(mingw32) || defined(_MSC_VER) - HANDLE hnd; -#endif - if (feof(fp)) - return ECL_LISTEN_EOF; -#ifdef FILE_CNT - if (FILE_CNT(fp) > 0) - return ECL_LISTEN_AVAILABLE; -#endif -#if !defined(mingw32) && !defined(_MSC_VER) -#if defined(HAVE_SELECT) - fd = fileno(fp); - FD_ZERO(&fds); - FD_SET(fd, &fds); - retv = select(fd + 1, &fds, NULL, NULL, &tv); - if (retv < 0) - FElibc_error("select() returned an error value", 0); - return (retv > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; -#elif defined(FIONREAD) - { long c = 0; - ioctl(fileno(fp), FIONREAD, &c); - return (c > 0)? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR; - } -#endif /* FIONREAD */ -#else - hnd = (HANDLE)_get_osfhandle(fileno(fp)); - switch (GetFileType(hnd)) { - case FILE_TYPE_CHAR: { - DWORD dw, dw_read, cm; - if (GetNumberOfConsoleInputEvents(hnd, &dw)) { - if (!GetConsoleMode(hnd, &cm)) - FEwin32_error("GetConsoleMode() failed", 0); - if (dw > 0) { - PINPUT_RECORD recs = (PINPUT_RECORD)GC_malloc(sizeof(INPUT_RECORD)*dw); - int i; - if (!PeekConsoleInput(hnd, recs, dw, &dw_read)) - FEwin32_error("PeekConsoleInput failed()", 0); - if (dw_read > 0) { - if (cm & ENABLE_LINE_INPUT) { - for (i=0; i 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR); - else if (GetLastError() == ERROR_BROKEN_PIPE) - return ECL_LISTEN_EOF; - else - FEwin32_error("PeekNamedPipe() failed", 0); - break; - } - default: - FEerror("Unsupported Windows file type: ~A", 1, MAKE_FIXNUM(GetFileType(hnd))); - break; - } -#endif - /* This code is portable, and implements the expected behavior for regular files. - It will fail on noninteractive streams. */ - { - /* regular file */ - ecl_off_t old_pos = ecl_ftello(fp), end_pos; - if (ecl_fseeko(fp, 0, SEEK_END) != 0) - FElibc_error("fseek() returned an error value", 0); - end_pos = ecl_ftello(fp); - if (ecl_fseeko(fp, old_pos, SEEK_SET) != 0) - FElibc_error("fseek() returned an error value", 0); - return (end_pos > old_pos ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_EOF); - } - return !ECL_LISTEN_AVAILABLE; -} - -int -ecl_listen_stream(cl_object strm) -{ - FILE *fp; - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - cl_object flag = funcall(2, @'gray::stream-listen', strm); - return !(flag == Cnil); - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - io_stream_begin_read(strm); - case smm_input: - fp = (FILE*)strm->stream.file; - if (fp == NULL) - wrong_file_handler(strm); - return flisten(fp); - -#if defined(ECL_WSOCK) - case smm_io_wsock: - case smm_input_wsock: - fp = (FILE*)strm->stream.file; - if ( ( int )fp == INVALID_SOCKET ) - wrong_file_handler( strm ); - else - { - if (CONSP(strm->stream.object0)) - return ECL_LISTEN_AVAILABLE; - else { - struct timeval tv = { 0, 0 }; - fd_set fds; - int result; - - FD_ZERO( &fds ); - FD_SET( ( int )fp, &fds ); - result = select( 0, &fds, NULL, NULL, &tv ); - if ( result == SOCKET_ERROR ) - wsock_error( "Cannot listen on Windows socket ~S.~%~A", strm ); - return ( result > 0 ? ECL_LISTEN_AVAILABLE : ECL_LISTEN_NO_CHAR ); - } - } -#endif - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_concatenated: { - cl_object l = strm->stream.object0; - while (!ecl_endp(l)) { - int f = ecl_listen_stream(CAR(l)); - l = CDR(l); - if (f == ECL_LISTEN_EOF) { - strm->stream.object0 = l; - } else { - return f; - } - } - return ECL_LISTEN_EOF; - } - case smm_two_way: - case smm_echo: - strm = strm->stream.object0; - goto BEGIN; - - case smm_string_input: - if (strm->stream.int0 < strm->stream.int1) - return ECL_LISTEN_AVAILABLE; - else - return ECL_LISTEN_EOF; - - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: -#endif - case smm_broadcast: - case smm_string_output: - not_an_input_stream(strm); - - default: - ecl_internal_error("illegal stream mode"); - } -} - -cl_object -ecl_file_position(cl_object strm) -{ - cl_object output; -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return funcall(2, @'gray::stream-file-position', strm); - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - strm->stream.last_op = 0; - case smm_output: - ecl_force_output(strm); - case smm_input: { - /* FIXME! This does not handle large file sizes */ - ecl_off_t offset; - FILE *fp = (FILE*)strm->stream.file; - if (fp == NULL) - wrong_file_handler(strm); - offset = ecl_ftello(fp); - if (offset < 0) - io_error(strm); - if (sizeof(ecl_off_t) == sizeof(long)) { - output = ecl_make_integer(offset); - } else { - output = ecl_off_t_to_integer(offset); - } - break; - } - case smm_string_output: - /* INV: The size of a string never exceeds a fixnum. */ - output = MAKE_FIXNUM(strm->stream.object0->base_string.fillp); - break; - case smm_string_input: - /* INV: The size of a string never exceeds a fixnum. */ - output = MAKE_FIXNUM(strm->stream.int0); - break; - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - strm = strm->stream.object0; - if (ecl_endp(strm)) - return MAKE_FIXNUM(0); - strm = CAR(strm); - goto BEGIN; - -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_concatenated: - case smm_two_way: - case smm_echo: - return Cnil; - - default: - ecl_internal_error("illegal stream mode"); - } - if (!strm->stream.char_stream_p) { - /* deduce header and convert to bits */ - output = ecl_times(strm->stream.header != 0xFF ? ecl_one_minus(output) : output, MAKE_FIXNUM(8)); - switch (strm->stream.buffer_state) { - case 0: break; - case -1: - /* bits left for writing, use them */ - output = ecl_plus(output, MAKE_FIXNUM(strm->stream.bits_left)); - break; - case 1: - /* bits left for reading, deduce them */ - output = ecl_minus(output, MAKE_FIXNUM(strm->stream.bits_left)); - break; - } - /* normalize to byte_size */ - output = ecl_floor2(output, MAKE_FIXNUM(strm->stream.byte_size)); - if (VALUES(1) != MAKE_FIXNUM(0)) { - ecl_internal_error("File position is not on byte boundary"); - } - } - return output; -} - -cl_object -ecl_file_position_set(cl_object strm, cl_object large_disp) -{ - ecl_off_t disp; - int extra = 0; -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return funcall(3, @'gray::stream-file-position', strm, large_disp); - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - case smm_output: - ecl_force_output(strm); - case smm_input:{ - FILE *fp = (FILE*)strm->stream.file; - if (!strm->stream.char_stream_p) { - large_disp = ecl_floor2(ecl_times(large_disp, MAKE_FIXNUM(strm->stream.byte_size)), - MAKE_FIXNUM(8)); - extra = fix(VALUES(1)); - /* include the header in byte offset */ - if (strm->stream.header != 0xFF) - large_disp = ecl_one_plus(large_disp); - /* flush output stream: required, otherwise internal buffer is lost */ - flush_output_stream_binary(strm); - /* reset internal buffer: should be set again if extra != 0 */ - strm->stream.bit_buffer = strm->stream.bits_left = strm->stream.buffer_state = 0; - } - disp = ecl_integer_to_off_t(large_disp); - if (fp == NULL) - wrong_file_handler(strm); - if (ecl_fseeko(fp, disp, 0) != 0) - return Cnil; - if (extra != 0) { - if (ecl_input_stream_p(strm)) { - /* prepare the buffer for reading */ - int c = ecl_read_byte8(strm); - if (c == EOF) - return Cnil; - strm->stream.bit_buffer = (c & 0xFF) >> extra; - strm->stream.bits_left = (8-extra); - strm->stream.buffer_state = 1; - /* reset extra to avoid error */ - extra = 0; - } - /* FIXME: consider case of output-only stream */ - } - break; - } - case smm_string_output: { - /* INV: byte_size == 8 */ - disp = fixnnint(large_disp); - if (disp < strm->stream.object0->base_string.fillp) { - strm->stream.object0->base_string.fillp = disp; - strm->stream.int0 = disp; - } else { - disp -= strm->stream.object0->base_string.fillp; - while (disp-- > 0) - ecl_write_char(' ', strm); - } - return Ct; - } - case smm_string_input: { - /* INV: byte_size == 8 */ - disp = fixnnint(large_disp); - if (disp >= strm->stream.int1) { - strm->stream.int0 = strm->stream.int1; - } else { - strm->stream.int0 = disp; - } - return Ct; - } - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - strm = strm->stream.object0; - if (ecl_endp(strm)) - return Cnil; - strm = CAR(strm); - goto BEGIN; - -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_concatenated: - case smm_two_way: - case smm_echo: - return Cnil; - - default: - ecl_internal_error("illegal stream mode"); - } - if (extra) { - FEerror("Unsupported stream byte size", 0); - } - return Ct; -} - -cl_object -cl_file_length(cl_object strm) -{ - cl_object output; -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) - FEwrong_type_argument(c_string_to_object("(OR BROADCAST-STREAM SYNONYM-STREAM FILE-STREAM)"), - strm); -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_io: - case smm_output: - ecl_force_output(strm); - case smm_input: { - FILE *fp = (FILE*)strm->stream.file; - cl_index bs; - if (fp == NULL) - wrong_file_handler(strm); - output = ecl_file_len(fp); - if (!strm->stream.char_stream_p) { - bs = strm->stream.byte_size; - if (strm->stream.header != 0xFF) - output = ecl_floor2(ecl_minus(ecl_times(ecl_one_minus(output), MAKE_FIXNUM(8)), - MAKE_FIXNUM((8-strm->stream.header)%8)), - MAKE_FIXNUM(bs)); - else - output = ecl_floor2(ecl_times(output, MAKE_FIXNUM(8)), - MAKE_FIXNUM(bs)); - if (VALUES(1) != MAKE_FIXNUM(0)) { - FEerror("File length is not on byte boundary", 0); - } - } - break; - } - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_broadcast: - strm = strm->stream.object0; - if (ecl_endp(strm)) { - output = MAKE_FIXNUM(0); - break; - } - strm = CAR(strm); - goto BEGIN; - -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_concatenated: - case smm_two_way: - case smm_echo: - case smm_string_input: - case smm_string_output: - FEwrong_type_argument(@'file-stream', strm); - - default: - ecl_internal_error("illegal stream mode"); - } - @(return output) -} - -cl_object si_file_column(cl_object strm) -{ - @(return MAKE_FIXNUM(ecl_file_column(strm))) -} - -int -ecl_file_column(cl_object strm) -{ - -BEGIN: -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - cl_object col = funcall(2, @'gray::stream-line-column', strm); - /* FIXME! The Gray streams specifies NIL is a valid - * value but means "unknown". Should we make it - * zero? */ - if (col == Cnil) - return 0; - else - return fixnnint(col); - } -#endif - if (type_of(strm) != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch ((enum ecl_smmode)strm->stream.mode) { - case smm_output: -#if defined(ECL_WSOCK) - case smm_output_wsock: - case smm_io_wsock: -#endif - case smm_io: - case smm_two_way: - case smm_string_output: - return(strm->stream.int1); - - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - - case smm_echo: - strm = strm->stream.object1; - goto BEGIN; - - case smm_input: -#if defined(ECL_WSOCK) - case smm_input_wsock: -#endif - case smm_string_input: - return 0; - - case smm_concatenated: - case smm_broadcast: - strm = strm->stream.object0; - if (ecl_endp(strm)) - return 0; - strm = CAR(strm); - goto BEGIN; - default: - ecl_internal_error("illegal stream mode"); - } -} - -cl_object -cl_make_synonym_stream(cl_object sym) -{ - cl_object x; - - sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol); - x = cl_alloc_object(t_stream); - x->stream.mode = (short)smm_synonym; - x->stream.closed = 0; - x->stream.file = NULL; - x->stream.object0 = sym; - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - @(return x) -} - -cl_object -cl_synonym_stream_symbol(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_synonym) - FEwrong_type_argument(@'synonym-stream', strm); - @(return strm->stream.object0) -} - -@(defun make_broadcast_stream (&rest ap) - cl_object x, streams; - int i; -@ - streams = Cnil; - for (i = 0; i < narg; i++) { - x = cl_va_arg(ap); - if (!ecl_output_stream_p(x)) - not_an_output_stream(x); - streams = CONS(x, streams); - } - x = cl_alloc_object(t_stream); - x->stream.mode = (short)smm_broadcast; - x->stream.closed = 0; - x->stream.file = NULL; - x->stream.object0 = cl_nreverse(streams); - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - @(return x) -@) - -cl_object -cl_broadcast_stream_streams(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_broadcast) - FEwrong_type_argument(@'broadcast-stream', strm); - return cl_copy_list(strm->stream.object0); -} - -@(defun make_concatenated_stream (&rest ap) - cl_object x, streams; - int i; -@ - streams = Cnil; - for (i = 0; i < narg; i++) { - x = cl_va_arg(ap); - if (!ecl_input_stream_p(x)) - not_an_input_stream(x); - streams = CONS(x, streams); - } - x = cl_alloc_object(t_stream); - x->stream.mode = (short)smm_concatenated; - x->stream.closed = 0; - x->stream.file = NULL; - x->stream.object0 = cl_nreverse(streams); - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - @(return x) -@) - -cl_object -cl_concatenated_stream_streams(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_concatenated) - FEwrong_type_argument(@'concatenated-stream', strm); - return cl_copy_list(strm->stream.object0); -} - -cl_object -cl_make_two_way_stream(cl_object istrm, cl_object ostrm) -{ - cl_object strm; - if (!ecl_input_stream_p(istrm)) - not_an_input_stream(istrm); - if (!ecl_output_stream_p(ostrm)) - not_an_output_stream(ostrm); - strm = cl_alloc_object(t_stream); - strm->stream.mode = (short)smm_two_way; - strm->stream.closed = 0; - strm->stream.file = NULL; - strm->stream.object0 = istrm; - strm->stream.object1 = ostrm; - strm->stream.int0 = strm->stream.int1 = 0; - @(return strm) -} - -cl_object -cl_two_way_stream_input_stream(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) - FEwrong_type_argument(@'two-way-stream', strm); - @(return strm->stream.object0) -} - -cl_object -cl_two_way_stream_output_stream(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_two_way) - FEwrong_type_argument(@'two-way-stream', strm); - @(return strm->stream.object1) -} - -cl_object -cl_make_echo_stream(cl_object strm1, cl_object strm2) -{ - cl_object output; - if (!ecl_input_stream_p(strm1)) - not_an_input_stream(strm1); - if (!ecl_output_stream_p(strm2)) - not_an_output_stream(strm2); - output = cl_make_two_way_stream(strm1, strm2); - output->stream.mode = smm_echo; - @(return output) -} - -cl_object -cl_echo_stream_input_stream(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) - FEwrong_type_argument(@'echo-stream', strm); - @(return strm->stream.object0) -} - -cl_object -cl_echo_stream_output_stream(cl_object strm) -{ - if (type_of(strm) != t_stream || strm->stream.mode != smm_echo) - FEwrong_type_argument(@'echo-stream', strm); - @(return strm->stream.object1) -} - -@(defun make_string_input_stream (strng &o istart iend) - cl_index s, e; -@ - strng = si_coerce_to_base_string(strng); -#ifdef ECL_UNICODE - if (type_of(strng) == t_string) { - FEerror("Reading from extended strings is not supported: ~A", - 1, strng); - } -#endif - if (Null(istart)) - s = 0; - else if (!FIXNUMP(istart) || FIXNUM_MINUSP(istart)) - goto E; - else - s = (cl_index)fix(istart); - if (Null(iend)) - e = strng->base_string.fillp; - else if (!FIXNUMP(iend) || FIXNUM_MINUSP(iend)) - goto E; - else - e = (cl_index)fix(iend); - if (e > strng->base_string.fillp || s > e) - goto E; - @(return (ecl_make_string_input_stream(strng, s, e))) - -E: - FEerror("~S and ~S are illegal as :START and :END~%\ -for the string ~S.", - 3, istart, iend, strng); -@) - -@(defun make-string-output-stream (&key (element_type @'base-char')) -@ - if (Null(funcall(3, @'subtypep', element_type, @'character'))) { - FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character", - 1, element_type); - } - @(return ecl_make_string_output_stream(128)) -@) - -cl_object -cl_get_output_stream_string(cl_object strm) -{ - cl_object strng; - if (type_of(strm) != t_stream || - (enum ecl_smmode)strm->stream.mode != smm_string_output) - FEerror("~S is not a string-output stream.", 1, strm); - strng = si_copy_to_simple_base_string(strm->stream.object0); - strm->stream.object0->base_string.fillp = 0; - @(return strng) -} - -cl_object -cl_streamp(cl_object strm) -{ -#ifdef ECL_CLOS_STREAMS - if (ECL_INSTANCEP(strm)) { - return funcall(2, @'gray::streamp', strm); - } -#endif - @(return ((type_of(strm) == t_stream) ? Ct : Cnil)) -} - -cl_object -cl_input_stream_p(cl_object strm) -{ - @(return (ecl_input_stream_p(strm) ? Ct : Cnil)) -} - -cl_object -cl_output_stream_p(cl_object strm) -{ - @(return (ecl_output_stream_p(strm) ? Ct : Cnil)) -} - -static cl_fixnum -normalize_stream_element_type(cl_object element_type) -{ - cl_fixnum sign = 0; - cl_index size; - if (funcall(3, @'subtypep', element_type, @'unsigned-byte') != Cnil) { - sign = +1; - } else if (funcall(3, @'subtypep', element_type, @'signed-byte') != Cnil) { - sign = -1; - } else { - FEerror("Not a valid stream element type: ~A", 1, element_type); - } - if (CONSP(element_type)) { - if (CAR(element_type) == @'unsigned-byte') - return fixnnint(cl_cadr(element_type)); - if (CAR(element_type) == @'signed-byte') - return -fixnnint(cl_cadr(element_type)); - } - for (size = 1; 1; size++) { - cl_object type; - type = cl_list(2, sign>0? @'unsigned-byte' : @'signed-byte', - MAKE_FIXNUM(size)); - if (funcall(3, @'subtypep', element_type, type) != Cnil) { - return size * sign; - } - } -} - -@(defun open (filename - &key (direction @':input') - (element_type @'base-char') - (if_exists Cnil iesp) - (if_does_not_exist Cnil idnesp) - (external_format @':default') - (use_header_p Cnil) - &aux strm) - enum ecl_smmode smm; - bool char_stream_p; - cl_fixnum byte_size; -@ - if (external_format != @':default') - FEerror("~S is not a valid stream external format.", 1, - external_format); - /* INV: ecl_open_stream() checks types */ - if (direction == @':input') { - smm = smm_input; - if (!idnesp) - if_does_not_exist = @':error'; - } else if (direction == @':output') { - smm = smm_output; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':io') { - smm = smm_io; - if (!iesp) - if_exists = @':new_version'; - if (!idnesp) { - if (if_exists == @':overwrite' || - if_exists == @':append') - if_does_not_exist = @':error'; - else - if_does_not_exist = @':create'; - } - } else if (direction == @':probe') { - smm = smm_probe; - if (!idnesp) - if_does_not_exist = Cnil; - } else { - FEerror("~S is an illegal DIRECTION for OPEN.", - 1, direction); - } - if (element_type == @':default') { - char_stream_p = 1; - byte_size = 8; - } else if (element_type == @'signed-byte') { - char_stream_p = 0; - byte_size = -8; - } else if (element_type == @'unsigned-byte') { - char_stream_p = 0; - byte_size = 8; - } else if (funcall(3, @'subtypep', element_type, @'character') != Cnil) { - char_stream_p = 1; - byte_size = 8; - } else { - char_stream_p = 0; - byte_size = normalize_stream_element_type(element_type); - } - strm = ecl_open_stream(filename, smm, if_exists, if_does_not_exist, - byte_size, char_stream_p, - (use_header_p != Cnil)); - @(return strm) -@) - -@(defun file-position (file_stream &o position) - cl_object output; -@ - if (Null(position)) { - output = ecl_file_position(file_stream); - } else { - if (position == @':start') { - position = MAKE_FIXNUM(0); - } else if (position == @':end') { - position = cl_file_length(file_stream); - if (position == Cnil) { - output = Cnil; - goto OUTPUT; - } - } - output = ecl_file_position_set(file_stream, position); - } - OUTPUT: - @(return output) -@) - -cl_object -cl_file_string_length(cl_object stream, cl_object string) -{ - cl_fixnum l; - /* This is a stupid requirement from the spec. Why returning 1??? - * Why not simply leaving the value unspecified, as with other - * streams one cannot write to??? - */ - if (type_of(stream) == t_stream && - stream->stream.mode == smm_broadcast) { - stream = stream->stream.object0; - if (ecl_endp(stream)) - @(return MAKE_FIXNUM(1)) - } - switch (type_of(string)) { - case t_base_string: - l = string->base_string.fillp; - break; - case t_character: - l = 1; - break; - default: - FEwrong_type_argument(@'string', string); - } - @(return MAKE_FIXNUM(l)) -} - - -cl_object -cl_open_stream_p(cl_object strm) -{ - /* ANSI and Cltl2 specify that open-stream-p should work - on closed streams, and that a stream is only closed - when #'close has been applied on it */ - if (type_of(strm) != t_stream) - FEwrong_type_argument(@'stream', strm); - @(return (strm->stream.closed ? Cnil : Ct)) -} - -cl_object -si_make_string_output_stream_from_string(cl_object s) -{ - cl_object strm; - - if (type_of(s) != t_base_string || !s->base_string.hasfillp) - FEerror("~S is not a base-string with a fill-pointer.", 1, s); - strm = cl_alloc_object(t_stream); - strm->stream.mode = (short)smm_string_output; - strm->stream.closed = 0; - strm->stream.file = NULL; - strm->stream.object0 = s; - strm->stream.object1 = OBJNULL; - strm->stream.int0 = s->base_string.fillp; - strm->stream.int1 = 0; - strm->stream.char_stream_p = 1; - strm->stream.byte_size = 8; - strm->stream.signed_bytes = 0; - @(return strm) -} - -cl_object -si_copy_stream(cl_object in, cl_object out) -{ - int c; - for (c = ecl_read_char(in); c != EOF; c = ecl_read_char(in)) { - ecl_write_char(c, out); - } - ecl_force_output(out); - @(return Ct) -} - -cl_object -cl_interactive_stream_p(cl_object strm) -{ - cl_object output = Cnil; - cl_type t; - BEGIN: - t = type_of(strm); -#ifdef ECL_CLOS_STREAMS - if (t == t_instance) - return funcall(2, @'gray::stream-interactive-p', strm); -#endif - if (t != t_stream) - FEtype_error_stream(strm); - if (strm->stream.closed) - FEclosed_stream(strm); - switch(strm->stream.mode) { - case smm_synonym: - strm = ecl_symbol_value(strm->stream.object0); - goto BEGIN; - case smm_two_way: - strm = strm->stream.object0; - goto BEGIN; - case smm_input: - case smm_io: -#ifdef HAVE_ISATTY - /* Here we should check for the type of file descriptor, - * and whether it is connected to a tty. */ - output = isatty(fileno((FILE*)strm->stream.file))? Ct : Cnil; -#endif - break; - default:; - } - @(return output) -} - -cl_object -ecl_make_stream_from_FILE(cl_object fname, void *fp, enum ecl_smmode smm) -{ - cl_object stream; - stream = cl_alloc_object(t_stream); - stream->stream.mode = (short)smm; - stream->stream.closed = 0; - stream->stream.file = fp; -#if defined (ECL_WSOCK) - if ( smm == smm_input_wsock || smm == smm_io_wsock ) - stream->stream.object0 = Cnil; - else - stream->stream.object0 = @'base-char'; -#else - stream->stream.object0 = @'base-char'; -#endif - stream->stream.object1 = fname; /* not really used */ - stream->stream.int0 = stream->stream.int1 = 0; - stream->stream.char_stream_p = 1; - stream->stream.byte_size = 8; - stream->stream.signed_bytes = 0; - stream->stream.last_op = 0; - si_set_finalizer(stream, Ct); - return(stream); -} - -cl_object -ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm) -{ - char *mode; /* file open mode */ - FILE *fp; /* file pointer */ - - switch(smm) { - case smm_input: - mode = "r"; - break; - case smm_output: - mode = "w"; - break; - case smm_io: - mode = "w+"; - break; -#if defined(ECL_WSOCK) - case smm_input_wsock: - case smm_output_wsock: - case smm_io_wsock: - break; -#endif - default: - FEerror("make_stream: wrong mode", 0); - } -#if defined(ECL_WSOCK) - if ( smm == smm_input_wsock || smm == smm_output_wsock || smm == smm_io_wsock ) - fp = ( FILE* )fd; - else - fp = fdopen( fd, mode ); -#else - fp = fdopen(fd, mode); -#endif - return ecl_make_stream_from_FILE(fname, fp, smm); -} - -int -ecl_stream_to_handle(cl_object s, bool output) -{ - FILE *f; - BEGIN: - if (type_of(s) != t_stream) - return -1; - switch ((enum ecl_smmode)s->stream.mode) { - case smm_input: - if (output) return -1; - f = (FILE*)s->stream.file; - break; - case smm_output: - if (!output) return -1; - f = (FILE*)s->stream.file; - break; - case smm_io: - f = (FILE*)s->stream.file; - break; - case smm_synonym: - s = ecl_symbol_value(s->stream.object0); - goto BEGIN; - case smm_two_way: - s = output? s->stream.object1 : s->stream.object0; - goto BEGIN; - default: - ecl_internal_error("illegal stream mode"); - } - return fileno(f); -} - void init_file(void) { + const cl_env_ptr env = ecl_process_env(); + int flags = ECL_STREAM_DEFAULT_FORMAT; cl_object standard_input; cl_object standard_output; cl_object error_output; - cl_object standard; + cl_object aux; cl_object null_stream; cl_object x; - null_stream = cl_alloc_object(t_stream); - null_stream->stream.mode = (short)smm_io; - null_stream->stream.closed = 1; - null_stream->stream.file = NULL; - null_stream->stream.object0 = @'base-char'; - null_stream->stream.object1 = make_constant_base_string("/dev/null"); - null_stream->stream.int0 = 0; - null_stream->stream.int1 = 0; - null_stream->stream.char_stream_p = 1; - null_stream->stream.byte_size = 8; - null_stream->stream.signed_bytes = 0; + null_stream = ecl_make_stream_from_FILE(make_constant_base_string("/dev/null"), + NULL, smm_io, 8, 1); + generic_close(null_stream); null_stream = cl_make_two_way_stream(null_stream, cl_make_broadcast_stream(0)); cl_core.null_stream = null_stream; - standard_input = cl_alloc_object(t_stream); - standard_input->stream.mode = (short)smm_input; - standard_input->stream.closed = 0; - standard_input->stream.file = stdin; - standard_input->stream.object0 = @'base-char'; - standard_input->stream.object1 = make_constant_base_string("stdin"); - standard_input->stream.int0 = 0; - standard_input->stream.int1 = 0; - standard_input->stream.char_stream_p = 1; - standard_input->stream.byte_size = 8; - standard_input->stream.signed_bytes = 0; - - standard_output = cl_alloc_object(t_stream); - standard_output->stream.mode = (short)smm_output; - standard_output->stream.closed = 0; - standard_output->stream.file = stdout; - standard_output->stream.object0 = @'base-char'; - standard_output->stream.object1= make_constant_base_string("stdout"); - standard_output->stream.int0 = 0; - standard_output->stream.int1 = 0; - standard_output->stream.char_stream_p = 1; - standard_output->stream.byte_size = 8; - standard_output->stream.signed_bytes = 0; - - error_output = cl_alloc_object(t_stream); - error_output->stream.mode = (short)smm_output; - error_output->stream.closed = 0; - error_output->stream.file = stderr; - error_output->stream.object0 = @'base-char'; - error_output->stream.object1= make_constant_base_string("stderr"); - error_output->stream.int0 = 0; - error_output->stream.int1 = 0; - error_output->stream.char_stream_p = 1; - error_output->stream.byte_size = 8; - error_output->stream.signed_bytes = 0; - - cl_core.terminal_io = standard - = cl_make_two_way_stream(standard_input, standard_output); - - ECL_SET(@'*terminal-io*', standard); - - x = cl_alloc_object(t_stream); - x->stream.mode = (short)smm_synonym; - x->stream.closed = 0; - x->stream.file = NULL; - x->stream.object0 = @'*terminal-io*'; - x->stream.object1 = OBJNULL; - x->stream.int0 = x->stream.int1 = 0; - standard = x; - - ECL_SET(@'*standard-input*', standard); - ECL_SET(@'*standard-output*', standard); +#if 1 + standard_input = ecl_make_stream_from_FILE(make_constant_base_string("stdin"), + stdin, smm_input, 8, flags); + standard_output = ecl_make_stream_from_FILE(make_constant_base_string("stdout"), + stdout, smm_output, 8, flags); + error_output = ecl_make_stream_from_FILE(make_constant_base_string("stderr"), + stderr, smm_output, 8, flags); +#else + standard_input = ecl_make_file_stream_from_fd(make_constant_base_string("stdin"), + STDIN_FILENO, smm_input, 8, flags); + standard_output = ecl_make_file_stream_from_fd(make_constant_base_string("stdout"), + STDOUT_FILENO, smm_output, 8, flags); + error_output = ecl_make_file_stream_from_fd(make_constant_base_string("stderr"), + STDERR_FILENO, smm_output, 8, flags); +#endif + cl_core.standard_input = standard_input; + ECL_SET(@'*standard-input*', standard_input); + cl_core.standard_output = standard_output; + ECL_SET(@'*standard-output*', standard_output); + ECL_SET(@'*trace-output*', standard_output); + cl_core.error_output = error_output; ECL_SET(@'*error-output*', error_output); - ECL_SET(@'*query-io*', standard); - ECL_SET(@'*debug-io*', standard); - ECL_SET(@'*trace-output*', standard); + cl_core.terminal_io = aux + = cl_make_two_way_stream(standard_input, standard_output); + + ECL_SET(@'*terminal-io*', aux); + aux = cl_make_synonym_stream(@'*terminal-io*'); + ECL_SET(@'*query-io*', aux); + ECL_SET(@'*debug-io*', aux); } diff --git a/src/c/format.d b/src/c/format.d index bc2b36cf0..0d21bbb3d 100644 --- a/src/c/format.d +++ b/src/c/format.d @@ -102,16 +102,17 @@ static cl_object doformat(cl_narg narg, cl_object strm, cl_object string, cl_va_ static cl_object get_aux_stream(void) { + cl_env_ptr env = ecl_process_env(); cl_object stream; - start_critical_section(); - if (cl_env.fmt_aux_stream == Cnil) - stream = ecl_make_string_output_stream(64); - else { - stream = cl_env.fmt_aux_stream; - cl_env.fmt_aux_stream = Cnil; + ecl_disable_interrupts_env(env); + if (env->fmt_aux_stream == Cnil) { + stream = ecl_make_string_output_stream(64, 1); + } else { + stream = env->fmt_aux_stream; + env->fmt_aux_stream = Cnil; } - end_critical_section(); + ecl_enable_interrupts_env(env); return stream; } @@ -410,15 +411,16 @@ static void fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign, int radix, int mincol, int padchar, int commachar) { + const cl_env_ptr env = ecl_process_env(); int l, l1; int s; if (!FIXNUMP(x) && type_of(x) != t_bignum) { fmt_prepare_aux_stream(fmt); - bds_bind(@'*print-escape*', Cnil); - bds_bind(@'*print-base*', MAKE_FIXNUM(radix)); + ecl_bds_bind(env, @'*print-escape*', Cnil); + ecl_bds_bind(env, @'*print-base*', MAKE_FIXNUM(radix)); si_write_object(x, fmt->aux_stream); - bds_unwind_n(2); + ecl_bds_unwind_n(env, 2); l = fmt->aux_string->string.fillp; mincol -= l; while (mincol-- > 0) @@ -428,10 +430,10 @@ fmt_integer(format_stack fmt, cl_object x, bool colon, bool atsign, return; } fmt_prepare_aux_stream(fmt); - bds_bind(@'*print-radix*', Cnil); - bds_bind(@'*print-base*', MAKE_FIXNUM(radix)); + ecl_bds_bind(env, @'*print-radix*', Cnil); + ecl_bds_bind(env, @'*print-base*', MAKE_FIXNUM(radix)); si_write_object(x, fmt->aux_stream); - bds_unwind_n(2); + ecl_bds_unwind_n(env, 2); l = l1 = fmt->aux_string->string.fillp; s = 0; if (tempstr(fmt, s) == '-') @@ -623,6 +625,7 @@ fmt_roman(format_stack fmt, int i, int one, int five, int ten, bool colon) static void fmt_radix(format_stack fmt, bool colon, bool atsign) { + const cl_env_ptr env = ecl_process_env(); int radix, mincol, padchar, commachar; cl_object x; int i, j, k; @@ -649,10 +652,10 @@ fmt_radix(format_stack fmt, bool colon, bool atsign) return; } fmt_prepare_aux_stream(fmt); - bds_bind(@'*print-radix*', Cnil); - bds_bind(@'*print-base*', MAKE_FIXNUM(10)); + ecl_bds_bind(env, @'*print-radix*', Cnil); + ecl_bds_bind(env, @'*print-base*', MAKE_FIXNUM(10)); si_write_object(x, fmt->aux_stream); - bds_unwind_n(2); + ecl_bds_unwind_n(env, 2); s = 0; i = fmt->aux_string->string.fillp; if (i == 1 && tempstr(fmt, s) == '0') { @@ -1428,7 +1431,7 @@ fmt_case(format_stack fmt, bool colon, bool atsign) int up_colon; bool b; - x = ecl_make_string_output_stream(64); + x = ecl_make_string_output_stream(64, 1); i = fmt->ctl_index; j = fmt_skip(fmt); if (fmt->ctl_str[--j] != ')' || fmt->ctl_str[--j] != '~') @@ -1441,7 +1444,7 @@ fmt_case(format_stack fmt, bool colon, bool atsign) else format(fmt, fmt->ctl_str + i, j - i); fmt_copy1(fmt, &fmt_old); - x = x->stream.object0; + x = STRING_OUTPUT_STRING(x); if (!colon && !atsign) for (i = 0; i < x->string.fillp; i++) { if (isupper(j = x->string.self[i])) @@ -1706,7 +1709,7 @@ fmt_justification(format_stack fmt, volatile bool colon, bool atsign) fields = Cnil; for (;;) { - cl_object this_field = ecl_make_string_output_stream(64); + cl_object this_field = ecl_make_string_output_stream(64, 1); i = fmt->ctl_index; j0 = j = fmt_skip(fmt); while (fmt->ctl_str[--j] != '~') @@ -1726,7 +1729,7 @@ fmt_justification(format_stack fmt, volatile bool colon, bool atsign) } fmt->stream = this_field; format(fmt, fmt->ctl_str + i, j - i); - fields = CONS(this_field->stream.object0, fields); + fields = CONS(STRING_OUTPUT_STRING(this_field), fields); fmt_copy1(fmt, &fmt_old); if (fmt->ctl_str[--j0] == '>') { @@ -1864,7 +1867,7 @@ doformat(cl_narg narg, cl_object strm, cl_object string, cl_va_list args, bool i fmt.indents = 0; fmt.string = string; fmt.aux_stream = get_aux_stream(); - fmt.aux_string = fmt.aux_stream->stream.object0; + fmt.aux_string = STRING_OUTPUT_STRING(fmt.aux_stream); if ((colon = ecl_setjmp(*fmt.jmp_buf))) { if (--colon) fmt_error(&fmt, "illegal ~:^"); @@ -1872,7 +1875,7 @@ doformat(cl_narg narg, cl_object strm, cl_object string, cl_va_list args, bool i format(&fmt, string->string.self, string->string.fillp); ecl_force_output(strm); } - cl_env.fmt_aux_stream = fmt.aux_stream; + ecl_process_env()->fmt_aux_stream = fmt.aux_stream; if (!in_formatter) output = Cnil; return output; @@ -2103,12 +2106,16 @@ DIRECTIVE: int null_strm = 0; @ if (Null(strm)) { +#ifdef ECL_UNICODE + strm = ecl_alloc_adjustable_extended_string(64); +#else strm = cl_alloc_adjustable_base_string(64); +#endif null_strm = 1; } else if (strm == Ct) { strm = ecl_symbol_value(@'*standard-output*'); } - if (type_of(strm) == t_base_string) { + if (ecl_stringp(strm)) { output = strm; if (!output->base_string.hasfillp) { cl_error(7, @'si::format-error', @@ -2118,8 +2125,7 @@ DIRECTIVE: @':control-string', string, @':offset', MAKE_FIXNUM(0)); } - strm = ecl_make_string_output_stream(0); - strm->stream.object0 = output; + strm = si_make_string_output_stream_from_string(strm); if (null_strm == 0) output = Cnil; } diff --git a/src/c/gbc.d b/src/c/gbc.d index 43ab7a65e..75e30ffd5 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -727,7 +727,7 @@ contblock_sweep_phase(void) q = p + 4; while (q < e && !get_mark_bit((int *)q)) q += 4; - cl_dealloc(p); + ecl_dealloc(p); p = q + 4; } i = j + 1; @@ -746,6 +746,7 @@ cl_object (*GC_exit_hook)() = NULL; void ecl_gc(cl_type t) { + const cl_env_ptr env = ecl_process_env(); int i, j; int tm; int gc_start = ecl_runtime(); @@ -775,8 +776,8 @@ ecl_gc(cl_type t) #error "We need to stop all other threads" #endif /* THREADS */ - interrupts = ecl_interrupt_enable; - ecl_interrupt_enable = 0; + interrupts = env->disable_interrupts; + env->disable_interrupts = 1; collect_blocks = t > t_end; if (collect_blocks) @@ -863,7 +864,7 @@ ecl_gc(cl_type t) fflush(stdout); } - ecl_interrupt_enable = interrupts; + env->disable_interrupts = interrupts; if (GC_exit_hook != NULL) (*GC_exit_hook)(); @@ -884,9 +885,7 @@ ecl_gc(cl_type t) fflush(stdout); } - if (cl_env.interrupt_pending) si_check_pending_interrupts(); - - end_critical_section(); + if (env->interrupt_pending) ecl_check_pending_interrupts(); } /* diff --git a/src/c/gfun.d b/src/c/gfun.d index e2dd35dba..be48510e8 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -41,7 +41,7 @@ si_set_raw_funcallable(cl_object instance, cl_object function) if (Null(function)) { if (instance->instance.isgf == 2) { int length = instance->instance.length-1; - cl_object *slots = (cl_object*)cl_alloc(sizeof(cl_object)*(length)); + cl_object *slots = (cl_object*)ecl_alloc(sizeof(cl_object)*(length)); instance->instance.isgf = 2; memcpy(slots, instance->instance.slots, sizeof(cl_object)*(length)); instance->instance.slots = slots; @@ -51,7 +51,7 @@ si_set_raw_funcallable(cl_object instance, cl_object function) } else { if (instance->instance.isgf == 0) { int length = instance->instance.length+1; - cl_object *slots = (cl_object*)cl_alloc(sizeof(cl_object)*length); + cl_object *slots = (cl_object*)ecl_alloc(sizeof(cl_object)*length); memcpy(slots, instance->instance.slots, sizeof(cl_object)*(length-1)); instance->instance.slots = slots; instance->instance.length = length; @@ -201,8 +201,9 @@ vector_hash_key(cl_object keys) */ static cl_object * -search_method_hash(cl_object keys, cl_object table) +search_method_hash(cl_env_ptr env, cl_object keys) { + cl_object table = env->method_hash; cl_index argno = keys->vector.fillp; cl_index i = vector_hash_key(keys); cl_index total_size = table->vector.dim; @@ -211,7 +212,7 @@ search_method_hash(cl_object keys, cl_object table) int k; i = i % total_size; i = i - (i % 3); - min_gen = cl_env.method_generation; + min_gen = env->method_generation; min_e = 0; for (k = 20; k--; ) { cl_object *e = table->vector.self.t + i; @@ -253,7 +254,7 @@ search_method_hash(cl_object keys, cl_object table) ecl_internal_error("search_method_hash"); } RECORD_KEY(min_e) = OBJNULL; - cl_env.method_generation++; + env->method_generation++; FOUND: /* * Once we have reached here, we set the new generation of @@ -261,12 +262,12 @@ search_method_hash(cl_object keys, cl_object table) * generation number does not become too large and we can * expire some elements. */ - gen = cl_env.method_generation; + gen = env->method_generation; RECORD_GEN_SET(min_e, gen); if (gen >= total_size/2) { cl_object *e = table->vector.self.t; gen = 0.5*gen; - cl_env.method_generation -= gen; + env->method_generation -= gen; for (i = table->vector.dim; i; i-= 3, e += 3) { cl_fixnum g = RECORD_GEN(e) - gen; if (g <= 0) { @@ -281,12 +282,12 @@ search_method_hash(cl_object keys, cl_object table) } static cl_object -get_spec_vector(cl_object frame, cl_object gf) +get_spec_vector(cl_env_ptr env, cl_object frame, cl_object gf) { cl_object *args = frame->frame.bottom; cl_index narg = frame->frame.top - args; cl_object spec_how_list = GFUN_SPEC(gf); - cl_object vector = cl_env.method_spec_vector; + cl_object vector = env->method_spec_vector; cl_object *argtype = vector->vector.self.t; int spec_no = 1; argtype[0] = gf; @@ -331,6 +332,7 @@ compute_applicable_method(cl_object frame, cl_object gf) cl_object _ecl_standard_dispatch(cl_object frame, cl_object gf) { + const cl_env_ptr env = ecl_process_env(); cl_object func, vector; /* * We have to copy the frame because it might be stored in cl_env.values @@ -346,23 +348,22 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf) #ifdef ECL_THREADS /* See whether we have to clear the hash from some generic functions right now. */ - if (cl_env.method_hash_clear_list != Cnil) { + if (env->method_hash_clear_list != Cnil) { cl_object clear_list; THREAD_OP_LOCK(); - clear_list = cl_env.method_hash_clear_list; + clear_list = env->method_hash_clear_list; loop_for_on_unsafe(clear_list) { do_clear_method_hash(&cl_env, ECL_CONS_CAR(clear_list)); } end_loop_for_on; - cl_env.method_hash_clear_list = Cnil; + env->method_hash_clear_list = Cnil; THREAD_OP_UNLOCK(); } #endif - vector = get_spec_vector(frame, gf); + vector = get_spec_vector(env, frame, gf); if (vector == OBJNULL) { func = compute_applicable_method(frame, gf); } else { - cl_object table = cl_env.method_hash; - cl_object *e = search_method_hash(vector, table); + cl_object *e = search_method_hash(env, vector); if (RECORD_KEY(e) != OBJNULL) { func = RECORD_VALUE(e); } else { @@ -371,7 +372,7 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf) if (RECORD_KEY(e) != OBJNULL) { /* The cache might have changed while we * computed applicable methods */ - e = search_method_hash(vector, table); + e = search_method_hash(env, vector); } RECORD_KEY(e) = keys; RECORD_VALUE(e) = func; diff --git a/src/c/hash.d b/src/c/hash.d index 36e1da165..d46bc2077 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -92,12 +92,14 @@ _hash_equal(int depth, cl_hashkey h, cl_object x) x = x->symbol.name; #ifdef ECL_UNICODE case t_base_string: - return hash_base_string(x->base_string.self, x->base_string.fillp, h); + return hash_base_string((unsigned char *)x->base_string.self, + x->base_string.fillp, h); case t_string: - return hash_full_string(x->base_string.self, x->base_string.fillp, h); + return hash_full_string(x->string.self, x->string.fillp, h); #else case t_base_string: - return hash_string(h, x->base_string.self, x->base_string.fillp); + return hash_string(h, (unsigned char *)x->base_string.self, + x->base_string.fillp); #endif case t_pathname: h = _hash_equal(0, h, x->pathname.directory); @@ -349,13 +351,13 @@ ecl_extend_hashtable(cl_object hashtable) } else { new_size = fix(new_size_obj); } - old = cl_alloc_object(t_hashtable); + old = ecl_alloc_object(t_hashtable); old->hash = hashtable->hash; hashtable->hash.data = NULL; /* for GC sake */ hashtable->hash.entries = 0; hashtable->hash.size = new_size; hashtable->hash.data = (struct ecl_hashtable_entry *) - cl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); + ecl_alloc(new_size * sizeof(struct ecl_hashtable_entry)); for (i = 0; i < new_size; i++) { hashtable->hash.data[i].key = OBJNULL; hashtable->hash.data[i].value = OBJNULL; @@ -451,13 +453,13 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size, /* * Build actual hash. */ - h = cl_alloc_object(t_hashtable); + h = ecl_alloc_object(t_hashtable); h->hash.test = htt; h->hash.size = hsize; h->hash.entries = 0; h->hash.data = NULL; /* for GC sake */ h->hash.data = (struct ecl_hashtable_entry *) - cl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); + ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); do_clrhash(h); h->hash.rehash_size = rehash_size; @@ -579,6 +581,7 @@ cl_hash_table_count(cl_object ht) static cl_object si_hash_table_iterate(cl_narg narg, cl_object env) { + const cl_env_ptr the_env = ecl_process_env(); cl_object index = CAR(env); cl_object ht = CADR(env); cl_fixnum i; diff --git a/src/c/instance.d b/src/c/instance.d index 3969903f6..8e4829f8a 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -20,7 +20,7 @@ cl_object ecl_allocate_instance(cl_object clas, cl_index size) { - cl_object x = cl_alloc_instance(size); + cl_object x = ecl_alloc_instance(size); cl_index i; CLASS_OF(x) = clas; for (i = 0; i < size; i++) @@ -186,9 +186,10 @@ si_copy_instance(cl_object x) } @(defun find-class (name &optional (errorp Ct) env) - cl_object class; + cl_object class, hash; @ - class = ecl_gethash_safe(name, SYM_VAL(@'si::*class-name-hash-table*'), Cnil); + hash = ECL_SYM_VAL(the_env, @'si::*class-name-hash-table*'); + class = ecl_gethash_safe(name, hash, Cnil); if (class == Cnil) { if (!Null(errorp)) FEerror("No class named ~S.", 1, name); @@ -264,6 +265,7 @@ enum ecl_built_in_classes { cl_object cl_class_of(cl_object x) { + cl_env_ptr the_env = ecl_process_env(); size_t index; cl_type tp = type_of(x); if (tp == t_instance) @@ -358,7 +360,7 @@ cl_class_of(cl_object x) } { cl_object output; - x = SYM_VAL(@'clos::*builtin-classes*'); + x = ECL_SYM_VAL(the_env, @'clos::*builtin-classes*'); /* We have to be careful because *builtin-classes* might be empty! */ if (Null(x)) { output = cl_find_class(1,@'t'); diff --git a/src/c/interpreter.d b/src/c/interpreter.d index f1bda688a..890d8a291 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -23,98 +23,94 @@ /* -------------------- INTERPRETER STACK -------------------- */ void -cl_stack_set_size(cl_index tentative_new_size) +ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) { - cl_index top = cl_env.stack_top - cl_env.stack; - cl_object *new_stack; + cl_index top = env->stack_top - env->stack; + cl_object *new_stack, *old_stack; cl_index safety_area = ecl_get_option(ECL_OPT_LISP_STACK_SAFETY_AREA); cl_index new_size = tentative_new_size + 2*safety_area; if (top > new_size) FEerror("Internal error: cannot shrink stack that much.",0); - start_critical_section(); + old_stack = env->stack; + new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); - new_stack = (cl_object *)cl_alloc_atomic(new_size * sizeof(cl_object)); - memcpy(new_stack, cl_env.stack, cl_env.stack_size * sizeof(cl_object)); + ecl_disable_interrupts_env(env); + memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); + env->stack_size = new_size; + env->stack = new_stack; + env->stack_top = env->stack + top; + env->stack_limit = env->stack + (new_size - 2*safety_area); + ecl_enable_interrupts_env(env); -#ifdef BOEHM_GBC - GC_free(cl_env.stack); -#else - cl_dealloc(cl_env.stack); -#endif - cl_env.stack_size = new_size; - cl_env.stack = new_stack; - cl_env.stack_top = cl_env.stack + top; - cl_env.stack_limit = cl_env.stack + (new_size - 2*safety_area); + ecl_dealloc(old_stack); /* A stack always has at least one element. This is assumed by cl__va_start * and friends, which take a sp=0 to have no arguments. */ if (top == 0) - cl_stack_push(MAKE_FIXNUM(0)); - - end_critical_section(); + ecl_stack_push(env, MAKE_FIXNUM(0)); } static void -cl_stack_grow(void) +ecl_stack_grow(cl_env_ptr env) { - cl_stack_set_size(cl_env.stack_size + LISP_PAGESIZE); + ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); } void -cl_stack_push(cl_object x) { - if (cl_env.stack_top >= cl_env.stack_limit) - cl_stack_grow(); - *(cl_env.stack_top++) = x; +ecl_stack_push(cl_env_ptr env, cl_object x) { + if (env->stack_top >= env->stack_limit) + ecl_stack_grow(env); + *(env->stack_top++) = x; } cl_object -cl_stack_pop() { - if (cl_env.stack_top == cl_env.stack) +ecl_stack_pop(cl_env_ptr env) { + if (env->stack_top == env->stack) FEerror("Internal error: stack underflow.",0); - return *(--cl_env.stack_top); + return *(--env->stack_top); } cl_index -cl_stack_index() { - return cl_env.stack_top - cl_env.stack; +ecl_stack_index(cl_env_ptr env) { + return env->stack_top - env->stack; } void -cl_stack_set_index(cl_index index) { - cl_object *new_top = cl_env.stack + index; - if (new_top > cl_env.stack_top) +ecl_stack_set_index(cl_env_ptr env, cl_index index) { + cl_object *new_top = env->stack + index; + if (new_top > env->stack_top) FEerror("Internal error: tried to advance stack.",0); - cl_env.stack_top = new_top; + env->stack_top = new_top; } void -cl_stack_pop_n(cl_index index) { - cl_object *new_top = cl_env.stack_top - index; - if (new_top < cl_env.stack) +ecl_stack_pop_n(cl_env_ptr env, cl_index index) { + cl_object *new_top = env->stack_top - index; + if (new_top < env->stack) FEerror("Internal error: stack underflow.",0); - cl_env.stack_top = new_top; + env->stack_top = new_top; } cl_index -cl_stack_push_values(void) { +ecl_stack_push_values(cl_env_ptr env) { cl_index i; - for (i=0; invalues; i++) + ecl_stack_push(env, env->values[i]); return i; } void -cl_stack_pop_values(cl_index n) { - NVALUES = n; +ecl_stack_pop_values(cl_env_ptr env, cl_index n) { + env->nvalues = n; while (n > 0) - VALUES(--n) = cl_stack_pop(); + env->values[--n] = ecl_stack_pop(env); } cl_index -cl_stack_push_list(cl_object list) +ecl_stack_push_list(cl_env_ptr env, cl_object list) { cl_index n; cl_object fast, slow; @@ -122,9 +118,9 @@ cl_stack_push_list(cl_object list) /* INV: A list's length always fits in a fixnum */ fast = slow = list; for (n = 0; CONSP(fast); n++, fast = CDR(fast)) { - *cl_env.stack_top = CAR(fast); - if (++cl_env.stack_top >= cl_env.stack_limit) - cl_stack_grow(); + *env->stack_top = CAR(fast); + if (++env->stack_top >= env->stack_limit) + ecl_stack_grow(env); if (n & 1) { /* Circular list? */ if (slow == fast) break; @@ -137,20 +133,21 @@ cl_stack_push_list(cl_object list) } cl_object -ecl_stack_frame_open(cl_object f, cl_index size) +ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) { - cl_object *top = cl_env.stack_top; + cl_object *top = env->stack_top; if (size) { - if (cl_env.stack_limit - top < size) { + if (env->stack_limit - top < size) { cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE; - cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE); - top = cl_env.stack_top; + ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE); + top = env->stack_top; } } f->frame.t = t_frame; - f->frame.stack = cl_env.stack; + f->frame.stack = env->stack; f->frame.bottom = top; - cl_env.stack_top = f->frame.top = (top + size); + f->frame.env = env; + env->stack_top = f->frame.top = (top + size); return f; } @@ -158,56 +155,59 @@ void ecl_stack_frame_enlarge(cl_object f, cl_index size) { cl_object *top; + cl_env_ptr env = f->frame.env; if (f->frame.stack == 0) { ecl_internal_error("Inconsistency in interpreter stack frame"); } - top = cl_env.stack_top; - if ((cl_env.stack_limit - top) < size) { + top = env->stack_top; + if ((env->stack_limit - top) < size) { cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE; - cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE); - f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack; - f->frame.stack = cl_env.stack; - top = cl_env.stack_top; + ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE); + f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack; + f->frame.stack = env->stack; + top = env->stack_top; } else if (top != f->frame.top) { - f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack; - f->frame.stack = cl_env.stack; - top = cl_env.stack_top; + f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack; + f->frame.stack = env->stack; + top = env->stack_top; } - cl_env.stack_top = f->frame.top = (top + size); + env->stack_top = f->frame.top = (top + size); } void ecl_stack_frame_push(cl_object f, cl_object o) { cl_object *top; + cl_env_ptr env = f->frame.env; if (f->frame.stack == 0) { ecl_internal_error("Inconsistency in interpreter stack frame"); } - top = cl_env.stack_top; - if (top >= cl_env.stack_limit) { - cl_stack_grow(); - f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack; - f->frame.stack = cl_env.stack; - top = cl_env.stack_top; + top = env->stack_top; + if (top >= env->stack_limit) { + ecl_stack_grow(env); + f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack; + f->frame.stack = env->stack; + top = env->stack_top; } else if (top != f->frame.top) { - f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack; - f->frame.stack = cl_env.stack; - top = cl_env.stack_top; + f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack; + f->frame.stack = env->stack; + top = env->stack_top; } *(top++) = o; - cl_env.stack_top = f->frame.top = top; + env->stack_top = f->frame.top = top; } void ecl_stack_frame_push_values(cl_object f) { + cl_env_ptr env = f->frame.env; if (f->frame.stack == 0) { ecl_internal_error("Inconsistency in interpreter stack frame"); } - cl_stack_push_values(); - f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack; - f->frame.stack = cl_env.stack; - f->frame.top = cl_env.stack_top; + ecl_stack_push_values(env); + f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack; + f->frame.stack = env->stack; + f->frame.top = env->stack_top; } cl_object @@ -241,10 +241,10 @@ ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o) } cl_object -ecl_stack_frame_from_va_list(cl_object frame, cl_va_list args) +ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object frame, cl_va_list args) { cl_index nargs = args[0].narg; - ecl_stack_frame_open(frame, nargs); + ecl_stack_frame_open(env, frame, nargs); while (nargs) { *(frame->frame.top-nargs) = cl_va_arg(args); nargs--; @@ -256,7 +256,7 @@ void ecl_stack_frame_close(cl_object f) { if (f->frame.stack) { - cl_stack_set_index(f->frame.bottom - f->frame.stack); + ecl_stack_set_index(f->frame.env, f->frame.bottom - f->frame.stack); } } @@ -264,7 +264,7 @@ cl_object ecl_stack_frame_copy(cl_object dest, cl_object orig) { cl_index size = orig->frame.top - orig->frame.bottom; - dest = ecl_stack_frame_open(dest, size); + dest = ecl_stack_frame_open(orig->frame.env, dest, size); memcpy(dest->frame.bottom, orig->frame.bottom, size * sizeof(cl_object)); return dest; } @@ -295,10 +295,11 @@ ecl_lex_env_get_record(register cl_object env, register int s) static cl_object lambda_bind_var(cl_object env, cl_object var, cl_object val, cl_object specials) { + const cl_env_ptr the_env = ecl_process_env(); if (!ecl_member_eq(var, specials)) env = bind_var(env, var, val); else - bds_bind(var, val); + ecl_bds_bind(the_env, var, val); return env; } @@ -431,25 +432,14 @@ lambda_bind(cl_object env, cl_narg narg, cl_object lambda, cl_object *sp) /* -------------------- AIDS TO THE INTERPRETER -------------------- */ -static cl_object -search_global(register cl_object s) { - cl_object x = SYM_VAL(s); - if (x == OBJNULL) - FEunbound_variable(s); - return x; -} - static cl_object close_around(cl_object fun, cl_object lex) { - cl_object v = cl_alloc_object(t_bclosure); + cl_object v = ecl_alloc_object(t_bclosure); v->bclosure.code = fun; v->bclosure.lex = lex; return v; } -#undef frs_pop -#define frs_pop(the_env) { the_env->frs_top--; } - /* * Manipulation of the interpreter stack. As shown here, we omit may * security checks, assuming that the interpreted code is consistent. @@ -460,7 +450,7 @@ close_around(cl_object fun, cl_object lex) { #define STACK_PUSH(the_env,x) { \ cl_object __aux = (x); \ if (the_env->stack_top == the_env->stack_limit) { \ - cl_stack_grow(); \ + ecl_stack_grow(the_env); \ } \ *(the_env->stack_top++) = __aux; } @@ -469,7 +459,7 @@ close_around(cl_object fun, cl_object lex) { #define STACK_PUSH_N(the_env,n) { \ cl_index __aux = (n); \ while ((the_env->stack_limit - the_env->stack_top) <= __aux) { \ - cl_stack_grow(); \ + ecl_stack_grow(the_env); \ } \ the_env->stack_top += __aux; } @@ -502,9 +492,8 @@ cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset) { ECL_OFFSET_TABLE - typedef struct cl_env_struct *cl_env_ptr; - const cl_env_ptr the_env = &cl_env; - volatile cl_index old_bds_top_index = cl_env.bds_top - cl_env.bds_org; + const cl_env_ptr the_env = ecl_process_env(); + volatile cl_index old_bds_top_index = the_env->bds_top - the_env->bds_org; cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset; cl_object *data = bytecodes->bytecodes.data; cl_object reg0, reg1, lex_env = env; @@ -512,12 +501,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs struct ecl_stack_frame frame_aux; volatile struct ihs_frame ihs; - ecl_cs_check(ihs); + ecl_cs_check(the_env, ihs); if (type_of(bytecodes) != t_bytecodes) FEinvalid_function(bytecodes); - ihs_push(&ihs, bytecodes, lex_env); + ecl_ihs_push(the_env, &ihs, bytecodes, lex_env); frame_aux.t = t_frame; frame_aux.stack = frame_aux.top = frame_aux.bottom = 0; reg0 = Cnil; @@ -554,7 +543,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs CASE(OP_VARS); { cl_object var_name; GET_DATA(var_name, vector, data); - reg0 = search_global(var_name); + reg0 = ECL_SYM_VAL(the_env, var_name); + if (reg0 == OBJNULL) + FEunbound_variable(var_name); THREAD_NEXT; } @@ -628,9 +619,11 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs VAR should be either a special variable or a constant. */ CASE(OP_PUSHVS); { - cl_object var_name; + cl_object var_name, value; GET_DATA(var_name, vector, data); - STACK_PUSH(the_env, search_global(var_name)); + value = ECL_SYM_VAL(the_env, var_name); + if (value == OBJNULL) FEunbound_variable(var_name); + STACK_PUSH(the_env, value); THREAD_NEXT; } @@ -712,8 +705,10 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs frame_aux.top = the_env->stack_top; frame_aux.bottom = the_env->stack_top - narg; AGAIN: - if (reg0 == OBJNULL || reg0 == Cnil) + if (reg0 == OBJNULL || reg0 == Cnil) { + cl_print(1,x); FEundefined_function(x); + } switch (type_of(reg0)) { case t_cfunfixed: if (narg != (cl_index)reg0->cfun.narg) @@ -789,8 +784,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs or a function. */ CASE(OP_EXIT); { - ihs_pop(); - bds_unwind(old_bds_top_index); + ecl_ihs_pop(the_env); + ecl_bds_unwind(the_env, old_bds_top_index); return reg0; } /* OP_FLET nfun{arg}, fun1{object} @@ -988,7 +983,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs CASE(OP_UNBINDS); { cl_oparg n; GET_OPARG(n, vector); - bds_unwind_n(n); + ecl_bds_unwind_n(the_env, n); THREAD_NEXT; } /* OP_BIND name{symbol} @@ -1025,13 +1020,13 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs CASE(OP_BINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - bds_bind(var_name, reg0); + ecl_bds_bind(the_env, var_name, reg0); THREAD_NEXT; } CASE(OP_PBINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - bds_bind(var_name, STACK_POP(the_env)); + ecl_bds_bind(the_env, var_name, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { @@ -1039,7 +1034,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs cl_object var_name; GET_OPARG(n, vector); GET_DATA(var_name, vector, data); - bds_bind(var_name, (n < the_env->nvalues) ? the_env->values[n] : Cnil); + ecl_bds_bind(the_env, var_name, + (n < the_env->nvalues) ? the_env->values[n] : Cnil); THREAD_NEXT; } /* OP_SETQ n{arg} @@ -1066,7 +1062,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs /* INV: Not NIL, and of type t_symbol */ if (var->symbol.stype & stp_constant) FEassignment_to_constant(var); - ECL_SETQ(var, reg0); + ECL_SETQ(the_env, var, reg0); THREAD_NEXT; } CASE(OP_PSETQ); { @@ -1079,7 +1075,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs cl_object var; GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(var, STACK_POP(the_env)); + ECL_SETQ(the_env, var, STACK_POP(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { @@ -1097,7 +1093,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs GET_DATA(var, vector, data); GET_OPARG(index, vector); v = (index >= the_env->nvalues)? Cnil : the_env->values[index]; - ECL_SETQ(var, v); + ECL_SETQ(the_env, var, v); THREAD_NEXT; } @@ -1133,7 +1129,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs GET_LABEL(exit, vector); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)exit); - if (frs_push(reg1) == 0) { + if (ecl_frs_push(the_env,reg1) == 0) { THREAD_NEXT; } else { reg0 = the_env->values[0]; @@ -1161,7 +1157,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ vector += n * OPARG_SIZE; - if (frs_push(reg1) != 0) { + if (ecl_frs_push(the_env,reg1) != 0) { /* Wait here for gotos. Each goto sets VALUES(0) to an integer which ranges from 0 to ntags-1, depending on the tag. These @@ -1179,7 +1175,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs } CASE(OP_EXIT_FRAME); { DO_EXIT_FRAME: - frs_pop(the_env); + ecl_frs_pop(the_env); STACK_POP_N(the_env, 2); lex_env = ECL_CONS_CDR(lex_env); THREAD_NEXT; @@ -1287,8 +1283,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs GET_LABEL(exit, vector); STACK_PUSH(the_env, lex_env); STACK_PUSH(the_env, (cl_object)exit); - if (frs_push(ECL_PROTECT_TAG) != 0) { - frs_pop(the_env); + if (ecl_frs_push(the_env,ECL_PROTECT_TAG) != 0) { + ecl_frs_pop(the_env); vector = (cl_opcode *)STACK_POP(the_env); lex_env = STACK_POP(the_env); reg0 = the_env->values[0]; @@ -1298,8 +1294,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs THREAD_NEXT; } CASE(OP_PROTECT_NORMAL); { - bds_unwind(the_env->frs_top->frs_bds_top_index); - frs_pop(the_env); + ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); + ecl_frs_pop(the_env); STACK_POP(the_env); lex_env = STACK_POP(the_env); STACK_PUSH(the_env, MAKE_FIXNUM(1)); @@ -1312,7 +1308,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs reg0 = the_env->values[0]; n = fix(STACK_POP(the_env)); if (n <= 0) - ecl_unwind(the_env->frs_top + n); + ecl_unwind(the_env, the_env->frs_top + n); THREAD_NEXT; } @@ -1329,9 +1325,9 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs for (n = 0; !ecl_endp(vars); n++, vars = ECL_CONS_CDR(vars)) { cl_object var = ECL_CONS_CAR(vars); if (values == Cnil) { - bds_bind(var, OBJNULL); + ecl_bds_bind(the_env, var, OBJNULL); } else { - bds_bind(var, cl_car(values)); + ecl_bds_bind(the_env, var, cl_car(values)); values = ECL_CONS_CDR(values); } } @@ -1340,35 +1336,35 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs } CASE(OP_EXIT_PROGV); { cl_index n = fix(STACK_POP(the_env)); - bds_unwind_n(n); + ecl_bds_unwind_n(the_env, n); THREAD_NEXT; } CASE(OP_STEPIN); { cl_object form; - cl_object a = SYM_VAL(@'si::*step-action*'); + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); cl_index n; GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; - n = cl_stack_push_values(); + n = ecl_stack_push_values(the_env); if (a == Ct) { /* We are stepping in, but must first ask the user * what to do. */ - ECL_SETQ(@'si::*step-level*', - cl_1P(SYM_VAL(@'si::*step-level*'))); + ECL_SETQ(the_env, @'si::*step-level*', + cl_1P(ECL_SYM_VAL(the_env, @'si::*step-level*'))); STACK_PUSH(the_env, form); INTERPRET_FUNCALL(form, the_env, frame_aux, 1, @'si::stepper'); } else if (a != Cnil) { /* The user told us to step over. *step-level* contains * an integer number that, when it becomes 0, means * that we have finished stepping over. */ - ECL_SETQ(@'si::*step-action*', cl_1P(a)); + ECL_SETQ(the_env, @'si::*step-action*', cl_1P(a)); } else { /* We are not inside a STEP form. This should * actually never happen. */ } - cl_stack_pop_values(n); + ecl_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } @@ -1379,32 +1375,32 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs cl_fixnum n; GET_OPARG(n, vector); SETUP_ENV(the_env); - if (SYM_VAL(@'si::*step-action*') == Ct) { + if (ECL_SYM_VAL(the_env, @'si::*step-action*') == Ct) { STACK_PUSH(the_env, reg0); INTERPRET_FUNCALL(reg0, the_env, frame_aux, 1, @'si::stepper'); } INTERPRET_FUNCALL(reg0, the_env, frame_aux, n, reg0); } CASE(OP_STEPOUT); { - cl_object a = SYM_VAL(@'si::*step-action*'); + cl_object a = ECL_SYM_VAL(the_env, @'si::*step-action*'); cl_index n; SETUP_ENV(the_env); the_env->values[0] = reg0; - n = cl_stack_push_values(); + n = ecl_stack_push_values(the_env); if (a == Ct) { /* We exit one stepping level */ - ECL_SETQ(@'si::*step-level*', - cl_1M(SYM_VAL(@'si::*step-level*'))); + ECL_SETQ(the_env, @'si::*step-level*', + cl_1M(ECL_SYM_VAL(the_env, @'si::*step-level*'))); } else if (a == MAKE_FIXNUM(0)) { /* We are back to the level in which the user * selected to step over. */ - ECL_SETQ(@'si::*step-action*', Ct); + ECL_SETQ(the_env, @'si::*step-action*', Ct); } else if (a != Cnil) { - ECL_SETQ(@'si::*step-action*', cl_1M(a)); + ECL_SETQ(the_env, @'si::*step-action*', cl_1M(a)); } else { /* Not stepping, nothing to be done. */ } - cl_stack_pop_values(n); + ecl_stack_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } diff --git a/src/c/load.d b/src/c/load.d index 292cc8d7e..78081634f 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -61,6 +61,7 @@ copy_object_file(cl_object original) int err; cl_object s, copy = make_constant_base_string("TMP:ECL"); copy = si_coerce_to_filename(si_mkstemp(copy)); + ecl_disable_interrupts(); #ifdef HAVE_LSTAT err = unlink(copy->base_string.self) || symlink(original->base_string.self, copy->base_string.self); @@ -71,6 +72,7 @@ copy_object_file(cl_object original) err = 1; #endif #endif + ecl_enable_interrupts(); if (err) { FEerror("Unable to copy file ~A to ~A", 2, original, copy); } @@ -81,10 +83,9 @@ copy_object_file(cl_object original) static cl_object ecl_library_find_by_name(cl_object filename) { - cl_object libraries = cl_core.libraries; - cl_index i; - for (i = 0; i < libraries->vector.fillp; i++) { - cl_object other = libraries->vector.self.t[i]; + cl_object l; + for (l = cl_core.libraries; l != Cnil; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); cl_object name = other->cblock.name; if (!Null(name) && ecl_string_eq(name, filename)) { return other; @@ -96,10 +97,9 @@ ecl_library_find_by_name(cl_object filename) static cl_object ecl_library_find_by_handle(void *handle) { - cl_object libraries = cl_core.libraries; - cl_index i; - for (i = 0; i < libraries->vector.fillp; i++) { - cl_object other = libraries->vector.self.t[i]; + cl_object l; + for (l = cl_core.libraries; l != Cnil; l = ECL_CONS_CDR(l)) { + cl_object other = ECL_CONS_CAR(l); if (handle == other->cblock.handle) { return other; } @@ -110,13 +110,13 @@ ecl_library_find_by_handle(void *handle) cl_object ecl_library_open(cl_object filename, bool force_reload) { cl_object block; - cl_object libraries = cl_core.libraries; bool self_destruct = 0; cl_index i; + char *filename_string; /* Coerces to a file name but does not merge with cwd */ - filename = coerce_to_physical_pathname(filename); - filename = cl_namestring(filename); + filename = si_coerce_to_filename(filename); + filename_string = (char*)filename->base_string.self; if (!force_reload) { /* When loading a foreign library, such as a dll or a @@ -147,22 +147,36 @@ ecl_library_open(cl_object filename, bool force_reload) { } #endif } - block = cl_alloc_object(t_codeblock); + block = ecl_alloc_object(t_codeblock); block->cblock.self_destruct = self_destruct; + block->cblock.locked = 0; + block->cblock.handle = NULL; + block->cblock.entry = NULL; + block->cblock.data = NULL; + block->cblock.data_size = 0; + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + block->cblock.data_text = NULL; + block->cblock.data_text_size = 0; block->cblock.name = filename; + block->cblock.next = Cnil; + block->cblock.links = Cnil; + block->cblock.cfuns_size = 0; + block->cblock.cfuns = NULL; + + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - block->cblock.handle = dlopen(filename->base_string.self, - RTLD_NOW|RTLD_GLOBAL); + block->cblock.handle = dlopen(filename_string, RTLD_NOW|RTLD_GLOBAL); #endif #ifdef HAVE_MACH_O_DYLD_H { NSObjectFileImage file; static NSObjectFileImageReturnCode code; - code = NSCreateObjectFileImageFromFile(filename->base_string.self, &file); + code = NSCreateObjectFileImageFromFile(filename_string, &file); if (code != NSObjectFileImageSuccess) { block->cblock.handle = NULL; } else { - NSModule out = NSLinkModule(file, filename->base_string.self, + NSModule out = NSLinkModule(file, filename_string, NSLINKMODULE_OPTION_PRIVATE| NSLINKMODULE_OPTION_BINDNOW| NSLINKMODULE_OPTION_RETURN_ON_ERROR); @@ -170,8 +184,9 @@ ecl_library_open(cl_object filename, bool force_reload) { }} #endif #if defined(mingw32) || defined(_MSC_VER) - block->cblock.handle = LoadLibrary(filename->base_string.self); + block->cblock.handle = LoadLibrary(filename_string); #endif + ecl_enable_interrupts(); /* * A second pass to ensure that the dlopen routine has not * returned a library that we had already loaded. If this is @@ -188,7 +203,7 @@ ecl_library_open(cl_object filename, bool force_reload) { block = other; } else { si_set_finalizer(block, Ct); - cl_vector_push_extend(2, block, libraries); + cl_core.libraries = CONS(block, cl_core.libraries); } } return block; @@ -198,17 +213,13 @@ void * ecl_library_symbol(cl_object block, const char *symbol, bool lock) { void *p; if (block == @':default') { - cl_object l = cl_core.libraries; - if (l) { - cl_index i; - for (i = 0; i < l->vector.fillp; i++) { - cl_object block = l->vector.self.t[i]; - p = ecl_library_symbol(block, symbol, lock); - if (p) { - return p; - } - } + cl_object l; + for (l = cl_core.libraries; l != Cnil; l = ECL_CONS_CDR(l)) { + cl_object block = ECL_CONS_CAR(l); + p = ecl_library_symbol(block, symbol, lock); + if (p) return p; } + ecl_disable_interrupts(); #if defined(mingw32) || defined(_MSC_VER) { HANDLE hndSnap = NULL; @@ -226,16 +237,18 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) { } CloseHandle(hndSnap); } - return hnd; + p = (void*)hnd; } #endif #ifdef HAVE_DLFCN_H - return dlsym(0, symbol); + p = dlsym(0, symbol); #endif #if !defined(mingw32) && !defined(_MSC_VER) && !defined(HAVE_DLFCN_H) - return 0; + p = 0; #endif + ecl_enable_interrupts(); } else { + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H p = dlsym(block->cblock.handle, symbol); #endif @@ -253,51 +266,58 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) { p = NSAddressOfSymbol(sym); } #endif + ecl_enable_interrupts(); /* Libraries whose symbols are being referenced by the FFI should not * get garbage collected. Until we find a better solution we simply lock * them for the rest of the runtime */ if (p) { block->cblock.locked |= lock; } - return p; } + return p; } cl_object ecl_library_error(cl_object block) { - const char *message; + cl_object output; + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H - message = dlerror(); + output = make_base_string_copy(dlerror()); #endif #ifdef HAVE_MACH_O_DYLD_H - NSLinkEditErrors c; - int number; - const char *filename; - NSLinkEditError(&c, &number, &filename, &message); + { + NSLinkEditErrors c; + int number; + const char *filename; + NSLinkEditError(&c, &number, &filename, &message); + output = make_base_string_copy(message); + } #endif #if defined(mingw32) || defined(_MSC_VER) - cl_object output; - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | - FORMAT_MESSAGE_ALLOCATE_BUFFER, - 0, GetLastError(), 0, (void*)&message, 0, NULL); - output = make_base_string_copy(message); - LocalFree(message); - return output; + { + const char *message; + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | + FORMAT_MESSAGE_ALLOCATE_BUFFER, + 0, GetLastError(), 0, (void*)&message, 0, NULL); + output = make_base_string_copy(message); + LocalFree(message); + } #endif - return make_base_string_copy(message); + ecl_enable_interrupts(); + return output; } void ecl_library_close(cl_object block) { const char *filename; - bool verbose = SYM_VAL(@'si::*gc-verbose*') != Cnil; - cl_object libraries = cl_core.libraries; + bool verbose = ecl_symbol_value(@'si::*gc-verbose*') != Cnil; + cl_object l; int i; if (Null(block->cblock.name)) filename = ""; else - filename = block->cblock.name->base_string.self; + filename = (char*)block->cblock.name->base_string.self; if (!Null(block->cblock.links)) { cl_mapc(2, @'si::unlink-symbol', block->cblock.links); } @@ -305,6 +325,7 @@ ecl_library_close(cl_object block) { if (verbose) { fprintf(stderr, ";;; Freeing library %s\n", filename); } + ecl_disable_interrupts(); #ifdef HAVE_DLFCN_H dlclose(block->cblock.handle); #endif @@ -314,6 +335,7 @@ ecl_library_close(cl_object block) { #if defined(mingw32) || defined(_MSC_VER) FreeLibrary(block->cblock.handle); #endif + ecl_enable_interrupts(); } if (block->cblock.self_destruct) { if (verbose) { @@ -321,42 +343,35 @@ ecl_library_close(cl_object block) { } unlink(filename); } - for (i = 0; i < libraries->vector.fillp; i++) { - if (libraries->vector.self.t[i] == block) { - memmove(libraries->vector.self.t+i, - libraries->vector.self.t+i+1, - (libraries->vector.fillp-i-1) * sizeof(cl_object)); - libraries->vector.fillp--; - break; - } - } + cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); } void ecl_library_close_all(void) { - int i; - while ((i = cl_core.libraries->vector.fillp)) - ecl_library_close(cl_core.libraries->vector.self.t[--i]); + while (cl_core.libraries != Cnil) { + ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + } } cl_object si_load_binary(cl_object filename, cl_object verbose, cl_object print) { + const cl_env_ptr the_env = ecl_process_env(); cl_object block; cl_object basename; cl_object prefix; cl_object output; /* We need the full pathname */ - filename = cl_namestring(cl_truename(filename)); + filename = cl_truename(filename); #ifdef ECL_THREADS /* Loading binary code is not thread safe. When another thread tries to load the same file, we may end up initializing twice the same module. */ mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(the_env) { #endif /* Try to load shared object file */ block = ecl_library_open(filename, 1); @@ -381,7 +396,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) make_constant_base_string("_")); basename = cl_pathname_name(1,filename); basename = @si::base-string-concatenate(2, prefix, @string-upcase(1, funcall(4, @'nsubstitute', CODE_CHAR('_'), CODE_CHAR('-'), basename))); - block->cblock.entry = ecl_library_symbol(block, basename->base_string.self, 0); + block->cblock.entry = ecl_library_symbol(block, (char*)basename->base_string.self, 0); if (block->cblock.entry == NULL) { output = ecl_library_error(block); @@ -407,6 +422,7 @@ OUTPUT: cl_object si_load_source(cl_object source, cl_object verbose, cl_object print) { + cl_env_ptr the_env = ecl_process_env(); cl_object x, strm; /* Source may be either a stream or a filename */ @@ -414,14 +430,15 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) /* INV: if "source" is not a valid stream, file.d will complain */ strm = source; } else { - strm = ecl_open_stream(source, smm_input, Cnil, Cnil, 8, 1, 1); + strm = ecl_open_stream(source, smm_input, Cnil, Cnil, 8, + ECL_STREAM_DEFAULT_FORMAT); if (Null(strm)) @(return Cnil) } - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(the_env) { cl_object form_index = MAKE_FIXNUM(0); cl_object location = CONS(source, form_index); - bds_bind(@'ext::*source-location*', location); + ecl_bds_bind(the_env, @'ext::*source-location*', location); for (;;) { x = cl_read(3, strm, Cnil, OBJNULL); if (x == OBJNULL) @@ -434,7 +451,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print) form_index = ecl_plus(MAKE_FIXNUM(1),form_index); ECL_RPLACD(location, form_index); } - bds_unwind1(); + ecl_bds_unwind1(the_env); } CL_UNWIND_PROTECT_EXIT { /* We do not want to come back here if close_stream fails, therefore, first we frs_pop() current jump point, then @@ -517,10 +534,11 @@ NOT_A_FILENAME: cl_format(3, Ct, make_constant_base_string("~&;;; Loading ~s~%"), filename); } - bds_bind(@'*package*', ecl_symbol_value(@'*package*')); - bds_bind(@'*readtable*', ecl_symbol_value(@'*readtable*')); - bds_bind(@'*load-pathname*', not_a_filename? Cnil : source); - bds_bind(@'*load-truename*', not_a_filename? Cnil : cl_truename(filename)); + ecl_bds_bind(the_env, @'*package*', ecl_symbol_value(@'*package*')); + ecl_bds_bind(the_env, @'*readtable*', ecl_symbol_value(@'*readtable*')); + ecl_bds_bind(the_env, @'*load-pathname*', not_a_filename? Cnil : source); + ecl_bds_bind(the_env, @'*load-truename*', + not_a_filename? Cnil : (filename = cl_truename(filename))); if (!Null(function)) { ok = funcall(4, function, filename, verbose, print); } else { @@ -542,7 +560,7 @@ NOT_A_FILENAME: #endif ok = si_load_source(filename, verbose, print); } - bds_unwind_n(4); + ecl_bds_unwind_n(the_env, 4); if (!Null(ok)) FEerror("LOAD: Could not load file ~S (Error: ~S)", 2, filename, ok); diff --git a/src/c/main.d b/src/c/main.d index 0c4968b35..2559e7fce 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -32,6 +32,9 @@ # include # endif #endif +#ifdef ECL_USE_MPROTECT +# include +#endif #include #include #include @@ -40,9 +43,9 @@ extern int GC_dont_gc; /******************************* EXPORTS ******************************/ #if !defined(ECL_THREADS) -struct cl_env_struct cl_env; +cl_env_ptr cl_env_p = NULL; #elif defined(WITH___THREAD) -__thread struct cl_env_struct * cl_env_p; +__thread cl_env_ptr cl_env_p = NULL; #endif struct cl_core_struct cl_core; const char *ecl_self; @@ -72,6 +75,8 @@ static cl_fixnum option_values[ECL_OPT_LIMIT+1] = { 131072, /* ECL_OPT_C_STACK_SIZE */ 4192, /* ECL_OPT_C_STACK_SAFETY_AREA */ 1, /* ECL_OPT_SIGALTSTACK_SIZE */ + 128*1024*1024, /* ECL_OPT_HEAP_SIZE */ + 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ 0}; #if !defined(GBC_BOEHM) @@ -95,7 +100,7 @@ ecl_set_option(int option, cl_fixnum value) if (option > ECL_OPT_LIMIT || option < 0) { FEerror("Invalid boot option ~D", 1, MAKE_FIXNUM(option)); } else { - if (option > ECL_OPT_BOOTED && + if (option < ECL_OPT_BOOTED && option_values[ECL_OPT_BOOTED]) { FEerror("Cannot change option ~D while ECL is running", 1, MAKE_FIXNUM(option)); @@ -105,7 +110,7 @@ ecl_set_option(int option, cl_fixnum value) } void -ecl_init_env(struct cl_env_struct *env) +ecl_init_env(cl_env_ptr env) { int i; @@ -117,13 +122,13 @@ ecl_init_env(struct cl_env_struct *env) env->stack_top = NULL; env->stack_limit = NULL; env->stack_size = 0; - cl_stack_set_size(ecl_get_option(ECL_OPT_LISP_STACK_SIZE)); + ecl_stack_set_size(env, ecl_get_option(ECL_OPT_LISP_STACK_SIZE)); #if !defined(ECL_CMU_FORMAT) env->print_pretty = FALSE; - env->queue = cl_alloc_atomic(ECL_PPRINT_QUEUE_SIZE * sizeof(short)); - env->indent_stack = cl_alloc_atomic(ECL_PPRINT_INDENTATION_STACK_SIZE * sizeof(short)); - env->fmt_aux_stream = ecl_make_string_output_stream(64); + env->queue = ecl_alloc_atomic(ECL_PPRINT_QUEUE_SIZE * sizeof(short)); + env->indent_stack = ecl_alloc_atomic(ECL_PPRINT_INDENTATION_STACK_SIZE * sizeof(short)); + env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); #endif #if !defined(GBC_BOEHM) # if defined(THREADS) @@ -137,7 +142,7 @@ ecl_init_env(struct cl_env_struct *env) #endif /* !GBC_BOEHM */ #ifdef ECL_DYNAMIC_FFI - env->fficall = cl_alloc(sizeof(struct ecl_fficall)); + env->fficall = ecl_alloc(sizeof(struct ecl_fficall)); ((struct ecl_fficall*)env->fficall)->registers = 0; #endif @@ -196,11 +201,37 @@ static const struct { {NULL, -1} }; +cl_env_ptr +_ecl_alloc_env() +{ + /* + * Allocates the lisp environment for a thread. Depending on which + * mechanism we use for detecting delayed signals, we may allocate + * the environment using mmap or the garbage collector. + */ + cl_env_ptr output; +#if defined(ECL_USE_MPROTECT) + output = mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, 0, 0); + if (output < 0) + ecl_internal_error("Unable to allocate environment structure."); +#else + output = ecl_alloc(sizeof(*output)); +#endif + /* + * An uninitialized environment _always_ disables interrupts. They + * are activated later on by the thread entry point or init_unixint(). + */ + output->disable_interrupts = 1; + return output; +} + int cl_shutdown(void) { + const cl_env_ptr env = ecl_process_env(); if (ecl_get_option(ECL_OPT_BOOTED) > 0) { - cl_object l = SYM_VAL(@'si::*exit-hooks*'); + cl_object l = ecl_symbol_value(@'si::*exit-hooks*'); cl_object form = cl_list(2, @'funcall', Cnil); while (CONSP(l)) { ecl_elt_set(form, 1, ECL_CONS_CAR(l)); @@ -225,6 +256,7 @@ cl_boot(int argc, char **argv) cl_object aux; cl_object features; int i; + cl_env_ptr env; i = ecl_get_option(ECL_OPT_BOOTED); if (i) { @@ -247,12 +279,11 @@ cl_boot(int argc, char **argv) init_unixint(0); init_alloc(); GC_disable(); -#ifdef ECL_THREADS - init_threads(); -#endif - -#if !defined(MSDOS) && !defined(cygwin) - ecl_self = ecl_expand_pathname(ecl_self); + env = _ecl_alloc_env(); +#if !defined(ECL_THREADS) || defined(WITH__THREAD) + cl_env_p = env; +#else + init_threads(env); #endif /* @@ -361,9 +392,7 @@ cl_boot(int argc, char **argv) /* LIBRARIES is an adjustable vector of objects. It behaves as a vector of weak pointers thanks to the magic in gbc.d/alloc_2.d */ - cl_core.libraries = si_make_vector(@'t', MAKE_FIXNUM(0), - @'t', MAKE_FIXNUM(0), - @'nil', @'nil'); + cl_core.libraries = Cnil; #if 0 /* FINALIZERS and FINALIZABLE_OBJECTS are also like LIBRARIES */ cl_core.finalizable_objects = si_make_vector(@'t', MAKE_FIXNUM(512), @@ -407,7 +436,7 @@ cl_boot(int argc, char **argv) * This cannot come later, because some routines need the * frame stack immediately (for instance SI:PATHNAME-TRANSLATIONS). */ - ecl_init_env(&cl_env); + ecl_init_env(env); #if !defined(GBC_BOEHM) /* We need this because a lot of stuff is to be created */ init_GC(); @@ -415,11 +444,11 @@ cl_boot(int argc, char **argv) GC_enable(); #ifdef ECL_THREADS - cl_env.bindings_hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), + env->bindings_hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), ecl_make_singlefloat(1.5f), ecl_make_singlefloat(0.75f), Cnil); /* no locking */ - ECL_SET(@'mp::*current-process*', cl_env.own_process); + ECL_SET(@'mp::*current-process*', env->own_process); #endif /* @@ -608,7 +637,7 @@ si_getenv(cl_object var) const char *value; var = ecl_check_cl_type(@'ext::getenv', var, t_base_string); - value = getenv(var->base_string.self); + value = getenv((char*)var->base_string.self); @(return ((value == NULL)? Cnil : make_base_string_copy(value))) } @@ -616,6 +645,7 @@ si_getenv(cl_object var) cl_object si_setenv(cl_object var, cl_object value) { + const cl_env_ptr the_env = ecl_process_env(); cl_fixnum ret_val; var = ecl_check_cl_type(@'ext::setenv', var, t_base_string); @@ -624,26 +654,27 @@ si_setenv(cl_object var, cl_object value) /* Remove the variable when setting to nil, so that * (si:setenv "foo" nil), then (si:getenv "foo) returns * the right thing. */ - unsetenv(var->base_string.self); + unsetenv((char*)var->base_string.self); #else #if defined(_MSC_VER) || defined(mingw32) si_setenv(var, make_simple_base_string("")); #else - putenv(var->base_string.self); + putenv((char*)var->base_string.self); #endif #endif ret_val = 0; } else { #ifdef HAVE_SETENV value = ecl_check_cl_type(@'intern', value, t_base_string); - ret_val = setenv(var->base_string.self, value->base_string.self, 1); + ret_val = setenv((char*)var->base_string.self, + (char*)value->base_string.self, 1); #else cl_object temp = cl_format(4, Cnil, make_constant_base_string("~A=~A"), var, value); if (temp->base_string.hasfillp && temp->base_string.fillp < temp->base_string.dim) temp->base_string.self[temp->base_string.fillp] = '\0'; - putenv(temp->base_string.self); + putenv((char*)temp->base_string.self); #endif } if (ret_val == -1) @@ -656,6 +687,7 @@ si_setenv(cl_object var, cl_object value) cl_object si_pointer(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); @(return ecl_make_unsigned_integer((cl_index)x)) } diff --git a/src/c/mapfun.d b/src/c/mapfun.d index 86415e2d1..748b5a2ad 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -22,7 +22,8 @@ struct ecl_stack_frame cdrs_frame_aux, cars_frame_aux; \ cl_object cdrs_frame, cars_frame; \ cl_index nargs; \ - cdrs_frame = ecl_stack_frame_from_va_list((cl_object)&cdrs_frame_aux, list); \ + cdrs_frame = ecl_stack_frame_from_va_list(ecl_process_env(),\ + (cl_object)&cdrs_frame_aux, list); \ cars_frame = ecl_stack_frame_copy((cl_object)&cars_frame_aux, cdrs_frame); \ nargs = ECL_STACK_FRAME_SIZE(cars_frame); \ if (nargs == 0) { \ diff --git a/src/c/newhash.h b/src/c/newhash.h index 770d575fe..3c121be92 100644 --- a/src/c/newhash.h +++ b/src/c/newhash.h @@ -144,7 +144,7 @@ static cl_index hash_word(cl_index c, cl_index w) return c; } -static cl_index hash_base_string(const char *s, cl_index len, cl_index h) +static cl_index hash_base_string(const unsigned char *s, cl_index len, cl_index h) { cl_index a = GOLDEN_RATIO, b = GOLDEN_RATIO, i; for (i = len; i >= 3; i -= 3) { @@ -179,4 +179,3 @@ static cl_index hash_full_string(const cl_object *s, cl_index len, cl_index h) mix(a, b, h); return h; } - diff --git a/src/c/num_arith.d b/src/c/num_arith.d index 97ef7f212..58245d541 100644 --- a/src/c/num_arith.d +++ b/src/c/num_arith.d @@ -840,7 +840,7 @@ ecl_negate(cl_object x) case t_ratio: z1 = ecl_negate(x->ratio.num); - z = cl_alloc_object(t_ratio); + z = ecl_alloc_object(t_ratio); z->ratio.num = z1; z->ratio.den = x->ratio.den; return(z); @@ -850,12 +850,12 @@ ecl_negate(cl_object x) return make_shortfloat(-ecl_shortfloat(x)); #endif case t_singlefloat: - z = cl_alloc_object(t_singlefloat); + z = ecl_alloc_object(t_singlefloat); sf(z) = -sf(x); return(z); case t_doublefloat: - z = cl_alloc_object(t_doublefloat); + z = ecl_alloc_object(t_doublefloat); df(z) = -df(x); return(z); #ifdef ECL_LONG_FLOAT @@ -1253,12 +1253,12 @@ ecl_one_plus(cl_object x) return make_shortfloat(1.0 + ecl_short_float(x)); #endif case t_singlefloat: - z = cl_alloc_object(t_singlefloat); + z = ecl_alloc_object(t_singlefloat); sf(z) = sf(x) + 1.0; return(z); case t_doublefloat: - z = cl_alloc_object(t_doublefloat); + z = ecl_alloc_object(t_doublefloat); df(z) = df(x) + 1.0; return(z); @@ -1310,12 +1310,12 @@ ecl_one_minus(cl_object x) #endif case t_singlefloat: - z = cl_alloc_object(t_singlefloat); + z = ecl_alloc_object(t_singlefloat); sf(z) = sf(x) - 1.0; return(z); case t_doublefloat: - z = cl_alloc_object(t_doublefloat); + z = ecl_alloc_object(t_doublefloat); df(z) = df(x) - 1.0; return(z); diff --git a/src/c/num_co.d b/src/c/num_co.d index cf5805412..4096e7eeb 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -126,6 +126,7 @@ cl_numerator(cl_object x) cl_object cl_denominator(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); AGAIN: switch (type_of(x)) { case t_ratio: @@ -145,6 +146,7 @@ cl_denominator(cl_object x) cl_object ecl_floor1(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; AGAIN: switch (type_of(x)) { @@ -199,6 +201,7 @@ ecl_floor1(cl_object x) cl_object ecl_floor2(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; cl_type ty; AGAIN: @@ -425,6 +428,7 @@ ecl_floor2(cl_object x, cl_object y) cl_object ecl_ceiling1(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; AGAIN: switch (type_of(x)) { @@ -479,6 +483,7 @@ ecl_ceiling1(cl_object x) cl_object ecl_ceiling2(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; cl_type ty; AGAIN: @@ -705,6 +710,7 @@ ecl_ceiling2(cl_object x, cl_object y) cl_object ecl_truncate1(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; AGAIN: switch (type_of(x)) { @@ -759,6 +765,7 @@ ecl_truncate1(cl_object x) cl_object ecl_truncate2(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); if (ecl_plusp(x) != ecl_plusp(y)) return ecl_ceiling2(x, y); else @@ -817,6 +824,7 @@ round_long_double(long double d) cl_object ecl_round1(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; AGAIN: switch (type_of(x)) { @@ -867,6 +875,7 @@ ecl_round1(cl_object x) cl_object ecl_round2(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); cl_object v0, v1; cl_object q; @@ -915,6 +924,7 @@ ecl_round2(cl_object x, cl_object y) cl_object cl_mod(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); /* INV: #'floor always outputs two values */ @floor(2, x, y); @(return VALUES(1)) @@ -923,6 +933,7 @@ cl_mod(cl_object x, cl_object y) cl_object cl_rem(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); @truncate(2, x, y); @(return VALUES(1)) } @@ -930,6 +941,7 @@ cl_rem(cl_object x, cl_object y) cl_object cl_decode_float(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); int e, s; cl_type tx = type_of(x); float f; @@ -989,6 +1001,7 @@ cl_decode_float(cl_object x) cl_object cl_scale_float(cl_object x, cl_object y) { + const cl_env_ptr the_env = ecl_process_env(); cl_fixnum k; AGAIN: if (FIXNUMP(y)) { @@ -1024,6 +1037,7 @@ cl_scale_float(cl_object x, cl_object y) cl_object cl_float_radix(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); while (cl_floatp(x) != Ct) { x = ecl_type_error(@'float-radix',"argument",x,@'float'); } @@ -1093,6 +1107,7 @@ cl_float_radix(cl_object x) cl_object cl_float_digits(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); AGAIN: switch (type_of(x)) { #ifdef ECL_SHORT_FLOAT @@ -1119,6 +1134,7 @@ cl_float_digits(cl_object x) cl_object cl_float_precision(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); int precision; float f; double d; AGAIN: @@ -1197,6 +1213,7 @@ cl_float_precision(cl_object x) cl_object cl_integer_decode_float(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); int e, s; AGAIN: switch (type_of(x)) { @@ -1297,6 +1314,7 @@ cl_integer_decode_float(cl_object x) cl_object cl_realpart(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); AGAIN: switch (type_of(x)) { case t_fixnum: @@ -1324,6 +1342,7 @@ cl_realpart(cl_object x) cl_object cl_imagpart(cl_object x) { + const cl_env_ptr the_env = ecl_process_env(); AGAIN: switch (type_of(x)) { case t_fixnum: diff --git a/src/c/num_log.d b/src/c/num_log.d index c9881b7dc..0dd611d81 100644 --- a/src/c/num_log.d +++ b/src/c/num_log.d @@ -848,7 +848,7 @@ si_bit_array_op(cl_object o, cl_object x, cl_object y, cl_object r) } L2: if (Null(r)) { - r = cl_alloc_object(t_array); + r = ecl_alloc_object(t_array); r->array.self.t = NULL; r->array.displaced = Cnil; r->array.rank = x->array.rank; diff --git a/src/c/num_rand.d b/src/c/num_rand.d index 31aa4372a..596d440a0 100644 --- a/src/c/num_rand.d +++ b/src/c/num_rand.d @@ -171,7 +171,7 @@ rando(cl_object x, cl_object rs) cl_object ecl_make_random_state(cl_object rs) { - cl_object z = cl_alloc_object(t_random); + cl_object z = ecl_alloc_object(t_random); if (rs == Ct) { z->random.value = init_random_state(); } else { diff --git a/src/c/number.d b/src/c/number.d index 134cc735c..4458900a9 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -87,7 +87,7 @@ cl_object ecl_make_integer(cl_fixnum l) { if (l > MOST_POSITIVE_FIXNUM || l < MOST_NEGATIVE_FIXNUM) { - cl_object z = cl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); #ifdef WITH_GMP mpz_init_set_si(z->big.big_num, l); #else /* WITH_GMP */ @@ -102,7 +102,7 @@ cl_object ecl_make_unsigned_integer(cl_index l) { if (l > MOST_POSITIVE_FIXNUM) { - cl_object z = cl_alloc_object(t_bignum); + cl_object z = ecl_alloc_object(t_bignum); #ifdef WITH_GMP mpz_init_set_ui(z->big.big_num, l); #else /* WITH_GMP */ @@ -134,7 +134,7 @@ ecl_make_ratio(cl_object num, cl_object den) return num; if (den == MAKE_FIXNUM(-1)) return ecl_negate(num); - r = cl_alloc_object(t_ratio); + r = ecl_alloc_object(t_ratio); r->ratio.num = num; r->ratio.den = den; return(r); @@ -158,7 +158,7 @@ ecl_make_singlefloat(float f) if (!isfinite(f)) { cl_error(1, @'floating-point-overflow'); } - x = cl_alloc_object(t_singlefloat); + x = ecl_alloc_object(t_singlefloat); sf(x) = f; return(x); } @@ -181,7 +181,7 @@ ecl_make_doublefloat(double f) if (!isfinite(f)) { cl_error(1, @'floating-point-overflow'); } - x = cl_alloc_object(t_doublefloat); + x = ecl_alloc_object(t_doublefloat); df(x) = f; return(x); } @@ -205,7 +205,7 @@ make_longfloat(long double f) if (!isfinite(f)) { cl_error(1, @'floating-point-overflow'); } - x = cl_alloc_object(t_longfloat); + x = ecl_alloc_object(t_longfloat); x->longfloat.value = f; return x; } @@ -337,7 +337,7 @@ ecl_make_complex(cl_object r, cl_object i) goto AGAIN; } - c = cl_alloc_object(t_complex); + c = ecl_alloc_object(t_complex); c->complex.real = r; c->complex.imag = i; return(c); @@ -589,12 +589,12 @@ init_number(void) ECL_SET(@'LEAST-NEGATIVE-LONG-FLOAT', num); ECL_SET(@'LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT', num); - cl_core.singlefloat_zero = cl_alloc_object(t_singlefloat); + cl_core.singlefloat_zero = ecl_alloc_object(t_singlefloat); sf(cl_core.singlefloat_zero) = (float)0; - cl_core.doublefloat_zero = cl_alloc_object(t_doublefloat); + cl_core.doublefloat_zero = ecl_alloc_object(t_doublefloat); df(cl_core.doublefloat_zero) = (double)0; #ifdef ECL_LONG_FLOAT - cl_core.longfloat_zero = cl_alloc_object(t_longfloat); + cl_core.longfloat_zero = ecl_alloc_object(t_longfloat); cl_core.longfloat_zero->longfloat.value = (long double)0; #endif cl_core.plus_half = ecl_make_ratio(MAKE_FIXNUM(1), MAKE_FIXNUM(2)); @@ -612,7 +612,7 @@ init_number(void) ECL_SET(@'pi', ecl_make_doublefloat((double)ECL_PI_D)); #endif - init_big(); + init_big(&cl_env); ECL_SET(@'*random-state*', ecl_make_random_state(Ct)); } diff --git a/src/c/package.d b/src/c/package.d index 368dd18a9..759cb91c7 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -111,7 +111,7 @@ make_package_hashtable() cl_object h; cl_index hsize = 128; - h = cl_alloc_object(t_hashtable); + h = ecl_alloc_object(t_hashtable); h->hash.lockable = 0; h->hash.test = htt_pack; h->hash.size = hsize; @@ -120,7 +120,7 @@ make_package_hashtable() h->hash.factor = 0.7; h->hash.entries = 0; h->hash.data = NULL; /* for GC sake */ - h->hash.data = (struct ecl_hashtable_entry *)cl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); + h->hash.data = (struct ecl_hashtable_entry *)ecl_alloc(hsize * sizeof(struct ecl_hashtable_entry)); return cl_clrhash(h); } @@ -169,7 +169,7 @@ ecl_make_package(cl_object name, cl_object nicknames, cl_object use_list) other, 1, name); return other; } - x = cl_alloc_object(t_package); + x = ecl_alloc_object(t_package); x->pack.internal = make_package_hashtable(); x->pack.external = make_package_hashtable(); #ifdef ECL_THREADS @@ -279,7 +279,7 @@ ecl_find_package_nolock(cl_object name) /* Note that this function may actually be called _before_ symbols are set up * and bound! */ if (ecl_get_option(ECL_OPT_BOOTED) && - SYM_VAL(@'si::*relative-package-names*') != Cnil) { + ECL_SYM_VAL(ecl_process_env(), @'si::*relative-package-names*') != Cnil) { return si_find_relative_package(1, name); } #endif @@ -301,15 +301,14 @@ si_coerce_to_package(cl_object p) cl_object ecl_current_package(void) { - cl_object x; - - x = ecl_symbol_value(@'*package*'); + cl_object x = ecl_symbol_value(@'*package*'); if (type_of(x) != t_package) { - ECL_SETQ(@'*package*', cl_core.user_package); + const cl_env_ptr env = ecl_process_env(); + ECL_SETQ(env, @'*package*', cl_core.user_package); FEerror("The value of *PACKAGE*, ~S, was not a package", 1, x); } - return(x); + return x; } /* @@ -329,11 +328,6 @@ ecl_intern(cl_object name, cl_object p, int *intern_flag) cl_object s, ul; name = ecl_check_type_string(@'intern', name); -#ifdef ECL_UNICODE - if (ecl_fits_in_base_string(name)) { - name = si_copy_to_simple_base_string(name); - } -#endif p = si_coerce_to_package(p); TRY_AGAIN_LABEL: PACKAGE_LOCK(p); @@ -389,11 +383,6 @@ ecl_find_symbol_nolock(cl_object name, cl_object p, int *intern_flag) cl_object s, ul; name = ecl_check_type_string(@'find-symbol', name); -#ifdef ECL_UNICODE - if (ecl_fits_in_base_string(name)) { - name = si_copy_to_simple_base_string(name); - } -#endif s = ecl_gethash_safe(name, p->pack.external, OBJNULL); if (s != OBJNULL) { *intern_flag = EXTERNAL; @@ -782,8 +771,9 @@ ecl_unuse_package(cl_object x, cl_object p) cl_object si_select_package(cl_object pack_name) { + const cl_env_ptr the_env = ecl_process_env(); cl_object p = si_coerce_to_package(pack_name); - @(return (ECL_SETQ(@'*package*', p))) + @(return (ECL_SETQ(the_env, @'*package*', p))) } cl_object @@ -1051,6 +1041,7 @@ BEGIN: cl_object si_package_hash_tables(cl_object p) { + const cl_env_ptr the_env = ecl_process_env(); cl_object he, hi, u; assert_type_package(p); PACKAGE_LOCK(p); diff --git a/src/c/pathname.d b/src/c/pathname.d index fa073eec8..217e786af 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -23,6 +23,7 @@ #include #include +#include #include #include #include @@ -122,7 +123,7 @@ ecl_make_pathname(cl_object host, cl_object device, cl_object directory, { cl_object x, p, component; - p = cl_alloc_object(t_pathname); + p = ecl_alloc_object(t_pathname); if (ecl_stringp(host)) p->pathname.logical = ecl_logical_hostname_p(host); else if (host == Cnil) @@ -624,10 +625,11 @@ si_default_pathname_defaults(void) * this routine might itself try to use the value of this variable. */ cl_object path = ecl_symbol_value(@'*default-pathname-defaults*'); while (type_of(path) != t_pathname) { - bds_bind(@'*default-pathname-defaults*', si_getcwd(0)); + const cl_env_ptr the_env = ecl_process_env(); + ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0)); path = ecl_type_error(@'pathname', "*default-pathname-defaults*", path, @'pathname'); - bds_unwind1(); + ecl_bds_unwind1(the_env); } @(return path) } @@ -642,25 +644,21 @@ L: #endif case t_base_string: x = cl_parse_namestring(1, x); - case t_pathname: break; - case t_stream: switch ((enum ecl_smmode)x->stream.mode) { case smm_input: case smm_output: case smm_probe: case smm_io: - x = x->stream.object1; - /* - The file was stored in stream.object1. - See open. - */ + case smm_input_file: + case smm_output_file: + case smm_io_file: + x = IO_STREAM_FILENAME(x); goto L; - case smm_synonym: - x = ecl_symbol_value(x->stream.object0); + x = SYNONYM_STREAM_STREAM(x); goto L; default: ;/* Fall through to error message */ @@ -807,8 +805,10 @@ si_coerce_to_filename(cl_object pathname_orig) FEerror("Too long filename: ~S.", 1, namestring); #ifdef ECL_UNICODE if (type_of(namestring) == t_string) { - FEerror("The filesystem does not accept filenames with extended characters: ~S", - 1, namestring); + if (!ecl_fits_in_base_string(namestring)) + FEerror("The filesystem does not accept filenames with extended characters: ~S", + 1, namestring); + namestring = si_copy_to_simple_base_string(namestring); } #endif return namestring; @@ -881,7 +881,7 @@ ecl_namestring(cl_object x, int truncate_if_unreadable) * or using ecl_make_pathname(). In all of these cases ECL will complain * at creation time if the pathname has wrong components. */ - buffer = ecl_make_string_output_stream(128); + buffer = ecl_make_string_output_stream(128, 1); logical = x->pathname.logical; host = x->pathname.host; if (logical) { @@ -1534,7 +1534,7 @@ copy_list_wildcards(cl_object *wilds, cl_object to) if (source->pathname.logical != from->pathname.logical) goto error; - out = cl_alloc_object(t_pathname); + out = ecl_alloc_object(t_pathname); out->pathname.logical = to->pathname.logical; /* Match host names */ diff --git a/src/c/print.d b/src/c/print.d index c4c7a8e8c..38359a95b 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -73,59 +73,60 @@ static void flush_queue(bool force, cl_object stream); static void writec_queue(int c, cl_object stream) { - if (cl_env.qc >= ECL_PPRINT_QUEUE_SIZE) + const cl_env_ptr env = ecl_process_env(); + if (env->qc >= ECL_PPRINT_QUEUE_SIZE) flush_queue(FALSE, stream); - if (cl_env.qc >= ECL_PPRINT_QUEUE_SIZE) + if (env->qc >= ECL_PPRINT_QUEUE_SIZE) FEerror("Can't pretty-print.", 0); - cl_env.queue[cl_env.qt] = c; - cl_env.qt = mod(cl_env.qt+1); - cl_env.qc++; + env->queue[env->qt] = c; + env->qt = mod(env->qt+1); + env->qc++; } static void flush_queue(bool force, cl_object stream) { + const cl_env_ptr env = ecl_process_env(); int c, i, j, k, l, i0; - BEGIN: - while (cl_env.qc > 0) { - c = cl_env.queue[cl_env.qh]; + while (env->qc > 0) { + c = env->queue[env->qh]; if (c < 0400) { ecl_write_char(c, stream); } else if (c == MARK) goto DO_MARK; else if (c == UNMARK) - cl_env.isp -= 2; + env->isp -= 2; else if (c == SET_INDENT) - cl_env.indent_stack[cl_env.isp] = ecl_file_column(stream); + env->indent_stack[env->isp] = ecl_file_column(stream); else if (c == INDENT) { goto DO_INDENT; } else if (c == INDENT1) { - i = ecl_file_column(stream)-cl_env.indent_stack[cl_env.isp]; - if (i < 8 && cl_env.indent_stack[cl_env.isp] < LINE_LENGTH/2) { + i = ecl_file_column(stream)-env->indent_stack[env->isp]; + if (i < 8 && env->indent_stack[env->isp] < LINE_LENGTH/2) { ecl_write_char(' ', stream); - cl_env.indent_stack[cl_env.isp] + env->indent_stack[env->isp] = ecl_file_column(stream); } else { - if (cl_env.indent_stack[cl_env.isp] < LINE_LENGTH/2) { - cl_env.indent_stack[cl_env.isp] - = cl_env.indent_stack[cl_env.isp-1] + 4; + if (env->indent_stack[env->isp] < LINE_LENGTH/2) { + env->indent_stack[env->isp] + = env->indent_stack[env->isp-1] + 4; } goto DO_INDENT; } } else if (c == INDENT2) { - cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1] + 2; + env->indent_stack[env->isp] = env->indent_stack[env->isp-1] + 2; goto PUT_INDENT; } - cl_env.qh = mod(cl_env.qh+1); - --cl_env.qc; + env->qh = mod(env->qh+1); + --env->qc; } return; DO_MARK: k = LINE_LENGTH - 1 - ecl_file_column(stream); - for (i = 1, j = 0, l = 1; l > 0 && i < cl_env.qc && j < k; i++) { - c = cl_env.queue[mod(cl_env.qh + i)]; + for (i = 1, j = 0, l = 1; l > 0 && i < env->qc && j < k; i++) { + c = env->queue[mod(env->qh + i)]; if (c == MARK) l++; else if (c == UNMARK) @@ -137,23 +138,23 @@ DO_MARK: } if (l == 0) goto FLUSH; - if (i == cl_env.qc && !force) + if (i == env->qc && !force) return; - cl_env.qh = mod(cl_env.qh+1); - --cl_env.qc; - if (cl_env.isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-2) + env->qh = mod(env->qh+1); + --env->qc; + if (env->isp >= ECL_PPRINT_INDENTATION_STACK_SIZE-2) FEerror("Can't pretty-print.", 0); - cl_env.isp+=2; - cl_env.indent_stack[cl_env.isp-1] = ecl_file_column(stream); - cl_env.indent_stack[cl_env.isp] = cl_env.indent_stack[cl_env.isp-1]; + env->isp+=2; + env->indent_stack[env->isp-1] = ecl_file_column(stream); + env->indent_stack[env->isp] = env->indent_stack[env->isp-1]; goto BEGIN; DO_INDENT: - if (cl_env.iisp > cl_env.isp) + if (env->iisp > env->isp) goto PUT_INDENT; k = LINE_LENGTH - 1 - ecl_file_column(stream); - for (i0 = 0, i = 1, j = 0, l = 1; i < cl_env.qc && j < k; i++) { - c = cl_env.queue[mod(cl_env.qh + i)]; + for (i0 = 0, i = 1, j = 0, l = 1; i < env->qc && j < k; i++) { + c = env->queue[mod(env->qh + i)]; if (c == MARK) l++; else if (c == UNMARK) { @@ -179,7 +180,7 @@ DO_INDENT: } else if (c < 0400) j++; } - if (i == cl_env.qc && !force) + if (i == env->qc && !force) return; if (i0 == 0) goto PUT_INDENT; @@ -187,23 +188,23 @@ DO_INDENT: goto FLUSH; PUT_INDENT: - cl_env.qh = mod(cl_env.qh+1); - --cl_env.qc; + env->qh = mod(env->qh+1); + --env->qc; ecl_write_char('\n', stream); - for (i = cl_env.indent_stack[cl_env.isp]; i > 0; --i) + for (i = env->indent_stack[env->isp]; i > 0; --i) ecl_write_char(' ', stream); - cl_env.iisp = cl_env.isp; + env->iisp = env->isp; goto BEGIN; FLUSH: for (j = 0; j < i; j++) { - c = cl_env.queue[cl_env.qh]; + c = env->queue[env->qh]; if (c == INDENT || c == INDENT1 || c == INDENT2) ecl_write_char(' ', stream); else if (c < 0400) ecl_write_char(c, stream); - cl_env.qh = mod(cl_env.qh+1); - --cl_env.qc; + env->qh = mod(env->qh+1); + --env->qc; } goto BEGIN; } @@ -211,7 +212,8 @@ FLUSH: static void write_ch(int c, cl_object stream) { - if (cl_env.print_pretty) + const cl_env_ptr env = ecl_process_env(); + if (env->print_pretty) writec_queue(c, stream); else if (c == INDENT || c == INDENT1) ecl_write_char(' ', stream); @@ -226,33 +228,34 @@ call_print_object(cl_object x, cl_object stream) call_structure_print_function(cl_object f, cl_object x, cl_object stream) #endif { + const cl_env_ptr env = ecl_process_env(); short ois[ECL_PPRINT_INDENTATION_STACK_SIZE]; - volatile bool p = cl_env.print_pretty; + volatile bool p = env->print_pretty; volatile int oqh, oqt, oqc, oisp, oiisp; - if ((p = cl_env.print_pretty)) { + if ((p = env->print_pretty)) { flush_queue(TRUE, stream); - oqh = cl_env.qh; - oqt = cl_env.qt; - oqc = cl_env.qc; - oisp = cl_env.isp; - oiisp = cl_env.iisp; - memcpy(ois, cl_env.indent_stack, cl_env.isp * sizeof(*ois)); + oqh = env->qh; + oqt = env->qt; + oqc = env->qc; + oisp = env->isp; + oiisp = env->iisp; + memcpy(ois, env->indent_stack, env->isp * sizeof(*ois)); } - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(env) { #ifdef CLOS funcall(3, @'print-object', x, stream); #else funcall(4, f, x, stream, MAKE_FIXNUM(0)); #endif } CL_UNWIND_PROTECT_EXIT { - if ((cl_env.print_pretty = p)) { - memcpy(cl_env.indent_stack, ois, oisp * sizeof(*ois)); - cl_env.iisp = oiisp; - cl_env.isp = oisp; - cl_env.qc = oqc; - cl_env.qt = oqt; - cl_env.qh = oqh; + if ((env->print_pretty = p)) { + memcpy(env->indent_stack, ois, oisp * sizeof(*ois)); + env->iisp = oiisp; + env->isp = oisp; + env->qc = oqc; + env->qt = oqt; + env->qh = oqh; } } CL_UNWIND_PROTECT_END; } @@ -281,9 +284,9 @@ static cl_object stream_or_default_output(cl_object stream) { if (Null(stream)) - return SYM_VAL(@'*standard-output*'); + return ECL_SYM_VAL(ecl_process_env(),@'*standard-output*'); else if (stream == Ct) - return SYM_VAL(@'*terminal-io*'); + return ECL_SYM_VAL(ecl_process_env(),@'*terminal-io*'); return stream; } @@ -293,7 +296,7 @@ ecl_print_base(void) cl_object object = ecl_symbol_value(@'*print-base*'); cl_fixnum base; if (!FIXNUMP(object) || (base = fix(object)) < 2 || base > 36) { - ECL_SETQ(@'*print-base*', MAKE_FIXNUM(10)); + ECL_SETQ(ecl_process_env(), @'*print-base*', MAKE_FIXNUM(10)); FEerror("~S is an illegal PRINT-BASE.", 1, object); } return base; @@ -309,7 +312,7 @@ ecl_print_level(void) } else if (FIXNUMP(object)) { level = fix(object); if (level < 0) { - ERROR: ECL_SETQ(@'*print-level*', Cnil); + ERROR: ECL_SETQ(ecl_process_env(), @'*print-level*', Cnil); FEerror("~S is an illegal PRINT-LEVEL.", 1, object); } } else if (type_of(object) != t_bignum) { @@ -330,7 +333,7 @@ ecl_print_length(void) } else if (FIXNUMP(object)) { length = fix(object); if (length < 0) { - ERROR: ECL_SETQ(@'*print-length*', Cnil); + ERROR: ECL_SETQ(ecl_process_env(), @'*print-length*', Cnil); FEerror("~S is an illegal PRINT-LENGTH.", 1, object); } } else if (type_of(object) != t_bignum) { @@ -353,7 +356,7 @@ ecl_print_case(void) cl_object output = ecl_symbol_value(@'*print-case*'); if (output != @':upcase' && output != @':downcase' && output != @':capitalize') { - ECL_SETQ(@'*print-case*', @':downcase'); + ECL_SETQ(ecl_process_env(), @'*print-case*', @':downcase'); FEerror("~S is an illegal PRINT-CASE.", 1, output); } return output; @@ -682,7 +685,7 @@ write_bignum(cl_object x, cl_object stream) struct powers powers[num_powers]; #else struct powers *powers = (struct powers*)malloc(sizeof(struct powers)*num_powers); - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { #endif cl_object p; cl_index i, n_digits; @@ -734,7 +737,7 @@ all_dots(cl_object s) { cl_index i; for (i = 0; i < s->base_string.fillp; i++) - if (s->base_string.self[i] != '.') + if (ecl_char(s, i) != '.') return 0; return 1; } @@ -754,8 +757,8 @@ needs_to_be_escaped(cl_object s, cl_object readtable, cl_object print_case) * string has to be escaped according to readtable case and the rules * of 22.1.3.3.2. */ for (i = 0; i < s->base_string.fillp; i++) { - int c = s->base_string.self[i] & 0377; - int syntax = readtable->readtable.table[c].syntax_type; + int c = ecl_char(s, i); + int syntax = ecl_readtable_get(readtable, c, 0); if (syntax != cat_constituent || ecl_invalid_character_p(c) || (c) == ':') return 1; if ((action == ecl_case_downcase) && isupper(c)) @@ -782,7 +785,7 @@ write_symbol_string(cl_object s, int action, cl_object print_case, write_ch('|', stream); capitalize = 1; for (i = 0; i < s->base_string.fillp; i++) { - int c = s->base_string.self[i]; + int c = ecl_char(s, i); if (escape) { if (c == '|' || c == '\\') { write_ch('\\', stream); @@ -882,7 +885,7 @@ write_character(int i, cl_object stream) write_str("#\\", stream); if (i < 32 || i == 127) { cl_object name = cl_char_name(CODE_CHAR(i)); - write_str(name->base_string.self, stream); + write_str((char*)name->base_string.self, stream); } else if (i >= 128) { int index = 0; char name[20]; @@ -898,6 +901,7 @@ write_character(int i, cl_object stream) static void write_array(bool vector, cl_object x, cl_object stream) { + cl_env_ptr env = ecl_process_env(); const cl_index *adims; cl_index subscripts[ARANKLIM]; cl_fixnum n, j, m, k, i; @@ -952,7 +956,7 @@ write_array(bool vector, cl_object x, cl_object stream) if (print_level >= n) { /* We can write the elements of the array */ print_level -= n; - bds_bind(@'*print-level*', MAKE_FIXNUM(print_level)); + ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level)); } else { /* The elements of the array are not printed */ n = print_level; @@ -1009,7 +1013,7 @@ write_array(bool vector, cl_object x, cl_object stream) m += k; } if (print_level >= 0) { - bds_unwind1(); + ecl_bds_unwind1(env); } if (readably) { write_ch(')', stream); @@ -1076,16 +1080,18 @@ si_write_ugly_object(cl_object x, cl_object stream) write_ch('.', stream); break; } - case t_ratio: + case t_ratio: { + const cl_env_ptr env = ecl_process_env(); if (ecl_print_radix()) { write_base(ecl_print_base(), stream); } - bds_bind(@'*print-radix*', Cnil); + ecl_bds_bind(env, @'*print-radix*', Cnil); si_write_ugly_object(x->ratio.num, stream); write_ch('/', stream); si_write_ugly_object(x->ratio.den, stream); - bds_unwind1(); + ecl_bds_unwind1(env); break; + } #ifdef ECL_SHORT_FLOAT case t_shortfloat: r = ecl_symbol_value(@'*read-default-float-format*'); @@ -1190,6 +1196,7 @@ si_write_ugly_object(cl_object x, cl_object stream) break; case t_list: { + const cl_env_ptr env = ecl_process_env(); bool circle; cl_fixnum print_level, print_length; if (Null(x)) { @@ -1246,12 +1253,12 @@ si_write_ugly_object(cl_object x, cl_object stream) write_ch('#', stream); break; } - bds_bind(@'*print-level*', MAKE_FIXNUM(print_level-1)); + ecl_bds_bind(env, @'*print-level*', MAKE_FIXNUM(print_level-1)); WRITE_MARK(stream); write_ch('(', stream); WRITE_SET_INDENT(stream); #if !defined(ECL_CMU_FORMAT) - if (cl_env.print_pretty && CAR(x) != OBJNULL && + if (ecl_process_env()->print_pretty && CAR(x) != OBJNULL && type_of(CAR(x)) == t_symbol && (r = si_get_sysprop(CAR(x), @'si::pretty-print-format')) != Cnil) goto PRETTY_PRINT_FORMAT; @@ -1283,7 +1290,7 @@ si_write_ugly_object(cl_object x, cl_object stream) RIGHT_PAREN: write_ch(')', stream); WRITE_UNMARK(stream); - bds_unwind1(); + ecl_bds_unwind1(env); break; #if !defined(ECL_CMU_FORMAT) PRETTY_PRINT_FORMAT: @@ -1337,46 +1344,46 @@ si_write_ugly_object(cl_object x, cl_object stream) if (ecl_print_readably()) FEprint_not_readable(x); write_str(x->stream.closed? "#stream.mode) { + case smm_input_file: case smm_input: write_str("input stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; - + case smm_output_file: case smm_output: write_str("output stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; - #ifdef _MSC_VER case smm_input_wsock: write_str("input win32 socket stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; case smm_output_wsock: write_str("output win32 socket stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; case smm_io_wsock: write_str("i/o win32 socket stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; #endif - + case smm_io_file: case smm_io: write_str("io stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; case smm_probe: write_str("probe stream ", stream); - si_write_ugly_object(x->stream.object1, stream); + si_write_ugly_object(IO_STREAM_FILENAME(x), stream); break; case smm_synonym: write_str("synonym stream to ", stream); - si_write_ugly_object(x->stream.object0, stream); + si_write_ugly_object(SYNONYM_STREAM_SYMBOL(x), stream); break; case smm_broadcast: @@ -1566,7 +1573,7 @@ si_write_ugly_object(cl_object x, cl_object stream) write_str("#frame.top - x->frame.bottom, stream); write_ch(' ', stream); - write_decimal(x->frame.bottom, stream); + write_addr((void*)x->frame.bottom, stream); write_ch('>', stream); break; #ifdef ECL_THREADS @@ -1633,18 +1640,19 @@ si_write_object_recursive(cl_object x, cl_object stream) bool print; circle_counter = ecl_symbol_value(@'si::*circle-counter*'); if (circle_counter == Cnil) { + cl_env_ptr env = ecl_process_env(); cl_object hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), ecl_make_singlefloat(1.5f), ecl_make_singlefloat(0.75f), Cnil); - bds_bind(@'si::*circle-counter*', Ct); - bds_bind(@'si::*circle-stack*', hash); + ecl_bds_bind(env, @'si::*circle-counter*', Ct); + ecl_bds_bind(env, @'si::*circle-stack*', hash); si_write_object(x, cl_core.null_stream); - ECL_SETQ(@'si::*circle-counter*', MAKE_FIXNUM(0)); + ECL_SETQ(env, @'si::*circle-counter*', MAKE_FIXNUM(0)); si_write_object(x, stream); cl_clrhash(hash); - bds_unwind_n(2); + ecl_bds_unwind_n(env, 2); return x; } code = search_print_circle(x); @@ -1673,16 +1681,17 @@ si_write_object_recursive(cl_object x, cl_object stream) #if !defined(ECL_CMU_FORMAT) cl_object si_write_object(cl_object x, cl_object stream) { + const cl_env_ptr env = ecl_process_env(); if (ecl_symbol_value(@'*print-pretty*') == Cnil) { - cl_env.print_pretty = 0; + env->print_pretty = 0; } else { - cl_env.print_pretty = 1; - cl_env.qh = cl_env.qt = cl_env.qc = 0; - cl_env.isp = cl_env.iisp = 0; - cl_env.indent_stack[0] = 0; + env->print_pretty = 1; + env->qh = env->qt = env->qc = 0; + env->isp = env->iisp = 0; + env->indent_stack[0] = 0; } si_write_object_recursive(x, stream); - if (cl_env.print_pretty) + if (env->print_pretty) flush_queue(TRUE, stream); } #endif /* !ECL_CMU_FORMAT */ @@ -1743,7 +1752,8 @@ search_print_circle(cl_object x) cl_fixnum new_code = fix(circle_counter) + 1; circle_counter = MAKE_FIXNUM(new_code); ecl_sethash(x, circle_stack, circle_counter); - ECL_SETQ(@'si::*circle-counter*', circle_counter); + ECL_SETQ(ecl_process_env(), @'si::*circle-counter*', + circle_counter); return -new_code; } else { return fix(code); @@ -1767,7 +1777,7 @@ potential_number_p(cl_object strng, int base) l = strng->base_string.fillp; if (l == 0) return FALSE; - s = strng->base_string.self; + s = (char*)strng->base_string.self; c = s[0]; /* A potential number must begin with a digit, sign or extension character (^ _) */ @@ -1813,27 +1823,27 @@ potential_number_p(cl_object strng, int base) (readably ecl_symbol_value(@'*print-readably*')) (right_margin ecl_symbol_value(@'*print-right-margin*'))) @{ - bds_bind(@'*print-array*', array); - bds_bind(@'*print-base*', base); - bds_bind(@'*print-case*', cas); - bds_bind(@'*print-circle*', circle); - bds_bind(@'*print-escape*', escape); - bds_bind(@'*print-gensym*', gensym); - bds_bind(@'*print-level*', level); - bds_bind(@'*print-length*', length); - bds_bind(@'*print-lines*', lines); - bds_bind(@'*print-miser-width*', miser_width); - bds_bind(@'*print-pprint-dispatch*', pprint_dispatch); - bds_bind(@'*print-pretty*', pretty); - bds_bind(@'*print-radix*', radix); - bds_bind(@'*print-readably*', readably); - bds_bind(@'*print-right-margin*', right_margin); + ecl_bds_bind(the_env, @'*print-array*', array); + ecl_bds_bind(the_env, @'*print-base*', base); + ecl_bds_bind(the_env, @'*print-case*', cas); + ecl_bds_bind(the_env, @'*print-circle*', circle); + ecl_bds_bind(the_env, @'*print-escape*', escape); + ecl_bds_bind(the_env, @'*print-gensym*', gensym); + ecl_bds_bind(the_env, @'*print-level*', level); + ecl_bds_bind(the_env, @'*print-length*', length); + ecl_bds_bind(the_env, @'*print-lines*', lines); + ecl_bds_bind(the_env, @'*print-miser-width*', miser_width); + ecl_bds_bind(the_env, @'*print-pprint-dispatch*', pprint_dispatch); + ecl_bds_bind(the_env, @'*print-pretty*', pretty); + ecl_bds_bind(the_env, @'*print-radix*', radix); + ecl_bds_bind(the_env, @'*print-readably*', readably); + ecl_bds_bind(the_env, @'*print-right-margin*', right_margin); strm = stream_or_default_output(strm); si_write_object(x, strm); ecl_force_output(strm); - bds_unwind_n(15); + ecl_bds_unwind_n(the_env, 15); @(return x) @) @@ -1852,12 +1862,12 @@ potential_number_p(cl_object strng, int base) @(defun pprint (obj &optional strm) @ strm = stream_or_default_output(strm); - bds_bind(@'*print-escape*', Ct); - bds_bind(@'*print-pretty*', Ct); + ecl_bds_bind(the_env, @'*print-escape*', Ct); + ecl_bds_bind(the_env, @'*print-pretty*', Ct); ecl_write_char('\n', strm); si_write_object(obj, strm); ecl_force_output(strm); - bds_unwind_n(2); + ecl_bds_unwind_n(the_env, 2); @(return) @) @@ -1970,22 +1980,24 @@ cl_write_byte(cl_object integer, cl_object binary_output_stream) cl_object ecl_princ(cl_object obj, cl_object strm) { + const cl_env_ptr the_env = ecl_process_env(); strm = stream_or_default_output(strm); - bds_bind(@'*print-escape*', Cnil); - bds_bind(@'*print-readably*', Cnil); + ecl_bds_bind(the_env, @'*print-escape*', Cnil); + ecl_bds_bind(the_env, @'*print-readably*', Cnil); si_write_object(obj, strm); - bds_unwind_n(2); + ecl_bds_unwind_n(the_env, 2); return obj; } cl_object ecl_prin1(cl_object obj, cl_object strm) { + const cl_env_ptr the_env = ecl_process_env(); strm = stream_or_default_output(strm); - bds_bind(@'*print-escape*', Ct); + ecl_bds_bind(the_env, @'*print-escape*', Ct); si_write_object(obj, strm); ecl_force_output(strm); - bds_unwind1(); + ecl_bds_unwind1(the_env); return obj; } diff --git a/src/c/read.d b/src/c/read.d index a8b4ac259..a54266205 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -32,26 +32,41 @@ #undef _complex -#define cat(rtbl,c) ((rtbl)->readtable.table[c].syntax_type) -#define read_suppress (SYM_VAL(@'*read-suppress*') != Cnil) +static cl_object dispatch_macro_character(cl_object table, cl_object strm, int c); -static struct ecl_readtable_entry* -read_table_entry(cl_object rdtbl, cl_object c); +#define read_suppress (ecl_symbol_value(@'*read-suppress*') != Cnil) -/* FIXME! *READ-EVAL* is not taken into account */ +#ifdef ECL_UNICODE +# define TOKEN_STRING_DIM(s) ((s)->string.dim) +# define TOKEN_STRING_FILLP(s) ((s)->string.fillp) +# define TOKEN_STRING_CHAR(s,n) CHAR_CODE((s)->string.self[n]) +# define TOKEN_STRING_CHAR_SET(s,n,c) (s)->string.self[n]=CODE_CHAR(c) +# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->string.self[n]==CODE_CHAR(c)) +#else +# define TOKEN_STRING_DIM(s) ((s)->base_string.dim) +# define TOKEN_STRING_FILLP(s) ((s)->base_string.fillp) +# define TOKEN_STRING_CHAR(s,n) ((s)->base_string.self[n]) +# define TOKEN_STRING_CHAR_SET(s,n,c) ((s)->base_string.self[n]=(c)) +# define TOKEN_STRING_CHAR_CMP(s,n,c) ((s)->base_string.self[n]==(c)) +#endif cl_object si_get_buffer_string() { - cl_object pool = cl_env.string_pool; + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; cl_object output; if (pool == Cnil) { +#ifdef ECL_UNICODE + output = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); +#else output = cl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); +#endif } else { output = CAR(pool); - cl_env.string_pool = CDR(pool); + env->string_pool = CDR(pool); } - output->base_string.fillp = 0; + TOKEN_STRING_FILLP(output) = 0; @(return output) } @@ -59,19 +74,24 @@ cl_object si_put_buffer_string(cl_object string) { if (string != Cnil) { - cl_object pool = cl_env.string_pool; + const cl_env_ptr env = ecl_process_env(); + cl_object pool = env->string_pool; cl_index l = 0; if (pool != Cnil) { /* We store the size of the pool in the string index */ - l = CAR(pool)->base_string.fillp; + l = TOKEN_STRING_FILLP(ECL_CONS_CAR(pool)); } if (l < ECL_MAX_STRING_POOL_SIZE) { - if (string->base_string.dim > ECL_BUFFER_STRING_SIZE) { + if (TOKEN_STRING_DIM(string) > ECL_BUFFER_STRING_SIZE) { /* String has been enlarged. Cut it. */ +#ifdef ECL_UNICODE + string = ecl_alloc_adjustable_extended_string(ECL_BUFFER_STRING_SIZE); +#else string = cl_alloc_adjustable_base_string(ECL_BUFFER_STRING_SIZE); +#endif } - string->base_string.fillp = l+1; - cl_env.string_pool = CONS(string, pool); + TOKEN_STRING_FILLP(string) = l+1; + env->string_pool = CONS(string, pool); } } @(return) @@ -85,14 +105,14 @@ cl_object ecl_read_object_non_recursive(cl_object in) { cl_object x; + const cl_env_ptr env = ecl_process_env(); - bds_bind(@'si::*sharp-eq-context*', Cnil); - bds_bind(@'si::*backq-level*', MAKE_FIXNUM(0)); + ecl_bds_bind(env, @'si::*sharp-eq-context*', Cnil); + ecl_bds_bind(env, @'si::*backq-level*', MAKE_FIXNUM(0)); x = ecl_read_object(in); - if (!Null(SYM_VAL(@'si::*sharp-eq-context*'))) + if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) x = patch_sharp(x); - bds_unwind1(); - bds_unwind1(); + ecl_bds_unwind_n(env, 2); return(x); } @@ -108,7 +128,7 @@ invert_buffer_case(cl_object x, cl_object escape_list, int sign) { cl_fixnum high_limit, low_limit; cl_object escape_interval; - cl_fixnum i = x->base_string.fillp; + cl_fixnum i = TOKEN_STRING_FILLP(x); do { if (escape_list != Cnil) { cl_object escape_interval = CAR(escape_list); @@ -120,13 +140,13 @@ invert_buffer_case(cl_object x, cl_object escape_list, int sign) } for (; i > high_limit; i--) { /* The character is not escaped */ - char c = x->base_string.self[i]; + int c = TOKEN_STRING_CHAR(x,i); if (isupper(c) && (sign < 0)) { c = tolower(c); } else if (islower(c) && (sign > 0)) { c = toupper(c); } - x->base_string.self[i] = c; + TOKEN_STRING_CHAR_SET(x,i,c); } for (; i > low_limit; i--) { /* The character is within an escaped interval */ @@ -161,11 +181,15 @@ BEGIN: return OBJNULL; if (c == EOF) FEend_of_file(in); - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, &x); } while (a == cat_whitespace); if ((a == cat_terminating || a == cat_non_terminating) && !only_token) { - cl_object x = rtbl->readtable.table[c].macro; - cl_object o = funcall(3, x, in, CODE_CHAR(c)); + cl_object o; + if (type_of(x) == t_hashtable) { + o = dispatch_macro_character(x, in, c); + } else { + o = funcall(3, x, in, CODE_CHAR(c)); + } if (NVALUES == 0) goto BEGIN; if (NVALUES > 1) FEerror("The readmacro ~S returned ~D values.", 2, x, MAKE_FIXNUM(i)); @@ -188,7 +212,7 @@ LOOP: } } else if (colon) { external_symbol = (colon == 1); - token->base_string.self[length] = '\0'; + TOKEN_STRING_CHAR_SET(token,length,'\0'); /* If the readtable case was :INVERT and all non-escaped characters * had the same case, we revert their case. */ if (read_case == ecl_case_invert) { @@ -210,7 +234,7 @@ LOOP: allow it, but later on in read_VV we make sure that all referenced packages have been properly built. */ - cl_object name = si_copy_to_simple_base_string(token); + cl_object name = cl_copy_seq(token); if (cl_core.packages_to_be_created == OBJNULL) { FEerror("There is no package with the name ~A.", 1, name); @@ -223,7 +247,7 @@ LOOP: cl_acons(name, p, cl_core.packages_to_be_created); } } - token->base_string.fillp = length = 0; + TOKEN_STRING_FILLP(token) = length = 0; upcase = count = colon = 0; escape_list = Cnil; } @@ -245,7 +269,7 @@ LOOP: cl_index begin = length; for (;;) { c = ecl_read_char_noeof(in); - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, NULL); if (a == cat_single_escape) { c = ecl_read_char_noeof(in); a = cat_constituent; @@ -289,7 +313,7 @@ LOOP: c = ecl_read_char(in); if (c == EOF) break; - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, NULL); } if (suppress) { @@ -302,12 +326,12 @@ LOOP: goto SYMBOL; /* The case in which the buffer is full of dots has to be especial cased */ - if (length == 1 && token->base_string.self[0] == '.') { + if (length == 1 && TOKEN_STRING_CHAR_CMP(token,0,'.')) { x = @'si::.'; goto OUTPUT; } else { for (i = 0; i < length; i++) - if (token->base_string.self[i] != '.') + if (!TOKEN_STRING_CHAR_CMP(token,i,'.')) goto MAYBE_NUMBER; FEreader_error("Dots appeared illegally.", in, 0); } @@ -315,16 +339,16 @@ LOOP: MAYBE_NUMBER: /* Here we try to parse a number from the content of the buffer */ base = ecl_current_read_base(); - if ((base <= 10) && isalpha(token->base_string.self[0])) + if ((base <= 10) && isalpha(TOKEN_STRING_CHAR(token,0))) goto SYMBOL; - x = ecl_parse_number(token, 0, token->base_string.fillp, &i, base); + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, base); if (x == Cnil) FEreader_error("Syntax error when reading number.~%Offending string: ~S.", in, 1, token); if (x != OBJNULL && length == i) goto OUTPUT; SYMBOL: - token->base_string.self[length] = '\0'; + /*TOKEN_STRING_CHAR_SET(token,length,'\0');*/ /* If the readtable case was :INVERT and all non-escaped characters * had the same case, we revert their case. */ if (read_case == ecl_case_invert) { @@ -340,7 +364,7 @@ LOOP: x = ecl_find_symbol(token, p, &intern_flag); if (intern_flag != EXTERNAL) { FEerror("Cannot find the external symbol ~A in ~S.", - 2, si_copy_to_simple_base_string(token), p); + 2, cl_copy_seq(token), p); } } else { if (p == Cnil) { @@ -445,7 +469,7 @@ ecl_parse_number(cl_object str, cl_index start, cl_index end, * 'e' or 'E' as exponent markers and we have to make a copy * of the number with this exponent marker. */ cl_index length = end - start; - char *buffer = (char*)cl_alloc_atomic(length+1); + char *buffer = (char*)ecl_alloc_atomic(length+1); char *parse_end; char exp_marker; cl_object output; @@ -514,7 +538,7 @@ ecl_parse_number(cl_object str, cl_index start, cl_index end, output = OBJNULL; } OUTPUT: - cl_dealloc(buffer); + ecl_dealloc(buffer); return output; } } @@ -578,7 +602,8 @@ static cl_object comma_reader(cl_object in, cl_object c) { cl_object x, y; - cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); + const cl_env_ptr env = ecl_process_env(); + cl_fixnum backq_level = fix(ECL_SYM_VAL(env, @'si::*backq-level*')); if (backq_level <= 0) FEreader_error("A comma has appeared out of a backquote.", in, 0); @@ -593,19 +618,20 @@ cl_object comma_reader(cl_object in, cl_object c) } else { x = @'si::unquote'; } - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level-1)); + ECL_SETQ(env, @'si::*backq-level*', MAKE_FIXNUM(backq_level-1)); y = ecl_read_object(in); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); + ECL_SETQ(env, @'si::*backq-level*', MAKE_FIXNUM(backq_level)); return cl_list(2, x, y); } static cl_object backquote_reader(cl_object in, cl_object c) { - cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*')); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level+1)); + const cl_env_ptr the_env = ecl_process_env(); + cl_fixnum backq_level = fix(ECL_SYM_VAL(the_env, @'si::*backq-level*')); + ECL_SETQ(the_env, @'si::*backq-level*', MAKE_FIXNUM(backq_level+1)); in = ecl_read_object(in); - ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level)); + ECL_SETQ(the_env, @'si::*backq-level*', MAKE_FIXNUM(backq_level)); #if 0 @(return cl_macroexpand_1(2, cl_list(2, @'si::quasiquote', in), Cnil)); #else @@ -631,7 +657,7 @@ read_constituent(cl_object in) if (c == EOF) { break; } - c_cat = cat(rtbl, c); + c_cat = ecl_readtable_get(rtbl, c, NULL); if (c_cat == cat_constituent || ((c_cat == cat_non_terminating) && not_first)) { @@ -658,11 +684,16 @@ double_quote_reader(cl_object in, cl_object c) int c = ecl_read_char_noeof(in); if (c == delim) break; - else if (cat(rtbl, c) == cat_single_escape) + else if (ecl_readtable_get(rtbl, c, NULL) == cat_single_escape) c = ecl_read_char_noeof(in); ecl_string_push_extend(token, c); } - output = si_copy_to_simple_base_string(token); +#ifdef ECL_UNICODE + if (ecl_fits_in_base_string(token)) + output = si_coerce_to_base_string(token); + else +#endif + output = cl_copy_seq(token); si_put_buffer_string(token); @(return output) } @@ -670,29 +701,44 @@ double_quote_reader(cl_object in, cl_object c) static cl_object dispatch_reader_fun(cl_object in, cl_object dc) { - cl_object x, y; - cl_fixnum i; - int d, c; - cl_object rtbl = ecl_current_readtable(); - - if (rtbl->readtable.table[ecl_char_code(dc)].dispatch_table == NULL) - FEreader_error("~C is not a dispatching macro character", in, 1, dc); + cl_object readtable = ecl_current_readtable(); + cl_object dispatch_table; + int c = ecl_char_code(dc); + ecl_readtable_get(readtable, c, &dispatch_table); + if (type_of(dispatch_table) != t_hashtable) + FEreader_error("~C is not a dispatching macro character", + in, 1, dc); + return dispatch_macro_character(dispatch_table, in, c); +} +static cl_object +dispatch_macro_character(cl_object table, cl_object in, int c) +{ + cl_object arg; + int d; c = ecl_read_char_noeof(in); d = ecl_digitp(c, 10); if (d >= 0) { - i = 0; + cl_fixnum i = 0; do { i = 10*i + d; c = ecl_read_char_noeof(in); d = ecl_digitp(c, 10); } while (d >= 0); - y = MAKE_FIXNUM(i); - } else - y = Cnil; - - x = rtbl->readtable.table[ecl_char_code(dc)].dispatch_table[c]; - return funcall(4, x, in, CODE_CHAR(c), y); + arg = MAKE_FIXNUM(i); + } else { + arg = Cnil; + } + { + cl_object dc = CODE_CHAR(c); + cl_object fun = ecl_gethash_safe(dc, table, Cnil); + if (Null(fun)) { + FEreader_error("No dispatch function defined " + "for character ~S", + in, 1, dc); + } + return funcall(4, fun, in, dc, arg); + } } static cl_object @@ -730,6 +776,7 @@ semicolon_reader(cl_object in, cl_object c) static cl_object sharp_C_reader(cl_object in, cl_object c, cl_object d) { + const cl_env_ptr the_env = ecl_process_env(); cl_object x, real, imag; if (d != Cnil && !read_suppress) @@ -748,9 +795,9 @@ sharp_C_reader(cl_object in, cl_object c, cl_object d) structures, we cannot check the types of the elements, and we must build the complex number by hand. */ if ((CONSP(real) || CONSP(imag)) && - !Null(SYM_VAL(@'si::*sharp-eq-context*'))) + !Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) { - x = cl_alloc_object(t_complex); + x = ecl_alloc_object(t_complex); x->complex.real = real; x->complex.imag = imag; } else { @@ -762,22 +809,23 @@ sharp_C_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_backslash_reader(cl_object in, cl_object c, cl_object d) { + const cl_env_ptr env = ecl_process_env(); cl_object nc, token; if (d != Cnil && !read_suppress) if (!FIXNUMP(d) || fix(d) != 0) FEreader_error("~S is an illegal CHAR-FONT.", in, 1, d); /* assuming that CHAR-FONT-LIMIT is 1 */ - bds_bind(@'*readtable*', cl_core.standard_readtable); + ecl_bds_bind(env, @'*readtable*', cl_core.standard_readtable); token = ecl_read_object_with_delimiter(in, EOF, 1, cat_single_escape); - bds_unwind_n(1); + ecl_bds_unwind1(env); if (token == Cnil) { c = Cnil; - } else if (token->base_string.fillp == 1) { - c = CODE_CHAR(token->base_string.self[0]); - } else if (token->base_string.fillp == 2 && token->base_string.self[0] == '^') { + } else if (TOKEN_STRING_FILLP(token) == 1) { + c = CODE_CHAR(TOKEN_STRING_CHAR(token,0)); + } else if (TOKEN_STRING_FILLP(token) == 2 && TOKEN_STRING_CHAR_CMP(token,0,'^')) { /* #\^x */ - c = CODE_CHAR(token->base_string.self[1] & 037); + c = CODE_CHAR(TOKEN_STRING_CHAR(token,1) & 037); } else { cl_object nc = cl_name_char(token); if (Null(nc)) { @@ -824,7 +872,7 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Reader macro #Y should be followed by a list", in, 0); - rv = cl_alloc_object(t_bytecodes); + rv = ecl_alloc_object(t_bytecodes); rv->bytecodes.name = CAR(x); x = CDR(x); lex = CAR(x); x = CDR(x); @@ -832,18 +880,18 @@ sharp_Y_reader(cl_object in, cl_object c, cl_object d) rv->bytecodes.definition = CAR(x); x = CDR(x); rv->bytecodes.code_size = fixint(cl_list_length(CAR(x))); - rv->bytecodes.code = cl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); + rv->bytecodes.code = ecl_alloc_atomic(rv->bytecodes.code_size * sizeof(uint16_t)); for ( i=0, nth=CAR(x) ; !ecl_endp(nth) ; i++, nth=CDR(nth) ) ((cl_opcode*)(rv->bytecodes.code))[i] = fixint(CAR(nth)); x = CDR(x); rv->bytecodes.data_size = fixint(cl_list_length(CAR(x))); - rv->bytecodes.data = cl_alloc(rv->bytecodes.data_size * sizeof(cl_object)); + rv->bytecodes.data = ecl_alloc(rv->bytecodes.data_size * sizeof(cl_object)); for ( i=0, nth=CAR(x) ; !ecl_endp(nth) ; i++, nth=CDR(nth) ) ((cl_object*)(rv->bytecodes.data))[i] = CAR(nth); if (lex != Cnil) { - cl_object x = cl_alloc_object(t_bclosure); + cl_object x = ecl_alloc_object(t_bclosure); x->bclosure.code = rv; x->bclosure.lex = lex; rv = x; @@ -869,8 +917,9 @@ static cl_object sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) { extern int _cl_backq_car(cl_object *); + const cl_env_ptr the_env = ecl_process_env(); cl_object v; - if (fix(SYM_VAL(@'si::*backq-level*')) > 0) { + if (fix(ECL_SYM_VAL(the_env, @'si::*backq-level*')) > 0) { /* First case: ther might be unquoted elements in the vector. * Then we just create a form that generates the vector. */ @@ -925,9 +974,10 @@ sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { + cl_env_ptr env = ecl_process_env(); + cl_index sp = ecl_stack_index(env); cl_object last, elt, x; cl_index dim, dimcount, i; - cl_index sp = cl_stack_index(); cl_object rtbl = ecl_current_readtable(); enum ecl_chattrib a; @@ -939,7 +989,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) int x = ecl_read_char(in); if (x == EOF) break; - a = cat(rtbl, x); + a = ecl_readtable_get(rtbl, x, NULL); if (a == cat_terminating || a == cat_whitespace) { ecl_unread_char(x, in); break; @@ -950,7 +1000,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Character ~:C is not allowed after #*", in, 1, CODE_CHAR(x)); } - cl_stack_push(MAKE_FIXNUM(x == '1')); + ecl_stack_push(env, MAKE_FIXNUM(x == '1')); } if (Null(d)) { dim = dimcount; @@ -960,17 +1010,17 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Too many elements in #*....", in, 0); if (dim && (dimcount == 0)) FEreader_error("Cannot fill the bit-vector #*.", in, 0); - else last = cl_env.stack_top[-1]; + else last = env->stack_top[-1]; } x = ecl_alloc_simple_vector(dim, aet_bit); for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? cl_env.stack[sp+i] : last; + elt = (i < dimcount) ? env->stack[sp+i] : last; if (elt == MAKE_FIXNUM(0)) x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; } - cl_stack_pop_n(dimcount); + ecl_stack_pop_n(env, dimcount); @(return x) } @@ -986,7 +1036,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d) if (d != Cnil && !read_suppress) extra_argument(':', in, d); c = ecl_read_char_noeof(in); - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, NULL); escape_flag = FALSE; token = si_get_buffer_string(); goto L; @@ -996,7 +1046,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d) c = ecl_read_char(in); if (c == EOF) goto M; - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, NULL); L: if (a == cat_single_escape) { c = ecl_read_char_noeof(in); @@ -1006,7 +1056,7 @@ sharp_colon_reader(cl_object in, cl_object ch, cl_object d) escape_flag = TRUE; for (;;) { c = ecl_read_char_noeof(in); - a = cat(rtbl, c); + a = ecl_readtable_get(rtbl, c, NULL); if (a == cat_single_escape) { c = ecl_read_char_noeof(in); a = cat_constituent; @@ -1057,8 +1107,8 @@ read_number(cl_object in, int radix, cl_object macro_char) if (token == Cnil) { x = Cnil; } else { - x = ecl_parse_number(token, 0, token->base_string.fillp, &i, radix); - if (x == OBJNULL || x == Cnil || i != token->base_string.fillp) { + x = ecl_parse_number(token, 0, TOKEN_STRING_FILLP(token), &i, radix); + if (x == OBJNULL || x == Cnil || i != TOKEN_STRING_FILLP(token)) { FEreader_error("Cannot parse the #~A readmacro.", in, 1, macro_char); } @@ -1120,8 +1170,9 @@ sharp_R_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_eq_reader(cl_object in, cl_object c, cl_object d) { + const cl_env_ptr the_env = ecl_process_env(); cl_object pair, value; - cl_object sharp_eq_context = SYM_VAL(@'si::*sharp-eq-context*'); + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); if (read_suppress) @(return) if (Null(d)) @@ -1129,7 +1180,7 @@ sharp_eq_reader(cl_object in, cl_object c, cl_object d) if (ecl_assql(d, sharp_eq_context) != Cnil) FEreader_error("Duplicate definitions for #~D=.", in, 1, d); pair = ecl_list1(d); - ECL_SETQ(@'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); + ECL_SETQ(the_env, @'si::*sharp-eq-context*', CONS(pair, sharp_eq_context)); value = ecl_read_object(in); if (value == pair) FEreader_error("#~D# is defined by itself.", in, 1, d); @@ -1140,12 +1191,13 @@ sharp_eq_reader(cl_object in, cl_object c, cl_object d) static cl_object sharp_sharp_reader(cl_object in, cl_object c, cl_object d) { + const cl_env_ptr the_env = ecl_process_env(); cl_object pair; if (read_suppress) @(return Cnil) if (Null(d)) FEreader_error("The ## readmacro requires an argument.", in, 0); - pair = ecl_assq(d, SYM_VAL(@'si::*sharp-eq-context*')); + pair = ecl_assq(d, ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*')); if (pair != Cnil) @(return pair) FEreader_error("#~D# is undefined.", in, 1, d); @@ -1205,7 +1257,9 @@ do_patch_sharp(cl_object x) static cl_object patch_sharp(cl_object x) { - cl_object pairs, sharp_eq_context = SYM_VAL(@'si::*sharp-eq-context*'); + const cl_env_ptr the_env = ecl_process_env(); + cl_object sharp_eq_context = ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'); + cl_object pairs; pairs = sharp_eq_context; loop_for_in(pairs) { @@ -1294,7 +1348,7 @@ sharp_dollar_reader(cl_object in, cl_object c, cl_object d) if (d != Cnil && !read_suppress) extra_argument('$', in, d); c = ecl_read_object(in); - rs = cl_alloc_object(t_random); + rs = ecl_alloc_object(t_random); rs->random.value = c; @(return rs) } @@ -1306,81 +1360,87 @@ sharp_dollar_reader(cl_object in, cl_object c, cl_object d) cl_object ecl_copy_readtable(cl_object from, cl_object to) { - struct ecl_readtable_entry *rtab; + struct ecl_readtable_entry *from_rtab, *to_rtab; cl_index i; size_t entry_bytes = sizeof(struct ecl_readtable_entry); size_t total_bytes = entry_bytes * RTABSIZE; + cl_object output; - /* Copy also the case for reading */ - if (Null(to)) { - to = cl_alloc_object(t_readtable); - to->readtable.table = NULL; - /* Saving for GC. */ - to->readtable.table = (struct ecl_readtable_entry *)cl_alloc_align(total_bytes, entry_bytes); -/* - for (i = 0; i < RTABSIZE; i++) - rtab[i] = from->readtable.table[i]; -*/ - /* structure assignment */ - } - rtab=to->readtable.table; - memcpy(rtab, from->readtable.table, total_bytes); - to->readtable.read_case = from->readtable.read_case; - + assert_type_readtable(from); + /* For the sake of garbage collector and thread safety we + * create an incomplete object and only copy to the destination + * at the end in a more or less "atomic" (meaning "fast") way. + */ + output = ecl_alloc_object(t_readtable); + output->readtable.table = to_rtab = (struct ecl_readtable_entry *) + ecl_alloc_align(total_bytes, entry_bytes); + from_rtab = from->readtable.table; + memcpy(to_rtab, from_rtab, total_bytes); for (i = 0; i < RTABSIZE; i++) { - if (from->readtable.table[i].dispatch_table != NULL) { - rtab[i].dispatch_table - = (cl_object *)cl_alloc_align(RTABSIZE * sizeof(cl_object), sizeof(cl_object)); - memcpy(rtab[i].dispatch_table, from->readtable.table[i].dispatch_table, - RTABSIZE * sizeof(cl_object *)); -/* - for (j = 0; j < RTABSIZE; j++) - rtab[i].dispatch_table[j] - = from->readtable.table[i].dispatch_table[j]; -*/ + cl_object d = from_rtab[i].dispatch; + if (type_of(d) == t_hashtable) { + d = si_copy_hash_table(d); } + to_rtab[i].dispatch = d; } - return(to); + output->readtable.read_case = from->readtable.read_case; +#ifdef ECL_UNICODE + if (!Null(from->readtable.hash)) { + output->readtable.hash = si_copy_hash_table(from->readtable.hash); + } else { + output->readtable.hash = Cnil; + } +#endif + if (!Null(to)) { + assert_type_readtable(to); + to->readtable = output->readtable; + output = to; + } + return output; } cl_object ecl_current_readtable(void) { + const cl_env_ptr the_env = ecl_process_env(); cl_object r; /* INV: *readtable* always has a value */ - r = SYM_VAL(@'*readtable*'); + r = ECL_SYM_VAL(the_env, @'*readtable*'); if (type_of(r) != t_readtable) { - ECL_SETQ(@'*readtable*', ecl_copy_readtable(cl_core.standard_readtable, Cnil)); + ECL_SETQ(the_env, @'*readtable*', + ecl_copy_readtable(cl_core.standard_readtable, Cnil)); FEerror("The value of *READTABLE*, ~S, was not a readtable.", 1, r); } - return(r); + return r; } int ecl_current_read_base(void) { + const cl_env_ptr the_env = ecl_process_env(); cl_object x; /* INV: *READ-BASE* always has a value */ - x = SYM_VAL(@'*read_base*'); + x = ECL_SYM_VAL(the_env, @'*read_base*'); if (FIXNUMP(x)) { cl_fixnum b = fix(x); if (b >= 2 && b <= 36) return b; } - ECL_SETQ(@'*read_base*', MAKE_FIXNUM(10)); + ECL_SETQ(the_env, @'*read_base*', MAKE_FIXNUM(10)); FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); } char ecl_current_read_default_float_format(void) { + const cl_env_ptr the_env = ecl_process_env(); cl_object x; /* INV: *READ-DEFAULT-FLOAT-FORMAT* is always bound to something */ - x = SYM_VAL(@'*read-default-float-format*'); + x = ECL_SYM_VAL(the_env, @'*read-default-float-format*'); if (x == @'single-float' || x == @'short-float') return 'F'; if (x == @'double-float') @@ -1392,7 +1452,7 @@ ecl_current_read_default_float_format(void) return 'D'; #endif } - ECL_SETQ(@'*read-default-float-format*', @'single-float'); + ECL_SETQ(the_env, @'*read-default-float-format*', @'single-float'); FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", 1, x); } @@ -1400,10 +1460,11 @@ ecl_current_read_default_float_format(void) static cl_object stream_or_default_input(cl_object stream) { + const cl_env_ptr the_env = ecl_process_env(); if (Null(stream)) - return SYM_VAL(@'*standard-input*'); + return ECL_SYM_VAL(the_env, @'*standard-input*'); if (stream == Ct) - return SYM_VAL(@'*terminal-io*'); + return ECL_SYM_VAL(the_env, @'*terminal-io*'); return stream; } @@ -1425,7 +1486,7 @@ stream_or_default_input(cl_object stream) if (Null(recursivep)) { cl_object rtbl = ecl_current_readtable(); int c = ecl_read_char(strm); - if (c != EOF && (cat(rtbl, c) != cat_whitespace)) { + if (c != EOF && (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace)) { ecl_unread_char(c, strm); } } @@ -1504,13 +1565,12 @@ do_read_delimited_list(int d, cl_object in, bool proper_list) if (Null(recursivep)) { l = do_read_delimited_list(delimiter, strm, 1); } else { - bds_bind(@'si::*sharp-eq-context*', Cnil); - bds_bind(@'si::*backq-level*', MAKE_FIXNUM(0)); + ecl_bds_bind(the_env, @'si::*sharp-eq-context*', Cnil); + ecl_bds_bind(the_env, @'si::*backq-level*', MAKE_FIXNUM(0)); l = do_read_delimited_list(delimiter, strm, 1); - if (!Null(SYM_VAL(@'si::*sharp-eq-context*'))) + if (!Null(ECL_SYM_VAL(the_env, @'si::*sharp-eq-context*'))) l = patch_sharp(l); - bds_unwind1(); - bds_unwind1(); + ecl_bds_unwind_n(the_env, 2); } @(return l) @) @@ -1537,21 +1597,21 @@ do_read_delimited_list(int d, cl_object in, bool proper_list) break; ecl_string_push_extend(token, c); } while(1); -EOFCHK: if (c == EOF && token->base_string.fillp == 0) { +EOFCHK: if (c == EOF && TOKEN_STRING_FILLP(token) == 0) { if (!Null(eof_errorp)) FEend_of_file(strm); value0 = eof_value; value1 = Ct; } else { #ifdef ECL_NEWLINE_IS_CRLF /* From \r\n, ignore \r */ - if (token->base_string.fillp > 0 && - token->base_string.self[token->base_string.fillp-1] == '\r') - token->base_string.fillp--; + if (TOKEN_STRING_FILLP(token) > 0 && + TOKEN_STRING_CHAR_CMP(token,TOKEN_STRING_FILLP(token)-1,'\r')) + TOKEN_STRING_FILLP(token)--; #endif #ifdef ECL_NEWLINE_IS_LFCR /* From \n\r, ignore \r */ ecl_read_char(strm); #endif - value0 = si_copy_to_simple_base_string(token); + value0 = cl_copy_seq(token); value1 = (c == EOF? Ct : Cnil); } si_put_buffer_string(token); @@ -1591,7 +1651,7 @@ EOFCHK: if (c == EOF && token->base_string.fillp == 0) { if (peek_type == Ct) { do { /* If the character is not a whitespace, output */ - if (cat(rtbl, c) != cat_whitespace) + if (ecl_readtable_get(rtbl, c, NULL) != cat_whitespace) break; /* Otherwise, read the whitespace and peek the * next character */ @@ -1676,8 +1736,7 @@ EOFCHK: if (c == EOF && token->base_string.fillp == 0) { fix(radix) < 2 || fix(radix) > 36) FEerror("~S is an illegal radix.", 1, radix); while (s < e && - read_table_entry(rtbl, cl_char(strng, MAKE_FIXNUM(s)))->syntax_type - == cat_whitespace) { + ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) == cat_whitespace) { s++; } if (s >= e) { @@ -1698,8 +1757,7 @@ EOFCHK: if (c == EOF && token->base_string.fillp == 0) { @(return x MAKE_FIXNUM(ep)); } for (s = ep; s < e; s++) { - if (read_table_entry(rtbl, cl_char(strng, MAKE_FIXNUM(s)))->syntax_type - != cat_whitespace) { + if (ecl_readtable_get(rtbl, ecl_char(strng, s), NULL) != cat_whitespace) { CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", Cnil, 1, strng); } @@ -1734,19 +1792,11 @@ CANNOT_PARSE: FEparse_error("Cannot parse an integer in the string ~S.", @(defun copy_readtable (&o (from ecl_current_readtable()) to) @ if (Null(from)) { - from = cl_core.standard_readtable; - if (to != Cnil) - assert_type_readtable(to); + to = ecl_copy_readtable(cl_core.standard_readtable, to); + } else { to = ecl_copy_readtable(from, to); - to->readtable.table['#'].dispatch_table['!'] - = cl_core.default_dispatch_macro; - /* We must forget #! macro. */ - @(return to) } - assert_type_readtable(from); - if (to != Cnil) - assert_type_readtable(to); - @(return ecl_copy_readtable(from, to)) + @(return to) @) cl_object @@ -1793,21 +1843,55 @@ cl_readtablep(cl_object readtable) static struct ecl_readtable_entry default_readtable_entry; #endif -static struct ecl_readtable_entry* -read_table_entry(cl_object rdtbl, cl_object c) +int +ecl_readtable_get(cl_object readtable, int c, cl_object *macro_or_table) { - /* INV: ecl_char_code() checks the type of `c' */ - cl_index code = ecl_char_code(c); - assert_type_readtable(rdtbl); + cl_object m; + enum ecl_chattrib cat; #ifdef ECL_UNICODE - if (!BASE_CHAR_CODE_P(code)) { - default_readtable_entry.syntax_type = cat_constituent; - default_readtable_entry.macro = Cnil; - default_readtable_entry.dispatch_table = NULL; - return &default_readtable_entry; - } + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + cat = cat_constituent; + m = Cnil; + if (!Null(hash)) { + cl_object pair = ecl_gethash_safe(CODE_CHAR(c), hash, Cnil); + if (!Null(pair)) { + cat = fix(ECL_CONS_CAR(pair)); + m = ECL_CONS_CDR(pair); + } + } + } else #endif - return &(rdtbl->readtable.table[code]); + { + m = readtable->readtable.table[c].dispatch; + cat = readtable->readtable.table[c].syntax_type; + } + if (macro_or_table) *macro_or_table = m; + return cat; +} + +void +ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, + cl_object macro_or_table) +{ +#ifdef ECL_UNICODE + if (c >= RTABSIZE) { + cl_object hash = readtable->readtable.hash; + if (Null(hash)) { + hash = cl__make_hash_table(@'eql', MAKE_FIXNUM(128), + ecl_make_singlefloat(1.5f), + ecl_make_singlefloat(0.5f), + Ct); + readtable->readtable.hash = hash; + } + ecl_sethash(CODE_CHAR(c), hash, + CONS(MAKE_FIXNUM(cat), macro_or_table)); + } else +#endif + { + readtable->readtable.table[c].dispatch = macro_or_table; + readtable->readtable.table[c].syntax_type = cat; + } } bool @@ -1819,111 +1903,115 @@ ecl_invalid_character_p(int c) @(defun set_syntax_from_char (tochr fromchr &o (tordtbl ecl_current_readtable()) fromrdtbl) - struct ecl_readtable_entry*torte, *fromrte; + enum ecl_chattrib cat; + cl_object dispatch; + cl_fixnum fc, tc; @ - /* INV: read_table_entry() checks all values */ if (Null(fromrdtbl)) fromrdtbl = cl_core.standard_readtable; - /* INV: ecl_char_code() checks the types of `tochar',`fromchar' */ - torte = read_table_entry(tordtbl, tochr); - fromrte = read_table_entry(fromrdtbl, fromchr); - torte->syntax_type = fromrte->syntax_type; - torte->macro = fromrte->macro; - if ((torte->dispatch_table = fromrte->dispatch_table) != NULL) { - size_t rtab_size = RTABSIZE * sizeof(cl_object); - torte->dispatch_table = (cl_object *)cl_alloc(rtab_size); - memcpy(torte->dispatch_table, fromrte->dispatch_table, rtab_size); + assert_type_readtable(fromrdtbl); + assert_type_readtable(tordtbl); + fc = ecl_char_code(fromchr); + tc = ecl_char_code(tochr); + + cat = ecl_readtable_get(fromrdtbl, fc, &dispatch); + if (type_of(dispatch) == t_hashtable) { + dispatch = si_copy_hash_table(dispatch); } + ecl_readtable_set(tordtbl, tc, cat, dispatch); @(return Ct) @) -@(defun set_macro_character (chr fnc - &optional ntp - (rdtbl ecl_current_readtable())) - struct ecl_readtable_entry*entry; +@(defun set_macro_character (c function &optional non_terminating_p + (readtable ecl_current_readtable())) @ - /* INV: read_table_entry() checks our arguments */ - entry = read_table_entry(rdtbl, chr); - if (ntp != Cnil) - entry->syntax_type = cat_non_terminating; - else - entry->syntax_type = cat_terminating; - while (Null(cl_functionp(fnc))) { - fnc = ecl_type_error(@'set-macro-character',"new_function", - fnc, @'function'); - } - entry->macro = fnc; + ecl_readtable_set(readtable, ecl_char_code(c), + Null(non_terminating_p)? + cat_terminating : + cat_non_terminating, + function); @(return Ct) @) -@(defun get_macro_character (chr &o (rdtbl ecl_current_readtable())) - struct ecl_readtable_entry*entry; - cl_object m; +@(defun get_macro_character (c &optional readtable) + enum ecl_chattrib cat; + cl_object dispatch, non_terminating_p; @ - - /* fix to allow NIL as readtable argument. Beppe */ - if (Null(rdtbl)) - rdtbl = cl_core.standard_readtable; - /* INV: read_table_entry() checks our arguments */ - entry = read_table_entry(rdtbl, chr); - m = entry->macro; - if (m == OBJNULL) - @(return Cnil Cnil) - @(return m ((entry->syntax_type == cat_non_terminating)? Ct : Cnil)) + if (Null(readtable)) + readtable = cl_core.standard_readtable; + cat = ecl_readtable_get(readtable, ecl_char_code(c), &dispatch); + if (type_of(dispatch) == t_hashtable) + dispatch = cl_core.dispatch_reader; + @(return dispatch ((cat == cat_non_terminating)? Ct : Cnil)) @) @(defun make_dispatch_macro_character (chr - &optional ntp (rdtbl ecl_current_readtable())) - struct ecl_readtable_entry*entry; - cl_object *table; - int i; + &optional non_terminating_p (readtable ecl_current_readtable())) + enum ecl_chattrib cat; + cl_object table; + int i, c; @ - /* INV: read_table_entry() checks our arguments */ - entry = read_table_entry(rdtbl, chr); - if (ntp != Cnil) - entry->syntax_type = cat_non_terminating; - else - entry->syntax_type = cat_terminating; - table = (cl_object *)cl_alloc(RTABSIZE * sizeof(cl_object)); - entry->dispatch_table = table; - for (i = 0; i < RTABSIZE; i++) - table[i] = cl_core.default_dispatch_macro; - entry->macro = cl_core.dispatch_reader; + assert_type_readtable(readtable); + c = ecl_char_code(chr); + cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; + table = cl__make_hash_table(@'eql', MAKE_FIXNUM(128), + ecl_make_singlefloat(1.5f), + ecl_make_singlefloat(0.5f), + Ct); + ecl_readtable_set(readtable, c, cat, table); @(return Ct) @) @(defun set_dispatch_macro_character (dspchr subchr fnc - &optional (rdtbl ecl_current_readtable())) - struct ecl_readtable_entry*entry; + &optional (readtable ecl_current_readtable())) + cl_object table; cl_fixnum subcode; @ - entry = read_table_entry(rdtbl, dspchr); - if (entry->macro != cl_core.dispatch_reader || entry->dispatch_table == NULL) + assert_type_readtable(readtable); + ecl_readtable_get(readtable, ecl_char_code(dspchr), &table); + if (type_of(table) != t_hashtable) { FEerror("~S is not a dispatch character.", 1, dspchr); + } subcode = ecl_char_code(subchr); - entry->dispatch_table[subcode] = fnc; + if (Null(fnc)) { + ecl_remhash(CODE_CHAR(subcode), table); + } else { + ecl_sethash(CODE_CHAR(subcode), table, fnc); + } if (islower(subcode)) { - entry->dispatch_table[toupper(subcode)] = fnc; + subcode = toupper(subcode); } else if (isupper(subcode)) { - entry->dispatch_table[tolower(subcode)] = fnc; + subcode = tolower(subcode); + } + if (Null(fnc)) { + ecl_remhash(CODE_CHAR(subcode), table); + } else { + ecl_sethash(CODE_CHAR(subcode), table, fnc); } @(return Ct) @) @(defun get_dispatch_macro_character (dspchr subchr - &optional (rdtbl ecl_current_readtable())) - struct ecl_readtable_entry*entry; - cl_fixnum subcode; + &optional (readtable ecl_current_readtable())) + cl_object table; + cl_fixnum c; @ - if (Null(rdtbl)) - rdtbl = cl_core.standard_readtable; - entry = read_table_entry(rdtbl, dspchr); - if (entry->macro != cl_core.dispatch_reader || entry->dispatch_table == NULL) + if (Null(readtable)) { + readtable = cl_core.standard_readtable; + } + assert_type_readtable(readtable); + c = ecl_char_code(dspchr); + ecl_readtable_get(readtable, c, &table); + if (type_of(table) != t_hashtable) { FEerror("~S is not a dispatch character.", 1, dspchr); - subcode = ecl_char_code(subchr); - if (ecl_digitp(subcode, 10) >= 0) + } + c = ecl_char_code(subchr); + + /* Since macro characters may take a number as argument, it is + not allowed to turn digits into dispatch macro characters */ + if (ecl_digitp(c, 10) >= 0) @(return Cnil) - @(return entry->dispatch_table[subcode]) + @(return ecl_gethash_safe(subchr, table, Cnil)) @) cl_object @@ -1939,7 +2027,7 @@ si_string_to_object(cl_object x) /* FIXME! Restricted to base string */ x = ecl_check_cl_type(@'si::string-to-object', x, t_base_string); - in = ecl_make_string_input_stream(x, 0, x->base_string.fillp); + in = ecl_make_string_input_stream(x, 0, TOKEN_STRING_FILLP(x)); x = ecl_read_object(in); if (x == OBJNULL) FEend_of_file(in); @@ -1967,101 +2055,107 @@ void init_read(void) { struct ecl_readtable_entry *rtab; - cl_object readtable; - cl_object *dtab; + cl_object r; int i; - cl_core.standard_readtable = cl_alloc_object(t_readtable); + cl_core.standard_readtable = r = ecl_alloc_object(t_readtable); cl_core.standard_readtable->readtable.read_case = ecl_case_upcase; cl_core.standard_readtable->readtable.table = rtab - = (struct ecl_readtable_entry *)cl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); + = (struct ecl_readtable_entry *) + ecl_alloc(RTABSIZE * sizeof(struct ecl_readtable_entry)); for (i = 0; i < RTABSIZE; i++) { rtab[i].syntax_type = cat_constituent; - rtab[i].macro = OBJNULL; - rtab[i].dispatch_table = NULL; + rtab[i].dispatch = Cnil; } +#ifdef ECL_UNICODE + cl_core.standard_readtable->readtable.hash = Cnil; +#endif cl_core.dispatch_reader = make_cf2(dispatch_reader_fun); - rtab['\t'].syntax_type = cat_whitespace; - rtab['\n'].syntax_type = cat_whitespace; - rtab['\f'].syntax_type = cat_whitespace; - rtab['\r'].syntax_type = cat_whitespace; - rtab[' '].syntax_type = cat_whitespace; - rtab['"'].syntax_type = cat_terminating; - rtab['"'].macro = make_cf2(double_quote_reader); - rtab['#'].syntax_type = cat_non_terminating; - rtab['#'].macro = cl_core.dispatch_reader; - rtab['\''].syntax_type = cat_terminating; - rtab['\''].macro = make_cf2(single_quote_reader); - rtab['('].syntax_type = cat_terminating; - rtab['('].macro = make_cf2(left_parenthesis_reader); - rtab[')'].syntax_type = cat_terminating; - rtab[')'].macro = make_cf2(right_parenthesis_reader); - rtab[','].syntax_type = cat_terminating; - rtab[','].macro = make_cf2(comma_reader); - rtab[';'].syntax_type = cat_terminating; - rtab[';'].macro = make_cf2(semicolon_reader); - rtab['\\'].syntax_type = cat_single_escape; - rtab['`'].syntax_type = cat_terminating; - rtab['`'].macro = make_cf2(backquote_reader); - rtab['|'].syntax_type = cat_multiple_escape; -/* - rtab['|'].macro = make_cf2(vertical_bar_reader); -*/ + ecl_readtable_set(r, '\t', cat_whitespace, Cnil); + ecl_readtable_set(r, '\n', cat_whitespace, Cnil); + ecl_readtable_set(r, '\f', cat_whitespace, Cnil); + ecl_readtable_set(r, '\r', cat_whitespace, Cnil); + ecl_readtable_set(r, ' ', cat_whitespace, Cnil); + + ecl_readtable_set(r, '"', cat_terminating, + make_cf2(double_quote_reader)); + + ecl_readtable_set(r, '\'', cat_terminating, + make_cf2(single_quote_reader)); + ecl_readtable_set(r, '(', cat_terminating, + make_cf2(left_parenthesis_reader)); + ecl_readtable_set(r, ')', cat_terminating, + make_cf2(right_parenthesis_reader)); + ecl_readtable_set(r, ',', cat_terminating, + make_cf2(comma_reader)); + ecl_readtable_set(r, ';', cat_terminating, + make_cf2(semicolon_reader)); + ecl_readtable_set(r, '\\', cat_single_escape, Cnil); + ecl_readtable_set(r, '`', cat_terminating, + make_cf2(backquote_reader)); + ecl_readtable_set(r, '|', cat_multiple_escape, Cnil); cl_core.default_dispatch_macro = make_cf3(default_dispatch_macro_fun); - rtab['#'].dispatch_table - = dtab - = (cl_object *)cl_alloc(RTABSIZE * sizeof(cl_object)); - for (i = 0; i < RTABSIZE; i++) - dtab[i] = cl_core.default_dispatch_macro; - dtab['C'] = dtab['c'] = make_cf3(sharp_C_reader); - dtab['\\'] = make_cf3(sharp_backslash_reader); - dtab['\''] = make_cf3(sharp_single_quote_reader); - dtab['('] = make_cf3(sharp_left_parenthesis_reader); - dtab['*'] = make_cf3(sharp_asterisk_reader); - dtab[':'] = make_cf3(sharp_colon_reader); - dtab['.'] = make_cf3(sharp_dot_reader); - /* Used for fasload only. */ - dtab['B'] = dtab['b'] = make_cf3(sharp_B_reader); - dtab['O'] = dtab['o'] = make_cf3(sharp_O_reader); - dtab['X'] = dtab['x'] = make_cf3(sharp_X_reader); - dtab['R'] = dtab['r'] = make_cf3(sharp_R_reader); -/* - dtab['A'] = dtab['a'] = make_cf3(sharp_A_reader); - dtab['S'] = dtab['s'] = make_cf3(sharp_S_reader); -*/ - dtab['A'] = dtab['a'] = @'si::sharp-a-reader'; - dtab['S'] = dtab['s'] = @'si::sharp-s-reader'; - dtab['P'] = dtab['p'] = make_cf3(sharp_P_reader); + cl_make_dispatch_macro_character(3, CODE_CHAR('#'), + Ct /* non terminating */, r); - dtab['='] = make_cf3(sharp_eq_reader); - dtab['#'] = make_cf3(sharp_sharp_reader); - dtab['+'] = make_cf3(sharp_plus_reader); - dtab['-'] = make_cf3(sharp_minus_reader); -/* - dtab['<'] = make_cf3(sharp_less_than_reader); -*/ - dtab['|'] = make_cf3(sharp_vertical_bar_reader); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('C'), + make_cf3(sharp_C_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('\\'), + make_cf3(sharp_backslash_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('\''), + make_cf3(sharp_single_quote_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('('), + make_cf3(sharp_left_parenthesis_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('*'), + make_cf3(sharp_asterisk_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR(':'), + make_cf3(sharp_colon_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('.'), + make_cf3(sharp_dot_reader), r); + /* Used for fasload only. */ + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('B'), + make_cf3(sharp_B_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('O'), + make_cf3(sharp_O_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('X'), + make_cf3(sharp_X_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('R'), + make_cf3(sharp_R_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('A'), + @'si::sharp-a-reader', r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('S'), + @'si::sharp-s-reader', r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('P'), + make_cf3(sharp_P_reader), r); + + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('='), + make_cf3(sharp_eq_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('#'), + make_cf3(sharp_sharp_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('+'), + make_cf3(sharp_plus_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('-'), + make_cf3(sharp_minus_reader), r); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('|'), + make_cf3(sharp_vertical_bar_reader), r); /* This is specific to this implementation */ - dtab['$'] = make_cf3(sharp_dollar_reader); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('$'), + make_cf3(sharp_dollar_reader), r); /* This is specific to this implimentation */ -/* - dtab[' '] = dtab['\t'] = dtab['\n'] = dtab['\f'] - = make_cf3(sharp_whitespace_reader); - dtab[')'] = make_cf3(sharp_right_parenthesis_reader); -*/ - dtab['Y'] = dtab['y'] = make_cf3(sharp_Y_reader); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('Y'), + make_cf3(sharp_Y_reader), r); init_backq(); ECL_SET(@'*readtable*', - readtable=ecl_copy_readtable(cl_core.standard_readtable, Cnil)); - readtable->readtable.table['#'].dispatch_table['!'] - = cl_core.default_dispatch_macro; /* We must forget #! macro. */ + r=ecl_copy_readtable(cl_core.standard_readtable, Cnil)); + cl_set_dispatch_macro_character(4, CODE_CHAR('#'), CODE_CHAR('!'), + Cnil, r); ECL_SET(@'*read-default-float-format*', @'single-float'); } @@ -2079,6 +2173,7 @@ init_read(void) cl_object read_VV(cl_object block, void (*entry_point)(cl_object)) { + const cl_env_ptr env = ecl_process_env(); volatile cl_object old_eptbc = cl_core.packages_to_be_created; volatile cl_object x; cl_index i, len, perm_len, temp_len; @@ -2086,14 +2181,28 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) cl_object *VV, *VVtemp = 0; if (block == NULL) { - block = cl_alloc_object(t_codeblock); + block = ecl_alloc_object(t_codeblock); + block->cblock.self_destruct = 0; + block->cblock.locked = 0; + block->cblock.handle = NULL; + block->cblock.data = NULL; + block->cblock.data_size = 0; + block->cblock.temp_data = NULL; + block->cblock.temp_data_size = 0; + block->cblock.data_text = NULL; + block->cblock.data_text_size = 0; + block->cblock.next = Cnil; + block->cblock.name = Cnil; + block->cblock.links = Cnil; + block->cblock.cfuns_size = 0; + block->cblock.cfuns = NULL; si_set_finalizer(block, Ct); } block->cblock.entry = entry_point; in = OBJNULL; - CL_UNWIND_PROTECT_BEGIN { - bds_bind(@'si::*cblock*', block); + CL_UNWIND_PROTECT_BEGIN(env) { + ecl_bds_bind(env, @'si::*cblock*', block); if (cl_core.packages_to_be_created == OBJNULL) cl_core.packages_to_be_created = Cnil; @@ -2105,7 +2214,7 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) temp_len = block->cblock.temp_data_size; len = perm_len + temp_len; #ifdef ECL_DYNAMIC_VV - VV = block->cblock.data = perm_len? (cl_object *)cl_alloc(perm_len * sizeof(cl_object)) : NULL; + VV = block->cblock.data = perm_len? (cl_object *)ecl_alloc(perm_len * sizeof(cl_object)) : NULL; #else VV = block->cblock.data; #endif @@ -2113,18 +2222,18 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) if ((len == 0) || (block->cblock.data_text == 0)) goto NO_DATA_LABEL; - VVtemp = block->cblock.temp_data = temp_len? (cl_object *)cl_alloc(temp_len * sizeof(cl_object)) : NULL; + VVtemp = block->cblock.temp_data = temp_len? (cl_object *)ecl_alloc(temp_len * sizeof(cl_object)) : NULL; memset(VVtemp, 0, temp_len * sizeof(*VVtemp)); /* Read all data for the library */ in=ecl_make_string_input_stream(make_constant_base_string(block->cblock.data_text), 0, block->cblock.data_text_size); - bds_bind(@'*read-base*', MAKE_FIXNUM(10)); - bds_bind(@'*read-default-float-format*', @'single-float'); - bds_bind(@'*read-suppress*', Cnil); - bds_bind(@'*readtable*', cl_core.standard_readtable); - bds_bind(@'*package*', cl_core.lisp_package); - bds_bind(@'si::*sharp-eq-context*', Cnil); + ecl_bds_bind(env, @'*read-base*', MAKE_FIXNUM(10)); + ecl_bds_bind(env, @'*read-default-float-format*', @'single-float'); + ecl_bds_bind(env, @'*read-suppress*', Cnil); + ecl_bds_bind(env, @'*readtable*', cl_core.standard_readtable); + ecl_bds_bind(env, @'*package*', cl_core.lisp_package); + ecl_bds_bind(env, @'si::*sharp-eq-context*', Cnil); for (i = 0 ; i < len; i++) { x = ecl_read_object(in); if (x == OBJNULL) @@ -2134,7 +2243,7 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) else VVtemp[i-perm_len] = x; } - if (!Null(SYM_VAL(@'si::*sharp-eq-context*'))) { + if (!Null(ECL_SYM_VAL(env, @'si::*sharp-eq-context*'))) { while (i--) { if (i < perm_len) { VV[i] = patch_sharp(VV[i]); @@ -2143,12 +2252,12 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) } } } - bds_unwind_n(6); + ecl_bds_unwind_n(env, 6); if (i < len) FEreader_error("Not enough data while loading binary file", in, 0); NO_DATA_LABEL: for (i = 0; i < block->cblock.cfuns_size; i++) { - struct ecl_cfun *prototype = block->cblock.cfuns+i; + const struct ecl_cfun *prototype = block->cblock.cfuns+i; cl_index fname_location = fix(prototype->block); cl_object fname = VV[fname_location]; cl_index location = fix(prototype->name); @@ -2170,9 +2279,9 @@ read_VV(cl_object block, void (*entry_point)(cl_object)) if (VVtemp) { block->cblock.temp_data = NULL; block->cblock.temp_data_size = 0; - cl_dealloc(VVtemp); + ecl_dealloc(VVtemp); } - bds_unwind1(); + ecl_bds_unwind1(env); } CL_UNWIND_PROTECT_EXIT { if (in != OBJNULL) cl_close(1,in); diff --git a/src/c/reference.d b/src/c/reference.d index e00c5dbb4..0188de1ca 100644 --- a/src/c/reference.d +++ b/src/c/reference.d @@ -126,14 +126,16 @@ si_coerce_to_function(cl_object fun) cl_object cl_symbol_value(cl_object sym) { + const cl_env_ptr the_env = ecl_process_env(); cl_object value; if (Null(sym)) { value = sym; } else { + const cl_env_ptr env = ecl_process_env(); if (!SYMBOLP(sym)) { FEtype_error_symbol(sym); } - value = SYM_VAL(sym); + value = ECL_SYM_VAL(the_env, sym); if (value == OBJNULL) FEunbound_variable(sym); } @@ -143,13 +145,14 @@ cl_symbol_value(cl_object sym) cl_object cl_boundp(cl_object sym) { + const cl_env_ptr the_env = ecl_process_env(); cl_object output; if (Null(sym)) { output = Ct; } else { if (!SYMBOLP(sym)) FEtype_error_symbol(sym); - if (SYM_VAL(sym) == OBJNULL) + if (ECL_SYM_VAL(the_env, sym) == OBJNULL) output = Cnil; else output = Ct; @@ -160,6 +163,7 @@ cl_boundp(cl_object sym) cl_object cl_special_operator_p(cl_object form) { + const cl_env_ptr the_env = ecl_process_env(); int special = ecl_symbol_type(form) & stp_special_form; @(return (special? Ct : Cnil)) } diff --git a/src/c/sequence.d b/src/c/sequence.d index b8cbff6a1..ac543832b 100644 --- a/src/c/sequence.d +++ b/src/c/sequence.d @@ -35,7 +35,7 @@ ecl_alloc_simple_vector(cl_index l, cl_elttype aet) return cl_alloc_simple_extended_string(l); #endif case aet_bit: - x = cl_alloc_object(t_bitvector); + x = ecl_alloc_object(t_bitvector); x->vector.hasfillp = FALSE; x->vector.adjustable = FALSE; x->vector.displaced = Cnil; @@ -44,7 +44,7 @@ ecl_alloc_simple_vector(cl_index l, cl_elttype aet) x->vector.self.bit = NULL; break; default: - x = cl_alloc_object(t_vector); + x = ecl_alloc_object(t_vector); x->vector.hasfillp = FALSE; x->vector.adjustable = FALSE; x->vector.displaced = Cnil; diff --git a/src/c/stacks.d b/src/c/stacks.d index 1bcfcbe06..48a0e0f5f 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -26,34 +26,41 @@ /************************ C STACK ***************************/ static void -cs_set_size(cl_index new_size) +cs_set_size(cl_env_ptr env, cl_index new_size) { volatile int foo = 0; cl_index safety_area = ecl_get_option(ECL_OPT_C_STACK_SAFETY_AREA); new_size += 2*safety_area; #ifdef ECL_DOWN_STACK - if (&foo > cl_env.cs_org - new_size + 16) - cl_env.cs_limit = cl_env.cs_org - new_size + 2*safety_area; + if (&foo > env->cs_org - new_size + 16) { + env->cs_limit = env->cs_org - new_size + 2*safety_area; + if (env->cs_limit < env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #else - if (&foo < cl_env.cs_org + new_size - 16) - cl_env.cs_limit = cl_env.cs_org + new_size - 2*safety_area; + if (&foo < env->cs_org + new_size - 16) { + env->cs_limit = env->cs_org + new_size - 2*safety_area; + if (env->cs_limit > env->cs_barrier) + env->cs_barrier = env->cs_limit; + } #endif else - ecl_internal_error("can't reset cl_env.cs_limit."); - cl_env.cs_size = new_size; + ecl_internal_error("can't reset env->cs_limit."); + env->cs_size = new_size; } void ecl_cs_overflow(void) { + cl_env_ptr env = ecl_process_env(); cl_index safety_area = ecl_get_option(ECL_OPT_C_STACK_SAFETY_AREA); - cl_index size = cl_env.cs_size; + cl_index size = env->cs_size; #ifdef ECL_DOWN_STACK - if (cl_env.cs_limit > cl_env.cs_org - size) - cl_env.cs_limit -= safety_area; + if (env->cs_limit > env->cs_org - size) + env->cs_limit -= safety_area; #else - if (cl_env.cs_limit < cl_env.cs_org + size) - cl_env.cs_limit += safety_area; + if (env->cs_limit < env->cs_org + size) + env->cs_limit += safety_area; #endif else ecl_internal_error("Cannot grow stack size."); @@ -61,7 +68,7 @@ ecl_cs_overflow(void) @'ext::stack-overflow', @':size', MAKE_FIXNUM(size), @':type', @'ext::c-stack'); size += size / 2; - cs_set_size(size); + cs_set_size(env, size); } @@ -69,19 +76,19 @@ ecl_cs_overflow(void) #ifdef ECL_THREADS void -bds_bind(cl_object s, cl_object value) +ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object value) { - struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash); - struct bds_bd *slot = ++cl_env.bds_top; - if (slot >= cl_env.bds_limit) { - bds_overflow(); - slot = cl_env.bds_top; + struct ecl_hashtable_entry *h = ecl_search_hash(s, env->bindings_hash); + struct bds_bd *slot = ++env->bds_top; + if (slot >= env->bds_limit) { + ecl_bds_overflow(); + slot = env->bds_top; } if (h->key == OBJNULL) { /* The previous binding was at most global */ slot->symbol = s; slot->value = OBJNULL; - ecl_sethash(s, cl_env.bindings_hash, value); + ecl_sethash(s, env->bindings_hash, value); } else { /* We have to save a dynamic binding */ slot->symbol = h->key; @@ -92,19 +99,19 @@ bds_bind(cl_object s, cl_object value) } void -bds_push(cl_object s) +ecl_bds_push(cl_env_ptr env, cl_object s) { - struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash); - struct bds_bd *slot = ++cl_env.bds_top; - if (slot >= cl_env.bds_limit) { - bds_overflow(); - slot = cl_env.bds_top; + struct ecl_hashtable_entry *h = ecl_search_hash(s, env->bindings_hash); + struct bds_bd *slot = ++env->bds_top; + if (slot >= env->bds_limit) { + ecl_bds_overflow(); + slot = env->bds_top; } if (h->key == OBJNULL) { /* The previous binding was at most global */ slot->symbol = s; slot->value = OBJNULL; - ecl_sethash(s, cl_env.bindings_hash, s->symbol.value); + ecl_sethash(s, env->bindings_hash, s->symbol.value); } else { /* We have to save a dynamic binding */ slot->symbol = h->key; @@ -114,16 +121,16 @@ bds_push(cl_object s) } void -bds_unwind1(void) +ecl_bds_unwind1(cl_env_ptr env) { - struct bds_bd *slot = cl_env.bds_top--; + struct bds_bd *slot = env->bds_top--; cl_object s = slot->symbol; - struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash); + struct ecl_hashtable_entry *h = ecl_search_hash(s, env->bindings_hash); if (slot->value == OBJNULL) { /* We have deleted all dynamic bindings */ h->key = OBJNULL; h->value = OBJNULL; - cl_env.bindings_hash->hash.entries--; + env->bindings_hash->hash.entries--; } else { /* We restore the previous dynamic binding */ h->value = slot->value; @@ -131,12 +138,12 @@ bds_unwind1(void) } cl_object * -ecl_symbol_slot(cl_object s) +ecl_symbol_slot(cl_env_ptr env, cl_object s) { if (Null(s)) s = Cnil_symbol; if (s->symbol.dynamic) { - struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash); + struct ecl_hashtable_entry *h = ecl_search_hash(s, env->bindings_hash); if (h->key != OBJNULL) return &h->value; } @@ -144,10 +151,10 @@ ecl_symbol_slot(cl_object s) } cl_object -ecl_set_symbol(cl_object s, cl_object value) +ecl_set_symbol(cl_env_ptr env, cl_object s, cl_object value) { if (s->symbol.dynamic) { - struct ecl_hashtable_entry *h = ecl_search_hash(s, cl_env.bindings_hash); + struct ecl_hashtable_entry *h = ecl_search_hash(s, env->bindings_hash); if (h->key != OBJNULL) { return (h->value = value); } @@ -157,69 +164,75 @@ ecl_set_symbol(cl_object s, cl_object value) #endif void -bds_unwind_n(int n) +ecl_bds_unwind_n(cl_env_ptr env, int n) { - while (n--) bds_unwind1(); + while (n--) ecl_bds_unwind1(env); } static void -bds_set_size(cl_index size) +ecl_bds_set_size(cl_env_ptr env, cl_index size) { - cl_index limit = (cl_env.bds_top - cl_env.bds_org); + bds_ptr old_org = env->bds_org; + cl_index limit = env->bds_top - old_org; if (size <= limit) { FEerror("Cannot shrink the binding stack below ~D.", 1, ecl_make_unsigned_integer(limit)); } else { cl_index margin = ecl_get_option(ECL_OPT_BIND_STACK_SAFETY_AREA); bds_ptr org; - org = cl_alloc_atomic(size * sizeof(*org)); - memcpy(org, cl_env.bds_org, (limit + 1) * sizeof(*org)); - cl_env.bds_top = org + limit; - cl_env.bds_org = org; - cl_env.bds_limit = org + (size - 2*margin); - cl_env.bds_size = size; + org = ecl_alloc_atomic(size * sizeof(*org)); + + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->bds_top = org + limit; + env->bds_org = org; + env->bds_limit = org + (size - 2*margin); + env->bds_size = size; + ecl_enable_interrupts_env(env); + + ecl_dealloc(old_org); } } void -bds_overflow(void) +ecl_bds_overflow(void) { + cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_get_option(ECL_OPT_BIND_STACK_SAFETY_AREA); - cl_index size = cl_env.bds_size; - bds_ptr org = cl_env.bds_org; + cl_index size = env->bds_size; + bds_ptr org = env->bds_org; bds_ptr last = org + size; - if (cl_env.bds_limit >= last) { + if (env->bds_limit >= last) { ecl_internal_error("Bind stack overflow, cannot grow larger."); } - cl_env.bds_limit += margin; + env->bds_limit += margin; cl_cerror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', MAKE_FIXNUM(size), @':type', @'ext::binding-stack'); - bds_set_size(size + (size / 2)); + ecl_bds_set_size(env, size + (size / 2)); } void -bds_unwind(cl_index new_bds_top_index) +ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) { - bds_ptr new_bds_top = new_bds_top_index + cl_env.bds_org; - bds_ptr bds = cl_env.bds_top; + bds_ptr new_bds_top = new_bds_top_index + env->bds_org; + bds_ptr bds = env->bds_top; for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS - bds_unwind1(); + ecl_bds_unwind1(env); #else bds->symbol->symbol.value = bds->value; #endif - cl_env.bds_top = new_bds_top; + env->bds_top = new_bds_top; } static bds_ptr get_bds_ptr(cl_object x) { - bds_ptr p; - if (FIXNUMP(x)) { - p = cl_env.bds_org + fix(x); - if (cl_env.bds_org <= p && p <= cl_env.bds_top) + cl_env_ptr env = ecl_process_env(); + bds_ptr p = env->bds_org + fix(x); + if (env->bds_org <= p && p <= env->bds_top) return(p); } FEerror("~S is an illegal bds index.", 1, x); @@ -228,7 +241,8 @@ get_bds_ptr(cl_object x) cl_object si_bds_top() { - @(return MAKE_FIXNUM(cl_env.bds_top - cl_env.bds_org)) + cl_env_ptr env = ecl_process_env(); + @(return MAKE_FIXNUM(env->bds_top - env->bds_org)) } cl_object @@ -276,7 +290,8 @@ ihs_function_name(cl_object x) static ihs_ptr get_ihs_ptr(cl_index n) { - ihs_ptr p = cl_env.ihs_top; + cl_env_ptr env = ecl_process_env(); + ihs_ptr p = env->ihs_top; if (n > p->index) FEerror("~D is an illegal IHS index.", 1, MAKE_FIXNUM(n)); while (n < p->index) @@ -287,13 +302,15 @@ get_ihs_ptr(cl_index n) cl_object ihs_top_function_name(void) { - return ihs_function_name(cl_env.ihs_top->function); + cl_env_ptr env = ecl_process_env(); + return ihs_function_name(env->ihs_top->function); } cl_object si_ihs_top(cl_object name) { - @(return MAKE_FIXNUM(cl_env.ihs_top->index)) + cl_env_ptr env = ecl_process_env(); + @(return MAKE_FIXNUM(env->ihs_top->index)) } cl_object @@ -327,13 +344,14 @@ static int frame_id = 0; cl_object new_frame_id(void) { - return(MAKE_FIXNUM(frame_id++)); + return MAKE_FIXNUM(frame_id++); } static void -frs_set_size(cl_index size) +frs_set_size(cl_env_ptr env, cl_index size) { - cl_index limit = (cl_env.frs_top - cl_env.frs_org); + ecl_frame_ptr old_org = env->frs_top; + cl_index limit = env->frs_top - old_org; if (size <= limit) { FEerror("Cannot shrink frame stack below ~D.", 1, ecl_make_unsigned_integer(limit)); @@ -341,66 +359,72 @@ frs_set_size(cl_index size) cl_index margin = ecl_get_option(ECL_OPT_FRAME_STACK_SAFETY_AREA); ecl_frame_ptr org; size += 2*margin; - org = cl_alloc_atomic(size * sizeof(*org)); - memcpy(org, cl_env.frs_org, (limit + 1) * sizeof(*org)); - cl_env.frs_top = org + limit; - cl_env.frs_org = org; - cl_env.frs_limit = org + (size - 2*margin); - cl_env.frs_size = size; + org = ecl_alloc_atomic(size * sizeof(*org)); + + ecl_disable_interrupts_env(env); + memcpy(org, old_org, (limit + 1) * sizeof(*org)); + env->frs_top = org + limit; + env->frs_org = org; + env->frs_limit = org + (size - 2*margin); + env->frs_size = size; + ecl_enable_interrupts_env(env); + + ecl_dealloc(old_org); } } static void frs_overflow(void) /* used as condition in list.d */ { + cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_get_option(ECL_OPT_FRAME_STACK_SAFETY_AREA); - cl_index size = cl_env.frs_size; - ecl_frame_ptr org = cl_env.frs_org; + cl_index size = env->frs_size; + ecl_frame_ptr org = env->frs_org; ecl_frame_ptr last = org + size; - if (cl_env.frs_limit >= last) { + if (env->frs_limit >= last) { ecl_internal_error("Frame stack overflow, cannot grow larger."); } - cl_env.frs_limit += margin; + env->frs_limit += margin; cl_cerror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', MAKE_FIXNUM(size), @':type', @'ext::frame-stack'); - frs_set_size(size + size / 2); + frs_set_size(env, size + size / 2); } ecl_frame_ptr -_frs_push(register cl_object val) +_ecl_frs_push(register cl_env_ptr env, register cl_object val) { - ecl_frame_ptr output = ++cl_env.frs_top; - if (output >= cl_env.frs_limit) { + ecl_frame_ptr output = ++env->frs_top; + if (output >= env->frs_limit) { frs_overflow(); - output = cl_env.frs_top; + output = env->frs_top; } - output->frs_bds_top_index = cl_env.bds_top - cl_env.bds_org; + output->frs_bds_top_index = env->bds_top - env->bds_org; output->frs_val = val; - output->frs_ihs = cl_env.ihs_top; - output->frs_sp = cl_stack_index(); + output->frs_ihs = env->ihs_top; + output->frs_sp = ecl_stack_index(env); return output; } void -ecl_unwind(ecl_frame_ptr fr) +ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) { - cl_env.nlj_fr = fr; - while (cl_env.frs_top != fr && cl_env.frs_top->frs_val != ECL_PROTECT_TAG) - --cl_env.frs_top; - cl_env.ihs_top = cl_env.frs_top->frs_ihs; - bds_unwind(cl_env.frs_top->frs_bds_top_index); - cl_stack_set_index(cl_env.frs_top->frs_sp); - ecl_longjmp(cl_env.frs_top->frs_jmpbuf, 1); + env->nlj_fr = fr; + while (env->frs_top != fr && env->frs_top->frs_val != ECL_PROTECT_TAG) + --env->frs_top; + env->ihs_top = env->frs_top->frs_ihs; + ecl_bds_unwind(env, env->frs_top->frs_bds_top_index); + ecl_stack_set_index(env, env->frs_top->frs_sp); + ecl_longjmp(env->frs_top->frs_jmpbuf, 1); /* never reached */ } ecl_frame_ptr frs_sch (cl_object frame_id) { + cl_env_ptr env = ecl_process_env(); ecl_frame_ptr top; - - for (top = cl_env.frs_top; top >= cl_env.frs_org; top--) + for (top = env->frs_top; top >= env->frs_org; top--) if (top->frs_val == frame_id) return(top); return(NULL); @@ -409,12 +433,11 @@ frs_sch (cl_object frame_id) static ecl_frame_ptr get_frame_ptr(cl_object x) { - ecl_frame_ptr p; - if (FIXNUMP(x)) { - p = cl_env.frs_org + fix(x); - if (cl_env.frs_org <= p && p <= cl_env.frs_top) - return(p); + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_org + fix(x); + if (env->frs_org <= p && p <= env->frs_top) + return p; } FEerror("~S is an illegal frs index.", 1, x); } @@ -422,7 +445,8 @@ get_frame_ptr(cl_object x) cl_object si_frs_top() { - @(return MAKE_FIXNUM(cl_env.frs_top - cl_env.frs_org)) + cl_env_ptr env = ecl_process_env(); + @(return MAKE_FIXNUM(env->frs_top - env->frs_org)) } cl_object @@ -446,36 +470,57 @@ si_frs_ihs(cl_object arg) cl_object si_sch_frs_base(cl_object fr, cl_object ihs) { + cl_env_ptr env = ecl_process_env(); ecl_frame_ptr x; - cl_index y; - - y = fixnnint(ihs); + cl_index y = fixnnint(ihs); for (x = get_frame_ptr(fr); - x <= cl_env.frs_top && x->frs_ihs->index < y; + x <= env->frs_top && x->frs_ihs->index < y; x++); - @(return ((x > cl_env.frs_top) ? Cnil : MAKE_FIXNUM(x - cl_env.frs_org))) + @(return ((x > env->frs_top) ? Cnil : MAKE_FIXNUM(x - env->frs_org))) } /********************* INITIALIZATION ***********************/ cl_object -si_set_stack_size(cl_object type, cl_object size) +si_set_limit(cl_object type, cl_object size) { + cl_env_ptr env = ecl_process_env(); cl_index the_size = fixnnint(size); if (type == @'ext::frame-stack') { - frs_set_size(the_size); + frs_set_size(env, the_size); } else if (type == @'ext::binding-stack') { - bds_set_size(the_size); + ecl_bds_set_size(env, the_size); } else if (type == @'ext::c-stack') { - cs_set_size(the_size); + cs_set_size(env, the_size); + } else if (type == @'ext::lisp-stack') { + ecl_stack_set_size(env, the_size); } else { - cl_stack_set_size(the_size); + _ecl_set_max_heap_size(the_size); } @(return) } +cl_object +si_get_limit(cl_object type) +{ + cl_env_ptr env = ecl_process_env(); + cl_index output; + if (type == @'ext::frame-stack') { + output = env->frs_size; + } else if (type == @'ext::binding-stack') { + output = env->bds_size; + } else if (type == @'ext::c-stack') { + output = env->cs_size; + } else if (type == @'ext::lisp-stack') { + output = env->stack_size; + } else { + output = cl_core.max_heap_size; + } + @(return ecl_make_unsigned_integer(output)) +} + void -init_stacks(struct cl_env_struct *env, int *new_cs_org) +init_stacks(cl_env_ptr env, int *new_cs_org) { static struct ihs_frame ihs_org = { NULL, NULL, NULL, 0}; cl_index size, margin; @@ -483,14 +528,14 @@ init_stacks(struct cl_env_struct *env, int *new_cs_org) margin = ecl_get_option(ECL_OPT_FRAME_STACK_SAFETY_AREA); size = ecl_get_option(ECL_OPT_FRAME_STACK_SIZE) + 2 * margin; env->frs_size = size; - env->frs_org = (ecl_frame_ptr)cl_alloc_atomic(size * sizeof(*env->frs_org)); + env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); env->frs_top = env->frs_org-1; env->frs_limit = &env->frs_org[size - 2*margin]; margin = ecl_get_option(ECL_OPT_BIND_STACK_SAFETY_AREA); size = ecl_get_option(ECL_OPT_BIND_STACK_SIZE) + 2 * margin; env->bds_size = size; - env->bds_org = (bds_ptr)cl_alloc_atomic(size * sizeof(*env->bds_org)); + env->bds_org = (bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); env->bds_top = env->bds_org-1; env->bds_limit = &env->bds_org[size - 2*margin]; @@ -500,19 +545,25 @@ init_stacks(struct cl_env_struct *env, int *new_cs_org) ihs_org.index = 0; env->cs_org = new_cs_org; + env->cs_barrier = new_cs_org; #if defined(HAVE_SYS_RESOURCE_H) && defined(RLIMIT_STACK) { - struct rlimit rl; - cl_index size; - getrlimit(RLIMIT_STACK, &rl); - if (rl.rlim_cur != RLIM_INFINITY) { - size = rl.rlim_cur / sizeof(cl_fixnum) / 2; - if (size > ecl_get_option(ECL_OPT_C_STACK_SIZE)) - ecl_set_option(ECL_OPT_C_STACK_SIZE, size); - } + struct rlimit rl; + cl_index size; + getrlimit(RLIMIT_STACK, &rl); + if (rl.rlim_cur != RLIM_INFINITY) { + size = rl.rlim_cur / sizeof(cl_fixnum) / 2; + if (size > ecl_get_option(ECL_OPT_C_STACK_SIZE)) + ecl_set_option(ECL_OPT_C_STACK_SIZE, size); +#ifdef ECL_DOWN_STACK + env->cs_barrier = env->cs_org - rl.rlim_cur - 1024; +#else + env->cs_barrier = env->cs_org + rl.rlim_cur + 1024; +#endif + } } #endif - cs_set_size(ecl_get_option(ECL_OPT_C_STACK_SIZE)); + cs_set_size(env, ecl_get_option(ECL_OPT_C_STACK_SIZE)); #if defined(HAVE_SIGPROCMASK) && defined(SA_SIGINFO) if (ecl_get_option(ECL_OPT_SIGALTSTACK_SIZE)) { @@ -523,7 +574,7 @@ init_stacks(struct cl_env_struct *env, int *new_cs_org) (sizeof(cl_object)*4); } env->altstack_size = size; - env->altstack = cl_alloc_atomic(size); + env->altstack = ecl_alloc_atomic(size); memset(&new_stack, 0, sizeof(new_stack)); new_stack.ss_size = env->altstack_size; new_stack.ss_sp = env->altstack; @@ -531,4 +582,7 @@ init_stacks(struct cl_env_struct *env, int *new_cs_org) sigaltstack(&new_stack, NULL); } #endif +#ifdef SA_SIGINFO + env->interrupt_info = ecl_alloc_atomic(sizeof(siginfo_t)); +#endif } diff --git a/src/c/string.d b/src/c/string.d index c50284dbb..5e92a179e 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -80,12 +80,12 @@ cl_alloc_simple_base_string(cl_index length) { cl_object x; - x = cl_alloc_object(t_base_string); + x = ecl_alloc_object(t_base_string); x->base_string.hasfillp = FALSE; x->base_string.adjustable = FALSE; x->base_string.displaced = Cnil; x->base_string.dim = (x->base_string.fillp = length); - x->base_string.self = (char *)cl_alloc_atomic(length+1); + x->base_string.self = (unsigned char*)ecl_alloc_atomic(length+1); x->base_string.self[length] = x->base_string.self[0] = 0; return(x); } @@ -97,12 +97,12 @@ cl_alloc_simple_extended_string(cl_index length) cl_object x; /* should this call si_make_vector? */ - x = cl_alloc_object(t_string); + x = ecl_alloc_object(t_string); x->string.hasfillp = FALSE; x->string.adjustable = FALSE; x->string.displaced = Cnil; x->string.dim = x->string.fillp = length; - x->string.self = (cl_object *)cl_alloc_align(sizeof (cl_object)*length, sizeof (cl_object)); + x->string.self = (cl_object *)ecl_alloc_align(sizeof (cl_object)*length, sizeof (cl_object)); return(x); } #endif @@ -122,6 +122,18 @@ cl_alloc_adjustable_base_string(cl_index l) return output; } +#ifdef ECL_UNICODE +cl_object +ecl_alloc_adjustable_extended_string(cl_index l) +{ + cl_object output = cl_alloc_simple_extended_string(l); + output->base_string.fillp = 0; + output->base_string.hasfillp = TRUE; + output->base_string.adjustable = TRUE; + return output; +} +#endif + /* Make_simple_base_string(s) makes a simple-base string from C string s. */ @@ -131,12 +143,12 @@ make_simple_base_string(char *s) cl_object x; cl_index l = strlen(s); - x = cl_alloc_object(t_base_string); + x = ecl_alloc_object(t_base_string); x->base_string.hasfillp = FALSE; x->base_string.adjustable = FALSE; x->base_string.displaced = Cnil; x->base_string.dim = (x->base_string.fillp = l); - x->base_string.self = s; + x->base_string.self = (unsigned char *)s; return(x); } @@ -445,7 +457,8 @@ compare_strings(cl_object string1, cl_index s1, cl_index e1, #endif static int -compare_base(char *s1, cl_index l1, char *s2, cl_index l2, int case_sensitive, cl_index *m) +compare_base(unsigned char *s1, cl_index l1, unsigned char *s2, cl_index l2, + int case_sensitive, cl_index *m) { cl_index l, c1, c2; for (l = 0; l < l1; l++, s1++, s2++) { @@ -944,14 +957,14 @@ nstring_case(cl_narg narg, cl_object fun, int (*casefun)(int, bool *), cl_va_lis for (i = 0, l = 0; i < narg; i++) { cl_object s = si_coerce_to_base_string(cl_va_arg(args)); if (s->base_string.fillp) { - cl_stack_push(s); + ecl_stack_push(the_env, s); l += s->base_string.fillp; } } /* Do actual copying by recovering those strings */ output = cl_alloc_simple_base_string(l); while (l) { - cl_object s = cl_stack_pop(); + cl_object s = ecl_stack_pop(the_env); size_t bytes = s->base_string.fillp; l -= bytes; memcpy(output->base_string.self + l, s->base_string.self, bytes); diff --git a/src/c/structure.d b/src/c/structure.d index 1ac555cf9..5fd9fcefc 100644 --- a/src/c/structure.d +++ b/src/c/structure.d @@ -66,11 +66,11 @@ si_structure_subtype_p(cl_object x, cl_object y) cl_object x; int i; @ - x = cl_alloc_object(T_STRUCTURE); + x = ecl_alloc_object(T_STRUCTURE); STYPE(x) = type; SLOTS(x) = NULL; /* for GC sake */ SLENGTH(x) = --narg; - SLOTS(x) = (cl_object *)cl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); + SLOTS(x) = (cl_object *)ecl_alloc_align(sizeof(cl_object)*narg, sizeof(cl_object)); if (narg >= ECL_SLOTS_LIMIT) FEerror("Limit on structure size exceeded: ~S slots requested.", 1, MAKE_FIXNUM(narg)); @@ -90,12 +90,12 @@ ecl_copy_structure(cl_object x) if (!si_structurep(x)) FEwrong_type_argument(@'structure', x); - y = cl_alloc_object(T_STRUCTURE); + y = ecl_alloc_object(T_STRUCTURE); STYPE(y) = STYPE(x); SLENGTH(y) = j = SLENGTH(x); size = sizeof(cl_object)*j; SLOTS(y) = NULL; /* for GC sake */ - SLOTS(y) = (cl_object *)cl_alloc_align(size, sizeof(cl_object)); + SLOTS(y) = (cl_object *)ecl_alloc_align(size, sizeof(cl_object)); memcpy(SLOTS(y), SLOTS(x), size); @(return y) } diff --git a/src/c/symbol.d b/src/c/symbol.d index 2e9514a9d..35b446294 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -116,7 +116,7 @@ cl_make_symbol(cl_object str) str = ecl_type_error(@'make-symbol',"name",str,@'string'); goto AGAIN; } - x = cl_alloc_object(t_symbol); + x = ecl_alloc_object(t_symbol); x->symbol.name = str; x->symbol.dynamic = 0; ECL_SET(x,OBJNULL); @@ -145,7 +145,8 @@ ecl_symbol_value(cl_object s) return s; } else { /* FIXME: Should we check symbol type? */ - cl_object value = SYM_VAL(s); + const cl_env_ptr the_env = ecl_process_env(); + cl_object value = ECL_SYM_VAL(the_env, s); if (value == OBJNULL) FEunbound_variable(s); return value; @@ -288,6 +289,7 @@ cl_symbol_plist(cl_object sym) cl_object cl_get_properties(cl_object place, cl_object indicator_list) { + const cl_env_ptr the_env = ecl_process_env(); cl_object l; #ifdef ECL_SAFE @@ -335,7 +337,7 @@ cl_symbol_name(cl_object x) @ { AGAIN: if (ecl_stringp(prefix)) { - counter = SYM_VAL(@'*gensym-counter*'); + counter = ECL_SYM_VAL(the_env, @'*gensym-counter*'); increment = 1; } else if ((t = type_of(prefix)) == t_fixnum || t == t_bignum) { counter = prefix; @@ -346,17 +348,17 @@ cl_symbol_name(cl_object x) cl_list(3, @'or', @'string', @'integer')); goto AGAIN; } - output = ecl_make_string_output_stream(64); - bds_bind(@'*print-escape*', Cnil); - bds_bind(@'*print-readably*', Cnil); - bds_bind(@'*print-base*', MAKE_FIXNUM(10)); - bds_bind(@'*print-radix*', Cnil); + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', Cnil); + ecl_bds_bind(the_env, @'*print-readably*', Cnil); + ecl_bds_bind(the_env, @'*print-base*', MAKE_FIXNUM(10)); + ecl_bds_bind(the_env, @'*print-radix*', Cnil); si_write_ugly_object(prefix, output); si_write_ugly_object(counter, output); - bds_unwind_n(4); + ecl_bds_unwind_n(the_env, 4); output = cl_make_symbol(cl_get_output_stream_string(output)); if (increment) - ECL_SETQ(@'*gensym-counter*',ecl_one_plus(counter)); + ECL_SETQ(the_env, @'*gensym-counter*',ecl_one_plus(counter)); @(return output); } @) @@ -367,14 +369,14 @@ cl_symbol_name(cl_object x) prefix = ecl_check_type_string(@'gentemp', prefix); pack = si_coerce_to_package(pack); ONCE_MORE: - output = ecl_make_string_output_stream(64); - bds_bind(@'*print-escape*', Cnil); - bds_bind(@'*print-readably*', Cnil); - bds_bind(@'*print-base*', MAKE_FIXNUM(10)); - bds_bind(@'*print-radix*', Cnil); + output = ecl_make_string_output_stream(64, 1); + ecl_bds_bind(the_env, @'*print-escape*', Cnil); + ecl_bds_bind(the_env, @'*print-readably*', Cnil); + ecl_bds_bind(the_env, @'*print-base*', MAKE_FIXNUM(10)); + ecl_bds_bind(the_env, @'*print-radix*', Cnil); si_write_ugly_object(prefix, output); si_write_ugly_object(cl_core.gentemp_counter, output); - bds_unwind_n(4); + ecl_bds_unwind_n(the_env, 4); cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter); s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag); if (intern_flag != 0) @@ -408,6 +410,7 @@ cl_keywordp(cl_object sym) cl_object si_rem_f(cl_object plist, cl_object indicator) { + cl_env_ptr the_env = ecl_process_env(); bool found = remf(&plist, indicator); @(return plist (found? Ct : Cnil)) } diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 0a3e05c5d..e223eefc9 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1369,7 +1369,7 @@ cl_symbols[] = { {KEY_ "UP", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "UPCASE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "USE", KEYWORD, NULL, -1, OBJNULL}, -{KEY_ "USE-HEADER-P", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "CSTREAM", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "VERBOSE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "VERSION", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "WILD", KEYWORD, NULL, -1, OBJNULL}, @@ -1489,7 +1489,6 @@ cl_symbols[] = { {MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL}, {MP_ "WITHOUT-INTERRUPTS", MP_CONSTANT, NULL, -1, OBJNULL}, -{MP_ "CHECK-PENDING-INTERRUPTS", SI_ORDINARY, si_check_pending_interrupts, 0, OBJNULL}, #endif {SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL}, @@ -1707,10 +1706,21 @@ cl_symbols[] = { {EXT_ "FRAME-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "LISP-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "C-STACK", EXT_ORDINARY, NULL, -1, OBJNULL}, -{EXT_ "SET-STACK-SIZE", EXT_ORDINARY, si_set_stack_size, 2, OBJNULL}, +{EXT_ "SET-LIMIT", EXT_ORDINARY, si_set_limit, 2, OBJNULL}, +{EXT_ "GET-LIMIT", EXT_ORDINARY, si_get_limit, 1, OBJNULL}, {EXT_ "SEGMENTATION-VIOLATION", EXT_ORDINARY, NULL, -1, OBJNULL}, {EXT_ "EXTENDED-STRING", EXT_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "CHECK-PENDING-INTERRUPTS", SI_ORDINARY, si_check_pending_interrupts, 0, OBJNULL}, + +{KEY_ "LATIN-1", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "ISO-8859-1", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "UTF-8", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "UCS-2", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "UCS-4", KEYWORD, NULL, -1, OBJNULL}, + +{EXT_ "STORAGE-EXHAUSTED", EXT_ORDINARY, NULL, -1, OBJNULL}, + /* 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 381f43cba..e51559a95 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1369,7 +1369,7 @@ cl_symbols[] = { {KEY_ "UP",NULL}, {KEY_ "UPCASE",NULL}, {KEY_ "USE",NULL}, -{KEY_ "USE-HEADER-P",NULL}, +{KEY_ "CSTREAM",NULL}, {KEY_ "VERBOSE",NULL}, {KEY_ "VERSION",NULL}, {KEY_ "WILD",NULL}, @@ -1489,7 +1489,6 @@ cl_symbols[] = { {MP_ "+LOAD-COMPILE-LOCK+",NULL}, {MP_ "WITH-LOCK",NULL}, {MP_ "WITHOUT-INTERRUPTS",NULL}, -{MP_ "CHECK-PENDING-INTERRUPTS","si_check_pending_interrupts"}, #endif {SYS_ "WHILE",NULL}, @@ -1707,10 +1706,21 @@ cl_symbols[] = { {EXT_ "FRAME-STACK",NULL}, {EXT_ "LISP-STACK",NULL}, {EXT_ "C-STACK",NULL}, -{EXT_ "SET-STACK-SIZE","si_set_stack_size"}, +{EXT_ "SET-LIMIT","si_set_limit"}, +{EXT_ "GET-LIMIT","si_get_limit"}, {EXT_ "SEGMENTATION-VIOLATION",NULL}, {EXT_ "EXTENDED-STRING",NULL}, +{SYS_ "CHECK-PENDING-INTERRUPTS","si_check_pending_interrupts"}, + +{KEY_ "LATIN-1",NULL}, +{KEY_ "ISO-8859-1",NULL}, +{KEY_ "UTF-8",NULL}, +{KEY_ "UCS-2",NULL}, +{KEY_ "UCS-4",NULL}, + +{EXT_ "STORAGE-EXHAUSTED",NULL}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/c/tcp.d b/src/c/tcp.d index 5fd61a41c..3de268cf7 100644 --- a/src/c/tcp.d +++ b/src/c/tcp.d @@ -123,6 +123,7 @@ int connect_to_server(char *host, int port) if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0) return(0); /* errno set by system call. */ + ecl_disable_interrupts(); #ifdef TCP_NODELAY /* make sure to turn off TCP coalescence */ #if defined(_MSC_VER) || defined(mingw32) @@ -135,20 +136,15 @@ int connect_to_server(char *host, int port) } #endif #endif - start_critical_section(); if (connect(fd, addr, addrlen) == -1) { #if defined(_MSC_VER) || defined(mingw32) closesocket(fd); #else (void) close (fd); #endif - end_critical_section(); - return(0); /* errno set by system call. */ + fd = 0; } - /* - * Return the id if the connection succeeded. - */ - end_critical_section(); + ecl_enable_interrupts(); return(fd); } @@ -279,17 +275,17 @@ si_open_client_stream(cl_object host, cl_object port) if (host->base_string.fillp > BUFSIZ - 1) FEerror("~S is a too long file name.", 1, host); - start_critical_section(); - fd = connect_to_server(host->base_string.self, fix(port)); - end_critical_section(); + ecl_disable_interrupts(); + fd = connect_to_server((char*)host->base_string.self, fix(port)); + ecl_enable_interrupts(); if (fd == 0) @(return Cnil) #if defined(_MSC_VER) || defined(mingw32) - stream = ecl_make_stream_from_fd(host, fd, smm_io_wsock); + stream = ecl_make_stream_from_fd(host, fd, smm_io_wsock, 8, 0); #else - stream = ecl_make_stream_from_fd(host, fd, smm_io); + stream = ecl_make_stream_from_fd(host, fd, smm_io, 8, 0); #endif @(return stream) @@ -302,17 +298,12 @@ si_open_server_stream(cl_object port) cl_index p; cl_object output; - start_critical_section(); p = ecl_fixnum_in_range(@'si::open-client-stream',"port",port,0,65535); + ecl_disable_interrupts(); fd = create_server_port(p); - end_critical_section(); + ecl_enable_interrupts(); - if (fd == 0) - output = Cnil; - else { - output = ecl_make_stream_from_fd(Cnil, fd, smm_io); - } - @(return output) + @(return ((fd == 0)? Cnil : ecl_make_stream_from_fd(Cnil, fd, smm_io, 8, 0))) } /************************************************************ @@ -350,7 +341,7 @@ si_open_unix_socket_stream(cl_object path) @(return Cnil) } - @(return ecl_make_stream_from_fd(path, fd, smm_io)) + @(return ecl_make_stream_from_fd(path, fd, smm_io, 8, 0)) #endif } @@ -360,6 +351,7 @@ si_open_unix_socket_stream(cl_object path) cl_object si_lookup_host_entry(cl_object host_or_address) { + const cl_env_ptr the_env = ecl_process_env(); struct hostent *he; unsigned long l; char address[4]; @@ -371,7 +363,7 @@ si_lookup_host_entry(cl_object host_or_address) switch (type_of(host_or_address)) { case t_base_string: host_or_address = si_copy_to_simple_base_string(host_or_address); - he = gethostbyname(host_or_address->base_string.self); + he = gethostbyname((char*)host_or_address->base_string.self); break; case t_fixnum: l = fix(host_or_address); diff --git a/src/c/threads.d b/src/c/threads.d index 5273d69a2..8c2b5f0be 100644 --- a/src/c/threads.d +++ b/src/c/threads.d @@ -31,30 +31,67 @@ # include #endif +#if defined(_MSVC) || defined(mingw32) +#define ECL_WINDOWS_THREADS +/* + * We have to put this explicit definition here because Boehm GC + * is designed to produce a DLL and we rather want a static + * reference + */ +#include +#include +extern HANDLE WINAPI GC_CreateThread( + LPSECURITY_ATTRIBUTES lpThreadAttributes, + DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress, + LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId ); +#ifndef WITH___THREAD +DWORD cl_env_key; +#endif +static DWORD main_thread; +#else #ifndef WITH___THREAD static pthread_key_t cl_env_key; #endif - static pthread_t main_thread; +#endif extern void ecl_init_env(struct cl_env_struct *env); -#ifndef WITH___THREAD -struct cl_env_struct * +#if !defined(WITH___THREAD) +cl_env_ptr ecl_process_env(void) { +#ifdef ECL_WINDOWS_THREADS + return TlsGetValue(cl_env_key); +#else struct cl_env_struct *rv = pthread_getspecific(cl_env_key); if (rv) return rv; FElibc_error("pthread_getspecific() failed.", 0); return NULL; +#endif } #endif +static void +ecl_set_process_env(cl_env_ptr env) +{ +#ifdef WITH___THREAD + cl_env_p = env; +#else +# ifdef ECL_WINDOWS_THREADS + TlsSetValue(cl_env_key, env); +# else + if (pthread_setspecific(cl_env_key, env)) + FElibc_error("pthread_setcspecific() failed.", 0); +# endif +#endif +} + cl_object mp_current_process(void) { - return cl_env.own_process; + return ecl_process_env()->own_process; } /*---------------------------------------------------------------------- @@ -82,7 +119,7 @@ thread_cleanup(void *env) * mp_process_kill(). */ THREAD_OP_LOCK(); - cl_core.processes = ecl_remove_eq(cl_env.own_process, + cl_core.processes = ecl_remove_eq(mp_current_process(), cl_core.processes); THREAD_OP_UNLOCK(); } @@ -90,46 +127,49 @@ thread_cleanup(void *env) static void * thread_entry_point(cl_object process) { + cl_env_ptr env = process->process.env; + /* 1) Setup the environment for the execution of the thread */ - pthread_cleanup_push(thread_cleanup, (void *)process->process.env); -#ifdef WITH___THREAD - cl_env_p = process->process.env; -#else - if (pthread_setspecific(cl_env_key, process->process.env)) - FElibc_error("pthread_setcspecific() failed.", 0); -#endif - ecl_init_env(process->process.env); - init_big_registers(); + pthread_cleanup_push(thread_cleanup, (void *)env); + ecl_init_env(env); + init_big_registers(env); + ecl_set_process_env(env); + ecl_enable_interrupts_env(env); /* 2) Execute the code. The CATCH_ALL point is the destination * provides us with an elegant way to exit the thread: we just * do an unwind up to frs_top. */ process->process.active = 1; - CL_CATCH_ALL_BEGIN { - bds_bind(@'mp::*current-process*', process); + CL_CATCH_ALL_BEGIN(env) { + ecl_bds_bind(env, @'mp::*current-process*', process); cl_apply(2, process->process.function, process->process.args); - bds_unwind1(); + ecl_bds_unwind1(env); } CL_CATCH_ALL_END; process->process.active = 0; /* 3) If everything went right, we should be exiting the thread * through this point. thread_cleanup is automatically invoked. */ +#ifdef ECL_WINDOWS_THREADS + thread_cleanup(env); + return 1; +#else pthread_cleanup_pop(1); return NULL; +#endif } static cl_object alloc_process(cl_object name) { - cl_object process = cl_alloc_object(t_process); + cl_object process = ecl_alloc_object(t_process); process->process.active = 0; process->process.name = name; process->process.function = Cnil; process->process.args = Cnil; process->process.interrupt = Cnil; - process->process.env = cl_alloc(sizeof(*process->process.env)); + process->process.env = _ecl_alloc_env(); process->process.env->own_process = process; return process; } @@ -137,6 +177,7 @@ alloc_process(cl_object name) static void initialize_process_bindings(cl_object process, cl_object initial_bindings) { + const cl_env_ptr this_env = ecl_process_env(); cl_object hash; /* FIXME! Here we should either use INITIAL-BINDINGS or copy lexical * bindings */ @@ -146,7 +187,7 @@ initialize_process_bindings(cl_object process, cl_object initial_bindings) ecl_make_singlefloat(0.7), Cnil); /* no need for locking */ } else { - hash = si_copy_hash_table(cl_env.bindings_hash); + hash = si_copy_hash_table(this_env->bindings_hash); } process->process.env->bindings_hash = hash; } @@ -155,15 +196,12 @@ void ecl_import_current_thread(cl_object name, cl_object bindings) { cl_object process = alloc_process(name); -#ifdef WITH___THREAD - cl_env_p = process->process.env; -#else - if (pthread_setspecific(cl_env_key, process->process.env)) - FElibc_error("pthread_setcspecific() failed.", 0); -#endif + cl_env_ptr env = process->process.env; initialize_process_bindings(process, bindings); - ecl_init_env(&cl_env); - init_big_registers(); + ecl_init_env(env); + init_big_registers(env); + ecl_set_process_env(env); + ecl_enable_interrupts_env(env); } void @@ -198,17 +236,34 @@ mp_interrupt_process(cl_object process, cl_object function) { if (mp_process_active_p(process) == Cnil) FEerror("Cannot interrupt the inactive process ~A", 1, process); +#ifdef ECL_WINDOWS_THREADS + { + CONTEXT context; + HANDLE thread = process->process.thread; + if (SuspendThread(thread) == (DWORD)-1) + FEwin32_error("Cannot suspend process ~A", 1, process); + context.ContextFlags = CONTEXT_CONTROL | CONTEXT_INTEGER; + if (!GetThreadContext(thread, &context)) + FEwin32_error("Cannot get context for process ~A", 1, process); + context.Eip = process_interrupt_handler; + if (!SetThreadContext(thread, &context)) + FEwin32_error("Cannot set context for process ~A", 1, process); + process->process.interrupt = function; + if (ResumeThread(thread) == (DWORD)-1) + FEwin32_error("Cannot resume process ~A", 1, process); + } +#else process->process.interrupt = function; if ( pthread_kill(process->process.thread, SIGUSR1) ) FElibc_error("pthread_kill() failed.", 0); +#endif @(return Ct) } cl_object mp_process_kill(cl_object process) { - mp_interrupt_process(process, @'mp::exit-process'); - @(return Ct) + return mp_interrupt_process(process, @'mp::exit-process'); } cl_object @@ -217,7 +272,11 @@ mp_process_yield(void) #ifdef HAVE_SCHED_YIELD sched_yield(); #else +# if defined(_MSVC) || defined(mingw32) + Sleep(0); +# else sleep(0); /* Use sleep(0) to yield to a >= priority thread */ +# endif #endif @(return) } @@ -225,6 +284,25 @@ mp_process_yield(void) cl_object mp_process_enable(cl_object process) { + cl_object output; +#ifdef ECL_WINDOWS_THREADS + HANDLE code; + DWORD threadId; + + if (mp_process_active_p(process) != Cnil) + FEerror("Cannot enable the running process ~A.", 1, process); + THREAD_OP_LOCK(); + code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); + if (code) { + /* If everything went ok, add the thread to the list. */ + cl_core.processes = CONS(process, cl_core.processes); + output = process; + } else { + output = Cnil; + } + process->process.thread = code; + THREAD_OP_UNLOCK(); +#else pthread_t *posix_thread; int code; @@ -232,18 +310,27 @@ mp_process_enable(cl_object process) FEerror("Cannot enable the running process ~A.", 1, process); THREAD_OP_LOCK(); code = pthread_create(&process->process.thread, NULL, thread_entry_point, process); - if (!code) { + if (code) { + output = Cnil; + } else { /* If everything went ok, add the thread to the list. */ cl_core.processes = CONS(process, cl_core.processes); + output = process; } /* FIXME: how to do FElibc_error() without leaving a lock? */ THREAD_OP_UNLOCK(); - @(return (code? Cnil : process)) +#endif + @(return output) } cl_object mp_exit_process(void) { - if (pthread_equal(pthread_self(), main_thread)) { +#ifdef ECL_WINDOWS_THREADS + int same = GetCurrentThreadId() == main_thread; +#else + int same = pthread_equal(pthread_self(), main_thread); +#endif + if (same) { /* This is the main thread. Quitting it means exiting the program. */ si_quit(0); @@ -252,14 +339,16 @@ mp_exit_process(void) back to the thread entry point, going through all possible UNWIND-PROTECT. */ - ecl_unwind(cl_env.frs_org); + const cl_env_ptr env = ecl_process_env(); + ecl_unwind(env, env->frs_org); } } cl_object mp_all_processes(void) { - /* Isn't it a race condition? */ + /* No race condition here because this list is never destructively + * modified. When we add or remove processes, we create new lists. */ @(return cl_copy_list(cl_core.processes)) } @@ -310,8 +399,15 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) pthread_mutexattr_t attr; cl_object output; @ + output = ecl_alloc_object(t_lock); +#ifdef ECL_WINDOWS_THREADS + output->lock.name = name; + output->lock.mutex = CreateMutex(NULL, FALSE, NULL); + output->lock.holder = Cnil; + output->lock.counter = 0; + output->lock.recursive = (recursive != Cnil); +#else pthread_mutexattr_init(&attr); - output = cl_alloc_object(t_lock); output->lock.name = name; output->lock.holder = Cnil; output->lock.counter = 0; @@ -324,6 +420,7 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) } pthread_mutex_init(&output->lock.mutex, &attr); pthread_mutexattr_destroy(&attr); +#endif si_set_finalizer(output, Ct); @(return output) @) @@ -355,17 +452,23 @@ mp_lock_holder(cl_object lock) cl_object mp_giveup_lock(cl_object lock) { + cl_object own_process = mp_current_process(); int code; if (type_of(lock) != t_lock) FEwrong_type_argument(@'mp::lock', lock); - if (lock->lock.holder != cl_env.own_process) { + if (lock->lock.holder != own_process) { FEerror("Attempt to give up a lock ~S that is not owned by ~S.", 2, - lock, cl_env.own_process); + lock, own_process); } if (--lock->lock.counter == 0) { lock->lock.holder = Cnil; } +#ifdef ECL_WINDOWS_THREADS + if (ReleaseMutex(lock->lock.mutex) == 0) + FEwin32_error("Unable to release Win32 Mutex", 0); +#else pthread_mutex_unlock(&lock->lock.mutex); +#endif @(return Ct) } @@ -375,22 +478,42 @@ mp_giveup_lock(cl_object lock) @ if (type_of(lock) != t_lock) FEwrong_type_argument(@'mp::lock', lock); + /* In Windows, all locks are recursive. We simulate the other case. */ /* We will complain always if recursive=0 and try to lock recursively. */ - if (!lock->lock.recursive && (lock->lock.holder == cl_env.own_process)) { + if (!lock->lock.recursive && (lock->lock.holder == the_env->own_process)) { FEerror("A recursive attempt was made to hold lock ~S", 1, lock); } +#ifdef ECL_WINDOWS_THREADS + switch (WaitForSingleObject(lock->lock.mutex, (wait==Ct?INFINITE:0))) { + case WAIT_OBJECT_0: + lock->lock.holder = env->own_process; + lock->lock.counter++; + output = Ct; + break; + case WAIT_TIMEOUT: + output = Cnil; + break; + case WAIT_ABANDONED: + ecl_internal_error(""); + break; + case WAIT_FAILED: + FEwin32_error("Unable to lock Win32 Mutex", 0); + break; + } +#else if (wait == Ct) { rc = pthread_mutex_lock(&lock->lock.mutex); } else { rc = pthread_mutex_trylock(&lock->lock.mutex); } if (rc == 0) { - lock->lock.holder = cl_env.own_process; + lock->lock.holder = the_env->own_process; lock->lock.counter++; output = Ct; } else { output = Cnil; } +#endif @(return output) @) @@ -401,33 +524,45 @@ mp_giveup_lock(cl_object lock) cl_object mp_make_condition_variable(void) { +#ifdef ECL_WINDOWS_THREADS + FEerror("Condition variables are not supported under Windows.", 0); + @(return Cnil) +#else pthread_condattr_t attr; cl_object output; pthread_condattr_init(&attr); - output = cl_alloc_object(t_condition_variable); + output = ecl_alloc_object(t_condition_variable); pthread_cond_init(&output->condition_variable.cv, &attr); pthread_condattr_destroy(&attr); si_set_finalizer(output, Ct); @(return output) +#endif } cl_object mp_condition_variable_wait(cl_object cv, cl_object lock) { +#ifdef ECL_WINDOWS_THREADS + FEerror("Condition variables are not supported under Windows.", 0); +#else if (type_of(cv) != t_condition_variable) FEwrong_type_argument(@'mp::condition-variable', cv); if (type_of(lock) != t_lock) FEwrong_type_argument(@'mp::lock', lock); if (pthread_cond_wait(&cv->condition_variable.cv, &lock->lock.mutex) == 0) - lock->lock.holder = cl_env.own_process; + lock->lock.holder = mp_current_process(); +#endif @(return Ct) } cl_object mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) { +#ifdef ECL_WINDOWS_THREADS + FEerror("Condition variables are not supported under Windows.", 0); +#else int rc; double r; struct timespec ts; @@ -443,7 +578,6 @@ mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) make_constant_base_string("Not a non-negative number ~S"), @':format-arguments', cl_list(1, seconds), @':expected-type', @'real', @':datum', seconds); - gettimeofday(&tp, NULL); /* Convert from timeval to timespec */ ts.tv_sec = tp.tv_sec; @@ -459,28 +593,37 @@ mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) } if (pthread_cond_timedwait(&cv->condition_variable.cv, &lock->lock.mutex, &ts) == 0) { - lock->lock.holder = cl_env.own_process; + lock->lock.holder = mp_current_process(); @(return Ct) } else { @(return Cnil) } +#endif } cl_object mp_condition_variable_signal(cl_object cv) { +#ifdef ECL_WINDOWS_THREADS + FEerror("Condition variables are not supported under Windows.", 0); +#else if (type_of(cv) != t_condition_variable) FEwrong_type_argument(@'mp::condition-variable', cv); pthread_cond_signal(&cv->condition_variable.cv); +#endif @(return Ct) } cl_object mp_condition_variable_broadcast(cl_object cv) { +#ifdef ECL_WINDOWS_THREADS + FEerror("Condition variables are not supported under Windows.", 0); +#else if (type_of(cv) != t_condition_variable) FEwrong_type_argument(@'mp::condition-variable', cv); pthread_cond_broadcast(&cv->condition_variable.cv); +#endif @(return Ct) } @@ -489,37 +632,44 @@ mp_condition_variable_broadcast(cl_object cv) */ void -init_threads() +init_threads(cl_env_ptr env) { cl_object process; - struct cl_env_struct *env; pthread_mutexattr_t attr; cl_core.processes = OBJNULL; +#ifdef ECL_WINDOWS_THREADS + cl_core.global_lock = CreateMutex(NULL, FALSE, NULL); +#else pthread_mutexattr_init(&attr); pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_ERRORCHECK_NP); pthread_mutex_init(&cl_core.global_lock, &attr); pthread_mutexattr_destroy(&attr); +#endif - process = cl_alloc_object(t_process); + 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 = cl_alloc(sizeof(*env)); + process->process.env = env; -#ifdef WITH___THREAD - cl_env_p = env; -#else - if (pthread_key_create(&cl_env_key, NULL) < 0) { - ecl_internal_error("Unable to create the thread local storage."); - } - pthread_setspecific(cl_env_key, env); -#endif env->own_process = process; +#if !defined(WITH___THREAD) +# if defined(ECL_WINDOWS_THREADS) + cl_env_key = TlsAlloc(); +# else + pthread_key_create(&cl_env_key, NULL); +# endif +#endif + ecl_set_process_env(env); cl_core.processes = ecl_list1(process); +#ifdef ECL_WINDOWS_THREADS + main_thread = GetCurrentThreadId(); +#else main_thread = pthread_self(); +#endif } diff --git a/src/c/threads_win32.d b/src/c/threads_win32.d deleted file mode 100644 index db99e264d..000000000 --- a/src/c/threads_win32.d +++ /dev/null @@ -1,488 +0,0 @@ -/* -*- mode: c; c-basic-offset: 8 -*- */ -/* - threads.d -- Posix threads with support from GCC. -*/ -/* - Copyright (c) 2003, Juan Jose Garcia Ripoll. - - ECL 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. -*/ -/* - * IMPORTANT!!!! IF YOU EDIT THIS FILE, CHANGE ALSO threads.d - */ - -#include -#include -#include -#ifdef HAVE_SCHED_YIELD -# include -#endif - -/* - * We have to put this explicit definition here because Boehm GC - * is designed to produce a DLL and we rather want a static - * reference - */ -#include -#include -extern HANDLE WINAPI GC_CreateThread( - LPSECURITY_ATTRIBUTES lpThreadAttributes, - DWORD dwStackSize, LPTHREAD_START_ROUTINE lpStartAddress, - LPVOID lpParameter, DWORD dwCreationFlags, LPDWORD lpThreadId ); -#ifndef WITH___THREAD -DWORD cl_env_key; -#endif - -static DWORD main_thread; - -extern void ecl_init_env(struct cl_env_struct *env); - -#ifndef WITH___THREAD -struct cl_env_struct * -ecl_process_env(void) -{ - return TlsGetValue(cl_env_key); -} -#endif - -cl_object -mp_current_process(void) -{ - return cl_env.own_process; -} - -/*---------------------------------------------------------------------- - * THREAD OBJECT - */ - -static void -assert_type_process(cl_object o) -{ - if (type_of(o) != t_process) - FEwrong_type_argument(@'mp::process', o); -} - -static void -thread_cleanup(void *env) -{ - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - THREAD_OP_LOCK(); - cl_core.processes = ecl_remove_eq(cl_env.own_process, - cl_core.processes); - THREAD_OP_UNLOCK(); -} - -static DWORD WINAPI -thread_entry_point(cl_object process) -{ - /* 1) Setup the environment for the execution of the thread */ -#ifdef WITH___THREAD - cl_env_p = process->process.env -#else - TlsSetValue(cl_env_key, (void *)process->process.env); -#endif - ecl_init_env(process->process.env); - init_big_registers(); - - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - process->process.active = 1; - CL_CATCH_ALL_BEGIN { - bds_bind(@'mp::*current-process*', process); - cl_apply(2, process->process.function, process->process.args); - bds_unwind1(); - } CL_CATCH_ALL_END; - process->process.active = 0; - - /* 3) If everything went right, we should be exiting the thread - * through this point. - */ - thread_cleanup(&cl_env); - return 1; -} - -static cl_object -alloc_process(cl_object name) -{ - cl_object process = cl_alloc_object(t_process); - process->process.active = 0; - process->process.name = name; - process->process.function = Cnil; - process->process.args = Cnil; - process->process.interrupt = Cnil; - process->process.env = cl_alloc(sizeof(*process->process.env)); - process->process.env->own_process = process; - return process; -} - -static void -initialize_process_bindings(cl_object process, cl_object initial_bindings) -{ - cl_object hash; - /* FIXME! Here we should either use INITIAL-BINDINGS or copy lexical - * bindings */ - if (initial_bindings != OBJNULL) { - hash = cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), - ecl_make_singlefloat(1.5), - ecl_make_singlefloat(0.7), - Cnil); /* no need for locking */ - } else { - hash = si_copy_hash_table(cl_env.bindings_hash); - } - process->process.env->bindings_hash = hash; -} - -void -ecl_import_current_thread(cl_object name, cl_object bindings) -{ - cl_object process = alloc_process(name); -#ifdef WITH___THREAD - cl_env_p = process->process.env; -#else - TlsSetValue(cl_env_key, (void *)process->process.env); -#endif - initialize_process_bindings(process, bindings); - ecl_init_env(&cl_env); - init_big_registers(); -} - -void -ecl_release_current_thread(void) -{ - thread_cleanup(&cl_env); -} - -@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) Ct)) - cl_object process; -@ - process = alloc_process(name); - initialize_process_bindings(process, initial_bindings); - @(return process) -@) - -cl_object -mp_process_preset(cl_narg narg, cl_object process, cl_object function, ...) -{ - cl_va_list args; - cl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@'mp::process-preset'); - assert_type_process(process); - process->process.function = function; - process->process.args = cl_grab_rest_args(args); - @(return process) -} - -static void -process_interrupt_handler(void) -{ - funcall(1, ecl_process_env()->own_process->process.interrupt); -} - -cl_object -mp_interrupt_process(cl_object process, cl_object function) -{ - CONTEXT context; - HANDLE thread = process->process.thread; - - if (mp_process_active_p(process) == Cnil) - FEerror("Cannot interrupt the inactive process ~A", 1, process); - if (SuspendThread(thread) == (DWORD)-1) - FEwin32_error("Cannot suspend process ~A", 1, process); - context.ContextFlags = CONTEXT_CONTROL | CONTEXT_INTEGER; - if (!GetThreadContext(thread, &context)) - FEwin32_error("Cannot get context for process ~A", 1, process); - context.Eip = process_interrupt_handler; - if (!SetThreadContext(thread, &context)) - FEwin32_error("Cannot set context for process ~A", 1, process); - process->process.interrupt = function; - if (ResumeThread(thread) == (DWORD)-1) - FEwin32_error("Cannot resume process ~A", 1, process); - @(return Ct) -} - -cl_object -mp_process_kill(cl_object process) -{ - return mp_interrupt_process(process, @'mp::exit-process'); -} - -cl_object -mp_process_yield(void) -{ -#ifdef HAVE_SCHED_YIELD - sched_yield(); -#else - Sleep(0); /* Use sleep(0) to yield to a >= priority thread */ -#endif - @(return) -} - -cl_object -mp_process_enable(cl_object process) -{ - HANDLE code; - DWORD threadId; - - if (mp_process_active_p(process) != Cnil) - FEerror("Cannot enable the running process ~A.", 1, process); - THREAD_OP_LOCK(); - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - if (code) { - /* If everything went ok, add the thread to the list. */ - cl_core.processes = CONS(process, cl_core.processes); - } - process->process.thread = code; - THREAD_OP_UNLOCK(); - @(return (code==NULL ? Cnil : process)) -} - -cl_object -mp_exit_process(void) -{ - if (GetCurrentThreadId() == main_thread) { - /* This is the main thread. Quitting it means exiting the - program. */ - si_quit(0); - } else { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ - ecl_unwind(cl_env.frs_org); - } -} - -cl_object -mp_all_processes(void) -{ - @(return cl_copy_list(cl_core.processes)) -} - -cl_object -mp_process_name(cl_object process) -{ - assert_type_process(process); - @(return process->process.name) -} - -cl_object -mp_process_active_p(cl_object process) -{ - assert_type_process(process); - @(return (process->process.active? Ct : Cnil)) -} - -cl_object -mp_process_whostate(cl_object process) -{ - assert_type_process(process); - @(return (cl_core.null_string)) -} - -cl_object -mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) -{ - cl_object process; - cl_va_list args; - cl_va_start(args, function, narg, 2); - if (narg < 2) - FEwrong_num_arguments(@'mp::process-run-function'); - if (CONSP(name)) { - process = cl_apply(2, @'mp::make-process', name); - } else { - process = mp_make_process(2, @':name', name); - } - cl_apply(4, @'mp::process-preset', process, function, - cl_grab_rest_args(args)); - return mp_process_enable(process); -} - -/*---------------------------------------------------------------------- - * LOCKS or MUTEX - */ - -@(defun mp::make-lock (&key name ((:recursive recursive) Ct)) - cl_object output; -@ - output = cl_alloc_object(t_lock); - output->lock.name = name; - output->lock.mutex = CreateMutex(NULL, FALSE, NULL); - output->lock.holder = Cnil; - output->lock.counter = 0; - output->lock.recursive = (recursive != Cnil); - si_set_finalizer(output, Ct); - @(return output) -@) - -cl_object -mp_recursive_lock_p(cl_object lock) -{ - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - @(return (lock->lock.recursive? Ct : Cnil)) -} - -cl_object -mp_lock_name(cl_object lock) -{ - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - @(return lock->lock.name) -} - -cl_object -mp_lock_holder(cl_object lock) -{ - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - @(return lock->lock.holder) -} - -cl_object -mp_giveup_lock(cl_object lock) -{ - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - if (lock->lock.holder != cl_env.own_process) { - FEerror("Attempt to give up a lock ~S that is not owned by ~S.", 2, - lock, cl_env.own_process); - } - if (--lock->lock.counter == 0) { - lock->lock.holder = Cnil; - } - if (ReleaseMutex(lock->lock.mutex) == 0) - FEwin32_error("Unable to release Win32 Mutex", 0); - @(return Ct) -} - -@(defun mp::get-lock (lock &optional (wait Ct)) - cl_object output; -@ - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - /* In Windows, all locks are recursive. We simulate the other case. */ - if (!lock->lock.recursive && (lock->lock.holder == cl_env.own_process)) { - FEerror("A recursive attempt was made to hold lock ~S", 1, lock); - } - switch (WaitForSingleObject(lock->lock.mutex, (wait==Ct?INFINITE:0))) { - case WAIT_OBJECT_0: - lock->lock.holder = cl_env.own_process; - lock->lock.counter++; - output = Ct; - break; - case WAIT_TIMEOUT: - output = Cnil; - break; - case WAIT_ABANDONED: - ecl_internal_error(""); - break; - case WAIT_FAILED: - FEwin32_error("Unable to lock Win32 Mutex", 0); - break; - } - @(return output) -@) - -/*---------------------------------------------------------------------- - * CONDITION VARIABLES - */ - -cl_object -mp_make_condition_variable(void) -{ - FEerror("Condition variables are not supported under Windows.", 0); - @(return Cnil) -} - -cl_object -mp_condition_variable_wait(cl_object cv, cl_object lock) -{ - if (type_of(cv) != t_condition_variable) - FEwrong_type_argument(@'mp::condition-variable', cv); - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - FEerror("Condition variables are not supported under Windows.", 0); - @(return Ct) -} - -cl_object -mp_condition_variable_timedwait(cl_object cv, cl_object lock, cl_object seconds) -{ - if (type_of(cv) != t_condition_variable) - FEwrong_type_argument(@'mp::condition-variable', cv); - if (type_of(lock) != t_lock) - FEwrong_type_argument(@'mp::lock', lock); - FEerror("Condition variables are not supported under Windows.", 0); - @(return Cnil) -} - -cl_object -mp_condition_variable_signal(cl_object cv) -{ - if (type_of(cv) != t_condition_variable) - FEwrong_type_argument(@'mp::condition-variable', cv); - FEerror("Condition variables are not supported under Windows.", 0); - @(return Ct) -} - -cl_object -mp_condition_variable_broadcast(cl_object cv) -{ - if (type_of(cv) != t_condition_variable) - FEwrong_type_argument(@'mp::condition-variable', cv); - FEerror("Condition variables are not supported under Windows.", 0); - @(return Ct) -} - -/*---------------------------------------------------------------------- - * INITIALIZATION - */ - -void -init_threads() -{ - cl_object process; - struct cl_env_struct *env; - - GC_INIT(); - - cl_core.processes = OBJNULL; - cl_core.global_lock = CreateMutex(NULL, FALSE, NULL); - - process = cl_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 = GetCurrentThread(); - process->process.env = env = (struct cl_env_struct*)cl_alloc(sizeof(*env)); - -#ifdef WITH___THREAD - cl_env_p = env -#else - cl_env_key = TlsAlloc(); - TlsSetValue(cl_env_key, env); -#endif - env->own_process = process; - - cl_core.processes = CONS(process, Cnil); - - main_thread = GetCurrentThreadId(); -} diff --git a/src/c/typespec.d b/src/c/typespec.d index 776c4557d..d1861fc92 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -75,7 +75,7 @@ void FEcircular_list(cl_object x) { /* FIXME: Is this the right way to rebind it? */ - bds_bind(@'*print-circle*', Ct); + ecl_bds_bind(ecl_process_env(), @'*print-circle*', Ct); cl_error(9, @'simple-type-error', @':format-control', make_constant_base_string("Circular list ~D"), @':format-arguments', cl_list(1, x), diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index bfa9ee818..2f6701b08 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -50,6 +50,38 @@ #endif #include +static int +safe_chdir(const char *path) +{ + int output; + ecl_disable_interrupts(); + output = chdir(path); + ecl_enable_interrupts(); + return output; +} + +static int +safe_stat(const char *path, struct stat *sb) +{ + int output; + ecl_disable_interrupts(); + output = stat(path, sb); + ecl_enable_interrupts(); + return output; +} + +#ifdef HAVE_LSTAT +static int +safe_lstat(const char *path, struct stat *sb) +{ + int output; + ecl_disable_interrupts(); + output = lstat(path, sb); + ecl_enable_interrupts(); + return output; +} +#endif + #if defined(_MSC_VER) || defined(mingw32) static void change_drive(cl_object pathname) @@ -57,7 +89,7 @@ change_drive(cl_object pathname) if (pathname->pathname.device != Cnil) { char device[3] = {'\0', ':', '\0'}; device[0] = pathname->pathname.device->base_string.self[0]; - if (chdir(device) < 0) { + if (safe_chdir(device) < 0) { FElibc_error("Can't change the current drive to ~S", 1, pathname->pathname.device); } @@ -86,24 +118,26 @@ current_dir(void) { cl_object output; const char *ok; #ifdef _MSC_VER - char *c; + unsigned char *c; #endif cl_index size = 128; do { - output = cl_alloc_adjustable_base_string(size); - ok = getcwd(output->base_string.self, size); - size += 256; - } while(ok == NULL); - size = strlen(output->base_string.self); + output = cl_alloc_adjustable_base_string(size); + ecl_disable_interrupts(); + ok = getcwd((char*)output->base_string.self, size); + ecl_enable_interrupts(); + size += 256; + } while (ok == NULL); + size = strlen((char*)output->base_string.self); if ((size + 1 /* / */ + 1 /* 0 */) >= output->base_string.dim) { - /* Too large to host the trailing '/' */ - cl_object other = cl_alloc_adjustable_base_string(size+2); - strcpy(other->base_string.self, output->base_string.self); - output = other; + /* Too large to host the trailing '/' */ + cl_object other = cl_alloc_adjustable_base_string(size+2); + strcpy((char*)other->base_string.self, (char*)output->base_string.self); + output = other; } #ifdef _MSC_VER - for (c=output->base_string.self; *c; c++) + for (c = output->base_string.self; *c; c++) if (*c == '\\') *c = '/'; #endif @@ -121,38 +155,44 @@ current_dir(void) { static cl_object file_kind(char *filename, bool follow_links) { + cl_object output; #if defined(_MSC_VER) || defined(mingw32) - DWORD dw = GetFileAttributes( filename ); + DWORD dw; + ecl_disable_interrupts(); + dw = GetFileAttributes( filename ); if (dw == -1) - return Cnil; + output = Cnil; else if ( dw & FILE_ATTRIBUTE_DIRECTORY ) - return @':directory'; + output = @':directory'; else - return @':file'; + output = @':file'; + ecl_enable_interrupts(); #else struct stat buf; -#ifdef HAVE_LSTAT - if ((follow_links? stat : lstat)(filename, &buf) < 0) -#else - if (stat(filename, &buf) < 0) -#endif - return Cnil; -#ifdef HAVE_LSTAT - if (S_ISLNK(buf.st_mode)) - return @':link'; -#endif - if (S_ISDIR(buf.st_mode)) - return @':directory'; - if (S_ISREG(buf.st_mode)) - return @':file'; - return @':special'; +# ifdef HAVE_LSTAT + if ((follow_links? safe_stat : safe_lstat)(filename, &buf) < 0) +# else + if (safe_stat(filename, &buf) < 0) +# endif + output = Cnil; +# ifdef HAVE_LSTAT + else if (S_ISLNK(buf.st_mode)) + output = @':link'; +# endif + else if (S_ISDIR(buf.st_mode)) + output = @':directory'; + else if (S_ISREG(buf.st_mode)) + output = @':file'; + else + output = @':special'; #endif + return output; } cl_object si_file_kind(cl_object filename, cl_object follow_links) { filename = si_coerce_to_filename(filename); - @(return file_kind(filename->base_string.self, !Null(follow_links))) + @(return file_kind((char*)filename->base_string.self, !Null(follow_links))) } #if defined(HAVE_LSTAT) && !defined(mingw32) && !defined(_MSV_VER) @@ -164,11 +204,14 @@ si_readlink(cl_object filename) { cl_object output, kind; do { output = cl_alloc_adjustable_base_string(size); - written = readlink(filename->base_string.self, output->base_string.self, size); + ecl_disable_interrupts(); + written = readlink((char*)filename->base_string.self, + (char*)output->base_string.self, size); + ecl_enable_interrupts(); size += 256; - } while(written == size); + } while (written == size); output->base_string.self[written] = '\0'; - kind = file_kind(output->base_string.self, FALSE); + kind = file_kind((char*)output->base_string.self, FALSE); if (kind == @':directory') { output->base_string.self[written++] = '/'; output->base_string.self[written] = '\0'; @@ -187,6 +230,7 @@ si_readlink(cl_object filename) { cl_object cl_truename(cl_object orig_pathname) { + const cl_env_ptr the_env = ecl_process_env(); cl_object dir; cl_object previous = current_dir(); @@ -201,11 +245,11 @@ cl_truename(cl_object orig_pathname) * then we resolve the value of the symlink and continue traversing * the filesystem. */ - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(the_env) { cl_object kind, filename; BEGIN: filename = si_coerce_to_filename(pathname); - kind = file_kind(filename->base_string.self, FALSE); + kind = file_kind((char*)filename->base_string.self, FALSE); if (kind == Cnil) { FEcannot_open(orig_pathname); #ifdef HAVE_LSTAT @@ -227,17 +271,17 @@ cl_truename(cl_object orig_pathname) { cl_object part = CAR(dir); if (type_of(part) == t_base_string) { - if (chdir(part->base_string.self) < 0) { + if (safe_chdir((char*)part->base_string.self) < 0) { ERROR: FElibc_error("Can't change the current directory to ~S", 1, pathname); } } else if (part == @':absolute') { - if (chdir("/") < 0) + if (safe_chdir("/") < 0) goto ERROR; } else if (part == @':relative') { /* Nothing to do */ } else if (part == @':up') { - if (chdir("..") < 0) + if (safe_chdir("..") < 0) goto ERROR; } else { FEerror("~S is not allowed in TRUENAME", 1, part); @@ -253,39 +297,46 @@ ERROR: FElibc_error("Can't change the current directory to ~S", #endif pathname = ecl_merge_pathnames(si_getcwd(0), pathname, @':newest'); } CL_UNWIND_PROTECT_EXIT { - chdir(previous->base_string.self); + safe_chdir((char*)previous->base_string.self); } CL_UNWIND_PROTECT_END; @(return pathname) } -void * -ecl_backup_fopen(const char *filename, const char *option) +int +ecl_backup_open(const char *filename, int option, int mode) { - char *backupfilename = cl_alloc(strlen(filename) + 5); + char *backupfilename = ecl_alloc(strlen(filename) + 5); if (backupfilename == NULL) { FElibc_error("Cannot allocate memory for backup filename", 0); } strcat(strcpy(backupfilename, filename), ".BAK"); + ecl_disable_interrupts(); #ifdef _MSC_VER /* MSVC rename doesn't remove an existing file */ - if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) + if (access(backupfilename, F_OK) == 0 && unlink(backupfilename)) { + ecl_enable_interrupts(); FElibc_error("Cannot remove the file ~S", 1, make_simple_base_string(backupfilename)); + } #endif - if (rename(filename, backupfilename)) + if (rename(filename, backupfilename)) { + ecl_enable_interrupts(); FElibc_error("Cannot rename the file ~S to ~S.", 2, make_constant_base_string(filename), make_simple_base_string(backupfilename)); - cl_dealloc(backupfilename); - return fopen(filename, option); + } + ecl_enable_interrupts(); + ecl_dealloc(backupfilename); + return open(filename, option, mode); } cl_object -ecl_file_len(void *fp) +ecl_file_len(int f) { struct stat filestatus; - - fstat(fileno((FILE*)fp), &filestatus); + ecl_disable_interrupts(); + fstat(f, &filestatus); + ecl_enable_interrupts(); return ecl_make_integer(filestatus.st_size); } @@ -305,10 +356,12 @@ ecl_file_len(void *fp) newn = ecl_merge_pathnames(newn, oldn, @':newest'); new_filename = si_coerce_to_filename(newn); + ecl_disable_interrupts(); while (if_exists == @':error' || if_exists == Cnil) { #if defined(_MSC_VER) || defined(mingw32) error = SetErrorMode(0); - if (MoveFile(old_filename->base_string.self, new_filename->base_string.self)) { + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { SetErrorMode(error); goto SUCCESS; } @@ -321,8 +374,9 @@ ecl_file_len(void *fp) goto FAILURE_CLOBBER; }; #else - if (link(old_filename->base_string.self, new_filename->base_string.self) == 0) { - (void)unlink(old_filename->base_string.self); + if (link((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self) == 0) { + (void)unlink((char*)old_filename->base_string.self); goto SUCCESS; } if (errno != EEXIST && errno != ENOTEMPTY) { @@ -331,21 +385,25 @@ ecl_file_len(void *fp) #endif /* if the file already exists */ if (if_exists != Cnil) { + ecl_enable_interrupts(); if_exists = CEerror(@':supersede', "When trying to rename ~S, ~S already exists", 2, oldn, new_filename); + ecl_disable_interrupts(); if (if_exists == Ct) if_exists= @':error'; } if (if_exists == Cnil) { - @(return Cnil) + ecl_enable_interrupts(); + @(return Cnil Cnil Cnil) } } if (if_exists == @':supersede' || if_exists == Ct) { #if defined(_MSC_VER) || defined(mingw32) error = SetErrorMode(0); - if (MoveFile(old_filename->base_string.self, new_filename->base_string.self)) { + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { SetErrorMode(error); goto SUCCESS; } @@ -356,50 +414,64 @@ ecl_file_len(void *fp) default: goto FAILURE_CLOBBER; }; - if (MoveFileEx(old_filename->base_string.self, new_filename->base_string.self, - MOVEFILE_REPLACE_EXISTING)) { + if (MoveFileEx((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self, + MOVEFILE_REPLACE_EXISTING)) { SetErrorMode(error); goto SUCCESS; } /* hack for win95/novell */ - chmod(old_filename->base_string.self, 0777); - chmod(new_filename->base_string.self, 0777); - SetFileAttributesA(new_filename->base_string.self, FILE_ATTRIBUTE_NORMAL); - SetFileAttributesA(new_filename->base_string.self, FILE_ATTRIBUTE_TEMPORARY); - if (MoveFile(old_filename->base_string.self, new_filename->base_string.self)) { + chmod((char*)old_filename->base_string.self, 0777); + chmod((char*)new_filename->base_string.self, 0777); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_NORMAL); + SetFileAttributesA((char*)new_filename->base_string.self, + FILE_ATTRIBUTE_TEMPORARY); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { SetErrorMode(error); goto SUCCESS; } /* fallback on old behavior */ - (void)DeleteFileA(new_filename->base_string.self); - if (MoveFile(old_filename->base_string.self, new_filename->base_string.self)) { + (void)DeleteFileA((char*)new_filename->base_string.self); + if (MoveFile((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self)) { SetErrorMode(error); goto SUCCESS; } /* fall through */ #else - if (rename(old_filename->base_string.self, new_filename->base_string.self) == 0) { + if (rename((char*)old_filename->base_string.self, + (char*)new_filename->base_string.self) == 0) { goto SUCCESS; } #endif } else { /* invalid key */ + ecl_enable_interrupts(); FEerror("~S is an illegal IF-EXISTS option for RENAME-FILE.", 1, if_exists); } FAILURE_CLOBBER: + ecl_enable_interrupts(); FElibc_error("Cannot rename the file ~S to ~S.", 2, oldn, newn); -SUCCESS:new_truename = cl_truename(newn); +SUCCESS: + ecl_enable_interrupts(); + new_truename = cl_truename(newn); @(return newn old_truename new_truename) @) cl_object cl_delete_file(cl_object file) { - cl_object filename; + cl_object filename = si_coerce_to_filename(file); + int ok; - filename = si_coerce_to_filename(file); - if (unlink(filename->base_string.self) < 0) + ecl_disable_interrupts(); + ok = unlink((char*)filename->base_string.self); + ecl_enable_interrupts(); + + if (ok < 0) FElibc_error("Cannot delete the file ~S.", 1, file); @(return Ct) } @@ -414,68 +486,34 @@ cl_probe_file(cl_object file) cl_object cl_file_write_date(cl_object file) { - cl_object filename, time; + cl_object time, filename = si_coerce_to_filename(file); struct stat filestatus; - - filename = si_coerce_to_filename(file); - if (stat(filename->base_string.self, &filestatus) < 0) - time = Cnil; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) + time = Cnil; else - time = UTC_time_to_universal_time(filestatus.st_mtime); + time = UTC_time_to_universal_time(filestatus.st_mtime); @(return time) } cl_object cl_file_author(cl_object file) { - cl_object filename = si_coerce_to_filename(file); + cl_object output, filename = si_coerce_to_filename(file); + struct stat filestatus; + if (safe_stat((char*)filename->base_string.self, &filestatus) < 0) + FElibc_error("Cannot get the file status of ~S.", 1, file); #ifdef HAVE_PWD_H - struct stat filestatus; - struct passwd *pwent; - - if (stat(filename->base_string.self, &filestatus) < 0) - FElibc_error("Cannot get the file status of ~S.", 1, file); - pwent = getpwuid(filestatus.st_uid); - @(return make_base_string_copy(pwent->pw_name)) + { + struct passwd *pwent; + ecl_disable_interrupts(); + pwent = getpwuid(filestatus.st_uid); + ecl_enable_interrupts(); + output = make_base_string_copy(pwent->pw_name); + } #else - struct stat filestatus; - if (stat(filename->base_string.self, &filestatus) < 0) - FElibc_error("Cannot get the file status of ~S.", 1, file); - @(return make_constant_base_string("UNKNOWN")) + output = make_constant_base_string("UNKNOWN"); #endif -} - -const char * -ecl_expand_pathname(const char *name) -{ - const char *path, *p; - static char pathname[255], *pn; - - if (IS_DIR_SEPARATOR(name[0])) return(name); - if ((path = getenv("PATH")) == NULL) ecl_internal_error("No PATH in environment"); - p = path; - pn = pathname; - do { - if ((*p == '\0') || (*p == PATH_SEPARATOR)) { - if (pn != pathname) *pn++ = DIR_SEPARATOR; /* on SYSV . is empty */ -LAST: strcpy(pn, name); -#ifdef _MSC_VER - if (GetFileAttributes(pathname) & FILE_ATTRIBUTE_DIRECTORY) - return ( pathname ); -#else - if (access(pathname, X_OK) == 0) - return (pathname); -#endif - pn = pathname; - if (p[0] == PATH_SEPARATOR && p[1] == '\0') { /* last entry is empty */ - p++; - goto LAST; - } - } - else - *pn++ = *p; - } while (*p++ != '\0'); - return(name); /* should never occur */ + @(return output) } cl_object @@ -492,7 +530,7 @@ ecl_homedir_pathname(cl_object user) /* This ensures that our string has the right length and it is terminated with a '\0' */ user = si_copy_to_simple_base_string(user); - p = user->base_string.self; + p = (char*)user->base_string.self; i = user->base_string.fillp; if (i > 0 && *p == '~') { p++; @@ -596,14 +634,16 @@ list_current_directory(const char *mask, bool only_dir) { cl_object out = Cnil; char *text; - #if defined(HAVE_DIRENT_H) DIR *dir; struct dirent *entry; + ecl_disable_interrupts(); dir = opendir("./"); - if (dir == NULL) - return Cnil; + if (dir == NULL) { + out = Cnil; + goto OUTPUT; + } while ((entry = readdir(dir))) { text = entry->d_name; @@ -613,30 +653,32 @@ list_current_directory(const char *mask, bool only_dir) HANDLE hFind = NULL; BOOL found = FALSE; + ecl_disable_interrupts(); for (;;) { - if (hFind == NULL) - { + if (hFind == NULL) { hFind = FindFirstFile(".\\*", &fd); - if (hFind == INVALID_HANDLE_VALUE) - return Cnil; + if (hFind == INVALID_HANDLE_VALUE) { + out = Cnil; + goto OUTPUT; + } found = TRUE; - } - else + } else { found = FindNextFile(hFind, &fd); - + } if (!found) break; text = fd.cFileName; - # else /* sys/dir.h as in SYSV */ FILE *fp; char iobuffer[BUFSIZ]; DIRECTORY dir; + ecl_disable_interrupts(); fp = fopen("./", OPEN_R); - if (fp == NULL) - return Cnil; - + if (fp == NULL) { + out = Cnil; + goto OUTPUT; + } setbuf(fp, iobuffer); for (;;) { if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0) @@ -665,6 +707,8 @@ list_current_directory(const char *mask, bool only_dir) fclose(fp); # endif /* !_MSC_VER */ #endif /* !HAVE_DIRENT_H */ + ecl_enable_interrupts(); +OUTPUT: return cl_nreverse(out); } @@ -689,7 +733,7 @@ dir_files(cl_object basedir, cl_object pathname) all_files = list_current_directory(NULL, FALSE); loop_for_in(all_files) { cl_object new = CAR(all_files); - char *text = new->base_string.self; + char *text = (char*)new->base_string.self; if (file_kind(text, TRUE) == @':directory') continue; if (ecl_stringp(new) && ecl_member_char(':', new)) { @@ -754,23 +798,23 @@ dir_recursive(cl_object pathname, cl_object directory) next_dir = list_current_directory((item == @':wild')? "*" : (const char *)item->base_string.self, TRUE); loop_for_in(next_dir) { - char *text = CAR(next_dir)->base_string.self; + char *text = (char*)(CAR(next_dir)->base_string.self); /* We are unable to move into this directory! */ - if (chdir(text) < 0) + if (safe_chdir(text) < 0) continue; item = dir_recursive(pathname, CDR(directory)); output = ecl_nconc(item, output); - chdir(prev_dir->base_string.self); + safe_chdir((char*)prev_dir->base_string.self); } end_loop_for_in; } else if (item == @':absolute') { /* * 2.2) If CAR(DIRECTORY) is :ABSOLUTE, we have to scan the * root directory. */ - if (chdir("/") < 0) + if (safe_chdir("/") < 0) return Cnil; output = dir_recursive(pathname, CDR(directory)); - chdir(prev_dir->base_string.self); + safe_chdir((char*)prev_dir->base_string.self); } else if (item == @':relative') { /* * 2.3) If CAR(DIRECTORY) is :RELATIVE, we have to scan the @@ -782,10 +826,10 @@ dir_recursive(cl_object pathname, cl_object directory) * 2.4) If CAR(DIRECTORY) is :UP, we have to scan the directory * which contains this one. */ - if (chdir("..") < 0) + if (safe_chdir("..") < 0) return Cnil; output = dir_recursive(pathname, CDR(directory)); - chdir(prev_dir->base_string.self); + safe_chdir((char*)prev_dir->base_string.self); } else if (item == @':wild-inferiors') { /* * 2.5) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do @@ -794,12 +838,12 @@ dir_recursive(cl_object pathname, cl_object directory) */ next_dir = list_current_directory("*", TRUE); loop_for_in(next_dir) { - char *text = CAR(next_dir)->base_string.self; - if (chdir(text) < 0) + char *text = (char*)(CAR(next_dir)->base_string.self); + if (safe_chdir(text) < 0) continue; item = dir_recursive(pathname, directory); output = ecl_nconc(item, output); - chdir(prev_dir->base_string.self); + safe_chdir((char*)prev_dir->base_string.self); } end_loop_for_in; output = ecl_nconc(output, dir_recursive(pathname, CDR(directory))); } @@ -810,14 +854,14 @@ dir_recursive(cl_object pathname, cl_object directory) cl_object prev_dir = Cnil; cl_object output; @ - CL_UNWIND_PROTECT_BEGIN { + CL_UNWIND_PROTECT_BEGIN(the_env) { prev_dir = current_dir(); mask = coerce_to_file_pathname(mask); change_drive(mask); output = dir_recursive(mask, mask->pathname.directory); } CL_UNWIND_PROTECT_EXIT { if (prev_dir != Cnil) - chdir(prev_dir->base_string.self); + safe_chdir((char*)prev_dir->base_string.self); } CL_UNWIND_PROTECT_END; @(return output) @) @@ -827,7 +871,7 @@ dir_recursive(cl_object pathname, cl_object directory) @ output = cl_parse_namestring(3, current_dir(), Cnil, Cnil); if (!Null(change_d_p_d)) { - ECL_SETQ(@'*default-pathname-defaults*', output); + ECL_SETQ(the_env, @'*default-pathname-defaults*', output); } @(return output) @) @@ -838,10 +882,16 @@ si_get_library_pathname(void) { cl_object s = cl_alloc_adjustable_base_string(cl_core.path_max); char *buffer = (char*)s->base_string.self; - HMODULE hnd = GetModuleHandle( "ecl.dll" ); + HMODULE hnd; cl_index len, ep; - if ((len = GetModuleFileName(hnd, buffer, cl_core.path_max-1)) == 0) - FEerror("GetModuleFileName failed (last error = ~S)", 1, MAKE_FIXNUM(GetLastError())); + ecl_disable_interrupts(); + hnd = GetModuleHandle("ecl.dll"); + len = GetModuleFileName(hnd, buffer, cl_core.path_max-1); + ecl_enable_interrupts(); + if (len == 0) { + FEerror("GetModuleFileName failed (last error = ~S)", + 1, MAKE_FIXNUM(GetLastError())); + } s->base_string.fillp = len; return ecl_parse_namestring(s, 0, len, &ep, Cnil); } @@ -857,29 +907,33 @@ si_get_library_pathname(void) directory->pathname.type != Cnil) FEerror("~A is not a directory pathname.", 1, directory); namestring = cl_namestring(directory); - if (chdir(namestring->base_string.self) <0) + if (safe_chdir((char*)namestring->base_string.self) <0) FElibc_error("Can't change the current directory to ~A", 1, namestring); if (change_d_p_d != Cnil) - ECL_SETQ(@'*default-pathname-defaults*', directory); + ECL_SETQ(the_env, @'*default-pathname-defaults*', directory); @(return previous) @) cl_object si_mkdir(cl_object directory, cl_object mode) { - cl_object filename; - cl_index modeint; + cl_object filename = si_coerce_to_filename(directory); + cl_index modeint = ecl_fixnum_in_range(@'si::mkdir',"mode",mode,0,0777); + int ok; - filename = si_coerce_to_filename(directory); - modeint = ecl_fixnum_in_range(@'si::mkdir',"mode",mode,0,0777); if (filename->base_string.fillp) filename->base_string.self[--filename->base_string.fillp] = 0; + + ecl_disable_interrupts(); #ifdef mingw32 - if (mkdir(filename->base_string.self) < 0) + ok = mkdir((char*)filename->base_string.self); #else - if (mkdir(filename->base_string.self, modeint) < 0) + ok = mkdir((char*)filename->base_string.self, modeint); #endif + ecl_enable_interrupts(); + + if (ok < 0) FElibc_error("Could not create directory ~S", 1, filename); @(return filename) } @@ -892,67 +946,78 @@ si_mkstemp(cl_object template) int fd; #if defined(mingw32) || defined(_MSC_VER) - cl_object phys, dir, file; char strTempDir[MAX_PATH]; char strTempFileName[MAX_PATH]; - char * s; - + char *s; + int ok; + phys = cl_translate_logical_pathname(1, template); - dir = cl_make_pathname(8, @':type', Cnil, @':name', Cnil, @':version', Cnil, @':defaults', phys); - dir = cl_namestring(dir); file = cl_file_namestring(phys); l = dir->base_string.fillp; - memcpy(strTempDir, dir->base_string.self, l); strTempDir[l] = 0; for (s = strTempDir; *s; s++) if (*s == '/') *s = '\\'; - if (!GetTempFileName(strTempDir, file->base_string.self, 0, strTempFileName)) - { - @(return Cnil) + ecl_disable_interrupts(); + ok = GetTempFileName(strTempDir, (char*)file->base_string.self, 0, + strTempFileName); + ecl_enable_interrupts(); + if (!ok) { + output = Cnil; + } else { + l = strlen(strTempFileName); + output = cl_alloc_simple_base_string(l); + memcpy(output->base_string.self, strTempFileName, l); } - - l = strlen(strTempFileName); - output = cl_alloc_simple_base_string(l); - memcpy(output->base_string.self, strTempFileName, l); - #else - template = si_coerce_to_filename(template); l = template->base_string.fillp; output = cl_alloc_simple_base_string(l + 6); memcpy(output->base_string.self, template->base_string.self, l); memcpy(output->base_string.self + l, "XXXXXX", 6); -#ifdef HAVE_MKSTEMP - fd = mkstemp(output->base_string.self); -#else - fd = mktemp(output->base_string.self); - fd = open(fd, O_CREAT|O_TRUNC, 0666); -#endif - if (fd < 0) - @(return Cnil) - close(fd); -#endif + ecl_disable_interrupts(); +# ifdef HAVE_MKSTEMP + fd = mkstemp((char*)output->base_string.self); +# else + if (mktemp((char*)output->base_string.self)) { + fd = open((char*)output->base_string.self, O_CREAT|O_TRUNC, 0666); + } else { + fd = -1; + } +# endif + ecl_enable_interrupts(); - @(return cl_truename(output)) + if (fd < 0) { + output = Cnil; + } else { + close(fd); + } +#endif + @(return (Null(output)? output : cl_truename(output))) } cl_object si_rmdir(cl_object directory) { + int code; directory = si_coerce_to_filename(directory); - if ( rmdir(directory->base_string.self) != 0 ) + + ecl_disable_interrupts(); + code = rmdir((char*)directory->base_string.self); + ecl_enable_interrupts(); + + if (code != 0) FElibc_error("Can't remove directory ~A.", 1, directory); @(return Cnil) } diff --git a/src/c/unixint.d b/src/c/unixint.d index ade360f60..5c9451045 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -15,6 +15,9 @@ See file '../Copyright' for full details. */ +#include +#include +#include #include #if defined(HAVE_FENV_H) && !defined(ECL_AVOID_FENV_H) # define _GNU_SOURCE @@ -36,6 +39,12 @@ # endif #endif #include +#ifdef ECL_USE_MPROTECT +# ifndef SA_SIGINFO +# error "We cannot use the mmap code without siginfo" +# endif +# include +#endif #if defined(mingw32) || defined(_MSC_VER) # include void handle_fpe_signal(int,int); @@ -150,9 +159,11 @@ static struct { /******************************* ------- ******************************/ -bool ecl_interrupt_enable; - #ifdef HAVE_SIGPROCMASK +#define define_handler(name, sig, info, aux) name(sig, info, aux) +#define call_handler(name, sig, info, aux) name(sig, info, aux) +#define reinstall_signal(x,y) +#define copy_siginfo(x,y) memcpy(x, y, sizeof(struct sigaction)) static void mysignal(int code, void *handler) { @@ -172,20 +183,45 @@ mysignal(int code, void *handler) sigaction(code, &new_action, &old_action); } #else +#define define_handler(name, sig, info, aux) name(sig) +#define call_handler(name, sig, info, aux) name(sig) #define mysignal(x,y) signal(x,y) +#define reinstall_signal(x,y) signal(x,y) +#define copy_siginfo(x,y) #endif -static void -#ifdef SA_SIGINFO -handle_signal(int sig, siginfo_t *info, void *aux) -#else -handle_signal(int sig) -#endif +static bool +interrupts_disabled_by_C(cl_env_ptr the_env) { + return the_env->disable_interrupts; +} + +static bool +interrupts_disabled_by_lisp(cl_env_ptr the_env) +{ + return (ecl_get_option(ECL_OPT_BOOTED) && + ecl_symbol_value(@'si::*interrupt-enable*') == Cnil); +} + +static void +jump_to_sigsegv_handler(cl_env_ptr the_env) +{ + ecl_frame_ptr destination = frs_sch(OBJNULL); + if (destination) { + the_env->nvalues = 0; + ecl_unwind(the_env, destination); + } + ecl_internal_error("SIGSEGV without handler to jump to."); +} + +static void +define_handler(lisp_signal_handler, int sig, siginfo_t *info, void *aux) +{ + cl_env_ptr the_env = &cl_env; switch (sig) { #if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32) case SIGUSR1: - funcall(1, cl_env.own_process->process.interrupt); + funcall(1, the_env->own_process->process.interrupt); break; #endif case SIGINT: @@ -220,87 +256,218 @@ handle_signal(int sig) cl_error(1, condition); break; } - case SIGSEGV: -#ifdef SA_SIGINFO - if (sbrk(0) < info->si_addr) { - GC_disable(); - cl_error(3, @'ext::stack-overflow', @':type', @'ext::c-stack'); + case SIGSEGV: { + ecl_frame_ptr destination = frs_sch(OBJNULL); + if (destination) { + the_env->nvalues = 0; + ecl_unwind(the_env, destination); } -#endif - cl_error(1, @'ext::segmentation-violation'); - break; + ecl_internal_error("SIGSEGV without handler to jump to."); + } + case SIGBUS: { + ecl_frame_ptr destination = frs_sch(OBJNULL); + if (destination) { + the_env->nvalues = 0; + ecl_unwind(the_env, destination); + } + ecl_internal_error("SIGSEGV without handler to jump to."); + } default: FEerror("Serious signal ~D caught.", 1, MAKE_FIXNUM(sig)); } } -/* - * TODO: Use POSIX signals, and in particular use sigaltstack to - * handle stack overflows gracefully. - */ -static void -#ifdef SA_SIGINFO -signal_catcher(int sig, siginfo_t *siginfo, void *data) -#else -signal_catcher(int sig) -#endif -{ -#ifdef GBC_BOEHM - int old_GC_enabled = GC_enabled(); -#endif - if (!ecl_get_option(ECL_OPT_BOOTED)) { - mysignal(sig, signal_catcher); - return; - } - if (!ecl_interrupt_enable || - Null(ecl_symbol_value(@'si::*interrupt-enable*'))) { - mysignal(sig, signal_catcher); - cl_env.interrupt_pending = sig; - return; - } #ifdef HAVE_SIGPROCMASK - CL_UNWIND_PROTECT_BEGIN { -#ifdef SA_SIGINFO - handle_signal(sig, siginfo, data); +static void +unblock_signal(int signal) +{ + struct sigaction oact; + sigset_t block_mask; + sigaction(signal, NULL, &oact); + block_mask = oact.sa_mask; + sigaddset(&block_mask, signal); +# ifdef ECL_THREADS + pthread_sigmask(SIG_UNBLOCK, &block_mask, NULL); +# else + sigprocmask(SIG_UNBLOCK, &block_mask, NULL); +# endif +} #else - handle_signal(sig); +#define unblock_signal(sig) #endif - } CL_UNWIND_PROTECT_EXIT { - sigset_t block_mask; - sigemptyset(&block_mask); - sigaddset(&block_mask, sig); -#ifdef ECL_THREADS - pthread_sigmask(SIG_UNBLOCK, &block_mask, NULL); -#else - sigprocmask(SIG_UNBLOCK, &block_mask, NULL); -#endif - if (old_GC_enabled) GC_enable() else GC_disable(); - } CL_UNWIND_PROTECT_END; -#else + +static void +define_handler(handle_signal_now, int sig, siginfo_t *info, void *aux) +{ #if defined (_MSC_VER) if (sig == SIGFPE) { handle_fpe_signal(sig, _fpecode); } #endif - handle_signal(sig); + unblock_signal(sig); + call_handler(lisp_signal_handler, sig, info, aux); +} + +static void define_handler(sigsegv_handler, int sig, siginfo_t *info, void *aux); + +static void +define_handler(non_evil_signal_handler, int sig, siginfo_t *siginfo, void *data) +{ + int old_errno = errno; + cl_env_ptr the_env; + if (!ecl_get_option(ECL_OPT_BOOTED)) { + ecl_internal_error("Got signal before environment was installed" + " on our thread."); + } + the_env = ecl_process_env(); + reinstall_signal(sig, non_evil_signal_handler); + printf("Non evil handler\n"); + /* + * If interrupts are disabled by C we are not so eager on + * detecting when the interrupts become enabled again. We + * queue the signal and are done with that. + */ + if (interrupts_disabled_by_lisp(the_env)) { + if (!the_env->interrupt_pending) { + the_env->interrupt_pending = sig; + copy_siginfo(the_env->interrupt_info, siginfo); + } + errno = old_errno; + return; + } + /* + * If interrupts are disabled by C, and we have not pushed a + * pending signal, save this signal and return. On platforms + * in which mprotect() works, we block all write access to the + * environment for a cheap check of pending interrupts. On other + * platforms we change the value of disable_interrupts to 3, so + * that we detect changes. + */ + if (interrupts_disabled_by_C(the_env)) { + the_env->disable_interrupts = 3; + if (!the_env->interrupt_pending) { + struct sigaction oact; + the_env->interrupt_pending = sig; + copy_siginfo(the_env->interrupt_info, siginfo); + printf("Postponing signal %d\n", sig); + sigaction(SIGSEGV, NULL, &oact); + printf("SIGSEGV Handler: %x\n", oact.sa_sigaction); + sigaction(SIGBUS, NULL, &oact); + printf("SIGBUS Handler: %x\n", oact.sa_sigaction); + printf("sigsegv_handler: %x\n", sigsegv_handler); +#ifdef ECL_USE_MPROTECT + printf("Protecting %x\n", the_env); + if (mprotect(the_env, sizeof(*the_env), PROT_READ) < 0) + ecl_internal_error("Unable to mprotect environment."); #endif + } + errno = old_errno; + return; + } + /* + * If interrupts are enabled, that means we are in a safe area + * and may execute arbitrary lisp code. We can thus call the + * appropriate handlers. + */ + errno = old_errno; + call_handler(handle_signal_now, sig, siginfo, data); +} + +static void +define_handler(sigsegv_handler, int sig, siginfo_t *info, void *aux) +{ + cl_env_ptr the_env = ecl_process_env(); + if (!ecl_get_option(ECL_OPT_BOOTED)) { + ecl_internal_error("Got signal before environment was installed" + " on our thread."); + } + the_env = ecl_process_env(); +#ifdef HAVE_SIGPROCMASK +# ifdef ECL_DOWN_STACK + if ((cl_fixnum*)info->si_addr > the_env->cs_barrier && + (cl_fixnum*)info->si_addr <= the_env->cs_org) { + return jump_to_sigsegv_handler(the_env); + } +# else + if ((cl_fixnum*)info->si_addr < the_env->cs_barrier && + (cl_fixnum*)info->si_addr >= the_env->cs_org) { + return jump_to_sigsegv_handler(the_env); + } +# endif + if (interrupts_disabled_by_lisp(the_env)) { + if (!the_env->interrupt_pending) { + the_env->interrupt_pending = sig; + copy_siginfo(the_env->interrupt_info, info); + } + return; + } + if (interrupts_disabled_by_C(the_env)) { + if (!the_env->interrupt_pending) { + the_env->interrupt_pending = sig; + copy_siginfo(the_env->interrupt_info, info); +# ifdef ECL_USE_MPROTECT + printf("Protecting %p\n", the_env); + if (mprotect(the_env, sizeof(*the_env), PROT_READ) < 0) + ecl_internal_error("Unable to mprotect environment."); +# endif + } + return; + } + handle_signal_now(sig, info, aux); +#else + reinstall_signal_handler(sig, sigsegv_signal_handler); + /* + * We cannot distinguish between a stack overflow and a simple + * access violation. Thus we assume the worst case and jump to + * the outermost handler. + */ + jump_to_sigsegv_handler(&cl_env); +#endif +} + +static void +define_handler(sigbus_handler, int sig, siginfo_t *info, void *aux) +{ + cl_env_ptr the_env = &cl_env; + printf("Entering sigbus_handler for address %0p\n", info->si_addr); +#if defined(SA_SIGINFO) && defined(ECL_USE_MPROTECT) + /* We access the environment when it was protected. That + * means there was a pending signal. */ + if (the_env == info->si_addr) { + int signal = the_env->interrupt_pending; + siginfo_t info = *(siginfo_t*)(the_env->interrupt_info); + printf("Unprotecting %p\n", the_env); + mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE); + the_env->interrupt_pending = 0; + the_env->disable_interrupts = 0; + unblock_signal(sig); + return handle_signal_now(signal, &info, aux); + } +#endif + call_handler(handle_signal_now, sig, info, aux); } cl_object si_check_pending_interrupts(void) { - int what = cl_env.interrupt_pending; - cl_env.interrupt_pending = 0; - if (what) { -#if defined (HAVE_SIGPROCMASK) && defined(SA_SIGINFO) - handle_signal(what, 0, 0); -#else - handle_signal(what); -#endif - } + ecl_check_pending_interrupts(); @(return) } +void +ecl_check_pending_interrupts(void) +{ + const cl_env_ptr env = ecl_process_env(); + int sig; + void *info; + env->disable_interrupts = 0; + info = env->interrupt_info; + sig = env->interrupt_pending; + if (sig) { + call_handler(handle_signal_now, sig, info, 0); + } +} + cl_object si_catch_signal(cl_object code, cl_object boolean) { @@ -326,8 +493,14 @@ si_catch_signal(cl_object code, cl_object boolean) #endif for (i = 0; known_signals[i].code >= 0; i++) { if (known_signals[i].code == code_int) { - mysignal(code_int, - Null(boolean)? SIG_DFL : signal_catcher); + if (Null(boolean)) + mysignal(code_int, SIG_DFL); + else if (code_int == SIGSEGV) + mysignal(code_int, sigsegv_handler); + else if (code_int == SIGBUS) + mysignal(code_int, sigbus_handler); + else + mysignal(code_int, non_evil_signal_handler); @(return Ct) } } @@ -352,15 +525,15 @@ LONG WINAPI W32_exception_filter(struct _EXCEPTION_POINTERS* ep) case EXCEPTION_FLT_DENORMAL_OPERAND: case EXCEPTION_FLT_INVALID_OPERATION: case EXCEPTION_FLT_STACK_CHECK: - handle_signal(SIGFPE); + non_evil_signal_handler(SIGFPE); break; /* Catch segmentation fault */ case EXCEPTION_ACCESS_VIOLATION: - handle_signal(SIGSEGV); + sigsegv_handler(SIGSEGV); break; /* Catch illegal instruction */ case EXCEPTION_ILLEGAL_INSTRUCTION: - handle_signal(SIGILL); + non_evil_signal_handler(SIGILL); break; /* Do not catch anything else */ default: @@ -386,7 +559,6 @@ void handle_fpe_signal(int sig, int num) condition = @'division-by-zero'; break; } - si_trap_fpe(@'last', Ct); cl_error(1, condition); } @@ -397,7 +569,7 @@ BOOL WINAPI W32_console_ctrl_handler(DWORD type) { /* Catch CTRL-C */ case CTRL_C_EVENT: - handle_signal(SIGINT); + non_evil_signal_handler(SIGINT); return TRUE; } return FALSE; @@ -442,26 +614,21 @@ init_unixint(int pass) if (pass == 0) { #ifdef SIGSEGV if (ecl_get_option(ECL_OPT_TRAP_SIGSEGV)) { - mysignal(SIGSEGV, signal_catcher); + mysignal(SIGSEGV, sigsegv_handler); } #endif -#if defined(SIGBUS) && !defined(GBC_BOEHM) +#if defined(SIGBUS) /*&& !defined(GBC_BOEHM)*/ if (ecl_get_option(ECL_OPT_TRAP_SIGBUS)) { - mysignal(SIGBUS, signal_catcher); + mysignal(SIGBUS, sigbus_handler); } #endif #ifdef SIGINT if (ecl_get_option(ECL_OPT_TRAP_SIGINT)) { - mysignal(SIGINT, signal_catcher); - } -#endif -#ifdef SIGFPE - if (ecl_get_option(ECL_OPT_TRAP_SIGFPE)) { - mysignal(SIGFPE, signal_catcher); + mysignal(SIGINT, non_evil_signal_handler); } #endif #if defined(ECL_THREADS) && !defined(_MSC_VER) && !defined(mingw32) - mysignal(SIGUSR1, signal_catcher); + mysignal(SIGUSR1, non_evil_signal_handler); #endif #ifdef _MSC_VER SetUnhandledExceptionFilter(W32_exception_filter); @@ -476,7 +643,12 @@ init_unixint(int pass) si_Xmake_constant(name, MAKE_FIXNUM(known_signals[i].code)); } ECL_SET(@'si::*interrupt-enable*', Ct); - si_trap_fpe(Ct, Ct); - ecl_interrupt_enable = 1; +#ifdef SIGFPE + if (ecl_get_option(ECL_OPT_TRAP_SIGFPE)) { + mysignal(SIGFPE, non_evil_signal_handler); + si_trap_fpe(Ct, Ct); + } +#endif + ecl_process_env()->disable_interrupts = 0; } } diff --git a/src/c/unixsys.d b/src/c/unixsys.d index d06ad05bc..a8746be50 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -63,9 +63,9 @@ si_make_pipe() output = Cnil; } else { cl_object fake_in_name = make_simple_base_string("PIPE-READ-ENDPOINT"); - cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], smm_input); + cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], smm_input, 8, 0); cl_object fake_out_name = make_simple_base_string("PIPE-WRITE-ENDPOINT"); - cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], smm_output); + cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], smm_output, 8, 0); output = cl_make_two_way_stream(in, out); } @(return output) @@ -124,7 +124,8 @@ si_make_pipe() /* The child inherits a duplicate of our input handle. Creating a duplicate avoids problems when the child closes it */ - int stream_handle = ecl_stream_to_handle(SYM_VAL(@'*standard-input*'), 0); + cl_object input_stream = ecl_symbol_value(@'*standard-input*'); + int stream_handle = ecl_stream_to_handle(input_stream, 0); if (stream_handle >= 0) DuplicateHandle(current, _get_osfhandle(stream_handle) /*GetStdHandle(STD_INPUT_HANDLE)*/, current, &child_stdin, 0, TRUE, @@ -156,7 +157,8 @@ si_make_pipe() /* The child inherits a duplicate of our output handle. Creating a duplicate avoids problems when the child closes it */ - int stream_handle = ecl_stream_to_handle(SYM_VAL(@'*standard-output*'), 1); + cl_object output_stream = ecl_symbol_value(@'*standard-output*'); + int stream_handle = ecl_stream_to_handle(output_stream, 1); if (stream_handle >= 0) DuplicateHandle(current, _get_osfhandle(stream_handle) /*GetStdHandle(STD_OUTPUT_HANDLE)*/, current, &child_stdout, 0, TRUE, @@ -177,7 +179,8 @@ si_make_pipe() /* The child inherits a duplicate of our output handle. Creating a duplicate avoids problems when the child closes it */ - int stream_handle = ecl_stream_to_handle(SYM_VAL(@'*error-output*'), 1); + cl_object error_stream = ecl_symbol_value(@'*error-output*'); + int stream_handle = ecl_stream_to_handle(error_stream, 1); if (stream_handle >= 0) DuplicateHandle(current, _get_osfhandle(stream_handle) /*GetStdHandle(STD_ERROR_HANDLE)*/, current, &child_stderr, 0, TRUE, @@ -269,8 +272,10 @@ si_make_pipe() child_stdin = fd[0]; } else { child_stdin = -1; - if (input == @'t') - child_stdin = ecl_stream_to_handle(SYM_VAL(@'*standard-input*'), 0); + if (input == @'t') { + cl_object input_stream = ecl_symbol_value(@'*standard-input*'); + child_stdin = ecl_stream_to_handle(input_stream, 0); + } if (child_stdin >= 0) child_stdin = dup(child_stdin); else @@ -283,8 +288,10 @@ si_make_pipe() child_stdout = fd[1]; } else { child_stdout = -1; - if (output == @'t') - child_stdout = ecl_stream_to_handle(SYM_VAL(@'*standard-output*'), 1); + if (output == @'t') { + cl_object output_stream = ecl_symbol_value(@'*standard-output*'); + child_stdout = ecl_stream_to_handle(output_stream, 1); + } if (child_stdout >= 0) child_stdout = dup(child_stdout); else @@ -293,7 +300,8 @@ si_make_pipe() if (error == @':output') { child_stderr = child_stdout; } else if (error == @'t') { - child_stderr = ecl_stream_to_handle(SYM_VAL(@'*error-output*'), 1); + cl_object error_stream = ecl_symbol_value(@'*error-output*'); + child_stderr = ecl_stream_to_handle(error_stream, 1); } else { child_stderr = -1; } @@ -323,7 +331,7 @@ si_make_pipe() argv_ptr[j] = arg->base_string.self; } } - execvp(command->base_string.self, argv_ptr); + execvp((char*)command->base_string.self, argv_ptr); /* at this point exec has failed */ perror("exec"); abort(); @@ -347,14 +355,14 @@ si_make_pipe() } if (parent_write > 0) { stream_write = ecl_make_stream_from_fd(command, parent_write, - smm_output); + smm_output, 8, 0); } else { parent_write = 0; stream_write = cl_core.null_stream; } if (parent_read > 0) { stream_read = ecl_make_stream_from_fd(command, parent_read, - smm_input); + smm_input, 8, 0); } else { parent_read = 0; stream_read = cl_core.null_stream; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 0eb9398c7..7f69300b0 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -554,7 +554,10 @@ returns with NIL." or return to an outer frame, undoing all the function calls so far." type)))))) -(define-condition storage-exhausted (storage-condition) ()) +(define-condition ext:storage-exhausted (storage-condition) () + (:REPORT + (lambda (condition stream) + (format stream "Memory limit reached. Please jump to an outer point or quit program.")))) (define-condition type-error (error) ((datum :INITARG :DATUM :READER type-error-datum) diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index 00a5d03c4..40dbf6453 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -86,9 +86,9 @@ (cond ((and (var-p loc) (member (var-kind loc) '(global special)) (eq (var-name loc) (var-name var))) - (wt-nl "bds_push(" (var-loc var) ");")) + (wt-nl "ecl_bds_push(cl_env_copy," (var-loc var) ");")) (t - (wt-nl "bds_bind(" (var-loc var) ",") + (wt-nl "ecl_bds_bind(cl_env_copy," (var-loc var) ",") (wt-coerce-loc :object loc) (wt ");"))) (push 'BDS-BIND *unwind-exit*) diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index a9b483994..5960503c4 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -60,7 +60,7 @@ (wt-nl *volatile* "cl_object env" (incf *env-lvl*) " = env" env-lvl ";"))) (bind "new_frame_id()" blk-var) - (wt-nl "if (frs_push(" blk-var ")!=0) {") + (wt-nl "if (ecl_frs_push(cl_env_copy," blk-var ")!=0) {") (let ((*unwind-exit* (cons 'FRAME *unwind-exit*))) (unwind-exit 'VALUES) (wt-nl "} else {") diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 88858bdde..01540b318 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -299,7 +299,7 @@ (format nil "env~D" n))) (defun wt-stack-pointer (narg) - (wt "cl_env.stack_top-" narg)) + (wt "cl_env_copy->stack_top-" narg)) (defun wt-call (fun args &optional fname) (wt fun "(") diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 0c0842fd2..765a960a4 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -30,18 +30,18 @@ (*unwind-exit* (list* *exit* 'FRAME *unwind-exit*))) (if (member new-destination '(TRASH VALUES)) (progn - (wt-nl "if (frs_push(" 'VALUE0 ")==0) {") + (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")==0) {") (wt-comment "BEGIN CATCH " code nil) (c2expr body) (wt-nl "}")) (progn - (wt-nl "if (frs_push(" 'VALUE0 ")) {") + (wt-nl "if (ecl_frs_push(cl_env_copy," 'VALUE0 ")) {") (wt-comment "BEGIN CATCH " code nil) (unwind-exit 'VALUES t) (wt-nl "}") (c2expr body))) (wt-label *exit*) - (wt-nl "frs_pop();") + (wt-nl "ecl_frs_pop(cl_env_copy);") (wt-comment "END CATCH " code nil) ) (unwind-exit new-destination))) @@ -61,28 +61,28 @@ (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) (wt-nl "{") (wt-nl "volatile bool unwinding = FALSE;") - (wt-nl "cl_index " sp "=cl_stack_index()," nargs ";") + (wt-nl "cl_index " sp "=ecl_stack_index(cl_env_copy)," nargs ";") (wt-nl "ecl_frame_ptr next_fr;") ;; Here we compile the form which is protected. When this form - ;; is aborted, it continues at the frs_pop() with unwinding=TRUE. - (wt-nl "if (frs_push(ECL_PROTECT_TAG)) {") - (wt-nl " unwinding = TRUE; next_fr=cl_env.nlj_fr;") + ;; is aborted, it continues at the ecl_frs_pop() with unwinding=TRUE. + (wt-nl "if (ecl_frs_push(cl_env_copy,ECL_PROTECT_TAG)) {") + (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;") (wt-nl "} else {") (let ((*unwind-exit* (cons 'FRAME *unwind-exit*)) (*destination* 'VALUES)) (c2expr* form)) (wt-nl "}") - (wt-nl "frs_pop();") + (wt-nl "ecl_frs_pop(cl_env_copy);") ;; Here we save the values of the form which might have been ;; aborted, and execute some cleanup code. This code may also ;; be aborted by some control structure, but is not protected. - (wt-nl nargs "=cl_stack_push_values();") + (wt-nl nargs "=ecl_stack_push_values(cl_env_copy);") (let ((*destination* 'TRASH)) (c2expr* body)) - (wt-nl "cl_stack_pop_values(" nargs ");") + (wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");") ;; Finally, if the protected form was aborted, jump to the ;; next catch point... - (wt-nl "if (unwinding) ecl_unwind(next_fr);") + (wt-nl "if (unwinding) ecl_unwind(cl_env_copy,next_fr);") ;; ... or simply return the values of the protected form. (unwind-exit 'VALUES) (wt "}"))) diff --git a/src/cmp/cmpcbk.lsp b/src/cmp/cmpcbk.lsp index c6245f54b..63e789df4 100644 --- a/src/cmp/cmpcbk.lsp +++ b/src/cmp/cmpcbk.lsp @@ -99,7 +99,7 @@ (when return-p (wt-nl return-type-name " output;")) (wt-nl "cl_object aux;") - (wt-nl "ECL_BUILD_STACK_FRAME(frame, helper)") + (wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)") (loop for n from 0 and type in arg-types and ct in arg-type-constants diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 8c701c502..501ed62e5 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -614,6 +614,10 @@ (space (third x)) (speed (fourth x))))) +(defun policy-check-stack-overflow (&optional (env *cmp-env*)) + "Do we add a stack check to every function?" + (>= (cmp-env-optimization 'safety env) 2)) + (defun policy-inline-slot-access-p (&optional (env *cmp-env*)) "Do we inline access to structures and sealed classes?" (or (< (cmp-env-optimization 'safety env) 2) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index 7e9133c63..48082fc1d 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -19,14 +19,16 @@ (when stack-frame (if (stringp stack-frame) (wt-nl "ecl_stack_frame_close(" stack-frame ");") - (wt-nl "cl_stack_set_index(" stack-frame ");"))) + (wt-nl "ecl_stack_set_index(cl_env_copy," stack-frame ");"))) (when bds-lcl - (wt-nl "bds_unwind(" bds-lcl ");")) + (wt-nl "ecl_bds_unwind(cl_env_copy," bds-lcl ");")) (if (< bds-bind 4) - (dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1();")) - (wt-nl "bds_unwind_n(" bds-bind ");")) + (dotimes (n bds-bind) + (declare (fixnum n)) + (wt-nl "ecl_bds_unwind1(cl_env_copy);")) + (wt-nl "ecl_bds_unwind_n(cl_env_copy," bds-bind ");")) (when ihs-p - (wt-nl "ihs_pop();"))) + (wt-nl "ecl_ihs_pop(cl_env_copy);"))) (defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) (declare (fixnum bds-bind)) @@ -81,7 +83,7 @@ (cond ((eq loc 'VALUES) ;; from multiple-value-prog1 or values (unwind-bds bds-lcl bds-bind stack-frame ihs-p) - (wt-nl "return VALUES(0);")) + (wt-nl "return cl_env_copy->values[0];")) ((eq loc 'RETURN) ;; from multiple-value-prog1 or values (unwind-bds bds-lcl bds-bind stack-frame ihs-p) @@ -116,7 +118,7 @@ (let ((*destination* (tmp-destination *destination*))) (set-loc loc) (setq loc *destination*)) - (wt-nl "frs_pop();")) + (wt-nl "ecl_frs_pop(cl_env_copy);")) (TAIL-RECURSION-MARK) (JUMP (setq jump-p t)) (t (baboon)))))) @@ -143,7 +145,7 @@ (baboon)) ;;; Never reached ) - ((eq ue 'FRAME) (wt-nl "frs_pop();")) + ((eq ue 'FRAME) (wt-nl "ecl_frs_pop(cl_env_copy);")) ((eq ue 'TAIL-RECURSION-MARK) (if (eq exit 'TAIL-RECURSION-MARK) (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp index 85a195322..2ea53f055 100644 --- a/src/cmp/cmpffi.lsp +++ b/src/cmp/cmpffi.lsp @@ -392,7 +392,7 @@ (loop for v in output-vars for i from 0 do (let ((*destination* `(VALUE ,i))) (set-loc v))) - (wt "NVALUES=" (length output-vars) ";") + (wt "cl_env_copy->nvalues=" (length output-vars) ";") 'VALUES)))))) (defun c2c-inline (arguments &rest rest) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 7c4e9da71..1bb307952 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -74,19 +74,21 @@ (case *destination* (VALUES (cond (is-call - (wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt ";")) + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";")) ((eq loc 'VALUES) (return-from set-loc)) (t - (wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;")))) + (wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) + (wt "; cl_env_copy->nvalues=1;")))) (VALUE0 (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) (RETURN (cond ((or is-call (eq loc 'VALUES)) (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";")) - ((eq loc 'VALUE0) (wt-nl "NVALUES=1;")) + ((eq loc 'VALUE0) (wt-nl "cl_env_copy->nvalues=1;")) ((eq loc 'RETURN) (return-from set-loc)) (t - (wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;")))) + (wt-nl "value0=") (wt-coerce-loc :object loc) + (wt "; cl_env_copy->nvalues=1;")))) (TRASH (cond (is-call (wt-nl "(void)" loc ";")) ((and (consp loc) @@ -114,7 +116,7 @@ ((eq loc 'RETURN) (wt "value0")) ; added for last inline-arg ((eq loc 'VALUES) - (wt "VALUES(0)")) + (wt "cl_env_copy->values[0]")) ((eq loc 'VA-ARG) (wt "va_arg(args,cl_object)")) ((eq loc 'CL-VA-ARG) @@ -166,7 +168,7 @@ (defun wt-character (value &optional vv) (wt (format nil "'\\~O'" value))) -(defun wt-value (i) (wt "VALUES(" i ")")) +(defun wt-value (i) (wt "cl_env_copy->values[" i "]")) (defun wt-keyvars (i) (wt "keyvars[" i "]")) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 318ec878d..506efe420 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -375,7 +375,7 @@ output = cl_safe_eval(c_string_to_object(lisp_code), Cnil, OBJNULL); ;; We should give a warning that we cannot link this module in (when flags (push flags ld-flags)) (push init-fn submodules)))))) - (setq c-file (open c-name :direction :output)) + (setq c-file (open c-name :direction :output :external-format :latin-1)) (format c-file +lisp-program-header+ submodules) (cond (shared-data-file (data-init shared-data-file) @@ -774,7 +774,7 @@ from the C language code. NIL means \"do not create the file\"." (let* ((null-stream (make-broadcast-stream)) (*compiler-output1* null-stream) (*compiler-output2* (if h-file - (open h-file :direction :output) + (open h-file :direction :output :external-format :latin-1) null-stream)) (t3local-fun (symbol-function 'T3LOCAL-FUN)) (compiler-conditions nil)) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index f4611d804..dce7c143e 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -81,10 +81,10 @@ ;; of a function. ((endp forms) (cond ((eq *destination* 'RETURN) - (wt-nl "value0=Cnil; NVALUES=0;") + (wt-nl "value0=Cnil; cl_env_copy->nvalues=0;") (unwind-exit 'RETURN)) ((eq *destination* 'VALUES) - (wt-nl "VALUES(0)=Cnil; NVALUES=0;") + (wt-nl "cl_env_copy->values[0]=Cnil; cl_env_copy->nvalues=0;") (unwind-exit 'VALUES)) (t (unwind-exit 'NIL)))) @@ -105,12 +105,12 @@ (forms (nreverse (coerce-locs (inline-args forms))))) ;; By inlining arguments we make sure that VL has no call to funct. ;; Reverse args to avoid clobbering VALUES(0) - (wt-nl "NVALUES=" nv ";") + (wt-nl "cl_env_copy->nvalues=" nv ";") (do ((vl forms (rest vl)) (i (1- (length forms)) (1- i))) ((null vl)) (declare (fixnum i)) - (wt-nl "VALUES(" i ")=" (first vl) ";")) + (wt-nl "cl_env_copy->values[" i "]=" (first vl) ";")) (unwind-exit 'VALUES) (close-inline-blocks))))) @@ -195,7 +195,7 @@ ;; If there are more variables, we have to check whether there ;; are enough values left in the stack. (when vars - (wt-nl "{int " nr "=NVALUES-" min-values ";") + (wt-nl "{int " nr "=cl_env_copy->nvalues-" min-values ";") ;; ;; Loop for assigning values to variables ;; diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index ebf458515..f78016c06 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -39,7 +39,7 @@ (let* ((new-destination (tmp-destination *destination*)) (*temp* *temp*)) (wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;") - (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open((cl_object)&_ecl_inner_frame_aux,0);") + (wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);") (let* ((*destination* new-destination) (*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*))) (c2expr* body)) @@ -72,12 +72,12 @@ (defun c1stack-pop (args) (c1expr `(c-inline ,args (t) (values &rest t) - "VALUES(0)=ecl_stack_frame_pop_values(#0);" + "cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);" :one-liner nil :side-effects t))) (defun c1apply-from-stack-frame (args) (c1expr `(c-inline ,args (t t) (values &rest t) - "VALUES(0)=ecl_apply_from_stack_frame(#0,#1);" + "cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);" :one-liner nil :side-effects t))) (put-sysprop 'with-stack 'C1 #'c1with-stack) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index a6029c4b1..523d88f7e 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -150,13 +150,13 @@ (wt-nl "{ cl_object " tag-loc ";") (setq env-grows t)) ; just to ensure closing the block (bind "new_frame_id()" tag-loc) - (wt-nl "if (frs_push(" tag-loc ")) {") + (wt-nl "if (ecl_frs_push(cl_env_copy," tag-loc ")) {") ;; Allocate labels. (dolist (tag body) (when (and (tag-p tag) (plusp (tag-ref tag))) (setf (tag-label tag) (next-label)) (setf (tag-unwind-exit tag) label) - (wt-nl "if (VALUES(0)==MAKE_FIXNUM(" (tag-index tag) "))") + (wt-nl "if (cl_env_copy->values[0]==MAKE_FIXNUM(" (tag-index tag) "))") (wt-go (tag-label tag)))) (when (var-ref-ccb tag-loc) (wt-nl "ecl_internal_error(\"GO found an inexistent tag\");")) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index cbaf131b8..ab41a17d5 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -128,6 +128,7 @@ " VLEX" *reservation-cmacro* " CLSR" *reservation-cmacro* " STCK" *reservation-cmacro*) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") (wt-nl "cl_object value0;") (wt-nl "cl_object *VVtemp;") (when shared-data @@ -349,7 +350,7 @@ " CLSR" *reservation-cmacro* " STCK" *reservation-cmacro*) (wt-nl "cl_object value0;") - (when sp (wt-nl "bds_check;")) + (when sp (wt-nl "ecl_bds_check(cl_env_copy);")) ; (when (compiler-push-events) (wt-nl "ihs_check;")) ) @@ -403,7 +404,7 @@ (wt-nl1 "{") (when (compiler-check-args) (wt-nl "check_arg(" (length arg-types) ");")) - (wt-nl "NVALUES=1;") + (wt-nl "cl_env_copy->nvalues=1;") (wt-nl "return " (case return-type (FIXNUM "MAKE_FIXNUM") (CHARACTER "CODE_CHAR") @@ -587,9 +588,12 @@ " VLEX" *reservation-cmacro* " CLSR" *reservation-cmacro* " STCK" *reservation-cmacro*) + (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();") (wt-nl *volatile* "cl_object value0;") (when (>= (fun-debug fun) 2) (wt-nl "struct ihs_frame ihs;")) + (when (policy-check-stack-overflow) + (wt-nl "ecl_cs_check(cl_env_copy,value0);")) (when (eq (fun-closure fun) 'CLOSURE) (let ((clv-used (remove-if #'(lambda (x) @@ -627,7 +631,7 @@ ;; name into the invocation stack (when (>= (fun-debug fun) 2) (push 'IHS *unwind-exit*) - (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ",Cnil);")) + (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol (fun-name fun)) ",Cnil);")) (c2lambda-expr (c1form-arg 0 lambda-expr) (c1form-arg 2 lambda-expr) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index d328872a2..661edd8cd 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -217,7 +217,7 @@ ((SPECIAL GLOBAL) (if (safe-compile) (wt "ecl_symbol_value(" var-loc ")") - (wt "SYM_VAL(" var-loc ")"))) + (wt "ECL_SYM_VAL(cl_env_copy," var-loc ")"))) (t (wt var-loc)) )) @@ -241,7 +241,7 @@ ((SPECIAL GLOBAL) (if (safe-compile) (wt-nl "cl_set(" var-loc ",") - (wt-nl "ECL_SET(" var-loc ",")) + (wt-nl "ECL_SETQ(cl_env_copy," var-loc ",")) (wt-coerce-loc (var-rep-type var) loc) (wt ");")) (t @@ -336,7 +336,7 @@ (sym-loc (make-lcl-var)) (val-loc (make-lcl-var))) (wt-nl "{cl_object " sym-loc "," val-loc ";") - (wt-nl "cl_index " lcl " = cl_env.bds_top - cl_env.bds_org;") + (wt-nl "cl_index " lcl " = cl_env_copy->bds_top - cl_env_copy->bds_org;") (push lcl *unwind-exit*) (let ((*destination* sym-loc)) (c2expr* symbols)) @@ -348,8 +348,8 @@ (wt-nl "if(type_of(CAR(" sym-loc "))!=t_symbol)") (wt-nl "FEinvalid_variable(\"~s is not a symbol.\",CAR(" sym-loc "));")) - (wt-nl "if(ecl_endp(" val-loc "))bds_bind(CAR(" sym-loc "),OBJNULL);") - (wt-nl "else{bds_bind(CAR(" sym-loc "),CAR(" val-loc "));") + (wt-nl "if(ecl_endp(" val-loc "))ecl_bds_bind(cl_env_copy,CAR(" sym-loc "),OBJNULL);") + (wt-nl "else{ecl_bds_bind(cl_env_copy,CAR(" sym-loc "),CAR(" val-loc "));") (wt-nl val-loc "=CDR(" val-loc ");}") (wt-nl sym-loc "=CDR(" sym-loc ");}") diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 5b1e3478f..d59287da7 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -143,7 +143,7 @@ (null (return-from data-dump)) ((or pathname string) (setf stream (open stream :direction :output :if-does-not-exist :create - :if-exists :supersede) + :if-exists :supersede :external-format :latin-1) must-close stream)) (stream)) (let ((*print-radix* nil) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 99e78b683..8db4f78f3 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -355,8 +355,6 @@ (proclaim-function make-echo-stream (stream stream) echo-stream) (proclaim-function make-string-input-stream (*) string-stream) (proclaim-function make-string-output-stream (*) string-stream) -(def-inline make-string-output-stream :always () string-stream - "ecl_make_string_output_stream(128)") (proclaim-function get-output-stream-string (string-stream) string) (proclaim-function streamp (t) t :predicate t) @@ -1108,7 +1106,7 @@ type_of(#0)==t_bitvector") (proclaim-function fboundp (symbol) t :predicate t) (proclaim-function symbol-value (symbol) t) (proclaim-function boundp (symbol) t :predicate t :no-side-effects t) -(def-inline boundp :always (symbol) :bool "SYM_VAL(#0)!=OBJNULL") +(def-inline boundp :always (symbol) :bool "ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL") (proclaim-function macro-function (symbol) t) (proclaim-function special-operator-p (symbol) t :predicate t) diff --git a/src/configure b/src/configure index cd433f0c3..111c98a65 100755 --- a/src/configure +++ b/src/configure @@ -4376,7 +4376,6 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { echo "$as_me:$LINENO: result: $ac_cv_ecl___thread" >&5 echo "${ECHO_T}$ac_cv_ecl___thread" >&6; } -ac_cv_ecl___thread=no @@ -10945,6 +10944,95 @@ fi done +{ echo "$as_me:$LINENO: checking for mprotect" >&5 +echo $ECHO_N "checking for mprotect... $ECHO_C" >&6; } +if test "${ac_cv_func_mprotect+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define mprotect to an innocuous variant, in case declares mprotect. + For example, HP-UX 11i declares gettimeofday. */ +#define mprotect innocuous_mprotect + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char mprotect (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef mprotect + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char mprotect (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_mprotect || defined __stub___mprotect +choke me +#endif + +int +main () +{ +return mprotect (); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && + $as_test_x conftest$ac_exeext; then + ac_cv_func_mprotect=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_cv_func_mprotect=no +fi + +rm -f core conftest.err conftest.$ac_objext conftest_ipa8_conftest.oo \ + conftest$ac_exeext conftest.$ac_ext +fi +{ echo "$as_me:$LINENO: result: $ac_cv_func_mprotect" >&5 +echo "${ECHO_T}$ac_cv_func_mprotect" >&6; } +if test $ac_cv_func_mprotect = yes; then + cat >>confdefs.h <<\_ACEOF +#define ECL_USE_MPROTECT 1 +_ACEOF + +fi + + if test ${with_cxx} = "no" ; then diff --git a/src/configure.in b/src/configure.in index ffbf189b7..363053640 100644 --- a/src/configure.in +++ b/src/configure.in @@ -532,6 +532,8 @@ AC_CHECK_FUNCS( [expf logf sqrtf cosf sinf tanf sinhf coshf tanhf] \ AC_CHECK_FUNCS( [sched_yield uname fseeko] ) +AC_CHECK_FUNC( [mprotect], AC_DEFINE(ECL_USE_MPROTECT) ) + dnl ===================================================================== dnl Checks for system services diff --git a/src/h/config.h.in b/src/h/config.h.in index 7dd1102f3..5bbc36ed4 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -82,6 +82,9 @@ /* Stack grows downwards */ #undef ECL_DOWN_STACK +/* Use mprotect for fast interrupt dispatch */ +#undef ECL_USE_MPROTECT + /* * C TYPES AND SYSTEM LIMITS */ diff --git a/src/h/ecl.h b/src/h/ecl.h index 15544f65c..e79219d72 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -67,11 +67,6 @@ typedef unsigned short uint16_t; # define CreateThread GC_CreateThread # endif # endif -# define start_critical_section() -# define end_critical_section() -#else -# define start_critical_section() -# define end_critical_section() #endif #include diff --git a/src/h/external.h b/src/h/external.h index 6a36b342d..a1ba7f322 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -10,6 +10,9 @@ extern "C" { */ struct cl_env_struct { + /* Flag for disabling interrupts while we call C library functions. */ + volatile int disable_interrupts; + /* The four stacks in ECL. */ /* @@ -57,6 +60,7 @@ struct cl_env_struct { */ cl_fixnum *cs_org; cl_fixnum *cs_limit; + cl_fixnum *cs_barrier; cl_index cs_size; /* Array where values are returned by functions. */ @@ -91,6 +95,7 @@ struct cl_env_struct { cl_object own_process; #endif int interrupt_pending; + void *interrupt_info; /* The following is a hash table for caching invocations of generic functions. In a multithreaded environment we must @@ -118,14 +123,17 @@ struct cl_env_struct { #endif #if defined(ECL_THREADS) # ifdef WITH___THREAD -extern __thread struct cl_env_struct * cl_env_p; -#define cl_env (*cl_env_p) +# define cl_env (*cl_env_p) +# define ecl_process_env() cl_env_p + extern __thread cl_env_ptr cl_env_p; # else -#define cl_env (*ecl_process_env()) -extern ECL_API struct cl_env_struct *ecl_process_env(void) __attribute__((const)); +# define cl_env (*ecl_process_env()) + extern ECL_API cl_env_ptr ecl_process_env(void) __attribute__((const)); # endif #else -extern ECL_API struct cl_env_struct cl_env; +# define cl_env (*cl_env_p) +# define ecl_process_env() cl_env_p + extern cl_env_ptr cl_env_p; #endif /* @@ -153,6 +161,9 @@ struct cl_core_struct { cl_object terminal_io; cl_object null_stream; + cl_object standard_input; + cl_object standard_output; + cl_object error_output; cl_object standard_readtable; cl_object dispatch_reader; cl_object default_dispatch_macro; @@ -185,6 +196,8 @@ struct cl_core_struct { #endif cl_object libraries; cl_object to_be_finalized; + + cl_index max_heap_size; cl_object bytes_consed; cl_object gc_counter; bool gc_stats; @@ -195,19 +208,21 @@ extern ECL_API struct cl_core_struct cl_core; /* alloc.c / alloc_2.c */ -extern ECL_API cl_object cl_alloc_object(cl_type t); -extern ECL_API cl_object cl_alloc_instance(cl_index slots); +extern ECL_API cl_object ecl_alloc_object(cl_type t); +extern ECL_API cl_object ecl_alloc_instance(cl_index slots); extern ECL_API cl_object ecl_cons(cl_object a, cl_object d); extern ECL_API cl_object ecl_list1(cl_object a); #ifdef GBC_BOEHM extern ECL_API cl_object si_gc(cl_object area); extern ECL_API cl_object si_gc_dump(void); extern ECL_API cl_object si_gc_stats(cl_object enable); -#define cl_alloc GC_malloc_ignore_off_page -#define cl_alloc_atomic GC_malloc_atomic_ignore_off_page -#define cl_alloc_align(s,d) GC_malloc_ignore_off_page(s) -#define cl_alloc_atomic_align(s,d) GC_malloc_atomic_ignore_off_page(s) -#define cl_dealloc(p) GC_free(p) +extern ECL_API void *ecl_alloc(cl_index n); +extern ECL_API void *ecl_alloc_atomic(cl_index n); +extern ECL_API void *ecl_alloc_uncollectable(size_t size); +extern ECL_API void ecl_free_uncollectable(void *); +extern ECL_API void ecl_dealloc(void *); +#define ecl_alloc_align(s,d) ecl_alloc(s) +#define ecl_alloc_atomic_align(s,d) ecl_alloc_atomic(s) #define ecl_register_static_root(x) ecl_register_root(x) #else extern ECL_API cl_object si_allocate _ARGS((cl_narg narg, cl_object type, cl_object qty, ...)); @@ -220,13 +235,13 @@ extern ECL_API cl_object si_allocate_contiguous_pages _ARGS((cl_narg narg, cl_ob extern ECL_API cl_object si_get_hole_size _ARGS((cl_narg narg)); extern ECL_API cl_object si_set_hole_size _ARGS((cl_narg narg, cl_object size)); extern ECL_API cl_object si_ignore_maximum_pages _ARGS((cl_narg narg, ...)); -extern ECL_API void *cl_alloc(cl_index n); -extern ECL_API void *cl_alloc_align(cl_index size, cl_index align); +extern ECL_API void *ecl_alloc(cl_index n); +extern ECL_API void *ecl_alloc_align(cl_index size, cl_index align); extern ECL_API void *ecl_alloc_uncollectable(size_t size); extern ECL_API void ecl_free_uncollectable(void *); -extern ECL_API void cl_dealloc(void *p); -#define cl_alloc_atomic(x) cl_alloc(x) -#define cl_alloc_atomic_align(x,s) cl_alloc_align(x,s) +extern ECL_API void ecl_dealloc(void *p); +#define ecl_alloc_atomic(x) ecl_alloc(x) +#define ecl_alloc_atomic_align(x,s) ecl_alloc_align(x,s) #define ecl_register_static_root(x) ecl_register_root(x); #endif /* GBC_BOEHM */ @@ -435,11 +450,11 @@ extern ECL_API cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, . /* interpreter.c */ extern ECL_API cl_object si_interpreter_stack _ARGS((cl_narg narg)); -extern ECL_API cl_object ecl_stack_frame_open(cl_object f, cl_index size); +extern ECL_API cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size); extern ECL_API void ecl_stack_frame_enlarge(cl_object f, cl_index size); extern ECL_API void ecl_stack_frame_push(cl_object f, cl_object o); extern ECL_API void ecl_stack_frame_push_values(cl_object f); -extern ECL_API cl_object ecl_stack_frame_from_va_list(cl_object f, cl_va_list args); +extern ECL_API cl_object ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object f, cl_va_list args); extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f); extern ECL_API cl_object ecl_stack_frame_elt(cl_object f, cl_index n); extern ECL_API void ecl_stack_frame_elt_set(cl_object f, cl_index n, cl_object o); @@ -449,17 +464,17 @@ extern ECL_API cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o); #define ECL_STACK_FRAME_SIZE(f) ((f)->frame.top - (f)->frame.bottom) #define si_apply_from_stack_frame ecl_apply_from_stack_frame -extern ECL_API void cl_stack_push(cl_object o); -extern ECL_API cl_object cl_stack_pop(void); -extern ECL_API cl_index cl_stack_index(void); -extern ECL_API void cl_stack_set_size(cl_index new_size); -extern ECL_API void cl_stack_set_index(cl_index sp); -extern ECL_API void cl_stack_pop_n(cl_index n); -extern ECL_API void cl_stack_insert(cl_index where, cl_index n); -extern ECL_API cl_index cl_stack_push_list(cl_object list); -extern ECL_API void cl_stack_push_n(cl_index n, cl_object *args); -extern ECL_API cl_index cl_stack_push_values(void); -extern ECL_API void cl_stack_pop_values(cl_index n); +extern ECL_API void ecl_stack_push(cl_env_ptr env, cl_object o); +extern ECL_API cl_object ecl_stack_pop(cl_env_ptr env); +extern ECL_API cl_index ecl_stack_index(cl_env_ptr env); +extern ECL_API void ecl_stack_set_size(cl_env_ptr env, cl_index new_size); +extern ECL_API void ecl_stack_set_index(cl_env_ptr env, cl_index sp); +extern ECL_API void ecl_stack_pop_n(cl_env_ptr env, cl_index n); +extern ECL_API void ecl_stack_insert(cl_env_ptr env, cl_index where, cl_index n); +extern ECL_API cl_index ecl_stack_push_list(cl_env_ptr env, cl_object list); +extern ECL_API void ecl_stack_push_n(cl_env_ptr env, cl_index n, cl_object *args); +extern ECL_API cl_index ecl_stack_push_values(cl_env_ptr env); +extern ECL_API void ecl_stack_pop_values(cl_env_ptr env, cl_index n); extern ECL_API cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset); /* disassembler.c */ @@ -587,9 +602,11 @@ extern ECL_API cl_object si_set_buffering_mode(cl_object strm, cl_object mode); extern ECL_API bool ecl_input_stream_p(cl_object strm); extern ECL_API bool ecl_output_stream_p(cl_object strm); -extern ECL_API cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, bool char_stream_p, bool use_header_p); +extern ECL_API cl_object ecl_stream_element_type(cl_object strm); +extern ECL_API bool ecl_interactive_stream_p(cl_object strm); +extern ECL_API cl_object ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, cl_object if_does_not_exist, cl_fixnum byte_size, int flags); extern ECL_API cl_object ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend); -extern ECL_API cl_object ecl_make_string_output_stream(cl_index line_length); +extern ECL_API cl_object ecl_make_string_output_stream(cl_index line_length, int extended); extern ECL_API cl_object ecl_read_byte(cl_object strm); extern ECL_API void ecl_write_byte(cl_object byte, cl_object strm); extern ECL_API int ecl_read_char_noeof(cl_object strm); @@ -598,16 +615,17 @@ extern ECL_API void ecl_unread_char(int c, cl_object strm); extern ECL_API int ecl_peek_char(cl_object strm); extern ECL_API int ecl_write_char(int c, cl_object strm); extern ECL_API void writestr_stream(const char *s, cl_object strm); -#define ecl_finish_output(x) ecl_force_output(x) extern ECL_API void ecl_force_output(cl_object strm); +extern ECL_API void ecl_finish_output(cl_object strm); extern ECL_API void ecl_clear_input(cl_object strm); extern ECL_API void ecl_clear_output(cl_object strm); extern ECL_API bool ecl_listen_stream(cl_object strm); extern ECL_API cl_object ecl_file_position(cl_object strm); extern ECL_API cl_object ecl_file_position_set(cl_object strm, cl_object disp); +extern ECL_API cl_object ecl_file_length(cl_object strm); extern ECL_API int ecl_file_column(cl_object strm); -extern ECL_API cl_object ecl_make_stream_from_fd(cl_object host, int fd, enum ecl_smmode smm); -extern ECL_API cl_object ecl_make_stream_from_FILE(cl_object host, void *fd, enum ecl_smmode smm); +extern ECL_API cl_object ecl_make_stream_from_fd(cl_object fname, int fd, enum ecl_smmode smm, cl_fixnum byte_size, int char_stream_p); +extern ECL_API cl_object ecl_make_stream_from_FILE(cl_object fname, void *fd, enum ecl_smmode smm, cl_fixnum byte_size, int char_stream_p); extern ECL_API int ecl_stream_to_handle(cl_object s, bool output); /* finalize.c */ @@ -647,7 +665,7 @@ extern ECL_API void ecl_register_root(cl_object *p); /* gfun.c */ #ifdef CLOS -extern ECL_API void _ecl_set_method_hash_size(struct cl_env_struct *env, cl_index size); +extern ECL_API void _ecl_set_method_hash_size(cl_env_ptr env, cl_index size); extern ECL_API cl_object si_clear_gfun_hash(cl_object what); extern ECL_API cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t); extern ECL_API cl_object si_generic_function_p(cl_object instance); @@ -854,6 +872,8 @@ typedef enum { ECL_OPT_C_STACK_SIZE, ECL_OPT_C_STACK_SAFETY_AREA, ECL_OPT_SIGALTSTACK_SIZE, + ECL_OPT_HEAP_SIZE, + ECL_OPT_HEAP_SAFETY_AREA, ECL_OPT_LIMIT } ecl_option; @@ -1265,6 +1285,8 @@ extern ECL_API cl_object cl_make_dispatch_macro_character _ARGS((cl_narg narg, c extern ECL_API cl_object cl_set_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, cl_object fnc, ...)); extern ECL_API cl_object cl_get_dispatch_macro_character _ARGS((cl_narg narg, cl_object dspchr, cl_object subchr, ...)); +extern ECL_API int ecl_readtable_get(cl_object rdtbl, int c, cl_object *macro); +extern ECL_API void ecl_readtable_set(cl_object rdtbl, int c, enum ecl_chattrib cat, cl_object macro_or_table); extern ECL_API cl_object ecl_read_object_non_recursive(cl_object in); extern ECL_API cl_object ecl_read_object(cl_object in); extern ECL_API cl_object ecl_parse_number(cl_object s, cl_index start, cl_index end, cl_index *ep, unsigned int radix); @@ -1320,11 +1342,12 @@ extern ECL_API cl_object si_bds_var(cl_object arg); extern ECL_API cl_object si_bds_val(cl_object arg); extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs); extern ECL_API cl_object si_reset_stack_limits(void); -extern ECL_API cl_object si_set_stack_size(cl_object type, cl_object size); +extern ECL_API cl_object si_set_limit(cl_object type, cl_object size); +extern ECL_API cl_object si_get_limit(cl_object type); -extern ECL_API void bds_overflow(void) /*__attribute__((noreturn))*/; -extern ECL_API void bds_unwind(cl_index new_bds_top_index); -extern ECL_API void ecl_unwind(ecl_frame_ptr fr) /*__attribute__((noreturn))*/; +extern ECL_API void ecl_bds_overflow(void) /*__attribute__((noreturn))*/; +extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index); +extern ECL_API void ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) /*__attribute__((noreturn))*/; extern ECL_API ecl_frame_ptr frs_sch(cl_object frame_id); extern ECL_API ecl_frame_ptr frs_sch_catch(cl_object frame_id); extern ECL_API cl_object new_frame_id(void); @@ -1533,10 +1556,9 @@ extern ECL_API cl_object cl_user_homedir_pathname _ARGS((cl_narg narg, ...)); extern ECL_API cl_object si_mkstemp(cl_object templ); extern ECL_API cl_object si_rmdir(cl_object directory); -extern ECL_API const char *ecl_expand_pathname(const char *name); extern ECL_API cl_object ecl_cstring_to_pathname(char *s); -extern ECL_API void *ecl_backup_fopen(const char *filename, const char *option); -extern ECL_API cl_object ecl_file_len(void *fp); +extern ECL_API int ecl_backup_open(const char *filename, int option, int mode); +extern ECL_API cl_object ecl_file_len(int f); extern ECL_API cl_object ecl_homedir_pathname(cl_object user); #if defined(_MSC_VER) || defined(mingw32) extern ECL_API cl_object si_get_library_pathname(void); @@ -1546,9 +1568,23 @@ extern ECL_API cl_object si_get_library_pathname(void); /* unixint.c */ +#ifdef ECL_USE_MPROTECT +#define ecl_disable_interrupts_env(env) ((env)->disable_interrupts=1) +#define ecl_enable_interrupts_env(env) ((env)->disable_interrupts=0) +#else +#define ecl_disable_interrupts_env(env) ((env)->disable_interrupts=1) +#define ecl_enable_interrupts_env(env) (((env)->disable_interrupts^=1) && (ecl_check_pending_interrupts(),0)) +#endif +#define ecl_disable_interrupts() ecl_disable_interrupts_env(&cl_env) +#define ecl_enable_interrupts() ecl_enable_interrupts_env(&cl_env) +#define ECL_PSEUDO_ATOMIC_ENV(env,stmt) (ecl_disable_interrupts_env(env),(stmt),ecl_enable_interrupts_env(env)) +#define ECL_PSEUDO_ATOMIC(stmt) (ecl_disable_interrupts(),(stmt),ecl_enable_interrupts()) extern ECL_API cl_object si_catch_signal(cl_object signal, cl_object state); extern ECL_API cl_object si_check_pending_interrupts(void); +extern ECL_API cl_object si_disable_interrupts(void); +extern ECL_API cl_object si_enable_interrupts(void); extern ECL_API cl_object si_trap_fpe(cl_object condition, cl_object flag); +extern ECL_API void ecl_check_pending_interrupts(void); /* unixsys.c */ @@ -1566,6 +1602,7 @@ extern ECL_API cl_object si_base_string_p(cl_object x); extern ECL_API cl_object si_coerce_to_base_string(cl_object x); extern ECL_API cl_object si_coerce_to_extended_string(cl_object x); extern ECL_API cl_object cl_alloc_simple_extended_string(cl_index l); +extern ECL_API cl_object ecl_alloc_adjustable_extended_string(cl_index l); #else #define si_base_char_p cl_characterp #define si_base_string_p cl_stringp @@ -1785,6 +1822,7 @@ extern ECL_API cl_object clos_install_method _ARGS((cl_narg narg, cl_object V1, /* standard.lsp */ extern ECL_API cl_object clos_standard_instance_set _ARGS((cl_narg narg, cl_object V1, cl_object V2, cl_object V3, ...)); #endif + #endif #ifdef __cplusplus diff --git a/src/h/internal.h b/src/h/internal.h index 4599d81b0..e99cc8c5d 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -25,8 +25,8 @@ extern "C" { extern void init_all_symbols(void); extern void init_alloc(void); extern void init_backq(void); -extern void init_big(void); -extern void init_big_registers(void); +extern void init_big(cl_env_ptr); +extern void init_big_registers(cl_env_ptr); #ifdef CLOS extern void init_clos(void); #endif @@ -39,17 +39,23 @@ extern void init_GC(void); extern void init_macros(void); extern void init_number(void); extern void init_read(void); -extern void init_stacks(struct cl_env_struct *, int *); +extern void init_stacks(cl_env_ptr, int *); extern void init_unixint(int pass); extern void init_unixtime(void); #ifdef mingw32 extern void init_compiler(void); #endif -extern void ecl_init_env(struct cl_env_struct *); +#ifdef ECL_THREADS +extern void init_threads(cl_env_ptr); +#endif +extern void ecl_init_env(cl_env_ptr); extern void init_lib_LSP(cl_object); +extern cl_env_ptr _ecl_alloc_env(void); + /* alloc.d/alloc_2.d */ +extern void _ecl_set_max_heap_size(cl_index new_size); extern cl_object ecl_alloc_bytecodes(cl_index data_size, cl_index code_size); /* compiler.d */ @@ -70,12 +76,12 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr; /* interpreter.d */ -#define cl_stack_ref(n) cl_env.stack[n] -#define cl_stack_index() (cl_env.stack_top-cl_env.stack) +#define ecl_stack_ref(env,n) (env)->stack[n] +#define ecl_stack_index(env) ((env)->stack_top-(env)->stack) -#define ECL_BUILD_STACK_FRAME(name,frame) \ +#define ECL_BUILD_STACK_FRAME(env,name,frame) \ struct ecl_stack_frame frame;\ - cl_object name = ecl_stack_frame_open((cl_object)&frame, 0); + cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0); /* ffi.d */ @@ -117,6 +123,28 @@ extern void* ecl_dynamic_callback_make(cl_object data, enum ecl_ffi_calling_conv #define OPEN_A "ab" #define OPEN_RA "a+b" +#define STRING_OUTPUT_STRING(strm) (strm)->stream.object0 +#define STRING_OUTPUT_COLUMN(strm) (strm)->stream.int1 +#define STRING_INPUT_STRING(strm) (strm)->stream.object0 +#define STRING_INPUT_POSITION(strm) (strm)->stream.int0 +#define STRING_INPUT_LIMIT(strm) (strm)->stream.int1 +#define TWO_WAY_STREAM_INPUT(strm) (strm)->stream.object0 +#define TWO_WAY_STREAM_OUTPUT(strm) (strm)->stream.object1 +#define SYNONYM_STREAM_SYMBOL(strm) (strm)->stream.object0 +#define SYNONYM_STREAM_STREAM(strm) ecl_symbol_value((strm)->stream.object0) +#define BROADCAST_STREAM_LIST(strm) (strm)->stream.object0 +#define ECHO_STREAM_INPUT(strm) (strm)->stream.object0 +#define ECHO_STREAM_OUTPUT(strm) (strm)->stream.object1 +#define CONCATENATED_STREAM_LIST(strm) (strm)->stream.object0 +#define IO_STREAM_FILE(strm) (FILE*)((strm)->stream.file) +#define IO_STREAM_COLUMN(strm) (strm)->stream.int1 +#define IO_STREAM_ELT_TYPE(strm) (strm)->stream.object0 +#define IO_STREAM_FILENAME(strm) (strm)->stream.object1 +#define IO_FILE_DESCRIPTOR(strm) (int)((strm)->stream.file) +#define IO_FILE_COLUMN(strm) (strm)->stream.int1 +#define IO_FILE_ELT_TYPE(strm) (strm)->stream.object0 +#define IO_FILE_FILENAME(strm) (strm)->stream.object1 + /* format.d */ #ifndef ECL_CMU_FORMAT @@ -193,8 +221,6 @@ extern cl_fixnum ecl_runtime(void); /* unixint.d */ -extern bool ecl_interrupt_enable; - #if defined(_MSC_VER) || defined(mingw32) # include # if defined(_MSC_VER) diff --git a/src/h/object.h b/src/h/object.h index be3b90fc9..826ef587e 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -454,8 +454,11 @@ struct ecl_structure { /* structure header */ enum ecl_smmode { /* stream mode */ smm_input, /* input */ + smm_input_file, /* input */ smm_output, /* output */ + smm_output_file, /* output */ smm_io, /* input-output */ + smm_io_file, /* input-output */ smm_synonym, /* synonym */ smm_broadcast, /* broadcast */ smm_concatenated, /* concatenated */ @@ -472,22 +475,71 @@ enum ecl_smmode { /* stream mode */ #endif }; +struct ecl_file_ops { + cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n); + cl_index (*read_byte8)(cl_object strm, unsigned char *c, cl_index n); + + int (*read_char)(cl_object strm); + int (*write_char)(cl_object strm, int c); + void (*unread_char)(cl_object strm, int c); + int (*peek_char)(cl_object strm); + + cl_index (*read_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); + cl_index (*write_vector)(cl_object strm, cl_object data, cl_index start, cl_index end); + + int (*listen)(cl_object strm); + void (*clear_input)(cl_object strm); + void (*clear_output)(cl_object strm); + void (*finish_output)(cl_object strm); + void (*force_output)(cl_object strm); + + int (*input_p)(cl_object strm); + int (*output_p)(cl_object strm); + int (*interactive_p)(cl_object strm); + cl_object (*element_type)(cl_object strm); + + cl_object (*length)(cl_object strm); + cl_object (*get_position)(cl_object strm); + cl_object (*set_position)(cl_object strm, cl_object pos); + int (*column)(cl_object strm); + + cl_object (*close)(cl_object strm); +}; + +enum { + ECL_STREAM_BINARY = 0, + ECL_STREAM_FORMAT = 0xF, +#ifdef ECL_UNICODE + ECL_STREAM_DEFAULT_FORMAT = 2, +#else + ECL_STREAM_DEFAULT_FORMAT = 1, +#endif + ECL_STREAM_ISO_8859_1 = 1, + ECL_STREAM_LATIN_1 = 1, + ECL_STREAM_UTF_8 = 2, + ECL_STREAM_UCS_2 = 3, + ECL_STREAM_UCS_4 = 4, + ECL_STREAM_SIGNED_BYTES = 16, + ECL_STREAM_C_STREAM = 32, + ECL_STREAM_MIGHT_SEEK = 64 +}; + struct ecl_stream { - HEADER4(mode,closed,char_stream_p,signed_bytes); - /* stream mode of enum smmode */ - /* stream element type */ - void *file; /* file pointer */ + HEADER2(mode,closed); + /* stream mode of enum smmode */ + /* closed stream? */ + struct ecl_file_ops *ops; /* dispatch table */ + void *file; /* file pointer */ cl_object object0; /* some object */ cl_object object1; /* some object */ + cl_fixnum unread; /* one-char buffer for unread-char */ cl_fixnum int0; /* some int */ cl_fixnum int1; /* some int */ - char *buffer; /* file buffer */ cl_index byte_size; /* size of byte in binary streams */ - unsigned char bit_buffer; - uint8_t bits_left; - int8_t buffer_state; /* 0: unknown, 1: reading, -1: writing */ - uint8_t header; /* number of significant bits in the last byte */ - int8_t last_op; /* 0: unknown, 1: reading, -1: writing */ + cl_fixnum last_op; /* 0: unknown, 1: reading, -1: writing */ + char *buffer; /* buffer for FILE */ + cl_object format; /* external format */ + int flags; /* character table, flags, etc */ }; struct ecl_random { @@ -506,13 +558,7 @@ enum ecl_chattrib { /* character attribute */ struct ecl_readtable_entry { /* read table entry */ enum ecl_chattrib syntax_type; /* character attribute */ - cl_object macro; /* macro function */ - cl_object *dispatch_table; /* pointer to the */ - /* dispatch table */ - /* NULL for */ - /* non-dispatching */ - /* macro character, or */ - /* non-macro character */ + cl_object dispatch; /* a macro, a hash or NIL */ }; enum ecl_readtable_case { @@ -522,10 +568,13 @@ enum ecl_readtable_case { ecl_case_preserve, }; -struct ecl_readtable { /* read table */ +struct ecl_readtable { /* read table */ HEADER; enum ecl_readtable_case read_case; /* readtable-case */ struct ecl_readtable_entry *table; /* read table itself */ +#ifdef ECL_UNICODE + cl_object hash; /* hash for values outside base-char range */ +#endif }; struct ecl_pathname { @@ -566,7 +615,7 @@ struct ecl_bytecodes { char *code; /* the intermediate language */ cl_object *data; /* non-inmediate constants used in the code */ cl_object file; /* file where it was defined... */ - cl_index file_position; /* and where it was created */ + cl_object file_position;/* and where it was created */ }; struct ecl_bclosure { @@ -645,6 +694,7 @@ struct ecl_stack_frame { cl_object *bottom; /* Bottom part */ cl_object *top; /* Top part */ cl_object *stack; /* Is this relative to the lisp stack? */ + struct cl_env_struct *env; }; /* diff --git a/src/h/stacks.h b/src/h/stacks.h index be9ec668b..d92b6c65b 100644 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -5,6 +5,7 @@ /* Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. Copyright (c) 1990, Giuseppe Attardi. + Copyright (c) 2000, 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 @@ -23,9 +24,9 @@ extern "C" { ***********/ #ifdef ECL_DOWN_STACK -#define ecl_cs_check(var) if ((int*)(&var) <= cl_env.cs_limit) ecl_cs_overflow() +#define ecl_cs_check(env,var) if ((int*)(&var) <= (env)->cs_limit) ecl_cs_overflow() #else -#define ecl_cs_check(var) if ((int*)(&var) >= cl_env.cs_limit) ecl_cs_overflow() +#define ecl_cs_check(env,var) if ((int*)(&var) >= (env)->cs_limit) ecl_cs_overflow() #endif /************** @@ -37,39 +38,46 @@ typedef struct bds_bd { cl_object value; /* previous value of the symbol */ } *bds_ptr; -#define bds_check \ - ((cl_env.bds_top >= cl_env.bds_limit)? bds_overflow() : (void)0) +#define ecl_bds_check(env) \ + ((env->bds_top >= env->bds_limit)? ecl_bds_overflow() : (void)0) + +typedef struct cl_env_struct *cl_env_ptr; #ifdef ECL_THREADS -extern ECL_API void bds_bind(cl_object symbol, cl_object value); -extern ECL_API void bds_push(cl_object symbol); -extern ECL_API void bds_unwind1(); -extern ECL_API cl_object *ecl_symbol_slot(cl_object s); -#define SYM_VAL(s) (*ecl_symbol_slot(s)) -#if 0 +extern ECL_API void ecl_bds_bind(cl_env_ptr env, cl_object symbol, cl_object v); +extern ECL_API void ecl_bds_push(cl_env_ptr env, cl_object symbol); +extern ECL_API void ecl_bds_unwind1(cl_env_ptr env); +extern ECL_API cl_object *ecl_symbol_slot(cl_env_ptr env, cl_object s); +extern ECL_API cl_object ecl_set_symbol(cl_env_ptr env, cl_object s, cl_object v); +#define ECL_SYM_VAL(env,s) (*ecl_symbol_slot(env,s)) #define ECL_SET(s,v) ((s)->symbol.value=(v)) -#define ECL_SETQ(s,v) (*ecl_symbol_slot(s)=(v)) +#define ECL_SETQ(env,s,v) (ecl_set_symbol(env,s,v)) #else -extern ECL_API cl_object ecl_set_symbol(cl_object s, cl_object v); -#define ECL_SET(s,v) (ecl_set_symbol(s,v)) -#define ECL_SETQ(s,v) (ecl_set_symbol(s,v)) -#endif -#else -#define SYM_VAL(s) ((s)->symbol.value) +#define ECL_SYM_VAL(env,s) ((s)->symbol.value) #define ECL_SET(s,v) ((s)->symbol.value=(v)) -#define ECL_SETQ(s,v) ((s)->symbol.value=(v)) -#define bds_bind(sym, val) \ - (bds_check,(++cl_env.bds_top)->symbol = (sym), \ - cl_env.bds_top->value = SYM_VAL(sym), \ - SYM_VAL(sym) = (val)) - -#define bds_push(sym) \ - (bds_check,(++cl_env.bds_top)->symbol = (sym), cl_env.bds_top->value = SYM_VAL(sym)) - -#define bds_unwind1() \ - (SYM_VAL(cl_env.bds_top->symbol) = cl_env.bds_top->value, --cl_env.bds_top) +#define ECL_SETQ(env,s,v) ((s)->symbol.value=(v)) +#define ecl_bds_bind(env,sym,val) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = (sym); \ + const cl_object v = (val); \ + ecl_bds_check(env_copy); \ + (++(env_copy->bds_top))->symbol = s, \ + env_copy->bds_top->value = s->symbol.value; \ + s->symbol.value = v; } while (0) +#define ecl_bds_push(env,sym) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = (sym); \ + const cl_object v = s->symbol.value; \ + ecl_bds_check(env_copy); \ + (++(env_copy->bds_top))->symbol = s, \ + env_copy->bds_top->value = s->symbol.value; } while (0); +#define ecl_bds_unwind1(env) do { \ + const cl_env_ptr env_copy = (env); \ + const cl_object s = env_copy->bds_top->symbol; \ + s->symbol.value = env_copy->bds_top->value; \ + --(env_copy->bds_top); } while (0) #endif /* ECL_THREADS */ -extern ECL_API void bds_unwind_n(int n); +extern ECL_API void ecl_bds_unwind_n(cl_env_ptr env, int n); /**************************** * INVOCATION HISTORY STACK @@ -82,15 +90,20 @@ typedef struct ihs_frame { cl_index index; } *ihs_ptr; -#define ihs_push(r,f,e) do { \ - (r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env=(e); \ - (r)->index=cl_env.ihs_top->index+1;\ - cl_env.ihs_top = (r); \ +#define ecl_ihs_push(env,rec,fun,lisp_env) do { \ + const cl_env_ptr __the_env = (env); \ + struct ihs_frame * const r = (rec); \ + r->next=__the_env->ihs_top; \ + r->function=(fun); \ + r->lex_env=(lisp_env); \ + r->index=__the_env->ihs_top->index+1; \ + __the_env->ihs_top = r; \ } while(0) -#define ihs_pop() do {\ - if (cl_env.ihs_top->next == NULL) ecl_internal_error("Underflow in IHS stack"); \ - cl_env.ihs_top = cl_env.ihs_top->next; \ +#define ecl_ihs_pop(env) do { \ + const cl_env_ptr __the_env = (env); \ + struct ihs_frame *r = __the_env->ihs_top; \ + if (r) __the_env->ihs_top = r->next; \ } while(0) extern ECL_API cl_object ihs_top_function_name(void); @@ -102,16 +115,16 @@ extern ECL_API cl_object ihs_top_function_name(void); * Frames are established, for instance, by CATCH, BLOCK, TAGBODY, * LAMBDA, UNWIND-PROTECT, etc. * - * Frames are established by frs_push(). For each call to frs_push() - * there must be a corresponding frs_pop(). More precisely, since our + * Frames are established by ecl_frs_push(). For each call to ecl_frs_push() + * there must be a corresponding ecl_frs_pop(). More precisely, since our * frame mechanism relies on the C stack and on the setjmp/longjmp * functions, any function that creates a frame must also destroy it - * with frs_pop() before returning. + * with ecl_frs_pop() before returning. * * Frames are identified by a value frs_val. This can be either a * unique identifier, created for each CATCH, BLOCK, etc, or a common * one ECL_PROTECT_TAG, used by UNWIND-PROTECT forms. The first type - * of frames can be target of a search frs_sch() and thus one can jump + * of frames can be target of a search ecl_frs_sch() and thus one can jump * to them. The second type of frames are like barriers designed to * intercept the jumps to the outer frames and are called * automatically by the function unwind() whenever it jumps to a frame @@ -126,9 +139,9 @@ typedef struct ecl_frame { cl_index frs_sp; } *ecl_frame_ptr; -extern ECL_API ecl_frame_ptr _frs_push(register cl_object val); -#define frs_push(val) ecl_setjmp(_frs_push(val)->frs_jmpbuf) -#define frs_pop() (cl_env.frs_top--) +extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_object); +#define ecl_frs_push(env,val) ecl_setjmp(_ecl_frs_push(env,val)->frs_jmpbuf) +#define ecl_frs_pop(env) ((env)->frs_top--) /******************* * ARGUMENTS STACK @@ -202,47 +215,52 @@ extern ECL_API ecl_frame_ptr _frs_push(register cl_object val); *********************************/ #define CL_NEWENV_BEGIN {\ - cl_index __i = cl_stack_push_values(); \ + const cl_env_ptr the_env = ecl_process_env(); \ + cl_index __i = ecl_stack_push_values(the_env); \ #define CL_NEWENV_END \ - cl_stack_pop_values(__i); } + ecl_stack_pop_values(the_env,__i); } -#define CL_UNWIND_PROTECT_BEGIN {\ +#define CL_UNWIND_PROTECT_BEGIN(the_env) do { \ bool __unwinding; ecl_frame_ptr __next_fr; \ + const cl_env_ptr __the_env = (the_env); \ cl_index __nr; \ - if (frs_push(ECL_PROTECT_TAG)) { \ - __unwinding=1; __next_fr=cl_env.nlj_fr; \ + if (ecl_frs_push(__the_env,ECL_PROTECT_TAG)) { \ + __unwinding=1; __next_fr=__the_env->nlj_fr; \ } else { #define CL_UNWIND_PROTECT_EXIT \ __unwinding=0; } \ - frs_pop(); \ - __nr = cl_stack_push_values(); + ecl_frs_pop(__the_env); \ + __nr = ecl_stack_push_values(__the_env); #define CL_UNWIND_PROTECT_END \ - cl_stack_pop_values(__nr); \ - if (__unwinding) ecl_unwind(__next_fr); } + ecl_stack_pop_values(__the_env,__nr); \ + if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) -#define CL_BLOCK_BEGIN(id) { \ - cl_object id = new_frame_id(); \ - if (frs_push(id) == 0) +#define CL_BLOCK_BEGIN(the_env,id) do { \ + const cl_object __id = new_frame_id(); \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,__id) == 0) -#define CL_BLOCK_END } \ - frs_pop() +#define CL_BLOCK_END \ + ecl_frs_pop(__the_env); } while(0) -#define CL_CATCH_BEGIN(tag) \ - if (frs_push(tag) == 0) { +#define CL_CATCH_BEGIN(the_env,tag) do { \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,tag) == 0) { #define CL_CATCH_END } \ - frs_pop(); + frs_pop(); } while (0) -#define CL_CATCH_ALL_BEGIN \ - if (frs_push(ECL_PROTECT_TAG) == 0) { +#define CL_CATCH_ALL_BEGIN(the_env) do { \ + const cl_env_ptr __the_env = (the_env); \ + if (ecl_frs_push(__the_env,ECL_PROTECT_TAG) == 0) { #define CL_CATCH_ALL_IF_CAUGHT } else { #define CL_CATCH_ALL_END } \ - frs_pop() + ecl_frs_pop(__the_env); } while(0) #ifdef __cplusplus } diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 6a1209a8f..bfc8c85e1 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -735,7 +735,7 @@ defined Lisp function and VALUE-TYPE is its the return type." (c-inline ,args ,arg-types ,result-type ,C-expr :one-liner t)))) -(defmacro defentry (name arg-types c-name) +(defmacro defentry (name arg-types c-name &key no-interrupts) "Syntax: (defentry symbol ({arg-type}*) (value-type function-name)) The compiler defines a Lisp function named by SYMBOL whose body consists of a @@ -748,9 +748,15 @@ CHAR, CHAR*, FLOAT, DOUBLE are allowed for these types." (if (consp c-name) (setf output-type (first c-name) c-name (second c-name))) - (setf c-name (string c-name)) - `(defun ,name ,args - (c-inline ,args ,arg-types ,output-type - ,(produce-function-call c-name (length arg-types)) - :one-liner t)))) + (let* ((call (produce-function-call (string c-name) (length arg-types))) + (full-text (if no-interrupts + (concatenate 'string + "ecl_disable_interrupts();@(return)=" + call + ";ecl_enable_interrupts();") + call))) + `(defun ,name ,args + (c-inline ,args ,arg-types ,output-type + ,full-text + :one-liner ,(not no-interrupts)))))) diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp index 396bec3bc..bfa41f07e 100644 --- a/src/lsp/format.lsp +++ b/src/lsp/format.lsp @@ -1996,7 +1996,7 @@ :downcase))))) ,@(expand-directive-list before)) #+ecl - `(let ((string (make-array 10 :element-type 'base-char + `(let ((string (make-array 10 :element-type 'character :fill-pointer 0 :adjustable t))) (unwind-protect (with-output-to-string (stream string) @@ -2033,7 +2033,7 @@ (before (subseq directives 0 posn)) (jumped t) (after (nthcdr (1+ posn) directives)) - (string (make-array 10 :element-type 'base-char + (string (make-array 10 :element-type 'character :adjustable t :fill-pointer 0))) (unwind-protect (with-output-to-string (stream string) diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp index 424371e3e..d929a0c99 100644 --- a/src/lsp/pprint.lsp +++ b/src/lsp/pprint.lsp @@ -145,7 +145,7 @@ (defun pretty-out (stream char) (declare (type pretty-stream stream) - (type base-char char) + (type character char) (si::c-local)) (cond ((char= char #\newline) (enqueue-newline stream :literal))