lac : df17ea9faceae683b5460fadbf247cb8958eb651

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

Generated by git2html.