lac : 6c7f5d02fe45a904d9840f53116dbafd12121f20

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