lac : b83c46fb5bba76ef6b7d48e30169fa2e8a921398

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

Generated by git2html.