├── BUGS ├── README ├── browser.virtua ├── examples └── conditions-example.virtua ├── index.html ├── jsparse.js ├── repl.virtua ├── standard.virtua ├── test.js ├── test.virtua └── virtua.js /BUGS: -------------------------------------------------------------------------------- 1 | -*- org -*- 2 | 3 | * Line comments and the whitespace of a file parse as #inert. 4 | This means that the programs "12 ;; foo" and "12 " evaluate 5 | to #inert, clearly evil. 6 | 7 | * DEFINE-CLASS creates new class, even if class exists. 8 | It should redefine the class, bring it up to date, instead. 9 | 10 | * Integration of JS's undefined is logically flawed. 11 | It's impossible to assign undefined to a variable, because 12 | environment lookup will confuse it with a non-existing binding. 13 | * The variable "constructor" is always bound to undefined. 14 | Because it's a property of every environment's bindings table. 15 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Virtua is an experimental interpreter written in JavaScript for a 2 | Lisp-like language with lexically-scoped fexprs, as in John Shutt's 3 | Kernel language. 4 | 5 | To try it out, visit REPL at http://manuel.github.com/virtua/ or serve 6 | directory locally over HTTP and browse index.html 7 | 8 | e.g. 9 | 10 | python -m SimpleHTTPServer 11 | -------------------------------------------------------------------------------- /browser.virtua: -------------------------------------------------------------------------------- 1 | ;; -*- Lisp -*- 2 | 3 | (defvar alert (js-global "alert")) 4 | (defvar prompt (js-global "prompt")) 5 | 6 | (defvar *window* (js-global "window")) 7 | (defvar *document* (js-global "document")) 8 | (defvar *body* (get-slot *document* "body")) 9 | 10 | (define-js-methods 11 | "appendChild" 12 | "createElement" 13 | "createTextNode" 14 | "focus" 15 | "getElementById" 16 | "scrollTo" 17 | "setAttribute" 18 | ) 19 | 20 | (defun define-dom-element (name) 21 | (defmacro maker (attrs . children) env 22 | (def e (createElement *document* name)) 23 | (map-plist (lambda (aname avalue) 24 | (setAttribute e 25 | (strslice (symbol-name aname) 1) 26 | (eval avalue env))) 27 | attrs) 28 | (map (lambda (child) 29 | (let ((ch (eval child env))) 30 | (if (instance? ch String) 31 | (appendChild e (createTextNode *document* ch)) 32 | (appendChild e ch)))) 33 | children) 34 | e) 35 | (eval (list def (intern name) maker) *top-level-environment*)) 36 | 37 | (defun define-dom-elements names 38 | (map define-dom-element names)) 39 | 40 | (define-dom-elements 41 | "DIV" 42 | "FORM" 43 | "INPUT" 44 | "P" 45 | "SPAN" 46 | "TABLE" 47 | "TD" 48 | "TH" 49 | "TR" 50 | ) 51 | -------------------------------------------------------------------------------- /examples/conditions-example.virtua: -------------------------------------------------------------------------------- 1 | ;; -*- LISP -*- 2 | 3 | ;; See http://axisofeval.blogspot.com/2011/04/whats-condition-system-and-why-do-you.html 4 | 5 | (defvar *val-option* nothing) 6 | 7 | (defclass No-Val-Error (Error) () 8 | (:constructor make-no-val-error ())) 9 | 10 | (defclass Use-Val-Restart (Restart) 11 | (val) 12 | (:constructor make-use-val-restart (val))) 13 | 14 | (defun get-val () 15 | (if-option (val *val-option*) 16 | val 17 | (throw (make-no-val-error) 18 | ((Use-Val-Restart r) (.val r))))) 19 | 20 | (defun set-val (new-val) 21 | (set! *val-option* (just new-val))) 22 | 23 | (handle (get-val) 24 | ((No-Val-Error e) (throw (make-use-val-restart "the default value")))) 25 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Virtua 0.1.2 5 | 6 | 7 | 8 | 9 | 59 | 60 | 61 | 99 | 100 | 101 | -------------------------------------------------------------------------------- /jsparse.js: -------------------------------------------------------------------------------- 1 | // Copyright (C) 2007 Chris Double. 2 | // 3 | // Redistribution and use in source and binary forms, with or without 4 | // modification, are permitted provided that the following conditions are met: 5 | // 6 | // 1. Redistributions of source code must retain the above copyright notice, 7 | // this list of conditions and the following disclaimer. 8 | // 9 | // 2. Redistributions in binary form must reproduce the above copyright notice, 10 | // this list of conditions and the following disclaimer in the documentation 11 | // and/or other materials provided with the distribution. 12 | // 13 | // THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, 14 | // INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 15 | // FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 16 | // DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 17 | // SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 18 | // PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 19 | // OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 20 | // WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 21 | // OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 22 | // ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | // 24 | 25 | function foldl(f, initial, seq) { 26 | for(var i=0; i< seq.length; ++i) 27 | initial = f(initial, seq[i]); 28 | return initial; 29 | } 30 | 31 | var memoize = true; 32 | 33 | function ParseState(input, index) { 34 | this.input = input; 35 | this.index = index || 0; 36 | this.length = input.length - this.index; 37 | this.cache = { }; 38 | return this; 39 | } 40 | 41 | ParseState.prototype.from = function(index) { 42 | var r = new ParseState(this.input, this.index + index); 43 | r.cache = this.cache; 44 | r.length = this.length - index; 45 | return r; 46 | } 47 | 48 | ParseState.prototype.substring = function(start, end) { 49 | return this.input.substring(start + this.index, (end || this.length) + this.index); 50 | } 51 | 52 | ParseState.prototype.trimLeft = function() { 53 | var s = this.substring(0); 54 | var m = s.match(/^\s+/); 55 | return m ? this.from(m[0].length) : this; 56 | } 57 | 58 | ParseState.prototype.at = function(index) { 59 | return this.input.charAt(this.index + index); 60 | } 61 | 62 | ParseState.prototype.toString = function() { 63 | return 'PS"' + this.substring(0) + '"'; 64 | } 65 | 66 | ParseState.prototype.getCached = function(pid) { 67 | if(!memoize) 68 | return false; 69 | 70 | var p = this.cache[pid]; 71 | if(p) 72 | return p[this.index]; 73 | else 74 | return false; 75 | } 76 | 77 | ParseState.prototype.putCached = function(pid, cached) { 78 | if(!memoize) 79 | return false; 80 | 81 | var p = this.cache[pid]; 82 | if(p) 83 | p[this.index] = cached; 84 | else { 85 | p = this.cache[pid] = { }; 86 | p[this.index] = cached; 87 | } 88 | } 89 | 90 | function ps(str) { 91 | return new ParseState(str); 92 | } 93 | 94 | // 'r' is the remaining string to be parsed. 95 | // 'matched' is the portion of the string that 96 | // was successfully matched by the parser. 97 | // 'ast' is the AST returned by the successfull parse. 98 | function make_result(r, matched, ast) { 99 | return { remaining: r, matched: matched, ast: ast }; 100 | } 101 | 102 | var parser_id = 0; 103 | 104 | // 'token' is a parser combinator that given a string, returns a parser 105 | // that parses that string value. The AST contains the string that was parsed. 106 | function token(s) { 107 | var pid = parser_id++; 108 | return function(state) { 109 | var savedState = state; 110 | var cached = savedState.getCached(pid); 111 | if(cached) 112 | return cached; 113 | 114 | var r = state.length >= s.length && state.substring(0,s.length) == s; 115 | if(r) 116 | cached = { remaining: state.from(s.length), matched: s, ast: s }; 117 | else 118 | cached = false; 119 | savedState.putCached(pid, cached); 120 | return cached; 121 | }; 122 | } 123 | 124 | // Like 'token' but for a single character. Returns a parser that given a string 125 | // containing a single character, parses that character value. 126 | function ch(c) { 127 | var pid = parser_id++; 128 | return function(state) { 129 | var savedState = state; 130 | var cached = savedState.getCached(pid); 131 | if(cached) 132 | return cached; 133 | var r = state.length >= 1 && state.at(0) == c; 134 | if(r) 135 | cached = { remaining: state.from(1), matched: c, ast: c }; 136 | else 137 | cached = false; 138 | savedState.putCached(pid, cached); 139 | return cached; 140 | }; 141 | } 142 | 143 | // 'range' is a parser combinator that returns a single character parser 144 | // (similar to 'ch'). It parses single characters that are in the inclusive 145 | // range of the 'lower' and 'upper' bounds ("a" to "z" for example). 146 | function range(lower, upper) { 147 | var pid = parser_id++; 148 | return function(state) { 149 | var savedState = state; 150 | var cached = savedState.getCached(pid); 151 | if(cached) 152 | return cached; 153 | 154 | if(state.length < 1) 155 | cached = false; 156 | else { 157 | var ch = state.at(0); 158 | if(ch >= lower && ch <= upper) 159 | cached = { remaining: state.from(1), matched: ch, ast: ch }; 160 | else 161 | cached = false; 162 | } 163 | savedState.putCached(pid, cached); 164 | return cached; 165 | }; 166 | } 167 | 168 | // Helper function to convert string literals to token parsers 169 | // and perform other implicit parser conversions. 170 | function toParser(p) { 171 | return (typeof(p) == "string") ? token(p) : p; 172 | } 173 | 174 | // Parser combinator that returns a parser that 175 | // skips whitespace before applying parser. 176 | function whitespace(p) { 177 | var p = toParser(p); 178 | var pid = parser_id++; 179 | return function(state) { 180 | var savedState = state; 181 | var cached = savedState.getCached(pid); 182 | if(cached) 183 | return cached; 184 | 185 | cached = p(state.trimLeft()); 186 | savedState.putCached(pid, cached); 187 | return cached; 188 | }; 189 | } 190 | 191 | // Parser combinator that passes the AST generated from the parser 'p' 192 | // to the function 'f'. The result of 'f' is used as the AST in the result. 193 | function action(p, f) { 194 | var p = toParser(p); 195 | var pid = parser_id++; 196 | return function(state) { 197 | var savedState = state; 198 | var cached = savedState.getCached(pid); 199 | if(cached) 200 | return cached; 201 | 202 | var x = p(state); 203 | if(x) { 204 | x.ast = f(x.ast); 205 | cached = x; 206 | } 207 | else { 208 | cached = false; 209 | } 210 | savedState.putCached(pid, cached); 211 | return cached; 212 | }; 213 | } 214 | 215 | // Given a parser that produces an array as an ast, returns a 216 | // parser that produces an ast with the array joined by a separator. 217 | function join_action(p, sep) { 218 | return action(p, function(ast) { return ast.join(sep); }); 219 | } 220 | 221 | // Given an ast of the form [ Expression, [ a, b, ...] ], convert to 222 | // [ [ [ Expression [ a ] ] b ] ... ] 223 | // This is used for handling left recursive entries in the grammar. e.g. 224 | // MemberExpression: 225 | // PrimaryExpression 226 | // FunctionExpression 227 | // MemberExpression [ Expression ] 228 | // MemberExpression . Identifier 229 | // new MemberExpression Arguments 230 | function left_factor(ast) { 231 | return foldl(function(v, action) { 232 | return [ v, action ]; 233 | }, 234 | ast[0], 235 | ast[1]); 236 | } 237 | 238 | // Return a parser that left factors the ast result of the original 239 | // parser. 240 | function left_factor_action(p) { 241 | return action(p, left_factor); 242 | } 243 | 244 | // 'negate' will negate a single character parser. So given 'ch("a")' it will successfully 245 | // parse any character except for 'a'. Or 'negate(range("a", "z"))' will successfully parse 246 | // anything except the lowercase characters a-z. 247 | function negate(p) { 248 | var p = toParser(p); 249 | var pid = parser_id++; 250 | return function(state) { 251 | var savedState = state; 252 | var cached = savedState.getCached(pid); 253 | if(cached) 254 | return cached; 255 | 256 | if(state.length >= 1) { 257 | var r = p(state); 258 | if(!r) 259 | cached = make_result(state.from(1), state.at(0), state.at(0)); 260 | else 261 | cached = false; 262 | } 263 | else { 264 | cached = false; 265 | } 266 | savedState.putCached(pid, cached); 267 | return cached; 268 | }; 269 | } 270 | 271 | // 'end_p' is a parser that is successful if the input string is empty (ie. end of parse). 272 | function end_p(state) { 273 | if(state.length == 0) 274 | return make_result(state, undefined, undefined); 275 | else 276 | return false; 277 | } 278 | 279 | // 'nothing_p' is a parser that always fails. 280 | function nothing_p(state) { 281 | return false; 282 | } 283 | 284 | // 'sequence' is a parser combinator that processes a number of parsers in sequence. 285 | // It can take any number of arguments, each one being a parser. The parser that 'sequence' 286 | // returns succeeds if all the parsers in the sequence succeeds. It fails if any of them fail. 287 | function sequence() { 288 | var parsers = []; 289 | for(var i = 0; i < arguments.length; ++i) 290 | parsers.push(toParser(arguments[i])); 291 | var pid = parser_id++; 292 | return function(state) { 293 | var savedState = state; 294 | var cached = savedState.getCached(pid); 295 | if(cached) { 296 | return cached; 297 | } 298 | 299 | var ast = []; 300 | var matched = ""; 301 | var i; 302 | for(i=0; i< parsers.length; ++i) { 303 | var parser = parsers[i]; 304 | var result = parser(state); 305 | if(result) { 306 | state = result.remaining; 307 | if(result.ast != undefined) { 308 | ast.push(result.ast); 309 | matched = matched + result.matched; 310 | } 311 | } 312 | else { 313 | break; 314 | } 315 | } 316 | if(i == parsers.length) { 317 | cached = make_result(state, matched, ast); 318 | } 319 | else 320 | cached = false; 321 | savedState.putCached(pid, cached); 322 | return cached; 323 | }; 324 | } 325 | 326 | // Like sequence, but ignores whitespace between individual parsers. 327 | function wsequence() { 328 | var parsers = []; 329 | for(var i=0; i < arguments.length; ++i) { 330 | parsers.push(whitespace(toParser(arguments[i]))); 331 | } 332 | return sequence.apply(null, parsers); 333 | } 334 | 335 | // 'choice' is a parser combinator that provides a choice between other parsers. 336 | // It takes any number of parsers as arguments and returns a parser that will try 337 | // each of the given parsers in order. The first one that succeeds results in a 338 | // successfull parse. It fails if all parsers fail. 339 | function choice() { 340 | var parsers = []; 341 | for(var i = 0; i < arguments.length; ++i) 342 | parsers.push(toParser(arguments[i])); 343 | var pid = parser_id++; 344 | return function(state) { 345 | var savedState = state; 346 | var cached = savedState.getCached(pid); 347 | if(cached) { 348 | return cached; 349 | } 350 | var i; 351 | for(i=0; i< parsers.length; ++i) { 352 | var parser=parsers[i]; 353 | var result = parser(state); 354 | if(result) { 355 | break; 356 | } 357 | } 358 | if(i == parsers.length) 359 | cached = false; 360 | else 361 | cached = result; 362 | savedState.putCached(pid, cached); 363 | return cached; 364 | } 365 | } 366 | 367 | // 'butnot' is a parser combinator that takes two parsers, 'p1' and 'p2'. 368 | // It returns a parser that succeeds if 'p1' matches and 'p2' does not, or 369 | // 'p1' matches and the matched text is longer that p2's. 370 | // Useful for things like: butnot(IdentifierName, ReservedWord) 371 | function butnot(p1,p2) { 372 | var p1 = toParser(p1); 373 | var p2 = toParser(p2); 374 | var pid = parser_id++; 375 | 376 | // match a but not b. if both match and b's matched text is shorter 377 | // than a's, a failed match is made 378 | return function(state) { 379 | var savedState = state; 380 | var cached = savedState.getCached(pid); 381 | if(cached) 382 | return cached; 383 | 384 | var br = p2(state); 385 | if(!br) { 386 | cached = p1(state); 387 | } else { 388 | var ar = p1(state); 389 | 390 | if (ar) { 391 | if(ar.matched.length > br.matched.length) 392 | cached = ar; 393 | else 394 | cached = false; 395 | } 396 | else { 397 | cached = false; 398 | } 399 | } 400 | savedState.putCached(pid, cached); 401 | return cached; 402 | } 403 | } 404 | 405 | // 'difference' is a parser combinator that takes two parsers, 'p1' and 'p2'. 406 | // It returns a parser that succeeds if 'p1' matches and 'p2' does not. If 407 | // both match then if p2's matched text is shorter than p1's it is successfull. 408 | function difference(p1,p2) { 409 | var p1 = toParser(p1); 410 | var p2 = toParser(p2); 411 | var pid = parser_id++; 412 | 413 | // match a but not b. if both match and b's matched text is shorter 414 | // than a's, a successfull match is made 415 | return function(state) { 416 | var savedState = state; 417 | var cached = savedState.getCached(pid); 418 | if(cached) 419 | return cached; 420 | 421 | var br = p2(state); 422 | if(!br) { 423 | cached = p1(state); 424 | } else { 425 | var ar = p1(state); 426 | if(ar.matched.length >= br.matched.length) 427 | cached = br; 428 | else 429 | cached = ar; 430 | } 431 | savedState.putCached(pid, cached); 432 | return cached; 433 | } 434 | } 435 | 436 | 437 | // 'xor' is a parser combinator that takes two parsers, 'p1' and 'p2'. 438 | // It returns a parser that succeeds if 'p1' or 'p2' match but fails if 439 | // they both match. 440 | function xor(p1, p2) { 441 | var p1 = toParser(p1); 442 | var p2 = toParser(p2); 443 | var pid = parser_id++; 444 | 445 | // match a or b but not both 446 | return function(state) { 447 | var savedState = state; 448 | var cached = savedState.getCached(pid); 449 | if(cached) 450 | return cached; 451 | 452 | var ar = p1(state); 453 | var br = p2(state); 454 | if(ar && br) 455 | cached = false; 456 | else 457 | cached = ar || br; 458 | savedState.putCached(pid, cached); 459 | return cached; 460 | } 461 | } 462 | 463 | // A parser combinator that takes one parser. It returns a parser that 464 | // looks for zero or more matches of the original parser. 465 | function repeat0(p) { 466 | var p = toParser(p); 467 | var pid = parser_id++; 468 | 469 | return function(state) { 470 | var savedState = state; 471 | var cached = savedState.getCached(pid); 472 | if(cached) { 473 | return cached; 474 | } 475 | 476 | var ast = []; 477 | var matched = ""; 478 | var result; 479 | while(result = p(state)) { 480 | ast.push(result.ast); 481 | matched = matched + result.matched; 482 | if(result.remaining.index == state.index) 483 | break; 484 | state = result.remaining; 485 | } 486 | cached = make_result(state, matched, ast); 487 | savedState.putCached(pid, cached); 488 | return cached; 489 | } 490 | } 491 | 492 | // A parser combinator that takes one parser. It returns a parser that 493 | // looks for one or more matches of the original parser. 494 | function repeat1(p) { 495 | var p = toParser(p); 496 | var pid = parser_id++; 497 | 498 | return function(state) { 499 | var savedState = state; 500 | var cached = savedState.getCached(pid); 501 | if(cached) 502 | return cached; 503 | 504 | var ast = []; 505 | var matched = ""; 506 | var result= p(state); 507 | if(!result) 508 | cached = false; 509 | else { 510 | while(result) { 511 | ast.push(result.ast); 512 | matched = matched + result.matched; 513 | if(result.remaining.index == state.index) 514 | break; 515 | state = result.remaining; 516 | result = p(state); 517 | } 518 | cached = make_result(state, matched, ast); 519 | } 520 | savedState.putCached(pid, cached); 521 | return cached; 522 | } 523 | } 524 | 525 | // A parser combinator that takes one parser. It returns a parser that 526 | // matches zero or one matches of the original parser. 527 | function optional(p) { 528 | var p = toParser(p); 529 | var pid = parser_id++; 530 | return function(state) { 531 | var savedState = state; 532 | var cached = savedState.getCached(pid); 533 | if(cached) 534 | return cached; 535 | var r = p(state); 536 | cached = r || make_result(state, "", false); 537 | savedState.putCached(pid, cached); 538 | return cached; 539 | } 540 | } 541 | 542 | // A parser combinator that ensures that the given parser succeeds but 543 | // ignores its result. This can be useful for parsing literals that you 544 | // don't want to appear in the ast. eg: 545 | // sequence(expect("("), Number, expect(")")) => ast: Number 546 | function expect(p) { 547 | return action(p, function(ast) { return undefined; }); 548 | } 549 | 550 | function chain(p, s, f) { 551 | var p = toParser(p); 552 | 553 | return action(sequence(p, repeat0(action(sequence(s, p), f))), 554 | function(ast) { return [ast[0]].concat(ast[1]); }); 555 | } 556 | 557 | // A parser combinator to do left chaining and evaluation. Like 'chain', it expects a parser 558 | // for an item and for a seperator. The seperator parser's AST result should be a function 559 | // of the form: function(lhs,rhs) { return x; } 560 | // Where 'x' is the result of applying some operation to the lhs and rhs AST's from the item 561 | // parser. 562 | function chainl(p, s) { 563 | var p = toParser(p); 564 | return action(sequence(p, repeat0(sequence(s, p))), 565 | function(ast) { 566 | return foldl(function(v, action) { return action[0](v, action[1]); }, ast[0], ast[1]); 567 | }); 568 | } 569 | 570 | // A parser combinator that returns a parser that matches lists of things. The parser to 571 | // match the list item and the parser to match the seperator need to 572 | // be provided. The AST is the array of matched items. 573 | function list(p, s) { 574 | return chain(p, s, function(ast) { return ast[1]; }); 575 | } 576 | 577 | // Like list, but ignores whitespace between individual parsers. 578 | function wlist() { 579 | var parsers = []; 580 | for(var i=0; i < arguments.length; ++i) { 581 | parsers.push(whitespace(arguments[i])); 582 | } 583 | return list.apply(null, parsers); 584 | } 585 | 586 | // A parser that always returns a zero length match 587 | function epsilon_p(state) { 588 | return make_result(state, "", undefined); 589 | } 590 | 591 | // Allows attaching of a function anywhere in the grammer. If the function returns 592 | // true then parse succeeds otherwise it fails. Can be used for testing if a symbol 593 | // is in the symbol table, etc. 594 | function semantic(f) { 595 | var pid = parser_id++; 596 | return function(state) { 597 | var savedState = state; 598 | var cached = savedState.getCached(pid); 599 | if(cached) 600 | return cached; 601 | cached = f() ? make_result(state, "", undefined) : false; 602 | savedState.putCached(pid, cached); 603 | return cached; 604 | } 605 | } 606 | 607 | // The and predicate asserts that a certain conditional 608 | // syntax is satisfied before evaluating another production. Eg: 609 | // sequence(and("0"), oct_p) 610 | // (if a leading zero, then parse octal) 611 | // It succeeds if 'p' succeeds and fails if 'p' fails. It never 612 | // consume any input however, and doesn't put anything in the resulting 613 | // AST. 614 | function and(p) { 615 | var p = toParser(p); 616 | var pid = parser_id++; 617 | return function(state) { 618 | var savedState = state; 619 | var cached = savedState.getCached(pid); 620 | if(cached) 621 | return cached; 622 | var r = p(state); 623 | cached = r ? make_result(state, "", undefined) : false; 624 | savedState.putCached(pid, cached); 625 | return cached; 626 | } 627 | } 628 | 629 | // The opposite of 'and'. It fails if 'p' succeeds and succeeds if 630 | // 'p' fails. It never consumes any input. This combined with 'and' can 631 | // be used for 'lookahead' and disambiguation of cases. 632 | // 633 | // Compare: 634 | // sequence("a",choice("+","++"),"b") 635 | // parses a+b 636 | // but not a++b because the + matches the first part and peg's don't 637 | // backtrack to other choice options if they succeed but later things fail. 638 | // 639 | // sequence("a",choice(sequence("+", not("+")),"++"),"b") 640 | // parses a+b 641 | // parses a++b 642 | // 643 | function not(p) { 644 | var p = toParser(p); 645 | var pid = parser_id++; 646 | return function(state) { 647 | var savedState = state; 648 | var cached = savedState.getCached(pid); 649 | if(cached) 650 | return cached; 651 | cached = p(state) ? false : make_result(state, "", undefined); 652 | savedState.putCached(pid, cached); 653 | return cached; 654 | } 655 | } 656 | 657 | 658 | -------------------------------------------------------------------------------- /repl.virtua: -------------------------------------------------------------------------------- 1 | ;; -*- Lisp -*- 2 | 3 | (defgeneric present (obj)) 4 | (defmethod present ((any Object)) 5 | (SPAN () (to-string any))) 6 | 7 | (defmethod present ((any User-Object)) 8 | (defun present-slot (name) 9 | (TR () 10 | (TH (:class "lisp-slot-name") name) 11 | (TD () (present-small (get-slot any name))))) 12 | (DIV (:class "lisp-user-object") 13 | (DIV (:class "lisp-user-object-class") (debug-name (class-of any))) 14 | (apply (wrap TABLE) (list* () (map present-slot (slot-names any)))))) 15 | 16 | (defgeneric present-small (obj)) 17 | (defmethod present-small ((any Object)) 18 | (SPAN () (to-string any))) 19 | 20 | ;(defmethod present ((b Boolean)) 21 | ; (def e (INPUT (:type "checkbox" :disabled "disabled"))) 22 | ; (when b (setAttribute e "checked" #t)) 23 | ; e) 24 | 25 | ;(defmethod present ((s String)) 26 | ; (DIV (:class "lisp-string") s)) 27 | 28 | (defclass Repl-Note () 29 | (content) 30 | (:constructor make-repl-note (content))) 31 | 32 | (defgeneric repl-note (message)) 33 | (defmethod repl-note ((s String)) 34 | (print (make-repl-note s))) 35 | 36 | (defmethod present ((n Repl-Note)) 37 | (DIV (:class "lisp-repl-note") 38 | (.content n))) 39 | 40 | (defclass Repl-Input () 41 | (string) 42 | (:constructor make-repl-input (string))) 43 | 44 | (defmethod present ((i Repl-Input)) 45 | (DIV (:class "lisp-repl-input") 46 | (.string i))) 47 | 48 | (defclass Repl-Error () 49 | (string) 50 | (:constructor make-repl-error (string))) 51 | 52 | (defmethod present ((e Repl-Error)) 53 | (DIV (:class "lisp-repl-error") 54 | (present (.string e)))) 55 | 56 | (defun print (string) 57 | (appendChild (getElementById *document* "lisp_output") 58 | (DIV (:class "lisp-repl-output") (present string)))) 59 | 60 | (defun repl-submit () 61 | ($js-try (lambda (exception) 62 | (js-call (js-global "console") "log" exception) 63 | (print "ERROR") (print exception) #f) 64 | (progn 65 | (defvar input (get-slot (getElementById *document* "lisp_line") "value")) 66 | (print (make-repl-input input)) 67 | (map (lambda (form) 68 | (print (eval form *top-level-environment*))) 69 | (read-from-string input)) 70 | (scrollTo *window* 0 (get-slot *body* "scrollHeight")) 71 | (set-slot! (getElementById *document* "lisp_line") "value" "") 72 | #f))) 73 | 74 | (defun print-stack-trace (f) 75 | ;; extreme hack: skip first 6 frames 76 | (def off 6) 77 | (while (> off 0) (set! f (get-slot f "parent")) (dec! off)) 78 | ;; only show fixed number of frames 79 | (def frames 10) 80 | (until (or? (= #void f) (= frames 0)) 81 | (print f) 82 | (set! f (get-slot f "parent")) 83 | (dec! frames))) 84 | 85 | (set! (js-global "lisp_repl_onsubmit") (js-function repl-submit)) 86 | 87 | (appendChild *body* 88 | (DIV () 89 | (DIV (:id "lisp_output")) 90 | (FORM (:id "lisp_input" :onsubmit "return lisp_repl_onsubmit()") 91 | (INPUT (:type "text" :id "lisp_line" :name "line"))))) 92 | 93 | (repl-note "Welcome to Virtua!") 94 | (focus (getElementById *document* "lisp_line")) 95 | 96 | (set! (js-global "lisp_simple_error") 97 | (js-function (lambda (msg) 98 | (print-stack-trace (stack-frame)) 99 | (js-throw msg)))) 100 | -------------------------------------------------------------------------------- /standard.virtua: -------------------------------------------------------------------------------- 1 | ;; Virtua standard language. -*- Lisp -*- 2 | ;; Copyright (c) 2012 Manuel Simoni. See license at end of file. 3 | 4 | ($define! def $define!) 5 | (def defvar def) 6 | (def begin $begin) 7 | (def progn $begin) 8 | (def if $if) 9 | (def vau $vau) 10 | (def loop $loop) 11 | 12 | ;;;; These are adapted from John Shutt's SINK and the R-1RK. 13 | 14 | (def list (wrap (vau x #ignore x))) 15 | 16 | (def list* 17 | (wrap (vau args #ignore 18 | (begin 19 | (def aux 20 | (wrap (vau ((head . tail)) #ignore 21 | (if (null? tail) 22 | head 23 | (cons head (aux tail)))))) 24 | (aux args))))) 25 | 26 | (def vau 27 | ((wrap (vau (vau) #ignore 28 | (vau (formals eformal . body) env 29 | (eval (list vau formals eformal 30 | (cons begin body)) 31 | env)))) 32 | vau)) 33 | 34 | (def lambda 35 | (vau (formals . body) env 36 | (wrap (eval (list* vau formals #ignore body) 37 | env)))) 38 | 39 | (def set-debug-name! 40 | (lambda (obj name) (set-slot! obj "lisp_debug_name" name))) 41 | (def debug-name 42 | (lambda (obj) (if (has-slot? obj "lisp_debug_name") 43 | (get-slot obj "lisp_debug_name") 44 | "anon"))) 45 | 46 | (def defun 47 | (vau (name args . body) env 48 | (def fun (eval (list* lambda args body) env)) 49 | (set-debug-name! fun (symbol-name name)) 50 | (eval (list def name fun) env))) 51 | 52 | (def defmacro 53 | (vau (name args e . body) env 54 | (def fun (eval (list* vau args e body) env)) 55 | (set-debug-name! fun (symbol-name name)) 56 | (eval (list def name fun) env))) 57 | 58 | (def caar (lambda (((x . #ignore) . #ignore)) x)) 59 | (def cdar (lambda (((#ignore . x) . #ignore)) x)) 60 | (def cadr (lambda ((#ignore . (x . #ignore))) x)) 61 | (def cddr (lambda ((#ignore . (#ignore . x))) x)) 62 | 63 | (defun apply (appv arg . opt) 64 | (eval (cons (unwrap appv) arg) 65 | (if (null? opt) 66 | (make-environment) 67 | (car opt)))) 68 | 69 | (defmacro or? (a b) env 70 | (if (eval a env) 71 | #t 72 | (if (eval b env) 73 | #t 74 | #f))) 75 | 76 | (defmacro and? (a b) env 77 | (if (eval a env) 78 | (if (eval b env) 79 | #t 80 | #f) 81 | #f)) 82 | 83 | (defun map (fn list) 84 | (if (null? list) 85 | () 86 | (cons (fn (car list)) 87 | (map fn (cdr list))))) 88 | 89 | (defmacro let (bindings . body) env 90 | (eval (cons (list* lambda (map car bindings) body) 91 | (map cadr bindings)) 92 | env)) 93 | 94 | (defmacro let* (bindings . body) env 95 | (eval (if (null? bindings) 96 | (list* let bindings body) 97 | (list let 98 | (list (car bindings)) 99 | (list* let* (cdr bindings) body))) 100 | env)) 101 | 102 | (defmacro cond clauses env 103 | (def aux (lambda ((test . body) . clauses) 104 | (if (eval test env) 105 | (apply (wrap begin) body env) 106 | (apply (wrap cond) clauses env)))) 107 | (if (null? clauses) 108 | #void 109 | (apply aux clauses))) 110 | 111 | (defun not? (x) (if x #f #t)) 112 | 113 | (defmacro when (test . body) env 114 | (eval (list if test (list* begin body) #void) env)) 115 | 116 | (defmacro unless (test . body) env 117 | (eval (list if test #void (list* begin body)) env)) 118 | 119 | (defmacro while (condition . body) env 120 | (def wrapped-body (list* begin body)) 121 | (block done 122 | (loop 123 | (if (eval condition env) 124 | (eval wrapped-body env) 125 | (return-from done #void))))) 126 | 127 | (defmacro until (condition . body) env 128 | (eval (list* while (list not? condition) body) env)) 129 | 130 | (def get-current-environment (wrap (vau () e e))) 131 | 132 | (def *top-level-environment* (get-current-environment)) 133 | 134 | (defmacro provide (symbols . body) env 135 | (eval (list def symbols 136 | (list let () 137 | (list* begin body) 138 | (list* list symbols))) 139 | env)) 140 | 141 | ;;;; Virtua-specific forms 142 | 143 | (defun pair? (obj) (instance? obj Pair)) 144 | (defun symbol? (obj) (instance? obj Symbol)) 145 | 146 | (def type-assertions 147 | (lambda (args) 148 | (if (pair? args) 149 | (let ((arg (car args))) 150 | (if (pair? arg) 151 | (cons (list assert (list instance? (car arg) (cadr arg))) 152 | (type-assertions (cdr args))) 153 | (type-assertions (cdr args)))) 154 | ()))) 155 | 156 | (def untype 157 | (lambda (args) 158 | (if (pair? args) 159 | (let ((arg (car args))) 160 | (cons (if (pair? arg) (car arg) arg) 161 | (untype (cdr args)))) 162 | args))) 163 | 164 | (defmacro typed-lambda (args . body) env 165 | (eval (list* lambda (untype args) (list* begin (type-assertions args)) body) env)) 166 | 167 | (def defun 168 | (vau (name args . body) env 169 | (def fun (eval (list* typed-lambda args body) env)) 170 | (set-debug-name! fun (symbol-name name)) 171 | (eval (list def name fun) env))) 172 | 173 | (defun to-string (obj) (anything-to-string obj)) ;; later redefined as generic 174 | 175 | (defmacro assert (that) env 176 | (if (not? (eval that env)) 177 | (js-throw (to-string that)) 178 | #void)) 179 | 180 | (def Block-Escape (make-class () "Block-Escape")) 181 | (defun make-block-escape () (make-instance Block-Escape)) 182 | 183 | (defmacro block (name . body) env 184 | (let ((tag (make-block-escape)) (val #void)) 185 | ($js-try (lambda (exc) (if (eq? tag exc) val (js-throw exc))) 186 | (apply (eval (list* lambda name body) env) 187 | (lambda (the-val) (set! val the-val) (js-throw tag)))))) 188 | 189 | (defun return-from ((exit Combiner) . val) 190 | (exit (if (null? val) #void (car val)))) 191 | 192 | (defmacro unwind-protect (protected . cleanup) env 193 | (eval (list $unwind-protect protected (list* begin cleanup)) env)) 194 | 195 | (defmacro scope body env 196 | (eval (list* let () body) env)) 197 | 198 | (defmacro set! (place value) env 199 | (if (instance? place Pair) 200 | (let (((cmb . args) place)) 201 | (eval (list* (setter (eval cmb env)) value args) env)) 202 | (eval (list $set! place value) env))) 203 | 204 | (defmacro op! (place op) env 205 | (eval (list set! place (list op place)) env)) 206 | 207 | (defmacro fluid-let ((name value) . body) env 208 | (let ((saved-value (eval name env))) 209 | (eval (list set! name value) env) 210 | (unwind-protect (eval (list* begin body) env) 211 | (eval (list set! name saved-value) env)))) 212 | 213 | (defun setter (obj) (get-slot obj "setter")) 214 | (defun set-setter! (obj setter) (set-slot! obj "setter" setter)) 215 | (set-setter! js-global (lambda (val name) (set-js-global! name val))) ; erm 216 | 217 | (defun define-js-method ((name String)) 218 | (defun js-method (rcv . args) 219 | (apply js-call (list* rcv name args))) 220 | (eval (list def (intern name) js-method) *top-level-environment*)) 221 | 222 | (defun define-js-methods names 223 | (map define-js-method names)) 224 | 225 | (define-js-methods 226 | "charAt" 227 | "concat" 228 | "slice" 229 | ) 230 | 231 | (defun strcat strings 232 | (apply concat (list* "" strings))) 233 | (def strelt charAt) 234 | (def strslice slice) 235 | 236 | ;;;; Object System 237 | 238 | (provide (defclass 239 | definterface 240 | defimplementation 241 | defgeneric 242 | defmethod) 243 | 244 | (defmacro defclass (name . stuff) env 245 | (if (null? stuff) 246 | (eval (list def name (make-class () (symbol-name name))) env) 247 | (let (((superclasses . stuff) stuff)) 248 | (let ((c (make-class (map (lambda (sc) (eval sc env)) superclasses) 249 | (symbol-name name)))) 250 | (eval (list def name c) env) 251 | (unless (null? stuff) 252 | (let (((slots . stuff) stuff)) 253 | (map (lambda (slot) (eval (list defslot slot) env)) slots) 254 | (unless (null? stuff) 255 | (let (((#ignore ctor-name args) (car stuff))) 256 | (eval (list defconstructor ctor-name name args) env)))))))) 257 | name) 258 | 259 | (defmacro definterface (name . supers) env 260 | (eval (list* defclass name supers) env)) 261 | 262 | (def defimplementation add-superclass!) 263 | 264 | (defmacro defconstructor (name class slots) env 265 | (eval (list def name 266 | (list typed-lambda slots 267 | (list construct-with-slots class (untype slots)))) 268 | env)) 269 | 270 | (defmacro construct-with-slots (class slots) env 271 | (let ((obj (make-instance (eval class env)))) 272 | (map (lambda (slot) 273 | (set-slot! obj (symbol-name slot) (eval slot env))) 274 | slots) 275 | obj)) 276 | 277 | (defmacro defslot (name) env 278 | (let* ((slot (symbol-name name)) 279 | (generic-name (intern (strcat "." slot))) 280 | (reader (lambda (obj) (get-slot obj slot))) 281 | (writer (lambda (val obj) (set-slot! obj slot val)))) 282 | (set-setter! reader writer) 283 | (eval (list def generic-name reader) env)) 284 | name) 285 | 286 | (defmacro defgeneric (name ignored-args . methods) env 287 | (eval (list def name 288 | (lambda (self . otree) (send self (symbol-name name) otree))) 289 | env) 290 | (map (lambda (m) 291 | (let (((#ignore args . body) m)) 292 | (eval (list* defmethod name args body) env))) 293 | methods) 294 | name) 295 | 296 | (defmacro defmethod (name (rcv-n-class . rest) . body) env 297 | (def rcv (if (pair? rcv-n-class) (car rcv-n-class) rcv-n-class)) 298 | (def class (if (pair? rcv-n-class) (cadr rcv-n-class) Object)) 299 | (put-method! (eval class env) 300 | (symbol-name name) 301 | (eval (list* vau (list* rcv (untype rest)) #ignore 302 | (list* begin (type-assertions rest)) 303 | body) 304 | env)) 305 | name) 306 | 307 | ) 308 | 309 | ;;;; Options 310 | 311 | (defclass Option) 312 | (defclass Nothing (Option)) 313 | (defvar nothing (make-instance Nothing)) 314 | (defclass Just (Option) 315 | (value) 316 | (:constructor just (value))) 317 | 318 | (defmacro if-option ((name option) then . else) env 319 | (let ((o (eval option env))) 320 | (if (instance? o Just) 321 | (eval (list let (list (list name (.value o))) then) env) 322 | (unless (null? else) 323 | (eval (car else) env))))) 324 | 325 | (defmacro when-option (name-and-option . then) env 326 | (eval (list if-option name-and-option (list* begin then) #void) env)) 327 | 328 | (defun find-if ((pred Combiner) list) 329 | (if (null? list) 330 | nothing 331 | (let ((kar (car list))) 332 | (if (pred kar) 333 | (just kar) 334 | (find-if pred (cdr list)))))) 335 | 336 | ;;;; Condition System 337 | 338 | (provide (Condition 339 | Error 340 | Warning 341 | Restart 342 | Simple-Error 343 | catch 344 | handle 345 | throw 346 | signal 347 | default-handler) 348 | 349 | (defclass Condition) 350 | (defclass Error (Condition)) 351 | (defclass Warning (Condition)) 352 | (defclass Restart (Condition)) 353 | 354 | (defclass Simple-Error (Error) 355 | (message) 356 | (:constructor make-simple-error ((message String)))) 357 | 358 | (defvar *handlers-frame-option* nothing) 359 | 360 | (defclass Handlers-Frame () 361 | (parent-option 362 | handlers-list) 363 | (:constructor make-handlers-frame ((parent-option Option) 364 | handlers-list))) 365 | 366 | (defclass Handler () 367 | (matcher-function 368 | handler-function) 369 | (:constructor make-handler ((matcher-function Combiner) 370 | (handler-function Combiner)))) 371 | 372 | (defun handler-matches-condition? ((handler Handler) (condition Condition)) 373 | ((.matcher-function handler) condition)) 374 | 375 | (defun call-with-handlers ((thunk Combiner) handlers-list) 376 | (fluid-let (*handlers-frame-option* 377 | (just (make-handlers-frame *handlers-frame-option* handlers-list))) 378 | (thunk))) 379 | 380 | (defgeneric signal-internal (condition) 381 | 382 | (:method ((condition Condition)) 383 | (defun signal-frame ((frame-option Option)) 384 | (if-option (frame frame-option) 385 | (progn 386 | (when-option (handler (find-if (lambda (h) 387 | (handler-matches-condition? h condition)) 388 | (.handlers-list frame))) 389 | ((.handler-function handler) condition)) 390 | (signal-frame (.parent-option frame))) 391 | (default-handler condition))) 392 | (signal-frame *handlers-frame-option*)) 393 | 394 | (:method ((message String)) 395 | (signal-internal (make-simple-error message)))) 396 | 397 | (defun throw-internal (x) 398 | (signal-internal x) 399 | (invoke-debugger x)) 400 | 401 | (defgeneric default-handler (condition) 402 | (:method ((c Condition)) 403 | #void) 404 | (:method ((w Warning)) 405 | (print w)) 406 | (:method ((e Error)) 407 | (invoke-debugger e)) 408 | (:method ((r Restart)) 409 | (invoke-debugger "unhandled restart"))) 410 | 411 | (defun invoke-debugger (x) (js-throw x)) 412 | 413 | ;; handler ::= ((Class var) . exprs) 414 | (defmacro handle (expr . handlers) env 415 | (call-with-handlers (lambda () (eval expr env)) 416 | (map (lambda (h) 417 | (let ((((c v . ac) . exprs) h)) 418 | (make-handler (lambda (condition) 419 | (instance? condition (eval c env))) 420 | (eval (list* lambda (list v) exprs) env)))) 421 | handlers))) 422 | 423 | (defmacro catch (expr . handlers) env 424 | (block normal-return 425 | ((block error-return ; note extra evaluation 426 | (eval (list* handle (list return-from normal-return expr) 427 | (map (lambda (h) 428 | (let (((cv . exprs) h)) 429 | (list cv (list return-from error-return 430 | (list* lambda () exprs))))) 431 | handlers)) 432 | env))))) 433 | 434 | (defmacro signal-with-restarts (raiser condition . restarts) env 435 | (eval (list* catch (list raiser condition) restarts) env)) 436 | 437 | (defmacro throw condition-and-restarts env 438 | (apply (wrap signal-with-restarts) (list* throw-internal condition-and-restarts) env)) 439 | 440 | (defmacro signal condition-and-restarts env 441 | (apply (wrap signal-with-restarts) (list* signal-internal condition-and-restarts) env)) 442 | 443 | ) ; conditions 444 | 445 | (defgeneric = (a b) 446 | (:method ((a Object) b) (eq? a b))) 447 | 448 | (defgeneric to-string (obj) 449 | (:method ((a Object)) 450 | (strcat "#[object " (anything-to-string a) "]")) 451 | (:method ((a Number)) 452 | (anything-to-string a)) 453 | (:method ((a String)) 454 | (anything-to-string a)) 455 | (:method ((a Symbol)) 456 | (symbol-name a)) 457 | (:method ((a Class)) 458 | (strcat "#[class " (debug-name a) "]")) 459 | (:method ((a Nil)) 460 | "()") 461 | (:method ((a Boolean)) 462 | (if a "#t" "#f")) 463 | (:method ((a Ignore)) 464 | "#ignore") 465 | (:method ((a Void)) 466 | "#void") 467 | (:method ((a Undefined)) 468 | "#undefined") 469 | (:method ((a Combiner)) 470 | (strcat "#[" (debug-name a) "]")) 471 | (:method ((cmb Compound-Combiner)) 472 | (strcat "#[" (debug-name cmb) " " (to-string (get-slot cmb "lisp_ptree")) "]")) 473 | (:method ((cmb Wrapper)) 474 | (strcat "#[" (debug-name cmb) " " (to-string (unwrap cmb)) "]")) 475 | (:method ((a Environment)) 476 | "#[environment]") 477 | (:method ((p Pair)) 478 | (defun pair-to-string (p) 479 | (def kar (car p)) 480 | (def kdr (cdr p)) 481 | (if (null? kdr) 482 | (to-string kar) 483 | (if (instance? kdr Pair) 484 | (strcat (to-string kar) " " (pair-to-string kdr)) 485 | (strcat (to-string kar) " . " (to-string kdr))))) 486 | (strcat "(" (pair-to-string p) ")")) 487 | (:method ((frm Stack-Frame)) 488 | (strcat (to-string (get-slot frm "cmb")) " " 489 | (to-string (get-slot frm "otree")))) 490 | ) 491 | 492 | ;;;; Numbers 493 | 494 | (provide (+ - * / %) 495 | (defmacro define-js-number-binop (name) env 496 | (def a (intern "a")) 497 | (def b (intern "b")) 498 | (def binop (js-binop name)) 499 | (eval (list def (intern name) 500 | (list typed-lambda (list (list a Number) (list b Number)) 501 | (list binop a b))) 502 | env)) 503 | (define-js-number-binop "+") 504 | (define-js-number-binop "-") 505 | (define-js-number-binop "*") 506 | (define-js-number-binop "/") 507 | (define-js-number-binop "%") 508 | ) 509 | 510 | (defmacro inc! (var . delta) env 511 | (eval (list set! var (list + var (if (pair? delta) (car delta) 1))) env)) 512 | 513 | (defmacro dec! (var . delta) env 514 | (eval (list set! var (list - var (if (pair? delta) (car delta) 1))) env)) 515 | 516 | (defun even? ((n Number)) (= 0 (% n 2))) 517 | (defun odd? ((n Number)) (not? (even? n))) 518 | 519 | ;;;; Comparison 520 | 521 | (def number< (js-binop "<")) 522 | 523 | (defgeneric < (a b) 524 | (:method ((a Number) (b Number)) 525 | (number< a b))) 526 | 527 | (defgeneric > (a b) 528 | (:method ((a Number) (b Number)) 529 | (number< b a))) 530 | 531 | (defgeneric <= (a b) 532 | (:method (a b) 533 | (or? (= a b) 534 | (< a b)))) 535 | 536 | (defgeneric >= (a b) 537 | (:method (a b) 538 | (or? (= a b) 539 | (> a b)))) 540 | 541 | ;;;; Property Lists 542 | 543 | ;; Calls fun with name and value of each property in plist. 544 | (defun map-plist (fun plist) 545 | (if (null? plist) 546 | () 547 | (cons (fun (car plist) (cadr plist)) 548 | (map-plist fun (cddr plist))))) 549 | 550 | ;;;; Collections 551 | 552 | (provide (Iterable 553 | Iterator 554 | iterator 555 | has-next? 556 | next! 557 | at) 558 | 559 | (defclass Iterable) 560 | (defclass Iterator) 561 | (defgeneric iterator (iterable)) 562 | (defgeneric has-next? (iterator)) 563 | (defgeneric next! (iterator)) 564 | (defgeneric at (iterable index)) 565 | 566 | (defmethod at ((s String) (i Number)) 567 | (strelt s i)) 568 | 569 | ) 570 | 571 | ;; Permission is hereby granted, free of charge, to any person 572 | ;; obtaining a copy of this software and associated documentation 573 | ;; files (the "Software"), to deal in the Software without 574 | ;; restriction, including without limitation the rights to use, copy, 575 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 576 | ;; of the Software, and to permit persons to whom the Software is 577 | ;; furnished to do so, subject to the following conditions: 578 | ;; 579 | ;; The above copyright notice and this permission notice shall be 580 | ;; included in all copies or substantial portions of the Software. 581 | ;; 582 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 583 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 584 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 585 | ;; NONINFRINGEMENT. ALSO, THERE IS NO KERNEL UNDERGROUND; IT'S ALL 586 | ;; JUST RUMOUR AND HEARSAY. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 587 | ;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 588 | ;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 589 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 590 | ;; DEALINGS IN THE SOFTWARE. 591 | -------------------------------------------------------------------------------- /test.js: -------------------------------------------------------------------------------- 1 | // Test suite for Virtua interpreter. 2 | // Copyright (c) 2012 Manuel Simoni. See license at end of file. 3 | 4 | (function() { 5 | 6 | lisp_assert(lisp_is_instance(Lisp_Object, Lisp_Class)); 7 | lisp_assert(lisp_is_instance(Lisp_Class, Lisp_Class)); 8 | lisp_assert(lisp_is_instance(Lisp_String, Lisp_Class)); 9 | lisp_assert(lisp_is_instance(Lisp_Symbol, Lisp_Class)); 10 | lisp_assert(lisp_is_instance(Lisp_Env, Lisp_Class)); 11 | lisp_assert(lisp_is_instance(Lisp_Pair, Lisp_Class)); 12 | lisp_assert(lisp_is_instance(Lisp_Boolean, Lisp_Class)); 13 | lisp_assert(lisp_is_instance(Lisp_Nil, Lisp_Class)); 14 | lisp_assert(lisp_is_instance(Lisp_Ignore, Lisp_Class)); 15 | lisp_assert(lisp_is_instance(Lisp_Void, Lisp_Class)); 16 | 17 | var string_foo = "foo"; 18 | lisp_assert(lisp_is_instance(string_foo, Lisp_String)); 19 | lisp_assert(!lisp_is_instance(string_foo, Lisp_Symbol)); 20 | lisp_assert(!lisp_is_instance(string_foo, Lisp_Class)); 21 | lisp_assert(lisp_is_instance(string_foo, Lisp_Object)); 22 | lisp_assert(!lisp_is_instance(string_foo, Lisp_Class)); 23 | lisp_assert(lisp_eval(string_foo) === string_foo); 24 | 25 | var symbol_foo = lisp_intern("foo"); 26 | lisp_assert(lisp_is_instance(symbol_foo, Lisp_Symbol)); 27 | lisp_assert(!lisp_is_instance(symbol_foo, Lisp_String)); 28 | lisp_assert(!lisp_is_instance(symbol_foo, Lisp_Class)); 29 | lisp_assert(lisp_is_instance(symbol_foo, Lisp_Object)); 30 | lisp_assert(symbol_foo === lisp_intern("foo")); 31 | lisp_assert(symbol_foo !== lisp_intern("bar")); 32 | lisp_assert(lisp_symbol_name(symbol_foo) === "foo"); 33 | 34 | var cons = lisp_cons(string_foo, symbol_foo); 35 | lisp_assert(lisp_is_instance(cons, Lisp_Pair)); 36 | lisp_assert(!lisp_is_instance(cons, Lisp_String)); 37 | lisp_assert(!lisp_is_instance(cons, Lisp_Class)); 38 | lisp_assert(lisp_is_instance(cons, Lisp_Object)); 39 | lisp_assert(lisp_car(cons) === string_foo); 40 | lisp_assert(lisp_cdr(cons) === symbol_foo); 41 | 42 | var env = lisp_make_env(null); 43 | lisp_assert(lisp_env_put(env, symbol_foo, string_foo) === string_foo); 44 | lisp_assert(lisp_env_lookup(env, symbol_foo) === string_foo); 45 | var child_env = lisp_make_env(env); 46 | lisp_assert(lisp_env_lookup(child_env, symbol_foo) === string_foo); 47 | var string_bar = "bar"; 48 | lisp_env_put(child_env, symbol_foo, string_bar); 49 | lisp_assert(lisp_env_lookup(child_env, symbol_foo) === string_bar); 50 | lisp_assert(lisp_env_lookup(env, symbol_foo) === string_foo); 51 | 52 | lisp_assert(lisp_eval(symbol_foo, env) === string_foo); 53 | lisp_assert(lisp_eval(symbol_foo, child_env) === string_bar); 54 | 55 | lisp_assert(lisp_is_instance(lisp_nil, Lisp_Nil)); 56 | lisp_assert(lisp_is_instance(lisp_nil, Lisp_Object)); 57 | lisp_assert(lisp_is_instance(lisp_ignore, Lisp_Ignore)); 58 | lisp_assert(lisp_is_instance(lisp_ignore, Lisp_Object)); 59 | lisp_assert(lisp_is_instance(lisp_void, Lisp_Void)); 60 | lisp_assert(lisp_is_instance(lisp_void, Lisp_Object)); 61 | 62 | }()); 63 | 64 | 65 | // Permission is hereby granted, free of charge, to any person 66 | // obtaining a copy of this software and associated documentation 67 | // files (the "Software"), to deal in the Software without 68 | // restriction, including without limitation the rights to use, copy, 69 | // modify, merge, publish, distribute, sublicense, and/or sell copies 70 | // of the Software, and to permit persons to whom the Software is 71 | // furnished to do so, subject to the following conditions: 72 | // 73 | // The above copyright notice and this permission notice shall be 74 | // included in all copies or substantial portions of the Software. 75 | // 76 | // THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 77 | // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 78 | // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 79 | // NONINFRINGEMENT. ALSO, THERE IS NO KERNEL UNDERGROUND; IT'S ALL 80 | // JUST RUMOUR AND HEARSAY. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 81 | // HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 82 | // WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 83 | // OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 84 | // DEALINGS IN THE SOFTWARE. 85 | -------------------------------------------------------------------------------- /test.virtua: -------------------------------------------------------------------------------- 1 | ;; Test suite for Virtua kernel language. -*- Lisp -*- 2 | ;; Copyright (c) 2012 Manuel Simoni. See license at end of file. 3 | 4 | ;;;; scope 5 | (assert (= 1 (scope 6 | (def x 1) 7 | (assert (= x 1)) 8 | (scope 9 | (assert (= x 1)) 10 | (def x 2) 11 | (assert (= x 2))) 12 | (assert (= x 1)) 13 | x))) 14 | 15 | ;;;; vau 16 | (assert (eq? ((vau #ignore env env)) 17 | (get-current-environment))) 18 | 19 | ;;;; Equality 20 | 21 | (assert (= #t #t)) 22 | (assert (= #f #f)) 23 | (assert (= 1 1)) 24 | (assert (= -1 -1)) 25 | (assert (= 1.444 1.444)) 26 | (assert (not? (= 1 1.444))) 27 | (assert (= "foo" "foo")) 28 | (assert (= "" "")) 29 | (assert (not? (= "foo" "bar"))) 30 | (assert (not? (= "foo" #t))) 31 | (assert (not? (= #t "foo"))) 32 | (assert (not? (= "foo" 12))) 33 | (assert (not? (= 12 "foo"))) 34 | (assert (not? (= (cons 1 2) 12))) 35 | (assert (not? (= 12 (cons 1 2)))) 36 | 37 | ;;;; Arrays 38 | 39 | (assert (instance? (js-array) Array)) 40 | 41 | ;;;; Binops 42 | 43 | (scope 44 | (def + (js-binop "+")) 45 | (def - (js-binop "-")) 46 | (def * (js-binop "*")) 47 | (def / (js-binop "/")) 48 | (assert (= 3 (+ 1 2))) 49 | (assert (= 1 (- 2 1))) 50 | (assert (= 42 (* 6 7))) 51 | (assert (= 3 (/ 9 3)))) 52 | 53 | ;;;; Printing 54 | 55 | (assert (= "#t" (to-string #t))) 56 | (assert (= "#f" (to-string #f))) 57 | (assert (= "()" (to-string ()))) 58 | (assert (= "1" (to-string 1))) 59 | (assert (= "1.22" (to-string 1.22))) 60 | 61 | (assert (instance? 19222222222222222222222222222222222222222222222222222 Number)) 62 | (assert (instance? -19222222222222222222222222222222222222222222222222222 Number)) 63 | (assert (instance? -19222222222222222222222222222222222222222222222222222.5 Number)) 64 | (assert (instance? 19222222222222222222222222222222222222222222222222222.3 Number)) 65 | (assert (instance? "foo" String)) 66 | (assert (instance? "" String)) 67 | 68 | (assert (eq? #t #t)) 69 | (assert (eq? #f #f)) 70 | (assert (eq? () ())) 71 | (assert (eq? #ignore #ignore)) 72 | (assert (eq? #void #void)) 73 | 74 | ;;;; Numbers 75 | 76 | (assert (even? 0)) 77 | (assert (even? -100)) 78 | (assert (even? 100)) 79 | (assert (not? (even? 3))) 80 | (assert (not? (even? -3))) 81 | (assert (odd? 101)) 82 | (assert (odd? -101)) 83 | 84 | ;;;; Object System 85 | 86 | (assert (instance? Object Class)) 87 | (assert (instance? Class Class)) 88 | 89 | (scope 90 | (defclass C) 91 | (def obj (make-instance C)) 92 | (assert (instance? obj C)) 93 | (assert (instance? obj User-Object)) 94 | (assert (instance? obj Object)) 95 | (assert (not? (instance? obj String)))) 96 | 97 | (scope 98 | (defclass A) 99 | (defclass B) 100 | (defclass C (A B)) 101 | (assert (subclass? A Object)) 102 | (assert (subclass? C A)) 103 | (assert (subclass? C B)) 104 | (assert (not? (subclass? A B))) 105 | (assert (not? (subclass? A C))) 106 | (assert (not? (subclass? B A))) 107 | (assert (not? (subclass? B C)))) 108 | 109 | (scope 110 | (defclass X) 111 | (defclass Y) 112 | (defclass Z (Y)) 113 | (defgeneric say (obj)) 114 | (defmethod say ((self X)) "x") 115 | (defmethod say ((self Y)) "y") 116 | (assert (= (say (make-instance X)) "x")) 117 | (assert (= (say (make-instance Y)) "y")) 118 | (assert (= (say (make-instance Z)) "y"))) 119 | 120 | (scope 121 | (definterface Foo) 122 | (defclass Bar) 123 | (defimplementation Bar Foo) 124 | (assert (subclass? Bar Foo))) 125 | 126 | (scope 127 | (definterface A) 128 | (definterface B (A)) 129 | (defclass C) 130 | (defimplementation C B) 131 | (assert (subclass? C B)) 132 | (assert (subclass? C A))) 133 | 134 | (scope 135 | (defclass Foo () 136 | (the-slot) 137 | (:constructor make-foo (the-slot))) 138 | (def the-foo (make-foo 12)) 139 | (assert (= (.the-slot the-foo) 12)) 140 | (set! (.the-slot the-foo) 13) 141 | (assert (= (.the-slot the-foo) 13))) 142 | 143 | (scope 144 | (defclass Point () 145 | (x y) 146 | (:constructor make-point (x y))) 147 | (def pt (make-point 12 24)) 148 | (assert (instance? pt Point)) 149 | (assert (instance? pt Object)) 150 | (assert (= 12 (.x pt))) 151 | (assert (= 24 (.y pt))) 152 | (set! (.x pt) 100) 153 | (assert (= 100 (.x pt))) 154 | (assert (= 24 (.y pt))) 155 | (set! (.y pt) 200) 156 | (assert (= 100 (.x pt))) 157 | (assert (= 200 (.y pt)))) 158 | 159 | ;;;; Control Flow 160 | 161 | (assert (= 12 ($js-try #void 12))) 162 | (assert (= "error" ($js-try (lambda (e) e) (js-throw "error")))) 163 | 164 | (assert (= 12 (block x 12))) 165 | (assert (= 12 (block x 1 2 3 12))) 166 | (assert (= 13 (block x (return-from x 13) 12))) 167 | 168 | (assert (= 1 (unwind-protect 1))) 169 | (assert (= 1 (unwind-protect 1 2))) 170 | (assert (= 1 (unwind-protect 1 2 3))) 171 | (assert (= 1 (block x (unwind-protect (return-from x 1) 2 3)))) 172 | (assert (= 3 (block x (unwind-protect 1 2 (return-from x 3))))) 173 | (assert (= 3 (block x (unwind-protect (return-from x 1) 2 (return-from x 3))))) 174 | 175 | ;;;; Misc 176 | 177 | (assert (= "foobar" (strcat "foo" "bar"))) 178 | 179 | (scope 180 | (def x 1) 181 | (fluid-let (x 2) 182 | (assert (= x 2))) 183 | (assert (= x 1)) 184 | (block exit 185 | (fluid-let (x 3) 186 | (assert (= x 3)) 187 | (return-from exit))) 188 | (assert (= x 1))) 189 | 190 | ;;;; Options 191 | 192 | (assert (= 12 (if-option (name (just 12)) name 13))) 193 | (assert (= 13 (if-option (name nothing) name 13))) 194 | (assert (= #void (if-option (name nothing) name))) 195 | (assert (= 12 (when-option (name (just 12)) 1 2 3 name))) 196 | (assert (= #void (when-option (name nothing) name 13))) 197 | (assert (= #void (when-option (name nothing) name))) 198 | 199 | (assert (= nothing (find-if (lambda (elt) (= elt 1)) (list 2 3 4 5)))) 200 | (assert (= #t (if-option (elt (find-if (lambda (elt) (= elt 4)) (list 2 3 4 5))) 201 | (begin (assert (= elt 4)) #t) 202 | #f))) 203 | 204 | ;;;; Conditions 205 | 206 | (assert (= (handle (throw "foo" ((Restart r) 12)) 207 | ((Simple-Error e) (throw (make-instance Restart)))) 208 | 12)) 209 | 210 | ;; Permission is hereby granted, free of charge, to any person 211 | ;; obtaining a copy of this software and associated documentation 212 | ;; files (the "Software"), to deal in the Software without 213 | ;; restriction, including without limitation the rights to use, copy, 214 | ;; modify, merge, publish, distribute, sublicense, and/or sell copies 215 | ;; of the Software, and to permit persons to whom the Software is 216 | ;; furnished to do so, subject to the following conditions: 217 | ;; 218 | ;; The above copyright notice and this permission notice shall be 219 | ;; included in all copies or substantial portions of the Software. 220 | ;; 221 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 222 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 223 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 224 | ;; NONINFRINGEMENT. ALSO, THERE IS NO KERNEL UNDERGROUND; IT'S ALL 225 | ;; JUST RUMOUR AND HEARSAY. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 226 | ;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 227 | ;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 228 | ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 229 | ;; DEALINGS IN THE SOFTWARE. 230 | -------------------------------------------------------------------------------- /virtua.js: -------------------------------------------------------------------------------- 1 | // Virtua interpreter. 2 | // Copyright (c) 2012 Manuel Simoni. See license at end of file. 3 | 4 | /**** Kernel Environment ****/ 5 | 6 | function lisp_make_kernel_env() { 7 | var env = lisp_make_env(null); 8 | /* Basics */ 9 | lisp_export(env, "$vau", lisp_make_instance(Lisp_Vau)); 10 | lisp_export(env, "$begin", lisp_make_instance(Lisp_Begin)); 11 | lisp_export(env, "$define!", lisp_make_instance(Lisp_Define)); 12 | lisp_export(env, "$set!", lisp_make_instance(Lisp_Set)); 13 | lisp_export(env, "$if", lisp_make_instance(Lisp_If)); 14 | lisp_export(env, "$loop", lisp_make_instance(Lisp_Loop)); 15 | lisp_export(env, "$unwind-protect", lisp_make_instance(Lisp_Unwind_Protect)); 16 | lisp_export(env, "$js-try", lisp_make_instance(Lisp_JS_Try)); 17 | lisp_export(env, "js-throw", lisp_make_wrapped_native(lisp_lib_throw, 1, 1)); 18 | lisp_export(env, "eq?", lisp_make_wrapped_native(lisp_lib_eq, 2, 2)); 19 | lisp_export(env, "make-environment", lisp_make_wrapped_native(lisp_lib_make_env, 0, 1)); 20 | lisp_export(env, "eval", lisp_make_wrapped_native(lisp_eval, 2, 2)); 21 | lisp_export(env, "wrap", lisp_make_wrapped_native(lisp_wrap, 1, 1)); 22 | lisp_export(env, "unwrap", lisp_make_wrapped_native(lisp_unwrap, 1, 1)); 23 | lisp_export(env, "cons", lisp_make_wrapped_native(lisp_cons, 2, 2)); 24 | lisp_export(env, "car", lisp_make_wrapped_native(lisp_car, 1, 1)); 25 | lisp_export(env, "cdr", lisp_make_wrapped_native(lisp_cdr, 1, 1)); 26 | lisp_export(env, "null?", lisp_make_wrapped_native(lisp_lib_null, 1, 1)); 27 | lisp_export(env, "intern", lisp_make_wrapped_native(lisp_intern, 1, 1)); 28 | lisp_export(env, "symbol-name", lisp_make_wrapped_native(lisp_symbol_name, 1, 1)); 29 | lisp_export(env, "#t", lisp_t); 30 | lisp_export(env, "#f", lisp_f); 31 | lisp_export(env, "#ignore", lisp_ignore); 32 | lisp_export(env, "#void", lisp_void); 33 | /* Objects */ 34 | lisp_export(env, "make-class", lisp_make_wrapped_native(lisp_lib_make_class, 2, 2)); 35 | lisp_export(env, "add-superclass!", lisp_make_wrapped_native(lisp_add_superclass, 2, 2)); 36 | lisp_export(env, "make-instance", lisp_make_wrapped_native(lisp_make_instance, 1, 1)); 37 | lisp_export(env, "class-of", lisp_make_wrapped_native(lisp_class_of, 1, 1)); 38 | lisp_export(env, "superclasses-of", lisp_make_wrapped_native(lisp_lib_superclasses_of, 1, 1)); 39 | lisp_export(env, "instance?", lisp_make_wrapped_native(lisp_is_instance, 2, 2)); 40 | lisp_export(env, "subclass?", lisp_make_wrapped_native(lisp_is_subclass, 2, 2)); 41 | lisp_export(env, "get-slot", lisp_make_wrapped_native(lisp_lib_get_slot, 2, 2)); 42 | lisp_export(env, "has-slot?", lisp_make_wrapped_native(lisp_lib_has_slot, 2, 2)); 43 | lisp_export(env, "set-slot!", lisp_make_wrapped_native(lisp_lib_set_slot, 3, 3)); 44 | lisp_export(env, "slot-names", lisp_make_wrapped_native(lisp_lib_slot_names, 1, 1)); 45 | lisp_export(env, "put-method!", lisp_make_wrapped_native(lisp_lib_put_method, 3, 3)); 46 | lisp_export(env, "send", lisp_make_wrapped_native(lisp_lib_send, 3, 3)); 47 | /* Classes */ 48 | lisp_export(env, "Object", Lisp_Object); 49 | lisp_export(env, "User-Object", Lisp_User_Object); 50 | lisp_export(env, "Class", Lisp_Class); 51 | lisp_export(env, "Environment", Lisp_Env); 52 | lisp_export(env, "Symbol", Lisp_Symbol); 53 | lisp_export(env, "Pair", Lisp_Pair); 54 | lisp_export(env, "Nil", Lisp_Nil); 55 | lisp_export(env, "Array", Lisp_Array); 56 | lisp_export(env, "String", Lisp_String); 57 | lisp_export(env, "Number", Lisp_Number); 58 | lisp_export(env, "Boolean", Lisp_Boolean); 59 | lisp_export(env, "Ignore", Lisp_Ignore); 60 | lisp_export(env, "Void", Lisp_Void); 61 | lisp_export(env, "Undefined", Lisp_Undefined); 62 | lisp_export(env, "Combiner", Lisp_Combiner); 63 | lisp_export(env, "Compound-Combiner", Lisp_Compound_Combiner); 64 | lisp_export(env, "Wrapper", Lisp_Wrapper); 65 | lisp_export(env, "Native-Combiner", Lisp_Native_Combiner); 66 | /* Misc */ 67 | lisp_export(env, "read-from-string", lisp_make_wrapped_native(lisp_read_from_string, 1, 1)); 68 | lisp_export(env, "anything-to-string", lisp_make_wrapped_native(lisp_to_string, 1, 1)); 69 | /* JS interop */ 70 | lisp_export(env, "js-global", lisp_make_wrapped_native(lisp_js_global, 1, 1)); 71 | lisp_export(env, "set-js-global!", lisp_make_wrapped_native(lisp_set_js_global, 2, 2)); 72 | lisp_export(env, "js-call", lisp_make_wrapped_native(lisp_js_call, 2)); 73 | lisp_export(env, "js-function", lisp_make_wrapped_native(lisp_js_function, 1, 1)); 74 | lisp_export(env, "js-binop", lisp_make_wrapped_native(lisp_js_binop, 1, 1)); 75 | lisp_export(env, "js-object", lisp_make_wrapped_native(lisp_js_object, 0, 1)); 76 | lisp_export(env, "js-array", lisp_make_wrapped_native(lisp_js_array, 0, 0)); 77 | /* Debugging */ 78 | lisp_export(env, "stack-frame", lisp_make_wrapped_native(lisp_stack_frame, 0, 0)); 79 | lisp_export(env, "Stack-Frame", Lisp_Stack_Frame); 80 | return env; 81 | }; 82 | 83 | /**** Object System ****/ 84 | 85 | /* Virtua's object system is class-based with multiple inheritance. 86 | JS booleans, strings, numbers, null, and undefined are integrated 87 | with the class system through some trickery. Let me explain. 88 | 89 | In order to make the JS objects appear as Lisp objects, we 90 | monkey-patch the classes (Boolean.prototype, String.prototype, ...) 91 | with a .lisp_isa property pointing to the class. This means that 92 | the JS objects inherit that. E.g. String.prototype.lisp_isa points 93 | to String.prototype, so all strings inherit that. This is done by 94 | lisp_init_class which is called both for all newly created Lisp 95 | classes, as well as all existing JS "classes" (prototypes). 96 | 97 | Note that JS's null is Lisp's void (not nil!), and JS's undefined 98 | is a proper object in Lisp, with its own class, Undefined. See the 99 | function lisp_class_of. */ 100 | 101 | /*** Bootstrap ***/ 102 | 103 | Lisp_Object = Object.prototype; 104 | 105 | function Lisp_Class_Prototype() {} 106 | Lisp_Class_Prototype.prototype = Lisp_Object; 107 | var Lisp_Class = new Lisp_Class_Prototype(); 108 | 109 | lisp_init_class(Lisp_Object, []); 110 | lisp_init_class(Lisp_Class, [Lisp_Object]); 111 | 112 | /*** Debugging ***/ 113 | 114 | var lisp_stack = null; 115 | 116 | /*** Core Behaviors ***/ 117 | 118 | /* Evaluates the object in the environment. */ 119 | function lisp_eval(obj, env) { 120 | return lisp_class_of(obj).lisp_eval(obj, env); 121 | } 122 | 123 | /* Combines the object with the operand tree in the environment. */ 124 | function lisp_combine(obj, otree, env) { 125 | var saved_stack = lisp_stack; 126 | lisp_stack = lisp_make_stack_frame(lisp_stack, obj, otree, env); 127 | try { 128 | return lisp_class_of(obj).lisp_combine(obj, otree, env); 129 | } finally { 130 | lisp_stack = saved_stack; 131 | } 132 | } 133 | 134 | /* Matches this object against the operand tree, possibly updating the environment. */ 135 | function lisp_match(obj, otree, env) { 136 | return lisp_class_of(obj).lisp_match(obj, otree, env); 137 | } 138 | 139 | /* Sends a message with the given selector and operand tree to this object. */ 140 | function lisp_send(obj, sel, otree) { 141 | return lisp_class_of(obj).lisp_send(obj, sel, otree); 142 | } 143 | 144 | /* By default, objects evaluate to themselves. */ 145 | Lisp_Object.lisp_eval = function(obj, env) { 146 | return obj; 147 | }; 148 | 149 | /* Make native functions callable. */ 150 | Lisp_Object.lisp_combine = function(obj, otree, env) { 151 | if (lisp_is_native_function(obj)) { 152 | var args = lisp_cons_list_to_array(lisp_eval_args(otree, env)); 153 | return obj.apply(null, args); 154 | } else { 155 | lisp_simple_error("Not a combiner: " + lisp_to_string(obj)); 156 | } 157 | }; 158 | 159 | /* By default, objects cannot be used as left-hand side patterns. */ 160 | Lisp_Object.lisp_match = function(obj, otree, env) { 161 | lisp_simple_error("Not a pattern."); 162 | }; 163 | 164 | /* All objects use the same method lookup algorithm. */ 165 | Lisp_Object.lisp_send = function(obj, sel, otree) { 166 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 167 | lisp_assert(lisp_is_instance(sel, Lisp_String)); 168 | lisp_assert(lisp_is_instance(otree, Lisp_Object)); 169 | var c = lisp_class_of(obj); 170 | var method = lisp_lookup_method(c, sel); 171 | if (typeof(method) !== "undefined") { 172 | return lisp_combine(method, lisp_cons(obj, otree), lisp_make_env(null)); 173 | } else { 174 | lisp_simple_error("Message not understood: " + sel + " by " + lisp_to_string(obj)); 175 | } 176 | }; 177 | 178 | function lisp_lookup_method(c, sel) { 179 | /* Temporary hack: simply disallow inheriting a method from more 180 | than one class. Will be replaced by Touretzky's inferential 181 | distance ordering. */ 182 | var method = c.lisp_methods[sel]; 183 | if (typeof(method) !== "undefined") { 184 | return method; 185 | } else { 186 | var sups = lisp_superclasses_of(c); 187 | for (var i = 0; i < sups.length; i++) { 188 | var sup_method = lisp_lookup_method(sups[i], sel); 189 | if (typeof(method) !== "undefined") { 190 | lisp_simple_error("More than one method found: " + sel); 191 | } else { 192 | method = sup_method; 193 | } 194 | } 195 | return method; 196 | } 197 | } 198 | 199 | /*** Object System Functionality ***/ 200 | 201 | /* Creates a new class with the given prototype, superclasses and 202 | native name (for debuggability). Note that classes that map to 203 | existing JS classes (booleans, strings, ...) are obviously not 204 | created by this function. On them, we only call lisp_init_class, 205 | and do not mess with their prototype chain. */ 206 | function lisp_make_class(proto, sups, native_name) { 207 | lisp_assert(lisp_is_native_array(sups)); 208 | lisp_assert(lisp_is_instance(native_name, Lisp_String)); 209 | var c = Object.create(proto); 210 | c.lisp_debug_name = native_name; 211 | lisp_init_class(c, sups); 212 | return c; 213 | } 214 | 215 | function lisp_init_class(c, sups) { 216 | /* .lisp_isa points at the class itself. This means that all its 217 | instances inherit that, and that we can tell that an object is 218 | a class by checking whether its .lisp_isa points at itself. 219 | 220 | .lisp_superclasses contains a list of superclass objects. This 221 | is independent of the prototype chain. We fix up all existing 222 | JS classes to have Lisp_Object as superclass when we call 223 | lisp_init_class on them. 224 | 225 | .lisp_methods is a dictionary of methods, initially empty. */ 226 | c.lisp_isa = c; 227 | c.lisp_superclasses = sups; 228 | c.lisp_methods = {}; 229 | } 230 | 231 | /* System classes may use a different prototype than Object. This is 232 | used to inherit core behaviors. */ 233 | function lisp_make_system_class(proto, native_name) { 234 | return lisp_make_class(proto, [proto], native_name); 235 | } 236 | 237 | /* User-defined classes can only inherit from User-Object or other 238 | user-defined classes. IOW, system classes cannot be subclassed for 239 | the time being. */ 240 | function lisp_make_user_class(sups, native_name) { 241 | lisp_assert(lisp_is_native_array(sups)); 242 | if (sups.length === 0) { 243 | sups = [Lisp_User_Object]; 244 | } else { 245 | for (var i = 0; i < sups.length; i++) { 246 | if (!lisp_is_subclass(sups[i], Lisp_User_Object)) 247 | lisp_simple_error("Can not inherit from system class: " + 248 | lisp_to_string(sups[i])); 249 | } 250 | } 251 | return lisp_make_class(Lisp_User_Object, sups, native_name); 252 | } 253 | 254 | /* Creates an instance of the given class. */ 255 | function lisp_make_instance(c) { 256 | lisp_assert(lisp_is_instance(c, Lisp_Class)); 257 | return Object.create(c); 258 | } 259 | 260 | /* Returns the class of the object. */ 261 | function lisp_class_of(obj) { 262 | /* Brace yourself, trickery ahead! First of all, undefined and 263 | null must be handled specially, because they cannot have 264 | properties. Note that null maps to Lisp's void. 265 | 266 | Once we've determined that an object is not undefined or null, 267 | we can look at its .lisp_isa property. Some JS objects 268 | (booleans, strings, ...) and all Lisp objects inherit it from 269 | their class. 270 | 271 | Thus, if an object doesn't have a .lisp_isa property, it's 272 | something external like a DOM object - we give all these 273 | objects the class Object. 274 | 275 | As a second, tricky, case: if the .lisp_isa property points to 276 | the object itself, then we know that we are dealing with a 277 | class, and give it the class Class. 278 | 279 | Finally, if we're dealing with a proper object we can return 280 | its class. */ 281 | if (typeof(obj) === "undefined") { 282 | return Lisp_Undefined; 283 | } else if (obj === null) { 284 | return Lisp_Void; 285 | } else { 286 | var c = obj.lisp_isa; 287 | if (typeof(c) === "undefined") { 288 | return Lisp_Object; 289 | } else if (c === obj) { 290 | return Lisp_Class; 291 | } else { 292 | return c; 293 | } 294 | } 295 | } 296 | 297 | /* Returns true if the object is a direct or general instance of the class. */ 298 | function lisp_is_instance(obj, c) { 299 | return lisp_is_subclass(lisp_class_of(obj), c); 300 | } 301 | 302 | /* Returns true if the class is a direct or general subclass of the superclass. */ 303 | function lisp_is_subclass(c, sc) { 304 | if (c === sc) { 305 | return true; 306 | } else { 307 | var sups = lisp_superclasses_of(c); 308 | for (var i = 0; i < sups.length; i++) { 309 | if (lisp_is_subclass(sups[i], sc)) { 310 | return true; 311 | } 312 | } 313 | return false; 314 | } 315 | } 316 | 317 | /* Returns the superclasses of a class, which are empty for the root class. */ 318 | function lisp_superclasses_of(c) { 319 | var sups = c.lisp_superclasses; 320 | if (typeof(sups) !== "undefined") { 321 | return sups; 322 | } else { 323 | lisp_simple_error("Not a class."); 324 | } 325 | } 326 | 327 | /* Adds a superclass to a class. */ 328 | function lisp_add_superclass(c, sc) { 329 | lisp_assert(lisp_is_instance(c, Lisp_Class)); 330 | lisp_assert(lisp_is_instance(sc, Lisp_Class)); 331 | if (!lisp_native_array_contains(c.lisp_superclasses, sc)) { 332 | c.lisp_superclasses.push(sc); 333 | } 334 | return lisp_void; 335 | } 336 | 337 | /* Puts a combiner as implementation for a message selector. */ 338 | function lisp_put_method(c, sel, cmb) { 339 | lisp_assert(lisp_is_instance(c, Lisp_Class)); 340 | lisp_assert(lisp_is_instance(sel, Lisp_String)); 341 | lisp_assert(lisp_is_instance(cmb, Lisp_Combiner)); 342 | c.lisp_methods[sel] = cmb; 343 | } 344 | 345 | /* Puts a wrapped native function as implementation for a message selector. */ 346 | function lisp_put_native_method(c, sel, native_fun) { 347 | lisp_put_method(c, sel, lisp_make_native(native_fun)); 348 | } 349 | 350 | /**** JS Objects ****/ 351 | 352 | /* Returns global variable with given name. */ 353 | function lisp_js_global(name) { 354 | lisp_assert(lisp_is_instance(name, Lisp_String)); 355 | return window[name]; 356 | } 357 | 358 | /* Updates global variable with given name. */ 359 | function lisp_set_js_global(name, value) { 360 | lisp_assert(lisp_is_instance(name, Lisp_String)); 361 | lisp_assert(lisp_is_instance(value, Lisp_Object)); 362 | window[name] = value; 363 | return name; 364 | } 365 | 366 | /* Calls a method of an object. */ 367 | function lisp_js_call(obj, sel) { 368 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 369 | lisp_assert(lisp_is_instance(sel, Lisp_String)); 370 | var args = Array.prototype.slice.call(arguments, 2); 371 | return obj[sel].apply(obj, args); 372 | } 373 | 374 | /* Creates a JS function from a combiner. */ 375 | function lisp_js_function(cmb) { 376 | lisp_assert(lisp_is_instance(cmb, Lisp_Combiner)); 377 | return function() { 378 | var args = lisp_array_to_cons_list(Array.prototype.slice.call(arguments)); 379 | return lisp_combine(cmb, args, lisp_make_env(null)); 380 | }; 381 | } 382 | 383 | /* Creates a combiner that corresponds to a JS binary operator. */ 384 | function lisp_js_binop(op) { 385 | var fun = new Function("a", "b", "return (a " + op + " b)"); 386 | var cmb = lisp_make_wrapped_native(fun, 2, 2); 387 | cmb.lisp_debug_name = op + " binop"; 388 | return cmb; 389 | } 390 | 391 | /* Creates JS object with given prototype (optional). */ 392 | function lisp_js_object(proto) { 393 | return Object.create((typeof(proto) !== "undefined") ? proto : null); 394 | } 395 | 396 | /* Creates JS array. */ 397 | function lisp_js_array() { 398 | return []; 399 | } 400 | 401 | /**** Arrays ****/ 402 | 403 | var Lisp_Array = Array.prototype; 404 | 405 | lisp_init_class(Lisp_Array, [Lisp_Object]); 406 | 407 | function lisp_make_array() { 408 | return []; 409 | } 410 | 411 | /**** Strings ****/ 412 | 413 | var Lisp_String = String.prototype; 414 | 415 | lisp_init_class(Lisp_String, [Lisp_Object]); 416 | 417 | /**** Numbers ****/ 418 | 419 | var Lisp_Number = Number.prototype; 420 | 421 | lisp_init_class(Lisp_Number, [Lisp_Object]); 422 | 423 | /* Creates a new number from the given number representation. */ 424 | function lisp_make_number(repr) { 425 | lisp_assert(lisp_is_instance(repr, Lisp_String)); 426 | return Number(repr); 427 | } 428 | 429 | /**** User Objects ****/ 430 | 431 | var Lisp_User_Object = lisp_make_system_class(Lisp_Object, "Lisp_User_Object"); 432 | 433 | /**** Symbols ****/ 434 | 435 | var lisp_symbols_table = {}; 436 | 437 | var Lisp_Symbol = lisp_make_system_class(Lisp_Object, "Lisp_Symbol"); 438 | 439 | /* A symbol evaluates to the value of the binding it names. */ 440 | Lisp_Symbol.lisp_eval = function(symbol, env) { 441 | return lisp_env_lookup(env, symbol); 442 | }; 443 | 444 | /* A symbol matches anything and binds the operand in the environment. */ 445 | Lisp_Symbol.lisp_match = function(symbol, otree, env) { 446 | lisp_env_put(env, symbol, otree); 447 | }; 448 | 449 | /* Use lisp_intern. */ 450 | function lisp_make_symbol_do_not_call(name) { 451 | lisp_assert(lisp_is_instance(name, Lisp_String)); 452 | var symbol = lisp_make_instance(Lisp_Symbol); 453 | symbol.lisp_name = name; 454 | return symbol; 455 | } 456 | 457 | /* Returns the symbol with the given name. */ 458 | function lisp_intern(name) { 459 | lisp_assert(lisp_is_instance(name, Lisp_String)); 460 | var symbol = lisp_symbols_table[name]; 461 | if (typeof(symbol) !== "undefined") { 462 | return symbol; 463 | } else { 464 | symbol = lisp_make_symbol_do_not_call(name); 465 | lisp_symbols_table[name] = symbol; 466 | return symbol; 467 | } 468 | } 469 | 470 | /* Returns the string name of a symbol. */ 471 | function lisp_symbol_name(symbol) { 472 | lisp_assert(lisp_is_instance(symbol, Lisp_Symbol)); 473 | return symbol.lisp_name; 474 | } 475 | 476 | /**** Pairs ****/ 477 | 478 | var Lisp_Pair = lisp_make_system_class(Lisp_Object, "Lisp_Pair"); 479 | 480 | /* A pair evaluates to the combination of its operator (car) with its 481 | operand tree (cdr). */ 482 | Lisp_Pair.lisp_eval = function(pair, env) { 483 | return lisp_combine(lisp_eval(lisp_car(pair), env), lisp_cdr(pair), env); 484 | }; 485 | 486 | /* A pair matches pairs, recursively. */ 487 | Lisp_Pair.lisp_match = function(pair, otree, env) { 488 | lisp_assert(lisp_is_instance(otree, Lisp_Pair)); 489 | lisp_match(lisp_car(pair), lisp_car(otree), env); 490 | lisp_match(lisp_cdr(pair), lisp_cdr(otree), env); 491 | }; 492 | 493 | /* Creates a new pair with the given first and second elements. */ 494 | function lisp_cons(car, cdr) { 495 | lisp_assert(lisp_is_instance(car, Lisp_Object)); 496 | lisp_assert(lisp_is_instance(cdr, Lisp_Object)); 497 | var cons = lisp_make_instance(Lisp_Pair); 498 | cons.lisp_car = car; 499 | cons.lisp_cdr = cdr; 500 | return cons; 501 | } 502 | 503 | /* Returns the first element of the pair. */ 504 | function lisp_car(cons) { 505 | lisp_assert(lisp_is_instance(cons, Lisp_Pair)); 506 | return cons.lisp_car; 507 | } 508 | 509 | /* Returns the second element of the pair. */ 510 | function lisp_cdr(cons) { 511 | lisp_assert(lisp_is_instance(cons, Lisp_Pair)); 512 | return cons.lisp_cdr; 513 | } 514 | 515 | function lisp_elt(pair, i) { 516 | if (i === 0) { 517 | return lisp_car(pair); 518 | } else { 519 | return lisp_elt(lisp_cdr(pair), i - 1); 520 | } 521 | } 522 | 523 | function lisp_array_to_cons_list(array, end) { 524 | var c = end ? end : lisp_nil; 525 | for (var i = array.length; i > 0; i--) 526 | c = lisp_cons(array[i - 1], c); 527 | return c; 528 | } 529 | 530 | function lisp_cons_list_to_array(c) { 531 | var res = []; 532 | while(c !== lisp_nil) { 533 | res.push(lisp_car(c)); 534 | c = lisp_cdr(c); 535 | } 536 | return res; 537 | } 538 | 539 | function lisp_list() { 540 | return lisp_array_to_cons_list(Array.prototype.slice.call(arguments)); 541 | } 542 | 543 | /**** Environments ****/ 544 | 545 | var Lisp_Env = lisp_make_system_class(Lisp_Object, "Lisp_Env"); 546 | 547 | /* Creates a new empty environment with an optional parent environment. */ 548 | function lisp_make_env(parent) { 549 | lisp_assert((parent === null) || lisp_is_instance(parent, Lisp_Env)); 550 | var env = lisp_make_instance(Lisp_Env); 551 | env.lisp_parent = parent; 552 | env.lisp_bindings = Object.create(null); 553 | return env; 554 | } 555 | 556 | /* Updates or creates a binding from a name to a value. */ 557 | function lisp_env_put(env, name, value) { 558 | lisp_assert(lisp_is_instance(env, Lisp_Env)); 559 | lisp_assert(lisp_is_instance(name, Lisp_Symbol)); 560 | lisp_assert(lisp_is_instance(value, Lisp_Object)); 561 | env.lisp_bindings[lisp_symbol_name(name)] = value; 562 | return value; 563 | } 564 | 565 | /* Updates or creates a binding from a string name to a value. */ 566 | function lisp_export(env, name, value) { 567 | if (value !== null) value.lisp_debug_name = name; 568 | return lisp_env_put(env, lisp_intern(name), value); 569 | } 570 | 571 | /* Looks up the value of a name in the environment and its ancestors. */ 572 | function lisp_env_lookup(env, name) { 573 | lisp_assert(lisp_is_instance(env, Lisp_Env)); 574 | lisp_assert(lisp_is_instance(name, Lisp_Symbol)); 575 | var native_name = lisp_symbol_name(name); 576 | var value = env.lisp_bindings[native_name]; 577 | if (typeof(value) !== "undefined") { 578 | return value; 579 | } else { 580 | if (env.lisp_parent !== null) { 581 | return lisp_env_lookup(env.lisp_parent, name); 582 | } else { 583 | lisp_simple_error("Undefined identifier: " + native_name); 584 | } 585 | } 586 | } 587 | 588 | /* Updates an existing binding from a name to a value. */ 589 | function lisp_env_set(env, name, value) { 590 | lisp_assert(lisp_is_instance(name, Lisp_Symbol)); 591 | lisp_assert(lisp_is_instance(value, Lisp_Object)); 592 | var native_name = lisp_symbol_name(name); 593 | return lisp_do_set(env, native_name, value); 594 | 595 | function lisp_do_set(env, native_name, value) { 596 | lisp_assert(lisp_is_instance(env, Lisp_Env)); 597 | if (typeof(env.lisp_bindings[native_name]) !== "undefined") { 598 | env.lisp_bindings[native_name] = value; 599 | return value; 600 | } else { 601 | if (env.lisp_parent !== null) { 602 | return lisp_do_set(env.lisp_parent, native_name, value); 603 | } else { 604 | lisp_simple_error("Cannot set undefined identifier: " + native_name); 605 | } 606 | } 607 | } 608 | } 609 | 610 | /**** Booleans ****/ 611 | 612 | var Lisp_Boolean = Boolean.prototype; 613 | 614 | lisp_init_class(Lisp_Boolean, [Lisp_Object]); 615 | 616 | var lisp_t = true; 617 | 618 | var lisp_f = false; 619 | 620 | /**** Nil ****/ 621 | 622 | var Lisp_Nil = lisp_make_system_class(Lisp_Object, "Lisp_Nil"); 623 | 624 | var lisp_nil = lisp_make_instance(Lisp_Nil); 625 | 626 | /* Nil matches only itself. */ 627 | Lisp_Nil.lisp_match = function(nil, otree, env) { 628 | if (otree !== lisp_nil) { 629 | lisp_simple_error("Expected (), got: " + lisp_to_string(otree)); 630 | } 631 | }; 632 | 633 | /**** Ignore ****/ 634 | 635 | var Lisp_Ignore = lisp_make_system_class(Lisp_Object, "Lisp_Ignore"); 636 | 637 | var lisp_ignore = lisp_make_instance(Lisp_Ignore); 638 | 639 | /* Ignore matches anything. */ 640 | Lisp_Ignore.lisp_match = function(ignore, otree, env) { 641 | }; 642 | 643 | /**** Void ****/ 644 | 645 | var Lisp_Void = lisp_make_system_class(Lisp_Object, "Lisp_Void"); 646 | 647 | var lisp_void = null; 648 | 649 | /**** Undefined ****/ 650 | 651 | var Lisp_Undefined = lisp_make_system_class(Lisp_Object, "Lisp_Undefined"); 652 | 653 | var lisp_undefined = undefined; 654 | 655 | /**** Combiners ****/ 656 | 657 | var Lisp_Combiner = lisp_make_system_class(Lisp_Object, "Lisp_Combiner"); 658 | 659 | /*** Compound Combiners ***/ 660 | 661 | /* Compound combiners are those created by $vau. They contain a 662 | parameter tree, a formal lexical environment parameter, a body, and 663 | a static lexical environment link. */ 664 | 665 | var Lisp_Compound_Combiner = lisp_make_system_class(Lisp_Combiner, "Lisp_Compound_Combiner"); 666 | 667 | function lisp_make_compound_combiner(ptree, envformal, body, senv) { 668 | lisp_assert(lisp_is_instance(ptree, Lisp_Object)); 669 | lisp_assert(lisp_is_instance(envformal, Lisp_Object)); 670 | lisp_assert(lisp_is_instance(body, Lisp_Object)); 671 | lisp_assert(lisp_is_instance(senv, Lisp_Env)); 672 | var cmb = lisp_make_instance(Lisp_Compound_Combiner); 673 | cmb.lisp_ptree = ptree; 674 | cmb.lisp_envformal = envformal; 675 | cmb.lisp_body = body; 676 | cmb.lisp_senv = senv; 677 | return cmb; 678 | } 679 | 680 | Lisp_Compound_Combiner.lisp_combine = function(cmb, otree, env) { 681 | // Match parameter tree against operand tree in new child 682 | // environment of static environment 683 | var xenv = lisp_make_env(cmb.lisp_senv); 684 | lisp_match(cmb.lisp_ptree, otree, xenv); 685 | // Pass in dynamic environment unless ignored 686 | lisp_match(cmb.lisp_envformal, env, xenv); 687 | // Enter body in extended environment 688 | return lisp_eval(cmb.lisp_body, xenv); 689 | }; 690 | 691 | /*** Wrappers ***/ 692 | 693 | /* A wrapper (applicative combiner) induces argument evaluation for an 694 | underlying combiner. What this means is that the operand tree must 695 | be a list, and all elements are evaluated to yield an arguments 696 | list, which is passed to the underlying combiner. */ 697 | 698 | var Lisp_Wrapper = lisp_make_system_class(Lisp_Combiner, "Lisp_Wrapper"); 699 | 700 | /* Creates a new wrapper around an underlying combiner. */ 701 | function lisp_wrap(underlying) { 702 | lisp_assert(lisp_is_instance(underlying, Lisp_Combiner)); 703 | var cmb = lisp_make_instance(Lisp_Wrapper); 704 | cmb.lisp_underlying = underlying; 705 | return cmb; 706 | } 707 | 708 | /* Extracts the underlying combiner of a wrapper. */ 709 | function lisp_unwrap(wrapper) { 710 | lisp_assert(lisp_is_instance(wrapper, Lisp_Wrapper)); 711 | return wrapper.lisp_underlying; 712 | } 713 | 714 | Lisp_Wrapper.lisp_combine = function(cmb, otree, env) { 715 | return lisp_combine(lisp_unwrap(cmb), lisp_eval_args(otree, env), env); 716 | }; 717 | 718 | function lisp_eval_args(otree, env) { 719 | if (otree === lisp_nil) { 720 | return lisp_nil; 721 | } else { 722 | return lisp_cons(lisp_eval(lisp_car(otree), env), 723 | lisp_eval_args(lisp_cdr(otree), env)); 724 | } 725 | } 726 | 727 | /*** $vau ***/ 728 | 729 | /* Creates a compound combiner. 730 | 731 | ($vau ptree envformal body) -> combiner */ 732 | 733 | var Lisp_Vau = lisp_make_system_class(Lisp_Combiner, "Lisp_Vau"); 734 | 735 | Lisp_Vau.lisp_combine = function(cmb, otree, env) { 736 | var ptree = lisp_elt(otree, 0); 737 | var envformal = lisp_elt(otree, 1); 738 | var body = lisp_elt(otree, 2); 739 | return lisp_make_compound_combiner(ptree, envformal, body, env); 740 | }; 741 | 742 | /*** $begin ***/ 743 | 744 | /* Evaluates forms in sequence, returning value of last, or #void if 745 | there are no forms. 746 | 747 | ($begin . forms) -> result */ 748 | 749 | var Lisp_Begin = lisp_make_system_class(Lisp_Combiner, "Lisp_Begin"); 750 | 751 | Lisp_Begin.lisp_combine = function(cmb, otree, env) { 752 | var res = lisp_void; 753 | while(otree !== lisp_nil) { 754 | res = lisp_eval(lisp_car(otree), env); 755 | otree = lisp_cdr(otree); 756 | }; 757 | return res; 758 | }; 759 | 760 | /*** $define! ***/ 761 | 762 | /* Matches a parameter tree against an operand tree in the current 763 | environment. 764 | 765 | ($define! ptree otree) -> ptree */ 766 | 767 | var Lisp_Define = lisp_make_system_class(Lisp_Combiner, "Lisp_Define"); 768 | 769 | Lisp_Define.lisp_combine = function(cmb, otree, env) { 770 | var lhs = lisp_elt(otree, 0); 771 | var rhs = lisp_elt(otree, 1); 772 | lisp_match(lhs, lisp_eval(rhs, env), env); 773 | return lhs; 774 | }; 775 | 776 | /*** $set! ***/ 777 | 778 | /* Updates the value of an existing binding. 779 | 780 | ($set! name value) -> value */ 781 | 782 | var Lisp_Set = lisp_make_system_class(Lisp_Combiner, "Lisp_Set"); 783 | 784 | Lisp_Set.lisp_combine = function(cmb, otree, env) { 785 | var name = lisp_elt(otree, 0); 786 | var value = lisp_elt(otree, 1); 787 | return lisp_env_set(env, name, lisp_eval(value, env)); 788 | }; 789 | 790 | /*** $if ***/ 791 | 792 | /* Performs either the consequent or alternative expression, depending 793 | on the boolean result of the test expression. 794 | 795 | ($if test consequent alternative) -> result */ 796 | 797 | var Lisp_If = lisp_make_system_class(Lisp_Combiner, "Lisp_If"); 798 | 799 | Lisp_If.lisp_combine = function(cmb, otree, env) { 800 | var test = lisp_elt(otree, 0); 801 | var consequent = lisp_elt(otree, 1); 802 | var alternative = lisp_elt(otree, 2); 803 | var test_result = lisp_eval(test, env); 804 | if (test_result === lisp_t) { 805 | return lisp_eval(consequent, env); 806 | } else if (test_result === lisp_f) { 807 | return lisp_eval(alternative, env); 808 | } else { 809 | lisp_simple_error("Condition must be a boolean."); 810 | } 811 | }; 812 | 813 | /*** $loop ***/ 814 | 815 | /* Repeatedly evaluates a body expression. 816 | 817 | ($loop body) -> | */ 818 | 819 | var Lisp_Loop = lisp_make_system_class(Lisp_Combiner, "Lisp_Loop"); 820 | 821 | Lisp_Loop.lisp_combine = function(cmb, otree, env) { 822 | var body = lisp_elt(otree, 0); 823 | while(true) { 824 | lisp_eval(body, env); 825 | } 826 | }; 827 | 828 | /*** $unwind-protect ***/ 829 | 830 | /* Performs a cleanup expression whether or not a protected expression 831 | exits normally. Returns the result of the protected expression. 832 | 833 | ($unwind-protect protected cleanup) -> result */ 834 | 835 | var Lisp_Unwind_Protect = lisp_make_system_class(Lisp_Combiner, "Lisp_Unwind_Protect"); 836 | 837 | Lisp_Unwind_Protect.lisp_combine = function(cmb, otree, env) { 838 | var protect = lisp_elt(otree, 0); 839 | var cleanup = lisp_elt(otree, 1); 840 | try { 841 | return lisp_eval(protect, env); 842 | } finally { 843 | lisp_eval(cleanup, env); 844 | } 845 | }; 846 | 847 | /*** $js-try ***/ 848 | 849 | /* ($js-try handler body) -> result */ 850 | 851 | var Lisp_JS_Try = lisp_make_system_class(Lisp_Combiner, "Lisp_JS_Try"); 852 | 853 | Lisp_JS_Try.lisp_combine = function(cmb, otree, env) { 854 | var handler_form = lisp_elt(otree, 0); 855 | var body_form = lisp_elt(otree, 1); 856 | var handler = lisp_eval(handler_form, env); 857 | try { 858 | return lisp_eval(body_form, env); 859 | } catch(e) { 860 | return lisp_combine(handler, lisp_list(e), lisp_make_env(null)); 861 | } 862 | }; 863 | 864 | /**** Native Combiners ****/ 865 | 866 | /* A native combiner contains a native function. By default, it gets 867 | called with the list of unevaluated arguments (it doesn't receive 868 | the operand tree as is). To have arguments evaluated, wrap it. */ 869 | 870 | var Lisp_Native_Combiner = lisp_make_system_class(Lisp_Combiner, "Lisp_Native_Combiner"); 871 | 872 | Lisp_Native_Combiner.lisp_combine = function(cmb, otree, env) { 873 | var args = lisp_cons_list_to_array(otree); 874 | if (typeof(cmb.lisp_min_args !== "undefined")) { 875 | if (args.length < cmb.lisp_min_args) { 876 | lisp_simple_error("Too few arguments."); 877 | } 878 | } 879 | if (typeof(cmb.lisp_max_args !== "undefined")) { 880 | if (args.length > cmb.lisp_max_args) { 881 | lisp_simple_error("Too many arguments."); 882 | } 883 | } 884 | return cmb.lisp_native_fun.apply(null, args); 885 | }; 886 | 887 | /* Creates a new native combiner for the native function. */ 888 | function lisp_make_native(native_fun, min_args, max_args) { 889 | lisp_assert(lisp_is_native_function(native_fun)); 890 | var cmb = lisp_make_instance(Lisp_Native_Combiner); 891 | cmb.lisp_native_fun = native_fun; 892 | cmb.lisp_min_args = min_args; 893 | cmb.lisp_max_args = max_args; 894 | return cmb; 895 | } 896 | 897 | /* Creates a new native wrapper for the native function. */ 898 | function lisp_make_wrapped_native(native_fun, min_args, max_args) { 899 | return lisp_wrap(lisp_make_native(native_fun, min_args, max_args)); 900 | } 901 | 902 | /**** Library ****/ 903 | 904 | /* Library functions are those that are exported to Lisp, but usually 905 | not directly used in the implementation from JavaScript. However, 906 | there is no clear distinction between library and "non-library" 907 | functions - there are also functions exported to Lisp that are not 908 | marked as library. It's important that all exported functions deal 909 | with Lisp values (e.g. booleans), and not JavaScript values. */ 910 | 911 | /*** Library Functions ***/ 912 | 913 | function lisp_lib_make_env(optional_parent) { 914 | return lisp_make_env((typeof(optional_parent) !== "undefined") ? optional_parent : null); 915 | } 916 | 917 | function lisp_lib_eq(a, b) { 918 | return a === b; 919 | } 920 | 921 | function lisp_lib_null(obj) { 922 | return lisp_lib_eq(obj, lisp_nil); 923 | } 924 | 925 | function lisp_lib_make_class(sups, native_name) { 926 | return lisp_make_user_class(lisp_cons_list_to_array(sups), native_name); 927 | } 928 | 929 | function lisp_lib_get_slot(obj, slot) { 930 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 931 | lisp_assert(lisp_is_instance(slot, Lisp_String)); 932 | var value = obj[slot]; 933 | if (typeof(value) !== "undefined") { 934 | return value; 935 | } else { 936 | lisp_simple_error("Unbound slot: " + slot); 937 | } 938 | } 939 | 940 | function lisp_lib_has_slot(obj, slot) { 941 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 942 | lisp_assert(lisp_is_instance(slot, Lisp_String)); 943 | var value = obj[slot]; 944 | return typeof(value) !== "undefined"; 945 | } 946 | 947 | function lisp_lib_set_slot(obj, slot, value) { 948 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 949 | lisp_assert(lisp_is_instance(slot, Lisp_String)); 950 | lisp_assert(lisp_is_instance(value, Lisp_Object)); 951 | obj[slot] = value; 952 | return value; 953 | } 954 | 955 | function lisp_lib_slot_names(obj) { 956 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 957 | var names = []; 958 | for (var name in obj) { 959 | if (obj.hasOwnProperty(name)) { 960 | names.push(name); 961 | } 962 | } 963 | return lisp_array_to_cons_list(names); 964 | } 965 | 966 | function lisp_lib_superclasses_of(c) { 967 | return lisp_array_to_cons_list(lisp_superclasses_of(c)); 968 | } 969 | 970 | function lisp_lib_put_method(c, sel, cmb) { 971 | lisp_assert(lisp_is_instance(c, Lisp_Class)); 972 | lisp_assert(lisp_is_instance(sel, Lisp_String)); 973 | lisp_assert(lisp_is_instance(cmb, Lisp_Combiner)); 974 | lisp_put_method(c, sel, cmb); 975 | return sel; 976 | } 977 | 978 | function lisp_lib_send(obj, sel, otree) { 979 | lisp_assert(lisp_is_instance(obj, Lisp_Object)); 980 | lisp_assert(lisp_is_instance(sel, Lisp_String)); 981 | lisp_assert(lisp_is_instance(otree, Lisp_Object)); 982 | return lisp_send(obj, sel, otree); 983 | } 984 | 985 | function lisp_lib_error(string) { 986 | lisp_assert(lisp_is_instance(string, Lisp_String)); 987 | lisp_simple_error(string); 988 | } 989 | 990 | function lisp_lib_throw(obj) { 991 | throw obj; 992 | } 993 | 994 | function lisp_to_string(obj) { 995 | var res; 996 | if (typeof(obj) === "undefined") { 997 | res = "undefined"; 998 | } else { 999 | try { 1000 | res = JSON.stringify(obj); 1001 | } catch(ignore) { 1002 | res = obj.toString() + " (non-JSON)"; 1003 | } 1004 | } 1005 | return res; 1006 | } 1007 | 1008 | /**** Debugging ****/ 1009 | 1010 | function lisp_stack_frame() { 1011 | return lisp_stack; 1012 | } 1013 | 1014 | var Lisp_Stack_Frame = lisp_make_system_class(Lisp_Object, "Lisp_Stack_Frame"); 1015 | 1016 | function lisp_make_stack_frame(parent, cmb, otree, env) { 1017 | var frame = lisp_make_instance(Lisp_Stack_Frame); 1018 | frame.parent = parent; 1019 | frame.cmb = cmb; 1020 | frame.otree = otree; 1021 | frame.env = env; 1022 | return frame; 1023 | } 1024 | 1025 | /**** Errors, Assertions, and Abominations ****/ 1026 | 1027 | function lisp_simple_error(msg) { 1028 | throw msg; 1029 | } 1030 | 1031 | function lisp_assert(bool) { 1032 | if (!bool) { 1033 | lisp_simple_error("Assertion failed."); 1034 | } 1035 | } 1036 | 1037 | function lisp_is_native_array(native_array) { 1038 | return (native_array instanceof Array); 1039 | } 1040 | 1041 | function lisp_is_native_function(native_function) { 1042 | return typeof(native_function) === "function"; 1043 | } 1044 | 1045 | function lisp_native_array_contains(native_array, obj) { 1046 | return (native_array.indexOf(obj) !== -1); 1047 | } 1048 | 1049 | /**** Parser ****/ 1050 | 1051 | /* Returns a cons list of the forms in the string. */ 1052 | function lisp_read_from_string(s) { 1053 | return lisp_array_to_cons_list(lisp_parse(s)); 1054 | } 1055 | 1056 | /* Returns an array of the forms in the native string. */ 1057 | function lisp_parse(string) { 1058 | lisp_assert(lisp_is_instance(string, Lisp_String)); 1059 | var result = lisp_program_syntax(ps(string)); 1060 | if (result.remaining.index === string.length) { 1061 | return result.ast; 1062 | } else { 1063 | lisp_simple_error("Parse error at index: " + result.remaining.index); 1064 | } 1065 | } 1066 | 1067 | var lisp_expression_syntax = 1068 | function(input) { return lisp_expression_syntax(input); }; // forward decl. 1069 | 1070 | var lisp_identifier_special_char = 1071 | choice("-", "&", "!", ":", "=", ">", "<", "%", 1072 | "+", "?", "/", "*", "#", "$", "_", "'", "."); 1073 | 1074 | var lisp_identifier_char = 1075 | choice(range("a", "z"), 1076 | range("A", "Z"), 1077 | range("0", "9"), 1078 | lisp_identifier_special_char); 1079 | 1080 | // Kludge: don't allow single dot as identifier, so as not to conflict 1081 | // with dotted pair syntax. 1082 | var lisp_identifier_syntax = 1083 | action(join_action(butnot(repeat1(lisp_identifier_char), "."), ""), 1084 | lisp_identifier_syntax_action); 1085 | 1086 | function lisp_identifier_syntax_action(ast) { 1087 | return lisp_intern(ast); 1088 | } 1089 | 1090 | var lisp_escape_char = 1091 | choice("\"", "\\"); 1092 | 1093 | var lisp_escape_sequence = 1094 | action(sequence("\\", lisp_escape_char), 1095 | lisp_escape_sequence_action); 1096 | 1097 | var lisp_string_char = 1098 | choice(negate(lisp_escape_char), 1099 | lisp_escape_sequence); 1100 | 1101 | var lisp_string_syntax = 1102 | action(sequence("\"", join_action(repeat0(lisp_string_char), ""), "\""), 1103 | lisp_string_syntax_action); 1104 | 1105 | function lisp_escape_sequence_action(ast) { 1106 | var escape_char = ast[1]; 1107 | return escape_char; 1108 | } 1109 | 1110 | function lisp_string_syntax_action(ast) { 1111 | lisp_assert(lisp_is_instance(ast[1], Lisp_String)); 1112 | return ast[1]; 1113 | } 1114 | 1115 | var lisp_digits = 1116 | join_action(repeat1(range("0", "9")), ""); 1117 | 1118 | var lisp_number_syntax = 1119 | action(sequence(optional(choice("+", "-")), 1120 | lisp_digits, 1121 | optional(join_action(sequence(".", lisp_digits), ""))), 1122 | lisp_number_syntax_action); 1123 | 1124 | function lisp_number_syntax_action(ast) { 1125 | var sign = ast[0] ? ast[0] : "+"; 1126 | var integral_digits = ast[1]; 1127 | var fractional_digits = ast[2] || ""; 1128 | return lisp_make_number(sign + integral_digits + fractional_digits); 1129 | } 1130 | 1131 | function lisp_make_constant_syntax(string, constant) { 1132 | return action(string, function(ast) { return constant; }); 1133 | } 1134 | 1135 | var lisp_nil_syntax = 1136 | lisp_make_constant_syntax("()", lisp_nil); 1137 | 1138 | var lisp_ignore_syntax = 1139 | lisp_make_constant_syntax("#ignore", lisp_ignore); 1140 | 1141 | var lisp_dot_syntax = 1142 | action(wsequence(".", lisp_expression_syntax), 1143 | lisp_dot_syntax_action); 1144 | 1145 | function lisp_dot_syntax_action(ast) { 1146 | return ast[1]; 1147 | } 1148 | 1149 | var lisp_compound_syntax = 1150 | action(wsequence("(", 1151 | repeat1(lisp_expression_syntax), 1152 | optional(lisp_dot_syntax), 1153 | ")"), 1154 | lisp_compound_syntax_action); 1155 | 1156 | function lisp_compound_syntax_action(ast) { 1157 | var exprs = ast[1]; 1158 | var end = ast[2] ? ast[2] : lisp_nil; 1159 | return lisp_array_to_cons_list(exprs, end); 1160 | } 1161 | 1162 | var lisp_line_terminator = choice(ch("\r"), ch("\n")); 1163 | 1164 | var lisp_line_comment_syntax = 1165 | action(sequence(";", 1166 | repeat0(negate(lisp_line_terminator)), 1167 | optional(lisp_line_terminator)), 1168 | lisp_nothing_action); 1169 | 1170 | var lisp_whitespace_syntax = 1171 | action(choice(" ", "\n", "\r", "\t"), lisp_nothing_action); 1172 | 1173 | function lisp_nothing_action(ast) { // HACK! 1174 | return lisp_void; 1175 | } 1176 | 1177 | var lisp_expression_syntax = 1178 | whitespace(choice(lisp_number_syntax, 1179 | lisp_nil_syntax, 1180 | lisp_ignore_syntax, 1181 | lisp_compound_syntax, 1182 | lisp_identifier_syntax, 1183 | lisp_string_syntax, 1184 | lisp_line_comment_syntax)); 1185 | 1186 | var lisp_program_syntax = 1187 | whitespace(repeat0(choice(lisp_expression_syntax, 1188 | lisp_whitespace_syntax))); // HACK! 1189 | 1190 | 1191 | // Permission is hereby granted, free of charge, to any person 1192 | // obtaining a copy of this software and associated documentation 1193 | // files (the "Software"), to deal in the Software without 1194 | // restriction, including without limitation the rights to use, copy, 1195 | // modify, merge, publish, distribute, sublicense, and/or sell copies 1196 | // of the Software, and to permit persons to whom the Software is 1197 | // furnished to do so, subject to the following conditions: 1198 | // 1199 | // The above copyright notice and this permission notice shall be 1200 | // included in all copies or substantial portions of the Software. 1201 | // 1202 | // THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 1203 | // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 1204 | // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 1205 | // NONINFRINGEMENT. ALSO, THERE IS NO KERNEL UNDERGROUND; IT'S ALL 1206 | // JUST RUMOUR AND HEARSAY. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 1207 | // HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 1208 | // WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 1209 | // OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 1210 | // DEALINGS IN THE SOFTWARE. 1211 | --------------------------------------------------------------------------------