cvs/stack/symbols.c

/*
    stack - an interactive interpreter for a stack-based language
    Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program 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 this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

    Authors: Mats Alritzson <masse@fukt.bth.se>
             Teddy Hogeborn <teddy@fukt.bth.se>
*/

#include "stack.h"
#include "messages.h"

/* Print newline. */
extern void nl(environment *env)
{
  printf("\n");
}

/* Print a newline to a port */
extern void nlport(environment *env)
{
  if(check_args(env, 1, port))
    return printerr(env);

  if(fprintf(CAR(env->head)->content.p, "\n") < 0) {
    env->err= 5;
    return printerr(env);
  }

  toss(env);
}

/* Gets the type of a value */
extern void type(environment *env)
{

  if(check_args(env, 1, unknown))
    return printerr(env);

  switch(CAR(env->head)->type){
  case empty:
    push_sym(env, "empty");
    break;
  case unknown:
    push_sym(env, "unknown");
    break;
  case integer:
    push_sym(env, "integer");
    break;
  case tfloat:
    push_sym(env, "float");
    break;
  case string:
    push_sym(env, "string");
    break;
  case symb:
    push_sym(env, "symbol");
    break;
  case func:
    push_sym(env, "function");
    break;
  case tcons:
    push_sym(env, "pair");
    break;
  case port:
    push_sym(env, "port");
    break;
  }
  swap(env);
  if (env->err) return;
  toss(env);
}

/* Print the top element of the stack but don't discard it */
extern void print_(environment *env)
{

  if(check_args(env, 1, unknown))
    return printerr(env);

  print_val(env, CAR(env->head), 0, NULL, stdout);
  if(env->err) return;
  nl(env);
}

/* Prints the top element of the stack */
extern void print(environment *env)
{
  print_(env);
  if(env->err) return;
  toss(env);
}

/* Print the top element of the stack without quotes, but don't
   discard it. */
extern void princ_(environment *env)
{

  if(check_args(env, 1, unknown))
    return printerr(env);

  print_val(env, CAR(env->head), 1, NULL, stdout);
}

/* Prints the top element of the stack without quotes. */
extern void princ(environment *env)
{
  princ_(env);
  if(env->err) return;
  toss(env);
}

/* Print a value to a port, but don't discard it */
extern void printport_(environment *env)
{

  if(check_args(env, 2, port, unknown))
    return printerr(env);

  print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
  if(env->err) return;
  nlport(env);
}

/* Print a value to a port */
extern void printport(environment *env)
{
  printport_(env);
  if(env->err) return;
  toss(env);
}

/* Print, without quotes, to a port, a value, but don't discard it. */
extern void princport_(environment *env)
{

  if(check_args(env, 2, port, unknown))
    return printerr(env);

  print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
  toss(env); if(env->err) return;
}

/* Print, without quotes, to a port, the top element. */
extern void princport(environment *env)
{
  princport_(env);
  if(env->err) return;
  toss(env);
}

/* Rotate the first three elements on the stack. */
extern void rot(environment *env)
{
  value *temp= env->head;

  if(check_args(env, 3, unknown, unknown, unknown))
    return printerr(env);
  
  env->head= CDR(CDR(env->head));
  CDR(CDR(temp))= CDR(env->head);
  CDR(env->head)= temp;
}

/* Relocate elements of the list on the stack. */
extern void expand(environment *env)
{
  value *temp, *new_head;

  if(check_args(env, 1, tcons))
    return printerr(env);

  rev(env);

  if(env->err)
    return;

  /* The first list element is the new stack head */
  new_head= temp= CAR(env->head);

  toss(env);

  /// XXX
  /* Find the end of the list */
  while(CDR(temp)->type != empty) {
    if (CDR(temp)->type == tcons)
      temp= CDR(temp);
    else {
      env->err= 2; /* Improper list */
      return printerr(env); 
    }
  }

  /* Connect the tail of the list with the old stack head */
  CDR(temp)= env->head;
  env->head= new_head;          /* ...and voila! */

}

/* Compares two elements by reference. */
extern void eq(environment *env)
{
  void *left, *right;

  if(check_args(env, 2, unknown, unknown))
    return printerr(env);

  left= CAR(env->head)->content.ptr;
  right= CAR(CDR(env->head))->content.ptr;
  toss(env); toss(env);

  push_int(env, left==right);
}

/* Negates the top element on the stack. */
extern void not(environment *env)
{
  int val;

  if(check_args(env, 1, integer))
    return printerr(env);

  val= CAR(env->head)->content.i;
  toss(env);
  push_int(env, !val);
}

/* Compares the two top elements on the stack and return 0 if they're the
   same. */
extern void neq(environment *env)
{
  eq(env);
  not(env);
}

extern void def(environment *env)
{
  symbol *sym;

  /* Needs two values on the stack, the top one must be a symbol */
  if(check_args(env, 2, symb, unknown))
    return printerr(env);

  /* long names are a pain */
  sym= CAR(env->head)->content.sym;

  /* Bind the symbol to the value */
  sym->val= CAR(CDR(env->head));

  toss(env); toss(env);
} 

/* Clear stack */
extern void clear(environment *env)
{
  env->head= new_val(env);
}

/* Forgets a symbol (remove it from the hash table) */
extern void forget(environment *env)
{
  char* sym_id;

  if(check_args(env, 1, symb))
    return printerr(env);

  sym_id= CAR(env->head)->content.sym->id;
  toss(env);

  return forget_sym(hash(env->symbols, sym_id));
}

/* Returns the current error number to the stack */
extern void errn(environment *env)
{
  push_int(env, env->err);
}

/* "+" */
extern void sx_2b(environment *env)
{
  int a, b;
  float fa, fb;
  size_t len;
  char* new_string;
  value *a_val, *b_val;

  if(check_args(env, 2, string, string)==0) {
    a_val= CAR(env->head);
    b_val= CAR(CDR(env->head));
    protect(a_val); protect(b_val);
    toss(env); if(env->err) return;
    toss(env); if(env->err) return;
    len= strlen(a_val->content.string)+strlen(b_val->content.string)+1;
    new_string= malloc(len);
    assert(new_string != NULL);
    strcpy(new_string, b_val->content.string);
    strcat(new_string, a_val->content.string);
    push_cstring(env, new_string);
    unprotect(a_val); unprotect(b_val);
    free(new_string);
    
    return;
  }
  
  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b+a);

    return;
  }

  if(check_args(env, 2, tfloat, tfloat)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb+fa);
    
    return;
  }

  if(check_args(env, 2, tfloat, integer)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_float(env, b+fa);
    
    return;
  }

  if(check_args(env, 2, integer, tfloat)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb+a);

    return;
  }

  return printerr(env);
}

/* "-" */
extern void sx_2d(environment *env)
{
  int a, b;
  float fa, fb;

  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b-a);

    return;
  }

  if(check_args(env, 2, tfloat, tfloat)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb-fa);
    
    return;
  }

  if(check_args(env, 2, tfloat, integer)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_float(env, b-fa);
    
    return;
  }

  if(check_args(env, 2, integer, tfloat)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb-a);

    return;
  }

  return printerr(env);
}

/* ">" */
extern void sx_3e(environment *env)
{
  int a, b;
  float fa, fb;

  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b>a);

    return;
  }

  if(check_args(env, 2, tfloat, tfloat)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_int(env, fb>fa);
    
    return;
  }

  if(check_args(env, 2, tfloat, integer)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b>fa);
    
    return;
  }

  if(check_args(env, 2, integer, tfloat)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_int(env, fb>a);

    return;
  }

  return printerr(env);
}

/* "<" */
extern void sx_3c(environment *env) 
{
  swap(env); if(env->err) return;
  sx_3e(env);
}

/* "<=" */
extern void sx_3c3d(environment *env)
{
  sx_3e(env); if(env->err) return;
  not(env);
}

/* ">=" */
extern void sx_3e3d(environment *env)
{
  sx_3c(env); if(env->err) return;
  not(env);
}

/* "dup"; duplicates an item on the stack */
extern void sx_647570(environment *env)
{
  if(check_args(env, 1, unknown))
    return printerr(env);

  push_val(env, copy_val(env, CAR(env->head)));
}

/* "if", If-Then */
extern void sx_6966(environment *env)
{
  int truth;

  if(check_args(env, 2, unknown, integer))
    return printerr(env);

  swap(env);
  if(env->err) return;
  
  truth= CAR(env->head)->content.i;

  toss(env);
  if(env->err) return;

  if(truth)
    eval(env);
  else
    toss(env);
}

/* If-Then-Else */
extern void ifelse(environment *env)
{
  int truth;

  if(check_args(env, 3, unknown, unknown, integer))
    return printerr(env);

  rot(env);
  if(env->err) return;
  
  truth= CAR(env->head)->content.i;

  toss(env);
  if(env->err) return;

  if(!truth)
    swap(env);
  if(env->err) return;

  toss(env);
  if(env->err) return;

  eval(env);
}

/* "else" */
extern void sx_656c7365(environment *env)
{

  if(check_args(env, 5, unknown, symb, unknown, symb, integer))
    return printerr(env);

  /// XXX

  if(CAR(CDR(env->head))->type!=symb
     || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
     || CAR(CDR(CDR(CDR(env->head))))->type!=symb
     || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
    env->err= 2;
    return printerr(env);
  }

  swap(env); toss(env); rot(env); toss(env);
  ifelse(env);
}

extern void then(environment *env)
{
   
  if(check_args(env, 3, unknown, symb, integer))
    return printerr(env);

  /// XXX

  if(CAR(CDR(env->head))->type!=symb
     || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
    env->err= 2;
    return printerr(env);
  }

  swap(env); toss(env);
  sx_6966(env);
}

/* "while" */
extern void sx_7768696c65(environment *env)
{
  int truth;
  value *loop, *test;

  if(check_args(env, 2, unknown, integer))
    return printerr(env);

  loop= CAR(env->head);
  protect(loop);
  toss(env); if(env->err) return;

  test= CAR(env->head);
  protect(test);
  toss(env); if(env->err) return;

  do {
    push_val(env, test);
    eval(env);

    /// XXX
    
    if(CAR(env->head)->type != integer) {
      env->err= 2;
      return printerr(env);
    }
    
    truth= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    
    if(truth) {
      push_val(env, loop);
      eval(env);
    } else {
      toss(env);
    }
  
  } while(truth);

  unprotect(loop); unprotect(test);
}


/* "for"; for-loop */
extern void sx_666f72(environment *env)
{
  value *loop;
  int foo1, foo2;

  if(check_args(env, 3, unknown, integer, integer))
    return printerr(env);

  loop= CAR(env->head);
  protect(loop);
  toss(env); if(env->err) return;

  foo2= CAR(env->head)->content.i;
  toss(env); if(env->err) return;

  foo1= CAR(env->head)->content.i;
  toss(env); if(env->err) return;

  if(foo1<=foo2) {
    while(foo1<=foo2) {
      push_int(env, foo1);
      push_val(env, loop);
      eval(env); if(env->err) return;
      foo1++;
    }
  } else {
    while(foo1>=foo2) {
      push_int(env, foo1);
      push_val(env, loop);
      eval(env); if(env->err) return;
      foo1--;
    }
  }
  unprotect(loop);
}

/* Variant of for-loop 
   Requires a list as first argument */
extern void foreach(environment *env)
{  
  value *loop, *foo;
  value *iterator;

  if(check_args(env, 2, unknown, tcons))
    return printerr(env);
  
  loop= CAR(env->head);
  protect(loop);
  toss(env); if(env->err) return;

  foo= CAR(env->head);
  protect(foo);
  toss(env); if(env->err) return;

  iterator= foo;

  while(iterator->type!=empty) {
    push_val(env, CAR(iterator));
    push_val(env, loop);
    eval(env); if(env->err) return;

    /// XXX
    if (iterator->type == tcons){
      iterator= CDR(iterator);
    } else {
      env->err= 2; /* Improper list */
      break;
    }
  }
  unprotect(loop); unprotect(foo);
  
  return printerr(env);
}

/* "to" */
extern void to(environment *env)
{
  int ending, start, i;
  value *iterator, *temp, *end;

  if(check_args(env, 2, integer, integer))
    return printerr(env);

  end= new_val(env);

  ending= CAR(env->head)->content.i;
  toss(env); if(env->err) return;
  start= CAR(env->head)->content.i;
  toss(env); if(env->err) return;

  push_sym(env, "[");

  if(ending>=start) {
    for(i= ending; i>=start; i--)
      push_int(env, i);
  } else {
    for(i= ending; i<=start; i++)
      push_int(env, i);
  }

  iterator= env->head;

  if(iterator->type==empty
     || (CAR(iterator)->type==symb
         && CAR(iterator)->content.sym->id[0]=='[')) {
    temp= end;
    toss(env);
  } else {
    /* Search for first delimiter */
    while(CDR(iterator)->type!=empty 
          && (CAR(CDR(iterator))->type!=symb
              || CAR(CDR(iterator))->content.sym->id[0]!='['))
      iterator= CDR(iterator);
    
    /* Extract list */
    temp= env->head;
    env->head= CDR(iterator);
    CDR(iterator)= end;

    if(env->head->type!=empty)
      toss(env);
  }

  /* Push list */
  push_val(env, temp);
}

/* Read a string */
extern void readline(environment *env)
{
  readlinestream(env, env->inputstream);
}

/* Read a string from a port */
extern void readlineport(environment *env)
{
  FILE *stream;

  if(check_args(env, 1, port))
    return printerr(env);

  stream=CAR(env->head)->content.p;
  readlinestream(env, stream); if(env->err) return;

  swap(env); if(env->err) return;
  toss(env);
}

/* "read"; Read a value and place on stack */
extern void sx_72656164(environment *env)
{
  readstream(env, env->inputstream);
}

/* "readport"; Read a value from a port and place on stack */
extern void readport(environment *env)
{
  FILE *stream;

  if(check_args(env, 1, port))
    return printerr(env);

  stream=CAR(env->head)->content.p;
  readstream(env, stream); if(env->err) return;

  swap(env); if(env->err) return;
  toss(env);
}

#ifdef __linux__
extern void beep(environment *env)
{
  int freq, dur, period, ticks;

  if(check_args(env, 2, integer, integer))
    return printerr(env);

  dur= CAR(env->head)->content.i;
  toss(env);
  freq= CAR(env->head)->content.i;
  toss(env);

  period= 1193180/freq;         /* convert freq from Hz to period
                                   length */
  ticks= dur*.001193180;        /* convert duration from �seconds to
                                   timer ticks */

/*    ticks=dur/1000; */

      /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
  switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
  case 0:
    usleep(dur);
    return;
  case -1:
    env->err= 5;
    return printerr(env);
  default:
    abort();
  }
}
#endif /* __linux__ */

/* "wait" */
extern void sx_77616974(environment *env)
{
  int dur;

  if(check_args(env, 1, integer))
    return printerr(env);

  dur= CAR(env->head)->content.i;
  toss(env);

  usleep(dur);
}


/* "*" */
extern void sx_2a(environment *env)
{
  int a, b;
  float fa, fb;

  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b*a);

    return;
  }

  if(check_args(env, 2, tfloat, tfloat)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb*fa);
    
    return;
  }

  if(check_args(env, 2, tfloat, integer)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_float(env, b*fa);
    
    return;
  }

  if(check_args(env, 2, integer, tfloat)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb*a);

    return;
  }

  return printerr(env);
}

/* "/" */
extern void sx_2f(environment *env)
{
  int a, b;
  float fa, fb;

  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_float(env, b/a);

    return;
  }

  if(check_args(env, 2, tfloat, tfloat)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb/fa);
    
    return;
  }

  if(check_args(env, 2, tfloat, integer)==0) {
    fa= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_float(env, b/fa);
    
    return;
  }

  if(check_args(env, 2, integer, tfloat)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    fb= CAR(env->head)->content.f;
    toss(env); if(env->err) return;
    push_float(env, fb/a);

    return;
  }

  return printerr(env);
}

/* "mod" */
extern void mod(environment *env)
{
  int a, b;

  if(check_args(env, 2, integer, integer)==0) {
    a= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    b= CAR(env->head)->content.i;
    toss(env); if(env->err) return;
    push_int(env, b%a);

    return;
  }

  return printerr(env);
}


/* "div" */
extern void sx_646976(environment *env)
{
  int a, b;

  if(check_args(env, 2, integer, integer))
    return printerr(env);
  
  a= CAR(env->head)->content.i;
  toss(env); if(env->err) return;
  b= CAR(env->head)->content.i;
  toss(env); if(env->err) return;
  push_int(env, (int)b/a);
}


extern void setcar(environment *env)
{

  if(check_args(env, 2, tcons, unknown))
    return printerr(env);

  CAR(CAR(CDR(env->head)))=CAR(env->head);
  toss(env);
}

extern void setcdr(environment *env)
{

  if(check_args(env, 2, tcons, unknown))
    return printerr(env);

  CDR(CAR(CDR(env->head)))=CAR(env->head);
  toss(env);
}

extern void car(environment *env)
{

  if(check_args(env, 1, tcons))
    return printerr(env);

  CAR(env->head)=CAR(CAR(env->head));
}

extern void cdr(environment *env)
{

  if(check_args(env, 1, tcons))
    return printerr(env);

  CAR(env->head)=CDR(CAR(env->head));
}

extern void cons(environment *env)
{
  value *val;

  if(check_args(env, 2, unknown, unknown))
    return printerr(env);

  val=new_val(env);
  val->content.c= malloc(sizeof(pair));
  assert(val->content.c!=NULL);

  env->gc_count += sizeof(pair);
  val->type=tcons;

  CAR(val)= CAR(CDR(env->head));
  CDR(val)= CAR(env->head);

  push_val(env, val);

  swap(env); if(env->err) return;
  toss(env); if(env->err) return;
  swap(env); if(env->err) return;
  toss(env);
}


/* General assoc function */
void assocgen(environment *env, funcp eqfunc)
{
  value *key, *item;

  /* Needs two values on the stack, the top one must be an association
     list */
  if(check_args(env, 2, tcons, unknown))
    return printerr(env);

  key=CAR(CDR(env->head));
  item=CAR(env->head);

  while(item->type == tcons){
    if(CAR(item)->type != tcons){
      env->err= 2;
      return printerr(env);
    }

    push_val(env, key);
    push_val(env, CAR(CAR(item)));
    eqfunc((void*)env); if(env->err) return;

    /* Check the result of 'eqfunc' */
    if(check_args(env, 1, integer))
      return printerr(env);

    if(CAR(env->head)->content.i){
      toss(env); if(env->err) return;
      break;
    }
    toss(env); if(env->err) return;

    if(item->type!=tcons) {
      env->err= 2;
      return printerr(env);
    }

    item=CDR(item);
  }

  if(item->type == tcons){      /* A match was found */
    push_val(env, CAR(item));
  } else {
    push_int(env, 0);
  }
  swap(env); if(env->err) return;
  toss(env); if(env->err) return;
  swap(env); if(env->err) return;
  toss(env);
}


/*  2: 3                        =>                */
/*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
extern void assq(environment *env)
{
  assocgen(env, (void*)eq);
}


/* "do" */
extern void sx_646f(environment *env)
{
  swap(env); if(env->err) return;
  eval(env);
}

/* "open" */
/* 2: "file"                                    */
/* 1: "r"       =>      1: #<port 0x47114711>   */
extern void sx_6f70656e(environment *env)
{
  value *new_port;
  FILE *stream;

  if(check_args(env, 2, string, string))
    return printerr(env);

  stream=fopen(CAR(CDR(env->head))->content.ptr,
               CAR(env->head)->content.ptr);

  if(stream == NULL) {
    env->err= 5;
    return printerr(env);
  }

  new_port=new_val(env);
  new_port->type=port;
  new_port->content.p=stream;

  push_val(env, new_port);

  swap(env); if(env->err) return;
  toss(env); if(env->err) return;
  swap(env); if(env->err) return;
  toss(env);
}


/* "close" */
extern void sx_636c6f7365(environment *env)
{
  int ret;

  if(check_args(env, 1, port))
    return printerr(env);

  ret= fclose(CAR(env->head)->content.p);

  if(ret != 0){
    env->err= 5;
    return printerr(env);
  }

  toss(env);
}


extern void mangle(environment *env)
{
  char *new_string;

  if(check_args(env, 1, string))
    return printerr(env);

  new_string= mangle_str(CAR(env->head)->content.string);

  toss(env);
  if(env->err) return;

  push_cstring(env, new_string);
}

/* "fork" */
extern void sx_666f726b(environment *env)
{
  push_int(env, fork());
}

/* "waitpid" */
extern void sx_77616974706964(environment *env)
{

  if(check_args(env, 1, integer))
    return printerr(env);

  push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
  swap(env); toss(env);
}


/* Discard the top element of the stack. */
extern void toss(environment *env)
{

  if(check_args(env, 1, unknown))
    return printerr(env);

  env->head= CDR(env->head); /* Remove the top stack item */
}


/* Quit stack. */
extern void quit(environment *env)
{
  int i;

  env->head= new_val(env);

  if (env->err) return;
  for(i= 0; i<HASHTBLSIZE; i++) {
    while(env->symbols[i]!= NULL) {
      forget_sym(&(env->symbols[i]));
    }
    env->symbols[i]= NULL;
  }

  env->gc_limit= 0;
  gc_maybe(env);

  words(env);

  if(env->free_string!=NULL)
    free(env->free_string);
  
#ifdef __linux__
  muntrace();
#endif

  exit(EXIT_SUCCESS);
}


/* List all defined words */
extern void words(environment *env)
{
  symbol *temp;
  int i;
  
  for(i= 0; i<HASHTBLSIZE; i++) {
    temp= env->symbols[i];
    while(temp!=NULL) {
#ifdef DEBUG
      if (temp->val != NULL && temp->val->gc.flag.protect)
        printf("(protected) ");
#endif /* DEBUG */
      printf("%s ", temp->id);
      temp= temp->next;
    }
  }
}


/* Only to be called by itself function printstack. */
void print_st(environment *env, value *stack_head, long counter)
{ 
  if(CDR(stack_head)->type != empty)
    print_st(env, CDR(stack_head), counter+1);
  printf("%ld: ", counter);
  print_val(env, CAR(stack_head), 0, NULL, stdout);
  printf("\n");
}


/* Prints the stack. */
extern void printstack(environment *env)
{
  if(env->head->type == empty) {
    printf("Stack Empty\n");
    return;
  }

  print_st(env, env->head, 1);
}


extern void copying(environment *env)
{
  puts(license_message);
}


extern void warranty(environment *env)
{
  puts(warranty_message);
}


/* random */
extern void sx_72616e646f6d(environment *env)
{
  push_int(env, (int)rand());
}


extern void seed(environment *env)
{
  if(check_args(env, 1, integer))
    return printerr(env);

  srand(CAR(env->head)->content.i);
  toss(env);
}


extern void ticks(environment *env)
{
  int val;

  val= (int)time(NULL);
  if(val<0) {
    env->err= 5;
    return printerr(env);
  }
  
  return push_int(env, val);
}


extern void push(environment *env)
{
  symbol *sym;
  value *oldval;
  value *newval;

  if(check_args(env, 2, symb, unknown)==0) {
    sym= CAR(env->head)->content.sym;
    oldval= sym->val;
  
    if(oldval==NULL)
      oldval= new_val(env);

    sym->val= new_val(env);
    sym->val->content.c= malloc(sizeof(pair));
    assert(sym->val->content.c!=NULL);
    env->gc_count += sizeof(pair);
    sym->val->type= tcons;
    CDR(sym->val)= oldval;
    CAR(sym->val)= CAR(CDR(env->head));
    env->head= CDR(CDR(env->head));

    return;
  }

  if(check_args(env, 2, tcons, unknown)==0
     || check_args(env, 2, empty, unknown)==0) {
    oldval= CAR(env->head);
    env->head= CDR(env->head);
    newval= new_val(env);
    newval->content.c= malloc(sizeof(pair));
    assert(newval->content.c!=NULL);
    env->gc_count += sizeof(pair);
    newval->type= tcons;
    CDR(newval)= oldval;
    CAR(newval)= CAR(env->head);
    env->head= CDR(env->head);
    push_val(env, newval);
    
    return;
  }

  return printerr(env);
}


extern void pop(environment *env)
{
  symbol *sym;
  value *val;

  if(check_args(env, 1, symb)==0) {
    sym= CAR(env->head)->content.sym;

    if(sym->val==NULL) {
      env->err= 3;
      return printerr(env);
    }

    env->head= CDR(env->head);
    if(sym->val->type==tcons) {
      push_val(env, CAR(sym->val));
      sym->val= CDR(sym->val);
    } else {
      env->err= 2;
      return printerr(env);
    }

    return;
  }

  if(check_args(env, 1, tcons)==0) {
    val= CAR(env->head);
    env->head= CDR(env->head);
    push_val(env, CAR(val));
    return;
  }

  return printerr(env);
}