lac : 54b3831bb6847a39d31917099711f45734540dbb

     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
    28: map_args (lreg_t lists)
    29: {
    30:   lreg_t args = lists;
    31:   lreg_t outargs = NIL, tail = NIL;
    32: 
    33:   for (; args != NIL; args = cdr (args))
    34:     {
    35:       if (!is_cons (args) || !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: 	{
    44: 	  outargs = tail =
    45: 	    cons (cons (sym_quote, cons (cons (car (car (args)), NIL), NIL)),
    46: 		  NIL);
    47: 	}
    48:       else
    49: 	{
    50: 	  lreg_t tmp =
    51: 	    cons (cons (sym_quote, cons (cons (car (car (args)), NIL), NIL)),
    52: 		  NIL);
    53: 	  rplacd (tail, tmp);
    54: 	  tail = tmp;
    55: 	}
    56: 
    57:       rplaca (args, cdr (car (args)));
    58:     }
    59: 
    60:   return outargs;
    61: }
    62: 
    63: 
    64: 
    65: LAC_API static lreg_t
    66: proc_mapcar (lreg_t args, lenv_t * argenv, lenv_t * env)
    67: {
    68:   _EXPECT_MIN_ARGS (args, 2);
    69:   lreg_t mapargs;
    70:   lreg_t fn, lists;
    71:   lreg_t outlist = NIL, tail = NIL;
    72:   lreg_t evd = argenv == NULL ? args : evargs (args, env);
    73:   fn = car (evd);
    74:   lists = cdr (evd);
    75: 
    76:   switch (lreg_type (fn))
    77:     {
    78:     case LREG_LAMBDA:
    79:     case LREG_MACRO:
    80:     case LREG_LLPROC:
    81:       break;
    82:     default:
    83:       _ERROR_AND_RET ("Syntax error in mapcar");
    84:     }
    85: 
    86: 
    87:   for (;;)
    88:     {
    89:       lreg_t outelm;
    90:       mapargs = map_args (lists);
    91:       if (mapargs == NIL)
    92: 	break;
    93:       outelm = apply (fn, car (mapargs), env);
    94: 
    95:       if (outlist == NIL)
    96: 	{
    97: 	  outlist = tail = cons (outelm, NIL);
    98: 	}
    99:       else
   100: 	{
   101: 	  lreg_t tmp = cons (outelm, NIL);
   102: 	  rplacd (tail, tmp);
   103: 	  tail = tmp;
   104: 	}
   105:     }
   106:   return outlist;
   107: }
   108: 
   109: LAC_API static lreg_t
   110: proc_reduce (lreg_t args, lenv_t * argenv, lenv_t * env)
   111: {
   112:   _EXPECT_ARGS (args, 2);
   113:   lreg_t acc;
   114:   lreg_t fn = ARGEVAL (car (args), argenv);
   115:   lreg_t list = ARGEVAL (car (cdr (args)), argenv);
   116: 
   117:   if (!is_cons (list))
   118:     _ERROR_AND_RET ("Syntax error in reduce\n");
   119: 
   120:   acc = car (list);
   121:   list = cdr (list);
   122: 
   123:   for (; list != NIL; list = cdr (list))
   124:     acc = apply (fn, cons (acc, cons (car (list), NIL)), env);
   125: 
   126:   return acc;
   127: }
   128: 
   129: void
   130: map_init (lenv_t * env)
   131: {
   132: 
   133:   lac_extproc_register (env, "MAPCAR", proc_mapcar);
   134:   lac_extproc_register (env, "REDUCE", proc_reduce);
   135: }