lac : 09cb84c16c7056491075780610d9505695a63563

     1: /*
     2:    lac -- a lisp interpreter library
     3:    Copyright (C) 2010 Gianluca Guida
     4: 
     5:    This program is free software; you can redistribute it and/or modify
     6:    it under the terms of the GNU General Public License as published by
     7:    the Free Software Foundation; either version 2 of the License, or
     8:    (at your option) any later version.
     9: 
    10:    This program is distributed in the hope that it will be useful,
    11:    but WITHOUT ANY WARRANTY; without even the implied warranty of
    12:    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13:    GNU General Public License for more details.
    14: 
    15:    You should have received a copy of the GNU General Public License along
    16:    with this program; if not, write to the Free Software Foundation, Inc.,
    17:    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    18: */
    19: 
    20: #define _GNU_SOURCE
    21: #include <stdio.h>
    22: #include <stdlib.h>
    23: #include <search.h>
    24: #include <string.h>
    25: #include <gc/gc.h>
    26: #include <signal.h>
    27: #include <sigsegv.h>
    28: #include "private.h"
    29: #include "lac.h"
    30: 
    31: 
    32: /*
    33:  * System symbols
    34:  */
    35: lreg_t sym_true;
    36: lreg_t sym_false;
    37: lreg_t sym_cond;
    38: lreg_t sym_apply;
    39: lreg_t sym_quote;
    40: lreg_t sym_quasiquote;
    41: lreg_t sym_unquote;
    42: lreg_t sym_splice;
    43: lreg_t sym_rest;
    44: 
    45: 
    46: /*
    47:  * Interface
    48:  */
    49: 
    50: lreg_t
    51: register_symbol (const char *s)
    52: {
    53:   unsigned len = strlen (s) + 1;
    54:   char *gcs = GC_malloc (len);
    55:   strncpy (gcs, s, len);
    56:   return intern_symbol (gcs);
    57: }
    58: 
    59: void
    60: lac_extproc_register (lenv_t * env, const char *sym, lac_function_t f)
    61: {
    62: 
    63:   env_define (env, register_symbol (sym), llproc_to_lreg (f));
    64: }
    65: 
    66: 
    67: /*
    68:  * Exception handling.
    69:  */
    70: 
    71: __thread struct _lac_xcpt *_lac_xcpt;
    72: __thread char *_lac_xcpt_msg;
    73: __thread lreg_t _lac_xcpt_reg;
    74: 
    75: inline void
    76: raise_exception (char *arg, lreg_t errlr)
    77: {
    78: 
    79:   _lac_xcpt_msg = arg;
    80:   _lac_xcpt_reg = errlr;
    81:   _throw ();
    82: }
    83: 
    84: /*
    85:  * Stack Overflow handling.
    86:  */
    87: 
    88: static sigset_t mainsigset;
    89: static char extra_stack[16384];
    90: 
    91: static void
    92: stackovf_continuation (void *arg1, void *arg2, void *arg3)
    93: {
    94:   raise_exception (arg1, NIL);
    95: }
    96: 
    97: static void
    98: stackovf_handler ()
    99: {
   100:   sigprocmask (SIG_SETMASK, &mainsigset, NULL);
   101:   sigsegv_leave_handler (stackovf_continuation, "STACK OVERFLOW", NULL, NULL);
   102: }
   103: 
   104: 
   105: /*
   106:  * Basic procedures.
   107:  */
   108: 
   109: /* Get symbol from string and intern it if new. */
   110:  lreg_t
   111: intern_symbol (char *s)
   112: {
   113:   ENTRY e = {.key = s }, *r;
   114: 
   115:   /* Assert that the char pointer is actually aligned. If not it means
   116:      that we're interning a symbol from a string not allocated by the
   117:      GC, and this is against the code rules of this thing. */
   118:   assert (((uintptr_t) s & LREG_TYPE_MASK) == 0);
   119: 
   120:   r = hsearch (e, ENTER);
   121:   return lreg_raw (lreg_raw_ptr ((lreg_t) r->key), LREG_SYMBOL);
   122: }
   123: 
   124: lreg_t
   125: cons (lreg_t a, lreg_t d)
   126: {
   127:   struct cons *c = GC_malloc (sizeof (struct cons));
   128:   c->a = a;
   129:   c->d = d;
   130:   return lreg_raw (c, LREG_CONS);
   131: }
   132: 
   133: 
   134: /*
   135:  * Eval/Apply
   136:  */
   137: 
   138: 
   139: lreg_t
   140: evargs (lreg_t list, lenv_t * env)
   141: {
   142:   lreg_t tmp, head = NIL, tail = NIL;
   143: 
   144:   while (is_cons (list))
   145:     {
   146:       tmp = cons (eval (car (list), env), NIL);
   147:       if (head != NIL)
   148: 	{
   149: 	  rplacd (tail, tmp);
   150: 	  tail = cdr (tail);
   151: 	}
   152:       else
   153: 	{
   154: 	  head = tmp;
   155: 	  tail = head;
   156: 	}
   157:       list = cdr (list);
   158:     }
   159: 
   160:   if (list != NIL)
   161:     {
   162:       raise_exception ("evargs: invalid arguments", list);
   163:       head = NIL;
   164:     }
   165:   return head;
   166: }
   167: 
   168: static void
   169: evbind (lreg_t binds, lreg_t args, lenv_t * argenv, lenv_t * env)
   170: {
   171:   lreg_t arg;
   172: 
   173:   while (is_cons (binds) && is_cons (args))
   174:     {
   175:       if (car (binds) == sym_rest)
   176: 	break;
   177:       arg = car (args);
   178:       if (argenv)
   179: 	arg = eval (arg, argenv);
   180:       env_define (env, car (binds), arg);
   181:       binds = cdr (binds);
   182:       args = cdr (args);
   183:     }
   184: 
   185:   if (car (binds) == sym_rest)
   186:     {
   187:       binds = cdr (binds);
   188:       arg = args;
   189:       if (argenv)
   190: 	arg = evargs (arg, argenv);
   191:       env_define (env, car (binds), arg);
   192:       binds = cdr (binds);
   193:       args = NIL;
   194:     }
   195: 
   196:   if (is_cons (binds))
   197:     raise_exception ("Undefined bindings", binds);
   198: 
   199:   if (is_cons (args))
   200:     raise_exception ("Too many arguments", args);
   201: }
   202: 
   203: lreg_t
   204: apply (lreg_t proc, lreg_t args, lenv_t * env)
   205: {
   206:   return eval (cons (sym_apply, cons (proc, cons (args, NIL))), env);
   207: }
   208: 
   209: static __thread int in_tco = 0;
   210: 
   211: lreg_t
   212: eval (lreg_t sexp, lenv_t * env)
   213: {
   214:   lreg_t ans;
   215:   unsigned type;
   216:   lenv_t *cloenv;
   217:   lenv_t *tenvs[2] = { NULL, NULL };
   218: 
   219: tco:
   220:   switch (lreg_raw_type (sexp))
   221:     {
   222:     case LREG_SYMBOL:
   223:       ans = env_lookup (env, sexp);
   224:       break;
   225:     case LREG_CONS:
   226:       {
   227: 	lreg_t proc = car (sexp), args = cdr (sexp);
   228: 	lenv_t *penv, *argenv;
   229: 
   230: 	ans = NIL;
   231: 	/* COND: embedded procedure */
   232: 	if (proc == sym_cond)
   233: 	  {
   234: 	    lreg_t cond = NIL;
   235: 	    lreg_t next, test, body;
   236: 
   237: 	    body = NIL;		/* Default return  */
   238: 	    while (args != NIL)
   239: 	      {
   240: 		test = car (args);
   241: 		if (!is_cons (test))
   242: 		  _ERROR_AND_RET ("Syntax error in cond");
   243: 		cond = eval (car (test), env);
   244: 		/* Lisp-specific! Scheme (as for R5RS) checks for #t,
   245: 		 * though guile doesn't.  */
   246: 		if (cond == NIL)
   247: 		  {
   248: 		    args = cdr (args);
   249: 		    continue;
   250: 		  }
   251: 		body = cdr (test);
   252: 		break;
   253: 	      }
   254: 	    if (body == NIL)
   255: 	      return cond;
   256: 	    next = cdr (body);
   257: 	    while (next != NIL)
   258: 	      {
   259: 		eval (car (body), env);
   260: 		body = next;
   261: 		next = cdr (next);
   262: 	      }
   263: 	    if (in_tco)
   264: 	      {
   265: 		sexp = car (body);
   266: 		/* env unchanged */
   267: 		goto tco;
   268: 	      }
   269: 	    in_tco = 1;
   270: 	    ans = eval (car (body), env);
   271: 	    in_tco = 0;
   272: 	    break;
   273: 	  }
   274: 	else if (proc == sym_apply)
   275: 	  {
   276: 	    proc = car (args);
   277: 	    args = eval (car (cdr (args)), env);;
   278: 	    argenv = NULL;
   279: 	    goto _apply;
   280: 	  }
   281: 	else
   282: 	  {
   283: 	    lreg_t lproc, binds, body, next;
   284: 
   285: 	    argenv = env;
   286: 	  _apply:
   287: 	    proc = eval (proc, env);
   288: 	    type = lreg_raw_type (proc);
   289: 	    if (type == LREG_LLPROC)
   290: 	      return lreg_to_llproc (proc) (args, argenv, env);
   291: 	    if (type != LREG_MACRO && type != LREG_LAMBDA)
   292: 	      {
   293: 		raise_exception ("not a procedure", proc);
   294: 		return NIL;
   295: 	      }
   296: 	    lproc = get_closure_proc (proc);
   297: 	    binds = get_proc_binds (lproc);
   298: 	    body = get_proc_body (lproc);
   299: 
   300: 	    if (tenvs[0] == NULL)
   301: 	      {
   302: 		tenvs[0] = alloca (sizeof (lenv_t));
   303: 		cloenv = tenvs[0];
   304: 	      }
   305: 	    if (type == LREG_MACRO)
   306: 	      {
   307: 		penv = NULL;
   308: 	      }
   309: 	    else
   310: 	      penv = argenv;
   311: 
   312: 	    env_pushnew (get_closure_env (proc), cloenv);
   313: 	    evbind (binds, args, penv, cloenv);
   314: 	    next = cdr (body);
   315: 	    while (body != NIL)
   316: 	      {
   317: 		if (next == NIL && type == LREG_LAMBDA && in_tco)
   318: 		  {
   319: 		    lenv_t *t;
   320: 
   321: 		    if (tenvs[1] == NULL)
   322: 		      {
   323: 			tenvs[1] = alloca (sizeof (lenv_t));
   324: 			env = tenvs[1];
   325: 		      }
   326: 		    /* Swap ENV */
   327: 		    t = env;
   328: 		    env = cloenv;
   329: 		    cloenv = t;
   330: 		    sexp = car (body);
   331: 		    goto tco;
   332: 		  }
   333: 		in_tco = 1;
   334: 		ans = eval (car (body), cloenv);
   335: 		in_tco = 0;
   336: 
   337: 		body = next;
   338: 		next = cdr (next);
   339: 	      }
   340: 	    if (type == LREG_LAMBDA)
   341: 	      break;
   342: 	    if (in_tco)
   343: 	      {
   344: 		/* Macro expand hook? */
   345: 		sexp = ans;
   346: 		/* env unchanged */
   347: 		goto tco;
   348: 	      }
   349: 	    in_tco = 1;
   350: 	    ans = eval (ans, env);
   351: 	    in_tco = 0;
   352: 	    break;
   353: 	  }
   354: 	break;
   355:       }
   356:     default:
   357:       ans = sexp;
   358:       break;
   359:     }
   360:   return ans;
   361: }
   362: 
   363: 
   364: /*
   365:  * Embedded  Procedures
   366:  */
   367: 
   368: /* Special Form */
   369: LAC_API static lreg_t
   370: proc_quote (lreg_t args, lenv_t * argenv, lenv_t * env)
   371: {
   372:   _EXPECT_ARGS (args, 1);
   373:   return car (args);
   374: }
   375: 
   376: static void
   377: _qquote (lreg_t sexp, lenv_t * env, lreg_t * first, lreg_t * last, int nested)
   378: {
   379:   switch (lreg_raw_type (sexp))
   380:     {
   381:     case LREG_CONS:
   382:       if (car (sexp) == sym_quasiquote)
   383: 	{
   384: 	  lreg_t qqd;
   385: 	  _qquote (cdr (sexp), env, &qqd, NULL, nested + 1);
   386: 	  *first = cons (sym_quasiquote, qqd);
   387: 	}
   388:       else if ((car (sexp) == sym_unquote))
   389: 	{
   390: 	  if (nested == 0)
   391: 	    *first = eval (car (cdr (sexp)), env);
   392: 	  else
   393: 	    {
   394: 	      lreg_t qqd;
   395: 	      _qquote (cdr (sexp), env, &qqd, NULL, nested - 1);
   396: 	      *first = cons (sym_unquote, qqd);
   397: 	    }
   398: 	}
   399:       else if (car (sexp) == sym_splice)
   400: 	{
   401: 	  if (nested == 0)
   402: 	    {
   403: 	      lreg_t tosplice;
   404: 
   405: 	      if (last == NULL)
   406: 		raise_exception ("SPLICE expected on car only.", NIL);
   407: 
   408: 	      tosplice = eval (car (cdr (sexp)), env);
   409: 	      switch (lreg_raw_type (tosplice))
   410: 		{
   411: 		  lreg_t tail = NIL;
   412: 		case LREG_CONS:
   413: 		  *first = tail = tosplice;
   414: 		  for (; tosplice != NIL && is_cons (cdr (tosplice));
   415: 		       tosplice = cdr (tosplice));
   416: 		  *last = tosplice;
   417: 		  break;
   418: 
   419: 		default:
   420: 		  *first = tosplice;
   421: 		  *last = cons (NIL, NIL);
   422: 		  break;
   423: 		}
   424: 	    }
   425: 	  else
   426: 	    {
   427: 	      lreg_t qqd;
   428: 	      _qquote (cdr (sexp), env, &qqd, NULL, nested - 1);
   429: 	      *first = cons (sym_splice, qqd);
   430: 	    }
   431: 	}
   432:       else
   433: 	{
   434: 	  lreg_t qqa, qqd, qqalast = NIL;
   435: 
   436: 	  _qquote (car (sexp), env, &qqa, &qqalast, nested);
   437: 	  _qquote (cdr (sexp), env, &qqd, NULL, nested);
   438: 
   439: 	  if (qqalast != NIL)
   440: 	    {
   441: 	      if (cdr (qqalast) == NIL)
   442: 		rplacd (qqalast, qqd);
   443: 	      else if (qqd != NIL)
   444: 		raise_exception ("Dotted pairs in spliced list can be"
   445: 				 " present only when splicing is at end of a list.",
   446: 				 qqd);
   447: 
   448: 	      *first = qqa;
   449: 	    }
   450: 	  else
   451: 	    *first = cons (qqa, qqd);
   452: 	}
   453:       break;
   454:     default:
   455:       *first = sexp;
   456:     }
   457: }
   458: 
   459: /* Special Form */
   460: LAC_API static lreg_t
   461: proc_quasiquote (lreg_t args, lenv_t * argenv, lenv_t * env)
   462: {
   463:   lreg_t ret;
   464:   _EXPECT_ARGS (args, 1);
   465:   _qquote (car (args), env, &ret, NULL, 0);
   466:   return ret;
   467: }
   468: 
   469: LAC_API static lreg_t
   470: proc_car (lreg_t args, lenv_t * argenv, lenv_t * env)
   471: {
   472:   _EXPECT_ARGS (args, 1);
   473:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   474: 
   475:   /* Lisp-specific! */
   476:   if (arg1 == NIL)
   477:     return NIL;
   478: 
   479:   if (!is_cons (arg1))
   480:     _ERROR_AND_RET ("argument is not cons");
   481: 
   482:   return car (arg1);
   483: }
   484: 
   485: LAC_API static lreg_t
   486: proc_cdr (lreg_t args, lenv_t * argenv, lenv_t * env)
   487: {
   488:   _EXPECT_ARGS (args, 1);
   489:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   490: 
   491:   /* Lisp-specific!
   492:      If I really want to keep this spec I should change cdr() and
   493:      car() to return NIL on NIL and remove these checks. */
   494:   if (arg1 == NIL)
   495:     return NIL;
   496: 
   497:   if (!is_cons (arg1))
   498:     _ERROR_AND_RET ("argument is not cons");
   499: 
   500:   return cdr (arg1);
   501: }
   502: 
   503: LAC_API static lreg_t
   504: proc_cons (lreg_t args, lenv_t * argenv, lenv_t * env)
   505: {
   506:   _EXPECT_ARGS (args, 2);
   507:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   508:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   509: 
   510:   return cons (arg1, arg2);
   511: }
   512: 
   513: LAC_API static lreg_t
   514: proc_rplaca (lreg_t args, lenv_t * argenv, lenv_t * env)
   515: {
   516:   _EXPECT_ARGS (args, 2);
   517:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   518:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   519: 
   520:   if (!is_cons (arg1))
   521:     _ERROR_AND_RET ("argument is not cons");
   522: 
   523:   rplaca (arg1, arg2);
   524:   return arg1;
   525: }
   526: 
   527: LAC_API static lreg_t
   528: proc_rplacd (lreg_t args, lenv_t * argenv, lenv_t * env)
   529: {
   530:   _EXPECT_ARGS (args, 2);
   531:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   532:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   533: 
   534:   if (!is_cons (arg1))
   535:     _ERROR_AND_RET ("argument is not cons");
   536: 
   537:   rplacd (arg1, arg2);
   538:   return arg1;
   539: }
   540: 
   541: LAC_API static lreg_t
   542: proc_eq (lreg_t args, lenv_t * argenv, lenv_t * env)
   543: {
   544:   _EXPECT_ARGS (args, 2);
   545:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   546:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   547: 
   548:   return (lreg_type (arg1) == lreg_type (arg2)
   549: 	  && lreg_ptr (arg1) == lreg_ptr (arg2)) ? sym_true : sym_false;
   550: }
   551: 
   552: LAC_API static lreg_t
   553: proc_atom_equal (lreg_t args, lenv_t * argenv, lenv_t * env)
   554: {
   555:   _EXPECT_ARGS (args, 2);
   556:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   557:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   558:   int rc = 0;
   559: 
   560:   if (lreg_type (arg1) != lreg_type (arg2))
   561:     raise_exception ("types mismatch", cons (arg1, arg2));
   562: 
   563:   switch (lreg_raw_type (arg1))
   564:     {
   565:     case LREG_NIL:
   566:       rc = 1;
   567:       break;
   568:     case LREG_LLPROC:
   569:     case LREG_LAMBDA:
   570:     case LREG_MACRO:
   571:     case LREG_SYMBOL:
   572:       rc = lreg_raw_ptr (arg1) == lreg_raw_ptr (arg2);
   573:       break;
   574:     case LREG_STRING:
   575:       rc = !strcmp (lreg_raw_ptr (arg1), lreg_raw_ptr (arg2));
   576:       break;
   577:     case LREG_EXTT:
   578:       rc = lacint_extty_equal (arg1, arg2);
   579:       break;
   580:     default:
   581:       raise_exception ("not an atom", arg1);
   582:     }
   583: 
   584:   return rc ? sym_true : sym_false;
   585: }
   586: 
   587: /* Special Form */
   588: LAC_API static lreg_t
   589: proc_labels (lreg_t args, lenv_t * argenv, lenv_t * env)
   590: {
   591:   /* At least 3 arguments required. */
   592:   _EXPECT_MIN_ARGS (args, 3);
   593:   lreg_t ret;
   594:   lreg_t lbl = car (args);
   595:   lreg_t binds = car (cdr (args));
   596:   lenv_t *penv = GC_malloc (sizeof (lenv_t));
   597: 
   598:   if (!is_cons (binds) && binds != NIL)
   599:     _ERROR_AND_RET ("Syntax error in labels");
   600: 
   601:   env_pushnew (env, penv);
   602:   ret =
   603:     lreg_raw (lreg_raw_ptr (cons (cdr (args), lreg_raw (penv, LREG_NIL))),
   604: 	      LREG_LAMBDA);
   605:   env_define (penv, lbl, ret);
   606:   return ret;
   607: }
   608: 
   609: /* Special Form */
   610: LAC_API static lreg_t
   611: proc_lambda (lreg_t args, lenv_t * argenv, lenv_t * env)
   612: {
   613:   /* At least 2 arguments required. */
   614:   _EXPECT_MIN_ARGS (args, 2);
   615:   lreg_t binds = car (args);
   616:   lenv_t *penv = GC_malloc (sizeof (lenv_t));
   617: 
   618:   if (!is_cons (binds) && binds != NIL)
   619:     _ERROR_AND_RET ("Syntax error in lambda");
   620: 
   621:   env_pushnew (env, penv);
   622:   return lreg_raw (lreg_raw_ptr (cons (args, lreg_raw (penv, LREG_NIL))),
   623: 		   LREG_LAMBDA);
   624: }
   625: 
   626: /* Special Form */
   627: LAC_API static lreg_t
   628: proc_macro (lreg_t args, lenv_t * argenv, lenv_t * env)
   629: {
   630:   /* At least 2 arguments required. */
   631:   _EXPECT_MIN_ARGS (args, 2);
   632:   lreg_t binds = car (args);
   633:   lenv_t *penv = GC_malloc (sizeof (lenv_t));
   634: 
   635:   if (!is_cons (binds) && binds != NIL)
   636:     _ERROR_AND_RET ("Syntax error in macro");
   637: 
   638:   env_pushnew (env, penv);
   639:   return lreg_raw (lreg_raw_ptr (cons (args, lreg_raw (penv, LREG_NIL))),
   640: 		   LREG_MACRO);
   641: }
   642: 
   643: /* Special Form */
   644: LAC_API static lreg_t
   645: proc_define (lreg_t args, lenv_t * argenv, lenv_t * env)
   646: {
   647:   lreg_t defd;
   648:   _EXPECT_ARGS (args, 2);
   649: 
   650:   if (!is_symbol (car (args)))
   651:     _ERROR_AND_RET ("Syntax error in define");
   652: 
   653:   defd = eval (car (cdr (args)), env);
   654:   env_define (env, car (args), defd);
   655:   return defd;
   656: }
   657: 
   658: LAC_API static lreg_t
   659: proc_set (lreg_t args, lenv_t * argenv, lenv_t * env)
   660: {
   661:   int r;
   662:   _EXPECT_ARGS (args, 2);
   663:   lreg_t arg1 = ARGEVAL (car (args), argenv);
   664:   lreg_t arg2 = ARGEVAL (car (cdr (args)), argenv);
   665: 
   666:   if (!is_symbol (arg1))
   667:     _ERROR_AND_RET ("Syntax error in set");
   668: 
   669:   r = env_set (env, arg1, arg2);
   670:   if (r < 0)
   671:     raise_exception ("Error while setting env.", NIL);
   672: 
   673:   if (r == 0)
   674:     return arg2;
   675: 
   676:   /* Not defined */
   677:   return NIL;
   678: }
   679: 
   680: LAC_DEFINE_TYPE_PFUNC (cons, LREG_CONS);
   681: LAC_DEFINE_TYPE_PFUNC (symbol, LREG_SYMBOL);
   682: 
   683: LAC_API static lreg_t
   684: proc_gensym (lreg_t args, lenv_t * argenv, lenv_t * env)
   685: {
   686: #define GENSYM "#GSYM"
   687:   static int id = 0;
   688:   int len;
   689:   lreg_t ret;
   690:   char *s, *s1;
   691:   _EXPECT_ARGS (args, 0);
   692:   asprintf (&s1, "%s-%08x", GENSYM, id);
   693:   len = strlen (s1);
   694:   s = GC_malloc (len);
   695:   memcpy (s, s1, len);
   696:   free (s1);
   697:   ret = intern_symbol (s);
   698:   id++;
   699:   return ret;
   700: }
   701: 
   702: LAC_API static lreg_t
   703: proc_load (lreg_t args, lenv_t * argenv, lenv_t * env)
   704: {
   705:   FILE *f;
   706:   char *file;
   707:   lreg_t arg1;
   708:   _EXPECT_ARGS (args, 1);
   709: 
   710:   arg1 = ARGEVAL (car (args), argenv);
   711:   if (lreg_type (arg1) != LREG_STRING)
   712:     _ERROR_AND_RET ("Syntax error in load");
   713: 
   714:   file = (char *) lreg_raw_ptr (arg1);
   715:   f = fopen ((char *) file, "r");
   716:   if (f == NULL)
   717:     _ERROR_AND_RET ("Could not open file");
   718: 
   719:   sexpr_parse_file (f, (lreg_t (*)(lreg_t, void *)) eval, (void *) env);
   720: 
   721:   return sym_true;
   722: }
   723: 
   724: 
   725: LAC_API static lreg_t
   726: proc_collect (lreg_t args, lenv_t * argenv, lenv_t * env)
   727: {
   728:   _EXPECT_ARGS (args, 0);
   729: 
   730:   GC_gcollect ();
   731:   return sym_true;
   732: }
   733: 
   734: 
   735: /*
   736:  * Initialization Functions
   737:  */
   738: 
   739: static void
   740: machine_init (lenv_t * env)
   741: {
   742:   /* Init symtab. */
   743:   hcreate (500);
   744: 
   745:   /* Init Null Env */
   746:   memset (env, 0, sizeof (struct env));
   747: 
   748:   /* Lisp-style booleans.
   749:      Can be changed into Scheme-scheme. */
   750:   sym_false = NIL;
   751:   sym_true = register_symbol ("T");
   752:   env_define (env, sym_true, sym_true);	/* Tautology. */
   753:   sym_quote = register_symbol ("QUOTE");
   754:   env_define (env, sym_quote, llproc_to_lreg (proc_quote));
   755:   sym_cond = register_symbol ("COND");
   756:   sym_apply = register_symbol ("APPLY");
   757: 
   758:   lac_extproc_register (env, "LAMBDA", proc_lambda);
   759:   lac_extproc_register (env, "DEFINE", proc_define);
   760:   lac_extproc_register (env, "MACRO", proc_macro);
   761:   lac_extproc_register (env, "LABELS", proc_labels);
   762: 
   763:   lac_extproc_register (env, "CONS", proc_cons);
   764:   lac_extproc_register (env, "CAR", proc_car);
   765:   lac_extproc_register (env, "CDR", proc_cdr);
   766:   lac_extproc_register (env, "RPLACA", proc_rplaca);
   767:   lac_extproc_register (env, "RPLACD", proc_rplacd);
   768:   lac_extproc_register (env, "EQ", proc_eq);
   769:   lac_extproc_register (env, "ATOM-EQUAL", proc_atom_equal);
   770:   lac_extproc_register (env, "LOAD", proc_load);
   771:   lac_extproc_register (env, "SET", proc_set);
   772:   lac_extproc_register (env, "GENSYM", proc_gensym);
   773:   lac_extproc_register (env, "CONSP", LAC_TYPE_PFUNC (cons));
   774:   lac_extproc_register (env, "SYMBOLP", LAC_TYPE_PFUNC (symbol));
   775: 
   776:   sym_quasiquote = register_symbol ("QUASIQUOTE");
   777:   env_define (env, sym_quasiquote, llproc_to_lreg (proc_quasiquote));
   778:   sym_unquote = register_symbol ("UNQUOTE");
   779:   sym_splice = register_symbol ("SPLICE");
   780:   sym_rest = register_symbol ("&REST");
   781: 
   782:   lac_extproc_register (env, "GC-COLLECT", proc_collect);
   783: }
   784: 
   785: 
   786: static void
   787: modules_init (lenv_t * env)
   788: {
   789:   void map_init (lenv_t * env);
   790:   void int_init (lenv_t * env);
   791:   void string_init (lenv_t * env);
   792: 
   793:   int_init (env);
   794:   string_init (env);
   795:   map_init (env);
   796: }
   797: 
   798: static void
   799: library_init (lenv_t * env)
   800: {
   801:   FILE *f;
   802: 
   803:   f = fopen ("sys.lac", "r");
   804:   if (f == NULL)
   805:     f = fopen (LAC_SYSDIR "/sys.lac", "r");
   806:   if (f == NULL)
   807:     raise_exception ("SYSTEM LIBRARY NOT FOUND", NIL);
   808: 
   809:   sexpr_parse_file (f, (lreg_t (*)(lreg_t, void *)) eval, (void *) env);
   810:   fclose (f);
   811: }
   812: 
   813: 
   814: void
   815: lac_error_print (FILE * f)
   816: {
   817:   fprintf (f, "(*LAC-ERROR* \"%s", lac_errmsg ());
   818:   if (lac_errlreg () != NIL)
   819:     {
   820:       fprintf (f, ": ");
   821:       sexpr_fprint (f, lac_errlreg ());
   822:     }
   823:   fprintf (f, "\")\n");
   824: }
   825: 
   826: lreg_t
   827: lac_eval (lreg_t lr, lenv_t *env)
   828: {
   829:   return eval (lr, env);
   830: }
   831: 
   832: lenv_t *
   833: lac_init (void)
   834: {
   835:   sigset_t emptyset;
   836:   lenv_t *env;
   837:   GC_init ();
   838: 
   839:   sigemptyset (&emptyset);
   840:   sigprocmask (SIG_BLOCK, &emptyset, &mainsigset);
   841: 
   842:   lac_on_error ({
   843: 		 lac_error_print (stderr); return NULL;
   844:     });
   845: 
   846:   stackoverflow_install_handler (stackovf_handler, extra_stack, 16384);
   847:   env = lac_envalloc ();
   848:   machine_init (env);
   849:   modules_init (env);
   850:   library_init (env);
   851:   lac_off_error ();
   852: 
   853:   return env;
   854: }
   855: 
   856: lenv_t *
   857: lac_envalloc (void)
   858: {
   859:   return GC_malloc (sizeof (lenv_t));
   860: }

Generated by git2html.