\begin{verbatim}
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
#include <stdio.h>
#include <setjmp.h>
#define TRUE    1
#define FALSE   0
typedef int bool;
typedef int fixnum;
typedef float shortfloat;
typedef double longfloat;
typedef union lispunion *object;
#define OBJNULL ((object)NULL)
struct fixnum_struct {
        short   t, m;
        fixnum  FIXVAL;
};
#define fix(x)  (x)->FIX.FIXVAL
#define SMALL_FIXNUM_LIMIT      1024
struct fixnum_struct small_fixnum_table[];
#define small_fixnum(i) (object)(small_fixnum_table+SMALL_FIXNUM_LIMIT+(i))
struct shortfloat_struct {
        short           t, m;
        shortfloat      SFVAL;
};
#define sf(x)   (x)->SF.SFVAL
struct longfloat_struct {
        short           t, m;
        longfloat       LFVAL;
};
#define lf(x)   (x)->LF.LFVAL
struct character {
        short           t, m;
        unsigned short  ch_code;
        unsigned char   ch_font;
        unsigned char   ch_bits;
};
struct character character_table[];
#define code_char(c)    (object)(character_table+(c))
#define char_code(x)    (x)->ch.ch_code
#define char_font(x)    (x)->ch.ch_font
#define char_bits(x)    (x)->ch.ch_bits
enum stype {
        stp_ordinary,
        stp_constant,
        stp_special
};
struct symbol {
        short   t, m;
        object  s_dbind;
        int     (*s_sfdef)();
#define s_fillp         st_fillp
#define s_self          st_self
        int     s_fillp;
        char    *s_self;
        object  s_gfdef;
        object  s_plist;
        object  s_hpack;
        short   s_stype;
        short   s_mflag;
};
struct cons {
        short   t, m;
        object  c_cdr;
        object  c_car;
};
struct array {
        short   t, m;
        short   a_rank;
        short   a_adjustable;
        int     a_dim;
        int     *a_dims;
        object  *a_self;
        object  a_displaced;
        short   a_elttype;
        short   a_offset;
};
struct vector {
        short   t, m;
        short   v_hasfillp;
        short   v_adjustable;
        int     v_dim;
        int     v_fillp;
        object  *v_self;
        object  v_displaced;
        short   v_elttype;
        short   v_offset;
};
struct string {
        short   t, m;
        short   st_hasfillp;
        short   st_adjustable;
        int     st_dim;
        int     st_fillp;
        char    *st_self;
        object  st_displaced;
};
struct ustring {
        short   t, m;
        short   ust_hasfillp;
        short   ust_adjustable;
        int     ust_dim;
        int     ust_fillp;
        unsigned char
                *ust_self;
        object  ust_displaced;
};
struct bitvector {
        short   t, m;
        short   bv_hasfillp;
        short   bv_adjustable;
        int     bv_dim;
        int     bv_fillp;
        char    *bv_self;
        object  bv_displaced;
        short   bv_elttype;
        short   bv_offset;
};
struct fixarray {
        short   t, m;
        short   fixa_rank;
        short   fixa_adjustable;
        int     fixa_dim;
        int     *fixa_dims;
        fixnum  *fixa_self;
        object  fixa_displaced;
        short   fixa_elttype;
        short   fixa_offset;
};
struct sfarray {
        short   t, m;
        short   sfa_rank;
        short   sfa_adjustable;
        int     sfa_dim;
        int     *sfa_dims;
        shortfloat
                *sfa_self;
        object  sfa_displaced;
        short   sfa_elttype;
        short   sfa_offset;
};
struct lfarray {
        short   t, m;
        short   lfa_rank;
        short   lfa_adjustable;
        int     lfa_dim;
        int     *lfa_dims;
        longfloat
                *lfa_self;
        object  lfa_displaced;
        short   lfa_elttype;
        short   lfa_offset;
};
struct structure {
        short   t, m;
        object  str_name;
        object  *str_self;
        int     str_length;
};
struct cfun {
        short   t, m;
        object  cf_name;
        int     (*cf_self)();
        object  cf_data;
        char    *cf_start;
        int     cf_size;
};
struct cclosure {
        short   t, m;
        object  cc_name;
        int     (*cc_self)();
        object  cc_env;
        object  cc_data;
        char    *cc_start;
        int     cc_size;
        object  *cc_turbo;
};
struct dummy {
        short   t, m;
};
union lispunion {
        struct fixnum_struct
                        FIX;
        struct shortfloat_struct
                        SF;
        struct longfloat_struct
                        LF;
        struct character
                        ch;
        struct symbol   s;
        struct cons     c;
        struct array    a;
        struct vector   v;
        struct string   st;
        struct ustring  ust;
        struct bitvector
                        bv;
        struct structure
                        str;
        struct cfun     cf;
        struct cclosure cc;
        struct dummy    d;
        struct fixarray fixa;
        struct sfarray  sfa;
        struct lfarray  lfa;
};
enum type {
        t_cons = 0,
        t_start = t_cons,
        t_fixnum,
        t_bignum,
        t_ratio,
        t_shortfloat,
        t_longfloat,
        t_complex,
        t_character,
        t_symbol,
        t_package,
        t_hashtable,
        t_array,
        t_vector,
        t_string,
        t_bitvector,
        t_structure,
        t_stream,
        t_random,
        t_readtable,
        t_pathname,
        t_cfun,
        t_cclosure,
        t_spice,
        t_end,
        t_contiguous,
        t_relocatable,
        t_other
};
#define type_of(obje)   ((enum type)(((object)(obje))->d.t))
#define endp(obje)      endp1(obje)
object value_stack[];
#define vs_org          value_stack
object *vs_limit;
object *vs_base;
object *vs_top;
#define vs_push(obje)   (*vs_top++ = (obje))
#define vs_pop          (*--vs_top)
#define vs_head         vs_top[-1]
#define vs_mark         object *old_vs_top = vs_top
#define vs_reset        vs_top = old_vs_top
#define vs_check        if (vs_top >= vs_limit)  \
                                vs_overflow();
#define vs_check_push(obje)  \
                        (vs_top >= vs_limit ?  \
                         (object)vs_overflow() : (*vs_top++ = (obje)))
#define check_arg(n)  \
                        if (vs_top - vs_base != (n))  \
                                check_arg_failed(n)
#define MMcheck_arg(n)  \
                        if (vs_top - vs_base < (n))  \
                                too_few_arguments();  \
                        else if (vs_top - vs_base > (n))  \
                                too_many_arguments()
#define vs_reserve(x)   if(vs_base+(x) >= vs_limit)  \
                                vs_overflow();
struct bds_bd {
        object  bds_sym;
        object  bds_val;
};
struct bds_bd bind_stack[];
#define bds_org         bind_stack
typedef struct bds_bd *bds_ptr;
bds_ptr bds_limit;
bds_ptr bds_top;
#define bds_check  \
        if (bds_top >= bds_limit)  \
                bds_overflow()
#define bds_bind(sym, val)  \
        ((++bds_top)->bds_sym = (sym),  \
        bds_top->bds_val = (sym)->s.s_dbind,  \
        (sym)->s.s_dbind = (val))
#define bds_unwind1  \
        ((bds_top->bds_sym)->s.s_dbind = bds_top->bds_val, --bds_top)
typedef struct invocation_history {
        object  ihs_function;
        object  *ihs_base;
} *ihs_ptr;
struct invocation_history ihs_stack[];
#define ihs_org         ihs_stack
ihs_ptr ihs_limit;
ihs_ptr ihs_top;
#define ihs_check  \
        if (ihs_top >= ihs_limit)  \
                ihs_overflow()
#define ihs_push(function)  \
        (++ihs_top)->ihs_function = (function);  \
        ihs_top->ihs_base = vs_base
#define ihs_pop()       (ihs_top--)
enum fr_class {
        FRS_CATCH,
        FRS_CATCHALL,
        FRS_PROTECT
};
struct frame {
        jmp_buf         frs_jmpbuf;
        object          *frs_lex;
        bds_ptr         frs_bds_top;
        enum fr_class   frs_class;
        object          frs_val;
        ihs_ptr         frs_ihs;
};
typedef struct frame *frame_ptr;
#define alloc_frame_id()        alloc_object(t_spice)
struct frame frame_stack[];
#define frs_org         frame_stack
frame_ptr frs_limit;
frame_ptr frs_top;
#define frs_push(class, val)  \
        if (++frs_top >= frs_limit)  \
                frs_overflow();  \
        frs_top->frs_lex = lex_env;\
        frs_top->frs_bds_top = bds_top;  \
        frs_top->frs_class = (class);  \
        frs_top->frs_val = (val);  \
        frs_top->frs_ihs = ihs_top;  \
        setjmp(frs_top->frs_jmpbuf)
#define frs_pop()       frs_top--
bool nlj_active;
frame_ptr nlj_fr;
object nlj_tag;
object *lex_env;
object caar();
object cadr();
object cdar();
object cddr();
object caaar();
object caadr();
object cadar();
object caddr();
object cdaar();
object cdadr();
object cddar();
object cdddr();
object caaaar();
object caaadr();
object caadar();
object caaddr();
object cadaar();
object cadadr();
object caddar();
object cadddr();
object cdaaar();
object cdaadr();
object cdadar();
object cdaddr();
object cddaar();
object cddadr();
object cdddar();
object cddddr();
#define MMcons(a,d)     make_cons((a),(d))
#define MMcar(x)        (x)->c.c_car
#define MMcdr(x)        (x)->c.c_cdr
#define CMPcar(x)       (x)->c.c_car
#define CMPcdr(x)       (x)->c.c_cdr
#define CMPcaar(x)      (x)->c.c_car->c.c_car
#define CMPcadr(x)      (x)->c.c_cdr->c.c_car
#define CMPcdar(x)      (x)->c.c_car->c.c_cdr
#define CMPcddr(x)      (x)->c.c_cdr->c.c_cdr
#define CMPcaaar(x)     (x)->c.c_car->c.c_car->c.c_car
#define CMPcaadr(x)     (x)->c.c_cdr->c.c_car->c.c_car
#define CMPcadar(x)     (x)->c.c_car->c.c_cdr->c.c_car
#define CMPcaddr(x)     (x)->c.c_cdr->c.c_cdr->c.c_car
#define CMPcdaar(x)     (x)->c.c_car->c.c_car->c.c_cdr
#define CMPcdadr(x)     (x)->c.c_cdr->c.c_car->c.c_cdr
#define CMPcddar(x)     (x)->c.c_car->c.c_cdr->c.c_cdr
#define CMPcdddr(x)     (x)->c.c_cdr->c.c_cdr->c.c_cdr
#define CMPcaaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_car
#define CMPcaaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_car
#define CMPcaadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_car
#define CMPcaaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_car
#define CMPcadaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_car
#define CMPcadadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_car
#define CMPcaddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_car
#define CMPcadddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_car
#define CMPcdaaar(x)    (x)->c.c_car->c.c_car->c.c_car->c.c_cdr
#define CMPcdaadr(x)    (x)->c.c_cdr->c.c_car->c.c_car->c.c_cdr
#define CMPcdadar(x)    (x)->c.c_car->c.c_cdr->c.c_car->c.c_cdr
#define CMPcdaddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_car->c.c_cdr
#define CMPcddaar(x)    (x)->c.c_car->c.c_car->c.c_cdr->c.c_cdr
#define CMPcddadr(x)    (x)->c.c_cdr->c.c_car->c.c_cdr->c.c_cdr
#define CMPcdddar(x)    (x)->c.c_car->c.c_cdr->c.c_cdr->c.c_cdr
#define CMPcddddr(x)    (x)->c.c_cdr->c.c_cdr->c.c_cdr->c.c_cdr
#define CMPfuncall      funcall
#define cclosure_call   funcall
object simple_lispcall();
object simple_lispcall_no_event();
object simple_symlispcall();
object simple_symlispcall_no_event();
object CMPtemp;
object CMPtemp1;
object CMPtemp2;
object CMPtemp3;
#define Cnil    ((object)&Cnil_body)
#define Ct      ((object)&Ct_body)
struct symbol Cnil_body, Ct_body;
object MF();
object MM();
object Scons;
object siSfunction_documentation;
object siSvariable_documentation;
object siSpretty_print_format;
object Slist;
object keyword_package;
object alloc_object();
object car();
object cdr();
object list();
object listA();
object coerce_to_string();
object elt();
object elt_set();
frame_ptr frs_sch();
frame_ptr frs_sch_catch();
object make_cclosure();
object nth();
object nthcdr();
object make_cons();
object append();
object nconc();
object reverse();
object nreverse();
object number_expt();
object number_minus();
object number_negate();
object number_plus();
object number_times();
object one_minus();
object one_plus();
object get();
object getf();
object putprop();
object remprop();
object string_to_object();
object symbol_function();
object symbol_value();
object make_fixnum();
object make_shortfloat();
object make_longfloat();
object structure_ref();
object structure_set();
object princ();
object prin1();
object print();
object terpri();
object aref();
object aset();
object aref1();
object aset1();
char object_to_char();
int object_to_int();
float object_to_float();
double object_to_double();
int FIXtemp;
#define CMPmake_fixnum(x) \
((((FIXtemp=(x))+1024)&-2048)==0?small_fixnum(FIXtemp):make_fixnum(FIXtemp))
#define Creturn(v) return((vs_top=vs,(v)))
#define Cexit return((vs_top=vs,0))
double sin(), cos(), tan();
\end{verbatim}
