Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Sketch of a metacircular evaluator

  • Loading branch information...
commit 46a55b382d5a3017d2a66f14fdadf286fbda4aeb 1 parent f1678d4
Tony Garnock-Jones authored September 04, 2011
5  index.html
@@ -12,6 +12,8 @@
12 12
     <input type="submit" value="eval">
13 13
   </form>
14 14
   <script type="text/javascript">
  15
+Vau.baseenv["display"] = function (x) { display(uneval(x)); };
  16
+Vau.loadPrelude();
15 17
 var global_env = Vau.extend(Vau.baseenv);
16 18
 global_env.globals = global_env;
17 19
 global_env["+"] = function (a, b) { return a + b; };
@@ -24,8 +26,7 @@
24 26
   document.getElementById("output").appendChild(d);
25 27
   return d;
26 28
 }
27  
-Vau.baseenv["display"] = function (x) { display(uneval(x)); };
28  
-Vau.loadPrelude();
  29
+global_env["window"] = window;
29 30
 function do_eval() {
30 31
   var input = document.forms.evalform.input.value;
31 32
   while (input) {
92  prelude.vau
@@ -40,4 +40,96 @@
40 40
 	   ($begin (proc (car xs))
41 41
 		   (for-each proc (cdr xs))))))
42 42
 
  43
+  ($define! @
  44
+    ($vau (objexp name) env
  45
+      (eval (list raw@ (eval objexp env) name) env)))
  46
+
  47
+  ($define! @=
  48
+    ($vau (objexp name valexp) env
  49
+      (eval (list raw@= (eval objexp env) name (eval valexp env)) env)))
  50
+
  51
+  ($define! apply
  52
+    ($lambda (appv arg . opt)
  53
+      (eval (cons (unwrap appv) arg)
  54
+	    ($if (null? opt)
  55
+		 (extend-env *base-env*)
  56
+		 (car opt)))))
  57
+
  58
+  ($define! reverse
  59
+    ($lambda (xs)
  60
+      (reverse-onto xs ())))
  61
+
  62
+  ($define! reverse-onto
  63
+    ($lambda (xs acc)
  64
+      ($if (null? xs)
  65
+	   acc
  66
+	   (reverse-onto (cdr xs) (cons (car xs) acc)))))
  67
+
  68
+  ($define! not
  69
+    ($lambda (x)
  70
+      ($if x #f #t)))
  71
+
  72
+  ($define! mc-eval
  73
+    ($lambda (exp env k)
  74
+      ($cond
  75
+       ((symbol? exp) (k (env-lookup env exp)))
  76
+       ((not (pair? exp)) (k exp))
  77
+       (#t (mc-eval (car exp) env (make-combiner (cdr exp) env k))))))
  78
+
  79
+  ($define! make-combiner
  80
+    ($lambda (argtree env k)
  81
+      ($lambda (rator)
  82
+	($cond
  83
+	 ((primitive-applicative? rator)
  84
+	  (mc-eval-args argtree () env (make-primitive-applier rator k)))
  85
+	 ((operative? rator)
  86
+	  ($let ((newenv (extend-env (@ rator staticenv))))
  87
+	    (mc-match! newenv (@ rator formals) argtree)
  88
+	    (mc-match! newenv (@ rator envformal) env)
  89
+	    (mc-eval (@ rator body) newenv k)))
  90
+	 ((applicative? rator)
  91
+	  (mc-eval-args argtree () env (make-applicative-combiner (@ rator underlying) env k)))
  92
+	 ((primitive-operative? rator)
  93
+	  (eval (list* rator argtree) env))
  94
+	 (#t ($error mc-eval "Not a callable: ~v with argtree: ~v" rator argtree))))))
  95
+
  96
+  ($define! make-primitive-applier
  97
+    ($lambda (rator k)
  98
+      ($lambda (args)
  99
+	(k (apply rator args)))))
  100
+
  101
+  ($define! make-applicative-combiner
  102
+    ($lambda (op env k)
  103
+      ($lambda (args)
  104
+	(mc-eval (cons op args) env k))))
  105
+
  106
+  ($define! mc-eval-args
  107
+    ($lambda (args revacc env k)
  108
+      ($if (null? args)
  109
+	   (k (reverse revacc))
  110
+	   (mc-eval (car args) env
  111
+		    ($lambda (v) (mc-eval-args (cdr args) (cons v revacc) env k))))))
  112
+
  113
+  ($define! $and
  114
+    ($vau exps env
  115
+      ($cond
  116
+       ((null? exps) #t)
  117
+       ((eval (car exps) env) (eval (cons $and (cdr exps)) env))
  118
+       (#t #f))))
  119
+
  120
+  ($define! mc-match!
  121
+    ($lambda (env pattern value)
  122
+      ($cond
  123
+       ((pair? pattern) ($if (pair? value)
  124
+			     ($begin (mc-match! env (car pattern) (car value))
  125
+				     (mc-match! env (cdr pattern) (cdr value)))
  126
+			     (mismatch pattern value)))
  127
+       ((symbol? pattern) (env-set! env pattern value))
  128
+       (($and (keyword? pattern) (=== (@ pattern name) "#ignore")) #t)
  129
+       ((=== pattern value) #t)
  130
+       (#t (mismatch pattern value)))))
  131
+
  132
+  ($define! mismatch
  133
+    ($lambda (pattern value)
  134
+      ($error mc-match! "Mismatch: ~v != ~v" pattern value)))
43 135
   )
60  vau2.js
@@ -410,7 +410,16 @@ Vau.coreenv.wrap = function (underlying) {
410 410
 };
411 411
 
412 412
 Vau.coreenv.unwrap = function (applicative) {
413  
-    return applicative.underlying;
  413
+    if (applicative instanceof Vau.Applicative) {
  414
+	return applicative.underlying;
  415
+    } else if (typeof applicative === "function") {
  416
+	return new Vau.Primitive(function (vm, dynenv, argtree) {
  417
+	    vm.a = applicative.apply(null, Vau.listToArray(argtree));
  418
+	});
  419
+    } else {
  420
+	throw {message: "Attempt to unwrap non-unwrappable object",
  421
+	       object: applicative};
  422
+    }
414 423
 };
415 424
 
416 425
 //---------------------------------------------------------------------------
@@ -457,8 +466,25 @@ Vau.baseenv["list*"] = function () {
457 466
 			   arguments[arguments.length - 1]);
458 467
 };
459 468
 
460  
-Vau.baseenv["make-base-env"] = function () {
461  
-    return Vau.extend(Vau.baseenv);
  469
+Vau.baseenv["env-set!"] = function (env, sym, val) {
  470
+    env[sym.name] = val;
  471
+    return val;
  472
+};
  473
+
  474
+Vau.baseenv["env-lookup"] = function (env, sym) {
  475
+    return env[sym.name];
  476
+};
  477
+
  478
+Vau.baseenv["extend-env"] = function (env) {
  479
+    return Vau.extend(env);
  480
+};
  481
+
  482
+Vau.baseenv["primitive-applicative?"] = function (x) {
  483
+    return typeof x === "function";
  484
+};
  485
+
  486
+Vau.baseenv["primitive-operative?"] = function (x) {
  487
+    return x instanceof Vau.Primitive;
462 488
 };
463 489
 
464 490
 Vau.baseenv["applicative?"] = function (x) {
@@ -469,6 +495,34 @@ Vau.baseenv["operative?"] = function (x) {
469 495
     return x instanceof Vau.Operative;
470 496
 };
471 497
 
  498
+Vau.baseenv["symbol?"] = function (x) {
  499
+    return x instanceof Vau.Symbol;
  500
+};
  501
+
  502
+Vau.baseenv["keyword?"] = function (x) {
  503
+    return x instanceof Vau.Keyword;
  504
+};
  505
+
  506
+Vau.baseenv["==="] = function (a, b) {
  507
+    return a === b;
  508
+};
  509
+
  510
+Vau.to_string = function (x) {
  511
+    if (typeof x === "string") return x;
  512
+    if (x instanceof Vau.Symbol) return x.name;
  513
+    if (x instanceof Vau.Keyword) return x.name.substring(1); // remove leading #
  514
+    throw {message: "Cannot extract string from object", object: x};
  515
+};
  516
+
  517
+Vau.baseenv["raw@"] = new Vau.Primitive(function (vm, dynenv, argtree) {
  518
+    vm.a = argtree.car[Vau.to_string(argtree.cdr.car)];
  519
+});
  520
+
  521
+Vau.baseenv["raw@="] = new Vau.Primitive(function (vm, dynenv, argtree) {
  522
+    argtree.car[Vau.to_string(argtree.cdr.car)] = argtree.cdr.cdr.car;
  523
+    vm.a = null;
  524
+});
  525
+
472 526
 Vau.baseenv["make-js-function"] = function (op, env) {
473 527
     return function () {
474 528
 	try {

0 notes on commit 46a55b3

Please sign in to comment.
Something went wrong with that request. Please try again.