lac : 38a14842379bc1cf15c57f53ae0c5a8265eb3912

     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: 	while((v = yylex(&lr, yyscan)) != -1) {
   121: 		Parse(parser, v, lr, cb);
   122: 	}
   123: 	Parse(parser, ENDPARSE, lr, cb);
   124: 
   125: 	/* XXX: ON EXCEPTION, destroy parser and retrow. */
   126: 
   127: 	ParseFree(parser, free);
   128: 	yylex_destroy(yyscan);
   129: }
   130: 
   131: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq)
   132: {
   133: 	yyscan_t yyscan;
   134: 	struct parse_cb cb;
   135: 
   136: 	cb.fn = fn;
   137: 	cb.opq = opq;
   138: 	cb.res = NIL;
   139: 
   140: 	yylex_init(&yyscan);
   141: 	yy_scan_string(s, yyscan);
   142: 
   143: 	_sexpr_parse(yyscan, &cb);
   144: 	return cb.res;
   145: }
   146: 
   147: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq)
   148: {
   149: 	yyscan_t yyscan;
   150: 	struct parse_cb cb;
   151: 
   152: 	cb.fn = fn;
   153: 	cb.opq = opq;
   154: 	cb.res = NIL;
   155: 
   156: 	yylex_init(&yyscan);
   157: 	yyset_in(f, yyscan);
   158: 
   159: 	_sexpr_parse(yyscan, &cb);
   160: 	return cb.res;
   161: }
   162: 
   163: 
   164: /*
   165:  * Print
   166:  */
   167: 
   168: static void sexpr_print_cons(FILE *f, lreg_t lr, const char *h)
   169: {
   170:   lreg_t a = car(lr);
   171:   lreg_t d = cdr(lr);
   172: 
   173:   printf(h);
   174:   sexpr_fprint(f, a);
   175: 
   176:   if (d == NIL) {
   177:     fprintf(f, ")");
   178:     return;
   179:   }
   180: 
   181:   if (lreg_raw_type(d) == LREG_CONS)
   182:     sexpr_print_cons(f, d, " ");
   183:   else
   184:     {
   185:       fprintf(f, " . ");
   186:       sexpr_fprint(f, cdr(lr));
   187:       fprintf(f, ")");
   188:     }
   189: }
   190: 
   191: void sexpr_fprint(FILE *f, lreg_t lr)
   192: {
   193:   switch ( lreg_type(lr) )
   194:     {
   195:     case LREG_NIL:
   196:       fprintf(f, "()");
   197:       break;
   198:     case LREG_SYMBOL:
   199:       fprintf(f, "%s", (char *)lreg_raw_ptr(lr));
   200:       break;
   201:     case LREG_STRING:
   202:       fprintf(f, "\"%s\"", (char *)lreg_raw_ptr(lr));
   203:       break;
   204:     case LREG_CONS:
   205:       sexpr_print_cons(f, lr, "(");
   206:       break;
   207:     case LREG_MACRO:
   208:       fprintf(f, "<#MACRO>");
   209:       break;
   210:     case LREG_LAMBDA:
   211:       fprintf(f, "<#LAMBDA>");
   212:       break;
   213:     case LREG_LLPROC:
   214:       fprintf(f, "<#LLPROC>");
   215:       break;
   216:     default:
   217:       if ( !lac_extty_print(f, lr) )
   218: 	fprintf(f, "<??? %d>",(int)lreg_type(lr));
   219:     }
   220:   return;
   221: }