pt-lisp/implementations/c/src/reader.c

#include <ctype.h>
#include <stdlib.h>
#include "lisp.h"

static Pointer READTABLE;

Pointer character(Char c) {
  Pointer ptr = memory_new(CHAR, sizeof(Char));
  CHAR(ptr) = c;
  return ptr;
}

unsigned get_utf8(FILE* s) {
  unsigned c = fgetc(s);
  if (c & 0x80 && c & 0x40) {
    switch(c >> 3 & 0x07) {
    case 0:
    case 1:
    case 2:
    case 3:
      c |= fgetc(s) << 8;
      break;
    case 4:
    case 5:
      c |= fgetc(s) << 8;
      c |= fgetc(s) << 16;
      break;
    case 6:
      c |= fgetc(s) << 8;
      c |= fgetc(s) << 16;
      c |= fgetc(s) << 24;
      break;
    default: break;
    }
  }
  return c;
}

unsigned unget_utf8(unsigned c, FILE* s) {
  switch (c & 0x80808000) {
  case 0x80808000: ungetc(c >> 24, s);
  case 0x00808000: ungetc(c >> 16, s);
  case 0x00008000: ungetc(c >> 8, s);
  }
  ungetc(c, s);
  return c;
}

Pointer stream(FILE* s) {
  Pointer ptr = memory_new(STREAM, sizeof(Stream));
  STREAM(ptr) = s;
  return ptr;
}

Char peek_char(Pointer type, Stream stream) {
  Char c;
  if (feof(stream)) return 0;
  if (type == NIL) {
    return unget_utf8(get_utf8(stream), stream);
  }
  if (type == T) {
    while(isspace((char) (c = get_utf8(stream))) && !feof(stream));
    if (feof(stream)) return 0;
    return unget_utf8(c, stream);
  }
  if (TYPE(type) == CHAR) {
    while((c = get_utf8(stream)) != CHAR(type) && !feof(stream));
    if (feof(stream)) return 0;
    return unget_utf8(c, stream);
  }

  return UNDEFINED;
}

Pointer peek_char_fn(Pointer args, Pointer env) {
  Pointer type = CAR(args);
  Pointer streamPtr = CAR(CDR(args));
  Stream stream = streamPtr == NIL
    ? STREAM(environment_get(env, STANDARD_INPUT))
    : STREAM(streamPtr);

  Char c = peek_char(type, stream);
  if (feof(stream)) {
    return NIL;
  }

  return character(c);
}

Pointer read_char_fn(Pointer args, Pointer env) {
  Pointer streamPtr = CAR(args);
  Stream stream = streamPtr == NIL
    ? STREAM(environment_get(env, STANDARD_INPUT))
    : STREAM(streamPtr);
  if (feof(stream)) {
    return NIL;
  }

  return character(get_utf8(stream));
}

static Pointer buffer;

Pointer read1(Pointer streamPtr, Pointer env) {
  Stream stream = STREAM(streamPtr);
  double num = 0;
  Pointer macro;
  Char c = peek_char(T, stream);
  if (feof(stream)) return NIL;

  macro = table_get(READTABLE, c);
  if (macro != UNDEFINED) {
    switch(memory_get(macro)->type) {
    case NATIVE_FUNC:
      return NATIVE_FUNC(macro)(LIST(streamPtr, character(get_utf8(stream))), env);
    case FUNC:
      return eval_fn(LIST(macro, streamPtr, character(get_utf8(stream))), env);
    default: break;
    }
  }
  
  string_clear(buffer);
  while ((c = peek_char(NIL, stream)) != 0 &&
	 !isspace((char) c) &&
	 table_get(READTABLE, c) == UNDEFINED) {
    buffer = string_push(buffer, getc(stream));
  }
  buffer = string_push(buffer, '\0');

  char* end;
  num = strtod(STRING(buffer).data, &end);
  if ((size_t) end == (size_t) STRING(buffer).data + STRING(buffer).length - 1) {
    return number(num);
  }

  return symbol(STRING(buffer).data, STRING(buffer).length - 1);
}

Pointer read_fn(Pointer args, Pointer env) {
  Pointer streamPtr = CAR(args);
  streamPtr = streamPtr == NIL ? environment_get(env, STANDARD_INPUT) : streamPtr;
  Stream stream = STREAM(streamPtr);
  Pointer result = read1(streamPtr, env);
  char c;
  while((c = getc(stream)) && isspace(c) && c != '\n');
  if (c != '\n') ungetc(c, stream);
  return result;
}

Pointer set_reader_macro(Pointer c, Pointer fn) {
  READTABLE = table_set(READTABLE, c, fn);
  return T;
}

Pointer set_reader_macro_fn(Pointer args, Pointer env) {
  (void) env;
  return set_reader_macro(CAR(args), CAR(CDR (args)));
}

static bool return_char(Stream stream) {
  Char c;
  return feof(stream) ||
    (c = peek_char(NIL, stream)) == 0 ||
    isspace((char) c) ||
    table_get(READTABLE, c) != UNDEFINED;
}

static char space[] = "SPACE";
static char tab[] = "TAB";
static char newline[] = "NEWLINE";

Pointer read_char_macro(Pointer args, Pointer env) {
  (void) env;
  Pointer streamPtr = CAR(args);
  Stream stream = streamPtr == NIL
    ? STREAM(environment_get(env, STANDARD_INPUT))
    : STREAM(streamPtr);
  Char c = get_utf8(stream);

  if (return_char(stream)) {
    return character(c);
  }

  int pos = 0;
  char searched_char = 0;
  c = toupper(c);
  if (c == (unsigned) space[pos]) {
    pos++;
    searched_char = ' ';
  } else if (c == (unsigned) tab[pos]) {
    pos++;
    searched_char = '\t';
  } else if (c == (unsigned) newline[pos]) {
    pos++;
    searched_char = '\n';
  }

  while (!feof(stream) &&
	 (c = get_utf8(stream)) &&
	 !isspace((char) c) &&
	 table_get(READTABLE, c) == UNDEFINED &&
	 searched_char != 0) {
    c = toupper(c);
    switch (searched_char) {
    case ' ':
      if (c == (unsigned) space[pos]) {
	if (pos == sizeof(space) - 2 && return_char(stream)) {
	  return character(' ');
	}
	pos++;
	continue;
      }
      break;
    case '\t':
      if (c == (unsigned) tab[pos]) {
	if (pos == sizeof(tab) - 2 && return_char(stream)) {
	  return character('\t');
	}
	pos++;
	continue;
      }
      break;
    case '\n':
      if (c == (unsigned) newline[pos]) {
	if (pos == sizeof(newline) - 2 && return_char(stream)) {
	  return character('\n');
	}
	pos++;
	continue;
      }
    }
    break;
  }

  return UNDEFINED; // ERROR!
}

Pointer read_list_macro(Pointer args, Pointer env) {
  Pointer streamPtr = CAR(args);
  Stream stream = streamPtr == NIL
    ? STREAM(environment_get(env, STANDARD_INPUT))
    : STREAM(streamPtr);
  Pointer car = read_fn(args, env);
  Pointer cdr = NIL;
  char c = peek_char(T, stream);

  if (!feof(stream)) {
    if (c != ')') {
      cdr = read_list_macro(args, env);
    } else {
      get_utf8(stream);
    }
  }

  return cons(car, cdr);
}

Pointer read_right_paren_macro(Pointer args, Pointer env) {
  (void) args; (void) env;
  return NIL; // TODO: Should return an error when the error system is set.
}

void reader_init(void) {
  buffer = string(NULL, 0);
  READTABLE = table(1);
  READTABLE = table_set(READTABLE, '(', native_func(read_list_macro));
  READTABLE = table_set(READTABLE, ')', native_func(read_list_macro));
  READTABLE = table_set(READTABLE, '\\', native_func(read_char_macro));
}