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