lac : 6f7aea43b1f2ba32f3c6d92af2b4cb794ac9c5cc

     1: /*
     2:    lac -- a lisp interpreter
     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: /* String type */
    21: #include "lac.h"
    22: #include <gc/gc.h>
    23: #include <stdio.h>
    24: #include <string.h>
    25: 
    26: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
    27: 
    28: static int
    29: string_compare (lreg_t arg1, lreg_t arg2)
    30: {
    31:   int d;
    32:   char *s1, *s2;
    33:   s1 = (char *) lreg_raw_ptr (arg1);
    34:   s2 = (char *) lreg_raw_ptr (arg2);
    35:   d = strcmp (s1, s2);
    36:   return d;
    37: }
    38: 
    39: #define BINARY_STR_OP_CHECKS(args)			\
    40:   _EXPECT_ARGS(args, 2);				\
    41:   lreg_t s1 = ARGEVAL(car(args), argenv);		\
    42:   lreg_t s2 = ARGEVAL(car(cdr(args)), argenv);		\
    43: 							\
    44:   if ( lreg_type(s1) != lreg_type(s2)			\
    45:        || !(lreg_type(s1) == LREG_STRING) )		\
    46:     _ERROR_AND_RET("Function requires two strings!\n");
    47: 
    48: 
    49: LAC_API lreg_t
    50: proc_string_lessp (lreg_t args, lenv_t * argenv, lenv_t * env)
    51: {
    52:   BINARY_STR_OP_CHECKS (args);
    53:   return (string_compare (s1, s2) >= 0 ? sym_false : sym_true);
    54: }
    55: 
    56: LAC_API static lreg_t
    57: proc_string_greaterp (lreg_t args, lenv_t * argenv, lenv_t * env)
    58: {
    59:   BINARY_STR_OP_CHECKS (args);
    60:   return (string_compare (s1, s2) <= 0 ? sym_false : sym_true);
    61: }
    62: 
    63: LAC_API static lreg_t
    64: proc_string_equal (lreg_t args, lenv_t * argenv, lenv_t * env)
    65: {
    66:   BINARY_STR_OP_CHECKS (args);
    67:   return (string_compare (s1, s2) != 0 ? sym_false : sym_true);
    68: }
    69: 
    70: LAC_DEFINE_TYPE_PFUNC (string, LREG_STRING)
    71:      void string_init (lenv_t * env)
    72: {
    73:   lac_extproc_register (env, "STRINGP", LAC_TYPE_PFUNC (string));
    74:   lac_extproc_register (env, "STRING-LESS", proc_string_lessp);
    75:   lac_extproc_register (env, "STRING-GREATER", proc_string_greaterp);
    76:   lac_extproc_register (env, "STRING-EQUAL", proc_string_equal);
    77: }