home *** CD-ROM | disk | FTP | other *** search
/ Stars of Shareware: Programmierung / SOURCE.mdf / programm / windows / c / xlisp21w / sources / xlinit.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-02-27  |  14.4 KB  |  449 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,obarray;
  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. #ifdef RATIOS
  21. extern LVAL s_rfmt;
  22. #endif
  23. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  24. extern LVAL k_test,k_tnot;
  25. extern LVAL k_direction,k_input,k_output;
  26. extern LVAL k_io, k_elementtype;
  27. extern LVAL s_termio, k_exist, k_nexist, k_error, k_rename, k_newversion;
  28. extern LVAL k_overwrite, k_append, k_supersede, k_rendel, k_probe, k_create;
  29. extern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
  30. extern LVAL k_verbose,k_print,k_count,k_upcase,k_downcase;
  31. extern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
  32. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  33. extern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
  34. extern LVAL a_vector,a_closure,a_char,a_ustream;
  35. #ifdef RATIOS
  36. extern LVAL a_ratio, a_rational;
  37. #endif
  38. extern LVAL s_gcflag,s_gchook;
  39. extern LVAL s_dispmacros;
  40. extern LVAL s_printlevel,s_printlength;
  41. extern LVAL s_strtypep, s_mkstruct, s_cpystruct, s_strref, s_strset;
  42. extern LVAL s_x, s_s, s_sslots;
  43. extern LVAL k_concname, k_include;
  44. extern LVAL s_elt;
  45. extern LVAL a_list, a_number, a_null, a_atom, a_anystream;
  46. extern LVAL s_and, s_or, s_not, s_satisfies, s_member;
  47. extern LVAL a_struct;
  48. #ifdef HASHFCNS
  49. extern LVAL s_gethash, a_hashtable, k_size;
  50. #endif
  51. #ifdef REDUCE
  52. extern LVAL k_ivalue;
  53. #endif
  54. #ifdef KEYARG
  55. extern LVAL k_key;
  56. #endif
  57. #ifdef COMPLX
  58. extern LVAL a_complex;
  59. #endif
  60. #ifdef DOSINPUT
  61. extern LVAL s_dosinput;     /* TAA mod */
  62. #endif
  63. #ifdef RANDOM
  64. extern LVAL s_randomstate, a_randomstate, k_data;
  65. #endif
  66. #ifdef READTABLECASE
  67. extern LVAL s_rtcase, k_preserve, k_invert;
  68. #endif
  69.  
  70.  
  71.  
  72.  
  73. extern FUNDEF funtab[];
  74.  
  75. /* Forward declarations */
  76. #ifdef ANSI
  77. FORWARD VOID XNEAR initwks(void);
  78. #else
  79. FORWARD VOID initwks();
  80. #endif
  81.  
  82. /* TAA MOD -- most compilers I use will generate better code calling
  83.    a static function. Because we have many calls of xlenter here, (which
  84.    will only execute once per session), I'm calling xlenter through a
  85.    static function senter() */
  86.  
  87. #ifdef ANSI
  88. LVAL XNEAR senter(char XNEAR *str)
  89. {
  90.     return xlenter(str);
  91. }
  92. #else
  93. #define senter(x) xlenter(x)
  94. #endif
  95.  
  96. /* $putpatch.c$: "MODULE_XLINIT_C_GLOBALS" */
  97.  
  98. /* xlinit - xlisp initialization routine */
  99. int xlinit(resfile) /* TAA Mod -- return true if load of init.lsp needed */
  100.         char *resfile;
  101. {
  102.     /* initialize xlisp (must be in this order) */
  103.     xlminit();  /* initialize xldmem.c */
  104.     xldinit();  /* initialize xldbug.c */
  105.  
  106. /* finish initializing */
  107. #ifdef SAVERESTORE
  108.     if (*resfile=='\0' || !xlirestore(resfile)) {
  109.         initwks();
  110.         /* $putpatch.c$: "MODULE_XLINIT_C_XLINIT" */
  111.         return TRUE;
  112.     }
  113.     return FALSE;
  114. #else
  115.     initwks();
  116.     /* $putpatch.c$: "MODULE_XLINIT_C_XLINIT" */
  117.     return TRUE;
  118. #endif
  119. }
  120.  
  121. /* initwks - build an initial workspace */
  122. LOCAL VOID XNEAR initwks()
  123. {
  124.     FUNDEF *p;
  125.     int i;
  126.     
  127.     xlsinit();  /* initialize xlsym.c */
  128.     xlsymbols();/* enter all symbols used by the interpreter */
  129.     xlrinit();  /* initialize xlread.c */
  130.     xloinit();  /* initialize xlobj.c */
  131.  
  132.     /* setup defaults */
  133.  
  134.     /*can't mark as unbound until *unbound* created*/
  135.     setfunction(s_unbound, s_unbound);
  136.     setfunction(obarray, s_unbound);
  137.     setfunction(NIL, s_unbound);
  138.  
  139.     setsvalue(s_evalhook, NIL);         /* no evalhook function */
  140.     setsvalue(s_applyhook, NIL);        /* no applyhook function */
  141.     setsvalue(s_tracelist, NIL);        /* no functions being traced */
  142.     setsvalue(s_tracenable, NIL);       /* traceback disabled */
  143.     setsvalue(s_tlimit, NIL);           /* trace limit infinite */
  144.     setsvalue(s_breakenable, NIL);      /* don't enter break loop on errors */
  145.     setsvalue(s_gcflag, NIL);           /* don't show gc information */
  146.     setsvalue(s_gchook, NIL);           /* no gc hook active */
  147.  
  148.     setsvalue(s_ifmt, NIL);             /* default integer print format */
  149.     setsvalue(s_ffmt, NIL);             /* float print format */
  150. #ifdef RATIOS
  151.     setsvalue(s_rfmt, NIL);             /* integer print format */
  152. #endif
  153.  
  154. #ifdef RANDOM
  155.     setsvalue(s_randomstate, newrandom(1L));    /* random state */
  156. #endif
  157.     setsvalue(s_printcase, k_upcase);   /* upper case output of symbols */
  158.     setsvalue(s_printlevel, NIL);       /* printing depth is infinite */
  159.     setsvalue(s_printlength, NIL);      /* printing length is infinite */
  160. #ifdef READTABLECASE
  161.     setsvalue(s_rtcase, k_upcase);      /* read converting to uppercase */
  162. #endif
  163.     setsvalue(s_dispmacros, NIL);       /* don't displace macros */
  164.  
  165.     /* install the built-in functions and special forms */
  166.     for (i = 0, p = funtab; (p->fd_subr) != (LVAL(*)())NULL; ++i, ++p)
  167.         if (p->fd_name != NULL)
  168.             xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
  169.  
  170.     /* add some synonyms */
  171.     setfunction(senter("NOT"), getfunction(senter("NULL")));
  172.     setfunction(senter("FIRST"), getfunction(senter("CAR")));
  173.     setfunction(senter("SECOND"), getfunction(senter("CADR")));
  174.     setfunction(senter("THIRD"), getfunction(senter("CADDR")));
  175.     setfunction(senter("FOURTH"), getfunction(senter("CADDDR")));
  176.     setfunction(senter("REST"), getfunction(senter("CDR")));
  177. }
  178.  
  179. /* xlsymbols - enter all of the symbols used by the interpreter */
  180. VOID xlsymbols()
  181. {
  182.     LVAL sym;
  183.  
  184.     /* enter the unbound variable indicator (must be first) */
  185.     s_unbound = senter("*UNBOUND*");
  186.     defconstant(s_unbound,s_unbound);   /* TAA mod -- was setvalue */
  187.  
  188.     /* put NIL in oblist */
  189.     {   /* duplicate code in xlenter, with different ending */
  190.         char *name= "NIL";
  191.         LVAL array = getvalue(obarray);
  192.         int i = hash(name, HSIZE);
  193.         
  194.         for (sym = getelement(array,i); !null(sym); sym = cdr(sym))
  195.             if (STRCMP(name, getstring(getpname(car(sym)))) == 0)
  196.                 goto noEnterNecessary;
  197.  
  198.         sym = consd(getelement(array,i));
  199.         rplaca(sym, NIL);
  200.         setelement(array, i, sym);
  201. noEnterNecessary: ;
  202.     }
  203.  
  204.     /* enter the 't' symbol */
  205.     true = senter("T");
  206.     defconstant(true, true);            /* TAA mod -- was setvalue */
  207.  
  208.     /* enter some other constants */
  209.  
  210. #ifdef TIMES
  211.     sym = senter("INTERNAL-TIME-UNITS-PER-SECOND");
  212.     defconstant(sym, cvfixnum((FIXTYPE) ticks_per_second()));
  213. #endif
  214. #ifdef COMPLX
  215.     sym = senter("PI");
  216.     defconstant(sym, cvflonum((FLOTYPE) PI));
  217. #endif
  218.  
  219.  
  220.     /* enter some important symbols */
  221.     s_dot       = senter(".");
  222.     s_quote     = senter("QUOTE");
  223.     s_function  = senter("FUNCTION");
  224.     s_bquote    = senter("BACKQUOTE");
  225.     s_comma     = senter("COMMA");
  226.     s_comat     = senter("COMMA-AT");
  227.     s_lambda    = senter("LAMBDA");
  228.     s_macro     = senter("MACRO");
  229.     s_eql       = senter("EQL");
  230.     s_ifmt      = senter("*INTEGER-FORMAT*");
  231.     s_ffmt      = senter("*FLOAT-FORMAT*");
  232. #ifdef RATIOS
  233.     s_rfmt      = senter("*RATIO-FORMAT*");
  234. #endif
  235.  
  236.     /* symbols set by the read-eval-print loop */
  237.     s_1plus     = senter("+");
  238.     s_2plus     = senter("++");
  239.     s_3plus     = senter("+++");
  240.     s_1star     = senter("*");
  241.     s_2star     = senter("**");
  242.     s_3star     = senter("***");
  243.     s_minus     = senter("-");
  244.  
  245.     /* enter setf place specifiers */
  246.     s_setf      = senter("*SETF*");
  247.     s_car       = senter("CAR");
  248.     s_cdr       = senter("CDR");
  249.     s_nth       = senter("NTH");
  250.     s_aref      = senter("AREF");
  251.     s_get       = senter("GET");
  252.     s_svalue    = senter("SYMBOL-VALUE");
  253.     s_sfunction = senter("SYMBOL-FUNCTION");
  254.     s_splist    = senter("SYMBOL-PLIST");
  255.     s_elt       = senter("ELT");
  256. #ifdef HASHFCNS
  257.     s_gethash   = senter("GETHASH");
  258. #endif
  259.  
  260.     /* enter the readtable variable and keywords */
  261.     s_rtable    = senter("*READTABLE*");
  262.     k_wspace    = senter(":WHITE-SPACE");
  263.     k_const     = senter(":CONSTITUENT");
  264.     k_nmacro    = senter(":NMACRO");
  265.     k_tmacro    = senter(":TMACRO");
  266.     k_sescape   = senter(":SESCAPE");
  267.     k_mescape   = senter(":MESCAPE");
  268.  
  269.     /* enter parameter list keywords */
  270.     k_test      = senter(":TEST");
  271.     k_tnot      = senter(":TEST-NOT");
  272.  
  273.     /* "open" keywords */
  274.     k_direction = senter(":DIRECTION");
  275.     k_input     = senter(":INPUT");
  276.     k_output    = senter(":OUTPUT");
  277.     k_io        = senter(":IO");
  278.     k_probe     = senter(":PROBE");
  279.     k_elementtype = senter(":ELEMENT-TYPE");
  280.     k_exist     = senter(":IF-EXISTS");
  281.     k_nexist    = senter(":IF-DOES-NOT-EXIST");
  282.     k_error     = senter(":ERROR");
  283.     k_rename    = senter(":RENAME");
  284.     k_newversion = senter(":NEW-VERSION");
  285.     k_overwrite = senter(":OVERWRITE");
  286.     k_append    = senter(":APPEND");
  287.     k_supersede = senter(":SUPERSEDE");
  288.     k_rendel    = senter(":RENAME-AND-DELETE");
  289.     k_create    = senter(":CREATE");
  290.  
  291.     /* enter *print-case* symbol and keywords */
  292.     s_printcase = senter("*PRINT-CASE*");
  293.     k_upcase    = senter(":UPCASE");
  294.     k_downcase  = senter(":DOWNCASE");
  295.  
  296. #ifdef READTABLECASE
  297.     /* enter *readtable-case* symbol and keywords */
  298.     s_rtcase    = senter("*READTABLE-CASE*");
  299.     k_preserve  = senter(":PRESERVE");
  300.     k_invert    = senter(":INVERT");
  301. #endif
  302.  
  303.     /* more printing symbols */
  304.     s_printlevel= senter("*PRINT-LEVEL*");
  305.     s_printlength = senter("*PRINT-LENGTH*");
  306.  
  307.     /* other keywords */
  308.     k_start     = senter(":START");
  309.     k_end       = senter(":END");
  310.     k_1start    = senter(":START1");
  311.     k_1end      = senter(":END1");
  312.     k_2start    = senter(":START2");
  313.     k_2end      = senter(":END2");
  314.     k_verbose   = senter(":VERBOSE");
  315.     k_print     = senter(":PRINT");
  316.     k_count     = senter(":COUNT");
  317.     k_concname  = senter(":CONC-NAME"); /* TAA-- added to save xlenters */
  318.     k_include   = senter(":INCLUDE");
  319.  
  320. #ifdef KEYARG   
  321.     k_key       = senter(":KEY");
  322. #endif
  323.  
  324. #ifdef REDUCE
  325.     k_ivalue    = senter(":INITIAL-VALUE");
  326. #endif
  327.  
  328. #ifdef HASHFCNS
  329.     k_size = senter(":SIZE");
  330. #endif
  331.  
  332. #ifdef RANDOM
  333.     k_data = senter(":DATA");
  334. #endif
  335.  
  336.  
  337.     /* enter lambda list keywords */
  338.     lk_optional = senter("&OPTIONAL");
  339.     lk_rest     = senter("&REST");
  340.     lk_key      = senter("&KEY");
  341.     lk_aux      = senter("&AUX");
  342.     lk_allow_other_keys = senter("&ALLOW-OTHER-KEYS");
  343.  
  344.     /* enter *standard-input*, *standard-output* and *error-output* */
  345.     /* TAA Modified so that stderr (CONSOLE) is used if no redirection */
  346.  
  347.     s_stderr = senter("*ERROR-OUTPUT*");
  348.     setsvalue(s_stderr,cvfile(CONSOLE,S_FORREADING|S_FORWRITING));
  349.     s_termio = senter("*TERMINAL-IO*");
  350.     setsvalue(s_termio,getvalue(s_stderr));
  351.     s_stdin = senter("*STANDARD-INPUT*");
  352.     setsvalue(s_stdin, getvalue(s_stderr));
  353.     s_stdout = senter("*STANDARD-OUTPUT*");
  354.     setsvalue(s_stdout, getvalue(s_stderr));
  355.  
  356.     /* enter *debug-io* and *trace-output* */
  357.     s_debugio = senter("*DEBUG-IO*");
  358.     setsvalue(s_debugio,getvalue(s_stderr));
  359.     s_traceout = senter("*TRACE-OUTPUT*");
  360.     setsvalue(s_traceout,getvalue(s_stderr));
  361.  
  362.     /* enter the eval and apply hook variables */
  363.     s_evalhook = senter("*EVALHOOK*");
  364.     s_applyhook = senter("*APPLYHOOK*");
  365.  
  366.     /* enter the symbol pointing to the list of functions being traced */
  367.     s_tracelist = senter("*TRACELIST*");
  368.  
  369.     /* enter the error traceback and the error break enable flags */
  370.     s_tracenable = senter("*TRACENABLE*");
  371.     s_tlimit = senter("*TRACELIMIT*");
  372.     s_breakenable = senter("*BREAKENABLE*");
  373.  
  374.     /* enter symbols to control printing of garbage collection messages */
  375.     s_gcflag = senter("*GC-FLAG*");
  376.     s_gchook = senter("*GC-HOOK*");
  377.  
  378.     /* enter symbol to control displacing of macros with expanded version */
  379.     s_dispmacros = senter("*DISPLACE-MACROS*");
  380.  
  381.     /* enter a copyright notice into the oblist */
  382.     sym = senter("**Copyright-1988-by-David-Betz**");
  383.     setsvalue(sym,true);
  384.  
  385.     /* enter type names */
  386.     a_subr      = senter("SUBR");
  387.     a_fsubr     = senter("FSUBR");
  388.     a_cons      = senter("CONS");
  389.     a_symbol    = senter("SYMBOL");
  390.     a_fixnum    = senter("FIXNUM");
  391.     a_flonum    = senter("FLONUM");
  392.     a_string    = senter("STRING");
  393.     a_object    = senter("OBJECT");
  394.     a_stream    = senter("FILE-STREAM");
  395.     a_vector    = senter("ARRAY");
  396.     a_closure   = senter("CLOSURE");
  397.     a_char      = senter("CHARACTER");
  398.     a_ustream   = senter("UNNAMED-STREAM");
  399.     a_list      = senter("LIST");
  400.     a_number    = senter("NUMBER");
  401.     a_null      = senter("NULL");
  402.     a_atom      = senter("ATOM");
  403.     a_anystream = senter("STREAM");
  404.     s_and       = senter("AND");
  405.     s_or        = senter("OR");
  406.     s_not       = senter("NOT");
  407.     s_satisfies = senter("SATISFIES");
  408.     s_member    = senter("MEMBER");
  409.     a_struct    = senter("STRUCT");
  410. #ifdef COMPLX
  411.     a_complex   = senter("COMPLEX");
  412. #endif
  413. #ifdef HASHFCNS
  414.     a_hashtable = senter("HASH-TABLE");
  415. #endif
  416. #ifdef RATIOS
  417.     a_ratio     = senter("RATIO");
  418.     a_rational  = senter("RATIONAL");
  419. #endif
  420.  
  421.  
  422.     /* struct feature symbols */
  423.     s_strtypep  = senter("%STRUCT-TYPE-P");
  424.     s_mkstruct  = senter("%MAKE-STRUCT");
  425.     s_cpystruct = senter("%COPY-STRUCT");
  426.     s_strref    = senter("%STRUCT-REF");
  427.     s_strset    = senter("%STRUCT-SET");
  428.     s_x         = senter("X");
  429.     s_s         = senter("S");
  430.     s_sslots    = senter("*STRUCT-SLOTS*");
  431.  
  432.  
  433. #ifdef RANDOM
  434.     s_randomstate = senter("*RANDOM-STATE*");
  435.     a_randomstate = senter("RANDOM-STATE");
  436.     sym = cons(NIL,NIL);    /* add to *struct-slots* property ((data nil)) */
  437.     sym = cons(senter("DATA"),sym);
  438.     sym = consa(sym);
  439.     xlputprop(a_randomstate,sym,s_sslots);
  440. #endif
  441.  
  442.  
  443.     /* add the object-oriented programming symbols and os specific stuff */
  444.     obsymbols();        /* object-oriented programming symbols */
  445.     ossymbols();        /* os specific symbols */
  446.     /* $putpatch.c$: "MODULE_XLINIT_C_XLSYMBOLS" */
  447. }
  448.  
  449.