lac : e854b7bfb0163c7ab22a56a471cd8c2c1ec639ba

     1: /*
     2:    lac -- a lisp interpreter
     3:    Copyright (C) 2010 Gianluca Guida
     4: 
     5:    This program is free software; you can redistribute it and/or modify
     6:    it under the terms of the GNU General Public License as published by
     7:    the Free Software Foundation; either version 2 of the License, or
     8:    (at your option) any later version.
     9: 
    10:    This program is distributed in the hope that it will be useful,
    11:    but WITHOUT ANY WARRANTY; without even the implied warranty of
    12:    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13:    GNU General Public License for more details.
    14: 
    15:    You should have received a copy of the GNU General Public License along
    16:    with this program; if not, write to the Free Software Foundation, Inc.,
    17:    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    18: */
    19: 
    20: %{
    21: #define YYSTYPE lreg_t
    22: 
    23: #include <ctype.h>
    24: #include <strings.h>
    25: 
    26: #include <lac.h>
    27: #include "sexpr.h"
    28: #include "private.h"
    29: %}
    30: 
    31: %option noyywrap
    32: %option reentrant
    33: %option bison-bridge
    34: 
    35: WHITESPACE [\ \t\n]
    36: DIGIT [0-9]
    37: HEXDIGIT [0-9a-fA-F]
    38: ALPHA [A-Za-z]
    39: SP_INIT [#\*/:<=>?^_~!$%&+-]
    40: SPECIAL [\*/:<=>?^_~!$%&+-.] 
    41: SIGN [+|-]
    42: 
    43: %%
    44: 
    45: ;(.)*
    46: {WHITESPACE}
    47: 
    48: {SIGN}?{DIGIT}+ {
    49: 	intptr_t n;
    50: 
    51: 	errno = 0;
    52: 	n = strtol(yytext, (char **)NULL, 10);
    53:         *yylval = lac_extty_box(LREG_INTEGER, (void *)n, 0);
    54: 	return INTEGER;
    55: }
    56: 
    57: (#x|0x){HEXDIGIT}+ {
    58: 	intptr_t n;
    59: 
    60: 	errno = 0;
    61: 	n = strtol(yytext+2, (char **)NULL, 16);
    62: 	if ( errno == ERANGE )
    63: 		raise_exception("Integer overflow in input", NIL);
    64: 	*yylval = lac_extty_box(LREG_INTEGER, (void *)n, 0);
    65: 	return INTEGER;
    66:  }
    67: 
    68: (NIL|nil) {
    69: 	*yylval = NIL;
    70: 	return NIHIL;
    71:  }
    72: 
    73: \"[^\"]*\" {
    74: 	size_t len = strlen(yytext);
    75: 	char *s = lac_alloc(len - 1);
    76: 	memcpy(s, yytext+1, len - 2);
    77: 	*yylval = lreg_raw(s, LREG_STRING);
    78: 	return STRING;
    79:  }
    80: 
    81: (({DIGIT}+({SPECIAL}|{ALPHA}))|{ALPHA}|{SP_INIT})({SPECIAL}|{ALPHA}|{DIGIT})* {
    82: 	int i;
    83: 	size_t len = strlen(yytext);
    84: 	char *s = lac_alloc(len + 1);
    85: 	for (i = 0; i < len; i++)
    86: 		*(s+i) = toupper((int)*(yytext+i));
    87: 	*yylval = intern_symbol(s);
    88: 	return SYMBOL;
    89:  }
    90: 
    91: ,@ { return COMMA_AT; }
    92: 
    93: \'  { return QUOTE; }
    94: 
    95: ` { return QUASI; }
    96: 
    97: , { return COMMA; }
    98: 
    99: \( { return OPAREN; }
   100: 
   101: \) { return CPAREN; }
   102: 
   103: \.  { return DOT; }
   104: 
   105: <<EOF>> { return -1; }
   106: 
   107: . { return -1; }
   108: 
   109: 
   110: %%
   111: 
   112: static void _sexpr_parse(yyscan_t yyscan, struct parse_cb *cb)
   113: {
   114: 	int v;
   115: 	lreg_t lr;
   116: 	void *parser;
   117: 
   118: 	parser = ParseAlloc(malloc);
   119: 
   120: 	lac_on_error({
   121: 			ParseFree(parser, free);
   122: 			yylex_destroy(yyscan);
   123: 			_throw();
   124: 	  });
   125: 
   126: 	while((v = yylex(&lr, yyscan)) != -1) {
   127: 		Parse(parser, v, lr, cb);
   128: 	}
   129: 	Parse(parser, ENDPARSE, lr, cb);
   130: 
   131: 	lac_off_error();
   132: 
   133: 	ParseFree(parser, free);
   134: 	yylex_destroy(yyscan);
   135: }
   136: 
   137: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq)
   138: {
   139: 	yyscan_t yyscan;
   140: 	struct parse_cb cb;
   141: 
   142: 	cb.fn = fn;
   143: 	cb.opq = opq;
   144: 	cb.res = NIL;
   145: 
   146: 	yylex_init(&yyscan);
   147: 	yy_scan_string(s, yyscan);
   148: 
   149: 	_sexpr_parse(yyscan, &cb);
   150: 	return cb.res;
   151: }
   152: 
   153: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq)
   154: {
   155: 	yyscan_t yyscan;
   156: 	struct parse_cb cb;
   157: 
   158: 	cb.fn = fn;
   159: 	cb.opq = opq;
   160: 	cb.res = NIL;
   161: 
   162: 	yylex_init(&yyscan);
   163: 	yyset_in(f, yyscan);
   164: 
   165: 	_sexpr_parse(yyscan, &cb);
   166: 	return cb.res;
   167: }
   168: 
   169: 
   170: /*
   171:  * Print
   172:  */
   173: 
   174: static void sexpr_print_cons(FILE *f, lreg_t lr, const char *h)
   175: {
   176:   lreg_t a = car(lr);
   177:   lreg_t d = cdr(lr);
   178: 
   179:   printf(h);
   180:   sexpr_fprint(f, a);
   181: 
   182:   if (d == NIL) {
   183:     fprintf(f, ")");
   184:     return;
   185:   }
   186: 
   187:   if (lreg_raw_type(d) == LREG_CONS)
   188:     sexpr_print_cons(f, d, " ");
   189:   else
   190:     {
   191:       fprintf(f, " . ");
   192:       sexpr_fprint(f, cdr(lr));
   193:       fprintf(f, ")");
   194:     }
   195: }
   196: 
   197: void sexpr_fprint(FILE *f, lreg_t lr)
   198: {
   199:   switch ( lreg_type(lr) )
   200:     {
   201:     case LREG_NIL:
   202:       fprintf(f, "()");
   203:       break;
   204:     case LREG_SYMBOL:
   205:       fprintf(f, "%s", (char *)lreg_raw_ptr(lr));
   206:       break;
   207:     case LREG_STRING:
   208:       fprintf(f, "\"%s\"", (char *)lreg_raw_ptr(lr));
   209:       break;
   210:     case LREG_CONS:
   211:       sexpr_print_cons(f, lr, "(");
   212:       break;
   213:     case LREG_MACRO:
   214:       fprintf(f, "<#MACRO>");
   215:       break;
   216:     case LREG_LAMBDA:
   217:       fprintf(f, "<#LAMBDA>");
   218:       break;
   219:     case LREG_LLPROC:
   220:       fprintf(f, "<#LLPROC>");
   221:       break;
   222:     default:
   223:       if ( !lac_extty_print(f, lr) )
   224: 	fprintf(f, "<??? %d>",(int)lreg_type(lr));
   225:     }
   226:   return;
   227: }