runtime/stdlib.js

   1 // Js_of_ocaml runtime support
   2 // http://www.ocsigen.org/js_of_ocaml/
   3 // Copyright (C) 2010 Jérôme Vouillon
   4 // Laboratoire PPS - CNRS Université Paris Diderot
   5 //
   6 // This program is free software; you can redistribute it and/or modify
   7 // it under the terms of the GNU Lesser General Public License as published by
   8 // the Free Software Foundation, with linking exception;
   9 // either version 2.1 of the License, or (at your option) any later version.
  10 //
  11 // This program is distributed in the hope that it will be useful,
  12 // but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 // GNU Lesser General Public License for more details.
  15 //
  16 // You should have received a copy of the GNU Lesser General Public License
  17 // along with this program; if not, write to the Free Software
  18 // Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  19
  20 ///////////// Core
  21 //Provides: caml_call_gen
  22 function caml_call_gen(f, args) {
  23   if(f.fun)
  24     return caml_call_gen(f.fun, args);
  25   var n = f.length;
  26   var d = n - args.length;
  27   if (d == 0)
  28     return f.apply(null, args);
  29   else if (d < 0)
  30     return caml_call_gen(f.apply(null, args.slice(0,n)), args.slice(n));
  31   else
  32     return function (x){ return caml_call_gen(f, args.concat([x])); };
  33 }
  34
  35 //Provides: caml_named_values
  36 var caml_named_values = {};
  37
  38 //Provides: caml_register_named_value
  39 //Requires: caml_named_values
  40 function caml_register_named_value(nm,v) {
  41   caml_named_values[nm] = v; return 0;
  42 }
  43
  44 //Provides: caml_global_data
  45 var caml_global_data = [0];
  46
  47 //Provides: caml_register_global
  48 //Requires: caml_global_data
  49 function caml_register_global (n, v) { caml_global_data[n + 1] = v; }
  50
  51 //Provides: caml_raise_constant
  52 function caml_raise_constant (tag) { throw [0, tag]; }
  53
  54 //Provides: caml_raise_with_arg
  55 function caml_raise_with_arg (tag, arg) { throw [0, tag, arg]; }
  56
  57 //Provides: caml_raise_with_string
  58 //Requires: caml_raise_with_arg, MlString
  59 function caml_raise_with_string (tag, msg) {
  60   caml_raise_with_arg (tag, new MlWrappedString (msg));
  61 }
  62
  63 //Provides: caml_invalid_argument
  64 //Requires: caml_raise_with_string
  65 function caml_invalid_argument (msg) {
  66   caml_raise_with_string(caml_global_data[4], msg);
  67 }
  68
  69 //Provides: caml_failwith
  70 //Requires: caml_raise_with_string, caml_global_data
  71 function caml_failwith (msg) {
  72   caml_raise_with_string(caml_global_data[3], msg);
  73 }
  74
  75 //Provides: caml_array_bound_error
  76 //Requires: caml_invalid_argument
  77 function caml_array_bound_error () {
  78   caml_invalid_argument("index out of bounds");
  79 }
  80
  81 //Provides: caml_raise_zero_divide
  82 //Requires: caml_raise_constant, caml_global_data
  83 function caml_raise_zero_divide () {
  84   caml_raise_constant(caml_global_data[6]);
  85 }
  86
  87 //Provides: caml_update_dummy
  88 function caml_update_dummy (x, y) {
  89   if( typeof y==="function" ) { x.fun = y; return 0; }
  90   if( y.fun ) { x.fun = y.fun; return 0; }
  91   var i = y.length; while (i--) x[i] = y[i]; return 0;
  92 }
  93
  94 //Provides: caml_obj_is_block const
  95 function caml_obj_is_block (x) { return +(x instanceof Array); }
  96 //Provides: caml_obj_tag const
  97 function caml_obj_tag (x) { return (x instanceof Array)?x[0]:1000; }
  98 //Provides: caml_obj_set_tag
  99 function caml_obj_set_tag (x, tag) { x[0] = tag; return 0; }
 100 //Provides: caml_obj_block const
 101 function caml_obj_block (tag, size) {
 102   var o = [tag];
 103   for (var i = 1; i <= size; i++) o[i] = 0;
 104   return o;
 105 }
 106 //Provides: caml_obj_dup mutable
 107 function caml_obj_dup (x) { return x.slice(); }
 108 //Provides: caml_obj_truncate
 109 function caml_obj_truncate (x, s) { x.length = s + 1; return 0; }
 110
 111 //Provides: caml_lazy_make_forward
 112 function caml_lazy_make_forward (v) { return [250, v]; }
 113
 114 //Provides: caml_mul const
 115 function caml_mul(x,y) {
 116   return ((((x >> 16) * y) << 16) + (x & 0xffff) * y)|0;
 117 }
 118
 119 //slightly slower
 120 // function mul32(x,y) {
 121 //   var xlo = x & 0xffff;
 122 //   var xhi = x - xlo;
 123 //   return (((xhi * y) |0) + xlo * y)|0;
 124 // }
 125
 126 //Provides: caml_div const
 127 //Requires: caml_raise_zero_divide
 128 function caml_div(x,y) {
 129   if (y == 0) caml_raise_zero_divide ();
 130   return (x/y)|0;
 131 }
 132
 133 //Provides: caml_mod const
 134 //Requires: caml_raise_zero_divide
 135 function caml_mod(x,y) {
 136   if (y == 0) caml_raise_zero_divide ();
 137   return x%y;
 138 }
 139
 140 ///////////// Pervasive
 141 //Provides: caml_array_set
 142 //Requires: caml_array_bound_error
 143 function caml_array_set (array, index, newval) {
 144   if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
 145   array[index+1]=newval; return 0;
 146 }
 147
 148 //Provides: caml_array_get mutable
 149 //Requires: caml_array_bound_error
 150 function caml_array_get (array, index) {
 151   if ((index < 0) || (index >= array.length - 1)) caml_array_bound_error();
 152   return array[index+1];
 153 }
 154
 155 //Provides: caml_make_vect const
 156 function caml_make_vect (len, init) {
 157   var b = [0]; for (var i = 1; i <= len; i++) b[i] = init; return b;
 158 }
 159
 160 //Provides: caml_compare_val
 161 //Requires: MlString, caml_int64_compare, caml_int_compare
 162 function caml_compare_val (a, b, total) {
 163   var stack = [];
 164   for(;;) {
 165     if (!(total && a === b)) {
 166       if (a instanceof MlString) {
 167         if (b instanceof MlString) {
 168           if (a != b) return a.compare(b);
 169         } else
 170           // Should not happen
 171           return 1;
 172       } else if (a instanceof Array && a[0] == (a[0]|0)) {
 173         // Forward object
 174         var ta = a[0];
 175         if (ta === 250) {
 176           a = a[1];
 177           continue;
 178         } else if (b instanceof Array && b[0] == (b[0]|0)) {
 179           // Forward object
 180           var tb = b[0];
 181           if (tb === 250) {
 182             b = b[1];
 183             continue;
 184           } else if (ta != tb) {
 185             return (ta < tb)?-1:1;
 186           } else {
 187             switch (ta) {
 188             case 248:
 189               // Object
 190               return caml_int_compare(a[2], b[2]);
 191             case 255:
 192               // Int64
 193               return caml_int64_compare(a, b);
 194             default:
 195               if (a.length != b.length) return (a.length < b.length)?-1:1;
 196               if (a.length > 1) stack.push(a, b, 1);
 197             }
 198           }
 199         } else
 200           return 1;
 201       } else if (b instanceof MlString ||
 202                  (b instanceof Array && b[0] == (b[0]|0))) {
 203         return -1;
 204       } else {
 205         if (a < b) return -1;
 206         if (a > b) return 1;
 207         if (total && a != b) {
 208           if (a == a) return 1;
 209           if (b == b) return -1;
 210         }
 211       }
 212     }
 213     if (stack.length == 0) return 0;
 214     var i = stack.pop();
 215     b = stack.pop();
 216     a = stack.pop();
 217     if (i + 1 < a.length) stack.push(a, b, i + 1);
 218     a = a[i];
 219     b = b[i];
 220   }
 221 }
 222 //Provides: caml_compare
 223 //Requires: caml_compare_val
 224 function caml_compare (a, b) { return caml_compare_val (a, b, true); }
 225 //Provides: caml_int_compare mutable
 226 function caml_int_compare (a, b) {
 227   if (a < b) return (-1); if (a == b) return 0; return 1;
 228 }
 229 //Provides: caml_equal mutable
 230 //Requires: caml_compare_val
 231 function caml_equal (x, y) { return +(caml_compare_val(x,y,false) == 0); }
 232 //Provides: caml_notequal mutable
 233 //Requires: caml_compare
 234 function caml_notequal (x, y) { return +(caml_compare_val(x,y,false) != 0); }
 235 //Provides: caml_greaterequal mutable
 236 //Requires: caml_compare
 237 function caml_greaterequal (x, y) { return +(caml_compare(x,y,false) >= 0); }
 238 //Provides: caml_greaterthan mutable
 239 //Requires: caml_compare
 240 function caml_greaterthan (x, y) { return +(caml_compare(x,y,false) > 0); }
 241 //Provides: caml_lessequal mutable
 242 //Requires: caml_compare
 243 function caml_lessequal (x, y) { return +(caml_compare(x,y,false) <= 0); }
 244 //Provides: caml_lessthan mutable
 245 //Requires: caml_compare
 246 function caml_lessthan (x, y) { return +(caml_compare(x,y,false) < 0); }
 247
 248 //Provides: caml_parse_sign_and_base
 249 //Requires: MlString
 250 function caml_parse_sign_and_base (s) {
 251   var i = 0, base = 10, sign = s.get(0) == 45?(i++,-1):1;
 252   if (s.get(i) == 48)
 253     switch (s.get(i + 1)) {
 254     case 120: case 88: base = 16; i += 2; break;
 255     case 111: case 79: base =  8; i += 2; break;
 256     case  98: case 66: base =  2; i += 2; break;
 257     }
 258   return [i, sign, base];
 259 }
 260
 261 //Provides: caml_parse_digit
 262 function caml_parse_digit(c) {
 263   if (c >= 48 && c <= 57)  return c - 48;
 264   if (c >= 65 && c <= 90)  return c - 55;
 265   if (c >= 97 && c <= 122) return c - 87;
 266   return -1;
 267 }
 268
 269 //Provides: caml_int_of_string
 270 //Requires: caml_parse_sign_and_base, caml_parse_digit, MlString, caml_failwith
 271 function caml_int_of_string (s) {
 272   var r = caml_parse_sign_and_base (s);
 273   var i = r[0], sign = r[1], base = r[2];
 274   var threshold = -1 >>> 0;
 275   var c = s.get(i);
 276   var d = caml_parse_digit(c);
 277   if (d < 0 || d >= base) caml_failwith("int_of_string");
 278   var res = d;
 279   for (;;) {
 280     i++;
 281     c = s.get(i);
 282     if (c == 95) continue;
 283     d = caml_parse_digit(c);
 284     if (d < 0 || d >= base) break;
 285     res = base * res + d;
 286     if (res > threshold) caml_failwith("int_of_string");
 287   }
 288   if (i != s.getLen()) caml_failwith("int_of_string");
 289   res = sign * res;
 290   if ((res | 0) != res) caml_failwith("int_of_string");
 291   return res;
 292 }
 293
 294 //Provides: caml_is_printable const
 295 function caml_is_printable(c) { return +(c > 31 && c < 127); }
 296
 297 ///////////// Format
 298 //Provides: caml_parse_format
 299 //Requires: caml_invalid_argument
 300 function caml_parse_format (fmt) {
 301   fmt = fmt.toString ();
 302   var len = fmt.length;
 303   if (len > 31) caml_invalid_argument("format_int: format too long");
 304   var f =
 305     { justify:'+', signstyle:'-', filler:' ', alternate:false,
 306       base:0, signedconv:false, width:0, uppercase:false,
 307       sign:1, prec:6, conv:'f' };
 308   for (var i = 0; i < len; i++) {
 309     var c = fmt.charAt(i);
 310     switch (c) {
 311     case '-':
 312       f.justify = '-'; break;
 313     case '+': case ' ':
 314       f.signstyle = c; break;
 315     case '0':
 316       f.filler = '0'; break;
 317     case '#':
 318       f.alternate = true; break;
 319     case '1': case '2': case '3': case '4': case '5':
 320     case '6': case '7': case '8': case '9':
 321       f.width = 0;
 322       while (c=fmt.charCodeAt(i) - 48, c >= 0 && c <= 9) {
 323         f.width = f.width * 10 + c; i++
 324       }
 325       i--;
 326      break;
 327     case '.':
 328       f.prec = 0;
 329       i++;
 330       while (c=fmt.charCodeAt(i) - 48, c >= 0 && c <= 9) {
 331         f.prec = f.prec * 10 + c; i++
 332       }
 333       i--;
 334     case 'd': case 'i':
 335       f.signedconv = true; /* fallthrough */
 336     case 'u':
 337       f.base = 10; break;
 338     case 'x':
 339       f.base = 16; break;
 340     case 'X':
 341       f.base = 16; f.uppercase = true; break;
 342     case 'o':
 343       f.base = 8; break;
 344     case 'e': case 'f': case 'g':
 345       f.signedconv = true; f.conv = c; break;
 346     case 'E': case 'F': case 'G':
 347       f.signedconv = true; f.uppercase = true;
 348       f.conv = c.toLowerCase (); break;
 349     }
 350   }
 351   return f;
 352 }
 353
 354 //Provides: caml_finish_formatting
 355 //Requires: MlString
 356 function caml_finish_formatting(f, rawbuffer) {
 357   if (f.uppercase) rawbuffer = rawbuffer.toUpperCase();
 358   var len = rawbuffer.length;
 359   /* Adjust len to reflect additional chars (sign, etc) */
 360   if (f.signedconv && (f.sign < 0 || f.signstyle != '-')) len++;
 361   if (f.alternate) {
 362     if (f.base == 8) len += 1;
 363     if (f.base == 16) len += 2;
 364   }
 365   /* Do the formatting */
 366   var buffer = "";
 367   if (f.justify == '+' && f.filler == ' ')
 368     for (var i = len; i < f.width; i++) buffer += ' ';
 369   if (f.signedconv) {
 370     if (f.sign < 0) buffer += '-';
 371     else if (f.signstyle != '-') buffer += f.signstyle;
 372   }
 373   if (f.alternate && f.base == 8) buffer += '0';
 374   if (f.alternate && f.base == 16) buffer += "0x";
 375   if (f.justify == '+' && f.filler == '0')
 376     for (var i = len; i < f.width; i++) buffer += '0';
 377   buffer += rawbuffer;
 378   if (f.justify == '-')
 379     for (var i = len; i < f.width; i++) buffer += ' ';
 380   return new MlWrappedString (buffer);
 381 }
 382
 383 //Provides: caml_format_int const
 384 //Requires: caml_parse_format, caml_finish_formatting
 385 function caml_format_int(fmt, i) {
 386   if (fmt.toString() == "%d") return new MlWrappedString(""+i);
 387   var f = caml_parse_format(fmt);
 388   if (i < 0) { if (f.signedconv) { f.sign = -1; i = -i; } else i >>>= 0; }
 389   var s = i.toString(f.base);
 390   return caml_finish_formatting(f, s);
 391 }
 392
 393 //Provides: caml_format_float const
 394 //Requires: caml_parse_format, caml_finish_formatting
 395 function caml_format_float (fmt, x) {
 396   var s, f = caml_parse_format(fmt);
 397   if (x < 0) { f.sign = -1; x = -x; }
 398   if (isNaN(x)) { s = "nan"; f.filler = ' '; }
 399   else if (!isFinite(x)) { s = "inf"; f.filler = ' '; }
 400   else
 401     switch (f.conv) {
 402     case 'e':
 403       var s = x.toExponential(f.prec);
 404       // exponent should be at least two digits
 405       var i = s.length;
 406       if (s.charAt(i - 3) == 'e')
 407         s = s.slice (0, i - 1) + '0' + s.slice (i - 1);
 408       break;
 409     case 'f':
 410       s = x.toFixed(f.prec); break;
 411     case 'g':
 412       var prec = f.prec?f.prec:1;
 413       s = x.toExponential(prec - 1);
 414       var j = s.indexOf('e');
 415       var exp = +s.slice(j + 1);
 416       if (exp < -4 || x.toFixed(0).length > prec) {
 417         // remove trailing zeroes
 418         var i = j - 1; while (s.charAt(i) == '0') i--;
 419         if (s.charAt(i) == '.') i--;
 420         s = s.slice(0, i + 1) + s.slice(j);
 421         i = s.length;
 422         if (s.charAt(i - 3) == 'e')
 423           s = s.slice (0, i - 1) + '0' + s.slice (i - 1);
 424         break;
 425       } else {
 426         var p = prec;
 427         if (exp < 0) { p -= exp + 1; s = x.toFixed(p); }
 428         else while (s = x.toFixed(p), s.length > prec + 1) p--;
 429         if (p) {
 430           // remove trailing zeroes
 431           var i = s.length - 1; while (s.charAt(i) == '0') i--;
 432           if (s.charAt(i) == '.') i--;
 433           s = s.slice(0, i + 1);
 434         }
 435       }
 436       break;
 437     }
 438   return caml_finish_formatting(f, s);
 439 }
 440
 441 ///////////// Hashtbl
 442 //Provides: caml_hash_univ_param mutable
 443 //Requires: MlString
 444 function caml_hash_univ_param (count, limit, obj) {
 445   var hash_accu = 0;
 446   function hash_aux (obj) {
 447     limit --;
 448     if (count < 0 || limit < 0) return;
 449     if (obj instanceof Array && obj[0] == (obj[0]|0)) {
 450       switch (obj[0]) {
 451       case 248:
 452         // Object
 453         count --;
 454         hash_accu = (hash_accu * 65599 + obj[2]) | 0;
 455         break
 456       case 250:
 457         // Forward
 458         limit++; hash_aux(obj); break;
 459       case 255:
 460         // Int64
 461         count --;
 462         hash_accu = (hash_accu * 65599 + obj[1] + (obj[2] << 24)) | 0;
 463         break;
 464       default:
 465         count --;
 466         hash_accu = (hash_accu * 19 + obj[0]) | 0;
 467         for (var i = obj.length - 1; i > 0; i--) hash_aux (obj[i]);
 468       }
 469     } else if (obj instanceof MlString) {
 470       count --;
 471       var a = obj.array, l = obj.getLen ();
 472       if (a) {
 473         for (var i = 0; i < l; i++) hash_accu = (hash_accu * 19 + a[i]) | 0;
 474       } else {
 475         var b = obj.getFullBytes ();
 476         for (var i = 0; i < l; i++)
 477           hash_accu = (hash_accu * 19 + b.charCodeAt(i)) | 0;
 478       }
 479     } else if (obj == (obj|0)) {
 480       // Integer
 481       count --;
 482       hash_accu = (hash_accu * 65599 + obj) | 0;
 483     } else if (obj == +obj) {
 484       // Float
 485       count--;
 486       var p = caml_int64_to_bytes (caml_int64_bits_of_float (obj));
 487       for (var i = 7; i >= 0; i--) hash_accu = (hash_accu * 19 + p[i]) | 0;
 488     }
 489   }
 490   hash_aux (obj);
 491   return hash_accu & 0x3FFFFFFF;
 492 }
 493
 494 ///////////// Sys
 495 //Provides: caml_sys_time mutable
 496 var caml_initial_time = new Date() * 0.001;
 497 function caml_sys_time () { return new Date() * 0.001 - caml_initial_time; }
 498 //Provides: caml_sys_get_config const
 499 //Requires: MlString
 500 function caml_sys_get_config () {
 501   return [0, new MlWrappedString("Unix"), 32];
 502 }
 503 //Provides: caml_sys_random_seed mutable
 504 function caml_sys_random_seed () {
 505   return new Date()^0xffffffff*Math.random();
 506 }
 507
 508 ///////////// CamlinternalOO
 509 //Provides: caml_get_public_method const
 510 function caml_get_public_method (obj, tag) {
 511   var meths = obj[1];
 512   var li = 3, hi = meths[1] * 2 + 1, mi;
 513   while (li < hi) {
 514     mi = ((li+hi) >> 1) | 1;
 515     if (tag < meths[mi+1]) hi = mi-2;
 516     else li = mi;
 517   }
 518   /* return 0 if tag is not there */
 519   return (tag == meths[li+1] ? meths[li] : 0);
 520 }
 521
 522 /////////////////////////////
 523
 524 // Dummy functions
 525 //Provides: caml_ml_out_channels_list const
 526 function caml_ml_out_channels_list () { return 0; }
 527 //Provides: caml_ml_flush const
 528 function caml_ml_flush () { return 0; }
 529 //Provides: caml_ml_open_descriptor_out const
 530 function caml_ml_open_descriptor_out () { return 0; }
 531 //Provides: caml_ml_open_descriptor_in const
 532 function caml_ml_open_descriptor_in () { return 0; }
 533 //Provides: caml_sys_get_argv const
 534 //Requires: MlString
 535 function caml_sys_get_argv () {
 536   var p = new MlWrappedString("a.out"); return [0, p, [0, p]];
 537 }
 538 //Provides: caml_ml_output const
 539 function caml_ml_output () { return 0; }
 540 //Provides: caml_final_register const
 541 function caml_final_register () { return 0; }
 542 //Provides: caml_final_release const
 543 function caml_final_release () { return 0; }