lac : 8a1192da2dcec3a97b199e992f0220233936cc5b

     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: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
   340: 
   341: /* Special Form */
   342: LAC_API static lreg_t proc_quote(lreg_t args, lenv_t *argenv, lenv_t *env)
   343: {
   344:   _EXPECT_ARGS(args, 1);
   345:   return car(args);
   346: }
   347: 
   348: static void _qquote(lreg_t sexp, lenv_t *env, lreg_t *first, lreg_t *last, int nested)
   349: {
   350:   switch ( lreg_raw_type(sexp) )
   351:     {
   352:     case LREG_CONS:
   353:       if ( car(sexp) == sym_quasiquote )
   354: 	{
   355: 	  lreg_t qqd;
   356: 	  _qquote(cdr(sexp), env, &qqd, NULL, nested+1);
   357: 	  *first = cons(sym_quasiquote, qqd);
   358: 	}
   359:       else if ( (car(sexp) == sym_unquote) )
   360: 	{
   361: 	  if ( nested == 0 )
   362: 	      *first = eval(car(cdr(sexp)), env);
   363: 	  else
   364: 	    {
   365: 	      lreg_t qqd;
   366: 	      _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
   367: 	      *first = cons(sym_unquote, qqd);
   368: 	    }
   369: 	}
   370:       else if ( car(sexp) == sym_splice )
   371: 	{
   372: 	  if ( nested == 0 )
   373: 	    {
   374: 	      lreg_t tosplice;
   375: 
   376: 	      if ( last == NULL )
   377: 		raise_exception("SPLICE expected on car only.", NIL);
   378:       
   379: 	      tosplice = eval(car(cdr(sexp)), env);
   380: 	      switch( lreg_raw_type (tosplice) )
   381: 		{
   382: 		  lreg_t tail = NIL;
   383: 		case LREG_CONS:
   384: 		  *first = tail = tosplice;
   385: 		  for ( ; tosplice != NIL && is_cons(cdr(tosplice)); 
   386: 			tosplice = cdr(tosplice) );
   387: 		  *last = tosplice;
   388: 		  break;
   389: 
   390: 		default:
   391: 		  *first = tosplice;
   392: 		  *last = cons(NIL,NIL);
   393: 		  break;
   394: 		}
   395: 	    }
   396: 	  else
   397: 	    {
   398: 	      lreg_t qqd;
   399: 	      _qquote(cdr(sexp), env, &qqd, NULL, nested - 1);
   400: 	      *first = cons(sym_splice, qqd);
   401: 	    }
   402: 	}
   403:       else
   404: 	{
   405: 	  lreg_t qqa, qqd, qqalast = NIL;
   406: 
   407: 	  _qquote(car(sexp), env, &qqa, &qqalast, nested);
   408: 	  _qquote(cdr(sexp), env, &qqd, NULL, nested);
   409: 
   410: 	  if ( qqalast != NIL )
   411: 	    {
   412: 	      if ( cdr(qqalast) == NIL  )
   413:                 rplacd(qqalast, qqd);
   414: 	      else if ( qqd != NIL )
   415: 		raise_exception("Dotted pairs in spliced list can be"
   416: 			    " present only when splicing is at end of a list.", qqd);
   417: 
   418: 	      *first = qqa;
   419: 	    }
   420: 	  else
   421: 	      *first = cons(qqa, qqd);
   422: 	}
   423:       break;
   424:     default:
   425:       *first = sexp;
   426:     }
   427: }
   428: 
   429: /* Special Form */
   430: LAC_API static lreg_t proc_quasiquote(lreg_t args, lenv_t *argenv, lenv_t *env)
   431: {
   432:   lreg_t ret;
   433:   _EXPECT_ARGS(args, 1);
   434:   _qquote(car(args), env, &ret, NULL, 0);
   435:   return ret;
   436: }
   437: 
   438: LAC_API static lreg_t proc_car(lreg_t args, lenv_t *argenv, lenv_t *env)
   439: {
   440:   _EXPECT_ARGS(args, 1);
   441:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   442: 
   443:   /* Lisp-specific! */
   444:   if (arg1 == NIL)
   445:     return NIL;
   446: 
   447:   if ( !is_cons(arg1) )
   448:     _ERROR_AND_RET("argument is not cons");
   449:  
   450:   return car(arg1); 
   451: }
   452: 
   453: LAC_API static lreg_t proc_cdr(lreg_t args, lenv_t *argenv, lenv_t *env)
   454: {
   455:   _EXPECT_ARGS(args, 1);
   456:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   457: 
   458:   /* Lisp-specific!
   459:      If I really want to keep this spec I should change cdr() and
   460:      car() to return NIL on NIL and remove these checks. */
   461:   if (arg1 == NIL)
   462: 	return NIL;
   463: 
   464:   if (!is_cons(arg1))
   465:     _ERROR_AND_RET("argument is not cons");
   466: 
   467:   return cdr(arg1);  
   468: }
   469: 
   470: LAC_API static lreg_t proc_cons(lreg_t args, lenv_t *argenv, lenv_t *env)
   471: {
   472:   _EXPECT_ARGS(args, 2);
   473:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   474:   lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   475: 
   476:   return cons(arg1, arg2);
   477: }
   478: 
   479: LAC_API static lreg_t proc_rplaca(lreg_t args, lenv_t *argenv, lenv_t *env)
   480: {
   481:   _EXPECT_ARGS(args, 2);
   482:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   483:   lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   484: 
   485:   if ( !is_cons(arg1) )
   486:     _ERROR_AND_RET("argument is not cons");
   487: 
   488:   rplaca(arg1, arg2);
   489:   return arg1;
   490: }
   491: 
   492: LAC_API static lreg_t proc_rplacd(lreg_t args, lenv_t *argenv, lenv_t *env)
   493: {
   494:   _EXPECT_ARGS(args, 2);
   495:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   496:   lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   497: 
   498:   if ( !is_cons(arg1) )
   499:     _ERROR_AND_RET("argument is not cons");
   500: 
   501:   rplacd(arg1, arg2);
   502:   return arg1;
   503: }
   504: 
   505: LAC_API static lreg_t proc_eq(lreg_t args, lenv_t *argenv, lenv_t *env)
   506: {
   507:   _EXPECT_ARGS(args, 2);
   508:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   509:   lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   510: 
   511:   return (lreg_type(arg1) == lreg_type(arg2)
   512: 	  && lreg_ptr(arg1) == lreg_ptr(arg2)) ? sym_true : sym_false;
   513: }
   514: 
   515: LAC_API static lreg_t proc_atom_equal(lreg_t args, lenv_t *argenv, lenv_t *env)
   516: {
   517: 	_EXPECT_ARGS(args, 2);
   518: 	lreg_t arg1 = ARGEVAL(car(args), argenv);
   519: 	lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   520: 	int rc = 0;
   521: 
   522: 	if (lreg_type(arg1) != lreg_type(arg2))
   523: 		raise_exception("types mismatch", cons(arg1, arg2));
   524: 
   525: 	switch(lreg_raw_type(arg1)) {
   526: 	case LREG_NIL:
   527: 		rc = 1;
   528: 		break;
   529: 	case LREG_LLPROC:
   530: 	case LREG_LAMBDA:
   531: 	case LREG_MACRO:
   532: 	case LREG_SYMBOL:
   533: 		rc = lreg_raw_ptr(arg1) == lreg_raw_ptr(arg2);
   534: 		break;
   535: 	case LREG_STRING:
   536: 		rc = !strcmp(lreg_raw_ptr(arg1), lreg_raw_ptr(arg2));
   537: 		break;
   538: 	case LREG_EXTT:
   539: 		rc = lacint_extty_equal(arg1, arg2);
   540: 		break;
   541: 	default:
   542: 		raise_exception("not an atom", arg1);
   543: 	}
   544: 
   545: 	return rc ? sym_true : sym_false;
   546: }
   547: 
   548: /* Special Form */
   549: LAC_API static lreg_t proc_labels(lreg_t args, lenv_t *argenv, lenv_t *env)
   550: {
   551:   /* At least 3 arguments required. */
   552:   _EXPECT_MIN_ARGS(args, 3);
   553:   lreg_t ret;
   554:   lreg_t lbl = car(args);
   555:   lreg_t binds = car(cdr(args));
   556:   lenv_t *penv = GC_malloc(sizeof(lenv_t));
   557: 
   558:   if ( !is_cons(binds) && binds != NIL )
   559:     _ERROR_AND_RET("Syntax error in labels");
   560: 
   561:   env_pushnew(env, penv);
   562:   ret = lreg_raw(lreg_raw_ptr(cons(cdr(args), lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
   563:   env_define(penv, lbl, ret);
   564:   return ret;
   565: }
   566: 
   567: /* Special Form */
   568: LAC_API static lreg_t proc_lambda(lreg_t args, lenv_t *argenv, lenv_t *env)
   569: {
   570:   /* At least 2 arguments required. */
   571:   _EXPECT_MIN_ARGS(args, 2);
   572:   lreg_t binds = car(args);
   573:   lenv_t *penv = GC_malloc(sizeof(lenv_t));
   574: 
   575:   if ( !is_cons(binds) && binds != NIL )
   576:     _ERROR_AND_RET("Syntax error in lambda");
   577: 
   578:   env_pushnew(env, penv);
   579:   return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_LAMBDA);
   580: }
   581: 
   582: /* Special Form */
   583: LAC_API static lreg_t proc_macro(lreg_t args, lenv_t *argenv, lenv_t *env)
   584: {
   585:   /* At least 2 arguments required. */
   586:   _EXPECT_MIN_ARGS(args, 2);
   587:   lreg_t binds = car(args);
   588:   lenv_t *penv = GC_malloc(sizeof(lenv_t));
   589: 
   590:   if ( !is_cons(binds) && binds != NIL )
   591:     _ERROR_AND_RET("Syntax error in macro");
   592: 
   593:   env_pushnew(env, penv);
   594:   return lreg_raw(lreg_raw_ptr(cons(args, lreg_raw(penv, LREG_NIL))), LREG_MACRO);
   595: }
   596: 
   597: /* Special Form */
   598: LAC_API static lreg_t proc_define(lreg_t args, lenv_t *argenv, lenv_t *env)
   599: {
   600:   lreg_t defd;
   601:   _EXPECT_ARGS(args, 2);
   602: 
   603:   if ( !is_symbol(car(args)) )
   604:     _ERROR_AND_RET("Syntax error in define");
   605: 
   606:   defd = eval(car(cdr(args)), env);
   607:   env_define(env, car(args), defd);
   608:   return defd;
   609: }
   610: 
   611: LAC_API static lreg_t proc_set(lreg_t args, lenv_t *argenv, lenv_t *env)
   612: {
   613:   int r;
   614:   _EXPECT_ARGS(args, 2);
   615:   lreg_t arg1 = ARGEVAL(car(args), argenv);
   616:   lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);
   617: 
   618:   if ( !is_symbol(arg1) )
   619:     _ERROR_AND_RET("Syntax error in set");
   620: 
   621:   r = env_set(env, arg1, arg2);
   622:   if ( r < 0 )
   623:     raise_exception("Error while setting env.", NIL);
   624: 
   625:   if ( r == 0 )
   626:     return arg2;
   627: 
   628:   /* Not defined */
   629:   return NIL;
   630: }
   631: 
   632: LAC_DEFINE_TYPE_PFUNC(cons, LREG_CONS);
   633: LAC_DEFINE_TYPE_PFUNC(symbol, LREG_SYMBOL);
   634: 
   635: LAC_API static lreg_t proc_gensym(lreg_t args, lenv_t *argenv, lenv_t *env)
   636: {
   637:   #define GENSYM "#GSYM"
   638:   static int id = 0;
   639:   int len;
   640:   lreg_t ret;
   641:   char *s, *s1;
   642:   _EXPECT_ARGS(args, 0);
   643:   asprintf(&s1, "%s-%08x", GENSYM, id);
   644:   len = strlen(s1);
   645:   s = GC_malloc(len);
   646:   memcpy(s, s1, len);
   647:   free(s1);
   648:   ret = intern_symbol(s);
   649:   id++;
   650:   return ret;
   651: }
   652: 
   653: LAC_API static lreg_t proc_load(lreg_t args, lenv_t *argenv, lenv_t *env)
   654: {
   655:   int r;
   656:   FILE *f;
   657:   char *file;
   658:   void *scan;
   659:   lreg_t res, arg1;
   660:   _EXPECT_ARGS(args, 1);
   661: 
   662:   arg1 = ARGEVAL(car(args), argenv);
   663:   if ( lreg_type(arg1) != LREG_STRING )
   664:     _ERROR_AND_RET("Syntax error in load");
   665: 
   666:   file = (char *)lreg_raw_ptr(arg1);
   667:   f = fopen((char *)file, "r");
   668:   if ( f == NULL )
   669:     _ERROR_AND_RET("Could not open file");
   670: 
   671:   sexpr_read_start(f, &scan);
   672:   lac_on_error({
   673:       sexpr_read_stop(scan);
   674:       _throw(); /* rethrow */
   675:     });
   676:   do {
   677:     r = sexpr_read(&res, scan);
   678:     eval(res, env);
   679:   } while(r);
   680: 
   681:   lac_off_error();
   682:   sexpr_read_stop(scan);
   683:   return sym_true;
   684: }
   685: 
   686: 
   687: /*
   688:  * Initialization Functions
   689:  */
   690: 
   691: static void machine_init(lenv_t *env)
   692: {
   693:   /* Init symtab. */
   694:   hcreate(500);
   695: 
   696:   /* Init Null Env */
   697:   memset(env, 0, sizeof(struct env));
   698: 
   699:   /* Lisp-style booleans.
   700:      Can be changed into Scheme-scheme. */
   701:   sym_false = NIL;
   702:   sym_true = register_symbol("T");
   703:   env_define(env, sym_true, sym_true); /* Tautology. */
   704:   sym_quote = register_symbol("QUOTE");
   705:   env_define(env, sym_quote, llproc_to_lreg(proc_quote));
   706:   sym_cond = register_symbol("COND");
   707:   sym_apply = register_symbol("APPLY");
   708: 
   709:   lac_extproc_register(env, "LAMBDA", proc_lambda);
   710:   lac_extproc_register(env, "DEFINE", proc_define);
   711:   lac_extproc_register(env, "MACRO", proc_macro);
   712:   lac_extproc_register(env, "LABELS", proc_labels);
   713: 
   714:   lac_extproc_register(env,"CONS", proc_cons);
   715:   lac_extproc_register(env,"CAR", proc_car);
   716:   lac_extproc_register(env,"CDR", proc_cdr);
   717:   lac_extproc_register(env,"RPLACA", proc_rplaca);
   718:   lac_extproc_register(env,"RPLACD", proc_rplacd);
   719:   lac_extproc_register(env,"EQ", proc_eq);
   720:   lac_extproc_register(env, "ATOM-EQUAL", proc_atom_equal);
   721:   lac_extproc_register(env,"LOAD", proc_load);
   722:   lac_extproc_register(env,"SET", proc_set);
   723:   lac_extproc_register(env,"GENSYM", proc_gensym);
   724:   lac_extproc_register(env,"CONSP", LAC_TYPE_PFUNC(cons));
   725:   lac_extproc_register(env,"SYMBOLP", LAC_TYPE_PFUNC(symbol));
   726: 
   727:   sym_quasiquote = register_symbol("QUASIQUOTE");
   728:   env_define(env, sym_quasiquote, llproc_to_lreg(proc_quasiquote));
   729:   sym_unquote = register_symbol("UNQUOTE");
   730:   sym_splice = register_symbol("SPLICE");
   731:   sym_rest = register_symbol("&REST");
   732: }
   733: 
   734: void map_init(lenv_t *env);
   735: void int_init(lenv_t *env);
   736: void string_init(lenv_t *env);
   737: static void
   738: modules_init(lenv_t *env)
   739: {
   740:   int_init(env);
   741:   string_init(env);
   742:   map_init(env);
   743: }
   744: 
   745: static void
   746: library_init(lenv_t *env)
   747: {
   748:   int r;
   749:   FILE *f;  
   750:   lreg_t res;
   751:   void *scan;
   752: 
   753:   f = fopen("sys.lac", "r");
   754:   if ( f == NULL )
   755:     f = fopen(LAC_SYSDIR"/sys.lac", "r");
   756:   if ( f == NULL )
   757:     raise_exception("SYSTEM LIBRARY NOT FOUND", NIL);
   758: 
   759:   sexpr_read_start(f, &scan);
   760:   do {
   761:     r = sexpr_read(&res, scan);
   762:     eval(res, env);
   763:   } while(r);
   764:   sexpr_read_stop(scan);
   765: 
   766:   fclose(f);
   767: }
   768: 
   769: lenv_t *
   770: lac_init(void)
   771: {
   772:   sigset_t emptyset;
   773:   lenv_t *env;
   774:   GC_init();
   775:  
   776:   sigemptyset(&emptyset); 
   777:   sigprocmask(SIG_BLOCK, &emptyset, &mainsigset);
   778: 
   779:   stackoverflow_install_handler(stackovf_handler, extra_stack, 16384);
   780:   env = lac_envalloc();
   781:   machine_init(env);
   782:   modules_init(env);
   783:   library_init(env);
   784: 
   785:   return env;
   786: }
   787: 
   788: lenv_t *
   789: lac_envalloc(void)
   790: {
   791:   return GC_malloc(sizeof(lenv_t));
   792: }
   793: 
   794: 

Generated by git2html.