lac : ed225f50b0a9bc12fb33de17ef35b50f8c0ba18f

     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: #include "lac.h"
    21: #include <stdio.h>
    22: #include <limits.h>
    23: 
    24: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
    25: 
    26: #define INT_UNBOX(lr, n) lac_extty_unbox(lr, (void **)&(n))
    27: 
    28: /*
    29:   LAC Type Interface.
    30:  */
    31: 
    32: static void int_print(FILE *fd, lreg_t lr)
    33: {
    34:   intptr_t n;
    35: 
    36:   INT_UNBOX(lr, n);
    37:   fprintf(fd, "%ld", n);
    38: }
    39: 
    40: static lac_exttype_t int_ty = { 
    41: 	.name = "integer",
    42: 	.print = int_print,
    43: 	.equal = NULL,
    44: };
    45: 
    46: 
    47: /*
    48:   Additional procedures.
    49:  */
    50: 
    51: #define _BINOP_CHECKS(a, b)					\
    52: 	_EXPECT_ARGS(args, 2);					\
    53: 	lreg_t arg1 = ARGEVAL(car(args), argenv);		\
    54: 	lreg_t arg2 = ARGEVAL(car(cdr(args)), argenv);		\
    55: 								\
    56: 	if ( !(lreg_type(arg1) == lreg_type(arg2))		\
    57: 	     || lreg_type(arg1) != LREG_INTEGER )		\
    58: 		_ERROR_AND_RET("+ requires two integers");	\
    59:   								\
    60: 	lac_extty_unbox(arg1, (void **)&a);			\
    61: 	lac_extty_unbox(arg2, (void **)&b);
    62: 
    63: 
    64: LAC_API static lreg_t proc_plus(lreg_t args, lenv_t *argenv, lenv_t *env)
    65: {
    66:   intptr_t n1, n2, n;
    67:   _BINOP_CHECKS(n1, n2);
    68: 
    69:   if ( ((n1>0) && (n2>0) && (n1 > (LONG_MAX-n2))) 
    70:        || ((n1<0) && (n2<0) && (n1 < (LONG_MIN-n2))) )
    71:     _ERROR_AND_RET("+: Integer overflow\n");
    72: 
    73:   n = n1 + n2;
    74:   return lac_extty_box(LREG_INTEGER, (void *)n, 0);
    75: }
    76: 
    77: LAC_API static lreg_t proc_minus(lreg_t args, lenv_t *argenv, lenv_t *env)
    78: {
    79:   long n1, n2, n;
    80:   _BINOP_CHECKS(n1, n2);
    81: 
    82:   if ( ((n1>0) && (n2 < 0) && (n1 > (LONG_MAX+n2)))
    83:        || ((n1<0) && (n2>0) && (n1 < (LONG_MIN + n2))) )
    84:     _ERROR_AND_RET("-: Integer signed overflow\n");
    85: 
    86:   n = n1 - n2;
    87:   return lac_extty_box(LREG_INTEGER, (void *)n, 0);
    88: }
    89: 
    90: LAC_API static lreg_t proc_star(lreg_t args, lenv_t *argenv, lenv_t *env)
    91: {
    92:   long n1, n2, n;
    93:   _BINOP_CHECKS(n1, n2);
    94: 
    95:   if ( n1 == 0 || n2 == 0 )
    96:     goto mul_res;
    97: 
    98:   if ( n1 > 0 )
    99:     if ( n2 > 0 ) {
   100:       if ( n1>(LONG_MAX/(n2)) )
   101: 	goto mul_of;
   102:     } else {
   103:       if ( n2<(LONG_MIN/(n1)) )
   104: 	goto mul_of;
   105:     }
   106:   else
   107:     if ( n2 > 0 ) {
   108:       if ( n1<(LONG_MIN/(n2)) )
   109: 	goto mul_of;
   110:     } else {
   111:       if ( n2 < (LONG_MAX/(n1)) )
   112: 	goto mul_of;
   113:     }
   114: 
   115:  mul_res:
   116:   n = n1 * n2;
   117:   return lac_extty_box(LREG_INTEGER, (void *)n, 0);
   118: 
   119:  mul_of:
   120:   _ERROR_AND_RET("*: Integer sign overflow\n");
   121:   return NIL;
   122: }
   123: 
   124: LAC_API static lreg_t proc_mod(lreg_t args, lenv_t *argenv, lenv_t *env)
   125: {
   126:   long n1, n2, n;
   127:   _BINOP_CHECKS(n1, n2);
   128: 
   129:   if ( (n2 == 0 ) || ( (n1 == LONG_MIN) && (n2 == -1) ) )
   130:       _ERROR_AND_RET("\%% would overflow or divide by zero\n");
   131: 
   132:   n = n1 % n2;
   133:   return lac_extty_box(LREG_INTEGER, (void *)n, 0);
   134: }
   135: 
   136: LAC_API static lreg_t proc_div(lreg_t args, lenv_t *argenv, lenv_t *env)
   137: {
   138:   long n1, n2, n;
   139:   _BINOP_CHECKS(n1, n2);
   140: 
   141:   if ( (n2 == 0 ) || ( (n1 == LONG_MIN) && (n2 == -1) ) )
   142:       _ERROR_AND_RET("\%% would overflow or divide by zero\n");
   143: 
   144:   n = n1 / n2;
   145:   return lac_extty_box(LREG_INTEGER, (void *)n, 0);
   146: }
   147: 
   148: LAC_API static lreg_t proc_greater(lreg_t args, lenv_t *argenv, lenv_t *env)
   149: {
   150:   long n1, n2;
   151:   _BINOP_CHECKS(n1, n2);
   152:   return n1 > n2 ? sym_true : sym_false;
   153: }
   154: 
   155: LAC_API static lreg_t proc_greatereq(lreg_t args, lenv_t *argenv, lenv_t *env)
   156: {
   157:   long n1, n2;
   158:   _BINOP_CHECKS(n1, n2);
   159:   return n1 >= n2 ? sym_true : sym_false;
   160: }
   161: 
   162: LAC_API static lreg_t proc_less(lreg_t args, lenv_t *argenv, lenv_t *env)
   163: {
   164:   long n1, n2;
   165:   _BINOP_CHECKS(n1, n2);
   166:   return n1 < n2 ? sym_true : sym_false;
   167: }
   168: 
   169: LAC_API static lreg_t proc_lesseq(lreg_t args, lenv_t *argenv, lenv_t *env)
   170: {
   171:   long n1, n2;
   172:   _BINOP_CHECKS(n1, n2);
   173:   return n1 <= n2 ? sym_true : sym_false;
   174: }
   175: 
   176: LAC_DEFINE_TYPE_PFUNC(integer, LREG_INTEGER);
   177: 
   178: void int_init(lenv_t *env)
   179: {
   180:   lac_extty_register(LREG_INTEGER, &int_ty);
   181:   lac_extproc_register(env, "INTEGERP",LAC_TYPE_PFUNC(integer));
   182:   lac_extproc_register(env, "+", proc_plus);
   183:   lac_extproc_register(env, "-", proc_minus);
   184:   lac_extproc_register(env, "*", proc_star);
   185:   lac_extproc_register(env, "%", proc_mod);
   186:   lac_extproc_register(env, "/", proc_div);
   187:   lac_extproc_register(env, ">", proc_greater);
   188:   lac_extproc_register(env, ">=", proc_greatereq);
   189:   lac_extproc_register(env, "<", proc_less);
   190:   lac_extproc_register(env, "<=", proc_lesseq);
   191: }

Generated by git2html.