gscheme/php/scheme.php

2563 lines
54 KiB
PHP
Raw Normal View History

2022-08-05 05:28:40 -04:00
<?
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>