2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
4
This file is part of GNU Common Lisp, herein referred to as GCL
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
27
Some system constants.
30
#define TRUE 1 /* boolean true value */
31
#define FALSE 0 /* boolean false value */
33
#define FIRSTWORD unsigned char t,flag; char s,m
35
#define NBPP 4 /* number of bytes per pointer */
38
#define PAGEWIDTH 11 /* page width */
42
#define PAGESIZE (1 << PAGEWIDTH) /* page size in bytes */
45
#define CHCODELIM 256 /* character code limit */
46
/* ASCII character set */
47
#define CHFONTLIM 1 /* character font limit */
48
#define CHBITSLIM 1 /* character bits limit */
49
#define CHCODEFLEN 8 /* character code field length */
50
#define CHFONTFLEN 0 /* character font field length */
51
#define CHBITSFLEN 0 /* character bits field length */
53
#define PHTABSIZE 512 /* number of entries */
54
/* in the package hash table */
56
#define ARANKLIM 64 /* array rank limit */
58
#define RTABSIZE CHCODELIM
61
#define CBMINSIZE 64 /* contiguous block minimal size */
64
#define CHAR_SIZE 8 /* number of bits in a char */
70
typedef unsigned long ufixnum;
71
typedef float shortfloat;
72
typedef double longfloat;
73
typedef unsigned short fatchar;
80
#define SIGNED_CHAR(x) (((char ) -1) < (char )0 ? (char) x \
81
: (x >= (1<<(CHAR_SIZE-1)) ? \
82
x - (((int)(1<<(CHAR_SIZE-1))) << 1) \
87
Definition of the type of LISP objects.
89
typedef union lispunion *object;
91
typedef union int_object iobject;
92
union int_object {object o; int i;};
96
It should not coincide with any legal object value.
98
#define OBJNULL ((object)NULL)
101
Definition of each implementation type.
104
struct fixnum_struct {
106
fixnum FIXVAL; /* fixnum value */
108
#define Mfix(obje) (obje)->FIX.FIXVAL
109
#define fix(x) Mfix(x)
111
#define SMALL_FIXNUM_LIMIT 1024
114
struct fixnum_struct small_fixnum_table[2*SMALL_FIXNUM_LIMIT];
116
#define small_fixnum(i) \
117
(object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i))
119
struct shortfloat_struct {
121
shortfloat SFVAL; /* shortfloat value */
123
#define Msf(obje) (obje)->SF.SFVAL
126
struct longfloat_struct {
128
longfloat LFVAL; /* longfloat value */
130
#define Mlf(obje) (obje)->LF.LFVAL
140
/* int _mp_alloc; Number of *limbs* allocated and pointed */
141
/* to by the _mp_d field. */
142
/* int _mp_size; abs(_mp_size) is the number of limbs the */
143
/* last field points to. If _mp_size is */
144
/* negative this is a negative number. */
145
/* void *_mp_d; Pointer to the limbs. */
146
/* } our_mpz_struct; */
152
__mpz_struct big_mpz_t;
154
plong *big_self; /* bignum body */
155
int big_length; /* bignum length */
161
object rat_den; /* denominator */
162
/* must be an integer */
163
object rat_num; /* numerator */
164
/* must be an integer */
169
object cmp_real; /* real part */
170
/* must be a number */
171
object cmp_imag; /* imaginary part */
172
/* must be a number */
177
unsigned short ch_code; /* code */
178
unsigned char ch_font; /* font */
179
unsigned char ch_bits; /* bits */
185
struct character character_table1[256+128];
186
#define character_table (character_table1+128)
187
#define code_char(c) (object)(character_table+(c))
188
#define char_code(obje) (obje)->ch.ch_code
189
#define char_font(obje) (obje)->ch.ch_font
190
#define char_bits(obje) (obje)->ch.ch_bits
192
enum stype { /* symbol type */
193
stp_ordinary, /* ordinary */
194
stp_constant, /* constant */
195
stp_special /* special */
198
#define Cnil ((object)&Cnil_body)
199
#define Ct ((object)&Ct_body)
203
#define NOT_SPECIAL ((void (*)())Cnil)
204
#define s_fillp st_fillp
205
#define s_self st_self
209
object s_dbind; /* dynamic binding */
210
void (*s_sfdef)(); /* special form definition */
211
/* This field coincides with c_car */
212
char *s_self; /* print name */
213
/* These fields coincide with */
214
/* st_fillp and st_self. */
215
int s_fillp; /* print name length */
217
object s_gfdef; /* global function definition */
219
/* its expansion function */
220
/* is to be stored. */
221
object s_plist; /* property list */
222
object s_hpack; /* home package */
223
/* Cnil for uninterned symbols */
224
short s_stype; /* symbol type */
226
short s_mflag; /* macro flag */
229
struct symbol Cnil_body, Ct_body;
233
object p_name; /* package name */
235
object p_nicknames; /* nicknames */
236
/* list of strings */
237
object p_shadowings; /* shadowing symbol list */
238
object p_uselist; /* use-list of packages */
239
object p_usedbylist; /* used-by-list of packages */
240
object *p_internal; /* hashtable for internal symbols */
241
object *p_external; /* hashtable for external symbols */
242
int p_internal_size; /* size of internal hash table*/
243
int p_external_size; /* size of external hash table */
244
int p_internal_fp; /* [rough] number of symbols */
245
int p_external_fp; /* [rough] number of symbols */
247
*p_link; /* package link */
251
The values returned by intern and find_symbol.
252
File_symbol may return 0.
259
All the packages are linked through p_link.
261
EXTER struct package *pack_pointer; /* package pointer */
265
object c_cdr; /* cdr */
266
object c_car; /* car */
269
enum httest { /* hash table key test function */
272
htt_equal /* equal */
275
struct htent { /* hash table entry */
276
object hte_key; /* key */
277
object hte_value; /* value */
280
struct hashtable { /* hash table header */
283
*ht_self; /* pointer to the hash table */
284
object ht_rhsize; /* rehash size */
285
object ht_rhthresh; /* rehash threshold */
286
int ht_nent; /* number of entries */
287
int ht_size; /* hash table size */
288
short ht_test; /* key test function */
292
enum aelttype { /* array element type */
294
aet_ch, /* string-char */
296
aet_fix, /* fixnum */
297
aet_sf, /* short-float */
298
aet_lf, /* plong-float */
299
aet_char, /* signed char */
300
aet_uchar, /* unsigned char */
301
aet_short, /* signed short */
302
aet_ushort, /* unsigned short */
306
struct array { /* array header */
308
object a_displaced; /* displaced */
309
short a_rank; /* array rank */
310
short a_elttype; /* element type */
311
object *a_self; /* pointer to the array */
312
short a_adjustable; /* adjustable flag */
313
short a_offset; /* bitvector offset */
314
int a_dim; /* dimension */
315
int *a_dims; /* table of dimensions */
321
struct vector { /* vector header */
323
object v_displaced; /* displaced */
324
short v_hasfillp; /* has-fill-pointer flag */
325
short v_elttype; /* element type */
327
object *v_self; /* pointer to the vector */
328
int v_fillp; /* fill pointer */
329
/* For simple vectors, */
330
/* v_fillp is equal to v_dim. */
331
int v_dim; /* dimension */
332
short v_adjustable; /* adjustable flag */
333
short v_offset; /* not used */
336
struct string { /* string header */
338
object st_displaced; /* displaced */
339
short st_hasfillp; /* has-fill-pointer flag */
340
short st_adjustable; /* adjustable flag */
341
char *st_self; /* pointer to the string */
342
int st_fillp; /* fill pointer */
343
/* For simple strings, */
344
/* st_fillp is equal to st_dim. */
345
int st_dim; /* dimension */
352
object ust_displaced;
354
short ust_adjustable;
355
unsigned char *ust_self;
363
#define USHORT_GCL(x,i) (((unsigned short *)(x)->ust.ust_self)[i])
364
#define SHORT_GCL(x,i) ((( short *)(x)->ust.ust_self)[i])
366
#define BV_OFFSET(x) ((type_of(x)==t_bitvector ? x->bv.bv_offset : \
367
type_of(x)== t_array ? x->a.a_offset : (abort(),0)))
369
#define SET_BV_OFFSET(x,val) ((type_of(x)==t_bitvector ? x->bv.bv_offset = val : \
370
type_of(x)== t_array ? x->a.a_offset=val : (abort(),0)))
375
struct bitvector { /* bitvector header */
377
object bv_displaced; /* displaced */
378
short bv_hasfillp; /* has-fill-pointer flag */
379
short bv_elttype; /* not used */
380
char *bv_self; /* pointer to the bitvector */
381
int bv_fillp; /* fill pointer */
382
/* For simple bitvectors, */
383
/* st_fillp is equal to st_dim. */
384
int bv_dim; /* dimension */
386
short bv_adjustable; /* adjustable flag */
387
short bv_offset; /* bitvector offset */
388
/* the position of the first bit */
389
/* in the first byte */
392
struct fixarray { /* fixnum array header */
394
object fixa_displaced; /* displaced */
395
short fixa_rank; /* array rank */
396
short fixa_elttype; /* element type */
397
fixnum *fixa_self; /* pointer to the array */
398
short fixa_adjustable;/* adjustable flag */
399
short fixa_offset; /* not used */
400
int fixa_dim; /* dimension */
401
int *fixa_dims; /* table of dimensions */
405
struct sfarray { /* short-float array header */
407
object sfa_displaced; /* displaced */
408
short sfa_rank; /* array rank */
409
short sfa_elttype; /* element type */
411
*sfa_self; /* pointer to the array */
412
short sfa_adjustable; /* adjustable flag */
413
short sfa_offset; /* not used */
414
int sfa_dim; /* dimension */
416
int *sfa_dims; /* table of dimensions */
422
struct lfarray { /* plong-float array header */
424
object lfa_displaced; /* displaced */
425
short lfa_rank; /* array rank */
426
short lfa_elttype; /* element type */
428
*lfa_self; /* pointer to the array */
429
short lfa_adjustable; /* adjustable flag */
430
short lfa_offset; /* not used */
431
int lfa_dim; /* dimension */
432
int *lfa_dims; /* table of dimensions */
437
struct structure { /* structure header */
439
object str_def; /* structure definition (a structure) */
440
object *str_self; /* structure self */
443
struct s_data {object name;
449
object print_function;
450
object slot_descriptions;
451
object slot_position;
456
#define S_DATA(x) ((struct s_data *)((x)->str.str_self))
457
#define SLOT_TYPE(def,i) (((S_DATA(def))->raw->ust.ust_self[i]))
458
#define SLOT_POS(def,i) USHORT_GCL(S_DATA(def)->slot_position,i)
459
#define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i))))
463
enum smmode { /* stream mode */
464
smm_input, /* input */
465
smm_output, /* output */
466
smm_io, /* input-output */
467
smm_probe, /* probe */
468
smm_synonym, /* synonym */
469
smm_broadcast, /* broadcast */
470
smm_concatenated, /* concatenated */
471
smm_two_way, /* two way */
473
smm_string_input, /* string input */
474
smm_string_output, /* string output */
475
smm_user_defined, /* for user defined */
476
smm_socket /* Socket stream */
479
/* for any stream that takes writec_char, directly (not two_way or echo)
480
ie. smm_output,smm_io, smm_string_output, smm_socket
482
#define STREAM_FILE_COLUMN(str) ((str)->sm.sm_int1)
485
#define ECHO_STREAM_N_UNREAD(strm) ((strm)->sm.sm_int0)
487
/* file fd for socket */
488
#define SOCKET_STREAM_FD(strm) ((strm)->sm.sm_fd)
489
#define SOCKET_STREAM_BUFFER(strm) ((strm)->sm.sm_object1)
491
/* for smm_string_input */
492
#define STRING_INPUT_STREAM_NEXT(strm) ((strm)->sm.sm_int0)
493
#define STRING_INPUT_STREAM_END(strm) ((strm)->sm.sm_int1)
495
/* for smm_two_way and smm_echo */
496
#define STREAM_OUTPUT_STREAM(strm) ((strm)->sm.sm_object1)
497
#define STREAM_INPUT_STREAM(strm) ((strm)->sm.sm_object0)
499
/* for smm_string_{input,output} */
500
#define STRING_STREAM_STRING(strm) ((strm)->sm.sm_object0)
504
FILE *sm_fp; /* file pointer */
505
object sm_object0; /* some object */
506
object sm_object1; /* some object */
507
int sm_int0; /* some int */
508
int sm_int1; /* column for input or output, stream */
509
char *sm_buffer; /* ptr to BUFSIZE block of storage */
510
char sm_mode; /* stream mode */
511
unsigned char sm_flags; /* flags from gcl_sm_flags */
512
short sm_fd; /* stream fd */
516
#define GET_STREAM_FLAG(strm,name) ((strm)->sm.sm_flags & (1<<(name)))
517
#define SET_STREAM_FLAG(strm,name,val) (val ? \
518
((strm)->sm.sm_flags |= (1<<(name))) : \
519
((strm)->sm.sm_flags &= ~(1<<(name))))
521
#define GCL_MODE_BLOCKING 1
522
#define GCL_MODE_NON_BLOCKING 0
523
#define GCL_TCP_ASYNC 1
537
#define BASEFF (unsigned char *)0xffffffff
539
#define BASEFF (char *)0xffffffff
544
#define BASEFF (unsigned char *)0xffffffff
548
#define BASEFF (unsigned char *)0xffffffff
558
unsigned rnd_value; /* random state value */
561
enum chattrib { /* character attribute */
562
cat_whitespace, /* whitespace */
563
cat_terminating, /* terminating macro */
564
cat_non_terminating, /* non-terminating macro */
565
cat_single_escape, /* single-escape */
566
cat_multiple_escape, /* multiple-escape */
567
cat_constituent /* constituent */
570
struct rtent { /* read table entry */
571
enum chattrib rte_chattrib; /* character attribute */
572
object rte_macro; /* macro function */
573
object *rte_dtab; /* pointer to the */
576
/* non-dispatching */
577
/* macro character, or */
578
/* non-macro character */
581
struct readtable { /* read table */
583
struct rtent *rt_self; /* read table itself */
588
object pn_host; /* host */
589
object pn_device; /* device */
590
object pn_directory; /* directory */
591
object pn_name; /* name */
592
object pn_type; /* type */
593
object pn_version; /* version */
596
struct cfun { /* compiled function header */
598
object cf_name; /* compiled function name */
599
void (*cf_self)(); /* entry address */
600
object cf_data; /* data the function uses */
604
struct cclosure { /* compiled closure header */
606
object cc_name; /* compiled closure name */
607
void (*cc_self)(); /* entry address */
608
object cc_env; /* environment */
609
object cc_data; /* data the closure uses */
612
object *cc_turbo; /* turbo charger */
617
object cl_name; /* name */
618
object (*cl_self)(); /* C start address of code */
619
object cl_data; /* To object holding VV vector */
620
int cl_argd; /* description of args + number */
621
int cl_envdim; /* length of the environment vector */
622
object *cl_env; /* environment vector referenced by cl_self()*/
627
object sfn_name; /* name */
628
object (*sfn_self)(); /* C start address of code */
629
object sfn_data; /* To object holding VV vector */
630
int sfn_argd; /* description of args + number */
636
object vfn_name; /* name */
637
object (*vfn_self)(); /* C start address of code */
638
object vfn_data; /* To object holding VV data */
639
unsigned short vfn_minargs; /* Min args and where varargs start */
640
unsigned short vfn_maxargs; /* Max number of args */
644
char *cfd_start; /* beginning of contblock for fun */
645
int cfd_size; /* size of contblock */
646
int cfd_fillp; /* size of self */
647
object *cfd_self; /* body */
663
Definition of lispunion.
668
struct bignum big; /* bignum */
669
struct ratio rat; /* ratio */
670
struct shortfloat_struct
671
SF; /* short floating-point number */
672
struct longfloat_struct
673
LF; /* plong floating-point number */
674
struct complex cmp; /* complex number */
677
struct symbol s; /* symbol */
678
struct package p; /* package */
679
struct cons c; /* cons */
682
struct array a; /* array */
683
struct vector v; /* vector */
684
struct string st; /* string */
690
struct stream sm; /* stream */
691
struct random rnd; /* random-states */
694
struct pathname pn; /* path name */
695
struct cfun cf; /* compiled function uses value stack] */
696
struct cclosure cc; /* compiled closure uses value stack */
697
struct closure cl; /* compiled closure uses c stack */
698
struct sfun sfn; /* simple function */
699
struct vfun vfn; /* function with variable number of args */
700
struct cfdata cfd; /* compiled fun data */
701
struct spice spc; /* spice */
703
struct dummy d; /* dummy */
705
struct fixarray fixa; /* fixnum array */
706
struct sfarray sfa; /* short-float array */
707
struct lfarray lfa; /* plong-float array */
710
#define address_int unsigned long
713
The struct of free lists.
719
#ifndef INT_TO_ADDRESS
720
#define INT_TO_ADDRESS(x) ((object )(long )x)
723
#define F_LINK(x) ((struct freelist *)(long) x)->f_link
724
#define FL_LINK F_LINK
725
#define SET_LINK(x,val) F_LINK(x) = (address_int) (val)
726
#define OBJ_LINK(x) ((object) INT_TO_ADDRESS(F_LINK(x)))
728
#define FREE (-1) /* free object */
733
#define type_of(obje) ((enum type)(((object)(obje))->d.t))
736
Storage manager for each type.
741
short tm_size; /* element size in bytes */
742
short tm_nppage; /* number per page */
743
object tm_free; /* free list */
744
/* Note that it is of type object. */
745
long tm_nfree; /* number of free elements */
746
long tm_nused; /* number of elements used */
747
long tm_npage; /* number of pages */
748
long tm_maxpage; /* maximum number of pages */
749
char *tm_name; /* type name */
750
int tm_gbccount; /* GBC count */
751
object tm_alt_free; /* Alternate free list (swap with tm_free) */
752
long tm_alt_nfree; /* Alternate nfree (length of nfree) */
753
short tm_sgc; /* this type has at least this many
755
short tm_sgc_minfree; /* number free on a page to qualify for
757
short tm_sgc_max; /* max on sgc pages */
758
short tm_min_grow; /* min amount to grow when growing */
759
short tm_max_grow; /* max amount to grow when growing */
760
short tm_growth_percent; /* percent to increase maxpages */
761
short tm_percent_free; /* percent which must be free after a gc for this type */
762
short tm_distinct; /* pages of this type are distinct */
768
The table of type managers.
770
EXTER struct typemanager tm_table[ 32 /* (int) t_relocatable */];
772
#define tm_of(t) (&(tm_table[(int)tm_table[(int)(t)].tm_type]))
775
Contiguous block header.
777
struct contblock { /* contiguous block header */
778
int cb_size; /* size in bytes */
780
*cb_link; /* contiguous block link */
784
The pointer to the contiguous blocks.
786
EXTER struct contblock *cb_pointer; /* contblock pointer */
788
/* SGC cont pages: After SGC_start, old_cb_pointer will be a linked
789
list of free blocks on non-SGC pages, and cb_pointer will be
790
likewise for SGC pages. CM 20030827*/
791
EXTER struct contblock *old_cb_pointer; /* old contblock pointer when in SGC */
793
/* SGC cont pages: FIXME -- at some point, enable runtime disabling of
794
SGC cont pages. Right now, the tm_sgc variable for type contiguous
795
will govern only the possible attempt to get new pages for SGC.
796
Contiguous pages normally allocated when SGC is on will always be
797
marked with SGC_PAGE_FLAG, as the current GBC algorithm always uses
798
sgc_contblock_sweep_phase in this case. */
799
/* #define SGC_CONT_ENABLED (sgc_enabled && tm_table[t_contiguous].tm_sgc) */
800
#define SGC_CONT_ENABLED (sgc_enabled)
803
Variables for memory management.
805
EXTER long ncb; /* number of contblocks */
806
/* int ncbpage; number of contblock pages */
807
#define ncbpage tm_table[t_contiguous].tm_npage
808
#define maxcbpage tm_table[t_contiguous].tm_maxpage
809
#define cbgbccount tm_table[t_contiguous].tm_gbccount
812
/* int maxcbpage; maximum number of contblock pages */
814
long holepage; /* hole pages */
815
#define nrbpage tm_table[t_relocatable].tm_npage
816
#define rbgbccount tm_table[t_relocatable].tm_gbccount
817
/* int nrbpage; number of relblock pages */
821
char *rb_start; /* relblock start */
822
EXTER char *rb_end; /* relblock end */
823
EXTER char *rb_limit; /* relblock limit */
824
EXTER char *rb_pointer; /* relblock pointer */
825
EXTER char *rb_start1; /* relblock start in copy space */
826
EXTER char *rb_pointer1; /* relblock pointer in copy space */
828
EXTER char *heap_end; /* heap end */
829
EXTER char *core_end; /* core end */
833
/* make f allocate enough extra, so that we can round
834
up, the address given to an even multiple. Special
835
case of size == 0 , in which case we just want an aligned
836
number in the address range
839
#define ALLOC_ALIGNED(f, size,align) \
840
(align <= sizeof(plong) ? (char *)((f)(size)) : \
841
(tmp_alloc = (char *)((f)(size+(size ?(align)-1 : 0)))+(align)-1 , \
842
(char *)(align * (((unsigned long)tmp_alloc)/align))))
843
#define AR_ALLOC(f,n,type) (type *) \
844
(ALLOC_ALIGNED(f,(n)*sizeof(type),sizeof(type)))
847
/* FIXME Make all other page constants scale similarly by default. */
849
#define HOLEPAGE (MAXPAGE/10)
853
/* #define INIT_HOLEPAGE 150 */
854
/* #define INIT_NRBPAGE 50 */
855
/* #define RB_GETA 512 */
857
#define INIT_HOLEPAGE (6*HOLEPAGE/5)
858
#define INIT_NRBPAGE (INIT_HOLEPAGE/3)
859
#define RB_GETA (10*INIT_NRBPAGE)
863
#define STATIC register
869
#define TIME_ZONE (-9)
873
/* For IEEEFLOAT, the double may have exponent in the second word
874
(little endian) or first word.*/
876
#if defined(I386) || defined(LITTLE_END)
877
#define HIND 1 /* (int) of double where the exponent and most signif is */
878
#define LIND 0 /* low part of a double */
879
#else /* big endian */
888
#define isUpper(xxx) (((xxx)&0200) == 0 && isupper((int)xxx))
889
#define isLower(xxx) (((xxx)&0200) == 0 && islower((int)xxx))
890
#define isDigit(xxx) (((xxx)&0200) == 0 && isdigit((int)xxx))
891
enum ftype {f_object,f_fixnum};
894
/* ...xx|xx|xxxx|xxxx|
897
/* a9a8a7a6a5a4a3a4a3a2a1a0rrrrnnnnnnnn
898
ai=argtype(i) ret nargs
900
#define SFUN_NARGS(x) (x & 0xff) /* 8 bits */
901
#define RESTYPE(x) (x<<8) /* 3 bits */
902
/* set if the VFUN_NARGS = m ; has been set correctly */
903
#define VFUN_NARG_BIT (1 <<11)
904
#define ARGTYPE(i,x) ((x) <<(12+(i*2)))
905
#define ARGTYPE1(x) (1 | ARGTYPE(0,x))
906
#define ARGTYPE2(x,y) (2 | ARGTYPE(0,x) | ARGTYPE(1,y))
907
#define ARGTYPE3(x,y,z) (3 | ARGTYPE(0,x) | ARGTYPE(1,y) | ARGTYPE(2,z))
909
object make_si_sfun();
910
EXTER object MVloc[10];
912
/* Set new to be an (object *) whose [i]'th elmt is the
913
ith elmnt in a va_list
915
((vl[0] == va_arg(ap,object)) ||
916
(vl[1] == va_arg(ap,object)) || .. vl[n-1] == va_arg(ap,object))
918
#define DONT_COPY_VA_LIST
919
In recent versions of gcc, i think the builtin_alist stuff does not
922
#ifdef DONT_COPY_VA_LIST
923
#define COERCE_VA_LIST(new,vl,n) new = (object *) (vl)
925
#define COERCE_VA_LIST(new,vl,n) \
929
if (n >= 65) FEerror("Too plong vl",0); \
930
for (i=0 ; i < (n); i++) new[i]=va_arg(vl,object);}
933
#ifdef DONT_COPY_VA_LIST
934
#error Cannot set DONT_COPY_VA_LIST in ANSI C
936
#define COERCE_VA_LIST_NEW(new,fst,vl,n) \
940
if (n >= 65) FEerror("va_list too long",0); \
941
for (i=0 ; i < (n); i++) new[i]=i ? va_arg(vl,object) : fst;}
946
#define make_si_vfun(s,f,min,max) \
947
make_si_vfun1(s,f,min | (max << 8))
949
/* Number of args supplied to a variable arg t_vfun
950
Used by the C function to set optionals */
957
double double_return;
959
EXTER struct call_data fcall;
961
#define VFUN_NARGS fcall.argd
962
#define RETURN2(x,y) do{/* object _x = (void *) x; */\
963
fcall.values[2]=y;fcall.nvalues=2; \
964
return (x) ;} while(0)
965
#define RETURN1(x) do{fcall.nvalues=1; return (x) ;} while(0)
966
#define RETURN0 do{fcall.nvalues=0; return Cnil ;} while(0)
968
#define RV(x) (*_p++ = x)
970
#define RETURNI(n,val1,listvals) RETURN(n,int,val1,listvals)
971
#define RETURNO(n,val1,listvals) RETURN(n,object,val1,listvals)
973
/* eg: RETURN(3,object,val1,(RV(val2),RV(val3))) */
974
#define RETURN(n,typ,val1,listvals) \
975
do{typ _val1 = val1; object *_p=&fcall.values[1]; listvals; fcall.nvalues= n; return _val1;}while(0)
976
/* #define CALL(n,form) (VFUN_NARGS=n,form) */
980
/* we sometimes have to touch the header of arrays or structures
981
to make sure the page is writable */
983
#define SGC_TOUCH(x) if ((x)->d.m) system_error(); (x)->d.m=0
988
object funcall_cfun(void(*)(),int,...);
989
object clear_compiler_properties();
990
EXTER object sSlambda_block_expanded;
994
{if (!(ex)){(void)fprintf(stderr, \
995
"Assertion failed: file \"%s\", line %d\n", __FILE__, __LINE__);exit(1);}}
1000
#ifndef FIX_PATH_STRING
1001
#define FIX_PATH_STRING(file) file
1005
#define CHECK_INTERRUPT if (signals_pending) raise_pending_signals(sig_safe)
1007
#define BEGIN_NO_INTERRUPT \
1008
plong old_signals_allowed = signals_allowed; \
1011
#define END_NO_INTERRUPT \
1012
signals_allowed = old_signals_allowed
1013
/* could add: if (signals_pending)
1014
raise_pending_signals(sig_use_signals_allowed_value) */
1017
#define END_NO_INTERRUPT_SAFE \
1018
signals_allowed = old_signals_allowed; \
1019
if (signals_pending) \
1020
do{ if(signals_allowed ==0) /* should not get here*/abort(); \
1021
raise_pending_signals(sig_safe)}while(0)
1023
void raise_pending_signals();
1025
EXTER unsigned plong signals_allowed, signals_pending ;
1027
EXTER struct symbol Dotnil_body;
1028
#define Dotnil ((object)&Dotnil_body)
1031
static struct cons s_my_dot={t_cons,0,0,0,Dotnil,Dotnil};\
1035
if (type_of(_x)==t_cons) {\
1036
if (type_of(_x->c.c_cdr)!=t_cons && _x->c.c_cdr!=Cnil)\
1037
s_my_dot.c_car=_x->c.c_cdr;\
1039
s_my_dot.c_car=Dotnil;\
1041
if (_x==s_my_dot.c_car)\
1042
x=(object)&s_my_dot;\
1044
s_my_dot.c_car=Dotnil;\
1045
if (_x==Cnil || _x==Dotnil)\
1048
FEwrong_type_argument(sLlist, _x);\
1054
#define endp_prop(a) (type_of(a)==t_cons ? FALSE : ((a)==Cnil ? TRUE : (FEwrong_type_argument(sLlist, (a)),FALSE)))
1056
#define proper_list(a) (type_of(a)==t_cons || (a)==Cnil)
1057
#define fix_dot(a) ((a) == Dotnil ? Cnil : (type_of(a)==t_cons && (a)->c.c_cdr==Dotnil ? (a)->c.c_car : (a)))
added
removed
h/object.h
