[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Gcl-devel] 2.5.4 candidate
|
From: |
Camm Maguire |
|
Subject: |
[Gcl-devel] 2.5.4 candidate |
|
Date: |
17 Jul 2003 14:19:35 -0400 |
|
User-agent: |
Gnus/5.09 (Gnus v5.9.0) Emacs/21.2 |
Greetings! I've setup a Version_2_5_4 tag with what I think are the
bugfix only changes from cvs head against 2.5.3. Please check it out
-- i.e. co or export the source with -r Version_2_5_4, and run your
favorite stuff against it. I've included below the diff against
2.5.3, as well as the diff against CVS head.
BTW, I've noticed with great satisfaction that a number of
contributors are checking in changes against the core files in o/,
etc. This is good, as I think GCL needs a diversity of contributors
to thrive. Some of the patches are quite large though, and difficult
to sort through, consisting of many changes in whitespace, etc. This
makes it difficult for me to read and certify for release. May I
please suggest that patches against these core files, and which are
not escaped with arch-specific ifdef's, not touch the formatting, and
be as terse as possible. We should prettify the code in one step at a
future point, IMHO. It does seem like some of the changes which I
have not incorporated into 2.5.4 remove global variable
initializations, e.g. in gbc.c and main.c -- why is this? Mike, I
think these are your mods?
I will also consider any ansi fixes which are immediate in the bugfix
category for consideration in 2.5.4.
Take care,
=============================================================================
against HEAD
=============================================================================
Index: h/gclincl.h.in
===================================================================
RCS file: /cvsroot/gcl/gcl/h/gclincl.h.in,v
retrieving revision 1.28
retrieving revision 1.27
diff -u -r1.28 -r1.27
--- h/gclincl.h.in 1 Jul 2003 07:32:16 -0000 1.28
+++ h/gclincl.h.in 26 Feb 2003 23:26:41 -0000 1.27
@@ -182,8 +182,6 @@
#undef HAVE_JAPI_H
-#undef HAVE_XDR
-
/* The number of bytes in a long *. */
#undef SIZEOF_LONG_P
Index: h/mingw.defs
===================================================================
RCS file: /cvsroot/gcl/gcl/h/mingw.defs,v
retrieving revision 1.29
retrieving revision 1.26
diff -u -r1.29 -r1.26
--- h/mingw.defs 7 Jul 2003 04:40:46 -0000 1.29
+++ h/mingw.defs 18 Feb 2003 02:32:03 -0000 1.26
@@ -7,7 +7,7 @@
SHELL = sh
OFLAG = -O
-LIBS += -lws2_32
+LIBS += -lwsock32
LIBC =
ODIR_DEBUG = -g
@@ -20,8 +20,8 @@
# MPIOBJS = $(MPIDIR)/mpi_glue.o
# LIBS += -L$(MPICHDIR)/lib -lmpich
-CFLAGS = -mms-bitfields -Wall -fwritable-strings -DVOL=volatile
-fsigned-char $(PROCESSOR_FLAGS) $(ODIR_DEBUG) -I$(GCLDIR)/o
-FINAL_CFLAGS = -mms-bitfields -Wall -fwritable-strings -DVOL=volatile
-fsigned-char $(PROCESSOR_FLAGS) $(ODIR_DEBUG)
+CFLAGS = -Wall -fwritable-strings -DVOL=volatile -fsigned-char
$(PROCESSOR_FLAGS) -I$(GCLDIR)/o
+FINAL_CFLAGS = -Wall -fwritable-strings -DVOL=volatile -fsigned-char
$(PROCESSOR_FLAGS)
O3FLAGS = -O2 -fomit-frame-pointer
O2FLAGS = -O
@@ -29,6 +29,13 @@
UNIX_SAVE_DEP = unexnt.c
+# CFLAGS = -g -Wall -DVOL=volatile -fsigned-char -fwritable-strings
$(PROCESSOR_FLAGS) -I$(GCLDIR)/o
+# FINAL_CFLAGS = -g -Wall -DVOL=volatile -fsigned-char -fwritable-strings
$(PROCESSOR_FLAGS)
+# O3FLAGS =
+# O2FLAGS =
+
+#CC = ${CROSS_PREFIX}gcc
+
AS = ${CROSS_PREFIX}as
AR = ${CROSS_PREFIX}ar q
RANLIB = ${CROSS_PREFIX}ranlib
@@ -79,11 +86,10 @@
TK_LISP_LIB=
TCL_EXES=
-# Don't do dvi on Windows
-GCL_DVI=
+# Don't do dvi and html
-# Use MSYS makeinfo
-HTML_CMD=makeinfo --html --no-split
+GCL_DVI=
+GCL_HTML=
#
# End h/mingw.defs
Index: h/mingw.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/mingw.h,v
retrieving revision 1.19
retrieving revision 1.17
diff -u -r1.19 -r1.17
--- h/mingw.h 11 Jul 2003 06:30:06 -0000 1.19
+++ h/mingw.h 27 Feb 2003 00:32:59 -0000 1.17
@@ -45,15 +45,7 @@
#undef DBEGIN_TY
#define DBEGIN_TY unsigned int
-extern DBEGIN_TY _dbegin;
-
-#define AV
-#ifdef AV
-# define _stacktop cs_limit
-# define _stackbottom cs_org
-#else
-extern DBEGIN_TY _stacktop, _stackbottom;
-#endif
+extern DBEGIN_TY _stacktop, _stackbottom, _dbegin;
/* define if there is no _cleanup, do here what needs
to be done before calling unexec
@@ -111,16 +103,10 @@
if the pointe/r is on the C stack or the 0 pointer
in winnt our heap starts at DBEGIN
*/
-#ifdef AV
-#define NULL_OR_ON_C_STACK(y) \
- ((y) == 0 || \
- ((y) > _stacktop && (y) < _stackbottom))
-#else
#define NULL_OR_ON_C_STACK(y) \
(((unsigned int)(y)) == 0 || \
(((unsigned int)(y)) > _stacktop && ((unsigned int)(y)) < _stackbottom))
-#endif
-
+
#if defined ( IN_FILE ) || defined ( IN_SOCKETS )
# define HAVE_NSOCKET
#endif
@@ -194,6 +180,7 @@
if (core_end != (sbrk(PAGESIZE*(n - m))))
#define USE_INTERNAL_REAL_TIME_FOR_RUNTIME
+#define SHARP_EQ_CONTEXT_SIZE 1024
/* Use this pending test in configure */
#define NO_MKSTEMP
Index: o/alloc.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/alloc.c,v
retrieving revision 1.20
retrieving revision 1.19
diff -u -r1.20 -r1.19
--- o/alloc.c 11 Jul 2003 06:33:53 -0000 1.20
+++ o/alloc.c 1 Mar 2003 22:37:37 -0000 1.19
@@ -62,7 +62,7 @@
#endif /* DEBUG_SBRK */
long real_maxpage = MAXPAGE;
-long new_holepage = 0;
+long new_holepage;
#define available_pages \
(real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
Index: o/funlink.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/funlink.c,v
retrieving revision 1.17
retrieving revision 1.16
diff -u -r1.17 -r1.16
--- o/funlink.c 7 Jul 2003 04:53:14 -0000 1.17
+++ o/funlink.c 1 Mar 2003 22:37:37 -0000 1.16
@@ -10,8 +10,6 @@
#include "sfun_argd.h"
#include "page.h"
-#undef DO_FUNLINK_DEBUG
-
static int
clean_link_array(object *,object *);
@@ -27,106 +25,65 @@
/* cleanup link */
void
call_or_link(object sym, void **link )
-{
- object fun;
- fun = sym->s.s_gfdef;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x START\n", fun );
-#endif
- if (fun == OBJNULL) {
- FEinvalid_function(sym);
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun );
-#endif
- return;
- }
- if ( type_of ( fun ) == t_cclosure && (fun->cc.cc_turbo) ) {
- if ( Rset ==0 ) {
- MMccall ( fun, fun->cc.cc_turbo );
- } else {
- (*(fun)->cf.cf_self)(fun->cc.cc_turbo);
- }
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x END 1\n", fun );
+{object fun;
+ fun = sym->s.s_gfdef;
+#if 0
+ fprintf ( stderr, "call_or_link: fun %x\n", fun );
#endif
- return;
- }
- if ( Rset == 0 ) {
- funcall(fun);
- } else {
- if ( type_of(fun) == t_cfun ) {
- (void) vpush_extend ( link,sLAlink_arrayA->s.s_dbind );
- (void) vpush_extend ( *link,sLAlink_arrayA->s.s_dbind );
- *link = (void *) (fun->cf.cf_self);
+ if (fun == OBJNULL) {FEinvalid_function(sym); return;}
+ if (type_of(fun) == t_cclosure
+ && (fun->cc.cc_turbo))
+ {if (Rset==0) {MMccall(fun, fun->cc.cc_turbo);}
+ else (*(fun)->cf.cf_self)(fun->cc.cc_turbo);
+ return;}
+ if (Rset==0) funcall(fun);
+ else
+ if (type_of(fun) == t_cfun)
+ { (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);
+ (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);
+ *link = (void *) (fun->cf.cf_self);
#if 0
- fprintf ( stderr, "call_or_link: cf %x\n", fun->cf );
- fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name );
- fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data );
- fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self );
- fflush ( stderr );
- fprintf ( stderr, "call_or_link: staddr %x\n",
fun->cf.cf_name->st.st_self );
- fprintf ( stderr, "call_or_link: ststring %s\n",
fun->cf.cf_name->st.st_self );
- fflush ( stderr );
+ fprintf ( stderr, "call_or_link: cf %x\n", fun->cf );
+ fprintf ( stderr, "call_or_link: cf_name %x\n", fun->cf.cf_name );
+ fprintf ( stderr, "call_or_link: cf_data %x\n", fun->cf.cf_data );
+ fprintf ( stderr, "call_or_link: cf_self %x\n", fun->cf.cf_self );
+ fflush ( stderr );
+ fprintf ( stderr, "call_or_link: staddr %x\n",
fun->cf.cf_name->st.st_self );
+ fprintf ( stderr, "call_or_link: ststring %s\n",
fun->cf.cf_name->st.st_self );
+ fflush ( stderr );
#endif
- ( *(void (*)()) (fun->cf.cf_self)) ();
- } else {
- funcall(fun);
- }
- }
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x END 2\n", fun );
-#endif
-}
+ (*(void (*)())(fun->cf.cf_self))();
+ }
+ else funcall(fun);}
void
-call_or_link_closure ( object sym, void **link, void **ptr )
-{
- object fun;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link_closure: fun %x START\n", fun );
-#endif
- fun = sym->s.s_gfdef;
- if (fun == OBJNULL) {
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x ERROR END\n", fun );
-#endif
- FEinvalid_function(sym);
- return;
- }
- if ( type_of ( fun ) == t_cclosure && ( fun->cc.cc_turbo ) ) {
- if ( Rset ) {
- (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
- (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );
- *ptr = (void *) ( fun->cc.cc_turbo );
- *link = (void *) ( fun->cf.cf_self );
- MMccall (fun, fun->cc.cc_turbo);
- } else {
- MMccall ( fun, fun->cc.cc_turbo );
- }
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x END 1\n", fun );
-#endif
- return;
- }
- if ( Rset == 0 ) {
- funcall ( fun );
- } else {
- /* can't do this if invoking foo(a) is illegal when foo is not defined
- to take any arguments. In the majority of C's this is legal */
-
- if ( type_of ( fun ) == t_cfun ) {
- (void) vpush_extend ( link, sLAlink_arrayA->s.s_dbind );
- (void) vpush_extend ( *link, sLAlink_arrayA->s.s_dbind );
- *link = (void *) (fun->cf.cf_self);
- ( *(void (*)()) (fun->cf.cf_self) ) ();
- } else {
- funcall(fun);
- }
- }
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_or_link: fun %x END 2\n", fun );
-#endif
-}
+call_or_link_closure(object sym, void **link, void **ptr)
+{object fun;
+ fun = sym->s.s_gfdef;
+ if (fun == OBJNULL) {FEinvalid_function(sym); return;}
+ if (type_of(fun) == t_cclosure
+ && (fun->cc.cc_turbo))
+ {if (Rset) {
+ (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);
+ (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);
+ *ptr = (void *)(fun->cc.cc_turbo);
+ *link = (void *) (fun->cf.cf_self);
+ MMccall(fun, fun->cc.cc_turbo);}
+ else
+ {MMccall(fun, fun->cc.cc_turbo);}
+ return;}
+ if (Rset==0) funcall(fun);
+ else
+ /* can't do this if invoking foo(a) is illegal when foo is not defined
+ to take any arguments. In the majority of C's this is legal */
+
+ if (type_of(fun) == t_cfun)
+ { (void) vpush_extend( link,sLAlink_arrayA->s.s_dbind);
+ (void) vpush_extend( *link,sLAlink_arrayA->s.s_dbind);
+ *link = (void *) (fun->cf.cf_self);
+ (*(void (*)())(fun->cf.cf_self))();
+ }
+ else funcall(fun);}
/* for pushing item into an array, where item is an address if array-type = t
or a fixnum if array-type = fixnum */
@@ -134,11 +91,7 @@
#define SET_ITEM(ar,ind,val) (*((object *)(&((ar)->ust.ust_self[ind]))))= val
static int
vpush_extend(void *item, object ar)
-{ register int ind;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "vpush_extend: item %x, ar %x\n", item, ar );
-#endif
- ind = ar->ust.ust_fillp;
+{ register int ind = ar->ust.ust_fillp;
AGAIN:
if (ind < ar->ust.ust_dim)
{SET_ITEM(ar,ind,item);
@@ -153,11 +106,7 @@
ar->ust.ust_dim=newdim;
ar->ust.ust_self=newself;
goto AGAIN;
- }
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "vpush_extend: item %x, ar %x END\n", item, ar );
-#endif
-}
+ }}
/* if we unlink a bunch of functions, this will mean there are some
@@ -168,9 +117,6 @@
static void
delete_link(void *address, object link_ar)
{object *ar,*ar_end,*p;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "delete_link: address %x, link_ar %x START\n", address,
link_ar );
-#endif
p=0;
ar = link_ar->v.v_self;
ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]);
@@ -183,11 +129,7 @@
ar=ar+2;}
if (number_unlinked > 40)
link_ar->v.v_fillp=
- clean_link_array(link_ar->v.v_self,ar_end);
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "delete_link: address %x, link_ar %x END\n", address,
link_ar );
-#endif
-}
+ clean_link_array(link_ar->v.v_self,ar_end); }
DEFUN_NEW("USE-FAST-LINKS",object,fSuse_fast_links,SI,1,2,NONE,OO,OO,OO,OO,(object
flag,...),
@@ -277,9 +219,6 @@
clean_link_array(object *ar, object *ar_end)
{int i=0;
object *orig;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "clean_link_array: ar %x, ar_end %x START\n", ar, ar_end );
-#endif
orig=ar;
number_unlinked=0;
while( ar<ar_end)
@@ -289,9 +228,6 @@
}
else ar=ar+2;
}
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "clean_link_array: ar %x, ar_end %x END\n", ar, ar_end );
-#endif
return(i*sizeof(object *));
}
@@ -310,9 +246,6 @@
object
c_apply_n(object (*fn)(), int n, object *x)
{object res=Cnil;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "c_apply_n: n %d, x %x START\n", n, x );
-#endif
switch(n){
case 0: res=LCAST(fn)();break;
case 1: res=LCAST(fn)(x[0]);break;
@@ -634,9 +567,6 @@
default: FEerror("Exceeded call-arguments-limit ",0);
}
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "c_apply_n: res %x END\n", n, res );
-#endif
return res;
}
@@ -648,9 +578,6 @@
call_proc(object sym, void **link, int argd, va_list ll)
{object fun;
int nargs;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_proc: sym %x START\n", sym );
-#endif
check_type_symbol(&sym);
fun=sym->s.s_gfdef;
if (fun && (type_of(fun)==t_sfun
@@ -778,9 +705,6 @@
call_proc_new(object sym, void **link, int argd, object first, va_list ll)
{object fun;
int nargs;
-#ifdef DO_FUNLINK_DEBUG
- fprintf ( stderr, "call_proc_new: sym %x START\n", sym );
-#endif
check_type_symbol(&sym);
fun=sym->s.s_gfdef;
if (fun && (type_of(fun)==t_sfun
Index: o/gbc.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/gbc.c,v
retrieving revision 1.14
retrieving revision 1.13
diff -u -r1.14 -r1.13
--- o/gbc.c 11 Jul 2003 06:33:53 -0000 1.14
+++ o/gbc.c 15 Feb 2003 00:38:28 -0000 1.13
@@ -93,21 +93,28 @@
#endif
-static int gc_time = -1;
-static int gc_start = 0;
-int sgc_enabled = 0;
-int first_protectable_page = 0;
-
+bool saving_system;
+static int gc_time = -1;
+static int gc_start = 0;
int runtime(void);
+int sgc_enabled=0;
+int first_protectable_page =0;
+
static char *copy_relblock(char *p, int s);
#include "page.h"
-extern bool saving_system;
-extern long real_maxpage;
-extern long new_holepage;
+
+#ifdef MV
+
+
+#endif
+
+
+long real_maxpage;
+long new_holepage;
#define available_pages \
(real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
@@ -659,7 +666,7 @@
object x;
struct typemanager *tm;
register long *j;
- long *top = (long *) topv, *bottom = (long *) bottomv;
+ long *top=topv,*bottom=bottomv;
/* if either of these happens we are marking the C stack
and need to use a local */
@@ -672,7 +679,7 @@
*/
if (offset)
- mark_stack_carefully ( (((char *) top) +offset), bottom, 0 );
+ mark_stack_carefully((((char *) top) +offset),bottom,0);
for (j=top ; j >= bottom ; j--) {
if (VALID_DATA_ADDRESS_P(*j)
Index: o/main.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/main.c,v
retrieving revision 1.28
retrieving revision 1.26
diff -u -r1.28 -r1.26
--- o/main.c 11 Jul 2003 06:25:11 -0000 1.28
+++ o/main.c 1 Mar 2003 22:37:37 -0000 1.26
@@ -28,296 +28,328 @@
#include <unistd.h>
#include <string.h>
-static void init_main(void);
-static void initlisp(void);
-static int multiply_stacks(int);
-void install_segmentation_catcher(void);
+static void
+init_main(void);
+
+static void
+initlisp(void);
+
+static int
+multiply_stacks(int);
#define IN_MAIN
#ifdef KCLOVM
-# include <ovm/ovm.h>
+#include <ovm/ovm.h>
void change_contexts();
int ovm_process_created;
void initialize_process();
#endif
#include "include.h"
-
#ifdef UNIX
-# include <signal.h>
-#endif
+#include <signal.h>
+
+#endif
#include "page.h"
+bool saving_system ;
+
#ifdef BSD
-# include <sys/time.h>
-# ifndef SGI
-# include <sys/resource.h>
-# endif
+#include <sys/time.h>
+#ifndef SGI
+#include <sys/resource.h>
+#endif
+#endif
+
+#ifdef AOSVS
+
#endif
#ifdef _WIN32
-# include <fcntl.h>
+#include <fcntl.h>
#endif
#define LISP_IMPLEMENTATION_VERSION "April 1994"
+char *system_directory;
+
+int page_multiple=1;
+
+
#define EXTRA_BUFSIZE 8
char stdin_buf[BUFSIZ + EXTRA_BUFSIZE];
char stdout_buf[BUFSIZ + EXTRA_BUFSIZE];
-char *system_directory = NULL;
-int page_multiple = 1;
+int debug; /* debug switch */
+int initflag = FALSE; /* initialized flag */
+
+long real_maxpage;
+object sSAlisp_maxpagesA;
+
+object siClisp_pagesize;
-int debug = FALSE; /* debug switch */
-int initflag = FALSE; /* initialized flag */
+object sStop_level;
-int stack_multiple = 1;
-int cssize = 0;
+
+object sSAmultiply_stacksA;
+int stack_multiple=1;
+static object stack_space;
#ifdef _WIN32
-unsigned int _dbegin = 0x10100000;
-# ifndef AV
+unsigned int _dbegin = 0x10100000;
unsigned int _stacktop, _stackbottom;
-# endif
#endif
-extern bool saving_system;
-extern long real_maxpage;
-extern int sgc_enabled;
-
-
-object sSAlisp_maxpagesA;
-object siClisp_pagesize;
-object sStop_level;
-object sSAmultiply_stacksA;
+int cssize;
-static object stack_space;
+int sgc_enabled;
+void install_segmentation_catcher(void);
#ifndef SIG_STACK_SIZE
-# define SIG_STACK_SIZE 1000
+#define SIG_STACK_SIZE 1000
#endif
-
#ifndef SETUP_SIG_STACK
-# if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
- struct sigstack estack;
-# endif
+#if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
+ struct sigstack estack;
+#endif
#endif
int
main(int argc, char **argv, char **envp) {
-#if defined ( BSD ) && defined ( RLIMIT_STACK )
- struct rlimit rl;
+#ifdef BSD
+#ifdef RLIMIT_STACK
+ struct rlimit rl;
+#endif
#endif
#ifdef RECREATE_HEAP
- RECREATE_HEAP
+ RECREATE_HEAP
#endif
-#if defined ( _WIN32 ) && !defined ( AV )
- {
- unsigned int dummy;
+#ifdef _WIN32
+ {
+ unsigned int dummy;
- _stackbottom = (unsigned int ) &argc;
- _stacktop = _stackbottom - CSSIZE; // ???
+ _stackbottom = (unsigned int ) &dummy;
+ _stacktop = _stackbottom - 0x10000; // ???
- }
+ }
#endif
- setbuf(stdin, stdin_buf);
- setbuf(stdout, stdout_buf);
+ setbuf(stdin, stdin_buf);
+ setbuf(stdout, stdout_buf);
#ifdef _WIN32
- _fmode = _O_BINARY;
+ _fmode = _O_BINARY;
#endif
- ARGC = argc;
- ARGV = argv;
+ ARGC = argc;
+ ARGV = argv;
#ifdef UNIX
- ENVP = envp;
- kcl_self = argv[0];
+ ENVP = envp;
+#endif
+
+#ifdef UNIX
+/*
+ if (argv[0][0] != '/')
+ error("can't get the program name");
+*/
+ kcl_self = argv[0];
#ifdef FIX_FILENAME
- {
- int n = strlen ( kcl_self );
- FIX_FILENAME ( Cnil, kcl_self );
- if ( strlen ( kcl_self ) > n ) {
- error ( "name grew" );
- }
- }
+ { int n = strlen(kcl_self);
+ FIX_FILENAME(Cnil,kcl_self);
+ if (strlen(kcl_self)> n) error("name grew");
+ }
#endif
- if ( !initflag ) {
- /* An uninitialised system eg raw_gcl */
- if ( argc < 2 ) {
- /* Provide the current directory as a default */
- system_directory = (char *) malloc ( strlen ( "./" ) + 3 );
- strcpy ( system_directory, "./" );
- } else {
- int lastchar = strlen ( argv[1] ) - 1;
- /* Squirrel away the system directory provided as argv[1] */
- system_directory = (char *) malloc ( strlen ( argv[1] ) + 3 );
- strcpy ( system_directory, argv[1] );
- if ( system_directory[0] != '/' ) {
- strcpy ( system_directory, "./" );
- } else {
- int j;
- for ( j = strlen ( system_directory ); system_directory[j-1]
!= '/'; --j );
- system_directory[j] = '\0';
- }
-
- if ( argv[1][lastchar] != '/') {
- error ( "Can't get the system directory." );
- }
- strcpy ( system_directory, argv[1] );
- }
- }
-#else /* UNIX */
- if (!initflag && argc > 1) {
- error("can't get the system directory");
- strcpy(system_directory, argv[1]);
- }
-#endif /* UNIX */
- GBC_enable = FALSE;
+ if (!initflag) {
+
+ system_directory= (char *) malloc(strlen(argv[1])+3);
+
+ strcpy(system_directory, argv[1]);
+ if (system_directory[0] != '/')
+ strcpy(system_directory, "./");
+ else {
+ int j;
+
+ for (j = strlen(system_directory);
+ system_directory[j-1] != '/'; --j)
+ ;
+ system_directory[j] = '\0';
+ }
+ }
- /* if stack_space not zero we have grown the stack space */
- if ( stack_space == 0 ) {
- vs_org = value_stack;
- vs_limit = &vs_org[VSSIZE];
- frs_org = frame_stack;
- frs_limit = &frs_org[FRSSIZE];
- bds_org = bind_stack;
- bds_limit = &bds_org[BDSSIZE];
-#ifdef KCLOVM
- bds_save_org = save_bind_stack;
- bds_save_top = bds_save_org - 1;
- bds_save_limit = &bds_save_org[BDSSIZE];
#endif
- ihs_org = ihs_stack;
- ihs_limit = &ihs_org[IHSSIZE];
- }
+#ifdef AOSVS
+
+
+
+
+
+
+
- vs_top = vs_base = vs_org;
- clear_stack ( vs_top, vs_top+200 );
- ihs_top = ihs_org-1;
- bds_top = bds_org-1;
- frs_top = frs_org-1;
- cs_org = &argc;
- cssize = CSSIZE;
- install_segmentation_catcher();
+
+
+
+
+#endif
+
+ if (!initflag && argc > 1) {
+#ifdef UNIX
+ if (argv[1][strlen(argv[1])-1] != '/')
+#endif
+#ifdef AOSVS
+
+#endif
+ error("can't get the system directory");
+ strcpy(system_directory, argv[1]);
+ }
+
+ GBC_enable = FALSE;
+
+ /* if stack_space not zero we have grown the stack space */
+ if (stack_space == 0)
+ {
+ vs_org = value_stack;
+ vs_limit = &vs_org[VSSIZE];
+ frs_org = frame_stack;
+ frs_limit = &frs_org[FRSSIZE];
+ bds_org = bind_stack;
+ bds_limit = &bds_org[BDSSIZE];
+#ifdef KCLOVM
+ bds_save_org = save_bind_stack;
+ bds_save_top = bds_save_org - 1;
+ bds_save_limit = &bds_save_org[BDSSIZE];
+#endif
+ ihs_org = ihs_stack;
+ ihs_limit = &ihs_org[IHSSIZE];}
+
+ vs_top = vs_base = vs_org;
+ clear_stack(vs_top,vs_top+200);
+ ihs_top = ihs_org-1;
+ bds_top = bds_org-1;
+ frs_top = frs_org-1;
+ cs_org = &argc;
+
+ cssize = CSSIZE;
+ install_segmentation_catcher();
#ifdef BSD
-# ifndef MAX_STACK_SIZE
-# define MAX_STACK_SIZE (1<<23) /* 8Mb */
-# endif
-# ifdef RLIMIT_STACK
- getrlimit(RLIMIT_STACK, &rl);
- if (rl.rlim_cur == RLIM_INFINITY ||
- rl.rlim_cur > MAX_STACK_SIZE)
- rl.rlim_cur=MAX_STACK_SIZE;
- cssize = rl.rlim_cur/4 - 4*CSGETA;
-# endif
-#endif /* BSD */
+#ifndef MAX_STACK_SIZE
+#define MAX_STACK_SIZE (1<<23) /* 8Mb */
+#endif
+#ifdef RLIMIT_STACK
+ getrlimit(RLIMIT_STACK, &rl);
+ if (rl.rlim_cur == RLIM_INFINITY ||
+ rl.rlim_cur > MAX_STACK_SIZE)
+ rl.rlim_cur=MAX_STACK_SIZE;
+ cssize = rl.rlim_cur/4 - 4*CSGETA;
+#endif
+#endif
#ifdef AV
- cs_limit = cs_org - cssize;
+ cs_limit = cs_org - cssize;
#endif
+#ifdef MV
- set_maxpage();
-
+#endif
+
+ set_maxpage();
#ifdef SETUP_SIG_STACK
- SETUP_SIG_STACK
+ SETUP_SIG_STACK
#else
-
-# if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
- {
- /* make sure the stack is 8 byte aligned */
-# ifdef SETJMP_ONE_DIRECTION
- static
-# endif /* SETUP_SIG_STACK */
+#if defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC)
+ {
+ /* make sure the stack is 8 byte aligned */
+#ifdef SETJMP_ONE_DIRECTION
+ static
+#endif
double estack_buf[SIG_STACK_SIZE];
- bzero(estack_buf,sizeof(estack_buf));
- estack.ss_sp = (char *) &estack_buf[SIG_STACK_SIZE-1];
- estack.ss_onstack=0;
- sigstack(&estack,0);
- }
-# endif /* defined(HAVE_SIGACTION) || defined(HAVE_SIGVEC) */
-
-#endif /* SETUP_SIG_STACK */
+ bzero(estack_buf,sizeof(estack_buf));
+ estack.ss_sp = (char *) &estack_buf[SIG_STACK_SIZE-1];
+ estack.ss_onstack=0;
+ sigstack(&estack,0);
+ }
+#endif
+#endif
- if (initflag) {
- if (saving_system) {
- saving_system = FALSE;
- terminal_io->sm.sm_object0->sm.sm_fp = stdin;
- terminal_io->sm.sm_object1->sm.sm_fp = stdout;
- init_big1();
+
+ if (initflag) {
+ if (saving_system) {
+ saving_system = FALSE;
+ terminal_io->sm.sm_object0->sm.sm_fp = stdin;
+ terminal_io->sm.sm_object1->sm.sm_fp = stdout;
+ init_big1();
#ifdef INIT_CORE_END
- INIT_CORE_END
+ INIT_CORE_END
#endif
- alloc_page(-(holepage + nrbpage));
- }
+ alloc_page(-(holepage + nrbpage));
+ }
- initflag = FALSE;
- GBC_enable = TRUE;
- vs_base = vs_top;
- ihs_push(Cnil);
- lex_new();
- vs_base = vs_top;
+ initflag = FALSE;
+ GBC_enable = TRUE;
+ vs_base = vs_top;
+ ihs_push(Cnil);
+ lex_new();
+ vs_base = vs_top;
- interrupt_enable = TRUE;
- install_default_signals();
+ interrupt_enable = TRUE;
+ install_default_signals();
- sSAlisp_maxpagesA->s.s_dbind = make_fixnum(real_maxpage);
- initflag = TRUE;
+ sSAlisp_maxpagesA->s.s_dbind = make_fixnum(real_maxpage);
+ initflag = TRUE;
#ifdef KCLOVM
- ovm_user_context_change = change_contexts;
- ovm_user_context_initialize = initialize_process;
+ ovm_user_context_change = change_contexts;
+ ovm_user_context_initialize = initialize_process;
- v_init_processes();
- ovm_process_created = 1;
+ v_init_processes();
+ ovm_process_created = 1;
#endif
#ifdef HAVE_READLINE
- init_readline_function();
+ init_readline_function();
#endif
- again:
- super_funcall(sStop_level);
- if (type_of(sSAmultiply_stacksA->s.s_dbind)==t_fixnum) {
- multiply_stacks(fix(sSAmultiply_stacksA->s.s_dbind));
- goto again;
- }
-
+ again:
+ super_funcall(sStop_level);
+ if (type_of(sSAmultiply_stacksA->s.s_dbind)==t_fixnum) {
+ multiply_stacks(fix(sSAmultiply_stacksA->s.s_dbind));
+ goto again;
+ }
+
#ifdef USE_DLOPEN
unlink_loaded_files();
#endif
- exit(0);
- }
+ exit(0);
+ }
- printf("GCL (GNU Common Lisp) %s %d pages\n",
- LISP_IMPLEMENTATION_VERSION,
- MAXPAGE);
- fflush(stdout);
+ printf("GCL (GNU Common Lisp) %s %d pages\n",
+ LISP_IMPLEMENTATION_VERSION,
+ MAXPAGE);
+ fflush(stdout);
- initlisp();
+ initlisp();
- vs_base = vs_top;
- ihs_push(Cnil);
- lex_new();
+ vs_base = vs_top;
+ ihs_push(Cnil);
+ lex_new();
- GBC_enable = TRUE;
+ GBC_enable = TRUE;
- CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
+ CMPtemp = CMPtemp1 = CMPtemp2 = CMPtemp3 = OBJNULL;
- init_init();
+ init_init();
- sLApackageA->s.s_dbind = user_package;
+ sLApackageA->s.s_dbind = user_package;
- lex_new();
- vs_base = vs_top;
- initflag = TRUE;
+ lex_new();
+ vs_base = vs_top;
+ initflag = TRUE;
- interrupt_enable = TRUE;
+ interrupt_enable = TRUE;
- super_funcall(sStop_level);
+ super_funcall(sStop_level);
- return 0;
+ return 0;
}
@@ -325,11 +357,11 @@
void install_segmentation_catcher(void)
{
#ifdef INSTALL_SEGMENTATION_CATCHER
- INSTALL_SEGMENTATION_CATCHER;
+ INSTALL_SEGMENTATION_CATCHER;
#else
-# ifdef SIGSEGV
+#ifdef SIGSEGV
(void) gcl_signal(SIGSEGV,segmentation_catcher);
-# endif
+#endif
#endif
}
@@ -337,25 +369,25 @@
void
error(char *s)
{
- if ( catch_fatal > 0 && interrupt_enable ) {
- catch_fatal = -1;
- if ( sgc_enabled ) {
- sgc_quit();
- } else {
- install_segmentation_catcher();
- }
- FEerror("Caught fatal error [memory may be damaged]",0);
- }
- printf ( "\nUnrecoverable error: %s.\n", s );
- fflush(stdout);
+ if (catch_fatal>0 && interrupt_enable )
+ {catch_fatal = -1;
+ if (sgc_enabled)
+ { sgc_quit();}
+ if (sgc_enabled==0)
+ { install_segmentation_catcher() ;}
+ FEerror("Caught fatal error [memory may be damaged]",0); }
+ printf("\nUnrecoverable error: %s.\n", s);
+ fflush(stdout);
#ifdef UNIX
- abort();
+ abort();
#endif
}
static void
initlisp(void) {
- int j;
+
+ int j;
+
if (NULL_OR_ON_C_STACK(&j) == 0
|| NULL_OR_ON_C_STACK(Cnil) != 0
|| (((unsigned long )core_end) !=0
@@ -363,8 +395,7 @@
{ /* check person has correct definition of above */
error("NULL_OR_ON_C_STACK macro invalid");
}
-
- init_alloc();
+ init_alloc();
Dotnil_body.t = (short)t_symbol;
Dotnil_body.s_dbind = Dotnil;
@@ -442,16 +473,16 @@
init_GBC();
#if defined ( UNIX ) || defined ( __MINGW32__ )
-# ifndef DGUX
+#ifndef DGUX
init_unixfasl();
init_unixsys();
init_unixsave();
-# else
+#else
-# endif
-#endif /* defined ( UNIX ) || defined ( __MINGW32__ ) */
+#endif
+#endif
init_alloc_function();
init_array_function();
@@ -557,6 +588,26 @@
error("Segmentation violation.");
}
+/* static void */
+/* cs_overflow(void) { */
+/* #ifdef AV */
+/* if (cs_limit < cs_org - cssize) */
+/* error("control stack overflow"); */
+/* cs_limit -= CSGETA; */
+/* #endif */
+/* #ifdef MV */
+
+
+
+/* #endif */
+/* FEerror("Control stack overflow.", 0); */
+/* } */
+
+/* static void */
+/* end_of_file(void) { */
+/* error("end of file"); */
+/* } */
+
DEFUNO_NEW("BYE",object,fLbye,LISP
,0,1,NONE,OI,OO,OO,OO,void,Lby,(fixnum exitc),"")
{ int n=VFUN_NARGS;
@@ -564,6 +615,7 @@
if (n>=1) exit_code=exitc;else exit_code=0;
#ifdef UNIX
+/* printf("Bye.\n"); */
exit(exit_code);
#else
RETURN(1,int,exit_code, 0);
@@ -580,6 +632,13 @@
{ return fLbye(exitc); }
+/* c_trace(void) */
+/* { */
+/* #ifdef AOSVS */
+
+/* #endif */
+/* } */
+
static void
siLargc(void) {
check_arg(0);
@@ -619,13 +678,14 @@
{vs_base[0] = make_simple_string(value);
#ifdef FREE_GETENV_RESULT
free(value);
+
#endif
}
else
vs_base[0] = Cnil;
}
-#endif /* UNIX */
+#endif
object *vs_marker;
@@ -866,31 +926,27 @@
make_cons(make_ordinary("KCL"), Cnil));
ADD_FEATURE("AKCL");
ADD_FEATURE("GCL");
-
#ifdef BROKEN_O4_OPT
ADD_FEATURE("BROKEN_O4_OPT");
#endif
-
#ifdef GMP
ADD_FEATURE("GMP");
#endif
-#if defined ( UNIX ) && !defined ( _WIN32 )
+#ifdef UNIX
+#ifndef _WIN32
ADD_FEATURE("UNIX");
+#endif
#endif
-
#ifdef IEEEFLOAT
ADD_FEATURE("IEEE-FLOATING-POINT");
#endif
-
#ifdef SGC
ADD_FEATURE("SGC");
#endif
-
#ifdef ADDITIONAL_FEATURES
ADDITIONAL_FEATURES;
#endif
-
#ifdef BSD
ADD_FEATURE("BSD");
#endif
@@ -915,7 +971,9 @@
&& ((-Seven)/ (-Three)) == 2)
{ ADD_FEATURE("TRUNCATE_USE_C");
} }
-#endif /* PECULIAR_MACHINE */
+#endif
+
+
make_special("*FEATURES*",features);}
Index: o/rel_coff.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/rel_coff.c,v
retrieving revision 1.6
retrieving revision 1.5
diff -u -r1.6 -r1.5
--- o/rel_coff.c 13 Jun 2003 05:09:11 -0000 1.6
+++ o/rel_coff.c 15 Feb 2003 00:38:28 -0000 1.5
@@ -7,26 +7,24 @@
relocate()
{
char *where;
- describe_sym ( relocation_info.r_symndx, 0 );
+ describe_sym(relocation_info.r_symndx);
where = the_start + relocation_info.r_vaddr;
- dprintf ( "relocate: where: %9x " , *where );
- dprintf ( "at %9x --> ", (unsigned int) where );
+ dprintf (where has %x , *where);
+ dprintf( at %x -->, where );
if (relocation_info.r_type == R_ABS)
- { dprintf( "R_ABS return %9x\n", relocation_info.r_type ); return; }
-
+ { dprintf( r_abs ,0) return; }
switch(relocation_info.r_type)
{
-
case R_DIR32:
- dprintf("new val R_DIR32 %9x\n", *((int *)where) +
+ dprintf(new val r_dir32 %x , *((int *)where) +
symbol_table[relocation_info.r_symndx].n_value);
*(int *)where= *((int *)where) +
symbol_table[relocation_info.r_symndx].n_value;
break;
-
case R_PCRLONG:
- dprintf( "new val R_PCRLONG %9x\n",
+
+ dprintf( r_pcrlong new value = %x ,
*((int *)where) - (int)start_address
+ symbol_table[relocation_info.r_symndx].n_value );
#ifdef _WIN32
@@ -37,16 +35,51 @@
*(int *)where= symbol_table[relocation_info.r_symndx].n_value
- (int) where - sizeof(int *);
#else
- *(int *)where= *((int *)where) - (int)start_address
+ *(int *)where= *((int *)where) - (int)start_address
+ symbol_table[relocation_info.r_symndx].n_value;
#endif
break;
-
- default:
- fprintf(stdout, "%d: unsupported relocation type.\n",
+ default:
+ fprintf(stdout, "%d: unsupported relocation type.",
relocation_info.r_type);
- FEerror("The relocation type was unknown\n",0,0);
+ FEerror("The relocation type was unknown",0,0);
}
}
+
+
+
+
+#ifdef DEBUG
+
+#define describe_sym describe_sym1
+describe_sym1(n)
+int n;
+{char *str;
+ char tem[9];
+ struct syment *sym;
+ sym= &symbol_table[n];
+ str= sym->n_zeroes == 0 ?
+ &my_string_table[sym->n_offset] :
+ (sym->n_name[SYMNMLEN -1] ?
+ /* MAKE IT NULL TERMINATED */
+ (strncpy(tem,sym->n_name,
+ SYMNMLEN),tem):
+ sym->n_name );
+ printf ("sym-index = %d table entry at %x",n,&symbol_table[n]);
+ printf("symbol is (%s):\nsymbol_table[n]._n._n_name
%s\nsymbol_table[n]._n._n_n._n_zeroes %d\nsymbol_table[n]._n._n_n._n_offset
%d\nsymbol_table[n]._n._n_nptr[0] %d\nsymbol_table[n]._n._n_nptr[n]
%d\nsymbol_table[n].n_value %d\nsymbol_table[n].n_scnum %d
+\nsymbol_table[n].n_type %d\nsymbol_table[n].n_sclass
%d\nsymbol_table[n].n_numaux %d", str,
+ symbol_table[n]._n._n_name,
+ symbol_table[n]._n._n_n._n_zeroes ,
+ symbol_table[n]._n._n_n._n_offset ,
+ symbol_table[n]._n._n_nptr[0] ,
+ symbol_table[n]._n._n_nptr[1] ,
+ symbol_table[n].n_value ,
+ symbol_table[n].n_scnum ,
+ symbol_table[n].n_type ,
+ symbol_table[n].n_sclass ,
+ symbol_table[n].n_numaux );
+}
+
+#endif
Index: o/sfasl.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sfasl.c,v
retrieving revision 1.14
retrieving revision 1.13
diff -u -r1.14 -r1.13
--- o/sfasl.c 13 Jun 2003 05:09:11 -0000 1.14
+++ o/sfasl.c 18 Feb 2003 02:32:03 -0000 1.13
@@ -1,26 +1,26 @@
/*
- Copyright William Schelter. All rights reserved.
- There is a companion file rsym.c which is used to build
- a list of the external symbols in a COFF or A.OUT object file, for
- example saved_kcl. These are loaded into kcl, and the
- linking is done directly inside kcl. This saves a good
- deal of time. For example a tiny file foo.o with one definition
- can be loaded in .04 seconds. This is much faster than
- previously possible in kcl.
- The function fasload from unixfasl.c is replaced by the fasload
- in this file.
- this file is included in unixfasl.c
- via #include "../c/sfasl.c\n"
- */
+Copyright William Schelter. All rights reserved.
+There is a companion file rsym.c which is used to build
+a list of the external symbols in a COFF or A.OUT object file, for
+example saved_kcl. These are loaded into kcl, and the
+linking is done directly inside kcl. This saves a good
+deal of time. For example a tiny file foo.o with one definition
+can be loaded in .04 seconds. This is much faster than
+previously possible in kcl.
+The function fasload from unixfasl.c is replaced by the fasload
+in this file.
+this file is included in unixfasl.c
+via #include "../c/sfasl.c"
+*/
/* for testing in standalone manner define STAND
- You may then compile this file cc -g -DSTAND -DDEBUG -I../hn
- a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/
- will write a /tmp/sfasltest file
- which you can use comp to compare with one produced by ld.
- */
-/*#define DEBUG*/
+ You may then compile this file cc -g -DSTAND -DDEBUG -I../hn
+ a.out /tmp/foo.o /public/gcl/unixport/saved_kcl /public/gcl/unixport/
+ will write a /tmp/sfasltest file
+ which you can use comp to compare with one produced by ld.
+ */
+
#define IN_SFASL
/* #ifdef STAND */
@@ -55,11 +55,11 @@
#ifdef DEBUG
#define debug sfasldebug
-int sfasldebug=1;
-#define dprintf(s,ar) if ( debug ) { fprintf ( stderr, ( s ), ar ) ;
fflush(stderr); }
+int sfasldebug=0;
+#define dprintf(s,ar) if(debug) { printf(" ( s )",ar) ; fflush(stdout);}
#define STAT
-#else /* end debug */
+#else /* end debug */
#define dprintf(s,ar)
#define STAT static
#endif
@@ -70,14 +70,14 @@
#define PTABLE_EXTRA 20
struct sfasl_info {
- struct syment *s_symbol_table;
- char *s_start_address;
- char *s_start_data;
- char *s_my_string_table;
- int s_extra_bss;
- char *s_the_start;
-};
+ struct syment *s_symbol_table;
+ char *s_start_address;
+ char *s_start_data;
+ char *s_my_string_table;
+ int s_extra_bss;
+ char *s_the_start;
+};
struct sfasl_info *sfaslp;
#define symbol_table sfaslp->s_symbol_table
@@ -86,64 +86,10 @@
#define extra_bss sfaslp->s_extra_bss
#define the_start sfaslp->s_the_start
-#ifdef DEBUG
-
-#define describe_sym describe_sym1
-void describe_sym1 ( int n, int aux_to_go )
-{
- char *str;
- char tem[9];
- struct syment *sym;
- sym = &symbol_table[n];
- if ( sym->n_zeroes == 0 ) {
- str = &my_string_table[sym->n_offset];
- } else {
- if ( sym->n_name[SYMNMLEN -1] != 0 ) {
- /* MAKE IT NULL TERMINATED */
- strncpy ( tem, sym->n_name, SYMNMLEN );
- tem[SYMNMLEN] = '\0';
- str = &tem[0];
- } else {
- str = sym->n_name;
- }
- }
- if ( aux_to_go > 0 ) {
- fprintf ( stderr," symbol_table[%3d] (%8x): auxiliary entry (%d to
go)\n", n, &symbol_table[n], aux_to_go - 1 );
- } else {
- if ( sym->n_zeroes == 0 ) {
- fprintf ( stderr,
- "symbol_table[%3d] (%8x) (%22s): "
- "n_offset %d, n_value %d, n_scnum %d, n_type %d, "
- "n_sclass %d, n_numaux %d\n",
- n,
- &symbol_table[n],
- str,
- symbol_table[n].n_offset,
- symbol_table[n].n_value,
- symbol_table[n].n_scnum,
- symbol_table[n].n_type,
- symbol_table[n].n_sclass,
- symbol_table[n].n_numaux );
- } else {
- fprintf ( stderr,
- "symbol_table[%3d] (%8x) (%22s): "
- "n_value %d, n_scnum %d, n_type %d, "
- "n_sclass %d, n_numaux %d\n",
- n,
- &symbol_table[n],
- str,
- symbol_table[n].n_value ,
- symbol_table[n].n_scnum ,
- symbol_table[n].n_type ,
- symbol_table[n].n_sclass ,
- symbol_table[n].n_numaux );
- }
- }
-}
-#else
-# define describe_sym(a,b)
-#endif /* DEBUG */
+#ifndef describe_sym
+#define describe_sym(a)
+#endif
#ifdef STAND
#include "rel_stand.c"
@@ -157,569 +103,556 @@
void relocate_symbols ( unsigned int length );
void set_symbol_address ( struct syment *sym, char *string );
-int fasload ( object faslfile )
-{
- long fasl_vector_start;
- struct filehdr fileheader;
- struct sfasl_info sfasl_info_buf;
+int
+fasload(faslfile)
+object faslfile;
+{ long fasl_vector_start;
+ struct filehdr fileheader;
+ struct sfasl_info sfasl_info_buf;
#ifdef COFF
- struct scnhdr section[10];
- struct aouthdr header;
+ struct scnhdr section[10];
+ struct aouthdr header;
#endif
- int textsize, datasize, bsssize, nsyms;
+ int textsize, datasize, bsssize,nsyms;
#if defined ( READ_IN_STRING_TABLE ) || defined ( HPUX )
- int string_size=0;
+ int string_size=0;
#endif
- object memory, data;
- FILE *fp;
- char filename[MAXPATHLEN];
- int i;
- int init_address=0;
- int aux_to_go = 0;
-
+ object memory, data;
+ FILE *fp;
+ char filename[MAXPATHLEN];
+ int i;
+ int init_address=0;
#ifndef STAND
- object *old_vs_base = vs_base;
- object *old_vs_top = vs_top;
+ object *old_vs_base = vs_base;
+ object *old_vs_top = vs_top;
#endif
- sfaslp = &sfasl_info_buf;
+ sfaslp = &sfasl_info_buf;
- extra_bss=0;
+ extra_bss=0;
#ifdef STAND
- strcpy(filename,faslfile);
- fp=fopen(filename,"r");
+ strcpy(filename,faslfile);
+ fp=fopen(filename,"r");
#else
- coerce_to_filename(faslfile, filename);
- faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
- vs_push(faslfile);
- fp = faslfile->sm.sm_fp;
+ coerce_to_filename(faslfile, filename);
+ faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
+ vs_push(faslfile);
+ fp = faslfile->sm.sm_fp;
#endif
- HEADER_SEEK(fp);
- if ( !fread ( (char *) &fileheader, sizeof(struct filehdr), 1, fp ) ) {
- FEerror("Could not get the header",0,0);
- }
- nsyms = NSYMS(fileheader);
-
+ HEADER_SEEK(fp);
+ if(!fread((char *)&fileheader, sizeof(struct filehdr), 1, fp))
+ FEerror("Could not get the header",0,0);
+ nsyms = NSYMS(fileheader);
#ifdef COFF
-# ifdef AIX3
- setup_for_aix_load();
-# endif
-
- fread ( &header, 1, fileheader.f_opthdr, fp );
- fread ( §ion[1],
- fileheader.f_nscns,
- sizeof ( struct scnhdr ),
- fp );
- textsize = section[TEXT_NSCN].s_size;
- datasize = section[DATA_NSCN].s_size;
- if (strcmp(section[BSS_NSCN].s_name, ".bss") == 0) {
- bsssize=section[BSS_NSCN].s_size;
- } else {
- bsssize=section[BSS_NSCN].s_size = 0;
- }
+
+#ifdef AIX3
+ setup_for_aix_load();
+#endif
+
+ fread(&header,1,fileheader.f_opthdr,fp);
+
+ fread(§ion[1],fileheader.f_nscns,sizeof (struct scnhdr),fp);
+ textsize = section[TEXT_NSCN].s_size;
+ datasize = section[DATA_NSCN].s_size;
+ if (strcmp(section[BSS_NSCN].s_name, ".bss") == 0)
+ bsssize=section[BSS_NSCN].s_size;
+ else bsssize=section[BSS_NSCN].s_size = 0;
#endif
#ifdef BSD
- textsize=fileheader.a_text;
- datasize=fileheader.a_data;
- bsssize=fileheader.a_bss;
-#endif
- dprintf ( "fasload: %s, ", filename );
- dprintf ( "number of symbols: %d\n", nsyms );
-
- /* Allocate space for the symbol table */
- symbol_table =
- (struct syment *) OUR_ALLOCA( sizeof(struct syment)*
- (unsigned int)nsyms);
- memset ( symbol_table, 0, sizeof(struct syment) * (unsigned int)nsyms );
- /* move the file pointer to the start of the symbol table */
- fseek(fp,(int)( N_SYMOFF(fileheader)), 0);
-
- /* Read the symbol table */
- for (i = 0; i < nsyms; i++) {
- fread((char *)&symbol_table[i], SYMESZ, 1, fp);
+ textsize=fileheader.a_text;
+ datasize=fileheader.a_data;
+ bsssize=fileheader.a_bss;
+#endif
+ symbol_table =
+ (struct syment *) OUR_ALLOCA(sizeof(struct syment)*
+ (unsigned int)nsyms);
+ fseek(fp,(int)( N_SYMOFF(fileheader)), 0);
+ {
+ for (i = 0; i < nsyms; i++)
+ { fread((char *)&symbol_table[i], SYMESZ, 1, fp);
+ dprintf( symbol table %d , i);
+ if (debug) describe_sym(i);
+ dprintf( at %d , &symbol_table[i]);
#ifdef HPUX
- symbol_table[i].n_un.n_strx = string_size;
- dprintf("string_size %d\n", string_size);
- string_size += symbol_table[i].n_length + 1;
- fseek(fp,(int)symbol_table[i].n_length,1);
-#endif
- }
- /*
- on MP386
- The sizeof(struct syment) = 20, while only SYMESZ =18. So we had to read
- one at a time.
- fread((char *)symbol_table, SYMESZ*fileheader.f_nsyms,1,fp);
- */
+ symbol_table[i].n_un.n_strx = string_size;
+ dprintf(string_size %d, string_size);
+ string_size += symbol_table[i].n_length + 1;
+ fseek(fp,(int)symbol_table[i].n_length,1);
+#endif
+ }
+ }
+/*
+on MP386
+The sizeof(struct syment) = 20, while only SYMESZ =18. So we had to read
+one at a time.
+fread((char *)symbol_table, SYMESZ*fileheader.f_nsyms,1,fp);
+*/
#ifdef READ_IN_STRING_TABLE
- my_string_table=READ_IN_STRING_TABLE(fp,string_size);
+
+my_string_table=READ_IN_STRING_TABLE(fp,string_size);
+
#else
-# ifdef MUST_SEEK_TO_STROFF
- fseek(fp,N_STROFF(fileheader),0);
-# endif
- {
- int ii=0;
- if ( !fread ( (char *) &ii, sizeof(int), 1, fp ) ) {
- FEerror ( "The string table of this file did not have any length",
- 0, 0 );
- }
- fseek(fp,-4,1);
- /* at present the string table is located just after the symbols */
- my_string_table = OUR_ALLOCA ( (unsigned int) ii );
- memset ( my_string_table, 0, ii );
- dprintf( " string table length = %d \n", ii);
- if ( ii != fread ( my_string_table, 1, ii, fp ) ) {
- FEerror ( "Could not read whole string table", 0, 0 );
+#ifdef MUST_SEEK_TO_STROFF
+ fseek(fp,N_STROFF(fileheader),0);
+#endif
+ {int ii=0;
+ if (!fread((char *)&ii,sizeof(int),1,fp))
+ {FEerror("The string table of this file did not have any length",0,
+ 0);}
+ fseek(fp,-4,1);
+ /* at present the string table is located just after the symbols */
+ my_string_table=OUR_ALLOCA((unsigned int)ii);
+ dprintf( string table leng = %d, ii);
+
+ if(ii!=fread(my_string_table,1,ii,fp))
+ FEerror("Could not read whole string table",0,0) ;
}
-#endif
-#ifdef DEBUG
- /* Output the symbol table for debugging.
- *
- * Must do this after the string table has been read,
- * rather than while reading in the symbol table as
- * done previously. */
- aux_to_go = 0;
- for (i = 0; i < nsyms; i++) {
- if ( aux_to_go <= 0 ) {
- aux_to_go = symbol_table[i].n_numaux;
- }
- if ( debug ) {
- describe_sym ( i, aux_to_go );
- }
- if ( aux_to_go > 0 ) {
- aux_to_go--;
- }
- }
-#endif
-
+#endif
#ifdef SEEK_TO_END_OFILE
- SEEK_TO_END_OFILE(fp);
-#else
- /* go past any zeroes */
- while ( ( i = getc ( fp ) ) == 0 );
+SEEK_TO_END_OFILE(fp);
+#else
+ while ((i = getc(fp)) == 0)
+ ;
ungetc(i, fp);
#endif
- /* point at the GCL fasl data */
+
fasl_vector_start=ftell(fp);
- if ( ! ( (c_table.ptable) && *(c_table.ptable) ) ) {
- build_symbol_table();
- }
-
- /* figure out if there is more bss space needed */
- extra_bss = get_extra_bss ( symbol_table,
- nsyms,
- datasize+textsize+bsssize,
- &init_address,
- bsssize );
+ if (!((c_table.ptable) && *(c_table.ptable)))
+ build_symbol_table();
+
+/* figure out if there is more bss space needed */
+ extra_bss=get_extra_bss(symbol_table,nsyms,datasize+textsize+bsssize,
+ &init_address,bsssize);
- /* allocate some memory */
+/* allocate some memory */
#ifndef STAND
- {
- BEGIN_NO_INTERRUPT;
- memory = alloc_object ( t_cfdata );
- memory->cfd.cfd_self = 0;
- memory->cfd.cfd_start = 0;
- memory->cfd.cfd_size = datasize + textsize + bsssize + extra_bss;
- vs_push(memory);
- the_start = start_address =
- memory->cfd.cfd_start =
- alloc_contblock ( memory->cfd.cfd_size );
- sfaslp->s_start_data = start_address + textsize;
- END_NO_INTERRUPT;
- }
-#else
- /* What does this mean? */
- the_start = start_address
- = malloc ( datasize + textsize + bsssize + extra_bss + 0x80000 );
- the_start = start_address = (char *) ( 0x1000 * ( ( ( (int) the_start +
0x70000) + 0x1000) / 0x1000 ) );
+ {BEGIN_NO_INTERRUPT;
+ memory = alloc_object(t_cfdata);
+ memory->cfd.cfd_self = 0;
+ memory->cfd.cfd_start = 0;
+ memory->cfd.cfd_size = datasize+textsize+bsssize + extra_bss;
+ vs_push(memory);
+ the_start=start_address=
+ memory->cfd.cfd_start =
+ alloc_contblock(memory->cfd.cfd_size);
sfaslp->s_start_data = start_address + textsize;
+ END_NO_INTERRUPT;
+ }
+#else
+ the_start=start_address
+ = malloc(datasize+textsize+bsssize + extra_bss + 0x80000);
+ the_start=start_address= (char *)(
+ 0x1000* ((((int)the_start + 0x70000) + 0x1000)/0x1000));
+ sfaslp->s_start_data = start_address + textsize;
+
#endif
- dprintf(" Code size %d, ", datasize+textsize+bsssize + extra_bss);
- if ( fseek ( fp, N_TXTOFF(fileheader), 0) < 0 ) {
- FEerror("file seek error",0,0);
- }
- fread ( the_start, textsize + datasize, 1, fp );
- dprintf("read %d bytes of text + data into memory at ", textsize +
datasize );
- /* relocate the actual loaded text */
- dprintf(" the_start (%x)\n", the_start);
+ dprintf( code size %d , datasize+textsize+bsssize + extra_bss);
+ if (fseek(fp,N_TXTOFF(fileheader) ,0) < 0)
+ FEerror("file seek error",0,0);
+ fread(the_start, textsize + datasize, 1, fp);
+ dprintf(read into memory text +data %d bytes, textsize + datasize);
+/* relocate the actual loaded text */
+
+ dprintf( the_start %x, the_start);
/* record which symbols are used */
-
+
#ifdef SYM_USED
- {
- int j=0;
- for(j=1; j< BSS_NSCN ; j++) {
- dprintf(" relocating section %d \n",j);
- if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0);
- for(i=0; i < section[j].s_nreloc; i++) {
- struct syment *sym;
- fread(&relocation_info, RELSZ, 1, fp);
- sym = & symbol_table[relocation_info.r_symndx];
- if (TC_SYMBOL_P(sym)) {
- SYM_USED(sym) = 1;
- }
- }
- }
- }
+ {int j=0;
+ for(j=1; j< BSS_NSCN ; j++)
+ { dprintf( relocating section %d \n,j);
+ if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0);
+ for(i=0; i < section[j].s_nreloc; i++)
+ { struct syment *sym;
+ fread(&relocation_info, RELSZ, 1, fp);
+ sym = & symbol_table[relocation_info.r_symndx];
+ if (TC_SYMBOL_P(sym))
+ SYM_USED(sym) = 1;
+ }}}
#endif
+
+
/* this looks up symbols in c.ptable and also adds new externals to
that c.table */
relocate_symbols(NSYMS(fileheader));
#ifdef COFF
- {
- int j = 0;
- for ( j = 1; j < BSS_NSCN ; j++) {
- dprintf("relocating section %d \n",j);
- if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0);
-# ifdef ADJUST_RELOC_START
- ADJUST_RELOC_START(j);
-# endif
- for ( i=0; i < section[j].s_nreloc; i++ ) {
- /* RELSZ = sizeof(relocation_info) */
- fread ( &relocation_info, RELSZ, 1, fp);
- dprintf ( " item %3d: ", i );
- relocate() ;
- }
- }
- }
+ {int j=0;
+ for(j=1; j< BSS_NSCN ; j++)
+ { dprintf( relocating section %d \n,j);
+ if (section[j].s_nreloc) fseek(fp,section[j].s_relptr,0);
+#ifdef ADJUST_RELOC_START
+ADJUST_RELOC_START(j)
+#endif
+ for(i=0; i < section[j].s_nreloc; i++)
+ /* RELSZ = sizeof(relocation_info) */
+ {fread(&relocation_info, RELSZ, 1, fp);
+ dprintf(relocating %d,i);
+ relocate();};
+ }};
#endif
#ifdef BSD
- fseek(fp,N_RELOFF(fileheader),0);
- {
- int nrel = fileheader.a_trsize/sizeof(struct reloc);
- for ( i=0; i < nrel; i++ ) {
- fread ( (char *)&relocation_info, sizeof(struct reloc),
+ fseek(fp,N_RELOFF(fileheader),0);
+ {int nrel = (fileheader.a_trsize/sizeof(struct reloc));
+ for (i=0; i < nrel; i++)
+ {fread((char *)&relocation_info, sizeof(struct reloc),
1, fp);
- dprintf("relocating %d\n",i);
- relocate();
- }
+ dprintf(relocating %d,i);
+ relocate();
+ }
}
-# ifdef N_DRELOFF
- fseek (fp, N_DRELOFF(fileheader), 0);
-# endif
- {
- int nrel = fileheader.a_drsize/sizeof(struct reloc);
- the_start += fileheader.a_text;
- for (i=0; i < nrel; i++) {
- fread ( (char *) &relocation_info, sizeof(struct reloc),
- 1, fp);
- dprintf("relocating %d\n",i);
- relocate();
- }
- }
-#endif
-
- /* end of relocation */
- dprintf(" END OF RELOCATION \n",0);
- dprintf(" invoking init function at %x", start_address);
- dprintf(" textsize is %x",textsize);
- dprintf(" datasize is %x\n",datasize);
+#ifdef N_DRELOFF
+ fseek (fp, N_DRELOFF(fileheader), 0);
+#endif
+ {int nrel = (fileheader.a_drsize/sizeof(struct reloc));
+ the_start += fileheader.a_text;
+ for (i=0; i < nrel; i++)
+
+ {fread((char *)&relocation_info, sizeof(struct reloc),
+ 1, fp);
+ dprintf(relocating %d,i);
+ relocate();
+ }
+ }
+#endif
+
+/* end of relocation */
+ dprintf( END OF RELOCATION \n,0);
+ dprintf( invoking init function at %x, start_address)
+ dprintf( textsize is %x,textsize);
+ dprintf( datasize is %x,datasize);
- /* read in the fasl vector */
+/* read in the fasl vector */
fseek(fp,fasl_vector_start,0);
- if ( feof ( fp ) ) {
- data=0;
- } else {
- data = read_fasl_vector(faslfile);
- vs_push(data);
+ if (feof(fp))
+ {data=0;}
+ else{
+ data = read_fasl_vector(faslfile);
+ vs_push(data);
#ifdef COFF
- dprintf(" read fasl now symbols %d \n", fileheader.f_nsyms);
+ dprintf( read fasl now symbols %d , fileheader.f_nsyms);
#endif
}
close_stream(faslfile);
+/*
+ {
+ int fd;
+
+ fd = creat ("xsgcl.bits", 0777);
+ write (fd, memory->cfd.cfd_start, textsize + datasize);
+ close (fd);
+
+ fd = open ("xsl2.bits", 0);
+ read (fd, memory->cfd.cfd_start, memory->cfd.cfd_size);
+ close (fd);
+ }
+*/
+
#ifndef STAND
ALLOCA_FREE(my_string_table);
ALLOCA_FREE(symbol_table);
-# ifdef CLEAR_CACHE
+
+
+#ifdef CLEAR_CACHE
CLEAR_CACHE;
-# endif
- dprintf ( "About to call_init %x \n", init_address );
- call_init ( init_address, memory, data, 0);
- dprintf ( "Finished call_init %x \n", memory );
+#endif
+ call_init(init_address,memory,data,0);
vs_base = old_vs_base;
vs_top = old_vs_top;
- dprintf ( "About to symbol_value %x \n", data );
-
- if ( symbol_value(sLAload_verboseA) != Cnil ) {
+ if(symbol_value(sLAload_verboseA)!=Cnil)
printf("start address -T %x ", memory->cfd.cfd_start);
- }
- return ( memory->cfd.cfd_size );
+ return(memory->cfd.cfd_size);
#endif
- {
- FILE *out;
- out=fopen("/tmp/sfasltest","w");
- fwrite((char *)&fileheader, sizeof(struct filehdr), 1, out);
- fwrite(start_address,sizeof(char),datasize+textsize,out);
- fclose(out);
- }
- printf("\n(start %x)\n",start_address);
- }
+ {FILE *out;
+ out=fopen("/tmp/sfasltest","w");
+ fwrite((char *)&fileheader, sizeof(struct filehdr), 1, out);
+ fwrite(start_address,sizeof(char),datasize+textsize,out);
+ fclose(out);}
+ printf("\n(start %x)\n",start_address);
+
}
int get_extra_bss(sym_table,length,start,ptr,bsssize)
- int length,bsssize;
- struct syment *sym_table;
- int *ptr; /* store init address offset here */
+ int length,bsssize;
+ struct syment *sym_table;
+ int *ptr; /* store init address offset here */
{
- int result = start;
+ int result = start;
#ifdef AIX3
- int next_bss = start - bsssize;
+ int next_bss = start - bsssize;
#endif
- struct syment *end,*sym;
+ struct syment *end,*sym;
#ifdef BSD
- char tem[SYMNMLEN +1];
+ char tem[SYMNMLEN +1];
#endif
- end =sym_table + length;
- for(sym=sym_table; sym < end; sym++)
- {
-
+ end =sym_table + length;
+ for(sym=sym_table; sym < end; sym++)
+ {
+
#ifdef FIND_INIT
- FIND_INIT
+ FIND_INIT
#endif
#ifdef AIX3
- /* we later go through the relocation entries making this 1
- for symbols used */
+ /* we later go through the relocation entries making this 1
+ for symbols used */
#ifdef SYM_USED
- if(TC_SYMBOL_P(sym))
- {SYM_USED(sym) = 0;}
+ if(TC_SYMBOL_P(sym))
+ {SYM_USED(sym) = 0;}
#endif
-
- /* fix up the external refer to _ptrgl to be local ref */
- if (sym->n_scnum == 0 &&
- strcmp(sym->n_name,"_ptrgl")==0)
- {struct syment* s =
- get_symbol("._ptrgl",TEXT_NSCN,sym_table,length);
- if (s ==0) FEerror("bad glue",0,0);
- sym->n_value = next_bss ;
- ptrgl_offset = next_bss;
- ptrgl_text = s->n_value;
- next_bss += 0xc;
- sym->n_scnum = DATA_NSCN;
- ((union auxent *)(sym+1))->x_csect.x_scnlen = 0xc;
-
- }
-
- if(sym->n_scnum != BSS_NSCN) goto NEXT;
- if(SYM_EXTERNAL_P(sym))
- {int val=sym->n_value;
- struct node joe;
- if (val && c_table.ptable)
- {struct node *answ;
- answ= find_sym(sym,0);
- if(answ)
- {sym->n_value = answ->address ;
- sym->n_scnum = N_UNDEF;
- val= ((union auxent *)(sym+1))->x_csect.x_scnlen;
- result -= val;
- goto NEXT;
- }}
- }
- /* reallocate the bss space */
- if (sym->n_value == 0)
- {result += ((union auxent *)(sym+1))->x_csect.x_scnlen;}
- sym->n_value = next_bss;
- next_bss += ((union auxent *)(sym+1))->x_csect.x_scnlen;
- NEXT:
- ;
- /* end aix3 */
+
+ /* fix up the external refer to _ptrgl to be local ref */
+ if (sym->n_scnum == 0 &&
+ strcmp(sym->n_name,"_ptrgl")==0)
+ {struct syment* s =
+ get_symbol("._ptrgl",TEXT_NSCN,sym_table,length);
+ if (s ==0) FEerror("bad glue",0,0);
+ sym->n_value = next_bss ;
+ ptrgl_offset = next_bss;
+ ptrgl_text = s->n_value;
+ next_bss += 0xc;
+ sym->n_scnum = DATA_NSCN;
+ ((union auxent *)(sym+1))->x_csect.x_scnlen = 0xc;
+
+ }
+
+ if(sym->n_scnum != BSS_NSCN) goto NEXT;
+ if(SYM_EXTERNAL_P(sym))
+ {int val=sym->n_value;
+ struct node joe;
+ if (val && c_table.ptable)
+ {struct node *answ;
+ answ= find_sym(sym,0);
+ if(answ)
+ {sym->n_value = answ->address ;
+ sym->n_scnum = N_UNDEF;
+ val= ((union auxent *)(sym+1))->x_csect.x_scnlen;
+ result -= val;
+ goto NEXT;
+ }}
+ }
+ /* reallocate the bss space */
+ if (sym->n_value == 0)
+ {result += ((union auxent *)(sym+1))->x_csect.x_scnlen;}
+ sym->n_value = next_bss;
+ next_bss += ((union auxent *)(sym+1))->x_csect.x_scnlen;
+ NEXT:
+ ;
+ /* end aix3 */
#endif
-
+
-
+
#ifdef BSD
- tem; /* ignored */
- if(SYM_EXTERNAL_P(sym) && SYM_UNDEF_P(sym))
+ tem; /* ignored */
+ if(SYM_EXTERNAL_P(sym) && SYM_UNDEF_P(sym))
#endif
#ifdef COFF
- if(0)
- /* what we really want is
- if (sym->n_scnum==0 && sym->n_sclass == C_EXT
- && !(bsearch(..in ptable for this symbol)))
- Since this won't allow loading in of a new external
array
- char foo[10] not ok
- static foo[10] ok.
- for the moment we give undefined symbol warning..
- Should really go through the symbols, recording the
external addr
- for ones found in ptable, and for the ones not in ptable
- set some flag, and add up the extra_bss required. Then
- when you have the new memory chunk in hand,
- you could make the pass setting the relative addresses.
- for the ones you flagged last time.
- */
-#endif
- /* external bss so not included in size of bss for file */
- {int val=sym->n_value;
- if (val && c_table.ptable
- && (0== find_sym(sym,0)))
- { sym->n_value=result;
- result += val;}}
-
- sym += NUM_AUX(sym);
+ if(0)
+ /* what we really want is
+ if (sym->n_scnum==0 && sym->n_sclass == C_EXT
+ && !(bsearch(..in ptable for this symbol)))
+ Since this won't allow loading in of a new external array
+ char foo[10] not ok
+ static foo[10] ok.
+ for the moment we give undefined symbol warning..
+ Should really go through the symbols, recording the external addr
+ for ones found in ptable, and for the ones not in ptable
+ set some flag, and add up the extra_bss required. Then
+ when you have the new memory chunk in hand,
+ you could make the pass setting the relative addresses.
+ for the ones you flagged last time.
+ */
+#endif
+ /* external bss so not included in size of bss for file */
+ {int val=sym->n_value;
+ if (val && c_table.ptable
+ && (0== find_sym(sym,0)))
+ { sym->n_value=result;
+ result += val;}}
+
+ sym += NUM_AUX(sym);
- }
- return (result-start);
+ }
+ return (result-start);
}
-
+
/* go through the symbol table changing the addresses of the symbols
- to reflect the current cfd_start */
+to reflect the current cfd_start */
-void relocate_symbols ( unsigned int length )
-{
- struct syment *end,*sym;
- unsigned int typ;
- char *str;
- char tem[SYMNMLEN +1];
- tem[SYMNMLEN]=0;
- end =symbol_table + length;
- for(sym=symbol_table; sym < end; sym++) {
- typ=NTYPE(sym);
+void
+relocate_symbols(length)
+unsigned int length;
+{struct syment *end,*sym;
+ unsigned int typ;
+ char *str;
+ char tem[SYMNMLEN +1];
+ tem[SYMNMLEN]=0;
+ end =symbol_table + length;
+ for(sym=symbol_table; sym < end; sym++) {
+ typ=NTYPE(sym);
#ifdef BSD
-# ifdef N_STAB
- if (N_STAB & sym->n_type) continue; /* skip: It is for dbx only */
-# endif
- typ=N_SECTION(sym);
- /* if(sym->n_type & N_EXT) should add the symbol name,
- so it would be accessible by future loads */
+#ifdef N_STAB
+ if (N_STAB & sym->n_type) continue;/* skip: It is for dbx only */
+#endif
+ typ=N_SECTION(sym);
+/* if(sym->n_type & N_EXT) should add the symbol name,
+ so it would be accessible by future loads */
#endif
- switch (typ) {
+ switch (typ) {
#ifdef BSD
- case N_ABS : case N_TEXT: case N_DATA: case N_BSS:
+ case N_ABS : case N_TEXT: case N_DATA: case N_BSS:
#endif
#ifdef COFF
-# ifdef _WIN32
- case TEXT_NSCN:
- sym->n_value = (int)start_address;
- break;
- case DATA_NSCN:
- sym->n_value = (int)sfaslp->s_start_data;
- break;
- case BSS_NSCN:
-# else /* _WIN32 */
- case TEXT_NSCN : case DATA_NSCN: case BSS_NSCN :
+#ifdef _WIN32
+ case TEXT_NSCN:
+ sym->n_value = (int)start_address;
+ break;
+ case DATA_NSCN:
+ sym->n_value = (int)sfaslp->s_start_data;
+ break;
+ case BSS_NSCN:
+#else /* _WIN32 */
+ case TEXT_NSCN : case DATA_NSCN: case BSS_NSCN :
#endif /* _WIN32 */
#endif /* COFF */
- str=SYM_NAME(sym);
- dprintf(" for sym %s \n",str);
- dprintf(" new value will be start %x\n", start_address);
+ str=SYM_NAME(sym);
+ dprintf( for sym %s ,str)
+ dprintf( new value will be start %x, start_address);
+
#ifdef AIX3
- if ( N_SECTION(sym) == DATA_NSCN
- && NUM_AUX(sym)
- && allocate_toc(sym) )
- break;
+ if(N_SECTION(sym) == DATA_NSCN
+ && NUM_AUX(sym)
+ && allocate_toc(sym))
+ break;
#endif
- sym->n_value = (int)start_address;
- break;
- case N_UNDEF:
- str=SYM_NAME(sym);
- dprintf(" undef symbol %s \n",str);
- dprintf(" symbol diff %d \n", sym - symbol_table);
- describe_sym ( sym-symbol_table, 0 );
- set_symbol_address(sym,str);
- describe_sym ( sym-symbol_table, 0 );
- break;
- default:
+ sym->n_value = (int)start_address;
+ break;
+ case N_UNDEF:
+ str=SYM_NAME(sym);
+ dprintf( undef symbol %s ,str);
+ dprintf( symbol diff %d , sym - symbol_table);
+ describe_sym(sym-symbol_table);
+ set_symbol_address(sym,str);
+ describe_sym(sym-symbol_table);
+ break;
+ default:
#ifdef COFF
- dprintf("am ignoring a scnum %d\n",(sym->n_scnum));
+ dprintf(am ignoring a scnum %d,(sym->n_scnum));
#endif
- break;
- }
- sym += NUM_AUX(sym);
- }
+ break;
+ }
+ sym += NUM_AUX(sym);
+ }
}
/*
- STEPS:
- 1) read in the symbol table from the file,
- 2) go through the symbol table, relocating external entries.
- 3) for i <=2 go thru the relocation information for this section
- relocating the text.
- 4) done.
- */
-
-struct node *find_sym ( struct syment *sym, char *name )
-{
- char tem[SYMNMLEN +1];
- tem [SYMNMLEN] = 0;
- if (name==0) name = SYM_NAME(sym);
- return find_sym_ptable(name);
-}
-
-void set_symbol_address ( struct syment *sym, char *string )
-{
- struct node *answ;
- if ( c_table.ptable ) {
- dprintf("string %s\n", string);
- answ = find_sym(sym,string);
- dprintf("answ %d \n", (answ ? answ->address : -1) );
- if ( answ ) {
+STEPS:
+1) read in the symbol table from the file,
+2) go through the symbol table, relocating external entries.
+3) for i <=2 go thru the relocation information for this section
+ relocating the text.
+4) done.
+*/
+
+struct node *
+find_sym(sym,name)
+ struct syment *sym;
+ char *name;
+{ char tem[SYMNMLEN +1];
+ tem [SYMNMLEN] = 0;
+ if (name==0) name = SYM_NAME(sym);
+ return find_sym_ptable(name);}
+
+void
+set_symbol_address(sym,string)
+struct syment *sym;
+char *string;
+{struct node *answ;
+ if (c_table.ptable)
+ {
+ dprintf(string %s, string);
+ answ = find_sym(sym,string);
+ dprintf(answ %d , (answ ? answ->address : -1));
+ if(answ)
+ {
#ifdef COFF
#ifdef _AIX370
- if ( NTYPE(sym) == N_UNDEF )
- sym->n_value = answ->address;
- else
+ if (NTYPE(sym) == N_UNDEF)
+ sym->n_value = answ->address;
+ else
#endif
- sym->n_value = answ->address -sym->n_value;
- /* for symbols in the local data,text and bss this gets added
- on when we add the current value */
+ sym->n_value = answ->address -sym->n_value;
+ /* for symbols in the local data,text and bss this gets added
+ on when we add the current value */
#endif
#ifdef BSD
- /* the old value of sym->n_value is the length of the common area
- starting at this address */
- sym->n_value = answ->address;
+ /* the old value of sym->n_value is the length of the common area
+ starting at this address */
+ sym->n_value = answ->address;
#endif
#ifdef AIX3
- fix_undef_toc_address(answ,sym,string);
+ fix_undef_toc_address(answ,sym,string);
#endif
- } else {
- fprintf ( stdout,"undefined %s symbol", string );
- fflush(stdout);
- }
- } else {
- FEerror("symbol table not loaded",0,0);
- }
-}
+}
+ else
+ {
+/*
+#ifdef BSD
+ {char *name;
+ name=malloc(1+strlen(string));
+ strcpy(name,string);
+ sym->n_value = sym->n_value + (unsigned int) the_start;
+ add_symbol(name,sym->n_value,NULL);
+ }
+#endif
+*/
+ fprintf(stdout,"undefined %s symbol",string)
+ ;fflush(stdout);
+
+ }}
+
+ else{FEerror("symbol table not loaded",0,0);}}
/* include the machine independent stuff */
#include "sfasli.c"
+
#ifdef DEBUG
-void print_name ( struct syment *p )
-{
- char tem[10], *name;
- name = SYM_NAME(p);
- name = (((p)->n_zeroes == 0) ?
- &my_string_table[(p)->n_offset] :
- ((p)->n_name[SYMNMLEN -1] ?
- (strncpy(tem,(p)->n_name,
- SYMNMLEN),
- (char *)tem) :
- (p)->n_name ));
-
- printf("(name:|%s|)",name);
- printf("(sclass 0x%x)",p->n_sclass);
-#ifndef __MINGW32__
- printf("(external_p 0x%x)",SYM_EXTERNAL_P(p));
-#endif
- printf("(n_type 0x%x)",p->n_type);
- printf("(n_value 0x%x)",p->n_value);
- printf("(numaux 0x%x)\n",NUM_AUX(p));
- fflush(stdout);
+print_name(p)
+ struct syment *p;
+{char tem[10],*name;
+ name=SYM_NAME(p);
+ name= (((p)->_n._n_n._n_zeroes == 0) ?
+ &my_string_table[(p)->_n._n_n._n_offset] :
+ ((p)->_n._n_name[SYMNMLEN -1] ?
+ (strncpy(tem,(p)->_n._n_name,
+ SYMNMLEN),
+ (char *)tem) :
+ (p)->_n._n_name ));
+
+ printf("(name:|%s|)",name);
+ printf("(sclass 0x%x)",p->n_sclass);
+ printf("(external_p 0x%x)",SYM_EXTERNAL_P(p));
+ printf("(n_type 0x%x)",p->n_type);
+ printf("(n_value 0x%x)",p->n_value);
+ printf("(numaux 0x%x)\n",NUM_AUX(p));
+ fflush(stdout);
}
#endif
Index: o/toplevel.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/toplevel.c,v
retrieving revision 1.5
retrieving revision 1.4
diff -u -r1.5 -r1.4
--- o/toplevel.c 8 Jul 2003 06:50:02 -0000 1.5
+++ o/toplevel.c 15 Feb 2003 00:38:28 -0000 1.4
@@ -28,7 +28,7 @@
#include "include.h"
-object sLcompile, sLload, sLeval, sLcompile_tl, sLload_tl, sLexecute;
+object sLcompile, sLload, sLeval;
object sLprogn;
@@ -132,10 +132,9 @@
if(endp(arg))
FEtoo_few_argumentsF(arg);
for (ss = MMcar(arg); !endp(ss); ss = MMcdr(ss))
- if ( (MMcar(ss) == sLeval) || (MMcar(ss) == sLexecute) )
+ if(MMcar(ss) == sLeval)
flag = TRUE;
- else if ( MMcar(ss) != sLload && MMcar(ss) != sLcompile &&
- MMcar(ss) != sLload_tl && MMcar(ss) != sLcompile_tl )
+ else if(MMcar(ss) != sLload && MMcar(ss) != sLcompile)
FEinvalid_form("~S is an undefined situation for EVAL-WHEN.",
MMcar(ss));
if(flag) {
@@ -195,13 +194,11 @@
}
DEF_ORDINARY("COMPILE",sLcompile,LISP,"");
-DEF_ORDINARY("COMPILE-TOPLEVEL",sLcompile_tl,KEYWORD,"");
DEF_ORDINARY("DECLARE",sLdeclare,LISP,"");
DEF_ORDINARY("EVAL",sLeval,LISP,"");
-DEF_ORDINARY("EXECUTE",sLexecute,KEYWORD,"");
+DEF_ORDINARY("EVAL",sLeval,LISP,"");
DEF_ORDINARY("FUNCTION-DOCUMENTATION",sSfunction_documentation,SI,"");
DEF_ORDINARY("LOAD",sLload,LISP,"");
-DEF_ORDINARY("LOAD-TOPLEVEL",sLload_tl,KEYWORD,"");
DEF_ORDINARY("PROGN",sLprogn,LISP,"");
DEF_ORDINARY("TYPEP",sLtypep,LISP,"");
DEF_ORDINARY("VALUES",sLvalues,LISP,"");
Index: o/unexnt.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/unexnt.c,v
retrieving revision 1.11
retrieving revision 1.10
diff -u -r1.11 -r1.10
--- o/unexnt.c 11 Jul 2003 06:28:32 -0000 1.11
+++ o/unexnt.c 13 Jan 2003 04:48:08 -0000 1.10
@@ -36,14 +36,6 @@
#include "cyglacks.h"
#endif
-#if 0
-#ifdef __MINGW32__
-# define SEPARATE_BSS_SECTION
-#endif
-#endif
-
-extern sigint();
-
/* Include relevant definitions from IMAGEHLP.H, which can be found
in \\win32sdk\mstools\samples\image\include\imagehlp.h. */
@@ -140,7 +132,7 @@
{
extern void mainCRTStartup (void);
-#if 1
+#if 0
/* Give us a way to debug problems with crashes on startup when
running under the MSVC profiler. */
if (GetEnvironmentVariable ("EMACS_DEBUG", NULL, 0) > 0)
@@ -709,8 +701,6 @@
printf ("\t0x%p BSS start in process.\n", bss_data);
printf ("\t0x%08lx BSS offset in executable.\n", index);
printf ("\t0x%08lx BSS size in bytes.\n", size);
- printf ("\t0x%08lx file base.\n", p_outfile->file_base );
- printf ("\t0x%08lx file base + index.\n", p_outfile->file_base + index );
memcpy ((char *) p_outfile->file_base + index, bss_data, size);
}
@@ -750,10 +740,6 @@
i = GetLastError ();
exit (1);
}
- printf ("\t0x%p BSS start in memory.\n", bss_start);
- printf ("\t0x%08lx BSS offset in saved executable.\n", index);
- printf ("\t0x%08lx BSS size in bytes.\n", bss_size);
- printf ("\t0x%08lx bytes read.\n", n_read);
CloseHandle (file);
}
@@ -789,11 +775,6 @@
file_base = MapViewOfFileEx (file_mapping, FILE_MAP_COPY, 0,
heap_index_in_executable, size,
get_heap_start ());
- printf ("\t0x%p Heap start in memory.\n", get_heap_start() );
- printf ("\t0x%08lx Heap offset in executable.\n",
heap_index_in_executable);
- printf ("\t0x%08lx Heap size in bytes.\n", size);
- printf ("\t0x%08lx file base.\n", file_base);
-
if (file_base != 0)
{
return;
@@ -972,11 +953,8 @@
the region below the 256MB line for our malloc arena - 229MB is
still a pretty decent arena to play in! */
-#if 0
unsigned long base = DBEGIN; /* 27MB */
-#else
- unsigned long base = 0x10100000 /*0x01B00000*/; /* 27MB */
-#endif
+ /* unsigned long base = 0x01B00000; */ /* 27MB */
unsigned long end = 1 << VALBITS; /* 256MB */
void *ptr = NULL;
@@ -1001,7 +979,6 @@
MEM_RESERVE,
PAGE_NOACCESS);
DBEGIN = (DBEGIN_TY) ptr;
- base = DBEGIN;
#endif
return ptr;
Index: cmpnew/cmpmain.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/cmpmain.lsp,v
retrieving revision 1.19
diff -u -r1.19 cmpmain.lsp
--- cmpnew/cmpmain.lsp 8 Jul 2003 04:20:42 -0000 1.19
+++ cmpnew/cmpmain.lsp 17 Jul 2003 18:06:44 -0000
@@ -45,18 +45,7 @@
;;If the following is a string, then it is inserted instead of
;; the include file cmpinclude.h, EXCEPT for system-p calls.
(defvar *cmpinclude-string* t)
-(defvar *compiler-default-type* #p".lsp")
-(defvar *compiler-normal-type* #p".lsp")
-(defun compiler-default-type (pname)
- "Set the default file extension (type) for compilable file names."
- (setf *compiler-default-type* (if (pathnamep pname)
- pname
- (make-pathname :type (string-left-trim "."
pname)))))
-
-(defun compiler-reset-type ()
- "Set the default file extension (type) to <.lsp>."
- (compiler-default-type *compiler-normal-type*))
;; Let the user write dump c-file etc to /dev/null.
(defun get-output-pathname (file ext name &optional (dir (pathname-directory
*default-pathname-defaults*)))
@@ -190,26 +179,26 @@
(cond (*compiler-in-use*
(format t "~&The compiler was called recursively.~%~
Cannot compile ~a.~%"
- (namestring (merge-pathnames input-pathname
*compiler-default-type*)))
+ (namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(t (setq *error-p* nil)
(setq *compiler-in-use* t)))
- (unless (probe-file (merge-pathnames input-pathname *compiler-default-type*))
+ (unless (probe-file (merge-pathnames input-pathname #".lsp"))
(format t "~&The source file ~a is not found.~%"
- (namestring (merge-pathnames input-pathname
*compiler-default-type*)))
+ (namestring (merge-pathnames input-pathname #".lsp")))
(setq *error-p* t)
(return-from compile-file1 (values)))
(when *compile-verbose*
(format t "~&Compiling ~a.~%"
- (namestring (merge-pathnames input-pathname
*compiler-default-type*))))
+ (namestring (merge-pathnames input-pathname #".lsp"))))
(and *record-call-info* (clear-call-table))
(with-open-file
- (*compiler-input* (merge-pathnames input-pathname
*compiler-default-type*))
+ (*compiler-input* (merge-pathnames input-pathname #".lsp"))
(cond ((numberp *split-files*)
Index: pcl/pcl_boot.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/pcl/pcl_boot.lisp,v
retrieving revision 1.2
retrieving revision 1.1
diff -u -r1.2 -r1.1
--- pcl/pcl_boot.lisp 15 Jul 2003 18:03:38 -0000 1.2
+++ pcl/pcl_boot.lisp 26 Feb 2003 22:21:38 -0000 1.1
@@ -203,13 +203,9 @@
(duplicate-option :method-class)
(initarg :method-class `',(cadr option))))
(:method
-; (error
-; "DEFGENERIC doesn't support the :METHOD option yet."))))
- (push `(defmethod ,function-specifier ,@(cdr option))
- methods))))
-; (t ;unsuported things must get a 'program-error
-; (simple-program-error "Unsupported option ~S." option))))
-
+ (error
+ "DEFGENERIC doesn't support the :METHOD option yet."))))
+
(let ((declarations (initarg :declarations)))
(when declarations (initarg :declarations `',declarations)))))
`(progn
=============================================================================
against 2.5.3
=============================================================================
Index: h/new_decl.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/new_decl.h,v
retrieving revision 1.42
retrieving revision 1.42.4.1
diff -u -r1.42 -r1.42.4.1
--- h/new_decl.h 1 Mar 2003 22:37:37 -0000 1.42
+++ h/new_decl.h 16 Jul 2003 02:02:49 -0000 1.42.4.1
@@ -1,465 +1,458 @@
-EXTER object fLbye (fixnum exitc) ;
-EXTER object fLquit (fixnum exitc) ;
-EXTER object fLexit (fixnum exitc) ;
-EXTER object sSAno_initA ;
-EXTER object fLidentity (object x0) ;
-EXTER object fLlisp_implementation_version (void) ;
-EXTER object sSAlisp_maxpagesA ;
-EXTER object sSAsystem_directoryA ;
-EXTER object sSAmultiply_stacksA ;
-EXTER object sStop_level ;
-EXTER object sSAcommand_argsA ;
-EXTER object sSAafter_gbc_hookA ;
-EXTER object sSAignore_maximum_pagesA ;
-EXTER object fSallocated (object typ) ;
-EXTER object fSreset_number_used (object typ) ;
-EXTER object fSstaticp (object x) ;
-EXTER object fSallocate (object type,fixnum npages,...) ;
-EXTER object fSallocate_sgc (object type,fixnum min,fixnum max,fixnum
free_percent) ;
-EXTER object fSallocate_growth
- (object type,fixnum min,fixnum max,fixnum percent,fixnum percent_free) ;
-EXTER object fSallocate_contiguous_pages (fixnum npages,...) ;
-EXTER object fSallocated_contiguous_pages (void) ;
-EXTER object fSmaximum_contiguous_pages (void) ;
-EXTER object fSallocate_relocatable_pages (fixnum npages,...) ;
-EXTER object fSallocated_relocatable_pages (void) ;
-EXTER object fSget_hole_size (void) ;
-EXTER object fSset_hole_size (fixnum npages,...) ;
-EXTER object fLgbc (object x0) ;
-EXTER object sSAnotify_gbcA ;
-EXTER object sSAgbc_messageA ;
-EXTER object sLcommon ;
-EXTER object sLnull ;
-EXTER object sLcons ;
-EXTER object sLlist ;
-EXTER object sLsymbol ;
-EXTER object sLarray ;
-EXTER object sLvector ;
-EXTER object sLbit_vector ;
-EXTER object sLstring ;
-EXTER object sLsequence ;
-EXTER object sLsimple_array ;
-EXTER object sLsimple_vector ;
-EXTER object sLsimple_bit_vector ;
-EXTER object sLsimple_string ;
-EXTER object sLfunction ;
-EXTER object sLcompiled_function ;
-EXTER object sLpathname ;
-EXTER object sLcharacter ;
-EXTER object sLnumber ;
-EXTER object sLrational ;
-EXTER object sLfloat ;
-EXTER object sLstring_char ;
-EXTER object sLinteger ;
-EXTER object sLratio ;
-EXTER object sLshort_float ;
-EXTER object sLstandard_char ;
-EXTER object sLboolean ;
-EXTER object sLfixnum ;
-EXTER object sLpositive_fixnum ;
-EXTER object sLcomplex ;
-EXTER object sLsingle_float ;
-EXTER object sLpackage ;
-EXTER object sLbignum ;
-EXTER object sLrandom_state ;
-EXTER object sLdouble_float ;
-EXTER object sLstream ;
-EXTER object sLbit ;
-EXTER object sLreadtable ;
-EXTER object sLlong_float ;
-EXTER object sLhash_table ;
-EXTER object sLkeyword ;
-EXTER object sLstructure ;
-EXTER object sLsatisfies ;
-EXTER object sLmember ;
-EXTER object sLnot ;
-EXTER object sLor ;
-EXTER object sLand ;
-EXTER object sLvalues ;
-EXTER object sLmod ;
-EXTER object sLsigned_byte ;
-EXTER object sLunsigned_byte ;
-EXTER object sLsigned_char ;
-EXTER object sLunsigned_char ;
-EXTER object sLsigned_short ;
-EXTER object sLunsigned_short ;
-EXTER object sLA ;
-EXTER object sLplusp ;
-EXTER object sLmethod_combination ;
-EXTER object sLarithmetic_error ;
-EXTER object sLbase_char ;
-EXTER object sLbase_string ;
-EXTER object sLbroadcast_stream ;
-EXTER object sLbuilt_in_class ;
-EXTER object sLcell_error ;
-EXTER object sLclass ;
-EXTER object sLconcatenated_stream ;
-EXTER object sLcondition ;
-EXTER object sLcontrol_error ;
-EXTER object sLdivision_by_zero ;
-EXTER object sLecho_stream ;
-EXTER object sLend_of_file ;
-EXTER object sLerror ;
-EXTER object sLextended_char ;
-EXTER object sLfile_error ;
-EXTER object sLfile_stream ;
-EXTER object sLfloating_point_inexact ;
-EXTER object sLfloating_point_invalid_operation ;
-EXTER object sLfloating_point_overflow ;
-EXTER object sLfloating_point_underflow ;
-EXTER object sLgeneric_function ;
-EXTER object sLlogical_pathname ;
-EXTER object sLmethod ;
-EXTER object sLpackage_error ;
-EXTER object sLparse_error ;
-EXTER object sLprint_not_readable ;
-EXTER object sLprogram_error ;
-EXTER object sLreader_error ;
-EXTER object sLserious_condition ;
-EXTER object sLsimple_base_string ;
-EXTER object sLsimple_condition ;
-EXTER object sLsimple_type_error ;
-EXTER object sLsimple_warning ;
-EXTER object sLstandard_class ;
-EXTER object sLstandard_generic_function ;
-EXTER object sLstandard_method ;
-EXTER object sLstandard_object ;
-EXTER object sLstorage_condition ;
-EXTER object sLstream_error ;
-EXTER object sLstring_stream ;
-EXTER object sLstructure_class ;
-EXTER object sLstructure_object ;
-EXTER object sLstyle_warning ;
-EXTER object sLsynonym_stream ;
-EXTER object sLtwo_way_stream ;
-EXTER object sLtype_error ;
-EXTER object sLunbound_slot ;
-EXTER object sLunbound_variable ;
-EXTER object sLundefined_function ;
-EXTER object sLwarning ;
-EXTER object sSchar_size ;
-EXTER object sSshort_size ;
-EXTER object fLfuncall (object fun,...) ;
-EXTER object fLapply (object fun,...) ;
-EXTER object fLeval (object x0) ;
-EXTER object fLconstantp (object x0) ;
-EXTER object sSlambda_block_expanded ;
-EXTER object sSAbreak_pointsA ;
-EXTER object sSAbreak_stepA ;
-EXTER object fLmacroexpand (object form,...) ;
-EXTER object sLfuncall ;
-EXTER object sLAmacroexpand_hookA ;
-EXTER object sSdefmacroA ;
-EXTER object sSAinhibit_macro_specialA ;
-EXTER object fLnot (object x0) ;
-EXTER object fLnot (object x0) ;
-EXTER object fLsymbolp (object x0) ;
-EXTER object fLatom (object x0) ;
-EXTER object fLconsp (object x0) ;
-EXTER object fLlistp (object x0) ;
-EXTER object fLnumberp (object x0) ;
-EXTER object fLintegerp (object x0) ;
-EXTER object fLrationalp (object x0) ;
-EXTER object fLrealp (object x0) ;
-EXTER object fLfloatp (object x0) ;
-EXTER object fLcomplexp (object x0) ;
-EXTER object fLcharacterp (object x0) ;
-EXTER object fLstringp (object x0) ;
-EXTER object fLbit_vector_p (object x0) ;
-EXTER object fLvectorp (object x0) ;
-EXTER object fLsimple_string_p (object x0) ;
-EXTER object fLsimple_bit_vector_p (object x0) ;
-EXTER object fLsimple_vector_p (object x0) ;
-EXTER object fLarrayp (object x0) ;
-EXTER object fLpackagep (object x0) ;
-EXTER object fLfunctionp (object x0) ;
-EXTER object fLcompiled_function_p (object x0) ;
-EXTER object fLcommonp (object x0) ;
-EXTER object fLeq (object x0,object x1) ;
-EXTER object fLeql (object x0,object x1) ;
-EXTER object fLequal (object x0,object x1) ;
-EXTER object fLequalp (object x0,object x1) ;
-EXTER object fScontains_sharp_comma (object x0) ;
-EXTER object fSspicep (object x0) ;
-EXTER object fSfixnump (object x0) ;
-EXTER object fLset (object symbol,object value) ;
-EXTER object fSfset (object sym,object function) ;
-EXTER object fLmakunbound (object sym) ;
-EXTER object fLfmakunbound (object sym) ;
-EXTER object sSclear_compiler_properties ;
-EXTER object fSclear_compiler_properties (object x0,object x1) ;
-EXTER object sLaref ;
-EXTER object sLcar ;
-EXTER object sLcdr ;
-EXTER object sLchar ;
-EXTER object sLdecf ;
-EXTER object sLelt ;
-EXTER object sLfill_pointer ;
-EXTER object sLget ;
-EXTER object sLgetf ;
-EXTER object sLgethash ;
-EXTER object sLincf ;
-EXTER object sLpop ;
-EXTER object sLpush ;
-EXTER object sLschar ;
-EXTER object sLsetf ;
-EXTER object sSsetf_lambda ;
-EXTER object sSstructure_access ;
-EXTER object sLsvref ;
-EXTER object sStraced ;
-EXTER object sLvector ;
-EXTER object sKallow_other_keys ;
-EXTER object fSerror_set (volatile object x0) ;
-EXTER object sLgensym_counter ;
-EXTER object fSmc (object name,object address) ;
-EXTER object fSmfsfun (object name,object address,object argd) ;
-EXTER object fSmfvfun (object name,object address,object argd) ;
-EXTER object fSmfvfun_key (object symbol,object address,object
argd,object keys) ;
-EXTER object fSmf (object name,object addr) ;
-EXTER object fSmm (object name,object addr) ;
-EXTER object fScompiled_function_name (object fun) ;
-EXTER object fSturbo_closure (object funobj) ;
-EXTER object fSspecialp (object sym) ;
-EXTER object sSdebug ;
-EXTER object fSdefvar1 (object sym,object val,...) ;
-EXTER object fSdebug (object sym,object val) ;
-EXTER object fSsetvv (object index,object val) ;
-EXTER object sSPmemory ;
-EXTER object sSPinit ;
-EXTER object fSinit_cmp_anon (void) ;
-EXTER object sKexternal ;
-EXTER object sKinherited ;
-EXTER object sKinternal ;
-EXTER object sKnicknames ;
-EXTER object sKuse ;
-EXTER object sLApackageA ;
-EXTER object fSset_gmp_allocate_relocatable
- (object flag) ;
-EXTER object fSallocate_bigger_fixnum_range (fixnum min,fixnum max) ;
-EXTER object fScmod (object num) ;
-EXTER object fScplus (object x0,object x1) ;
-EXTER object fSctimes (object x0,object x1) ;
-EXTER object fScdifference (object x0,object x1) ;
-EXTER object fLnth (fixnum index,object list) ;
-EXTER object fLfirst (object x) ;
-EXTER object fLsecond (object x) ;
-EXTER object fLthird (object x) ;
-EXTER object fLfourth (object x) ;
-EXTER object fLfifth (object x) ;
-EXTER object fLsixth (object x) ;
-EXTER object fLseventh (object x) ;
-EXTER object fLeighth (object x) ;
-EXTER object fLninth (object x) ;
-EXTER object fLtenth (object x) ;
-EXTER object fSnext_hash_table_entry (object table,object ind) ;
-EXTER object fLhash_table_test (object table) ;
-EXTER object fLhash_table_size (object table) ;
-EXTER object sLarray_rank_limit ;
-EXTER object sLarray_dimension_limit ;
-EXTER object sLarray_total_size_limit ;
-EXTER object sLbit ;
-EXTER object fLaref (object x,fixnum i, ...) ;
-EXTER object fLsvref (object x,ufixnum i) ;
-EXTER object fLrow_major_aref (object x,fixnum i) ;
-EXTER object fSaset1 (object x, fixnum i,object val) ;
-EXTER object fSaset (object x,fixnum i,object y, ...) ;
-EXTER object fSsvset (object x,fixnum i,object val) ;
-EXTER object fSmake_vector1 (fixnum n,fixnum elt_type,object staticp,...)
;
-EXTER object fSget_aelttype (object x) ;
-EXTER object fSmake_vector (object x0,object x1,object x2,object
x3,object x4,object x5,object x6,...) ;
-EXTER object fSmake_array1
- (fixnum elt_type,object staticp,object initial_element,object
displaced_to,fixnum displaced_index_offset,
- object dimensions) ;
-EXTER object fScopy_array_portion (object x,object y,fixnum i1,fixnum
i2,object n1o) ;
-EXTER object fSfill_pointer_set (object x,fixnum i) ;
-EXTER object fLfill_pointer (object x) ;
-EXTER object
- fLarray_has_fill_pointer_p (object x) ;
-EXTER object fLarray_element_type (object x) ;
-EXTER object fLadjustable_array_p (object x) ;
-EXTER object fSdisplaced_array_p (object x) ;
-EXTER object fLarray_rank (object x) ;
-EXTER object fLarray_dimension (object x,fixnum i) ;
-EXTER object fSreplace_array (object old,object new) ;
-EXTER object fLarray_total_size (object x) ;
-EXTER object fSaset_by_cursor (object array,object val,object cursor) ;
-EXTER object sSAmatch_dataA ;
-EXTER object sSAcase_fold_searchA ;
-EXTER object fSmatch_beginning (fixnum i) ;
-EXTER object fSmatch_end (fixnum i) ;
-EXTER object fSstring_match (object pattern,object string,...) ;
-EXTER object sSs_data ;
-EXTER object sLcompile ;
-EXTER object sLdeclare ;
-EXTER object sLeval ;
-EXTER object sLeval ;
-EXTER object sSfunction_documentation ;
-EXTER object sLload ;
-EXTER object sLprogn ;
-EXTER object sLtypep ;
-EXTER object sLvalues ;
-EXTER object sSvariable_documentation ;
-EXTER object sLwarn ;
-EXTER object sSAallow_gzipped_fileA ;
-EXTER object sKmyaddr ;
-EXTER object sKmyport ;
-EXTER object sKasync ;
-EXTER object sKhost ;
-EXTER object sKserver ;
-EXTER object sSsocket ;
-EXTER object sLAstandard_inputA ;
-EXTER object sLAstandard_outputA ;
-EXTER object sLAerror_outputA ;
-EXTER object sLAterminal_ioA ;
-EXTER object sLAquery_ioA ;
-EXTER object sLAdebug_ioA ;
-EXTER object sLAtrace_outputA ;
-EXTER object sSAignore_eof_on_terminal_ioA ;
-EXTER object sSAload_pathnameA ;
-EXTER object sLAload_verboseA ;
-EXTER object sKabort ;
-EXTER object sKappend ;
-EXTER object sKcreate ;
-EXTER object sKdefault ;
-EXTER object sKdirection ;
-EXTER object sKelement_type ;
-EXTER object sKerror ;
-EXTER object sKif_does_not_exist ;
-EXTER object sKif_exists ;
-EXTER object sKinput ;
-EXTER object sKio ;
-EXTER object sKnew_version ;
-EXTER object sKoutput ;
-EXTER object sKoverwrite ;
-EXTER object sKprint ;
-EXTER object sKprobe ;
-EXTER object sKrename ;
-EXTER object sKrename_and_delete ;
-EXTER object sKset_default_pathname ;
-EXTER object sKsupersede ;
-EXTER object sKverbose ;
-EXTER object sLAread_default_float_formatA ;
-EXTER object sLAread_baseA ;
-EXTER object sLAread_suppressA ;
-EXTER object sSY ;
-EXTER object sSYB ;
-EXTER object sSYZ ;
-EXTER object sLlistA ;
-EXTER object sLappend ;
-EXTER object sLnconc ;
-EXTER object sLapply ;
-EXTER object sLvector ;
-EXTER object sKupcase ;
-EXTER object sKdowncase ;
-EXTER object sKcapitalize ;
-EXTER object sKstream ;
-EXTER object sKescape ;
-EXTER object sKreadably ;
-EXTER object sKpretty ;
-EXTER object sKcircle ;
-EXTER object sKbase ;
-EXTER object sKradix ;
-EXTER object sKcase ;
-EXTER object sKgensym ;
-EXTER object sKlevel ;
-EXTER object sKlength ;
-EXTER object sKarray ;
-EXTER object sLAprint_escapeA ;
-EXTER object sLAprint_readablyA ;
-EXTER object sLAprint_prettyA ;
-EXTER object sLAprint_circleA ;
-EXTER object sLAprint_baseA ;
-EXTER object sLAprint_radixA ;
-EXTER object sLAprint_caseA ;
-EXTER object sLAprint_gensymA ;
-EXTER object sLAprint_levelA ;
-EXTER object sLAprint_lengthA ;
-EXTER object sLAprint_arrayA ;
-EXTER object sSAprint_packageA ;
-EXTER object sSAprint_structureA ;
-EXTER object sSpretty_print_format ;
-EXTER object sSAprint_nansA ;
-EXTER object fLformat (object strm, object control,...) ;
-EXTER object sSAindent_formatted_outputA ;
-EXTER object fSsetenv (object variable,object value) ;
-EXTER object fLdelete_file (object path) ;
-EXTER object fLerror (object fmt_string,...) ;
-EXTER object fLspecific_error (object error_name,object fmt_string,...) ;
-EXTER object fLspecific_correctable_error
- (object error_name,object fmt_string,...) ;
-EXTER object fLcerror (object continue_fmt_string,object fmt_string,...)
;
-EXTER object fSihs_top (void) ;
-EXTER object fSihs_fun (object x0) ;
-EXTER object fSihs_vs (object x0) ;
-EXTER object fSfrs_top (void) ;
-EXTER object fSfrs_vs (object x0) ;
-EXTER object fSfrs_bds (object x0) ;
-EXTER object fSfrs_class (object x0) ;
-EXTER object fSfrs_tag (object x0) ;
-EXTER object fSfrs_ihs (object x0) ;
-EXTER object fSbds_top (void) ;
-EXTER object fSbds_var (object x0) ;
-EXTER object fSbds_val (object x0) ;
-EXTER object fSvs_top (void) ;
-EXTER object fSvs (object x0) ;
-EXTER object fSsch_frs_base (object x0,object x1) ;
-EXTER object fSinternal_super_go (object tag,object x1,object x2) ;
-EXTER object sSuniversal_error_handler ;
-EXTER object fSuniversal_error_handler (object x0,object x1,object
x2,object x3,object error_fmt_string) ;
-EXTER object sSterminal_interrupt ;
-EXTER object sKwrong_type_argument ;
-EXTER object sKtoo_few_arguments ;
-EXTER object sKtoo_many_arguments ;
-EXTER object sKunexpected_keyword ;
-EXTER object sKinvalid_form ;
-EXTER object sKunbound_variable ;
-EXTER object sKinvalid_variable ;
-EXTER object sKundefined_function ;
-EXTER object sKinvalid_function ;
-EXTER object sKpackage_error ;
-EXTER object sKcatch ;
-EXTER object sKprotect ;
-EXTER object sKcatchall ;
-EXTER object fLget_universal_time (void) ;
-EXTER object fLget_internal_real_time (void) ;
-EXTER object sSAdefault_time_zoneA ;
-EXTER object fSgetpid (void) ;
-EXTER object fSuse_fast_links (object flag,...) ;
-EXTER object sScdefn ;
-EXTER object sLAlink_arrayA ;
-EXTER object fSprofile (object start_address,object scale) ;
-EXTER object fSfunction_start (object funobj) ;
-EXTER object fSset_up_combined (object first,...) ;
-EXTER object fSdisplay_profile (object start_addr,object scal) ;
-EXTER object fSarray_adress (object array) ;
-EXTER object sSAprofile_arrayA ;
-EXTER object sSAinterrupt_enableA ;
-EXTER object sSsigusr1_interrupt ;
-EXTER object sSsigio_interrupt ;
-EXTER object sSsignal_safety_required (fixnum signo,fixnum safety) ;
-EXTER object fSallow_signal (fixnum n) ;
-EXTER object fSinitfun
- (object sym,object addr_ind,object argd,...) ;
-EXTER object fSinitmacro (object first,...) ;
-EXTER object fSset_key_struct (object key_struct_ind) ;
-EXTER object fSinvoke (object x) ;
-EXTER object fSopen_named_socket (fixnum port) ;
-EXTER object fSclose_fd (fixnum fd) ;
-EXTER object fSclose_sfd (object sfd) ;
-EXTER object fSaccept_socket_connection (object named_socket) ;
-EXTER object fShostname_to_hostid (object host) ;
-EXTER object fSgethostname (void) ;
-EXTER object fShostid_to_hostname (object host_id) ;
-EXTER object fScheck_fd_for_input (fixnum fd,fixnum timeout) ;
-EXTER object fSclear_connection (fixnum fd) ;
-EXTER object fSconnection_state_fd (object sfd) ;
-EXTER object fSour_write (object sfd,object buffer,fixnum nbytes) ;
-EXTER object fSour_read_with_offset (object fd,object buffer,fixnum
offset,fixnum nbytes,fixnum timeout) ;
-EXTER object fSprint_to_string1 (object str,object x,object the_code) ;
-EXTER object fSset_sigio_for_fd (fixnum fd) ;
-EXTER object fSreset_string_input_stream (object strm,object
string,fixnum start,fixnum end) ;
-EXTER object fScheck_state_input (object osfd,fixnum timeout) ;
-EXTER object fSclear_connection_state (object osfd) ;
-EXTER object fSgetpeername (object sock) ;
-EXTER object fSgetsockname (object sock) ;
-EXTER object fSset_blocking (object sock,object setBlocking) ;
+EXTER object fLbye (fixnum exitc);
+EXTER object fLquit (fixnum exitc);
+EXTER object fLexit (fixnum exitc);
+EXTER object sSAno_initA;
+EXTER object fLidentity (object x0);
+EXTER object fLlisp_implementation_version (void);
+EXTER object sSAlisp_maxpagesA;
+EXTER object sSAsystem_directoryA;
+EXTER object sSAmultiply_stacksA;
+EXTER object sStop_level;
+EXTER object sSAcommand_argsA;
+EXTER object sSAafter_gbc_hookA;
+EXTER object sSAignore_maximum_pagesA;
+EXTER object fSallocated (object typ);
+EXTER object fSreset_number_used (object typ);
+EXTER object fSstaticp (object x);
+EXTER object fSallocate (object type,fixnum npages,...);
+EXTER object fSallocate_sgc (object type,fixnum min,fixnum max,fixnum
free_percent);
+EXTER object fSallocate_growth (object type,fixnum min,fixnum max,fixnum
percent,fixnum percent_free);
+EXTER object fSallocate_contiguous_pages (fixnum npages,...);
+EXTER object fSallocated_contiguous_pages (void);
+EXTER object fSmaximum_contiguous_pages (void);
+EXTER object fSallocate_relocatable_pages (fixnum npages,...);
+EXTER object fSallocated_relocatable_pages (void);
+EXTER object fSget_hole_size (void);
+EXTER object fSset_hole_size (fixnum npages,...);
+EXTER object fLgbc (object x0);
+EXTER object sSAnotify_gbcA;
+EXTER object sSAgbc_messageA;
+EXTER object sLcommon;
+EXTER object sLnull;
+EXTER object sLcons;
+EXTER object sLlist;
+EXTER object sLsymbol;
+EXTER object sLarray;
+EXTER object sLvector;
+EXTER object sLbit_vector;
+EXTER object sLstring;
+EXTER object sLsequence;
+EXTER object sLsimple_array;
+EXTER object sLsimple_vector;
+EXTER object sLsimple_bit_vector;
+EXTER object sLsimple_string;
+EXTER object sLfunction;
+EXTER object sLcompiled_function;
+EXTER object sLpathname;
+EXTER object sLcharacter;
+EXTER object sLnumber;
+EXTER object sLrational;
+EXTER object sLfloat;
+EXTER object sLstring_char;
+EXTER object sLinteger;
+EXTER object sLratio;
+EXTER object sLshort_float;
+EXTER object sLstandard_char;
+EXTER object sLboolean;
+EXTER object sLfixnum;
+EXTER object sLpositive_fixnum;
+EXTER object sLcomplex;
+EXTER object sLsingle_float;
+EXTER object sLpackage;
+EXTER object sLbignum;
+EXTER object sLrandom_state;
+EXTER object sLdouble_float;
+EXTER object sLstream;
+EXTER object sLbit;
+EXTER object sLreadtable;
+EXTER object sLlong_float;
+EXTER object sLhash_table;
+EXTER object sLkeyword;
+EXTER object sLstructure;
+EXTER object sLsatisfies;
+EXTER object sLmember;
+EXTER object sLnot;
+EXTER object sLor;
+EXTER object sLand;
+EXTER object sLvalues;
+EXTER object sLmod;
+EXTER object sLsigned_byte;
+EXTER object sLunsigned_byte;
+EXTER object sLsigned_char;
+EXTER object sLunsigned_char;
+EXTER object sLsigned_short;
+EXTER object sLunsigned_short;
+EXTER object sLA;
+EXTER object sLplusp;
+EXTER object sLmethod_combination;
+EXTER object sLarithmetic_error;
+EXTER object sLbase_char;
+EXTER object sLbase_string;
+EXTER object sLbroadcast_stream;
+EXTER object sLbuilt_in_class;
+EXTER object sLcell_error;
+EXTER object sLclass;
+EXTER object sLconcatenated_stream;
+EXTER object sLcondition;
+EXTER object sLcontrol_error;
+EXTER object sLdivision_by_zero;
+EXTER object sLecho_stream;
+EXTER object sLend_of_file;
+EXTER object sLerror;
+EXTER object sLextended_char;
+EXTER object sLfile_error;
+EXTER object sLfile_stream;
+EXTER object sLfloating_point_inexact;
+EXTER object sLfloating_point_invalid_operation;
+EXTER object sLfloating_point_overflow;
+EXTER object sLfloating_point_underflow;
+EXTER object sLgeneric_function;
+EXTER object sLlogical_pathname;
+EXTER object sLmethod;
+EXTER object sLpackage_error;
+EXTER object sLparse_error;
+EXTER object sLprint_not_readable;
+EXTER object sLprogram_error;
+EXTER object sLreader_error;
+EXTER object sLserious_condition;
+EXTER object sLsimple_base_string;
+EXTER object sLsimple_condition;
+EXTER object sLsimple_type_error;
+EXTER object sLsimple_warning;
+EXTER object sLstandard_class;
+EXTER object sLstandard_generic_function;
+EXTER object sLstandard_method;
+EXTER object sLstandard_object;
+EXTER object sLstorage_condition;
+EXTER object sLstream_error;
+EXTER object sLstring_stream;
+EXTER object sLstructure_class;
+EXTER object sLstructure_object;
+EXTER object sLstyle_warning;
+EXTER object sLsynonym_stream;
+EXTER object sLtwo_way_stream;
+EXTER object sLtype_error;
+EXTER object sLunbound_slot;
+EXTER object sLunbound_variable;
+EXTER object sLundefined_function;
+EXTER object sLwarning;
+EXTER object sSchar_size;
+EXTER object sSshort_size;
+EXTER object fLfuncall (object fun,...);
+EXTER object fLapply (object fun,...);
+EXTER object fLeval (object x0);
+EXTER object fLconstantp (object x0);
+EXTER object sSlambda_block_expanded;
+EXTER object sSAbreak_pointsA;
+EXTER object sSAbreak_stepA;
+EXTER object fLmacroexpand (object form,...);
+EXTER object sLfuncall;
+EXTER object sLAmacroexpand_hookA;
+EXTER object sSdefmacroA;
+EXTER object sSAinhibit_macro_specialA;
+EXTER object fLnot (object x0);
+EXTER object fLnot (object x0);
+EXTER object fLsymbolp (object x0);
+EXTER object fLatom (object x0);
+EXTER object fLconsp (object x0);
+EXTER object fLlistp (object x0);
+EXTER object fLnumberp (object x0);
+EXTER object fLintegerp (object x0);
+EXTER object fLrationalp (object x0);
+EXTER object fLrealp (object x0);
+EXTER object fLfloatp (object x0);
+EXTER object fLcomplexp (object x0);
+EXTER object fLcharacterp (object x0);
+EXTER object fLstringp (object x0);
+EXTER object fLbit_vector_p (object x0);
+EXTER object fLvectorp (object x0);
+EXTER object fLsimple_string_p (object x0);
+EXTER object fLsimple_bit_vector_p (object x0);
+EXTER object fLsimple_vector_p (object x0);
+EXTER object fLarrayp (object x0);
+EXTER object fLpackagep (object x0);
+EXTER object fLfunctionp (object x0);
+EXTER object fLcompiled_function_p (object x0);
+EXTER object fLcommonp (object x0);
+EXTER object fLeq (object x0,object x1);
+EXTER object fLeql (object x0,object x1);
+EXTER object fLequal (object x0,object x1);
+EXTER object fLequalp (object x0,object x1);
+EXTER object fScontains_sharp_comma (object x0);
+EXTER object fSspicep (object x0);
+EXTER object fSfixnump (object x0);
+EXTER object fLset (object symbol,object value);
+EXTER object fSfset (object sym,object function);
+EXTER object fLmakunbound (object sym);
+EXTER object fLfmakunbound (object sym);
+EXTER object sSclear_compiler_properties;
+EXTER object fSclear_compiler_properties (object x0,object x1);
+EXTER object sLaref;
+EXTER object sLcar;
+EXTER object sLcdr;
+EXTER object sLchar;
+EXTER object sLdecf;
+EXTER object sLelt;
+EXTER object sLfill_pointer;
+EXTER object sLget;
+EXTER object sLgetf;
+EXTER object sLgethash;
+EXTER object sLincf;
+EXTER object sLpop;
+EXTER object sLpush;
+EXTER object sLschar;
+EXTER object sLsetf;
+EXTER object sSsetf_lambda;
+EXTER object sSstructure_access;
+EXTER object sLsvref;
+EXTER object sStraced;
+EXTER object sLvector;
+EXTER object sKallow_other_keys;
+EXTER object fSerror_set (volatile object x0);
+EXTER object sLgensym_counter;
+EXTER object fSmc (object name,object address);
+EXTER object fSmfsfun (object name,object address,object argd);
+EXTER object fSmfvfun (object name,object address,object argd);
+EXTER object fSmfvfun_key (object symbol,object address,object argd,object
keys);
+EXTER object fSmf (object name,object addr);
+EXTER object fSmm (object name,object addr);
+EXTER object fScompiled_function_name (object fun);
+EXTER object fSturbo_closure (object funobj);
+EXTER object fSspecialp (object sym);
+EXTER object sSdebug;
+EXTER object fSdefvar1 (object sym,object val,...);
+EXTER object fSdebug (object sym,object val);
+EXTER object fSsetvv (object index,object val);
+EXTER object sSPmemory;
+EXTER object sSPinit;
+EXTER object fSinit_cmp_anon (void);
+EXTER object sKexternal;
+EXTER object sKinherited;
+EXTER object sKinternal;
+EXTER object sKnicknames;
+EXTER object sKuse;
+EXTER object sLApackageA;
+EXTER object fSset_gmp_allocate_relocatable (object flag);
+EXTER object fSallocate_bigger_fixnum_range (fixnum min,fixnum max);
+EXTER object fScmod (object num);
+EXTER object fScplus (object x0,object x1);
+EXTER object fSctimes (object x0,object x1);
+EXTER object fScdifference (object x0,object x1);
+EXTER object fLnth (fixnum index,object list);
+EXTER object fLfirst (object x);
+EXTER object fLsecond (object x);
+EXTER object fLthird (object x);
+EXTER object fLfourth (object x);
+EXTER object fLfifth (object x);
+EXTER object fLsixth (object x);
+EXTER object fLseventh (object x);
+EXTER object fLeighth (object x);
+EXTER object fLninth (object x);
+EXTER object fLtenth (object x);
+EXTER object fSnext_hash_table_entry (object table,object ind);
+EXTER object fLhash_table_test (object table);
+EXTER object fLhash_table_size (object table);
+EXTER object sLarray_rank_limit;
+EXTER object sLarray_dimension_limit;
+EXTER object sLarray_total_size_limit;
+EXTER object sLbit;
+EXTER object fLaref (object x,fixnum i, ...);
+EXTER object fLsvref (object x,ufixnum i);
+EXTER object fLrow_major_aref (object x,fixnum i);
+EXTER object fSaset1 (object x, fixnum i,object val);
+EXTER object fSaset (object x,fixnum i,object y, ...);
+EXTER object fSsvset (object x,fixnum i,object val);
+EXTER object fSmake_vector1 (fixnum n,fixnum elt_type,object staticp,...);
+EXTER object fSget_aelttype (object x);
+EXTER object fSmake_vector (object x0,object x1,object x2,object x3,object
x4,object x5,object x6,...);
+EXTER object fSmake_array1 (fixnum elt_type,object staticp,object
initial_element,object displaced_to,fixnum displaced_index_offset, object
dimensions);
+EXTER object fScopy_array_portion (object x,object y,fixnum i1,fixnum
i2,object n1o);
+EXTER object fSfill_pointer_set (object x,fixnum i);
+EXTER object fLfill_pointer (object x);
+EXTER object fLarray_has_fill_pointer_p (object x);
+EXTER object fLarray_element_type (object x);
+EXTER object fLadjustable_array_p (object x);
+EXTER object fSdisplaced_array_p (object x);
+EXTER object fLarray_rank (object x);
+EXTER object fLarray_dimension (object x,fixnum i);
+EXTER object fSreplace_array (object old,object new);
+EXTER object fLarray_total_size (object x);
+EXTER object fSaset_by_cursor (object array,object val,object cursor);
+EXTER object sSAmatch_dataA;
+EXTER object sSAcase_fold_searchA;
+EXTER object fSmatch_beginning (fixnum i);
+EXTER object fSmatch_end (fixnum i);
+EXTER object fSstring_match (object pattern,object string,...);
+EXTER object sSs_data;
+EXTER object sLcompile;
+EXTER object sLdeclare;
+EXTER object sLeval;
+EXTER object sLeval;
+EXTER object sSfunction_documentation;
+EXTER object sLload;
+EXTER object sLprogn;
+EXTER object sLtypep;
+EXTER object sLvalues;
+EXTER object sSvariable_documentation;
+EXTER object sLwarn;
+EXTER object sSAallow_gzipped_fileA;
+EXTER object sKmyaddr;
+EXTER object sKmyport;
+EXTER object sKasync;
+EXTER object sKhost;
+EXTER object sKserver;
+EXTER object sSsocket;
+EXTER object sLAstandard_inputA;
+EXTER object sLAstandard_outputA;
+EXTER object sLAerror_outputA;
+EXTER object sLAterminal_ioA;
+EXTER object sLAquery_ioA;
+EXTER object sLAdebug_ioA;
+EXTER object sLAtrace_outputA;
+EXTER object sSAignore_eof_on_terminal_ioA;
+EXTER object sSAload_pathnameA;
+EXTER object sLAload_verboseA;
+EXTER object sKabort;
+EXTER object sKappend;
+EXTER object sKcreate;
+EXTER object sKdefault;
+EXTER object sKdirection;
+EXTER object sKelement_type;
+EXTER object sKerror;
+EXTER object sKif_does_not_exist;
+EXTER object sKif_exists;
+EXTER object sKinput;
+EXTER object sKio;
+EXTER object sKnew_version;
+EXTER object sKoutput;
+EXTER object sKoverwrite;
+EXTER object sKprint;
+EXTER object sKprobe;
+EXTER object sKrename;
+EXTER object sKrename_and_delete;
+EXTER object sKset_default_pathname;
+EXTER object sKsupersede;
+EXTER object sKverbose;
+EXTER object sLAread_default_float_formatA;
+EXTER object sLAread_baseA;
+EXTER object sLAread_suppressA;
+EXTER object sSY;
+EXTER object sSYB;
+EXTER object sSYZ;
+EXTER object sLlistA;
+EXTER object sLappend;
+EXTER object sLnconc;
+EXTER object sLapply;
+EXTER object sLvector;
+EXTER object sKupcase;
+EXTER object sKdowncase;
+EXTER object sKcapitalize;
+EXTER object sKstream;
+EXTER object sKescape;
+EXTER object sKreadably;
+EXTER object sKpretty;
+EXTER object sKcircle;
+EXTER object sKbase;
+EXTER object sKradix;
+EXTER object sKcase;
+EXTER object sKgensym;
+EXTER object sKlevel;
+EXTER object sKlength;
+EXTER object sKarray;
+EXTER object sLAprint_escapeA;
+EXTER object sLAprint_readablyA;
+EXTER object sLAprint_prettyA;
+EXTER object sLAprint_circleA;
+EXTER object sLAprint_baseA;
+EXTER object sLAprint_radixA;
+EXTER object sLAprint_caseA;
+EXTER object sLAprint_gensymA;
+EXTER object sLAprint_levelA;
+EXTER object sLAprint_lengthA;
+EXTER object sLAprint_arrayA;
+EXTER object sSAprint_packageA;
+EXTER object sSAprint_structureA;
+EXTER object sSpretty_print_format;
+EXTER object sSAprint_nansA;
+EXTER object fLformat (object strm, object control,...);
+EXTER object sSAindent_formatted_outputA;
+EXTER object fSsetenv (object variable,object value);
+EXTER object fLdelete_file (object path);
+EXTER object fLerror (object fmt_string,...);
+EXTER object fLspecific_error (object error_name,object fmt_string,...);
+EXTER object fLspecific_correctable_error (object error_name,object
fmt_string,...);
+EXTER object fLcerror (object continue_fmt_string,object fmt_string,...);
+EXTER object fSihs_top (void);
+EXTER object fSihs_fun (object x0);
+EXTER object fSihs_vs (object x0);
+EXTER object fSfrs_top (void);
+EXTER object fSfrs_vs (object x0);
+EXTER object fSfrs_bds (object x0);
+EXTER object fSfrs_class (object x0);
+EXTER object fSfrs_tag (object x0);
+EXTER object fSfrs_ihs (object x0);
+EXTER object fSbds_top (void);
+EXTER object fSbds_var (object x0);
+EXTER object fSbds_val (object x0);
+EXTER object fSvs_top (void);
+EXTER object fSvs (object x0);
+EXTER object fSsch_frs_base (object x0,object x1);
+EXTER object fSinternal_super_go (object tag,object x1,object x2);
+EXTER object sSuniversal_error_handler;
+EXTER object fSuniversal_error_handler (object x0,object x1,object x2,object
x3,object error_fmt_string);
+EXTER object sSterminal_interrupt;
+EXTER object sKwrong_type_argument;
+EXTER object sKtoo_few_arguments;
+EXTER object sKtoo_many_arguments;
+EXTER object sKunexpected_keyword;
+EXTER object sKinvalid_form;
+EXTER object sKunbound_variable;
+EXTER object sKinvalid_variable;
+EXTER object sKundefined_function;
+EXTER object sKinvalid_function;
+EXTER object sKpackage_error;
+EXTER object sKcatch;
+EXTER object sKprotect;
+EXTER object sKcatchall;
+EXTER object fLget_universal_time (void);
+EXTER object fLget_internal_real_time (void);
+EXTER object sSAdefault_time_zoneA;
+EXTER object fSgetpid (void);
+EXTER object fSuse_fast_links (object flag,...);
+EXTER object sScdefn;
+EXTER object sLAlink_arrayA;
+EXTER object fSprofile (object start_address,object scale);
+EXTER object fSfunction_start (object funobj);
+EXTER object fSset_up_combined (object first,...);
+EXTER object fSdisplay_profile (object start_addr,object scal);
+EXTER object fSarray_adress (object array);
+EXTER object sSAprofile_arrayA;
+EXTER object sSAinterrupt_enableA;
+EXTER object sSsigusr1_interrupt;
+EXTER object sSsigio_interrupt;
+EXTER object sSsignal_safety_required (fixnum signo,fixnum safety);
+EXTER object fSallow_signal (fixnum n);
+EXTER object fSinitfun (object sym,object addr_ind,object argd,...);
+EXTER object fSinitmacro (object first,...);
+EXTER object fSset_key_struct (object key_struct_ind);
+EXTER object fSinvoke (object x);
+EXTER object fSopen_named_socket (fixnum port);
+EXTER object fSclose_fd (fixnum fd);
+EXTER object fSclose_sfd (object sfd);
+EXTER object fSaccept_socket_connection (object named_socket);
+EXTER object fShostname_to_hostid (object host);
+EXTER object fSgethostname (void);
+EXTER object fShostid_to_hostname (object host_id);
+EXTER object fScheck_fd_for_input (fixnum fd,fixnum timeout);
+EXTER object fSclear_connection (fixnum fd);
+EXTER object fSconnection_state_fd (object sfd);
+EXTER object fSour_write (object sfd,object buffer,fixnum nbytes);
+EXTER object fSour_read_with_offset (object fd,object buffer,fixnum
offset,fixnum nbytes,fixnum timeout);
+EXTER object fSprint_to_string1 (object str,object x,object the_code);
+EXTER object fSset_sigio_for_fd (fixnum fd);
+EXTER object fSreset_string_input_stream (object strm,object string,fixnum
start,fixnum end);
+EXTER object fScheck_state_input (object osfd,fixnum timeout);
+EXTER object fSclear_connection_state (object osfd);
+EXTER object fSgetpeername (object sock);
+EXTER object fSgetsockname (object sock);
+EXTER object fSset_blocking (object sock,object setBlocking);
Index: h/object.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/object.h,v
retrieving revision 1.18
retrieving revision 1.18.4.1
diff -u -r1.18 -r1.18.4.1
--- h/object.h 1 Mar 2003 22:37:37 -0000 1.18
+++ h/object.h 16 Jul 2003 02:02:49 -0000 1.18.4.1
@@ -360,8 +360,8 @@
};
-#define USHORT(x,i) (((unsigned short *)(x)->ust.ust_self)[i])
-#define SHORT(x,i) ((( short *)(x)->ust.ust_self)[i])
+#define USHORT_GCL(x,i) (((unsigned short *)(x)->ust.ust_self)[i])
+#define SHORT_GCL(x,i) ((( short *)(x)->ust.ust_self)[i])
#define BV_OFFSET(x) ((type_of(x)==t_bitvector ? x->bv.bv_offset : \
type_of(x)== t_array ? x->a.a_offset : (abort(),0)))
@@ -455,7 +455,7 @@
#define S_DATA(x) ((struct s_data *)((x)->str.str_self))
#define SLOT_TYPE(def,i) (((S_DATA(def))->raw->ust.ust_self[i]))
-#define SLOT_POS(def,i) USHORT(S_DATA(def)->slot_position,i)
+#define SLOT_POS(def,i) USHORT_GCL(S_DATA(def)->slot_position,i)
#define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i))))
Index: h/protoize.h
===================================================================
RCS file: /cvsroot/gcl/gcl/h/protoize.h,v
retrieving revision 1.26
retrieving revision 1.26.4.1
diff -u -r1.26 -r1.26.4.1
--- h/protoize.h 1 Mar 2003 22:37:37 -0000 1.26
+++ h/protoize.h 16 Jul 2003 02:02:49 -0000 1.26.4.1
@@ -1737,6 +1737,9 @@
object
cplus(object,object);
+object
+Icall_error_handler(object,object,int,...);
+
#if defined (__MINGW32__)
int bcmp ( const void *s1, const void *s2, size_t n );
void bcopy ( const void *s1, void *s2, size_t n );
Index: o/array.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/array.c,v
retrieving revision 1.20
retrieving revision 1.20.4.1
diff -u -r1.20 -r1.20.4.1
--- o/array.c 1 Mar 2003 22:37:37 -0000 1.20
+++ o/array.c 16 Jul 2003 02:02:51 -0000 1.20.4.1
@@ -164,9 +164,9 @@
case aet_uchar:
return small_fixnum(x->ust.ust_self[i]);
case aet_short:
- return make_fixnum(SHORT(x, i));
+ return make_fixnum(SHORT_GCL(x, i));
case aet_ushort:
- return small_fixnum(USHORT(x, i));
+ return make_fixnum(USHORT_GCL(x, i));
default:
FEerror("unknown array type",0);
@@ -234,11 +234,11 @@
break;
case aet_short:
ASSURE_TYPE(val,t_fixnum);
- SHORT(x, i) = Mfix(val);
+ SHORT_GCL(x, i) = Mfix(val);
break;
case aet_ushort:
ASSURE_TYPE(val,t_fixnum);
- USHORT(x, i) = Mfix(val);
+ USHORT_GCL(x, i) = Mfix(val);
break;
default:
FEerror("unknown array type",0);
@@ -739,21 +739,59 @@
static char *
raw_aet_ptr(object x, short int typ)
{ /* doubles are the largest raw type */
- static double u;
- if (x==Cnil) return aet_types[typ].dflt;
+
+ static union{
+ object o;char c;fixnum i;shortfloat f;longfloat d;
+ unsigned char uc;short s;unsigned short us;} u;
+
+ if (x==Cnil)
+ return aet_types[typ].dflt;
+
switch (typ){
-#define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break;
- case aet_object: STORE_TYPED(&u,object,x);
- case aet_ch: STORE_TYPED(&u,char, char_code(x));
- case aet_bit: STORE_TYPED(&u,fixnum, -Mfix(x));
- case aet_fix: STORE_TYPED(&u,fixnum, Mfix(x));
- case aet_sf: STORE_TYPED(&u,shortfloat, Msf(x));
- case aet_lf: STORE_TYPED(&u,longfloat, Mlf(x));
- case aet_char: STORE_TYPED(&u, char, Mfix(x));
- case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x));
- case aet_short: STORE_TYPED(&u, short, Mfix(x));
- case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x));
- default: FEerror("bad elttype",0);
+/* #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break; */
+ case aet_object:
+ /* STORE_TYPED(&u,object,x); */
+ u.o=x;
+ break;
+ case aet_ch:
+ /* STORE_TYPED(&u,char, char_code(x)); */
+ u.c=char_code(x);
+ break;
+ case aet_bit:
+ /* STORE_TYPED(&u,fixnum, -Mfix(x)); */
+ u.i=-Mfix(x);
+ break;
+ case aet_fix:
+ /* STORE_TYPED(&u,fixnum, Mfix(x)); */
+ u.i=Mfix(x);
+ break;
+ case aet_sf:
+ /* STORE_TYPED(&u,shortfloat, Msf(x)); */
+ u.f=Msf(x);
+ break;
+ case aet_lf:
+ /* STORE_TYPED(&u,longfloat, Mlf(x)); */
+ u.d=Mlf(x);
+ break;
+ case aet_char:
+ /* STORE_TYPED(&u, char, Mfix(x)); */
+ u.c=(char)Mfix(x);
+ break;
+ case aet_uchar:
+ /* STORE_TYPED(&u, unsigned char, Mfix(x)); */
+ u.uc=(unsigned char)Mfix(x);
+ break;
+ case aet_short:
+ /* STORE_TYPED(&u, short, Mfix(x)); */
+ u.s=(short)Mfix(x);
+ break;
+ case aet_ushort:
+ /* STORE_TYPED(&u,unsigned short,Mfix(x)); */
+ u.us=(unsigned short)Mfix(x);
+ break;
+ default:
+ FEerror("bad elttype",0);
+ break;
}
return (char *)&u;
}
Index: o/character.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/character.d,v
retrieving revision 1.5
retrieving revision 1.5.4.1
diff -u -r1.5 -r1.5.4.1
--- o/character.d 26 Feb 2003 22:21:37 -0000 1.5
+++ o/character.d 16 Jul 2003 02:02:51 -0000 1.5.4.1
@@ -355,7 +355,7 @@
@(defun char_code (c)
@
check_type_character(&c);
- @(return `small_fixnum(char_code(c))`)
+ @(return `make_fixnum(char_code(c))`)
@)
@(defun char_bits (c)
Index: o/error.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/error.c,v
retrieving revision 1.15
retrieving revision 1.15.4.1
diff -u -r1.15 -r1.15.4.1
--- o/error.c 27 Feb 2003 15:50:59 -0000 1.15
+++ o/error.c 16 Jul 2003 02:02:51 -0000 1.15.4.1
@@ -120,7 +120,7 @@
-static object
+object
Icall_error_handler(object error_name,object error_format_string,int
nfmt_args,...)
{ object b[20];
b[0]= error_name;
@@ -238,6 +238,7 @@
b[3]=null_string;
b[4]=fmt_string;
i=4;
+ n--;
va_start(ap,fmt_string);
while (--n)
b[++i]=va_arg(ap,object);
Index: o/list.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/list.d,v
retrieving revision 1.19
retrieving revision 1.19.4.1
diff -u -r1.19 -r1.19.4.1
--- o/list.d 1 Mar 2003 22:37:37 -0000 1.19
+++ o/list.d 16 Jul 2003 02:02:51 -0000 1.19.4.1
@@ -999,7 +999,7 @@
check_arg(2);
y = vs_pop;
- for (x = vs_base[0]; !endp(x);) {
+ for (x = vs_base[0]; !endp_prop(x);) {
z = x;
x = x->c.c_cdr;
z->c.c_cdr = y;
Index: o/multival.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/multival.c,v
retrieving revision 1.4
retrieving revision 1.4.4.1
diff -u -r1.4 -r1.4.4.1
--- o/multival.c 15 Feb 2003 00:38:28 -0000 1.4
+++ o/multival.c 16 Jul 2003 02:02:51 -0000 1.4.4.1
@@ -43,7 +43,7 @@
check_arg(1);
list = vs_base[0];
vs_top = vs_base;
- while (!endp(list)) {
+ while (!endp_prop(list)) {
vs_push(MMcar(list));
list = MMcdr(list);
}
Index: o/nsocket.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/nsocket.c,v
retrieving revision 1.7
retrieving revision 1.7.4.1
diff -u -r1.7 -r1.7.4.1
--- o/nsocket.c 26 Feb 2003 22:21:37 -0000 1.7
+++ o/nsocket.c 16 Jul 2003 02:02:51 -0000 1.7.4.1
@@ -341,7 +341,7 @@
if (hostEntPtr != (struct hostent *) NULL)
host = make_simple_string(hostEntPtr->h_name);
else host = address;
- return list(3,address,host,small_fixnum(ntohs(peername.sin_port)));
+ return list(3,address,host,make_fixnum(ntohs(peername.sin_port)));
} else {
return Cnil;
}
@@ -364,7 +364,7 @@
if (hostEntPtr != (struct hostent *) NULL)
host = make_simple_string(hostEntPtr->h_name);
else host=address;
- return list(3,address,host,small_fixnum(ntohs(sockname.sin_port)));
+ return list(3,address,host,make_fixnum(ntohs(sockname.sin_port)));
} else {
return Cnil;
}
Index: o/num_co.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/num_co.c,v
retrieving revision 1.10
retrieving revision 1.10.4.1
diff -u -r1.10 -r1.10.4.1
--- o/num_co.c 15 Feb 2003 00:38:28 -0000 1.10
+++ o/num_co.c 16 Jul 2003 02:02:51 -0000 1.10.4.1
@@ -98,6 +98,7 @@
integer_decode_double(double d, int *hp, int *lp, int *ep, int *sp)
{
int h, l;
+ union {double d;int i[2];} u;
if (d == 0.0) {
*hp = *lp = 0;
@@ -109,8 +110,11 @@
#else
- h = *((int *)(&d) + HIND);
- l = *((int *)(&d) + LIND);
+ u.d=d;
+ h=u.i[HIND];
+ l=u.i[LIND];
+/* h = *((int *)(&d) + HIND); */
+/* l = *((int *)(&d) + LIND); */
#endif
#ifdef VAX
*ep = ((h >> 7) & 0xff) - 128 - 56;
@@ -187,6 +191,7 @@
{
float f;
int m;
+ union {float f;int i;} u;
f = d;
if (f == 0.0) {
@@ -195,7 +200,9 @@
*sp = 1;
return;
}
- m = *(int *)(&f);
+ u.f=f;
+ m=u.i;
+/* m = *(int *)(&f); */
#ifdef VAX
*ep = ((m >> 7) & 0xff) - 128 - 24;
*mp = ((m >> 16) & 0xffff) | (((m & 0x7f) | 0x80) << 16);
@@ -227,6 +234,8 @@
static int
double_exponent(double d)
{
+ union {double d;int i[2];} u;
+
if (d == 0.0)
return(0);
#ifdef VAX
@@ -239,7 +248,8 @@
#ifdef NS32K
#else
- return ((((*((int *)(&d) + HIND)) & 0x7ff00000) >> 20) - 1022);
+ u.d=d;
+ return (((u.i[HIND] & 0x7ff00000) >> 20) - 1022);
#endif
#endif
#ifdef MV
@@ -254,11 +264,13 @@
set_exponent(double d, int e)
{
double dummy;
+ union {double d;int i[2];} u;
if (d == 0.0)
return(0.0);
- *((int *)(&d) + HIND)
+ u.d=d;
+ u.i[HIND]
#ifdef VAX
= *(int *)(&d) & 0xffff807f | ((e + 128) << 7) & 0x7f80;
#endif
@@ -269,7 +281,7 @@
#ifdef NS32K
#else
- = (*((int *)(&d) + HIND) & 0x800fffff) | (((e + 1022) << 20) &
0x7ff00000);
+ = (u.i[HIND] & 0x800fffff) | (((e + 1022) << 20) & 0x7ff00000);
#endif
#endif
#ifdef MV
@@ -1215,6 +1227,8 @@
double smallest_double, smallest_norm_double, biggest_double;
float float_epsilon, float_negative_epsilon;
double double_epsilon, double_negative_epsilon;
+ union {double d;int i[2];} u;
+ union {float f;int i;} uf;
#ifdef VAX
@@ -1232,10 +1246,15 @@
#else
-
- ((int *) &smallest_float)[0]= 1;
- ((int *) &smallest_double)[HIND] = 0;
- ((int *) &smallest_double)[LIND] = 1;
+ uf.i=1;
+ u.i[HIND]=0;
+ u.i[LIND]=1;
+ smallest_float=uf.f;
+ smallest_double=u.d;
+
+/* ((int *) &smallest_float)[0]= 1; */
+/* ((int *) &smallest_double)[HIND] = 0; */
+/* ((int *) &smallest_double)[LIND] = 1; */
#endif
#endif
@@ -1277,9 +1296,16 @@
#else
- ((int *) &biggest_float)[0]= 0x7f7fffff;
- ((int *) &biggest_double)[HIND] = 0x7fefffff;
- ((int *) &biggest_double)[LIND] = 0xffffffff;
+ uf.i=0x7f7fffff;
+ u.i[HIND]=0x7fefffff;
+ u.i[LIND]=0xffffffff;
+
+ biggest_float=uf.f;
+ biggest_double=u.d;
+
+/* ((int *) &biggest_float)[0]= 0x7f7fffff; */
+/* ((int *) &biggest_double)[HIND] = 0x7fefffff; */
+/* ((int *) &biggest_double)[LIND] = 0xffffffff; */
#ifdef BAD_FPCHIP
/* &&&& I am adding junk values to get past debugging */
Index: o/num_log.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/num_log.c,v
retrieving revision 1.9
retrieving revision 1.9.4.1
diff -u -r1.9 -r1.9.4.1
--- o/num_log.c 17 Feb 2003 16:50:21 -0000 1.9
+++ o/num_log.c 16 Jul 2003 02:02:51 -0000 1.9.4.1
@@ -685,8 +685,9 @@
for (b1=b,i=0;i<x->a.a_rank;i++,b1=b1->c.c_cdr) {
b1->d.t=(int)t_cons;
b1->d.m=FALSE;
- b1->c.c_car=x->a.a_dims[i]<SMALL_FIXNUM_LIMIT ?
- small_fixnum(x->a.a_dims[i]) :
+ b1->c.c_car=/* x->a.a_dims[i]<SMALL_FIXNUM_LIMIT ? */
+ /* small_fixnum(x->a.a_dims[i]) : */
+ /* now done in a macro */
make_fixnum(x->a.a_dims[i]);
b1->c.c_cdr=i<x->a.a_rank-1 ? (object)++p : Cnil;
}
Index: o/number.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/number.c,v
retrieving revision 1.9
retrieving revision 1.9.4.1
diff -u -r1.9 -r1.9.4.1
--- o/number.c 1 Mar 2003 22:37:37 -0000 1.9
+++ o/number.c 16 Jul 2003 02:02:51 -0000 1.9.4.1
@@ -47,6 +47,13 @@
FEerror("~S is not a non-negative fixnum.", 1, x);
return(fix(x));
}
+#if 0
+object small_fixnum ( int i ) {
+#include <assert.h>
+ assert ( ( -SMALL_FIXNUM_LIMIT <= i ) && ( i < SMALL_FIXNUM_LIMIT ) );
+ (object) small_fixnum_table + SMALL_FIXNUM_LIMIT + i;
+}
+#endif
#define BIGGER_FIXNUM_RANGE
Index: o/read.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/read.d,v
retrieving revision 1.14
retrieving revision 1.14.4.1
diff -u -r1.14 -r1.14.4.1
--- o/read.d 26 Feb 2003 22:21:37 -0000 1.14
+++ o/read.d 16 Jul 2003 02:02:51 -0000 1.14.4.1
@@ -2742,7 +2742,7 @@
object in;
{
int dimcount, dim;
- object *vsp;
+ object *vsp,vspo;
VOL object x;
int i;
bool e;
@@ -2755,7 +2755,7 @@
old_sharp_eq_context[SHARP_EQ_CONTEXT_SIZE];
int old_backq_level;
- vsp=(object *)&vsp;
+ vsp=&vspo;
old_READtable = READtable;
old_READdefault_float_format = READdefault_float_format;
old_READbase = READbase;
Index: o/sequence.d
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sequence.d,v
retrieving revision 1.3
retrieving revision 1.3.4.1
diff -u -r1.3 -r1.3.4.1
--- o/sequence.d 15 Oct 2002 19:32:01 -0000 1.3
+++ o/sequence.d 16 Jul 2003 02:02:51 -0000 1.3.4.1
@@ -123,7 +123,9 @@
E:
vs_push(make_fixnum(index));
/* FIXME message should indicate out of range */
- FEwrong_type_argument(sLpositive_fixnum,vs_head);
+ Icall_error_handler(sKwrong_type_argument,
+ make_simple_string("The index, ~S, is too large."),
+ 1,vs_head);
return(Cnil);
}
@@ -257,7 +259,7 @@
case aet_short:
case aet_ushort:
for (i = s, j = 0; i < e; i++, j++)
- USHORT(x, j) = USHORT(sequence, i);
+ USHORT_GCL(x, j) = USHORT_GCL(sequence, i);
break;
case aet_char:
case aet_uchar:
@@ -414,7 +416,7 @@
case aet_short:
case aet_ushort:
for (j = k - 1, i = 0; j >=0; --j, i++)
- USHORT(y, j) = USHORT(x, i);
+ USHORT_GCL(y, j) = USHORT_GCL(x, i);
break;
case aet_char:
case aet_uchar:
@@ -517,9 +519,9 @@
case aet_ushort:
for (i = 0, j = k - 1; i < j; i++, --j) {
unsigned short y;
- y = USHORT(x, i);
- USHORT(x, i) = USHORT(x, j);
- USHORT(x, y) = y;
+ y = USHORT_GCL(x, i);
+ USHORT_GCL(x, i) = USHORT_GCL(x, j);
+ USHORT_GCL(x, y) = y;
}
return(seq);
case aet_char:
Index: o/sockets.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/sockets.c,v
retrieving revision 1.8
retrieving revision 1.8.4.1
diff -u -r1.8 -r1.8.4.1
--- o/sockets.c 1 Mar 2003 22:37:37 -0000 1.8
+++ o/sockets.c 16 Jul 2003 02:02:51 -0000 1.8.4.1
@@ -105,8 +105,14 @@
"Open a socket on PORT and return (cons fd portname) where file \
descriptor is a small fixnum which is the write file descriptor for \
the socket. If PORT is zero do automatic allocation of port")
-{ int s, n, rc; struct
-sockaddr_in addr;
+{
+#ifdef __MINGW32__
+ SOCKET s;
+#else
+ int s;
+#endif
+ int n, rc;
+ struct sockaddr_in addr;
#ifdef __MINGW32__
if ( w32_socket_init() < 0 ) {
@@ -117,7 +123,11 @@
/* Using TCP layer */
s = socket(PF_INET, SOCK_STREAM, 0);
+#ifdef __MINGW32__
+ if ( s == INVALID_SOCKET )
+#else
if (s < 0)
+#endif
{
perror("ERROR !!! socket creation failed in sock_connect_to_name\n");
return Cnil;
@@ -175,7 +185,7 @@
return Cnil;
}
- return make_cons(make_fixnum(s), small_fixnum(ntohs(addr.sin_port)));
+ return make_cons(make_fixnum(s), make_fixnum(ntohs(addr.sin_port)));
}
DEFUN_NEW("CLOSE-FD",object,fSclose_fd,SI,1,1,NONE,OI,OO,OO,OO,(fixnum fd),
Index: o/structure.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/structure.c,v
retrieving revision 1.9
retrieving revision 1.9.4.1
diff -u -r1.9 -r1.9.4.1
--- o/structure.c 27 Feb 2003 17:47:05 -0000 1.9
+++ o/structure.c 16 Jul 2003 02:02:51 -0000 1.9.4.1
@@ -75,7 +75,7 @@
case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
case aet_uchar: return(small_fixnum(STREF(unsigned char,x,s_pos[i])));
- case aet_ushort: return(small_fixnum(STREF(unsigned short,x,s_pos[i])));
+ case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
default:
bad_raw_type();
Index: o/usig2.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/usig2.c,v
retrieving revision 1.11
retrieving revision 1.11.4.1
diff -u -r1.11 -r1.11.4.1
--- o/usig2.c 1 Mar 2003 22:37:37 -0000 1.11
+++ o/usig2.c 16 Jul 2003 02:02:51 -0000 1.11.4.1
@@ -253,8 +253,10 @@
SS1(p->ihs_topVAL,*ihs_top);
{ void **pp = p->save_objects;
#undef XS
- /* #define XS(a) *pp++ = (void *) (a); */
-#define XS(a) *pp++ = * (void **) (&a);
+#undef XSI
+#define XS(a) *pp++ = (void *) (a);
+#define XSI(a) XS(a)
+/* #define XS(a) *pp++ = * (void **) (&a); */
#include "usig2_aux.c"
if ((pp - (&(p->save_objects)[0])) >= (sizeof(p->save_objects)/sizeof(void
*)))
abort();
@@ -309,12 +311,15 @@
RS1(p->ihs_topVAL,*ihs_top);
{ void **pp = p->save_objects;
#undef XS
+#undef XSI
/* #define XS(a) a = (void *)(*pp++)
We store back in the location 'a' the value we have saved.
*/
-#define XS(a) do { void **_p = (void **)(&a); *_p = (void *)(*pp++);}while(0)
+/* #define XS(a) do { void **_p = (void **)(&a); *_p = (void
*)(*pp++);}while(0) */
+#define XS(a) a = (void *)(*pp++)
+#define XSI(a) {union {void *v;long l;}u; u.v=*pp++; a = u.l;}
#include "usig2_aux.c"
}
Index: o/usig2_aux.c
===================================================================
RCS file: /cvsroot/gcl/gcl/o/usig2_aux.c,v
retrieving revision 1.3
retrieving revision 1.3.4.1
diff -u -r1.3 -r1.3.4.1
--- o/usig2_aux.c 15 Feb 2003 00:38:28 -0000 1.3
+++ o/usig2_aux.c 16 Jul 2003 02:02:51 -0000 1.3.4.1
@@ -1,58 +1,58 @@
-XS(string_register->st.st_fillp);
-XS(string_register->st.st_fillp);
-XS(string_register->st.st_dim);
+XSI(string_register->st.st_fillp);
+XSI(string_register->st.st_fillp);
+XSI(string_register->st.st_dim);
XS(string_register->st.st_self);
-XS(token->st.st_fillp);
-XS(in_signal_handler);
-XS(nlj_active);
+XSI(token->st.st_fillp);
+XSI(in_signal_handler);
+XSI(nlj_active);
XS(nlj_fr);
XS(nlj_tag);
XS(CMPtemp);
XS(CMPtemp1);
XS(CMPtemp2);
XS(CMPtemp3);
-XS(FIXtemp);
-XS(PRINTarray);
-XS(PRINTbase);
+XSI(FIXtemp);
+XSI(PRINTarray);
+XSI(PRINTbase);
XS(PRINTcase);
-XS(PRINTcircle);
-XS(PRINTescape);
-XS(PRINTgensym);
-XS(PRINTlength);
-XS(PRINTlevel);
-XS(PRINTpackage);
-XS(PRINTpretty);
-XS(PRINTradix);
+XSI(PRINTcircle);
+XSI(PRINTescape);
+XSI(PRINTgensym);
+XSI(PRINTlength);
+XSI(PRINTlevel);
+XSI(PRINTpackage);
+XSI(PRINTpretty);
+XSI(PRINTradix);
XS(PRINTstream);
-XS(PRINTstructure);
+XSI(PRINTstructure);
XS(PRINTvs_limit);
XS(PRINTvs_top);
-XS(READbase);
-XS(READdefault_float_format);
-XS(READsuppress);
+XSI(READbase);
+XSI(READdefault_float_format);
+XSI(READsuppress);
XS(READtable);
-XS(ctl_end);
-XS(ctl_index);
-XS(ctl_origin);
+XSI(ctl_end);
+XSI(ctl_index);
+XSI(ctl_origin);
XS(endp_temp);
-XS(eval1);
-XS(line_length);
-XS(in_list_flag);
+XSI(eval1);
+XSI(line_length);
+XSI(in_list_flag);
XS(kf);
XS(tf);
-XS(left_trim);
-XS(right_trim);
+XSI(left_trim);
+XSI(right_trim);
XS(lex_env);
XS(key_function);
XS(test_function);
XS(item_compared);
-XS(intern_flag);
+XSI(intern_flag);
XS(printStructBufp);
XS(sfaslp);
-XS(preserving_whitespace_flag);
+XSI(preserving_whitespace_flag);
XS(sharing_table);
-XS(string_sign);
-XS(string_boundary);
+XSI(string_sign);
+XSI(string_boundary);
XS(car_or_cdr);
XS(casefun);
XS(tmp_alloc);
Index: lsp/predlib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/predlib.lsp,v
retrieving revision 1.10
retrieving revision 1.10.4.1
diff -u -r1.10 -r1.10.4.1
--- lsp/predlib.lsp 26 Feb 2003 12:44:50 -0000 1.10
+++ lsp/predlib.lsp 16 Jul 2003 02:02:50 -0000 1.10.4.1
@@ -149,7 +149,8 @@
;;; TYPEP predicate.
;;; FIXME --optimize with most likely cases first
-(defun typep (object type &aux tp i tem)
+(defun typep (object type &optional env &aux tp i tem)
+ (declare (ignore env))
(when (classp type)
(return-from typep (if (member type (class-precedence-list (funcall
'class-of object))) t nil)))
(if (atom type)
@@ -297,7 +298,8 @@
;;; SUBTYPEP predicate.
-(defun subtypep (type1 type2 &aux t1 t2 i1 i2 ntp1 ntp2 tem)
+(defun subtypep (type1 type2 &optional env &aux t1 t2 i1 i2 ntp1 ntp2 tem)
+ (declare (ignore env))
(let ((c1 (classp type1)) (c2 (classp type2)))
(when (and c1 c2)
(return-from subtypep
Index: cmpnew/cmpcall.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/cmpcall.lsp,v
retrieving revision 1.5
retrieving revision 1.5.4.1
diff -u -r1.5 -r1.5.4.1
--- cmpnew/cmpcall.lsp 26 Feb 2003 22:21:35 -0000 1.5
+++ cmpnew/cmpcall.lsp 16 Jul 2003 02:02:47 -0000 1.5.4.1
@@ -408,11 +408,11 @@
(cond
((null type)
(wt-nl1 "static void LnkT"
- num "(){ call_or_link(VV[" num "],(void **)&Lnk" num");}"
+ num "(){ call_or_link(VV[" num "],(void **)(void *)&Lnk" num");}"
))
((eql type 'proclaimed-closure)
(wt-nl1 "static void LnkT" num
- "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void
**)&Lnk" num",(void **)&Lclptr" num");}"))
+ "(ptr) object *ptr;{ call_or_link_closure(VV[" num "],(void
**)(void *)&Lnk" num",(void **)(void *)&Lclptr" num");}"))
(t
;;change later to include above.
;;(setq type (cdr (assoc type '((t . "object")(:btpr . "bptr")))))
@@ -423,11 +423,11 @@
(declaration-type (rep-type type)) "V1;"
"va_list ap;va_start(ap,first);V1=call_"
(if vararg "v" "") "proc_new(VV["
- (add-object name)"],(void **)&Lnk" num )
+ (add-object name)"],(void **)(void *)&Lnk" num )
(or vararg (wt "," (proclaimed-argd args type)))
(wt ",first,ap);va_end(ap);return V1;}" )))
(t (wt "(){return call_proc0(VV[" (add-object name)
- "],(void **)&Lnk" num ");}" ))))
+ "],(void **)(void *)&Lnk" num ");}" ))))
(t (error "unknown link type ~a" type)))
(setq name (symbol-name name))
(if (find #\/ name) (setq name (remove #\/ name)))
Index: cmpnew/cmptop.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/cmptop.lsp,v
retrieving revision 1.7
retrieving revision 1.7.4.1
diff -u -r1.7 -r1.7.4.1
--- cmpnew/cmptop.lsp 26 Feb 2003 22:21:35 -0000 1.7
+++ cmpnew/cmptop.lsp 16 Jul 2003 02:02:48 -0000 1.7.4.1
@@ -109,6 +109,7 @@
(si:putprop 'import t 'package-operation)
(si:putprop 'provide t 'package-operation)
(si:putprop 'require t 'package-operation)
+(si:putprop 'defpackage:defpackage t 'package-operation)
;;; Pass 1 top-levels.
@@ -193,8 +194,11 @@
(when *non-package-operation*
(cmpwarn "The package operation ~s was in a bad place."
form))
- (maybe-eval t form)
- (wt-data-package-operation form))
+ (let ((res (if (setq fd (macro-function fun))
+ (cmp-expand-macro fd fun (copy-list (cdr
form)))
+ form)))
+ (maybe-eval t res)
+ (wt-data-package-operation res)))
((setq fd (get fun 't1))
(when *compile-print* (print-current-form))
(funcall fd args))
@@ -1012,7 +1016,7 @@
(t (wt-nl "parse_key_new_new(")))
(if (eql 0 *cs*)(setq *cs* 1))
(wt "narg," (if *vararg-use-vs* "base " "Vcs ")
- "+" key-offset",(struct key *)&LI" cfun "key,first,ap);")
+ "+" key-offset",(struct key *)(void *)&LI" cfun "key,first,ap);")
))
Index: clcs/clcs_conditions.lisp
===================================================================
RCS file: /cvsroot/gcl/gcl/clcs/clcs_conditions.lisp,v
retrieving revision 1.1
retrieving revision 1.1.4.1
diff -u -r1.1 -r1.1.4.1
--- clcs/clcs_conditions.lisp 26 Feb 2003 22:21:34 -0000 1.1
+++ clcs/clcs_conditions.lisp 16 Jul 2003 02:02:46 -0000 1.1.4.1
@@ -149,6 +149,8 @@
)
(DEFMACRO DEFINE-CONDITION (NAME PARENT-LIST SLOT-SPECS &REST OPTIONS)
+ (unless (or parent-list (eq name 'condition))
+ (setq parent-list (list 'condition)))
(let* ((REPORT-FUNCTION nil)
(DOCUMENTATION nil))
(DO ((O OPTIONS (CDR O)))
=============================================================================
--
Camm Maguire address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
Re: [Gcl-devel] RE: [Gcl-commits] CVSROOT: /cvsroot/gcl, Camm Maguire, 2003/07/17