Scheme

By Marko Riedel, mriedel@neuearbeit.de, http://www.geocities.com/markoriedelde/index.html. 0){ $ltokens[]=$parts[1]; } $ltokens[]=array('string', $parts[2]); } if(strlen($current)){ $ltokens[]=$current; } for($tok=0; $tok0){ $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 ''; } else if(valtype($exp)=='bcode'){ return ''; } else if(valtype($exp)=='thunk'){ return ''; } else if(valtype($exp)=='primitive'){ return ''; } 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; $p0){ $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] . "
\n"; if($stacktrace && $instr[0]!='start'){ echo "> "; 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)
\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); } } ?> Scheme Scheme

Library: form $form: " . $errmsg . "
\n"; } else{ $successes++; } } else{ echo "Library: form $form: " . $errmsg . "
\n"; break; } $form++; } } else{ echo "" . "Couldn't load library: $lname" . "
\n"; } if($successes){ echo "" . "Library: $lname: loaded $successes " . "form" . ($succeses==1 ? '' : 's') . "." . "
\n"; } $stacktrace = $stflag; } $program = stripslashes($program); tokenize($program); $form = 1; $imageindex = 0; while(isset($tokens[$base])){ $exp = readexp(); if(is_array($exp)){ echo "

Form $form

\n"; $form++; $str = tohtmlstring2($exp); echo "\n"; echo $str; echo "

\n"; $bcode = array(array('start')); $bc=1; compile($exp); if($showbytecodes){ for($b=0; $b\n"; } echo "

\n"; } $imagedata = array(0, 0, 0, 0, array()); echo ""; $outputstr = ''; if(run()){ echo "" . $errmsg . " \n"; } printargstack(); echo "\n"; if(strlen($outputstr)>0){ echo "

Output\n"; echo "

" . 
	  htmlspecialchars($outputstr) . 
	  "

\n"; } echo "

\n"; if(count($imagedata[4])>0){ $images[$imageindex] = $imagedata; echo "
\n"; echo "\n"; echo "
\n"; $imageindex++; } } else{ echo "" . $errmsg . "
\n"; break; } } } ?>