home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / xsinit.c < prev    next >
C/C++ Source or Header  |  1990-01-08  |  8KB  |  229 lines
  1. /* xsinit.c - xscheme initialization routines */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7. #include "xsbcode.h"
  8.  
  9. /* macro to store a byte into a bytecode vector */
  10. #define pb(x)    (*bcode++ = (x))
  11.  
  12. /* global variables */
  13. LVAL lk_optional,lk_rest;
  14. LVAL obarray,true,eof_object,default_object,s_unassigned;
  15. LVAL cs_map1,cs_foreach1,cs_withfile1,cs_load1,cs_force1;
  16. LVAL c_lpar,c_rpar,c_dot,c_quote,s_quote;
  17. LVAL s_eval,s_unbound,s_stdin,s_stdout,s_stderr;
  18. LVAL s_printcase,k_upcase,k_downcase;
  19. LVAL s_fixfmt,s_flofmt;
  20.  
  21. /* external variables */
  22. extern jmp_buf top_level;
  23. extern FUNDEF funtab[];
  24. extern int xsubrcnt;
  25. extern int csubrcnt;
  26.  
  27. /* xlinitws - create an initial workspace */
  28. xlinitws(ssize)
  29.   unsigned int ssize;
  30. {
  31.     unsigned char *bcode;
  32.     int type,i;
  33.     LVAL code;
  34.     FUNDEF *p;
  35.  
  36.     /* allocate memory for the workspace */
  37.     xlminit(ssize);
  38.  
  39.     /* initialize the obarray */
  40.     s_unbound = NIL; /* to make cvsymbol work */
  41.     obarray = cvsymbol("*OBARRAY*");
  42.     setvalue(obarray,newvector(HSIZE));
  43.  
  44.     /* add the symbol *OBARRAY* to the obarray */
  45.     setelement(getvalue(obarray),
  46.                hash(getstring(getpname(obarray)),HSIZE),
  47.                cons(obarray,NIL));
  48.  
  49.     /* enter the eof object */
  50.     eof_object = cons(xlenter("**EOF**"),NIL);
  51.  
  52.     /* enter the default object */
  53.     default_object = cons(xlenter("**DEFAULT**"),NIL);
  54.  
  55.     /* initialize the error handlers */
  56.     setvalue(xlenter("*ERROR-HANDLER*"),NIL);
  57.     setvalue(xlenter("*UNBOUND-HANDLER*"),NIL);
  58.  
  59.     /* install the built-in functions */
  60.     for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p) {
  61.     type = (i < xsubrcnt ? XSUBR : (i < csubrcnt ? CSUBR : SUBR));
  62.     xlsubr(p->fd_name,type,p->fd_subr,i);
  63.     }
  64.     xloinit(); /* initialize xsobj.c */
  65.  
  66.     /* setup some synonyms */
  67.     setvalue(xlenter("NOT"),getvalue(xlenter("NULL?")));
  68.     setvalue(xlenter("PRIN1"),getvalue(xlenter("WRITE")));
  69.     setvalue(xlenter("PRINC"),getvalue(xlenter("DISPLAY")));
  70.  
  71.     /* enter all of the symbols used by the runtime system */
  72.     xlsymbols();
  73.  
  74.     /* set the initial values of the symbols #T, T and NIL */
  75.     setvalue(true,true);
  76.     setvalue(xlenter("T"),true);
  77.     setvalue(xlenter("NIL"),NIL);
  78.  
  79.     /* default to lowercase output of symbols */
  80.     setvalue(s_printcase,k_downcase);
  81.  
  82.     /* setup the print formats for numbers */
  83.     setvalue(s_fixfmt,cvstring(IFMT));
  84.     setvalue(s_flofmt,cvstring(FFMT));
  85.  
  86.     /* build the 'eval' function */
  87.     code = newcode(4); cpush(code);
  88.     setelement(code,0,newstring(0x12));
  89.     setelement(code,1,xlenter("EVAL"));
  90.     setelement(code,2,cons(xlenter("X"),NIL));
  91.     setelement(code,3,xlenter("COMPILE"));
  92.     drop(1);
  93.  
  94.     /* store the byte codes */
  95.     bcode = (unsigned char *)getstring(getbcode(code));
  96.  
  97. pb(OP_FRAME);pb(0x02);        /* 0000 12 02    FRAME 02        */
  98. pb(OP_MVARG);pb(0x01);        /* 0002 13 01    MVARG 01        */
  99. pb(OP_ALAST);            /* 0004 1a       ALAST            */
  100. pb(OP_SAVE);pb(0x00);pb(0x10);    /* 0005 0b 00 10 SAVE 0010        */
  101. pb(OP_EREF);pb(0x00);pb(0x01);    /* 0008 09 00 01 EREF 00 01 ; x        */
  102. pb(OP_PUSH);            /* 000b 10       PUSH            */
  103. pb(OP_GREF);pb(0x03);        /* 000c 05 03    GREF 03 ; compile    */
  104. pb(OP_CALL);pb(0x01);        /* 000e 0c 01    CALL 01        */
  105. pb(OP_CALL);pb(0x00);        /* 0010 0c 00    CALL 00        */
  106.  
  107.     setvalue(getelement(code,1),cvclosure(code,NIL));
  108.  
  109.     /* setup the initialization code */
  110.     code = newcode(6); cpush(code);
  111.     setelement(code,0,newstring(0x11));
  112.     setelement(code,1,xlenter("*INITIALIZE*"));
  113.     setelement(code,3,cvstring("xscheme.ini"));
  114.     setelement(code,4,xlenter("LOAD"));
  115.     setelement(code,5,xlenter("*TOPLEVEL*"));
  116.     drop(1);
  117.  
  118.     /* store the byte codes */
  119.     bcode = (unsigned char *)getstring(getbcode(code));
  120.  
  121. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  122. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  123. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  124. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "xscheme.ini"    */
  125. pb(OP_PUSH);            /* 0008 10       PUSH            */
  126. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; load        */
  127. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  128. pb(OP_GREF); pb(0x05);        /* 000d 05 05    GREF 05 ; *toplevel*    */
  129. pb(OP_CALL); pb(0x00);        /* 000f 0c 00    CALL 00        */
  130.  
  131.     setvalue(getelement(code,1),cvclosure(code,NIL));
  132.  
  133.     /* setup the main loop code */
  134.     code = newcode(9); cpush(code);
  135.     setelement(code,0,newstring(0x28));
  136.     setelement(code,1,xlenter("*TOPLEVEL*"));
  137.     setelement(code,3,cvstring("\n> "));
  138.     setelement(code,4,xlenter("DISPLAY"));
  139.     setelement(code,5,xlenter("READ"));
  140.     setelement(code,6,xlenter("EVAL"));
  141.     setelement(code,7,xlenter("WRITE"));
  142.     setelement(code,8,xlenter("*TOPLEVEL*"));
  143.     drop(1);
  144.  
  145.     /* store the byte codes */
  146.     bcode = (unsigned char *)getstring(getbcode(code));
  147.  
  148. pb(OP_FRAME);pb(0x01);        /* 0000 12 01    FRAME 01        */
  149. pb(OP_ALAST);            /* 0002 1a       ALAST            */
  150. pb(OP_SAVE); pb(0x00); pb(0x0d);/* 0003 0b 00 0d SAVE 000d        */
  151. pb(OP_LIT);  pb(0x03);        /* 0006 04 03    LIT 03 ; "\n> "        */
  152. pb(OP_PUSH);            /* 0008 10       PUSH            */
  153. pb(OP_GREF); pb(0x04);        /* 0009 05 04    GREF 04 ; display    */
  154. pb(OP_CALL); pb(0x01);        /* 000b 0c 01    CALL 01        */
  155. pb(OP_SAVE); pb(0x00); pb(0x24);/* 000d 0b 00 24 SAVE 0024        */
  156. pb(OP_SAVE); pb(0x00); pb(0x1f);/* 0010 0b 00 1f SAVE 001f        */
  157. pb(OP_SAVE); pb(0x00); pb(0x1a);/* 0013 0b 00 1a SAVE 001a        */
  158. pb(OP_GREF); pb(0x05);        /* 0016 05 05    GREF 05 ; read        */
  159. pb(OP_CALL); pb(0x00);        /* 0018 0c 00    CALL 00        */
  160. pb(OP_PUSH);            /* 001a 10       PUSH            */
  161. pb(OP_GREF); pb(0x06);        /* 001b 05 06    GREF 06 ; eval        */
  162. pb(OP_CALL); pb(0x01);        /* 001d 0c 01    CALL 01        */
  163. pb(OP_PUSH);            /* 001f 10       PUSH            */
  164. pb(OP_GREF); pb(0x07);        /* 0020 05 07    GREF 07 ; write    */
  165. pb(OP_CALL); pb(0x01);        /* 0022 0c 01    CALL 01        */
  166. pb(OP_GREF); pb(0x08);        /* 0024 05 08    GREF 08 ; *toplevel*    */
  167. pb(OP_CALL); pb(0x00);        /* 0026 0c 00    CALL 00        */
  168.  
  169.     setvalue(getelement(code,1),cvclosure(code,NIL));
  170. }
  171.  
  172. /* xlsymbols - lookup/enter all symbols used by the runtime system */
  173. xlsymbols()
  174. {
  175.     LVAL sym;
  176.  
  177.     /* top-level procedure symbol */
  178.     s_eval = xlenter("EVAL");
  179.  
  180.     /* enter the symbols used by the system */
  181.     true         = xlenter("#T");
  182.     s_unbound     = xlenter("*UNBOUND*");
  183.     s_unassigned = xlenter("#!UNASSIGNED");
  184.  
  185.     /* enter the i/o symbols */
  186.     s_stdin  = xlenter("*STANDARD-INPUT*");
  187.     s_stdout = xlenter("*STANDARD-OUTPUT*");
  188.     s_stderr = xlenter("*ERROR-OUTPUT*");
  189.  
  190.     /* enter the symbols used by the printer */
  191.     s_fixfmt = xlenter("*FIXNUM-FORMAT*");
  192.     s_flofmt = xlenter("*FLONUM-FORMAT*");
  193.  
  194.     /* enter the lambda list keywords */
  195.     lk_optional = xlenter("#!OPTIONAL");
  196.     lk_rest     = xlenter("#!REST");
  197.  
  198.     /* enter symbols needed by the reader */
  199.     c_lpar   = xlenter("(");
  200.     c_rpar   = xlenter(")");
  201.     c_dot    = xlenter(".");
  202.     c_quote  = xlenter("'");
  203.     s_quote  = xlenter("QUOTE");
  204.  
  205.     /* 'else' is a useful synonym for #t in cond clauses */
  206.     sym = xlenter("ELSE");
  207.     setvalue(sym,true);
  208.  
  209.     /* setup stdin/stdout/stderr */
  210.     setvalue(s_stdin,cvport(stdin,PF_INPUT));
  211.     setvalue(s_stdout,cvport(stdout,PF_OUTPUT));
  212.     setvalue(s_stderr,cvport(stderr,PF_OUTPUT));
  213.  
  214.     /* enter *print-case* and its keywords */
  215.     k_upcase    = xlenter("UPCASE");
  216.     k_downcase    = xlenter("DOWNCASE");
  217.     s_printcase    = xlenter("*PRINT-CASE*");
  218.  
  219.     /* get the built-in continuation subrs */
  220.     cs_map1 = getvalue(xlenter("%MAP1"));
  221.     cs_foreach1 = getvalue(xlenter("%FOR-EACH1"));
  222.     cs_withfile1 = getvalue(xlenter("%WITH-FILE1"));
  223.     cs_load1 = getvalue(xlenter("%LOAD1"));
  224.     cs_force1 = getvalue(xlenter("%FORCE1"));
  225.  
  226.     /* initialize xsobj.c */
  227.     obsymbols();
  228. }
  229.