(module value "core-mzscheme.ss"
(require (planet "evector.scm" ("soegaard" "evector.plt" 1 0))
(all-except (planet "list.ss" ("dherman" "list.plt" 1 0)) empty)
(lib "string.ss" "srfi" "13")
(prefix s: (lib "string.ss"))
(lib "etc.ss")
"../syntax/ast.ss"
"../syntax/regexps.ss"
"exceptions.ss"
"object.ss")
(define current-this (make-parameter #f))
(define (deref val)
(if (ref? val)
((ref-get val))
val))
(define (set-ref! ref val)
((ref-set! ref) val))
(define (delete-ref! ref)
((ref-delete! ref)))
(define (build-object0 table proto)
(make-object #f #f proto (object-class proto) table))
(define NaN +nan.0)
(define (NaN? x)
(or (eqv? x +nan.0)
(eqv? x -nan.0)))
(define (infinite? x)
(or (eqv? x +inf.0)
(eqv? x -inf.0)))
(define (has-attribute? p a)
(and (pair? p)
(bit-flag-set? (cdr p) a)))
(define (value->primitive v object->primitive)
(if (primitive? v)
v
(object->primitive v)))
(define (value->number v)
(if (primitive? v)
(primitive->number v)
(primitive->number (object->number v))))
(define (primitive->number v)
(cond
[(void? v) +nan.0]
[(null? v) 0]
[(eq? v 'true) 1]
[(eq? v 'false) 0]
[(number? v) v]
[(string? v) (string->number v)]))
(define (number-sign x)
(if (negative? x) - +))
(define (real->integer v)
((number-sign v) (inexact->exact (floor (abs v)))))
(define (value->integer v)
(let ([v (value->number v)])
(cond
[(NaN? v) 0]
[(or (zero? v) (infinite? v)) v]
[else (real->integer v)])))
(define (value->finite-integer v)
(let ([v (value->number v)])
(if (or (NaN? v) (infinite? v) (zero? v))
0
(real->integer v))))
(define 2^32 (expt 2 32))
(define 2^31 (expt 2 31))
(define 2^16 (expt 2 16))
(define 2^32-1 (sub1 (expt 2 32)))
(define (value->int32 v)
(let* ([i (value->finite-integer v)]
[masked (modulo i 2^32)])
(if (>= masked 2^31)
(- masked 2^32)
masked)))
(define (value->uint32 v)
(modulo (value->finite-integer v) 2^32))
(define (value->uint16 v)
(modulo (value->finite-integer v) 2^16))
(define (value->boolean x)
(cond
[(void? x) 'false]
[(null? x) 'false]
[(symbol? x) x]
[(number? x) (make-boolean (or (zero? x) (NaN? x)))]
[(string? x) (make-boolean (string=? x ""))]
[(object? x) 'true]))
(define (value->string x)
(if (object? x)
(primitive->string (object->string x))
(primitive->string x)))
(define (completion->value x)
(if (not x) (void) x))
(define (completion->string x)
(if (or (not x) (void? x))
""
(value->string x)))
(define (primitive->string p)
(cond
[(void? p) "undefined"]
[(null? p) "null"]
[(eq? p 'true) "true"]
[(eq? p 'false) "false"]
[(number? p) (number->string p)]
[(string? p) p]
[else (error 'primitive->string "unrecognized primitive: ~v" p)]))
(define (number->string x)
(cond
[(eqv? x -inf.0) "-Infinity"]
[(eqv? x +inf.0) "Infinity"]
[(NaN? x) "NaN"]
[(zero? x) "0"]
[(integer? x) (mz:number->string (inexact->exact x))]
[else (mz:number->string x)]))
(define (primitive? x)
(or (void? x)
(null? x)
(eq? x 'true)
(eq? x 'false)
(number? x)
(string? x)))
(define (string->number x)
(mz:string->number x))
(define (try o method-names)
(if (null? method-names)
(raise-runtime-type-error here "object with string representation" "?")
(let ([method (object-get o (car method-names))])
(cond
[(and method (object? method) (object-call method))
=> (lambda (f)
(let ([result (parameterize ([current-this o])
(f (evector)))])
(if (primitive? result)
(primitive->string result)
(try o (cdr method-names)))))]
[else (try o (cdr method-names))]))))
(define (object->string o)
(try o '("toString" "valueOf")))
(define (object->number o)
(try o '("valueOf" "toString")))
(define (value->object v)
(cond
[(void? v) (raise-runtime-type-error here "defined value" "undefined")]
[(null? v) (raise-runtime-type-error here "non-null value" "null")]
[(symbol? v) ((object-construct Boolean) (evector v))]
[(string? v) ((object-construct String) (evector v))]
[(object? v) v]))
(define (value->string/debug v)
(cond
[(string? v) (string->source-string v)]
[(object? v) (object->string/debug v)]
[else (value->string v)]))
(define (object->string/debug o)
(object->string/debug/immediate o))
(define (object->string/debug/immediate o)
(string-append "{"
(string-join (map (lambda (key)
(format "~a:~a"
key
(value->string/debug (object-get o key))))
(object-keys o))
","
'infix)
"}"))
(define (set-array-length! a x)
(value->array-index x
(lambda (length string?)
(set-evector-length! (array-vector a) length))
(lambda (string)
(raise-runtime-type-error here "array index" string))))
(define (array-index? x)
(and (integer? x)
(<= 0 x 2^32-1)))
(define (value->array-index x sk fk)
(cond
[(array-index? x) (sk (inexact->exact x) #f)]
[(number? x) (fk (number->string x))]
[else
(let ([s (value->string x)])
(cond
[(parse-array-index s)
=> (lambda (index)
(sk index s))]
[else (fk s)]))]))
(define (parse-array-index s)
(and (s:regexp-match-exact? rx:integer s)
(let ([i (string->number s)])
(and (array-index? i)
(string=? (number->string i) s)
(inexact->exact i)))))
(define (property->value p)
(cond
[(and (pair? p) (ref? (car p)))
(deref (car p))]
[(pair? p)
(car p)]
[(ref? p)
(deref p)]
[else p]))
(define (has-property? o key)
(or (has-property?/immediate o key)
(let ([proto (object-proto o)])
(and proto (has-property? proto key)))))
(define (has-property?/immediate o key)
(or (and (array? o) (array-has-property?/immediate o key))
(object-has-property?/immediate o key)))
(define (array-has-property?/immediate a key)
(value->array-index key
(lambda (index string?)
(let ([vec (array-vector a)])
(and (< index (evector-length vec))
(evector-ref vec index)
#t)))
(lambda (string) #f)))
(define (object-has-property?/immediate o key)
(hash-table-contains? (object-properties o) key))
(define (object-get o key)
(object-get1 o key (lambda (string)
(let ([proto (object-proto o)])
(and proto (object-get proto string))))))
(define (object-get1 o key fk)
(if (array? o)
(array-get1 o key fk)
(object-table-get (object-properties o) key fk)))
(define (array-get1 a key fk)
(value->array-index key
(lambda (index string?)
(let ([vec (array-vector a)])
(cond
[(and (< index (evector-length vec))
(evector-ref vec index))
=> property->value]
[else (fk (or string? (number->string index)))])))
(lambda (string)
(object-table-get (object-properties a)
string
fk))))
(define (object-table-get table key fk)
(let* ([s (value->string key)]
[v (hash-table-get table key (lambda () #f))])
(or (and v (property->value v))
(fk s))))
(define object-put!
(opt-lambda (o key value [attributes empty-bit-field])
(if (array? o)
(array-put! o key value attributes)
(object-table-put! o (value->string key) value attributes))))
(define array-put!
(opt-lambda (a key value [attributes empty-bit-field])
(value->array-index key
(lambda (index string?)
(array-vector-put! a index value attributes))
(lambda (string)
(object-table-put! a string value attributes)))))
(define (put!/permission previous put! value attributes)
(unless (has-attribute? previous READ-ONLY?)
(cond
[(and (pair? previous) (ref? (car previous)))
(set-ref! (car previous) value)]
[(pair? previous)
(set-car! previous value)]
[(ref? previous)
(set-ref! previous value)]
[previous
(put! value)]
[(not (empty-bit-field? attributes))
(put! (cons value attributes))]
[else
(put! value)])))
(define array-vector-put!
(opt-lambda (a index value [attributes empty-bit-field])
(let ([vec (array-vector a)])
(put!/permission (and (< index (evector-length vec))
(evector-ref vec index))
(lambda (p)
(evector-set! vec index p))
value
attributes))))
(define object-table-put!
(opt-lambda (o key value [attributes empty-bit-field])
(let ([table (object-properties o)])
(put!/permission (hash-table-get table key (lambda () #f))
(lambda (p)
(hash-table-put! table key p))
value
attributes))))
(define (object-delete! o key)
(if (array? o)
(array-delete! o key)
(object-table-delete! (object-properties o) key)))
(define (array-delete! a key)
(value->array-index key
(lambda (index string?)
(array-vector-delete! (array-vector a) index))
(lambda (string)
(object-table-delete! (object-properties a) key))))
(define (object-table-delete! table key)
(cond
[(hash-table-get table key (lambda () #f))
=> (lambda (p)
(if (has-attribute? p DONT-DELETE?)
'false
(begin (hash-table-remove! table key)
'true)))]
[else 'true]))
(define (array-vector-delete! vec i)
(cond
[(and (<= i (evector-length vec))
(evector-ref vec i))
=> (lambda (p)
(if (has-attribute? p DONT-DELETE?)
'false
(begin (evector-set! vec i #f)
'true)))]
[else 'true]))
(define (descendant-of? x y)
(and (object? x)
(let ([proto (object-proto x)])
(or (eq? proto y)
(and proto (descendant-of? proto y))))))
(define (hash-table-contains? t key)
(and (hash-table-get t key (lambda () #f))
#t))
(define (object-keys-stream object)
(let ([current-object object]
[current-keys (object-keys object)]
[visited (make-hash-table 'equal)])
(letrec ([next-key (lambda ()
(cond
[(pair? current-keys)
(let ([key (begin0 (car current-keys)
(set! current-keys (cdr current-keys)))])
(if (and (not (hash-table-contains? visited key))
(has-property?/immediate object key)
(not (has-attribute? (hash-table-get (object-properties object) key)
DONT-ENUM?)))
(begin (hash-table-put! visited key #t)
key)
(next-key)))]
[(and current-object (null? current-keys))
(set! current-object (object-proto current-object))
(set! current-keys (and current-object (object-keys current-object)))
(next-key)]
[else #f]))])
next-key)))
(define (object-keys* o)
(let ([next-key (object-keys-stream o)])
(let loop ([acc '()])
(cond
[(next-key) => (lambda (key)
(loop (cons key acc)))]
[else (reverse acc)]))))
(define (object-keys o)
(append (if (array? o)
(build-list (evector-length (array-vector o))
number->string)
null)
(hash-table-map (object-properties o)
(lambda (key value) key))))
(define (true-value? x)
(or (object? x)
(and (primitive? x)
(not (or (eq? x 'false)
(void? x)
(null? x)
(and (number? x) (zero? x))
(and (string? x) (string=? x "")))))))
(define (make-boolean b)
(if b 'true 'false))
(define (call v args err)
(let* ([o (value->object v)]
[proc (object-call o)])
(if proc (proc args) (err "function" (value->string v)))))
(define current-completion-context (make-parameter null))
(define-syntax with-completion-context
(syntax-rules ()
[(_ e0 e1 ...)
(parameterize ([current-completion-context (cons #f (current-completion-context))])
e0 e1 ...)]))
(define (push-completion-context!)
(current-completion-context (cons #f (current-completion-context))))
(define (pop-completion-context!)
(current-completion-context (cdr (current-completion-context))))
(define (previous-completion)
(let ([completion-context (current-completion-context)])
(and (pair? completion-context)
(car completion-context))))
(define (complete! v)
(when v
(set-car! (current-completion-context) v))
(previous-completion))
(define (build-object table)
(build-object0 table proto:Object))
(define (build-function arity proc)
(letrec ([f (make-object proc
(lambda (arg-vec)
(let* ([proto (or (object-get f "prototype") proto:Object)]
[new-object (build-object0 '() proto)])
(parameterize ([current-this new-object])
(proc arg-vec))
new-object))
proto:Function
"Function"
(object-table
[length arity (DONT-DELETE? READ-ONLY? DONT-ENUM?)]
[prototype (build-object (object-table [constructor f (DONT-ENUM?)]))
(DONT-DELETE?)]))])
f))
(define (build-array vec)
(letrec ([a (make-array #f
#f
proto:Array
"Array"
(object-table
[constructor Array (DONT-ENUM? DONT-DELETE?)]
[length (lambda ()
(evector-length vec))
(lambda (v)
(set-array-length! a v))
(DONT-ENUM? DONT-DELETE?)])
vec)])
a))
(define (make-unknown-ref name error-thunk)
(make-ref (lambda ()
(or (object-get global-object name)
(error-thunk)))
(lambda (val)
(object-put! global-object name val)
val)
(lambda ()
(object-delete! global-object name))))
(define (make-object-ref object key)
(if (array? object)
(value->array-index key
(lambda (index string?)
(make-array-ref (array-vector object) index))
(lambda (string)
(make-object-table-ref object string)))
(make-object-table-ref object (value->string key))))
(define (make-object-table-ref object key)
(let ([table (object-properties object)])
(make-ref (lambda ()
(object-table-get table key void))
(lambda (val)
(object-put! object key val))
(lambda ()
(object-delete! object key)))))
(define (make-array-ref array i)
(make-ref (lambda ()
(if (<= i (evector-length array))
(evector-ref array i)
(void)))
(lambda (val)
(evector-set! array i val)
val)
(lambda ()
(cond
[(and (<= i (evector-length array))
(evector-ref array i))
=> (lambda (p)
(if (has-attribute? p DONT-DELETE?)
'false
(begin (evector-set! array i #f)
'true)))]
[else 'true]))))
(define make-lexical-ref
(opt-lambda ([init (void)])
(let ([x init])
(make-ref (lambda () x)
(lambda (val)
(set! x val)
val)
(lambda () 'false)))))
(define (string->source-string v)
(string-append "'"
(apply string-append
(map (lambda (ch)
(case ch
[(#\newline) "\\n"]
[(#\') "\\'"]
[(#\return) "\\r"]
[else (string ch)]))
(string->list v)))
"'"))
(define (make-scope-chain-ref scope-chain name error-thunk)
(if (null? scope-chain)
(make-unknown-ref name error-thunk)
(let ([rest-ref (make-scope-chain-ref (cdr scope-chain) name error-thunk)])
(make-ref (lambda ()
(or (object-get (car scope-chain) name)
(deref rest-ref)))
(lambda (val)
(if (has-property? (car scope-chain) name)
(object-put! (car scope-chain) name val)
(set-ref! rest-ref val)))
(lambda ()
(object-delete! (car scope-chain) name))))))
(define (make-activation-object ids arguments)
(let ([o (make-object #f
#f
proto:Object
"Object"
(object-table [arguments arguments (DONT-DELETE?)]))]
[arg-vec (array-vector arguments)])
(for-each (lambda (id i)
(object-put! o
(symbol->string (Identifier-name id))
(make-array-ref arg-vec i)
(bit-field DONT-DELETE?)))
ids
(iota ids))
o))
(define (make-arguments-object f vec)
(make-array #f
#f
proto:Object
"Object"
(object-table [length (evector-length vec) (DONT-ENUM?)]
[callee f (DONT-ENUM?)])
vec))
(define (initialize-global-object!)
(set! global-object (make-object #f #f #f "Object" (object-table))))
(define global-object
(make-object #f #f #f "Object" (object-table)))
(define proto:Array
(make-object #f #f #f "Array" (object-table)))
(define proto:Function
(make-object void void #f "Function" (object-table)))
(define proto:Object
(make-object #f #f #f "Object" (object-table)))
(define proto:String
(make-object #f #f #f "String" (object-table)))
(define proto:Boolean
(make-object #f #f #f "Boolean" (object-table)))
(define proto:Number
(make-object #f #f #f "Number" (object-table)))
(define (make-primitive-constructor proto call construct)
(make-object call
construct
proto:Function
"Function"
(object-table
[prototype proto (DONT-ENUM? DONT-DELETE? READ-ONLY?)]
[length 1 (DONT-ENUM? DONT-DELETE? READ-ONLY?)])))
(define Array (make-primitive-constructor proto:Array build-array build-array))
(define Function (make-primitive-constructor proto:Function #f #f))
(define Object (make-primitive-constructor proto:Object #f #f))
(define String (make-primitive-constructor proto:String #f #f))
(define Boolean (make-primitive-constructor proto:Boolean #f #f))
(define Number (make-primitive-constructor proto:Number #f #f))
(for-each (lambda (name constructor proto)
(object-put! global-object name constructor (bit-field DONT-ENUM? DONT-DELETE?))
(object-put! proto "constructor" constructor))
(list "Array" "Function" "Object" "String" "Boolean" "Number")
(list Array Function Object String Boolean Number)
(list proto:Array proto:Function proto:Object proto:String proto:Boolean proto:Number))
(provide current-this)
(provide bit-field make-bit-field bit-flag-set?)
(provide READ-ONLY? DONT-ENUM? DONT-DELETE?)
(provide (struct object (call construct proto class properties))
(struct array (vector))
function?
ref? set-ref! delete-ref! deref)
(provide set-array-length!)
(provide object-table build-object0)
(provide has-property? has-attribute? object-get object-put! object-keys object-keys* object-keys-stream descendant-of?)
(provide NaN NaN? infinite?)
(provide object->number object->string
completion->value completion->string
value->boolean value->string value->object value->primitive
value->number value->integer value->int32 value->uint32 value->uint16)
(provide make-boolean true-value?)
(provide call)
(provide with-completion-context push-completion-context! pop-completion-context! previous-completion complete!)
(provide build-object build-function build-array)
(provide make-unknown-ref make-object-ref make-array-ref make-lexical-ref make-scope-chain-ref make-arguments-object)
(provide initialize-global-object!)
(provide global-object proto:Array proto:Function proto:Object proto:String proto:Boolean proto:Number)
(provide Array Function Object String Boolean Number))