├── README ├── arclite.arc ├── buffer.js ├── build.sh ├── eval.js ├── index.html ├── jquery.js ├── primitives.js ├── reader.js ├── styles.css ├── test ├── test_buffer.html ├── test_eval.html ├── test_primitives.html ├── test_reader.html ├── test_suite.html ├── test_tutorial.html └── test_types.html ├── types.js └── utils.js /README: -------------------------------------------------------------------------------- 1 | This is a JavaScript port of Paul Graham's Arc programming language. It is nearly-fully-conforming, in the sense of being able to run arc.arc: it lacks continuations and some of the I/O primitives, which is why there's a special arclite.arc with the broken forms stripped out. Firefox (and other browsers which support __proto__) only; does not work in IE. 2 | 3 | The source code is written as a series of modules; build.sh takes care of concatenating them together to a single arclite.js file. The index.html file provides a host for this file, letting you evaluate arc forms in your browser. There are also JSUnit tests in /test. 4 | -------------------------------------------------------------------------------- /arclite.arc: -------------------------------------------------------------------------------- 1 | ;;; Fixups to the standard library to get around incompatibilities in primitives, 2 | ;;; mostly related to the lack of mutable strings 3 | 4 | (def map (f . seqs) 5 | (if (some [isa _ 'string] seqs) 6 | ; Doesn't even work in reference implementation...I wonder why I bother ;-) 7 | (withs (n (apply min (map len seqs)) 8 | lists (map [coerce _ 'cons] seqs)) 9 | (apply f lists)) 10 | (no (cdr seqs)) 11 | (map1 f (car seqs)) 12 | ((afn (seqs) 13 | (if (some no seqs) 14 | nil 15 | (cons (apply f (map1 car seqs)) 16 | (self (map1 cdr seqs))))) 17 | seqs))) 18 | 19 | (def subseq (seq start (o end (len seq))) 20 | (if (isa seq 'string) 21 | (let s2 "" 22 | (for i start (- end 1) 23 | (= s2 (+ s2 (seq i)))) 24 | s2) 25 | (firstn (- end start) (nthcdr start seq)))) 26 | 27 | (def copy (x) 28 | (case (type x) 29 | sym x 30 | cons (apply (fn args args) x) 31 | string (subseq x 0) 32 | table (let new (table) 33 | (ontable k v x 34 | (= (new k) v)) 35 | new) 36 | (err "Can't copy " x))) 37 | -------------------------------------------------------------------------------- /buffer.js: -------------------------------------------------------------------------------- 1 | (function() { 2 | 3 | if(typeof window.Buffer != 'undefined') { 4 | var _Buffer = window.Buffer; 5 | } 6 | 7 | var Buffer = window.Buffer = function(args) { 8 | if(this instanceof arguments.callee) { 9 | this.init.apply(this, args && args.callee ? args : arguments); 10 | } else { 11 | return new Buffer(arguments); 12 | } 13 | }; 14 | 15 | Buffer.no_conflict = function() { 16 | window.Buffer = _Buffer; 17 | return Buffer; 18 | }; 19 | 20 | Buffer.prototype = { 21 | 22 | init: function(text) { 23 | this._text = text; 24 | this._pos = 0; 25 | }, 26 | 27 | read: function() { 28 | var c = this.peek(); 29 | if(c === false) { 30 | return false; 31 | } 32 | 33 | this.eat(); 34 | return c; 35 | }, 36 | 37 | read_until: function(pred) { 38 | var start = this._pos 39 | while(this.peek() !== false && !pred(this.peek())) { 40 | this.eat(); 41 | }; 42 | return this._text.substring(start, this._pos); 43 | }, 44 | 45 | eat: function() { 46 | ++this._pos; 47 | if(this._pos > this._text.length) { 48 | throw new Error('Unexpected end of file at position ' + this._pos); 49 | } 50 | }, 51 | 52 | peek: function() { 53 | if(this._pos >= this._text.length) { 54 | return false; 55 | } 56 | 57 | return this._text.charAt(this._pos); 58 | }, 59 | 60 | get: function(index) { 61 | return this._text.charAt(index != undefined ? index : this._pos); 62 | } 63 | 64 | }; 65 | 66 | })(); 67 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | cat utils.js buffer.js types.js reader.js primitives.js eval.js > arclite.js 3 | -------------------------------------------------------------------------------- /eval.js: -------------------------------------------------------------------------------- 1 | (function () { 2 | 3 | if(typeof window.Eval != 'undefined') { 4 | var _Eval = window.val; 5 | } 6 | 7 | function is_literal(expr) { 8 | switch(expr.__type().__to_js()) { 9 | case 'char': 10 | case 'string': 11 | case 'int': 12 | case 'num': 13 | return true; 14 | default: 15 | return false; 16 | } 17 | }; 18 | 19 | function xcar(expr) { 20 | return expr.__teq('cons') ? expr._car : false; 21 | }; 22 | 23 | function car_eq(expr, val) { 24 | var car = xcar(expr); 25 | return car && car.__eq(val); 26 | }; 27 | 28 | function cadr(expr) { 29 | return expr._cdr._car; 30 | }; 31 | 32 | function apply(fn, args) { 33 | Utils.assert('Null function object passed', fn); 34 | while(fn._tagged) { 35 | fn = fn._val; 36 | } 37 | if(fn.__call == 'native') { 38 | return apply_fn(fn, args); 39 | } else { 40 | return fn.__call(args); 41 | } 42 | }; 43 | 44 | function apply_fn(fn, args) { 45 | var new_env = {}; 46 | new_env.__proto__ = fn._env; 47 | args = Types.list(args); 48 | 49 | function bind_var(fn_arg, call_arg) { 50 | var recurse = true; 51 | if(fn_arg.__teq('cons')) { 52 | // Not the end of the list... 53 | var sym = fn_arg._car; 54 | if(sym.__teq('sym')) { 55 | // Normal binding 56 | if(call_arg.__teq('cons')) { 57 | new_env[sym] = call_arg._car; 58 | bind_var(fn_arg._cdr, call_arg._cdr); 59 | } else { 60 | Utils.error('Wrong number of args for function: expected ' + 61 | fn._args.__print() + ', found ' + args.__print()); 62 | } 63 | } else if(car_eq(sym, 'o')) { 64 | // Optional parameters 65 | var default_expr = cadr(sym._cdr); 66 | new_env[cadr(sym)] = call_arg._car || 67 | (default_expr ? eval(default_expr, new_env) : Types.NIL); 68 | bind_var(fn_arg._cdr, call_arg._cdr || call_arg); 69 | } else if(sym.__teq('cons')) { 70 | // Destructuring 71 | bind_var(sym, call_arg._car); 72 | } else { 73 | Utils.error('Unknown object type in arg list ' + fn._args.__print()); 74 | } 75 | } else if(fn_arg == Types.NIL && call_arg == Types.NIL) { 76 | // End of the arg list; do nothing 77 | } else if(fn_arg.__teq('sym')) { 78 | // Rest parameter 79 | new_env[fn_arg] = call_arg; 80 | } else { 81 | Utils.error("Couldn't bind parameters " + args + ' to list ' + fn._args); 82 | } 83 | }; 84 | 85 | bind_var(fn._args, args); 86 | var last_result = Types.NIL; 87 | fn._body.__each(function(expr) { 88 | last_result = eval(expr, new_env); 89 | }); 90 | return last_result; 91 | }; 92 | 93 | function eval_quasiquote(expr, env) { 94 | var accum = []; 95 | do { 96 | var current = expr._car; 97 | if(car_eq(current, 'unquote')) { 98 | accum.push(eval(cadr(current), env)); 99 | } else if(car_eq(current, 'unquote-splicing')) { 100 | var results = eval(cadr(current), env).__to_list(); 101 | for(var i = 0, len = results.length; i < len; ++i) { 102 | accum.push(results[i]); 103 | } 104 | } else if(current.__teq('cons')) { 105 | accum.push(eval_quasiquote(current, env)); 106 | } else { 107 | accum.push(current); 108 | } 109 | expr = expr._cdr; 110 | } while(expr.__teq('cons')); 111 | return Types.list(accum); 112 | }; 113 | 114 | function eval_symbol(expr, env) { 115 | if(!is_symbol_macro(expr)) { 116 | var result = env[expr]; 117 | if(!result) { 118 | Utils.error('Unbound variable ' + expr); 119 | } 120 | return result; 121 | } else { 122 | return eval(symbol_expand(expr), env); 123 | } 124 | }; 125 | 126 | function eval_if(expr, env) { 127 | Utils.assert('No test for conditional', expr._car); 128 | var test = eval(expr._car, env); 129 | 130 | if(expr._cdr == Types.NIL) { 131 | return test; 132 | } 133 | 134 | if(test == Types.NIL) { 135 | var alternative = expr._cdr._cdr; 136 | return alternative != Types.NIL ? eval_if(alternative, env) : Types.NIL; 137 | } else { 138 | var consequent = cadr(expr); 139 | Utils.assert('No if-true clause', consequent); 140 | return eval(consequent, env); 141 | } 142 | }; 143 | 144 | function eval_fn(expr, env) { 145 | return Types.fn(expr._car, expr._cdr, env); 146 | }; 147 | 148 | function eval_symbol_macro(expr, env, macrodefs) { 149 | var name = cadr(expr), 150 | def = Types.fn(Types.list(Types.sym('expr')), expr._cdr._cdr, env); 151 | return macrodefs[name] = env[name] = def; 152 | }; 153 | 154 | function eval_set(expr, env) { 155 | function set_value(varname, value, env_segment) { 156 | if(!env_segment) { 157 | eval.global_env[varname] = value; 158 | return; 159 | } 160 | 161 | // hasOwnProperty requires a JS string, for some reason, even 162 | // though the actual key is a symbol string 163 | if(env_segment.hasOwnProperty(varname.__to_js())) { 164 | env_segment[varname] = value; 165 | } else { 166 | set_value(varname, value, env_segment.__proto__); 167 | } 168 | }; 169 | 170 | var varname, value; 171 | while(expr != Types.NIL) { 172 | varname = expr._car; 173 | value = eval(cadr(expr), env); 174 | set_value(varname, value, env); 175 | expr = expr._cdr._cdr; 176 | }; 177 | return value; 178 | }; 179 | 180 | function is_macro(expr, env) { 181 | env = env || eval.global_env; 182 | var sym = expr._car; 183 | return sym && env[sym] && env[sym].__teq('mac'); 184 | }; 185 | 186 | function eval_call(expr, env) { 187 | if(is_macro(expr, env)) { 188 | return eval_macro_call(expr, env); 189 | } else { 190 | return eval_fn_call(expr, env); 191 | } 192 | }; 193 | 194 | function is_symbol_macro(expr) { 195 | return expr.indexOf('~') != -1 || expr.indexOf(':') != -1; 196 | }; 197 | 198 | function symbol_expand(expr, env) { 199 | function complement(section) { 200 | return section.charAt(0) == '~' 201 | ? Types.list(Types.sym('complement'), Types.sym(section.substr(1))) 202 | : Types.sym(section); 203 | }; 204 | var sections = expr.split(':'); 205 | return sections.length > 1 206 | ? Types.list([Types.sym('compose')].concat(Utils.map(sections, complement))) 207 | : complement(sections[0]); 208 | }; 209 | 210 | function macro_expand(expr, env) { 211 | // Assumes that we've already checked and made sure the call is a macro 212 | env = env || eval.global_env; 213 | var macro_def = env[expr._car], 214 | macro_result = apply(macro_def, expr._cdr.__to_list()); 215 | Utils.assert('Macro call has no return value', macro_result); 216 | return macro_result; 217 | }; 218 | 219 | function eval_macro_call(expr, env) { 220 | return eval(macro_expand(expr, env), env); 221 | }; 222 | 223 | function eval_fn_call(expr, env) { 224 | var form = expr.__to_list(); 225 | for(var i = 0, len = form.length; i < len; ++i) { 226 | var result = eval(form[i], env); 227 | Utils.assert("Eval of " + form[i].__print() + " yielded undefined", result); 228 | form[i] = result; 229 | } 230 | return apply(form[0], form.slice(1)); 231 | }; 232 | 233 | var eval = window.Eval = function(expr, env) { 234 | env = env || eval.global_env; 235 | 236 | try { 237 | if(is_literal(expr)) { 238 | return expr; 239 | } else if(expr.__teq('sym')) { 240 | return eval_symbol(expr, env); 241 | } else if(car_eq(expr, 'quote')) { 242 | return cadr(expr); 243 | } else if(car_eq(expr, 'quasiquote')) { 244 | return eval_quasiquote(cadr(expr), env); 245 | } else if(car_eq(expr, 'if')) { 246 | return eval_if(expr._cdr, env); 247 | } else if(car_eq(expr, 'fn')) { 248 | return eval_fn(expr._cdr, env); 249 | } else if(car_eq(expr, 'set')) { 250 | return eval_set(expr._cdr, env); 251 | } else if(expr.__teq('cons')) { 252 | return eval_call(expr, env); 253 | } else { 254 | Utils.error('Unknown form type ' + expr); 255 | } 256 | } catch(e) { 257 | if(!(e instanceof Utils.ArcError)) { 258 | Utils.error('Internal error: ' + e.message, expr); 259 | } else { 260 | e.expr = expr; 261 | throw e; 262 | } 263 | } 264 | }; 265 | 266 | var exposed_interpreter_functions = { 267 | 268 | bound: function(name) { 269 | return eval.global_env[name] || Types.NIL; 270 | }, 271 | 272 | apply: Primitives._varargs(function() { 273 | // The behavior of apply is to flatten the last element into the arg list 274 | // if it is itself a list. I have no idea why it does this; it leads to 275 | // odd behavior like (apply + 1 2 '(3 4)) => 10 but 276 | // (apply + 1 '(2 3) 4) => error. But I need to do it for compatibility. 277 | var args = [].slice.call(arguments, 1), 278 | last_elem = args[args.length - 1]; 279 | if(last_elem.__teq('cons')) { 280 | args = args.slice(0, -1).concat(last_elem.__to_list()); 281 | } 282 | return apply(arguments[0], args); 283 | }, 1), 284 | 285 | 'atomic-invoke': function(f) { return apply(f, []); }, 286 | 287 | ssyntax: function(expr) { return Types.bool(is_symbol_macro(expr)); }, 288 | ssexpand: function(expr) { return symbol_expand(expr, eval.global_env); }, 289 | macex1: function(expr) { return is_macro(expr) ? macro_expand(expr) : expr; }, 290 | macex: function(expr) { 291 | while(is_macro(expr)) { 292 | expr = macro_expand(expr); 293 | } 294 | return expr; 295 | }, 296 | 297 | // Fake I/O: 298 | stdout: function() { return Types.T; }, 299 | stdin: function() { return Types.T; }, 300 | sread: function(arc_string) { return Read(arc_string.__to_js()); }, 301 | disp: Primitives._varargs(function() { 302 | for(var i = 0, len = arguments.length; i < len; ++i) { 303 | eval.stdout += arguments[i]; 304 | } 305 | return Types.NIL; 306 | }), 307 | 308 | writec: Primitives._varargs(function(c) { 309 | eval.stdout += c; 310 | return Types.NIL; 311 | }, 1) 312 | 313 | }; 314 | 315 | function init_globals() { 316 | var env = {}; 317 | function add_primitive(namespace, name) { 318 | var prim = namespace[name]; 319 | if(typeof prim == 'function') { 320 | env[name] = Types.primitive(prim, name); 321 | } else if(name.charAt(0) != '_') { 322 | env[name] = prim; 323 | } 324 | }; 325 | for(var prop in Primitives) { 326 | add_primitive(Primitives, prop); 327 | } 328 | for(var prop in exposed_interpreter_functions) { 329 | add_primitive(exposed_interpreter_functions, prop); 330 | } 331 | return env; 332 | }; 333 | 334 | Utils.extend(eval, { 335 | 336 | no_conflict: function() { 337 | window.Eval = _eval; 338 | return eval; 339 | }, 340 | 341 | init_globals: init_globals, 342 | global_env: init_globals(), 343 | character_macros: {}, 344 | symbol_macros: {}, 345 | 346 | eval_line: function(text) { 347 | return eval(Read(text)); 348 | }, 349 | 350 | eval_text: function(text) { 351 | var last_result, 352 | buf = Buffer(text); 353 | while(buf.peek() !== false) { 354 | var text = Read(buf); 355 | if(text === false) break; // Last token is zero-length 356 | last_result = eval(text); 357 | buf.read_until(Read.is_not_whitespace); 358 | } 359 | return last_result; 360 | }, 361 | 362 | stdout: '', 363 | stdin: '', 364 | clear_stdout: function() { 365 | eval.stdout = ''; 366 | } 367 | }); 368 | 369 | })(); 370 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | ArcLite - Arc Ported to JavaScript 4 | 5 | 6 | 7 | 55 | 56 | 57 |

ArcLite - Arc in JavaScript

58 |
59 | 60 | 61 |
62 |
63 | 64 | Paste code... 66 |
67 | 71 |
72 | 

  73 |         

  74 |         

  75 |         

  76 | 
So, Arc came out about a week ago, and I tried to stay away, but it was just too tempting.  I ended up spending a week porting it to JavaScript.  You can download the implementation as either a single file or as a tarball.  The unit tests assume you have JSUnit installed and accessible.

  77 | 
Notes & deviations from the reference implementation: 

  95 |         
1592 |         
1630 |     
1631 | 
1632 | 


--------------------------------------------------------------------------------
/primitives.js:
--------------------------------------------------------------------------------
  1 | (function () {
  2 | 
  3 | if(typeof window.Primitives != 'undefined') {
  4 |     var _Primitives = window.Primitives;
  5 | }
  6 | 
  7 | var gensym_count = 0;
  8 | 
  9 | 
 10 | function varargs(fn, minimum) {
 11 |     fn._varargs = minimum || 0;
 12 |     return fn;
 13 | };
 14 | 
 15 | var Primitives = window.Primitives = {
 16 |     _no_conflict: function() {
 17 |         window.Primitives = _Primitives;
 18 |         return Primitives;
 19 |     },
 20 | 
 21 |     _varargs: varargs,
 22 | 
 23 |     /*----- Generic interpreter functions -----*/
 24 |     error: function() {
 25 |         var msg = Utils.invoke(arguments, '__to_js').join('');
 26 |         Utils.error(msg);
 27 |     },
 28 |     
 29 |     is: varargs(function() {
 30 |         return Types.bool(Utils.pairwise(arguments, true, function(v1, v2) {
 31 |             return v1.__teq(v2.__type().__to_js()) && v1.__veq(v2);
 32 |         }));
 33 |     }, 2),
 34 | 
 35 |     uniq: function() { 
 36 |         return Types.sym('gs' + (++gensym_count)); 
 37 |     },
 38 | 
 39 |     sig: Types.table({}),
 40 | 
 41 |     sref: function(collection, new_val, index) {
 42 |         collection.__set(index, new_val);
 43 |         return new_val;
 44 |     },
 45 | 
 46 |     /*----- Types -----*/
 47 | 
 48 |     t: Types.T,
 49 |     nil: Types.NIL,
 50 |     // Wrapper so that fn.length is properly set
 51 |     annotate: function(tag, val) { return Types.tagged(tag, val); },
 52 | 
 53 |     type: function(val) { return val.__type(); },
 54 |     rep: function(val) { return val._tagged ? val._val : val; },
 55 |     coerce: function(val, type) { return val.__coerce(type); },
 56 |     // TODO: radix argument for coerce
 57 | 
 58 |     /*----- Lists -----*/
 59 |     cons: function(car, cdr) { return Types.cons(car, cdr); },
 60 | 
 61 |     car: function(list) {
 62 |         if(list == Types.NIL) return list;
 63 |         Utils.assert("Can't take car of " + list, list._car);
 64 |         return list._car;
 65 |     },
 66 | 
 67 |     cdr: function(list) {
 68 |         if(list == Types.NIL) return list; 
 69 |         Utils.assert("Can't take cdr of " + list, list._cdr);
 70 |         return list._cdr;
 71 |     },
 72 | 
 73 |     scar: function(cons, new_val) {
 74 |         Utils.assert(cons + ' is not a list', cons._car);
 75 |         cons._car = new_val;
 76 |         return new_val;
 77 |     },
 78 | 
 79 |     scdr: function(cons, new_val) {
 80 |         Utils.assert(cons + ' is not a list', cons._cdr);
 81 |         cons._cdr = new_val;
 82 |         return new_val;
 83 |     },
 84 | 
 85 |     /*----- Hashtables -----*/
 86 |     table: Types.table,
 87 | 
 88 |     /*----- Strings -----*/
 89 |     newstring: varargs(function(length, fill) {
 90 |         fill = fill != undefined ? fill.__to_js() : '\0';
 91 |         var str = '';
 92 |         for(var i = 0; i < length; ++i) {
 93 |             str += fill;
 94 |         }
 95 |         return Types.str(str);
 96 |     }, 1),
 97 | 
 98 |     /*----- Arithmetic -----*/
 99 |     '+': varargs(function() { 
100 |         var op = function(x, y) { return x + y; };
101 |         if(Utils.all(arguments, function(x) { return x.__teq('string'); })) {
102 |             op = function(x, y) { return x.toString() + y.toString(); };
103 |         } else if(Utils.all(arguments, function(x) { 
104 |                     return x.__teq("cons") || x == Types.NIL; })) {
105 |             op = function(x, y) { 
106 |                 var accum = x.__to_list ? x.__to_list() : x;
107 |                 return accum.concat(y.__to_list()); 
108 |             };
109 |         }
110 |             
111 |         var result = Utils.fold1(arguments, op);
112 |         if(result instanceof Array) {
113 |             return Types.list(result);
114 |         } else if(typeof result == 'string') {
115 |             return Types.str(result);
116 |         } else {
117 |             return Types.wrap_num(result)
118 |         }
119 |     }),
120 |     '-': varargs(function() { return Types.wrap_num(Utils.fold1(arguments, 'x - y')); }),
121 |     '*': varargs(function() { return Types.wrap_num(Utils.fold1(arguments, 'x * y')); }),
122 |     '/': varargs(function() { return Types.wrap_num(Utils.fold1(arguments, 'x / y')); }),
123 |     'mod': function(x, y) { return Types.int_(x % y); },
124 |     'expt': function(base, pow) { return Types.wrap_num(Math.pow(base, pow)); },
125 |     'sqrt': function(x) { return Types.wrap_num(Math.sqrt(x)); },
126 | 
127 |     '>': varargs(function() { return Types.bool(Utils.pairwise(arguments, true, 'x > y')); }),
128 |     '<': varargs(function() { return Types.bool(Utils.pairwise(arguments, true, 'x < y')); }),
129 | 
130 |     len: function(x) {
131 |         switch(x.__type().__to_js()) {
132 |             case 'cons': return Types.int_(x.__to_list().length);
133 |             case 'string': return Types.int_(x.length);
134 |             case 'table': return Types.int_(x.__length());
135 |             default: Utils.error(x.__type() + ' has no len method');
136 |         }
137 |     },
138 | 
139 |     rand: function(max) {
140 |         return Types.int_(Math.floor(Math.random() * max));
141 |     },
142 | 
143 |     // No-ops for now; dunno if they're doable in Javascript
144 |     truncate: Utils.id,
145 |     exact: Utils.id
146 | 
147 | };
148 | 
149 | })();
150 | 


--------------------------------------------------------------------------------
/reader.js:
--------------------------------------------------------------------------------
  1 | (function (t) {
  2 | /**
  3 |  * S-expression reader, capable of reading one or multiple S-expressions
  4 |  * out of a string of text and returning them as nested JavaScript lists.
  5 |  * 
  6 |  * @dependency buffer.js
  7 |  * @dependency types.js
  8 |  */
  9 | 
 10 | 
 11 | if(typeof window.Read != 'undefined') {
 12 |     var _read = window.Read;
 13 | }
 14 | 
 15 | function is_newline(c) {
 16 |     return c == '\n' || c == '\r';
 17 | };
 18 | 
 19 | function is_whitespace(c) {
 20 |     return c == ' ' ||  c == '\t' || is_newline(c);
 21 | };
 22 | 
 23 | function is_not_whitespace(c) {
 24 |     return !is_whitespace(c);
 25 | };
 26 | 
 27 | function is_delim(c) {
 28 |     return c === false || is_whitespace(c) || c == '(' || c == ')' 
 29 |         || c == '[' || c == ']';
 30 | };
 31 | 
 32 | function decorate_form(keyword, buffer, eat_char) {
 33 |     eat_char = eat_char == undefined ? true : eat_char;
 34 |     if(eat_char) {
 35 |         buffer.eat();
 36 |     }
 37 |     var form = read(buffer);
 38 |     buffer.read_until(is_not_whitespace);
 39 |     return Types.list([Types.sym(keyword), form]);
 40 | };
 41 | 
 42 | function read_token(buffer) {
 43 |     var token = buffer.read_until(is_delim);
 44 |     buffer.read_until(is_not_whitespace);
 45 |     return token;
 46 | };
 47 | 
 48 | function read_string(buffer) {
 49 |     function is_segment_break(c) {
 50 |         return c == '\\' || c == '"';
 51 |     };
 52 |     buffer.eat();   // "
 53 |     var str = '';
 54 |     while(buffer.peek() != '"') {
 55 |         if(buffer.peek() === false) {
 56 |             Utils.error('Unclosed string literal');
 57 |         }
 58 | 
 59 |         if(buffer.peek() == '\\') {
 60 |             buffer.eat()    // \
 61 |             var c = buffer.read();
 62 |             switch(c) {
 63 |                 case 'n': str += '\n'; break;
 64 |                 case 'r': str += '\r'; break;
 65 |                 case 't': str += '\t'; break;
 66 |                 case '"': str += '"'; break;
 67 |                 case '0': str += '\0'; break;
 68 |                 default: Utils.error('Invalid escape char: ' + c);
 69 |             }
 70 |         };
 71 |         str += buffer.read_until(is_segment_break);
 72 |     };
 73 |     buffer.eat();   // trailing "
 74 |     buffer.read_until(is_not_whitespace);
 75 |     return Types.str(str);
 76 | };
 77 | 
 78 | function read_delimited(delim, buffer) {
 79 |     var elements = [];
 80 | 
 81 |     buffer.eat();   // open (
 82 |     buffer.read_until(is_not_whitespace);
 83 |     var c;
 84 |     while((c = buffer.peek()) != delim) {
 85 |         if(c === false) {
 86 |             Utils.error('Unclosed delimiter');
 87 |         }
 88 |         elements.push(read(buffer));
 89 |     }
 90 |     buffer.eat();   // close )
 91 |     buffer.read_until(is_not_whitespace);
 92 | 
 93 |     var len = elements.length;
 94 |     if(len >= 3) {
 95 |         var is_dotted = false,
 96 |             possible_dot = elements[len - 2];
 97 |         if(possible_dot.__type().__eq('sym') && possible_dot.__eq('.')) {
 98 |             elements[len - 2] = elements[len - 1];
 99 |             elements.length--;
100 |             is_dotted = true;
101 |         }
102 |     }
103 | 
104 |     return Types.list(elements, is_dotted);
105 | };
106 | 
107 | function read_list(buffer) {
108 |     return read_delimited(')', buffer);
109 | };
110 | 
111 | function read_brackets(buffer) {
112 |     return Types.list([Types.sym('fn'), Types.list([Types.sym('_')]), 
113 |                        read_delimited(']', buffer)]);
114 | };
115 | 
116 | function parse_char_literal(token) {
117 |     var c = token.substr(2);
118 |     switch(c) {
119 |         case 'newline': return '\n';
120 |         case 'space': return ' ';
121 |         case 'tab': return '\t';
122 |         default: return c.charAt(0) == 'x' && c.length > 1 ? 
123 |             String.fromCharCode(parseInt(c.substr(1), 16)) : c;
124 |     };
125 | };
126 | 
127 | function parse_token(token) {
128 |     if(token.match(/^-?\d+\.\d+(e\d+)?$/i)) {
129 |         return Types.num(parseFloat(token));
130 |     } else if(token.match(/^-?\d+$/)) {
131 |         return Types.int_(parseInt(token));
132 |     } else if(token.match(/^#\\.+$/)) {
133 |         return Types.chr(parse_char_literal(token));
134 |     } else if(token == 'nil') {
135 |         return Types.NIL;
136 |     } else {
137 |         return Types.sym(token);
138 |     }
139 | };
140 | 
141 | function read(buffer) {
142 |     var c = buffer.peek();
143 |     switch(c) {
144 |         case false: return false;
145 |         case '"': return read_string(buffer);
146 |         case "'": return decorate_form('quote', buffer);
147 |         case '`': return decorate_form('quasiquote', buffer);
148 |         case '(': return read_list(buffer);
149 |         case '[': return read_brackets(buffer);
150 |         case ',':
151 |             buffer.eat();
152 |             if(buffer.peek() == '@') {
153 |                 return decorate_form('unquote-splicing', buffer);
154 |             } else {
155 |                 return decorate_form('unquote', buffer, false);
156 |             }
157 |         case ';': 
158 |             buffer.read_until(is_newline);
159 |             buffer.read_until(is_not_whitespace);
160 |             return read(buffer);
161 |         default: 
162 |             return parse_token(read_token(buffer));
163 |     }
164 | };
165 | 
166 | window.Read = function(text) {
167 |     if(!(text instanceof Buffer)) {
168 |         text = Buffer(text);
169 |     }
170 |     return read(text);
171 | };
172 | 
173 | Utils.extend(window.Read, {
174 |     no_conflict: function() {
175 |         window.Read = _read;
176 |         return read;
177 |     },
178 |     is_not_whitespace: is_not_whitespace,
179 | 
180 |     // Exposed for testing...
181 |     test: {
182 |         is_delim: is_delim,
183 |         is_not_whitespace: is_not_whitespace,
184 |         read_token: read_token
185 |     }
186 | });
187 | 
188 | })(Types);
189 | 


--------------------------------------------------------------------------------
/styles.css:
--------------------------------------------------------------------------------
 1 | h1 {
 2 |     text-align: center;
 3 | }
 4 | 
 5 | #inputLine, #outputWrap, #labelLine, #blockInput {
 6 |     display: block;
 7 |     margin: 0 auto;
 8 |     width: 60%;
 9 | }
10 | 
11 | #page {
12 |     width: 80%;
13 |     margin-left: auto;
14 |     margin-right: auto;
15 |     border: 1px solid black;
16 | }
17 | 
18 | p, ol, ul {
19 |     font-family: Helvetica, Arial, sans-serif;
20 |     margin-left: auto;
21 |     margin-right: auto;
22 |     width: 90%;
23 | }
24 | 
25 | #inputLine {
26 |     margin-bottom: 10px;
27 | }
28 | 
29 | #input {
30 |     width: 80%;
31 | }
32 | 
33 | #eval {
34 |     width: 15%;
35 | }
36 | 
37 | #labelLine label {
38 |     float: left;
39 |     width: 50%;
40 |     text-align: left;
41 | }
42 | 
43 | #labelLine a {
44 |     width: 50%;
45 |     float: left;
46 |     text-align: right;
47 | }
48 | 
49 | #blockInput {
50 |     clear: both;
51 | }
52 | 
53 | #blockInput textarea {
54 |     display: block;
55 |     height: 300px;
56 |     width: 100%;
57 | }
58 | 
59 | #blockInput button {
60 |     display: block;
61 |     margin-left: auto;
62 |     margin-right: auto;
63 | }
64 | 
65 | #outputWrap {
66 |     clear: both;
67 |     border: 1px solid black;
68 |     width: 60%;
69 |     height: 80px;
70 |     padding: 0;
71 | }
72 | 
73 | #output {
74 |     overflow-y: auto;
75 |     width: 99.5%;
76 |     height: 100%;
77 |     margin: 0;
78 |     padding: 0;
79 | }
80 | 
81 | .inputText, .outputText, .errorText {
82 |     width: 100%;
83 | }
84 | 
85 | .inputText {
86 |     color: black;
87 | }
88 | 
89 | .outputText {
90 |     color: green;
91 | }
92 | 
93 | .errorText {
94 |     color: red;
95 | }
96 | 


--------------------------------------------------------------------------------
/test/test_buffer.html:
--------------------------------------------------------------------------------
 1 | 
 2 | 
 3 | 
49 | 


--------------------------------------------------------------------------------
/test/test_eval.html:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | 
  4 | 
  5 | 
  6 | 
  7 | 
  8 | 
123 | 


--------------------------------------------------------------------------------
/test/test_primitives.html:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | 
  4 | 
  5 | 
  6 | 
115 | 


--------------------------------------------------------------------------------
/test/test_reader.html:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | 
  4 | 
  5 | 
  6 | 
139 | 


--------------------------------------------------------------------------------
/test/test_suite.html:
--------------------------------------------------------------------------------
 1 | 
 2 | 
13 | 


--------------------------------------------------------------------------------
/test/test_tutorial.html:
--------------------------------------------------------------------------------
   1 | 
   2 | ; Main Arc lib.  Ported to Scheme version Jul 06.
   3 | 
   4 | ; optimize ~foo in functional position in ac, like compose
   5 | ; rename: string, into-string (shorter).  could call intos string,
   6 | ;  but then what to call string?
   7 | ; get hold of error types within arc
   8 | ; why is macex defined in scheme instead of using def below?
   9 | ; write disp, read, write in arc
  10 | ; could prob write rmfile and dir in terms of system
  11 | ; could I get all of macros up into lib.arc?
  12 | 
  13 | ; any logical reason I can't say (push x (if foo y z)) ?
  14 | ;   eval would have to always ret 2 things, the val and where it came from
  15 | ; idea: implicit tables of tables; setf empty field, becomes table
  16 | ;   or should setf on a table just take n args?
  17 | ; idea: permanent objs that live on disk and are updated when modified
  18 | 
  19 | ; compromises in this implementation: 
  20 | ; no objs in code
  21 | ;  (mac testlit args (listtab args)) breaks when called
  22 | ; separate string type
  23 | ;  (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail
  24 | 
  25 | 
  26 | (set do (annotate 'mac
  27 |           (fn args `((fn () ,@args)))))
  28 | 
  29 | (set safeset (annotate 'mac
  30 |                (fn (var val)
  31 |                  `(do (if (bound ',var)
  32 |                           (do (disp "*** redefining ")
  33 |                               (disp ',var)
  34 |                               (writec #\newline)))
  35 |                       (set ,var ,val)))))
  36 | 
  37 | (set def (annotate 'mac
  38 |             (fn (name parms . body)
  39 |               `(do (sref sig ',parms ',name)
  40 |                    (safeset ,name (fn ,parms ,@body))))))
  41 | 
  42 | (def caar (xs) (car (car xs)))
  43 | (def cadr (xs) (car (cdr xs)))
  44 | (def cddr (xs) (cdr (cdr xs)))
  45 | 
  46 | (def no (x) (is x nil))
  47 | 
  48 | (def acons (x) (is (type x) 'cons))
  49 | 
  50 | (def atom (x) (no (acons x)))
  51 | 
  52 | (def list args args)
  53 | 
  54 | (def idfn (x) x)
  55 | 
  56 | ; Maybe later make this internal.
  57 | 
  58 | (def map1 (f xs)
  59 |   (if (no xs) 
  60 |       nil
  61 |       (cons (f (car xs)) (map1 f (cdr xs)))))
  62 | 
  63 | (def pair (xs (o f list))
  64 |   (if (no xs)
  65 |        nil
  66 |       (no (cdr xs))
  67 |        (list (list (car xs)))
  68 |       (cons (f (car xs) (cadr xs))
  69 |             (pair (cddr xs) f))))
  70 | 
  71 | (set mac (annotate 'mac
  72 |            (fn (name parms . body)
  73 |              `(do (sref sig ',parms ',name)
  74 |                   (safeset ,name (annotate 'mac (fn ,parms ,@body)))))))
  75 | 
  76 | (mac and args
  77 |   (if args
  78 |       (if (cdr args)
  79 |           `(if ,(car args) (and ,@(cdr args)))
  80 |           (car args))
  81 |       't))
  82 | 
  83 | (def assoc (key al)
  84 |   (if (atom al)
  85 |        nil
  86 |       (and (acons (car al)) (is (caar al) key))
  87 |        (car al)
  88 |       (assoc key (cdr al))))
  89 | 
  90 | (def alref (al key) (cadr (assoc key al)))
  91 | 
  92 | (mac with (parms . body)
  93 |   `((fn ,(map1 car (pair parms))
  94 |      ,@body)
  95 |     ,@(map1 cadr (pair parms))))
  96 | 
  97 | (mac let (var val . body)
  98 |   `(with (,var ,val) ,@body))
  99 | 
 100 | (mac withs (parms . body)
 101 |   (if (no parms) 
 102 |       `(do ,@body)
 103 |       `(let ,(car parms) ,(cadr parms) 
 104 |          (withs ,(cddr parms) ,@body))))
 105 | 
 106 | ; Rtm prefers to overload + to do this
 107 | 
 108 | (def join args
 109 |   (if (no args)
 110 |       nil
 111 |       (let a (car args) 
 112 |         (if (no a) 
 113 |             (apply join (cdr args))
 114 |             (cons (car a) (apply join (cdr a) (cdr args)))))))
 115 | 
 116 | ; Need rfn for use in macro expansions.
 117 | 
 118 | (mac rfn (name parms . body)
 119 |   `(let ,name nil
 120 |      (set ,name (fn ,parms ,@body))))
 121 | 
 122 | (mac afn (parms . body)
 123 |   `(let self nil
 124 |      (set self (fn ,parms ,@body))))
 125 | 
 126 | ; Ac expands x:y:z into (compose x y z), ~x into (complement x)
 127 | 
 128 | ; Only used when the call to compose doesn't occur in functional position.  
 129 | ; Composes in functional position are transformed away by ac.
 130 | 
 131 | (mac compose args
 132 |   (let g (uniq)
 133 |     `(fn ,g
 134 |        ,((afn (fs)
 135 |            (if (cdr fs)
 136 |                (list (car fs) (self (cdr fs)))
 137 |                `(apply ,(if (car fs) (car fs) 'idfn) ,g)))
 138 |          args))))
 139 | 
 140 | (mac complement (f)
 141 |   (let g (uniq)
 142 |     `(fn ,g (no (apply ,f ,g)))))
 143 | 
 144 | (def rev (xs) 
 145 |   ((afn (xs acc)
 146 |      (if (no xs)
 147 |          acc
 148 |          (self (cdr xs) (cons (car xs) acc))))
 149 |    xs nil))
 150 | 
 151 | (def isnt (x y) (no (is x y)))
 152 | 
 153 | (mac w/uniq (names . body)
 154 |   (if (acons names)
 155 |       `(with ,(apply + nil (map1 (fn (n) (list n '(uniq)))
 156 |                              names))
 157 |          ,@body)
 158 |       `(let ,names (uniq) ,@body)))
 159 | 
 160 | (mac or args
 161 |   (and args
 162 |        (w/uniq g
 163 |          `(let ,g ,(car args)
 164 |             (if ,g ,g (or ,@(cdr args)))))))
 165 | 
 166 | (def alist (x) (or (no x) (is (type x) 'cons)))
 167 | 
 168 | (mac in (x . choices)
 169 |   (w/uniq g
 170 |     `(let ,g ,x
 171 |        (or ,@(map1 (fn (c) `(is ,g ,c)) choices)))))
 172 | 
 173 | ; should take n args
 174 | 
 175 | (def iso (x y)
 176 |   (or (is x y)
 177 |       (and (acons x) 
 178 |            (acons y) 
 179 |            (iso (car x) (car y)) 
 180 |            (iso (cdr x) (cdr y)))))
 181 | 
 182 | (mac when (test . body)
 183 |   `(if ,test (do ,@body)))
 184 | 
 185 | (mac unless (test . body)
 186 |   `(if (no ,test) (do ,@body)))
 187 | 
 188 | (mac while (test . body)
 189 |   (w/uniq (gf gp)
 190 |     `((rfn ,gf (,gp)
 191 |         (when ,gp ,@body (,gf ,test)))
 192 |       ,test)))
 193 | 
 194 | (def empty (seq) 
 195 |   (or (no seq) 
 196 |       (and (no (acons seq)) (is (len seq) 0))))
 197 | 
 198 | (def reclist (f xs)
 199 |   (and xs (or (f xs) (reclist f (cdr xs)))))
 200 | 
 201 | (def recstring (test s (o start 0))
 202 |   (let n (len s)
 203 |     ((afn (i)
 204 |        (and (< i (len s))
 205 |             (or (test i)
 206 |                 (self (+ i 1)))))
 207 |      start)))
 208 | 
 209 | (def testify (x)
 210 |   (if (isa x 'fn) x [is _ x]))
 211 | 
 212 | (def some (test seq)
 213 |   (let f (testify test)
 214 |     (if (alist seq)
 215 |         (reclist f:car seq)
 216 |         (recstring f:seq seq))))
 217 | 
 218 | (def all (test seq) 
 219 |   (~some (complement (testify test)) seq))
 220 |        
 221 | (def mem (test seq)
 222 |   (let f (testify test)
 223 |     (reclist [if (f:car _) _] seq)))
 224 | 
 225 | (def find (test seq)
 226 |   (let f (testify test)
 227 |     (if (alist seq)
 228 |         (reclist   [if (f:car _) (car _)] seq)
 229 |         (recstring [if (f:seq _) (seq _)] seq))))
 230 | 
 231 | (def isa (x y) (is (type x) y))
 232 | 
 233 | ; Possible to write map without map1, but makes News 3x slower.
 234 | 
 235 | ;(def map (f . seqs)
 236 | ;  (if (some1 no seqs)
 237 | ;       nil
 238 | ;      (no (cdr seqs))
 239 | ;       (let s1 (car seqs)
 240 | ;         (cons (f (car s1))
 241 | ;               (map f (cdr s1))))
 242 | ;      (cons (apply f (map car seqs))
 243 | ;            (apply map f (map cdr seqs)))))
 244 | 
 245 | 
 246 | (def map (f . seqs)
 247 |   (if (some [isa _ 'string] seqs) 
 248 |        (withs (n   (apply min (map len seqs))
 249 |                new (newstring n))
 250 |          ((afn (i)
 251 |             (if (is i n)
 252 |                 new
 253 |                 (do (sref new (apply f (map [_ i] seqs)) i)
 254 |                     (self (+ i 1)))))
 255 |           0))
 256 |       (no (cdr seqs)) 
 257 |        (map1 f (car seqs))
 258 |       ((afn (seqs)
 259 |         (if (some no seqs)  
 260 |             nil
 261 |             (cons (apply f (map1 car seqs))
 262 |                   (self (map1 cdr seqs)))))
 263 |        seqs)))
 264 | 
 265 | (def mappend (f . args)
 266 |   (apply + nil (apply map f args)))
 267 | 
 268 | (def firstn (n xs)
 269 |   (if (and (> n 0) xs)
 270 |       (cons (car xs) (firstn (- n 1) (cdr xs)))
 271 |       nil))
 272 | 
 273 | (def nthcdr (n xs)
 274 |   (if (> n 0)
 275 |       (nthcdr (- n 1) (cdr xs))
 276 |       xs))
 277 | 
 278 | ; Generalization of pair: (tuples x) = (pair x)
 279 | 
 280 | (def tuples (xs (o n 2))
 281 |   (if (no xs)
 282 |       nil
 283 |       (cons (firstn n xs)
 284 |             (tuples (nthcdr n xs) n))))
 285 | 
 286 | (def caris (x val) (and (acons x) (is (car x) val)))
 287 | 
 288 | (def warn (msg . args)
 289 |   (disp (+ "Warning: " msg ". "))
 290 |   (map [do (write _) (disp " ")] args)
 291 |   (disp #\newline))
 292 | 
 293 | (mac atomic body
 294 |   `(atomic-invoke (fn () ,@body)))
 295 | 
 296 | (mac atlet args
 297 |   `(atomic (let ,@args)))
 298 |   
 299 | (mac atwith args
 300 |   `(atomic (with ,@args)))
 301 | 
 302 | (mac atwiths args
 303 |   `(atomic (withs ,@args)))
 304 | 
 305 | ; setforms returns (vars get set) for a place based on car of an expr
 306 | ;  vars is a list of gensyms alternating with expressions whose vals they
 307 | ;   should be bound to, suitable for use as first arg to withs
 308 | ;  get is an expression returning the current value in the place
 309 | ;  set is an expression representing a function of one argument
 310 | ;   that stores a new value in the place
 311 | 
 312 | ; A bit gross that it works based on the *name* in the car, but maybe
 313 | ; wrong to worry.  Macros live in expression land.
 314 | 
 315 | ; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons.
 316 | ; can't in cl though.  could I define a setter for push or pop?
 317 | 
 318 | (set setter (table))
 319 | 
 320 | (mac defset (name parms . body)
 321 |   (w/uniq gexpr
 322 |     `(sref setter 
 323 |            (fn (,gexpr)
 324 |              (let ,parms (cdr ,gexpr)
 325 |                ,@body))
 326 |            ',name)))
 327 | 
 328 | (defset car (x)
 329 |   (w/uniq g
 330 |     (list (list g x)
 331 |           `(car ,g)
 332 |           `(fn (val) (scar ,g val)))))
 333 | 
 334 | (defset cdr (x)
 335 |   (w/uniq g
 336 |     (list (list g x)
 337 |           `(cdr ,g)
 338 |           `(fn (val) (scdr ,g val)))))
 339 | 
 340 | (defset caar (x)
 341 |   (w/uniq g
 342 |     (list (list g x)
 343 |           `(caar ,g)
 344 |           `(fn (val) (scar (car ,g) val)))))
 345 | 
 346 | (defset cadr (x)
 347 |   (w/uniq g
 348 |     (list (list g x)
 349 |           `(cadr ,g)
 350 |           `(fn (val) (scar (cdr ,g) val)))))
 351 | 
 352 | (defset cddr (x)
 353 |   (w/uniq g
 354 |     (list (list g x)
 355 |           `(cddr ,g)
 356 |           `(fn (val) (scdr (cdr ,g) val)))))
 357 | 
 358 | ; Note: if expr0 macroexpands into any expression whose car doesn't
 359 | ; have a setter, setforms assumes it's a data structure in functional 
 360 | ; position.  Such bugs will be seen only when the code is executed, when 
 361 | ; sref complains it can't set a reference to a function.
 362 | 
 363 | (def setforms (expr0)
 364 |   (let expr (macex expr0)
 365 |     (if (isa expr 'sym)
 366 |          (w/uniq (g h)
 367 |            (list (list g expr) 
 368 |                  g
 369 |                  `(fn (,h) (set ,expr ,h))))
 370 |         ; make it also work for uncompressed calls to compose
 371 |         (and (acons expr) (metafn (car expr)))
 372 |          (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr)))
 373 |          (let f (setter (car expr))
 374 |            (if f
 375 |                (f expr)
 376 |                ; assumed to be data structure in fn position
 377 |                (do (when (caris (car expr) 'fn)
 378 |                      (warn "Inverting what looks like a function call" 
 379 |                            expr0 expr))
 380 |                    (w/uniq (g h)
 381 |                      (let argsyms (map [uniq] (cdr expr))
 382 |                         (list (+ (list g (car expr))
 383 |                                  (mappend list argsyms (cdr expr)))
 384 |                               `(,g ,@argsyms)
 385 |                               `(fn (,h) (sref ,g ,h ,@argsyms)))))))))))
 386 | 
 387 | (def metafn (x)
 388 |   (or (ssyntax x)
 389 |       (and (acons x) (in (car x) 'compose 'complement))))
 390 | 
 391 | (def expand-metafn-call (f args)
 392 |   (if (is (car f) 'compose)
 393 |       ((afn (fs)
 394 |          (if (caris (car fs) 'compose)            ; nested compose
 395 |               (self (join (cdr (car fs)) (cdr fs)))
 396 |              (cdr fs)
 397 |               (list (car fs) (self (cdr fs)))
 398 |              (cons (car fs) args)))
 399 |        (cdr f))
 400 |       (err "Can't invert " (cons f args))))
 401 | 
 402 | (def expand= (place val)
 403 |   (if (isa place 'sym)
 404 |       `(set ,place ,val)
 405 |       (let (vars prev setter) (setforms place)
 406 |         (w/uniq g
 407 |           `(atwith ,(+ vars (list g val))
 408 |              (,setter ,g))))))
 409 | 
 410 | (def expand=list (terms)
 411 |   `(do ,@(map (fn ((p v)) (expand= p v))  ; [apply expand= _]
 412 |                   (pair terms))))
 413 | 
 414 | (mac = args
 415 |   (expand=list args))
 416 | 
 417 | (mac loop (start test update . body)
 418 |   (w/uniq (gfn gparm)
 419 |     `(do ,start
 420 |          ((rfn ,gfn (,gparm) 
 421 |             (if ,gparm
 422 |                 (do ,@body ,update (,gfn ,test))))
 423 |           ,test))))
 424 | 
 425 | (mac for (v init max . body)
 426 |   (w/uniq (gi gm)
 427 |     `(with (,v nil ,gi ,init ,gm (+ ,max 1))
 428 |        (loop (set ,v ,gi) (< ,v ,gm) (set ,v (+ ,v 1))
 429 |          ,@body))))
 430 | 
 431 | (mac repeat (n . body)
 432 |   `(for ,(uniq) 1 ,n ,@body))
 433 | 
 434 | ; could bind index instead of gensym
 435 | 
 436 | (mac each (var expr . body)
 437 |   (w/uniq (gseq g)
 438 |     `(let ,gseq ,expr
 439 |        (if (alist ,gseq)
 440 |             ((afn (,g)
 441 |                (when (acons ,g)
 442 |                  (let ,var (car ,g) ,@body)
 443 |                  (self (cdr ,g))))
 444 |              ,gseq)
 445 |            (isa ,gseq 'table)
 446 |             (maptable (fn (,g ,var) ,@body)
 447 |                       ,gseq)
 448 |             (for ,g 0 (- (len ,gseq) 1)
 449 |               (let ,var (,gseq ,g) ,@body))))))
 450 | 
 451 | ; (nthcdr x y) = (subseq y x).
 452 | 
 453 | (def subseq (seq start (o end (len seq)))
 454 |   (if (isa seq 'string)
 455 |       (let s2 (newstring (- end start))
 456 |         (for i 0 (- end start 1)
 457 |           (= (s2 i) (seq (+ start i))))
 458 |         s2)
 459 |       (firstn (- end start) (nthcdr start seq))))
 460 |       
 461 | (mac ontable (k v h . body)
 462 |   `(maptable (fn (,k ,v) ,@body) ,h))
 463 | 
 464 | (mac whilet (var test . body)
 465 |   (w/uniq (gf gp)
 466 |     `((rfn ,gf (,gp)
 467 |         (let ,var ,gp
 468 |           (when ,var ,@body (,gf ,test))))
 469 |       ,test)))
 470 | 
 471 | (def last (seq)
 472 |   (if (no (cdr seq))
 473 |       (car seq)
 474 |       (last (cdr seq))))
 475 | 
 476 | (def rem (test seq)
 477 |   (let f (testify test)
 478 |     (if (alist seq)
 479 |         ((afn (s)
 480 |            (if (no s)       nil
 481 |                (f (car s))  (self (cdr s))
 482 |                             (cons (car s) (self (cdr s)))))
 483 |           seq)
 484 |         (coerce (rem test (coerce seq 'cons)) 'string))))
 485 | 
 486 | (def keep (test seq) 
 487 |   (rem (complement (testify test)) seq))
 488 | 
 489 | (def trues (f seq) (rem nil (map f seq)))
 490 | 
 491 | (mac do1 args
 492 |   (w/uniq g
 493 |     `(let ,g ,(car args)
 494 |        ,@(cdr args)
 495 |        ,g)))
 496 | 
 497 | ; Would like to write a faster case based on table generated by a macro,
 498 | ; but can't insert objects into expansions in Mzscheme.
 499 | 
 500 | (mac caselet (var expr . args)
 501 |   (let ex (afn (args)
 502 |             (if (no (cdr args)) 
 503 |                 (car args)
 504 |                 `(if (is ,var ',(car args))
 505 |                      ,(cadr args)
 506 |                      ,(self (cddr args)))))
 507 |     `(let ,var ,expr ,(ex args))))
 508 | 
 509 | (mac case (expr . args)
 510 |   `(caselet ,(uniq) ,expr ,@args))
 511 | 
 512 | (mac push (x place)
 513 |   (w/uniq gx
 514 |     (let (binds val setter) (setforms place)
 515 |       `(let ,gx ,x
 516 |          (atwiths ,binds
 517 |            (,setter (cons ,gx ,val)))))))
 518 | 
 519 | (mac swap (place1 place2)
 520 |   (w/uniq (g1 g2)
 521 |     (with ((binds1 val1 setter1) (setforms place1)
 522 |            (binds2 val2 setter2) (setforms place2))
 523 |       `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2))
 524 |          (,setter1 ,g2)
 525 |          (,setter2 ,g1)))))
 526 | 
 527 | (mac rotate places
 528 |   (with (vars (map [uniq] places)
 529 |          forms (map setforms places))
 530 |     `(atwiths ,(mappend (fn (g (binds val setter))
 531 |                           (+ binds (list g val)))
 532 |                         vars
 533 |                         forms)
 534 |        ,@(map (fn (g (binds val setter))
 535 |                 (list setter g))
 536 |               (+ (cdr vars) (list (car vars)))
 537 |               forms))))
 538 | 
 539 | (mac pop (place)
 540 |   (w/uniq g
 541 |     (let (binds val setter) (setforms place)
 542 |       `(atwiths ,(+ binds (list g val))
 543 |          (do1 (car ,g) 
 544 |               (,setter (cdr ,g)))))))
 545 | 
 546 | (def adjoin (x xs (o test iso))
 547 |   (if (some [test x _] xs)
 548 |       xs
 549 |       (cons x xs)))
 550 | 
 551 | (mac pushnew (x place . args)
 552 |   (w/uniq gx
 553 |     (let (binds val setter) (setforms place)
 554 |       `(atwiths ,(+ (list gx x) binds)
 555 |          (,setter (adjoin ,gx ,val ,@args))))))
 556 | 
 557 | (mac pull (test place)
 558 |   (w/uniq g
 559 |     (let (binds val setter) (setforms place)
 560 |       `(atwiths ,(+ (list g test) binds)
 561 |          (,setter (rem ,g ,val))))))
 562 | 
 563 | (mac ++ (place (o i 1))
 564 |   (if (isa place 'sym)
 565 |       `(= ,place (+ ,place ,i))
 566 |       (w/uniq gi
 567 |         (let (binds val setter) (setforms place)
 568 |           `(atwiths ,(+ binds (list gi i))
 569 |              (,setter (+ ,val ,gi)))))))
 570 | 
 571 | (mac -- (place (o i 1))
 572 |   (if (isa place 'sym)
 573 |       `(= ,place (- ,place ,i))
 574 |       (w/uniq gi
 575 |         (let (binds val setter) (setforms place)
 576 |           `(atwiths ,(+ binds (list gi i))
 577 |              (,setter (- ,val ,gi)))))))
 578 | 
 579 | ; E.g. (inc x) equiv to (zap + x 1)
 580 | 
 581 | (mac zap (op place . args)
 582 |   (with (gop    (uniq)
 583 |          gargs  (map [uniq] args)
 584 |          mix    (afn seqs 
 585 |                   (if (some no seqs)
 586 |                       nil
 587 |                       (+ (map car seqs)
 588 |                          (apply self (map cdr seqs))))))
 589 |     (let (binds val setter) (setforms place)
 590 |       `(atwiths ,(+ binds (list gop op) (mix gargs args))
 591 |          (,setter (,gop ,val ,@gargs))))))
 592 | 
 593 | ; Can't simply mod pr to print strings represented as lists of chars,
 594 | ; because empty string will get printed as nil.  Would need to rep strings
 595 | ; as lists of chars annotated with 'string, and modify car and cdr to get
 596 | ; the rep of these.  That would also require hacking the reader.  
 597 | 
 598 | ;(def pr args
 599 | ;  (if (isa (car args) 'output)
 600 | ;      (do (error "stream arg!" args)
 601 | ;          (map1 [disp _ (car args)] (cdr args))
 602 | ;          (cadr args))
 603 | ;      (do (map1 disp args)
 604 | ;          (car args))))
 605 | 
 606 | (def pr args
 607 |   (map1 disp args)
 608 |   (car args))
 609 | 
 610 | ; Rtm says this version should make the server 20% faster because map1
 611 | ; generates so much garbage; in fact makes slower; maybe rewrite map1?
 612 | 
 613 | ;(def newpr args
 614 | ;  (if (isa (car args) 'output)
 615 | ;      (do (each a (cdr args) (disp a (car args)))
 616 | ;          (cadr args))
 617 | ;      (do (each a args (disp a))
 618 | ;          (car args))))
 619 | 
 620 | (def prn args
 621 |   (do1 (apply pr args)
 622 |        (writec #\newline
 623 |                (if (isa (car args) 'output) (car args) (stdout)))))
 624 | 
 625 | (mac nil! args
 626 |   `(do ,@(map (fn (a) `(= ,a nil)) args)))
 627 | 
 628 | (mac t! args
 629 |   `(do ,@(map (fn (a) `(= ,a t)) args)))
 630 | 
 631 | ; Destructing means ambiguity: are pat vars bound in else? (no)
 632 | 
 633 | (mac iflet (var expr then . rest)
 634 |   (w/uniq gv
 635 |     `(let ,gv ,expr
 636 |        (if ,gv (let ,var ,gv ,then) ,@rest))))
 637 | 
 638 | (mac whenlet (var expr . body)
 639 |   `(iflet ,var ,expr (do ,@body)))
 640 | 
 641 | (mac aif (expr . body)
 642 |   `(let it ,expr (if it ,@body)))
 643 | 
 644 | (mac awhen (expr . body)
 645 |   `(let it ,expr (if it (do ,@body))))
 646 | 
 647 | (mac aand args
 648 |   (if (no args)
 649 |       't 
 650 |       (no (cdr args))
 651 |        (car args)
 652 |       `(let it ,(car args) (and it (aand ,@(cdr args))))))
 653 | 
 654 | (mac accum (accfn . body)
 655 |   (w/uniq gacc
 656 |     `(withs (,gacc nil ,accfn [push _ ,gacc])
 657 |        ,@body
 658 |        ,gacc)))
 659 | 
 660 | ; Repeatedly evaluates its body till it returns nil, then returns vals.
 661 | 
 662 | (mac drain (expr (o eof nil))
 663 |   (w/uniq (gacc gdone gres)
 664 |     `(with (,gacc nil ,gdone nil)
 665 |        (while (no ,gdone)
 666 |          (let ,gres ,expr
 667 |            (if (is ,gres ,eof)
 668 |                (= ,gdone t)
 669 |                (push ,gres ,gacc))))
 670 |        (rev ,gacc))))
 671 | 
 672 | ; For the common C idiom while x = snarfdata != stopval.
 673 | ; Rename this if use it often.
 674 | 
 675 | (mac whiler (var expr endval . body)
 676 |   (w/uniq gf
 677 |     `((rfn ,gf (,var)
 678 |         (when (and ,var (no (is ,var ,endval)))
 679 |           ,@body 
 680 |           (,gf ,expr)))
 681 |       ,expr)))
 682 |   
 683 | ;(def macex (e)
 684 | ;  (if (atom e)
 685 | ;      e
 686 | ;      (let op (and (atom (car e)) (eval (car e)))
 687 | ;        (if (isa op 'mac)
 688 | ;            (apply (rep op) (cdr e))
 689 | ;            e))))
 690 | 
 691 | (def consif (x y) (if x (cons x y) y))
 692 | 
 693 | (def string args
 694 |   (apply + "" (map [coerce _ 'string] args)))
 695 | 
 696 | (def flat (x (o stringstoo))
 697 |   ((rfn f (x acc)
 698 |      (if (or (no x) (and stringstoo (is x "")))
 699 |           acc
 700 |          (and (atom x) (no (and stringstoo (isa x 'string))))
 701 |           (cons x acc)
 702 |          (f (car x) (f (cdr x) acc))))
 703 |    x nil))
 704 | 
 705 | ; Perhaps not the final idea, or at least final name
 706 |         
 707 | (mac default (x test alt)
 708 |   (w/uniq gx
 709 |     `(let ,gx ,x
 710 |        (if (,test ,gx) ,gx ,alt))))
 711 | 
 712 | (def pos (test seq (o start 0))
 713 |   (let f (testify test)
 714 |     (if (alist seq)
 715 |         ((afn (seq n)
 716 |            (if (no seq)   
 717 |                 nil
 718 |                (f (car seq)) 
 719 |                 n
 720 |                (self (cdr seq) (+ n 1))))
 721 |          (nthcdr start seq) 
 722 |          start)
 723 |         (recstring [if (f (seq _)) _] seq start))))
 724 | 
 725 | (def even (n) (is (mod n 2) 0))
 726 | 
 727 | (def odd (n) (no (even n)))
 728 | 
 729 | (mac after (x . ys)
 730 |   `(protect (fn () ,x) (fn () ,@ys)))
 731 | 
 732 | (let expander 
 733 |      (fn (f var name body)
 734 |        `(let ,var (,f ,name)
 735 |           (after (do ,@body) (close ,var))))
 736 | 
 737 |   (mac w/infile (var name . body)
 738 |     (expander 'infile var name body))
 739 | 
 740 |   (mac w/outfile (var name . body)
 741 |     (expander 'outfile var name body))
 742 | 
 743 |   (mac w/instring (var str . body)
 744 |     (expander 'instring var str body))
 745 |   )
 746 | 
 747 | (mac w/outstring (var . body)
 748 |   `(let ,var (outstring) ,@body))
 749 | 
 750 | (mac w/appendfile (var name . body)
 751 |   `(let ,var (outfile ,name 'append)
 752 |      (after (do ,@body) (close ,var))))
 753 | 
 754 | ; rename this simply "to"?  - prob not; rarely use
 755 | 
 756 | (mac w/stdout (str . body)
 757 |   `(call-w/stdout ,str (fn () ,@body)))
 758 | 
 759 | (mac w/stdin (str . body)
 760 |   `(call-w/stdin ,str (fn () ,@body)))
 761 | 
 762 | (mac tostring body
 763 |   (w/uniq gv
 764 |    `(w/outstring ,gv
 765 |       (w/stdout ,gv ,@body)
 766 |       (inside ,gv))))
 767 | 
 768 | (mac fromstring (str . body)
 769 |   (w/uniq gv
 770 |    `(w/instring ,gv ,str
 771 |       (w/stdin ,gv ,@body))))
 772 | 
 773 | (def readstring1 (s (o eof nil)) (w/instring i s (read i eof)))
 774 | 
 775 | (def read ((o x (stdin)) (o eof nil))
 776 |   (if (isa x 'string) (readstring1 x eof) (sread x eof)))
 777 | 
 778 | (def readfile (name) (w/infile s name (drain (read s))))
 779 | 
 780 | (def readfile1 (name) (w/infile s name (read s)))
 781 | 
 782 | (def writefile1 (val name) (w/outfile s name (write val s)) val)
 783 | 
 784 | (def readall (src (o eof nil))
 785 |   ((afn (i)
 786 |     (let x (read i eof)
 787 |       (if (is x eof)
 788 |           nil
 789 |           (cons x (self i)))))
 790 |    (if (isa src 'string) (instring src) src)))
 791 | 
 792 | (def sym (x) (coerce x 'sym))
 793 | 
 794 | (mac rand-choice exprs
 795 |   `(case (rand ,(len exprs))
 796 |      ,@(let key -1 
 797 |          (mappend [list (++ key) _]
 798 |                   exprs))))
 799 | 
 800 | (mac n-of (n expr)
 801 |   (w/uniq ga
 802 |     `(let ,ga nil     
 803 |        (repeat ,n (push ,expr ,ga))
 804 |        (rev ,ga))))
 805 | 
 806 | (def rand-string (n)
 807 |   (with (cap (fn () (+ 65 (rand 26)))
 808 |          sm  (fn () (+ 97 (rand 26)))
 809 |          dig (fn () (+ 48 (rand 10))))
 810 |     (coerce (map [coerce _ 'char]
 811 |                  (cons (rand-choice (cap) (sm))
 812 |                        (n-of (- n 1) (rand-choice (cap) (sm) (dig)))))
 813 |             'string)))
 814 | 
 815 | (mac forlen (var s . body)
 816 |   `(for ,var 0 (- (len ,s) 1) ,@body))
 817 | 
 818 | (mac on (var s . body)
 819 |   (if (is var 'index)
 820 |       (err "Can't use index as first arg to on.")
 821 |       (w/uniq gs
 822 |         `(let ,gs ,s
 823 |            (forlen index ,gs
 824 |              (let ,var (,gs index)
 825 |                ,@body))))))
 826 | 
 827 | (def best (f seq)
 828 |   (if (no seq)
 829 |       nil
 830 |       (let wins (car seq)
 831 |         (each elt (cdr seq)
 832 |           (if (f elt wins) (= wins elt)))
 833 |         wins)))
 834 |               
 835 | (def max args (best > args))
 836 | (def min args (best < args))
 837 | 
 838 | ; (mac max2 (x y)
 839 | ;   (w/uniq (a b)
 840 | ;     `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b))))
 841 | 
 842 | (def most (f seq) 
 843 |   (unless (no seq)
 844 |     (withs (wins (car seq) topscore (f wins))
 845 |       (each elt (cdr seq)
 846 |         (let score (f elt)
 847 |           (if (> score topscore) (= wins elt topscore score))))
 848 |       wins)))
 849 | 
 850 | ; Insert so that list remains sorted.  Don't really want to expose
 851 | ; these but seem to have to because can't include a fn obj in a 
 852 | ; macroexpansion.
 853 |   
 854 | (def insert-sorted (test elt seq)
 855 |   (if (no seq)
 856 |        (list elt) 
 857 |       (test elt (car seq)) 
 858 |        (cons elt seq)
 859 |       (cons (car seq) (insert-sorted test elt (cdr seq)))))
 860 | 
 861 | (mac insort (test elt seq)
 862 |   `(zap [insert-sorted ,test ,elt _] ,seq))
 863 | 
 864 | (def reinsert-sorted (test elt seq)
 865 |   (if (no seq) 
 866 |        (list elt) 
 867 |       (is elt (car seq))
 868 |        (reinsert-sorted test elt (cdr seq))
 869 |       (test elt (car seq)) 
 870 |        (cons elt (rem elt seq))
 871 |       (cons (car seq) (reinsert-sorted test elt (cdr seq)))))
 872 | 
 873 | (mac insortnew (test elt seq)
 874 |   `(zap [reinsert-sorted ,test ,elt _] ,seq))
 875 | 
 876 | ; Could make this look at the sig of f and return a fn that took the 
 877 | ; right no of args and didn't have to call apply (or list if 1 arg).
 878 | 
 879 | (def memo (f)
 880 |   (let cache (table)
 881 |     (fn args
 882 |       (or (cache args)
 883 |           (= (cache args) (apply f args))))))
 884 | 
 885 | (mac defmemo (name parms . body)
 886 |   `(safeset ,name (memo (fn ,parms ,@body))))
 887 | 
 888 | (def <= args
 889 |   (or (no args) 
 890 |       (no (cdr args))
 891 |       (and (no (> (car args) (cadr args)))
 892 |            (apply <= (cdr args)))))
 893 | 
 894 | (def >= args
 895 |   (or (no args) 
 896 |       (no (cdr args))
 897 |       (and (no (< (car args) (cadr args)))
 898 |            (apply >= (cdr args)))))
 899 |               
 900 | (def whitec (c)
 901 |   (in c #\space #\newline #\tab #\return))
 902 | 
 903 | (def nonwhite (c) (no (whitec c)))
 904 | 
 905 | (def alphadig (c)
 906 |   (or (<= #\a c #\z) (<= #\A c #\Z) (<= #\0 c #\9)))
 907 | 
 908 | (def punc (c)
 909 |   (in c #\. #\, #\; #\: #\! #\?))
 910 | 
 911 | (def readline ((o str (stdin)))
 912 |   (awhen (readc str)
 913 |     (tostring 
 914 |       (writec it)
 915 |       (whiler c (readc str) #\newline
 916 |         (writec c)))))
 917 | 
 918 | ; Don't currently use this but suspect some code could.
 919 | 
 920 | (mac summing (sumfn . body)
 921 |   (w/uniq (gc gt)
 922 |     `(let ,gc 0
 923 |        (let ,sumfn (fn (,gt) (if ,gt (++ ,gc)))
 924 |          ,@body)
 925 |        ,gc)))
 926 | 
 927 | (def trav (f base tree)
 928 |   (if (atom tree)
 929 |       (base tree)
 930 |       (f (trav f base (car tree)) (trav f base (cdr tree)))))
 931 | 
 932 | (def carif (x) (if (atom x) x (car x)))
 933 | 
 934 | ; Could prob be generalized beyond printing.
 935 | 
 936 | (def prall (elts (o init "") (o sep ", "))
 937 |   (when elts
 938 |     (pr init (car elts))
 939 |     (map [pr sep _] (cdr elts))
 940 |     elts))
 941 |              
 942 | (def prs args     
 943 |   (prall args "" #\space))
 944 | 
 945 | (def tree-subst (old new tree)
 946 |   (if (is tree old)
 947 |        new
 948 |       (atom tree)
 949 |        tree
 950 |       (cons (tree-subst old new (car tree))
 951 |             (tree-subst old new (cdr tree)))))
 952 | 
 953 | (def ontree (f tree)
 954 |   (f tree)
 955 |   (unless (atom tree)
 956 |     (ontree f (car tree))
 957 |     (ontree f (cdr tree))))
 958 | 
 959 | (def dotted (x)
 960 |   (if (atom x)
 961 |       nil
 962 |       (and (cdr x) (or (atom (cdr x))
 963 |                        (dotted (cdr x))))))
 964 | 
 965 | (def fill-table (table data)
 966 |   (each (k v) (pair data) (= (table k) v))
 967 |   table)
 968 | 
 969 | (mac obj args
 970 |   (w/uniq g
 971 |     `(let ,g (table)
 972 |        ,@(map (fn ((k v)) `(= (,g ',k) ,v))
 973 |               (pair args))
 974 |        ,g)))
 975 | 
 976 | (def keys (h) 
 977 |   (accum a (ontable k v h (a k))))
 978 | 
 979 | (def vals (h) 
 980 |   (accum a (ontable k v h (a v))))
 981 | 
 982 | ; These two should really be done by coerce.  Wrap coerce?
 983 | 
 984 | (def tablist (h)
 985 |   (accum a (maptable (fn args (a args)) h)))
 986 | 
 987 | (def listtab (al)
 988 |   (let h (table)
 989 |     (map (fn ((k v)) (= (h k) v))
 990 |          al)
 991 |     h))
 992 | 
 993 | (def load-table (file (o eof))
 994 |   (w/infile i file (read-table i eof)))
 995 | 
 996 | (def read-table ((o i (stdin)) (o eof))
 997 |   (let e (read i eof)
 998 |     (if (alist e) (listtab e) e)))
 999 | 
1000 | (def load-tables (file)
1001 |   (w/infile i file
1002 |     (w/uniq eof
1003 |       (drain (read-table i eof) eof))))
1004 | 
1005 | (def save-table (h file)
1006 |   (w/outfile o file (write-table h o)))
1007 | 
1008 | (def write-table (h (o o (stdout)))
1009 |   (write (tablist h) o))
1010 | 
1011 | (def copy (x)
1012 |   (case (type x)
1013 |     sym    x
1014 |     cons   (apply (fn args args) x)
1015 |     string (let new (newstring (len x))
1016 |              (forlen i x
1017 |                (= (new i) (x i)))
1018 |              new)
1019 |     table  (let new (table)
1020 |              (ontable k v x 
1021 |                (= (new k) v))
1022 |              new)
1023 |            (err "Can't copy " x)))
1024 | 
1025 | (def abs (n)
1026 |   (if (< n 0) (- n) n))
1027 | 
1028 | ; The problem with returning a list instead of multiple values is that
1029 | ; you can't act as if the fn didn't return multiple vals in cases where
1030 | ; you only want the first.  Not a big problem.
1031 | 
1032 | (def round (n)
1033 |   (withs (base (truncate n) rem (abs (- n base)))
1034 |     (if (> rem 1/2) ((if (> n 0) + -) base 1)
1035 |         (< rem 1/2) base
1036 |         (odd base)  ((if (> n 0) + -) base 1)
1037 |                     base)))
1038 | 
1039 | (def roundup (n)
1040 |   (withs (base (truncate n) rem (abs (- n base)))
1041 |     (if (>= rem 1/2) 
1042 |         ((if (> n 0) + -) base 1)
1043 |         base)))
1044 | 
1045 | (def to-nearest (n quantum)
1046 |   (* (roundup (/ n quantum)) quantum))
1047 | 
1048 | (def avg (ns) (/ (apply + ns) (len ns)))
1049 | 
1050 | ; Use mergesort on assumption that mostly sorting mostly sorted lists
1051 | ; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1) 
1052 | 
1053 | (def sort (test seq)
1054 |   (if (alist seq)
1055 |       (mergesort test (copy seq))
1056 |       (coerce (mergesort test (coerce seq 'cons)) (type seq))))
1057 | 
1058 | ; Destructive stable merge-sort, adapted from slib and improved 
1059 | ; by Eli Barzilay for MzLib; re-written in Arc.
1060 | 
1061 | (def mergesort (less? lst)
1062 |   (with (n (len lst))
1063 |     (if (<= n 1) lst
1064 |         ; ; check if the list is already sorted
1065 |         ; ; (which can be a common case, eg, directory lists).
1066 |         ; (let loop ([last (car lst)] [next (cdr lst)])
1067 |         ;   (or (null? next)
1068 |         ;       (and (not (less? (car next) last))
1069 |         ;            (loop (car next) (cdr next)))))
1070 |         ; lst
1071 |         ((afn (n)
1072 |            (if (> n 2)
1073 |                 ; needs to evaluate L->R
1074 |                 (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round
1075 |                         a (self j)
1076 |                         b (self (- n j)))
1077 |                   (merge less? a b))
1078 |                ; the following case just inlines the length 2 case,
1079 |                ; it can be removed (and use the above case for n>1)
1080 |                ; and the code still works, except a little slower
1081 |                (is n 2)
1082 |                 (with (x (car lst) y (cadr lst) p lst)
1083 |                   (= lst (cddr lst))
1084 |                   (when (less? y x) (scar p y) (scar (cdr p) x))
1085 |                   (scdr (cdr p) nil)
1086 |                   p)
1087 |                (is n 1)
1088 |                 (with (p lst)
1089 |                   (= lst (cdr lst))
1090 |                   (scdr p nil)
1091 |                   p)
1092 |                nil))
1093 |          n))))
1094 | 
1095 | ; Also by Eli.
1096 | 
1097 | (def merge (less? x y)
1098 |   (if (no x) y
1099 |       (no y) x
1100 |       (let lup nil
1101 |         (set lup
1102 |              (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x?
1103 |                (if (less? (car y) (car x))
1104 |                  (do (if r-x? (scdr r y))
1105 |                      (if (cdr y) (lup y x (cdr y) nil) (scdr y x)))
1106 |                  ; (car x) <= (car y)
1107 |                  (do (if (no r-x?) (scdr r x))
1108 |                      (if (cdr x) (lup x (cdr x) y t) (scdr x y))))))
1109 |         (if (less? (car y) (car x))
1110 |           (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x))
1111 |               y)
1112 |           ; (car x) <= (car y)
1113 |           (do (if (cdr x) (lup x (cdr x) y t) (scdr x y))
1114 |               x)))))
1115 | 
1116 | (def bestn (n f seq)
1117 |   (firstn n (sort f seq)))
1118 | 
1119 | (def split (seq pos)
1120 |   (withs (mid (nthcdr (- pos 1) seq) 
1121 |           s2  (cdr mid))
1122 |     (nil! (cdr mid))
1123 |     (list seq s2)))
1124 | 
1125 | (mac time (expr)
1126 |   (w/uniq (t1 t2)
1127 |     `(let ,t1 (msec)
1128 |        (do1 ,expr
1129 |             (let ,t2 (msec)
1130 |               (prn "time: " (- ,t2 ,t1) " msec."))))))
1131 | 
1132 | (mac jtime (expr)
1133 |   `(do1 'ok (time ,expr)))
1134 | 
1135 | (mac time10 (expr)
1136 |   `(time (repeat 10 ,expr)))
1137 | 
1138 | (= templates* (table))
1139 | 
1140 | (def maps (fn . args)
1141 |   (apply join (apply map fn args)))
1142 | 
1143 | (mac deftem (tem . fields)
1144 |   (withs (name (carif tem) includes (if (acons tem) (cdr tem)))
1145 |     `(= (templates* ',name) 
1146 |         (+ (maps templates* ',(rev includes))
1147 |            (list ,@(map (fn ((k v)) `(list ',k (fn () ,v)))
1148 |                         (pair fields)))))))
1149 | 
1150 | (def inst (tem . args)
1151 |   (let x (table)
1152 |     (each (k v) (templates* tem)
1153 |       (unless (no v) (= (x k) (v))))
1154 |     (each (k v) (pair args)
1155 |       (= (x k) v))
1156 |     x))
1157 | 
1158 | ; To write something to be read by temread, (write (tablist x))
1159 | 
1160 | (def temread (tem (o str (stdin)))
1161 |   (templatize tem (read str)))
1162 | 
1163 | ; Converts alist to inst; ugly; maybe should make this part of coerce.
1164 | ; Note: discards fields not defined by the template.
1165 | 
1166 | (def templatize (tem raw)
1167 |   (with (x (inst tem) fields (templates* tem))
1168 |     (each (k v) raw
1169 |       (when (assoc k fields)
1170 |         (= (x k) v)))
1171 |     x))
1172 | 
1173 | (def temload (tem file)
1174 |   (w/infile i file (temread tem i)))
1175 | 
1176 | (def temloadall (tem file)
1177 |   (map (fn (pairs) (templatize tem pairs))       
1178 |        (w/infile in file (readall in))))
1179 | 
1180 | 
1181 | (def number (n) (in (type n) 'int 'num))
1182 | 
1183 | (def cache (timef valf)
1184 |   (with (cached nil gentime nil)
1185 |     (fn ()
1186 |       (unless (and cached (< (- (seconds) gentime) (timef)))
1187 |         (= cached  (valf)
1188 |            gentime (seconds)))
1189 |       cached)))
1190 | 
1191 | (mac errsafe (expr)
1192 |   `(on-err (fn (c) nil)
1193 |            (fn () ,expr)))
1194 | 
1195 | (def saferead (arg) (errsafe (read arg)))
1196 | 
1197 | (def safe-load-table (filename) 
1198 |   (or (errsafe (load-table filename))
1199 |       (table)))
1200 | 
1201 | (def ensure-dir (path)
1202 |   (unless (dir-exists path)
1203 |     (system (string "mkdir " path))))
1204 | 
1205 | (def date ((o time (seconds)))
1206 |   (let val (tostring (system (string "date -u -r " time " \"+%Y-%m-%d\"")))
1207 |     (subseq val 0 (- (len val) 1))))
1208 | 
1209 | (def since (t1) (- (seconds) t1))
1210 | 
1211 | (def count (test x)
1212 |   (with (n 0 testf (testify test))
1213 |     (each elt x
1214 |       (if (testf elt) (++ n)))
1215 |     n))
1216 | 
1217 | (def ellipsize (str (o limit 80))
1218 |   (if (<= (len str) limit)
1219 |       str
1220 |       (+ (subseq str 0 limit) "...")))
1221 | 
1222 | (def random-elt (seq) (seq (rand (len seq))))
1223 | 
1224 | (mac until (test . body)
1225 |   `(while (no ,test) ,@body))
1226 | 
1227 | (def before (x y seq (o i 0))
1228 |   (with (xp (pos x seq i) yp (pos y seq i))
1229 |     (and xp (or (no yp) (< xp yp)))))
1230 | 
1231 | (def orf fns
1232 |   (fn (x) (some [_ x] fns)))
1233 | 
1234 | (def andf fns
1235 |   (fn (x) (all [_ x] fns)))
1236 | 
1237 | (def atend (i s)
1238 |   (>= i (- (len s) 1)))
1239 | 
1240 | (def multiple (x y)
1241 |   (is 0 (mod x y)))
1242 | 
1243 | (mac nor args `(no (or ,@args))) 
1244 | 
1245 | ; Consider making the default sort fn take compare's two args (when do 
1246 | ; you ever have to sort mere lists of numbers?) and rename current sort
1247 | ; as prim-sort or something.
1248 | 
1249 | ; Could simply modify e.g. > so that (> len) returned the same thing
1250 | ; as (compare > len).
1251 | 
1252 | (def compare (comparer scorer)
1253 |   (fn (x y) (comparer (scorer x) (scorer y))))
1254 | 
1255 | ; Cleaner thus, but may only ever need in 2 arg case.
1256 | 
1257 | ;(def compare (comparer scorer)
1258 | ;  (fn args (apply comparer map scorer args)))
1259 | 
1260 | (def only (f g . args)
1261 |   (aif (apply g args) (f it)))
1262 | 
1263 | (mac conswhen (f x y)
1264 |   (w/uniq (gf gx)
1265 |    `(with (,gf ,f ,gx ,x)
1266 |       (if (,gf ,gx) (cons ,gx ,y) ,y))))
1267 | 
1268 | ; Could rename this get, but don't unless it's frequently used.
1269 | 
1270 | (def firstn-that (n f xs)
1271 |   (if (or (<= n 0) (no xs))
1272 |        nil
1273 |       (f (car xs))
1274 |        (cons (car xs) (firstn-that (- n 1) f (cdr xs)))
1275 |        (firstn-that n f (cdr xs))))
1276 | 
1277 | (def dedup (xs)
1278 |   (with (h (table) acc nil)
1279 |     (each x xs
1280 |       (unless (h x)
1281 |         (push x acc)
1282 |         (t! (h x))))
1283 |     (rev acc)))
1284 | 
1285 | (def single (x) (and (acons x) (no (cdr x))))
1286 | 
1287 | (def plural (n str)
1288 |   (if (or (is n 1) (single n))
1289 |       str 
1290 |       (string str "s")))
1291 | 
1292 | (def intersperse (x ys)
1293 |   (cons (car ys)
1294 |         (mappend [list x _] (cdr ys))))
1295 | 
1296 | (def counts (seq (o c (table)))
1297 |   (if (no seq)
1298 |       c
1299 |       (do (zap [if _ (+ _ 1) 1] (c (car seq)))
1300 |           (counts (cdr seq) c))))
1301 | 
1302 | (def commonest (seq)
1303 |   (with (winner nil n 0)
1304 |     (ontable k v (counts seq)
1305 |       (when (> v n) (= winner k n v)))
1306 |     (list winner n)))
1307 | 
1308 | (def splitn (n xs)
1309 |   (let acc nil
1310 |     ((afn (n xs)
1311 |        (if (or (no xs) (<= n 0))
1312 |            (list (rev acc) xs)
1313 |            (do (push (car xs) acc)
1314 |                (self (- n 1) (cdr xs)))))
1315 |      n xs)))
1316 | 
1317 | (def reduce (f xs)
1318 |   (if (cddr xs)
1319 |       (reduce f (cons (f (car xs) (cadr xs)) (cddr xs)))
1320 |       (apply f xs)))
1321 | 
1322 | (def rreduce (f xs)
1323 |   (if (cddr xs)
1324 |       (f (car xs) (rreduce f (cdr xs)))
1325 |       (apply f xs)))
1326 | 
1327 | (let argsym (uniq)
1328 | 
1329 |   (def parse-format (str)
1330 |     (rev (accum a
1331 |            (with (chars nil  i -1)
1332 |              (w/instring s str
1333 |                (whilet c (readc s)
1334 |                  (case c 
1335 |                    #\# (do (a (coerce (rev chars) 'string))
1336 |                            (nil! chars)
1337 |                            (a (read s)))
1338 |                    #\~ (do (a (coerce (rev chars) 'string))
1339 |                            (nil! chars)
1340 |                            (readc s)
1341 |                            (a (list argsym (++ i))))
1342 |                        (push c chars))))
1343 |               (when chars
1344 |                 (a (coerce (rev chars) 'string)))))))
1345 |   
1346 |   (mac prf (str . args)
1347 |     `(let ,argsym (list ,@args)
1348 |        (pr ,@(parse-format str))))
1349 | )
1350 | 
1351 | (def load (file)
1352 |   (w/infile f file
1353 |     (whilet e (read f)
1354 |       (eval e))))
1355 | 
1356 | (def positive (x)
1357 |   (and (number x) (> x 0)))
1358 | 
1359 | (mac w/table (var . body)
1360 |   `(let ,var (table) ,@body ,var))
1361 | 
1362 | (def ero args 
1363 |   (each a args 
1364 |     (write a (stderr)) 
1365 |     (writec #\space (stderr))))
1366 | 
1367 | (def queue () (list nil nil 0))
1368 | 
1369 | ; Despite call to atomic, once had some sign this wasn't thread-safe.
1370 | 
1371 | (def enq (obj q)
1372 |   (atomic
1373 |     (++ (q 2))
1374 |     (if (no (car q))
1375 |         (= (cadr q) (= (car q) (list obj)))
1376 |         (= (cdr (cadr q)) (list obj)
1377 |            (cadr q)       (cdr (cadr q))))
1378 |     (car q)))
1379 | 
1380 | (def deq (q)
1381 |   (atomic (unless (is (q 2) 0) (-- (q 2)))
1382 |           (pop (car q))))
1383 | 
1384 | ; Should redef len to do this, and make queues lists annotated queue.
1385 | 
1386 | (def qlen (q) (q 2))
1387 | 
1388 | (def qlist (q) (car q))
1389 | 
1390 | (def enq-limit (val q (o limit 1000))
1391 |   (atomic
1392 |      (unless (< (qlen q) limit)
1393 |        (deq q))
1394 |      (enq val q)))
1395 | 
1396 | (def median (ns)
1397 |   ((sort > ns) (truncate (/ (len ns) 2))))
1398 | 
1399 | (mac noisy-each (n var val . body)
1400 |   (w/uniq (gn gc)
1401 |     `(with (,gn ,n ,gc 0)
1402 |        (each ,var ,val
1403 |          (when (multiple (++ ,gc) ,gn)
1404 |            (pr ".") 
1405 |            ;(flushout)
1406 |            )
1407 |          ,@body)
1408 |        (prn)
1409 |        ;(flushout)
1410 |        )))
1411 | 
1412 | (mac point (name . body)
1413 |   (w/uniq g
1414 |     `(ccc (fn (,g)
1415 |             (let ,name [,g _]
1416 |               ,@body)))))
1417 | 
1418 | (mac catch body
1419 |   `(point throw ,@body))
1420 | 
1421 | (def downcase (x)
1422 |   (let downc (fn (c)
1423 |                (let n (coerce c 'int)
1424 |                  (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223))
1425 |                      (coerce (+ n 32) 'char)
1426 |                      c)))
1427 |     (case (type x)
1428 |       string (map downc x)
1429 |       char   (downc x)
1430 |       sym    (sym (map downc (coerce x 'string)))
1431 |              (err "Can't downcase" x))))
1432 | 
1433 | (def upcase (x)
1434 |   (let upc (fn (c)
1435 |              (let n (coerce c 'int)
1436 |                (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255))
1437 |                    (coerce (- n 32) 'char)
1438 |                    c)))
1439 |     (case (type x)
1440 |       string (map upc x)
1441 |       char   (upc x)
1442 |       sym    (sym (map upc (coerce x 'string)))
1443 |              (err "Can't upcase" x))))
1444 | 
1445 | (def range (start end)
1446 |   (if (> start end)
1447 |       nil
1448 |       (cons start (range (+ start 1) end))))
1449 | 
1450 | (def mismatch (s1 s2)
1451 |   (catch
1452 |     (on c s1
1453 |       (when (isnt c (s2 index))
1454 |         (throw index)))))
1455 | 
1456 | (def memtable (ks)
1457 |   (let h (table)
1458 |     (each k ks (t! (h k)))
1459 |     h))
1460 | 
1461 | (= bar* " | ")
1462 | 
1463 | (mac w/bars body
1464 |   (w/uniq (out needbars)
1465 |     `(let ,needbars nil
1466 |        (do ,@(map (fn (e)
1467 |                     `(let ,out (tostring ,e)
1468 |                        (unless (is ,out "")
1469 |                          (if ,needbars
1470 |                              (pr bar* ,out)
1471 |                              (do (t! ,needbars)
1472 |                                  (pr ,out))))))
1473 |                   body)))))
1474 | 
1475 | 
1476 | ; Lower priority ideas
1477 | 
1478 | ; solution to the "problem" of improper lists: allow any atom as a list
1479 | ;  terminator, not just nil.  means list recursion should terminate on 
1480 | ;  atom rather than nil, (def empty (x) (or (atom x) (is x "")))
1481 | ; table should be able to take an optional initial-value.  handle in sref.
1482 | ; warn about code of form (if (= )) -- probably mean is
1483 | ; warn when a fn has a parm that's already defined as a macro.
1484 | ;   (def foo (after) (after))
1485 | ; idea: a fn (nothing) that returns a special gensym which is ignored
1486 | ;  by map, so can use map in cases when don't want all the vals
1487 | ; idea: anaph macro so instead of (aand x y) say (anaph and x y)
1488 | ; idea: foo.bar!baz as an abbrev for (foo bar 'baz)
1489 | ; could uniq be (def uniq () (annotate 'symbol (list 'u))) again?
1490 | ; idea: use x- for (car x) and -x for (cdr x)  (but what about math -?)
1491 | ; idea: get rid of strings and just use symbols
1492 | ; could a string be (#\a #\b . "") ?
1493 | ; better err msg when , outside of a bq
1494 | ; idea: parameter (p foo) means in body foo is (pair arg)
1495 | ; idea: make ('string x) equiv to (coerce x 'string) ?  or isa?
1496 | ;   quoted atoms in car valuable unused semantic space
1497 | 
1498 | 

1499 | 
1500 | ;;; Fixups to the standard library to get around incompatibilities in primitives,
1501 | ;;; mostly related to the lack of mutable strings
1502 | 
1503 | (def map (f . seqs)
1504 |   (if (some [isa _ 'string] seqs)
1505 |         ; Doesn't even work in reference implementation...I wonder why I bother ;-)
1506 |        (withs (n   (apply min (map len seqs))
1507 |                lists (map [coerce _ 'cons] seqs))
1508 |          (apply f lists))
1509 |       (no (cdr seqs)) 
1510 |        (map1 f (car seqs))
1511 |       ((afn (seqs)
1512 |         (if (some no seqs)  
1513 |             nil
1514 |             (cons (apply f (map1 car seqs))
1515 |                   (self (map1 cdr seqs)))))
1516 |        seqs)))
1517 | 
1518 | (def subseq (seq start (o end (len seq)))
1519 |   (if (isa seq 'string)
1520 |       (let s2 ""
1521 |         (for i start (- end 1)
1522 |           (= s2 (+ s2 (seq i))))
1523 |         s2)
1524 |       (firstn (- end start) (nthcdr start seq))))
1525 | 
1526 | (def copy (x)
1527 |   (case (type x)
1528 |     sym    x
1529 |     cons   (apply (fn args args) x)
1530 |     string (subseq x 0)
1531 |     table  (let new (table)
1532 |              (ontable k v x 
1533 |                (= (new k) v))
1534 |              new)
1535 |            (err "Can't copy " x)))
1536 | 
1537 | 

1538 | 
1539 | 
1540 | 
1541 | 
1542 | 
1543 | 
1544 | 
1545 | 
1623 | 


--------------------------------------------------------------------------------
/test/test_types.html:
--------------------------------------------------------------------------------
 1 | 
 2 | 
 3 | 
 4 | 
 5 | 
66 | 


--------------------------------------------------------------------------------
/types.js:
--------------------------------------------------------------------------------
  1 | (function ($) {
  2 | /**
  3 |  * A representation for primitive types.  Arc types inherit from a common
  4 |  * base class that provides defaults (all of which just raise an error)
  5 |  * for some of the basic operations that the interpreter performs.
  6 |  * 
  7 |  * @dependency utils.js
  8 |  */
  9 | 
 10 | if(typeof window.Types != 'undefined') {
 11 |     var _Types = window.Types;
 12 | }
 13 | 
 14 | var ArcBase = {
 15 | 
 16 |     _not_defined: function(method) {
 17 |         $.error('' + method + ' not defined on ' + this._type);
 18 |     },
 19 |     _cant_be_coerced: function(type) {
 20 |         $.error(this._type + " object can't be coerced to " + type);
 21 |     },
 22 | 
 23 |     __type: function() { return this._type; },
 24 |     __call: function(args) { return Types.bool(this.__veq(args[0])); },
 25 |     __set: function(index, val) { this._not_defined('__set'); },
 26 |     __coerce: function(type) { this._not_defined('coerce'); },
 27 |     __to_js: function() { return this; },
 28 |     __eq: function(js_obj) { return this.__to_js() == js_obj; },
 29 |     __teq: function(js_obj) { return this.__type().__eq(js_obj); },
 30 |     __veq: function(arc_obj) { return this.__eq(arc_obj.__to_js()); },
 31 |     __print: function() { return Types.str(this.toString()); }
 32 | };
 33 | 
 34 | function new_arc_type(base_proto, init, methods) {
 35 |     $.extend(base_proto, ArcBase);
 36 |     $.extend(base_proto, methods);
 37 |     return $.class_decorator(init, base_proto);
 38 | };
 39 | 
 40 | function copy_number(val) {
 41 |     return new Number(val);
 42 | };
 43 | 
 44 | function copy_string(val) {
 45 |     return new String(val);
 46 | };
 47 | 
 48 | function make_tagged(type, val) {
 49 |     return { _val: val, _type: type, _tagged: true };
 50 | };
 51 | 
 52 | function make_cons(car, cdr) {
 53 |     $.assert('Passed a non-arc object as car of a list', car && car.__type);
 54 |     $.assert('Passed a non-arc object as cdr of a list', cdr && cdr.__type);
 55 |     return { _car: car, _cdr: cdr };
 56 | };
 57 | 
 58 | function make_table(val) {
 59 |     return val || {};
 60 | };
 61 | 
 62 | function make_function(args, body, env) {
 63 |     return {
 64 |         _args: args,
 65 |         _body: body,
 66 |         _env: env
 67 |     }
 68 | };
 69 | 
 70 | function decorate_primitive(fn, name) {
 71 |     fn._name = name || 'unnamed';
 72 |     return fn;
 73 | };
 74 | 
 75 | // Must be declared outside because it's referenced in the definition of Types
 76 | var sym = new_arc_type(new String(), copy_string, {});
 77 | $.extend(sym.__fake_proto, {
 78 |     _type: sym('sym'),
 79 |     __coerce: function(type) {
 80 |         if(type.__eq('string')) {
 81 |             return Types.str(this == Types.NIL ? '' : this.__to_js())
 82 |         } else {
 83 |             return this._not_defined(type);
 84 |         }
 85 |     },
 86 |     __to_list: function() { return []; }, // For nil
 87 |     __to_js: function() { 
 88 |         var retval = this.toString();
 89 |         if(retval == 't') return true;
 90 |         if(retval == 'nil') return false;
 91 |         return this.toString(); 
 92 |     }
 93 | });
 94 | 
 95 | var Types = window.Types = {
 96 | 
 97 |     no_conflict: function() {
 98 |         window.Types = _Types;
 99 |         return Types;
100 |     },
101 | 
102 |     tagged: new_arc_type(new Object(), make_tagged, {
103 |         __call: function(args) { return this._val.__call.call(this._val, args); },
104 |         __set: function(index, val) { return this._val.__set.call(this._val, index, val); },
105 |         __print: function() {
106 |             return Types.str('(tagged ' + this._type + ' ' + this._val.__print() + ')');
107 |         }
108 |     }),
109 | 
110 |     sym: sym,
111 |     NIL: sym('nil'),
112 |     T: sym('t'),
113 |     bool: function(val) {
114 |         return val ? Types.T : Types.NIL;
115 |     },
116 | 
117 |     chr: new_arc_type(new String(), copy_string, { 
118 |         _type: sym('char'),
119 |         __to_js: function() { return this.toString(); },
120 |         __coerce: function(type) {
121 |             switch(type.__to_js()) {
122 |                 case 'int': return Types.int_(this.charCodeAt(0));
123 |                 case 'string': return Types.str(this);
124 |                 case 'sym': return Types.sym(this);
125 |                 default: return this._cant_be_coerced(type);
126 |             }
127 |         },
128 |         __print: function() { return Types.str('#\\' + this); }
129 |     }),
130 | 
131 |     str: new_arc_type(new String(), copy_string, { 
132 |         _type: sym('string'),
133 |         __call: function(args) {
134 |             return Types.chr(this.charAt(args[0]));
135 |         },
136 |         __set: function(index, new_val) {
137 |             // The spec says to mutate the string, but JavaScript strings are
138 |             // immutable.  Instead we return a copy with the specified character
139 |             // changed, and hope that nobody was depending upon mutation
140 |             return Types.str(this.substr(0, index) + new_val.toString() 
141 |                             + this.substr(index + 1));
142 |         },
143 |         __coerce: function(type) {
144 |             switch(type.__to_js()) {
145 |                 case 'sym': return Types.sym(this);
146 |                 case 'cons': 
147 |                     var retval = [];
148 |                     for(var i = 0, len = this.length; i < len; ++i) {
149 |                         retval.push(Types.chr(this.charAt(i)));
150 |                     }
151 |                     return Types.list(retval);
152 |                 case 'int': 
153 |                     var parsed = parseInt(this);
154 |                     if(isNaN(parsed)) {
155 |                         $.error("Can't coerce " + this + ' to int');
156 |                     }
157 |                     return Types.int_(parsed);
158 |                 default: return this._cant_be_coerced(type);
159 |             }
160 |         },
161 |         __to_js: function() { return this.toString(); },
162 |         __print: function() { return Types.str('"' + this + '"'); }
163 |     }),
164 | 
165 |     int_: new_arc_type(new Number(), copy_number, { 
166 |         _type: sym('int'),
167 |         __coerce: function(type) {
168 |             switch(type.__to_js()) {
169 |                 case 'char': return Types.chr(String.fromCharCode(this));
170 |                 case 'string': return Types.str(this.toString());
171 |                 default: return this._cant_be_coerced(type);
172 |             }
173 |         },
174 |         __to_js: function() { return parseInt(this.toString()); }
175 |     }),
176 | 
177 |     num: new_arc_type(new Number(), copy_number, { 
178 |         _type: sym('num'),
179 |         __coerce: function(type) {
180 |             switch(type.__to_js()) {
181 |                 case 'int': return Types.int_(Math.round(this));
182 |                 case 'char': return Types.chr(String.fromCharCode(Math.round(this)));
183 |                 case 'string': return Types.str(this.toString());
184 |                 default: return this._cant_be_coerced(type);
185 |             }
186 |         },
187 |         __to_js: function() { return parseFloat(this.toString()); }
188 |     }),
189 | 
190 |     cons: new_arc_type(new Object(), make_cons, { 
191 |         _type: sym('cons'),
192 |         __index: function(index) {
193 |             var current = this;
194 |             for(var i = 0; i < index; ++i) {
195 |                 current = current._cdr;
196 |                 if(!current.__type().__eq('cons')) {
197 |                     $.error('Index out of range: ' + index);
198 |                 }
199 |             }
200 |             return current;
201 |         },
202 |         __call: function(args) {
203 |             return this.__index(args[0])._car;
204 |         },
205 |         __set: function(index, new_val) {
206 |             this.__index(index)._car = new_val;
207 |             return new_val;
208 |         },
209 |         __each: function(fn) {
210 |             var current = this;
211 |             while(current.__teq('cons')) {
212 |                 fn(current._car);
213 |                 current = current._cdr;
214 |             }
215 |             return current;
216 |         },
217 |         __coerce: function(type) {
218 |             if(type.__to_js() == 'string') {
219 |                 var accum = '';
220 |                 function add_char(chr) { 
221 |                     accum += String.fromCharCode(chr.__to_js());
222 |                 };
223 |                 var last = this.__each(add_char);
224 |                 if(!last == Types.NIL) {
225 |                     add_char(last);
226 |                 }
227 |                 return Types.str(accum);
228 |             } else {
229 |                 return this._cant_be_coerced(type);
230 |             }
231 |         },
232 |         __to_list: function() {
233 |             var retval = [];
234 |             var last = this.__each(function(elem) { retval.push(elem); });
235 |             if(last != Types.NIL) {
236 |                 retval.push(last);
237 |             }
238 |             return retval;
239 |         },
240 |         __print: function() {
241 |             var segments = [];
242 |             var last = this.__each(function(elem) { 
243 |                 segments.push(elem.__print().toString());
244 |             });
245 |             if(last != Types.NIL) {
246 |                 segments.push('.');
247 |                 segments.push(last.__print().toString());
248 |             }
249 |             return Types.str('(' + segments.join(' ') + ')');
250 |         },
251 |         __to_js: function() { return this.__to_list(); }
252 |     }),
253 | 
254 |     list: function(arr, improper) {
255 |         if(arr.length == 0) {
256 |             return Types.NIL;
257 |         }
258 | 
259 |         var i = arr.length - 1;
260 |         for(var current = improper ? arr[i--] : Types.NIL; i >= 0; --i) {
261 |             current = Types.cons(arr[i], current);
262 |         }
263 |         return current;
264 |     },
265 | 
266 |     table: new_arc_type(new Object(), make_table, { 
267 |         _type: sym('table'),
268 |         __call: function(args) {
269 |             return this[args[0].toString()] || Types.NIL;
270 |         },
271 |         __set: function(index, new_val) {
272 |             if(new_val == Types.NIL) {
273 |                 delete this[index];
274 |             } else {
275 |                 this[index] = new_val;
276 |             }
277 |             return new_val;
278 |         },
279 |         __length: function() {
280 |             var len = 0;
281 |             Utils.prop_map(this, function() { len++; });
282 |             return len;
283 |         },
284 |         __print: function() {
285 |             var text = '#hash(';
286 |             Utils.prop_map(this, function(v, key) { text += '(' + key + ' . ' + ')'; });
287 |             return Types.str(text + ')');
288 |         },
289 |         __to_js: function() {
290 |             return Utils.extend({}, this);
291 |         }
292 |     }),
293 | 
294 |     fn: new_arc_type(new Object(), make_function, { 
295 |         _type: sym('fn'),
296 |         __call: 'native',
297 |         __print: function() {
298 |             var argstr = this._args.__teq('cons') 
299 |                 ? '(' + this._args.__to_list().join(' ') + ')'
300 |                 : this._args.toString();
301 |             return Types.str('#procedure: ' + argstr);
302 |         }
303 |     }),
304 | 
305 |     primitive: new_arc_type(new Function(), decorate_primitive, {
306 |         _type: sym('fn'),
307 |         __call: function(args) {
308 |             if(this._varargs === undefined && args.length != this.length) {
309 |                 Utils.error(this._name + ' takes ' + this.length + 
310 |                             ' arguments, found ' + Types.list(args).__print());
311 |             }
312 |             if(this._varargs !== undefined && args.length < this._varargs) {
313 |                 Utils.error(this._name + ' takes at least ' + this.length + 
314 |                             ' arguments, found ' + Types.list(args).__print());
315 | 
316 |             }
317 |             var result = this.apply(null, args);
318 |             Utils.assert(this._name + ' did not return a value.', result);
319 |             return result;
320 |         },
321 |         __print: function() {
322 |             return Types.str('#primitive procedure: ' + this._name);
323 |         }
324 |     }),
325 | 
326 |     to_js: function(arc_obj) {
327 |         var result = arc_obj.__to_js();
328 |         return Utils.prop_map(result, Types.to_js);
329 |     },
330 | 
331 |     to_arc: function(js_obj) {
332 |         switch(typeof js_obj) {
333 |             case 'number': return Types.wrap_num(js_obj);
334 |             case 'string': return Types.str(js_obj);
335 |             case 'boolean': return Types.bool(js_obj);
336 |             case 'function': return Types.primitive(js_obj);
337 |             case 'undefined': return Types.NIL;
338 |             default:
339 |                 if(js_obj instanceof Array) {
340 |                     return Types.list(Utils.map(js_obj, Types.to_arc));
341 |                 } else {
342 |                     return Types.table(Utils.prop_map(Utils.extend({}, js_obj), 
343 |                                                       Types._to_arc));
344 |                 }
345 |         }
346 |     },
347 | 
348 |     /** Detects the type of the result and wraps it with a num or int_ */
349 |     wrap_num: function(result) {
350 |         var constr = result == Math.round(result) ? Types.int_ : Types.num;
351 |         return constr(result);
352 |     }
353 | 
354 | };
355 | 
356 | })(Utils);
357 | 


--------------------------------------------------------------------------------
/utils.js:
--------------------------------------------------------------------------------
  1 | (function () {
  2 | /**
  3 |  * Some basic utility functions.  I want to avoid coupling this to large
  4 |  * JavaScript libraries.
  5 |  */
  6 | if(typeof window.Utils != 'undefined') {
  7 |     var _Utils = window.Utils;
  8 | }
  9 | 
 10 | function ArcError(msg, expr) {
 11 |     this.message = msg;
 12 |     this.expr = expr;
 13 | };
 14 | ArcError.prototype = new Error();
 15 | ArcError.prototype.name = 'ArcError';
 16 | 
 17 | var Utils = window.Utils = {
 18 | 
 19 |     no_conflict: function() {
 20 |         window.Utils = _Utils;
 21 |         return Utils;
 22 |     },
 23 | 
 24 |     extend: function(dest, src) {
 25 |         for(var prop in src) {
 26 |             if(src.hasOwnProperty(prop)) {
 27 |                 dest[prop] = src[prop];
 28 |             }
 29 |         }
 30 |         return dest;
 31 |     },
 32 | 
 33 |     class_decorator: function(init, new_proto) {
 34 |         new_proto.__init = init;
 35 |         var constr =  function() {
 36 |             var self = init.apply(this, arguments);
 37 |             var args = [self.__proto__].concat([].slice.call(arguments, 1));
 38 |             self.__proto__ = new_proto;
 39 |             return self;
 40 |         };
 41 |         constr.__fake_proto = new_proto;
 42 |         return constr;
 43 |     },
 44 | 
 45 |     invoke: function(collection, method) {
 46 |         var accum = [],
 47 |             args = [].slice.call(arguments, 2);
 48 |         for(var i = 0, len = collection.length; i < len; ++i) {
 49 |             var item = collection[i];
 50 |             accum.push(item[method].apply(item, args));
 51 |         }
 52 |         return accum;
 53 |     },
 54 | 
 55 |     map: function(collection, fn) {
 56 |         var accum = [];
 57 |         for(var i = 0, len = collection.length; i < len; ++i) {
 58 |             accum.push(fn(collection[i], i));
 59 |         }
 60 |         return accum;
 61 |     },
 62 | 
 63 |     prop_map: function(collection, fn) {
 64 |         for(var prop in collection) {
 65 |             if(collection.hasOwnProperty(prop)) {
 66 |                 collection[prop] = fn(collection[prop], prop);
 67 |             }
 68 |         }
 69 |         return collection;
 70 |     },
 71 | 
 72 |     ensure_fn: function(fn) {
 73 |         if(typeof fn == 'string') {
 74 |             fn = eval('false || function(x, y) { return ' + fn + '; }');
 75 |         };
 76 |         return fn;
 77 |     },
 78 | 
 79 |     all: function(args, pred) {
 80 |         pred = Utils.ensure_fn(pred);
 81 |         for(var i = 0, len = args.length; i < len; ++i) {
 82 |             if(!pred(args[i])) {
 83 |                 return false;
 84 |             }
 85 |         }
 86 |         return true;
 87 |     },
 88 | 
 89 |     pairwise: function(args, base, pred) {
 90 |         if(args.length == 0) {
 91 |             return base;
 92 |         }
 93 |         pred = Utils.ensure_fn(pred);
 94 | 
 95 |         for(var i = 0, len = args.length - 1; i < len; ++i) {
 96 |             if(!pred(args[i], args[i + 1])) {
 97 |                 return false;
 98 |             }
 99 |         }
100 |         return true;
101 |     },
102 | 
103 |     fold1: function(args, fn) {
104 |         if(args.length == 0) {
105 |             return 0;
106 |         } else if(args.length == 1) {
107 |             return args[0];
108 |         }
109 |         fn = Utils.ensure_fn(fn);
110 | 
111 |         var base = args[0];
112 |         for(var i = 1, len = args.length; i < len; ++i) {
113 |             base = fn(base, args[i]);
114 |         }
115 |         return base;
116 |     },
117 | 
118 |     assert: function(msg, condition) {
119 |         if(!condition) {
120 |             Utils.error('Assertion failure: ' + msg);
121 |         }
122 |     },
123 | 
124 |     error: function(msg, expr) {
125 |         throw new ArcError(msg, expr);
126 |     },
127 | 
128 |     id: function(val) {
129 |         return val;
130 |     },
131 | 
132 |     ArcError: ArcError
133 | 
134 | };
135 | 
136 | })();
137 | 


--------------------------------------------------------------------------------