plang: arith.c Source File

00001 /*
00002  * plang logic programming language
00003  * Copyright (C) 2011  Southern Storm Software, Pty Ltd.
00004  *
00005  * The plang package is free software: you can redistribute it and/or
00006  * modify it under the terms of the GNU Lesser General Public License
00007  * as published by the Free Software Foundation, either version 3 of
00008  * the License, or (at your option) any later version.
00009  *
00010  * The plang package is distributed in the hope that it will be useful,
00011  * but WITHOUT ANY WARRANTY; without even the implied warranty of
00012  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00013  * GNU Lesser General Public License for more details.
00014  *
00015  * You should have received a copy of the GNU Lesser General Public
00016  * License along with the libcompiler library.  If not,
00017  * see <http://www.gnu.org/licenses/>.
00018  */
00019 
00020 #include <plang/database.h>
00021 #include <plang/errors.h>
00022 #include "term-priv.h"
00023 #include "database-priv.h"
00024 #include "context-priv.h"
00025 #include <math.h>
00026 #include <string.h>
00027 #include <stdlib.h>
00028 #include <stdio.h>
00029 #include <errno.h>
00030 #include <time.h>
00031 #ifdef HAVE_FENV_H
00032 #include <fenv.h>
00033 #endif
00034 
00134 /* Internal expression evaluator */
00135 p_goal_result p_arith_eval
00136     (p_context *context, p_arith_value *result,
00137      p_term *expr, p_term **error)
00138 {
00139     expr = p_term_deref_member(context, expr);
00140     if (!expr || (expr->header.type & P_TERM_VARIABLE) != 0) {
00141         *error = p_create_instantiation_error(context);
00142         return P_RESULT_ERROR;
00143     }
00144     switch (expr->header.type) {
00145     case P_TERM_ATOM: {
00146         p_db_arith func = p_db_builtin_arith(expr, 0);
00147         if (!func)
00148             break;
00149         return (*func)(context, result, 0, 0, error); }
00150     case P_TERM_FUNCTOR: {
00151         p_arith_value args[2];
00152         p_goal_result goal_result;
00153         p_db_arith func = p_db_builtin_arith
00154             (expr->functor.functor_name, (int)(expr->header.size));
00155         if (!func)
00156             break;
00157         if (expr->header.size == 2) {
00158             goal_result = p_arith_eval
00159                 (context, args, expr->functor.arg[0], error);
00160             if (goal_result != P_RESULT_TRUE)
00161                 return goal_result;
00162             goal_result = p_arith_eval
00163                 (context, args + 1, expr->functor.arg[1], error);
00164             if (goal_result != P_RESULT_TRUE)
00165                 return goal_result;
00166             return (*func)(context, result, args, expr->functor.arg, error);
00167         } else if (expr->header.size == 1) {
00168             goal_result = p_arith_eval
00169                 (context, args, expr->functor.arg[0], error);
00170             if (goal_result != P_RESULT_TRUE)
00171                 return goal_result;
00172             return (*func)(context, result, args, expr->functor.arg, error);
00173         } else {
00174             unsigned int index;
00175             p_arith_value *args = GC_MALLOC
00176                 (sizeof(p_arith_value) * expr->header.size);
00177             if (!args)
00178                 break;
00179             for (index = 0; index < expr->header.size; ++index) {
00180                 goal_result = p_arith_eval
00181                     (context, args + index,
00182                      expr->functor.arg[index], error);
00183                 if (goal_result != P_RESULT_TRUE)
00184                     return goal_result;
00185             }
00186             goal_result = (*func)
00187                 (context, result, args, expr->functor.arg, error);
00188             GC_FREE(args);
00189             return goal_result;
00190         }
00191         break; }
00192     case P_TERM_INTEGER:
00193         result->type = P_TERM_INTEGER;
00194         result->integer_value = p_term_integer_value(expr);
00195         return P_RESULT_TRUE;
00196     case P_TERM_REAL:
00197         result->type = P_TERM_REAL;
00198         result->real_value = p_term_real_value(expr);
00199         return P_RESULT_TRUE;
00200     case P_TERM_STRING:
00201         result->type = P_TERM_STRING;
00202         result->string_value = expr;
00203         return P_RESULT_TRUE;
00204     default: break;
00205     }
00206     *error = p_create_type_error(context, "evaluable", expr);
00207     return P_RESULT_ERROR;
00208 }
00209 
00274 static p_goal_result p_builtin_is
00275     (p_context *context, p_term **args, p_term **error)
00276 {
00277     p_arith_value value;
00278     p_goal_result result;
00279     p_term *value_term;
00280     result = p_arith_eval(context, &value, args[1], error);
00281     if (result != P_RESULT_TRUE)
00282         return result;
00283     switch (value.type) {
00284     case P_TERM_INTEGER:
00285         value_term = p_term_create_integer(context, value.integer_value);
00286         break;
00287     case P_TERM_REAL:
00288         value_term = p_term_create_real(context, value.real_value);
00289         break;
00290     case P_TERM_STRING:
00291         value_term = value.string_value;
00292         break;
00293     default: return P_RESULT_FAIL;
00294     }
00295     if (p_term_unify(context, args[0], value_term, P_BIND_DEFAULT))
00296         return P_RESULT_TRUE;
00297     else
00298         return P_RESULT_FAIL;
00299 }
00300 
00344 static int p_builtin_num_cmp
00345     (p_context *context, p_term **args, p_term **error)
00346 {
00347     p_arith_value value1;
00348     p_arith_value value2;
00349     if (p_arith_eval(context, &value1, args[0], error) != P_RESULT_TRUE)
00350         return -2;
00351     if (p_arith_eval(context, &value2, args[1], error) != P_RESULT_TRUE)
00352         return -2;
00353     if (value1.type == P_TERM_INTEGER) {
00354         if (value2.type == P_TERM_INTEGER) {
00355             if (value1.integer_value < value2.integer_value)
00356                 return -1;
00357             else if (value1.integer_value > value2.integer_value)
00358                 return 1;
00359             else
00360                 return 0;
00361         } else if (value2.type == P_TERM_REAL) {
00362             double val1 = value1.integer_value;
00363             if (val1 < value2.real_value)
00364                 return -1;
00365             else if (val1 > value2.real_value)
00366                 return 1;
00367             else
00368                 return 0;
00369         } else {
00370             *error = p_create_type_error(context, "number", args[1]);
00371             return -2;
00372         }
00373     } else if (value1.type == P_TERM_REAL) {
00374         if (value2.type == P_TERM_REAL) {
00375             if (value1.real_value < value2.real_value)
00376                 return -1;
00377             else if (value1.real_value > value2.real_value)
00378                 return 1;
00379             else
00380                 return 0;
00381         } else if (value2.type == P_TERM_INTEGER) {
00382             double val2 = value2.integer_value;
00383             if (value1.real_value < val2)
00384                 return -1;
00385             else if (value1.real_value > val2)
00386                 return 1;
00387             else
00388                 return 0;
00389         } else {
00390             *error = p_create_type_error(context, "number", args[1]);
00391             return -2;
00392         }
00393     } else if (value1.type == P_TERM_STRING) {
00394         if (value2.type == P_TERM_STRING) {
00395             int cmp = p_term_strcmp
00396                 (value1.string_value, value2.string_value);
00397             if (cmp < 0)
00398                 return -1;
00399             else if (cmp > 0)
00400                 return 1;
00401             else
00402                 return 0;
00403         } else {
00404             *error = p_create_type_error(context, "string", args[1]);
00405             return -2;
00406         }
00407     } else {
00408         *error = p_create_type_error(context, "number", args[0]);
00409         return -2;
00410     }
00411 }
00412 static p_goal_result p_builtin_num_eq
00413     (p_context *context, p_term **args, p_term **error)
00414 {
00415     int cmp = p_builtin_num_cmp(context, args, error);
00416     if (cmp == -2)
00417         return P_RESULT_ERROR;
00418     else if (cmp == 0)
00419         return P_RESULT_TRUE;
00420     else
00421         return P_RESULT_FAIL;
00422 }
00423 
00470 static p_goal_result p_builtin_num_ne
00471     (p_context *context, p_term **args, p_term **error)
00472 {
00473     int cmp = p_builtin_num_cmp(context, args, error);
00474     if (cmp == -2)
00475         return P_RESULT_ERROR;
00476     else if (cmp != 0)
00477         return P_RESULT_TRUE;
00478     else
00479         return P_RESULT_FAIL;
00480 }
00481 
00527 static p_goal_result p_builtin_num_lt
00528     (p_context *context, p_term **args, p_term **error)
00529 {
00530     int cmp = p_builtin_num_cmp(context, args, error);
00531     if (cmp == -2)
00532         return P_RESULT_ERROR;
00533     else if (cmp < 0)
00534         return P_RESULT_TRUE;
00535     else
00536         return P_RESULT_FAIL;
00537 }
00538 
00589 static p_goal_result p_builtin_num_le
00590     (p_context *context, p_term **args, p_term **error)
00591 {
00592     int cmp = p_builtin_num_cmp(context, args, error);
00593     if (cmp == -2)
00594         return P_RESULT_ERROR;
00595     else if (cmp <= 0)
00596         return P_RESULT_TRUE;
00597     else
00598         return P_RESULT_FAIL;
00599 }
00600 
00646 static p_goal_result p_builtin_num_gt
00647     (p_context *context, p_term **args, p_term **error)
00648 {
00649     int cmp = p_builtin_num_cmp(context, args, error);
00650     if (cmp == -2)
00651         return P_RESULT_ERROR;
00652     else if (cmp > 0)
00653         return P_RESULT_TRUE;
00654     else
00655         return P_RESULT_FAIL;
00656 }
00657 
00703 static p_goal_result p_builtin_num_ge
00704     (p_context *context, p_term **args, p_term **error)
00705 {
00706     int cmp = p_builtin_num_cmp(context, args, error);
00707     if (cmp == -2)
00708         return P_RESULT_ERROR;
00709     else if (cmp >= 0)
00710         return P_RESULT_TRUE;
00711     else
00712         return P_RESULT_FAIL;
00713 }
00714 
00755 static p_goal_result p_builtin_atom_name
00756     (p_context *context, p_term **args, p_term **error)
00757 {
00758     p_term *atom = p_term_deref_member(context, args[0]);
00759     p_term *string = p_term_deref_member(context, args[1]);
00760     p_term *result;
00761     if (!atom || !string) {
00762         *error = p_create_instantiation_error(context);
00763         return P_RESULT_ERROR;
00764     }
00765     if (atom->header.type == P_TERM_ATOM) {
00766         result = p_term_create_string_n
00767             (context, p_term_name(atom), p_term_name_length(atom));
00768         if (p_term_unify(context, string, result, P_BIND_DEFAULT))
00769             return P_RESULT_TRUE;
00770         else
00771             return P_RESULT_FAIL;
00772     } else if (atom->header.type & P_TERM_VARIABLE) {
00773         if (string->header.type & P_TERM_VARIABLE) {
00774             *error = p_create_instantiation_error(context);
00775             return P_RESULT_ERROR;
00776         } else if (string->header.type != P_TERM_STRING) {
00777             *error = p_create_type_error(context, "string", string);
00778             return P_RESULT_ERROR;
00779         }
00780         result = p_term_create_atom_n
00781             (context, p_term_name(string), p_term_name_length(string));
00782         if (p_term_unify(context, atom, result, P_BIND_DEFAULT))
00783             return P_RESULT_TRUE;
00784         else
00785             return P_RESULT_FAIL;
00786     } else {
00787         *error = p_create_type_error(context, "atom", atom);
00788         return P_RESULT_ERROR;
00789     }
00790 }
00791 
00843 static p_goal_result p_builtin_fperror
00844     (p_context *context, p_term **args, p_term **error)
00845 {
00846     p_term *type = p_term_deref_member(context, args[0]);
00847     if (!type || (type->header.type & P_TERM_VARIABLE) != 0) {
00848         *error = p_create_instantiation_error(context);
00849         return P_RESULT_ERROR;
00850     }
00851     if (type->header.type != P_TERM_ATOM) {
00852         *error = p_create_type_error(context, "atom", args[0]);
00853         return P_RESULT_ERROR;
00854     }
00855 #if defined(HAVE_FENV_H) && defined(HAVE_FECLEAREXCEPT) && \
00856         defined(HAVE_FETESTEXCEPT)
00857     if (type == p_term_create_atom(context, "clear")) {
00858         feclearexcept(FE_ALL_EXCEPT);
00859         return P_RESULT_TRUE;
00860     } else {
00861         int excepts = 0;
00862         if (type == p_term_create_atom(context, "inexact"))
00863             excepts = FE_INEXACT;
00864         else if (type == p_term_create_atom(context, "overflow"))
00865             excepts = FE_OVERFLOW;
00866         else if (type == p_term_create_atom(context, "undefined"))
00867             excepts = FE_INVALID;
00868         else if (type == p_term_create_atom(context, "underflow"))
00869             excepts = FE_UNDERFLOW;
00870         else if (type == p_term_create_atom(context, "zero_divisor"))
00871             excepts = FE_DIVBYZERO;
00872         else
00873             return P_RESULT_FAIL;
00874         if (fetestexcept(excepts))
00875             return P_RESULT_TRUE;
00876         else
00877             return P_RESULT_FAIL;
00878     }
00879 #else
00880     if (type == p_term_create_atom(context, "clear"))
00881         return P_RESULT_TRUE;
00882     else
00883         return P_RESULT_FAIL;
00884 #endif
00885 }
00886 
00920 static p_goal_result p_builtin_isnan
00921     (p_context *context, p_term **args, p_term **error)
00922 {
00923     p_arith_value value;
00924     p_goal_result result;
00925     result = p_arith_eval(context, &value, args[0], error);
00926     if (result != P_RESULT_TRUE)
00927         return result;
00928     if (value.type == P_TERM_INTEGER) {
00929         return P_RESULT_FAIL;
00930     } else if (value.type == P_TERM_REAL) {
00931         if (isnan(value.real_value))
00932             return P_RESULT_TRUE;
00933         else
00934             return P_RESULT_FAIL;
00935     } else {
00936         *error = p_create_type_error(context, "number", args[0]);
00937         return P_RESULT_ERROR;
00938     }
00939 }
00940 
00978 static p_goal_result p_builtin_isinf
00979     (p_context *context, p_term **args, p_term **error)
00980 {
00981     p_arith_value value;
00982     p_goal_result result;
00983     result = p_arith_eval(context, &value, args[0], error);
00984     if (result != P_RESULT_TRUE)
00985         return result;
00986     if (value.type == P_TERM_INTEGER) {
00987         return P_RESULT_FAIL;
00988     } else if (value.type == P_TERM_REAL) {
00989         if (isinf(value.real_value) != 0)
00990             return P_RESULT_TRUE;
00991         else
00992             return P_RESULT_FAIL;
00993     } else {
00994         *error = p_create_type_error(context, "number", args[0]);
00995         return P_RESULT_ERROR;
00996     }
00997 }
00998 
01039 static p_goal_result p_builtin_randomize_0
01040     (p_context *context, p_term **args, p_term **error)
01041 {
01042     time_t tm;
01043     time(&tm);
01044     context->random_seed = (unsigned int)(tm & 0x7FFFFFFF);
01045     return P_RESULT_TRUE;
01046 }
01047 static p_goal_result p_builtin_randomize_1
01048     (p_context *context, p_term **args, p_term **error)
01049 {
01050     p_term *value = p_term_deref_member(context, args[0]);
01051     if (!value || (value->header.type & P_TERM_VARIABLE) != 0) {
01052         *error = p_create_instantiation_error(context);
01053         return P_RESULT_ERROR;
01054     }
01055     if (value->header.type == P_TERM_INTEGER) {
01056         context->random_seed =
01057             (unsigned int)(p_term_integer_value(value) & 0x7FFFFFFF);
01058     } else if (value->header.type == P_TERM_REAL) {
01059         double v = p_term_real_value(value);
01060         if (v < 0.0)
01061             v = -v;
01062         if (v < 1.0)
01063             v *= 2147483648.0;
01064         context->random_seed = (unsigned int)(((int)v) & 0x7FFFFFFF);
01065     } else {
01066         *error = p_create_type_error(context, "number", value);
01067         return P_RESULT_ERROR;
01068     }
01069     return P_RESULT_TRUE;
01070 }
01071 
01118 static p_goal_result p_arith_add
01119     (p_context *context, p_arith_value *result,
01120      const p_arith_value *values, p_term **args, p_term **error)
01121 {
01122     if (values[0].type == P_TERM_INTEGER) {
01123         if (values[1].type == P_TERM_INTEGER) {
01124             result->type = P_TERM_INTEGER;
01125             result->integer_value =
01126                 values[0].integer_value + values[1].integer_value;
01127             return P_RESULT_TRUE;
01128         } else if (values[1].type == P_TERM_REAL) {
01129             result->type = P_TERM_REAL;
01130             result->real_value =
01131                 values[0].integer_value + values[1].real_value;
01132             return P_RESULT_TRUE;
01133         } else {
01134             *error = p_create_type_error(context, "number", args[1]);
01135             return P_RESULT_ERROR;
01136         }
01137     } else if (values[0].type == P_TERM_REAL) {
01138         if (values[1].type == P_TERM_REAL) {
01139             result->type = P_TERM_REAL;
01140             result->real_value =
01141                 values[0].real_value + values[1].real_value;
01142             return P_RESULT_TRUE;
01143         } else if (values[1].type == P_TERM_INTEGER) {
01144             result->type = P_TERM_REAL;
01145             result->real_value =
01146                 values[0].real_value + values[1].integer_value;
01147             return P_RESULT_TRUE;
01148         } else {
01149             *error = p_create_type_error(context, "number", args[1]);
01150             return P_RESULT_ERROR;
01151         }
01152     } else if (values[0].type == P_TERM_STRING) {
01153         if (values[1].type == P_TERM_STRING) {
01154             result->type = P_TERM_STRING;
01155             result->string_value = p_term_concat_string
01156                 (context, values[0].string_value,
01157                  values[1].string_value);
01158             return P_RESULT_TRUE;
01159         } else {
01160             *error = p_create_type_error(context, "string", args[1]);
01161             return P_RESULT_ERROR;
01162         }
01163     } else {
01164         return P_RESULT_FAIL;
01165     }
01166 }
01167 
01213 static p_goal_result p_arith_neg
01214     (p_context *context, p_arith_value *result,
01215      const p_arith_value *values, p_term **args, p_term **error)
01216 {
01217     if (values[0].type == P_TERM_INTEGER) {
01218         result->type = P_TERM_INTEGER;
01219         result->integer_value = -(values[0].integer_value);
01220         return P_RESULT_TRUE;
01221     } else if (values[0].type == P_TERM_REAL) {
01222         result->type = P_TERM_REAL;
01223         result->real_value = -(values[0].real_value);
01224         return P_RESULT_TRUE;
01225     } else {
01226         *error = p_create_type_error(context, "number", args[0]);
01227         return P_RESULT_ERROR;
01228     }
01229 }
01230 
01271 static p_goal_result p_arith_sub
01272     (p_context *context, p_arith_value *result,
01273      const p_arith_value *values, p_term **args, p_term **error)
01274 {
01275     if (values[0].type == P_TERM_INTEGER) {
01276         if (values[1].type == P_TERM_INTEGER) {
01277             result->type = P_TERM_INTEGER;
01278             result->integer_value =
01279                 values[0].integer_value - values[1].integer_value;
01280             return P_RESULT_TRUE;
01281         } else if (values[1].type == P_TERM_REAL) {
01282             result->type = P_TERM_REAL;
01283             result->real_value =
01284                 values[0].integer_value - values[1].real_value;
01285             return P_RESULT_TRUE;
01286         } else {
01287             *error = p_create_type_error(context, "number", args[1]);
01288             return P_RESULT_ERROR;
01289         }
01290     } else if (values[0].type == P_TERM_REAL) {
01291         if (values[1].type == P_TERM_REAL) {
01292             result->type = P_TERM_REAL;
01293             result->real_value =
01294                 values[0].real_value - values[1].real_value;
01295             return P_RESULT_TRUE;
01296         } else if (values[1].type == P_TERM_INTEGER) {
01297             result->type = P_TERM_REAL;
01298             result->real_value =
01299                 values[0].real_value - values[1].integer_value;
01300             return P_RESULT_TRUE;
01301         } else {
01302             *error = p_create_type_error(context, "number", args[1]);
01303             return P_RESULT_ERROR;
01304         }
01305     } else {
01306         *error = p_create_type_error(context, "number", args[0]);
01307         return P_RESULT_ERROR;
01308     }
01309 }
01310 
01351 static p_goal_result p_arith_mul
01352     (p_context *context, p_arith_value *result,
01353      const p_arith_value *values, p_term **args, p_term **error)
01354 {
01355     if (values[0].type == P_TERM_INTEGER) {
01356         if (values[1].type == P_TERM_INTEGER) {
01357             result->type = P_TERM_INTEGER;
01358             result->integer_value =
01359                 values[0].integer_value * values[1].integer_value;
01360             return P_RESULT_TRUE;
01361         } else if (values[1].type == P_TERM_REAL) {
01362             result->type = P_TERM_REAL;
01363             result->real_value =
01364                 values[0].integer_value * values[1].real_value;
01365             return P_RESULT_TRUE;
01366         } else {
01367             *error = p_create_type_error(context, "number", args[1]);
01368             return P_RESULT_ERROR;
01369         }
01370     } else if (values[0].type == P_TERM_REAL) {
01371         if (values[1].type == P_TERM_REAL) {
01372             result->type = P_TERM_REAL;
01373             result->real_value =
01374                 values[0].real_value * values[1].real_value;
01375             return P_RESULT_TRUE;
01376         } else if (values[1].type == P_TERM_INTEGER) {
01377             result->type = P_TERM_REAL;
01378             result->real_value =
01379                 values[0].real_value * values[1].integer_value;
01380             return P_RESULT_TRUE;
01381         } else {
01382             *error = p_create_type_error(context, "number", args[1]);
01383             return P_RESULT_ERROR;
01384         }
01385     } else {
01386         *error = p_create_type_error(context, "number", args[0]);
01387         return P_RESULT_ERROR;
01388     }
01389 }
01390 
01448 static p_goal_result p_arith_div
01449     (p_context *context, p_arith_value *result,
01450      const p_arith_value *values, p_term **args, p_term **error)
01451 {
01452     if (values[0].type == P_TERM_INTEGER) {
01453         if (values[1].type == P_TERM_INTEGER) {
01454             if (values[1].integer_value != 0) {
01455                 result->type = P_TERM_INTEGER;
01456                 result->integer_value =
01457                     values[0].integer_value / values[1].integer_value;
01458                 return P_RESULT_TRUE;
01459             }
01460         } else if (values[1].type == P_TERM_REAL) {
01461             result->type = P_TERM_REAL;
01462             result->real_value =
01463                 values[0].integer_value / values[1].real_value;
01464             return P_RESULT_TRUE;
01465         } else {
01466             *error = p_create_type_error(context, "number", args[1]);
01467             return P_RESULT_ERROR;
01468         }
01469     } else if (values[0].type == P_TERM_REAL) {
01470         if (values[1].type == P_TERM_REAL) {
01471             result->type = P_TERM_REAL;
01472             result->real_value =
01473                 values[0].real_value / values[1].real_value;
01474             return P_RESULT_TRUE;
01475         } else if (values[1].type == P_TERM_INTEGER) {
01476             result->type = P_TERM_REAL;
01477             result->real_value =
01478                 values[0].real_value / values[1].integer_value;
01479             return P_RESULT_TRUE;
01480         } else {
01481             *error = p_create_type_error(context, "number", args[1]);
01482             return P_RESULT_ERROR;
01483         }
01484     } else {
01485         *error = p_create_type_error(context, "number", args[0]);
01486         return P_RESULT_ERROR;
01487     }
01488     *error = p_create_evaluation_error(context, "zero_divisor");
01489     return P_RESULT_ERROR;
01490 }
01491 
01550 P_INLINE double p_arith_fmod(double x, double y)
01551 {
01552 #if defined(HAVE_FMOD)
01553     return fmod(x, y);
01554 #else
01555     /* Return NaN if we have no way to calculate the remainder */
01556     return 0.0 / 0.0;
01557 #endif
01558 }
01559 static p_goal_result p_arith_mod
01560     (p_context *context, p_arith_value *result,
01561      const p_arith_value *values, p_term **args, p_term **error)
01562 {
01563     if (values[0].type == P_TERM_INTEGER) {
01564         if (values[1].type == P_TERM_INTEGER) {
01565             if (values[1].integer_value != 0) {
01566                 result->type = P_TERM_INTEGER;
01567                 result->integer_value =
01568                     values[0].integer_value % values[1].integer_value;
01569                 return P_RESULT_TRUE;
01570             }
01571         } else if (values[1].type == P_TERM_REAL) {
01572             result->type = P_TERM_REAL;
01573             result->real_value =
01574                 p_arith_fmod(values[0].integer_value,
01575                              values[1].real_value);
01576             return P_RESULT_TRUE;
01577         } else {
01578             *error = p_create_type_error(context, "number", args[1]);
01579             return P_RESULT_ERROR;
01580         }
01581     } else if (values[0].type == P_TERM_REAL) {
01582         if (values[1].type == P_TERM_REAL) {
01583             result->type = P_TERM_REAL;
01584             result->real_value =
01585                 p_arith_fmod(values[0].real_value,
01586                              values[1].real_value);
01587             return P_RESULT_TRUE;
01588         } else if (values[1].type == P_TERM_INTEGER) {
01589             result->type = P_TERM_REAL;
01590             result->real_value =
01591                 p_arith_fmod(values[0].real_value,
01592                              values[1].integer_value);
01593             return P_RESULT_TRUE;
01594         } else {
01595             *error = p_create_type_error(context, "number", args[1]);
01596             return P_RESULT_ERROR;
01597         }
01598     } else {
01599         *error = p_create_type_error(context, "number", args[0]);
01600         return P_RESULT_ERROR;
01601     }
01602     *error = p_create_evaluation_error(context, "zero_divisor");
01603     return P_RESULT_ERROR;
01604 }
01605 
01662 P_INLINE double p_arith_drem(double x, double y)
01663 {
01664 #if defined(HAVE_REMAINDER)
01665     return remainder(x, y);
01666 #elif defined(HAVE_DREM)
01667     return drem(x, y);
01668 #else
01669     if (isnan(x) || isnan(y) || y == 0.0) {
01670         return 0.0 / 0.0;
01671     } else {
01672         double quotient = x / y;
01673         if (quotient >= 0.0)
01674             return x - ceil(quotient) * y;
01675         else
01676             return x - floor(quotient) * y;
01677     }
01678 #endif
01679 }
01680 static p_goal_result p_arith_rem
01681     (p_context *context, p_arith_value *result,
01682      const p_arith_value *values, p_term **args, p_term **error)
01683 {
01684     if (values[0].type == P_TERM_INTEGER) {
01685         if (values[1].type == P_TERM_INTEGER) {
01686             if (values[1].integer_value != 0) {
01687                 result->type = P_TERM_INTEGER;
01688                 result->integer_value =
01689                     values[0].integer_value % values[1].integer_value;
01690                 return P_RESULT_TRUE;
01691             }
01692         } else if (values[1].type == P_TERM_REAL) {
01693             result->type = P_TERM_REAL;
01694             result->real_value =
01695                 p_arith_drem(values[0].integer_value,
01696                              values[1].real_value);
01697             return P_RESULT_TRUE;
01698         } else {
01699             *error = p_create_type_error(context, "number", args[1]);
01700             return P_RESULT_ERROR;
01701         }
01702     } else if (values[0].type == P_TERM_REAL) {
01703         if (values[1].type == P_TERM_REAL) {
01704             result->type = P_TERM_REAL;
01705             result->real_value =
01706                 p_arith_drem(values[0].real_value,
01707                              values[1].real_value);
01708             return P_RESULT_TRUE;
01709         } else if (values[1].type == P_TERM_INTEGER) {
01710             result->type = P_TERM_REAL;
01711             result->real_value =
01712                 p_arith_drem(values[0].real_value,
01713                              values[1].integer_value);
01714             return P_RESULT_TRUE;
01715         } else {
01716             *error = p_create_type_error(context, "number", args[1]);
01717             return P_RESULT_ERROR;
01718         }
01719     } else {
01720         *error = p_create_type_error(context, "number", args[0]);
01721         return P_RESULT_ERROR;
01722     }
01723     *error = p_create_evaluation_error(context, "zero_divisor");
01724     return P_RESULT_ERROR;
01725 }
01726 
01766 static p_goal_result p_arith_and
01767     (p_context *context, p_arith_value *result,
01768      const p_arith_value *values, p_term **args, p_term **error)
01769 {
01770     if (values[0].type == P_TERM_INTEGER) {
01771         if (values[1].type == P_TERM_INTEGER) {
01772             result->type = P_TERM_INTEGER;
01773             result->integer_value =
01774                 values[0].integer_value & values[1].integer_value;
01775             return P_RESULT_TRUE;
01776         } else {
01777             *error = p_create_type_error(context, "integer", args[1]);
01778             return P_RESULT_ERROR;
01779         }
01780     } else {
01781         *error = p_create_type_error(context, "integer", args[0]);
01782         return P_RESULT_ERROR;
01783     }
01784 }
01785 
01825 static p_goal_result p_arith_or
01826     (p_context *context, p_arith_value *result,
01827      const p_arith_value *values, p_term **args, p_term **error)
01828 {
01829     if (values[0].type == P_TERM_INTEGER) {
01830         if (values[1].type == P_TERM_INTEGER) {
01831             result->type = P_TERM_INTEGER;
01832             result->integer_value =
01833                 values[0].integer_value | values[1].integer_value;
01834             return P_RESULT_TRUE;
01835         } else {
01836             *error = p_create_type_error(context, "integer", args[1]);
01837             return P_RESULT_ERROR;
01838         }
01839     } else {
01840         *error = p_create_type_error(context, "integer", args[0]);
01841         return P_RESULT_ERROR;
01842     }
01843 }
01844 
01884 static p_goal_result p_arith_xor
01885     (p_context *context, p_arith_value *result,
01886      const p_arith_value *values, p_term **args, p_term **error)
01887 {
01888     if (values[0].type == P_TERM_INTEGER) {
01889         if (values[1].type == P_TERM_INTEGER) {
01890             result->type = P_TERM_INTEGER;
01891             result->integer_value =
01892                 values[0].integer_value ^ values[1].integer_value;
01893             return P_RESULT_TRUE;
01894         } else {
01895             *error = p_create_type_error(context, "integer", args[1]);
01896             return P_RESULT_ERROR;
01897         }
01898     } else {
01899         *error = p_create_type_error(context, "integer", args[0]);
01900         return P_RESULT_ERROR;
01901     }
01902 }
01903 
01942 static p_goal_result p_arith_not
01943     (p_context *context, p_arith_value *result,
01944      const p_arith_value *values, p_term **args, p_term **error)
01945 {
01946     if (values[0].type == P_TERM_INTEGER) {
01947         result->type = P_TERM_INTEGER;
01948         result->integer_value = ~(values[0].integer_value);
01949         return P_RESULT_TRUE;
01950     } else {
01951         *error = p_create_type_error(context, "integer", args[0]);
01952         return P_RESULT_ERROR;
01953     }
01954 }
01955 
01996 static p_goal_result p_arith_lshift
01997     (p_context *context, p_arith_value *result,
01998      const p_arith_value *values, p_term **args, p_term **error)
01999 {
02000     if (values[0].type == P_TERM_INTEGER) {
02001         if (values[1].type == P_TERM_INTEGER) {
02002             result->type = P_TERM_INTEGER;
02003             result->integer_value =
02004                 values[0].integer_value <<
02005                     (values[1].integer_value & 31);
02006             return P_RESULT_TRUE;
02007         } else {
02008             *error = p_create_type_error(context, "integer", args[1]);
02009             return P_RESULT_ERROR;
02010         }
02011     } else {
02012         *error = p_create_type_error(context, "integer", args[0]);
02013         return P_RESULT_ERROR;
02014     }
02015 }
02016 
02063 static p_goal_result p_arith_rshift
02064     (p_context *context, p_arith_value *result,
02065      const p_arith_value *values, p_term **args, p_term **error)
02066 {
02067     if (values[0].type == P_TERM_INTEGER) {
02068         if (values[1].type == P_TERM_INTEGER) {
02069             result->type = P_TERM_INTEGER;
02070             result->integer_value =
02071                 values[0].integer_value >>
02072                     (values[1].integer_value & 31);
02073             return P_RESULT_TRUE;
02074         } else {
02075             *error = p_create_type_error(context, "integer", args[1]);
02076             return P_RESULT_ERROR;
02077         }
02078     } else {
02079         *error = p_create_type_error(context, "integer", args[0]);
02080         return P_RESULT_ERROR;
02081     }
02082 }
02083 
02123 static p_goal_result p_arith_rushift
02124     (p_context *context, p_arith_value *result,
02125      const p_arith_value *values, p_term **args, p_term **error)
02126 {
02127     if (values[0].type == P_TERM_INTEGER) {
02128         if (values[1].type == P_TERM_INTEGER) {
02129             result->type = P_TERM_INTEGER;
02130             result->integer_value =
02131                 (int)(((unsigned int)(values[0].integer_value)) >>
02132                             (values[1].integer_value & 31));
02133             return P_RESULT_TRUE;
02134         } else {
02135             *error = p_create_type_error(context, "integer", args[1]);
02136             return P_RESULT_ERROR;
02137         }
02138     } else {
02139         *error = p_create_type_error(context, "integer", args[0]);
02140         return P_RESULT_ERROR;
02141     }
02142 }
02143 
02181 static p_goal_result p_arith_abs
02182     (p_context *context, p_arith_value *result,
02183      const p_arith_value *values, p_term **args, p_term **error)
02184 {
02185     if (values[0].type == P_TERM_INTEGER) {
02186         result->type = P_TERM_INTEGER;
02187         if (values[0].integer_value == (int)(-0x7fffffff - 1)) {
02188             *error = p_create_evaluation_error(context, "int_overflow");
02189             return P_RESULT_ERROR;
02190         } else if (values[0].integer_value < 0) {
02191             result->integer_value = -(values[0].integer_value);
02192         } else {
02193             result->integer_value = values[0].integer_value;
02194         }
02195         return P_RESULT_TRUE;
02196     } else if (values[0].type == P_TERM_REAL) {
02197         result->type = P_TERM_REAL;
02198         result->real_value = fabs(values[0].real_value);
02199         return P_RESULT_TRUE;
02200     } else {
02201         *error = p_create_type_error(context, "number", args[0]);
02202         return P_RESULT_ERROR;
02203     }
02204 }
02205 
02241 static p_goal_result p_arith_acos
02242     (p_context *context, p_arith_value *result,
02243      const p_arith_value *values, p_term **args, p_term **error)
02244 {
02245     if (values[0].type == P_TERM_INTEGER) {
02246         result->type = P_TERM_REAL;
02247         result->real_value = acos((double)(values[0].integer_value));
02248         return P_RESULT_TRUE;
02249     } else if (values[0].type == P_TERM_REAL) {
02250         result->type = P_TERM_REAL;
02251         result->real_value = acos(values[0].real_value);
02252         return P_RESULT_TRUE;
02253     } else {
02254         *error = p_create_type_error(context, "number", args[0]);
02255         return P_RESULT_ERROR;
02256     }
02257 }
02258 
02294 static p_goal_result p_arith_asin
02295     (p_context *context, p_arith_value *result,
02296      const p_arith_value *values, p_term **args, p_term **error)
02297 {
02298     if (values[0].type == P_TERM_INTEGER) {
02299         result->type = P_TERM_REAL;
02300         result->real_value = asin((double)(values[0].integer_value));
02301         return P_RESULT_TRUE;
02302     } else if (values[0].type == P_TERM_REAL) {
02303         result->type = P_TERM_REAL;
02304         result->real_value = asin(values[0].real_value);
02305         return P_RESULT_TRUE;
02306     } else {
02307         *error = p_create_type_error(context, "number", args[0]);
02308         return P_RESULT_ERROR;
02309     }
02310 }
02311 
02350 static p_goal_result p_arith_atan
02351     (p_context *context, p_arith_value *result,
02352      const p_arith_value *values, p_term **args, p_term **error)
02353 {
02354     if (values[0].type == P_TERM_INTEGER) {
02355         result->type = P_TERM_REAL;
02356         result->real_value = atan((double)(values[0].integer_value));
02357         return P_RESULT_TRUE;
02358     } else if (values[0].type == P_TERM_REAL) {
02359         result->type = P_TERM_REAL;
02360         result->real_value = atan(values[0].real_value);
02361         return P_RESULT_TRUE;
02362     } else {
02363         *error = p_create_type_error(context, "number", args[0]);
02364         return P_RESULT_ERROR;
02365     }
02366 }
02367 
02409 static p_goal_result p_arith_atan2
02410     (p_context *context, p_arith_value *result,
02411      const p_arith_value *values, p_term **args, p_term **error)
02412 {
02413     if (values[0].type == P_TERM_INTEGER) {
02414         if (values[1].type == P_TERM_INTEGER) {
02415             result->type = P_TERM_REAL;
02416             result->real_value =
02417                 atan2(values[0].integer_value, values[1].integer_value);
02418             return P_RESULT_TRUE;
02419         } else if (values[1].type == P_TERM_REAL) {
02420             result->type = P_TERM_REAL;
02421             result->real_value =
02422                 atan2(values[0].integer_value, values[1].real_value);
02423             return P_RESULT_TRUE;
02424         } else {
02425             *error = p_create_type_error(context, "number", args[1]);
02426             return P_RESULT_ERROR;
02427         }
02428     } else if (values[0].type == P_TERM_REAL) {
02429         if (values[1].type == P_TERM_REAL) {
02430             result->type = P_TERM_REAL;
02431             result->real_value =
02432                 atan2(values[0].real_value, values[1].real_value);
02433             return P_RESULT_TRUE;
02434         } else if (values[1].type == P_TERM_INTEGER) {
02435             result->type = P_TERM_REAL;
02436             result->real_value =
02437                 atan2(values[0].real_value, values[1].integer_value);
02438             return P_RESULT_TRUE;
02439         } else {
02440             *error = p_create_type_error(context, "number", args[1]);
02441             return P_RESULT_ERROR;
02442         }
02443     } else {
02444         *error = p_create_type_error(context, "number", args[0]);
02445         return P_RESULT_ERROR;
02446     }
02447 }
02448 
02491 static p_goal_result p_arith_ceil
02492     (p_context *context, p_arith_value *result,
02493      const p_arith_value *values, p_term **args, p_term **error)
02494 {
02495     if (values[0].type == P_TERM_INTEGER) {
02496         result->type = P_TERM_INTEGER;
02497         result->integer_value = values[0].integer_value;
02498         return P_RESULT_TRUE;
02499     } else if (values[0].type == P_TERM_REAL) {
02500         result->type = P_TERM_REAL;
02501         result->real_value = ceil(values[0].real_value);
02502         return P_RESULT_TRUE;
02503     } else {
02504         *error = p_create_type_error(context, "number", args[0]);
02505         return P_RESULT_ERROR;
02506     }
02507 }
02508 
02547 static p_goal_result p_arith_byte
02548     (p_context *context, p_arith_value *result,
02549      const p_arith_value *values, p_term **args, p_term **error)
02550 {
02551     if (values[0].type == P_TERM_STRING) {
02552         if (values[1].type == P_TERM_INTEGER) {
02553             int index = values[1].integer_value;
02554             if (index >= 0 &&
02555                     index < (int)(values[0].string_value->header.size)) {
02556                 result->type = P_TERM_INTEGER;
02557                 result->integer_value =
02558                     (int)((p_term_name(values[0].string_value))[index]
02559                             & 0xFF);
02560                 return P_RESULT_TRUE;
02561             } else {
02562                 *error = p_create_domain_error
02563                     (context, "string_index", args[1]);
02564                 return P_RESULT_ERROR;
02565             }
02566         } else {
02567             *error = p_create_type_error(context, "integer", args[1]);
02568             return P_RESULT_ERROR;
02569         }
02570     } else {
02571         *error = p_create_type_error(context, "string", args[0]);
02572         return P_RESULT_ERROR;
02573     }
02574 }
02575 
02610 static p_goal_result p_arith_byte_to_string
02611     (p_context *context, p_arith_value *result,
02612      const p_arith_value *values, p_term **args, p_term **error)
02613 {
02614     if (values[0].type == P_TERM_INTEGER) {
02615         int ch = values[0].integer_value;
02616         if (ch >= 0 && ch <= 255) {
02617             char str[1];
02618             str[0] = (char)ch;
02619             result->type = P_TERM_STRING;
02620             result->string_value =
02621                 p_term_create_string_n(context, str, 1);
02622             return P_RESULT_TRUE;
02623         } else {
02624             *error = p_create_type_error(context, "byte", args[0]);
02625             return P_RESULT_ERROR;
02626         }
02627     } else {
02628         *error = p_create_type_error(context, "integer", args[0]);
02629         return P_RESULT_ERROR;
02630     }
02631 }
02632 
02674 static p_goal_result p_arith_char
02675     (p_context *context, p_arith_value *result,
02676      const p_arith_value *values, p_term **args, p_term **error)
02677 {
02678     if (values[0].type == P_TERM_STRING) {
02679         if (values[1].type == P_TERM_INTEGER) {
02680             int index = values[1].integer_value;
02681             const char *str = p_term_name(values[0].string_value);
02682             size_t len = p_term_name_length(values[0].string_value);
02683             size_t size;
02684             int ch;
02685             while (index > 0 && len > 0) {
02686                 ch = _p_term_next_utf8(str, len, &size);
02687                 str += size;
02688                 len -= size;
02689                 --index;
02690             }
02691             if (index == 0 && len > 0) {
02692                 ch = _p_term_next_utf8(str, len, &size);
02693                 result->type = P_TERM_INTEGER;
02694                 result->integer_value = ch;
02695                 return P_RESULT_TRUE;
02696             } else {
02697                 *error = p_create_domain_error
02698                     (context, "string_index", args[1]);
02699                 return P_RESULT_ERROR;
02700             }
02701         } else {
02702             *error = p_create_type_error(context, "integer", args[1]);
02703             return P_RESULT_ERROR;
02704         }
02705     } else {
02706         *error = p_create_type_error(context, "string", args[0]);
02707         return P_RESULT_ERROR;
02708     }
02709 }
02710 
02745 static p_goal_result p_arith_char_to_string
02746     (p_context *context, p_arith_value *result,
02747      const p_arith_value *values, p_term **args, p_term **error)
02748 {
02749     if (values[0].type == P_TERM_INTEGER) {
02750         int ch = values[0].integer_value;
02751         if (ch >= 0 && ch <= 0x10FFFF) {
02752             char str[4];
02753             size_t len;
02754             if (ch < 0x80) {
02755                 str[0] = (char)ch;
02756                 len = 1;
02757             } else if (ch < (1 << (5 + 6))) {
02758                 str[0] = (char)(0xC0 | (ch >> 6));
02759                 str[1] = (char)(0x80 | (ch & 0x3F));
02760                 len = 2;
02761             } else if (ch < (1 << (4 + 6 + 6))) {
02762                 str[0] = (char)(0xE0 | (ch >> 12));
02763                 str[1] = (char)(0x80 | ((ch >> 6) & 0x3F));
02764                 str[2] = (char)(0x80 | (ch & 0x3F));
02765                 len = 3;
02766             } else {
02767                 str[0] = (char)(0xF0 | (ch >> 18));
02768                 str[1] = (char)(0x80 | ((ch >> 12) & 0x3F));
02769                 str[2] = (char)(0x80 | ((ch >> 6) & 0x3F));
02770                 str[3] = (char)(0x80 | (ch & 0x3F));
02771                 len = 4;
02772             }
02773             result->type = P_TERM_STRING;
02774             result->string_value =
02775                 p_term_create_string_n(context, str, len);
02776             return P_RESULT_TRUE;
02777         } else {
02778             *error = p_create_representation_error
02779                 (context, "character_code");
02780             return P_RESULT_ERROR;
02781         }
02782     } else {
02783         *error = p_create_type_error(context, "integer", args[0]);
02784         return P_RESULT_ERROR;
02785     }
02786 }
02787 
02827 static p_goal_result p_arith_cos
02828     (p_context *context, p_arith_value *result,
02829      const p_arith_value *values, p_term **args, p_term **error)
02830 {
02831     if (values[0].type == P_TERM_INTEGER) {
02832         result->type = P_TERM_REAL;
02833         result->real_value = cos((double)(values[0].integer_value));
02834         return P_RESULT_TRUE;
02835     } else if (values[0].type == P_TERM_REAL) {
02836         result->type = P_TERM_REAL;
02837         result->real_value = cos(values[0].real_value);
02838         return P_RESULT_TRUE;
02839     } else {
02840         *error = p_create_type_error(context, "number", args[0]);
02841         return P_RESULT_ERROR;
02842     }
02843 }
02844 
02884 static p_goal_result p_arith_exp
02885     (p_context *context, p_arith_value *result,
02886      const p_arith_value *values, p_term **args, p_term **error)
02887 {
02888     if (values[0].type == P_TERM_INTEGER) {
02889         result->type = P_TERM_REAL;
02890         result->real_value = exp((double)(values[0].integer_value));
02891         return P_RESULT_TRUE;
02892     } else if (values[0].type == P_TERM_REAL) {
02893         result->type = P_TERM_REAL;
02894         result->real_value = exp(values[0].real_value);
02895         return P_RESULT_TRUE;
02896     } else {
02897         *error = p_create_type_error(context, "number", args[0]);
02898         return P_RESULT_ERROR;
02899     }
02900 }
02901 
02925 static p_goal_result p_arith_e
02926     (p_context *context, p_arith_value *result,
02927      const p_arith_value *values, p_term **args, p_term **error)
02928 {
02929     result->type = P_TERM_REAL;
02930     result->real_value = 2.7182818284590452354;
02931     return P_RESULT_TRUE;
02932 }
02933 
02965 static p_goal_result p_arith_float
02966     (p_context *context, p_arith_value *result,
02967      const p_arith_value *values, p_term **args, p_term **error)
02968 {
02969     if (values[0].type == P_TERM_INTEGER) {
02970         result->type = P_TERM_REAL;
02971         result->real_value = values[0].integer_value;
02972         return P_RESULT_TRUE;
02973     } else if (values[0].type == P_TERM_REAL) {
02974         result->type = P_TERM_REAL;
02975         result->real_value = values[0].real_value;
02976         return P_RESULT_TRUE;
02977     } else if (values[0].type == P_TERM_STRING) {
02978         const char *str = p_term_name(values[0].string_value);
02979         char *endptr;
02980         double val;
02981         errno = 0;
02982         val = strtod(str, &endptr);
02983         if (errno == ERANGE || endptr == str) {
02984             /* No conversion performed or value is out of range */
02985             *error = p_create_type_error(context, "number", args[0]);
02986             return P_RESULT_ERROR;
02987         }
02988         while (*endptr == ' ' || *endptr == '\t' ||
02989                *endptr == '\r' || *endptr == '\n')
02990             ++endptr;
02991         if (*endptr != '\0') {
02992             /* Trailing characters other than whitespace */
02993             *error = p_create_type_error(context, "number", args[0]);
02994             return P_RESULT_ERROR;
02995         }
02996         result->type = P_TERM_REAL;
02997         result->real_value = val;
02998         return P_RESULT_TRUE;
02999     } else {
03000         *error = p_create_type_error(context, "number", args[0]);
03001         return P_RESULT_ERROR;
03002     }
03003 }
03004 
03042 static p_goal_result p_arith_float_fractional_part
03043     (p_context *context, p_arith_value *result,
03044      const p_arith_value *values, p_term **args, p_term **error)
03045 {
03046     if (values[0].type == P_TERM_INTEGER) {
03047         result->type = P_TERM_INTEGER;
03048         result->integer_value = 0;
03049         return P_RESULT_TRUE;
03050     } else if (values[0].type == P_TERM_REAL) {
03051         double ipart;
03052         result->type = P_TERM_REAL;
03053         result->real_value = modf(values[0].real_value, &ipart);
03054         return P_RESULT_TRUE;
03055     } else {
03056         *error = p_create_type_error(context, "number", args[0]);
03057         return P_RESULT_ERROR;
03058     }
03059 }
03060 
03098 static p_goal_result p_arith_float_integer_part
03099     (p_context *context, p_arith_value *result,
03100      const p_arith_value *values, p_term **args, p_term **error)
03101 {
03102     if (values[0].type == P_TERM_INTEGER) {
03103         result->type = P_TERM_INTEGER;
03104         result->integer_value = values[0].integer_value;
03105         return P_RESULT_TRUE;
03106     } else if (values[0].type == P_TERM_REAL) {
03107         result->type = P_TERM_REAL;
03108         modf(values[0].real_value, &(result->real_value));
03109         return P_RESULT_TRUE;
03110     } else {
03111         *error = p_create_type_error(context, "number", args[0]);
03112         return P_RESULT_ERROR;
03113     }
03114 }
03115 
03154 static p_goal_result p_arith_floor
03155     (p_context *context, p_arith_value *result,
03156      const p_arith_value *values, p_term **args, p_term **error)
03157 {
03158     if (values[0].type == P_TERM_INTEGER) {
03159         result->type = P_TERM_INTEGER;
03160         result->integer_value = values[0].integer_value;
03161         return P_RESULT_TRUE;
03162     } else if (values[0].type == P_TERM_REAL) {
03163         result->type = P_TERM_REAL;
03164         result->real_value = floor(values[0].real_value);
03165         return P_RESULT_TRUE;
03166     } else {
03167         *error = p_create_type_error(context, "number", args[0]);
03168         return P_RESULT_ERROR;
03169     }
03170 }
03171 
03197 static p_goal_result p_arith_inf
03198     (p_context *context, p_arith_value *result,
03199      const p_arith_value *values, p_term **args, p_term **error)
03200 {
03201     result->type = P_TERM_REAL;
03202     result->real_value = 1.0 / 0.0;
03203     return P_RESULT_TRUE;
03204 }
03205 
03252 static p_goal_result p_arith_integer
03253     (p_context *context, p_arith_value *result,
03254      const p_arith_value *values, p_term **args, p_term **error)
03255 {
03256     if (values[0].type == P_TERM_INTEGER) {
03257         result->type = P_TERM_INTEGER;
03258         result->integer_value = values[0].integer_value;
03259         return P_RESULT_TRUE;
03260     } else if (values[0].type == P_TERM_REAL) {
03261         if (values[0].real_value >= 2147483648.0 ||
03262                 values[0].real_value <= -2147483649.0) {
03263             *error = p_create_evaluation_error(context, "int_overflow");
03264             return P_RESULT_ERROR;
03265         }
03266         result->type = P_TERM_INTEGER;
03267         result->integer_value = (int)(values[0].real_value);
03268         return P_RESULT_TRUE;
03269     } else if (values[0].type == P_TERM_STRING) {
03270         const char *str = p_term_name(values[0].string_value);
03271         char *endptr;
03272         long val;
03273         errno = 0;
03274         val = strtol(str, &endptr, 0);
03275         if (errno == ERANGE) {
03276             /* Value is out of range */
03277             *error = p_create_evaluation_error(context, "int_overflow");
03278             return P_RESULT_ERROR;
03279         } else if (endptr == str) {
03280             /* No conversion performed - data is not an integer */
03281             *error = p_create_type_error(context, "integer", args[0]);
03282             return P_RESULT_ERROR;
03283         }
03284         while (*endptr == ' ' || *endptr == '\t' ||
03285                *endptr == '\r' || *endptr == '\n')
03286             ++endptr;
03287         if (*endptr != '\0') {
03288             /* Trailing characters other than whitespace */
03289             *error = p_create_type_error(context, "integer", args[0]);
03290             return P_RESULT_ERROR;
03291         }
03292         if (val != (int)val) {
03293             /* Value is out of range for a 32-bit integer */
03294             *error = p_create_evaluation_error(context, "int_overflow");
03295             return P_RESULT_ERROR;
03296         }
03297         result->type = P_TERM_INTEGER;
03298         result->integer_value = (int)val;
03299         return P_RESULT_TRUE;
03300     } else {
03301         *error = p_create_type_error(context, "integer", args[0]);
03302         return P_RESULT_ERROR;
03303     }
03304 }
03305 
03347 static p_term *p_arith_mid
03348     (p_context *context, p_term *str, unsigned int start,
03349      unsigned int length)
03350 {
03351     size_t slen = p_term_name_length_utf8(str);
03352     const char *sstart;
03353     const char *sposn;
03354     size_t ch_size;
03355     if (!slen)
03356         return str;
03357     if (start >= slen)
03358         return p_term_create_string_n(context, "", 0);
03359     if (start == 0 && length >= slen)
03360         return str;
03361     if (length > (slen - start))
03362         length = (unsigned int)(slen - start);
03363     sstart = p_term_name(str);
03364     while (slen > 0 && start > 0) {
03365         _p_term_next_utf8(sstart, slen, &ch_size);
03366         sstart += ch_size;
03367         --slen;
03368         --start;
03369     }
03370     sposn = sstart;
03371     while (slen > 0 && length > 0) {
03372         _p_term_next_utf8(sposn, slen, &ch_size);
03373         sposn += ch_size;
03374         --slen;
03375         --length;
03376     }
03377     return p_term_create_string_n(context, sstart, sposn - sstart);
03378 }
03379 static p_goal_result p_arith_left
03380     (p_context *context, p_arith_value *result,
03381      const p_arith_value *values, p_term **args, p_term **error)
03382 {
03383     p_term *str;
03384     int length;
03385     if (values[0].type != P_TERM_STRING) {
03386         *error = p_create_type_error(context, "string", args[0]);
03387         return P_RESULT_ERROR;
03388     }
03389     if (values[1].type != P_TERM_INTEGER) {
03390         *error = p_create_type_error(context, "integer", args[1]);
03391         return P_RESULT_ERROR;
03392     }
03393     str = values[0].string_value;
03394     length = values[1].integer_value;
03395     if (length < 0) {
03396         *error = p_create_domain_error
03397             (context, "not_less_than_zero", args[1]);
03398         return P_RESULT_ERROR;
03399     }
03400     result->type = P_TERM_STRING;
03401     result->string_value = p_arith_mid
03402         (context, str, 0, (unsigned int)length);
03403     return P_RESULT_TRUE;
03404 }
03405 
03447 static p_term *p_arith_mid_bytes
03448     (p_context *context, p_term *str, unsigned int start,
03449      unsigned int length)
03450 {
03451     if (!str->header.size)
03452         return str;
03453     if (start >= str->header.size)
03454         return p_term_create_string_n(context, "", 0);
03455     if (start == 0 && length >= str->header.size)
03456         return str;
03457     if (length > (str->header.size - start))
03458         length = str->header.size - start;
03459     return p_term_create_string_n
03460         (context, str->string.name + start, length);
03461 }
03462 static p_goal_result p_arith_left_bytes
03463     (p_context *context, p_arith_value *result,
03464      const p_arith_value *values, p_term **args, p_term **error)
03465 {
03466     p_term *str;
03467     int length;
03468     if (values[0].type != P_TERM_STRING) {
03469         *error = p_create_type_error(context, "string", args[0]);
03470         return P_RESULT_ERROR;
03471     }
03472     if (values[1].type != P_TERM_INTEGER) {
03473         *error = p_create_type_error(context, "integer", args[1]);
03474         return P_RESULT_ERROR;
03475     }
03476     str = values[0].string_value;
03477     length = values[1].integer_value;
03478     if (length < 0) {
03479         *error = p_create_domain_error
03480             (context, "not_less_than_zero", args[1]);
03481         return P_RESULT_ERROR;
03482     }
03483     result->type = P_TERM_STRING;
03484     result->string_value = p_arith_mid_bytes
03485         (context, str, 0, (unsigned int)length);
03486     return P_RESULT_TRUE;
03487 }
03488 
03521 static p_goal_result p_arith_length
03522     (p_context *context, p_arith_value *result,
03523      const p_arith_value *values, p_term **args, p_term **error)
03524 {
03525     if (values[0].type == P_TERM_STRING) {
03526         result->type = P_TERM_INTEGER;
03527         result->integer_value = (int)
03528             p_term_name_length_utf8(values[0].string_value);
03529         return P_RESULT_TRUE;
03530     } else {
03531         *error = p_create_type_error(context, "string", args[0]);
03532         return P_RESULT_ERROR;
03533     }
03534 }
03535 
03567 static p_goal_result p_arith_length_bytes
03568     (p_context *context, p_arith_value *result,
03569      const p_arith_value *values, p_term **args, p_term **error)
03570 {
03571     if (values[0].type == P_TERM_STRING) {
03572         result->type = P_TERM_INTEGER;
03573         result->integer_value = (int)
03574             p_term_name_length(values[0].string_value);
03575         return P_RESULT_TRUE;
03576     } else {
03577         *error = p_create_type_error(context, "string", args[0]);
03578         return P_RESULT_ERROR;
03579     }
03580 }
03581 
03622 static p_goal_result p_arith_log
03623     (p_context *context, p_arith_value *result,
03624      const p_arith_value *values, p_term **args, p_term **error)
03625 {
03626     if (values[0].type == P_TERM_INTEGER) {
03627         result->type = P_TERM_REAL;
03628         result->real_value = log((double)(values[0].integer_value));
03629         return P_RESULT_TRUE;
03630     } else if (values[0].type == P_TERM_REAL) {
03631         result->type = P_TERM_REAL;
03632         result->real_value = log(values[0].real_value);
03633         return P_RESULT_TRUE;
03634     } else {
03635         *error = p_create_type_error(context, "number", args[0]);
03636         return P_RESULT_ERROR;
03637     }
03638 }
03639 
03698 static p_goal_result p_arith_mid_2
03699     (p_context *context, p_arith_value *result,
03700      const p_arith_value *values, p_term **args, p_term **error)
03701 {
03702     p_term *str;
03703     int start;
03704     if (values[0].type != P_TERM_STRING) {
03705         *error = p_create_type_error(context, "string", args[0]);
03706         return P_RESULT_ERROR;
03707     }
03708     if (values[1].type != P_TERM_INTEGER) {
03709         *error = p_create_type_error(context, "integer", args[1]);
03710         return P_RESULT_ERROR;
03711     }
03712     str = values[0].string_value;
03713     start = values[1].integer_value;
03714     if (start < 0) {
03715         *error = p_create_domain_error
03716             (context, "not_less_than_zero", args[1]);
03717         return P_RESULT_ERROR;
03718     }
03719     result->type = P_TERM_STRING;
03720     result->string_value = p_arith_mid
03721         (context, str, (unsigned int)start, str->header.size);
03722     return P_RESULT_TRUE;
03723 }
03724 static p_goal_result p_arith_mid_3
03725     (p_context *context, p_arith_value *result,
03726      const p_arith_value *values, p_term **args, p_term **error)
03727 {
03728     p_term *str;
03729     int start;
03730     int length;
03731     if (values[0].type != P_TERM_STRING) {
03732         *error = p_create_type_error(context, "string", args[0]);
03733         return P_RESULT_ERROR;
03734     }
03735     if (values[1].type != P_TERM_INTEGER) {
03736         *error = p_create_type_error(context, "integer", args[1]);
03737         return P_RESULT_ERROR;
03738     }
03739     if (values[2].type != P_TERM_INTEGER) {
03740         *error = p_create_type_error(context, "integer", args[2]);
03741         return P_RESULT_ERROR;
03742     }
03743     str = values[0].string_value;
03744     start = values[1].integer_value;
03745     length = values[2].integer_value;
03746     if (start < 0) {
03747         *error = p_create_domain_error
03748             (context, "not_less_than_zero", args[1]);
03749         return P_RESULT_ERROR;
03750     }
03751     if (length < 0) {
03752         *error = p_create_domain_error
03753             (context, "not_less_than_zero", args[2]);
03754         return P_RESULT_ERROR;
03755     }
03756     result->type = P_TERM_STRING;
03757     result->string_value = p_arith_mid
03758         (context, str, (unsigned int)start, (unsigned int)length);
03759     return P_RESULT_TRUE;
03760 }
03761 
03823 static p_goal_result p_arith_mid_bytes_2
03824     (p_context *context, p_arith_value *result,
03825      const p_arith_value *values, p_term **args, p_term **error)
03826 {
03827     p_term *str;
03828     int start;
03829     if (values[0].type != P_TERM_STRING) {
03830         *error = p_create_type_error(context, "string", args[0]);
03831         return P_RESULT_ERROR;
03832     }
03833     if (values[1].type != P_TERM_INTEGER) {
03834         *error = p_create_type_error(context, "integer", args[1]);
03835         return P_RESULT_ERROR;
03836     }
03837     str = values[0].string_value;
03838     start = values[1].integer_value;
03839     if (start < 0) {
03840         *error = p_create_domain_error
03841             (context, "not_less_than_zero", args[1]);
03842         return P_RESULT_ERROR;
03843     }
03844     result->type = P_TERM_STRING;
03845     result->string_value = p_arith_mid_bytes
03846         (context, str, (unsigned int)start, str->header.size);
03847     return P_RESULT_TRUE;
03848 }
03849 static p_goal_result p_arith_mid_bytes_3
03850     (p_context *context, p_arith_value *result,
03851      const p_arith_value *values, p_term **args, p_term **error)
03852 {
03853     p_term *str;
03854     int start;
03855     int length;
03856     if (values[0].type != P_TERM_STRING) {
03857         *error = p_create_type_error(context, "string", args[0]);
03858         return P_RESULT_ERROR;
03859     }
03860     if (values[1].type != P_TERM_INTEGER) {
03861         *error = p_create_type_error(context, "integer", args[1]);
03862         return P_RESULT_ERROR;
03863     }
03864     if (values[2].type != P_TERM_INTEGER) {
03865         *error = p_create_type_error(context, "integer", args[2]);
03866         return P_RESULT_ERROR;
03867     }
03868     str = values[0].string_value;
03869     start = values[1].integer_value;
03870     length = values[2].integer_value;
03871     if (start < 0) {
03872         *error = p_create_domain_error
03873             (context, "not_less_than_zero", args[1]);
03874         return P_RESULT_ERROR;
03875     }
03876     if (length < 0) {
03877         *error = p_create_domain_error
03878             (context, "not_less_than_zero", args[2]);
03879         return P_RESULT_ERROR;
03880     }
03881     result->type = P_TERM_STRING;
03882     result->string_value = p_arith_mid_bytes
03883         (context, str, (unsigned int)start, (unsigned int)length);
03884     return P_RESULT_TRUE;
03885 }
03886 
03912 static p_goal_result p_arith_nan
03913     (p_context *context, p_arith_value *result,
03914      const p_arith_value *values, p_term **args, p_term **error)
03915 {
03916     result->type = P_TERM_REAL;
03917     result->real_value = 0.0 / 0.0;
03918     return P_RESULT_TRUE;
03919 }
03920 
03944 static p_goal_result p_arith_pi
03945     (p_context *context, p_arith_value *result,
03946      const p_arith_value *values, p_term **args, p_term **error)
03947 {
03948     result->type = P_TERM_REAL;
03949     result->real_value = 3.14159265358979323846;
03950     return P_RESULT_TRUE;
03951 }
03952 
04011 static p_goal_result p_arith_pow
04012     (p_context *context, p_arith_value *result,
04013      const p_arith_value *values, p_term **args, p_term **error)
04014 {
04015     if (values[0].type == P_TERM_INTEGER) {
04016         if (values[1].type == P_TERM_INTEGER) {
04017             result->type = P_TERM_REAL;
04018             result->real_value =
04019                 pow(values[0].integer_value, values[1].integer_value);
04020             return P_RESULT_TRUE;
04021         } else if (values[1].type == P_TERM_REAL) {
04022             result->type = P_TERM_REAL;
04023             result->real_value =
04024                 pow(values[0].integer_value, values[1].real_value);
04025             return P_RESULT_TRUE;
04026         } else {
04027             *error = p_create_type_error(context, "number", args[1]);
04028             return P_RESULT_ERROR;
04029         }
04030     } else if (values[0].type == P_TERM_REAL) {
04031         if (values[1].type == P_TERM_REAL) {
04032             result->type = P_TERM_REAL;
04033             result->real_value =
04034                 pow(values[0].real_value, values[1].real_value);
04035             return P_RESULT_TRUE;
04036         } else if (values[1].type == P_TERM_INTEGER) {
04037             result->type = P_TERM_REAL;
04038             result->real_value =
04039                 pow(values[0].real_value, values[1].integer_value);
04040             return P_RESULT_TRUE;
04041         } else {
04042             *error = p_create_type_error(context, "number", args[1]);
04043             return P_RESULT_ERROR;
04044         }
04045     } else {
04046         *error = p_create_type_error(context, "number", args[0]);
04047         return P_RESULT_ERROR;
04048     }
04049 }
04050 
04076 static p_goal_result p_arith_random
04077     (p_context *context, p_arith_value *result,
04078      const p_arith_value *values, p_term **args, p_term **error)
04079 {
04080     context->random_seed = context->random_seed * 1103515245 + 12345;
04081     result->type = P_TERM_REAL;
04082     result->real_value =
04083         (((int)(context->random_seed)) & 0x7FFFFFFF) / 2147483648.0;
04084     return P_RESULT_TRUE;
04085 }
04086 
04128 static p_goal_result p_arith_right
04129     (p_context *context, p_arith_value *result,
04130      const p_arith_value *values, p_term **args, p_term **error)
04131 {
04132     p_term *str;
04133     int length;
04134     size_t str_len;
04135     if (values[0].type != P_TERM_STRING) {
04136         *error = p_create_type_error(context, "string", args[0]);
04137         return P_RESULT_ERROR;
04138     }
04139     if (values[1].type != P_TERM_INTEGER) {
04140         *error = p_create_type_error(context, "integer", args[1]);
04141         return P_RESULT_ERROR;
04142     }
04143     str = values[0].string_value;
04144     length = values[1].integer_value;
04145     if (length < 0) {
04146         *error = p_create_domain_error
04147             (context, "not_less_than_zero", args[1]);
04148         return P_RESULT_ERROR;
04149     }
04150     result->type = P_TERM_STRING;
04151     str_len = p_term_name_length_utf8(str);
04152     if (((size_t)length) >= str_len) {
04153         result->string_value = str;
04154     } else {
04155         result->string_value = p_arith_mid
04156             (context, str, (unsigned int)(str_len - (size_t)length),
04157              (unsigned int)length);
04158     }
04159     return P_RESULT_TRUE;
04160 }
04161 
04203 static p_goal_result p_arith_right_bytes
04204     (p_context *context, p_arith_value *result,
04205      const p_arith_value *values, p_term **args, p_term **error)
04206 {
04207     p_term *str;
04208     int length;
04209     if (values[0].type != P_TERM_STRING) {
04210         *error = p_create_type_error(context, "string", args[0]);
04211         return P_RESULT_ERROR;
04212     }
04213     if (values[1].type != P_TERM_INTEGER) {
04214         *error = p_create_type_error(context, "integer", args[1]);
04215         return P_RESULT_ERROR;
04216     }
04217     str = values[0].string_value;
04218     length = values[1].integer_value;
04219     if (length < 0) {
04220         *error = p_create_domain_error
04221             (context, "not_less_than_zero", args[1]);
04222         return P_RESULT_ERROR;
04223     }
04224     result->type = P_TERM_STRING;
04225     if (length >= str->header.size) {
04226         result->string_value = str;
04227     } else {
04228         result->string_value = p_arith_mid_bytes
04229             (context, str, str->header.size - (unsigned int)length,
04230              (unsigned int)length);
04231     }
04232     return P_RESULT_TRUE;
04233 }
04234 
04235 /* Standardized rounding function that avoids system-specific
04236  * variations in round() and rint() */
04237 P_INLINE double p_arith_round_nearest(double x)
04238 {
04239     if (x >= 0.0) {
04240         double y = floor(x);
04241         if ((x - y) >= 0.5)
04242             return ceil(x);
04243         else
04244             return y;
04245     } else {
04246         double y = ceil(x);
04247         if ((x - y) <= -0.5)
04248             return floor(x);
04249         else
04250             return y;
04251     }
04252 }
04253 
04299 static p_goal_result p_arith_round
04300     (p_context *context, p_arith_value *result,
04301      const p_arith_value *values, p_term **args, p_term **error)
04302 {
04303     if (values[0].type == P_TERM_INTEGER) {
04304         result->type = P_TERM_INTEGER;
04305         result->integer_value = values[0].integer_value;
04306         return P_RESULT_TRUE;
04307     } else if (values[0].type == P_TERM_REAL) {
04308         result->type = P_TERM_REAL;
04309         result->real_value =
04310             p_arith_round_nearest(values[0].real_value);
04311         return P_RESULT_TRUE;
04312     } else {
04313         *error = p_create_type_error(context, "number", args[0]);
04314         return P_RESULT_ERROR;
04315     }
04316 }
04317 
04355 static p_goal_result p_arith_sign
04356     (p_context *context, p_arith_value *result,
04357      const p_arith_value *values, p_term **args, p_term **error)
04358 {
04359     if (values[0].type == P_TERM_INTEGER) {
04360         result->type = P_TERM_INTEGER;
04361         if (values[0].integer_value < 0)
04362             result->integer_value = -1;
04363         else if (values[0].integer_value > 0)
04364             result->integer_value = 1;
04365         else
04366             result->integer_value = 0;
04367         return P_RESULT_TRUE;
04368     } else if (values[0].type == P_TERM_REAL) {
04369         result->type = P_TERM_INTEGER;
04370         if (values[0].real_value < 0.0)
04371             result->integer_value = -1;
04372         else if (values[0].real_value > 0.0)
04373             result->integer_value = 1;
04374         else
04375             result->integer_value = 0;
04376         return P_RESULT_TRUE;
04377     } else {
04378         *error = p_create_type_error(context, "number", args[0]);
04379         return P_RESULT_ERROR;
04380     }
04381 }
04382 
04422 static p_goal_result p_arith_sin
04423     (p_context *context, p_arith_value *result,
04424      const p_arith_value *values, p_term **args, p_term **error)
04425 {
04426     if (values[0].type == P_TERM_INTEGER) {
04427         result->type = P_TERM_REAL;
04428         result->real_value = sin((double)(values[0].integer_value));
04429         return P_RESULT_TRUE;
04430     } else if (values[0].type == P_TERM_REAL) {
04431         result->type = P_TERM_REAL;
04432         result->real_value = sin(values[0].real_value);
04433         return P_RESULT_TRUE;
04434     } else {
04435         *error = p_create_type_error(context, "number", args[0]);
04436         return P_RESULT_ERROR;
04437     }
04438 }
04439 
04478 static p_goal_result p_arith_sqrt
04479     (p_context *context, p_arith_value *result,
04480      const p_arith_value *values, p_term **args, p_term **error)
04481 {
04482     if (values[0].type == P_TERM_INTEGER) {
04483         result->type = P_TERM_REAL;
04484         result->real_value = sqrt((double)(values[0].integer_value));
04485         return P_RESULT_TRUE;
04486     } else if (values[0].type == P_TERM_REAL) {
04487         result->type = P_TERM_REAL;
04488         result->real_value = sqrt(values[0].real_value);
04489         return P_RESULT_TRUE;
04490     } else {
04491         *error = p_create_type_error(context, "number", args[0]);
04492         return P_RESULT_ERROR;
04493     }
04494 }
04495 
04532 static p_goal_result p_arith_string
04533     (p_context *context, p_arith_value *result,
04534      const p_arith_value *values, p_term **args, p_term **error)
04535 {
04536     char buffer[128];
04537     if (values[0].type == P_TERM_INTEGER) {
04538         result->type = P_TERM_STRING;
04539         snprintf(buffer, sizeof(buffer), "%d", values[0].integer_value);
04540         result->string_value = p_term_create_string(context, buffer);
04541         return P_RESULT_TRUE;
04542     } else if (values[0].type == P_TERM_REAL) {
04543         result->type = P_TERM_STRING;
04544         if (isnan(values[0].real_value)) {
04545             result->string_value = p_term_create_string(context, "nan");
04546             return P_RESULT_TRUE;
04547         } else if (isinf(values[0].real_value) != 0) {
04548             if (values[0].real_value < 0)
04549                 result->string_value = p_term_create_string(context, "-inf");
04550             else
04551                 result->string_value = p_term_create_string(context, "inf");
04552             return P_RESULT_TRUE;
04553         }
04554         snprintf(buffer, sizeof(buffer) - 8,
04555                  "%.10g", values[0].real_value);
04556         if (strchr(buffer, '.') == 0 && strchr(buffer, 'e') == 0) {
04557             /* Must have a decimal spec for floating-point values */
04558             strcat(buffer, ".0");
04559         }
04560         result->string_value = p_term_create_string(context, buffer);
04561         return P_RESULT_TRUE;
04562     } else if (values[0].type == P_TERM_STRING) {
04563         result->type = P_TERM_STRING;
04564         result->string_value = values[0].string_value;
04565         return P_RESULT_TRUE;
04566     } else {
04567         *error = p_create_type_error(context, "string", args[0]);
04568         return P_RESULT_ERROR;
04569     }
04570 }
04571 
04608 static p_goal_result p_arith_string_2
04609     (p_context *context, p_arith_value *result,
04610      const p_arith_value *values, p_term **args, p_term **error)
04611 {
04612     char prec[64];
04613     char buffer[128];
04614     if (values[1].type != P_TERM_INTEGER) {
04615         *error = p_create_type_error(context, "integer", args[1]);
04616         return P_RESULT_ERROR;
04617     }
04618     if (values[0].type == P_TERM_INTEGER) {
04619         result->type = P_TERM_STRING;
04620         snprintf(buffer, sizeof(buffer), "%d", values[0].integer_value);
04621         result->string_value = p_term_create_string(context, buffer);
04622         return P_RESULT_TRUE;
04623     } else if (values[0].type == P_TERM_REAL) {
04624         result->type = P_TERM_STRING;
04625         if (isnan(values[0].real_value)) {
04626             result->string_value = p_term_create_string(context, "nan");
04627             return P_RESULT_TRUE;
04628         } else if (isinf(values[0].real_value) != 0) {
04629             if (values[0].real_value < 0)
04630                 result->string_value = p_term_create_string(context, "-inf");
04631             else
04632                 result->string_value = p_term_create_string(context, "inf");
04633             return P_RESULT_TRUE;
04634         }
04635         snprintf(prec, sizeof(prec), "%%.%dg", values[1].integer_value);
04636         snprintf(buffer, sizeof(buffer) - 8,
04637                  prec, values[0].real_value);
04638         if (strchr(buffer, '.') == 0 && strchr(buffer, 'e') == 0) {
04639             /* Must have a decimal spec for floating-point values */
04640             strcat(buffer, ".0");
04641         }
04642         result->string_value = p_term_create_string(context, buffer);
04643         return P_RESULT_TRUE;
04644     } else if (values[0].type == P_TERM_STRING) {
04645         result->type = P_TERM_STRING;
04646         result->string_value = values[0].string_value;
04647         return P_RESULT_TRUE;
04648     } else {
04649         *error = p_create_type_error(context, "string", args[0]);
04650         return P_RESULT_ERROR;
04651     }
04652 }
04653 
04690 static p_goal_result p_arith_tan
04691     (p_context *context, p_arith_value *result,
04692      const p_arith_value *values, p_term **args, p_term **error)
04693 {
04694     if (values[0].type == P_TERM_INTEGER) {
04695         result->type = P_TERM_REAL;
04696         result->real_value = tan((double)(values[0].integer_value));
04697         return P_RESULT_TRUE;
04698     } else if (values[0].type == P_TERM_REAL) {
04699         result->type = P_TERM_REAL;
04700         result->real_value = tan(values[0].real_value);
04701         return P_RESULT_TRUE;
04702     } else {
04703         *error = p_create_type_error(context, "number", args[0]);
04704         return P_RESULT_ERROR;
04705     }
04706 }
04707 
04708 void _p_db_init_arith(p_context *context)
04709 {
04710     static struct p_builtin const builtins[] = {
04711         /* Predicates */
04712         {"is", 2, p_builtin_is},
04713         {"=:=", 2, p_builtin_num_eq},
04714         {"=!=", 2, p_builtin_num_ne},
04715         {"=\\=", 2, p_builtin_num_ne},
04716         {"<", 2, p_builtin_num_lt},
04717         {"<=", 2, p_builtin_num_le},
04718         {"=<", 2, p_builtin_num_le},
04719         {">", 2, p_builtin_num_gt},
04720         {">=", 2, p_builtin_num_ge},
04721         {"atom_name", 2, p_builtin_atom_name},
04722         {"fperror", 1, p_builtin_fperror},
04723         {"isnan", 1, p_builtin_isnan},
04724         {"isinf", 1, p_builtin_isinf},
04725         {"randomize", 0, p_builtin_randomize_0},
04726         {"randomize", 1, p_builtin_randomize_1},
04727         {0, 0, 0}
04728     };
04729     static struct p_arith const ariths[] = {
04730         /* Functions */
04731         {"+", 2, p_arith_add},
04732         {"-", 1, p_arith_neg},
04733         {"-", 2, p_arith_sub},
04734         {"*", 2, p_arith_mul},
04735         {"/", 2, p_arith_div},
04736         {"%", 2, p_arith_mod},
04737         {"**", 2, p_arith_pow},
04738         {"/\\", 2, p_arith_and},
04739         {"\\/", 2, p_arith_or},
04740         {"^", 2, p_arith_xor},
04741         {"~", 1, p_arith_not},
04742         {"\\", 1, p_arith_not},
04743         {"<<", 2, p_arith_lshift},
04744         {">>", 2, p_arith_rshift},
04745         {">>>", 2, p_arith_rushift},
04746         {"abs", 1, p_arith_abs},
04747         {"acos", 1, p_arith_acos},
04748         {"asin", 1, p_arith_asin},
04749         {"atan", 1, p_arith_atan},
04750         {"atan2", 2, p_arith_atan2},
04751         {"byte", 2, p_arith_byte},
04752         {"byte_to_string", 1, p_arith_byte_to_string},
04753         {"ceil", 1, p_arith_ceil},
04754         {"ceiling", 1, p_arith_ceil},
04755         {"char", 2, p_arith_char},
04756         {"char_to_string", 1, p_arith_char_to_string},
04757         {"cos", 1, p_arith_cos},
04758         {"e", 0, p_arith_e},
04759         {"exp", 1, p_arith_exp},
04760         {"float", 1, p_arith_float},
04761         {"float_fractional_part", 1, p_arith_float_fractional_part},
04762         {"float_integer_part", 1, p_arith_float_integer_part},
04763         {"floor", 1, p_arith_floor},
04764         {"inf", 0, p_arith_inf},
04765         {"integer", 1, p_arith_integer},
04766         {"left", 2, p_arith_left},
04767         {"left_bytes", 2, p_arith_left_bytes},
04768         {"length", 1, p_arith_length},
04769         {"length_bytes", 1, p_arith_length_bytes},
04770         {"log", 1, p_arith_log},
04771         {"mid", 2, p_arith_mid_2},
04772         {"mid", 3, p_arith_mid_3},
04773         {"mid_bytes", 2, p_arith_mid_bytes_2},
04774         {"mid_bytes", 3, p_arith_mid_bytes_3},
04775         {"mod", 2, p_arith_mod},
04776         {"nan", 0, p_arith_nan},
04777         {"pi", 0, p_arith_pi},
04778         {"pow", 2, p_arith_pow},
04779         {"random", 0, p_arith_random},
04780         {"rem", 2, p_arith_rem},
04781         {"right", 2, p_arith_right},
04782         {"right_bytes", 2, p_arith_right_bytes},
04783         {"round", 1, p_arith_round},
04784         {"sign", 1, p_arith_sign},
04785         {"sin", 1, p_arith_sin},
04786         {"sqrt", 1, p_arith_sqrt},
04787         {"string", 1, p_arith_string},
04788         {"string", 2, p_arith_string_2},
04789         {"tan", 1, p_arith_tan},
04790         {"truncate", 1, p_arith_integer},
04791         {0, 0, 0}
04792     };
04793     _p_db_register_builtins(context, builtins);
04794     _p_db_register_ariths(context, ariths);
04795 }