lac : e164ed080613d1a7436a7094f989c88be874b8ca

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