2563 lines
54 KiB
PHP
2563 lines
54 KiB
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>></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>
|
|
|