3 /* Begin for cmpinclude */
9 /* End for cmpinclude */
11 (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
12 Copying of this file is authorized to users who have executed the true and
13 proper "License Agreement for Kyoto Common LISP" with SIGLISP.
21 #define FIRSTWORD short t; char s,m
22 #define SGC_TOUCH(x) x->d.m=0
24 #define FIRSTWORD short t; short m
27 #define STSET(type,x,i,val) do{SGC_TOUCH(x);STREF(type,x,i) = (val);} while(0)
39 typedef float shortfloat
;
40 typedef double longfloat
;
41 typedef unsigned short fatchar
;
42 #define SIGNED_CHAR(x) (((char ) -1) < (char )0 ? (char) x \
43 : (x >= (1<<(CHAR_SIZE-1)) ? \
44 x - (((int)(1<<(CHAR_SIZE-1))) << 1) \
46 typedef union lispunion
*object
;
47 typedef union int_object iobject
;
48 union int_object
{int i
; object o
;};
50 #define OBJNULL ((object)NULL)
51 struct fixnum_struct
{
55 #define fix(x) (x)->FIX.FIXVAL
56 #define SMALL_FIXNUM_LIMIT 1024
57 extern struct fixnum_struct small_fixnum_table
[COM_LENG
];
58 #define small_fixnum(i) (object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i))
62 long *big_self
; /* bignum body */
63 int big_length
; /* bignum length */
65 #define MP(x) ((GEN)(x)->big.big_self)
66 struct shortfloat_struct
{
70 #define sf(x) (x)->SF.SFVAL
71 struct longfloat_struct
{
75 #define lf(x) (x)->LF.LFVAL
78 unsigned short ch_code
;
79 unsigned char ch_font
;
80 unsigned char ch_bits
;
82 struct character character_table1
[256+128];
83 #define character_table (character_table1+128)
84 #define code_char(c) (object)(character_table+(c))
85 #define char_code(x) (x)->ch.ch_code
86 #define char_font(x) (x)->ch.ch_font
87 #define char_bits(x) (x)->ch.ch_bits
97 #define s_fillp st_fillp
98 #define s_self st_self
126 struct fat_string
{ /* vector header */
128 unsigned fs_raw
: 24; /* tells if the things in leader are raw */
129 unsigned char fs_leader_length
; /* leader_Length */
130 int fs_dim
; /* dimension */
131 int fs_fillp
; /* fill pointer */
132 /* For simple vectors, */
133 /* fs_fillp is equal to fs_dim. */
134 fatchar
*fs_self
; /* pointer to the vector Note the leader starts at (int *) *fs_self - fs_leader_length */
161 short ust_adjustable
;
166 object ust_displaced
;
168 #define USHORT(x,i) (((unsigned short *)(x)->ust.ust_self)[i])
184 short fixa_adjustable
;
188 object fixa_displaced
;
195 short sfa_adjustable
;
200 object sfa_displaced
;
207 short lfa_adjustable
;
212 object lfa_displaced
;
217 struct structure
{ /* structure header */
219 object str_def
; /* structure definition (a structure) */
220 object
*str_self
; /* structure self */
223 #define STREF(type,x,i) (*((type *)(((char *)((x)->str.str_self))+(i))))
232 struct dclosure
{ /* compiled closure header */
234 int (*dc_self
)(); /* entry address */
235 object
*dc_env
; /* environment */
261 unsigned short vfn_minargs
;
262 unsigned short vfn_maxargs
;
270 FILE *sm_fp
; /* file pointer */
271 object sm_object0
; /* some object */
272 object sm_object1
; /* some object */
273 int sm_int0
; /* some int */
274 int sm_int1
; /* some int */
275 char *sm_buffer
; /* ptr to BUFSIZE block of storage */
276 short sm_mode
; /* stream mode */
282 struct shortfloat_struct
285 struct longfloat_struct
305 struct fat_string fs
;
307 struct fixarray fixa
;
313 t_start
= 0 , /* t_cons, */
347 #define type_of(obje) ((enum type)(((object)(obje))->d.t))
348 #define endp(obje) endp1(obje)
349 extern object value_stack
[COM_LENG
];
350 #define vs_org value_stack
354 #define vs_push(obje) (*vs_top++ = (obje))
355 #define vs_pop (*--vs_top)
356 #define vs_head vs_top[-1]
357 #define vs_mark object *old_vs_top = vs_top
358 #define vs_reset vs_top = old_vs_top
359 #define vs_check if (vs_top >= vs_limit) \
361 #define vs_check_push(obje) \
362 (vs_top >= vs_limit ? \
363 (object)vs_overflow() : (*vs_top++ = (obje)))
364 #define check_arg(n) \
365 if (vs_top - vs_base != (n)) \
367 #define MMcheck_arg(n) \
368 if (vs_top - vs_base < (n)) \
369 too_few_arguments(); \
370 else if (vs_top - vs_base > (n)) \
372 #define vs_reserve(x) if(vs_base+(x) >= vs_limit) \
378 extern struct bds_bd bind_stack
[COM_LENG
];
379 typedef struct bds_bd
*bds_ptr
;
384 if (bds_top >= bds_limit) \
386 #define bds_bind(sym, val) \
387 ((++bds_top)->bds_sym = (sym), \
388 bds_top->bds_val = (sym)->s.s_dbind, \
389 (sym)->s.s_dbind = (val))
390 #define bds_unwind1 \
391 ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top)
392 typedef struct invocation_history
{
396 extern struct invocation_history ihs_stack
[COM_LENG
];
401 if (ihs_top >= ihs_limit) \
403 #define ihs_push(function) \
404 (++ihs_top)->ihs_function = (function); \
405 ihs_top->ihs_base = vs_base
406 #define ihs_pop() (ihs_top--)
416 enum fr_class frs_class
;
420 typedef struct frame
*frame_ptr
;
421 #define alloc_frame_id() alloc_object(t_spice)
422 extern struct frame frame_stack
[COM_LENG
];
427 #define frs_push(class, val) \
428 if (++frs_top >= frs_limit) \
430 frs_top->frs_lex = lex_env;\
431 frs_top->frs_bds_top = bds_top; \
432 frs_top->frs_class = (class); \
433 frs_top->frs_val = (val); \
434 frs_top->frs_ihs = ihs_top; \
435 setjmp(frs_top->frs_jmpbuf)
436 #define frs_pop() frs_top--
469 #define MMcons(a,d) make_cons((a),(d))
470 #define MMcar(x) (x)->c.c_car
471 #define MMcdr(x) (x)->c.c_cdr
472 #define CMPcar(x) (x)->c.c_car
473 #define CMPcdr(x) (x)->c.c_cdr
474 #define CMPcaar(x) (x)->c.c_car->c.c_car
475 #define CMPcadr(x) (x)->c.c_cdr->c.c_car
476 #define CMPcdar(x) (x)->c.c_car->c.c_cdr
477 #define CMPcddr(x) (x)->c.c_cdr->c.c_cdr
478 #define CMPcaaar(x) (x)->c.c_car->c.c_car->c.c_car
479 #define CMPcaadr(x) (x)->c.c_cdr->c.c_car->c.c_car
480 #define CMPcadar(x) (x)->c.c_car->c.c_cdr->c.c_car
481 #define CMPcaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car
482 #define CMPcdaar(x) (x)->c.c_car->c.c_car->c.c_cdr
483 #define CMPcdadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr
484 #define CMPcddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr
485 #define CMPcdddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr
486 #define CMPcaaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_car
487 #define CMPcaaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_car
488 #define CMPcaadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_car
489 #define CMPcaaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car
490 #define CMPcadaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_car
491 #define CMPcadadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car
492 #define CMPcaddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car
493 #define CMPcadddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car
494 #define CMPcdaaar(x) (x)->c.c_car->c.c_car->c.c_car->c.c_cdr
495 #define CMPcdaadr(x) (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr
496 #define CMPcdadar(x) (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr
497 #define CMPcdaddr(x) (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr
498 #define CMPcddaar(x) (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr
499 #define CMPcddadr(x) (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr
500 #define CMPcdddar(x) (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr
501 #define CMPcddddr(x) (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr
502 #define CMPfuncall funcall
503 #define cclosure_call funcall
504 object
simple_lispcall();
505 object
simple_lispcall_no_event();
506 object
simple_symlispcall();
507 object
simple_symlispcall_no_event();
512 #define Cnil ((object)&Cnil_body)
513 #define Ct ((object)&Ct_body)
514 struct symbol Cnil_body
, Ct_body
;
519 object siSfunction_documentation
;
520 object siSvariable_documentation
;
521 object siSpretty_print_format
;
523 object keyword_package
;
524 object
alloc_object();
529 object
coerce_to_string();
533 frame_ptr
frs_sch_catch();
534 object
make_cclosure();
535 object
make_cclosure_new();
543 object
number_expt();
544 object
number_minus();
545 object
number_negate();
546 object
number_plus();
547 object
number_times();
555 object
string_to_object();
556 object
symbol_function();
557 object
symbol_value();
558 object
make_fixnum();
559 object
make_shortfloat();
560 object
make_longfloat();
561 object
structure_ref();
562 object
structure_set();
579 object
symbol_name();
580 char object_to_char();
582 float object_to_float();
583 double object_to_double();
584 char *object_to_string();
586 #define CMPmake_fixnum(x) \
587 ((((FIXtemp=(x))+1024)&-2048)==0?small_fixnum(FIXtemp):make_fixnum(FIXtemp))
588 #define Creturn(v) return((vs_top=vs,(v)))
589 #define Cexit return((vs_top=vs,0))
590 double sin(), cos(), tan();
591 object
read_byte1(),read_char1();
593 #define fs_leader(ar,i) (((object *)((ar)->fs.fs_self))[-(i+1)])
601 #define ALLOCA_CONS(n) (alloca_val=alloca((n)*sizeof(struct cons)))
602 #define ON_STACK_CONS(x,y) (alloca_val=alloca(sizeof(struct cons)), on_stack_cons(x,y))
603 #define ON_STACK_LIST on_stack_list
604 #define ON_STACK_LIST_VECTOR on_stack_list_vector
605 #define ON_STACK_MAKE_LIST on_stack_make_list
606 object
on_stack_cons();
607 object
on_stack_list();
608 object
on_stack_list_vector();
609 object
on_stack_make_list();
611 #define ALLOCA_CONS(n) 0
612 #define ON_STACK_CONS(x,y) MMcons(x,y)
613 #define ON_STACK_LIST list
614 #define ON_STACK_LIST_VECTOR list_vector
615 #define ON_STACK_MAKE_LIST make_list
619 struct call_data
{ object fun
;
621 struct call_data fcall
;
623 object
list_vector();
625 #define VARG(min,max) ((min) | (max << 8))
626 #define VFUN_NARGS fcall.argd
627 extern object Cstd_key_defaults
[];
628 int vfun_wrong_number_of_args();
629 int eql(),equal(),eq();
631 object
LVformat(),LVerror();
632 #define EQ(x,y) ((x)==(y))
636 /* #include "../h/genpari.h"*/
637 typedef unsigned long *GEN
;
638 GEN
addii(),mulii(),mulsi(),powerii(),shifti(),stoi(),dvmdii(),subii();
640 #define signe(x) (((GEN)(x))[1]>>24)
641 #define lg(x) (((GEN)(x))[0]&0xffff)
642 #define setlg(x,s) (((GEN)(x))[0]=(((GEN)(x))[0]&0xffff0000)+s)
643 #define lgef(x) (((GEN)(x))[1]&0xffff)
644 #define setlgef(x,s) (((GEN)(x))[1]=(((GEN)(x))[1]&0xffff0000)+s)
647 #define ulong unsigned long
648 /* #define DEBUG_AVMA */
651 #define save_avma long lvma = (in_saved_avma = 1, avma)
652 #define restore_avma avma = (in_saved_avma = 0, lvma)
654 #define save_avma long lvma = avma
655 #define restore_avma avma = lvma
661 object
make_integer();
662 /* copy x to y, increasing space by factor of 2 */
668 #define otoi(x) (integ_temp = (x) , (type_of(integ_temp) == t_bignum \
669 ? MP(integ_temp) :stoi(fix(integ_temp))))
674 #define SETQ_II(var,alloc,val) \
675 do{GEN _xx =(val) ; \
676 int _n = replace_copy1(_xx,var); \
677 if(_n) var = replace_copy2(_xx,alloca(_n));}while(0)
679 #define SETQ_IO(var,alloc,val) {object _xx =(val) ; \
680 int _n = obj_replace_copy1(_xx,var); \
681 if(_n) var = obj_replace_copy2(_xx,alloca(_n));}
682 #define IDECL(a,b,c) ulong b[4];a =(b[0]=0x1010000 +4,b)
684 GEN
setq_io(),setq_ii();
685 #define SETQ_IO(x,alloc,val) (x)=setq_io(x,&alloc,val)
686 #define SETQ_II(x,alloc,val) (x)=setq_ii(x,&alloc,val)
687 #define IDECL(a,b,c) ulong b[4];a =(b[0]=0x1010000 +4,b);object c
692 #define alloca __builtin_alloca