lac : 72eb5b12e039f43e3f5294a36c8f3688976e86ce

     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: /* Mapping functions */
    21: #include "lac.h"
    22: #include <gc/gc.h>
    23: 
    24: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
    25: #define is_cons(lr) (lreg_raw_type(lr) == LREG_CONS)
    26: 
    27: static lreg_t map_args(lreg_t lists)
    28: {
    29:   lreg_t args = lists;
    30:   lreg_t outargs = NIL, tail = NIL;
    31: 
    32:   for ( ; args != NIL ; args = cdr(args) )
    33:     {
    34:       if ( !is_cons(args) ||
    35: 	   !is_cons(car(args)) )
    36: 	{
    37: 	  if ( is_cons(args) && car(args) == NIL )
    38: 	      return NIL;
    39: 	  raise_exception("Syntax Error in mapcar", args);
    40: 	}
    41: 
    42:       if ( outargs == NIL ) {
    43:         outargs = tail = cons(cons(sym_quote, cons(cons(car(car(args)), NIL), NIL)), NIL);
    44:       } else {
    45: 	lreg_t tmp = cons(cons(sym_quote, cons(cons(car(car(args)), NIL), NIL)), NIL);
    46:         rplacd(tail, tmp);
    47:         tail = tmp;
    48:       }
    49: 
    50:       rplaca(args, cdr(car(args)));
    51:     }
    52: 
    53:   return outargs;
    54: }
    55: 
    56: 
    57: 
    58: LAC_API static lreg_t proc_mapcar(lreg_t args, lenv_t *argenv, lenv_t *env)
    59: {
    60:   _EXPECT_MIN_ARGS(args, 2);
    61:   lreg_t mapargs;
    62:   lreg_t fn, lists;
    63:   lreg_t outlist = NIL, tail = NIL;
    64:   lreg_t evd = argenv == NULL ? args : evargs(args, env);
    65:   fn = car(evd);
    66:   lists = cdr(evd);
    67: 
    68:   switch ( lreg_type(fn) )
    69:     {
    70:     case LREG_LAMBDA:
    71:     case LREG_MACRO:
    72:     case LREG_LLPROC:
    73:       break;
    74:     default:
    75:       _ERROR_AND_RET("Syntax error in mapcar");
    76:     }
    77: 
    78: 
    79:   for (;;)
    80:     {
    81:       lreg_t outelm;
    82:       mapargs = map_args(lists);
    83:       if ( mapargs == NIL )
    84:         break;
    85:       outelm = apply(fn, car(mapargs), env);
    86:       
    87:       if ( outlist == NIL ) {
    88:         outlist = tail = cons(outelm, NIL);
    89:       } else {
    90:         lreg_t tmp = cons(outelm, NIL);
    91:         rplacd(tail, tmp);
    92:         tail = tmp;
    93:       }
    94:     }
    95:   return outlist; 
    96: }
    97: 
    98: LAC_API static lreg_t proc_reduce(lreg_t args, lenv_t *argenv, lenv_t *env)
    99: {
   100:   _EXPECT_ARGS(args, 2);
   101:   lreg_t acc;
   102:   lreg_t fn = ARGEVAL(car(args), argenv);
   103:   lreg_t list = ARGEVAL(car(cdr(args)), argenv);
   104: 
   105:   if ( !is_cons(list) )
   106:       _ERROR_AND_RET("Syntax error in reduce\n");
   107: 
   108:   acc = car(list);
   109:   list = cdr(list);
   110: 
   111:   for ( ; list != NIL; list = cdr(list) )
   112: 	  acc = apply(fn, cons(acc, cons(car(list), NIL)), env);
   113: 
   114:   return acc;
   115: }
   116: 
   117: void map_init(lenv_t *env)
   118: {
   119: 
   120:   lac_extproc_register(env, "MAPCAR", proc_mapcar);
   121:   lac_extproc_register(env, "REDUCE", proc_reduce);
   122: }