lac : 8647c1ba18e47685616546fd7b7b5fbc065be7ec

     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_eval_string(char *s, lenv_t *env)
   138: {
   139: 	yyscan_t yyscan;
   140: 	struct parse_cb cb;
   141: 
   142: 	cb.fn = (lreg_t (*)(lreg_t,void*))eval;
   143: 	cb.opq = (void *)env;
   144: 	cb.res = NIL;
   145: 
   146: 	yylex_init(&yyscan);
   147: 	yy_scan_string(s, yyscan);
   148: 
   149: 	lac_on_error ({
   150: 	    lac_error_print (stderr);
   151: 	    return NIL;
   152: 	  });
   153: 
   154: 	_sexpr_parse(yyscan, &cb);
   155: 
   156: 	lac_off_error();
   157: 	return cb.res;
   158: }
   159: 
   160: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq)
   161: {
   162: 	yyscan_t yyscan;
   163: 	struct parse_cb cb;
   164: 
   165: 	cb.fn = fn;
   166: 	cb.opq = opq;
   167: 	cb.res = NIL;
   168: 
   169: 	yylex_init(&yyscan);
   170: 	yy_scan_string(s, yyscan);
   171: 
   172: 	_sexpr_parse(yyscan, &cb);
   173: 
   174: 	return cb.res;
   175: }
   176: 
   177: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq)
   178: {
   179: 	yyscan_t yyscan;
   180: 	struct parse_cb cb;
   181: 
   182: 	cb.fn = fn;
   183: 	cb.opq = opq;
   184: 	cb.res = NIL;
   185: 
   186: 	yylex_init(&yyscan);
   187: 	yyset_in(f, yyscan);
   188: 
   189: 	_sexpr_parse(yyscan, &cb);
   190: 	return cb.res;
   191: }
   192: 
   193: 
   194: /*
   195:  * Print
   196:  */
   197: 
   198: static void sexpr_print_cons(FILE *f, lreg_t lr, const char *h)
   199: {
   200:   lreg_t a = car(lr);
   201:   lreg_t d = cdr(lr);
   202: 
   203:   printf(h);
   204:   sexpr_fprint(f, a);
   205: 
   206:   if (d == NIL) {
   207:     fprintf(f, ")");
   208:     return;
   209:   }
   210: 
   211:   if (lreg_raw_type(d) == LREG_CONS)
   212:     sexpr_print_cons(f, d, " ");
   213:   else
   214:     {
   215:       fprintf(f, " . ");
   216:       sexpr_fprint(f, cdr(lr));
   217:       fprintf(f, ")");
   218:     }
   219: }
   220: 
   221: void sexpr_fprint(FILE *f, lreg_t lr)
   222: {
   223:   switch ( lreg_type(lr) )
   224:     {
   225:     case LREG_NIL:
   226:       fprintf(f, "()");
   227:       break;
   228:     case LREG_SYMBOL:
   229:       fprintf(f, "%s", (char *)lreg_raw_ptr(lr));
   230:       break;
   231:     case LREG_STRING:
   232:       fprintf(f, "\"%s\"", (char *)lreg_raw_ptr(lr));
   233:       break;
   234:     case LREG_CONS:
   235:       sexpr_print_cons(f, lr, "(");
   236:       break;
   237:     case LREG_MACRO:
   238:       fprintf(f, "<#MACRO>");
   239:       break;
   240:     case LREG_LAMBDA:
   241:       fprintf(f, "<#LAMBDA>");
   242:       break;
   243:     case LREG_LLPROC:
   244:       fprintf(f, "<#LLPROC>");
   245:       break;
   246:     default:
   247:       if ( !lac_extty_print(f, lr) )
   248: 	fprintf(f, "<??? %d>",(int)lreg_type(lr));
   249:     }
   250:   return;
   251: }

Generated by git2html.