diff options
Diffstat (limited to 'agen5/expGuile.c')
| -rw-r--r-- | agen5/expGuile.c | 522 |
1 files changed, 522 insertions, 0 deletions
diff --git a/agen5/expGuile.c b/agen5/expGuile.c new file mode 100644 index 0000000..e05a2a7 --- /dev/null +++ b/agen5/expGuile.c @@ -0,0 +1,522 @@ + +/** + * @file expGuile.c + * + * Time-stamp: "2012-03-04 19:06:37 bkorb" + * + * This module implements the expression functions that should + * be part of Guile. + * + * This file is part of AutoGen. + * Copyright (c) 1992-2012 Bruce Korb - all rights reserved + * + * AutoGen is free software: you can redistribute it and/or modify it + * under the terms of the GNU General Public License as published by the + * Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * AutoGen is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + * See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see <http://www.gnu.org/licenses/>. + */ + +LOCAL teGuileType +ag_scm_type_e(SCM typ) +{ + if (AG_SCM_BOOL_P( typ)) return GH_TYPE_BOOLEAN; + if (AG_SCM_SYM_P( typ)) return GH_TYPE_SYMBOL; + if (AG_SCM_STRING_P(typ)) return GH_TYPE_STRING; + if (AG_SCM_IS_PROC( typ)) return GH_TYPE_PROCEDURE; + if (AG_SCM_CHAR_P( typ)) return GH_TYPE_CHAR; + if (AG_SCM_VEC_P( typ)) return GH_TYPE_VECTOR; + if (AG_SCM_PAIR_P( typ)) return GH_TYPE_PAIR; + if (AG_SCM_NUM_P( typ)) return GH_TYPE_NUMBER; + if (AG_SCM_LIST_P( typ)) return GH_TYPE_LIST; + + return GH_TYPE_UNDEFINED; +} + + +LOCAL SCM +ag_scm_c_eval_string_from_file_line( + char const * pzExpr, char const * pzFile, int line) +{ + SCM port = scm_open_input_string(AG_SCM_STR02SCM(pzExpr)); + + if (OPT_VALUE_TRACE >= TRACE_EVERYTHING) + fprintf(trace_fp, TRACE_EVAL_STRING, pzFile, line, pzExpr); + + { + static SCM file = SCM_UNDEFINED; + static char * pzOldFile = NULL; + + if ((pzOldFile == NULL) || (strcmp(pzOldFile, pzFile) != 0)) { + if (pzOldFile != NULL) + AGFREE(pzOldFile); + AGDUPSTR(pzOldFile, pzFile, "scheme source"); + file = AG_SCM_STR02SCM(pzFile); + } + + { + SCM ln = AG_SCM_INT2SCM(line); + scm_set_port_filename_x(port, file); + scm_set_port_line_x(port, ln); + scm_set_port_column_x(port, SCM_INUM0); + } + } + + { + SCM ans = SCM_UNSPECIFIED; + + /* Read expressions from that port; ignore the values. */ + for (;;) { + SCM form = scm_read(port); + if (SCM_EOF_OBJECT_P(form)) + break; + ans = scm_primitive_eval_x(form); + } + + return ans; + } +} + + +/*=gfunc max + * + * what: maximum value in list + * general_use: + * + * exparg: list , list of values. Strings are converted to numbers ,, list + * + * doc: Return the maximum value in the list +=*/ +SCM +ag_scm_max(SCM list) +{ + int len; + SCM car; + long max_val = LONG_MIN; +# ifndef MAX +# define MAX(m,v) ((v > m) ? v : m) +# endif + len = scm_ilength(list); + if (len <= 0) + return SCM_UNDEFINED; + + while (--len >= 0) { + long val; + + car = SCM_CAR(list); + list = SCM_CDR(list); + + switch (ag_scm_type_e(car)) { + case GH_TYPE_BOOLEAN: + if (car == SCM_BOOL_F) { + val = 0; + } else { + val = 1; + } + break; + + case GH_TYPE_CHAR: + val = (int)AG_SCM_CHAR(car); + break; + + case GH_TYPE_NUMBER: + val = AG_SCM_TO_LONG(car); + break; + + case GH_TYPE_STRING: + val = strtol(ag_scm2zchars(car, "number-in-string"), NULL, 0); + break; + + default: + continue; + } + max_val = MAX(max_val, val); + } + + return AG_SCM_FROM_LONG(max_val); +} + + +/*=gfunc min + * + * what: minimum value in list + * general_use: + * + * exparg: list , list of values. Strings are converted to numbers ,, list + * + * doc: Return the minimum value in the list +=*/ +SCM +ag_scm_min(SCM list) +{ + int len; + SCM car; + long min_val = LONG_MAX; +# ifndef MIN +# define MIN(m,v) ((v < m) ? v : m) +# endif + len = scm_ilength(list); + if (len <= 0) + return SCM_UNDEFINED; + + while (--len >= 0) { + long val; + + car = SCM_CAR(list); + list = SCM_CDR(list); + + switch (ag_scm_type_e(car)) { + case GH_TYPE_BOOLEAN: + if (car == SCM_BOOL_F) { + val = 0; + } else { + val = 1; + } + break; + + case GH_TYPE_CHAR: + val = (int)AG_SCM_CHAR(car); + break; + + case GH_TYPE_NUMBER: + val = AG_SCM_TO_LONG(car); + break; + + case GH_TYPE_STRING: + val = strtol(ag_scm2zchars(car, "number-in-string"), NULL, 0); + break; + + default: + continue; + } + min_val = MIN(min_val, val); + } + + return AG_SCM_FROM_LONG(min_val); +} + + +/*=gfunc sum + * + * what: sum of values in list + * general_use: + * + * exparg: list , list of values. Strings are converted to numbers ,, list + * + * doc: Compute the sum of the list of expressions. +=*/ +SCM +ag_scm_sum(SCM list) +{ + int len = scm_ilength(list); + long sum = 0; + + if (len <= 0) + return AG_SCM_INT2SCM(0); + + do { + SCM car = SCM_CAR(list); + list = SCM_CDR(list); + switch (ag_scm_type_e(car)) { + default: + return SCM_UNDEFINED; + + case GH_TYPE_CHAR: + sum += (long)(unsigned char)AG_SCM_CHAR(car); + break; + + case GH_TYPE_NUMBER: + sum += AG_SCM_TO_LONG(car); + break; + + case GH_TYPE_STRING: + sum += strtol(ag_scm2zchars(car, "number-in-string"), NULL, 0); + } + } while (--len > 0); + + return AG_SCM_FROM_LONG(sum); +} + + +/*=gfunc string_to_c_name_x + * + * what: map non-name chars to underscore + * general_use: + * + * exparg: str , input/output string + * + * doc: Change all the graphic characters that are invalid in a C name token + * into underscores. Whitespace characters are ignored. Any other + * character type (i.e. non-graphic and non-white) will cause a failure. +=*/ +SCM +ag_scm_string_to_c_name_x(SCM str) +{ + int len; + char* pz; + + if (! AG_SCM_STRING_P(str)) + scm_wrong_type_arg(STR_TO_C_NAME, 1, str); + + + + for (pz = (char*)(void*)AG_SCM_CHARS(str), len = AG_SCM_STRLEN(str); + --len >= 0; + pz++) { + + char ch = *pz; + if (IS_ALPHANUMERIC_CHAR(ch) || IS_WHITESPACE_CHAR(ch)) + continue; + + if (! IS_GRAPHIC_CHAR(ch)) + scm_misc_error(STR_TO_C_NAME, STR_TO_C_MAP_FAIL, str); + + *pz = '_'; + } + + return str; +} + + +/*=gfunc string_upcase_x + * + * what: make a string be upper case + * general_use: + * + * exparg: str , input/output string + * + * doc: Change to upper case all the characters in an SCM string. +=*/ +SCM +ag_scm_string_upcase_x(SCM str) +{ + int len; + char* pz; + + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + len = AG_SCM_STRLEN(str); + pz = (char*)(void*)AG_SCM_CHARS(str); + while (--len >= 0) { + char ch = *pz; + if (IS_LOWER_CASE_CHAR(ch)) + *pz = toupper(ch); + pz++; + } + + return str; +} + + +/*=gfunc string_upcase + * + * what: upper case a new string + * general_use: + * + * exparg: str , input string + * + * doc: Create a new SCM string containing the same text as the original, + * only all the lower case letters are changed to upper case. +=*/ +SCM +ag_scm_string_upcase(SCM str) +{ + SCM res; + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + res = AG_SCM_STR2SCM(AG_SCM_CHARS(str), AG_SCM_STRLEN(str)); + scm_string_upcase_x(res); + return res; +} + + +/*=gfunc string_capitalize_x + * + * what: capitalize a string + * general_use: + * + * exparg: str , input/output string + * + * doc: capitalize all the words in an SCM string. +=*/ +SCM +ag_scm_string_capitalize_x(SCM str) +{ + int len; + char* pz; + bool word_start = true; + + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + len = AG_SCM_STRLEN(str); + pz = (char*)(void*)AG_SCM_CHARS(str); + + while (--len >= 0) { + char ch = *pz; + + if (! IS_ALPHANUMERIC_CHAR(ch)) { + word_start = true; + + } else if (word_start) { + word_start = false; + if (IS_LOWER_CASE_CHAR(ch)) + *pz = toupper(ch); + + } else if (IS_UPPER_CASE_CHAR(ch)) + *pz = tolower(ch); + + pz++; + } + + return str; +} + + +/*=gfunc string_capitalize + * + * what: capitalize a new string + * general_use: + * + * exparg: str , input string + * + * doc: Create a new SCM string containing the same text as the original, + * only all the first letter of each word is upper cased and all + * other letters are made lower case. +=*/ +SCM +ag_scm_string_capitalize(SCM str) +{ + SCM res; + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + res = AG_SCM_STR2SCM(AG_SCM_CHARS(str), AG_SCM_STRLEN(str)); + ag_scm_string_capitalize_x(res); + return res; +} + + +/*=gfunc string_downcase_x + * + * what: make a string be lower case + * general_use: + * + * exparg: str , input/output string + * + * doc: Change to lower case all the characters in an SCM string. +=*/ +SCM +ag_scm_string_downcase_x(SCM str) +{ + int len; + char* pz; + + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + len = AG_SCM_STRLEN(str); + pz = (char*)(void*)AG_SCM_CHARS(str); + while (--len >= 0) { + char ch = *pz; + if (IS_UPPER_CASE_CHAR(ch)) + *pz = tolower(ch); + pz++; + } + + return str; +} + + +/*=gfunc string_downcase + * + * what: lower case a new string + * general_use: + * + * exparg: str , input string + * + * doc: Create a new SCM string containing the same text as the original, + * only all the upper case letters are changed to lower case. +=*/ +SCM +ag_scm_string_downcase(SCM str) +{ + SCM res; + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + res = AG_SCM_STR2SCM(AG_SCM_CHARS(str), AG_SCM_STRLEN(str)); + ag_scm_string_downcase_x(res); + return res; +} + + +/*=gfunc string_to_camelcase + * + * what: make a string be CamelCase + * general_use: + * + * exparg: str , input/output string + * + * doc: Capitalize the first letter of each block of letters and numbers, + * and stripping out characters that are not alphanumerics. + * For example, "alpha-beta0gamma" becomes "AlphaBeta0gamma". +=*/ +SCM +ag_scm_string_to_camelcase(SCM str) +{ + int len; + char* pzd, * res; + char* pzs; + bool cap_done = false; + + if (! AG_SCM_STRING_P(str)) + return SCM_UNDEFINED; + + len = AG_SCM_STRLEN(str); + res = pzd = ag_scribble(len + 1); + pzs = (char*)(void*)AG_SCM_CHARS(str); + + while (--len >= 0) { + unsigned int ch = *(pzs++); + if (IS_LOWER_CASE_CHAR(ch)) { + if (! cap_done) { + ch = toupper(ch); + cap_done = true; + } + + } else if (IS_UPPER_CASE_CHAR(ch)) { + if (cap_done) + ch = tolower(ch); + else + cap_done = true; + + } else if (IS_DEC_DIGIT_CHAR(ch)) { + cap_done = false; + + } else { + cap_done = false; + continue; + } + + *(pzd++) = ch; + } + + return AG_SCM_STR2SCM(res, (pzd - res)); +} +/* + * Local Variables: + * mode: C + * c-file-style: "stroustrup" + * indent-tabs-mode: nil + * End: + * end of agen5/expGuile.c */ |