/* xsinit.c - xscheme initialization routines */
/*	Copyright (c) 1988, by David Michael Betz
	All Rights Reserved
	Permission is granted for unrestricted non-commercial use	*/

#include "xscheme.h"
#include "xsbcode.h"

/* macro to store a byte into a bytecode vector */
#define pb(x)	(*bcode++ = (x))

/* global variables */
LVAL lk_optional,lk_rest;
LVAL obarray,true,eof_object,default_object,s_unassigned;
LVAL cs_map1,cs_foreach1,cs_withfile1,cs_load1,cs_force1;
LVAL c_lpar,c_rpar,c_dot,c_quote,s_quote;
LVAL s_eval,s_unbound,s_stdin,s_stdout,s_stderr;
LVAL s_printcase,k_upcase,k_downcase;
LVAL s_fixfmt,s_flofmt;

/* external variables */
extern jmp_buf top_level;
extern FUNDEF funtab[];
extern int xsubrcnt;
extern int csubrcnt;

/* xlinitws - create an initial workspace */
xlinitws(ssize)
  unsigned int ssize;
{
    unsigned char *bcode;
    int type,i;
    LVAL code;
    FUNDEF *p;

    /* setup an initialization error handler */
    if (setjmp(top_level))
	exit(1);

    /* allocate memory for the workspace */
    xlminit(ssize);

    /* initialize the obarray */
    obarray = cvsymbol("*OBARRAY*");
    setvalue(obarray,newvector(HSIZE));

    /* add the symbol *OBARRAY* to the obarray */
    setelement(getvalue(obarray),
               hash(getstring(getpname(obarray)),HSIZE),
               cons(obarray,NIL));

    /* enter the eof object */
    eof_object = cons(xlenter("**EOF**"),NIL);
    
    /* enter the default object */
    default_object = cons(xlenter("**DEFAULT**"),NIL);

    /* initialize the error handlers */
    setvalue(xlenter("*ERROR-HANDLER*"),NIL);
    setvalue(xlenter("*UNBOUND-HANDLER*"),NIL);
    
    /* install the built-in functions */
    for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) {
	type = (i < xsubrcnt ? XSUBR : (i < csubrcnt ? CSUBR : SUBR));
	xlsubr(p->fd_name,type,p->fd_subr,i);
    }
    xloinit(); /* initialize xsobj.c */

    /* setup some synonyms */
    setvalue(xlenter("NOT"),getvalue(xlenter("NULL?")));
    setvalue(xlenter("PRIN1"),getvalue(xlenter("WRITE")));
    setvalue(xlenter("PRINC"),getvalue(xlenter("DISPLAY")));

    /* enter all of the symbols used by the runtime system */
    xlsymbols();

    /* set the initial values of the symbols #T, T and NIL */
    setvalue(true,true);
    setvalue(xlenter("T"),true);
    setvalue(xlenter("NIL"),NIL);

    /* default to lowercase output of symbols */
    setvalue(s_printcase,k_downcase);

    /* setup the print formats for numbers */
    s_fixfmt = xlenter("*FIXNUM-FORMAT*");
    setvalue(s_fixfmt,cvstring(IFMT));
    s_flofmt = xlenter("*FLONUM-FORMAT*");
    setvalue(s_flofmt,cvstring(FFMT));
    
    /* build the 'eval' function */
    code = newcode(4); cpush(code);
    setelement(code,0,newstring(0x12));
    setelement(code,1,xlenter("EVAL"));
    setelement(code,2,cons(xlenter("X"),NIL));
    setelement(code,3,xlenter("COMPILE"));
    drop(1);

    /* store the byte codes */
    bcode = (unsigned char *)getstring(getbcode(code));

pb(OP_FRAME);pb(0x02);		/* 0000 12 02    FRAME 02		*/
pb(OP_MVARG);pb(0x01);		/* 0002 13 01    MVARG 01		*/
pb(OP_ALAST);			/* 0004 1a       ALAST			*/
pb(OP_SAVE);pb(0x00);pb(0x10);	/* 0005 0b 00 10 SAVE 0010		*/
pb(OP_EREF);pb(0x00);pb(0x01);	/* 0008 09 00 01 EREF 00 01 ; x		*/
pb(OP_PUSH);			/* 000b 10       PUSH			*/
pb(OP_GREF);pb(0x03);		/* 000c 05 03    GREF 03 ; compile	*/
pb(OP_CALL);pb(0x01);		/* 000e 0c 01    CALL 01		*/
pb(OP_CALL);pb(0x00);		/* 0010 0c 00    CALL 00		*/

    setvalue(getelement(code,1),cvclosure(code,NIL));

    /* setup the initialization code */
    code = newcode(6); cpush(code);
    setelement(code,0,newstring(0x11));
    setelement(code,1,xlenter("*INITIALIZE*"));
    setelement(code,3,cvstring("xscheme.ini"));
    setelement(code,4,xlenter("LOAD"));
    setelement(code,5,xlenter("*TOPLEVEL*"));
    drop(1);

    /* store the byte codes */
    bcode = (unsigned char *)getstring(getbcode(code));

pb(OP_FRAME);pb(0x01);		/* 0000 12 01    FRAME 01		*/
pb(OP_ALAST);			/* 0002 1a       ALAST			*/
pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d		*/
pb(OP_LIT);  pb(0x03);		/* 0006 04 03    LIT 03 ; "xscheme.ini"	*/
pb(OP_PUSH);			/* 0008 10       PUSH			*/
pb(OP_GREF); pb(0x04);		/* 0009 05 04    GREF 04 ; load		*/
pb(OP_CALL); pb(0x01);		/* 000b 0c 01    CALL 01		*/
pb(OP_GREF); pb(0x05);		/* 000d 05 05    GREF 05 ; *toplevel*	*/
pb(OP_CALL); pb(0x00);		/* 000f 0c 00    CALL 00		*/

    setvalue(getelement(code,1),cvclosure(code,NIL));

    /* setup the main loop code */
    code = newcode(9); cpush(code);
    setelement(code,0,newstring(0x28));
    setelement(code,1,xlenter("*TOPLEVEL*"));
    setelement(code,3,cvstring("\n> "));
    setelement(code,4,xlenter("DISPLAY"));
    setelement(code,5,xlenter("READ"));
    setelement(code,6,xlenter("EVAL"));
    setelement(code,7,xlenter("WRITE"));
    setelement(code,8,xlenter("*TOPLEVEL*"));
    drop(1);

    /* store the byte codes */
    bcode = (unsigned char *)getstring(getbcode(code));

pb(OP_FRAME);pb(0x01);		/* 0000 12 01    FRAME 01		*/
pb(OP_ALAST);			/* 0002 1a       ALAST			*/
pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d		*/
pb(OP_LIT);  pb(0x03);		/* 0006 04 03    LIT 03 ; "\n> "		*/
pb(OP_PUSH);			/* 0008 10       PUSH			*/
pb(OP_GREF); pb(0x04);		/* 0009 05 04    GREF 04 ; display	*/
pb(OP_CALL); pb(0x01);		/* 000b 0c 01    CALL 01		*/
pb(OP_SAVE); pb(0x00); pb(0x24);/* 000d 0b 00 24 SAVE 0024		*/
pb(OP_SAVE); pb(0x00); pb(0x1f);/* 0010 0b 00 1f SAVE 001f		*/
pb(OP_SAVE); pb(0x00); pb(0x1a);/* 0013 0b 00 1a SAVE 001a		*/
pb(OP_GREF); pb(0x05);		/* 0016 05 05    GREF 05 ; read		*/
pb(OP_CALL); pb(0x00);		/* 0018 0c 00    CALL 00		*/
pb(OP_PUSH);			/* 001a 10       PUSH			*/
pb(OP_GREF); pb(0x06);		/* 001b 05 06    GREF 06 ; eval		*/
pb(OP_CALL); pb(0x01);		/* 001d 0c 01    CALL 01		*/
pb(OP_PUSH);			/* 001f 10       PUSH			*/
pb(OP_GREF); pb(0x07);		/* 0020 05 07    GREF 07 ; write	*/
pb(OP_CALL); pb(0x01);		/* 0022 0c 01    CALL 01		*/
pb(OP_GREF); pb(0x08);		/* 0024 05 08    GREF 08 ; *toplevel*	*/
pb(OP_CALL); pb(0x00);		/* 0026 0c 00    CALL 00		*/

    setvalue(getelement(code,1),cvclosure(code,NIL));
}

/* xlsymbols - lookup/enter all symbols used by the runtime system */
xlsymbols()
{
    LVAL sym;
    
    /* top-level procedure symbol */
    s_eval = xlenter("EVAL");
    
    /* enter the symbols used by the system */
    true         = xlenter("#T");
    s_unbound	 = xlenter("*UNBOUND*");
    s_unassigned = xlenter("#!UNASSIGNED");
    s_stdin	 = xlenter("*STANDARD-INPUT*");
    s_stdout	 = xlenter("*STANDARD-OUTPUT*");
    s_stderr	 = xlenter("*ERROR-OUTPUT*");
    
    /* enter the lambda list keywords */
    lk_optional = xlenter("#!OPTIONAL");
    lk_rest     = xlenter("#!REST");

    /* enter symbols needed by the reader */
    c_lpar   = xlenter("(");
    c_rpar   = xlenter(")");
    c_dot    = xlenter(".");
    c_quote  = xlenter("'");
    s_quote  = xlenter("QUOTE");

    /* 'else' is a useful synonym for #t in cond clauses */
    sym = xlenter("ELSE");
    setvalue(sym,true);

    /* setup stdin/stdout/stderr */
    setvalue(s_stdin,cvport(stdin,PF_INPUT));
    setvalue(s_stdout,cvport(stdout,PF_OUTPUT));
    setvalue(s_stderr,cvport(stderr,PF_OUTPUT));

    /* enter *print-case* and its keywords */
    k_upcase	= xlenter("UPCASE");
    k_downcase	= xlenter("DOWNCASE");
    s_printcase	= xlenter("*PRINT-CASE*");

    /* get the built-in continuation subrs */
    cs_map1 = getvalue(xlenter("%MAP1"));
    cs_foreach1 = getvalue(xlenter("%FOR-EACH1"));
    cs_withfile1 = getvalue(xlenter("%WITH-FILE1"));
    cs_load1 = getvalue(xlenter("%LOAD1"));
    cs_force1 = getvalue(xlenter("%FORCE1"));

    /* initialize xsobj.c */
    obsymbols();
}