home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / lisp / xlisp / xlsp21_src / sources / c / xlinit < prev    next >
Encoding:
Text File  |  1992-04-25  |  14.3 KB  |  457 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 NEAR 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 NEAR senter(char NEAR *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 NEAR 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. #ifdef DOSINPUT
  164.     setsvalue(s_dosinput, NIL);         /* use XLISP line editing */
  165. #endif
  166.     setsvalue(s_dispmacros, NIL);       /* don't displace macros */
  167.  
  168.     /* install the built-in functions and special forms */
  169.     for (i = 0, p = funtab; (p->fd_subr) != (LVAL(*)())NULL; ++i, ++p)
  170.         if (p->fd_name != NULL)
  171.             xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
  172.  
  173.     /* add some synonyms */
  174.     setfunction(senter("NOT"), getfunction(senter("NULL")));
  175.     setfunction(senter("FIRST"), getfunction(senter("CAR")));
  176.     setfunction(senter("SECOND"), getfunction(senter("CADR")));
  177.     setfunction(senter("THIRD"), getfunction(senter("CADDR")));
  178.     setfunction(senter("FOURTH"), getfunction(senter("CADDDR")));
  179.     setfunction(senter("REST"), getfunction(senter("CDR")));
  180. }
  181.  
  182. /* xlsymbols - enter all of the symbols used by the interpreter */
  183. VOID xlsymbols()
  184. {
  185.     LVAL sym;
  186.  
  187.     /* enter the unbound variable indicator (must be first) */
  188.     s_unbound = senter("*UNBOUND*");
  189.     defconstant(s_unbound,s_unbound);   /* TAA mod -- was setvalue */
  190.  
  191.     /* put NIL in oblist */
  192.     {   /* duplicate code in xlenter, with different ending */
  193.         char *name= "NIL";
  194.         LVAL array = getvalue(obarray);
  195.         int i = hash(name, HSIZE);
  196.         
  197.         for (sym = getelement(array,i); !null(sym); sym = cdr(sym))
  198.             if (STRCMP(name, getstring(getpname(car(sym)))) == 0)
  199.                 goto noEnterNecessary;
  200.  
  201.         sym = consd(getelement(array,i));
  202.         rplaca(sym, NIL);
  203.         setelement(array, i, sym);
  204. noEnterNecessary: ;
  205.     }
  206.  
  207.     /* enter the 't' symbol */
  208.     true = senter("T");
  209.     defconstant(true, true);            /* TAA mod -- was setvalue */
  210.  
  211.     /* enter some other constants */
  212.  
  213. #ifdef TIMES
  214.     sym = senter("INTERNAL-TIME-UNITS-PER-SECOND");
  215.     defconstant(sym, cvfixnum((FIXTYPE) ticks_per_second()));
  216. #endif
  217. #ifdef COMPLX
  218.     sym = senter("PI");
  219.     defconstant(sym, cvflonum((FLOTYPE) PI));
  220. #endif
  221.  
  222.  
  223.     /* enter some important symbols */
  224.     s_dot       = senter(".");
  225.     s_quote     = senter("QUOTE");
  226.     s_function  = senter("FUNCTION");
  227.     s_bquote    = senter("BACKQUOTE");
  228.     s_comma     = senter("COMMA");
  229.     s_comat     = senter("COMMA-AT");
  230.     s_lambda    = senter("LAMBDA");
  231.     s_macro     = senter("MACRO");
  232.     s_eql       = senter("EQL");
  233.     s_ifmt      = senter("*INTEGER-FORMAT*");
  234.     s_ffmt      = senter("*FLOAT-FORMAT*");
  235. #ifdef RATIOS
  236.     s_rfmt      = senter("*RATIO-FORMAT*");
  237. #endif
  238.  
  239.     /* symbols set by the read-eval-print loop */
  240.     s_1plus     = senter("+");
  241.     s_2plus     = senter("++");
  242.     s_3plus     = senter("+++");
  243.     s_1star     = senter("*");
  244.     s_2star     = senter("**");
  245.     s_3star     = senter("***");
  246.     s_minus     = senter("-");
  247.  
  248.     /* enter setf place specifiers */
  249.     s_setf      = senter("*SETF*");
  250.     s_car       = senter("CAR");
  251.     s_cdr       = senter("CDR");
  252.     s_nth       = senter("NTH");
  253.     s_aref      = senter("AREF");
  254.     s_get       = senter("GET");
  255.     s_svalue    = senter("SYMBOL-VALUE");
  256.     s_sfunction = senter("SYMBOL-FUNCTION");
  257.     s_splist    = senter("SYMBOL-PLIST");
  258.     s_elt       = senter("ELT");
  259. #ifdef HASHFCNS
  260.     s_gethash   = senter("GETHASH");
  261. #endif
  262.  
  263.     /* enter the readtable variable and keywords */
  264.     s_rtable    = senter("*READTABLE*");
  265.     k_wspace    = senter(":WHITE-SPACE");
  266.     k_const     = senter(":CONSTITUENT");
  267.     k_nmacro    = senter(":NMACRO");
  268.     k_tmacro    = senter(":TMACRO");
  269.     k_sescape   = senter(":SESCAPE");
  270.     k_mescape   = senter(":MESCAPE");
  271.  
  272.     /* enter parameter list keywords */
  273.     k_test      = senter(":TEST");
  274.     k_tnot      = senter(":TEST-NOT");
  275.  
  276.     /* "open" keywords */
  277.     k_direction = senter(":DIRECTION");
  278.     k_input     = senter(":INPUT");
  279.     k_output    = senter(":OUTPUT");
  280.     k_io        = senter(":IO");
  281.     k_probe     = senter(":PROBE");
  282.     k_elementtype = senter(":ELEMENT-TYPE");
  283.     k_exist     = senter(":IF-EXISTS");
  284.     k_nexist    = senter(":IF-DOES-NOT-EXIST");
  285.     k_error     = senter(":ERROR");
  286.     k_rename    = senter(":RENAME");
  287.     k_newversion = senter(":NEW-VERSION");
  288.     k_overwrite = senter(":OVERWRITE");
  289.     k_append    = senter(":APPEND");
  290.     k_supersede = senter(":SUPERSEDE");
  291.     k_rendel    = senter(":RENAME-AND-DELETE");
  292.     k_create    = senter(":CREATE");
  293.  
  294.     /* enter *print-case* symbol and keywords */
  295.     s_printcase = senter("*PRINT-CASE*");
  296.     k_upcase    = senter(":UPCASE");
  297.     k_downcase  = senter(":DOWNCASE");
  298.  
  299. #ifdef READTABLECASE
  300.     /* enter *readtable-case* symbol and keywords */
  301.     s_rtcase    = senter("*READTABLE-CASE*");
  302.     k_preserve  = senter(":PRESERVE");
  303.     k_invert    = senter(":INVERT");
  304. #endif
  305.  
  306.     /* more printing symbols */
  307.     s_printlevel= senter("*PRINT-LEVEL*");
  308.     s_printlength = senter("*PRINT-LENGTH*");
  309. #ifdef DOSINPUT
  310.     s_dosinput  = senter("*DOS-INPUT*");
  311. #endif
  312.     
  313.     /* other keywords */
  314.     k_start     = senter(":START");
  315.     k_end       = senter(":END");
  316.     k_1start    = senter(":START1");
  317.     k_1end      = senter(":END1");
  318.     k_2start    = senter(":START2");
  319.     k_2end      = senter(":END2");
  320.     k_verbose   = senter(":VERBOSE");
  321.     k_print     = senter(":PRINT");
  322.     k_count     = senter(":COUNT");
  323.     k_concname  = senter(":CONC-NAME"); /* TAA-- added to save xlenters */
  324.     k_include   = senter(":INCLUDE");
  325.  
  326. #ifdef KEYARG   
  327.     k_key       = senter(":KEY");
  328. #endif
  329.  
  330. #ifdef REDUCE
  331.     k_ivalue    = senter(":INITIAL-VALUE");
  332. #endif
  333.  
  334. #ifdef HASHFCNS
  335.     k_size = senter(":SIZE");
  336. #endif
  337.  
  338. #ifdef RANDOM
  339.     k_data = senter(":DATA");
  340. #endif
  341.  
  342.  
  343.     /* enter lambda list keywords */
  344.     lk_optional = senter("&OPTIONAL");
  345.     lk_rest     = senter("&REST");
  346.     lk_key      = senter("&KEY");
  347.     lk_aux      = senter("&AUX");
  348.     lk_allow_other_keys = senter("&ALLOW-OTHER-KEYS");
  349.  
  350.     /* enter *standard-input*, *standard-output* and *error-output* */
  351.     /* TAA Modified so that stderr (CONSOLE) is used if no redirection */
  352.  
  353.     s_stderr = senter("*ERROR-OUTPUT*");
  354.     setsvalue(s_stderr,cvfile(CONSOLE,S_FORREADING|S_FORWRITING));
  355.     s_termio = senter("*TERMINAL-IO*");
  356.     setsvalue(s_termio,getvalue(s_stderr));
  357.     s_stdin = senter("*STANDARD-INPUT*");
  358.     setsvalue(s_stdin,redirectin ? 
  359.         cvfile(STDIN,S_FORREADING): getvalue(s_stderr));
  360.     s_stdout = senter("*STANDARD-OUTPUT*");
  361.     setsvalue(s_stdout,redirectout ? 
  362.         cvfile(STDOUT,S_FORWRITING): getvalue(s_stderr));
  363.  
  364.     /* enter *debug-io* and *trace-output* */
  365.     s_debugio = senter("*DEBUG-IO*");
  366.     setsvalue(s_debugio,getvalue(s_stderr));
  367.     s_traceout = senter("*TRACE-OUTPUT*");
  368.     setsvalue(s_traceout,getvalue(s_stderr));
  369.  
  370.     /* enter the eval and apply hook variables */
  371.     s_evalhook = senter("*EVALHOOK*");
  372.     s_applyhook = senter("*APPLYHOOK*");
  373.  
  374.     /* enter the symbol pointing to the list of functions being traced */
  375.     s_tracelist = senter("*TRACELIST*");
  376.  
  377.     /* enter the error traceback and the error break enable flags */
  378.     s_tracenable = senter("*TRACENABLE*");
  379.     s_tlimit = senter("*TRACELIMIT*");
  380.     s_breakenable = senter("*BREAKENABLE*");
  381.  
  382.     /* enter symbols to control printing of garbage collection messages */
  383.     s_gcflag = senter("*GC-FLAG*");
  384.     s_gchook = senter("*GC-HOOK*");
  385.  
  386.     /* enter symbol to control displacing of macros with expanded version */
  387.     s_dispmacros = senter("*DISPLACE-MACROS*");
  388.  
  389.     /* enter a copyright notice into the oblist */
  390.     sym = senter("**Copyright-1988-by-David-Betz**");
  391.     setsvalue(sym,true);
  392.  
  393.     /* enter type names */
  394.     a_subr      = senter("SUBR");
  395.     a_fsubr     = senter("FSUBR");
  396.     a_cons      = senter("CONS");
  397.     a_symbol    = senter("SYMBOL");
  398.     a_fixnum    = senter("FIXNUM");
  399.     a_flonum    = senter("FLONUM");
  400.     a_string    = senter("STRING");
  401.     a_object    = senter("OBJECT");
  402.     a_stream    = senter("FILE-STREAM");
  403.     a_vector    = senter("ARRAY");
  404.     a_closure   = senter("CLOSURE");
  405.     a_char      = senter("CHARACTER");
  406.     a_ustream   = senter("UNNAMED-STREAM");
  407.     a_list      = senter("LIST");
  408.     a_number    = senter("NUMBER");
  409.     a_null      = senter("NULL");
  410.     a_atom      = senter("ATOM");
  411.     a_anystream = senter("STREAM");
  412.     s_and       = senter("AND");
  413.     s_or        = senter("OR");
  414.     s_not       = senter("NOT");
  415.     s_satisfies = senter("SATISFIES");
  416.     s_member    = senter("MEMBER");
  417.     a_struct    = senter("STRUCT");
  418. #ifdef COMPLX
  419.     a_complex   = senter("COMPLEX");
  420. #endif
  421. #ifdef HASHFCNS
  422.     a_hashtable = senter("HASH-TABLE");
  423. #endif
  424. #ifdef RATIOS
  425.     a_ratio     = senter("RATIO");
  426.     a_rational  = senter("RATIONAL");
  427. #endif
  428.  
  429.  
  430.     /* struct feature symbols */
  431.     s_strtypep  = senter("%STRUCT-TYPE-P");
  432.     s_mkstruct  = senter("%MAKE-STRUCT");
  433.     s_cpystruct = senter("%COPY-STRUCT");
  434.     s_strref    = senter("%STRUCT-REF");
  435.     s_strset    = senter("%STRUCT-SET");
  436.     s_x         = senter("X");
  437.     s_s         = senter("S");
  438.     s_sslots    = senter("*STRUCT-SLOTS*");
  439.  
  440.  
  441. #ifdef RANDOM
  442.     s_randomstate = senter("*RANDOM-STATE*");
  443.     a_randomstate = senter("RANDOM-STATE");
  444.     sym = cons(NIL,NIL);    /* add to *struct-slots* property ((data nil)) */
  445.     sym = cons(senter("DATA"),sym);
  446.     sym = consa(sym);
  447.     xlputprop(a_randomstate,sym,s_sslots);
  448. #endif
  449.  
  450.  
  451.     /* add the object-oriented programming symbols and os specific stuff */
  452.     obsymbols();        /* object-oriented programming symbols */
  453.     ossymbols();        /* os specific symbols */
  454.     /* $putpatch.c$: "MODULE_XLINIT_C_XLSYMBOLS" */
  455. }
  456.  
  457.