gscheme/php/scheme.php

<?
function author()
{
?>
<HR>

By Marko Riedel, 
<A HREF=mailto:mriedel@neuearbeit.de>
mriedel@neuearbeit.de</A>,
<A HREF=http://www.geocities.com/markoriedelde/index.html TARGET=_top>
http://www.geocities.com/markoriedelde/index.html.</A>
<?
}

session_start();

session_register("images");

if(empty($images)){
    $images = array();
}

if(isset($genImage)){
    if(empty($images[$genImage])){
	exit;
    }

    $imagedata = $images[$genImage];

    Header("Content-type: image/jpeg");
    
    $offsx = -(int)$imagedata[0]+3;
    $offsy = -(int)$imagedata[1]+3;

    $dimx   = (int)($imagedata[2]-$imagedata[0])+6;
    $dimy   = (int)($imagedata[3]-$imagedata[1])+6;

    $im    = ImageCreate($dimx, $dimy);
    $black = ImageColorAllocate($im, 0, 0, 0);
    $white = ImageColorAllocate($im, 255, 255, 255);
    ImageFill($im, 0, 0, $white);

    $currentx   = -$offsx;
    $currenty   = -$offsy;
    $currentcol = $black;

    for($ind=0, $data=$imagedata[4]; $ind<count($data); $ind++){
	$cmd = $data[$ind];

	if($cmd[0]==2){
	    $currentcol = 
		 ImageColorAllocate($im, $cmd[1], $cmd[2], $cmd[3]); 
	}
	else{
	    if($cmd[0]==1){
		ImageLine($im, $currentx+$offsx, $dimy-($currenty+$offsy), 
		          $cmd[1]+$offsx, $dimy-($cmd[2]+$offsy), 
		          $currentcol);

	    }
	    $currentx = $cmd[1];
	    $currenty = $cmd[2];
	}
    }

    ImageJPEG($im);
    ImageDestroy($im);

    exit;
}

function tokenize($text)
{
    global $tokens, $base;

    $tokens=array(); $base=0;
    $lines=explode("\n", $text);

    for($lind=0; $lind<count($lines); $lind++){
	if(preg_match("/^([^;]*);/", $lines[$lind], $parts)){
	    $lines[$lind]=$parts[1];
	}
	for($current=$lines[$lind], $ltokens=array(); 
	     preg_match("/([^\"]*)\"([^\"]*)\"(.*)$/", 
			$current, $parts);
	    $current=$parts[3]){
	    if(strlen($parts[1])>0){
		$ltokens[]=$parts[1];
	    }
	    $ltokens[]=array('string', $parts[2]);
	}
	if(strlen($current)){
	    $ltokens[]=$current;
	}

	for($tok=0; $tok<count($ltokens); $tok++){
	    if(is_array($ltokens[$tok])){
		$tokens[] = $ltokens[$tok];
	    }
	    else{
		for($tok1=0, $nosp=preg_split("/\s+/", $ltokens[$tok]);
		    $tok1<count($nosp); $tok1++){
		    for($current=$nosp[$tok1]; 
			preg_match("/([^\(\)\']*)(\(|\)|\')(.*)$/", 
				   $current, $parts);
			$current=$parts[3]){
			if(strlen($parts[1])>0){
			    $tokens[]=array('text', $parts[1]);
			}
			if($parts[2]=='('){
			    $tokens[]=array('left');
			}
			else if($parts[2]==')'){
			    $tokens[]=array('right');
			}
			else{
			    $tokens[]=array('quote');
			}
		    }
		    if(strlen($current)){
			$tokens[]=array('text', $current);
		    }
		}
	    }
	}
    }
}

$envindex = 0;
$environments = array();

function newenv($table)
{
  global $envindex, $environments;

  $environments[$envindex++] = $table;
  return ($envindex-1);
}

function writetoenv($tag, $sym, $val)
{
  global $environments;

  $environments[$tag][$sym] = $val;
}

function readfromenv($tag, $sym)
{
  global $environments;

  $val = $environments[$tag][$sym];
  if(isset($val)){
    return $val;
  }
  return -1;
}

function newval($type, $val)
{
  return array($type, $val);
}

function valtype($v)
{
  return $v[0];
}

function valdata($v)
{
  return $v[1];
}

$thunkindex = 0;
$thunks = array();

function newthunk()
{
  global $thunkindex, $thunks;

  $thunks[$thunkindex++] = array(-1, -1);
  return array('thunk', $thunkindex-1);
}

function writeargptothunk($t, $argp)
{
  global $thunks;
  $thunks[$t[1]][0] = $argp;
}

function readargpfromthunk($t)
{
  global $thunks;
  return $thunks[$t[1]][0];
}

function writeenvptothunk($t, $envp)
{
  global $thunks;
  $thunks[$t[1]][1] = $envp;
}

function readenvpfromthunk($t)
{
  global $thunks;
  return $thunks[$t[1]][1];
}

$closureindex = 0;
$closures = array();

function newclosure($args, $code, $argtype, $env)
{
  global $closureindex, $closures;

  $closures[$closureindex++] = array($args, $code, $argtype, $env);
  return array('closure', $closureindex-1);
}

function closuretag($c)
{
  return $c[1];
}

function closureargs($c)
{
  global $closures;
  return $closures[$c[1]][0];
}

function closurebody($c)
{
  global $closures;
  return $closures[$c[1]][1];
}

function closureargtype($c)
{
  global $closures;
  return $closures[$c[1]][2];
}

function closureenv($c)
{
  global $closures;
  return $closures[$c[1]][3];
}

$pairindex = 0;
$pairs = array();

function cons($a, $b)
{
  global $pairindex, $pairs;
  
  $pairs[$pairindex++] = array($a, $b);
  return array('pair', $pairindex-1);
}

function car($p)
{
  global $pairs;
  return $pairs[$p[1]][0];
}

function cdr($p)
{
  global $pairs;
  return $pairs[$p[1]][1];
}

function setcar($p, $v)
{
  global $pairs;
  $pairs[$p[1]][0] = $v;
}

function setcdr($p, $v)
{
  global $pairs;
  $pairs[$p[1]][1] = $v;
}

$nullunique = array('empty');
function null()
{
    global $nullunique;
    return $nullunique;
}

function array2list($items)
{
    $res = null();

    for($p=count($items)-1; $p>=0; $p--){
	$res = cons($items[$p], $res);
    }

    return $res;
}

function btrue()
{
  return newval('boolean', '#t');
}

function bfalse()
{
  return newval('boolean', '#f');
}

function isfalse($val)
{
  if($val[0]=='empty' ||
     ($val[0]=='boolean' && $val[1]=='#f')){
    return 1;
  }

  return 0;
}

function readexp()
{
    global $tokens, $base, $errmsg;

    while(isset($tokens[$base])){
	$tok = $tokens[$base++];
	
	if($tok[0]=='string'){
	    return $tok;
	}

	if($tok[0]=='text'){
	    if(preg_match("/^[+-]?\d+(\.\d+)?([eE][+-]?\d+)?$/", $tok[1]) ||
	       preg_match("/^[+-]?\d+$/", $tok[1])){
		return newval('number', $tok[1]);
	    }

	    if(preg_match("/^[\+\-\*\/\=\>\<]|<=|>=$/", $tok[1]) ||
	       preg_match("/^[a-zA-Z\?][a-zA-Z0-9\-\?\!\*]*$/", $tok[1])){
		return newval('symbol', $tok[1]);
	    }
	    
	    if(preg_match("/^\#[tf]$/", $tok[1])){
		return newval('boolean', $tok[1]);
	    }

	    if(preg_match("/^\#\\\\(\w+|\.|\,|\+|\-|\*|\/)$/", 
			  $tok[1], $parts)){
	        return newval('character', $parts[1]);
	    }

	    if($tok[1]=='.'){
		return newval('improper', $tok[1]);
	    }
	}
	else if($tok[0]=='quote'){
	    $quoted = readexp();
	    if(is_array($quoted)){
		return cons(newval('symbol', 'quote'), cons($quoted, null()));
	    }
	    else{
		$errmsg = 'quote missing an item';
		return -1;
	    }
	}
	else if($tok[0]=='left'){
	    $items = array(); $isimproper = 0;
	    while(isset($tokens[$base]) &&
		  $tokens[$base][0]!='right'){
		$item = readexp();
		if(is_array($item)){
		    if($item[0]=='improper'){
			$isimproper = 1;
			break;
		    }
		    else{
			$items[] = $item;
		    }
		}
		else{
		    return -1;
		}
	    }
	    if(!isset($tokens[$base])){
		$errmsg = 'ran out of list items';
		return -1;
	    }
	    if($isimproper){
		$item = readexp();
		if(is_array($item)){
		    if(!isset($tokens[$base])){
			$errmsg = 'improper list missing closing parenthesis';
			return -1;
		    }
		    if($tokens[$base][0]!='right'){
			$errmsg = 'improper list not closed by parenthesis';
			return -1;
		    }
		    $base++;

		    $result = $item;
		}
		else{
		    $errmsg = 'improper list missing last item';
		    return -1;
		}
	    }
	    else{
		$base++;
		$result = null();
	    }

	    for($ind=count($items)-1; $ind>=0; $ind--){
		$result = cons($items[$ind], $result);
	    }

	    return $result;
	}
	else if($tok[0]=='right'){
	    $errmsg = 'missing open parenthesis';
	    return -1;
	}
    }

    $errmsg = 'parse error';
    return -1;
}

$chartable = array();
$chartable["newline"] = "\n";
$chartable["tab"]     = "\t";
$chartable["space"]   = " ";

function tostring($exp, $expchars)
{
    global $chartable;

    if(valtype($exp)=='pair'){
	$result  = '(';
	$result .= tostring(car($exp), $expchars);
	
	for($rest=cdr($exp); valtype($rest)=='pair'; $rest=cdr($rest)){
	  $result .= ' ' . tostring(car($rest), $expchars);
	}
	if(valtype($rest)!='empty'){
	    $result .= ' . ' . tostring($rest, $expchars);
	}

	$result .= ')';

	return $result;
    }
    else if(valtype($exp)=='empty'){
	return '()';
    }
    else if(valtype($exp)=='closure'){
	return '<closure: ' . 
	  tostring(closureargs($exp), 'noexpchars') . '>';
    }
    else if(valtype($exp)=='bcode'){
        return '<byte codes: ' . count(valdata($exp)) . '>';
    }
    else if(valtype($exp)=='thunk'){
        return '<thunk: #' . valdata($exp) . '>';
    }
    else if(valtype($exp)=='primitive'){
	return '<primitive: ' . valdata($exp) . '>';
    }
    else if(valtype($exp)=='string'){
	if($expchars=='expchars'){
	    return valdata($exp);
	}
	return '"' . valdata($exp) . '"';
    }
    else if(valtype($exp)=='character'){
	if($expchars=='expchars'){
	    $expanded = $chartable[valdata($exp)];
	    if(!empty($expanded)){
		return $expanded;
	    }
	    else{
	      $str = valdata($exp);
	      return $str[0];
	    }
	}
	else{
	    return "#\\" . valdata($exp);
	}
    }
    else{
	return valdata($exp);
    }
}

function tohtmlstring($exp, $expchars)
{
  return htmlspecialchars(tostring($exp, $expchars));
}

function tostring2($exp, $depth)
{
    if(valtype($exp)=='pair'){
        if(!$depth){
	  return '...';
	}

	$result  = '(';
	$result .= tostring2(car($exp), $depth-1);
	
	for($rest=cdr($exp); $rest[0]=='pair'; $rest=cdr($rest)){
	  $result .= ' ' . tostring2(car($rest), $depth-1);
	}
	if($rest[0]!='empty'){
	    $result .= ' . ' . tostring($rest, 'noexpchars');
	}

	$result .= ')';

	return $result;
    }

    return tostring($exp, 'noexpchars');
}


function tohtmlstring2($exp)
{
  $stringdepth = 3;
  return htmlspecialchars(tostring2($exp, $stringdepth));
}

function lookup($symbol, $layers)
{
    if($layers[0]=='empty'){
	return -1;
    }

    $layer = car($layers);
    $val   = readfromenv($layer, $symbol);
    if(is_array($val)){
      return array($layer, $val);
    }

    return lookup($symbol, cdr($layers));
}

function sequence($seq)
{
    global $bcode, $bc;

    $count=0;
    while(valtype($seq)=='pair'){
      compile(car($seq));
      $seq=cdr($seq);
      if(valtype($seq)=='pair'){
	  $bcode[$bc++] = array('popargs', 1);
      }
      $count++;
    }

    if($seq[0]!='empty'){
      $bcode[$bc++] = array('error', 'parse error in sequence term ' . $count);
      return;
    }
}

$specialforms = array("define" => 1, "set!"  => 1, "lambda" => 1, 
		      "if"     => 1, "and"   => 1, "or"     => 1,
		      "begin"  => 1, "apply" => 1,
		      "quote"  => 1, "case"  => 1, "cond"   => 1,
                      "let"    => 1, "let*"  => 1, "letrec" => 1,
		      "call-with-current-continuation" => 1);

function codesegment($current)
{
  global $bcode, $bc;
	
  $codeseg = array();
  for($c = $current; $c<$bc; $c++){
    $codeseg[] = $bcode[$c];
  }
  $bc = $current;

  return $codeseg;
}

function handlespecial($name, $args)
{
    global $bcode, $bc;

    switch($name){
        case 'apply':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', "bad first arg to $name");
	  return;
	}
	if(valtype(cdr($args))!='pair'){
	  $bcode[$bc++] = array('error', "bad second arg to $name");
	  return;
	}
	if(valtype(cdr(cdr($args)))!='empty'){
	  $bcode[$bc++] = array('error', "too many args to $name");
	  return;
	}
	compile(car($args));
	$bcode[$bc++] = array('checkptc');
	compile(car(cdr($args)));
	$bcode[$bc++] = array('listapplication');
        break;

        case  'call-with-current-continuation':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', "bad first arg to $name");
	  return;
	}

	$t = newthunk();

	$bcode[$bc++] = array('argptothunk', $t);
	$bcode[$bc++] = array('envptothunk', $t);
	compile(car($args));
	$bcode[$bc++] = array('checkptc');
	$bcode[$bc++] = array('toargs', $t);
	$bcode[$bc++] = array('application', 1);
	$bcode[$bc++] = $t;
        break;

	case 'define': 
        case 'set!':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', "bad first arg to $name");
	  return;
	}
	if(valtype(car($args))!='symbol'){
	  $bcode[$bc++] = array('error', "first arg to $name not a symbol");
	  return;
	}
	$bcode[$bc++] = array('toargs', car($args));
	if(valtype(cdr($args))!='pair'){
	  $bcode[$bc++] = array('error', "bad second arg to $name");
	  return;
	}
	if($name=='define'){
	  $bcode[$bc++] = array('globalenv');
	  compile(car(cdr($args)));
	  $bcode[$bc++] = array('popenv', 1);
	}
	else{
	  compile(car(cdr($args)));
	}
	$bcode[$bc++] = array($name);
	break;

	case 'lambda':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', 'bad first arg to lambda');
	  return;
	}
	$argstr = car($args);
	$argtype = -1;
	if(valtype($argstr)=='symbol'){
	    $argtype = 0;
	}
	else if(valtype($argstr)=='pair' || 
		valtype($argstr)=='empty'){
	    for($tocheck = $argstr, $count=1; 
		valtype($tocheck)=='pair'; 
		$tocheck = cdr($tocheck), $count++){
		if(valtype(car($tocheck))!='symbol'){
		    $msg = 'lambda arg ' . $count . ' not a symbol';
		    break;
		}
	    }
	    if(valtype($tocheck)=='symbol'){
		$argtype = 1;
	    }
	    else if(valtype($tocheck)=='empty'){
		$argtype = 2;
	    }
	    else{
		$msg = 'lambda arg not symbol or null terminator:';
	    }
	}
	else{
	    $msg = 'lambda single arg not a symbol';
	}
	if($argtype==-1){
	    $bcode[$bc++] = array('error', $msg);
	    return;
	}

	if(valtype(cdr($args))=='empty'){
	  $bcode[$bc++] = array('error', 'lambda body is empty');
	  return;
	}

	$current = $bc;
	sequence(cdr($args));
	$lcode = codesegment($current);

	$bcode[$bc++] = array('toargs', car($args));  
	$bcode[$bc++] = array('toargs', newval('bcode', $lcode));
	$bcode[$bc++] = array('toargs', newval('number', $argtype));
	$bcode[$bc++] = array('closure');
	break;

        case 'begin':
	if(valtype($args)=='empty'){
	  $bcode[$bc++] = array('toargs', null());
	  return;
	}

	sequence($args);
        break;

	case 'cond':
	for($clauses = array(), $elseclause = 0;
	    valtype($args)=='pair'; $args = cdr($args)){
	    $clause = car($args);

	    if(valtype($clause)!='pair'){
		$bcode[$bc++] = array('error', 'bad cond clause');
		return;
	    }
	    $test  = car($clause);
	    $ccode = cdr($clause);
	    if(valtype($ccode)!='pair'){
		$bcode[$bc++] = array('error', 'empty cond clause');
		return;
	    }

	    if(valtype($test)=='symbol' &&
	       valdata($test)=='else'){
		if(is_array($elseclause)){
		    $bcode[$bc++] = 
			 array('error', 'cond: more than one else clause');
		    return;
		}
		$elseclause = $clause;
	    }
	    else{
		if(is_array($elseclause)){
		    $bcode[$bc++] = 
			 array('error', 'cond: else clause must be last');
		    return;
		}
		$type = 'seq';
		$first = car($ccode);
		if(valtype($first)=='symbol' &&
		   valdata($first)=='=>'){
		    $expr = cdr($ccode);
		    if(valtype($expr)=='empty'){
			$bcode[$bc++] = 
			     array('error', 'cond: empty => clause');
			return;
		    }
		    if(valtype(cdr($expr))!='empty'){
			$bcode[$bc++] = 
			     array('error', 
				   'cond: more than one expr in => clause');
			return;
		    }
		    $type = 'proc';
		}

		$clauses[] = array($clause, $type);
	    }
	}
	
	$count = 0;

	$current = $bc;
	if(is_array($elseclause)){
	    sequence(cdr($elseclause));
	    $elsecode = codesegment($current);
	    
	    $bcode[$bc++] = array('toargs', newval('string', 'else'));
	    $bcode[$bc++] = array('toargs', newval('bcode', $elsecode));
	    $count+=2;
	}

	for($c=count($clauses)-1; $c>=0; $c--){
	    $clause = $clauses[$c][0];
	    $type   = $clauses[$c][1];

	    $current = $bc;
	    compile(car($clause));
	    $tcode = codesegment($current);

	    if($type=='proc'){
		compile(car(cdr(cdr($clause))));
		$code = codesegment($current);
	    }
	    else{
		sequence(cdr($clause));
		$code = codesegment($current);
	    }
	    
	    $bcode[$bc++] = array('toargs', newval('bcode', $tcode));
	    $bcode[$bc++] = array('toargs', newval('string', $type));
	    $bcode[$bc++] = array('toargs', newval('bcode', $code));
	    $count+=3;
	}

	$bcode[$bc++] = array('cond', $count);
	break;
	
	case 'case':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', 'case value missing');
	  return;
	}
	$caseval = car($args);
	compile($caseval);

	for($clauses = array(), $elseclause = 0, 
		$count=0, $cl = cdr($args);
	    valtype($cl)=='pair'; $cl = cdr($cl)){
	    $clause = car($cl);

	    if(valtype($clause)!='pair'){
		$bcode[$bc++] = array('error', 'bad case clause');
		return;
	    }
	    $data = car($clause);
	    if(valtype($data)!='pair' &&
	       !(valtype($data)=='symbol' &&
		 valdata($data)=='else')){
		$bcode[$bc++] = 
		     array('error', 'bad case data: ' . tostring($data, 0));
		return;
	    }
	    $ccode = cdr($clause);
	    if(valtype($ccode)!='pair'){
		$bcode[$bc++] = array('error', 'empty case clause');
		return;
	    }

	    if(valtype($data)=='symbol' &&
	       valdata($data)=='else'){
		if(is_array($elseclause)){
		    $bcode[$bc++] = 
			 array('error', 'case: more than one else clause');
		    return;
		}
		$elseclause = $clause;
	    }
	    else{
		if(is_array($elseclause)){
		    $bcode[$bc++] = 
			 array('error', 'case: else clause must be last');
		    return;
		}
		$clauses[] = $clause;
	    }

	    $count++;
	}
	
	$current = $bc;
	if(is_array($elseclause)){
	    sequence(cdr($elseclause));
	    $elsecode = codesegment($current);
	    
	    $bcode[$bc++] = array('toargs', car($elseclause));
	    $bcode[$bc++] = array('toargs', newval('bcode', $elsecode));
	}

	for($c=count($clauses)-1; $c>=0; $c--){
	    $clause = $clauses[$c];

	    $current = $bc;
	    sequence(cdr($clause));
	    $ccode = codesegment($current);
	    
	    $bcode[$bc++] = array('toargs', car($clause));
	    $bcode[$bc++] = array('toargs', newval('bcode', $ccode));
	}

	$bcode[$bc++] = array('case', $count);
	break;

        case 'if':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', 'bad if condition');
	  return;
	}
	$ifcond = car($args);
	if(valtype(cdr($args))!='pair'){
	  $bcode[$bc++] = array('error', 'true clause missing from if');
	  return;
	}
	$iftrue = car(cdr($args));
	if(valtype(cdr(cdr($args)))!='pair'){
	  $iffalse = cons(newval('symbol', 'quote'), cons(null(), null()));
	}
	else{
	  $iffalse = car(cdr(cdr($args)));
	}

	compile($ifcond);

	$current = $bc;
	compile($iftrue);
	$tcode = codesegment($current);
	compile($iffalse);
	$fcode = codesegment($current);

	$bcode[$bc++] = array('toargs', newval('bcode', $tcode));
	$bcode[$bc++] = array('toargs', newval('bcode', $fcode));
	$bcode[$bc++] = array('if');

        break;

        case 'and':
        case 'or':
	$count = 0;
	$current = $bc;
	$terms = array();

	while(valtype($args)=='pair'){
	  compile(car($args));

	  $terms[] = codesegment($current);

	  $count++; $args = cdr($args);
	}
	for($tind = $count-1; $tind>=0; $tind--){
	  $tcode = $terms[$tind];
	  $bcode[$bc++] = array('toargs', newval('bcode', $tcode));
	}

	$bcode[$bc++] = array('toargs', ($name=='and' ? btrue() : bfalse()));
	$bcode[$bc++] = array($name, $count);
        break;

        case 'quote':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', 'quote missing an item');
	  return;
	}
	if(valtype(cdr($args))!='empty'){
	  $bcode[$bc++] = array('error', 'quote takes a single argument');
	  return;
	}
	$bcode[$bc++] = array('toargs', car($args));
        break;
	
	case 'let':
        case 'let*':
        case 'letrec':
	if(valtype($args)!='pair'){
	  $bcode[$bc++] = array('error', "bad first arg to $name");
	  return;
	}
	if($name=='letrec'){
	  $bcode[$bc++] = array('layer', 0);
	}
	for($bindings=car($args), $count=0; valtype($bindings)=='pair';
	    $bindings=cdr($bindings)){
	    $binding=car($bindings);
	    if(valtype($binding)!='pair'){
	      $bcode[$bc++] = 
		   array('error', '$name binding ' . ($count+1) . ' bad');
	      return;
	    }

	    if(valtype(car($binding))!='symbol'){
		$bcode[$bc++] = array('error', "first arg to $name binding " . 
				 ($count+1) . ' not a symbol');
		return;
	    }
	    $bcode[$bc++] = array('toargs', car($binding));
	    $count++;
	    compile(car(cdr($binding)));
	    if($name=='let*'){
	      $bcode[$bc++] = array('layer', 1);
	    }
	    else if($name=='letrec'){
	      $bcode[$bc++] = array('define', 1);
	      $bcode[$bc++] = array('popargs', 1);
	    }
	}
	if(valtype($bindings)!='empty'){
	  $bcode[$bc++] = 
	       array('error', "parse error at $name binding " . ($count+1));
	  return;
	}
	if($name=='let'){
	  $bcode[$bc++] = array('layer', $count);
	}

	if(valtype(cdr($args))=='empty'){
	  $bcode[$bc++] = array('error', "$name body is empty");
	  return;
	}
	sequence(cdr($args));

	if($name=='let' || $name=='letrec'){
	  $bcode[$bc++] = array('popenv', 1);
	}
	else{
	  $bcode[$bc++] = array('popenv', $count);
	}
	break;
    }
}

$primtable = 
array("+", "*", "-", "/", "=", ">", "<",
      "draw-move", "draw-line", "draw-color",
      "sin", "cos", "sqrt",
        "quotient", "remainder", "not",
	"zero?", "pair?", "number?", "eqv?", "eq?",
	"cons", "car", "cdr", "list", "null?",
	"set-car!", "set-cdr!",
	"display", "newline");

function drawcmd($name, $x, $y)
{
  global $imagedata;

  if($x<$imagedata[0]){
      $imagedata[0] = $x;
  }
  if($y<$imagedata[1]){
      $imagedata[1] = $y;
  }
  if($x>$imagedata[2]){
      $imagedata[2] = $x;
  }
  if($y>$imagedata[3]){
      $imagedata[3] = $y;
  }

  if($name=='draw-move'){
      $imagedata[4][] = array(0, $x, $y);
  }
  else{
      $imagedata[4][] = array(1, $x, $y);
  }
}

function len($l)
{
    $len = 0; 
    while(valtype($l)=='pair'){
	$len++;
	$l = cdr($l);
    }
    return $len;
}

function applyprimitive($name, $argc)
{
  global $argstack, $argp, $errmsg;
  global $outputstr;
  global $imagedata;


  switch($name){
  case 'sin':
  case 'cos':
  case 'sqrt':
      if($argc!=1){
	  $errmsg = "$name requires one argument";
	  return -1;
      }
      $a = $argstack[$argp-1];
      if(valtype($a)!='number'){
	  $errmsg = "first arg to $name not a number";
	  return -1;
      }

      $av = valdata($a);

      if($name=='sin'){
	  return newval('number', sin($av));
      }
      else if($name=='cos'){
	  return newval('number', cos($av));
      }
      
      if($av<0){
	  $errmsg = "arg to $name must not be negative";
	  return -1;
      }
      return newval('number', sqrt($av));
  break;

  case 'draw-move':
  case 'draw-line':
      if($argc!=2){
	  $errmsg = "$name requires two arguments";
	  return -1;
      }
      $a = $argstack[$argp-2];
      if(valtype($a)!='number'){
	  $errmsg = "first arg to $name not a number";
	  return -1;
      }
      $b = $argstack[$argp-1];
      if(valtype($b)!='number'){
	  $errmsg = "second arg to $name not a number";
	  return -1;
      }

      $av = valdata($a);
      $bv = valdata($b);

      if(!count($imagedata[4])){
	  if($name=='draw-line'){
	      $imagedata[0] = 0;
	      $imagedata[1] = 0;
	      $imagedata[2] = 0;
	      $imagedata[3] = 0;
	  }
	  else{
	      $imagedata[0] = $av;
	      $imagedata[1] = $bv;
	      $imagedata[2] = $av;
	      $imagedata[3] = $bv;
	  }
      }
      drawcmd($name, $av, $bv);
      return null();
  break;
  case 'draw-color':
      if($argc!=1){
	  $errmsg = "$name requires one argument";
	  return -1;
      }
      $c = $argstack[$argp-1];
      if(len($c)!=3){
	  $errmsg = "$name requires a list; form: (R, G, B)";
	  return -1;
      }
      $red = car($c);
      if(valtype($red)!='number'){
	  $errmsg = "$name: red component not a number";
	  return -1;
      }
      $green = car(cdr($c));
      if(valtype($green)!='number'){
	  $errmsg = "$name: green component not a number";
	  return -1;
      }
      $blue = car(cdr(cdr($c)));
      if(valtype($blue)!='number'){
	  $errmsg = "$name: blue component not a number";
	  return -1;
      }
      $imagedata[4][] =
	   array(2, valdata($red), valdata($green), valdata($blue));
      return null();
  break;
  case 'quotient':
      if($argc!=2){
	  $errmsg = 'quotient requires two arguments';
	  return -1;
      }
      $a = $argstack[$argp-2];
      if(valtype($a)!='number'){
	  $errmsg = 'first arg to quotient not a number';
	  return -1;
      }
      $p = (int)valdata($a);
      if($p!=valdata($a)){
	  $errmsg = 'first arg to quotient not an integer';
	  return -1;
      }

      $b = $argstack[$argp-1];
      if(valtype($a)!='number'){
	  $errmsg = 'second arg to quotient not a number';
	  return -1;
      }
      $q = (int)valdata($b);
      if($q!=valdata($b)){
	  $errmsg = 'second arg to quotient not an integer';
	  return -1;
      }
      if(!$q){
	  $errmsg = 'second arg to quotient must not be zero';
	  return -1;
      }

      return newval('number', (int)($p / $q));
  break;
  case 'remainder':
      if($argc!=2){
	  $errmsg = 'remainder requires two arguments';
	  return -1;
      }
      $a = $argstack[$argp-2];
      if(valtype($a)!='number'){
	  $errmsg = 'first arg to remainder not a number';
	  return -1;
      }
      $p = (int)valdata($a);
      if($p!=valdata($a)){
	  $errmsg = 'first arg to remainder not an integer';
	  return -1;
      }

      $b = $argstack[$argp-1];
      if(valtype($a)!='number'){
	  $errmsg = 'second arg to remainder not a number';
	  return -1;
      }
      $q = (int)valdata($b);
      if($q!=valdata($b)){
	  $errmsg = 'second arg to remainder not an integer';
	  return -1;
      }
      if(!$q){
	  $errmsg = 'second arg to remainder must not be zero';
	  return -1;
      }

      return newval('number', $p % $q);
  break;
  case 'eqv?':
  case 'eq?':
    if($argc!=2){
      $errmsg = '$name requires two arguments';
      return -1;
    }
    $itema = $argstack[$argp-2];
    $itemb = $argstack[$argp-1];
    
    if(valtype($itema)!=valtype($itemb)){
      return bfalse();
    }

    return (valdata($itema)==valdata($itemb) ? 
	      btrue() : bfalse());
  case 'pair?':
    if($argc!=1){
      $errmsg = 'pair? requires one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    return 
      (valtype($item)=='pair' ? btrue() : bfalse());
  case 'number?':
    if($argc!=1){
      $errmsg = 'number? requires one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    return
      (valtype($item)=='number' ? btrue() : bfalse());
  case 'zero?':
    if($argc!=1){
      $errmsg = 'zero? requires one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'zero? requires a numeric argument';
      return -1;
    }
    return (valdata($item) ? bfalse() : btrue());
  case 'not':
    if($argc!=1){
      $errmsg = 'not requires one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];

    if(valtype($item)=='boolean' &&
       valdata($item)=='#f'){
      return btrue();
    }
    return bfalse();
  case 'list':
    for($res=null(), $c=1; $c<=$argc; $c++){
      $res = cons($argstack[$argp-$c], $res);
    }
    return $res;
  case 'cons':
    if($argc!=2){
      $errmsg = 'cons requires two arguments';
      return -1;
    }
    $a = $argstack[$argp-2];
    $b = $argstack[$argp-1];
    return cons($a, $b);
  case 'set-car!':
    if($argc!=2){
      $errmsg = 'set-car! requires two arguments';
      return -1;
    }
    $p = $argstack[$argp-2];
    if(valtype($p)!='pair'){
      $errmsg = 'first argument to set-car! must be a pair';
      return -1;
    }
    $v = $argstack[$argp-1];
    setcar($p, $v);
    return $v;
  case 'set-cdr!':
    if($argc!=2){
      $errmsg = 'set-cdr! requires two arguments';
      return -1;
    }
    $p = $argstack[$argp-2];
    if(valtype($p)!='pair'){
      $errmsg = 'first argument to set-cdr! must be a pair';
      return -1;
    }
    $v = $argstack[$argp-1];
    setcdr($p, $v);
    return $v;
  case 'car':
    if($argc!=1){
      $errmsg = 'car takes a single argument';
      return -1;
    }
    $p = $argstack[$argp-1];
    if(valtype($p)!='pair'){
      $errmsg = 'argument to car must be a pair';
      return -1;
    }
    return car($p);
  case 'cdr':
    if($argc!=1){
      $errmsg = 'cdr takes a single argument';
      return -1;
    }
    $p = $argstack[$argp-1];
    if(valtype($p)!='pair'){
      $errmsg = 'argument to cdr must be a pair';
      return -1;
    }
    return cdr($p);
  case 'null?':
    if($argc!=1){
      $errmsg = 'null takes a single argument';
      return -1;
    }
    $p = $argstack[$argp-1];
    if(valtype($p)=='empty'){
      return newval('boolean', '#t');
    }
    return newval('boolean', '#f');
  case 'display':
    if($argc!=1){
      $errmsg = 'display requires one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    $outputstr .= tohtmlstring($item, 'expchars');
    return null();
  case 'newline':
    if($argc){
      $errmsg = 'newline takes no arguments';
      return -1;
    }
    $outputstr .= "\n";
    return null();
  case '+':
    if(!$argc){
      return newval('number', 0);
    }
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'first arg to + not a number';
      return -1;
    }
    for($res = valdata($item), $c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to + not a number';
	return -1;
      }
      $res += valdata($item);
    }
    return newval('number', $res);
  case '*':
    if(!$argc){
      return newval('number', 1);
    }
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'first arg to * not a number';
      return -1;
    }
    for($res = valdata($item), $c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to * not a number';
	return -1;
      }
      $res *= valdata($item);
    }
    return newval('number', $res);
  case '-':
    if(!$argc){
      $errmsg = '- requires at least one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'first arg to - not a number';
      return -1;
    }
    for($res = valdata($item), $c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to - not a number';
	return -1;
      }
      $res -= valdata($item);
    }
    return newval('number', ($argc==1 ? -$res : $res));
  case '/':
    if(!$argc){
      $errmsg = '/ requires at least one argument';
      return -1;
    }
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'first arg to - not a number';
      return -1;
    }
    for($res = valdata($item), $c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to - not a number';
	return -1;
      }
      $res /= valdata($item);
    }
    return newval('number', ($argc==1 ? 1/$res : $res));
  case '=':
    $item = $argstack[$argp-$argc];
    if(valtype($item)!='number'){
      $errmsg = 'first arg to = not a number';
      return -1;
    }
    for($res = valdata($item), $c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to = not a number';
	return -1;
      }
      if($res != valdata($item)){
	return newval('boolean', '#f');
      }
    }
    return newval('boolean', '#t');
  case '>':
    if($argc<2){
      $errmsg = '> requires at least two arguments';
      return -1;
    }
    $current = $argstack[$argp-$argc];
    if(valtype($current)!='number'){
      $errmsg = 'first arg to - not a number';
      return -1;
    }
    for($c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to > not a number';
	return -1;
      }
      if(valdata($current) <= valdata($item)){
	  return bfalse();
      }
      $current = $item;
    }
    return btrue();
  case '<':
    if($argc<2){
      $errmsg = '< requires at least two arguments';
      return -1;
    }
    $current = $argstack[$argp-$argc];
    if(valtype($current)!='number'){
      $errmsg = 'first arg to - not a number';
      return -1;
    }
    for($c=1; $c<$argc; $c++){
      $item = $argstack[$argp-$argc+$c];
      if(valtype($item)!='number'){
	$errmsg = 'arg ' . ($c+1)  . ' to < not a number';
	return -1;
      }
      if(valdata($current) >= valdata($item)){
	  return bfalse();
      }
      $current = $item;
    }
    return btrue();
  }
}

function init()
{
    global $primtable, $initialenv;

    $prim = array();
    for($p=0; $p<count($primtable); $p++){
	$prim[$primtable[$p]] = newval('primitive', $primtable[$p]);
    }

    $initialenv = cons(newenv(array()), cons(newenv($prim), null()));
}

function printargstack()
{
  global $argstack, $argp;

  for($p=0; $p<$argp; $p++){
    echo tohtmlstring($argstack[$p], 'noexpchars') . " ";
  }
  echo "\n";
}

function insertcode($prev, $code, $tag)
{
    global $codestack, $codep;

    $codestack[$codep-1][1] = $prev;
    $codestack[$codep] = array($code, -1, count($code), $tag);
    $codep++;
}

function findmarkforward($obj)
{
    global $codestack, $codep;

    $type = valtype($obj); $tag = valdata($obj);

    while($codep>0){
	$bcode     = $codestack[$codep-1][0];
	$searchpos = $codestack[$codep-1][1]; 
	$mx        = $codestack[$codep-1][2];
	while($searchpos<$mx){
	    if(valtype($bcode[$searchpos])!=$type ||
	       valdata($bcode[$searchpos])!=$tag){
		$searchpos++;
	    }
	    else{
		return $searchpos;
	    }
	}
	$codep--;
    }

    return -1;
}

function run()
{
    global $initialenv, $bcode, $bc, $errmsg;
    global $envstack, $argstack, $envp, $argp;
    global $stacktrace;

    global $codestack, $codep;

    $codestack = array(array($bcode, 0, $bc, -1, 0)); 
    $codep = 1;

    $argstack = array();
    $argp = 0;

    $b = 0;
    while(1){
	$instr = $codestack[$codep-1][0][$b];

	// echo $b . ' ' . $instr[0] . "<BR>\n";
	if($stacktrace && $instr[0]!='start'){
	  echo "<B>&gt;</B> ";
	  printargstack();
	}

	switch($instr[0]){
	    case 'cond':
            $count  = $instr[1];

            $type   = valdata($argstack[$argp-2]);
	    $code   = valdata($argstack[$argp-1]);

	    if($type=='else'){
		insertcode($b, $code, -1);
		$b = -1;

		unset($argstack[$argp-1]); $argp--;
		unset($argstack[$argp-1]); $argp--;
	    }
	    else{
		$tcode = valdata($argstack[$argp-3]);
		
		insertcode($b, array(array('cond1', $count)), -1);
		insertcode(-1, $tcode, -1);
		$b = -1;
	    }
	    break;

	    case 'cond1':
	    $count  = $instr[1];

            $type    = valdata($argstack[$argp-3]);
	    $code    = valdata($argstack[$argp-2]);
	    $tres    = $argstack[$argp-1];
	    
	    if(!isfalse($tres)){
		if($type=='proc'){
		    $pcode = array();
		    $pcode[] = array('checkptc', $tres);
		    $pcode[] = array('toargs', $tres);
		    $pcode[] = array('application', 1);
		    insertcode($b, $pcode, -1);
		    insertcode(-1, $code, -1);
		}
		else{
		    insertcode($b, $code, -1);
		}
		$b = -1;

		$topop = $count+1;
	    }
	    else{
		if($count>=3){
		    insertcode($b, array(array('cond', $count-3)), -1);
		    $b = -1;
		}

		$topop = 4;
	    }

	    for($c=0; $c<$topop; $c++){
		unset($argstack[$argp-1]); $argp--;
	    }

	    break;

	    case 'case':
            $count = $instr[1];
            $caseval = $argstack[$argp-1-2*$count];
	    $casevaltype = valtype($caseval);
	    $casevaldata = valdata($caseval);


	    for($c=0; $c<$count; $c++){
		$cases = $argstack[$argp-2];
		$code  = $argstack[$argp-1];

		$match = 0;
		if(valtype($cases)=='symbol'){
		    $match = 1;
		}
		else{
		    while(valtype($cases)=='pair'){
			$item = car($cases);
			if(valtype($item)==$casevaltype &&
			   valdata($item)==$casevaldata){
			    $match = 1;
			    break;
			}
			$cases = cdr($cases);
		    }
		}
		
		if($match){
		    insertcode($b, valdata($code), -1);
		    $b = -1;
		    break;
		}

		unset($argstack[$argp-1]); $argp--;
		unset($argstack[$argp-1]); $argp--;
	    }

	    while($c<$count){
		unset($argstack[$argp-1]); $argp--;
		unset($argstack[$argp-1]); $argp--;
		$c++;
	    }

	    unset($argstack[$argp-1]); $argp--;
	    break;

	    case 'thunk':
	    writeargptothunk($instr, -1);
	    break;

	    case 'argptothunk':
	    writeargptothunk($instr[1], $argp);
	    break;

	    case 'envptothunk':
	    writeenvptothunk($instr[1], $envp);
	    break;

	    case 'error':
	    $errmsg = $instr[1];
	    return -1;

	    case 'start':
	    $envstack = array($initialenv);
	    $envp = 1;
	    break;
	    
	    case 'if':
	    if(isfalse($argstack[$argp-3])){
	      $icode = $argstack[$argp-1];
	    }
	    else{
	      $icode = $argstack[$argp-2];
	    }

	    insertcode($b, valdata($icode), -1);
	    $b = -1;

	    unset($argstack[$argp-1]);
	    unset($argstack[$argp-2]);
	    unset($argstack[$argp-3]);
	    $argp -= 3;

	    break;

	    case 'and':
	    case  'or':
	    $op = $instr[0];

	    $count = $instr[1];
	    if(valtype($argstack[$argp-1])!='boolean'){
	      $errmsg = 'boolean required in ' . $op .
		'; got ' . valtype($argstack[$argp-1]);
	      return -1;
	    }

	    $bool = $argstack[$argp-1];
	    if(($op=='and' && valdata($bool)=='#t') ||
	       ($op=='or'  && valdata($bool)=='#f')){
	      if($count){
		$tcode = valdata($argstack[$argp-2]);
		insertcode($b, array(array($op, $count-1)), -1);
		insertcode(-1, $tcode, -1);
		$b = -1;
		
		unset($argstack[$argp-1]); $argp--;
		unset($argstack[$argp-1]); $argp--;
	      }
	    }
	    else{
	      unset($argstack[$argp-1]); $argp--; // boolean
	      while($count>0){
		unset($argstack[$argp-1]); $argp--;
		$count--;
	      }
	      $argstack[$argp++] = $bool;
	    }
	    break;

	    case 'closure':
	    $cl = newclosure($argstack[$argp-3],
			     $argstack[$argp-2],
			     $argstack[$argp-1],
			     $envstack[$envp-1]);

	    unset($argstack[$argp-1]);
	    unset($argstack[$argp-2]);
	    $argp -= 2;
	    $argstack[$argp-1] = $cl;
	    break;

	    case 'layer':
	    $newlayer = array();

            for($p=$argp-2; $p>=$argp-2*$instr[1]; $p-=2){
	      $newlayer[$argstack[$p][1]]  = $argstack[$p+1];
	      unset($argstack[$p]); unset($argstack[$p+1]);
	    }
	    $argp -= 2*$instr[1];

	    $envstack[$envp] = cons(newenv($newlayer), $envstack[$envp-1]);
	    $envp++;
	    break;

	    case  'listapplication':
            $argl = $argstack[$argp-1];
	    if(valtype($argl)!='empty' && 
	       valtype($argl)!='pair'){
	      $errmsg = 'second arg to apply not a list';
	      return -1;
	    }
	    unset($argstack[--$argp]);

	    $argc = 0;
	    while(valtype($argl)=='pair'){
	      $argstack[$argp++] = car($argl);
	      $argc++;
	      $argl = cdr($argl);
	    }
	    // pass through to application
	    case  'application':
	    if($instr[0]=='application'){
	      $argc = $instr[1];
	    }

	    $op=$argstack[$argp-1-$argc];
	    if(valtype($op)=='primitive'){
	      $res = applyprimitive(valdata($op), $argc);
	      if(!is_array($res)){
		return -1;
	      }
	      $newargp = $argp-$argc-1;
	    }
	    else if(valtype($op)=='thunk'){
	      if($argc!=1){
		$errmsg = 'continuation requires a single argument';
		return -1;
	      }
	      if(readargpfromthunk($op)==-1){
		$errmsg = 'thunk #' . valdata($op) . ' has expired';
		return -1;
	      }

	      $codestack[$codep-1][1] = $b;
	      $b = findmarkforward($op);

	      $newenvp = readenvpfromthunk($op);
	      while($envp>$newenvp){
		unset($envstack[--$envp]);
	      }

	      $res = $argstack[$argp-1];
	      $newargp = readargpfromthunk($op);
	    }
	    else{
	      $newlayer = array();
	      $argl = closureargs($op);
	      if(valdata(closureargtype($op))>0){
		for($p=$argp-$argc;
		    valtype($argl)=='pair'; $p++, $argl=cdr($argl)){
		  if($p>=$argp){
		    $errmsg = 'not enough arguments';
		    return -1;
		  }
		  $newlayer[valdata(car($argl))] = $argstack[$p];
		}
		if(valdata(closureargtype($op))==1){
		  $items = array();
		  while($p<$argp){
		    $items[] = $argstack[$p];
		    $p++;
		  }
		  $newlayer[valdata($argl)] = array2list($items);
		}
		else if($p<$argp){
		  $errmsg = 'too many arguments';
		  return -1;
		}
	      }
	      else{
		for($p=$argp-$argc, $items=array(); $p<$argp; $p++){
		  $items[] = $argstack[$p];
		}
		$newlayer[valdata($argl)] = array2list($items);
	      }

	      $tag = closuretag($op);

	      $tailrec  = 0; $codestack[$codep-1][1] = $b;
	      $popcount = 0;
	      for($cp=$codep-1; $cp>=0; $cp--){
		  $pos = $codestack[$cp][1]+1;
		  $mx  = $codestack[$cp][2];
		  while($pos<$mx){
		      $instr = $codestack[$cp][0][$pos];
		      if(valtype($instr)=='popenv'){
			  $popcount += valdata($instr);
			  $pos++;
		      }
		      else{
			  break;
		      }
		  }
		  if($pos<$mx){
		      break;
		  }
		  if($codestack[$cp][3]==$tag){
		      $tailrec = 1;
		      break;
		  }
	      }

	      if($tailrec){
		  $envp -= $popcount;
		  $envstack[$envp-1] = 
		       cons(newenv($newlayer), closureenv($op));
		  $codep = $cp+1;
	      }
	      else{
		  $envstack[$envp] = 
		       cons(newenv($newlayer), closureenv($op));
		  $envp++;

		  $lcode = valdata(closurebody($op));
		  insertcode($b, array(array('popenv', 1)), -1);
		  insertcode(-1, $lcode, $tag);
	      }
	      $b = -1;

	      $newargp = $argp-$argc-1;
	    }

	    while($argp>$newargp){
	      unset($argstack[--$argp]);
	    }

	    if(valtype($op)=='primitive' ||
	       valtype($op)=='thunk'){
	      $argstack[$argp] = $res;
	      $argp++;
	    }
	    break;

	    case 'toargs':
	    $argstack[$argp] = $instr[1];
	    $argp++;
	    break;

	    case 'popargs':
	    unset($argstack[$argp-1]);
	    $argp--;
	    break;

	    case 'popenv':
            $count = $instr[1];
	    while($count>0){
	      unset($envstack[$envp-1]);
	      $envp--;
	      $count--;
	    }
	    break;

	    case 'globalenv':
	    $envstack[$envp] = $envstack[0];
	    $envp++;
	    break;

	    case 'checkptc':
	    $item = $argstack[$argp-1];
	    if(valtype($item)!='primitive' && 
	       valtype($item)!='closure'   &&
	       valtype($item)!='thunk'){
		$errmsg = 'primitive, closure or thunk required';
		return -1;
	    }
	    break;

	    case 'lookup':
	    $item = $argstack[$argp-1];
	    $res = lookup(valdata($item), $envstack[$envp-1]);
	    if(!is_array($res)){
		$errmsg = "symbol " . valdata($item) . " not bound";
		return -1;
	    }
	    $argstack[$argp-1] = $res[1];
	    break;

	    case 'define':
	    case 'set!':
            $val = $argstack[--$argp]; unset($argstack[$argp]);
	    $sym = $argstack[$argp-1];

	    $env = car($envstack[$envp-1]);
	    if($instr[0]=='set!'){
	      $res = lookup(valdata($sym), $envstack[$envp-1]);
	      if(is_array($res)){
		$env = $res[0];
	      }
	    }
	    writetoenv($env, valdata($sym), $val);
	    break;

	    default:
	    $errmsg = 
		 "instruction $instr[0] unknown " .
		 "(codestack: $codep, position: $b)<BR>\n";
	    return -1;
	}

	$b++;
	while($b==$codestack[$codep-1][2]){
	    $codep--;
	    if(!$codep){
		break;
	    }
	    $b   = $codestack[$codep-1][1]+1;
	}

	if(!$codep){
	    break;
	}
    }

    return 0;
}

function compile($exp)
{
    global $specialforms;
    global $bcode, $bc;

    if($exp[0]=='pair'){
	$toapply = car($exp);
	if($toapply[0]=='symbol'){
	    if(isset($specialforms[$toapply[1]])){
		handlespecial($toapply[1], cdr($exp));
		return;
	    }
	}
	for($item=$exp, $count=0; valtype($item)=='pair'; $item=cdr($item)){
	    $count++;
	    compile(car($item));
	    if($count==1){
		$bcode[$bc++] = array('checkptc');
	    }
	}
	if(valtype($item)!='empty'){
	    $bcode[$bc++] = array('error', 'application not a proper list');
	    return;
	}
	$bcode[$bc++] = array('application', $count-1);
    }
    else if($exp[0]=='symbol'){
	$bcode[$bc++] = array('toargs', $exp);
	$bcode[$bc++] = array('lookup');
    }
    else{
	$bcode[$bc++] = array('toargs', $exp);
    }
}

?>
<HTML>
<HEAD>
<TITLE>Scheme</TITLE>
<SCRIPT TYPE="text/javascript">

progs      = new Array();
needslib   = new Array();

p =
"(case (* 2 3)\n" +
"  ((2 3 5 7) 'prime)\n" +
"  ((1 4 6 8 9) 'composite))\n" +
"(case (car '(c d))\n" +
"  ((a) 'a)\n" +
"  ((b) 'b))\n" +
"(case (car '(c d))\n" +
"  ((a e i o u) 'vowel)\n" +
"  ((w y) 'semivowel)\n" +
"  (else 'consonant))\n" +
"(case 'a\n" +
"  ((b c) (display \"not reached\") (newline) 'b)\n" +
"  ((a d) (display \"reached\") (newline) 'a))\n";

progs["case"] = p;

p =
"(define primes\n" +
"  ;;; check for composite numbers by testing the\n" +
"  ;;; most probable divisors first\n" +
"  (let* ((start (list 2))\n" +
"         (end start))\n" +
"    (letrec\n" +
"	((composite?\n" +
"	  (lambda (v l)\n" +
"	    (let ((d (car l)))\n" +
"	      (if (> (* d d) v) #f\n" +
"		  (if (zero? (remainder v d)) #t\n" +
"		      (composite? v (cdr l)))))))\n" +
"	 (findnext\n" +
"	  (lambda (v)\n" +
"	    (if (composite? v start)\n" +
"		(findnext (+ v 1)) v))))\n" +
"      (lambda ()\n" +
"	(let* ((current (car end))\n" +
"	       (next (findnext (+ current 1)))\n" +
"	       (p (cons next '())))\n" +
"	  (set-cdr! end p)\n" +
"	  (set! end p)\n" +
"	  current)))))\n" +
"\n" +
"(define displayprimes\n" +
"  (lambda (n)\n" +
"    (if (not (zero? n))\n" +
"	(begin\n" +
"	  (display (primes)) (newline)\n" +
"	  (displayprimes (- n 1))))))\n" +
"\n" +
"(displayprimes 14)\n";

progs["primes"] = p;


p =
"(define count\n" + 
" (let ((c 0)) (lambda () (set! c (+ 1 c)) c)))\n" +
"(count) (count) (count)\n";

progs["let-over-lambda"] = p;

p = 
"(define reduce\n" +
" (lambda (op base l)\n" +
"  (if (null? l) base\n" +
"   (op (car l) (reduce op base (cdr l))))))\n" +
"(reduce + 0 '(2 3 4))\n" +
"(reduce * 1 '(2 3 4))\n" +
"(reduce cons '() '(2 3 4))\n";

progs["reduce"] = p;

p = 
"(define factorial\n" +
" (lambda (n)\n" +
"  (if (= 0 n) 1\n" +
"   (* n (factorial (- n 1))))))\n\n" +
"(factorial 6)\n\n" +
"(define factit\n" +
" (lambda (n)\n" +
"  (letrec\n" +
"    ((fit\n" +
"      (lambda (n acc)\n" +
"        (if (= n 0) acc (fit (- n 1) (* n acc))))))\n" +
"   (fit n 1))))\n\n" +
"(factit 6)\n";

progs["factorial"] = p;

p =
"(define rec\n" +
" (lambda (n stop)\n" +
"  (display n) (newline)\n" +
"  (if (= n 0) (stop 0)\n" +
"   (begin\n" +
"     (rec (- n 1) stop)\n" +
"     (display n) (newline)))))\n" +
"(rec 6 (lambda (x) '()))\n" +
"(call-with-current-continuation\n" +
" (lambda (t) (rec 6 t)))\n";

progs["call-cc"] = p;

p =
"(define jumper\n" +
"  (lambda (n m)\n" +
"    (letrec\n" +
"	((rec\n" +
"	  (lambda (n m jump)\n" +
"	    (if (= n 0) (jump '())\n" +
"		(if (= n m)\n" +
"		    (call-with-current-continuation\n" +
"		     (lambda (t) (rec (- n 1) m t)))\n" +
"		    (rec (- n 1) m jump)))\n" +
"	     (display n) (newline))))\n" +
"      (rec n m (lambda (v) v)))))\n" +
"(jumper 10 3)\n" +
"(jumper 6 4)\n";

progs["call-cc1"] = p;

p =
"(define tailrec\n" +
"  (lambda (n)\n" +
"    (display n) (newline)\n" +
"    (if (= n 0) '()\n" +
"	(tailrec (- n 1)))))\n" +
"(tailrec 5)\n";

progs["tail-recursion"] = p;

p =
"(and) (and #t #f)\n" +
"(and\n" +
"  (begin (display 1) #t)\n" +
"  (begin (display 2) #f)\n" +
"  (begin (display 3) #f))\n" +
"(or) (or #f #t)\n" +
"(or\n" +
"  (begin (display 1) #f)\n" +
"  (begin (display 2) #t)\n" +
"  (begin (display 3) #t))\n";

progs["and-or"] = p;


p =
"(define rootfinder\n" +
"  (let ((epsilon 1e-8))\n" +
"    (lambda (p a b)\n" +
"      (let ((mid (/ (+ a b) 2)))\n" +
"	(if (< (- b a) epsilon) mid\n" +
"	    (let \n" +
"		((s1 (if (> (p a) 0)   'pos 'neg))\n" +
"		 (s2 (if (> (p mid) 0) 'pos 'neg)))\n" +
"	      (if (eq? s1 s2)\n" +
"		  (rootfinder p mid b)\n" +
"		  (rootfinder p a mid))))))))\n" +
"\n" +
"(define sqrteq\n" +
"  (lambda (a)\n" +
"    (lambda (x)\n" +
"      (- (* x x) a))))\n" +
"\n" +
"(define r5 (rootfinder (sqrteq 5) 0 5))\n" +
"r5\n" +
"(* r5 r5)\n" +
"\n" +
"(define cbrteq\n" +
"  (lambda (a)\n" +
"    (lambda (x)\n" +
"      (- (* x x x) a))))\n" +
"\n" +
"(define cr7 (rootfinder (cbrteq 7) 0 7))\n" +
"cr7\n" +
"(* cr7 cr7 cr7)\n";


progs["rootfinder"] = p;

p =
"(define plotter\n" +
"  (lambda (f res x1 x2 y1 y2)\n" +
"    (let* ((dx (- x2 x1)) (dy (- y2 y1)) (delta (/ dx res)))\n" +
"      (letrec\n" +
"	  ((scaled\n" +
"	    (lambda (f x y) \n" +
"	      (f\n" +
"	       (* res (/ (- x x1) dx))\n" +
"	       (* res (/ (- y y1) dy)))))\n" +
"	   (plotit\n" +
"	    (lambda (x)\n" +
"	      (scaled draw-line x (f x))\n" +
"	      (if (< x x2) (plotit (+ x delta))))))\n" +
"	(scaled draw-move 0 y1)\n" +
"	(scaled draw-line 0 y2)\n" +
"	(scaled draw-move x1 0)\n" +
"	(scaled draw-line x2 0)\n" +
"	(draw-color '(255 0 0))\n" +
"	(scaled draw-move x1 (f x1))\n" +
"	(plotit x1)))))\n" +
"\n" +
"(plotter (lambda (x) (* x x x)) 70 -5 5 -50 50)\n" +
"(plotter sin 50 -5 5 -1 1)\n" +
"(plotter (lambda (x) (* x (sin x))) 100 -25 25 -25 25)\n" +
"(plotter (lambda (x) (+ (* x x) (* -5 x) 6)) 80 -1 5 -3 10)\n";

progs["plotter"] = p;

p =
"(define koch\n" +
"  (let ((s (/ (sqrt 3) 2 3)))\n" +
"    (lambda (res depth)\n" +
"      (letrec\n" +
"	  ((iter\n" +
"	    (lambda (x1 y1 x2 y2 d)\n" +
"	      (if (zero? d) \n" +
"		  (draw-line x2 y2)\n" +
"		  (let* ((dx (- x2 x1)) \n" +
"			 (dy (- y2 y1))\n" +
"			 (thx (+ x1 (/ dx 3))) \n" +
"			 (thy (+ y1 (/ dy 3)))\n" +
"			 (thx2 (+ x1 (* 2 (/ dx 3)))) \n" +
"			 (thy2 (+ y1 (* 2 (/ dy 3))))\n" +
"			 (mx (/ (+ x1 x2) 2)) \n" +
"			 (my (/ (+ y1 y2) 2))\n" +
"			 (midx (+ mx (* (- dy) s))) \n" +
"			 (midy (+ my (* dx s))))\n" +
"		    (iter x1 y1 thx thy (- d 1))\n" +
"		    (iter thx thy midx midy (- d 1))\n" +
"		    (iter midx midy thx2 thy2 (- d 1))\n" +
"		    (iter thx2 thy2 x2 y2 (- d 1)))))))\n" +
"	(draw-move 0 0)\n" +
"	(draw-color '(0 255 0))\n" +
"	(iter 0 0 res 0 depth)))))\n" +
"\n" +
"(koch 200 4)\n";

progs["koch-curve"] = p;


p =
";;; library required\n\n" +
"(reverse '(a b c d e f))\n\n" +
"(filter '(1 2 a b 3 c 4 5 d e f) number?)\n\n" +
"(define l '(1 2 3 4 5))\n" +
"(append l '(6 7 8))\n" +
"(append l '(6 7 8) '(9 10 11))\n" +
"(append l '(6 7 8 (9 10 11)))\n" +
"(append l 6)\n";

progs["list-misc"] = p;
needslib["list-misc"] = 1;

p =
";;; library required\n" +
"\n" +
"(cond ((> 3 2) (display 'here)  (newline) 'greater)\n" +
"      ((< 3 2) (display 'there) (newline) 'less))\n" +
"(cond ((> 3 3) 'greater)\n" +
"      ((< 3 3) 'less)\n" +
"      (else 'equal))\n" +
"(cond\n" +
" (#f 'not-reached)\n" +
" ((assq 'c '((a 1) (b 2) (c 3))) => cdr))\n" +
"\n" +
";;; syntax errors\n" +
"(cond ())\n" +
"(cond (else 'a) (else 'b))\n" +
"(cond (#t =>))\n" +
"\n" +
"(define testcond\n" +
"  (lambda (l)\n" +
"    (cond\n" +
"     ((assq 'a l) => (lambda (p) (set-car! p 'd)))\n" +
"     ((assq 'b l) => (lambda (p) (set-car! p 'e)))\n" +
"     ((assq 'c l) => (lambda (p) (set-car! p 'f))))))\n" +
"\n" +
"(define l '((a 1) (b 2) (c 3)))\n" +
"(testcond l)\n" +
"(testcond l)\n" +
"(testcond l)\n" +
"l\n";

progs["cond"] = p;
needslib["cond"] = 1;


p =
";;; library required\n\n" +
"(define l '(a (1 2 (3 4) 5) b))\n" +
"(memv 'a l) \n" +
"(memv '(1 2 (3 4) 5) l) \n" +
"(member '(1 2 (3 4) 5) l)\n" +
"(define k '((a 1) (b 2) ((((a))) 3)))\n" +
"(assq 'a k)\n" +
"(assq '(((a))) k)\n" +
"(assoc '(((a))) k)\n";

progs["eq-mem-association"] = p;
needslib["eq-mem-association"] = 1;

function setprog()
{
  var form = document.forms["mainform"];
  var ind  = form.progs.selectedIndex;
  var name = form.progs.options[ind].value;

  if(name=="--menu--"){
      return;
  }
 
  form.program.value = progs[name];
  if(needslib[name]){
    form.loadlibrary.checked = true;
  }
}

</SCRIPT>
</HEAD>

<FONT SIZE=24><B>Scheme</B></FONT><P><P>
<?
if(isset($program)){
  if(!strcmp(strtoupper($showbytecodes), "ON")){
    $showbytecodes=1; $sbc='CHECKED';
  }
  else{
    $showbytecodes=0; $sbc='';
  }

  if(!strcmp(strtoupper($stacktrace), "ON")){
    $stacktrace=1; $stacktr='CHECKED';
  }
  else{
    $stacktrace=0; $stacktr='';
  }

  if(!strcmp(strtoupper($loadlibrary), "ON")){
    $loadlibrary=1; $loadlib='CHECKED';
  }
  else{
    $loadlibrary=0; $loadlib='';
  }

  init();

  if($loadlibrary){
    $stflag = $stacktrace; $stacktrace = 0;
    $lname = "library.scm";

    $fp = @fopen($lname, "r");
    if($fp){
      $library = fread($fp, filesize($lname));
      fclose($fp);

      tokenize($library);
      $form = 1; $successes = 0;
      while(isset($tokens[$base])){
	$exp = readexp();
	if(is_array($exp)){
	  $bcode = array(array('start')); $bc=1;
	  compile($exp);

	  $outputstr = '';
	  if(run()){
	    echo 
	      "<EM>Library: form $form: " . 
	      $errmsg  . 
	      "</EM><BR>\n";
	  }
	  else{
	    $successes++;
	  }
	}
	else{
	  echo 
	    "<EM>Library: form $form: " . 
	    $errmsg  . 
	    "</EM><BR>\n";
	  break;
	}
	$form++;
      }
    }
    else{
      echo 
	"<FONT COLOR=red>" .
	"Couldn't load library: $lname" . 
	"</FONT><BR>\n";
    }

    if($successes){
      echo 
	"<FONT COLOR=red>" .
	"Library: $lname: loaded $successes " . 
	"form" . ($succeses==1 ? '' : 's') . "." .
	"</FONT><BR>\n";
    }
    $stacktrace = $stflag;
  }

  $program = stripslashes($program);
  tokenize($program);
    
  $form = 1; $imageindex = 0;
  while(isset($tokens[$base])){
    $exp = readexp();
    if(is_array($exp)){
      echo "<H2>Form $form</H2>\n"; $form++;

      $str = tohtmlstring2($exp);
      echo "<TT>\n";
      echo $str;
      echo "</TT><HR>\n";

      $bcode = array(array('start')); $bc=1;
      compile($exp);

      if($showbytecodes){
	for($b=0; $b<count($bcode); $b++){
	  $instr = $bcode[$b];
	  echo "$instr[0] ";
	  for($arg=1; $arg<count($instr); $arg++){
	    if(is_array($instr[$arg])){
	      echo tohtmlstring($instr[$arg], 'noexpchars') . " ";
	    }
	    else{
	      echo $instr[$arg] . " ";
	    }
	  }
	  echo "<BR>\n";
	}
	echo "<HR>\n";
      }

      $imagedata = array(0, 0, 0, 0, array());
	    
      echo "<TT><PRE>";
      $outputstr = '';
      if(run()){
	echo "<EM>" . $errmsg  . "</EM><BR>\n";
      }
      printargstack();
      echo "</PRE></TT>\n";

      if(strlen($outputstr)>0){
	echo "<P><B>Output</B>\n";
	echo 
	  "<PRE><TT>" . 
	  htmlspecialchars($outputstr) . 
	  "</TT></PRE>\n";
      }
      echo "<P>\n";

      if(count($imagedata[4])>0){
	  $images[$imageindex] = $imagedata;

	  echo "<TABLE BORDER=5><TR><TD ALIGN=CENTER VALIGN=CENTER>\n";
	  echo "<IMG SRC=\"scheme.php?";
	  echo SID;
	  echo "&genImage=$imageindex";
	  echo "&time=" . time() . "\">\n";
	  echo "</TD></TR></TABLE>\n";
          $imageindex++;
      }
    }
    else{
      echo "<EM>" . $errmsg  . "</EM><BR>\n";
      break;
    }
  }
}
?>
<FORM NAME=mainform METHOD=POST ACTION="scheme.php">
<SELECT NAME=progs onChange="setprog()">
<OPTION VALUE="--menu--" SELECTED>TEST CASES
<OPTION VALUE=reduce>reduce
<OPTION VALUE=factorial>factorial
<OPTION VALUE=call-cc>call-cc
<OPTION VALUE=call-cc1>call-cc1
<OPTION VALUE=tail-recursion>tail-recursion
<OPTION VALUE=let-over-lambda>let-over-lambda
<OPTION VALUE=list-misc>list-misc
<OPTION VALUE=and-or>and-or
<OPTION VALUE=primes>primes
<OPTION VALUE=case>case
<OPTION VALUE=cond>cond
<OPTION VALUE=rootfinder>rootfinder
<OPTION VALUE=plotter>plotter
<OPTION VALUE=koch-curve>koch-curve
<OPTION VALUE=eq-mem-association>eq-mem-association
</SELECT>
<BR>
<TEXTAREA NAME=program ROWS=12 COLS=80>
<? echo $program; ?>
</TEXTAREA>
<BR>
<INPUT TYPE=SUBMIT VALUE="Evaluate">
Show byte codes
<INPUT TYPE=CHECKBOX  NAME=showbytecodes  <? echo $sbc; ?>>
Show stack trace
<INPUT TYPE=CHECKBOX  NAME=stacktrace     <? echo $stacktr; ?>>
Load library
<INPUT TYPE=CHECKBOX  NAME=loadlibrary    <? echo $loadlib; ?>>
</FORM>

<? author(); ?>
</BODY>
</HTML>