#lang scheme/base (require (planet "evector.scm" ("soegaard" "evector.plt" 1)) srfi/13/string (except-in scheme/list empty) scheme/match scheme/math "../../debug.ss" "../syntax/regexps.ss" "exceptions.ss" "value.ss" "runtime.ss") ;; TODO: abstract out the conveniences like install-properties! into a separate module (provide install-standard-library! install-standard-library-once! install-properties! reset-global-object! reset-primitive-constructors!) (define (object-descriptor object) (format "[object ~a]" (object-class object))) (define js:print (build-function 1 (lambda args (let ([print1 (lambda (x) (display (any->string x)))]) (unless (null? args) (print1 (car args)) (for-each (lambda (arg) (display " ") (print1 arg)) (cdr args))) (newline))))) (define js:parseInt (build-function 2 (lambda ([string (void)] [radix (void)] . _) (let* ([s (string-trim (any->string string) char-whitespace?)] [r (any->int32 radix)] [sign (if (char=? (string-ref s 0) #\-) (begin (set! s (substring s 1)) -1) 1)]) (if (or (and (not (zero? r)) (< r 2)) (> r 36)) +nan.0 (let ([r (cond [(or (string-prefix? "0x" s) (string-prefix? "0X" s)) (set! s (substring s 2)) 16] [(string-prefix? "0" s) (set! s (substring s 1)) 8] [(zero? r) 10] [else r])]) (cond [(regexp-match (build-integer-regexp r) s) => (lambda (match) (let sum ([factor 1] [total 0] [digits (map char->digit (reverse (string->list (car match))))]) (if (null? digits) total (sum (* factor r) (+ total (* (car digits) factor)) (cdr digits)))))] [else +nan.0]))))))) (define (char->digit ch) (cond [(memv ch (string->list "0123456789")) (- (char->integer ch) (char->integer #\0))] [(memv ch (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (- (char->integer ch) (char->integer #\A))] [(memv ch (string->list "abcdefghijklmnopqrstuvwxyz")) (- (char->integer ch) (char->integer #\a))] [else (error 'char->digit "bad digit: ~a" ch)])) (define (build-integer-regexp base) (regexp (cond [(<= base 10) (format "^[0-~a]+" (sub1 base))] [(= base 11) "^[0-9Aa]+"] [else (let ([last-char-index (- base 11)]) (format "^[0-9A-~aa-~a]+" (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" last-char-index) (string-ref "abcdefghijklmnopqrstuvwxyz" last-char-index)))]))) ;; 15.1.2.3 (define js:parseFloat (build-function 1 (lambda ([arg (void)] . _) (let ([s (string-trim (any->string arg) char-whitespace?)]) (cond [(regexp-match rx:float s) => (lambda (match) ;; TODO: calculate the MV according to 9.3.1 (string->number (car match)))] [else +nan.0]))))) (define js:isNaN (build-function 1 (lambda ([arg (void)] . _) (NaN? (any->number arg))))) (define js:isFinite (build-function 1 (lambda ([arg (void)] . _) (let ([x (any->number arg)]) (and (not (NaN? x)) (not (infinite? x))))))) (define js:eval (build-function 1 (lambda args (raise-runtime-exception here "indirect eval")))) (define (tmp:stub arity name) (build-function arity (lambda args (error name "not yet implemented")))) (define js:decodeURI (tmp:stub 1 'decodeURI)) (define js:decodeURIComponent (tmp:stub 1 'decodeURIComponent)) (define js:encodeURI (tmp:stub 1 'encodeURI)) (define js:encodeURIComponent (tmp:stub 1 'encodeURIComponent)) (define (reset-object! object) (set-object-properties! object (object-table)) (set-ref! eval-ref js:eval)) (define (reset-global-object! global) (reset-object! global) (reset-object! proto:global) ;; TODO: get this from (object-proto global) instead? (reset-object! proto:proto) (object-put! proto:proto 'write (build-function 1 (lambda args (write (object-descriptor (current-this)) (if (null? args) (current-output-port) (car args)))))) (object-put! proto:proto 'display (build-function 1 (lambda args (display (object-descriptor (current-this)) (if (null? args) (current-output-port) (car args)))))) (object-put! proto:global 'toString (build-function 0 (lambda args (object-descriptor (current-this))))) (object-put! proto:global 'hasOwnProperty (build-function 1 (lambda args (has-own-property? (current-this) (any->property-name (get-arg args 0))))))) (define (reset-primitive-constructors! global) (for ([ctor (list Object Function Array String Boolean Number Trace Name)] [proto (list proto:Object proto:Function proto:Array proto:String proto:Boolean proto:Number proto:Trace proto:Name)] [name '(Object Function Array String Boolean Number Trace Name)]) (reset-object! proto) (reset-object! ctor) ;; 15.2.3.1, 15.3.3.1, 15.4.3.1, 15.5.3.1, 15.6.3.1, 15.7.3.1 (object-put! ctor 'prototype proto (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15, 15.2.3, 15.3.3, 15.4.3, 15.5.3, 15.6.3, 15.7.3 (object-put! ctor 'length 1 (bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15? (object-put! global name ctor (bit-field DONT-ENUM? DONT-DELETE?)) ;; 15.2.4.1, 15.3.4.1, 15.4.4.1, 15.5.4.1, 15.6.4.1, 15.7.4.1 (object-put! proto 'constructor ctor)) (reset-object! Math) (object-put! global 'Math Math (bit-field DONT-ENUM? DONT-DELETE?))) (define Object-methods `(;; 15.2.4.2 (toString ,(build-function 0 (lambda args (object-descriptor (current-this))))) ;; 15.2.4.3 (toLocaleString ,(build-function 0 (lambda args (let ([toString (object-get (current-this) 'toString (lambda () (raise-runtime-type-error here "function" "undefined")))]) (apply toString args))))) ;; 14.2.4.4 (valueOf ,(build-function 0 (lambda args (current-this)))) ;; 15.2.4.5 (hasOwnProperty ,(build-function 0 (lambda args (has-own-property? (current-this) (any->property-name (get-arg args 0)))))) ;; 15.2.4.6 (isPrototypeOf ,(build-function 1 (lambda args (let ([O (current-this)] [V (if (null? args) (void) (car args))]) (and (object? V) (let loop ([V (object-proto V)]) (and V (or (eq? O V) (loop (object-proto V)))))))))) ;; 15.2.4.7 (propertyIsEnumerable ,(build-function 1 (lambda args (let ([O (current-this)] [V (any->property-name (if (null? args) (void) (car args)))]) (and (has-own-property? O V) (not (bit-flag-set? (object-get-attributes O V) DONT-ENUM?))))))) )) (define Function-methods `(;; 15.3.4.2 (toString ,(build-function 0 (lambda args (unless (descendant-of? (current-this) proto:Function) (raise-runtime-type-error here "function" "object")) ;; TODO: show function source "[object Function]"))) ;; 15.3.4.3 (apply ,(tmp:stub 2 "apply")) ;; 15.3.4.4 (call ,(tmp:stub 1 "call")) )) ;; NOTE: according to Brendan this is a bug in the spec and no one adheres to it (define (as-if-by-new-Array) (new-Array)) ; (let* ([obj (object-get global-object "Array" (lambda () ; (raise-runtime-exception here "Array undefined")))] ;; TODO: can't happen? (DONT-DELETE) ; [ctor (or (and (function? obj) (function-construct obj)) ; (and (object? obj) (raise-runtime-type-error here "constructor" "object")) ; (raise-runtime-type-error here "constructor" "primitive"))]) ; (ctor))) (define Array-methods `((write ,(build-function 1 (lambda args (let ([this (current-this)] [out (if (null? args) (current-output-port) (car args))]) (for ([i (in-range (object-get this 'length (lambda () 0) any->uint32))]) (when (> i 0) (display "," out)) (object-get this (any->string i) void (lambda (x) (write x out)))))))) (display ,(build-function 1 (lambda args (let ([this (current-this)] [out (if (null? args) (current-output-port) (car args))]) (for ([i (in-range (object-get this 'length (lambda () 0) any->uint32))]) (when (> i 0) (display "," out)) (object-get this (any->property-name i) void (lambda (x) (display x out)))))))) ;; 15.4.4.2 (toString ,(build-function 0 (lambda args (let ([this (current-this)]) (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))]) (object-get this (any->property-name i) (lambda () "") any->string)) "," 'infix))))) ;; 15.4.4.3 (toLocaleString ,(build-function 0 (lambda args (let ([this (current-this)]) (unless (descendant-of? this proto:Array) (raise-runtime-type-error here "array" "object")) (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))]) (object-get this (any->string i) (lambda () "") (lambda (v) (invoke (any->object v) 'toLocaleString '() (lambda (s1 s2) (raise-runtime-type-error here s1 s2)))))) ; (let ([v (object-get this (any->string i))]) ; (if v ; (invoke (any->object v) ; "toLocaleString" ; '() ; (lambda (s1 s2) ; (raise-runtime-type-error here s1 s2))) ; ""))) ;; TODO: use locale info to choose separator "," 'infix))))) ;; 15.4.4.4 (concat ,(build-function 1 (lambda args (let ([this (current-this)] [A (as-if-by-new-Array)]) ;; (listof value) * nat -> nat (define (copy-arrays arrays n) (if (pair? arrays) (let ([E (car arrays)]) ;; nat * nat * nat -> nat (define (copy-array Result6 n k) (if (= k Result6) (copy-arrays (cdr arrays) n) (let ([Result8 (any->property-name k)]) (when (has-property? E Result8) (object-put! A (any->string n) (object-get E Result8))) (copy-array Result6 (add1 n) (add1 k))))) (if (array? E) (copy-array (object-get E 'length) n 0) (begin (object-put! A n E) (copy-arrays (cdr arrays) (add1 n))))) n)) (object-put! A "length" (copy-arrays (cons this args) 0)) A)))) ;; 15.4.4.5 (join ,(build-function 1 (lambda args (let ([this (current-this)]) (string-join (for/list ([i (in-range (object-get this 'length (lambda () 0) any->uint32))]) (object-get this (any->property-name i) (lambda () "") (lambda (v) (if (or (void? v) (null? v)) "" (any->string v))))) (or (and (pair? args) (any->string (car args))) ",") 'infix))))) ;; 15.4.4.6 (pop ,(build-function 0 (lambda args (let ([this (current-this)]) (let ([len (object-get this 'length (lambda () 0) any->uint32)]) (if (zero? len) (begin (object-put! this 'length len) (void)) (let* ([key (any->property-name (sub1 len))] [val (object-get this key void)]) (object-delete! this key) (object-put! this "length" (sub1 len)) val))))))) ;; 15.4.4.7 (push ,(build-function 1 (lambda args (let ([this (current-this)]) (let* ([len (object-get this 'length (lambda () 0) any->uint32)] [new-len (+ len (length args))]) (for ([arg args] [n (in-range len new-len)]) (object-put! this (any->property-name n) arg)) (object-put! this 'length new-len) new-len))))) ;; 15.4.4.8 (reverse ,(build-function 0 (lambda args (let ([this (current-this)]) (let* ([len (object-get this 'length (lambda () 0) any->uint32)] [half (floor (/ len 2))]) (define (loop left) (if (= left half) this (let* ([right (sub1 (- len left))] [left-key (any->property-name left)] [right-key (any->property-name right)]) (object-get this left-key (lambda () (object-get this right-key (lambda () (object-delete! this left-key) (object-delete! this right-key)) (lambda (right-val) (object-delete! this right-key) (object-put! this left-key right-val)))) (lambda (left-val) (object-get this right-key (lambda () (object-put! this right-key left-val) (object-delete! this right-key)) (lambda (right-val) (object-put! this left-key right-val) (object-put! this right-key left-val))))) ; (cond ; [(object-get this left-key) ; => (lambda (left-val) ; (cond ; [(object-get this right-key) ; => (lambda (right-val) ; (object-put! this left-key right-val) ; (object-put! this right-key left-val))] ; [else ; (object-put! this right-key left-val) ; (object-delete! this right-key)]))] ; [(object-get this right-key) ; => (lambda (right-val) ; (object-delete! this right-key) ; (object-put! this left-key right-val))] ; [else ; (object-delete! this left-key) ; (object-delete! this right-key)]) (loop (add1 left))))) (loop 0)))))) ;; 15.4.4.9 (shift ,(build-function 0 (lambda args (let ([this (current-this)]) (let ([len (object-get this 'length (lambda () 0) any->uint32)]) (if (zero? len) (begin (object-put! this 'length len) (void)) (let ([removed (object-get this "0")]) (define (loop k) (if (= k len) (begin (object-delete! this (any->property-name (sub1 len))) (object-put! this 'length (sub1 len)) removed) (let ([k-key (any->property-name k)] [k-1-key (any->property-name (sub1 k))]) (object-get this k-key (lambda () (object-delete! this k-1-key)) (lambda (val) (object-put! this k-1-key val))) ; (cond ; [(object-get this k-key) ; => (lambda (val) ; (object-put! this k-1-key val))] ; [else (object-delete! this k-1-key)]) (loop (add1 k))))) (loop 0)))))))) ;; 15.4.4.10 (slice ,(build-function 2 (lambda args (let* ([this (current-this)] [len (object-get this 'length (lambda () 0) any->uint32)] [A (as-if-by-new-Array)]) (define (any->index x) (let ([int (any->integer x)]) (if (negative? int) (max (+ len int) 0) (min int len)))) (let-values ([(start end) (match args [(list) (values (any->index (void)) (any->index (void)))] [(list start) (values (any->index start) (any->index (void)))] [(list start end _ ...) (values (any->index start) (any->index end))])]) (define (loop k n) (if (>= k end) (object-put! A 'length n) (let ([k-key (any->property-name k)]) (when (has-property? this k-key) (object-put! A (any->property-name n) (object-get this k-key))) (loop (add1 k) (add1 n))))) (loop start 0) A))))) ;; 15.4.4.11 (sort ,(build-function 1 (lambda args (let ([this (current-this)] [comparefn (if (null? args) (void) (car args))]) (define (SortCompare j k) (let ([j-key (any->property-name j)] [k-key (any->property-name k)]) (let ([has-j? (has-property? this j-key)] [has-k? (has-property? this k-key)]) (cond [(and (not has-j?) (not has-k?)) 0] [(not has-j?) 1] [(not has-k?) -1] [else (let ([x (object-get this j-key)] [y (object-get this k-key)]) (cond [(and (void? x) (void? y)) 0] [(void? x) 1] [(void? y) -1] [(void? comparefn) (let ([x-str (any->string x)] [y-str (any->string y)]) (cond [(stringinteger (SortCompare j p))]) (if (or (zero? cmp) (negative? cmp)) j (drop-top (sub1 j)))))] [i (let raise-bottom ([i i]) (let ([cmp (any->integer (SortCompare i p))]) (if (or (zero? cmp) (positive? cmp)) i (raise-bottom (add1 i)))))]) (if (< i j) (begin (swap! i j) (loop i j)) j))) (loop (sub1 p) (add1 r))) (define (swap! i j) (let ([i-key (any->property-name i)] [j-key (any->property-name j)]) (let ([has-i? (has-property? this i)] [has-j? (has-property? this j)]) (cond [(and (not has-i?) (not has-j?)) (void)] [(not has-i?) (let ([j-val (object-get this j-key)]) (object-delete! this j-key) (object-put! this i-key j-val))] [(not has-j?) (let ([i-val (object-get this i-key)]) (object-delete! this i-key) (object-put! this j-key i-val))] [else (let ([i-val (object-get this i-key)] [j-val (object-get this j-key)]) (object-put! this i-key j-val) (object-put! this j-key i-val))])))) (let ([len (object-get this 'length (lambda () 0) any->uint32)]) (quicksort! 0 (sub1 len)) this))))) ;; 15.4.4.12 (splice ,(build-function 2 (lambda args (let* ([this (current-this)] [len (object-get this 'length (lambda () 0) any->uint32)] [A (as-if-by-new-Array)]) (let-values ([(start deleteCount items) (match args [(list) (values 0 0 null)] [(list start) (values (any->integer start) 0 null)] [(list start deleteCount items ...) (values (any->integer start) (any->integer deleteCount) items)])]) (let* ([start (if (negative? start) ;; 5 (max (+ len start) 0) (min start len))] [deleteCount (min (max deleteCount 0) (- len start))]) ;; 6 ;; 7 - 15 (for ([k (in-range 0 deleteCount)]) (let ([key (any->property-name (+ start k))]) (when (has-property? this key) (object-put! A (any->property-name k) (object-get this key))))) ;; 16 (object-put! A 'length deleteCount) (let* ([insertCount (length items)] ;; 17 [newLength (+ (- len deleteCount) insertCount)]) ;; 18 - 19 (cond [(< insertCount deleteCount) ;; 20 - 30 (for ([k (in-range start (- len deleteCount))]) (let ([from-key (any->property-name (+ k deleteCount))] [to-key (any->property-name (+ k insertCount))]) (if (has-property? this from-key) (object-put! this to-key (object-get this from-key)) (object-delete! this to-key)))) ;; 31 - 36 (for ([k (in-range len newLength)]) (object-delete! this (any->property-name (sub1 k))))] [(> insertCount deleteCount) ;; 37 - 47 (for ([k (in-range (- len deleteCount) start -1)]) (let ([from-key (any->property-name (+ k (sub1 deleteCount)))] [to-key (any->property-name (+ k (sub1 insertCount)))]) (if (has-property? this from-key) (object-put! this to-key (object-get this from-key)) (object-delete! this to-key))))]) ;; 48 - 52 (for ([item items] [k (in-range start (+ start insertCount))]) (object-put! this (any->property-name k) item)) ;; 53 (object-put! this 'length newLength) ;; 54 A))))))) ;; 15.4.4.13 (unshift ,(build-function 1 (lambda args (let* ([this (current-this)] [len (object-get this 'length (lambda () 0) any->uint32)] ;; 2 [count (length args)]) ;; 3 ;; 4 - 14 (for ([k (in-range len 0 -1)]) (let ([from-key (any->property-name (sub1 k))] ;; 6 [to-key (any->property-name (+ count (sub1 k)))]) ;; 7 (if (has-property? this from-key) (object-put! this to-key (object-get this from-key)) (object-delete! this to-key)))) ;; 15 - 20 (for ([item args] [k (in-range 0 count)]) (object-put! this (any->property-name k) item)) (let ([new-len (+ len count)]) ;; 21 (object-put! this 'length new-len) new-len))))) )) (define String-statics `(;; 15.5.3.2 (fromCharCode ,(build-function 1 (lambda args (list->string (map (compose integer->char any->uint16) args))))) )) (define (show-wrapper write?) (build-function 1 (lambda args (let ([this (current-this)] [out (if (null? args) (current-output-port) (car args))] [show (if write? write display)]) (cond [(wrapper? this) (show (wrapper-value this) out)] [(object? this) (display "[object Object]" out)] [else (show this out)]))))) (define write-wrapper (show-wrapper #t)) (define display-wrapper (show-wrapper #f)) (define String-methods `((write ,write-wrapper) (display ,display-wrapper) ;; 15.5.4.2 (toString ,(build-function 0 (lambda args (current-this)))) ;; 15.5.4.3 (valueOf ,(tmp:stub 0 "valueOf")) ;; 15.5.4.4 (charAt ,(tmp:stub 1 "charAt")) ;; 15.5.4.5 (charCodeAt ,(tmp:stub 1 "charCodeAt")) ;; 15.5.4.6 (concat ,(tmp:stub 1 "concat")) ;; 15.5.4.7 (indexOf ,(tmp:stub 1 "indexOf")) ;; 15.5.4.8 (lastIndexOf ,(tmp:stub 1 "lastIndexOf")) ;; 15.5.4.9 (localeCompare ,(tmp:stub 1 "localeCompare")) ;; 15.5.4.10 (match ,(tmp:stub 1 "match")) ;; 15.5.4.11 (replace ,(tmp:stub 2 "replace")) ;; 15.5.4.12 (search ,(tmp:stub 1 "search")) ;; 15.5.4.13 (slice ,(tmp:stub 2 "slice")) ;; 15.5.4.14 (split ,(tmp:stub 2 "split")) ;; 15.5.4.15 (substring ,(tmp:stub 2 "substring")) ;; 15.5.4.16 (toLowerCase ,(tmp:stub 0 "toLowerCase")) ;; 15.5.4.17 (toLocaleLowerCase ,(tmp:stub 0 "toLocaleLowerCase")) ;; 15.5.4.18 (toUpperCase ,(tmp:stub 0 "toUpperCase")) ;; 15.5.4.19 (toLocaleUpperCase ,(tmp:stub 0 "toLocaleUpperCase")) )) (define Boolean-methods `((write ,write-wrapper) (display ,display-wrapper) ;; 15.6.4.2 (toString ,(tmp:stub 0 "toString")) ;; 15.6.4.3 (valueOf ,(tmp:stub 0 "valueOf")) )) (define Number-statics `(;; 15.7.3.2 ;; TODO: fix this (MAX_VALUE ,(void) ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?)) ;; 15.7.3.3 ;; TODO: fix this (MIN_VALUE ,(void) ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?)) ;; 15.7.3.4 (NaN +nan.0 ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?)) ;; 15.7.3.5 (NEGATIVE_INFINITY -inf.0 ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?)) ;; 15.7.3.6 (POSITIVE_INFINITY +inf.0 ,(bit-field DONT-DELETE? READ-ONLY? DONT-ENUM?)) )) (define Number-methods `((write ,write-wrapper) (display ,display-wrapper) ;; 15.7.4.2 (toString ,(tmp:stub 0 "toString")) ;; 15.7.4.3 (toLocaleString ,(tmp:stub 0 "toLocaleString")) ;; 15.7.4.4 (valueOf ,(tmp:stub 0 "valueOf")) ;; 15.7.4.5 (toFixed ,(tmp:stub 1 "toFixed")) ;; 15.7.4.6 (toExponential ,(tmp:stub 1 "toExponential")) ;; 15.7.4.7 (toPrecision ,(tmp:stub 1 "toPrecision")) )) ;; 15.8.1 (define Math-static-properties `(;; 15.8.1.1 (E ,(exp 1) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.2 (LN10 ,(log 10) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.3 (LN2 ,(log 2) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.4 (LOG2E ,(/ 1 (log 2)) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.5 (LOG10E ,(/ 1 (log 10)) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.6 (PI ,pi ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.7 (SQRT1_2 ,(sqrt 1/2) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) ;; 15.8.1.8 (SQRT_2 ,(sqrt 2) ,(bit-field DONT-ENUM? DONT-DELETE? READ-ONLY?)) )) ;; 15.8.2 (define Math-static-methods `(;; 15.8.2.1 (abs ,(tmp:stub 1 "abs")) ;; 15.8.2.2 (acos ,(tmp:stub 1 "acos")) ;; 15.8.2.3 (asin ,(tmp:stub 1 "asin")) ;; 15.8.2.4 (atan ,(tmp:stub 1 "atan")) ;; 15.8.2.5 (atan2 ,(tmp:stub 2 "atan2")) ;; 15.8.2.6 (ceil ,(tmp:stub 1 "ceil")) ;; 15.8.2.7 (cos ,(tmp:stub 1 "cos")) ;; 15.8.2.8 (exp ,(tmp:stub 1 "exp")) ;; 15.8.2.9 (floor ,(tmp:stub 1 "floor")) ;; 15.8.2.10 (log ,(tmp:stub 1 "log")) ;; 15.8.2.11 (max ,(tmp:stub 2 "max")) ;; 15.8.2.12 (min ,(tmp:stub 2 "min")) ;; 15.8.2.13 (pow ,(tmp:stub 2 "pow")) ;; 15.8.2.14 (random ,(tmp:stub 0 "random")) ;; 15.8.2.15 (round ,(tmp:stub 1 "round")) ;; 15.8.2.16 (sin ,(tmp:stub 1 "sin")) ;; 15.8.2.17 (sqrt ,(tmp:stub 1 "sqrt")) ;; 15.8.2.18 (tan ,(tmp:stub 1 "tan")) )) (define global-properties `(;; 15.1.1.1 (NaN +nan.0 ,(bit-field DONT-ENUM? DONT-DELETE?)) ;; 15.1.1.2 (Infinity +inf.0 ,(bit-field DONT-ENUM? DONT-DELETE?)) ;; 15.1.1.3 (undefined ,(void) ,(bit-field DONT-ENUM? DONT-DELETE?)) )) (define eval-ref (let ([state js:eval]) (make-ref (lambda () state) (lambda (val) (set! state val) (original-eval? (eq? val js:eval)) val) (lambda () #t)))) (define global-methods `(;; 15.1.2.1 (eval ,eval-ref ,(bit-field DONT-DELETE?)) ;; 15.1.2.2 (parseInt ,js:parseInt) ;; 15.1.2.3 (parseFloat ,js:parseFloat) ;; 15.1.2.4 (isNaN ,js:isNaN) ;; 15.1.2.5 (isFinite ,js:isFinite) ;; 15.1.3.1 (decodeURI ,js:decodeURI) ;; 15.1.3.2 (decodeURIComponent ,js:decodeURIComponent) ;; 15.1.3.3 (encodeURI ,js:encodeURI) ;; 15.1.3.4 (encodeURIComponent ,js:encodeURIComponent) )) (define global-custom-properties `((it ,(void) ,(bit-field DONT-ENUM? DONT-DELETE?)) )) (define global-custom-methods `(;; 15 (print ,js:print) )) (define Trace-methods `((toString ,(build-function 0 (lambda args (object-descriptor (current-this))))) (trace ,(build-function 2 (case-lambda [() (void)] [(x) (void)] [(x thunk . rest) (let ([this (current-this)]) ;; XXX: check descendant of Trace (unless (wrapper? this) (raise-runtime-type-error here "Trace" "object")) (unless (procedure? thunk) (raise-runtime-type-error here "function" "?")) (with-continuation-mark (wrapper-value this) x (thunk)))]))) (toArray ,(build-function 0 (lambda args (let ([this (current-this)]) ;; XXX: check descendant of Trace (unless (wrapper? this) (raise-runtime-type-error here "Trace" "object")) (list->array (continuation-mark-set->list (current-continuation-marks) (wrapper-value this))))))) )) ;; XXX: this toString binding should exist in the primordial prototype object (define Name-methods `((toString ,(build-function 0 (lambda args (object-descriptor (current-this))))) )) (define (install-properties! object properties) (for-each (lambda (property) (match property [(list name value) (object-put! object name value (bit-field DONT-ENUM?))] [(list name value attributes) (object-put! object name value attributes)])) properties)) (define installation-cache (make-hasheq)) (define (install-standard-library-once! global) (hash-ref installation-cache global (lambda () (hash-set! installation-cache global #f) (install-standard-library! global) #t))) (define (install-standard-library! global) (reset-global-object! global) (reset-primitive-constructors! global) (install-properties! global global-properties) (install-properties! global global-methods) (install-properties! global global-custom-properties) (install-properties! global global-custom-methods) (install-properties! proto:Object Object-methods) (install-properties! proto:Function Function-methods) (install-properties! proto:Array Array-methods) (install-properties! String String-statics) (install-properties! proto:String String-methods) (install-properties! proto:Boolean Boolean-methods) (install-properties! Number Number-statics) (install-properties! proto:Number Number-methods) (install-properties! Math Math-static-properties) (install-properties! Math Math-static-methods) (install-properties! proto:Trace Trace-methods) (install-properties! proto:Name Name-methods) (current-this global) (original-eval? #t) global)