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