objects

#   Copyright © 2008, 2009 Sam Chapin
#
#   This file is part of Gospel.
#
#   Gospel is free software: you can redistribute it and/or modify
#   it under the terms of version 3 of the GNU General Public License
#   as published by the Free Software Foundation.
#
#   Gospel 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 Gospel.  If not, see <http://www.gnu.org/licenses/>.

&self

&maximumConnectionBacklog
&path
&POSIXFileDescriptor
&POSIXFileMode

&selector
&value:

@deadEnd deadEnd
  obj e = slotlessObject(oMessageNotUnderstoodException, 0);
  addCanonSlot(e, sSelector, selector(threadContinuation(currentThread)));
  raise(e);
@null deadEnd
!serialized
  valueReturn(string("<null>"));
!raise
  die("Attempted to raise nil as an exception.");
!handle:
  die("Exception handler requested where none established.");
!identity
  normalReturn;
!interpret
  normalReturn;
!interpretInScope:inEnvironment:
  normalReturn;
!print
  fputs("<null>", stdout);
  fflush(stdout);
  normalReturn;
@defaultMessageTarget object
!interpret
  valueReturn(env(threadContinuation(currentThread)));
@methodBody null
!subexpressions:
  int l = vectorLength(evaluated(threadContinuation(currentThread)));
  valueReturn(l == 1 ? oNull : arg(l - 2));
@internals null
# Used by the core to implement some of the interpreter's behaviour. Not meant for user code.
# The hidden data field contains the symbol table. The default initialization, to NULL, is correct:
#  If we also explicitly initialized it to NULL here, we would be overwriting the symbols of the builtins.
!loadFile:
  char *filename = safeStringValue(arg(0));
  FILE *f = fopen(filename, "r");
  if (!f) die("Could not open \"%s\" for input.", filename);
  continuation c = threadContinuation(currentThread);
  void *lastValue = loadStream(f, env(c), dynamicEnv(c));
  if (lastValue == eSyntaxError) die("Syntax error.");
  valueReturn(lastValue);
!vectorLiteral
  int c = vectorLength(evaluated(threadContinuation(currentThread))) - 1;
  vector v = makeVector(c);
  while (c--) setIdx(v, c, arg(c));
  valueReturn(vectorObject(v));
!methodBody
  int l = vectorLength(evaluated(threadContinuation(currentThread)));
  valueReturn(l == 1 ? oNull : arg(l - 2));
@nave object oInternals
# We stash a pointer to oInternals here to lend it oNave's immunity to garbage collection.
# It would perhaps make more sense to give oInternals the immunity, and let oNave borrow it,
# but future changes to the interpreter may eliminate the need for oInternals.
!return
  retarget(isStackFrame);
  setContinuation(stackFrameContinuation(target));
  valueReturn(oNull);
!return:
  retarget(isStackFrame);
  obj v = shelter(currentThread, arg(0)); // Because it might be orphaned when we change continuations.
  setContinuation(stackFrameContinuation(target));
  valueReturn(v);
!return:atDepth:
  retarget(isStackFrame);
  obj frame = target;
  for (int i = safeIntegerValue(arg(1));;) {
    if (frame == oNave) raise(eBadReturnDepth);
    if (!i--) break;
    frame = proto(frame);
  }
  obj v = shelter(currentThread, arg(0)); // Because it might be orphaned when we change continuations.
  setContinuation(stackFrameContinuation(frame));
  valueReturn(v);
!thisContext
  normalReturn;
!recurse
  retarget(isStackFrame);
  setContinuation(stackFrameContinuation(target));
  gotoNext;
$parser
# TODO: Put the next entry in an "interpreter" namespace when objgen supports it:
$defaultMessageTarget
$true
$false
$object
$nave
$integer
$null
$code
$block
$primitive
$string
$symbol
$exception
$vector
$file
$TCPSocket
$regex
$range
$canon oNamespaceCanon
!dynamicContext
  valueReturn(dynamicEnv(threadContinuation(currentThread)));
!collectGarbage
  forbidGC();
  collectGarbage();
  permitGC();
  normalReturn;
!exit
  exit(0);
@object null
!addMethod:as:
  obj m = blockMethod(check(arg(1), isBlock));
  vector p = duplicateVector(methodParams(m));
  setIdx(p, 0, sSelf);
  valueReturn(addSlot(target,
                      waitFor(arg(0)),
                      method(p, methodBody(m), methodScope(m)),
                      threadContinuation(currentThread)));
!actor
  valueReturn(newActor(target, oNave, oDynamicEnvironment));
!raise
  // TODO: It might be better to swap in the actor's current promise at a different stage, in case e.g. object#raise gets redefined.
  continuation c = threadContinuation(currentThread);
  setContinuation(subexpressionContinuation(currentPromise(),
                                            env(c),
                                            dynamicEnv(c),
                                            dynamicEnv(c),
                                            sHandle_,
                                            newVector(1, target),
                                            0));
  trimStack();
!do:
  obj b = check(arg(0), isBlock), m = blockMethod(b);
  vector statements = methodBody(m);
  int n = vectorLength(statements);
  vector newStatements = makeVector(n);
  for (int i = 0; i < n; ++i)
    setIdx(newStatements, i, waitFor(call(quote(idx(statements, i)), sCascading_, newVector(1, target))));
  invokeBlock(block(blockEnv(b), method(methodParams(m), suffix(target, newStatements), methodScope(m))));
!self
  normalReturn;
!interpretInScope:inEnvironment:
  continuation c = threadContinuation(currentThread);
  setContinuation(newContinuation(origin(c),
                                  sInterpret,
                                  newVector(1, target),
                                  emptyVector, // There should be no reason for anyone to examine this.
                                  waitFor(arg(0)),
                                  waitFor(arg(1)),
                                  oldContinuation(c)));
  gotoNext;
!evaluate:in:
  continuation c = threadContinuation(currentThread);
  setContinuation(subexpressionContinuation(origin(c),
                                            target,
                                            waitFor(arg(1)),
                                            parseString(safeStringValue(arg(0))),
                                            sIdentity,
                                            emptyVector,
                                            oldContinuation(c)));
  gotoNext;
!includeExactPath:in:
  FILE *f = fopen(safeStringValue(arg(0)), "r");
  if (!f) raise(eInclusion);
  void *lastValue = loadStream(f, target, waitFor(arg(1)));
  if (lastValue == eSyntaxError) raise(eSyntaxError);
  valueReturn(lastValue);
!setProto:
  obj p = waitFor(arg(0));
  setProto(target, p);
  valueReturn(p);
!is:
  if (target == waitFor(arg(0))) valueReturn(oTrue);
  valueReturn(oFalse);
!send:
  continuation c = origin(threadContinuation(currentThread));
  setContinuation(subexpressionContinuation(c,
                                            env(c),
                                            dynamicEnv(c),
                                            target,
                                            waitFor(arg(0)),
                                            emptyVector,
                                            oldContinuation(c)));
  gotoNext;
!localMethods
  int n = slotCount(target);
  vector v = makeVector(n);
  while (n--) setIdx(v, n, slotName(target, n));
  valueReturn(vectorObject(v));
!proto
  valueReturn(proto(target));
!identity
  normalReturn;
!addSlot:as:
  valueReturn(addSlot(target, waitFor(arg(0)), arg(1), threadContinuation(currentThread)));
!setSlot:to:
  void **slot = deepLookup(target, waitFor(arg(0)), threadContinuation(currentThread));
  if (!slot) raise(eSettingNonexistantSlot);
  valueReturn(*slot = arg(1));
!instance
  obj o = slotlessObject(target, hiddenEntity(target));
  setVectorType(o, vectorType(target));
  valueReturn(o);
@namespaceCanon object
$serialized string("<canon namespace>")
@vector object emptyVector
!++ appending
  retarget(isVectorObject);
  valueReturn(vectorObject(vectorAppend(vectorObjectVector(target), safeVector(arg(0)))));
!ofLength:containing:
  int l = safeIntegerValue(arg(0));
  if (l < 0) raise(eNegativeVectorLength);
  obj o = arg(1);
  vector v = makeVector(l);
  while (l--) setIdx(v, l, o);
  valueReturn(vectorObject(v));
!length
  retarget(isVectorObject);
  valueReturn(integer(vectorLength(vectorObjectVector(target))));
!at:put:ifAbsent:
  retarget(isVectorObject);
  int i = safeIntegerValue(arg(0));
  vector v = vectorObjectVector(target);
  if (i < 0) i = vectorLength(v) + i;
  if (i < 0 || i >= vectorLength(v)) invokeBlock(arg(2));
  valueReturn(setIdx(v, i, arg(1)));
!at:ifAbsent:
  int i = safeIntegerValue(arg(0));
  vector v = safeVector(target);
  if (i < 0) i = vectorLength(v) + i;
  if (i < 0 || i >= vectorLength(v)) invokeBlock(arg(1));
  valueReturn(idx(v, i));
@primitive object newAtomVector(1, prototypePrimitiveHiddenValue)
@string object newAtomVector(1, 0)
~singleCharacterExpected Attempted to set a string position to something other than a single character.
~negativeStringLength Attempted to create a string with negative length.
~badIntegerRepresentation Attempted to convert into an integer a string that doesn't represent one.
?asDecimalInteger
  retarget(isString);
  obj i = emptyBignum();
  if (mpz_set_str(bignumData(i), stringData(target), 10)) raise(eBadIntegerRepresentation);
  valueReturn(i);
!ofLength:containing:
  obj c = check(arg(1), isString);
  if (stringLength(c) != 1) raise(eSingleCharacterExpected);
  int i = safeIntegerValue(arg(0));
  if (i < 0) raise(eNegativeStringLength);
  vector s = newAtomVector(CELLS_REQUIRED_FOR_BYTES(i + 1));
  memset(vectorData(s), stringIdx(c, 0), i); // TODO: Write barrier.
  ((char *)vectorData(s))[i] = 0; // TODO: Write barrier.
  valueReturn(typedObject(oString, s));
!at:ifAbsent:
  obj s = check(target, isString);
  int i = safeIntegerValue(arg(0)), length = stringLength(s);
  if (i < 0) i = length + i;
  if (i < 0 || i >= length) invokeBlock(arg(1));
  obj c = string(" ");
  setStringIdx(c, 0, stringIdx(s, i));
  valueReturn(c);
!at:put:ifAbsent:
  obj s = check(target, isString);
  int i = safeIntegerValue(arg(0)), length = stringLength(s);
  if (i < 0) i = length + i;
  if (i < 0 || i >= length) invokeBlock(arg(2));
  obj c = check(arg(1), isString);
  if (stringLength(c) != 1) raise(eSingleCharacterExpected);
  setStringIdx(s, i, stringIdx(c, 0));
  valueReturn(c);
!length
  valueReturn(integer(stringLength(check(target, isString))));
!parse
  retarget(isString);
  valueReturn(parseString(stringData(target)));
!serialized
  retarget(isString);
  // FIXME: This should probably convert e.g. newlines to "\n".
  obj quote = string("\""); // TODO: Create this string once, at startup.
  valueReturn(appendStrings(quote, appendStrings(target, quote)));
!++ appending:
  retarget(isString);
  valueReturn(appendStrings(target, check(arg(0), isString)));
!print
  retarget(isString);
  fputs(stringData(target), stdout);
  fflush(stdout);
  normalReturn;
@symbol object newAtomVector(1, 0)
!serialized
  retarget(isSymbol);
  // TODO: Create the dollarsign string once, at startup.
  valueReturn(appendStrings(string("$"), target));
@range object
&from:to:
@regex object makeAtomVector(CELLS_REQUIRED_FOR_BYTES(sizeof(regex_t)))
~regexSyntaxError Syntax error in regex.
~regexOutOfMemory Memory exhausted while matching regex.
~regexDidNotMatch Regex didn't match.
!for:
  vector v = makeAtomVector(CELLS_REQUIRED_FOR_BYTES(sizeof(regex_t)));
  if (regcomp(vectorData(v), safeStringValue(arg(0)), 0)) raise(eRegexSyntaxError);
  valueReturn(typedObject(oRegex, v));
?of:ifAbsent:
  retarget(isRegex);
  char *s = safeStringValue(arg(0));
  regmatch_t indices[1];
  if (regexec(vectorData(hiddenEntity(target)), s, 1, indices, REG_NOTBOL | REG_NOTEOL))
    invokeBlock(arg(1));
  valueReturn(waitFor(call(oRange,
                           sFrom_to_,
                           newVector(2, integer(indices->rm_so), integer(indices->rm_eo)))));
@blockLiteral object method(newVector(1, oSymbol), newVector(1, oBlockLiteral), oNull)
# This could inherit from oMethod, but we're avoiding that because we might want to make oMethod and
# oPrimitive more magical than they are now.
!interpret
  retarget(isBlockLiteral);
  obj m = hiddenEntity(target);
  valueReturn(block(env(threadContinuation(currentThread)),
                    method(methodParams(m), methodBody(m), env(threadContinuation(currentThread)))));
@block object newVector(2, oNull, oMethod)
~blockExpected Block expected.
!bind:
  retarget(isBlock);
  setBlockEnv(target, waitFor(arg(0)));
  normalReturn;
!appliedTo:
  retarget(isBlock);
  vector args = safeVector(waitFor(arg(0)));
  obj m = blockMethod(target);
  if (vectorLength(args) != methodArity(m)) raise(eBadArity);
  setContinuation(methodContinuation(threadContinuation(currentThread), prefix(target, args), m));
  gotoNext;
!arity
  retarget(isBlock);
  valueReturn(integer(methodArity(blockMethod(target))));
@method object newVector(2, newVector(1, oSymbol), newVector(1, oNull))
@quote object
!interpret
  retarget(isQuote);
  valueReturn(unquote(target));
@code object
!definedOn:
  retarget(isCode);
  obj oldTarget = codeTarget(target), newTarget = quote(waitFor(arg(0)));
  if (oldTarget == oMethodBody) {
    // We have been called on the methodBody#subexpressions: message generated by the parser to represent a parenthesized list of statements. We will retarget each statement.
    vector oldBody = codeArgs(target);
    int n = vectorLength(oldBody);
    vector newBody = makeVector(n);
    for (int i = 0; i < n; ++i)
      setIdx(newBody, i, waitFor(call(quote(idx(oldBody, i)), sDefinedOn_, newVector(1, newTarget))));
    valueReturn(message(oMethodBody, sSubexpressions_, newBody));
  }
  valueReturn(message(newTarget, codeSelector(target), codeArgs(target)));
!cascading:
  retarget(isCode);
  obj messageTarget = codeTarget(target), cascadeTarget = quote(arg(0));
  if (messageTarget == oMethodBody) {
    // We have been called on the methodBody#subexpressions: message generated by the parser to represent a parenthesized list of statements. We will cascade each one, meaning that the target expression will be reevaluated for each item. (The other reasonable behaviour would be to cascade only the first statement, but doing it this way allows $cascading: to be used in the implementation of $do: and still yield the expected behaviour for multiple statements on the same line, placed by the parser into a subexpressions node instead of separate items in the main block body that $do: looks at.)
    vector statements = duplicateVector(codeArgs(target));
    for (int i = vectorLength(statements); i--;)
      setIdx(statements,
             i,
             waitFor(call(quote(idx(statements, i)), sCascading_, newVector(1, cascadeTarget))));
    valueReturn(message(oMethodBody, sSubexpressions_, statements));
  }
  valueReturn(message(waitFor(call(quote(messageTarget), sCascading_, newVector(1, cascadeTarget))),
                      codeSelector(target),
                      codeArgs(target)));  
!interpret
  retarget(isCode);
  continuation c = threadContinuation(currentThread);
  setContinuation(newContinuation(origin(c),
                                  codeSelector(target),
                                  emptyVector,
                                  prefix(codeTarget(target) ?: env(c), codeArgs(target)),
                                  env(c),
                                  dynamicEnv(c),
                                  oldContinuation(c)));
  gotoNext;
@endOfFile object
# Returned by the parser when it encounters an end-of-file.
!interpret
  exit(0);
@parser object newAtomVector(1, beginParsing(stdin))
~syntaxError Syntax error.
!read
  // FIXME: This is not typesafe.
  obj parserOutput = parse(hiddenAtom(target));
  if (parserOutput == eSyntaxError) raise(eSyntaxError);
  valueReturn(parserOutput);
@integer object emptyBignumVector()
?serialized
  retarget(isInteger);
  __mpz_struct *i = bignumData(target);
  char s[mpz_sizeinbase(i, 10) + 2]; // Extra are for null terminator and possible minus sign.
  obj o = string(mpz_get_str(s, 10, i));
  valueReturn(o);
?+ plus:
  retarget(isInteger);
  obj z = emptyBignum();
  mpz_add(bignumData(z), bignumData(target), bignumData(check(arg(0), isInteger)));
  valueReturn(z);
?- minus:
  retarget(isInteger);
  obj z = emptyBignum();
  mpz_sub(bignumData(z), bignumData(target), bignumData(check(arg(0), isInteger)));
  valueReturn(z);
?< isLessThan:
  retarget(isInteger);
  valueReturn(mpz_cmp(bignumData(target), bignumData(check(arg(0), isInteger))) < 0 ? oTrue : oFalse);  
?== equals:
  retarget(isInteger);
  valueReturn(mpz_cmp(bignumData(target), bignumData(check(arg(0), isInteger))) ? oFalse : oTrue);
!secondsDelay
  retarget(isInteger);
  int i = integerValue(target);
  while (i) i = sleep(i);
  valueReturn(target);
@TCPSocket fileStream
~socketCreation Error while creating socket.
~socketBinding Error while binding socket.
~socketClosing Error while closing socket.
~socketListening Error while beginning to listen on socket.
~socketAccept Error while accepting connection to socket.
~socketShutdown Error during socket shutdown.
!shutdown
  if (shutdown(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)), SHUT_RDWR))
    raise(eSocketShutdown);
  normalReturn;
!new
  int fd = socket(PF_INET, SOCK_STREAM, 0);
  if (fd == -1) raise(eSocketCreation);
  obj s = slotlessObject(oTCPSocket, emptyVector);
  addSlot(s, sPOSIXFileDescriptor, integer(fd), threadContinuation(currentThread));
  valueReturn(s);
?accept
  struct sockaddr socketParameters;
  socklen_t socketParametersSize = sizeof(struct sockaddr);
  int fd = accept(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)),
                  &socketParameters,
                  &socketParametersSize);
  if (fd == -1) raise(eSocketAccept);
  obj s = slotlessObject(oTCPSocket, emptyVector);
  addSlot(s, sPOSIXFileDescriptor, integer(fd), threadContinuation(currentThread));
  valueReturn(s);
?bind:
  struct sockaddr_in s;
  memset(&s, 0, sizeof(struct sockaddr_in));
  s.sin_family = AF_INET;
  s.sin_port = htons(safeIntegerValue(waitFor(arg(0))));
  s.sin_addr.s_addr = htonl(INADDR_ANY);
  if (bind(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)),
           (struct sockaddr *)&s, (socklen_t)sizeof(struct sockaddr_in)))
    raise(eSocketBinding);
  normalReturn;
!listen
  if (listen(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)),
             safeIntegerValue(call(target, sMaximumConnectionBacklog, emptyVector))))
    raise(eSocketListening);
  normalReturn;
@file object
# Relies on canon.
~errorWhileOpening Error while opening a file.
~errorWhileClosing Error while closing a file.
!openForReading
  int fd = open(safeStringValue(call(target, sPath, emptyVector)), O_RDONLY);
  if (fd == -1) raise(eErrorWhileOpening);
  obj o = typedObject(oFileStream, 0);
  addCanonSlot(o, sPOSIXFileDescriptor, integer(fd));
  valueReturn(o);
!openForWriting
  int fd = open(safeStringValue(call(target, sPath, emptyVector)), O_WRONLY);
  if (fd == -1) raise(eErrorWhileOpening);
  obj o = typedObject(oFileStream, 0);
  addCanonSlot(o, sPOSIXFileDescriptor, integer(fd));
  valueReturn(o);
!openForReadingAndWriting
  int fd = open(safeStringValue(call(target, sPath, emptyVector)), O_RDWR);
  if (fd == -1) raise(eErrorWhileOpening);
  obj o = typedObject(oFileStream, 0);
  addCanonSlot(o, sPOSIXFileDescriptor, integer(fd));
  valueReturn(o);
@fileStream object
~streamRead Error while reading from a POSIX file stream.
~streamWrite Error while writing to a POSIX file stream.
~streamClose Error while closing a POSIX file stream.
?read:
  int count = safeIntegerValue(arg(0));
  char s[count];
  ssize_t i = read(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)), s, count);
  if (i == -1) raise(eStreamRead);
  s[i] = 0;
  valueReturn(string(s));
!write:
  char *s = safeStringValue(arg(0));
  ssize_t i = write(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector)), s, strlen(s));
  if (i == -1) raise(eStreamWrite);
  valueReturn(integer(i));
!close
  if (close(safeIntegerValue(call(target, sPOSIXFileDescriptor, emptyVector))))
    raise(eStreamClose);
  normalReturn;
@true object
@false object
@messageNotUnderstoodException object
@badTypeException object
@exception object
$badType oBadTypeException
$messageNotUnderstood oMessageNotUnderstoodException
~inclusion Error while attempting to open a file for inclusion.
~badArity Wrong number of arguments. 
~stringExpected String expected.
~stackFrameExpected Stack frame expected.
~primitiveExpected Primitive expected.
~vectorExpected Vector expected.
~integerExpected Integer expected.
~negativeVectorLength Attempted to create a vector with negative length.
~messageNotUnderstood Message not understood.
~outOfBounds Out-of-bounds array access.
~badReturnDepth Too many carets in return statement.
~topLevelRecursion Attempted to recurse at the top level.
~settingNonexistantSlot Attempted to set a nonexistant slot.
~gettingNonexistantSlot Attempted to access a nonexistant slot.
~missingArgument Too few arguments to primitive function.
@dynamicEnvironment object newVector(1, oNamespaceCanon)
!setNamespaces:
  retarget(isEnvironment);
  setHiddenData(target, safeVector(waitFor(arg(0))));
  normalReturn;
!namespaces
  retarget(isEnvironment);
  // FIXME: Typesafety?
  valueReturn(vectorObject(hiddenEntity(target)));