home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLINIT.C < prev    next >
C/C++ Source or Header  |  1988-02-11  |  8KB  |  226 lines
  1. /* xlinit.c - xlisp initialization module */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL true,s_dot,s_unbound;
  10. extern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
  11. extern LVAL s_lambda,s_macro;
  12. extern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout;
  13. extern LVAL s_evalhook,s_applyhook,s_tracelist;
  14. extern LVAL s_tracenable,s_tlimit,s_breakenable;
  15. extern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get,s_eql;
  16. extern LVAL s_svalue,s_sfunction,s_splist;
  17. extern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
  18. extern LVAL k_sescape,k_mescape;
  19. extern LVAL s_ifmt,s_ffmt,s_printcase;
  20. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  21. extern LVAL k_test,k_tnot;
  22. extern LVAL k_direction,k_input,k_output;
  23. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  24. extern LVAL k_verbose,k_print,k_count,k_key,k_upcase,k_downcase;
  25. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  26. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  27. extern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
  28. extern LVAL a_vector,a_closure,a_char,a_ustream;
  29. extern LVAL s_gcflag,s_gchook;
  30. extern FUNDEF funtab[];
  31.  
  32. /* xlinit - xlisp initialization routine */
  33. xlinit()
  34. {
  35.     /* initialize xlisp (must be in this order) */
  36.     xlminit();    /* initialize xldmem.c */
  37.     xldinit();    /* initialize xldbug.c */
  38.  
  39.     /* finish initializing */
  40. #ifdef SAVERESTORE
  41.     if (!xlirestore("xlisp.wks"))
  42. #endif
  43.     initwks();
  44. }
  45.  
  46. /* initwks - build an initial workspace */
  47. LOCAL initwks()
  48. {
  49.     FUNDEF *p;
  50.     int i;
  51.     
  52.     xlsinit();    /* initialize xlsym.c */
  53.     xlsymbols();/* enter all symbols used by the interpreter */
  54.     xlrinit();    /* initialize xlread.c */
  55.     xloinit();    /* initialize xlobj.c */
  56.  
  57.     /* setup defaults */
  58.     setvalue(s_evalhook,NIL);        /* no evalhook function */
  59.     setvalue(s_applyhook,NIL);        /* no applyhook function */
  60.     setvalue(s_tracelist,NIL);        /* no functions being traced */
  61.     setvalue(s_tracenable,NIL);        /* traceback disabled */
  62.     setvalue(s_tlimit,NIL);         /* trace limit infinite */
  63.     setvalue(s_breakenable,NIL);    /* don't enter break loop on errors */
  64.     setvalue(s_gcflag,NIL);        /* don't show gc information */
  65.     setvalue(s_gchook,NIL);        /* no gc hook active */
  66.     setvalue(s_ifmt,cvstring(IFMT));    /* integer print format */
  67.     setvalue(s_ffmt,cvstring("%g"));    /* float print format */
  68.     setvalue(s_printcase,k_upcase);    /* upper case output of symbols */
  69.  
  70.     /* install the built-in functions and special forms */
  71.     for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p)
  72.     if (p->fd_name)
  73.         xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
  74.  
  75.     /* add some synonyms */
  76.     setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
  77.     setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
  78.     setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
  79.     setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
  80.     setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
  81.     setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
  82. }
  83.  
  84. /* xlsymbols - enter all of the symbols used by the interpreter */
  85. xlsymbols()
  86. {
  87.     LVAL sym;
  88.  
  89.     /* enter the unbound variable indicator (must be first) */
  90.     s_unbound = xlenter("*UNBOUND*");
  91.     setvalue(s_unbound,s_unbound);
  92.  
  93.     /* enter the 't' symbol */
  94.     true = xlenter("T");
  95.     setvalue(true,true);
  96.  
  97.     /* enter some important symbols */
  98.     s_dot    = xlenter(".");
  99.     s_quote    = xlenter("QUOTE");
  100.     s_function    = xlenter("FUNCTION");
  101.     s_bquote    = xlenter("BACKQUOTE");
  102.     s_comma    = xlenter("COMMA");
  103.     s_comat    = xlenter("COMMA-AT");
  104.     s_lambda    = xlenter("LAMBDA");
  105.     s_macro    = xlenter("MACRO");
  106.     s_eql    = xlenter("EQL");
  107.     s_ifmt    = xlenter("*INTEGER-FORMAT*");
  108.     s_ffmt    = xlenter("*FLOAT-FORMAT*");
  109.  
  110.     /* symbols set by the read-eval-print loop */
  111.     s_1plus    = xlenter("+");
  112.     s_2plus    = xlenter("++");
  113.     s_3plus    = xlenter("+++");
  114.     s_1star    = xlenter("*");
  115.     s_2star    = xlenter("**");
  116.     s_3star    = xlenter("***");
  117.     s_minus    = xlenter("-");
  118.  
  119.     /* enter setf place specifiers */
  120.     s_setf    = xlenter("*SETF*");
  121.     s_car    = xlenter("CAR");
  122.     s_cdr    = xlenter("CDR");
  123.     s_nth    = xlenter("NTH");
  124.     s_aref    = xlenter("AREF");
  125.     s_get    = xlenter("GET");
  126.     s_svalue    = xlenter("SYMBOL-VALUE");
  127.     s_sfunction    = xlenter("SYMBOL-FUNCTION");
  128.     s_splist    = xlenter("SYMBOL-PLIST");
  129.  
  130.     /* enter the readtable variable and keywords */
  131.     s_rtable    = xlenter("*READTABLE*");
  132.     k_wspace    = xlenter(":WHITE-SPACE");
  133.     k_const    = xlenter(":CONSTITUENT");
  134.     k_nmacro    = xlenter(":NMACRO");
  135.     k_tmacro    = xlenter(":TMACRO");
  136.     k_sescape    = xlenter(":SESCAPE");
  137.     k_mescape    = xlenter(":MESCAPE");
  138.  
  139.     /* enter parameter list keywords */
  140.     k_test    = xlenter(":TEST");
  141.     k_tnot    = xlenter(":TEST-NOT");
  142.  
  143.     /* "open" keywords */
  144.     k_direction = xlenter(":DIRECTION");
  145.     k_input     = xlenter(":INPUT");
  146.     k_output    = xlenter(":OUTPUT");
  147.  
  148.     /* enter *print-case* symbol and keywords */
  149.     s_printcase = xlenter("*PRINT-CASE*");
  150.     k_upcase    = xlenter(":UPCASE");
  151.     k_downcase  = xlenter(":DOWNCASE");
  152.  
  153.     /* other keywords */
  154.     k_start    = xlenter(":START");
  155.     k_end    = xlenter(":END");
  156.     k_1start    = xlenter(":START1");
  157.     k_1end    = xlenter(":END1");
  158.     k_2start    = xlenter(":START2");
  159.     k_2end    = xlenter(":END2");
  160.     k_verbose    = xlenter(":VERBOSE");
  161.     k_print    = xlenter(":PRINT");
  162.     k_count    = xlenter(":COUNT");
  163.     k_key    = xlenter(":KEY");
  164.  
  165.     /* enter lambda list keywords */
  166.     lk_optional    = xlenter("&OPTIONAL");
  167.     lk_rest    = xlenter("&REST");
  168.     lk_key    = xlenter("&KEY");
  169.     lk_aux    = xlenter("&AUX");
  170.     lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS");
  171.  
  172.     /* enter *standard-input*, *standard-output* and *error-output* */
  173.     s_stdin = xlenter("*STANDARD-INPUT*");
  174.     setvalue(s_stdin,cvfile(stdin));
  175.     s_stdout = xlenter("*STANDARD-OUTPUT*");
  176.     setvalue(s_stdout,cvfile(stdout));
  177.     s_stderr = xlenter("*ERROR-OUTPUT*");
  178.     setvalue(s_stderr,cvfile(stderr));
  179.  
  180.     /* enter *debug-io* and *trace-output* */
  181.     s_debugio = xlenter("*DEBUG-IO*");
  182.     setvalue(s_debugio,getvalue(s_stderr));
  183.     s_traceout = xlenter("*TRACE-OUTPUT*");
  184.     setvalue(s_traceout,getvalue(s_stderr));
  185.  
  186.     /* enter the eval and apply hook variables */
  187.     s_evalhook = xlenter("*EVALHOOK*");
  188.     s_applyhook = xlenter("*APPLYHOOK*");
  189.  
  190.     /* enter the symbol pointing to the list of functions being traced */
  191.     s_tracelist = xlenter("*TRACELIST*");
  192.  
  193.     /* enter the error traceback and the error break enable flags */
  194.     s_tracenable = xlenter("*TRACENABLE*");
  195.     s_tlimit = xlenter("*TRACELIMIT*");
  196.     s_breakenable = xlenter("*BREAKENABLE*");
  197.  
  198.     /* enter a symbol to control printing of garbage collection messages */
  199.     s_gcflag = xlenter("*GC-FLAG*");
  200.     s_gchook = xlenter("*GC-HOOK*");
  201.  
  202.     /* enter a copyright notice into the oblist */
  203.     sym = xlenter("**Copyright-1988-by-David-Betz**");
  204.     setvalue(sym,true);
  205.  
  206.     /* enter type names */
  207.     a_subr    = xlenter("SUBR");
  208.     a_fsubr    = xlenter("FSUBR");
  209.     a_cons    = xlenter("CONS");
  210.     a_symbol    = xlenter("SYMBOL");
  211.     a_fixnum    = xlenter("FIXNUM");
  212.     a_flonum    = xlenter("FLONUM");
  213.     a_string    = xlenter("STRING");
  214.     a_object    = xlenter("OBJECT");
  215.     a_stream    = xlenter("FILE-STREAM");
  216.     a_vector    = xlenter("ARRAY");
  217.     a_closure    = xlenter("CLOSURE");
  218.     a_char      = xlenter("CHARACTER");
  219.     a_ustream    = xlenter("UNNAMED-STREAM");
  220.  
  221.     /* add the object-oriented programming symbols and os specific stuff */
  222.     obsymbols();    /* object-oriented programming symbols */
  223.     ossymbols();    /* os specific symbols */
  224. }
  225.  
  226.